theory ValueOntologyTestLong imports ValueOntology (** Benzmüller, Fuenmayor & Lomfeld, 2021 **)
begin
lemma "True" nitpick[satisfy,show_all,card \<iota>=10] oops
lemma "\<lfloor>Conflict\<^sup>p\<rfloor>" nitpick[satisfy,card \<iota>=4] nitpick oops (*contingent*)
 (*derivation operators satisfy main properties of Galois connections*)
lemma G:      "B \<^bold>\<sqsubseteq> A\<up> \<longleftrightarrow> A \<^bold>\<sqsubseteq> B\<down>" by blast
lemma G1:     "A \<^bold>\<sqsubseteq> A\<up>\<down>" by simp
lemma G2:     "B \<^bold>\<sqsubseteq> B\<down>\<up>" by simp
lemma G3:     "A\<^sub>1 \<^bold>\<sqsubseteq> A\<^sub>2 \<longrightarrow> A\<^sub>2\<up> \<^bold>\<sqsubseteq> A\<^sub>1\<up>" by simp
lemma G4:     "B\<^sub>1 \<^bold>\<sqsubseteq> B\<^sub>2 \<longrightarrow> B\<^sub>2\<down> \<^bold>\<sqsubseteq> B\<^sub>1\<down>" by simp
lemma cl1:    "A\<up> = A\<up>\<down>\<up>" by blast
lemma cl2:    "B\<down> = B\<down>\<up>\<down>" by blast
lemma dual1a: "(A\<^sub>1 \<^bold>\<squnion> A\<^sub>2)\<up> = (A\<^sub>1\<up> \<^bold>\<sqinter> A\<^sub>2\<up>)" by blast
lemma dual1b: "(B\<^sub>1 \<^bold>\<squnion> B\<^sub>2)\<down> = (B\<^sub>1\<down> \<^bold>\<sqinter> B\<^sub>2\<down>)" by blast
lemma         "(A\<^sub>1 \<^bold>\<sqinter> A\<^sub>2)\<up> \<^bold>\<sqsubseteq> (A\<^sub>1\<up> \<^bold>\<squnion> A\<^sub>2\<up>)" nitpick oops (*countermodel*)
lemma         "(B\<^sub>1 \<^bold>\<sqinter> B\<^sub>2)\<down> \<^bold>\<sqsubseteq> (B\<^sub>1\<down> \<^bold>\<squnion> B\<^sub>2\<down>)" nitpick oops (*countermodel*)
lemma dual2a: "(A\<^sub>1\<up> \<^bold>\<squnion> A\<^sub>2\<up>) \<^bold>\<sqsubseteq>  (A\<^sub>1 \<^bold>\<sqinter> A\<^sub>2)\<up>" by blast
lemma dual2b: "(B\<^sub>1\<down> \<^bold>\<squnion> B\<^sub>2\<down>) \<^bold>\<sqsubseteq>  (B\<^sub>1 \<^bold>\<sqinter> B\<^sub>2)\<down>" by blast
 (*value conflict tests*)
lemma "\<lfloor>[RELI\<^sup>p] \<^bold>\<and> [WILL\<^sup>p] \<^bold>\<rightarrow> Conflict\<^sup>p\<rfloor>" by simp
lemma "\<lfloor>Conflict\<^sup>p \<^bold>\<rightarrow> [RELI\<^sup>p] \<^bold>\<and> [WILL\<^sup>p]\<rfloor>" by simp
lemma "\<lfloor>[RELI\<^sup>p] \<^bold>\<and> [WILL\<^sup>p]\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>[FAIR\<^sup>d] \<^bold>\<and> [EFFI\<^sup>d]\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(\<^bold>\<not>Conflict\<^sup>p) \<^bold>\<and> [FAIR\<^sup>d] \<^bold>\<and> [EFFI\<^sup>d]\<rfloor>"
 nitpick[satisfy,show_all] nitpick oops (*contingent: p & d independent*)
lemma "\<lfloor>(\<^bold>\<not>Conflict\<^sup>d) \<^bold>\<and> (\<^bold>\<not>Conflict\<^sup>p) \<^bold>\<and> [RELI\<^sup>d] \<^bold>\<and> [WILL\<^sup>p]\<rfloor>"
 nitpick[satisfy,show_all] nitpick oops (*contingent: p & d independent*)
 (*values in two non-opposed quadrants: no conflict*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> Conflict\<^sup>x\<rfloor>" nitpick oops (*countermodel found*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<and> [GAIN\<^sup>x] \<^bold>\<and> [EFFI\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> Conflict\<^sup>x\<rfloor>" nitpick oops
 (*values in two opposed quadrants: conflict*)
lemma "\<lfloor>[RESP\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> Conflict\<^sup>x\<rfloor>" by simp
 (*values in three quadrants: conflict*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<and> [EFFI\<^sup>x] \<^bold>\<and> [RELI\<^sup>x] \<^bold>\<rightarrow> Conflict\<^sup>x\<rfloor>" by simp
 (*values in opposed quadrants for different parties: no conflict*)
lemma "\<lfloor>[EQUI\<^sup>x] \<^bold>\<and> [GAIN\<^sup>y] \<^bold>\<rightarrow> (Conflict\<^sup>x \<^bold>\<or> Conflict\<^sup>y)\<rfloor>" nitpick oops (*cntmdl*)
lemma "\<lfloor>[RESP\<^sup>x] \<^bold>\<and> [STAB\<^sup>y] \<^bold>\<rightarrow> (Conflict\<^sup>x \<^bold>\<or> Conflict\<^sup>y)\<rfloor>" nitpick oops (*cntmdl*)
 (*value preferences tests*)
lemma "\<lfloor>[WILL\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<rfloor>" nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>[WILL\<^sup>x]\<^bold>\<prec>[STAB\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[WILL\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<rfloor>" by blast
lemma "\<lfloor>[WILL\<^sup>x]\<^bold>\<prec>[STAB\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[WILL\<^sup>x]\<^bold>\<prec>[RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<rfloor>" by blast
lemma "\<lfloor>[WILL\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[WILL\<^sup>x]\<^bold>\<prec>[STAB\<^sup>x]\<rfloor>" (*nitpick*) nitpick[satisfy] oops (*ctgnt?*)
lemma "\<lfloor>[WILL\<^sup>x]\<^bold>\<prec>[RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[WILL\<^sup>x]\<^bold>\<prec>[STAB\<^sup>x]\<rfloor>" nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>[WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x]\<rfloor>" nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>[WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[STAB\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x]\<rfloor>" by metis
lemma "\<lfloor>[RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[STAB\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x]\<rfloor>" by metis
lemma "\<lfloor>[STAB\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x]\<rfloor>" nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>[STAB\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x]\<rfloor> \<longrightarrow> \<lfloor>[RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x]\<^bold>\<prec>[WILL\<^sup>x]\<rfloor>" nitpick nitpick[satisfy] oops (*contingent*)
 (*basic properties*)
lemma "\<lfloor>[X]\<^bold>\<prec>[X]\<rfloor>" nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>(([X]\<^bold>\<prec>[Y]) \<^bold>\<and> ([Y]\<^bold>\<prec>[Z])) \<^bold>\<rightarrow> ([X]\<^bold>\<prec>[Z])\<rfloor>" using tSBR by blast (*transitive*)
lemma "\<lfloor>([X]\<^bold>\<prec>[Y]) \<^bold>\<and> ([Y]\<^bold>\<prec>[X])\<rfloor> \<longrightarrow> X = Y" nitpick oops (*not antisymmetric*)
end


theory IMP_Minus_To_IMP_Minus_Minus_nat
  imports  IMP_Minus_To_IMP_Minus_Minus  IMP_Minus_Max_Constant_Nat Binary_Operations_Nat
begin

fun map_var_bit_to_var:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_var_bit_to_var v n = (if n =0 then 0 else (var_bit_to_var_nat (prod_encode (v,hd_nat n)))## map_var_bit_to_var v (tl_nat n)  )"

fun map_var_bit_to_var_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_var_bit_to_var_acc acc v n = (if n =0 then acc
else map_var_bit_to_var_acc ((var_bit_to_var_nat (prod_encode (v,hd_nat n)))## acc) v (tl_nat n)  )"

lemma submap_var_bit_to_var :
"map_var_bit_to_var v n =  map_nat (\<lambda>i. var_bit_to_var_nat (prod_encode (v,i))) n "
  apply (induct v n rule:map_var_bit_to_var.induct)
  apply auto
  done

lemma map_var_bit_to_var_append:
"map_var_bit_to_var v (append_nat xs ys) =
append_nat(map_var_bit_to_var v xs) (map_var_bit_to_var v ys)"
proof -
  obtain xs' ys' where "ys = list_encode ys'"  "xs = list_encode xs'"
  by (metis list_decode_inverse)
  thus ?thesis
    apply(auto simp add: sub_append submap_var_bit_to_var
sub_map
 simp del:map_nat.simps
map_var_bit_to_var.simps)
    done
qed

lemma map_var_bit_to_var_induct:
"reverse_nat (map_var_bit_to_var v (append_nat xs ys))
= map_var_bit_to_var_acc (reverse_nat (map_var_bit_to_var v xs)) v ys"
  apply(induct ys arbitrary:xs rule:length_nat.induct)
   apply(auto simp del:  map_var_bit_to_var_acc.simps  map_var_bit_to_var.simps
          simp add: append_nat_0)
   apply simp
    apply(auto simp del:  map_var_bit_to_var_acc.simps  map_var_bit_to_var.simps
          simp add: append_nat_0 append_nat_Suc)
  apply (subst (2) map_var_bit_to_var_acc.simps)
  apply(auto simp add: map_var_bit_to_var_append subtail_var_bit_to_var
        reverse_append_nat simp del:  map_var_bit_to_var_acc.simps  map_var_bit_to_var.simps
          simp add: append_nat_0 append_nat_Suc)
  apply(subst map_var_bit_to_var.simps)
  apply(auto simp add: cons_Nil
 simp del:  map_var_bit_to_var_acc.simps  map_var_bit_to_var.simps)

  apply(auto simp only: cons0 sub_hd head.simps sub_tl tail.simps)
  apply(subst map_var_bit_to_var.simps)
    apply(auto simp add: reverse_singleton_nat append_singleton_nat
 simp del:  map_var_bit_to_var_acc.simps  map_var_bit_to_var.simps)
  done

definition map_var_bit_to_var_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_var_bit_to_var_tail v n = reverse_nat (map_var_bit_to_var_acc 0 v n)"

lemma subtail_map_var_bit_to_var:
"map_var_bit_to_var_tail v n = map_var_bit_to_var v n"
  apply(auto simp only: map_var_bit_to_var_tail_def)
  using map_var_bit_to_var_induct [of v 0 n] rev_rev_nat map_var_bit_to_var.simps
  by (metis append_nat.simps(1) reverse_nat_0)

definition var_bit_list_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"var_bit_list_nat n v = map_var_bit_to_var v (list_less_nat n)"

definition var_bit_list_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"var_bit_list_tail n v = map_var_bit_to_var_tail v (list_less_tail n)"

lemma subtail_var_bit_list:
"var_bit_list_tail n v = var_bit_list_nat n v"
  apply(auto simp only: var_bit_list_tail_def var_bit_list_nat_def
          subtail_list_less subtail_map_var_bit_to_var)
  done

lemma sub_var_bit_list: "var_bit_list_nat n (vname_encode v) = vname_list_encode (var_bit_list n v)"
  apply (simp only: submap_var_bit_to_var  var_bit_list_nat_def var_bit_list_def sub_var_bit_to_var sub_map sub_list_less
        vname_list_encode_def
 flip: vname_nat_encode.simps )
  apply auto
  by (metis comp_apply)

declare nth_nat.simps[simp del]
datatype IMPm_IMPmm = Bot IMP_Minus_Minus_com |
                      SKIP nat|
                      Assign vname aexp nat |
                      Seq_0 IMP_Minus_com IMP_Minus_com nat |
                      Seq_m IMP_Minus_com IMP_Minus_com nat IMP_Minus_Minus_com  |
                      Seq_f IMP_Minus_com IMP_Minus_com nat IMP_Minus_Minus_com IMP_Minus_Minus_com  |
                      If_0  vname IMP_Minus_com IMP_Minus_com nat|
                      If_m  vname IMP_Minus_com IMP_Minus_com nat IMP_Minus_Minus_com  |
                      If_f vname IMP_Minus_com IMP_Minus_com nat  IMP_Minus_Minus_com IMP_Minus_Minus_com |
                      While_0 vname IMP_Minus_com nat|
                      While_f vname IMP_Minus_com nat IMP_Minus_Minus_com

fun IMPm_IMPmm_encode :: "IMPm_IMPmm \<Rightarrow> nat" where
"IMPm_IMPmm_encode (Bot x) = list_encode [0,comm_encode x]"|
"IMPm_IMPmm_encode (SKIP n) = list_encode [1, n]"|
"IMPm_IMPmm_encode (Assign v a n) = list_encode [2, vname_encode v, aexp_encode a , n]"|
"IMPm_IMPmm_encode (Seq_0 c1 c2 n) = list_encode [3, com_encode c1, com_encode c2, n]"|
"IMPm_IMPmm_encode (Seq_m c1 c2 n c3) = list_encode [4, com_encode c1 ,com_encode c2, n , comm_encode c3]"|
"IMPm_IMPmm_encode (Seq_f c1 c2 n c3 c4) = list_encode [5, com_encode c1 ,com_encode c2, n , comm_encode c3,comm_encode c4]"|
"IMPm_IMPmm_encode (If_0 v c1 c2 n) = list_encode [6, vname_encode v, com_encode c1, com_encode c2, n]"|
"IMPm_IMPmm_encode (If_m v c1 c2 n c3) = list_encode [7, vname_encode v, com_encode c1, com_encode c2, n, comm_encode c3]"|
"IMPm_IMPmm_encode (If_f v c1 c2 n c3 c4) = list_encode [8, vname_encode v, com_encode c1, com_encode c2, n, comm_encode c3 , comm_encode c4]"|
"IMPm_IMPmm_encode (While_0 v c n) = list_encode [9, vname_encode v, com_encode c , n]"|
"IMPm_IMPmm_encode (While_f v c n c') = list_encode [10, vname_encode v, com_encode c, n, comm_encode c']"

fun IMPm_IMPmm_decode :: "nat \<Rightarrow> IMPm_IMPmm" where
"IMPm_IMPmm_decode  n = (case list_decode n of
    [0,x] \<Rightarrow> Bot (comm_decode x)|
    [Suc 0,n] \<Rightarrow> SKIP n|
    [Suc (Suc 0) , v , a, n] \<Rightarrow> Assign (vname_decode v) (aexp_decode a) n|
    [Suc (Suc (Suc 0)), c1, c2,n] \<Rightarrow> Seq_0 (com_decode c1) (com_decode c2) n|
    [Suc (Suc (Suc (Suc 0))), c1, c2 ,n, c3] \<Rightarrow> Seq_m (com_decode c1) (com_decode c2) n (comm_decode c3)|
    [Suc (Suc (Suc (Suc (Suc 0)))), c1, c2, n, c3,c4] \<Rightarrow> Seq_f (com_decode c1) (com_decode c2) n (comm_decode c3) (comm_decode c4)|
    [Suc (Suc (Suc (Suc (Suc (Suc 0))))), v ,c1, c2,n] \<Rightarrow> If_0 (vname_decode v) (com_decode c1)  (com_decode c2) n|
    [Suc (Suc (Suc (Suc (Suc (Suc (Suc 0)))))), v ,c1 ,c2,n,c3] \<Rightarrow> If_m (vname_decode v) (com_decode c1) (com_decode c2) n (comm_decode c3)|
    [Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0))))))),v ,c1 ,c2,n,c3,c4] \<Rightarrow> If_f (vname_decode v) (com_decode c1) (com_decode c2) n (comm_decode c3) (comm_decode c4)|
    [Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0)))))))),v,c,n] \<Rightarrow> While_0 (vname_decode v) (com_decode c)  n|
    [Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0))))))))), v, c, n, c'] \<Rightarrow> While_f (vname_decode v) (com_decode c) n (comm_decode c')
) "

lemma IMPm_IMPmm_id :
"IMPm_IMPmm_decode (IMPm_IMPmm_encode x) = x"
  apply(cases x)
   apply(auto simp add: IMPm_IMPmm_encode.simps IMPm_IMPmm_decode.simps list_encode_inverse comm_id vname_id aexp_id com_id
                    simp del: comm_encode.simps com_encode.simps comm_decode.simps com_decode.simps aexp_encode.simps aexp_decode.simps)
  done

definition IMPm_IMPmm_list_encode :: "IMPm_IMPmm list \<Rightarrow> nat" where
"IMPm_IMPmm_list_encode xs = list_encode (map IMPm_IMPmm_encode xs)"

definition IMPm_IMPmm_list_decode :: "nat \<Rightarrow> IMPm_IMPmm list " where
"IMPm_IMPmm_list_decode xs = map IMPm_IMPmm_decode (list_decode xs)"

lemma IMPm_IMPmm_list_id:
"IMPm_IMPmm_list_decode (IMPm_IMPmm_list_encode x) = x"
  apply(auto simp only:  IMPm_IMPmm_list_decode_def  IMPm_IMPmm_list_encode_def list_encode_inverse
            map_map comp_def IMPm_IMPmm_id)
  apply auto
  done

fun size_e :: "Com.com \<Rightarrow> nat" where
"size_e Com.com.SKIP = 1 "|
"size_e (Com.com.Assign v a)  = 1"|
"size_e (Com.com.Seq c1 c2) = Suc (size_e c1 + size_e c2)"|
"size_e (Com.com.If v c1 c2) = Suc (size_e c1 + size_e c2)"|
"size_e (Com.com.While v c) = Suc (size_e c)"

fun size_stack_rev :: "IMPm_IMPmm list \<Rightarrow> nat" where
"size_stack_rev (Seq_0 c1 c2 _# s) =  (if s = [] then Suc (2* (size_e c1 + size_e c2)) else  Suc (2 * size_e c2) + size_stack_rev s )  "|
"size_stack_rev (Seq_m c1 c2 _ _#s) = (if s = [] then  Suc (2 * size_e c2) else  Suc (size_stack_rev s)) "|
"size_stack_rev (If_0 _ c1 c2 _# s) =  (if s = [] then Suc (2* (size_e c1 + size_e c2)) else  Suc (2 * size_e c2) + size_stack_rev s )  "|
"size_stack_rev (If_m _ c1 c2  _ _#s) = (if s = [] then  Suc (2 * size_e c2) else  Suc (size_stack_rev s)) "|
"size_stack_rev (While_0 _ c _ #s)  = (if s = [] then Suc (2* size_e c) else Suc (size_stack_rev s) )"|
"size_stack_rev (Bot x # s) = (if s =[] then 0 else Suc (size_stack_rev s))"|
"size_stack_rev (_#s) = (if s = [] then 1 else Suc (size_stack_rev s))"|
"size_stack_rev [] = 1"

fun size_stack :: "IMPm_IMPmm list \<Rightarrow> nat" where
"size_stack s = size_stack_rev (rev s)"

lemma
size_stack_mono :" x \<noteq> [] \<Longrightarrow>y \<noteq>  [] \<Longrightarrow> size_stack_rev y < size_stack_rev x
 \<Longrightarrow> size_stack_rev (s @ y) < size_stack_rev (s @ x) "
  apply(induct s )
   apply auto
  subgoal for a xs
    apply (cases a)
           apply (auto)
    done
  done

lemma size_stack_var_0:"(size_stack_rev x = 0) = (\<exists>n. x = [Bot n]) "
  apply(cases x)
   apply auto
  subgoal for a xs
    apply (cases a)
           apply (auto split :if_splits)
    done
 subgoal for a xs
    apply (cases a)
           apply (auto split :if_splits)
   done
  done

fun push_on_stack :: "IMP_Minus_com \<Rightarrow> nat \<Rightarrow> IMPm_IMPmm list \<Rightarrow> IMPm_IMPmm list" where
"push_on_stack Com.SKIP n stack = SKIP n # stack "|
"push_on_stack (Com.Assign v aexp) n stack =  ( Assign v aexp n) # stack "|
"push_on_stack (Com.Seq c1 c2) n stack =  ( Seq_0 c1 c2 n) # stack "|
"push_on_stack (Com.If v c1 c2) n stack =  (If_0 v c1 c2 n) # stack "|
"push_on_stack (Com.While v c) n stack =  (While_0 v c n) # stack "

definition push_on_stack_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"push_on_stack_nat c n s = (if hd_nat c = 0 then (1##n##0)##s else
if hd_nat c = 1 then (2## (nth_nat (Suc 0) c) ## (nth_nat (Suc (Suc 0)) c) ## n ## 0)## s else
if hd_nat c = 2 then (3## (nth_nat (Suc 0) c) ## (nth_nat (Suc (Suc 0)) c) ## n ## 0)## s else
if hd_nat c = 3 then (6## (nth_nat (Suc 0) c) ## (nth_nat (Suc (Suc 0)) c) ## (nth_nat (Suc (Suc (Suc 0))) c) ## n ## 0) ## s else
(9## (nth_nat (Suc 0) c) ## (nth_nat (Suc (Suc 0)) c) ## n ## 0)## s
)"

lemma sub_push_on_stack:
"push_on_stack_nat (com_encode c) n (IMPm_IMPmm_list_encode s) =
IMPm_IMPmm_list_encode (push_on_stack c n s)"
  apply(cases c)
      apply (auto simp only: push_on_stack_nat_def push_on_stack.simps sub_hd head.simps com_encode.simps
             IMPm_IMPmm_list_encode_def sub_cons cons0 sub_nth nth.simps)
  apply auto
  done

fun add_result_to_stack :: "IMP_Minus_Minus_com \<Rightarrow> IMPm_IMPmm list \<Rightarrow> IMPm_IMPmm list" where
"add_result_to_stack c [] = [Bot c]"|
"add_result_to_stack c (Seq_0 c1 c2 n # stack) = Seq_m c1 c2 n c # stack" |
"add_result_to_stack c (Seq_m c1 c2 n c3 #stack) = (Seq_f c1 c2 n c3 c) # stack"|
"add_result_to_stack c (If_0 v c1 c2  n # stack)  = If_m v c1 c2 n c # stack"|
"add_result_to_stack c (If_m v c1 c2 n c3 #stack) = If_f v c1 c2 n c3 c # stack"|
"add_result_to_stack c (While_0 v c' n # stack ) = While_f v c' n c #stack"|
"add_result_to_stack c s = s"

definition add_result_to_stack_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add_result_to_stack_nat c s = (if s = 0 then (0##c##0)##0
else (let h = hd_nat s; con = hd_nat h; t = tl_nat s  in
  if con = 3 then ((4## (nth_nat (Suc 0) h) ## (nth_nat (Suc (Suc 0)) h) ## (nth_nat (Suc (Suc (Suc 0))) h) ## c ## 0) ## t)
  else if con = 4 then ((5## (nth_nat (Suc 0) h) ## (nth_nat (Suc (Suc 0)) h) ## (nth_nat (Suc (Suc (Suc 0))) h)  ## (nth_nat (Suc (Suc (Suc ( Suc 0)))) h) ## c ## 0) ## t)
  else if con = 6 then ((7## (nth_nat (Suc 0) h) ## (nth_nat (Suc (Suc 0)) h) ## (nth_nat (Suc (Suc (Suc 0))) h)  ## (nth_nat (Suc (Suc (Suc ( Suc 0)))) h) ## c ## 0) ## t)
  else if con = 7 then ((8## (nth_nat (Suc 0) h) ## (nth_nat (Suc (Suc 0)) h) ## (nth_nat (Suc (Suc (Suc 0))) h)  ## (nth_nat (Suc (Suc (Suc ( Suc 0)))) h)  ## (nth_nat (Suc (Suc (Suc ( Suc (Suc 0))))) h) ## c ## 0) ## t)
  else if con = 9 then ((10 ## (nth_nat (Suc 0) h) ## (nth_nat (Suc (Suc 0)) h) ## (nth_nat (Suc (Suc (Suc 0))) h) ## c ## 0) ## t)
  else s
))"

lemma sub_add_result_to_stack:
"add_result_to_stack_nat (comm_encode c) (IMPm_IMPmm_list_encode s)
= IMPm_IMPmm_list_encode (add_result_to_stack c s) "
  apply(cases s)
      apply (auto simp only: map_is_Nil_conv
      list_encode_non_empty
      list.simps add_result_to_stack_nat_def add_result_to_stack.simps sub_hd head.simps comm_encode.simps
             IMPm_IMPmm_list_encode_def sub_cons cons0 sub_nth nth.simps)

   apply (auto simp del: list_encode.simps)
  subgoal for a xs
    apply(cases a)
   apply (auto simp add: Let_def sub_tl sub_cons sub_nth sub_hd list.simps simp del: list_encode.simps)
    done
  done

lemma add_res_less:
"\<forall>x. s \<noteq> [Bot x] \<and> a \<noteq> Bot x \<Longrightarrow> size_stack (add_result_to_stack r s) < size_stack (a#s) "
  apply(cases s)
   apply auto
   apply (cases a)
  apply (auto simp add: size_stack_var_mono)
  subgoal for a xs
    apply (cases a)
    using size_stack_mono size_stack_var_0 nat_less_le    apply (auto )
    done
  done

function IMP_Minus_to_IMP_Minus_Minus_stack :: "IMPm_IMPmm list \<Rightarrow> IMP_Minus_Minus_com" where
"IMP_Minus_to_IMP_Minus_Minus_stack (Seq_0 c1 c2 n #stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (push_on_stack c1 n (Seq_0 c1 c2 n #stack))"|
"IMP_Minus_to_IMP_Minus_Minus_stack (Seq_m c1 c2 n c3 #stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (push_on_stack c2 n (Seq_m c1 c2 n c3 #stack ))"|
"IMP_Minus_to_IMP_Minus_Minus_stack (If_0 v c1 c2 n # stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (push_on_stack c1 n (If_0 v c1 c2 n #stack ))"|
"IMP_Minus_to_IMP_Minus_Minus_stack (If_m v c1 c2 n c3 # stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (push_on_stack c2 n (If_m v c1 c2 n c3 #stack ))"|
"IMP_Minus_to_IMP_Minus_Minus_stack (While_0 v c n # stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (push_on_stack c n (While_0 v c n #stack ))" |
"IMP_Minus_to_IMP_Minus_Minus_stack (SKIP _ # stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (add_result_to_stack (IMP_Minus_Minus_Com.SKIP) stack)" |
"IMP_Minus_to_IMP_Minus_Minus_stack (Assign v aexp n # stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (add_result_to_stack (assignment_to_binary n v aexp) stack)"|
"IMP_Minus_to_IMP_Minus_Minus_stack (Seq_f _ _ _ c1 c2 # stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (add_result_to_stack (IMP_Minus_Minus_Com.Seq c1 c2) stack)"|
"IMP_Minus_to_IMP_Minus_Minus_stack (If_f v _ _ n c1 c2 # stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (add_result_to_stack ( IMP_Minus_Minus_Com.If (var_bit_list n v) c1  c2) stack)"|
"IMP_Minus_to_IMP_Minus_Minus_stack (While_f v _ n c # stack) =
  IMP_Minus_to_IMP_Minus_Minus_stack (add_result_to_stack (IMP_Minus_Minus_Com.While (var_bit_list n v) c) stack)"|
"IMP_Minus_to_IMP_Minus_Minus_stack (Bot res # stack) =  res"|
"IMP_Minus_to_IMP_Minus_Minus_stack [] =  com.SKIP"
  by pat_completeness  auto
termination
proof  (relation "measure size_stack",goal_cases)
case 1
then show ?case by auto
next
  case (2 c1 c2 n stack)
  then show ?case   using size_stack_mono by (cases c1)  auto
next
  case (3 c1 c2 n c3 stack)
  then show ?case  using size_stack_mono by (cases c2)  auto
next
  case (4 v c1 c2 n stack)
  then show ?case  using size_stack_mono by (cases c1)  auto
next
  case (5 v c1 c2 n c3 stack)
  then show ?case  using size_stack_mono by (cases c2)  auto
next
  case (6 v c n stack)
  then show ?case  using size_stack_mono by (cases c)  auto
next
  case (7 uu stack)
  then show ?case using add_res_less apply auto
    by (metis IMP_Minus_To_IMP_Minus_Minus_nat.size_stack_var_0
IMPm_IMPmm.distinct One_nat_def Suc_less_SucD Suc_mono add_result_to_stack.simps
gr0I length_Cons length_append_singleton list.size(3) rev_singleton_conv zero_less_one)

next
  case (8 v aexp n stack)
  then show ?case  using add_res_less apply auto
    by (metis IMP_Minus_To_IMP_Minus_Minus_nat.size_stack_var_0
IMPm_IMPmm.distinct One_nat_def Suc_less_SucD Suc_mono add_result_to_stack.simps
gr0I length_Cons length_append_singleton list.size(3) rev_singleton_conv zero_less_one)

next
case (9 uv uw ux c1 c2 stack)
  then show ?case  using add_res_less apply auto
    by (metis IMP_Minus_To_IMP_Minus_Minus_nat.size_stack_var_0
IMPm_IMPmm.distinct One_nat_def Suc_less_SucD Suc_mono add_result_to_stack.simps
gr0I length_Cons length_append_singleton list.size(3) rev_singleton_conv zero_less_one)

next
  case (10 v uy uz n c1 c2 stack)
  then show ?case  using add_res_less apply auto
    by (metis IMP_Minus_To_IMP_Minus_Minus_nat.size_stack_var_0
IMPm_IMPmm.distinct One_nat_def Suc_less_SucD Suc_mono add_result_to_stack.simps
gr0I length_Cons length_append_singleton list.size(3) rev_singleton_conv zero_less_one)

next
  case (11 v va n c stack)
  then show ?case  using add_res_less apply auto
    by (metis IMP_Minus_To_IMP_Minus_Minus_nat.size_stack_var_0
IMPm_IMPmm.distinct One_nat_def Suc_less_SucD Suc_mono add_result_to_stack.simps
gr0I length_Cons length_append_singleton list.size(3) rev_singleton_conv zero_less_one)

qed

function (domintros) IMP_Minus_to_IMP_Minus_Minus_stack_nat :: "nat \<Rightarrow> nat" where
"IMP_Minus_to_IMP_Minus_Minus_stack_nat s  = ( if s = 0 then 0##0 else let h = hd_nat s ; c = hd_nat h ; t = tl_nat s in
  if c = 3  then  IMP_Minus_to_IMP_Minus_Minus_stack_nat (push_on_stack_nat (nth_nat (Suc 0) h) (nth_nat (Suc (Suc (Suc 0))) h) s)
else if c = 4 then IMP_Minus_to_IMP_Minus_Minus_stack_nat (push_on_stack_nat (nth_nat (Suc (Suc 0)) h) (nth_nat (Suc (Suc (Suc 0))) h) s)
else if c = 6 then IMP_Minus_to_IMP_Minus_Minus_stack_nat (push_on_stack_nat (nth_nat (Suc (Suc 0)) h) (nth_nat (Suc (Suc (Suc (Suc 0)))) h) s)
else if c = 7 then IMP_Minus_to_IMP_Minus_Minus_stack_nat (push_on_stack_nat (nth_nat (Suc (Suc (Suc 0))) h) (nth_nat (Suc (Suc (Suc (Suc 0)))) h) s)
else if c = 9 then IMP_Minus_to_IMP_Minus_Minus_stack_nat (push_on_stack_nat (nth_nat (Suc (Suc 0)) h) (nth_nat (Suc (Suc (Suc 0))) h) s)
else if c = 1 then IMP_Minus_to_IMP_Minus_Minus_stack_nat (add_result_to_stack_nat (0##0) t)
else if c = 2 then IMP_Minus_to_IMP_Minus_Minus_stack_nat (add_result_to_stack_nat (assignment_to_binary_nat (nth_nat (Suc (Suc (Suc 0))) h) (nth_nat (Suc 0) h) (nth_nat (Suc (Suc 0)) h)) t)
else if c = 5 then IMP_Minus_to_IMP_Minus_Minus_stack_nat (add_result_to_stack_nat (2 ## (nth_nat (Suc (Suc (Suc (Suc 0)))) h) ## (nth_nat (Suc (Suc (Suc (Suc(Suc 0))))) h) ## 0  ) t)
else if c = 8 then IMP_Minus_to_IMP_Minus_Minus_stack_nat (add_result_to_stack_nat (3 ## (var_bit_list_nat (nth_nat (Suc (Suc (Suc (Suc 0)))) h)
  (nth_nat (Suc 0) h))
 ## (nth_nat (Suc (Suc (Suc (Suc (Suc 0))))) h) ## (nth_nat (Suc (Suc (Suc (Suc (Suc (Suc 0)))))) h) ## 0  ) t)
else if c = 10 then IMP_Minus_to_IMP_Minus_Minus_stack_nat (add_result_to_stack_nat (4 ## (var_bit_list_nat (nth_nat (Suc (Suc (Suc 0))) h)
  (nth_nat (Suc 0) h))
 ## (nth_nat (Suc (Suc (Suc (Suc 0)))) h)  ## 0  ) t )

else nth_nat (Suc 0) h

)"
  by pat_completeness auto

lemma push_non_empty : "push_on_stack c n s \<noteq> []"
  apply(cases c)
      apply auto
  done
lemma add_result_non_empty: "add_result_to_stack c s \<noteq> []"
  apply(cases s)
   apply auto
  subgoal for a xs
    apply(cases a)
              apply auto
    done
  done

lemma IMP_Minus_To_IMP_Minus_Minus_term:
"IMP_Minus_to_IMP_Minus_Minus_stack_nat_dom (IMPm_IMPmm_list_encode c)"
proof (induct c rule:IMP_Minus_to_IMP_Minus_Minus_stack.induct)
case (1 c1 c2 n stack)
  then show ?case  using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [3, com_encode c1, com_encode c2, n] # map IMPm_IMPmm_encode stack)"]
    apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
    apply( simp only: sub_push_on_stack flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)
    done
next
  case (2 c1 c2 n c3 stack)
  then show ?case using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [4, com_encode c1, com_encode c2, n, comm_encode c3] # map IMPm_IMPmm_encode stack)"]
    apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
    apply( simp only: sub_push_on_stack flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)
    done
next
  case (3 v c1 c2 n stack)
  then show ?case  using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [6, vname_encode v, com_encode c1, com_encode c2, n] # map IMPm_IMPmm_encode stack)"]

    apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
    apply( simp only: sub_push_on_stack flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)
    done
next
  case (4 v c1 c2 n c3 stack)
  then show ?case  using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [7, vname_encode v, com_encode c1, com_encode c2, n, comm_encode c3] # map IMPm_IMPmm_encode stack)"]
    apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
            apply( simp only: sub_push_on_stack flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)

    done
  next
    case (5 v c n stack)
    then show ?case  using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [9, vname_encode v, com_encode c, n] # map IMPm_IMPmm_encode stack)"]
 apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
            apply( simp only: sub_add_result_to_stack sub_push_on_stack flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)
      done
next
  case (6 uu stack)
  then show ?case  using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [1, uu] # map IMPm_IMPmm_encode stack)"]
    apply(simp only: Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  flip: comm_encode.simps )
    apply( simp only:sub_add_result_to_stack  flip: IMPm_IMPmm_list_encode_def )
    done
next
  case (7 v aexp n stack)
  then show ?case   using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [2, vname_encode v, aexp_encode aexp, n] # map IMPm_IMPmm_encode stack)"]

    apply(simp only: Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  flip: comm_encode.simps )
       apply( simp only:sub_add_result_to_stack sub_assignment_to_binary  flip: IMPm_IMPmm_list_encode_def )
done
  next
  case (8 uv uw ux c1 c2 stack)
  then show ?case using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [5, com_encode uv, com_encode uw, ux, comm_encode c1, comm_encode c2] #
         map IMPm_IMPmm_encode stack)"]

    apply(simp only: sub_var_bit_list sub_add_result_to_stack  Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  )
    apply(simp only: sub_add_result_to_stack flip: IMPm_IMPmm_list_encode_def comm_encode.simps)
    done
next
  case (9 v uy uz n c1 c2 stack)
  then show ?case   using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [8, vname_encode v, com_encode uy, com_encode uz, n, comm_encode c1,
          comm_encode c2] #
         map IMPm_IMPmm_encode stack)"]

    apply(simp only: sub_var_bit_list sub_add_result_to_stack  Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  )
  apply(simp only: sub_add_result_to_stack flip: IMPm_IMPmm_list_encode_def comm_encode.simps)
    done
next
  case (10 v va n c stack)
  then show ?case   using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [10, vname_encode v, com_encode va, n, comm_encode c] #
         map IMPm_IMPmm_encode stack)"]

    apply(simp only: sub_var_bit_list sub_add_result_to_stack  Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  )
  apply(simp only: sub_add_result_to_stack flip: IMPm_IMPmm_list_encode_def comm_encode.simps)
    done
next
  case (11 res stack)
  then show ?case   using IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros[of
"list_encode
       (list_encode [0, comm_encode res] #
         map IMPm_IMPmm_encode stack)"]
    apply(simp only: sub_var_bit_list sub_add_result_to_stack  Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  )
done
next
  case 12
  then show ?case by (auto intro: IMP_Minus_to_IMP_Minus_Minus_stack_nat.domintros
simp add:IMPm_IMPmm_list_encode_def)
qed

lemma IMPm_IMPmm_list_encode_0: "(IMPm_IMPmm_list_encode xs = 0) = (xs = [])"
  by (auto simp add: IMPm_IMPmm_list_encode_def list_encode_0)
lemma subtailnat_IMP_Minus_to_IMP_Minus_Minus_stack:
" IMP_Minus_to_IMP_Minus_Minus_stack_nat (IMPm_IMPmm_list_encode s)
= comm_encode (IMP_Minus_to_IMP_Minus_Minus_stack s) "
proof (induct s rule: IMP_Minus_to_IMP_Minus_Minus_stack.induct )
case (1 c1 c2 n stack)
  then show ?case apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
  using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
            apply( simp only: sub_push_on_stack  flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)
            apply (auto simp add: push_non_empty  IMPm_IMPmm_list_encode_0) done
next
  case (2 c1 c2 n c3 stack)
  then show ?case  apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
          apply( simp only: sub_push_on_stack IMPm_IMPmm_list_encode_0 flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)
           apply (auto) done
next
  case (3 v c1 c2 n stack)
  then show ?case  apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
            apply( simp only: sub_push_on_stack flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)
          apply (auto simp add: IMPm_IMPmm_list_encode_0  ) done
next
  case (4 v c1 c2 n c3 stack)
  then show ?case apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
            apply( simp only: sub_push_on_stack flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)
          apply (auto simp add: IMPm_IMPmm_list_encode_0  ) done
next
  case (5 v c n stack)
  then show ?case apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: Let_def sub_hd head.simps sub_nth nth.simps sub_push_on_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps)
            apply( simp only: sub_add_result_to_stack sub_push_on_stack flip:IMPm_IMPmm_encode.simps list.simps IMPm_IMPmm_list_encode_def)
          apply (auto simp add: IMPm_IMPmm_list_encode_0  ) done
next
  case (6 uu stack)
  then show ?case apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  flip: comm_encode.simps )
       apply( simp only:sub_add_result_to_stack  flip: IMPm_IMPmm_list_encode_def )
          apply (auto simp add: IMPm_IMPmm_list_encode_0  ) done
next
  case (7 v aexp n stack)
  then show ?case  apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  flip: comm_encode.simps )
       apply( simp only:sub_add_result_to_stack sub_assignment_to_binary  flip: IMPm_IMPmm_list_encode_def )
          apply (auto simp add: IMPm_IMPmm_list_encode_0  ) done
next
  case (8 uv uw ux c1 c2 stack)
  then show ?case apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  flip: comm_encode.simps )
       apply( simp only:sub_add_result_to_stack sub_assignment_to_binary  flip: IMPm_IMPmm_list_encode_def )
 apply (auto simp add: IMPm_IMPmm_list_encode_0  ) done
next
  case (9 v uy uz n c1 c2 stack)
  then show ?case apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: sub_var_bit_list sub_add_result_to_stack  Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  )
  apply(simp only: sub_add_result_to_stack flip: IMPm_IMPmm_list_encode_def comm_encode.simps)
  apply (auto simp add: IMPm_IMPmm_list_encode_0  )
done
next
  case (10 v va n c stack)
  then show ?case apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: sub_var_bit_list sub_add_result_to_stack  Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  )
  apply(simp only: sub_add_result_to_stack flip: IMPm_IMPmm_list_encode_def comm_encode.simps)
          apply (auto simp add: IMPm_IMPmm_list_encode_0  ) done
next
  case (11 res stack)
  then show ?case apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
            apply(simp only: sub_var_bit_list sub_add_result_to_stack  Let_def cons0 sub_cons sub_hd sub_tl tail.simps head.simps sub_nth nth.simps sub_push_on_stack sub_add_result_to_stack sub_nth nth.simps
IMPm_IMPmm_list_encode_def list.simps IMPm_IMPmm_encode.simps  )
  apply(simp only: sub_add_result_to_stack flip: IMPm_IMPmm_list_encode_def comm_encode.simps)
  apply (auto simp add: IMPm_IMPmm_list_encode_0  ) done
next
  case 12
  then show ?case  apply(subst IMP_Minus_to_IMP_Minus_Minus_stack_nat.psimps)
  using  IMP_Minus_To_IMP_Minus_Minus_term apply blast
    apply (auto simp add: IMPm_IMPmm_list_encode_0 cons_def  )
  done
qed

lemma IMP_Minus_to_IMP_Minus_Minus_stack_correct:
"IMP_Minus_to_IMP_Minus_Minus_stack (push_on_stack c n stack)
= IMP_Minus_to_IMP_Minus_Minus_stack (add_result_to_stack (IMP_Minus_To_IMP_Minus_Minus c n) stack)"
  by (induct c arbitrary:stack) auto

definition IMP_Minus_to_IMP_Minus_Minus_t:: "IMP_Minus_com \<Rightarrow> nat \<Rightarrow> IMP_Minus_Minus_com" where
  "IMP_Minus_to_IMP_Minus_Minus_t c n =
IMP_Minus_to_IMP_Minus_Minus_stack (push_on_stack c n [])"

definition IMP_Minus_To_IMP_Minus_Minus_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "IMP_Minus_To_IMP_Minus_Minus_nat c n =
IMP_Minus_to_IMP_Minus_Minus_stack_nat (push_on_stack_nat c n 0)"

lemma IMPm_IMPmm_nil: "0 = IMPm_IMPmm_list_encode []"
  using IMPm_IMPmm_list_encode_def by force

lemma subtailnat_IMP_Minus_to_IMP_Minus_Minus:
"IMP_Minus_To_IMP_Minus_Minus_nat (com_encode c) n
= comm_encode (IMP_Minus_to_IMP_Minus_Minus_t c n)"
  using push_non_empty subtailnat_IMP_Minus_to_IMP_Minus_Minus_stack
  apply(auto simp only: IMPm_IMPmm_nil IMP_Minus_To_IMP_Minus_Minus_nat_def IMP_Minus_to_IMP_Minus_Minus_t_def
       sub_push_on_stack )
  done

lemma subtail_IMP_Minus_to_IMP_Minus_Minus:
"IMP_Minus_to_IMP_Minus_Minus_t c n =
IMP_Minus_To_IMP_Minus_Minus c n "
  using  IMP_Minus_to_IMP_Minus_Minus_stack_correct [of c n "[]"]
  apply (auto simp add:IMP_Minus_to_IMP_Minus_Minus_t_def)
  done
lemma sub_IMP_Minus_To_IMP_Minus_Minus:
"IMP_Minus_To_IMP_Minus_Minus_nat (com_encode c) n = comm_encode (IMP_Minus_To_IMP_Minus_Minus c n)"
  using subtail_IMP_Minus_to_IMP_Minus_Minus subtailnat_IMP_Minus_to_IMP_Minus_Minus by presburger

definition IMP_Minus_To_IMP_Minus_Minus_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"IMP_Minus_To_IMP_Minus_Minus_tail c n = IMP_Minus_To_IMP_Minus_Minus_nat c n "

lemma subtail_IMP_Minus_To_IMP_Minus_Minus:
"IMP_Minus_To_IMP_Minus_Minus_tail c n = IMP_Minus_To_IMP_Minus_Minus_nat c n "
  by (simp add: IMP_Minus_To_IMP_Minus_Minus_tail_def)

end


(*

Copyright (c) 2017, ETH Zurich
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

(*<*)
theory Equivalence
  imports Resolution
begin
(*>*)

subsection {* View Equivalence *}
text_raw {* \label{sec:vieweq} *}

text {* A view is a function that encodes the result of all address resolutions beginning at a
  given node. *}

type_synonym view = "addr \<Rightarrow> name set"

definition view_from :: "nodeid \<Rightarrow> net \<Rightarrow> view"
  where "view_from node net = (\<lambda>addr. resolve net (node, addr))"

text {* A remapping is a renaming of nodes, leaving addresses intact. *}
type_synonym remap = "nodeid \<Rightarrow> nodeid"

definition rename :: "remap \<Rightarrow> name \<Rightarrow> name"
  where "rename m n = (m (fst n), snd n)"
    (*<*)
lemma rename_id:
  "rename id ` S = S"
  unfolding rename_def id_def by(auto)
    (*>*)

primrec rename_list :: "(nodeid \<Rightarrow> nodeid) \<Rightarrow> nodeid list \<Rightarrow> (nodeid \<Rightarrow> nodeid)"
  where "rename_list f [] = id" |
        "rename_list f (nd#nds) = (\<lambda>x. if x = nd then f nd else x) o (rename_list f nds)"

text {* Two nets are view-equivalent for some node, if the two views have the same domain, and
  give the same result for all addresses, modulo a renaming of accepting nodes. *}
definition view_eq :: "nodeid \<Rightarrow> (remap \<times> net) \<Rightarrow> (remap \<times> net) \<Rightarrow> bool"
  where "view_eq nd x y \<longleftrightarrow>
          (\<forall>a. resolve_dom (snd x,(nd,a)) = resolve_dom (snd y,(nd,a))) \<and>
          (\<forall>a. resolve_dom (snd x,(nd,a)) \<longrightarrow>
            rename (fst x) ` view_from nd (snd x) a =
            rename (fst y) ` view_from nd (snd y) a)"
    (*<*)
definition view_le :: "nodeid \<Rightarrow> (remap \<times> net) \<Rightarrow> (remap \<times> net) \<Rightarrow> bool"
  where "view_le nd x y \<longleftrightarrow>
          (\<forall>a. resolve_dom (snd x,(nd,a)) \<longrightarrow> resolve_dom (snd y,(nd,a))) \<and>
          (\<forall>a. resolve_dom (snd x,(nd,a)) \<longrightarrow>
            rename (fst x) ` view_from nd (snd x) a =
            rename (fst y) ` view_from nd (snd y) a)"
    (*>*)

definition view_eq_on :: "nodeid set \<Rightarrow> (remap \<times> net) \<Rightarrow> (remap \<times> net) \<Rightarrow> bool"
  where "view_eq_on S x y \<longleftrightarrow> (\<forall>nd\<in>S. view_eq nd x y)"
    (*<*)
definition view_le_on :: "nodeid set \<Rightarrow> (remap \<times> net) \<Rightarrow> (remap \<times> net) \<Rightarrow> bool"
  where "view_le_on S x y \<longleftrightarrow> (\<forall>nd\<in>S. view_le nd x y)"
    (*>*)
text {* Two nodes are equivalent (for a given net) if they have the same view. *}
definition node_eq :: "net \<Rightarrow> nodeid \<Rightarrow> nodeid \<Rightarrow> bool"
  where "node_eq net nd nd' \<longleftrightarrow>
          (\<forall>a. resolve_dom (net,(nd,a)) = resolve_dom (net,(nd',a))) \<and>
          (\<forall>a. resolve_dom (net,(nd,a)) \<longrightarrow> view_from nd net a = view_from nd' net a)"
    (*<*)
lemma view_eq_empty:
  "view_eq_on {} x y"
  by(simp add:view_eq_on_def)

lemma view_eq_onI:
  "(\<And>nd. nd \<in> S \<Longrightarrow> view_eq nd x y) \<Longrightarrow> view_eq_on S x y"
  by(simp add:view_eq_on_def)

lemma view_le_onI:
  "(\<And>nd. nd \<in> S \<Longrightarrow> view_le nd x y) \<Longrightarrow> view_le_on S x y"
  by(simp add:view_le_on_def)

lemma view_eqI:
  "(\<And>a. resolve_dom (snd x, (nd,a)) = resolve_dom (snd y, (nd,a))) \<Longrightarrow>
   (\<And>a. resolve_dom (snd x, (nd,a)) \<Longrightarrow>
        rename (fst x) ` view_from nd (snd x) a =
        rename (fst y) ` view_from nd (snd y) a) \<Longrightarrow> view_eq nd x y"
  by(simp add:view_eq_def)

lemma view_leI:
  "(\<And>a. resolve_dom (snd x, (nd,a)) \<Longrightarrow> resolve_dom (snd y, (nd,a))) \<Longrightarrow>
   (\<And>a. resolve_dom (snd x, (nd,a)) \<Longrightarrow>
        rename (fst x) ` view_from nd (snd x) a =
        rename (fst y) ` view_from nd (snd y) a) \<Longrightarrow> view_le nd x y"
  by(simp add:view_le_def)

lemma view_eq_domD:
  "view_eq nd x y \<Longrightarrow> resolve_dom (snd x, nd, a) = resolve_dom (snd y, nd, a)"
  by(simp only:view_eq_def)

lemma view_le_domD:
  "view_le nd x y \<Longrightarrow> resolve_dom (snd x, nd, a) \<Longrightarrow> resolve_dom (snd y, nd, a)"
  by(simp only:view_le_def)

lemma view_eq_viewD:
  "view_eq nd x y \<Longrightarrow> resolve_dom (snd x, nd, a) \<Longrightarrow>
   rename (fst x) ` view_from nd (snd x) a = rename (fst y) ` view_from nd (snd y) a"
  by(simp only:view_eq_def)

lemma view_le_viewD:
  "view_le nd x y \<Longrightarrow> resolve_dom (snd x, nd, a) \<Longrightarrow>
   rename (fst x) ` view_from nd (snd x) a = rename (fst y) ` view_from nd (snd y) a"
  by(simp only:view_le_def)

    (*>*)
text {* Both view-equivalence and node-equivalence are proper equivalence relations. *}

lemma equivp_view_eq:
  "\<And>nd. equivp (view_eq nd)"
    (*<*)
  by(intro equivpI sympI transpI reflpI, simp_all add:view_eq_def)
    (*>*)

lemma equivp_view_eq_on:
  fixes S :: "nodeid set"
  shows "equivp (view_eq_on S)"
    (*<*)
  unfolding view_eq_on_def using equivp_view_eq
  by(blast intro:equivpI reflpI sympI transpI
           dest:equivp_reflp equivp_symp equivp_transp)

lemma equivp_node_eq:
  "\<And>net. equivp (node_eq net)"
  by(intro equivpI sympI transpI reflpI, simp_all add:node_eq_def)

lemma transp_view_le:
  "\<And>nd. transp (view_le nd)"
  by(intro transpI, simp add:view_le_def)

lemma transp_view_le_on:
  "\<And>S. transp (view_le_on S)"
  unfolding view_le_on_def
  using transp_view_le by(blast dest:transpD intro:transpI)

lemma view_eq_view_le:
  "view_eq nd x y \<Longrightarrow> view_le nd x y"
  by(simp add:view_eq_def view_le_def)

lemma view_eq_on_view_le_on:
  "view_eq_on S x y \<Longrightarrow> view_le_on S x y"
  by(simp add:view_eq_on_def view_le_on_def view_eq_view_le)

lemma view_eq_antisym:
  "view_le nd x y \<Longrightarrow> view_le nd y x \<Longrightarrow> view_eq nd x y"
  unfolding view_le_def view_eq_def by(blast)

lemma view_eq_on_antisym:
  "view_le_on S x y \<Longrightarrow> view_le_on S y x \<Longrightarrow> view_eq_on S x y"
  unfolding view_le_on_def view_eq_on_def by(blast intro:view_eq_antisym)

lemmas view_eq_symp = equivp_symp[OF equivp_view_eq]
lemmas view_eq_on_symp = equivp_symp[OF equivp_view_eq_on]

text {* Declare rules for transitivity reasoning. *}
lemmas [trans] = equivp_transp[OF equivp_view_eq_on] equivp_transp[OF equivp_view_eq]
                 transpD[OF transp_view_le_on] transpD[OF transp_view_le]
                 transpD[OF transp_view_le_on, OF view_eq_on_view_le_on]
                 transpD[OF transp_view_le, OF view_eq_view_le]
                 transpD[OF transp_view_le_on, OF _ view_eq_on_view_le_on]
                 transpD[OF transp_view_le, OF _ view_eq_view_le]
    (*>*)
text {* Both equivalence relations preserve resolution. *}

lemma node_eq_resolve:
  fixes nd nd' :: nodeid and net :: net and a :: addr
  shows "node_eq net nd nd' \<Longrightarrow> resolve_dom (net,nd,a) \<Longrightarrow> resolve net (nd,a) = resolve net (nd',a)"
    (*<*)
  by(simp only:node_eq_def view_from_def)
    (*>*)

lemma view_eq_resolve:
  fixes nd :: nodeid and x y :: "remap \<times> net" and a :: addr
  shows "view_eq nd x y \<Longrightarrow> resolve_dom (snd x,nd,a) \<Longrightarrow>
         rename (fst x) ` resolve (snd x) (nd,a) = rename (fst y) ` resolve (snd y) (nd,a)"
    (*<*)
  by(simp only:view_eq_def view_from_def)

lemma view_le_resolve:
  shows "view_le nd x y \<Longrightarrow> resolve_dom (snd x,nd,a) \<Longrightarrow>
         rename (fst x) ` resolve (snd x) (nd,a) = rename (fst y) ` resolve (snd y) (nd,a)"
  by(simp only:view_le_def view_from_def)
    (*>*)
text {* View-equivalence is preserved by any further node renaming. *}
    (*<*)
lemma view_le_comp:
  assumes le_fg: "view_le nd (f,net) (g,net')"
  shows "view_le nd (h o f,net) (h o g,net')"
proof(intro view_leI, simp_all)
  fix a
  assume dom: "resolve_dom (net, nd, a)"
  with le_fg show dom': "resolve_dom (net', nd, a)"
    by(auto dest:view_le_domD)

  show "rename (h \<circ> f) ` view_from nd net a = rename (h \<circ> g) ` view_from nd net' a"
    (is "?A (h o f) = ?B (h o g)")
  proof(intro set_eqI iffI)
    fix x
    assume "x \<in> ?A (h o f)"
    then obtain y where yin: "y \<in> view_from nd net a" and xeq: "x = rename (h o f) y"
      by(blast)

    let ?x' = "rename f y"
    from yin have "?x' \<in> ?A f" by(auto)
    with dom have "?x' \<in> ?B g" by(simp add: view_le_viewD[OF le_fg, simplified])
    then obtain y' where y'in: "y' \<in> view_from nd net' a" and x'eq: "?x' = rename g y'"
      by(blast)

    from xeq x'eq have "x = rename (h o g) y'" by(simp add:rename_def)
    with y'in show "x \<in> ?B (h o g)" by(blast)
  next
    fix x
    assume "x \<in> ?B (h o g)"
    then obtain y where yin: "y \<in> view_from nd net' a" and xeq: "x = rename (h o g) y"
      by(blast)

    let ?x' = "rename g y"
    from yin have "?x' \<in> ?B g" by(auto)
    with dom have "?x' \<in> ?A f" by(simp add: view_le_viewD[OF le_fg, simplified])
    then obtain y' where y'in: "y' \<in> view_from nd net a" and x'eq: "?x' = rename f y'"
      by(blast)

    from xeq x'eq have "x = rename (h o f) y'" by(simp add:rename_def)
    with y'in show "x \<in> ?A (h o f)" by(blast)
  qed
qed
    (*>*)
lemma view_eq_comp:
  "view_eq nd (f,net) (g,net') \<Longrightarrow> view_eq nd (h o f,net) (h o g,net')"
    (*<*)
  by(blast intro:view_eq_antisym view_le_comp
     dest:view_eq_view_le view_eq_view_le[OF view_eq_symp])

lemma view_le_on_comp:
  "view_le_on S (f,net) (g,net') \<Longrightarrow> view_le_on S (h o f,net) (h o g,net')"
  by(simp add:view_le_comp view_le_on_def)

lemma view_eq_on_comp:
  "view_eq_on S (f,net) (g,net') \<Longrightarrow> view_eq_on S (h o f,net) (h o g,net')"
  by(simp add:view_eq_comp view_eq_on_def)
(*>*)
text {* For transformations that add nodes, we need to know that the new node has no descendents
  or ancestors. *}
definition fresh_node :: "net \<Rightarrow> nodeid \<Rightarrow> bool"
  where "fresh_node net nd \<longleftrightarrow>
          (\<forall>a. translate (net nd) a = {}) \<and>
          (\<forall>x y. (x,y) \<in> decodes_to net \<longrightarrow> fst x \<noteq> nd) \<and>
          accept (net nd) = {}"

(*<*)
lemma fresh_node_translateD: "\<And>net nd a. fresh_node net nd \<Longrightarrow> translate (net nd) a = {}"
  by(auto simp:fresh_node_def)
lemma fresh_node_reachableD: "\<And>net nd x y. fresh_node net nd \<Longrightarrow> (x,y) \<in> decodes_to net \<Longrightarrow> fst x \<noteq> nd"
  unfolding fresh_node_def by(blast)
lemma fresh_node_acceptD: "\<And>net nd. fresh_node net nd \<Longrightarrow> accept (net nd) = {}"
  by(simp add:fresh_node_def)

end
(*>*)


theory Impl_List_Playground
imports "../TopoS_Impl"
begin

text\<open>The executbale models and the composition theory. We can build examples here\<close>

definition testGraph :: "string list_graph" where
  "testGraph \<equiv> \<lparr> nodesL = [''Master'', ''Slave1'', ''Slave2'', ''other1'', ''other2''],
                 edgesL = [(''Master'', ''Slave1'')] \<rparr>"

lemma "wf_list_graph testGraph" by eval

definition req1 ::"(string SecurityInvariant)" where
  "req1 \<equiv> new_configured_list_SecurityInvariant SINVAR_SecGwExt_impl.SINVAR_LIB_PolEnforcePointExtended \<lparr>
      node_properties = [''Master'' \<mapsto> PolEnforcePoint,
                         ''Slave1'' \<mapsto> DomainMember,
                         ''Slave2'' \<mapsto> DomainMember]
      \<rparr> ''req1''"

definition "req2 \<equiv> new_configured_list_SecurityInvariant SINVAR_NoRefl_impl.SINVAR_LIB_NoRefl \<lparr>
      node_properties = [''Master'' \<mapsto> Refl,
                         ''other1'' \<mapsto> Refl,
                         ''other2'' \<mapsto> Refl]
      \<rparr> ''req2''"

definition "reqs = [req1, req2]"

definition "max_network = generate_valid_topology reqs
      \<lparr>nodesL = nodesL testGraph, edgesL = List.product (nodesL testGraph) (nodesL testGraph) \<rparr>"

value "max_network"

ML\<open>
visualize_graph @{context} @{term "reqs"} @{term "max_network"};
\<close>

end


theory Hopcroft_Tarjan_Mutual_Recursion
  imports
    Hopcroft_Tarjan
begin

type_synonym ('a, 'b) component = "('a, 'b) Directed_Multigraph.edge list"

record ('b, 't, 'g, 'a) state =
  root :: 'b
  tree :: 't
  multigraph :: 'g
  ESTACK :: "('a, 'b) Directed_Multigraph.edge list"
  Cs :: "('a, 'b) component list"

locale path_search =
  other
  where other = other +
    T: Map
  where empty = T_empty
    and update = T_update
    and delete = T_delete
    and lookup = T_lookup
    and invar = T_invar +
    P: Incidence_Structure
  where insert = insert
  for other :: "('a::linorder, 'b::linorder) Multigraph.edge \<Rightarrow> 'b \<Rightarrow> 'b"
    and T_empty
    and T_update :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and T_delete
    and T_lookup
    and T_invar
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes algorithm_5 :: "('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) Directed_Multigraph.edge \<Rightarrow> ('b, 't, 'g, 'a) state \<Rightarrow> ('b, 't, 'g, 'a) state"
  fixes algorithm_6 :: "('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) Directed_Multigraph.edge \<Rightarrow> ('b, 't, 'g, 'a) state \<Rightarrow> ('b, 't, 'g, 'a) state"
  assumes root_algorithm_5: "root (algorithm_5 N e \<sigma>) = root \<sigma>"
  assumes root_algorithm_6: "root (algorithm_6 N e \<sigma>) = root \<sigma>"
begin

definition tree_arc_2 where
  "tree_arc_2 e \<sigma> \<equiv> tree.tree_arc (T_lookup (tree \<sigma>)) e"

definition incidence_2 where
  "incidence_2 G \<equiv> Directed_Multigraph.incidence (\<lambda>v. incidence v G)"

function (domintros)
  path_search
  and fold' where
  "path_search N e \<sigma> =
   (if tree_arc_2 e \<sigma>
    then let \<sigma>1 = fold' N (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>;
             \<sigma>2 = \<sigma>1\<lparr>ESTACK := e # ESTACK \<sigma>1\<rparr>;
             \<sigma>3 = algorithm_5 N e \<sigma>2;
             \<sigma>4 = algorithm_6 N e \<sigma>3
         in \<sigma>4
    else \<sigma>\<lparr>ESTACK := e # ESTACK \<sigma>\<rparr>)" |
  fold'_Nil: "fold' N [] \<sigma> = \<sigma>" |
  fold'_Cons: "fold' N (e # es) \<sigma> = fold' N es (path_search N e \<sigma>)"
  by pat_completeness simp+
thm path_search_fold'.pinduct

end

locale algorithm_3_pre = path_search
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
begin

definition init where
  "init r T P \<equiv>
   \<lparr>root = r,
    tree = T,
    multigraph = P,
    ESTACK = [],
    Cs = []\<rparr>"

definition algorithm_3 where
  "algorithm_3 r T P N \<equiv>
   let \<sigma> = path_search N (hd (Directed_Multigraph.incidence (\<lambda>v. incidence v P) r)) (init r T P)
   in ESTACK \<sigma> # Cs \<sigma>"

end

locale algorithm_3 = algorithm_3_pre
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes T :: "'g \<Rightarrow> 'b \<Rightarrow> 't"
  fixes N :: "'g \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> nat"
  fixes I :: "'g \<Rightarrow> 'b \<Rightarrow> 'g"
  assumes steps_1_2_3_high_3:
    "\<lbrakk> biconnected_multigraph other (P.E G); r \<in> Multigraph.V (P.E G) \<rbrakk> \<Longrightarrow>
     steps_1_2_3_high_3 other r (\<lambda>v. incidence v (I G r)) (N G r) (P.E G) (T_lookup (T G r))"
begin

definition algorithm_3' :: "'g \<Rightarrow> 'b \<Rightarrow> ('a, 'b) Multigraph.edge list list" where
  "algorithm_3' G r \<equiv> map (map undirect) (algorithm_3 r (T G r) (I G r) (N G r))"

end

subsection \<open>Verification of the correctness of the algorithm\<close>

subsubsection \<open>Assumptions on the input\<close>

locale path_search_valid_input = path_search
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes N :: "'b \<Rightarrow> nat"
  fixes e :: "('a, 'b) Directed_Multigraph.edge"
  assumes "0 \<le> N (tail e)"
begin
end

locale algorithm_3_pre_valid_input = algorithm_3_pre
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes r :: 'b
  fixes T :: 't
  fixes P :: 'g
  fixes N :: "'b \<Rightarrow> nat"
  assumes steps_1_2_3_high_2: "steps_1_2_3_high_2 r (\<lambda>v. incidence v P) (T_lookup T) N"
begin
sublocale path_search_valid_input
  where N = N
    and e = "hd (Directed_Multigraph.incidence (\<lambda>v. incidence v P) r)"
  sorry
end

abbreviation (in algorithm_3_pre) algorithm_3_pre_valid_input' where
  "algorithm_3_pre_valid_input' \<equiv>
   algorithm_3_pre_valid_input
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    T_update
    insert"

locale algorithm_3_valid_input = algorithm_3
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes G :: 'g
  fixes r :: 'b
  assumes biconnected_multigraph: "biconnected_multigraph other (P.E G)"
  assumes r_mem_V: "r \<in> Multigraph.V (P.E G)"
begin
sublocale algorithm_3_pre_valid_input
  where T = "T G r"
    and P = "I G r"
    and N = "N G r"
  sorry
end

abbreviation (in algorithm_3) algorithm_3_valid_input' where
  "algorithm_3_valid_input' \<equiv>
   algorithm_3_valid_input
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    T
    N
    I
    T_update
    insert"

subsubsection \<open>Loop invariants\<close>

locale path_search_invar = path_search_valid_input
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes \<sigma> :: "('b, 't, 'g, 'a) state"
    (* QUESTION: Use P.E instead? *)
  assumes finite_multigraph: "finite (undirect ` P.A (multigraph \<sigma>))"
  assumes simple_multigraph: "simple (undirect ` P.A (multigraph \<sigma>))"
  assumes finite_Cs: "Ball (set (map set (map (map undirect) (Cs \<sigma>)))) finite"
  assumes no_separation_pair_Cs: "\<forall>G\<in>set (map set (map (map undirect) (Cs \<sigma>))). \<not> (\<exists>a b. is_separation_pair G a b)"
    (* TODO: Order. *)
  assumes palm_tree_2: "palm_tree_2 (root \<sigma>) (T_lookup (tree \<sigma>)) (\<lambda>v. incidence v (multigraph \<sigma>))"
begin
end

abbreviation (in path_search) path_search_invar' where
  "path_search_invar' N e \<equiv>
   path_search_invar
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    N
    e
    T_update
    insert"

abbreviation (in path_search_valid_input) path_search_invar'' where
  "path_search_invar'' \<equiv> path_search_invar' N e"

lemma (in algorithm_3_pre_valid_input) path_search_invar_init:
  shows "path_search_invar' N (hd (Directed_Multigraph.incidence (\<lambda>v. incidence v P) r)) (init r T P)"
  sorry

subsubsection \<open>Termination\<close>

fun (in path_search) idk ::
  "('b \<Rightarrow> nat) \<times> ('a, 'b) Directed_Multigraph.edge \<times> ('b, 't, 'g, 'a) state +
   ('b \<Rightarrow> nat) \<times> ('a, 'b) Directed_Multigraph.edge list \<times> ('b, 't, 'g, 'a) state \<Rightarrow>
   nat" where
  "idk (Inl (_, _, \<sigma>)) = card (P.A (multigraph \<sigma>)) - length (ESTACK \<sigma>)" |
  "idk (Inr (_, es, _)) = length es"

function zig :: "'a graph \<Rightarrow> 'a graph \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
and zag :: "'a graph \<Rightarrow> 'a graph \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  proper_zig: "zig G M v \<pi> \<sigma> = v # (
                    if \<exists>u. {u,v} \<in> M
                    then zag G M (THE u. {u,v} \<in> M) \<pi> \<sigma>
                    else [])" if "matching M"
| no_matching_zig: "zig  M v  _ = [v]" if "\<not>matching M"

| proper_zag: "zag G M u \<pi> \<sigma> =  u # (if \<exists>v. {u,v} \<in> M
                      then
                      (let v = THE v. {u,v} \<in> M in (
                        if \<exists>v'. shifts_to G M u v v' \<pi> \<sigma>
                        then zig G M (THE v'. shifts_to G M u v v' \<pi> \<sigma>) \<pi> \<sigma>
                        else [])
                      )
                      else []
                    )" if "matching M"
| no_matching_zag: "zag  M v  _ = [v]" if "\<not>matching M"
  by auto (metis prod_cases5 sumE)

definition zig_zag_relation where
  "zig_zag_relation \<equiv>
    {(Inr (G, M, u, \<pi>, \<sigma>), Inl (G, M, v, \<pi>, \<sigma>)) | (G :: 'a graph) M u v \<pi> \<sigma>. matching M \<and> {u,v} \<in> M \<and> ((\<exists>v'. shifts_to G M u v v' \<pi> \<sigma>) \<longrightarrow> index \<sigma> v < index \<sigma> (THE v'. shifts_to G M u v v' \<pi> \<sigma>))} \<union>
    {(Inl (G, M, v', \<pi>, \<sigma>), Inr (G, M, u, \<pi>, \<sigma>)) | (G :: 'a graph) M u v' \<pi> \<sigma>. matching M \<and> (\<exists>v. {u,v} \<in> M \<and> shifts_to G M u (THE v. {u,v} \<in> M) v' \<pi> \<sigma>) \<and> index \<sigma> (THE v. {u,v} \<in> M) < index \<sigma> v'}"

lemma (in path_search)
  shows
    "path_search_fold'_dom (Inl (N, e, \<sigma>))"
    "path_search_fold'_dom (Inr (N, incidence_2 (multigraph \<sigma>) (head e), \<sigma>))"

proof (induct "card (P.A (multigraph \<sigma>)) - length (ESTACK \<sigma>)" arbitrary: \<sigma> rule: less_induct)
  case less
  show "path_search_fold'_dom (Inl (N, e, \<sigma>))"
  proof (cases "tree_arc_2 e \<sigma>")
    case True
    show ?thesis
      sorry
  next
    case False
    thus ?thesis
      by (fast intro: path_search_fold'.domintros(1))
  qed
  show "path_search_fold'_dom (Inr (N, incidence_2 (multigraph \<sigma>) (head e), \<sigma>))"
  proof (cases "incidence_2 (multigraph \<sigma>) (head e)")
    case Nil
    thus ?thesis
      by (auto intro: path_search_fold'.domintros(2))
  next
    case (Cons e es)
    then show ?thesis
      sorry
  qed
qed

lemma (in path_search_valid_input) path_search_fold'_dom_Inl:
  assumes "path_search_invar'' \<sigma>"
  shows "path_search_fold'_dom (Inl (N, e, \<sigma>))"
  sorry

lemma (in path_search_valid_input) path_search_fold'_dom_Inr:
  assumes "path_search_invar'' \<sigma>"
  shows "path_search_fold'_dom (Inr (N, incidence_2 (multigraph \<sigma>) (head e), \<sigma>))"
  sorry

lemma (in path_search_invar) path_search_fold'_dom_Inl:
  shows "path_search_fold'_dom (Inl (N, e, \<sigma>))"
  sorry

lemma (in path_search_invar) path_search_fold'_dom_Inr:
  shows "path_search_fold'_dom (Inr (N, incidence_2 (multigraph \<sigma>) (head e), \<sigma>))"
  sorry

lemma (in path_search) path_search_fold'_induct_1:
  assumes "path_search_invar' N e \<sigma>"
  assumes
    "\<And>N e \<sigma>.
        path_search_fold'_dom (Inl (N, e, \<sigma>)) \<Longrightarrow> (tree_arc_2 e \<sigma> \<Longrightarrow> Q N (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>) \<Longrightarrow> P N e \<sigma>"
  assumes "\<And>N \<sigma>. Q N [] \<sigma>"
  assumes
    "\<And>N e es \<sigma>.
        path_search_fold'_dom (Inr (N, e # es, \<sigma>)) \<Longrightarrow> P N e \<sigma> \<Longrightarrow> Q N es (path_search N e \<sigma>) \<Longrightarrow> Q N (e # es) \<sigma>"
  shows
    "P N e \<sigma>"
  thm path_search_fold'.pinduct
proof (rule path_search_fold'.pinduct(1)[where ?Q = Q], goal_cases)
  case 1
  show ?case
    using assms(1)
    by (intro path_search_invar.path_search_fold'_dom_Inl)
next
  case (2 N e \<sigma>)
  thus ?case
    by (intro assms(2))
next
  case (3 N \<sigma>)
  thus ?case
    using assms(3)
    ..
next
  case (4 N e es \<sigma>)
  thus ?case
    by (intro assms(4))
qed

lemma (in path_search) path_search_fold'_induct_2:
  assumes "path_search_invar' N e \<sigma>"
  assumes
    "\<And>N e \<sigma>.
        path_search_fold'_dom (Inl (N, e, \<sigma>)) \<Longrightarrow> (tree_arc_2 e \<sigma> \<Longrightarrow> Q N (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>) \<Longrightarrow> P N e \<sigma>"
  assumes "\<And>N \<sigma>. Q N [] \<sigma>"
  assumes
    "\<And>N e es \<sigma>.
        path_search_fold'_dom (Inr (N, e # es, \<sigma>)) \<Longrightarrow> P N e \<sigma> \<Longrightarrow> Q N es (path_search N e \<sigma>) \<Longrightarrow> Q N (e # es) \<sigma>"
  shows
    "Q N (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>"
proof (rule path_search_fold'.pinduct(2)[where ?P = P], goal_cases)
  case 1
  show ?case
    using assms(1)
    by (intro path_search_invar.path_search_fold'_dom_Inr)
next
  case (2 N e \<sigma>)
  thus ?case
    by (intro assms(2))
next
  case (3 N \<sigma>)
  thus ?case
    using assms(3)
    ..
next
  case (4 N e es \<sigma>)
  thus ?case
    by (intro assms(4))
qed

lemmas (in path_search) path_search_fold'_induct = path_search_fold'_induct_1 path_search_fold'_induct_2

(* FIXME: Prove the two induction rules separately. *)
(*
lemma (in path_search) path_search_fold'_induct:
  assumes "path_search_invar' N e \<sigma>"
  assumes
    "\<And>N e \<sigma>.
        (tree_arc_2 e \<sigma> \<Longrightarrow> Q N (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>) \<Longrightarrow> P N e \<sigma>"
  assumes "\<And>N \<sigma>. Q N [] \<sigma>"
  assumes
    "\<And>N e es \<sigma>.
        P N e \<sigma> \<Longrightarrow> Q N es (path_search N e \<sigma>) \<Longrightarrow> Q N (e # es) \<sigma>"
  shows
    "P N e \<sigma>"
    "Q N (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>"
  thm path_search_fold'.pinduct
proof -
  show "P N e \<sigma>"
  proof (rule path_search_fold'.pinduct[where ?Q = Q], goal_cases)
    case 1
    show ?case
      using assms(1)
      by (intro path_search_invar.path_search_fold'_dom_Inl)
  next
    case (2 N e \<sigma>)
    thus ?case
      by (intro assms(2))
  next
    case (3 N \<sigma>)
    thus ?case
      using assms(3)
      ..
  next
    case (4 N e es \<sigma>)
    thus ?case
      by (intro assms(4))
  qed
  show "Q N (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>"
  proof (rule path_search_fold'.pinduct[where ?P = P], goal_cases)
    case 1
    show ?case
      using assms(1)
      by (intro path_search_invar.path_search_fold'_dom_Inr)
  next
    case (2 N e \<sigma>)
    thus ?case
      by (intro assms(2))
  next
    case (3 N \<sigma>)
    thus ?case
      using assms(3)
      ..
  next
    case (4 N e es \<sigma>)
    thus ?case
      by (intro assms(4))
  qed
  thm path_search_fold'.pinduct
qed
*)

subsubsection \<open>Correctness\<close>

lemma (in path_search) root_path_search_fold':
  shows
    "path_search_fold'_dom (Inl (N, e, \<sigma>)) \<Longrightarrow> root (path_search N e \<sigma>) = root \<sigma>"
    "path_search_fold'_dom (Inr (N, incidence_2 (multigraph \<sigma>) (head e), \<sigma>)) \<Longrightarrow>
     root (fold' N (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>) = root \<sigma>"
proof (induction rule: path_search_fold'.pinduct)
  case (1 N e \<sigma>)
  thus ?case
    by (simp add: path_search.psimps Let_def root_algorithm_6 root_algorithm_5)
next
  case (2 N \<sigma>)
  thus ?case
    by (simp add: fold'.psimps(1))
next
  case (3 N e es \<sigma>)
  thus ?case
    by (simp add: fold'.psimps(2))
qed

lemma (in path_search)
  assumes "path_search_invar' N e \<sigma>"
  shows
    "root (path_search N e \<sigma>) = root \<sigma>"
    "root (fold' N (incidence_2 (multigraph \<sigma>) (head e)) \<sigma>) = root \<sigma>"
  using assms
  by (fast dest: path_search_invar.path_search_fold'_dom_Inl path_search_invar.path_search_fold'_dom_Inr root_path_search_fold')+

end


(*
 * Copyright (c) 2020, CleanQ Project - Systems Group, ETH Zurich
 * All rights reserved.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 *
 * See "LICENSE" for details.
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Refine_Mod2
  imports Refinements
begin

definition lift_mod_2 :: "nat \<Rightarrow> nat"
  where "lift_mod_2 = (\<lambda>n. n mod 2)"

lemma add_refines:
  "((\<Gamma>a,UNIV,Language.Basic id), (\<Gamma>c,UNIV,Language.Basic (\<lambda>n. n + 2)))
      \<in> refinement_s (separable_lift lift_mod_2 id)"
  unfolding lift_mod_2_def by(auto intro: refinement_s_BasicI)

(*
lemma add_c_valid:
  "HoarePartialDef.valid \<Gamma>c {} {n. n mod 4 = 0} (Language.Basic (\<lambda>n. n + 2)) {n. n mod 4 = 2} {}"
  thm hoare_sound
  term cvalid
  apply(hoare)
*)

lemma double_refines:
  "((\<Gamma>a,UNIV,Language.Basic (\<lambda>n. 0)), (\<Gamma>c,UNIV,Language.Basic (\<lambda>n. n * 2)))
      \<in> refinement_s (separable_lift lift_mod_2 id)"
  unfolding lift_mod_2_def by(auto intro: refinement_s_BasicI)

lemma halve_refines:
  "((\<Gamma>a,UNIV,Language.Basic (\<lambda>n. n + 1)),
    (\<Gamma>c,Semantic.Normal ` {n. n mod 4 = 2},Language.Basic (\<lambda>n. n div 2)))
      \<in> refinement_s (separable_lift lift_mod_2 id)"
  unfolding lift_mod_2_def
proof(rule refinement_s_BasicI, auto) (* XXX - not the way to do it. *)
  (* But here you're down to the object logic. *)
  fix n::nat
  assume mod_4_2: "n mod 4 = 2"
  have "n = 4 * (n div 4) + (n mod 4)"
    by(simp)
  also from mod_4_2 have "... = 4 * (n div 4) + 2"
    by(simp)
  also have "... = (2 * (2 * (n div 4))) + 2"
    by(simp)
  finally have n_sum: "n = 2 * (2 * (n div 4)) + 2" .
  hence "n div 2 = ((2 * (2 * (n div 4))) + 2) div 2"
    by(simp)
  also have "... = (2 * (n div 4)) + (2 div 2)"
    by(simp)
  also have "... = 2 * (n div 4) + 1"
    by(simp)
  finally have "n div 2 mod 2 = (2 * (n div 4) + 1) mod 2"
    by(simp)
  also have "... = 1"
    by(simp)
  also {
    from n_sum have "n mod 2 = (2 * (2 * (n div 4)) + 2) mod 2"
      by(simp)
    also have "... = 0" by(simp)
    finally have "1 = Suc (n mod 2)" by(simp)
  }
  finally show "n div 2 mod 2 = Suc (n mod 2)" .
qed

(* XXX - SeqI needs to take a concrete hoare triple. *)

end