(* TODO Rename. *)
theory Segment
  imports
    Walk
begin

definition tbd :: "('a, 'b) multigraph \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) edge \<Rightarrow> ('a, 'b) multigraph" where
  "tbd G X e \<equiv>
   {e'. \<exists>p u v. walk G p u v \<and>
                e \<in> set p \<and>
                e' \<in> set p \<and>
                set (tl (butlast (walk_vertices p u))) \<inter> X = {}}"

(**)

(* TODO Use \<forall>v\<in>V. v \<notin> set (tl (butlast p)) instead of intersection? Or an implication? *)
definition tbd :: "'a graph \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a graph" where
  "tbd G X e \<equiv>
   {e'. \<exists>p. path G p \<and>
            e \<in> set (edges_of_path p) \<and>
            e' \<in> set (edges_of_path p) \<and>
            set (tl (butlast p)) \<inter> X = {}}"

subsubsection \<open>\<close>

lemma mem_tbdE:
  assumes "e' \<in> tbd G X e"
  obtains p where
    "path G p \<and> e \<in> set (edges_of_path p) \<and> e' \<in> set (edges_of_path p) \<and> set (tl (butlast p)) \<inter> X = {}"
  using assms
  by (auto simp add: tbd_def)

lemma mem_tbdI:
  assumes "path G p"
  assumes "e \<in> set (edges_of_path p)"
  assumes "e' \<in> set (edges_of_path p)"
  assumes "set (tl (butlast p)) \<inter> X = {}"
  shows "e' \<in> tbd G X e"
  using assms
  by (auto simp add: tbd_def)

lemma tbd_subset_graphI:
  assumes "\<And>x y. {x, y} \<in> tbd G X e \<Longrightarrow> {x, y} \<in> S"
  shows "tbd G X e \<subseteq> S"
  using assms
  by (force intro: mem_tbdE v_in_edge_in_path_inj)

subsubsection \<open>\<close>

lemma tbd_subset_connected_component:
  shows "tbd G X e \<subseteq> connected_component G e"
  by (auto simp add: tbd_def connected_component_def)

lemma tbd_subset_graph:
  shows "tbd G X e \<subseteq> G"
  using tbd_subset_connected_component connected_component_subset_graph
  by (rule subset_trans)

lemma mem_tbdE_2:
  assumes "{x, y} \<in> tbd G X {u, v}"
  obtains p where
    "walk_betw (tbd G X {u, v}) u p x"
proof (cases "u = x")
  case True
  have "x \<in> Vs (tbd G X {u, v})"
    using assms
    by (intro edges_are_Vs)
  thus ?thesis
    using True
    by (auto intro: walk_reflexive that)
next
  case False
  obtain p where p:
    "path G p"
    "{u, v} \<in> set (edges_of_path p)"
    "{x, y} \<in> set (edges_of_path p)"
    "set (tl (butlast p)) \<inter> X = {}"
    using assms
    by (auto elim: mem_tbdE)
  then obtain p' where
    walk_betw_p': "walk_betw G u p' x" and
    "set (edges_of_path p') \<subseteq> set (edges_of_path p)"
    by (metis tbdE set_edges_of_path_sublist_subset_2)
  hence "set (edges_of_path p') \<subseteq> tbd G X {u, v}"
    using p(1, 2, 4)
    by (auto simp add: tbd_def)
  moreover have "walk_betw (set (edges_of_path p')) u p' x"
    using walk_betw_p' False
    by (intro length_ge_2I walk_betw_in_set_edges_of_path)
  ultimately show ?thesis
    by (intro that) (rule walk_subset)
qed

lemma mem_tbdE_3:
  assumes "{x, y} \<in> tbd G X {u, v}"
  obtains p where
    "walk_betw G u p x"
  using assms tbd_subset_graph
  by (fastforce elim: mem_tbdE_2 dest: walk_subset)

lemma tbd_refl:
  assumes "{u, v} \<in> G"
  shows "{u, v} \<in> tbd G X {u, v}"
  using assms
  by (fastforce simp add: tbd_def dest: edges_are_walks)

lemma tbd_symmetric:
  assumes "e' \<in> tbd G X e"
  shows "e \<in> tbd G X e'"
  using assms
  by (auto elim: mem_tbdE intro: mem_tbdI)

subsection \<open>Relation with @{term Berge.connected_component} and @{term connected_component}\<close>

subsubsection \<open>\<close>

text \<open>A connected component is a special case of a tbd.\<close>

lemma connected_component_tbd_cong:
  shows "connected_component G = tbd G {}"
  by (auto simp add: connected_component_def tbd_def)

subsubsection \<open>\<close>

(* TODO Rename. *)
(* TODO Can we avoid considering all possibilities, that is, whether e comes before or after e', and
the directions of e and e'? *)
thm path_split_edge
lemma bar:
  assumes "{x, y} \<in> tbd G X {u, v}"
  assumes "x \<in> X"
  assumes "y \<in> X"
  shows "{x, y} = {u, v}"
  sorry

(* TODO Rename. *)
lemma 1:
  assumes "{u, v} \<in> G"
  assumes "u \<in> X"
  assumes "v \<in> X"
  shows "tbd G X {u, v} = {{u, v}}"
proof (standard, goal_cases)
  case 1
  show ?case
  proof (rule tbd_subset_graphI)
    fix x y
    assume "{x, y} \<in> tbd G X {u, v}"
    thus "{x, y} \<in> {{u, v}}"
      using assms(2, 3)
      by (auto dest: tbd_symmetric bar)
  qed
next
  case 2
  show ?case
    using assms(1)
    by (auto intro: tbd_refl)
qed

lemma mem_tbdE_4:
  assumes "{x, y} \<in> tbd G X {u, v}"
  assumes "u \<notin> X"
  assumes "x \<notin> X"
  assumes "u \<noteq> x"
  obtains p where
    "walk_betw (G - incidence G X) u p x"
proof -
  obtain p where p:
    "path G p"
    "{u, v} \<in> set (edges_of_path p)"
    "{x, y} \<in> set (edges_of_path p)"
    "set (tl (butlast p)) \<inter> X = {}"
    using assms(1)
    by (auto elim: mem_tbdE)
  then obtain p' where p':
    "walk_betw G u p' x"
    "sublist p' p \<or> sublist p' (rev p)"
    by (elim tbdE)
  have "set (edges_of_path p') \<subseteq> G - incidence G X"
  proof -
    { fix e
      assume "e \<in> set (edges_of_path p') \<and> e \<in> incidence G X"
      then obtain a where
        "a \<in> set p'" and
        a_mem_V: "a \<in> X"
        by (auto simp add: incidence_def intro: v_in_edge_in_path_gen)
      then consider
        (hd) "a = hd p'" |
        (tl_butlast) "a \<in> set (tl (butlast p'))" |
        (last) "a = last p'"
        by (auto dest: mem_setD)
      hence False
      proof (cases)
        case hd
        thus ?thesis
          using p'(1) assms(2) a_mem_V
          by (simp add: walk_between_nonempty_path(3))
      next
        case tl_butlast
        thus ?thesis
          using p'(2) set_tl_butlast_sublist_subset_2 p(4) a_mem_V
          by auto
      next
        case last
        thus ?thesis
          using p'(1) assms(3) a_mem_V
          by (simp add: walk_between_nonempty_path(4))
      qed }
    thus ?thesis
      using p'(1) tbd_subset_graph
      by (fastforce dest: set_edges_of_path_subset)
  qed
  moreover have "walk_betw (set (edges_of_path p')) u p' x"
    using p'(1) assms(4)
    by (intro length_ge_2I walk_betw_in_set_edges_of_path)
  ultimately show ?thesis
    by (intro that) (rule walk_subset)
qed

(* TODO Rename. *)
lemma two_aux:
  assumes "u \<notin> X"
  assumes "{x, y} \<in> tbd G X {u, v}"
  assumes "x \<notin> X"
  shows
    "{x, y} \<in>
     component_edges (G - incidence G X) (Berge.connected_component (G - incidence G X) u) \<union>
     idk G (Berge.connected_component (G - incidence G X) u) X"
proof -
  let ?G' = "G - incidence G X"
  let ?C = "Berge.connected_component ?G' u"
  have x_mem: "x \<in> ?C"
  proof (cases "u = x")
    case True
    thus ?thesis
      using in_own_connected_component
      by force
  next
    case False
    thus ?thesis
      using assms(1-3)
      by (auto intro: mem_tbdE_4)
  qed
  show ?thesis
  proof (cases "y \<in> X")
    case True
    thus ?thesis
      using tbd_subset_graph assms(2) x_mem
      by (fastforce intro: mem_idkI)
  next
    case False
    hence "{x, y} \<in> ?G'"
      using tbd_subset_graph assms(2, 3)
      by (auto simp add: incidence_def)
    moreover hence "y \<in> ?C"
      using x_mem
      by (fastforce dest: connected_components_member_eq[symmetric] intro: edges_are_walks)
    ultimately show ?thesis
      using x_mem
      by (auto intro: mem_component_edgesI_2)
  qed
qed

(* TODO Rename. *)
lemma two_aux_2:
  assumes "{u, v} \<in> G"
  assumes "u \<notin> X"
  assumes "{x, y} \<in> G"
  assumes "x \<in> Berge.connected_component (G - incidence G X) u"
  shows "{x, y} \<in> tbd G X {u, v}"
proof -
  let ?G' = "G - incidence G X"
  let ?C = "Berge.connected_component ?G' u"
  obtain p where
    "walk_betw G u p x \<and> set p \<inter> X = {}"
  proof (cases "u = x")
    case True
    thus ?thesis
      using assms(1, 2)
      by (fastforce intro: edges_are_Vs walk_reflexive that)
  next
    case False
    hence "u \<in> Vs ?G'"
      using assms(4)
      by (auto dest: connected_components_member_sym in_connected_component_in_edges)
    then obtain p where
      "walk_betw ?G' u p x"
      using assms(4)
      by (elim in_connected_component_has_path)
    hence "walk_betw G u p x \<and> set p \<subseteq> Vs ?G'"
      using Diff_subset[of G "incidence G X"]
      by (blast dest: walk_in_Vs intro: walk_subset)
    thus ?thesis
      using Vs_minus_incidence_subset
      by (fast intro: that)
  qed
  hence
    "walk_betw G v (v # p @ [y]) y \<and>
     {u, v} \<in> set (edges_of_path (v # p @ [y])) \<and>
     {x, y} \<in> set (edges_of_path (v # p @ [y])) \<and>
     set (tl (butlast (v # p @ [y]))) \<inter> X = {}"
    using assms(1, 3)
    by (auto simp add: insert_commute dest: walk_betw_Cons_snocI)
  thus ?thesis
    by (fastforce dest: walk_between_nonempty_path(1) intro: mem_tbdI)
qed

(* TODO Rename. *)
lemma 2:
  assumes "{u, v} \<in> G"
  assumes "u \<notin> X"
  shows
    "tbd G X {u, v} =
     component_edges (G - incidence G X) (Berge.connected_component (G - incidence G X) u) \<union>
     idk G (Berge.connected_component (G - incidence G X) u) X"
proof (standard, goal_cases)
  case 1
  let ?G' = "G - incidence G X"
  let ?C = "Berge.connected_component ?G' u"
  show ?case
  proof (rule tbd_subset_graphI)
    fix x y
    assume assm: "{x, y} \<in> tbd G X {u, v}"
    consider
      "x \<in> X \<and> y \<in> X" |
      "x \<notin> X" |
      "y \<notin> X"
      by fast
    thus "{x, y} \<in> component_edges ?G' ?C \<union> idk G ?C X"
    proof (cases)
      case 1
      thus ?thesis
        using assms(2) assm
        by (auto dest: bar)
    next
      case 2
      thus ?thesis
        using assms(2) assm
        by (intro two_aux)
    next
      case 3
      thus ?thesis
        using assms(2) assm
        by (auto simp add: insert_commute dest: two_aux[where ?x = y and ?y = x])
    qed
  qed
next
  case 2
  let ?G' = "G - incidence G X"
  let ?C = "Berge.connected_component ?G' u"
  have "component_edges ?G' ?C \<subseteq> tbd G X {u, v}"
  proof (rule component_edges_subsetI)
    fix x y
    assume "{x, y} \<in> component_edges ?G' ?C"
    thus "{x, y} \<in> tbd G X {u, v}"
      using assms
      by (auto dest: mem_component_edgesD(1, 2) intro: two_aux_2)
  qed
  moreover have "idk G ?C X \<subseteq> tbd G X {u, v}"
  proof (rule idk_subsetI)
    fix x y
    assume assm: "{x, y} \<in> idk G ?C X"
    then consider
      (x) "x \<in> ?C" |
      (y) "y \<in> ?C"
      by (auto dest: mem_idkD(2))
    thus "{x, y} \<in> tbd G X {u, v}"
    proof (cases)
      case x
      thus ?thesis
        using assms assm
        by (auto dest: mem_idkD(1) intro: two_aux_2)
    next
      case y
      hence "{y, x} \<in> tbd G X {u, v}"
        using assms assm
        by (fastforce simp add: insert_commute dest: mem_idkD(1) intro: two_aux_2)
      thus ?thesis
        by (simp add: insert_commute)
    qed
  qed
  ultimately show ?case
    by blast
qed

(* TODO Rename. *)
lemma 3:
  assumes "{u, v} \<in> G"
  assumes "u \<notin> X"
  assumes "v \<notin> X"
  shows
    "tbd G X {u, v} =
     connected_component (G - incidence G X) {u, v} \<union>
     idk G (Vs (connected_component (G - incidence G X) {u, v})) X"
proof -
  let ?G' = "G - incidence G X"
  let ?C = "connected_component ?G' {u, v}"
  let ?C' = "Berge.connected_component ?G' u"
  have "tbd G X {u, v} = component_edges ?G' ?C' \<union> idk G ?C' X"
    using assms(1, 2)
    by (intro 2)
  also have "... = ?C \<union> idk G (Vs ?C) X"
  proof -
    have "{u, v} \<in> ?G'"
      using assms
      by (auto simp add: incidence_def idk_def)
    thus ?thesis
      by (simp add: component_edges_connected_component_cong[symmetric] Vs_component_edges_connected_component_cong)
  qed
  finally show ?thesis
    .
qed

subsection \<open>\<close>

definition tbds :: "'a graph \<Rightarrow> 'a set \<Rightarrow> 'a graph set" where
  "tbds G X \<equiv> {S. \<exists>e. e \<in> G \<and> S = tbd G X e}"

lemma tbds_image_cong:
  shows "tbds G X = (tbd G X) ` G"
  by (auto simp add: tbds_def)

end


(*
 * @TAG(OTHER_LGPL)
 *)

(*  Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Heap.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

theory Simpl_Heap
imports Main
begin

subsection "References"

definition "ref = (UNIV::nat set)"

typedef ref = ref by (simp add: ref_def)

code_type ref
  (SML "int")

lemma finite_nat_ex_max:
  assumes fin: "finite (N::nat set)"
  shows "\<exists>m. \<forall>n\<in>N. n < m"
using fin
proof (induct)
  case empty
  show ?case by auto
next
  case (insert k N)
  have "\<exists>m. \<forall>n\<in>N. n < m" by fact
  then obtain m where m_max: "\<forall>n\<in>N. n < m"..
  show "\<exists>m. \<forall>n\<in>insert k N. n < m"
  proof (rule exI [where x="Suc (max k m)"])
  qed (insert m_max, auto simp add: max_def)
qed

lemma infinite_nat: "\<not>finite (UNIV::nat set)"
proof
  assume fin: "finite (UNIV::nat set)"
  then obtain m::nat where "\<forall>n\<in>UNIV. n < m"
    by (rule finite_nat_ex_max [elim_format] ) auto
  moreover have "m\<in>UNIV"..
  ultimately show False by blast
qed

lemma infinite_ref [simp,intro]: "\<not>finite (UNIV::ref set)"
proof
  assume "finite (UNIV::ref set)"
  hence "finite (range Rep_ref)"
    by simp
  moreover
  have "range Rep_ref = ref"
  proof
    show "range Rep_ref \<subseteq> ref"
      by (simp add: ref_def)
  next
    show "ref \<subseteq> range Rep_ref"
    proof
      fix x
      assume x: "x \<in> ref"
      show "x \<in> range Rep_ref"
        by (rule Rep_ref_induct) (auto simp add: ref_def)
    qed
  qed
  ultimately have "finite ref"
    by simp
  thus False
    by (simp add: ref_def infinite_nat)
qed

consts Null :: ref

definition new :: "ref set \<Rightarrow> ref" where
  "new A = (SOME a. a \<notin> {Null} \<union> A)"

text {*
  Constant @{const "Null"} can be defined later on.  Conceptually
  @{const "Null"} and @{const "new"} are @{text "fixes"} of a locale
  with @{prop "finite A \<Longrightarrow> new A \<notin> A \<union> {Null}"}.  But since definitions
  relative to a locale do not yet work in Isabelle2005 we use this
  workaround to avoid lots of parameters in definitions.
*}

lemma new_notin [simp,intro]:
 "finite A \<Longrightarrow> new (A) \<notin> A"
  apply (unfold new_def)
  apply (rule someI2_ex)
  apply (fastforce intro: ex_new_if_finite)
  apply simp
  done

lemma new_not_Null [simp,intro]:
  "finite A \<Longrightarrow> new (A) \<noteq> Null"
  apply (unfold new_def)
  apply (rule someI2_ex)
  apply (fastforce intro: ex_new_if_finite)
  apply simp
done

end


chapter\<open>Formalizing Provability\<close>

theory Pf_Predicates
imports Coding_Predicates
begin

section \<open>Section 4 Predicates (Leading up to Pf)\<close>

subsection \<open>The predicate \<open>SentP\<close>, for the Sentiential (Boolean) Axioms\<close>

nominal_function SentP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom y \<sharp> (z,w,x); atom z \<sharp> (w,x); atom w \<sharp> x\<rbrakk> \<Longrightarrow>
    SentP x = Ex y (Ex z (Ex w (FormP (Var y) AND FormP (Var z) AND FormP (Var w) AND
               ( (x EQ Q_Imp (Var y) (Var y)) OR
                 (x EQ Q_Imp (Var y) (Q_Disj (Var y) (Var z)) OR
                 (x EQ Q_Imp (Q_Disj (Var y) (Var y)) (Var y)) OR
                 (x EQ Q_Imp (Q_Disj (Var y) (Q_Disj (Var z) (Var w)))
                             (Q_Disj (Q_Disj (Var y) (Var z)) (Var w))) OR
                 (x EQ Q_Imp (Q_Disj (Var y) (Var z))
                             (Q_Imp (Q_Disj (Q_Neg (Var y)) (Var w)) (Q_Disj (Var z) (Var w)))))))))"
  by (auto simp: eqvt_def SentP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows SentP_fresh_iff [simp]: "a \<sharp> SentP x \<longleftrightarrow> a \<sharp> x"                  (is ?thesis1)
   and SentP_sf [iff]:         "Sigma_fm (SentP x)"                     (is ?thsf)
proof -
  obtain y::name and z::name and w::name  where "atom y \<sharp> (z,w,x)" "atom z \<sharp> (w,x)" "atom w \<sharp> x"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

subsection \<open>The predicate \<open>Equality_axP\<close>, for the Equality Axioms\<close>

function Equality_axP :: "tm \<Rightarrow> fm"
  where "Equality_axP x =
    x EQ \<guillemotleft>refl_ax\<guillemotright> OR x EQ \<guillemotleft>eq_cong_ax\<guillemotright> OR x EQ \<guillemotleft>mem_cong_ax\<guillemotright> OR x EQ \<guillemotleft>eats_cong_ax\<guillemotright>"
by auto

termination
  by lexicographic_order

subsection \<open>The predicate \<open>HF_axP\<close>, for the HF Axioms\<close>

function HF_axP :: "tm \<Rightarrow> fm"
  where "HF_axP x = x EQ \<guillemotleft>HF1\<guillemotright> OR x EQ \<guillemotleft>HF2\<guillemotright>"
by auto

termination
  by lexicographic_order

lemma HF_axP_sf [iff]: "Sigma_fm (HF_axP t)"
  by auto

subsection \<open>The specialisation axioms\<close>

subsubsection \<open>Defining the syntax\<close>

nominal_function Special_axP :: "tm \<Rightarrow> fm" where
  "\<lbrakk>atom v \<sharp> (p,sx,y,ax,x); atom x \<sharp> (p,sx,y,ax);
    atom ax \<sharp> (p,sx,y); atom y \<sharp> (p,sx); atom sx \<sharp> p\<rbrakk> \<Longrightarrow>
  Special_axP p = Ex v (Ex x (Ex ax (Ex y (Ex sx
                   (FormP (Var x) AND VarP (Var v) AND TermP (Var y) AND
                    AbstFormP (Var v) Zero (Var x) (Var ax) AND
                    SubstFormP (Var v) (Var y) (Var x) (Var sx) AND
                    p EQ Q_Imp (Var sx) (Q_Ex (Var ax)))))))"
  by (auto simp: eqvt_def Special_axP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows Special_axP_fresh_iff [simp]: "a \<sharp> Special_axP p \<longleftrightarrow> a \<sharp> p" (is ?thesis1)
   and Special_axP_sf [iff]:       "Sigma_fm (Special_axP p)" (is ?thesis3)
proof -
  obtain v::name and x::name and ax::name and y::name and sx::name
    where "atom v \<sharp> (p,sx,y,ax,x)" "atom x \<sharp> (p,sx,y,ax)"
          "atom ax \<sharp> (p,sx,y)" "atom y \<sharp> (p,sx)" "atom sx \<sharp> p"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis3
    by auto
qed

subsection \<open>The induction axioms\<close>

subsubsection \<open>Defining the syntax\<close>

nominal_function Induction_axP :: "tm \<Rightarrow> fm" where
  "\<lbrakk>atom ax \<sharp> (p,v,w,x,x0,xw,xevw,allw,allvw);
    atom allvw \<sharp> (p,v,w,x,x0,xw,xevw,allw); atom allw \<sharp> (p,v,w,x,x0,xw,xevw);
    atom xevw \<sharp> (p,v,w,x,x0,xw); atom xw \<sharp> (p,v,w,x,x0);
    atom x0 \<sharp> (p,v,w,x); atom x \<sharp> (p,v,w);
    atom w \<sharp> (p,v); atom v \<sharp> p\<rbrakk> \<Longrightarrow>
  Induction_axP p = Ex v (Ex w (Ex x (Ex x0 (Ex xw (Ex xevw (Ex allw (Ex allvw (Ex ax
               ((Var v NEQ Var w) AND VarNonOccFormP (Var w) (Var x) AND
                SubstFormP (Var v) Zero (Var x) (Var x0) AND
                SubstFormP (Var v) (Var w) (Var x) (Var xw) AND
                SubstFormP (Var v) (Q_Eats (Var v) (Var w)) (Var x) (Var xevw) AND
                AbstFormP (Var w) Zero (Q_Imp (Var x) (Q_Imp (Var xw) (Var xevw))) (Var allw) AND
                AbstFormP (Var v) Zero (Q_All (Var allw)) (Var allvw) AND
                AbstFormP (Var v) Zero (Var x) (Var ax) AND
                p EQ Q_Imp (Var x0) (Q_Imp (Q_All (Var allvw)) (Q_All (Var ax))))))))))))"
  by (auto simp: eqvt_def Induction_axP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows Induction_axP_fresh_iff [simp]: "a \<sharp> Induction_axP p \<longleftrightarrow> a \<sharp> p" (is ?thesis1)
   and Induction_axP_sf [iff]: "Sigma_fm (Induction_axP p)" (is ?thesis3)
proof -
  obtain v::name and w::name and x::name and x0::name and xw::name and xevw::name
                 and allw::name and allvw::name and ax::name
    where atoms: "atom ax \<sharp> (p,v,w,x,x0,xw,xevw,allw,allvw)"
                 "atom allvw \<sharp> (p,v,w,x,x0,xw,xevw,allw)" "atom allw \<sharp> (p,v,w,x,x0,xw,xevw)"
                 "atom xevw \<sharp> (p,v,w,x,x0,xw)" "atom xw \<sharp> (p,v,w,x,x0)" "atom x0 \<sharp> (p,v,w,x)"
                 "atom x \<sharp> (p,v,w)" "atom w \<sharp> (p,v)" "atom v \<sharp> p"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis3
    by auto
qed

subsection \<open>The predicate \<open>AxiomP\<close>, for any Axioms\<close>

definition AxiomP :: "tm \<Rightarrow> fm"
  where "AxiomP x \<equiv> x EQ \<guillemotleft>extra_axiom\<guillemotright> OR SentP x OR Equality_axP x OR
                    HF_axP x OR Special_axP x OR Induction_axP x"

lemma AxiomP_I:
  "{} \<turnstile> AxiomP \<guillemotleft>extra_axiom\<guillemotright>"
  "{} \<turnstile> SentP x \<Longrightarrow> {} \<turnstile> AxiomP x"
  "{} \<turnstile> Equality_axP x \<Longrightarrow> {} \<turnstile> AxiomP x"
  "{} \<turnstile> HF_axP x \<Longrightarrow> {} \<turnstile> AxiomP x"
  "{} \<turnstile> Special_axP x \<Longrightarrow> {} \<turnstile> AxiomP x"
  "{} \<turnstile> Induction_axP x \<Longrightarrow> {} \<turnstile> AxiomP x"
  unfolding AxiomP_def
  by (rule Disj_I1, rule Refl,
      rule Disj_I2, rule Disj_I1, assumption,
      rule Disj_I2, rule Disj_I2, rule Disj_I1, assumption,
      rule Disj_I2, rule Disj_I2, rule Disj_I2, rule Disj_I1, assumption,
      rule Disj_I2, rule Disj_I2, rule Disj_I2, rule Disj_I2, rule Disj_I1, assumption,
      rule Disj_I2, rule Disj_I2, rule Disj_I2, rule Disj_I2, rule Disj_I2, assumption)

lemma AxiomP_eqvt [eqvt]: "(p \<bullet> AxiomP x) = AxiomP (p \<bullet> x)"
  by (simp add: AxiomP_def)

lemma AxiomP_fresh_iff [simp]: "a \<sharp> AxiomP x \<longleftrightarrow> a \<sharp> x"
  by (auto simp: AxiomP_def)

lemma AxiomP_sf [iff]: "Sigma_fm (AxiomP t)"
  by (auto simp: AxiomP_def)

subsection \<open>The predicate \<open>ModPonP\<close>, for the inference rule Modus Ponens\<close>

definition ModPonP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "ModPonP x y z = (y EQ Q_Imp x z)"

lemma ModPonP_eqvt [eqvt]: "(p \<bullet> ModPonP x y z) = ModPonP (p \<bullet> x) (p \<bullet> y) (p \<bullet> z)"
  by (simp add: ModPonP_def)

lemma ModPonP_fresh_iff [simp]: "a \<sharp> ModPonP x y z \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> y \<and> a \<sharp> z"
  by (auto simp: ModPonP_def)

lemma ModPonP_sf [iff]: "Sigma_fm (ModPonP t u v)"
  by (auto simp: ModPonP_def)

lemma ModPonP_subst [simp]:
  "(ModPonP t u v)(i::=w) = ModPonP (subst i w t) (subst i w u) (subst i w v)"
  by (auto simp: ModPonP_def)

subsection \<open>The predicate \<open>ExistsP\<close>, for the existential rule\<close>
subsubsection \<open>Definition\<close>

(*  "\<turnstile> A IMP B \<Longrightarrow> atom i \<sharp> B \<Longrightarrow>  \<turnstile> (Ex i A) IMP B" *)
nominal_function ExistsP :: "tm \<Rightarrow> tm \<Rightarrow> fm" where
  "\<lbrakk>atom x \<sharp> (p,q,v,y,x'); atom x' \<sharp> (p,q,v,y);
    atom y \<sharp> (p,q,v); atom v \<sharp> (p,q)\<rbrakk> \<Longrightarrow>
  ExistsP p q = Ex x (Ex x' (Ex y (Ex v (FormP (Var x) AND
                    VarNonOccFormP (Var v) (Var y) AND
                    AbstFormP (Var v) Zero (Var x) (Var x') AND
                    p EQ Q_Imp (Var x) (Var y) AND
                    q EQ Q_Imp (Q_Ex (Var x')) (Var y)))))"
  by (auto simp: eqvt_def ExistsP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows ExistsP_fresh_iff [simp]: "a \<sharp> ExistsP p q \<longleftrightarrow> a \<sharp> p \<and> a \<sharp> q"    (is ?thesis1)
   and ExistsP_sf [iff]:       "Sigma_fm (ExistsP p q)"   (is ?thesis3)
proof -
  obtain x::name and x'::name and y::name and v::name
    where "atom x \<sharp> (p,q,v,y,x')"  "atom x' \<sharp> (p,q,v,y)" "atom y \<sharp> (p,q,v)"  "atom v \<sharp> (p,q)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis3
    by auto
qed

lemma ExistsP_subst [simp]: "(ExistsP p q)(j::=w) = ExistsP (subst j w p) (subst j w q)"
proof -
  obtain x::name and x'::name and y::name and v::name
    where "atom x \<sharp> (j,w,p,q,v,y,x')"   "atom x' \<sharp> (j,w,p,q,v,y)"
          "atom y \<sharp> (j,w,p,q,v)"   "atom v \<sharp> (j,w,p,q)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: ExistsP.simps [of x _ _ x' y v])
qed

subsection \<open>The predicate \<open>SubstP\<close>, for the substitution rule\<close>

text\<open>Although the substitution rule is derivable in the calculus, the derivation is
too complicated to reproduce within the proof function. It is much easier to
provide it as an immediate inference step, justifying its soundness in terms
of other inference rules.\<close>

subsubsection \<open>Definition\<close>

nominal_function SubstP :: "tm \<Rightarrow> tm \<Rightarrow> fm" where
  "\<lbrakk>atom u \<sharp> (p,q,v); atom v \<sharp> (p,q)\<rbrakk> \<Longrightarrow>
   SubstP p q = Ex v (Ex u (SubstFormP (Var v) (Var u) p q))"
  by (auto simp: eqvt_def SubstP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows SubstP_fresh_iff [simp]: "a \<sharp> SubstP p q \<longleftrightarrow> a \<sharp> p \<and> a \<sharp> q"        (is ?thesis1)
   and SubstP_sf [iff]: "Sigma_fm (SubstP p q)"                           (is ?thesis3)
proof -
  obtain u::name and v::name  where "atom u \<sharp> (p,q,v)" "atom v \<sharp> (p,q)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis3
    by auto
qed

lemma SubstP_subst [simp]: "(SubstP p q)(j::=w) = SubstP (subst j w p) (subst j w q)"
proof -
  obtain u::name and v::name  where "atom u \<sharp> (j,w,p,q,v)"  "atom v \<sharp> (j,w,p,q)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: SubstP.simps [of u _ _ v])
qed

subsection \<open>The predicate \<open>PrfP\<close>\<close>

(*Prf(s,k,t) \<equiv> LstSeq(s,k,t) \<and> (\<forall>n\<in>k)[Sent (s n) \<or> (\<exists>m,l\<in>n)[ModPon (s m) (s l) (s n)]]*)
nominal_function PrfP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,sl,m,n,sm,sn); atom sl \<sharp> (s,m,n,sm,sn);
          atom m \<sharp> (s,n,sm,sn); atom n \<sharp> (s,k,sm,sn);
          atom sm \<sharp> (s,sn); atom sn \<sharp> (s)\<rbrakk> \<Longrightarrow>
    PrfP s k t =
      LstSeqP s k t AND
      All2 n (SUCC k) (Ex sn (HPair (Var n) (Var sn) IN s AND (AxiomP (Var sn) OR
                Ex m (Ex l (Ex sm (Ex sl (Var m IN Var n AND Var l IN Var n AND
                       HPair (Var m) (Var sm) IN s AND HPair (Var l) (Var sl) IN s AND
                       (ModPonP (Var sm) (Var sl) (Var sn) OR
                        ExistsP (Var sm) (Var sn) OR
                        SubstP (Var sm) (Var sn)))))))))"
  by (auto simp: eqvt_def PrfP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows PrfP_fresh_iff [simp]: "a \<sharp> PrfP s k t \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> t"      (is ?thesis1)
  and PrfP_imp_OrdP [simp]:    "{PrfP s k t} \<turnstile> OrdP k"         (is ?thord)
  and PrfP_imp_LstSeqP [simp]: "{PrfP s k t} \<turnstile> LstSeqP s k t"  (is ?thlstseq)
  and PrfP_sf [iff]:           "Sigma_fm (PrfP s k t)"         (is ?thsf)
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms: "atom l \<sharp> (s,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,m,n,sm,sn)"
        "atom m \<sharp> (s,n,sm,sn)"   "atom n \<sharp> (s,k,sm,sn)"
        "atom sm \<sharp> (s,sn)"   "atom sn \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thord ?thlstseq ?thsf
    by (auto intro: LstSeqP_OrdP)
qed

lemma PrfP_subst [simp]:
     "(PrfP t u v)(j::=w) = PrfP (subst j w t) (subst j w u) (subst j w v)"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where "atom l \<sharp> (t,u,v,j,w,sl,m,n,sm,sn)"   "atom sl \<sharp> (t,u,v,j,w,m,n,sm,sn)"
          "atom m \<sharp> (t,u,v,j,w,n,sm,sn)"   "atom n \<sharp> (t,u,v,j,w,sm,sn)"
          "atom sm \<sharp> (t,u,v,j,w,sn)"   "atom sn \<sharp> (t,u,v,j,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: PrfP.simps [of l _ sl m n sm sn])
qed

subsection \<open>The predicate \<open>PfP\<close>\<close>

nominal_function PfP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom k \<sharp> (s,y); atom s \<sharp> y\<rbrakk> \<Longrightarrow>
    PfP y = Ex k (Ex s (PrfP (Var s) (Var k) y))"
  by (auto simp: eqvt_def PfP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows PfP_fresh_iff [simp]: "a \<sharp> PfP y \<longleftrightarrow> a \<sharp> y"           (is ?thesis1)
   and PfP_sf [iff]: "Sigma_fm (PfP y)"                      (is ?thsf)
proof -
  obtain k::name and s::name where "atom k \<sharp> (s,y)" "atom s \<sharp> y"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma PfP_subst [simp]: "(PfP t)(j::=w) = PfP (subst j w t)"
proof -
  obtain k::name and s::name where "atom k \<sharp> (s,t,j,w)" "atom s \<sharp> (t,j,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: PfP.simps [of k s])
qed

lemma ground_PfP [simp]: "ground_fm (PfP y) = ground y"
  by (simp add: ground_aux_def ground_fm_aux_def supp_conv_fresh)

end


(*  Title:       Executable Transitive Closures of Finite Relations
    Author:      Christian Sternagel <c.sternagel@gmail.com>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

section \<open>Closure Computation using Lists\<close>

theory Transitive_Closure_List_Impl
imports Transitive_Closure_Impl
begin

text \<open>
  We provide two algorithms for the computation of the reflexive transitive closure which internally
  work on lists. The first one (@{term rtrancl_list_impl}) computes the closure on demand for a
  given set of initial states. The second one (@{term memo_list_rtrancl}) precomputes the closure
  for each individual state, stores the result, and then only does a look-up.

  For the transitive closure there are the corresponding algorithms @{term trancl_list_impl} and
  @{term memo_list_trancl}.
\<close>

subsection \<open>Computing Closures from Sets On-The-Fly\<close>

text \<open>
  The algorithms are based on the generic algorithms @{const rtrancl_impl} and @{const trancl_impl}
  instantiated by list operations. Here, after computing the successors in a straightforward way,
  we use @{const remdups} to not have duplicates in the results. Moreover, also in the union
  operation we filter to those elements that have not yet been seen. The use of @{const filter} in
  the union operation is preferred over @{const remdups} since by construction the latter set will
  not contain duplicates.
\<close>

definition rtrancl_list_impl :: "('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "rtrancl_list_impl = rtrancl_impl
    (\<lambda> r as. remdups (map snd (filter (\<lambda> (a, b). a \<in> set as) r)))
    (\<lambda> xs ys. (filter (\<lambda> x. x \<notin> set ys) xs) @ ys)
    (\<lambda> x xs. x \<in> set xs)
    []"

definition trancl_list_impl :: "('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "trancl_list_impl = trancl_impl
    (\<lambda> r as. remdups (map snd (filter (\<lambda> (a, b). a \<in> set as) r)))
    (\<lambda> xs ys. (filter (\<lambda> x. x \<notin> set ys) xs) @ ys)
    (\<lambda> x xs. x \<in> set xs)
    []"

lemma rtrancl_list_impl:
  "set (rtrancl_list_impl r as) = {b. \<exists> a \<in> set as. (a, b) \<in> (set r)\<^sup>*}"
  unfolding rtrancl_list_impl_def
  by (rule set_access_gen.rtrancl_impl, unfold_locales, force+)

lemma trancl_list_impl:
  "set (trancl_list_impl r as) = {b. \<exists> a \<in> set as. (a, b) \<in> (set r)\<^sup>+}"
  unfolding trancl_list_impl_def
  by (rule set_access_gen.trancl_impl, unfold_locales, force+)

subsection \<open>Precomputing Closures for Single States\<close>

text \<open>
  Storing all relevant entries is done by mapping all left-hand sides of the relation to their
  closure. To avoid redundant entries, @{const remdups} is used.
\<close>

definition memo_list_rtrancl :: "('a \<times> 'a) list \<Rightarrow> ('a \<Rightarrow> 'a list)"
where
  "memo_list_rtrancl r =
    (let
      tr = rtrancl_list_impl r;
      rm = map (\<lambda>a. (a, tr [a])) ((remdups \<circ> map fst) r)
    in
      (\<lambda>a. case map_of rm a of
        None \<Rightarrow> [a]
      | Some as \<Rightarrow> as))"

lemma memo_list_rtrancl:
  "set (memo_list_rtrancl r a) = {b. (a, b) \<in> (set r)\<^sup>*}" (is "?l = ?r")
proof -
  let ?rm = "map (\<lambda> a. (a, rtrancl_list_impl r [a])) ((remdups \<circ> map fst) r)"
  show ?thesis
  proof (cases "map_of ?rm a")
    case None
    have one: "?l = {a}"
      unfolding memo_list_rtrancl_def Let_def None
      by auto
    from None [unfolded map_of_eq_None_iff]
    have a: "a \<notin> fst ` set r" by force
    {
      fix b
      assume "b \<in> ?r"
      from this [unfolded rtrancl_power relpow_fun_conv] obtain n f where
        ab: "f 0 = a \<and> f n = b" and steps: "\<And> i. i < n \<Longrightarrow> (f i, f (Suc i)) \<in> set r" by auto
      from ab steps [of 0] a have "a = b"
        by (cases n, force+)
    }
    then have "?r = {a}" by auto
    then show ?thesis unfolding one by simp
  next
    case (Some as)
    have as: "set as = {b. (a, b) \<in> (set r)^*}"
      using map_of_SomeD [OF Some]
        rtrancl_list_impl [of r "[a]"] by force
    then show ?thesis unfolding memo_list_rtrancl_def Let_def Some by simp
  qed
qed

definition memo_list_trancl :: "('a \<times> 'a) list \<Rightarrow> ('a \<Rightarrow> 'a list)"
where
  "memo_list_trancl r =
    (let
      tr = trancl_list_impl r;
      rm = map (\<lambda>a. (a, tr [a])) ((remdups \<circ> map fst) r)
    in
      (\<lambda>a. case map_of rm a of
        None \<Rightarrow> []
      | Some as \<Rightarrow> as))"

lemma memo_list_trancl:
  "set (memo_list_trancl r a) = {b. (a, b) \<in> (set r)\<^sup>+}" (is "?l = ?r")
proof -
  let ?rm = "map (\<lambda> a. (a, trancl_list_impl r [a])) ((remdups \<circ> map fst) r)"
  show ?thesis
  proof (cases "map_of ?rm a")
    case None
    have one: "?l = {}"
      unfolding memo_list_trancl_def Let_def None
      by auto
    from None [unfolded map_of_eq_None_iff]
      have a: "a \<notin> fst ` set r" by force
    {
      fix b
      assume "b \<in> ?r"
      from this [unfolded trancl_unfold_left] a have False by force
    }
    then have "?r = {}" by auto
    then show ?thesis unfolding one by simp
  next
    case (Some as)
    have as: "set as = {b. (a, b) \<in> (set r)\<^sup>+}"
      using map_of_SomeD [OF Some]
        trancl_list_impl[of r "[a]"] by force
    then show ?thesis unfolding memo_list_trancl_def Let_def Some by simp
  qed
qed

end


theory FP64
imports
  IEEE
  Word_Lib.Word_64
begin

section \<open>Concrete encodings\<close>

text \<open>Floating point operations defined as operations on words.
  Called ''fixed precision'' (fp) word in HOL4.\<close>

type_synonym float64 = "(11,52)float"
type_synonym fp64 = "64 word"

lift_definition fp64_of_float :: "float64 \<Rightarrow> fp64" is
  "\<lambda>(s::1 word, e::11 word, f::52 word). word_cat s (word_cat e f::63 word)" .

lift_definition float_of_fp64 :: "fp64 \<Rightarrow> float64" is
  "\<lambda>x. apsnd word_split (word_split x::1 word * 63 word)" .

definition "rel_fp64 \<equiv> (\<lambda>x (y::word64). x = float_of_fp64 y)"

definition eq_fp64::"float64 \<Rightarrow> float64 \<Rightarrow> bool" where [simp]: "eq_fp64 \<equiv> (=)"

lemma float_of_fp64_inverse[simp]: "fp64_of_float (float_of_fp64 a) = a"
  by (auto
      simp: fp64_of_float_def float_of_fp64_def Abs_float_inverse apsnd_def map_prod_def word_size
      dest!: word_cat_split_alt[rotated]
      split: prod.splits)

lemma float_of_fp64_inj_iff[simp]: "fp64_of_float r = fp64_of_float s \<longleftrightarrow> r = s"
  using Rep_float_inject
  by (force simp: fp64_of_float_def word_cat_inj word_size split: prod.splits)

lemma fp64_of_float_inverse[simp]: "float_of_fp64 (fp64_of_float a) = a"
  using float_of_fp64_inj_iff float_of_fp64_inverse by blast

lemma Quotientfp: "Quotient eq_fp64 fp64_of_float float_of_fp64 rel_fp64"
  \<comment>\<open>\<^term>\<open>eq_fp64\<close> is a workaround to prevent a (failing -- TODO: why?)
      code setup in \<open>setup_lifting\<close>.\<close>
  by (force intro!: QuotientI simp: rel_fp64_def)

setup_lifting Quotientfp

lift_definition fp64_lessThan::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "flt::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_lessEqual::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "fle::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_greaterThan::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "fgt::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_greaterEqual::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "fge::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_equal::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "feq::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_abs::"fp64 \<Rightarrow> fp64" is
  "abs::float64\<Rightarrow>float64" by simp

lift_definition fp64_negate::"fp64 \<Rightarrow> fp64" is
  "uminus::float64\<Rightarrow>float64" by simp

lift_definition fp64_sqrt::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fsqrt::roundmode\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_add::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fadd::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_sub::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fsub::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_mul::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fmul::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_div::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fdiv::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_mul_add::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fmul_add::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

end


(* Title:   Monoid_SST_Type.thy
   Author:  Akama Hitoshi
*)

theory Monoid_SST_Type
  imports Main "../Core/Update" "../Core/Monoid_SST" "../Decomposition/Shuffle"
begin

type_synonym ('q, 'x, 'y) msst_type = "'q \<times> 'x \<Rightarrow> 'y shuffle set"

definition mult_shuffles :: "'x shuffle set \<Rightarrow> 'x shuffle set \<Rightarrow> 'x shuffle set" (infixl "\<otimes>" 60) where
  "A \<otimes> B = (\<Union>a\<in>A. \<Union>b\<in>B. { a \<odot> b })"

lemma mult_shuffles_member:
  assumes a: "a \<in> A"
  assumes b: "b \<in> B"
  shows "a \<odot> b \<in> A \<otimes> B"
  using a b by (auto simp add: mult_shuffles_def)

lemma mult_shuffles_right_unit [simp]: "A \<otimes> { idS } = A"
  by (simp add: mult_shuffles_def)

lemma mult_shuffles_left_unit [simp]: "{ idS } \<otimes> A = A"
  by (simp add: mult_shuffles_def)

lemma mult_shuffles_assoc [simp]:
  "A \<otimes> (B \<otimes> C) = (A \<otimes> B) \<otimes> C"
  by (rule equalityI, simp_all add: mult_shuffles_def compS_assoc)

lemma mult_shuffles_subset:
  assumes "A \<subseteq> C"
  assumes "B \<subseteq> D"
  shows "A \<otimes> B \<subseteq> C \<otimes> D"
proof
  fix x
  assume "x \<in> A \<otimes> B"
  then obtain a b where ab: "x = a \<odot> b \<and> a \<in> A \<and> b \<in> B"
    unfolding mult_shuffles_def by blast
  then have cd: "a \<in> C \<and> b \<in> D" using assms(1) assms(2) by blast
  then show "x \<in> C \<otimes> D" by (auto simp add: mult_shuffles_member ab)
qed

definition tails where
  "tails xs = {ys. \<exists>zs. xs = zs @ ys}"

fun type_hom :: "('q, 'x, 'y) msst_type \<Rightarrow> ('q \<times> (('x + ('y, 'b) update) list) \<Rightarrow> 'y shuffle set)" where
  "type_hom \<gamma> (q, []) = { idS }" |
  "type_hom \<gamma> (q, (Inl x#xs)) = \<gamma> (q, x) \<otimes> type_hom \<gamma> (q, xs)" |
  "type_hom \<gamma> (q, (Inr m#xs)) = { \<pi>\<^sub>1 m } \<otimes> type_hom \<gamma> (q, xs)"

definition bctype_idS where
  "bctype_idS k msst \<gamma> = (\<forall>x. idS \<in> \<gamma> (initial msst, x))"

definition bctype_step where
  "bctype_step k msst \<gamma> = (\<forall>x q a. type_hom \<gamma> (q, eta msst (q, a) x) \<subseteq> \<gamma> (delta msst (q, a), x))"

definition bctype_bounded where
  "bctype_bounded k msst \<gamma> = (\<forall>q x. \<forall>m \<in> \<gamma> (q, x). (reachable msst q \<longrightarrow> bounded_shuffle k m))"

definition bctype_tails where
  "bctype_tails k msst \<gamma> = (\<forall>q x w. \<forall>u \<in> tails (SST.eta_hat msst (q, w) x).
        \<forall>m \<in> type_hom \<gamma> (q, u). (reachable msst q \<longrightarrow> bounded_shuffle k m))"

definition bctype :: "nat \<Rightarrow> ('q, 'x, 'y, 'a, 'b) MSST \<Rightarrow> ('q, 'x, 'y) msst_type \<Rightarrow> bool" where
  "bctype k msst \<gamma> \<equiv> bctype_idS k msst \<gamma> \<and> bctype_step k msst \<gamma> \<and>
                      bctype_bounded k msst \<gamma> \<and> bctype_tails k msst \<gamma>"

lemma bctype_idS:
  assumes "bctype k msst \<gamma>"
  shows "idS \<in> \<gamma> (initial msst, x)"
  using assms unfolding bctype_def bctype_idS_def by simp

lemma bctype_step:
  assumes "bctype k msst \<gamma>"
  shows "type_hom \<gamma> (q, eta msst (q, a) x) \<subseteq> \<gamma> (delta msst (q, a), x)"
  using assms unfolding bctype_def bctype_step_def by simp

lemma bctype_bounded:
  assumes "bctype k msst \<gamma>"
  assumes "reachable msst q"
  assumes "m \<in> \<gamma> (q, x)"
  shows "bounded_shuffle k m"
  using assms unfolding bctype_def bctype_bounded_def by simp

lemma bctype_tails:
  assumes "bctype k msst \<gamma>"
  assumes "reachable msst q"
  assumes "u \<in> tails (SST.eta_hat msst (q, w) x)"
  assumes "m \<in> type_hom \<gamma> (q, u)"
  shows "bounded_shuffle k m"
  using assms unfolding bctype_def bctype_tails_def by simp

lemma type_hom_append [simp]: "type_hom \<gamma> (q, u @ v) = type_hom \<gamma> (q, u) \<otimes> type_hom \<gamma> (q, v)"
  by (induct u arbitrary: q rule: xa_induct, simp_all)

lemma type_hom_subset:
  assumes bc: "bctype k msst \<gamma>"
  shows "type_hom \<gamma> (q, hat_hom (SST.eta msst (q, a)) u)
      \<subseteq> type_hom \<gamma> (delta msst (q, a), u)"
  using bctype_step[OF bc]
  by (induct u rule: xa_induct, simp_all add: mult_shuffles_subset)

lemma type_hom_hat_hom:
  assumes "bctype k msst \<gamma>"
  shows "type_hom \<gamma> (q, hat_hom (eta_hat msst (q, w)) u)
      \<subseteq> type_hom \<gamma> (delta_hat msst (q, w), u)"
proof (induct w arbitrary: q u)
case Nil
  then show ?case by simp
next
  case (Cons a w)
  then show ?case (is "?a \<subseteq> ?b") proof -
    have "?a \<subseteq> type_hom \<gamma> (delta msst (q, a), hat_hom (SST.eta_hat msst (delta msst (q, a), w)) u)"
      using assms by (simp add: type_hom_subset compU_lem)
    also have "... \<subseteq> ?b"
      by (simp add: Cons)
    finally show "?a \<subseteq> ?b" .
  qed
qed

end


theory EtaExpansion
imports "../Launchbury/Terms" "../Launchbury/Substitution"
begin

definition fresh_var :: "exp \<Rightarrow> var" where
  "fresh_var e = (SOME v. v \<notin> fv e)"

lemma fresh_var_not_free:
  "fresh_var e \<notin> fv e"
proof-
  obtain v :: var where "atom v \<sharp> e" by (rule obtain_fresh)
  hence "v \<notin> fv e" by (metis fv_not_fresh)
  thus ?thesis unfolding fresh_var_def by (rule someI)
qed

lemma fresh_var_fresh[simp]:
  "atom (fresh_var e) \<sharp> e"
  by (metis fresh_var_not_free fv_not_fresh)

lemma fresh_var_subst[simp]:
  "e[fresh_var e::=x] = e"
  by (metis fresh_var_fresh subst_fresh_noop)

fun eta_expand :: "nat \<Rightarrow> exp \<Rightarrow> exp" where
   "eta_expand 0 e = e"
|  "eta_expand (Suc n) e = (Lam [fresh_var e]. eta_expand n (App e (fresh_var e)))"

lemma eta_expand_eqvt[eqvt]:
  "\<pi> \<bullet> (eta_expand n e) = eta_expand (\<pi> \<bullet> n) (\<pi> \<bullet> e)"
  apply (induction n arbitrary: e \<pi>)
  apply (auto simp add: fresh_Pair permute_pure)
  apply (metis fresh_at_base_permI fresh_at_base_permute_iff fresh_var_fresh subst_fresh_noop subst_swap_same)
  done

lemma fresh_eta_expand[simp]: "a \<sharp> eta_expand n e \<longleftrightarrow> a \<sharp> e"
  apply (induction n arbitrary: e)
  apply  (simp add: fresh_Pair)
  apply  (clarsimp simp add: fresh_Pair fresh_at_base)
  by (metis fresh_var_fresh)

lemma subst_eta_expand: "(eta_expand n e)[x ::= y] = eta_expand n (e[x ::= y])"
proof (induction n arbitrary: e)
case 0 thus ?case by simp
next
case (Suc n)
  obtain z :: var where "atom z \<sharp> (e, fresh_var e, x, y)" by (rule obtain_fresh)

  have "(eta_expand (Suc n) e)[x::=y] = (Lam [fresh_var e]. eta_expand n (App e (fresh_var e)))[x::=y]" by simp
  also have "\<dots> = (Lam [z]. eta_expand n (App e z))[x::=y]"
    apply (subst change_Lam_Variable[where y' = z])
    using `atom z \<sharp> _`
    by (auto simp add: fresh_Pair eta_expand_eqvt pure_fresh permute_pure flip_fresh_fresh intro!: eqvt_fresh_cong2[where f = eta_expand, OF eta_expand_eqvt])
  also have "\<dots> = Lam [z]. (eta_expand n (App e z))[x::=y]"
    using `atom z \<sharp> _` by simp
  also have "\<dots> = Lam [z]. eta_expand n (App e z)[x::=y]" unfolding Suc.IH..
  also have "\<dots> = Lam [z]. eta_expand n (App e[x::=y] z)"
    using `atom z \<sharp> _` by simp
  also have "\<dots> = Lam [fresh_var (e[x::=y])]. eta_expand n (App e[x::=y] (fresh_var (e[x::=y])))"
    apply (subst change_Lam_Variable[where y' = "fresh_var (e[x::=y])"])
    using `atom z \<sharp> _`
    by (auto simp add: fresh_Pair eqvt_fresh_cong2[where f = eta_expand, OF eta_expand_eqvt] pure_fresh eta_expand_eqvt  flip_fresh_fresh subst_pres_fresh simp del: exp_assn.eq_iff)
  also have "\<dots> = eta_expand (Suc n) e[x::=y]" by simp
  finally show ?case.
qed

lemma isLam_eta_expand:
  "isLam e \<Longrightarrow> isLam (eta_expand n e)" and "n > 0 \<Longrightarrow> isLam (eta_expand n e)"
by (induction n) auto

lemma isVal_eta_expand:
  "isVal e \<Longrightarrow> isVal (eta_expand n e)" and "n > 0 \<Longrightarrow> isVal (eta_expand n e)"
by (induction n) auto

end


header {* Open Singly Linked Lists *}
theory Open_List
imports List_Seg Imp_List_Spec
begin

subsection {* Definitions *}
type_synonym 'a os_list = "'a node ref option"

abbreviation os_list :: "'a list \<Rightarrow> ('a\<Colon>heap) os_list \<Rightarrow> assn" where
  "os_list l p \<equiv> lseg l p None"

subsection {* Precision *}
lemma os_prec:
  "precise os_list"
  by rule (simp add: lseg_prec2)

lemma os_imp_list_impl: "imp_list os_list"
  apply unfold_locales
  apply (rule os_prec)
  done
interpretation os!: imp_list os_list by (rule os_imp_list_impl)

subsection {* Operations *}
subsubsection {* Allocate Empty List *}

definition os_empty :: "'a\<Colon>heap os_list Heap" where
  "os_empty \<equiv> return None"

lemma os_empty_rule: "<emp> os_empty <os_list []>"
  unfolding os_empty_def
  apply sep_auto
  done

lemma os_empty_impl: "imp_list_empty os_list os_empty"
  apply unfold_locales
  apply (sep_auto heap add: os_empty_rule)
  done
interpretation os!: imp_list_empty os_list os_empty by (rule os_empty_impl)

subsubsection {* Emptiness check *}
text {* A linked list is empty, iff it is the null pointer. *}

definition os_is_empty :: "'a\<Colon>heap os_list \<Rightarrow> bool Heap" where
  "os_is_empty b \<equiv> return (b = None)"

lemma os_is_empty_rule:
  "<os_list xs b> os_is_empty b <\<lambda>r. os_list xs b * \<up>(r \<longleftrightarrow> xs = [])>"
  unfolding os_is_empty_def
  apply sep_auto
  done

lemma os_is_empty_impl: "imp_list_is_empty os_list os_is_empty"
  apply unfold_locales
  apply (sep_auto heap add: os_is_empty_rule)
  done
interpretation os!: imp_list_is_empty os_list os_is_empty
  by (rule os_is_empty_impl)

subsubsection {* Prepend *}

text {* To push an element to the front of a list we allocate a new node which
  stores the element and the old list as successor. The new list is the new
  allocated reference. *}

definition os_prepend :: "'a \<Rightarrow> 'a\<Colon>heap os_list \<Rightarrow> 'a os_list Heap" where
  "os_prepend a n = do { p \<leftarrow> ref (Node a n); return (Some p) }"

lemma os_prepend_rule:
  "<os_list xs n> os_prepend x n <os_list (x # xs)>"
  unfolding os_prepend_def
  apply sep_auto
  done

lemma os_prepend_impl: "imp_list_prepend os_list os_prepend"
  apply unfold_locales
  apply (sep_auto heap add: os_prepend_rule)
  done
interpretation os!: imp_list_prepend os_list os_prepend
  by (rule os_prepend_impl)

subsubsection{* Pop *}
text {* To pop the first element out of the list we look up the value and the
  reference of the node and return the pair of those. *}

fun os_pop :: "'a\<Colon>heap os_list \<Rightarrow> ('a \<times> 'a os_list) Heap" where
  "os_pop None   = raise ''Empty Os_list''" |
  "os_pop (Some p) = do {m \<leftarrow> !p; return (val m, next m)}"

declare os_pop.simps[simp del]

lemma os_pop_rule:
  "xs \<noteq> [] \<Longrightarrow> <os_list xs r>
  os_pop r
  <\<lambda>(x,r'). os_list (tl xs) r' * (the r) \<mapsto>\<^sub>r (Node x r') * \<up>(x = hd xs)>"

  apply (cases r, simp_all)
  apply (cases xs, simp_all)

  apply (sep_auto simp: os_pop.simps)
  done

lemma os_pop_impl: "imp_list_pop os_list os_pop"
  apply unfold_locales
  apply (sep_auto heap add: os_pop_rule)
  done
interpretation os!: imp_list_pop os_list os_pop by (rule os_pop_impl)

subsubsection {* Reverse *}

text {* The following reversal function is equivalent to the one from
  Imperative HOL. And gives a more difficult example. *}

partial_function (heap) os_reverse_aux
  :: "'a\<Colon>heap os_list \<Rightarrow> 'a os_list \<Rightarrow> 'a os_list Heap"
  where [code]:
  "os_reverse_aux q p = (case p of
    None \<Rightarrow> return q |
    Some r \<Rightarrow> do {
      v \<leftarrow> !r;
      r := Node (val v) q;
      os_reverse_aux p (next v) })"

lemma [simp, sep_dflt_simps]:
  "os_reverse_aux q None = return q"
  "os_reverse_aux q (Some r) = do {
      v \<leftarrow> !r;
      r := Node (val v) q;
      os_reverse_aux (Some r) (next v) }"
  apply (subst os_reverse_aux.simps)
  apply simp
  apply (subst os_reverse_aux.simps)
  apply simp
  done

definition "os_reverse p = os_reverse_aux None p"

lemma os_reverse_aux_rule:
  "<os_list xs p * os_list ys q>
    os_reverse_aux q p
  <os_list ((rev xs) @ ys) >"
proof (induct xs arbitrary: p q ys)
  case Nil thus ?case
    apply sep_auto
    done
next
  case (Cons x xs)
  show ?case
    apply (cases p, simp_all)
    apply (sep_auto heap add: cons_pre_rule[OF _ Cons.hyps])
    done
qed

lemma os_reverse_rule: "<os_list xs p> os_reverse p <os_list (rev xs)>"
  unfolding os_reverse_def
  apply (auto simp: os_reverse_aux_rule[where ys="[]", simplified, rule_format])
  done

lemma os_reverse_impl: "imp_list_reverse os_list os_reverse"
  apply unfold_locales
  apply (sep_auto heap add: os_reverse_rule)
  done
interpretation os!: imp_list_reverse os_list os_reverse
  by (rule os_reverse_impl)

subsubsection {* Remove *}

text {* Remove all appearances of an element from a linked list. *}

partial_function (heap) os_rem
  :: "'a::heap \<Rightarrow> 'a node ref option \<Rightarrow> 'a node ref option Heap"
  where [code]:
  "os_rem x b = (case b of
     None \<Rightarrow> return None |
     Some p \<Rightarrow> do {
       n \<leftarrow> !p;
       q \<leftarrow> os_rem x (next n);
       (if (val n = x)
         then return q
         else do {
           p := Node (val n) q;
           return (Some p) }) })"

lemma [simp, sep_dflt_simps]:
  "os_rem x None = return None"
  "os_rem x (Some p) = do {
       n \<leftarrow> !p;
       q \<leftarrow> os_rem x (next n);
       (if (val n = x)
         then return q
         else do {
           p := Node (val n) q;
           return (Some p) }) }"
  apply (subst os_rem.simps, simp)+
  done

lemma os_rem_rule[sep_heap_rules]:
  "<os_list xs b> os_rem x b <\<lambda>r. os_list (removeAll x xs) r * true>"
proof (induct xs arbitrary: b x) (* Have to generalize over x, as
    sep_auto preprocessor introduces a new variable. Alternative:
    No preprocessing. (See alternative proof below) *)
  case Nil show ?case
    apply sep_auto
    done
next
  case (Cons y xs)
  show ?case by (sep_auto heap add: Cons.hyps)
qed

lemma os_rem_rule_alt_proof:
  "<os_list xs b> os_rem x b <\<lambda>r. os_list (removeAll x xs) r * true>"
proof (induct xs arbitrary: b)
  case Nil show ?case
    apply sep_auto
    done
next
  case (Cons y xs)
  show ?case
    by (sep_auto (nopre) heap add: Cons.hyps) (* Switching off preprocessor *)
qed

subsubsection {* Iterator *}

type_synonym 'a os_list_it = "'a os_list"
definition "os_is_it l p l2 it
  \<equiv> \<exists>\<^sub>Al1. \<up>(l=l1@l2) * lseg l1 p it * os_list l2 it"

definition os_it_init :: "'a os_list \<Rightarrow> ('a os_list_it) Heap"
  where "os_it_init l = return l"

fun os_it_next where
  "os_it_next (Some p) = do {
    n \<leftarrow> !p;
    return (val n,next n)
  }"

definition os_it_has_next :: "'a os_list_it \<Rightarrow> bool Heap" where
  "os_it_has_next it \<equiv> return (it\<noteq>None)"

lemma os_iterate_impl:
  "imp_list_iterate os_list os_is_it os_it_init os_it_has_next os_it_next"
  apply unfold_locales
  unfolding os_it_init_def os_is_it_def[abs_def]
  apply sep_auto

  apply (case_tac it, simp)
  apply (case_tac l', simp)
  apply sep_auto
  apply (rule ent_frame_fwd[OF lseg_append])
    apply frame_inference
    apply simp

  unfolding os_it_has_next_def
  apply (sep_auto elim!: list_not_emptyE)

  apply solve_entails
  apply (rule ent_frame_fwd[OF lseg_conc])
    apply frame_inference
    apply solve_entails
  done
interpretation os!:
  imp_list_iterate os_list os_is_it os_it_init os_it_has_next os_it_next
  by (rule os_iterate_impl)

subsubsection {* List-Sum *}

partial_function (heap) os_sum' :: "int os_list_it \<Rightarrow> int \<Rightarrow> int Heap"
  where [code]:
  "os_sum' it s = do {
    b \<leftarrow> os_it_has_next it;
    if b then do {
      (x,it') \<leftarrow> os_it_next it;
      os_sum' it' (s+x)
    } else return s
  }"

lemma os_sum'_rule[sep_heap_rules]:
  "<os_is_it l p l' it>
    os_sum' it s
  <\<lambda>r. os_list l p * \<up>(r = s + listsum l')>\<^sub>t"
proof (induct l' arbitrary: it s)
  case Nil thus ?case
    apply (subst os_sum'.simps)
    apply (sep_auto intro: os.quit_iteration)
    done
next
  case (Cons x l')
  show ?case
    apply (subst os_sum'.simps)
    apply (sep_auto heap: Cons.hyps)
    done
qed

definition "os_sum p \<equiv> do {
  it \<leftarrow> os_it_init p;
  os_sum' it 0}"

lemma os_sum_rule[sep_heap_rules]:
  "<os_list l p> os_sum p <\<lambda>r. os_list l p * \<up>(r=listsum l)>\<^sub>t"
  unfolding os_sum_def
  by sep_auto

end


theory FreeLogic imports Main

begin
 consts fExistence:: "'a\<Rightarrow>bool" ("E") (*Existence/definedness predicate in free logic*)

 abbreviation fNot ("\<^bold>\<not>") (*Free negation*)
   where "\<^bold>\<not>\<phi> \<equiv> \<not>\<phi>"
 abbreviation fImplies (infixr "\<^bold>\<rightarrow>" 13) (*Free implication*)
   where "\<phi> \<^bold>\<rightarrow> \<psi> \<equiv> \<phi> \<longrightarrow> \<psi>"
 abbreviation fIdentity (infixr "\<^bold>=" 13) (*Free identity*)
   where "l \<^bold>= r \<equiv> l = r"
 abbreviation fForall ("\<^bold>\<forall>") (*Free universal quantification*)
   where "\<^bold>\<forall>\<Phi> \<equiv> \<forall>x. E x \<longrightarrow> \<Phi> x"
 abbreviation fForallBinder (binder "\<^bold>\<forall>" [8] 9) (*Binder notation*)
   where "\<^bold>\<forall>x. \<phi> x \<equiv> \<^bold>\<forall>\<phi>"

 abbreviation fOr (infixr "\<^bold>\<or>" 11)
   where "\<phi> \<^bold>\<or> \<psi> \<equiv> (\<^bold>\<not>\<phi>) \<^bold>\<rightarrow> \<psi>"
 abbreviation fAnd (infixr "\<^bold>\<and>" 12)
   where "\<phi> \<^bold>\<and> \<psi> \<equiv> \<^bold>\<not>(\<^bold>\<not>\<phi> \<^bold>\<or> \<^bold>\<not>\<psi>)"
 abbreviation fImplied (infixr "\<^bold>\<leftarrow>" 13)
   where "\<phi> \<^bold>\<leftarrow> \<psi> \<equiv> \<psi> \<^bold>\<rightarrow> \<phi>"
 abbreviation fEquiv (infixr "\<^bold>\<leftrightarrow>" 15)
   where "\<phi> \<^bold>\<leftrightarrow> \<psi> \<equiv> (\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<and> (\<psi> \<^bold>\<rightarrow> \<phi>)"
 abbreviation fExists ("\<^bold>\<exists>")
   where "\<^bold>\<exists>\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
 abbreviation fExistsBinder (binder "\<^bold>\<exists>" [8]9)
   where "\<^bold>\<exists>x. \<phi> x \<equiv> \<^bold>\<exists>\<phi>"
 abbreviation fExistsUnique ("\<^bold>\<exists>!")
  where "\<^bold>\<exists>!\<phi> \<equiv> \<^bold>\<exists>x. (\<phi> x \<and> (\<^bold>\<forall>y. \<phi> y \<longrightarrow> y = x))"
 abbreviation fExistsUniqueBinder (binder "\<^bold>\<exists>!" [8]9)
  where "\<^bold>\<exists>!x. \<phi> x \<equiv> \<^bold>\<exists>!\<phi>"

abbreviation KlEq (infixr "\<cong>" 56) (* Kleene equality *)
   where "x \<cong> y \<equiv> (E x \<^bold>\<or> E y) \<^bold>\<rightarrow> x \<^bold>= y"
abbreviation ExId (infixr "\<simeq>" 56) (* Existing identity *)
   where "x \<simeq> y \<equiv> E x \<^bold>\<and> E y \<^bold>\<and> x \<^bold>= y"

lemma fallI [intro]: "\<^bold>\<forall>x. \<phi> x" if "\<And>x. E x \<longrightarrow> \<phi> x" using that by simp
lemma fexI [intro]: "\<^bold>\<exists>x. \<phi> x" if "E x \<and> \<phi> x" using that by auto
lemma fexE [elim]: "(\<And>x. (E x \<and> \<phi> x) \<Longrightarrow> C) \<Longrightarrow> C" if "\<^bold>\<exists>x. \<phi> x" using that by auto

lemma equE: assumes "A \<Longrightarrow> B" and "B \<Longrightarrow> A" shows "A \<^bold>\<leftrightarrow> B"
  using assms(1) assms(2) by blast
lemma contraposition: assumes "\<not>B \<longrightarrow> \<not>A" shows "A \<longrightarrow> B"
  using assms by blast

end


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

(*
Termination for recursive functions.
*)
theory Factorial
imports
  "../../AutoCorres"
  "../../../../lib/Monad_WP/OptionMonadWP"
begin

(* Parse the input file. *)
install_C_file "factorial.c"

autocorres "factorial.c"

context factorial begin

(* Termination *)
thm factorial'.simps

lemma ovalidNF_grab_asm2:
  "ovalidNF (\<lambda>s. G \<and> P s) f Q \<Longrightarrow> G \<Longrightarrow> ovalidNF P f Q"
  by (auto simp: ovalidNF_def)

lemma ovalidNF_grab_asm_eq:
  "(G \<longrightarrow> ovalidNF P f Q) = ovalidNF (\<lambda>s. G \<and> P s) f Q"
  by (auto simp: ovalidNF_def)

lemma ovalid_post_triv:
  "(\<And>r s. Q r s) \<Longrightarrow> ovalid P f Q"
  by (simp add: ovalid_def)

lemma factorial'_terminates: "no_ofail (\<lambda>_. m > unat n) (factorial' m n)"
proof (induct n arbitrary: m rule: less_induct)
   fix x m
   assume induct_asm0: "(\<And>y m. y < x \<Longrightarrow> no_ofail (\<lambda>_. unat y < m) (factorial' m y))"
   have induct_asm: "(\<And>y m. no_ofail (\<lambda>_. y < x \<and> unat y < m) (factorial' m y))"
     apply (rule no_ofail_grab_asm)
     by (rule induct_asm0)

   show "no_ofail (\<lambda>_. unat x < m) (factorial' m x)"
     apply (subst factorial'.simps)
     apply (wp induct_asm ovalid_post_triv)
     apply unat_arith
    done
qed

lemma factorial'_terminates_old: "m > unat n \<longrightarrow> factorial' m n s \<noteq> None"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, simp add: ocondition_def obind_def split: option.splits)
  apply (metis One_nat_def Suc_eq_plus1 less_diff_conv option.distinct(1) unatSuc)
  done

(* A fun fact *)
function fact :: "('n :: len) word \<Rightarrow> ('n :: len) word" where
  "fact n = (if n = 0 then 1 else n * fact (n - 1))"
  by auto
termination by (metis "termination" in_measure measure_unat wf_measure)
declare fact.simps [simp del]

(* Termination & correctness *)
lemma factorial'_correct: "ovalidNF (\<lambda>_. m > unat n) (factorial' m n) (\<lambda>r _. r = fact n)"
proof (induct n arbitrary: m)
   fix n m
   show "ovalidNF (\<lambda>_. unat 0 < m) (factorial' m 0) (\<lambda>r _. r = fact 0)"
     apply (subst factorial'.simps)
     apply (simp add: ovalidNF_def ocondition_def ofail_def oreturn_def obind_def fact.simps)
     done

   assume induct_asm0: "\<And>m. ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. r = fact n)"
   have induct_asm: "\<And>m. 1 + n \<noteq> 0 \<Longrightarrow> ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. (1 + n) * r = fact (1 + n))"
     apply (subst fact.simps)
     apply simp
     apply (insert induct_asm0)
     apply (unfold ovalidNF_def)
     apply simp
     done

   show "\<lbrakk> 1 + n \<noteq> 0 \<rbrakk>
          \<Longrightarrow> ovalidNF (\<lambda>_. unat (1 + n) < m) (factorial' m (1 + n))
              (\<lambda>r _. r = fact (1 + n))"
     apply (subst factorial'.simps)
     apply (rule_tac G = "1 + n \<noteq> 0" in ovalidNF_grab_asm2)
      apply wp
       apply (simp del: One_nat_def)
       apply (wp induct_asm)
      apply unat_arith
     apply assumption
    done
qed

lemma factorial'_correct_old: "m > unat n \<longrightarrow> factorial' m n s = Some (fact n)"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (clarsimp split: option.splits)
  apply (intro conjI impI)
    apply unat_arith
   apply (metis (hide_lams, no_types) Nat.add_0_right le_iff_add Suc_eq_plus1_left Suc_pred factorial.factorial'_terminates_old less_nat_zero_code nat_add_left_cancel_less nat_less_le)
  apply (unat_arith, force)
  done

(* Termination & correctness of call_factorial *)
thm call_factorial'_def

lemma "\<lbrace> \<top> \<rbrace> call_factorial' \<lbrace> \<lambda>r s. r = fact 42 \<rbrace>!"
  unfolding call_factorial'_def
  apply wp
   using factorial'_correct_old
   apply force
  apply (force simp: option_monad_mono_eq (* factorial'_mono *))
  done

end

end