theory HoareTRPointers

imports Main "HOL-Hoare.HeapSyntax"

begin

section \<open>Preliminary Example : List Reversal\<close>

lemma hd_tl:"xs \<noteq> [] \<Longrightarrow> xs = hd xs # tl xs"
  by simp

fun tail_rev::"'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"tail_rev [] acc = acc" |
"tail_rev (x#xs) acc = tail_rev xs (x # acc)"

lemma tail_rev:"\<forall>ys. tail_rev xs ys = rev xs @ ys"
apply (induction xs)
apply (auto)
done

lemma "tail_rev xs [] = rev xs" by (simp add:tail_rev)

lemma hd_tl_app:"xs \<noteq> [] \<Longrightarrow> xs = [hd xs] @ tl xs"
  by simp

lemma impRev: "VARS (acc::'a list) (xs::'a list)
 {xs=X}
 acc:=[];
 WHILE xs \<noteq> []
 INV {rev(xs)@acc = rev(X)}
 DO acc := (hd xs # acc); xs := tl xs OD
 {acc=rev(X)}"
apply (vcg)
  apply (simp)
  using hd_tl_app apply (force)
  apply (auto)
done

lemma impRev_isar: "VARS acc x
 {x=X}  acc:=[];
 WHILE x \<noteq> []  INV {rev(x)@acc = rev(X)}
 DO acc := (hd x # acc); x := tl x OD
 {acc=rev(X)}"
proof (vcg)
  fix acc x
  assume ass:"rev x @ acc = rev X \<and> x \<noteq> []"
  show "rev (tl x) @ hd x # acc = rev X"
    proof -
      from ass obtain 1:"rev x @ acc = rev X"
        and 2:" x\<noteq>[]" by blast
      from 2 have "x = hd x # tl x"  by simp
      from 1 and this  have 3:"rev x = rev (hd x # tl x)" by simp
      have "rev (hd x # tl x) = rev (tl x) @ [hd x]" by simp
      from 3 and this have "rev x =  rev (tl x) @ [hd x]" by simp
      from this and 1 show ?thesis by simp
    qed
qed (auto)

section \<open>Pointers and Linked Lists in Isabelle \<close>

\<comment>\<open> example:  0 \<mapsto> 1 \<mapsto> 2  \<mapsto> Null \<close>
definition next_n::"nat \<Rightarrow>nat ref" where
   "next_n\<equiv>(\<lambda>n. Null)(0:=Ref 1,1:=Ref(2),2:=Null)"
definition name::"nat \<Rightarrow> string"  where
   "name \<equiv> (\<lambda>n .'''')(0:=''Anne'',1:=''Paul'',2:=''July'')"
definition age::"nat \<Rightarrow> int"  where
   "age \<equiv> (\<lambda>n . 0)(0:=19,1:=21,2:=17)"
definition p::"nat ref" where "p\<equiv> Ref 0"
definition tmp::"nat ref" where "tmp\<equiv>p"

lemma "p^.name = ''Anne''" by (simp add:p_def name_def)
lemma "p^.next_n^.next_n=Ref 2" by (simp add:p_def next_n_def)
lemma "p^.next_n^.name = ''Paul''"
    by (simp add:p_def name_def next_n_def)
lemma "p^.next_n^.age = 21" by (simp add:p_def next_n_def age_def)
lemma "tmp^.age = 19" unfolding  p_def tmp_def age_def by simp

lemma "VARS (next_n::nat \<Rightarrow> nat ref)
        (age::nat \<Rightarrow> int) (p::nat ref)
        (tmp::nat ref)
{p= Ref 0 \<and> x=Ref 0 \<and> y= Ref 1 \<and> z = Ref 2}
x^.age := 19;x^.next_n := y;
y^.age := 21;y^.next_n := z;
z^.age := 17;z^.next_n := Null;tmp := x
{p^.next_n^.age = 21 \<and> tmp^.age = 19}"
  apply (vcg)
  apply (simp)
done

lemma "next_n 1 = Ref 2" by (simp add:next_n_def)
lemma "Ref 1^. next_n = Ref 2" by (simp add:next_n_def)
lemma "(next_n (Ref 2 \<rightarrow> Ref 4)) 2 = Ref 4" by (simp add:next_n_def)
lemma "(next_n (Ref 2 \<rightarrow> Ref 4)) 0 = Ref 1" by (simp add:next_n_def)
lemma "(next_n (2 := Ref 4)) 0  = Ref 1" by (simp add:next_n_def)
lemma "(next_n 4 = next_n 7) =  True" by (simp add:next_n_def)
lemma "(Ref 4^.next_n = Ref 7^.next_n) = True" by (simp add:next_n_def)

section \<open>Aliasing\<close>

text "An example due to Suzuki:"
\<comment> \<open>w0 \<rightarrow> x0 \<rightarrow> y0 \<rightarrow> z0\<close>
\<comment> \<open> function update solves the problem
    of aliasing using the tricks for arrays \<close>

lemma "VARS (v::'a \<Rightarrow> int) (next::'a \<Rightarrow> 'a ref)
  {w = Ref w0 & x = Ref x0 & y = Ref y0 & z = Ref z0 &
   distinct[w0,x0,y0,z0]}
  w^.v := 1; w^.next := x;
  x^.v := 2; x^.next := y;
  y^.v := 3; y^.next := z;
  z^.v := 4; x^.next := z
\<comment> \<open>w0 \<rightarrow> x0 \<rightarrow>  z0 \<and> y0 \<rightarrow> z0 \<close>
  {w^.next^.next^.v = 4 \<and> y^.next^.v=4}"
apply (vcg)
apply (auto)
done

\<comment> \<open>w0 \<rightarrow> x0 \<rightarrow> y0\<close>
lemma "VARS (v::'a \<Rightarrow> int)
       (next::'a \<Rightarrow> 'a ref) (tmp::'a ref)
  {w = Ref w0 & x = Ref x0 & y = Ref y0 \<and>
   distinct[w0,x0,y0]}
  w^.v := 1; w^.next := x;
  x^.v := 2; x^.next := y;
  y^.v := 3; tmp := y
\<comment> \<open>w0 \<rightarrow> x0 \<rightarrow>  z0 \<and> y0 \<rightarrow> z0 \<close>
  {w^.next^.next^.v = 3 \<and> tmp^.v=3}"
apply (vcg)
apply (simp)
done

\<comment> \<open>{i=j \<and> a[i] = 3} a[i] = 4 {a[j] = 4}\<close>

lemma "VARS (a::nat \<Rightarrow> int)
{i=j \<and> a(i) = 3}
a := a(i:=4)
{a(j) = 4}"
apply (vcg)
apply (simp)
done

section \<open> Simple Examples of Pointer Programs \<close>

\<comment> \<open>deletion at the front of a linked list without ghost variables\<close>

lemma "VARS (next::'a \<Rightarrow> 'a ref) (p::'a ref) (q::'a ref)
{List next p Ps \<and> p \<noteq> Null}
  q := p;p := p^.next
{\<exists> a as. List next p as \<and> q = Ref a \<and> a # as = Ps}"
apply (vcg)
apply (auto)
done

lemma "VARS (next::'a \<Rightarrow> 'a ref) (p::'a ref) (q::'a ref)
{List next p Ps \<and> p \<noteq> Null}
  q := p;p := p^.next
{\<exists> a as. List next p as \<and> q = Ref a \<and> a # as = Ps}"
proof (vcg)
  fix "next" p q val
  assume ass:"List next p Ps \<and> p \<noteq> Null "
  from this obtain a as where "Ps = a # as" and
   "p = Ref a" and "List next (next a) as" by auto
  from this show "\<exists>a as. List next (next (addr p)) as
      \<and>  p = Ref a \<and> a # as = Ps" by simp
qed

\<comment> \<open>deletion at the front of a linked list
      with ghost variables\<close>
lemma "VARS (next::'a \<Rightarrow> 'a ref) (p::'a ref)
      (ps::'a list) (q::'a ref) (val::'a)
{List next p Ps \<and> p \<noteq> Null}
  ps := Ps;q := p; p := p^.next;
  ps := tl ps; val := addr q
{List next p ps  \<and> val # ps = Ps}"
  apply (vcg)
  apply (auto)
done

\<comment> \<open>deletion at the front - example\<close>
lemma "VARS next p ps  q val
{ p \<noteq> Null \<and> List next p Ps \<and> Ps = [0,1,2]}
  ps := Ps; q:= p; p := p^.next;
  ps:= tl ps ;val := addr q
{List next p ps \<and> val#ps =[0,1,2]}"
apply (vcg)
apply (auto)
done

\<comment> \<open>number of nodes in a linked list -
     without ghost variables\<close>
lemma "VARS (next::'a \<Rightarrow> 'a ref) (p::'a ref)
         (ps::'a list) (k::nat) j
{List next p Ps \<and> j = length Ps}
k:=0;
WHILE p \<noteq> Null
INV {\<exists> as. List next p as \<and> length as + k = j}
DO p := p^.next; k := k+1 OD
{j = k \<and> List next p []}"
apply (vcg)
  apply (fastforce)
  apply (fastforce)
  apply (fastforce)
done

section \<open>Case Study : In-Place List Reversal\<close>

lemma in_place_rev: "VARS p q tmp next
{List next p Ps}
q := Null;
WHILE p \<noteq> Null
  INV {\<exists> ps qs. List next p ps \<and> List next q qs
       \<and> set ps \<inter> set qs = {}
       \<and>  rev ps @ qs = rev Ps}
DO
  tmp := p; p:= p^.next;
  tmp^.next := q; q:=tmp
OD
{List next q (rev Ps)}"
apply (vcg)
  \<comment> \<open>List is a function ; [] is neutral\<close>
  apply (simp)
  apply (clarsimp)
     apply (smt  List_hd_not_in_tl
            disjoint_iff_not_equal notin_List_update
            set_ConsD)
  apply (auto)
done

value "(next(u\<rightarrow>v)) (addr u)"

\<comment> \<open> Yes!\<close>
lemma "List next q qs \<Longrightarrow> u = Ref a \<Longrightarrow> a \<notin> set qs \<Longrightarrow>
        List (next(u\<rightarrow>q)) u (a # qs)" by simp

lemma in_place_rev_draft: "VARS p q tmp next
{List next p Ps}
q := Null;
WHILE p \<noteq> Null
  INV {\<exists> ps qs. List next p ps \<and> List next q qs
       \<and> set ps \<inter> set qs = {}
       \<and>  rev ps @ qs = rev Ps}
DO
  tmp := p; p:= p^.next;
  tmp^.next := q; q:=tmp
OD
{List next q (rev Ps)}"
proof (vcg)
  fix p q tmp "next"
  assume  ass:
          "(\<exists>ps qs. List next p ps \<and>
           List next q qs \<and>
           set ps \<inter> set qs = {} \<and>
           rev ps @ qs = rev Ps) \<and> p \<noteq> Null"
  show "\<exists>ps qs.
          List (next(p \<rightarrow> q)) (next (addr p)) ps \<and>
          List (next(p \<rightarrow> q)) p qs \<and>
          set ps \<inter> set qs = {} \<and>
          rev ps @ qs = rev Ps" sorry
qed (auto)

lemma in_place_rev_isar: "VARS p q tmp next
{List next p Ps}
q := Null;
WHILE p \<noteq> Null
  INV {\<exists> ps qs. List next p ps \<and> List next q qs
       \<and> set ps \<inter> set qs = {}
       \<and>  rev ps @ qs = rev Ps}
DO
  tmp := p; p:= p^.next;
  tmp^.next := q; q:=tmp
OD
{List next q (rev Ps)}"
proof (vcg)
  fix p q tmp "next"
  assume  ass:
          "(\<exists>ps qs. List next p ps \<and>
           List next q qs \<and>
           set ps \<inter> set qs = {} \<and>
           rev ps @ qs = rev Ps) \<and> p \<noteq> Null"
  show "\<exists>ps qs.
          List (next(p \<rightarrow> q)) (next (addr p)) ps \<and>
          List (next(p \<rightarrow> q)) p qs \<and>
          set ps \<inter> set qs = {} \<and>
          rev ps @ qs = rev Ps"
      proof -
        from ass obtain ps qs where
          a1:"List next p ps" and a2 :"List next q qs"
          and a3: "set ps \<inter> set qs = {}" and
          a4: "rev ps @ qs = rev Ps" and a5:"p \<noteq> Null"
              by blast
         from a5 and a1 obtain a as where a6:"p=Ref a"
          and a7:"ps = a # as"  and
          a8:"List next (next a) as" and a9:"a = addr p"  by auto
        from a8 a6 have "a \<notin> set as" by simp
        from this and  a8
          have "List (next(a :=  q)) (next a) as" by simp
        from this and  a9
          have c1:"List (next(p \<rightarrow> q)) (next (addr p)) as" by simp
        from a7 and a3 have a10:"a \<notin> set qs" by simp
        from this and a2 and a6 have
           c2:"List (next(p \<rightarrow> q)) p (a#qs)" by simp
        from a7 and a3 and a10 and \<open>a\<notin> set as\<close>
            have c3: "set as \<inter> set (a#qs) = {}" by simp
        from a4 and a7
          have "rev as @ (a # qs) = rev Ps" by simp
        from this and c1 and c2 and c3 show ?thesis by blast
      qed
qed (auto)

lemma in_place_rev_isar2: "VARS p q tmp next
{List next p Ps}
q := Null;
WHILE p \<noteq> Null
  INV {\<exists> ps qs. List next p ps \<and> List next q qs
       \<and> set ps \<inter> set qs = {}
       \<and>  rev ps @ qs = rev Ps}
DO
  tmp := p; p:= p^.next;
  tmp^.next := q; q:=tmp
OD
{List next q (rev Ps)}"
proof (vcg)
  fix p q tmp "next"
  assume  ass:
          "(\<exists>ps qs. List next p ps \<and>
           List next q qs \<and>
           set ps \<inter> set qs = {} \<and>
           rev ps @ qs = rev Ps) \<and> p \<noteq> Null"
  show "\<exists>ps qs.
          List (next(p \<rightarrow> q)) (next (addr p)) ps \<and>
          List (next(p \<rightarrow> q)) p qs \<and>
          set ps \<inter> set qs = {} \<and>
          rev ps @ qs = rev Ps"
      proof -
        \<comment> \<open> breaking assumptions into pieces \<close>
        from ass obtain ps qs where
          a1:"List next p ps" and a2 :"List next q qs"
          and a3: "set ps \<inter> set qs = {}" and
          a4: "rev ps @ qs = rev Ps" and a5:"p \<noteq> Null"
              by blast
         from a5 and a1 obtain a as where "p=Ref a"
          and "ps = a # as"  and
          "List next (next a) as" and "a = addr p"  by auto
        from \<open>List next (next a) as\<close>
              have "a \<notin> set as" by simp
        from this and  \<open>List next (next a) as\<close>
          have "List (next(a :=  q)) (next a) as" by simp
        from this and  \<open>a = addr p\<close>
          have c1:"List (next(p \<rightarrow> q)) (next (addr p)) as" by simp
        from \<open>ps = a # as\<close> and a3 have "a \<notin> set qs" by simp
        from this and a2 and \<open>p=Ref a\<close> have
           c2:"List (next(p \<rightarrow> q)) p (a#qs)" by simp
        from \<open>ps = a # as\<close> and a3 and \<open>a \<notin> set qs\<close> and \<open>a\<notin> set as\<close>
            have c3: "set as \<inter> set (a#qs) = {}" by simp
        from a4 and \<open>ps = a # as\<close>
          have "rev as @ (a # qs) = rev Ps" by simp
        from this and c1 and c2 and c3 show ?thesis by blast
      qed

qed (auto)

lemma in_place_rev_ghost: "VARS p ps qs q tmp next
{List next p Ps \<and> ps = Ps}
q := Null; qs := [];
WHILE p \<noteq> Null
  INV {List next p ps \<and> List next q qs
       \<and> set ps \<inter> set qs = {}
       \<and>  rev ps @ qs = rev Ps}
DO
  tmp := p; p:= p^.next;
  tmp^.next := q; q:=tmp;
  qs := hd ps # qs;ps := tl ps
OD
{List next q (rev Ps)}"
apply (vcg)
  apply (simp)
  apply (clarsimp)
  apply (auto)
done

section \<open> Case Study: In-Place Cyclic Lists Reversal \<close>

\<comment>\<open> 1 \<mapsto> 2 \<mapsto> 3 \<mapsto> 1 \<mapsto> 2 \<mapsto> 3 \<dots> \<close>

definition  nciclic::"nat \<Rightarrow> nat ref" where
   "nciclic\<equiv>(\<lambda>n. Null)(1:=Ref 2,2:=Ref(3),3:=Ref(1))"

lemma "Path nciclic (Ref 1) [] (Ref 1)"
     by (simp add:nciclic_def)

lemma "Path nciclic (Ref 1) [1] (Ref 2)"
     by (simp add:nciclic_def)
lemma "Path nciclic (Ref 1) [1,2,3] (Ref 1)" by
          (simp add:nciclic_def)
lemma "Path nciclic (Ref 1) [1,2,3,1,2] (Ref 3)" by
       (simp add:nciclic_def)

\<comment> \<open>Why nciclic is not needed?\<close>
lemma "\<not>(distPath nciclic (Ref 1) [1,2,3,1,2] (Ref 3))"
  by (simp add: distPath_def)

definition cyclic2 where
  "cyclic2 \<equiv> (\<lambda>n. Null) (1:= Ref 1)"

lemma "Path cyclic2 (Ref 1) [1] (Ref 1)" by (simp add:cyclic2_def)
lemma "distPath cyclic2 (Ref 1) [1] (Ref 1)"
   by (simp add:cyclic2_def distPath_def)
lemma "Path cyclic2 (Ref 1) [1,1,1,1] (Ref 1)"
    by (simp add:cyclic2_def)

lemma circular_list_rev_I:
  "VARS next root p q tmp
  {root = Ref r \<and> distPath next root (r#Ps) root}
  p := root; q := root^.next;
  WHILE q \<noteq> root
  INV {\<exists> ps qs. distPath next p ps root
               \<and> distPath next q qs root \<and>
                root = Ref r \<and> r \<notin> set Ps  \<and>
                set ps \<inter> set qs = {} \<and>
                 Ps = (rev ps) @ qs  }
  DO tmp := q; q := q^.next; tmp^.next := p; p:=tmp OD;
  root^.next := p
  { root = Ref r \<and> distPath next root (r#rev Ps) root}"
apply (simp only:distPath_def)
apply vcg
  apply (fastforce)
  prefer 2
  apply (fastforce)
  apply (clarsimp)
    apply (drule (2) neq_dP)
    apply clarsimp
    apply(rule_tac x="a # ps" in exI)
    apply clarsimp
done

lemma circular_rev_draft:
  "VARS next root p q tmp
  {root = Ref r \<and> distPath next root (r#Ps) root}
  p := root; q := root^.next;
  WHILE q \<noteq> root
  INV {\<exists> ps qs. distPath next p ps root
               \<and> distPath next q qs root \<and>
                root = Ref r \<and> r \<notin> set Ps  \<and>
                set ps \<inter> set qs = {} \<and>
                 Ps = (rev ps) @ qs  }
  DO tmp := q; q := q^.next; tmp^.next := p; p:=tmp OD;
  root^.next := p
  { root = Ref r \<and> distPath next root (r#rev Ps) root}"
unfolding distPath_def
proof (vcg)
  fix "next" and  root and p q tmp
  assume ass:
   "(\<exists>ps qs.(Path next p ps root \<and> distinct ps) \<and>
     (Path next q qs root \<and> distinct qs) \<and>
     root = Ref r \<and> r \<notin> set Ps \<and>
     set ps \<inter> set qs = {} \<and> Ps = rev ps @ qs) \<and>
       q \<noteq> root"
  show "\<exists>ps qs. (Path (next(q \<rightarrow> p)) q ps root
        \<and> distinct ps)
        \<and> (Path (next(q \<rightarrow> p)) (next (addr q)) qs root
        \<and> distinct qs) \<and> root = Ref r \<and>  r \<notin> set Ps
        \<and>  set ps \<inter> set qs = {} \<and> Ps = rev ps @ qs" sorry
qed (force)+

lemma cyclic_list_rev_I':
"VARS next root p q tmp
{root = Ref r \<and> distPath next root (r#Ps) root}
p := root; q := root^.next;
WHILE q \<noteq> root
INV {\<exists> ps qs. distPath next p ps root
             \<and> distPath next q qs root \<and>
              root = Ref r \<and> r \<notin> set Ps  \<and>
              set ps \<inter> set qs = {} \<and>
               Ps = (rev ps) @ qs  }
DO tmp := q; q := q^.next; tmp^.next := p; p:=tmp OD;
root^.next := p
{ root = Ref r \<and> distPath next root (r#rev Ps) root}"
unfolding distPath_def
proof (vcg)
fix "next" root p q tmp
assume "root = Ref r \<and>
       Path next root (r # Ps) root \<and>
         distinct (r # Ps)"
  from this have "Path next (next r) Ps root"
   and "distinct Ps" and "r\<notin> set Ps"
   and "Path next root [] root" and "root = Ref r" by auto
  from this show
    "\<exists>ps qs. (Path next root ps root \<and> distinct ps)
     \<and> (Path next (next (addr root)) qs root \<and>
     distinct qs) \<and> root = Ref r \<and>  r \<notin> set Ps \<and>
      set ps \<inter> set qs = {} \<and> Ps = rev ps @ qs" by force
next
  fix "next" root p q tmp
  assume "(\<exists>ps qs. (Path next p ps root \<and> distinct ps) \<and>
           (Path next q qs root \<and> distinct qs) \<and>
           root = Ref r \<and> r \<notin> set Ps \<and>
           set ps \<inter> set qs = {} \<and>
           Ps = rev ps @ qs) \<and> \<not> q \<noteq> root"
  from this obtain ps1 qs1 where  "q = root"  and
    "Path next q qs1 root" and "qs1 = []"  and
    "Ps = rev ps1"  and pr:"Path next p ps1 root"
    and "distinct ps1"  and "r \<notin> set Ps" and
    "root = Ref r"  by auto
  from \<open>Ps = rev ps1\<close> and \<open>r \<notin> set Ps\<close>
    have "rev Ps = ps1" and "r \<notin> set (rev Ps)"  by auto
  from this and pr and \<open>root = Ref r\<close> and \<open>q = root\<close>
    and \<open>distinct ps1\<close>
  show "root = Ref r
          \<and> Path (next(root \<rightarrow> p)) root (r# rev Ps) root
          \<and> distinct (r# rev Ps) " by simp

next
  fix "next" and  root and p q tmp
  assume ass:
   "(\<exists>ps qs.(Path next p ps root \<and> distinct ps) \<and>
     (Path next q qs root \<and> distinct qs) \<and>
     root = Ref r \<and> r \<notin> set Ps \<and>
     set ps \<inter> set qs = {} \<and> Ps = rev ps @ qs) \<and>
       q \<noteq> root"
  show "\<exists>ps qs. (Path (next(q \<rightarrow> p)) q ps root
        \<and> distinct ps)
        \<and> (Path (next(q \<rightarrow> p)) (next (addr q)) qs root
        \<and> distinct qs) \<and> root = Ref r \<and>  r \<notin> set Ps
        \<and>  set ps \<inter> set qs = {} \<and> Ps = rev ps @ qs"
  proof -
    from ass have "root = Ref r" and "r \<notin> set Ps"
      and "q \<noteq> root" by auto
    from ass obtain ps1 qs1 where
      pr:"Path next p ps1 root" and dps:"distinct ps1" and
      qr:"Path next q qs1 root" and dqs:"distinct qs1" and
      setI:"set ps1 \<inter> set qs1 = {}" and
        psr: "Ps = rev ps1 @ qs1"  by blast
    from qr and \<open>q\<noteq>root\<close> and dqs  obtain x bs where
     "q=Ref x" and "qs1= x#bs"
     "Path next (next x) bs root"
      by (metis Path.simps(2) neq_dP)
    from setI and \<open>qs1 = x#bs\<close> have "x \<notin> set ps1" by simp
    from this and pr and \<open>q=Ref x\<close> and dps have
      c1:"Path (next(q\<rightarrow>p)) q (x#ps1) root \<and> distinct (x#ps1)"
        by simp
    from dqs and \<open>qs1 = x#bs\<close> have "x \<notin> set bs" by simp
    from this and  qr and \<open>qs1 = x#bs\<close> and dqs and \<open>q=Ref x\<close>
      have c2:"Path (next(q \<rightarrow> p)) (next (addr q)) bs root \<and>
             distinct bs" by simp
    from setI and \<open>qs1 = x#bs\<close> and dps and dqs
      have c3:"set (x#ps1) \<inter> set bs = {}" by simp
    from psr and \<open>qs1 = x#bs\<close>
      have c4:"rev (x#ps1) @ bs = rev ps1 @ qs1" by simp
    from this c1 and c2 and c3 and c4 and psr
      and \<open>root = Ref r\<close> and \<open>r \<notin> set Ps\<close>
    show ?thesis  by metis
   qed
qed

section \<open> Other Examples \<close>

\<comment> \<open> reverses a list Ps onto a list Qs \<close>
\<comment> \<open> uses ghost variables \<close>
lemma lrev_ghost:"VARS next p ps q qs r
  {List next p Ps \<and> List next q Qs \<and> set Ps \<inter> set Qs = {} \<and>
   ps = Ps \<and> qs = Qs}
  WHILE p \<noteq> Null
  INV {List next p ps \<and> List next q qs \<and> set ps \<inter> set qs = {} \<and>
       rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.next; r^.next := q; q := r;
     qs := (hd ps) # qs; ps := tl ps OD
  {List next q (rev Ps @ Qs)}"
apply (vcg)
apply (simp)
apply (fastforce)
apply (auto)
done

\<comment> \<open> an concrete example \<close>
lemma "VARS (next::int \<Rightarrow> int ref) (p::int ref)
              (ps::int list) (q::int ref) (qs::int list)
               (r::int ref)
{List next p Ps \<and> List next q Qs
  \<and> set Ps \<inter> set Qs = {} \<and>
   ps = Ps \<and> qs = Qs
   \<and> Ps =[1,2,3] \<and> Qs=[]}
  WHILE p \<noteq> Null
  INV {List next p ps \<and> List next q qs
        \<and> set ps \<inter> set qs = {} \<and>
       rev ps @ qs = rev Ps @ Qs \<and>
       rev ps @ qs = [3,2,1]}
  DO  r := p; p := p^.next;
      r^.next := q; q := r;
      qs := (hd ps) # qs; ps := tl ps OD
{List next q (rev Ps@ Qs) \<and> qs = [3,2,1]}"
apply (vcg)
apply auto[1]
apply (fastforce)
apply (fastforce)
done

 \<comment> \<open> Allocation of nodes \<close>

definition new :: "'a set \<Rightarrow> 'a"
  where "new A = (SOME a. a \<notin> A)"

lemma new_notin:
 "\<lbrakk> ~finite(UNIV::'a set); finite(A::'a set); B \<subseteq> A \<rbrakk> \<Longrightarrow> new (A) \<notin> B"
apply(unfold new_def)
apply(rule someI2_ex)
apply (fast intro:ex_new_if_finite)
apply (fast)
done

lemma "~finite(UNIV::'a set) \<Longrightarrow>
  VARS (xs::'a list) (elem::'a \<Rightarrow> 'a) (next::'a \<Rightarrow>'a ref)
      (alloc::'a list) (p::'a ref) (q::'a ref)
  {Xs = xs \<and> p = (Null::'a ref)}
  WHILE xs \<noteq> []
  INV {islist next p \<and> set(list next p) \<subseteq> set alloc \<and>
       map elem (rev(list next p)) @ xs = Xs}
  DO q := Ref(new(set alloc)); alloc := (addr q)#alloc;
     q^.next := p; q^.elem := hd xs; xs := tl xs; p := q
  OD
  {islist next p \<and> map elem (rev(list next p)) = Xs}"
apply vcg_simp
 apply (clarsimp simp: subset_insert_iff neq_Nil_conv fun_upd_apply
        new_notin)
apply fastforce
done

 \<comment> \<open> Exercises \<close>
lemma len_butlast:"xs\<noteq> [] \<Longrightarrow>
   length (butlast xs) + 1 = length xs" by simp

lemma list_ptr:
  "List next pt1 xs \<Longrightarrow> List next pt2 xs \<Longrightarrow> pt1 = pt2"
by (metis List_def List_distinct List_unique Path.simps(1)
       last_snoc neq_dP rotate1.simps(2))

lemma "List next ptr ps \<Longrightarrow> ptr\<noteq>Null \<Longrightarrow> ps \<noteq> []" by auto

lemma "List next ptr ps \<Longrightarrow> distinct ps" by simp

\<comment> \<open>insertion at the beginning of the list\<close>

\<comment> \<open>deletion at the end of a linked list\<close>

lemma "List (next(h:=Null)) (Ref h) [h]" by simp
lemma "Path next Null [] Null" by simp
lemma "ps \<noteq> [] \<and> distinct ps  \<Longrightarrow>
  List (next(last ps:=Null)) (Ref (hd ps)) ps" oops
lemma "distPath next Null [] Null" by (simp add:distPath_def)
lemma "distPath next ptr [] ptr  \<Longrightarrow> ptr = Null \<Longrightarrow>
       List next ptr []" by simp
lemma "distPath next ptr [1,2] q \<Longrightarrow> next 2 = q" by (simp add:distPath_def)
lemma "distPath next ptr [1,2] q  \<Longrightarrow>
   List (next(2:=Null)) ptr [1,2]" by (simp add:distPath_def)
lemma "distPath next ptr [1,2] q \<Longrightarrow> ptr = Ref 1 \<and> next 1 = Ref 2
 \<and> next 2 = q"  by (simp add:distPath_def)
lemma "distPath next ptr [1,2] q \<Longrightarrow> heap = next(2:=Null)
\<Longrightarrow> heap 2 = Null"  by (simp add:distPath_def)
lemma "distPath next ptr [1,2] q \<Longrightarrow> heap = next(2:=Null) \<Longrightarrow> Path heap ptr
[1,2] Null"  by (simp add:distPath_def)
lemma "distPath next ptr [1,2] Null \<Longrightarrow> List next ptr [1,2]"
by (simp add:distPath_def)
lemma "butlast [1,2,3] = [1,2]" by simp
lemma "butlast [1] = []" by simp

lemma "VARS p next q tmp  ps qs
{List next p Ps  \<and> p \<noteq> Null}
IF p^.next = Null
  \<comment> \<open>Ps has exactly one element\<close>
  THEN p:= Null;ps:=[];qs:=Ps
ELSE
  \<comment> \<open>Ps has at least two elements \<close>
  tmp := p; q:= p^.next;
  ps :=[hd Ps]; qs := tl Ps;
  WHILE q^.next \<noteq> Null
  INV  {p \<noteq> Null \<and> List next p Ps
        \<and> List next q qs
        \<and> List (next(last ps := Null)) p ps
        \<and> ps @ qs = Ps
        \<and> set ps \<inter> set qs = {}
        \<and> next (last ps) = q
        \<and> last ps = addr tmp
       \<comment> \<open> \<and> next (addr tmp) = q\<close>
        \<and> ps \<noteq> [] \<and> qs \<noteq> []
       }
  DO
     tmp := q;
     ps := ps @ [hd qs];
     q:= q^.next;
     qs := tl qs
  OD;
  tmp^.next := Null
FI
{
 (List next p ps \<and> Ps = ps @ [last Ps])}"
apply (vcg)
    apply (clarsimp)
      using List_def apply fastforce
    apply (intro conjI)
      apply (simp_all)
      apply (metis List_def Path.simps(2) addr.simps
            list.collapse)
      apply (metis List_app List_def Path.simps(2)
             Path_is_List disjoint_iff_not_equal
             hd_in_set list.collapse)
      apply (metis List_distinct disjoint_iff_not_equal
           distinct.simps(2) hd_Cons_tl list.set_sel(2))
      apply (metis List_def Path.simps(2) addr.simps
             list.collapse)
      apply (metis List_def Path.simps(2) addr.simps
              list.collapse)
      apply (metis List_def Path.simps(1) Path.simps(2)
           addr.simps list.collapse ref.distinct(1))
   apply (intro conjI)
      apply auto[1]
      apply (metis List_def Path.simps(2) addr.simps
       last_snoc list.exhaust ref.distinct(1))
done

lemma "VARS p next q tmp  ps qs
{List next p Ps  \<and> p \<noteq> Null}
IF p^.next = Null
  \<comment> \<open>Ps has exactly one element\<close>
  THEN p:= Null;ps:=[];qs:=Ps
ELSE
  \<comment> \<open>Ps has at least two elements \<close>
  tmp := p; q:= p^.next;
  ps :=[hd Ps]; qs := tl Ps;
  WHILE q^.next \<noteq> Null
  INV  {p \<noteq> Null \<and> List next p Ps
        \<and> List next q qs
        \<and> List (next(last ps := Null)) p ps
        \<and> ps @ qs = Ps
        \<and> set ps \<inter> set qs = {}
        \<and> next (last ps) = q
        \<and> last ps = addr tmp
       \<comment> \<open> \<and> next (addr tmp) = q\<close>
        \<and> ps \<noteq> [] \<and> qs \<noteq> []
       }
  DO
     tmp := q;
     ps := ps @ [hd qs];
     q:= q^.next;
     qs := tl qs
  OD;
  tmp^.next := Null
FI
{
 (List next p ps \<and> Ps = ps @ [last Ps])}"
apply (vcg_simp)
   apply (clarify)
     apply (metis List_Ref List_def List_hd_not_in_tl
         List_unique Path.simps(1) addr.simps last.simps
         list.distinct(1) list.sel(1) list.sel(3))
     apply (intro conjI)
       apply (metis List_def Path.simps(2) addr.simps
          list.collapse)
       apply (metis List_app List_def Path.simps(2)
         Path_is_List disjoint_iff_not_equal hd_in_set
         list.collapse)
       apply (metis List_distinct distinct.simps(2)
          hd_Cons_tl)
       apply (simp add: disjoint_iff_not_equal list.set_sel(2))
       apply (metis List_def Path.simps(2) addr.simps
         list.collapse)
       apply (metis List_def Path.simps(2) addr.simps
         list.collapse)
       apply  (metis List_def Path.simps(1) Path.simps(2)
          addr.simps list.collapse ref.distinct(1))
     apply (metis (no_types, hide_lams) List_unique
         Path.simps(1) Path_is_List addr.simps
         append.left_neutral empty_iff empty_set
         fun_upd_triv last_appendR last_in_set
         not_Ref_eq self_append_conv set_ConsD)
done

lemma "VARS p next q tmp  ps qs
{List next p Ps  \<and> p \<noteq> Null}
IF p^.next = Null
  \<comment> \<open>Ps has exactly one element\<close>
  THEN p:= Null;ps:=[];qs:=Ps
ELSE
  \<comment> \<open>Ps has at least two elements \<close>
  tmp := p; q:= p^.next;
  ps :=[hd Ps]; qs := tl Ps;
  WHILE q^.next \<noteq> Null
  INV  {p \<noteq> Null \<and> List next p Ps
        \<and> List next q qs
        \<and> List (next(last ps := Null)) p ps
        \<and> ps @ qs = Ps
        \<and> set ps \<inter> set qs = {}
        \<and> next (last ps) = q
        \<and> last ps = addr tmp
       \<comment> \<open> \<and> next (addr tmp) = q\<close>
        \<and> ps \<noteq> [] \<and> qs \<noteq> []
       }
  DO
     tmp := q;
     ps := ps @ [hd qs];
     q:= q^.next;
     qs := tl qs
  OD;
  tmp^.next := Null
FI
{\<exists> a as. List next p as \<and> as @ [a] = Ps}"
apply (vcg)
   apply (intro conjI)
      apply auto[1]
      apply (clarsimp)
          apply (metis List_Ref List_hd_not_in_tl
             list.set_intros(1) list.set_intros(2))
   apply (intro conjI)
      apply (simp_all)
      apply (metis List_def Path.simps(2) addr.simps
         list.collapse)
      apply (metis List_app List_def Path.simps(2)
         Path_is_List disjoint_iff_not_equal hd_in_set
         list.collapse)
      apply (metis List_distinct disjoint_iff_not_equal
         distinct.simps(2) hd_Cons_tl list.set_sel(2))
      apply (metis List_def Path.simps(2) addr.simps
         list.collapse)
      apply (metis List_def Path.simps(2) addr.simps
         list.collapse)
      apply (metis List_Ref List_def Path.simps(2)
         addr.simps list.collapse list.distinct(1))
  by (metis List_unique Path.simps(1) Path_is_List
      addr.simps append.left_neutral empty_iff empty_set
       fun_upd_triv not_Ref_eq self_append_conv)

lemma "VARS p next q tmp  ps qs
{List next p Ps  \<and> p \<noteq> Null}
IF p^.next = Null
  \<comment> \<open>Ps has exactly one element\<close>
  THEN p:= Null;ps:=[];qs:=Ps
ELSE
  \<comment> \<open>Ps has at least two elements \<close>
  tmp := p; q:= p^.next;
  ps :=[hd Ps]; qs := tl Ps;
  WHILE q^.next \<noteq> Null
  INV  {p \<noteq> Null \<and> List next p Ps
        \<and> List next q qs
        \<and> List (next(last ps := Null)) p ps
        \<and> ps @ qs = Ps
        \<and> set ps \<inter> set qs = {}
        \<and> next (last ps) = q
        \<and> last ps = addr tmp
       \<comment> \<open> \<and> next (addr tmp) = q\<close>
        \<and> ps \<noteq> [] \<and> qs \<noteq> []
       }
  DO
     tmp := q;
     ps := ps @ [hd qs];
     q:= q^.next;
     qs := tl qs
  OD;
  tmp^.next := Null
FI
{\<exists> a as. List next p as \<and> as @ [a] = Ps}"
apply (vcg_simp)
apply (intro conjI)
    apply (metis List_def List_unique Path.simps(1)
         Path.simps(2) addr.simps)
    apply (metis List_Ref List_hd_not_in_tl addr.simps
       hd_Cons_tl list.discI list.inject)
apply (intro conjI)
      apply (metis List_def Path.simps(2) addr.simps
      list.collapse)
      apply (metis List_app List_def Path.simps(2)
           Path_is_List disjoint_iff_not_equal hd_in_set
          list.collapse)
      apply (metis List_distinct distinct.simps(2) hd_Cons_tl)
      apply (simp add: disjoint_iff_not_equal list.set_sel(2))
      apply (metis List_def Path.simps(2) addr.simps
          list.collapse)
      apply (metis List_def Path.simps(2) addr.simps
        list.collapse)
      apply (metis List_def Path.simps(1) Path.simps(2)
        addr.simps list.collapse ref.distinct(1))
apply  (metis List_unique Path.simps(1) Path_is_List
       addr.simps append.left_neutral empty_iff empty_set
       fun_upd_triv not_Ref_eq self_append_conv)
done

abbreviation inv_del where
"inv_del heap head q tp ps qs xs \<equiv>
  p \<noteq> Null \<and> List heap head xs
        \<and> List heap q qs
        \<and> List (heap(last ps := Null)) head ps
        \<and> ps @ qs =xs
        \<and> set ps \<inter> set qs = {}
        \<and> heap (last ps) = q
        \<and> last ps = addr tp
        \<and> ps \<noteq> [] \<and> qs \<noteq> []"

abbreviation inv_del_end where
"inv_del_end \<equiv> True"

    lemma "VARS p next q tmp  ps qs
    {List next p Ps  \<and> p \<noteq> Null}
    IF p^.next = Null
      \<comment> \<open>Ps has exactly one element\<close>
      THEN p:= Null;ps:=[];qs:=Ps
    ELSE
      \<comment> \<open>Ps has at least two elements \<close>
      tmp := p; q:= p^.next;
      ps :=[hd Ps]; qs := tl Ps;
      WHILE q^.next \<noteq> Null
      INV  {inv_del_end}
      DO
         tmp := q; ps := ps @ [hd qs];
         q:= q^.next;qs := tl qs
      OD;
      tmp^.next := Null
    FI
    {\<exists> a as. List next p as \<and> as @ [a] = Ps}"
oops

lemma "VARS p next q tmp  ps qs
{List next p Ps  \<and> p \<noteq> Null}
IF p^.next = Null
  \<comment> \<open>Ps has exactly one element\<close>
  THEN p:= Null;ps:=[];qs:=Ps
ELSE
  \<comment> \<open>Ps has at least two elements \<close>
  tmp := p; q:= p^.next;
  ps :=[hd Ps]; qs := tl Ps;
  WHILE q^.next \<noteq> Null
  INV  {p \<noteq> Null \<and> List next p Ps
        \<and> List next q qs
        \<and> List (next(last ps := Null)) p ps
        \<and> ps @ qs = Ps
        \<and> set ps \<inter> set qs = {}
        \<and> next (last ps) = q
        \<and> last ps = addr tmp
        \<and> ps \<noteq> [] \<and> qs \<noteq> []
       }
  DO
     tmp := q;  ps := ps @ [hd qs];
     q:= q^.next; qs := tl qs
  OD;
  tmp^.next := Null
FI
{\<exists> a as. List next p as \<and> as @ [a] = Ps}"
proof (vcg_simp)
  fix p "next"
  assume ass:"List next p Ps \<and> (\<exists>y. p = Ref y)"
  show "(next (addr p) = Null \<longrightarrow> (\<exists>a. [a] = Ps)) \<and>
        ((\<exists>y. next (addr p) = Ref y) \<longrightarrow>
        List next (next (addr p)) (tl Ps) \<and>
        p = Ref (hd Ps) \<and> hd Ps # tl Ps = Ps \<and>
        hd Ps \<notin> set (tl Ps) \<and> next (hd Ps) = next (addr p) \<and>
        hd Ps = addr p \<and> tl Ps \<noteq> [])" (is "(?C1 \<longrightarrow> ?D1)
         \<and> (?C2 \<longrightarrow> ?D2)")
   proof (intro conjI)
      show "?C1 \<longrightarrow> ?D1"
        proof (rule impI)
          assume h:"next (addr p) = Null"
          from ass obtain a and as::"'a list"  where
           "p = Ref a"  and "List next (next a) as" and
           "a#as=Ps"  by auto
          from this and h have "as =[]" by simp
          from this and \<open>a#as=Ps\<close> show ?D1
           by auto
        qed
   next
      show "?C2 \<longrightarrow> ?D2"
        proof
          assume h:" \<exists>y. next (addr p) = Ref y"
          from this obtain a where
           nap:"next (addr p) = Ref a" by auto
          from ass obtain y where pr:"p = Ref y" and
              "Ps \<noteq> []" and "y = hd Ps"  by auto
          from this have ht:"Ps = hd Ps # tl Ps" by simp
          from this and ass have
           c1: "List next (next (addr p)) (tl Ps)" and
            hs: "hd Ps \<notin> set (tl Ps)" by auto
          from  this and nap have "tl Ps \<noteq> []" and
           "hd (tl Ps) = a" by auto
          from c1 and pr and  \<open>tl Ps \<noteq> []\<close> and ht and hs
           \<open>y=hd Ps\<close> and h show ?D2 by simp
        qed
   qed
next
  fix p "next" q tmp ps qs
  assume ass:"(\<exists>y. p = Ref y) \<and> List next p Ps \<and>
     List next q qs \<and> List (next(last ps := Null)) p ps \<and>
     ps @ qs = Ps \<and> set ps \<inter> set qs = {} \<and>
     next (last ps) = q \<and> last ps = addr tmp \<and>
     ps \<noteq> [] \<and> qs \<noteq> [] \<and> (\<exists>y. next (addr q) = Ref y)"
  show "List next (next (addr q)) (tl qs) \<and>
        List (next(hd qs := Null)) p (ps @ [hd qs]) \<and>
        hd qs \<notin> set (tl qs) \<and> set ps \<inter> set (tl qs) = {}
        \<and> next (hd qs) = next (addr q) \<and>
        hd qs = addr q \<and> tl qs \<noteq> []" (is "?Goal")
  proof -
    from ass have lqs:"List next q qs" "qs \<noteq> []"
      "(\<exists>y. next (addr q) = Ref y)" by auto
    from this obtain a where go:"next (addr q) = Ref a"
      "hd qs = addr q" "qs = hd qs # tl qs"
      "List next (next (addr q)) (tl qs)"
       by (metis List_def Path.simps(2) addr.simps hd_tl)
    from this(1) this(4) have "tl qs \<noteq> []" by auto
    from  go(2) go(4) have "hd qs \<notin> set (tl qs)" by simp
    from ass have spq:"set ps \<inter> set qs = {}"  by auto
    from this  \<open>qs\<noteq>[]\<close>  have spt:"set ps \<inter> set (tl qs) ={}"
         using list.set_sel(2) by fastforce
    from ass have lps:"List (next(last ps := Null)) p ps"
      "next (last ps) = q" by auto
    from spq go(3) \<open>qs\<noteq>[]\<close> have "hd qs \<notin> set ps" by auto
    from this go(3) lps have
     "List (next(hd qs := Null)) p (ps @ [hd qs])"
      by (metis List_app List_def Path.simps(2)
           Path_is_List ass)
    from this spt go \<open>tl qs \<noteq> []\<close> \<open>hd qs \<notin> set (tl qs)\<close>
      show ?Goal by simp
  qed
next
  fix p "next" q tmp ps qs
  assume ass:"(\<exists>y. p = Ref y) \<and> List next p Ps \<and>
    List next q qs \<and> List (next(last ps := Null)) p ps
    \<and> ps @ qs = Ps \<and> set ps \<inter> set qs = {}
    \<and> next (last ps) = q \<and> last ps = addr tmp
    \<and> ps \<noteq> [] \<and> qs \<noteq> [] \<and> next (addr q) = Null"
  show "\<exists>a as.
          List (next(tmp \<rightarrow> Null)) p as \<and> as @ [a] = Ps"
   proof -
     from ass have lqs:"List next q qs" and "qs \<noteq> []"
       and nq:"next (addr q) = Null" and
      lps: "List (next(last ps := Null)) p ps"
     and pq: "ps @ qs = Ps" and
        tmp:"last ps = addr tmp" by auto
     from this(1-2) obtain a as where "q=Ref a" and
       qs:"qs = a # as" and "List next (next a) as"
       by (induction qs) simp_all
     from this(3) and nq and \<open>q=Ref a\<close>
        have "as = []" by simp
     from pq and this and qs have "ps @ [a] = Ps" by simp
     from lps and this and tmp  show ?thesis
       by auto
   qed
qed

lemma "VARS p next q tmp  ps qs
{List next p Ps  \<and> p \<noteq> Null}
IF p^.next = Null
  \<comment> \<open>Ps has exactly one element\<close>
  THEN p:= Null;ps:=[];qs:=Ps
ELSE
  \<comment> \<open>Ps has at least two elements \<close>
  tmp := p; q:= p^.next;
  ps :=[hd Ps]; qs := tl Ps;
  WHILE q^.next \<noteq> Null
  INV  {p \<noteq> Null \<and> List next p Ps
        \<and> List next q qs
        \<and> List (next(last ps := Null)) p ps
        \<and> ps @ qs = Ps
        \<and> set ps \<inter> set qs = {}
        \<and> next (last ps) = q
        \<and> last ps = addr tmp
        \<and> ps \<noteq> [] \<and> qs \<noteq> []
       }
  DO
     tmp := q;  ps := ps @ [hd qs];
     q:= q^.next; qs := tl qs
  OD;
  tmp^.next := Null
FI
{\<exists> a. List next p ps \<and> ps @ [a]  = Ps}"
apply (vcg_simp)
apply (intro conjI)
   apply auto[1]
   apply (metis List_Ref List_hd_not_in_tl addr.simps list.discI
    list.sel(1) list.sel(3))
apply (intro conjI)
   apply (metis List_def Path.simps(2) addr.simps list.collapse)
   apply (metis List_app List_def Path.simps(2) Path_is_List
         disjoint_iff_not_equal hd_Cons_tl hd_in_set)
   apply (metis List_distinct distinct.simps(2) list.collapse)
   apply (simp add: disjoint_iff_not_equal list.set_sel(2))
   apply (metis List_def Path.simps(2) addr.simps list.collapse)
   apply (metis List_def Path.simps(2) addr.simps list.collapse)
   apply (metis List_def Path.simps(1) Path.simps(2) addr.simps
          list.collapse ref.distinct(1))
apply (metis List_unique Path.simps(1) Path_is_List
       addr.simps append.left_neutral empty_iff empty_set
       fun_upd_triv not_Ref_eq self_append_conv)
done

lemma "VARS p next q tmp  ps qs
{List next p Ps  \<and> p \<noteq> Null}
IF p^.next = Null
  \<comment> \<open>Ps has exactly one element\<close>
  THEN p:= Null;ps:=[];qs:=Ps
ELSE
  \<comment> \<open>Ps has at least two elements \<close>
  tmp := p; q:= p^.next;
  ps :=[hd Ps]; qs := tl Ps;
  WHILE q^.next \<noteq> Null
  INV  {p \<noteq> Null \<and> List next p Ps
        \<and> List next q qs
        \<and> List (next(last ps := Null)) p ps
        \<and> ps @ qs = Ps
        \<and> set ps \<inter> set qs = {}
        \<and> next (last ps) = q
        \<and> last ps = addr tmp
        \<and> ps \<noteq> [] \<and> qs \<noteq> []
       }
  DO
     tmp := q;  ps := ps @ [hd qs];
     q:= q^.next; qs := tl qs
  OD;
  tmp^.next := Null
FI
{List next p ps \<and> ps @ qs  = Ps \<and> length qs = 1}"
apply (vcg_simp)
apply (intro conjI)
  using Suc_length_conv apply auto[1]
  apply (metis List_Ref List_hd_not_in_tl addr.simps list.discI
    list.sel(1) list.sel(3))
apply (intro conjI)
  apply (metis List_def Path.simps(2) addr.simps list.collapse)
  apply (metis List_app List_def Path.simps(2) Path_is_List
     disjoint_iff_not_equal hd_Cons_tl hd_in_set)
  apply (metis List_distinct distinct.simps(2) list.collapse)
  apply (simp add: disjoint_iff_not_equal list.set_sel(2))
  apply (metis List_def Path.simps(2) addr.simps list.collapse)
  apply (metis List_def Path.simps(2) addr.simps list.collapse)
  apply (metis List_def Path.simps(1) Path.simps(2) addr.simps
   list.collapse ref.distinct(1))
apply (metis List_Ref List_def Path.simps(1) Path.simps(2)
     addr.simps length_Cons list.size(3) neq_Nil_conv)
done

\<comment> \<open>double-linked lists\<close>

end


header {* Union-Find Data-Structure *}
theory Union_Find
imports
  "../Sep_Main"
  "../../Collections/Lib/Partial_Equivalence_Relation"
  "~~/src/HOL/Library/Code_Target_Numeral"
begin
text {*
  We implement a simple union-find data-structure based on an array.
  It uses path compression and a size-based union heuristics.
*}

subsection {* Abstract Union-Find on Lists *}
text {*
  We first formulate union-find structures on lists, and later implement
  them using Imperative/HOL. This is a separation of proof concerns
  between proving the algorithmic idea correct and generating the verification
  conditions.
*}

subsubsection {* Representatives *}
text {*
  We define a function that searches for the representative of an element.
  This function is only partially defined, as it does not terminate on all
  lists. We use the domain of this function to characterize valid union-find
  lists.
*}
function (domintros) rep_of
  where "rep_of l i = (if l!i = i then i else rep_of l (l!i))"
  by pat_completeness auto

text {* A valid union-find structure only contains valid indexes, and
  the @{text "rep_of"} function terminates for all indexes. *}
definition
  "ufa_invar l \<equiv> \<forall>i<length l. rep_of_dom (l,i) \<and> l!i<length l"

lemma ufa_invarD:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of_dom (l,i)"
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> l!i<length l"
  unfolding ufa_invar_def by auto

text {* We derive the following equations for the @{text "rep-of"} function. *}
lemma rep_of_refl: "l!i=i \<Longrightarrow> rep_of l i = i"
  apply (subst rep_of.psimps)
  apply (rule rep_of.domintros)
  apply (auto)
  done

lemma rep_of_step:
  "\<lbrakk>ufa_invar l; i<length l; l!i\<noteq>i\<rbrakk> \<Longrightarrow> rep_of l i = rep_of l (l!i)"
  apply (subst rep_of.psimps)
  apply (auto dest: ufa_invarD)
  done

lemmas rep_of_simps = rep_of_refl rep_of_step

lemma rep_of_iff: "\<lbrakk>ufa_invar l; i<length l\<rbrakk>
  \<Longrightarrow> rep_of l i = (if l!i=i then i else rep_of l (l!i))"
  by (simp add: rep_of_simps)

text {* We derive a custom induction rule, that is more suited to
  our purposes. *}
lemma rep_of_induct[case_names base step, consumes 2]:
  assumes I: "ufa_invar l"
  assumes L: "i<length l"
  assumes BASE: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i=i \<rbrakk> \<Longrightarrow> P l i"
  assumes STEP: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i\<noteq>i; P l (l!i) \<rbrakk>
    \<Longrightarrow> P l i"
  shows "P l i"
proof -
  from ufa_invarD[OF I L] have "ufa_invar l \<and> i<length l \<longrightarrow> P l i"
    apply (induct l\<equiv>l i rule: rep_of.pinduct)
    apply (auto intro: STEP BASE dest: ufa_invarD)
    done
  thus ?thesis using I L by simp
qed

text {* In the following, we define various properties of @{text "rep_of"}. *}
lemma rep_of_min:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
proof -
  have "\<lbrakk>rep_of_dom (l,i) \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    apply (induct arbitrary:  rule: rep_of.pinduct)
    apply (subst rep_of.psimps, assumption)
    apply (subst (2) rep_of.psimps, assumption)
    apply auto
    done
  thus "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    by (metis ufa_invarD(1))
qed

lemma rep_of_bound:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l i < length l"
  apply (induct rule: rep_of_induct)
  apply (auto simp: rep_of_iff)
  done

lemma rep_of_idem:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l (rep_of l i) = rep_of l i"
  by (auto simp: rep_of_min rep_of_refl)

lemma rep_of_min_upd: "\<lbrakk> ufa_invar l; x<length l; i<length l \<rbrakk> \<Longrightarrow>
  rep_of (l[rep_of l x := rep_of l x]) i = rep_of l i"
  by (metis list_update_id rep_of_min)

lemma rep_of_idx:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of l (l!i) = rep_of l i"
  by (metis rep_of_step)

subsubsection {* Abstraction to Partial Equivalence Relation *}
definition ufa_\<alpha> :: "nat list \<Rightarrow> (nat\<times>nat) set"
  where "ufa_\<alpha> l
    \<equiv> {(x,y). x<length l \<and> y<length l \<and> rep_of l x = rep_of l y}"

lemma ufa_\<alpha>_equiv[simp, intro!]: "part_equiv (ufa_\<alpha> l)"
  apply rule
  unfolding ufa_\<alpha>_def
  apply (rule symI)
  apply auto
  apply (rule transI)
  apply auto
  done

lemma ufa_\<alpha>_lenD:
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> x<length l"
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> y<length l"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_dom[simp]: "Domain (ufa_\<alpha> l) = {0..<length l}"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_refl[simp]: "(i,i)\<in>ufa_\<alpha> l \<longleftrightarrow> i<length l"
  unfolding ufa_\<alpha>_def
  by simp

lemma ufa_\<alpha>_len_eq:
  assumes "ufa_\<alpha> l = ufa_\<alpha> l'"
  shows "length l = length l'"
  by (metis assms le_antisym less_not_refl linorder_le_less_linear ufa_\<alpha>_refl)

subsubsection {* Operations *}
lemma ufa_init_invar: "ufa_invar [0..<n]"
  unfolding ufa_invar_def
  by (auto intro: rep_of.domintros)

lemma ufa_init_correct: "ufa_\<alpha> [0..<n] = {(x,x) | x. x<n}"
  unfolding ufa_\<alpha>_def
  using ufa_init_invar[of n]
  apply (auto simp: rep_of_refl)
  done

lemma ufa_find_correct: "\<lbrakk>ufa_invar l; x<length l; y<length l\<rbrakk>
  \<Longrightarrow> rep_of l x = rep_of l y \<longleftrightarrow> (x,y)\<in>ufa_\<alpha> l"
  unfolding ufa_\<alpha>_def
  by auto

abbreviation "ufa_union l x y \<equiv> l[rep_of l x := rep_of l y]"

lemma ufa_union_invar:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  shows "ufa_invar (ufa_union l x y)"
  unfolding ufa_invar_def
proof (intro allI impI, simp only: length_list_update)
  fix i
  assume A: "i<length l"
  with I have "rep_of_dom (l,i)" by (auto dest: ufa_invarD)

  have "ufa_union l x y ! i < length l" using I L A
    apply (cases "i=rep_of l x")
    apply (auto simp: rep_of_bound dest: ufa_invarD)
    done
  moreover have "rep_of_dom (ufa_union l x y, i)" using I A L
  proof (induct rule: rep_of_induct)
    case (base i)
    thus ?case
      apply -
      apply (rule rep_of.domintros)
      apply (cases "i=rep_of l x")
      apply auto
      apply (rule rep_of.domintros)
      apply (auto simp: rep_of_min)
      done
  next
    case (step i)

    from step.prems `ufa_invar l` `i<length l` `l!i\<noteq>i`
    have [simp]: "ufa_union l x y ! i = l!i"
      apply (auto simp: rep_of_min rep_of_bound nth_list_update)
      done

    from step show ?case
      apply -
      apply (rule rep_of.domintros)
      apply simp
      done
  qed
  ultimately show
    "rep_of_dom (ufa_union l x y, i) \<and> ufa_union l x y ! i < length l"
    by blast

qed

lemma ufa_union_aux:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  assumes IL: "i<length l"
  shows "rep_of (ufa_union l x y) i =
    (if rep_of l i = rep_of l x then rep_of l y else rep_of l i)"
  using I IL
proof (induct rule: rep_of_induct)
  case (base i)
  have [simp]: "rep_of l i = i" using `l!i=i` by (simp add: rep_of_refl)
  note [simp] = `ufa_invar l` `i<length l`
  show ?case proof (cases)
    assume A[simp]: "rep_of l x = i"
    have [simp]: "l[i := rep_of l y] ! i = rep_of l y"
      by (auto simp: rep_of_bound)

    show ?thesis proof (cases)
      assume [simp]: "rep_of l y = i"
      show ?thesis by (simp add: rep_of_refl)
    next
      assume A: "rep_of l y \<noteq> i"
      have [simp]: "rep_of (l[i := rep_of l y]) i = rep_of l y"
        apply (subst rep_of_step[OF ufa_union_invar[OF I L], simplified])
        using A apply simp_all
        apply (subst rep_of_refl[where i="rep_of l y"])
        using I L
        apply (simp_all add: rep_of_min)
        done
      show ?thesis by (simp add: rep_of_refl)
    qed
  next
    assume A: "rep_of l x \<noteq> i"
    hence "ufa_union l x y ! i = l!i" by (auto)
    also note `l!i=i`
    finally have "rep_of (ufa_union l x y) i = i" by (simp add: rep_of_refl)
    thus ?thesis using A by auto
  qed
next
  case (step i)

  note [simp] = I L `i<length l`

  have "rep_of l x \<noteq> i" by (metis I L(1) rep_of_min `l!i\<noteq>i`)
  hence [simp]: "ufa_union l x y ! i = l!i"
    by (auto simp add: nth_list_update rep_of_bound `l!i\<noteq>i`) []

  have "rep_of (ufa_union l x y) i = rep_of (ufa_union l x y) (l!i)"
    by (auto simp add: rep_of_iff[OF ufa_union_invar[OF I L]])
  also note step.hyps(4)
  finally show ?case
    by (auto simp: rep_of_idx)
qed

lemma ufa_union_correct: "\<lbrakk> ufa_invar l; x<length l; y<length l \<rbrakk>
  \<Longrightarrow> ufa_\<alpha> (ufa_union l x y) = per_union (ufa_\<alpha> l) x y"
  unfolding ufa_\<alpha>_def per_union_def
  by (auto simp: ufa_union_aux
    split: split_if_asm
  )

lemma ufa_compress_aux:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  and "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
proof -
  {
    fix i
    assume "i<length (l[x := rep_of l x])"
    hence IL: "i<length l" by simp

    have G1: "l[x := rep_of l x] ! i < length (l[x := rep_of l x])"
      using I IL
      by (auto dest: ufa_invarD[OF I] simp: nth_list_update rep_of_bound)
    from I IL have G2: "rep_of (l[x := rep_of l x]) i = rep_of l i
      \<and> rep_of_dom (l[x := rep_of l x], i)"
    proof (induct rule: rep_of_induct)
      case (base i)
      thus ?case
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_refl)
        done
    next
      case (step i)
      hence D: "rep_of_dom (l[x := rep_of l x], i)"
        apply -
        apply (rule rep_of.domintros)
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done

      thus ?case apply simp using step
        apply -
        apply (subst rep_of.psimps[OF D])
        apply (cases "x=i")
        apply (auto simp: rep_of_min rep_of_idx)
        apply (subst rep_of.psimps[where i="rep_of l i"])
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done
    qed
    note G1 G2
  } note G=this

  thus "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
    by auto

  from G show "ufa_invar (l[x := rep_of l x])"
    by (auto simp: ufa_invar_def)
qed

lemma ufa_compress_invar:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  using assms by (rule ufa_compress_aux)

lemma ufa_compress_correct:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_\<alpha> (l[x := rep_of l x]) = ufa_\<alpha> l"
  by (auto simp: ufa_\<alpha>_def ufa_compress_aux[OF I])

subsection {* Implementation with Imperative/HOL *}
text {* In this section, we implement the union-find data-structure with
  two arrays, one holding the next-pointers, and another one holding the size
  information. Note that we do not prove that the array for the
  size information contains any reasonable values, as the correctness of the
  algorithm is not affected by this. We leave it future work to also estimate
  the complexity of the algorithm.
*}

type_synonym uf = "nat array \<times> nat array"

definition is_uf :: "(nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn" where
  "is_uf R u \<equiv> case u of (s,p) \<Rightarrow>
  \<exists>\<^sub>Al szl. p\<mapsto>\<^sub>al * s\<mapsto>\<^sub>aszl
    * \<up>(ufa_invar l \<and> ufa_\<alpha> l = R \<and> length szl = length l)"

definition uf_init :: "nat \<Rightarrow> uf Heap" where
  "uf_init n \<equiv> do {
    l \<leftarrow> Array.of_list [0..<n];
    szl \<leftarrow> Array.new n (1::nat);
    return (szl,l)
  }"

lemma uf_init_rule[sep_heap_rules]:
  "<emp> uf_init n <is_uf {(i,i) |i. i<n}>"
  unfolding uf_init_def is_uf_def[abs_def]
  by (sep_auto simp: ufa_init_correct ufa_init_invar)

partial_function (heap) uf_rep_of :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where [code]:
  "uf_rep_of p i = do {
    n \<leftarrow> Array.nth p i;
    if n=i then return i else uf_rep_of p n
  }"

lemma uf_rep_of_rule[sep_heap_rules]: "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al> uf_rep_of p i <\<lambda>r. p\<mapsto>\<^sub>al * \<up>(r=rep_of l i)>"
  apply (induct rule: rep_of_induct)
  apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_refl)

  apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_step)
  done

text {* We chose a non tail-recursive version here, as it is easier to prove. *}
partial_function (heap) uf_compress :: "nat \<Rightarrow> nat \<Rightarrow> nat array \<Rightarrow> unit Heap"
  where [code]:
  "uf_compress i ci p = (
    if i=ci then return ()
    else do {
      ni\<leftarrow>Array.nth p i;
      uf_compress ni ci p;
      Array.upd i ci p;
      return ()
    })"

lemma uf_compress_rule: "\<lbrakk> ufa_invar l; i<length l; ci=rep_of l i \<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al> uf_compress i ci p
  <\<lambda>_. \<exists>\<^sub>Al'. p\<mapsto>\<^sub>al' * \<up>(ufa_invar l' \<and> length l' = length l
     \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>"
proof (induction rule: rep_of_induct)
  case (base i) thus ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: rep_of_refl)
    done
next
  case (step i)
  note SS = `ufa_invar l` `i<length l` `l!i\<noteq>i` `ci = rep_of l i`

  from step.IH
  have IH':
    "<p \<mapsto>\<^sub>a l>
       uf_compress (l ! i) (rep_of l i) p
     <\<lambda>_. \<exists>\<^sub>Al'. p \<mapsto>\<^sub>a l' *
        \<up> (ufa_invar l' \<and> length l = length l'
           \<and> (\<forall>i<length l'. rep_of l i = rep_of l' i))
     >"
    apply (simp add: rep_of_idx SS)
    apply (erule
      back_subst[OF _ cong[OF cong[OF arg_cong[where f=hoare_triple]]]])
    apply (auto) [2]
    apply (rule ext)
    apply (rule ent_iffI)
    apply sep_auto+
    done

  show ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: SS)

    apply (rule IH')

    using SS apply (sep_auto (plain))
    using ufa_compress_invar apply fastforce []
    apply simp
    using ufa_compress_aux(2) apply fastforce []
    done
qed

definition uf_rep_of_c :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where "uf_rep_of_c p i \<equiv> do {
    ci\<leftarrow>uf_rep_of p i;
    uf_compress i ci p;
    return ci
  }"

lemma uf_rep_of_c_rule[sep_heap_rules]: "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al> uf_rep_of_c p i <\<lambda>r. \<exists>\<^sub>Al'. p\<mapsto>\<^sub>al'
    * \<up>(r=rep_of l i \<and> ufa_invar l'
       \<and> length l' = length l
       \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>"
  unfolding uf_rep_of_c_def
  by (sep_auto heap: uf_compress_rule)

definition uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap" where
  "uf_cmp u i j \<equiv> do {
    let (s,p)=u;
    n\<leftarrow>Array.len p;
    if (i\<ge>n \<or> j\<ge>n) then return False
    else do {
      ci\<leftarrow>uf_rep_of_c p i;
      cj\<leftarrow>uf_rep_of_c p j;
      return (ci=cj)
    }
  }"

lemma cnv_to_ufa_\<alpha>_eq:
  "\<lbrakk>(\<forall>i<length l. rep_of l' i = rep_of l i); length l = length l'\<rbrakk>
  \<Longrightarrow> (ufa_\<alpha> l = ufa_\<alpha> l')"
  unfolding ufa_\<alpha>_def by auto

lemma uf_cmp_rule[sep_heap_rules]:
  "<is_uf R u> uf_cmp u i j <\<lambda>r. is_uf R u * \<up>(r\<longleftrightarrow>(i,j)\<in>R)>"
  unfolding uf_cmp_def is_uf_def
  apply (sep_auto dest: ufa_\<alpha>_lenD simp: not_le split: prod.split)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (subst ufa_find_correct)
  apply (auto simp add: )
  done

definition uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap" where
  "uf_union u i j \<equiv> do {
    let (s,p)=u;
    ci \<leftarrow> uf_rep_of p i;
    cj \<leftarrow> uf_rep_of p j;
    if (ci=cj) then return (s,p)
    else do {
      si \<leftarrow> Array.nth s ci;
      sj \<leftarrow> Array.nth s cj;
      if si<sj then do {
        Array.upd ci cj p;
        Array.upd cj (si+sj) s;
        return (s,p)
      } else do {
        Array.upd cj ci p;
        Array.upd ci (si+sj) s;
        return (s,p)
      }
    }
  }"

lemma uf_union_rule[sep_heap_rules]: "\<lbrakk>i\<in>Domain R; j\<in> Domain R\<rbrakk>
  \<Longrightarrow> <is_uf R u> uf_union u i j <is_uf (per_union R i j)>"
  unfolding uf_union_def
  apply (cases u)
  apply (simp add: is_uf_def[abs_def])
  apply (sep_auto
    simp: per_union_cmp ufa_\<alpha>_lenD ufa_find_correct
    rep_of_bound
    ufa_union_invar
    ufa_union_correct
  )
  done

export_code uf_init uf_cmp uf_union checking SML_imp

export_code uf_init uf_cmp uf_union checking Scala_imp

(*
ML_val {*
  val u = @{code uf_init} 10 ();

  val u = @{code uf_union} u 1 2 ();
  val u = @{code uf_union} u 3 4 ();
  val u = @{code uf_union} u 5 6 ();
  val u = @{code uf_union} u 7 8 ();

  val u = @{code uf_union} u 1 3 ();
  val u = @{code uf_union} u 5 7 ();

  val u = @{code uf_union} u 1 5 ();

  val b = @{code uf_cmp} u 8 4 ();
  val it = u;
*}*)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_NStoogeSort2Sorts
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function twoThirds :: "Nat => Nat" where
  "twoThirds y =
   (if (y = (S (S Z))) then S Z else
      (if (y = (S Z)) then S Z else
         (case y of
            Z => Z
            | S z => plus (S (S Z)) (twoThirds (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((le z y2) & (ordered (cons2 y2 xs)))"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "Nat list => Nat list"
  and nstoogesort2 :: "Nat list => Nat list"
  and nstooge2sort1 :: "Nat list => Nat list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "ordered (nstoogesort2 xs)"
  oops

end


(*  Title:      FOL/ex/Nat_Class.thy
    Author:     Markus Wenzel, TU Muenchen
*)

theory Nat_Class
imports FOL
begin

text {*
  This is an abstract version of theory @{text Nat}. Instead of
  axiomatizing a single type @{text nat} we define the class of all
  these types (up to isomorphism).

  Note: The @{text rec} operator had to be made \emph{monomorphic},
  because class axioms may not contain more than one type variable.
*}

class nat =
  fixes Zero :: 'a  ("0")
    and Suc :: "'a \<Rightarrow> 'a"
    and rec :: "'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a"
  assumes induct: "P(0) \<Longrightarrow> (\<And>x. P(x) \<Longrightarrow> P(Suc(x))) \<Longrightarrow> P(n)"
    and Suc_inject: "Suc(m) = Suc(n) \<Longrightarrow> m = n"
    and Suc_neq_Zero: "Suc(m) = 0 \<Longrightarrow> R"
    and rec_Zero: "rec(0, a, f) = a"
    and rec_Suc: "rec(Suc(m), a, f) = f(m, rec(m, a, f))"
begin

definition add :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "+" 60)
  where "m + n = rec(m, n, \<lambda>x y. Suc(y))"

lemma Suc_n_not_n: "Suc(k) \<noteq> (k::'a)"
  apply (rule_tac n = k in induct)
   apply (rule notI)
   apply (erule Suc_neq_Zero)
  apply (rule notI)
  apply (erule notE)
  apply (erule Suc_inject)
  done

lemma "(k + m) + n = k + (m + n)"
  apply (rule induct)
  back
  back
  back
  back
  back
  oops

lemma add_Zero [simp]: "0 + n = n"
  apply (unfold add_def)
  apply (rule rec_Zero)
  done

lemma add_Suc [simp]: "Suc(m) + n = Suc(m + n)"
  apply (unfold add_def)
  apply (rule rec_Suc)
  done

lemma add_Zero_right: "m + 0 = m"
  apply (rule_tac n = m in induct)
   apply simp
  apply simp
  done

lemma add_Suc_right: "m + Suc(n) = Suc(m + n)"
  apply (rule_tac n = m in induct)
   apply simp_all
  done

lemma
  assumes prem: "\<And>n. f(Suc(n)) = Suc(f(n))"
  shows "f(i + j) = i + f(j)"
  apply (rule_tac n = i in induct)
   apply simp
  apply (simp add: prem)
  done

end

end


theory Smap_laws
  imports Main "$HIPSTER_HOME/IsaHipster"
    "../itp2018/types/Stream"
begin
setup Tactic_Data.set_coinduct_sledgehammer
primcorec smap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap f xs = SCons (f (shd xs)) (smap f (stl xs))"
(*cohipster smap*)
lemma lemma_a [thy_expl]: "SCons (y z) (smap y x2) = smap y (SCons z x2)"
  by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    simp
(*cohipster smap Fun.id*)  \<comment> "Explore smap and identity funtcion"

(*cohipster smap Fun.comp*) \<comment> "Explore smap and function composition"
text_raw \<open>\DefineSnippet{smaplaws}{\<close>

lemma lemma_aa [thy_expl]: "smap id y = y"
 by (coinduction arbitrary: y rule: Stream.Stream.coinduct_strong)
    simp

lemma lemma_ab [thy_expl]: "smap (y \<circ> z) x2 = smap y (smap z x2)"
 by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    auto
text_raw \<open>}%EndSnippet\<close>

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_42
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = nil2"
| "take (S z) (nil2) = nil2"
| "take (S z) (cons2 x2 x3) = cons2 x2 (take z x3)"

theorem property0 :
  "((take (S n) (cons2 x xs)) = (cons2 x (take n xs)))"
  find_proof DInd
  apply (induct)
   apply auto
  done

theorem property0' :
  "((take (S n) (cons2 x xs)) = (cons2 x (take n xs)))"
  apply (induct n)
   apply auto
  done

end


theory ConcreteSemantics10_1_Def_Init_Big
  imports Main "~~/src/HOL/IMP/Def_Init_Exp"  "~~/src/HOL/IMP/Def_Init"
begin

subsection "Initialization-Sensitive Big Step Semantics"

inductive
  big_step :: "(com \<times> state option) \<Rightarrow> state option \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
None: "(c,None) \<Rightarrow> None" |
Skip: "(SKIP,s) \<Rightarrow> s" |
AssignNone: "aval a s = None \<Longrightarrow> (x ::= a, Some s) \<Rightarrow> None" |
Assign: "aval a s = Some i \<Longrightarrow> (x ::= a, Some s) \<Rightarrow> Some(s(x := Some i))" |
Seq:    "(c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2 \<Longrightarrow> (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s\<^sub>1) \<Rightarrow> s\<^sub>3" |

IfNone:  "bval b s = None \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,Some s) \<Rightarrow> None" |
IfTrue:  "\<lbrakk> bval b s = Some True;  (c\<^sub>1,Some s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow>
  (IF b THEN c\<^sub>1 ELSE c\<^sub>2,Some s) \<Rightarrow> s'" |
IfFalse: "\<lbrakk> bval b s = Some False;  (c\<^sub>2,Some s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow>
  (IF b THEN c\<^sub>1 ELSE c\<^sub>2,Some s) \<Rightarrow> s'" |

WhileNone: "bval b s = None \<Longrightarrow> (WHILE b DO c,Some s) \<Rightarrow> None" |
WhileFalse: "bval b s = Some False \<Longrightarrow> (WHILE b DO c,Some s) \<Rightarrow> Some s" |
WhileTrue:
  "\<lbrakk> bval b s = Some True;  (c,Some s) \<Rightarrow> s';  (WHILE b DO c,s') \<Rightarrow> s'' \<rbrakk> \<Longrightarrow>
  (WHILE b DO c,Some s) \<Rightarrow> s''"

lemmas big_step_induct = big_step.induct[split_format(complete)]

subsection "Soundness wrt Big Steps"

text\<open>Note the special form of the induction because one of the arguments
of the inductive predicate is not a variable but the term \<^term>\<open>Some s\<close>:\<close>

(* Lemma 10.5 (Soundness of D). *)
theorem Sound:
  "\<lbrakk> (c,Some s) \<Rightarrow> s';  D A c A';  A \<subseteq> dom s \<rbrakk>
  \<Longrightarrow> \<exists> t. s' = Some t \<and> A' \<subseteq> dom t"
proof (induction c "Some s" s' arbitrary: s A A' rule:big_step_induct)
(* I failed to show the case of None *)
(*  case None
  then show ?case sorry
next*)
  case Skip
  then show ?case by fastforce
next
  case (AssignNone a s x)
  then show ?case
    by auto (metis aval_Some option.simps(3) subset_trans)
next
  case (Assign a s i x)
  then show ?case by auto
next
  case (Seq c\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by auto metis
next
  case (IfNone b s c\<^sub>1 c\<^sub>2)
  then show ?case
    by auto (metis bval_Some option.simps(3) order_trans)
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
  then show ?case by auto blast
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  then show ?case by auto blast
next
  case (WhileNone b s c)
  then show ?case
    by auto (metis bval_Some option.simps(3) order_trans)
next
  case (WhileFalse b s c)
  then show ?case by auto
next
  case (WhileTrue b s c s' s'')
  from \<open>D A (WHILE b DO c) A'\<close> obtain A' where "D A c A'" by blast
  then obtain t' where "s' = Some t'" "A \<subseteq> dom s"
    using WhileTrue.hyps(3) WhileTrue.prems(2) by blast
  then show ?case
    by (meson D_incr WhileTrue.hyps(3) WhileTrue.hyps(5) WhileTrue.prems(1) \<open>D A c A'\<close> dual_order.trans)
qed

end


theory SINVAR_BLPtrusted
imports "../TopoS_Helper"
begin

subsection \<open>SecurityInvariant Basic Bell LaPadula with trusted entities\<close>

type_synonym security_level = nat

record node_config =
    security_level::security_level
    trusted::bool

definition default_node_properties :: "node_config"
  where  "default_node_properties \<equiv> \<lparr> security_level = 0, trusted = False \<rparr>"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow>  bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (if trusted (nP e2) then True else security_level (nP e1) \<le> security_level (nP e2) ))"

text\<open>A simplified version of the Bell LaPadula model was presented in @{file \<open>SINVAR_BLPbasic.thy\<close>}.
In this theory, we extend this template with a notion of trust by adding a Boolean flag @{const trusted} to the host attributes.
This is a refinement to represent real-world scenarios more accurately and analogously happened to the
original Bell LaPadula model (see publication ``Looking Back at the Bell-La Padula Model''
A trusted host can receive information of any security level and may declassify it,
i.e. distribute the information with its own security level.
For example, a @{term "trusted (sc::node_config) = True"} host is allowed to receive any information
and with the @{term "0::security_level"} level, it is allowed to reveal it to anyone.
\<close>

definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto split: prod.split prod.split_asm)[6]
   apply(simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops split: prod.split prod.split_asm)[1]
   apply (metis prod.inject)
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma "a \<noteq> b \<Longrightarrow> ((\<exists> x. y x)) \<Longrightarrow> ((\<forall> x. \<not> y x) \<Longrightarrow> a = b )" by simp

lemma BLP_def_unique: "otherbot \<noteq> default_node_properties \<Longrightarrow>
    \<exists>G p i f. wf_graph G \<and> \<not> sinvar G p \<and> f \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G p) \<and>
       sinvar (delete_edges G f) p \<and>
         i \<in> snd ` f \<and> sinvar G (p(i := otherbot)) "
  apply(simp add:default_node_properties_def)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: prod.split_asm prod.split)
  apply(rule_tac x="\<lparr> nodes={vertex_1, vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: wf_graph_def)
  apply(rule_tac x="(\<lambda> x. default_node_properties)(vertex_1 := \<lparr>security_level = 1, trusted = False \<rparr>, vertex_2 := \<lparr>security_level = 0, trusted = False \<rparr>)" in exI, simp add:default_node_properties_def)
  apply(rule_tac x="vertex_2" in exI, simp)
  apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(case_tac otherbot)
  apply simp
  apply(erule disjE)
   apply force
  apply fast
  done

subsubsection \<open>ENF\<close>
  definition BLP_P where "BLP_P \<equiv> (\<lambda>n1 n2.(if trusted n2 then True else security_level n1 \<le> security_level n2 ))"
  lemma zero_default_candidate: "\<forall>nP e1 e2. \<not> BLP_P (nP e1) (nP e2) \<longrightarrow> \<not> BLP_P (nP e1) default_node_properties"
    apply(rule allI)+
    apply(case_tac "nP e1")
    apply(case_tac "nP e2")
    apply(rename_tac privacy2 trusted2 more2)
    apply (simp add: BLP_P_def default_node_properties_def)
    done
  lemma privacylevel_refl: "BLP_P e e"
    by(simp_all add: BLP_P_def)
  lemma BLP_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar BLP_P"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    unfolding BLP_P_def
    by simp
  lemma BLP_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar BLP_P"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: BLP_ENF)
    apply(simp add: privacylevel_refl)
  done

  definition BLP_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) set set" where
  "BLP_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> \<not> BLP_P (nP e1) (nP e2)} })"
  lemma BLP_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF BLP_ENF] BLP_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation BLPtrusted: SecurityInvariant_IFS
  where default_node_properties = default_node_properties
  and sinvar = sinvar
  rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply unfold_locales
      apply(rule ballI)
      apply (rule_tac f=f in SecurityInvariant_withOffendingFlows.ENF_snds_refl_instance[OF BLP_ENF_refl zero_default_candidate])
       apply(simp)
      apply(simp)
     apply(erule default_uniqueness_by_counterexample_IFS)
     apply(fact BLP_def_unique)
    apply(fact BLP_offending_set)
   done

  lemma TopoS_BLPtrusted: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_type (open) node_config
hide_const (open) sinvar_mono

hide_const (open) BLP_P
hide_fact BLP_def_unique zero_default_candidate  privacylevel_refl BLP_ENF BLP_ENF_refl

hide_const (open) sinvar receiver_violation default_node_properties

end


theory list_SelectPermutations
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

fun select2 :: "'a => (('a, ('a list)) Pair2) list =>
                (('a, ('a list)) Pair2) list" where
"select2 x (Nil2) = Nil2"
| "select2 x (Cons2 (Pair y2 ys) x2) =
     Cons2 (Pair y2 (Cons2 x ys)) (select2 x x2)"

fun select :: "'a list => (('a, ('a list)) Pair2) list" where
"select (Nil2) = Nil2"
| "select (Cons2 y xs) = Cons2 (Pair y xs) (select2 y (select xs))"

fun propSelectPermutations :: "((int, (int list)) Pair2) list =>
                               (int list) list" where
"propSelectPermutations (Nil2) = Nil2"
| "propSelectPermutations (Cons2 (Pair y2 ys) z) =
     Cons2 (Cons2 y2 ys) (propSelectPermutations z)"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "int list => int list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

fun all :: "('t => bool) => 't list => bool" where
"all x (Nil2) = True"
| "all x (Cons2 z xs) = and2 (x z) (all x xs)"

(*hipster select2
          select
          propSelectPermutations
          or2
          null
          elem
          delete
          and2
          isPermutation
          all *)

theorem x0 :
  "!! (xs :: int list) .
     all
       (% (x :: int list) => isPermutation x xs)
       (propSelectPermutations (select xs))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory ExF002
imports Main
begin

lemma "\<lbrakk> \<forall>x.(P x \<longrightarrow> Q x) ; P a \<rbrakk> \<Longrightarrow> Q a"
proof -
assume "\<forall>x.(P x \<longrightarrow> Q x)"
assume "P a"
from \<open>\<forall>x.(P x \<longrightarrow> Q x)\<close> have "P a \<longrightarrow> Q a" by (rule allE)
from this and  \<open>P a\<close> show ?thesis by (rule impE)
qed


theory Ordered_Euclidean_Space
imports
  Cartesian_Euclidean_Space
  "~~/src/HOL/Library/Product_Order"
begin

subsection \<open>An ordering on euclidean spaces that will allow us to talk about intervals\<close>

class ordered_euclidean_space = ord + inf + sup + abs + Inf + Sup + euclidean_space +
  assumes eucl_le: "x \<le> y \<longleftrightarrow> (\<forall>i\<in>Basis. x \<bullet> i \<le> y \<bullet> i)"
  assumes eucl_less_le_not_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
  assumes eucl_inf: "inf x y = (\<Sum>i\<in>Basis. inf (x \<bullet> i) (y \<bullet> i) *\<^sub>R i)"
  assumes eucl_sup: "sup x y = (\<Sum>i\<in>Basis. sup (x \<bullet> i) (y \<bullet> i) *\<^sub>R i)"
  assumes eucl_Inf: "Inf X = (\<Sum>i\<in>Basis. (INF x:X. x \<bullet> i) *\<^sub>R i)"
  assumes eucl_Sup: "Sup X = (\<Sum>i\<in>Basis. (SUP x:X. x \<bullet> i) *\<^sub>R i)"
  assumes eucl_abs: "\<bar>x\<bar> = (\<Sum>i\<in>Basis. \<bar>x \<bullet> i\<bar> *\<^sub>R i)"
begin

subclass order
  by standard
    (auto simp: eucl_le eucl_less_le_not_le intro!: euclidean_eqI antisym intro: order.trans)

subclass ordered_ab_group_add_abs
  by standard (auto simp: eucl_le inner_add_left eucl_abs abs_leI)

subclass ordered_real_vector
  by standard (auto simp: eucl_le intro!: mult_left_mono mult_right_mono)

subclass lattice
  by standard (auto simp: eucl_inf eucl_sup eucl_le)

subclass distrib_lattice
  by standard (auto simp: eucl_inf eucl_sup sup_inf_distrib1 intro!: euclidean_eqI)

subclass conditionally_complete_lattice
proof
  fix z::'a and X::"'a set"
  assume "X \<noteq> {}"
  hence "\<And>i. (\<lambda>x. x \<bullet> i) ` X \<noteq> {}" by simp
  thus "(\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> Inf X" "(\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X \<le> z"
    by (auto simp: eucl_Inf eucl_Sup eucl_le
      intro!: cInf_greatest cSup_least)
qed (force intro!: cInf_lower cSup_upper
      simp: bdd_below_def bdd_above_def preorder_class.bdd_below_def preorder_class.bdd_above_def
        eucl_Inf eucl_Sup eucl_le)+

lemma inner_Basis_inf_left: "i \<in> Basis \<Longrightarrow> inf x y \<bullet> i = inf (x \<bullet> i) (y \<bullet> i)"
  and inner_Basis_sup_left: "i \<in> Basis \<Longrightarrow> sup x y \<bullet> i = sup (x \<bullet> i) (y \<bullet> i)"
  by (simp_all add: eucl_inf eucl_sup inner_sum_left inner_Basis if_distrib comm_monoid_add_class.sum.delta
      cong: if_cong)

lemma inner_Basis_INF_left: "i \<in> Basis \<Longrightarrow> (INF x:X. f x) \<bullet> i = (INF x:X. f x \<bullet> i)"
  and inner_Basis_SUP_left: "i \<in> Basis \<Longrightarrow> (SUP x:X. f x) \<bullet> i = (SUP x:X. f x \<bullet> i)"
  using eucl_Sup [of "f ` X"] eucl_Inf [of "f ` X"] by (simp_all add: comp_def)

lemma abs_inner: "i \<in> Basis \<Longrightarrow> \<bar>x\<bar> \<bullet> i = \<bar>x \<bullet> i\<bar>"
  by (auto simp: eucl_abs)

lemma
  abs_scaleR: "\<bar>a *\<^sub>R b\<bar> = \<bar>a\<bar> *\<^sub>R \<bar>b\<bar>"
  by (auto simp: eucl_abs abs_mult intro!: euclidean_eqI)

lemma interval_inner_leI:
  assumes "x \<in> {a .. b}" "0 \<le> i"
  shows "a\<bullet>i \<le> x\<bullet>i" "x\<bullet>i \<le> b\<bullet>i"
  using assms
  unfolding euclidean_inner[of a i] euclidean_inner[of x i] euclidean_inner[of b i]
  by (auto intro!: ordered_comm_monoid_add_class.sum_mono mult_right_mono simp: eucl_le)

lemma inner_nonneg_nonneg:
  shows "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> a \<bullet> b"
  using interval_inner_leI[of a 0 a b]
  by auto

lemma inner_Basis_mono:
  shows "a \<le> b \<Longrightarrow> c \<in> Basis  \<Longrightarrow> a \<bullet> c \<le> b \<bullet> c"
  by (simp add: eucl_le)

lemma Basis_nonneg[intro, simp]: "i \<in> Basis \<Longrightarrow> 0 \<le> i"
  by (auto simp: eucl_le inner_Basis)

lemma Sup_eq_maximum_componentwise:
  fixes s::"'a set"
  assumes i: "\<And>b. b \<in> Basis \<Longrightarrow> X \<bullet> b = i b \<bullet> b"
  assumes sup: "\<And>b x. b \<in> Basis \<Longrightarrow> x \<in> s \<Longrightarrow> x \<bullet> b \<le> X \<bullet> b"
  assumes i_s: "\<And>b. b \<in> Basis \<Longrightarrow> (i b \<bullet> b) \<in> (\<lambda>x. x \<bullet> b) ` s"
  shows "Sup s = X"
  using assms
  unfolding eucl_Sup euclidean_representation_sum
  by (auto intro!: conditionally_complete_lattice_class.cSup_eq_maximum)

lemma Inf_eq_minimum_componentwise:
  assumes i: "\<And>b. b \<in> Basis \<Longrightarrow> X \<bullet> b = i b \<bullet> b"
  assumes sup: "\<And>b x. b \<in> Basis \<Longrightarrow> x \<in> s \<Longrightarrow> X \<bullet> b \<le> x \<bullet> b"
  assumes i_s: "\<And>b. b \<in> Basis \<Longrightarrow> (i b \<bullet> b) \<in> (\<lambda>x. x \<bullet> b) ` s"
  shows "Inf s = X"
  using assms
  unfolding eucl_Inf euclidean_representation_sum
  by (auto intro!: conditionally_complete_lattice_class.cInf_eq_minimum)

end

lemma
  compact_attains_Inf_componentwise:
  fixes b::"'a::ordered_euclidean_space"
  assumes "b \<in> Basis" assumes "X \<noteq> {}" "compact X"
  obtains x where "x \<in> X" "x \<bullet> b = Inf X \<bullet> b" "\<And>y. y \<in> X \<Longrightarrow> x \<bullet> b \<le> y \<bullet> b"
proof atomize_elim
  let ?proj = "(\<lambda>x. x \<bullet> b) ` X"
  from assms have "compact ?proj" "?proj \<noteq> {}"
    by (auto intro!: compact_continuous_image continuous_intros)
  from compact_attains_inf[OF this]
  obtain s x
    where s: "s\<in>(\<lambda>x. x \<bullet> b) ` X" "\<And>t. t\<in>(\<lambda>x. x \<bullet> b) ` X \<Longrightarrow> s \<le> t"
      and x: "x \<in> X" "s = x \<bullet> b" "\<And>y. y \<in> X \<Longrightarrow> x \<bullet> b \<le> y \<bullet> b"
    by auto
  hence "Inf ?proj = x \<bullet> b"
    by (auto intro!: conditionally_complete_lattice_class.cInf_eq_minimum)
  hence "x \<bullet> b = Inf X \<bullet> b"
    by (auto simp: eucl_Inf inner_sum_left inner_Basis if_distrib \<open>b \<in> Basis\<close> sum.delta
      cong: if_cong)
  with x show "\<exists>x. x \<in> X \<and> x \<bullet> b = Inf X \<bullet> b \<and> (\<forall>y. y \<in> X \<longrightarrow> x \<bullet> b \<le> y \<bullet> b)" by blast
qed

lemma
  compact_attains_Sup_componentwise:
  fixes b::"'a::ordered_euclidean_space"
  assumes "b \<in> Basis" assumes "X \<noteq> {}" "compact X"
  obtains x where "x \<in> X" "x \<bullet> b = Sup X \<bullet> b" "\<And>y. y \<in> X \<Longrightarrow> y \<bullet> b \<le> x \<bullet> b"
proof atomize_elim
  let ?proj = "(\<lambda>x. x \<bullet> b) ` X"
  from assms have "compact ?proj" "?proj \<noteq> {}"
    by (auto intro!: compact_continuous_image continuous_intros)
  from compact_attains_sup[OF this]
  obtain s x
    where s: "s\<in>(\<lambda>x. x \<bullet> b) ` X" "\<And>t. t\<in>(\<lambda>x. x \<bullet> b) ` X \<Longrightarrow> t \<le> s"
      and x: "x \<in> X" "s = x \<bullet> b" "\<And>y. y \<in> X \<Longrightarrow> y \<bullet> b \<le> x \<bullet> b"
    by auto
  hence "Sup ?proj = x \<bullet> b"
    by (auto intro!: cSup_eq_maximum)
  hence "x \<bullet> b = Sup X \<bullet> b"
    by (auto simp: eucl_Sup[where 'a='a] inner_sum_left inner_Basis if_distrib \<open>b \<in> Basis\<close> sum.delta
      cong: if_cong)
  with x show "\<exists>x. x \<in> X \<and> x \<bullet> b = Sup X \<bullet> b \<and> (\<forall>y. y \<in> X \<longrightarrow> y \<bullet> b \<le> x \<bullet> b)" by blast
qed

lemma (in order) atLeastatMost_empty'[simp]:
  "(~ a <= b) \<Longrightarrow> {a..b} = {}"
  by (auto)

instance real :: ordered_euclidean_space
  by standard auto

lemma in_Basis_prod_iff:
  fixes i::"'a::euclidean_space*'b::euclidean_space"
  shows "i \<in> Basis \<longleftrightarrow> fst i = 0 \<and> snd i \<in> Basis \<or> snd i = 0 \<and> fst i \<in> Basis"
  by (cases i) (auto simp: Basis_prod_def)

instantiation prod :: (abs, abs) abs
begin

definition "\<bar>x\<bar> = (\<bar>fst x\<bar>, \<bar>snd x\<bar>)"

instance ..

end

instance prod :: (ordered_euclidean_space, ordered_euclidean_space) ordered_euclidean_space
  by standard
    (auto intro!: add_mono simp add: euclidean_representation_sum'  Ball_def inner_prod_def
      in_Basis_prod_iff inner_Basis_inf_left inner_Basis_sup_left inner_Basis_INF_left Inf_prod_def
      inner_Basis_SUP_left Sup_prod_def less_prod_def less_eq_prod_def eucl_le[where 'a='a]
      eucl_le[where 'a='b] abs_prod_def abs_inner)

text\<open>Instantiation for intervals on \<open>ordered_euclidean_space\<close>\<close>

lemma
  fixes a :: "'a::ordered_euclidean_space"
  shows cbox_interval: "cbox a b = {a..b}"
    and interval_cbox: "{a..b} = cbox a b"
    and eucl_le_atMost: "{x. \<forall>i\<in>Basis. x \<bullet> i <= a \<bullet> i} = {..a}"
    and eucl_le_atLeast: "{x. \<forall>i\<in>Basis. a \<bullet> i <= x \<bullet> i} = {a..}"
    by (auto simp: eucl_le[where 'a='a] eucl_less_def box_def cbox_def)

lemma closed_eucl_atLeastAtMost[simp, intro]:
  fixes a :: "'a::ordered_euclidean_space"
  shows "closed {a..b}"
  by (simp add: cbox_interval[symmetric] closed_cbox)

lemma closed_eucl_atMost[simp, intro]:
  fixes a :: "'a::ordered_euclidean_space"
  shows "closed {..a}"
  by (simp add: eucl_le_atMost[symmetric])

lemma closed_eucl_atLeast[simp, intro]:
  fixes a :: "'a::ordered_euclidean_space"
  shows "closed {a..}"
  by (simp add: eucl_le_atLeast[symmetric])

lemma bounded_closed_interval:
  fixes a :: "'a::ordered_euclidean_space"
  shows "bounded {a .. b}"
  using bounded_cbox[of a b]
  by (metis interval_cbox)

lemma convex_closed_interval:
  fixes a :: "'a::ordered_euclidean_space"
  shows "convex {a .. b}"
  using convex_box[of a b]
  by (metis interval_cbox)

lemma image_smult_interval:"(\<lambda>x. m *\<^sub>R (x::_::ordered_euclidean_space)) ` {a .. b} =
  (if {a .. b} = {} then {} else if 0 \<le> m then {m *\<^sub>R a .. m *\<^sub>R b} else {m *\<^sub>R b .. m *\<^sub>R a})"
  using image_smult_cbox[of m a b]
  by (simp add: cbox_interval)

lemma is_interval_closed_interval:
  "is_interval {a .. (b::'a::ordered_euclidean_space)}"
  by (metis cbox_interval is_interval_cbox)

lemma compact_interval:
  fixes a b::"'a::ordered_euclidean_space"
  shows "compact {a .. b}"
  by (metis compact_cbox interval_cbox)

lemma homeomorphic_closed_intervals:
  fixes a :: "'a::euclidean_space" and b and c :: "'a::euclidean_space" and d
  assumes "box a b \<noteq> {}" and "box c d \<noteq> {}"
    shows "(cbox a b) homeomorphic (cbox c d)"
apply (rule homeomorphic_convex_compact)
using assms apply auto
done

lemma homeomorphic_closed_intervals_real:
  fixes a::real and b and c::real and d
  assumes "a<b" and "c<d"
    shows "{a..b} homeomorphic {c..d}"
by (metis assms compact_interval continuous_on_id convex_real_interval(5) emptyE homeomorphic_convex_compact interior_atLeastAtMost_real mvt)

no_notation
  eucl_less (infix "<e" 50)

lemma One_nonneg: "0 \<le> (\<Sum>Basis::'a::ordered_euclidean_space)"
  by (auto intro: sum_nonneg)

lemma
  fixes a b::"'a::ordered_euclidean_space"
  shows bdd_above_cbox[intro, simp]: "bdd_above (cbox a b)"
    and bdd_below_cbox[intro, simp]: "bdd_below (cbox a b)"
    and bdd_above_box[intro, simp]: "bdd_above (box a b)"
    and bdd_below_box[intro, simp]: "bdd_below (box a b)"
  unfolding atomize_conj
  by (metis bdd_above_Icc bdd_above_mono bdd_below_Icc bdd_below_mono bounded_box
    bounded_subset_cbox interval_cbox)

instantiation vec :: (ordered_euclidean_space, finite) ordered_euclidean_space
begin

definition "inf x y = (\<chi> i. inf (x $ i) (y $ i))"
definition "sup x y = (\<chi> i. sup (x $ i) (y $ i))"
definition "Inf X = (\<chi> i. (INF x:X. x $ i))"
definition "Sup X = (\<chi> i. (SUP x:X. x $ i))"
definition "\<bar>x\<bar> = (\<chi> i. \<bar>x $ i\<bar>)"

instance
  apply standard
  unfolding euclidean_representation_sum'
  apply (auto simp: less_eq_vec_def inf_vec_def sup_vec_def Inf_vec_def Sup_vec_def inner_axis
    Basis_vec_def inner_Basis_inf_left inner_Basis_sup_left inner_Basis_INF_left
    inner_Basis_SUP_left eucl_le[where 'a='a] less_le_not_le abs_vec_def abs_inner)
  done

end

lemma ANR_interval [iff]:
    fixes a :: "'a::ordered_euclidean_space"
    shows "ANR{a..b}"
by (simp add: interval_cbox)

lemma ENR_interval [iff]:
    fixes a :: "'a::ordered_euclidean_space"
    shows "ENR{a..b}"
  by (auto simp: interval_cbox)

end