(*  Title:      CIDR_Split.thy
    Authors:    Julius Michaelis, Cornelius Diekmann
*)
theory CIDR_Split
imports IP_Address
        Prefix_Match
        Hs_Compat
begin

section\<open>CIDR Split Motivation (Example for IPv4)\<close>
  text\<open>When talking about ranges of IP addresses, we can make the ranges explicit by listing their elements.\<close>
context
begin
  private lemma "map (of_nat \<circ> nat) [1 .. 4] = ([1, 2, 3, 4]:: 32 word list)" by eval
  private definition ipv4addr_upto :: "32 word \<Rightarrow> 32 word \<Rightarrow> 32 word list" where
    "ipv4addr_upto i j \<equiv> map (of_nat \<circ> nat) [int (unat i) .. int (unat j)]"
  private lemma ipv4addr_upto: "set (ipv4addr_upto i j) = {i .. j}"
    proof -
      have int_interval_eq_image: "{int m..int n} = int ` {m..n}" for m n
        by (auto intro!: image_eqI [of _ int "nat k" for k])
      have helpX:"\<And>f (i::nat) (j::nat). (f \<circ> nat) ` {int i..int j} = f ` {i .. j}"
        by (auto simp add: image_comp int_interval_eq_image)
    {   fix xa :: int
        assume a1: "int (unat i) \<le> xa \<and> xa \<le> int (unat j)"
        then have f2: "int (nat xa) = xa"
          by force
        then have "unat (of_int xa::32 word) = nat xa"
          using a1 by (metis (full_types) le_unat_uoi nat_int nat_mono of_int_of_nat_eq)
        then have "i \<le> of_int xa" and "of_int xa \<le> j"
          using f2 a1 by (metis (no_types) uint_nat word_le_def)+
    } note hlp=this
    show ?thesis
      unfolding ipv4addr_upto_def
      apply(intro set_eqI)
      apply(simp)
      apply(safe)
        apply(simp_all)
        using hlp apply blast
        using hlp apply blast
        apply (metis atLeastAtMost_iff imageI image_int_atLeastAtMost of_int_of_nat_eq word_le_nat_alt word_unat.Rep_inverse)
        done
    qed

  text\<open>The function @{const ipv4addr_upto} gives back a list of all the ips in the list.
        This list can be pretty huge! In the following, we will use CIDR notation (e.g. 192.168.0.0/24)
        to describe the list more compactly.\<close>
end

section\<open>CIDR Split\<close>

context
begin

private lemma find_SomeD: "find f x = Some y \<Longrightarrow> f y \<and> y \<in> set x"
  by(induction x; simp split: if_splits)

(*pfxes needs a dummy parameter. The first parameter is a dummy that we have the 'a::len0 type and
  can refer to its length.*)
private definition pfxes :: "'a::len0 itself \<Rightarrow> nat list" where
  "pfxes _ = map nat [0..int(len_of TYPE ('a))]"
private lemma "pfxes TYPE(32) = map nat [0 .. 32]" by eval

private definition "largest_contained_prefix (a::('a :: len) word) r = (
  let cs = (map (\<lambda>s. PrefixMatch a s) (pfxes TYPE('a)));
      \<comment> \<open>anything that is a subset should also be a valid prefix. but try proving that.\<close>
      cfs = find (\<lambda>s. valid_prefix s \<and> wordinterval_subset (prefix_to_wordinterval s) r) cs in
  cfs)
"
(* The joke is that it is always Some, given that a \<in> r. *)

text\<open>Split off one prefix:\<close>
private definition wordinterval_CIDR_split1
  :: "'a::len wordinterval \<Rightarrow> 'a prefix_match option \<times> 'a wordinterval" where
  "wordinterval_CIDR_split1 r \<equiv> (
   let ma = wordinterval_lowest_element r in
   case ma of
      None \<Rightarrow> (None, r) |
      Some a \<Rightarrow> (case largest_contained_prefix a r of
        None \<Rightarrow> (None, r) |
        Some m \<Rightarrow> (Some m, wordinterval_setminus r (prefix_to_wordinterval m))))"

private lemma wordinterval_CIDR_split1_innard_helper: fixes a::"'a::len word"
  shows "wordinterval_lowest_element r = Some a \<Longrightarrow>
  largest_contained_prefix a r \<noteq> None"
proof -
  assume a: "wordinterval_lowest_element r = Some a"
  have b: "(a,len_of(TYPE('a))) \<in> set (map (Pair a) (pfxes TYPE('a)))"
    unfolding pfxes_def set_map set_upto
    using Set.image_iff atLeastAtMost_iff int_eq_iff order_refl by metis (*400ms*)
  have c: "valid_prefix (PrefixMatch a (len_of(TYPE('a))))" by(simp add: valid_prefix_def pfxm_mask_def)
  have "wordinterval_to_set (prefix_to_wordinterval (PrefixMatch a (len_of(TYPE('a))))) = {a}"
    unfolding prefix_to_wordinterval_def pfxm_mask_def by simp
  moreover have "a \<in> wordinterval_to_set r"
    using a wordinterval_lowest_element_set_eq wordinterval_lowest_none_empty
    by (metis is_lowest_element_def option.distinct(1))
  ultimately have d:
    "wordinterval_to_set (prefix_to_wordinterval (PrefixMatch a (LENGTH('a)))) \<subseteq> wordinterval_to_set r"
    by simp
  show ?thesis
    unfolding largest_contained_prefix_def Let_def
    using b c d by(auto simp add: find_None_iff)
qed

private lemma r_split1_not_none: fixes r:: "'a::len wordinterval"
  shows "\<not> wordinterval_empty r \<Longrightarrow> fst (wordinterval_CIDR_split1 r) \<noteq> None"
  unfolding wordinterval_CIDR_split1_def Let_def
  by(cases "wordinterval_lowest_element r")
    (auto simp add: wordinterval_lowest_none_empty
          dest: wordinterval_CIDR_split1_innard_helper)

private lemma largest_contained_prefix_subset:
  "largest_contained_prefix a r = Some p \<Longrightarrow> wordinterval_to_set (prefix_to_wordinterval p) \<subseteq> wordinterval_to_set r"
unfolding largest_contained_prefix_def Let_def
by(drule find_SomeD) simp

private lemma wordinterval_CIDR_split1_snd: "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow> u = wordinterval_setminus r (prefix_to_wordinterval s)"
  unfolding wordinterval_CIDR_split1_def Let_def by(clarsimp split: option.splits)

private lemma largest_contained_prefix_subset_s1D:
  "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow> wordinterval_to_set (prefix_to_wordinterval s) \<subseteq> wordinterval_to_set r"
by(intro largest_contained_prefix_subset[where a = "the (wordinterval_lowest_element r)"])
  (simp add: wordinterval_CIDR_split1_def split: option.splits)

private theorem wordinterval_CIDR_split1_preserve: fixes r:: "'a::len wordinterval"
  shows "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow> wordinterval_eq (wordinterval_union (prefix_to_wordinterval s) u) r"
proof(unfold wordinterval_eq_set_eq)
  assume as: "wordinterval_CIDR_split1 r = (Some s, u)"
  have ud: "u = wordinterval_setminus r (prefix_to_wordinterval s)"
    using as[THEN wordinterval_CIDR_split1_snd] .
  with largest_contained_prefix_subset_s1D[OF as]
  show "wordinterval_to_set (wordinterval_union (prefix_to_wordinterval s) u) = wordinterval_to_set r"
    unfolding ud by auto
qed

private lemma wordinterval_CIDR_split1_some_r_ne:
  "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow> \<not> wordinterval_empty r"
proof(rule ccontr, goal_cases)
  case 1
  have "wordinterval_lowest_element r = None" unfolding wordinterval_lowest_none_empty using 1(2) unfolding not_not .
  then have "wordinterval_CIDR_split1 r = (None, r)" unfolding wordinterval_CIDR_split1_def Let_def by simp
  then show False using 1(1) by simp
qed

private lemma wordinterval_CIDR_split1_distinct: fixes r:: "'a::len wordinterval"
  shows "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow>
           wordinterval_empty (wordinterval_intersection (prefix_to_wordinterval s) u)"
proof(goal_cases)
  case 1
  have nn: "wordinterval_lowest_element r \<noteq> None"
    using wordinterval_CIDR_split1_some_r_ne 1 wordinterval_lowest_none_empty by metis
  from 1 have "u = wordinterval_setminus r (prefix_to_wordinterval s)"
    by(elim wordinterval_CIDR_split1_snd)
  then show ?thesis by simp
qed

private lemma wordinterval_CIDR_split1_distinct2: fixes r:: "'a::len wordinterval"
  shows "wordinterval_CIDR_split1 r = (Some s, u) \<Longrightarrow>
          wordinterval_empty (wordinterval_intersection (prefix_to_wordinterval s) u)"
by(rule wordinterval_CIDR_split1_distinct[where r = r]) simp

function wordinterval_CIDR_split_prefixmatch
  :: "'a::len wordinterval \<Rightarrow> 'a prefix_match list" where
  "wordinterval_CIDR_split_prefixmatch rs = (
      if
        \<not> wordinterval_empty rs
      then case wordinterval_CIDR_split1 rs
                      of (Some s, u) \<Rightarrow> s # wordinterval_CIDR_split_prefixmatch u
                      |   _ \<Rightarrow> []
      else
        []
      )"
  by pat_completeness simp

termination wordinterval_CIDR_split_prefixmatch
proof(relation "measure (card \<circ> wordinterval_to_set)", rule wf_measure, unfold in_measure comp_def, goal_cases)
  note vernichter = wordinterval_empty_set_eq wordinterval_intersection_set_eq wordinterval_union_set_eq wordinterval_eq_set_eq
  case (1 rs x y x2)
  note some = 1(2)[unfolded 1(3), symmetric]
  from prefix_never_empty have "wordinterval_to_set (prefix_to_wordinterval x2) \<noteq> {}" unfolding vernichter .
  thus ?case
    unfolding wordinterval_CIDR_split1_preserve[OF some, unfolded vernichter, symmetric]
    unfolding card_Un_disjoint[OF finite finite wordinterval_CIDR_split1_distinct[OF some, unfolded vernichter]]
    by auto
qed

private lemma unfold_rsplit_case:
  assumes su: "(Some s, u) = wordinterval_CIDR_split1 rs"
  shows "(case wordinterval_CIDR_split1 rs of (None, u) \<Rightarrow> []
                                            | (Some s, u) \<Rightarrow> s # wordinterval_CIDR_split_prefixmatch u) = s # wordinterval_CIDR_split_prefixmatch u"
using su by (metis option.simps(5) split_conv)

lemma "wordinterval_CIDR_split_prefixmatch
          (RangeUnion (WordInterval (0x40000000) 0x5FEFBBCC) (WordInterval 0x5FEEBB1C 0x7FFFFFFF))
       = [PrefixMatch (0x40000000::32 word) 2]" by eval
lemma "length (wordinterval_CIDR_split_prefixmatch (WordInterval 0 (0xFFFFFFFE::32 word))) = 32" by eval

declare wordinterval_CIDR_split_prefixmatch.simps[simp del]

theorem wordinterval_CIDR_split_prefixmatch:
  "wordinterval_to_set r = (\<Union>x\<in>set (wordinterval_CIDR_split_prefixmatch r). prefix_to_wordset x)"
proof(induction r rule: wordinterval_CIDR_split_prefixmatch.induct)
  case (1 rs)
  show ?case proof(cases "wordinterval_empty rs")
    case True
    thus ?thesis by(simp add: wordinterval_CIDR_split_prefixmatch.simps)
  next
    case False
    obtain x y where s1: "wordinterval_CIDR_split1 rs = (Some x, y)"
      using r_split1_not_none[OF False] by(auto simp add: fst_def split: prod.splits)
    have mIH: "wordinterval_to_set y = (\<Union>x\<in>set (wordinterval_CIDR_split_prefixmatch y). prefix_to_wordset x)"
      using 1[OF False s1[symmetric] refl] .
    have *: "wordinterval_to_set rs = prefix_to_wordset x \<union> (\<Union>x\<in>set (wordinterval_CIDR_split_prefixmatch y). prefix_to_wordset x)"
      unfolding mIH[symmetric]
    proof -
      have ud: "y = wordinterval_setminus rs (prefix_to_wordinterval x)"
        using wordinterval_CIDR_split1_snd[OF s1] .
      have ss: "prefix_to_wordset x \<subseteq> wordinterval_to_set rs"
        using largest_contained_prefix_subset_s1D[OF s1] by simp
      show "wordinterval_to_set rs = prefix_to_wordset x \<union> wordinterval_to_set y"
        unfolding ud using ss by simp blast
    qed
    show ?thesis
      apply(subst wordinterval_CIDR_split_prefixmatch.simps)
      apply(unfold if_P[OF False] s1 prod.simps option.simps *) (* WOOOOO simplifier bug (* try making this a simp add: *) *)
      apply(simp)
    done
  qed
qed

lemma wordinterval_CIDR_split_prefixmatch_all_valid_Ball: fixes r:: "'a::len wordinterval"
  shows "\<forall>e\<in>set (wordinterval_CIDR_split_prefixmatch r). valid_prefix e \<and> pfxm_length e \<le> LENGTH('a)"
(* The induction is somewhat verbose, so it is less annoying to write the two down at once *)
proof(induction r rule: wordinterval_CIDR_split_prefixmatch.induct)
  case 1
  case (1 rs)
  show ?case proof(cases "wordinterval_empty rs")
    case False
    obtain x y where s1: "wordinterval_CIDR_split1 rs = (Some x, y)"
      using r_split1_not_none[OF False] by(auto simp add: fst_def split: prod.splits)
    hence i1: "valid_prefix x"
      unfolding wordinterval_CIDR_split1_def Let_def largest_contained_prefix_def
      by(auto dest: find_SomeD split: option.splits)
    have i2: "pfxm_length x \<le> LENGTH('a)"
      using s1 unfolding wordinterval_CIDR_split1_def Let_def largest_contained_prefix_def pfxes_def
      by(force split: option.splits dest: find_SomeD simp: nat_le_iff)
    have mIH: "\<forall>a\<in>set (wordinterval_CIDR_split_prefixmatch y). valid_prefix a \<and> pfxm_length a \<le> LENGTH('a)"
      using 1[OF False s1[symmetric] refl] .
    with i1 i2 show ?thesis
      apply(subst wordinterval_CIDR_split_prefixmatch.simps)
      apply(unfold if_P[OF False] s1 prod.simps option.simps)
      apply(simp)
    done
  qed (simp add: wordinterval_CIDR_split_prefixmatch.simps)
qed

private lemma wordinterval_CIDR_split_prefixmatch_all_valid_less_Ball_hlp:
	"x \<in> set [s\<leftarrow>map (PrefixMatch x2) (pfxes TYPE('a::len0)) . valid_prefix s \<and> wordinterval_to_set (prefix_to_wordinterval s) \<subseteq> wordinterval_to_set rs] \<Longrightarrow> pfxm_length x \<le> LENGTH('a)"
by(clarsimp simp: pfxes_def) presburger

text\<open>Since @{const wordinterval_CIDR_split_prefixmatch} only returns valid prefixes, we can safely convert it to CIDR lists\<close>
(* actually, just valid_prefix doesn't mean that the prefix length is sane. Fortunately, wordinterval_CIDR_split_prefixmatch_all_valid_Ball does entail that *)
lemma "valid_prefix (PrefixMatch (0::16 word) 20)" by(simp add: valid_prefix_def)

lemma wordinterval_CIDR_split_disjunct: "a \<in> set (wordinterval_CIDR_split_prefixmatch i) \<Longrightarrow>
  b \<in> set (wordinterval_CIDR_split_prefixmatch i) \<Longrightarrow> a \<noteq> b \<Longrightarrow>
  prefix_to_wordset a \<inter> prefix_to_wordset b = {}"
proof(induction i rule: wordinterval_CIDR_split_prefixmatch.induct)
  case (1 rs)
  note IH = 1(1)
  have prema: "a \<in> set (wordinterval_CIDR_split_prefixmatch rs)" (is "a \<in> ?os") using 1 by simp
  have premb: "b \<in> ?os" using 1 by simp
  show ?case proof(cases "wordinterval_empty rs")
    case False
    obtain x y where s1: "wordinterval_CIDR_split1 rs = (Some x, y)"
      using r_split1_not_none[OF False] by(auto simp add: fst_def split: prod.splits)
    have mi: "k \<in> set (wordinterval_CIDR_split_prefixmatch y)" (is "k \<in> ?rs")
      if p: "k \<noteq> x" "k \<in> ?os" for k using p s1
      by(subst (asm) wordinterval_CIDR_split_prefixmatch.simps) (simp only: if_P[OF False] split: prod.splits option.splits; simp)
    have a: "k \<in> ?rs \<Longrightarrow> prefix_to_wordset k \<subseteq> wordinterval_to_set y" for k
      (* this is actually a quite general statement, might make a lemma out of it *)
      unfolding wordinterval_CIDR_split_prefixmatch by blast
    have b: "prefix_to_wordset x \<inter> wordinterval_to_set y = {}"
      using wordinterval_CIDR_split1_snd[OF s1] by simp
    show ?thesis
    proof(cases "a = x"; cases "b = x")
      assume as: "a = x" "b \<noteq> x"
      with a[OF mi[OF as(2) premb]] b
      show ?thesis by blast
    next
      assume as: "a \<noteq> x" "b = x"
      with a[OF mi[OF as(1) prema]] b
      show ?thesis by blast
    next
      assume as: "a \<noteq> x" "b \<noteq> x" (* Nothing to do case *)
      have i: "a \<in> ?rs" "b \<in> ?rs"
        using as mi prema premb by blast+
      show "prefix_to_wordset a \<inter> prefix_to_wordset b = {}"
        by(rule IH[OF False s1[symmetric] refl i]) (fact 1)
    next
      assume as: "a = x" "b = x" (* impossible case *)
      with 1 have False by simp
      thus ?thesis ..
    qed
  next
    case True
    hence "wordinterval_CIDR_split_prefixmatch rs = []" by(simp add: wordinterval_CIDR_split_prefixmatch.simps)
    thus ?thesis using prema by simp
  qed
qed

lemma wordinterval_CIDR_split_distinct: "distinct (wordinterval_CIDR_split_prefixmatch i)"
(* wish this was a corollary *)
proof(induction i rule: wordinterval_CIDR_split_prefixmatch.induct)
  case (1 rs)
  show ?case proof(cases "wordinterval_empty rs")
    case False
    obtain x y where s1: "wordinterval_CIDR_split1 rs = (Some x, y)"
      using r_split1_not_none[OF False] by(auto simp add: fst_def split: prod.splits)
    have mIH: "distinct (wordinterval_CIDR_split_prefixmatch y)"
      using 1[OF False s1[symmetric] refl] .
    have "prefix_to_wordset x \<inter> wordinterval_to_set y = {}"
      using wordinterval_CIDR_split1_snd[OF s1] by simp
    hence i1: "x \<notin> set (wordinterval_CIDR_split_prefixmatch y)"
      unfolding wordinterval_CIDR_split_prefixmatch using prefix_never_empty[of x, simplified] by blast
    show ?thesis
      using s1
      by(subst wordinterval_CIDR_split_prefixmatch.simps)
        (simp add: if_P[OF False] mIH i1 split: option.splits prod.splits)
  qed (simp add: wordinterval_CIDR_split_prefixmatch.simps)
qed

lemma wordinterval_CIDR_split_existential:
	"x \<in> wordinterval_to_set w \<Longrightarrow> \<exists>s. s \<in> set (wordinterval_CIDR_split_prefixmatch w) \<and> x \<in> prefix_to_wordset s"
using wordinterval_CIDR_split_prefixmatch[symmetric] by fastforce

subsection\<open>Versions for @{const ipset_from_cidr}\<close>

definition cidr_split :: "'i::len wordinterval \<Rightarrow> ('i word \<times> nat) list" where
  "cidr_split rs \<equiv> map prefix_match_to_CIDR (wordinterval_CIDR_split_prefixmatch rs)"

corollary cidr_split_prefix:
  fixes r :: "'i::len wordinterval"
  shows "(\<Union>x\<in>set (cidr_split r). uncurry ipset_from_cidr x) = wordinterval_to_set r"
    unfolding wordinterval_CIDR_split_prefixmatch[symmetric] cidr_split_def
    apply(simp add: prefix_match_to_CIDR_def2 wordinterval_CIDR_split_prefixmatch)
    using prefix_to_wordset_ipset_from_cidr wordinterval_CIDR_split_prefixmatch_all_valid_Ball by blast

corollary cidr_split_prefix_single:
  fixes start :: "'i::len word"
  shows "(\<Union>x\<in>set (cidr_split (iprange_interval (start, end))). uncurry ipset_from_cidr x) = {start..end}"
  unfolding wordinterval_to_set.simps[symmetric]
  using cidr_split_prefix iprange_interval.simps by metis

private lemma interval_in_splitD: "xa \<in> foo \<Longrightarrow> prefix_to_wordset xa \<subseteq> \<Union>(prefix_to_wordset ` foo)" by auto

end

end


theory ExponentialCategory imports Category

begin

definition (in categoryProduct) isExponential:: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("isExp")
  where "isExp a b c \<epsilon> \<equiv> \<^bold>\<exists>p1 p2. product a c (dom \<epsilon>) p1 p2 \<and> \<epsilon>:(a\<^bold>\<times>c)\<rightarrow>b \<and>
                        (\<^bold>\<forall>z f. \<^bold>\<exists>q1 q2. product z a (dom f) q1 q2 \<and> f:(z\<^bold>\<times>a)\<rightarrow>b \<and>
                          (\<^bold>\<exists>!\<ff>. \<ff>:z\<rightarrow>c \<and> (\<^bold>\<exists>!\<jj>. \<jj>:(dom f)\<rightarrow>(dom \<epsilon>) \<and>
                            p2 \<cdot> \<jj> \<simeq> \<ff> \<cdot> q1 \<and> p1 \<cdot> \<jj> \<simeq> q2 \<and> \<epsilon> \<cdot> \<jj> \<simeq> f)))"

class exponentialCategory = categoryProduct +
  fixes  exp::"'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_\<^sup>_")

  assumes E1: "\<^bold>\<forall>a b. \<^bold>\<exists>\<epsilon>. isExp a b (exp a b) \<epsilon>" and
          E2: "E (a\<^sup>b) \<longrightarrow> (E a \<and> E b)"
begin

\<comment> \<open>Checking notation\<close>
lemma "\<^bold>\<forall>a b. \<^bold>\<exists>\<epsilon>. (isExp a b (a\<^sup>b) \<epsilon>)"
  using local.E1 by blast

lemma "True" nitpick[satisfy] oops

lemma "\<exists>x. final x" oops

abbreviation finalObj::'a where "finalObj \<equiv> SOME x. final x"

end

sublocale exponentialCategory \<subseteq> cartesianCategory domain codomain composition product_func finalObj sorry

proposition "E A \<and> type (A::'a::exponentialCategory) \<longrightarrow> isFunctor (\<lambda>x. (x\<^sup>A))" oops

end


theory Map_Map_E2
imports "$HETS_ISABELLE_LIB/MainHC" "List" "$HETS_LIB/Isabelle/RestrictOpProps"
uses "$HETS_ISABELLE_LIB/prelude"
begin

ML "Header.initialize
    [\"Ax1\", \"Ax2\", \"Ax3\", \"Ax4\", \"Ax1_5\", \"Ax2_6\",
     \"Ax3_7\"]"

consts
X_filter :: "'a list => ('a => bool) => 'a list"
X_map :: "('a => 'b partial) => 'a list => 'b list partial"

axioms
Ax1 [rule_format] :
"ALL (f :: 'a => 'b partial). X_map f [] = makePartial []"

Ax2 [rule_format] :
"ALL (f :: 'a => 'b partial).
 ALL (l :: 'a list).
 ALL (x :: 'a).
 X_map f (Cons x l) =
 restrictOp
 (makePartial (Cons (makeTotal (f x)) (makeTotal (X_map f l))))
 (defOp (f x) & defOp (X_map f l))"

Ax3 [rule_format] :
"ALL (P :: 'a => bool).
 ALL (l :: 'a list).
 ALL (x :: 'a).
 X_filter (Cons x l) P =
 (if P x then Cons x (X_filter l P) else X_filter l P)"

Ax4 [rule_format] : "ALL (P :: 'a => bool). X_filter [] P = []"

declare Ax1 [simp]
declare Ax4 [simp]

theorem Ax1_5 :
"ALL (P :: 'a => bool).
 ALL (f :: 'a => 'a partial).
 ALL (l :: 'a list).
 defOp (X_map f l) --> defOp (X_map f (X_filter l P))"
apply (rule allI)+
apply (induct_tac l)
apply (simp add: Ax1 Ax2 Ax3 Ax4)
apply (simp add: Ax1 Ax2 Ax3 Ax4)
done

lemma defopXmapcons: "defOp(X_map f (Cons h l)) -->defOp(f h) & defOp(X_map f l)"
apply (auto)
apply (simp add: Ax2)
apply (simp add: Ax2)
done

lemma filter_under_xmap_meta : "!!f hd l. defOp (X_map f (X_filter (Cons hd l) P)) ==>  (~(P hd) | ((P hd) & defOp(f hd) )) & defOp(X_map f (X_filter l P)) "
apply (auto)
apply (simp add: Ax3 Ax2 if_P)
apply (simp add: Ax3 Ax2 if_P)
apply (case_tac "P hd")
apply (simp add: Ax3 Ax2 if_P)
apply (simp add: Ax3 Ax2 if_P)
done

ML "Header.record \"Ax1_5\""

theorem Ax2_6 :
"ALL (Q :: 'a => bool).
 ALL (f :: 'a => 'a partial).
 ALL (l :: 'a list).
 defOp (X_map f l) -->
 X_map f (X_filter l (% h. defOp (f h) & Q (makeTotal (f h)))) =
 restrictOp (makePartial (X_filter (makeTotal (X_map f l)) Q))
 (defOp (X_map f l))"
apply (rule allI)+
apply (induct_tac l)
apply (simp)
apply (simp add: Ax3 Ax2)
done

ML "Header.record \"Ax2_6\""

theorem Ax3_7 :
"ALL (f :: 'a => 'a partial).
 ALL (l :: 'a list).
 ALL (x :: 'a).
 defOp (f x) -->
 defOp
 (restrictOp (makePartial (Cons (makeTotal (f x)) l))
  (defOp (f x)))"
apply (auto)
done

ML "Header.record \"Ax3_7\""

end


section \<open> Extension and Restriction \<close>

theory Extension
  imports Substitutions
begin

subsection \<open> Expressions \<close>

syntax
  "_aext"      :: "logic \<Rightarrow> svid \<Rightarrow> logic" (infixl "\<up>" 80)
  "_ares"      :: "logic \<Rightarrow> svid \<Rightarrow> logic" (infixl "\<down>" 80)
  "_pre"       :: "logic \<Rightarrow> logic" ("_\<^sup><" [999] 1000)
  "_post"      :: "logic \<Rightarrow> logic" ("_\<^sup>>" [999] 1000)
  "_drop_pre"  :: "logic \<Rightarrow> logic" ("_\<^sub><" [999] 1000)
  "_drop_post" :: "logic \<Rightarrow> logic" ("_\<^sub>>" [999] 1000)

translations
  "_aext P a" == "CONST aext P a"
  "_ares P a" == "CONST ares P a"
  "_pre P" == "_aext (P)\<^sub>e fst\<^sub>L"
  "_post P" == "_aext (P)\<^sub>e snd\<^sub>L"
  "_drop_pre P" == "_ares (P)\<^sub>e fst\<^sub>L"
  "_drop_post P" == "_ares (P)\<^sub>e snd\<^sub>L"

expr_constructor aext
expr_constructor ares

named_theorems alpha

lemma aext_var [alpha]: "($x)\<^sub>e \<up> a = ($a:x)\<^sub>e"
  by (simp add: expr_defs lens_defs)

lemma ares_aext [alpha]: "weak_lens a \<Longrightarrow> P \<up> a \<down> a = P"
  by (simp add: expr_defs)

lemma aext_ares [alpha]: "\<lbrakk> mwb_lens a; (- $a) \<sharp> P \<rbrakk> \<Longrightarrow> P \<down> a \<up> a = P"
  unfolding unrest_compl_lens
  by (auto simp add: expr_defs fun_eq_iff lens_create_def)

lemma expr_pre [simp]: "e\<^sup>< (s\<^sub>1, s\<^sub>2) = (e)\<^sub>e s\<^sub>1"
  by (simp add: subst_ext_def subst_app_def)

lemma expr_post [simp]: "e\<^sup>> (s\<^sub>1, s\<^sub>2) = (@e)\<^sub>e s\<^sub>2"
  by (simp add: subst_ext_def subst_app_def)

lemma unrest_aext_expr_lens [unrest]: "\<lbrakk> mwb_lens x; x \<bowtie> a \<rbrakk> \<Longrightarrow> $x \<sharp> (P \<up> a)"
  by (expr_simp add: lens_indep.lens_put_irr2)

subsection \<open> Substitutions \<close>

definition subst_aext :: "'a subst \<Rightarrow> ('a \<Longrightarrow> 'b) \<Rightarrow> 'b subst"
  where [expr_defs]: "subst_aext \<sigma> x = (\<lambda> s. put\<^bsub>x\<^esub> s (\<sigma> (get\<^bsub>x\<^esub> s)))"

definition subst_ares :: "'b subst \<Rightarrow> ('a \<Longrightarrow> 'b) \<Rightarrow> 'a subst"
  where [expr_defs]: "subst_ares \<sigma> x = (\<lambda> s. get\<^bsub>x\<^esub> (\<sigma> (create\<^bsub>x\<^esub> s)))"

syntax
  "_subst_aext" :: "logic \<Rightarrow> svid \<Rightarrow> logic" (infixl "\<up>\<^sub>s" 80)
  "_subst_ares" :: "logic \<Rightarrow> svid \<Rightarrow> logic" (infixl "\<down>\<^sub>s" 80)

translations
  "_subst_aext P a" == "CONST subst_aext P a"
  "_subst_ares P a" == "CONST subst_ares P a"

lemma subst_id_ext [usubst]:
  "vwb_lens x \<Longrightarrow> [\<leadsto>] \<up>\<^sub>s x = [\<leadsto>]"
  by expr_auto

lemma upd_subst_ext [alpha]:
  "vwb_lens x \<Longrightarrow> \<sigma>(y \<leadsto> e) \<up>\<^sub>s x = (\<sigma> \<up>\<^sub>s x)(x:y \<leadsto> e \<up> x)"
  by expr_auto

lemma apply_subst_ext [alpha]:
  "vwb_lens x \<Longrightarrow> (\<sigma> \<dagger> e) \<up> x = (\<sigma> \<up>\<^sub>s x) \<dagger> (e \<up> x)"
  by (expr_auto)

lemma subst_aext_comp [usubst]:
  "vwb_lens a \<Longrightarrow> (\<sigma> \<up>\<^sub>s a) \<circ>\<^sub>s (\<rho> \<up>\<^sub>s a) = (\<sigma> \<circ>\<^sub>s \<rho>) \<up>\<^sub>s a"
  by expr_auto

end


header {* Definition *}

theory %invisible Definition
imports Main
begin

text {* \label{chap:definition} *}

text {* In stepwise refinement~\cite{DijkstraConstructive,WirthRefinement},
a program is derived from a specification
via a sequence of intermediate specifications. *}

text {* Pop-refinement (where `pop' stands for `predicates over programs')
is an approach to stepwise refinement,
carried out inside an interactive theorem prover
(e.g.\ Isabelle/HOL, HOL4, Coq, PVS, ACL2)
as follows:
\begin{enumerate}
\item
Formalize the syntax and semantics
of (the needed subset of) the target programming language (and libraries),
as a deep embedding.
\item
Specify the requirements
by defining a predicate over programs
that characterizes the possible implementations.
\item
Refine the specification stepwise
by defining monotonically decreasing predicates over programs
(decreasing with respect to inclusion, i.e.\ logical implication),
according to decisions that narrow down the possible implementations.
\item
Conclude the derivation
with a predicate that characterizes a unique program in explicit syntactic form,
from which the program text is readily obtained.
\end{enumerate} *}

end %invisible


section \<open>The Proof System\<close>

theory OG_Hoare imports OG_Tran begin

fun assertions :: "'a ann_com \<Rightarrow> ('a assn) set" where
  "assertions (AnnBasic (x, r) f) = (if x then {r} else {})"
| "assertions (AnnSeq c1 c2) = assertions c1 \<union> assertions c2"
| "assertions (AnnCond1 (x, r) b c1 c2) = (if x then {r} else {}) \<union> assertions c1 \<union> assertions c2"
| "assertions (AnnCond2 (x, r) b c) = (if x then {r} else {}) \<union> assertions c"
| "assertions (AnnWhile (x, r) b (y, i) c) = (if x then {r} else {}) \<union> (if y then {i} else {}) \<union> assertions c"
| "assertions (AnnAwait (x, r) b c) = (if x then {r} else {})"

primrec atomics :: "'a ann_com \<Rightarrow> ('a assn \<times> 'a com) set" where
  "atomics (AnnBasic r f) = {(snd r, Basic f)}"
| "atomics (AnnSeq c1 c2) = atomics c1 \<union> atomics c2"
| "atomics (AnnCond1 r b c1 c2) = atomics c1 \<union> atomics c2"
| "atomics (AnnCond2 r b c) = atomics c"
| "atomics (AnnWhile r b i c) = atomics c"
| "atomics (AnnAwait r b c) = {(snd r \<inter> b, c)}"

primrec uses_pre :: "'a ann_com \<Rightarrow> bool" where
  "uses_pre (AnnBasic r f) = fst r"
| "uses_pre (AnnSeq c1 c2) = uses_pre c1"
| "uses_pre (AnnCond1 r b c1 c2) = fst r"
| "uses_pre (AnnCond2 r b c) = fst r"
| "uses_pre (AnnWhile r b i c) = fst r"
| "uses_pre (AnnAwait r b c) = fst r"

primrec uses_all_pres :: "'a ann_com \<Rightarrow> bool" where
  "uses_all_pres (AnnBasic r f) = fst r"
| "uses_all_pres (AnnSeq c1 c2) = (uses_all_pres c1 \<and> uses_all_pres c2)"
| "uses_all_pres (AnnCond1 r b c1 c2) = (fst r \<and> uses_all_pres c1 \<and> uses_all_pres c2)"
| "uses_all_pres (AnnCond2 r b c) = (fst r \<and> uses_all_pres c)"
| "uses_all_pres (AnnWhile r b i c) = (fst r \<and> fst i \<and> uses_all_pres c)"
| "uses_all_pres (AnnAwait r b c) = fst r"

primrec uses_all_pres' :: "'a com \<Rightarrow> bool" where
  "uses_all_pres' (Parallel Ts) = (\<forall>i<length Ts. com(Ts ! i) \<noteq> None \<longrightarrow> uses_all_pres (the(com(Ts ! i))))"
| "uses_all_pres' (Basic f) = True"
| "uses_all_pres' (Seq c1 c2) = (uses_all_pres' c1 \<and> uses_all_pres' c2)"
| "uses_all_pres' (Cond b c1 c2) = (uses_all_pres' c1 \<and> uses_all_pres' c2)"
| "uses_all_pres' (While b i c) = uses_all_pres' c"

lemma uses_all_pres[simp]:
  "uses_all_pres c \<Longrightarrow> uses_pre c"
  apply(induct rule: ann_com_com.induct [THEN conjunct1])
  by auto

lemma atom_com_uses:
  "atom_com c \<Longrightarrow> uses_all_pres' c"
by induct auto

primrec com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op" where
  "com (c, q) = c"

primrec post :: "'a ann_triple_op \<Rightarrow> 'a assn" where
  "post (c, q) = q"

definition interfree_aux :: "'a assn \<Rightarrow> ('a ann_com_op \<times> 'a assn \<times> 'a ann_com_op) \<Rightarrow> bool" where
  "interfree_aux \<equiv> \<lambda>I (co, q, co'). co'= None \<or>
                    (\<forall>(r,a) \<in> atomics (the co'). \<parallel>= (q \<inter> r \<inter> I) a (q \<union> -I) \<and>
                    (co = None \<or> (\<forall>p \<in> assertions (the co). \<parallel>= (p \<inter> r \<inter> I) a (p \<union> -I))))"

definition interfree :: "'a assn \<Rightarrow> (('a ann_triple_op) list) \<Rightarrow> bool" where
  "interfree I Ts \<equiv> \<forall>i j. i < length Ts \<and> j < length Ts \<and> i \<noteq> j \<longrightarrow>
                           interfree_aux I (com (Ts!i), post (Ts!i), com (Ts!j))"

inductive
  oghoare :: "'a assn \<Rightarrow> 'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool"  ("(4 _ \<parallel>- _//_//_)" [55,90,55,90] 50)
  and ann_hoare :: "'a assn \<Rightarrow> 'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool"  ("(3 _ \<turnstile> _// _)" [55,60,90] 45)
where
  AnnBasic: "r \<inter> I \<subseteq> {s. f s \<subseteq> q \<union> - I} \<Longrightarrow> I \<turnstile> (AnnBasic (_, r) f) q"

| AnnSeq:   "\<lbrakk> I \<turnstile> c0 pre c1; I \<turnstile> c1 q \<rbrakk> \<Longrightarrow> I \<turnstile> (AnnSeq c0 c1) q"

| AnnCond1: "\<lbrakk> r \<inter> b \<inter> I \<subseteq> pre c1; I \<turnstile> c1 q; r \<inter> -b \<inter> I \<subseteq> pre c2; I \<turnstile> c2 q\<rbrakk>
              \<Longrightarrow> I \<turnstile> (AnnCond1 (_, r) b c1 c2) q"
| AnnCond2: "\<lbrakk> r \<inter> b \<inter> I \<subseteq> pre c; I \<turnstile> c q; r \<inter> -b \<inter> I \<subseteq> q \<rbrakk> \<Longrightarrow> I \<turnstile> (AnnCond2 (_, r) b c) q"

| AnnWhile: "\<lbrakk> r \<inter> I \<subseteq> i; i \<inter> b \<inter> I \<subseteq> pre c; I \<turnstile> c i; i \<inter> -b \<inter> I \<subseteq> q \<rbrakk>
              \<Longrightarrow> I \<turnstile> (AnnWhile (_, r) b (_, i) c) q"

| AnnAwait:  "\<lbrakk> atom_com c; UNIV \<parallel>- (r \<inter> b \<inter> I) c (q \<union> -I) \<rbrakk> \<Longrightarrow> I \<turnstile> (AnnAwait (_, r) b c) q"

| AnnConseq: "\<lbrakk>I \<turnstile> c q; q \<subseteq> q' \<rbrakk> \<Longrightarrow> I \<turnstile> c q'"

| Parallel: "\<lbrakk> \<forall>i<length Ts. \<exists>c q. Ts!i = (Some c, q) \<and> I \<turnstile> c q; interfree I Ts \<rbrakk>
           \<Longrightarrow> I \<parallel>- ((\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i)))) \<union> -I)
                       Parallel Ts
                    (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"

| Basic:   "I \<parallel>- {s. f s \<subseteq> q} (Basic f) q"

| Seq:    "\<lbrakk> I \<parallel>- p c1 r; I \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> I \<parallel>- p (Seq c1 c2) q "

| Cond:   "\<lbrakk> I \<parallel>- (p \<inter> b) c1 q; I \<parallel>- (p \<inter> -b) c2 q \<rbrakk> \<Longrightarrow> I \<parallel>- p (Cond b c1 c2) q"

| While:  "\<lbrakk> I \<parallel>- (p \<inter> b) c p \<rbrakk> \<Longrightarrow> I \<parallel>- p (While b i c) (p \<inter> -b)"

| Conseq: "\<lbrakk> p' \<subseteq> p; I \<parallel>- p c q ; q \<subseteq> q' \<rbrakk> \<Longrightarrow> I \<parallel>- p' c q'"

abbreviation
  oghoare' :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool"  ("(3 \<parallel>- _//_//_)" [90,55,90] 50)
where
  "\<parallel>- p c q \<equiv> UNIV \<parallel>- p c q"

abbreviation
  ann_hoare' :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool"  ("(2\<turnstile> _// _)" [60,90] 45)
where
  "\<turnstile> c q \<equiv> UNIV \<turnstile> c q"

section \<open>Soundness\<close>
(* In the version Isabelle-10-Sep-1999: HOL: The THEN and ELSE
parts of conditional expressions (if P then x else y) are no longer
simplified.  (This allows the simplifier to unfold recursive
functional programs.)  To restore the old behaviour, we declare
@{text "lemmas [cong del] = if_weak_cong"}. *)

lemmas [cong del] = if_weak_cong

lemmas ann_hoare_induct = oghoare_ann_hoare.induct [THEN conjunct2]
lemmas oghoare_induct = oghoare_ann_hoare.induct [THEN conjunct1]

lemmas AnnBasic = oghoare_ann_hoare.AnnBasic
lemmas AnnSeq = oghoare_ann_hoare.AnnSeq
lemmas AnnCond1 = oghoare_ann_hoare.AnnCond1
lemmas AnnCond2 = oghoare_ann_hoare.AnnCond2
lemmas AnnWhile = oghoare_ann_hoare.AnnWhile
lemmas AnnAwait = oghoare_ann_hoare.AnnAwait
lemmas AnnConseq = oghoare_ann_hoare.AnnConseq

lemmas Parallel = oghoare_ann_hoare.Parallel
lemmas Basic = oghoare_ann_hoare.Basic
lemmas Seq = oghoare_ann_hoare.Seq
lemmas Cond = oghoare_ann_hoare.Cond
lemmas While = oghoare_ann_hoare.While
lemmas Conseq = oghoare_ann_hoare.Conseq

subsection \<open>Soundness of the System for Atomic Programs\<close>

lemma Basic_ntran [rule_format]:
 "(Basic f, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow> t \<in> f s"
apply(induct "n")
 apply(simp (no_asm))
apply(fast dest: relpow_Suc_D2 Parallel_empty_lemma elim: transition_cases)
done

lemma SEM_fwhile: "SEM S (p \<inter> b) \<subseteq> p \<Longrightarrow> SEM (fwhile b S k) p \<subseteq> (p \<inter> -b)"
apply (induct "k")
 apply(simp (no_asm) add: L3_5v_lemma3)
apply(simp (no_asm) add: L3_5iv L3_5ii Parallel_empty)
apply(rule conjI)
 apply (blast dest: L3_5i)
apply(simp add: SEM_def sem_def id_def)
apply (auto dest: Basic_ntran rtrancl_imp_UN_relpow)
apply blast
done

lemma atom_hoare_sound [rule_format]:
 "I \<parallel>- p c q \<longrightarrow> atom_com(c) \<longrightarrow> I = UNIV \<longrightarrow> \<parallel>= p c q"
apply (unfold com_validity_def)
apply(rule oghoare_induct)
apply simp_all
\<comment>\<open>Basic\<close>
    apply(simp add: SEM_def sem_def)
    apply(fast dest: rtrancl_imp_UN_relpow Basic_ntran)
\<comment>\<open>Seq\<close>
   apply(intro impI)
   apply(rule subset_trans)
    prefer 2 apply simp
   apply(simp add: L3_5ii L3_5i)
\<comment>\<open>Cond\<close>
  apply(simp add: L3_5iv)
\<comment>\<open>While\<close>
 apply (force simp add: L3_5v dest: SEM_fwhile)
\<comment>\<open>Conseq\<close>
apply(force simp add: SEM_def sem_def)
done

subsection \<open>Soundness of the System for Component Programs\<close>

inductive_cases ann_transition_cases:
    "(None,s) -1\<rightarrow> (c', s')"
    "(Some (AnnBasic r f),s) -1\<rightarrow> (c', s')"
    "(Some (AnnSeq c1 c2), s) -1\<rightarrow> (c', s')"
    "(Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (c', s')"
    "(Some (AnnCond2 r b c), s) -1\<rightarrow> (c', s')"
    "(Some (AnnWhile r b I c), s) -1\<rightarrow> (c', s')"
    "(Some (AnnAwait r b c),s) -1\<rightarrow> (c', s')"

text \<open>Strong Soundness for Component Programs:\<close>

lemma ann_hoare_case_analysis [rule_format]: "I \<turnstile> C q' \<longrightarrow>
  ((\<forall>x r f. C = AnnBasic (x, r) f \<longrightarrow> (\<exists>q. r \<inter> I \<subseteq> {s. f s \<subseteq> q \<union> -I } \<and> q \<inter> I \<subseteq> q')) \<and>
  (\<forall>c0 c1. C = AnnSeq c0 c1 \<longrightarrow> (\<exists>q. q \<inter> I \<subseteq> q' \<and> I \<turnstile> c0 pre c1 \<and> I \<turnstile> c1 q)) \<and>
  (\<forall>x r b c1 c2. C = AnnCond1 (x, r) b c1 c2 \<longrightarrow> (\<exists>q. q \<inter> I \<subseteq> q' \<and>
  r \<inter> b \<inter> I \<subseteq> pre c1 \<and> I \<turnstile> c1 q \<and> r \<inter> -b \<inter> I \<subseteq> pre c2 \<and> I \<turnstile> c2 q)) \<and>
  (\<forall>x r b c. C = AnnCond2 (x, r) b c \<longrightarrow>
  (\<exists>q. q \<inter> I \<subseteq> q' \<and> r \<inter> b \<inter> I \<subseteq> pre c  \<and> I \<turnstile> c q \<and> r \<inter> -b \<inter> I \<subseteq> q)) \<and>
  (\<forall>x r b y i c. C = AnnWhile (x, r) b (y, i) c \<longrightarrow>
  (\<exists>q. q \<inter> I \<subseteq> q' \<and> r \<inter> I \<subseteq> i \<and> i \<inter> b \<inter> I \<subseteq> pre c \<and> I \<turnstile> c i \<and> i \<inter> -b \<inter> I \<subseteq> q)) \<and>
  (\<forall>x r b c. C = AnnAwait (x, r) b c \<longrightarrow> (\<exists>q. q \<inter> I \<subseteq> q' \<and> \<parallel>- (r \<inter> b \<inter> I) c (q \<union> -I))))"
apply(rule ann_hoare_induct)
apply simp_all
 apply(rule_tac x=q in exI,simp)+
apply(rule conjI,clarify,simp,clarify,rule_tac x=qa in exI,fast)+
apply(clarify,simp,clarify,rule_tac x=qa in exI,fast)
done

lemma Help: "(transition \<inter> {(x,y). True}) = (transition)"
apply force
done

lemma Strong_Soundness_aux_aux [rule_format]:
 "(co, s) -1\<rightarrow> (co', t) \<longrightarrow> (\<forall>c. co = Some c \<longrightarrow> s\<in> pre c \<longrightarrow>
 (\<forall>q. \<turnstile> c q \<longrightarrow> (if co' = None then t\<in>q else t \<in> pre(the co') \<and> \<turnstile> (the co') q )))"
apply(rule ann_transition_transition.induct [THEN conjunct1])
apply simp_all
\<comment>\<open>Basic\<close>
         apply clarify
         apply(frule ann_hoare_case_analysis)
         apply force
\<comment>\<open>Seq\<close>
        apply clarify
        apply(frule ann_hoare_case_analysis,simp)
        apply(fast intro: AnnConseq)
       apply clarify
       apply(frule ann_hoare_case_analysis,simp)
       apply clarify
       apply(rule conjI)
        apply force
       apply(rule AnnSeq,simp)
       apply(fast intro: AnnConseq)
\<comment>\<open>Cond1\<close>
      apply clarify
      apply(frule ann_hoare_case_analysis,simp)
      apply(fast intro: AnnConseq)
     apply clarify
     apply(frule ann_hoare_case_analysis,simp)
     apply(fast intro: AnnConseq)
\<comment>\<open>Cond2\<close>
    apply clarify
    apply(frule ann_hoare_case_analysis,simp)
    apply(fast intro: AnnConseq)
   apply clarify
   apply(frule ann_hoare_case_analysis,simp)
   apply(fast intro: AnnConseq)
\<comment>\<open>While\<close>
  apply clarify
  apply(frule ann_hoare_case_analysis,simp)
  apply force
 apply clarify
 apply(frule ann_hoare_case_analysis,simp)
 apply auto
 apply(rule AnnSeq)
  apply simp
 apply(rule AnnWhile, simp_all)[1]
\<comment>\<open>Await\<close>
apply(frule ann_hoare_case_analysis,simp)
apply clarify
apply(drule atom_hoare_sound)
  apply simp
 apply simp
apply(simp add: com_validity_def SEM_def sem_def)
apply(simp add: Help All_None_def)
apply force
done

lemma Strong_Soundness_aux: "\<lbrakk> (Some c, s) -*\<rightarrow> (co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
  \<Longrightarrow> if co = None then t \<in> q else t \<in> pre (the co) \<and> \<turnstile> (the co) q"
apply(erule rtrancl_induct2)
 apply simp
apply(case_tac "a")
 apply(fast elim: ann_transition_cases)
apply(erule Strong_Soundness_aux_aux)
 apply simp
apply simp_all
done

lemma Strong_Soundness: "\<lbrakk> (Some c, s)-*\<rightarrow>(co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
  \<Longrightarrow> if co = None then t\<in>q else t \<in> pre (the co)"
apply(force dest:Strong_Soundness_aux)
done

lemma ann_hoare_sound: "\<turnstile> c q  \<Longrightarrow> \<Turnstile> c q"
apply (unfold ann_com_validity_def ann_SEM_def ann_sem_def)
apply clarify
apply(drule Strong_Soundness)
apply simp_all
done

subsection \<open>Soundness of the System for Parallel Programs\<close>

lemma Parallel_length_post_P1: "(Parallel Ts,s) -P1\<rightarrow> (R', t) \<Longrightarrow>
  (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
  (\<forall>i. i<length Ts \<longrightarrow> post(Rs ! i) = post(Ts ! i)))"
apply(erule transition_cases)
apply simp
apply clarify
apply(case_tac "i=ia")
apply simp+
done

lemma Parallel_length_post_PStar: "(Parallel Ts,s) -P*\<rightarrow> (R',t) \<Longrightarrow>
  (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
  (\<forall>i. i<length Ts \<longrightarrow> post(Ts ! i) = post(Rs ! i)))"
apply(erule rtrancl_induct2)
 apply(simp_all)
apply clarify
apply simp
apply(drule Parallel_length_post_P1)
apply auto
done

lemma assertions_lemma: "uses_pre c \<Longrightarrow> pre c \<in> assertions c"
apply(induct rule: ann_com_com.induct [THEN conjunct1])
apply auto
done

lemma interfree_aux1 [rule_format]:
  "(c,s) -1\<rightarrow> (r,t)  \<longrightarrow> (interfree_aux I (c1, q1, c) \<longrightarrow> interfree_aux I (c1, q1, r))"
apply (rule ann_transition_transition.induct [THEN conjunct1])
apply(safe)
prefer 13
apply (rule TrueI)
apply (simp_all add:interfree_aux_def)
apply force+
done

lemma interfree_aux2 [rule_format]:
  "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux I (c, q, a)  \<longrightarrow> interfree_aux I (r, q, a) )"
apply (rule ann_transition_transition.induct [THEN conjunct1])
apply(force simp add:interfree_aux_def)+
done

lemma interfree_lemma: "\<lbrakk> (Some c, s) -1\<rightarrow> (r, t);interfree I Ts ; i<length Ts;
           Ts!i = (Some c, q) \<rbrakk> \<Longrightarrow> interfree I (Ts[i:= (r, q)])"
apply(simp add: interfree_def)
apply clarify
apply(case_tac "i=j")
 apply(drule_tac t = "ia" in not_sym)
 apply simp_all
apply(force elim: interfree_aux1)
apply(force elim: interfree_aux2 simp add:nth_list_update)
done

text \<open>Strong Soundness Theorem for Parallel Programs:\<close>

lemma Parallel_Strong_Soundness_Seq_aux:
  "\<lbrakk>interfree I Ts; i<length Ts; com(Ts ! i) = Some(AnnSeq c0 c1); uses_pre c1 \<rbrakk>
  \<Longrightarrow>  interfree I (Ts[i:=(Some c0, pre c1)])"
apply(simp add: interfree_def)
apply clarify
apply(case_tac "i=j")
 apply(force simp add: nth_list_update interfree_aux_def)
apply(case_tac "i=ia")
 apply(erule_tac x=ia in allE)
 apply(force simp add:interfree_aux_def assertions_lemma)
apply simp
done

lemma Parallel_Strong_Soundness_Seq [rule_format (no_asm)]:
 "\<lbrakk> \<forall>i<length Ts. (if com(Ts!i) = None then b \<in> post(Ts!i)
  else b \<in> pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i));
  com(Ts ! i) = Some(AnnSeq c0 c1); i<length Ts; interfree I Ts; uses_pre c1 \<rbrakk> \<Longrightarrow>
 (\<forall>ia<length Ts. (if com(Ts[i:=(Some c0, pre c1)]! ia) = None
  then b \<in> post(Ts[i:=(Some c0, pre c1)]! ia)
 else b \<in> pre(the(com(Ts[i:=(Some c0, pre c1)]! ia))) \<and>
 \<turnstile> the(com(Ts[i:=(Some c0, pre c1)]! ia)) post(Ts[i:=(Some c0, pre c1)]! ia)))
  \<and> interfree I (Ts[i:= (Some c0, pre c1)])"
apply(rule conjI)
 apply safe
 apply(case_tac "i=ia")
  apply simp
  apply(force dest: ann_hoare_case_analysis)
 apply simp
apply(fast elim: Parallel_Strong_Soundness_Seq_aux)
done

lemma Parallel_Strong_Soundness_Seq_aux_aux:
 "\<lbrakk>\<forall>x<length Ts.
      (\<exists>y. OG_Hoare.com (Ts ! x) = Some y) \<longrightarrow> uses_all_pres (the (OG_Hoare.com (Ts ! x)));
   i < length Ts; OG_Hoare.com (Ts ! i) = Some (AnnSeq c0 c1)\<rbrakk>
    \<Longrightarrow> \<forall>ia<length Ts.
          (\<exists>y. OG_Hoare.com (Ts[i := (Some c0, pre c1)] ! ia) = Some y) \<longrightarrow>
          uses_all_pres (the (OG_Hoare.com (Ts[i := (Some c0, pre c1)] ! ia)))"
apply clarsimp
apply (erule_tac x=ia in allE)
apply clarsimp
apply (case_tac "i=ia")
 apply simp
apply simp
done

lemma Parallel_Strong_Soundness_aux_aux [rule_format]:
 "(Some c, b) -1\<rightarrow> (co, t) \<longrightarrow>
  (\<forall>Ts. i<length Ts \<longrightarrow> com(Ts ! i) = Some c \<longrightarrow>
  (\<forall>i<length Ts. com(Ts ! i) \<noteq> None \<longrightarrow> uses_all_pres (the (com (Ts ! i)))) \<longrightarrow>
  (\<forall>i<length Ts. (if com(Ts ! i) = None then b\<in>post(Ts!i)
  else b\<in>pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i))) \<longrightarrow>
 interfree UNIV Ts \<longrightarrow>
  (\<forall>j. j<length Ts \<and> i\<noteq>j \<longrightarrow>
  (if com(Ts!j) = None then t\<in>post(Ts!j)
   else t\<in>pre(the(com(Ts!j))) \<and> \<turnstile> the(com(Ts!j)) post(Ts!j))))"
apply(rule ann_transition_transition.induct [THEN conjunct1])
apply safe
prefer 11
apply(rule TrueI)
apply simp_all
\<comment>\<open>Basic\<close>
   apply(erule_tac x = "i" in all_dupE, erule (1) notE impE)
   apply(erule_tac x = "i" in all_dupE, erule (1) notE impE)
   apply(erule_tac x = "j" in allE , erule (1) notE impE)
   apply(erule_tac x = "j" in allE , erule (1) notE impE)
   apply(simp add: interfree_def)
   apply(erule_tac x = "j" in allE,simp)
   apply(erule_tac x = "i" in allE,simp)
   apply(drule_tac t = "i" in not_sym)
   apply(case_tac "com(Ts ! j)=None")
    apply(force intro: converse_rtrancl_into_rtrancl
          simp add: interfree_aux_def com_validity_def SEM_def sem_def All_None_def)[1]
   apply(simp add:interfree_aux_def)
   apply clarify
   apply simp
   apply(erule_tac x="pre y" in ballE)
    apply(force intro: converse_rtrancl_into_rtrancl
          simp add: com_validity_def SEM_def sem_def All_None_def)
   apply(clarsimp simp:assertions_lemma)
\<comment>\<open>Seqs\<close>
  apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
  apply(erule_tac x = "i" in all_dupE)
  apply (drule  Parallel_Strong_Soundness_Seq,simp+)
  apply (erule impE)
   apply (erule  Parallel_Strong_Soundness_Seq_aux_aux,simp+)
 apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
 apply(erule_tac x = "i" in all_dupE)
 apply(drule  Parallel_Strong_Soundness_Seq,simp+)
 apply (erule impE)
  apply (erule  Parallel_Strong_Soundness_Seq_aux_aux,simp+)

\<comment>\<open>Await\<close>
apply(erule_tac x=i in all_dupE)
apply(rule_tac x = "i" in allE , assumption , erule (1) notE impE)
apply(erule_tac x = "j" in allE , erule (1) notE impE)
apply(simp add: interfree_def)
apply(erule_tac x = "j" in allE,simp)
apply(erule_tac x = "j" in allE,simp)
apply(erule_tac x = "i" in allE,simp)
apply(drule_tac t = "i" in not_sym)
apply(case_tac "com(Ts ! j)=None")
 apply(force intro: converse_rtrancl_into_rtrancl simp add: interfree_aux_def
        com_validity_def SEM_def sem_def All_None_def Help)
apply(simp add:interfree_aux_def)
apply clarify
apply simp
apply(erule_tac x="pre y" in ballE)
 apply(force intro: converse_rtrancl_into_rtrancl
       simp add: com_validity_def SEM_def sem_def All_None_def Help)
apply(clarsimp simp:assertions_lemma)
done

lemma uses_all_pres_ann_transition[rule_format]:
  "(co, s) -1\<rightarrow> (co', t) \<longrightarrow> co \<noteq> None \<longrightarrow> uses_all_pres (the co) \<longrightarrow> co' \<noteq> None \<longrightarrow> uses_all_pres (the (co'))"
apply (induct rule: ann_transition_transition.induct[THEN conjunct1])
apply auto
done

lemma Parallel_uses_all_pres_P1:
  "\<lbrakk>(Parallel Ts,s) -P1\<rightarrow> (R', t);
    \<forall>i<length Ts. com(Ts ! i) \<noteq> None \<longrightarrow> uses_all_pres (the(com(Ts ! i)))\<rbrakk>
   \<Longrightarrow> \<exists>Rs. R' = (Parallel Rs) \<and>
         (\<forall>i<length Rs. com(Rs ! i) \<noteq> None \<longrightarrow> uses_all_pres (the(com(Rs ! i))))"
apply(erule transition_cases)
apply simp
apply clarify
apply(case_tac "i=ia")
apply (drule uses_all_pres_ann_transition)
apply auto
done

lemma Parallel_uses_all_pres_PStar:
  "\<lbrakk>(Parallel Ts,s) -P*\<rightarrow> (R',t);
    \<forall>i<length Ts. com(Ts ! i) \<noteq> None \<longrightarrow> uses_all_pres (the(com(Ts ! i)))\<rbrakk>
   \<Longrightarrow> \<exists>Rs. R' = (Parallel Rs) \<and>
         (\<forall>i<length Rs. com(Rs ! i) \<noteq> None \<longrightarrow> uses_all_pres (the(com(Rs ! i))))"
apply(erule rtrancl_induct2)
 apply(simp_all)
apply clarify
apply simp
apply(drule Parallel_uses_all_pres_P1, clarsimp)
apply clarsimp
done

lemma Parallel_Strong_Soundness_aux [rule_format]:
 "\<lbrakk>(Ts',s) -P*\<rightarrow> (Rs',t);  Ts' = (Parallel Ts); interfree UNIV Ts;
 \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. (Ts ! i) = (Some c, q) \<and> s\<in>(pre c) \<and> \<turnstile> c q \<and> uses_all_pres c) \<rbrakk> \<Longrightarrow>
  \<forall>Rs. Rs' = (Parallel Rs) \<longrightarrow>
  (\<forall>j. j<length Rs \<longrightarrow>
  (if com(Rs ! j) = None then t\<in>post(Ts ! j)
  else t\<in>pre(the(com(Rs ! j))) \<and> \<turnstile> the(com(Rs ! j)) post(Ts ! j))) \<and> interfree UNIV Rs"
apply(erule rtrancl_induct2)
 apply clarify
\<comment>\<open>Base\<close>
 apply force
\<comment>\<open>Induction step\<close>
apply clarify
apply(frule Parallel_length_post_PStar)
apply(drule Parallel_uses_all_pres_PStar)
 apply force
apply clarify
apply (ind_cases "(Parallel Ts, s) -P1\<rightarrow> (Parallel Rs, t)" for Ts s Rs t)
apply(rule conjI)
 apply clarify
 apply(case_tac "i=j")
  apply(simp split del:if_split)
  apply(erule Strong_Soundness_aux_aux,simp+)
   apply force
  apply force
 apply(clarsimp split del: if_split)
 apply(erule Parallel_Strong_Soundness_aux_aux)
 apply(simp_all add: split del: if_split)
  apply force
apply(rule interfree_lemma)
apply simp_all
done

lemma Parallel_Strong_Soundness:
 "\<lbrakk>(Parallel Ts, s) -P*\<rightarrow> (Parallel Rs, t); interfree UNIV Ts; j<length Rs;
  \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. Ts ! i = (Some c, q) \<and> s\<in>pre c \<and> \<turnstile> c q \<and> uses_all_pres c) \<rbrakk> \<Longrightarrow>
  if com(Rs ! j) = None then t\<in>post(Ts ! j) else t\<in>pre (the(com(Rs ! j)))"
apply(drule  Parallel_Strong_Soundness_aux)
apply auto
done

lemma oghoare_sound [rule_format]: "(I \<parallel>- p c q \<longrightarrow> uses_all_pres' c  \<longrightarrow> I = UNIV \<longrightarrow> \<parallel>= p c q)"
apply (unfold com_validity_def)
apply (induct rule: oghoare_induct)
apply(rule TrueI)+
\<comment>\<open>Parallel\<close>
      apply(simp add: SEM_def sem_def)
      apply(clarify, rename_tac x y i Ts')
      apply(frule Parallel_length_post_PStar)
      apply clarify
      apply(drule_tac j=i in Parallel_Strong_Soundness)
         apply simp
        apply simp
       apply clarsimp
       apply ((drule_tac x=ia in spec, clarsimp)+)[1]
      apply simp
      apply(erule_tac V = "\<forall>i. P i" for P in thin_rl)
      apply(drule_tac s = "length Rs" in sym)
      apply(erule allE, erule impE, assumption)
      apply(force dest: nth_mem simp add: All_None_def)
\<comment>\<open>Basic\<close>
    apply(simp add: SEM_def sem_def)
    apply(force dest: rtrancl_imp_UN_relpow Basic_ntran)
\<comment>\<open>Seq\<close>
   apply (intro impI)
   apply(rule subset_trans)
    prefer 2 apply simp
   apply(simp add: L3_5ii L3_5i)
\<comment>\<open>Cond\<close>
   apply (rule impI)
  apply(simp add: L3_5iv L3_5i Int_commute)[1]
\<comment>\<open>While\<close>
 apply(simp add: L3_5v)
 apply (blast dest: SEM_fwhile)
\<comment>\<open>Conseq\<close>
 apply (intro impI)
 apply simp
apply(auto simp add: SEM_def sem_def)
done

end


section {*lists\_length*}
theory
  lists_length

imports
  lists_set

begin

lemma drop_length_append: "
  length f \<le> length (f @ c)"
  apply(force)
  done

lemma length_diff: "
  k - length w>0
  \<Longrightarrow> length w \<le> k"
  apply(force)
  done

lemma length_shorter_append2: "
  w @ v = r
  \<Longrightarrow> length r \<le> length v
  \<Longrightarrow> w = []"
  apply(force)
  done

lemma foldl_emptyX: "
  (\<And>i. i < length w \<Longrightarrow> w!i = [])
  \<Longrightarrow> foldl (@) [] w = []"
  apply(induct w)
   apply(clarsimp)
  apply(rename_tac a w)(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "a = []")
   apply(rename_tac a w)(*strict*)
   prefer 2
   apply(erule_tac
      x = "0"
      in meta_allE)
   apply(clarsimp)
  apply(rename_tac a w)(*strict*)
  apply(clarsimp)
  apply(rename_tac w)(*strict*)
  apply(subgoal_tac "(\<And>i. i < length w \<Longrightarrow> w ! i = [])")
   apply(rename_tac w)(*strict*)
   apply(force)
  apply(rename_tac w i)(*strict*)
  apply(erule_tac
      x = "Suc i"
      in meta_allE)
  apply(clarsimp)
  done

lemma border_right_by_length: "
  length w = length v
  \<Longrightarrow> a@w = b@v
  \<Longrightarrow> w = v"
  apply(rule_tac
      t = "w"
      and s = "drop(length a) (a@w)"
      in ssubst)
   apply(force)
  apply(rule_tac
      t = "v"
      and s = "drop(length b) (b@v)"
      in ssubst)
   apply(force)
  apply(force)
  done

lemma set_subset_drop: "
  length w = length v
  \<Longrightarrow> x@w = y@v
  \<Longrightarrow> set x \<subseteq> set y"
  apply (metis append_same_eq border_right_by_length set_eq_subset)
  done

lemma length_shorter_append: "
  f @ c = w @ [X]
  \<Longrightarrow> length f \<le> Suc (length w)"
  apply (metis drop_length_append length_append_singleton)
  done

lemma append_length_inc: "
  w1 = w2@r
  \<Longrightarrow> length w2 \<le> length w1"
  apply(force)
  done

lemma length_map_Some: "
  length w = length (map Some w)"
  apply(induct w)
   apply(auto)
  done

lemma length_Suc: "
  Suc (length w) = length (w @ [a])"
  apply(force)
  done

lemma NonEmptyListHasTailElem: "
  length w = Suc n
  \<Longrightarrow> \<exists>w' x'. w = w' @ [x']"
  apply(subgoal_tac "\<forall>w. length w = Suc n \<longrightarrow> (\<exists>w' x'. w = w' @ [x'])")
   apply(force)
  apply(thin_tac "length w = Suc n")
  apply(induct_tac n)
   apply(clarsimp)
   apply(rename_tac w)(*strict*)
   apply(case_tac w)
    apply(rename_tac w)(*strict*)
    apply(clarsimp)
   apply(rename_tac w a list)(*strict*)
   apply(clarsimp)
  apply(rename_tac n)(*strict*)
  apply(clarsimp)
  apply(rename_tac n w)(*strict*)
  apply(case_tac w)
   apply(rename_tac n w)(*strict*)
   apply(auto)
  done

lemma lengthNonEmpty: "
  Suc 0 \<le> length ya
  \<Longrightarrow> ya \<noteq> []"
  apply(auto)
  done

lemma lengthNonEmpty2: "
  Suc 0 \<le> length ya
  \<Longrightarrow> (\<exists>y a. ya = y @ [a])"
  apply(rule_tac
      P = "Suc 0 \<le> length ya"
      and Q = "(\<exists>y a. ya = y @ [a])"
      in impE)
    apply(thin_tac "Suc 0 \<le> length ya")
    apply(induct_tac ya)
     apply(simp)
    apply(rename_tac a list)(*strict*)
    defer
    apply(auto)
  apply(rename_tac a list)(*strict*)
  apply(case_tac list)
   apply(rename_tac a list)(*strict*)
   apply(auto)
  done

lemma lengthDec: "
  length (v @ [a]) - length [a] \<le> length v"
  apply(induct v)
   apply(auto)
  done

lemma lengthDec2: "
  length v + Suc 0 = length (v @ [a])"
  apply(induct v)
   apply(auto)
  done

lemma Suc_length: "
  length (y@[a]) = Suc (length y)"
  apply(clarsimp)
  done

lemma length2: "
  length [a,b] = Suc(Suc 0)"
  apply(auto)
  done

lemma NotNil_Length: "
  w \<noteq> []
  \<Longrightarrow> \<exists>n. length w = Suc n"
  apply(case_tac w)
   apply(auto)
  done

lemma lengthSmallerUnderDecomp: "
  a@b = c@d
  \<Longrightarrow>length c \<le> length a + length b"
  apply(rule_tac
      j = "length c + length d"
      in Nat.le_trans)
   apply(simp)
  apply(rule_tac
      s = "length (a@b)"
      in ssubst)
   apply(rule sym)
   apply(rule length_append)
  apply(rule_tac
      s = "length (c@d)"
      in ssubst)
   apply(simp)
  apply(subgoal_tac "length c + length d = length (c@d)")
   apply(simp)
  apply(rule sym)
  apply(rule length_append)
  done

end


theory CSLSemantics imports Main Real Log Ln Taylor -- "the imports taken from Complex_Main"
begin

(* A Remark on deep embeddings:

The key-point is how binders and bound or free variables are represented.

In different papers there are different approaches:

*** Proving the Completeness Theorem within Isabelle/HOL (2004):
Variables are integers, binders use a deBruijn-Index style without mentioning the bound variable
(least variable is bound by a binder, e.g., All (All ((Var 1) = 2*(Var 2))) = !x. !y. y=2*x)

*** Implementing Z in Isabelle (1995):
Z is deeply embedded in a logic based on Isabelle/Pure (not HOL!).

Looks for me rather shallow than deep (apparently Jigsaw is a deeper embedding,
simulating also the substitution machinery, see p.18(371)).

From p.3(356):
"Variable binding is expressed using higher-order abstract syntax.
This enables us to express inference rules involving substitution
for bound variables in such a way that the usual side conditions are automatically respected.
Thus, for instance, the inference rule ForallIntro: P ==> forall x. P
with the side condition that x does not occur free in the assumptions, can be formalized
in Isabelle as:
!! x. Trueprop(P(x)) ==> Trueprop(forall(%x.P(x))) .
"

* A simple setting to reason about

program: "y := x ^ 2"

program-property to prove: "y >= 0"

*)

subsection {* Preliminaries: Functions for term-interpretation  *}

-- "power is only defined for natural number exponents"
definition
  realpow :: "real => real => real" where
 "realpow x y == x^natfloor(y)"

-- "list variants of binary min and max. Works only on non-empty argument lists."
definition
  nMin :: "real list => real" where
 "nMin l == foldl min (hd l) l"
definition
  nMax :: "real list => real" where
 "nMax l == foldl max (hd l) l"

subsection {* State, Terms, Programs *}

types State = "int => real"

datatype CSLnullary = Cpi
datatype CSLunary = Cuminus | Csign | Cabs | Csqrt | Cfthrt | Ccos | Csin | Ctan
datatype CSLbinary = Cplus | Cminus | Ctimes | Cdivide | Cpower
datatype CSLnary = Cmin | Cmax

datatype CSLbinaryP = Cle | Clt | Cge | Cgt | Cneq | Ceq | Cconvergence

datatype Term = Const int | Num real | Fun0 CSLnullary
  | Fun1 CSLunary Term | Fun2 CSLbinary Term Term | FunN CSLnary "Term list"

datatype Boolterm = Ctrue | Cfalse | Pred2 CSLbinaryP Term Term
  | Conj Boolterm Boolterm (infixl "&&" 35) | Disj Boolterm Boolterm (infixl "||" 30) | Neg Boolterm

datatype Command = Assign int Term (infix ":=" 30) | Seq Command Command
  | IfCond Boolterm Command Command | Repeat Boolterm Command

(*
ML {* Display.print_syntax (the_context()) *}

*)

constdefs true :: bool
  "true == True"
  false :: bool
  "false == False"

nonterminals
  semiargs glyx

syntax
  "_semiargs2" :: "['a, 'a] => semiargs"             ("_;/ _" [10, 10] 9)
  "_semiargs" :: "['a, semiargs] => semiargs"        ("_;/ _" [10, 9] 9)

  "_cslle" :: "[glyx, glyx]\<Rightarrow>glyx" (infix "<=" 50)
  "_csllt" :: "[glyx, glyx]\<Rightarrow>glyx" (infix "<" 50)
  "_cslge" :: "[glyx, glyx]\<Rightarrow>glyx" (infix ">=" 50)
  "_cslgt" :: "[glyx, glyx]\<Rightarrow>glyx" (infix ">" 50)
  "_csleq" :: "[glyx, glyx]\<Rightarrow>glyx" (infix "=" 50)
  "_cslneq" :: "[glyx, glyx]\<Rightarrow>glyx" (infix "~=" 50)

  "_cslplus" :: "[glyx, glyx]\<Rightarrow>glyx" (infixl "+" 65)
  "_cslminus" :: "[glyx, glyx]\<Rightarrow>glyx" (infixl "-" 65)
  "_csltimes" :: "[glyx, glyx]\<Rightarrow>glyx" (infixl "*" 70)
  "_csldivide" :: "[glyx, glyx]\<Rightarrow>glyx" (infixl "'/" 70)
  "_cslpower" :: "[glyx, glyx]\<Rightarrow>glyx" (infixl "^" 75)

  "_csluminus" :: "glyx\<Rightarrow>glyx"     ("(- _)" [81] 80)

  "_isatrue" :: "'a"             ("True" 1000)
  "_isafalse" :: "'a"            ("False" 1000)
  "_csltrue" :: "glyx"             ("True" 1000)
  "_cslfalse" :: "glyx"            ("False" 1000)
  "_cslneg" :: "glyx\<Rightarrow>glyx"        ("(~_)" [40] 40)

  "" :: "glyx \<Rightarrow> 'a" ("_") -- "We need this for glyx to be valid terms"
  "" :: "'a \<Rightarrow> glyx" ("_")
(*
  "_cslle" :: "['a, 'a]\<Rightarrow>'a" (infix "<<=" 50)
  "_csllt" :: "['a, 'a]\<Rightarrow>'a" (infix "<<" 50)
  "_cslge" :: "['a, 'a]\<Rightarrow>'a" (infix ">>=" 50)
  "_cslgt" :: "['a, 'a]\<Rightarrow>'a" (infix ">>" 50)
  "_csleq" :: "['a, 'a]\<Rightarrow>'a" (infix "===" 50)
  "_cslneq" :: "['a, 'a]\<Rightarrow>'a" (infix "~==" 50)

  "_cslplus" :: "['a, 'a]\<Rightarrow>'a" (infixl "+++" 65)
  "_cslminus" :: "['a, 'a]\<Rightarrow>'a" (infixl "--" 65)
  "_csltimes" :: "['a, 'a]\<Rightarrow>'a" (infixl "**" 70)
  "_csldivide" :: "['a, 'a]\<Rightarrow>'a" (infixl "'/'/'/" 70)
  "_cslpower" :: "['a, 'a]\<Rightarrow>'a" (infixl "^^" 75)

  "_csluminus" :: "'a\<Rightarrow>'a"     ("(-- _)" [81] 80)
*)

  "_cslpi" :: "'a"             ("Pi" 999)
  "_cslsign" :: "'a\<Rightarrow>'a"       ("(sign'(_'))" 999)
  "_cslabs" :: "'a\<Rightarrow>'a"        ("(abs'(_'))" 999)
  "_cslsqrt" :: "'a\<Rightarrow>'a"       ("(sqrt'(_'))" 999)
  "_cslfthrt" :: "'a\<Rightarrow>'a"      ("(fthrt'(_'))" 999)
  "_cslsin" :: "'a\<Rightarrow>'a"        ("(sin'(_'))" 999)
  "_cslcos" :: "'a\<Rightarrow>'a"        ("(cos'(_'))" 999)
  "_csltan" :: "'a\<Rightarrow>'a"        ("(tan'(_'))" 999)

  "_cslconv" :: "['a, 'a]\<Rightarrow>'a" ("(convergence'(_, _'))" 999)

  "_cslmin" :: "args\<Rightarrow>'a"      ("(min'(_'))" 999)
  "_cslmax" :: "args\<Rightarrow>'a"      ("(max'(_'))" 999)

  "" :: "semiargs \<Rightarrow> 'a" ("_") -- "We need this for a sequence to be a logical"

  -- "We need to write the rule for repeat here because the arguments are switched"
  "_cslrepeat" :: "['a, 'a]\<Rightarrow>'a"              ("(repeat _ until _)" [9, 20] 10)

translations

(*
  "_cslle x y"              == "Pred2 Cle x y"
  "_csllt x y"              == "Pred2 Clt x y"
  "_cslge x y"              == "Pred2 Cge x y"
  "_cslgt x y"              == "Pred2 Cgt x y"
  "_csleq x y"              == "Pred2 Ceq x y"
  "_cslneq x y"             == "Pred2 Cneq x y"

  "_cslplus x y"            == "Fun2 Cplus x y"
  "_cslminus x y"           == "Fun2 Cminus x y"
  "_csltimes x y"           == "Fun2 Ctimes x y"
  "_csldivide x y"          == "Fun2 Cdivide x y"
  "_cslpower x y"           == "Fun2 Cpower x y"

  "_csluminus x"            == "Fun1 Cuminus x"
*)
  "_cslle x y"              == "Pred2 Cle x y"
  "_csllt x y"              == "Pred2 Clt x y"
  "_cslge x y"              == "Pred2 Cge x y"
  "_cslgt x y"              == "Pred2 Cgt x y"
  "_csleq x y"              == "Pred2 Ceq x y"
  "_cslneq x y"             == "Pred2 Cneq x y"

  "_cslplus x y"            == "Fun2 Cplus x y"
  "_cslminus x y"           == "Fun2 Cminus x y"
  "_csltimes x y"           == "Fun2 Ctimes x y"
  "_csldivide x y"          == "Fun2 Cdivide x y"
  "_cslpower x y"           == "Fun2 Cpower x y"

  "_csluminus x"            == "Fun1 Cuminus x"

  "sign(x)"                 == "Fun1 Csign x"
  "abs(x)"                  == "Fun1 Cabs x"
  "sqrt(x)"                 == "Fun1 Csqrt x"
  "fthrt(x)"                == "Fun1 Cfthrt x"
  "sin(x)"                  == "Fun1 Csin x"
  "cos(x)"                  == "Fun1 Ccos x"
  "tan(x)"                  == "Fun1 Ctan x"

  "min(x)"                  == "FunN Cmin [x]"
  "min(x,xs)"               == "FunN Cmin (concat x xs)"
  "max(x)"                  == "FunN Cmax [x]"
  "max(x,xs)"               == "FunN Cmax (concat x xs)"

  "Pi"                      == "Fun0 Cpi"
  "_isatrue"                == "true"
  "_isafalse"               == "false"
  "_csltrue"                == "Ctrue"
  "_cslfalse"               == "Cfalse"
  "_cslneg x"               == "Neg x"
  "_Numeral x"              == "Num x"

  "_cslrepeat b u" == "Repeat u b"
  "_semiargs2 x y" == "Seq x y"
  "_semiargs x y" == "Seq x y"

term "!x. f(FF && (TT && (FF || - abs(x + x / Pi) <= (Pi+ Pi + max(Pi)))))"

(*
term "!x. f(FF && (TT && (FF || -- abs(x+++ x /// Pi) <<= (Pi+++ Pi +++ max(Pi)))))"
*)

term "x:=a;x:=a"
term "x:=a;x:=a;x:=a"
term "x:=a;x:=a;x:=a;x:=a"
(*
term "x:=a; repeat y:=c;z:=c until Const x >> Pi; x:=a"
term "x:=a; repeat y:=c;z:=c until Const x >> Pi; repeat y:=c;repeat y:=c;z:=c until Const x >> Pi until Const x >> Pi"

ML {* Display.print_syntax (the_context()) *}
*)
term "(x::Term)<u"
term "(x::real) < b"

term "x:=a;x:=a"
term "x:=a;x:=a;x:=a"
term "x:=a;x:=a;x:=a;x:=a"
term "x:=a; repeat y:=c;z:=c until Const x > Pi; x:=a"
term "x:=a; repeat y:=c;z:=c until Const x > Pi; repeat y:=c;repeat y:=c;z:=c until Const x > Pi until Const x > Pi"

fun iFun0 :: "CSLnullary => real" where
"iFun0 Cpi = pi"

fun iFun1 :: "CSLunary => (real => real)" where
"iFun1 Cuminus = uminus" |
"iFun1 Csign = sgn" |
"iFun1 Cabs = abs" |
"iFun1 Csqrt = sqrt" |
"iFun1 Cfthrt = sqrt o sqrt" |
"iFun1 Ccos = cos" |
"iFun1 Csin = sin" |
"iFun1 Ctan = tan"

fun iFun2 :: "CSLbinary => (real => real => real)" where
"iFun2 Cplus = plus" |
"iFun2 Cminus = minus" |
"iFun2 Ctimes = times" |
"iFun2 Cdivide = divide" |
"iFun2 Cpower = realpow"

fun iFunN :: "CSLnary => (real list => real)" where
"iFunN Cmin = nMin" |
"iFunN Cmax = nMax"

fun iPred2 :: "CSLbinaryP => (real => real => bool)" where
"iPred2 Cle = less_eq" |
"iPred2  Clt =  less" |
"iPred2  Cge =  op >=" |
"iPred2  Cgt =  op >" |
"iPred2  Cneq =  op ~=" |
"iPred2  Ceq = op ="

(*
ML {* Display.print_syntax (the_context()) *}
*)

ML {* @{term "!y::real. x <= y"} *}
fun iTerm :: "State => Term => real" where
"iTerm s (Const i) = s i" |
"iTerm s (Num r) = r" |
"iTerm s (Fun0 c) = iFun0 c" |
"iTerm s (Fun1 c t) = iFun1 c (iTerm s t)" |
"iTerm s (Fun2 c t u) = iFun2 c (iTerm s t) (iTerm s u)" |
"iTerm s (FunN c l) = iFunN c (map (iTerm s) l)"

-- "Because the convergence predicate depends on a before- and after-state we need to pass two states to this function"
-- "The second state is always the current state"
fun iBoolterm :: "State => State => Boolterm => bool" where
"iBoolterm s s' Ctrue = True" |
"iBoolterm s s' Cfalse = False" |
"iBoolterm s s' (Pred2 Cconvergence t u) =
  (let tBefore = iTerm s t;
       tAfter = iTerm s' t;
       uVal = iTerm s' u
   in abs (tBefore - tAfter) <= uVal)" |
"iBoolterm s s' (Pred2 c t u) =  iPred2 c (iTerm s' t) (iTerm s' u)" |
"iBoolterm s s' (Conj p q) = (iBoolterm s s' p & iBoolterm s s' q)" |
"iBoolterm s s' (Disj p q) = (iBoolterm s s' p | iBoolterm s s' q)" |
"iBoolterm s s' (Neg p) = Not (iBoolterm s s' p)"

function iCommand :: "State => Command => State" where
"iCommand s (IfCond p c1 c2) = (if iBoolterm s s p then iCommand s c1 else iCommand s c2)" |
"iCommand s (Assign i t) = (%x . if x = i then iTerm s t else s x)" |
"iCommand s (Seq c1 c2) = (let s' = iCommand s c1 in iCommand s' c2)" |
"iCommand s (Repeat p c) = (let s' = iCommand s c in (if iBoolterm s s' p then s' else iCommand s' (Repeat p c)))"
  by pat_completeness auto
(* alternatively
  by (auto, case_tac "b", auto)
*)

subsection {* The Assignment Store *}

fun constsOf :: "Term => int set" where
"constsOf (Num n) = {}" |
"constsOf (Const i) = {i}" |
"constsOf (Fun0 c) = {}" |
"constsOf (Fun1 c t) = constsOf t" |
"constsOf (Fun2 c t u) = constsOf t Un constsOf u" |
"constsOf (FunN c l) = Union (set (map constsOf l))"

types ConstantTermAssignments = "int ~=> Term"

definition
  -- "flat dependency for the given constant when lookuped in the CTA"
  constsOfLookuped :: "ConstantTermAssignments => int => int set" where
 "constsOfLookuped f i == (case f i of
                            Some t => constsOf t |
                            _ => {})"

definition
  -- "flat dependency relation, not transitive by construction"
  depOrder1 :: "ConstantTermAssignments => (int*int) set" where
 "depOrder1 f == {(x, y) | x y . y: constsOfLookuped f x}"

definition
  -- "transitive closure of depOrder1"
  depOrder :: "ConstantTermAssignments => (int*int) set" where
 "depOrder f == (depOrder1 f)^+"

definition
  -- "set of constants the current term (recursively) depends on"
  dependsOn :: "ConstantTermAssignments => Term => int set" where
 "dependsOn f t == Image (depOrder f) (constsOf t)"

-- "An AssignmentStore is a finite ConstantTermAssignments without cycles"
definition AS_set :: "ConstantTermAssignments set" where
          "AS_set == {f. let ord = depOrder f in wf ord & finite ord}"

lemma emptyAS_has_empty_dep_order : "depOrder empty == {}"
  by (simp add: depOrder1_def depOrder_def constsOfLookuped_def)

lemma emptyAS_in_AS': "empty : AS_set"
  by (simp add: emptyAS_has_empty_dep_order AS_set_def)

typedef (AS) AssignmentStore = AS_set
  morphisms asCTA toAS
  by (rule exI[of _ empty], simp only: emptyAS_in_AS')

lemma emptyAS_in_AS: "empty : AS"
  by (simp add: emptyAS_in_AS' AS_def)

function fullexpand :: "AssignmentStore => Term => Term" where
"fullexpand as (Num r) = Num r" |
"fullexpand as (Const i) = (case (asCTA as) i of
                              Some y => fullexpand as y
                            | None => Const i)" |
"fullexpand as (Fun0 c) = Fun0 c" |
"fullexpand as (Fun1 c t) = Fun1 c (fullexpand as t)" |
"fullexpand as (Fun2 c t u) = Fun2 c (fullexpand as t) (fullexpand as u)" |
"fullexpand as (FunN c l) = FunN c (map (fullexpand as) l)"
  by pat_completeness auto

(*
 fullexpand is total essentially because the lookup in the
 Const-case is terminating because of the wellfoundness of "as" and
 the recursion on the structure of Term also terminates
 *)
lemma fullexpand_is_total : "!! as t . fullexpand_dom (as, t)"
  sorry

(* arg_cong and fun_cong are the crucial axioms
lemma T1:
  assumes H0: "f x = g"
  shows "!!i. f x i = g i"
by (rule arg_cong, simp add: H0)
by (rule fun_cong, simp add: H0)
*)

lemma fullexpand_disjoint_as_identity':
  "(!x. x : constsOf t --> (asCTA as) x = None) --> fullexpand as t = t"
  by (rule fullexpand.pinduct[OF fullexpand_is_total], auto simp add: fullexpand_is_total, rule map_idI, auto)

lemma fullexpand_disjoint_as_identity:
  "(!!x. x : constsOf t ==> (asCTA as) x = None) ==> fullexpand as t = t"
  using fullexpand_disjoint_as_identity' by simp

lemma "!!t . fullexpand (toAS empty) t = t"
  using fullexpand_disjoint_as_identity toAS_inverse emptyAS_in_AS by simp

ML {* print_mode *}

nonterminals
  updbinds2 updbind2
syntax
  "_updbind2" :: "['a, 'a] => updbind2"             ("(2_ ::=/ _)")
  ""         :: "updbind2 => updbinds2"             ("_")
  "_updbinds2":: "[updbind2, updbinds2] => updbinds2" ("_,/ _")
  "_Update2"  :: "['a, updbinds2] => 'a"            ("_/'((_)')" [1000,0] 900)

translations
  "_Update2 f (_updbinds2 b bs)"  == "_Update2 (_Update2 f b) bs"
  "f(x::=y)"                     == "toAS ((asCTA f)(x |-> y))"

-- "If we encounter a cycle in an assignment we return None"
fun iProg :: "AssignmentStore => Command ~=> AssignmentStore" where
   "iProg as (Assign i t) = (let t' = fullexpand as t
                             in if i : constsOf t' then None else Some (as(i ::= t')))" |
   "iProg as (Seq c c') = (case iProg as c of
                             Some as' => iProg as' c'
                           | None => None)"

subsection {* Respectful States *}

definition respectsAS :: "State => AssignmentStore => bool" (infixl "resp" 50) where
         "s resp as == !x t . (asCTA as) x = Some t --> s x = iTerm s t"

theorem State_AssertionStore_interpretation_respect_preserving:
  "[|s resp as; iProg as p = Some as'|] ==> (iCommand s p) resp as'"
  sorry

theorem iTerm_invariant_under_full_expansion:
  "s resp as ==> !t. iTerm s t = iTerm s (fullexpand as t)"
proof-
  fix s as
  assume H0: "s resp as"
  show ?thesis
    sorry
qed
(* continue work here:

    apply (rule allI, induct_tac "t")
    apply(simp add: fullexpand_is_total fullexpand.psimps)
    apply (case_tac "asCTA as int")
    proof-
      fix i
      assume H1: "asCTA as i = None"
      hence H2: "(case (asCTA as) i of
                   Some y => fullexpand as y
                 | None => Const i)=Const i" (is "?cc = ?ci")
	by simp
      have "s i = iTerm s (Const i)" by simp
      also have "... = iTerm s ?cc" by (simp add: H2)

      -- "TODO: show macht probleme!"
      finally show "s i = iTerm s ?cc"
*)

ML {* Display.print_syntax (the_context()) *}
ML {* ProofDisplay.print_theory (the_context()) *}
ML {* ProofDisplay.print_theory (theory "Main") *}

constdefs c3 :: Command -- "The command for  x := 0; x := x + 1"
         "c3 == 1 := Num 0; 1 := Const 1 + Num 1" --"Seq (Assign 1 (Num 0)) (Assign 1 (Add (Const 1) (Num 1)))"

constdefs p3 :: Boolterm -- "The property for  x > 0"
         "p3 == Const 1 > Num 0"

lemma soundProg3:
  "!! s :: State .
   let s' = iCommand s c3
   in iBoolterm s s' p3"
  sorry

subsection {* Extended Parameters *}

datatype EPC =  EP CSLbinaryP nat nat | EPStar nat | EPBot nat

datatype RS = RS "EPC list"