theory sort_BubSortPermutes'
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

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

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 bubble :: "int list => (bool, (int list)) Pair2" where
"bubble (Nil2) = Pair False (Nil2)"
| "bubble (Cons2 y (Nil2)) = Pair False (Cons2 y (Nil2))"
| "bubble (Cons2 y (Cons2 y2 xs)) =
     (if y <= y2 then
        case bubble (Cons2 y2 xs) of
          | Pair b6 ys5 =>
              (if y <= y2 then
                 (if y <= y2 then
                    case bubble (Cons2 y2 xs) of
                      | Pair b10 ys9 => Pair (or2 (~ (y <= y2)) b6) (Cons2 y ys9)
                    end
                    else
                    case bubble (Cons2 y xs) of
                      | Pair b9 ys8 => Pair (or2 (~ (y <= y2)) b6) (Cons2 y ys8)
                    end)
                 else
                 (if y <= y2 then
                    case bubble (Cons2 y2 xs) of
                      | Pair b8 ys7 => Pair (or2 (~ (y <= y2)) b6) (Cons2 y2 ys7)
                    end
                    else
                    case bubble (Cons2 y xs) of
                      | Pair b7 ys6 => Pair (or2 (~ (y <= y2)) b6) (Cons2 y2 ys6)
                    end))
        end
        else
        case bubble (Cons2 y xs) of
          | Pair c2 ys =>
              (if y <= y2 then
                 (if y <= y2 then
                    case bubble (Cons2 y2 xs) of
                      | Pair b5 ys4 => Pair (or2 (~ (y <= y2)) c2) (Cons2 y ys4)
                    end
                    else
                    case bubble (Cons2 y xs) of
                      | Pair b4 ys3 => Pair (or2 (~ (y <= y2)) c2) (Cons2 y ys3)
                    end)
                 else
                 (if y <= y2 then
                    case bubble (Cons2 y2 xs) of
                      | Pair b3 ys2 => Pair (or2 (~ (y <= y2)) c2) (Cons2 y2 ys2)
                    end
                    else
                    case bubble (Cons2 y xs) of
                      | Pair b2 zs => Pair (or2 (~ (y <= y2)) c2) (Cons2 y2 zs)
                    end))
        end)"

fun bubsort :: "int list => int list" where
"bubsort x =
   case bubble x of
     | Pair c ys =>
         (if c then
            case bubble x of | Pair b2 xs => bubsort xs
            end
            else
            x)
   end"

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))"

(*hipster or2 null elem delete bubble bubsort and2 isPermutation *)

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

end


(*
    Author:      David Sanan
    Maintainer:  David Sanan, sanan at ntu edu sg
    License:     LGPL
*)

(*  Title:      Sep_Prod_Instance.thy
    Author:     David Sanan, NTU

Copyright (C) 2015-2016 David Sanan
Some rights reserved, NTU
This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

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

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)
theory Sep_Prod_Instance
imports Sep_Algebra.Separation_Algebra "Separata.Separata"
begin
section{* Product of Separation Algebras Instantiation *}

instantiation prod::(sep_algebra,sep_algebra) sep_algebra
begin
definition zero_prod_def: "0 \<equiv> (0,0)"
definition plus_prod_def: "p1 + p2 \<equiv> ((fst p1) + (fst p2),(snd p1) + (snd p2))"
definition sep_disj_prod_def: "sep_disj p1 p2 \<equiv> ((fst p1) ## (fst p2) \<and> (snd p1) ## (snd p2))"

instance
  apply standard
        apply (simp add: sep_disj_prod_def zero_prod_def)
       apply (simp add: sep_disj_commute sep_disj_prod_def)
      apply (simp add: zero_prod_def  plus_prod_def)
     apply (simp add: plus_prod_def sep_disj_prod_def sep_disj_commute sep_add_commute)
    apply (simp add: plus_prod_def sep_add_assoc sep_disj_prod_def)
   apply (simp add: sep_disj_prod_def plus_prod_def )
   apply (fastforce intro:sep_disj_addD1)
  apply (simp add: sep_disj_prod_def prod_def plus_prod_def sep_disj_addI1)
  done
end

instantiation prod::(heap_sep_algebra, heap_sep_algebra) heap_sep_algebra
begin
  instance
   proof
    fix x :: "'a \<times> 'b" and z :: "'a \<times> 'b" and y :: "'a \<times> 'b"
    assume a1: "x + z = y + z"
    assume a2: "x ## z"
    assume a3: "y ## z"
    have f4: "fst x + fst z = fst y + fst z \<and> snd x + snd z = snd y + snd z"
      using a1 by (simp add: plus_prod_def)
    have f5: "\<forall>p pa. p ## pa = ((fst p::'a) ## fst pa \<and> (snd p::'b) ## snd pa)"
      using sep_disj_prod_def by blast
    hence f6: "fst x = fst y"
      using f4 a3 a2 by (meson sep_add_cancel)
    have "snd x = snd y"
      using f5 f4 a3 a2 by (meson sep_add_cancel)
    thus "x = y"
      using f6 by (simp add: prod_eq_iff)
  next
     fix x:: "'a \<times> 'b"
     assume "x##x"
     thus "x=0"
      by (metis sep_add_disj sep_disj_prod_def surjective_pairing zero_prod_def)
   next
     fix a :: "'a \<times> 'b" and b :: "'a \<times> 'b" and c :: "'a \<times> 'b" and d :: "'a \<times> 'b" and w :: "'a \<times> 'b"
     assume wab:"a + b = w" and wcd:"c + d = w" and  abdis:"a ## b" and cddis:"c ## d"
     then obtain a1 a2 b1 b2 c1 c2 d1 d2 w1 w2 where
       a:"a= (a1,a2)" and
       b:"b= (b1,b2)" and
       c:"c= (c1,c2)" and
       d:"d= (d1,d2)" and
       e:"w= (w1,w2)" by fastforce
     have "\<exists>e1 f1 g1 h1. a1=e1+f1 \<and> b1 = g1 + h1 \<and> c1=e1+g1 \<and> d1 = f1+h1 \<and>
         e1##f1 \<and> g1##h1 \<and> e1##g1 \<and> f1##h1"
     using wab wcd abdis cddis a b c d e
       unfolding plus_prod_def sep_disj_prod_def
       using sep_add_cross_split
       by fastforce
     also have "\<exists>e2 f2 g2 h2. a2=e2+f2 \<and> b2 = g2 + h2 \<and> c2=e2+g2 \<and> d2 = f2+h2 \<and>
         e2##f2 \<and> g2##h2 \<and> e2##g2 \<and> f2##h2"
       using wab wcd abdis cddis a b c d e
       unfolding plus_prod_def sep_disj_prod_def
       using sep_add_cross_split
       by fastforce
     ultimately show  "\<exists> e f g h. e + f = a \<and> g + h = b \<and> e + g = c \<and> f + h = d \<and>
                  e ## f \<and> g ## h \<and> e ## g \<and> f ## h"
     using  a b c d e
       unfolding plus_prod_def sep_disj_prod_def
       by fastforce
    next
      fix x :: "'a \<times> 'b" and y :: "'a \<times> 'b"
      assume "x+y=0" and
             "x##y"
      thus "x=0"
      proof -
        have f1: "(fst x + fst y, snd x + snd y) = 0"
          by (metis (full_types) \<open>x + y = 0\<close> plus_prod_def)
        then have f2: "fst x = 0"
          by (metis (no_types) \<open>x ## y\<close> fst_conv sep_add_ind_unit sep_disj_prod_def zero_prod_def)
        have "snd x + snd y = 0"
          using f1 by (metis snd_conv zero_prod_def)
        then show ?thesis
          using f2 by (metis (no_types) \<open>x ## y\<close> fst_conv plus_prod_def sep_add_ind_unit sep_add_zero sep_disj_prod_def snd_conv zero_prod_def)
      qed
    next
      fix x :: "'a \<times> 'b" and y :: "'a \<times> 'b" and z :: "'a \<times> 'b"
      assume "x ## y" and "y ## z" and "x ## z"
      then have "x ## (fst y + fst z, snd y + snd z)"
          by (metis \<open>x ## y\<close> \<open>x ## z\<close> \<open>y ## z\<close> disj_dstri fst_conv sep_disj_prod_def snd_conv)
      thus "x ## y + z" by (metis plus_prod_def)
    next
      fix x :: "'a \<times> 'b" and y :: "'a \<times> 'b" and z :: "'a \<times> 'b"
      assume "y ## z"
      then show "x ## y + z = (x ## y \<and> x ## z)"
        unfolding sep_disj_prod_def plus_prod_def
        by auto
    next
      fix x :: "'a \<times> 'b" and y :: "'a \<times> 'b"
      assume "x ## x" and "x + x = y"
      thus  "x=y"
        by (metis disjoint_zero_sym plus_prod_def sep_add_disj sep_add_zero_sym sep_disj_prod_def)
  qed
end

lemma fst_fst_dist:"fst (fst x + fst y) = fst (fst x) + fst (fst y)"
by (simp add: plus_prod_def)

lemma fst_snd_dist:"fst (snd x + snd y) = fst (snd x) + fst (snd y)"
by (simp add: plus_prod_def)

lemma snd_fst_dist:"snd (fst x + fst y) = snd (fst x) + snd (fst y)"
by (simp add: plus_prod_def)

lemma snd_snd_dist:"snd (snd x + snd y) = snd (snd x) + snd (snd y)"
by (simp add: plus_prod_def)

lemma dis_sep:"(\<sigma>1, \<sigma>2) = (x1',x2') + (x1'',x2'') \<and>
       (x1',x2') ## (x1'',x2'') \<Longrightarrow>
       \<sigma>1 =(x1'+ x1'') \<and> x1' ## x1'' \<and> x2' ## x2''
      \<and> \<sigma>2 =(x2'+ x2'')"
by (simp add: plus_prod_def sep_disj_prod_def)

lemma substate_prod: "\<sigma>1 \<preceq> \<sigma>1' \<and> \<sigma>2 \<preceq> \<sigma>2' \<Longrightarrow> (\<sigma>1,\<sigma>2)  \<preceq>  (\<sigma>1',\<sigma>2')"
proof -
  assume a1:"\<sigma>1 \<preceq> \<sigma>1' \<and> \<sigma>2 \<preceq> \<sigma>2'"
  then obtain x where sub_x:"\<sigma>1 ## x \<and> \<sigma>1 + x = \<sigma>1'" using sep_substate_def by blast
  with a1 obtain y where sub_y:"\<sigma>2 ## y \<and> \<sigma>2 + y = \<sigma>2'" using sep_substate_def by blast
  have dis_12:"(\<sigma>1,\<sigma>2)##(x,y)" using sub_x sub_y  by (simp add: sep_disj_prod_def)
  have union_12:"(\<sigma>1',\<sigma>2') = (\<sigma>1,\<sigma>2)+(x,y)" using  sub_x sub_y  by (simp add: plus_prod_def)
  show "(\<sigma>1,\<sigma>2) \<preceq> (\<sigma>1',\<sigma>2')" using sep_substate_def dis_12 union_12 by auto
qed

lemma disj_sep_substate:
  "(\<sigma>1,\<sigma>'\<triangleright>\<sigma>1') \<and> (\<sigma>2,\<sigma>''\<triangleright>\<sigma>2')  \<Longrightarrow>
   (\<sigma>1,\<sigma>2)  \<preceq>  (\<sigma>1',\<sigma>2')"
proof-
assume a1:"(\<sigma>1,\<sigma>'\<triangleright>\<sigma>1') \<and> (\<sigma>2,\<sigma>''\<triangleright>\<sigma>2')"
  thus "(\<sigma>1,\<sigma>2)  \<preceq>  (\<sigma>1',\<sigma>2')"
    by (metis substate_prod tern_rel_def sep_substate_disj_add)
qed

lemma sep_tran_disjoint_split:
    "(x , y \<triangleright> (\<sigma>1::('a::heap_sep_algebra, 'a::heap_sep_algebra)prod,\<sigma>2))  \<Longrightarrow>
     (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')\<Longrightarrow>
     (\<sigma>1',\<sigma>2') = (((fst (fst x) + fst (fst y) + fst \<sigma>'),snd (fst x) + snd (fst y) + snd \<sigma>'),
                   fst (snd x) + fst (snd y) + fst \<sigma>'', snd (snd x) + snd (snd y) + snd \<sigma>'')"
proof-
  assume a1:"(x, y \<triangleright> (\<sigma>1,\<sigma>2))"
  then have descomp_sigma:"\<sigma>1 = fst x + fst y \<and> \<sigma>2 = snd x + snd y \<and> fst x ## fst y \<and> snd x ## snd y"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  assume a2: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
  then show "(\<sigma>1',\<sigma>2') =(((fst (fst x) + fst (fst y) + fst \<sigma>'),snd (fst x) + snd (fst y) + snd \<sigma>'),
                   fst (snd x) + fst (snd y) + fst \<sigma>'', snd (snd x) + snd (snd y) + snd \<sigma>'')"
    by (simp add: descomp_sigma plus_prod_def tern_rel_def)
qed

lemma sep_tran_disjoint_disj1:
   "(x , y \<triangleright> (\<sigma>1::('a::heap_sep_algebra, 'a::heap_sep_algebra)prod,\<sigma>2))  \<Longrightarrow>
     (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')\<Longrightarrow>
    (fst (fst x + fst y) ##  fst \<sigma>')
    \<and> (snd (fst x + fst y) ##  snd \<sigma>')
   \<and> ((fst (snd x + snd y)) ##  fst \<sigma>'')
   \<and> ((snd (snd x + snd y)) ##  snd \<sigma>'')
   "
proof -
 assume a1:"(x, y \<triangleright> (\<sigma>1,\<sigma>2))"
  then have descomp_sigma:
       "\<sigma>1 = fst x + fst y \<and> \<sigma>2 = snd x + snd y \<and>
        fst x ## fst y \<and> snd x ## snd y"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  assume a2: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
 then show " (fst (fst x + fst y) ##  fst \<sigma>')
    \<and> (snd (fst x + fst y) ##  snd \<sigma>')
   \<and> ((fst (snd x + snd y)) ##  fst \<sigma>'')
   \<and> ((snd (snd x + snd y)) ##  snd \<sigma>'')
   "
  by (simp add: descomp_sigma sep_disj_prod_def tern_rel_def)
qed

lemma sep_tran_disjoint_disj:
   "(x , y \<triangleright> (\<sigma>1::('a::heap_sep_algebra, 'a::heap_sep_algebra)prod,\<sigma>2))  \<Longrightarrow>
     (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')\<Longrightarrow>
    (fst (fst x) ##  fst \<sigma>') \<and> (fst (fst y) ## fst \<sigma>')
    \<and> (snd (fst x) ##  snd \<sigma>') \<and> (snd (fst y) ##  snd \<sigma>')
   \<and> (fst (snd x) ##  fst \<sigma>'') \<and> (fst (snd y) ## fst \<sigma>'')
   \<and> (snd (snd x) ##  snd \<sigma>'') \<and> (snd (snd y) ## snd \<sigma>'')
   "
proof -
 assume a1:"(x, y \<triangleright> (\<sigma>1,\<sigma>2))"
  then have descomp_sigma:
       "\<sigma>1 = fst x + fst y \<and> \<sigma>2 = snd x + snd y \<and>
        fst x ## fst y \<and> snd x ## snd y"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  then have sep_comp:"fst (fst x)## fst (fst y) \<and> snd (fst x) ## snd (fst y) \<and>
             fst (snd x)## fst (snd y) \<and> snd (snd x) ## snd (snd y)"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  assume a2: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
  then have  " (fst (fst x + fst y) ##  fst \<sigma>')
    \<and> (snd (fst x + fst y) ##  snd \<sigma>')
   \<and> ((fst (snd x + snd y)) ##  fst \<sigma>'')
   \<and> ((snd (snd x + snd y)) ##  snd \<sigma>'')
   " using a1 a2 sep_tran_disjoint_disj1 by blast
  then have disjall:" ((fst (fst x)) + (fst (fst y)) ##  fst \<sigma>')
    \<and> (snd (fst x) + snd( fst y) ##  snd \<sigma>')
   \<and> ((fst (snd x) + fst (snd y)) ##  fst \<sigma>'')
   \<and> ((snd (snd x) + snd (snd y)) ##  snd \<sigma>'')
   " by (simp add: plus_prod_def)
 then show "(fst (fst x) ##  fst \<sigma>') \<and> (fst (fst y) ## fst \<sigma>')
    \<and> (snd (fst x) ##  snd \<sigma>') \<and> (snd (fst y) ##  snd \<sigma>')
   \<and> (fst (snd x) ##  fst \<sigma>'') \<and> (fst (snd y) ## fst \<sigma>'')
   \<and> (snd (snd x) ##  snd \<sigma>'') \<and> (snd (snd y) ## snd \<sigma>'')"
       using sep_comp sep_add_disjD by metis
qed

lemma disj_union_dist1: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2') \<Longrightarrow>
                        ((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>'')\<triangleright> (\<sigma>1',\<sigma>2'))"
unfolding tern_rel_def
by (simp add: plus_prod_def sep_disj_prod_def)

lemma disj_union_dist2: "((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>'')\<triangleright> (\<sigma>1',\<sigma>2')) \<Longrightarrow>
                         (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
unfolding tern_rel_def
by (simp add: plus_prod_def sep_disj_prod_def)

lemma disj_union_dist: "((\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')) =
                        ((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>'')\<triangleright> (\<sigma>1',\<sigma>2'))"
using disj_union_dist1 disj_union_dist2 by blast

lemma sep_tran_eq_y':
    "(x , y \<triangleright> (\<sigma>1::('a::heap_sep_algebra, 'a::heap_sep_algebra)prod,\<sigma>2))  \<Longrightarrow>
     (\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')\<Longrightarrow>
     \<exists>x' y'. (x' , y' \<triangleright> (\<sigma>1',\<sigma>2')) \<and> (fst y'=snd y')"
proof-
  assume a1:"(x, y \<triangleright> (\<sigma>1,\<sigma>2))"
  then have descomp_sigma:"\<sigma>1 = fst x + fst y \<and> \<sigma>2 = snd x + snd y \<and> fst x ## fst y \<and> snd x ## snd y"
     by (simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  assume a2: "(\<sigma>1 , \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2 , \<sigma>''\<triangleright> \<sigma>2')"
  then have "(( fst x + fst y), \<sigma>'\<triangleright> \<sigma>1') \<and> ((snd x + snd y), \<sigma>''\<triangleright> \<sigma>2')"
  using descomp_sigma by auto
  have descomp_sigma1':"fst \<sigma>1' = fst \<sigma>1 + fst \<sigma>' \<and>
                            snd \<sigma>1' = snd \<sigma>1 + snd \<sigma>' \<and>
                            fst \<sigma>1 ## fst \<sigma>' \<and> snd \<sigma>1 ## snd \<sigma>'" using a2
    by (auto simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
   have descomp_sigma1':"fst \<sigma>2' = fst \<sigma>2 + fst \<sigma>'' \<and>
                            snd \<sigma>2' = snd \<sigma>2 + snd \<sigma>'' \<and>
                            fst \<sigma>2 ## fst \<sigma>'' \<and> snd \<sigma>2 ## snd \<sigma>''"
    using a2
    by (auto simp add: tern_rel_def plus_prod_def sep_disj_prod_def)
  then show "\<exists>x' y'. (x' , y'\<triangleright>(\<sigma>1',\<sigma>2'))  \<and> (fst y'=snd y')"
    by (metis (no_types) eq_fst_iff eq_snd_iff sep_add_zero tern_rel_def sep_disj_zero zero_prod_def)
qed

lemma sep_dis_con_eq:
  "x ## y \<and> (h::('a::sep_algebra, 'a::sep_algebra)prod) = x + y \<Longrightarrow>
   x' ## y' \<and> h = x' + y' \<Longrightarrow>
   x+y=x'+y'"
by simp

(*
instantiation prod::(heap_sep_algebra_labelled_sequents, heap_sep_algebra_labelled_sequents) heap_sep_algebra_labelled_sequents
begin
instance proof qed
end
*)

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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_prop_10
  imports "../../Test_Base"
begin

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

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

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

theorem property0 :
  "((rev (rev y)) = y)"
  oops

end


(*  Title:       AWN_Invariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Generic invariants on sequential AWN processes"

theory AWN_Invariants
imports Invariants AWN_SOS AWN_Labels
begin

subsection "Invariants via labelled control terms"

text \<open>
  Used to state that the initial control-state of an automaton appears within a process
  specification \<open>\<Gamma>\<close>, meaning that its transitions, and those of its subterms, are
  subsumed by those of \<open>\<Gamma>\<close>.
\<close>

definition
  control_within :: "('s, 'm, 'p, 'l) seqp_env \<Rightarrow> ('z \<times> ('s, 'm, 'p, 'l) seqp) set \<Rightarrow> bool"
where
  "control_within \<Gamma> \<sigma> \<equiv> \<forall>(\<xi>, p)\<in>\<sigma>. \<exists>pn. p \<in> subterms (\<Gamma> pn)"

lemma control_withinI [intro]:
  assumes "\<And>p. p \<in> Range \<sigma> \<Longrightarrow> \<exists>pn. p \<in> subterms (\<Gamma> pn)"
    shows "control_within \<Gamma> \<sigma>"
  using assms unfolding control_within_def by auto

lemma control_withinD [dest]:
  assumes "control_within \<Gamma> \<sigma>"
      and "(\<xi>, p) \<in> \<sigma>"
    shows "\<exists>pn. p \<in> subterms (\<Gamma> pn)"
  using assms unfolding control_within_def by blast

lemma control_within_topI [intro]:
  assumes "\<And>p. p \<in> Range \<sigma> \<Longrightarrow> \<exists>pn. p = \<Gamma> pn"
    shows "control_within \<Gamma> \<sigma>"
  using assms unfolding control_within_def
  by clarsimp (metis Range.RangeI subterms_refl)

lemma seqp_sos_subterms:
  assumes "wellformed \<Gamma>"
      and "\<exists>pn. p \<in> subterms (\<Gamma> pn)"
      and "((\<xi>, p), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
    shows "\<exists>pn. p' \<in> subterms (\<Gamma> pn)"
  using assms
  proof (induct p)
    fix p1 p2
    assume IH1: "\<exists>pn. p1 \<in> subterms (\<Gamma> pn) \<Longrightarrow>
                      ((\<xi>, p1), a, (\<xi>', p')) \<in> seqp_sos \<Gamma> \<Longrightarrow>
                      \<exists>pn. p' \<in> subterms (\<Gamma> pn)"
       and IH2: "\<exists>pn. p2 \<in> subterms (\<Gamma> pn) \<Longrightarrow>
                      ((\<xi>, p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma> \<Longrightarrow>
                      \<exists>pn. p' \<in> subterms (\<Gamma> pn)"
       and "\<exists>pn. p1 \<oplus> p2 \<in> subterms (\<Gamma> pn)"
       and "((\<xi>, p1 \<oplus> p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
    from \<open>\<exists>pn. p1 \<oplus> p2 \<in> subterms (\<Gamma> pn)\<close> obtain pn
                                            where "p1 \<in> subterms (\<Gamma> pn)"
                                              and "p2 \<in> subterms (\<Gamma> pn)" by auto
    from \<open>((\<xi>, p1 \<oplus> p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>\<close>
      have "((\<xi>, p1), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>
            \<or> ((\<xi>, p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>" by auto
    thus "\<exists>pn. p' \<in> subterms (\<Gamma> pn)"
    proof
      assume "((\<xi>, p1), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
      with \<open>p1 \<in> subterms (\<Gamma> pn)\<close> show ?thesis by (auto intro: IH1)
    next
      assume "((\<xi>, p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
      with \<open>p2 \<in> subterms (\<Gamma> pn)\<close> show ?thesis by (auto intro: IH2)
    qed
  qed auto

lemma reachable_subterms:
  assumes "wellformed \<Gamma>"
      and "control_within \<Gamma> (init A)"
      and "trans A = seqp_sos \<Gamma>"
      and "(\<xi>, p) \<in> reachable A I"
    shows "\<exists>pn. p \<in> subterms (\<Gamma> pn)"
  using assms(4)
  proof (induct rule: reachable_pair_induct)
    fix \<xi> p
    assume "(\<xi>, p) \<in> init A"
    with \<open>control_within \<Gamma> (init A)\<close> show "\<exists>pn. p \<in> subterms (\<Gamma> pn)" ..
  next
    fix \<xi> p a \<xi>' p'
    assume "(\<xi>, p) \<in> reachable A I"
       and "\<exists>pn. p \<in> subterms (\<Gamma> pn)"
       and *: "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
       and "I a"
    moreover from * and assms(3) have "((\<xi>, p), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>" by simp
    ultimately show "\<exists>pn. p' \<in> subterms (\<Gamma> pn)"
    using \<open>wellformed \<Gamma>\<close>
      by (auto elim: seqp_sos_subterms)
  qed

definition
  onl :: "('s, 'm, 'p, 'l) seqp_env
           \<Rightarrow> ('z \<times> 'l \<Rightarrow> bool)
           \<Rightarrow> 'z \<times> ('s, 'm, 'p, 'l) seqp
           \<Rightarrow> bool"
where
  "onl \<Gamma> P \<equiv> (\<lambda>(\<xi>, p). \<forall>l\<in>labels \<Gamma> p. P (\<xi>, l))"

lemma onlI [intro]:
  assumes "\<And>l. l\<in>labels \<Gamma> p \<Longrightarrow> P (\<xi>, l)"
    shows "onl \<Gamma> P (\<xi>, p)"
  using assms unfolding onl_def by simp

lemmas onlI' [intro] = onlI [simplified atomize_ball]

lemma onlD [dest]:
  assumes "onl \<Gamma> P (\<xi>, p)"
    shows "\<forall>l\<in>labels \<Gamma> p. P (\<xi>, l)"
  using assms unfolding onl_def by simp

lemma onl_invariantI [intro]:
  assumes init: "\<And>\<xi> p l. \<lbrakk> (\<xi>, p) \<in> init A; l \<in> labels \<Gamma> p \<rbrakk> \<Longrightarrow> P (\<xi>, l)"
      and step: "\<And>\<xi> p a \<xi>' p' l'.
                   \<lbrakk> (\<xi>, p) \<in> reachable A I;
                     \<forall>l\<in>labels \<Gamma> p. P (\<xi>, l);
                     ((\<xi>, p), a, (\<xi>', p')) \<in> trans A;
                     l' \<in> labels \<Gamma> p';
                     I a \<rbrakk> \<Longrightarrow> P (\<xi>', l')"
    shows "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
  proof (rule invariant_pairI)
    fix \<xi> p
    assume "(\<xi>, p) \<in> init A"
    hence "\<forall>l\<in>labels \<Gamma> p. P (\<xi>, l)" using init by simp
    thus "onl \<Gamma> P (\<xi>, p)" ..
  next
    fix \<xi> p a \<xi>' p'
    assume rp: "(\<xi>, p) \<in> reachable A I"
       and "onl \<Gamma> P (\<xi>, p)"
       and tr: "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
       and "I a"
    from \<open>onl \<Gamma> P (\<xi>, p)\<close> have "\<forall>l\<in>labels \<Gamma> p. P (\<xi>, l)" ..
    with rp tr \<open>I a\<close> have "\<forall>l'\<in>labels \<Gamma> p'. P (\<xi>', l')" by (auto elim: step)
    thus "onl \<Gamma> P (\<xi>', p')" ..
  qed

lemma onl_invariantD [dest]:
  assumes "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
      and "(\<xi>, p) \<in> reachable A I"
      and "l \<in> labels \<Gamma> p"
    shows "P (\<xi>, l)"
  using assms unfolding onl_def by auto

lemma onl_invariant_initD [dest]:
  assumes invP: "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
      and init: "(\<xi>, p) \<in> init A"
      and pnl:  "l \<in> labels \<Gamma> p"
    shows "P (\<xi>, l)"
  proof -
    from init have "(\<xi>, p) \<in> reachable A I" ..
    with invP show ?thesis using pnl ..
  qed

lemma onl_invariant_sterms:
  assumes wf: "wellformed \<Gamma>"
      and il: "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
      and rp: "(\<xi>, p) \<in> reachable A I"
      and "p'\<in>sterms \<Gamma> p"
      and "l\<in>labels \<Gamma> p'"
    shows "P (\<xi>, l)"
  proof -
    from wf \<open>p'\<in>sterms \<Gamma> p\<close> \<open>l\<in>labels \<Gamma> p'\<close> have "l\<in>labels \<Gamma> p"
      by (rule labels_sterms_labels)
    with il rp show "P (\<xi>, l)" ..
  qed

lemma onl_invariant_sterms_weaken:
  assumes wf: "wellformed \<Gamma>"
      and il: "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
      and rp: "(\<xi>, p) \<in> reachable A I'"
      and "p'\<in>sterms \<Gamma> p"
      and "l\<in>labels \<Gamma> p'"
      and weaken: "\<And>a. I' a \<Longrightarrow> I a"
    shows "P (\<xi>, l)"
  proof -
    from \<open>(\<xi>, p) \<in> reachable A I'\<close> have "(\<xi>, p) \<in> reachable A I"
      by (rule reachable_weakenE)
         (erule weaken)
    with assms(1-2) show ?thesis using assms(4-5) by (rule onl_invariant_sterms)
  qed

lemma onl_invariant_sterms_TT:
  assumes wf: "wellformed \<Gamma>"
      and il: "A \<TTurnstile> onl \<Gamma> P"
      and rp: "(\<xi>, p) \<in> reachable A I"
      and "p'\<in>sterms \<Gamma> p"
      and "l\<in>labels \<Gamma> p'"
    shows "P (\<xi>, l)"
  using assms by (rule onl_invariant_sterms_weaken) simp

lemma trans_from_sterms:
  assumes "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
      and "wellformed \<Gamma>"
    shows "\<exists>p'\<in>sterms \<Gamma> p. ((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
  using assms by (induction p rule: sterms_pinduct [OF \<open>wellformed \<Gamma>\<close>]) auto

lemma trans_from_sterms':
  assumes "((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
      and "wellformed \<Gamma>"
      and "p' \<in> sterms \<Gamma> p"
    shows "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
  using assms by (induction p rule: sterms_pinduct [OF \<open>wellformed \<Gamma>\<close>]) auto

lemma trans_to_dterms:
  assumes "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
      and "wellformed \<Gamma>"
   shows "\<forall>r\<in>sterms \<Gamma> q. r \<in> dterms \<Gamma> p"
  using assms by (induction q) auto

theorem cterms_includes_sterms_of_seq_reachable:
  assumes "wellformed \<Gamma>"
      and "control_within \<Gamma> (init A)"
      and "trans A = seqp_sos \<Gamma>"
    shows "\<Union>(sterms \<Gamma> ` snd ` reachable A I) \<subseteq> cterms \<Gamma>"
  proof
    fix qs
    assume "qs \<in> \<Union>(sterms \<Gamma> ` snd ` reachable A I)"
    then obtain \<xi> and q where  *: "(\<xi>, q) \<in> reachable A I"
                          and **: "qs \<in> sterms \<Gamma> q" by auto
    from * have "\<And>x. x \<in> sterms \<Gamma> q \<Longrightarrow> x \<in> cterms \<Gamma>"
    proof (induction rule: reachable_pair_induct)
      fix \<xi> p q
      assume "(\<xi>, p) \<in> init A"
         and "q \<in> sterms \<Gamma> p"
      from \<open>control_within \<Gamma> (init A)\<close> and \<open>(\<xi>, p) \<in> init A\<close>
        obtain pn where "p \<in> subterms (\<Gamma> pn)" by auto
      with \<open>wellformed \<Gamma>\<close> show "q \<in> cterms \<Gamma>" using \<open>q\<in>sterms \<Gamma> p\<close>
        by (rule subterms_sterms_in_cterms)
    next
      fix p \<xi> a \<xi>' q x
      assume "(\<xi>, p) \<in> reachable A I"
         and IH: "\<And>x. x \<in> sterms \<Gamma> p \<Longrightarrow> x \<in> cterms \<Gamma>"
         and "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
         and "x \<in> sterms \<Gamma> q"
      from this(3) and \<open>trans A = seqp_sos \<Gamma>\<close> have "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>" by simp
      from this and \<open>wellformed \<Gamma>\<close> obtain ps
        where ps: "ps \<in> sterms \<Gamma> p"
          and step: "((\<xi>, ps), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
        by (rule trans_from_sterms [THEN bexE])
      from ps have "ps \<in> cterms \<Gamma>" by (rule IH)
      moreover from step \<open>wellformed \<Gamma>\<close> \<open>x \<in> sterms \<Gamma> q\<close> have "x \<in> dterms \<Gamma> ps"
        by (rule trans_to_dterms [rule_format])
      ultimately show "x \<in> cterms \<Gamma>" by (rule ctermsDI)
    qed
    thus "qs \<in> cterms \<Gamma>" using ** .
  qed

corollary seq_reachable_in_cterms:
  assumes "wellformed \<Gamma>"
      and "control_within \<Gamma> (init A)"
      and "trans A = seqp_sos \<Gamma>"
      and "(\<xi>, p) \<in> reachable A I"
      and "p' \<in> sterms \<Gamma> p"
    shows "p' \<in> cterms \<Gamma>"
  using assms(1-3)
  proof (rule cterms_includes_sterms_of_seq_reachable [THEN subsetD])
    from assms(4-5) show "p' \<in> \<Union>(sterms \<Gamma> ` snd ` reachable A I)"
      by (auto elim!: rev_bexI)
  qed

lemma seq_invariant_ctermI:
  assumes wf: "wellformed \<Gamma>"
      and cw: "control_within \<Gamma> (init A)"
      and sl: "simple_labels \<Gamma>"
      and sp: "trans A = seqp_sos \<Gamma>"
      and init: "\<And>\<xi> p l. \<lbrakk>
                   (\<xi>, p) \<in> init A;
                   l\<in>labels \<Gamma> p
                 \<rbrakk> \<Longrightarrow> P (\<xi>, l)"
      and step: "\<And>p l \<xi> a q l' \<xi>' pp. \<lbrakk>
                 p\<in>cterms \<Gamma>;
                 l\<in>labels \<Gamma> p;
                 P (\<xi>, l);
                 ((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
                 ((\<xi>, p), a, (\<xi>', q)) \<in> trans A;
                 l'\<in>labels \<Gamma> q;
                 (\<xi>, pp)\<in>reachable A I;
                 p\<in>sterms \<Gamma> pp;
                 (\<xi>', q)\<in>reachable A I;
                 I a
               \<rbrakk> \<Longrightarrow> P (\<xi>', l')"
    shows "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
  proof
       fix \<xi> p l
    assume "(\<xi>, p) \<in> init A"
       and *: "l \<in> labels \<Gamma> p"
      with init show "P (\<xi>, l)" by auto
  next
       fix \<xi> p a \<xi>' q l'
    assume sr: "(\<xi>, p) \<in> reachable A I"
       and pl: "\<forall>l\<in>labels \<Gamma> p. P (\<xi>, l)"
       and tr: "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
       and A6: "l' \<in> labels \<Gamma> q"
       and "I a"
     from this(3) and \<open>trans A = seqp_sos \<Gamma>\<close> have tr': "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>" by simp
     show "P (\<xi>', l')"
    proof -
      from sr and tr and \<open>I a\<close> have A7: "(\<xi>', q) \<in> reachable A I" ..
      from tr' obtain p' where "p' \<in> sterms \<Gamma> p"
                           and "((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
        by (blast dest: trans_from_sterms [OF _ wf])
      from wf cw sp sr this(1) have A1: "p'\<in>cterms \<Gamma>"
        by (rule seq_reachable_in_cterms)
      from labels_not_empty [OF wf] obtain ll where A2: "ll\<in>labels \<Gamma> p'"
          by blast
      with \<open>p'\<in>sterms \<Gamma> p\<close> have "ll\<in>labels \<Gamma> p"
        by (rule labels_sterms_labels [OF wf])
      with pl have A3: "P (\<xi>, ll)" by simp
      from \<open>((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>\<close> and sp
        have A5: "((\<xi>, p'), a, (\<xi>', q)) \<in> trans A" by simp
      with sp have A4: "((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>" by simp
      from sr \<open>p'\<in>sterms \<Gamma> p\<close>
        obtain pp where A7: "(\<xi>, pp)\<in>reachable A I"
                    and A8: "p'\<in>sterms \<Gamma> pp"
        by auto
      from sr tr \<open>I a\<close> have A9: "(\<xi>', q) \<in> reachable A I" ..
      from A1 A2 A3 A4 A5 A6 A7 A8 A9 \<open>I a\<close> show ?thesis by (rule step)
    qed
  qed

lemma seq_invariant_ctermsI:
  assumes wf: "wellformed \<Gamma>"
      and "control_within \<Gamma> (init A)"
      and "simple_labels \<Gamma>"
      and "trans A = seqp_sos \<Gamma>"
      and init: "\<And>\<xi> p l. \<lbrakk>
                   (\<xi>, p) \<in> init A;
                   l\<in>labels \<Gamma> p
                 \<rbrakk> \<Longrightarrow> P (\<xi>, l)"
      and step: "\<And>p l \<xi> a q l' \<xi>' pp pn. \<lbrakk>
                 wellformed \<Gamma>;
                 p\<in>ctermsl (\<Gamma> pn);
                 not_call p;
                 l\<in>labels \<Gamma> p;
                 P (\<xi>, l);
                 ((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
                 ((\<xi>, p), a, (\<xi>', q)) \<in> trans A;
                 l'\<in>labels \<Gamma> q;
                 (\<xi>, pp)\<in>reachable A I;
                 p\<in>sterms \<Gamma> pp;
                 (\<xi>', q)\<in>reachable A I;
                 I a
               \<rbrakk> \<Longrightarrow> P (\<xi>', l')"
    shows "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
  using assms(1-4) proof (rule seq_invariant_ctermI)
    fix \<xi> p l
    assume "(\<xi>, p) \<in> init A"
       and "l \<in> labels \<Gamma> p"
    thus "P (\<xi>, l)" by (rule init)
  next
    fix p l \<xi> a q l' \<xi>' pp
    assume "p \<in> cterms \<Gamma>"
       and otherassms: "l \<in> labels \<Gamma> p"
           "P (\<xi>, l)"
           "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
           "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
           "l' \<in> labels \<Gamma> q"
           "(\<xi>, pp) \<in> reachable A I"
           "p \<in> sterms \<Gamma> pp"
           "(\<xi>', q) \<in> reachable A I"
           "I a"
    from this(1) obtain pn where "p \<in> ctermsl(\<Gamma> pn)"
                             and "not_call p"
      unfolding cterms_def' [OF wf] by auto
    with wf show "P (\<xi>', l')"
      using otherassms by (rule step)
  qed

subsection "Step invariants via labelled control terms"

definition
  onll :: "('s, 'm, 'p, 'l) seqp_env
           \<Rightarrow> (('z \<times> 'l, 'a) transition \<Rightarrow> bool)
           \<Rightarrow> ('z \<times> ('s, 'm, 'p, 'l) seqp, 'a) transition \<Rightarrow> bool"
where
  "onll \<Gamma> P \<equiv> (\<lambda>((\<xi>, p), a, (\<xi>', p')). \<forall>l\<in>labels \<Gamma> p. \<forall>l'\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l')))"

lemma onllI [intro]:
  assumes "\<And>l l'. \<lbrakk> l\<in>labels \<Gamma> p; l'\<in>labels \<Gamma> p' \<rbrakk> \<Longrightarrow> P ((\<xi>, l), a, (\<xi>', l'))"
    shows "onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'))"
  using assms unfolding onll_def by simp

lemma onllIl [intro]:
  assumes "\<forall>l\<in>labels \<Gamma> p. \<forall>l'\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
    shows "onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'))"
  using assms by auto

lemma onl_weaken [elim!]: "\<And>\<Gamma> P Q s. \<lbrakk> onl \<Gamma> P s; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> onl \<Gamma> Q s"
  by (clarsimp dest!: onlD intro!: onlI)

lemma onll_weaken [elim!]: "\<And>\<Gamma> P Q s. \<lbrakk> onll \<Gamma> P s; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> onll \<Gamma> Q s"
  by (clarsimp dest!: onllD intro!: onllI)

lemma onll_weaken' [elim!]: "\<And>\<Gamma> P Q s. \<lbrakk> onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'));
                                        \<And>l l'. P ((\<xi>, l), a, (\<xi>', l')) \<Longrightarrow> Q ((\<xi>, l), a, (\<xi>', l')) \<rbrakk>
                                      \<Longrightarrow> onll \<Gamma> Q ((\<xi>, p), a, (\<xi>', p'))"
  by (clarsimp dest!: onllD intro!: onllI)

lemma onll_step_invariantI [intro]:
  assumes *: "\<And>\<xi> p l a \<xi>' p' l'. \<lbrakk> (\<xi>, p)\<in>reachable A I;
                                   ((\<xi>, p), a, (\<xi>', p')) \<in> trans A;
                                   I a;
                                   l \<in>labels \<Gamma> p;
                                   l'\<in>labels \<Gamma> p' \<rbrakk>
                                 \<Longrightarrow> P ((\<xi>, l), a, (\<xi>', l'))"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
  proof
    fix \<xi> p \<xi>' p' a
    assume "(\<xi>, p) \<in> reachable A I"
       and "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
       and "I a"
    hence "\<forall>l\<in>labels \<Gamma> p. \<forall>l'\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))" by (auto elim!: *)
    thus "onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'))" ..
  qed

lemma onll_step_invariantE [elim]:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and "(\<xi>, p) \<in> reachable A I"
      and "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
      and "I a"
      and lp:  "l \<in>labels \<Gamma> p"
      and lp': "l'\<in>labels \<Gamma> p'"
    shows "P ((\<xi>, l), a, (\<xi>', l'))"
  proof -
    from assms(1-4) have "onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'))" ..
    with lp lp' show "P ((\<xi>, l), a, (\<xi>', l'))" by auto
  qed

lemma onll_step_invariantD [dest]:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and "(\<xi>, p) \<in> reachable A I"
      and "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
      and "I a"
    shows "\<forall>l\<in>labels \<Gamma> p. \<forall>l'\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  using assms by auto

lemma seq_step_invariant_sterms:
  assumes inv: "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and wf: "wellformed \<Gamma>"
      and sp: "trans A = seqp_sos \<Gamma>"
      and "l'\<in>labels \<Gamma> q"
      and sr: "(\<xi>, p) \<in> reachable A I"
      and tr: "((\<xi>, p'), a, (\<xi>', q)) \<in> trans A"
      and "I a"
      and "p'\<in>sterms \<Gamma> p"
    shows "\<forall>l\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  proof
    from tr and sp have "((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>" by simp
    hence "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
      using wf \<open>p'\<in>sterms \<Gamma> p\<close> by  (rule trans_from_sterms')
    with sp have trp: "((\<xi>, p), a, (\<xi>', q)) \<in> trans A" by simp
    fix l assume "l \<in> labels \<Gamma> p'"
    with wf inv sr trp \<open>I a\<close> \<open>l'\<in>labels \<Gamma> q\<close> \<open>p'\<in>sterms \<Gamma> p\<close>
      show "P ((\<xi>, l), a, (\<xi>', l'))" by (rule onll_step_invariant_sterms)
  qed

lemma seq_step_invariant_sterms_weaken:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and "wellformed \<Gamma>"
      and "trans A = seqp_sos \<Gamma>"
      and "l'\<in>labels \<Gamma> q"
      and "(\<xi>, p) \<in> reachable A I'"
      and "((\<xi>, p'), a, (\<xi>', q)) \<in> trans A"
      and "I' a"
      and "p'\<in>sterms \<Gamma> p"
      and weaken: "\<And>a. I' a \<Longrightarrow> I a"
    shows "\<forall>l\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  proof -
    from \<open>I' a\<close> have "I a" by (rule weaken)
    from \<open>(\<xi>, p) \<in> reachable A I'\<close> have Ir: "(\<xi>, p) \<in> reachable A I"
        by (rule reachable_weakenE) (erule weaken)
    with assms(1-4) show ?thesis
      using \<open>((\<xi>, p'), a, (\<xi>', q)) \<in> trans A\<close> \<open>I a\<close> and \<open>p'\<in>sterms \<Gamma> p\<close>
      by (rule seq_step_invariant_sterms)
  qed

lemma seq_step_invariant_sterms_TT:
  assumes "A \<TTurnstile>\<^sub>A onll \<Gamma> P"
      and "wellformed \<Gamma>"
      and "trans A = seqp_sos \<Gamma>"
      and "l'\<in>labels \<Gamma> q"
      and "(\<xi>, p) \<in> reachable A I"
      and "((\<xi>, p'), a, (\<xi>', q)) \<in> trans A"
      and "I a"
      and "p'\<in>sterms \<Gamma> p"
    shows "\<forall>l\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  using assms by (rule seq_step_invariant_sterms_weaken) simp

lemma onll_step_invariant_any_sterms:
  assumes "wellformed \<Gamma>"
      and "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and "(\<xi>, p) \<in> reachable A I"
      and "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
      and "I a"
      and "l'\<in>labels \<Gamma> q"
    shows "\<forall>p'\<in>sterms \<Gamma> p. \<forall>l\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  by (intro ballI) (rule onll_step_invariant_sterms [OF assms])

lemma seq_step_invariant_ctermsI [intro]:
  assumes wf: "wellformed \<Gamma>"
      and cw: "control_within \<Gamma> (init A)"
      and sl: "simple_labels \<Gamma>"
      and sp: "trans A = seqp_sos \<Gamma>"
      and step: "\<And>p l \<xi> a q l' \<xi>' pp pn. \<lbrakk>
                 wellformed \<Gamma>;
                 p\<in>ctermsl (\<Gamma> pn);
                 not_call p;
                 l\<in>labels \<Gamma> p;
                 ((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
                 ((\<xi>, p), a, (\<xi>', q)) \<in> trans A;
                 l'\<in>labels \<Gamma> q;
                 (\<xi>, pp) \<in> reachable A I;
                 p\<in>sterms \<Gamma> pp;
                 (\<xi>', q) \<in> reachable A I;
                 I a
               \<rbrakk> \<Longrightarrow> P ((\<xi>, l), a, (\<xi>', l'))"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
  using assms(1-4) proof (rule seq_step_invariant_ctermI)
    fix p pp l \<xi> a q l' \<xi>'
    assume "p \<in> cterms \<Gamma>"
       and otherassms: "l \<in> labels \<Gamma> p"
           "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
           "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
           "l' \<in> labels \<Gamma> q"
           "(\<xi>, pp) \<in> reachable A I"
           "p \<in> sterms \<Gamma> pp"
           "(\<xi>', q) \<in> reachable A I"
           "I a"
    from this(1) obtain pn where "p \<in> ctermsl(\<Gamma> pn)"
                             and "not_call p"
      unfolding cterms_def' [OF wf] by auto
    with wf show "P ((\<xi>, l), a, (\<xi>', l'))"
      using otherassms by (rule step)
  qed

end


(*  Title:      HOL/Option.thy
    Author:     Folklore
*)

section {* Datatype option *}

theory Option
imports Lifting Finite_Set
begin

datatype 'a option =
    None
  | Some (the: 'a)

datatype_compat option

lemma [case_names None Some, cases type: option]:
  -- {* for backward compatibility -- names of variables differ *}
  "(y = None \<Longrightarrow> P) \<Longrightarrow> (\<And>a. y = Some a \<Longrightarrow> P) \<Longrightarrow> P"
by (rule option.exhaust)

lemma [case_names None Some, induct type: option]:
  -- {* for backward compatibility -- names of variables differ *}
  "P None \<Longrightarrow> (\<And>option. P (Some option)) \<Longrightarrow> P option"
by (rule option.induct)

text {* Compatibility: *}

setup {* Sign.mandatory_path "option" *}

lemmas inducts = option.induct
lemmas cases = option.case

setup {* Sign.parent_path *}

lemma not_None_eq [iff]: "(x ~= None) = (EX y. x = Some y)"
  by (induct x) auto

lemma not_Some_eq [iff]: "(ALL y. x ~= Some y) = (x = None)"
  by (induct x) auto

text{*Although it may appear that both of these equalities are helpful
only when applied to assumptions, in practice it seems better to give
them the uniform iff attribute. *}

lemma inj_Some [simp]: "inj_on Some A"
by (rule inj_onI) simp

lemma case_optionE:
  assumes c: "(case x of None => P | Some y => Q y)"
  obtains
    (None) "x = None" and P
  | (Some) y where "x = Some y" and "Q y"
  using c by (cases x) simp_all

lemma split_option_all: "(\<forall>x. P x) \<longleftrightarrow> P None \<and> (\<forall>x. P (Some x))"
by (auto intro: option.induct)

lemma split_option_ex: "(\<exists>x. P x) \<longleftrightarrow> P None \<or> (\<exists>x. P (Some x))"
using split_option_all[of "\<lambda>x. \<not>P x"] by blast

lemma UNIV_option_conv: "UNIV = insert None (range Some)"
by(auto intro: classical)

subsubsection {* Operations *}

lemma ospec [dest]: "(ALL x:set_option A. P x) ==> A = Some x ==> P x"
  by simp

setup {* map_theory_claset (fn ctxt => ctxt addSD2 ("ospec", @{thm ospec})) *}

lemma elem_set [iff]: "(x : set_option xo) = (xo = Some x)"
  by (cases xo) auto

lemma set_empty_eq [simp]: "(set_option xo = {}) = (xo = None)"
  by (cases xo) auto

lemma map_option_case: "map_option f y = (case y of None => None | Some x => Some (f x))"
  by (auto split: option.split)

lemma map_option_is_None [iff]:
    "(map_option f opt = None) = (opt = None)"
  by (simp add: map_option_case split add: option.split)

lemma map_option_eq_Some [iff]:
    "(map_option f xo = Some y) = (EX z. xo = Some z & f z = y)"
  by (simp add: map_option_case split add: option.split)

lemma map_option_o_case_sum [simp]:
    "map_option f o case_sum g h = case_sum (map_option f o g) (map_option f o h)"
  by (rule o_case_sum)

lemma map_option_cong: "x = y \<Longrightarrow> (\<And>a. y = Some a \<Longrightarrow> f a = g a) \<Longrightarrow> map_option f x = map_option g y"
by (cases x) auto

functor map_option: map_option proof -
  fix f g
  show "map_option f \<circ> map_option g = map_option (f \<circ> g)"
  proof
    fix x
    show "(map_option f \<circ> map_option g) x= map_option (f \<circ> g) x"
      by (cases x) simp_all
  qed
next
  show "map_option id = id"
  proof
    fix x
    show "map_option id x = id x"
      by (cases x) simp_all
  qed
qed

lemma case_map_option [simp]:
  "case_option g h (map_option f x) = case_option g (h \<circ> f) x"
  by (cases x) simp_all

lemma rel_option_iff:
  "rel_option R x y = (case (x, y) of (None, None) \<Rightarrow> True
    | (Some x, Some y) \<Rightarrow> R x y
    | _ \<Rightarrow> False)"
by (auto split: prod.split option.split)

primrec bind :: "'a option \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'b option" where
bind_lzero: "bind None f = None" |
bind_lunit: "bind (Some x) f = f x"

lemma bind_runit[simp]: "bind x Some = x"
by (cases x) auto

lemma bind_assoc[simp]: "bind (bind x f) g = bind x (\<lambda>y. bind (f y) g)"
by (cases x) auto

lemma bind_rzero[simp]: "bind x (\<lambda>x. None) = None"
by (cases x) auto

lemma bind_cong: "x = y \<Longrightarrow> (\<And>a. y = Some a \<Longrightarrow> f a = g a) \<Longrightarrow> bind x f = bind y g"
by (cases x) auto

lemma bind_split: "P (bind m f)
  \<longleftrightarrow> (m = None \<longrightarrow> P None) \<and> (\<forall>v. m=Some v \<longrightarrow> P (f v))"
    by (cases m) auto

lemma bind_split_asm: "P (bind m f) = (\<not>(
    m=None \<and> \<not>P None
  \<or> (\<exists>x. m=Some x \<and> \<not>P (f x))))"
  by (cases m) auto

lemmas bind_splits = bind_split bind_split_asm

definition these :: "'a option set \<Rightarrow> 'a set"
where
  "these A = the ` {x \<in> A. x \<noteq> None}"

lemma these_empty [simp]:
  "these {} = {}"
  by (simp add: these_def)

lemma these_insert_None [simp]:
  "these (insert None A) = these A"
  by (auto simp add: these_def)

lemma these_insert_Some [simp]:
  "these (insert (Some x) A) = insert x (these A)"
proof -
  have "{y \<in> insert (Some x) A. y \<noteq> None} = insert (Some x) {y \<in> A. y \<noteq> None}"
    by auto
  then show ?thesis by (simp add: these_def)
qed

lemma in_these_eq:
  "x \<in> these A \<longleftrightarrow> Some x \<in> A"
proof
  assume "Some x \<in> A"
  then obtain B where "A = insert (Some x) B" by auto
  then show "x \<in> these A" by (auto simp add: these_def intro!: image_eqI)
next
  assume "x \<in> these A"
  then show "Some x \<in> A" by (auto simp add: these_def)
qed

lemma these_image_Some_eq [simp]:
  "these (Some ` A) = A"
  by (auto simp add: these_def intro!: image_eqI)

lemma Some_image_these_eq:
  "Some ` these A = {x\<in>A. x \<noteq> None}"
  by (auto simp add: these_def image_image intro!: image_eqI)

lemma these_empty_eq:
  "these B = {} \<longleftrightarrow> B = {} \<or> B = {None}"
  by (auto simp add: these_def)

lemma these_not_empty_eq:
  "these B \<noteq> {} \<longleftrightarrow> B \<noteq> {} \<and> B \<noteq> {None}"
  by (auto simp add: these_empty_eq)

hide_const (open) bind these
hide_fact (open) bind_cong

subsection {* Transfer rules for the Transfer package *}

context
begin
interpretation lifting_syntax .

lemma option_bind_transfer [transfer_rule]:
  "(rel_option A ===> (A ===> rel_option B) ===> rel_option B)
    Option.bind Option.bind"
  unfolding rel_fun_def split_option_all by simp

end

subsubsection {* Interaction with finite sets *}

lemma finite_option_UNIV [simp]:
  "finite (UNIV :: 'a option set) = finite (UNIV :: 'a set)"
  by (auto simp add: UNIV_option_conv elim: finite_imageD intro: inj_Some)

instance option :: (finite) finite
  by default (simp add: UNIV_option_conv)

subsubsection {* Code generator setup *}

definition is_none :: "'a option \<Rightarrow> bool" where
  [code_post]: "is_none x \<longleftrightarrow> x = None"

lemma is_none_code [code]:
  shows "is_none None \<longleftrightarrow> True"
    and "is_none (Some x) \<longleftrightarrow> False"
  unfolding is_none_def by simp_all

lemma [code_unfold]:
  "HOL.equal x None \<longleftrightarrow> is_none x"
  "HOL.equal None = is_none"
  by (auto simp add: equal is_none_def)

hide_const (open) is_none

code_printing
  type_constructor option \<rightharpoonup>
    (SML) "_ option"
    and (OCaml) "_ option"
    and (Haskell) "Maybe _"
    and (Scala) "!Option[(_)]"
| constant None \<rightharpoonup>
    (SML) "NONE"
    and (OCaml) "None"
    and (Haskell) "Nothing"
    and (Scala) "!None"
| constant Some \<rightharpoonup>
    (SML) "SOME"
    and (OCaml) "Some _"
    and (Haskell) "Just"
    and (Scala) "Some"
| class_instance option :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: 'a option \<Rightarrow> 'a option \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) infix 4 "=="

code_reserved SML
  option NONE SOME

code_reserved OCaml
  option None Some

code_reserved Scala
  Option None Some

end