theory SAS_Plus_Plus_To_SAS_Plus_Nat
  imports   Primitives SAS_Plus_Plus_To_SAS_Plus
begin

definition SAS_Plus_Plus_State_To_SAS_Plus_list::
  "(dom \<times> (variable,domain_element) assignment list) \<Rightarrow>
        (var,dom) assignment list" where
"SAS_Plus_Plus_State_To_SAS_Plus_list is = (Stage, fst is) #
 map (\<lambda>(x,y). (x,DE y)) (map (\<lambda>(x,y). (Var x, y)) (snd is))"

lemma inj_var: "inj Var"
  by (meson SAS_Plus_Plus_To_SAS_Plus.variable.inject inj_onI)

lemma sublist_SAS_Plus_Plus_State_To_SAS_Plus_apply:
  "map_of (SAS_Plus_Plus_State_To_SAS_Plus_list is) k =
      SAS_Plus_Plus_State_To_SAS_Plus (islist_to_map is) k"
  apply (cases "is")
  apply (cases k)
  apply (auto simp add: SAS_Plus_Plus_State_To_SAS_Plus_list_def  SAS_Plus_Plus_State_To_SAS_Plus_def
        map_comp_def map_of_map simp del:map_map)
  subgoal for a b x
    apply (cases "map_of b x")
     apply auto
    subgoal
    proof -
      assume "k = Var x" "map_of b x = None"
      hence "\<forall>y. (x,y) \<notin> set b"
        using weak_map_of_SomeI by force
      hence "\<forall>y. (Var x, y) \<notin> set (map (\<lambda>(x, y). (Var x, y)) b)"
        by auto
      thus ?thesis
        by (metis (no_types, lifting) imageE map_of_eq_None_iff prod.collapse)
    qed
    using map_of_mapk_SomeI inj_var by fast
  done

lemma sublist_SAS_Plus_Plus_State_To_SAS_Plus:
  "map_of (SAS_Plus_Plus_State_To_SAS_Plus_list is) =
      SAS_Plus_Plus_State_To_SAS_Plus (islist_to_map is)"
  using sublist_SAS_Plus_Plus_State_To_SAS_Plus_apply by blast

fun map_sasps :: "nat\<Rightarrow>nat" where
"map_sasps n = (if n = 0 then 0 else (prod_encode (Suc(fst_nat (hd_nat n)) , Suc(Suc(snd_nat (hd_nat n))) ))## map_sasps (tl_nat n))"
fun map_sasps_acc :: "nat \<Rightarrow> nat\<Rightarrow>nat" where
"map_sasps_acc acc n = (if n = 0 then acc else map_sasps_acc ((prod_encode (Suc(fst_nat (hd_nat n)) , Suc(Suc(snd_nat (hd_nat n))) ))## acc) (tl_nat n))"

lemma submap_sasps:
 "map_sasps  n = map_nat (\<lambda>x. prod_encode (Suc(fst_nat x) , Suc(Suc(snd_nat x)) )) n"
  apply (induct n rule:map_sasps.induct)
  apply auto
  done

lemma map_sasps_induct:
"map_sasps_acc acc n = map_acc  (\<lambda>x. prod_encode (Suc(fst_nat x) , Suc(Suc(snd_nat x)) )) acc n "
  apply(induct acc n rule:map_sasps_acc.induct)
  apply auto
  done

definition map_sasps_tail :: "nat \<Rightarrow> nat" where
"map_sasps_tail n = reverse_nat (map_sasps_acc 0 n)"

lemma subtail_map_sasps:
"map_sasps_tail n = map_sasps n"
  using map_sasps_tail_def  map_sasps_induct submap_sasps subtail_map
  by presburger

definition SAS_Plus_Plus_State_To_SAS_Plus_nat :: "nat \<Rightarrow> nat" where
"SAS_Plus_Plus_State_To_SAS_Plus_nat is = (prod_encode (0,fst_nat is))##
(map_sasps (snd_nat is))"

definition SAS_Plus_Plus_State_To_SAS_Plus_tail:: "nat \<Rightarrow> nat" where
"SAS_Plus_Plus_State_To_SAS_Plus_tail is = (prod_encode (0,fst_nat is))##
(map_sasps_tail (snd_nat is))"

lemma subtail_SAS_Plus_Plus_State_To_SAS_Plus:
"SAS_Plus_Plus_State_To_SAS_Plus_tail is = SAS_Plus_Plus_State_To_SAS_Plus_nat is"
  apply(auto simp only: SAS_Plus_Plus_State_To_SAS_Plus_tail_def
SAS_Plus_Plus_State_To_SAS_Plus_nat_def
subtail_map_sasps)
  done

lemma subnat_SAS_Plus_Plus_State_To_SAS_Plus:
"SAS_Plus_Plus_State_To_SAS_Plus_nat(islist_encode is) =
    sas_plus_assignment_list_encode (SAS_Plus_Plus_State_To_SAS_Plus_list is)"
  apply (cases "is")
  apply (auto simp only:sas_plus_assignment_list_encode_def)
  apply (auto simp only: islist_encode.simps sas_assignment_list_encode_def
      SAS_Plus_Plus_State_To_SAS_Plus_nat_def sub_cons cons0 sub_map sub_snd
                snd_def sub_fst fst_def map_map comp_def sas_assignment_encode.simps
                   SAS_Plus_Plus_State_To_SAS_Plus_list_def list.map
                          list_encode_eq submap_sasps
                  simp flip: var_encode.simps dom_encode.simps
                            sas_plus_assignment_encode.simps)
  apply(auto simp add: prod_encode_eq sub_fst sub_snd sas_plus_assignment_list_encode_def comp_def
          Case_def)
  done

lemma sub_SAS_Plus_Plus_State_To_SAS_Plus:
      "sas_plus_state_decode (SAS_Plus_Plus_State_To_SAS_Plus_nat(islist_encode is))
        = SAS_Plus_Plus_State_To_SAS_Plus (islist_to_map is)"
  using subnat_SAS_Plus_Plus_State_To_SAS_Plus sublist_SAS_Plus_Plus_State_To_SAS_Plus
  by (simp add: sas_plus_assignment_list_id sas_plus_state_decode_def)

fun map_var_de :: "nat \<Rightarrow> nat" where
"map_var_de n = (if n = 0 then 0 else (prod_encode(Suc (fst_nat (hd_nat n)), Suc (Suc(snd_nat (hd_nat n)))))## map_var_de (tl_nat n) )"

fun map_var_de_acc :: " nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_var_de_acc acc n = (if n = 0 then acc else  map_var_de_acc
((prod_encode(Suc (fst_nat (hd_nat n)), Suc (Suc(snd_nat (hd_nat n)))))## acc) (tl_nat n) )"

lemma submap_var_de :
"map_var_de n = map_nat (\<lambda> x. prod_encode(Suc (fst_nat x), Suc (Suc(snd_nat x)))) n"
  apply (induct n rule: map_var_de.induct)
  apply auto
  done

lemma map_var_de_induct:
"map_var_de_acc acc n = map_acc  (\<lambda> x. prod_encode(Suc (fst_nat x), Suc (Suc(snd_nat x)))) acc n "
  apply (induct acc n rule: map_var_de_acc.induct)
  apply auto
  done

definition map_var_de_tail :: "nat \<Rightarrow> nat" where
"map_var_de_tail n = reverse_nat (map_var_de_acc 0 n)"

lemma subtail_map_var_de:
"map_var_de_tail n = map_var_de n"
  using map_var_de_tail_def  submap_var_de  map_var_de_induct
      subtail_map
  by presburger

definition SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_nat::
  "nat \<Rightarrow> nat" where
"SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_nat op =
  ((prod_encode(0,0)) ## (map_var_de (nth_nat 0 op)))##
   (( map_sasps  (nth_nat (Suc 0) op))) ## 0"

definition SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_tail::
  "nat \<Rightarrow> nat" where
"SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_tail op =
  ((prod_encode(0,0)) ## (map_var_de_tail (nth_nat 0 op)))##
   (( map_sasps_tail  (nth_nat (Suc 0) op))) ## 0"

lemma subtail_SAS_Plus_Plus_Operator_To_SAS_Plus_Operator:
"SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_tail op =  SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_nat op"
  apply(auto simp only: SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_tail_def
SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_nat_def
subtail_map_sasps
subtail_map_var_de)
  done

lemma fst_sas_assignment : "fst_nat (sas_assignment_encode x) = variable_encode (fst x)"
  apply (cases x)
  apply (auto simp add:sub_fst)
  done
lemma snd_sas_assignment : "snd_nat (sas_assignment_encode x) = domain_element_encode (snd x)"
  apply (cases x)
  apply (auto simp add:sub_snd)
  done

lemma sub_SAS_Plus_Plus_Operator_To_SAS_Plus_Operator:
  "SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_nat (operator_encode op) =
    operator_plus_encode (SAS_Plus_Plus_Operator_To_SAS_Plus_Operator op)"
  apply (auto simp only: submap_var_de
          SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_nat_def
           operator_encode_def sub_nth nth.simps submap_sasps
              sas_assignment_list_encode_def sub_map sub_cons cons0 map_map comp_def
          SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def
          operator_plus_encode_def sas_plus_operator.simps
            sas_plus_assignment_list_encode_def list.simps
            sas_plus_assignment_encode.simps var_encode.simps dom_encode.simps
              fst_sas_assignment snd_sas_assignment
         )
  done

definition initialization_operators_list::
    "(variable, domain_element) sas_plus_list_problem \<Rightarrow> operator_plus list" where
"initialization_operators_list  P =
  concat (map (\<lambda> v. (if v \<in> set (map fst (initial_ofl P)) then []
    else map (\<lambda> y. \<lparr> precondition_of = [(Stage, Init)],  effect_of = [(Var v, DE y)]\<rparr>)
      (thef (map_list_find (range_ofl P) v)))) (variables_ofl P))"

lemma dom_map_of : "dom (map_of x) = set ( map fst x)"
  apply (induct x)
   apply auto
  apply force
  done

lemma sublist_initialization_operators:
"initialization_operators_list  P = initialization_operators (list_problem_to_problem P)"
  apply (auto simp only:initialization_operators_list_def initialization_operators_def
          dom_map_of sub_map_list_find[of "range_ofl P"] list_problem_to_problem.simps sas_plus_problem.simps)
  done

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

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

lemma submap_inner:
"map_inner v n =  map_nat (\<lambda> y. (((prod_encode (0, 1)))##0) ## ((prod_encode (Suc v, Suc (Suc y)))## 0) ## 0) n"
  apply (induct v n rule:map_inner.induct)
  apply auto
  done

lemma map_inner_induct:
"map_inner_acc v acc n = map_acc (\<lambda> y. (((prod_encode (0, 1)))##0) ## ((prod_encode (Suc v, Suc (Suc y)))## 0) ## 0) acc n "
  apply(induct v acc n rule:map_inner_acc.induct)
  apply auto
  done

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

lemma subtail_map_inner:
"map_inner_tail v n = map_inner v n"
  using map_inner_tail_def  map_inner_induct submap_inner
        subtail_map by presburger

fun map_fst :: "nat\<Rightarrow>nat" where
"map_fst n  = (if n =0 then 0 else (fst_nat (hd_nat n)) ## map_fst (tl_nat n))"

fun map_fst_acc :: "nat \<Rightarrow> nat\<Rightarrow>nat" where
"map_fst_acc acc n  = (if n =0 then acc else map_fst_acc ((fst_nat (hd_nat n)) ## acc) (tl_nat n))"

lemma submap_fst :
"map_fst n = map_nat fst_nat n"
  apply (induct n rule:map_fst.induct)
  apply auto
  done
lemma map_fst_induct:
"map_fst_acc acc n = map_acc fst_nat acc n"
  apply(induct acc n rule:map_fst_acc.induct)
  apply auto
  done

definition map_fst_tail :: "nat \<Rightarrow> nat" where
"map_fst_tail n = reverse_nat (map_fst_acc 0 n)"

lemma subtail_map_fst :
"map_fst_tail n = map_fst n"
  using map_fst_tail_def map_fst_induct submap_fst subtail_map
  by presburger

function map_outer :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_outer P n = (if n =0 then 0 else (if elemof (hd_nat n) (map_fst (nth_nat (Suc (Suc 0)) P)) \<noteq> 0 then 0
    else (map_inner (hd_nat n)
      (the_nat (map_list_find_nat (nth_nat (Suc (Suc (Suc (Suc 0)))) P) (hd_nat n))))) ## map_outer P (tl_nat n))"
   apply pat_completeness
  apply (auto simp only:)
  done
termination by lexicographic_order

lemma submap_outer:
"map_outer P n = map_nat (\<lambda> v. (if elemof v (map_fst (nth_nat (Suc (Suc 0)) P)) \<noteq> 0 then 0
    else map_inner v
      (the_nat (map_list_find_nat (nth_nat (Suc (Suc (Suc (Suc 0)))) P) v)))) n"
  apply (induct P n rule:map_outer.induct)
  by (metis (no_types, lifting) map_nat.elims map_outer.elims)
declare map_list_find_nat.simps elemof.simps [simp del]

function  map_outer_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_outer_acc P acc n = (if n =0 then acc else map_outer_acc P ((if elemof (hd_nat n) (map_fst_tail (nth_nat (Suc (Suc 0)) P)) \<noteq> 0 then 0
    else (map_inner_tail (hd_nat n)
      (the_nat (map_list_find_nat (nth_nat (Suc (Suc (Suc (Suc 0)))) P) (hd_nat n))))) ## acc) (tl_nat n))"
  apply pat_completeness
  apply (auto simp only:)
  done
termination by lexicographic_order

lemma map_outer_induct :
"map_outer_acc P acc n = map_acc (\<lambda> v. (if elemof v (map_fst (nth_nat (Suc (Suc 0)) P)) \<noteq> 0 then 0
    else map_inner v
      (the_nat (map_list_find_nat (nth_nat (Suc (Suc (Suc (Suc 0)))) P) v)))) acc n"
  apply(induct P acc n rule:map_outer_acc.induct)
  using subtail_map_fst subtail_map_inner
  by (metis (no_types, lifting) map_acc.elims map_outer_acc.elims)

definition map_outer_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_outer_tail P  n = reverse_nat (map_outer_acc P  0 n)"

lemma subtail_map_outer:
"map_outer_tail P  n  = map_outer P n "
  using map_outer_tail_def  map_outer_induct submap_outer subtail_map
  by presburger

definition initialization_operators_nat::
    "nat \<Rightarrow> nat" where
"initialization_operators_nat  P =
  concat_nat (map_outer P (nth_nat 0 P))"

definition initialization_operators_tail::
    "nat \<Rightarrow> nat" where
"initialization_operators_tail  P =
  concat_tail (map_outer_tail P (nth_nat 0 P))"

lemma subtail_initialization_operators:
"initialization_operators_tail  P =
initialization_operators_nat  P
"
  apply(simp only: initialization_operators_tail_def initialization_operators_nat_def
      subtail_concat subtail_map_outer)
  done

lemma simp_vdlist_encode: "vdlist_encode = prod_encode o (\<lambda>(x,y). (variable_encode x,list_encode (map domain_element_encode y)))"
  by force

lemma simp_sas_assignment_encode: "sas_assignment_encode = prod_encode o (\<lambda>(x,y). (variable_encode x,domain_element_encode y))"
  by force

lemma map_find_map:"inj f \<Longrightarrow> map_list_find  (map (\<lambda>(x, y). (f x, g (h y))) l) (f x) =
       (case map_list_find l x of None \<Rightarrow> None | Some y \<Rightarrow> Some (g (h y)))"
  apply (induct l arbitrary:x)
   apply (auto simp add:inj_def)
  done

lemma map_find_map2:"inj f \<Longrightarrow> map_list_find  (map (\<lambda>(x, y). (f x, g y)) l) (f x) =
       (case map_list_find l x of None \<Rightarrow> None | Some y \<Rightarrow> Some (g  y))"
  apply (rule  map_find_map) apply auto
  done

lemma inj_map_set: "inj f \<Longrightarrow> (f x \<in> set (map f xs)) = ( x \<in> set xs)"
  apply (auto simp add:inj_def)
  done

lemma sub_the_dec: "thef x  = list_decode (the_nat (list_option_encode x))"
  apply (auto simp only: sub_the list_encode_inverse)
  done

lemma sub_thedec_spec: "thef (map_list_find (range_ofl P) x) =
list_decode (the_nat (list_option_encode (map_list_find (range_ofl P) x)))
"
  using sub_the_dec by blast

lemma thef_simps: "thef xs  = (case xs of None \<Rightarrow> [] | Some x \<Rightarrow> x)"
  apply (cases xs)
   apply (auto)
  done

lemma map_nat0:"map_nat f 0 = 0"
  by auto
thm "option.case_distrib"
lemma subnat_initialization_operators:
 "initialization_operators_nat (list_problem_encode P)
  =  list_encode (map operator_plus_encode  (initialization_operators_list P)) "
  apply (auto simp only: initialization_operators_nat_def list_problem_encode_def
                sas_plus_list_problem.simps sub_nth nth.simps sas_assignment_list_encode_def submap_fst
                      submap_inner submap_outer
                          sub_map map_map comp_def fst_sas_assignment sub_elem_of cons0 sub_cons sub_the sub_map_list_find_nat
                          )
  apply (auto simp only:  simp_vdlist_encode sub_map_list_find_nat sub_the
      initialization_operators_list_def )
  apply (auto simp only: map_map comp_def)
  apply (simp only: flip: comp_def[of variable_encode fst] map_map)

  using variable_inj   apply (auto simp only:  map_find_map inj_map_set if_distrib
          list_encode.simps(1) list.simps)
  apply (auto simp only: sub_map_list_find_nat map_find_map
operator_plus_encode_def map_concat

 simp flip: comp_def[of "prod_encode" "\<lambda>x.(case x of
 (x, y) \<Rightarrow> (variable_encode x, list_encode (map domain_element_encode y)))"] map_map
)
  apply (auto simp only: map_map comp_def if_distrib list.simps operator_plus_encode_def
            sas_plus_operator.simps sas_plus_assignment_list_encode_def
            sas_plus_assignment_encode.simps option.case_distrib thefn.simps option_encode.simps
the_nat.simps zero_diff diff_Suc_1 sub_map map_nat0 if_cancel
 )
  apply (auto simp only: simp flip: list_encode.simps if_distrib  option.case_distrib[of list_encode]
       )
  apply (auto simp only: list_encode.simps )
  apply (auto simp only: sub_concat thef_simps simp flip: comp_def[of list_encode "(\<lambda>x. case map_list_find (range_ofl P) x of None \<Rightarrow> []
                    | Some xa \<Rightarrow>
                        if x \<in> set (map fst (initial_ofl P)) then []
                        else map (\<lambda>xa. Suc (prod_encode
    (Suc (prod_encode (prod_encode (0, 1), 0)),
     Suc (prod_encode
           (Suc (prod_encode
                  (prod_encode
                    (Suc (variable_encode x),
                     Suc (Suc (domain_element_encode xa))),
                   0)),
            0)))))
                              xa)"] map_map )
  apply (simp only:One_nat_def)
  apply (auto simp only:option.case_distrib list.simps if_cancel var_encode.simps dom_encode.simps)
  done

fun map_init_seq :: "nat \<Rightarrow> nat" where
"map_init_seq n = (if n = 0 then 0 else ((((prod_encode (0,1))##0) ##
      ((prod_encode(Suc (fst_nat (hd_nat n)), Suc (Suc (snd_nat (hd_nat n)))))##0) ##0)) ## map_init_seq (tl_nat n))"

fun map_init_seq_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_init_seq_acc  acc n = (if n = 0 then acc else map_init_seq_acc (((((prod_encode (0,1))##0) ##
      ((prod_encode(Suc (fst_nat (hd_nat n)), Suc (Suc (snd_nat (hd_nat n)))))##0) ##0)) ## acc) (tl_nat n))"

lemma submap_init_seq:
"map_init_seq n = map_nat (\<lambda>v. (((prod_encode (0,1))##0) ##
      ((prod_encode(Suc (fst_nat v), Suc (Suc (snd_nat v))))##0) ##0)) n"
  apply (induct n rule:map_init_seq.induct)
  apply auto
  done

lemma map_init_seq_induct:
"map_init_seq_acc  acc n = map_acc  (\<lambda>v. (((prod_encode (0,1))##0) ##
      ((prod_encode(Suc (fst_nat v), Suc (Suc (snd_nat v))))##0) ##0)) acc n"
  apply(induct acc n rule:map_init_seq_acc.induct)
  apply auto
  done

definition map_init_seq_tail :: "nat \<Rightarrow> nat" where
"map_init_seq_tail n = reverse_nat (map_init_seq_acc 0 n) "

lemma subtail_map_init_seq:
"map_init_seq_tail n = map_init_seq n"
  using map_init_seq_tail_def map_init_seq_induct
submap_init_seq subtail_map by presburger

definition initialization_sequence_nat:: "nat \<Rightarrow> nat" where
  "initialization_sequence_nat vs = map_init_seq vs"

definition initialization_sequence_tail:: "nat \<Rightarrow> nat" where
  "initialization_sequence_tail vs = map_init_seq_tail vs"

lemma subtail_initialization_sequence:
"initialization_sequence_tail vs = initialization_sequence_nat vs"
  using initialization_sequence_nat_def
 initialization_sequence_tail_def
 subtail_map_init_seq by presburger

lemma sub_initialization_sequence :
  "initialization_sequence_nat (sas_assignment_list_encode vs) =
      list_encode (map operator_plus_encode (initialization_sequence vs)) "
  apply (auto simp only: submap_init_seq initialization_sequence_nat_def cons0
              sub_cons sas_assignment_list_encode_def sub_map map_map comp_def
                fst_sas_assignment snd_sas_assignment)
  apply (auto simp only: initialization_sequence_def map_map comp_def
                    sas_plus_assignment_list_encode_def
              operator_plus_encode_def sas_plus_operator.simps simp flip: var_encode.simps
                    dom_encode.simps sas_plus_assignment_encode.simps)
  apply auto
  done

definition initial_state_list::
  "(variable, domain_element) sas_plus_list_problem \<Rightarrow> (var, dom) assignment list" where
"initial_state_list P = SAS_Plus_Plus_State_To_SAS_Plus_list (Init,
  map (\<lambda>v. (v, case (map_list_find (initial_ofl P) v) of  Some val \<Rightarrow> val |
        None \<Rightarrow> (the (map_list_find (range_ofl P) v)) ! 0 ) ) (variables_ofl P)
)"

lemma sublist_initial_state_helper_apply:
" (\<lambda>v. if v \<in> set ((P)\<^sub>\<V>\<^sub>+)
           then Some
                 (case map_of ((P)\<^sub>I\<^sub>+) v of None \<Rightarrow> the (map_of (range_ofl P) v) ! 0
                  | Some val \<Rightarrow> val)
           else None) k =
 map_of
       (map (\<lambda>v. (v, case map_of ((P)\<^sub>I\<^sub>+) v of
                      None \<Rightarrow> the (map_of (range_ofl P) v) ! 0 | Some val \<Rightarrow> val))
         ((P)\<^sub>\<V>\<^sub>+)) k
"
  apply (auto)
  subgoal
proof -
  assume a1: "k \<in> set ((P)\<^sub>\<V>\<^sub>+)"
  then have "set ((P)\<^sub>\<V>\<^sub>+) \<noteq> {}"
    by force
  then show "Some (case map_of ((P)\<^sub>I\<^sub>+) k of None \<Rightarrow> the (map_of (range_ofl P) k) ! 0 | Some a \<Rightarrow> a) = map_of (map (\<lambda>b. (b, case map_of ((P)\<^sub>I\<^sub>+) b of None \<Rightarrow> the (map_of (range_ofl P) b) ! 0 | Some a \<Rightarrow> a)) ((P)\<^sub>\<V>\<^sub>+)) k"
    using a1 by (simp add: map_of_from_function_graph_is_some_if)
qed
  by (simp add: map_of_map_restrict)

lemma sublist_initial_state_helper:
"(\<lambda>v. if v \<in> set ((P)\<^sub>\<V>\<^sub>+)
           then Some
                 (case map_of ((P)\<^sub>I\<^sub>+) v of None \<Rightarrow> the (map_of (range_ofl P) v) ! 0
                  | Some val \<Rightarrow> val)
           else None)
=  map_of
       (map (\<lambda>v. (v, case map_of ((P)\<^sub>I\<^sub>+) v of
                      None \<Rightarrow> the (map_of (range_ofl P) v) ! 0 | Some val \<Rightarrow> val))
         ((P)\<^sub>\<V>\<^sub>+))
"
  using  sublist_initial_state_helper_apply by fast

lemma sublist_initial_state:
" map_of (initial_state_list P)  = initial_state (list_problem_to_problem P) "
  apply (auto simp only:initial_state_list_def sublist_SAS_Plus_Plus_State_To_SAS_Plus
  islist_to_map.simps map_of_map  sub_map_list_find sublist_initial_state_helper
  initial_state_def list_problem_to_problem.simps sas_plus_problem.simps
)
  done

lemma map_op:"a # xs = x \<Longrightarrow> map f x = f a # map f xs"
  apply auto
  done
declare map_list_find_nat.simps [simp del]
fun map_initial_state :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_initial_state P n = (if n = 0 then 0 else (prod_encode(hd_nat n, case (map_list_find_nat (nth_nat (Suc (Suc 0))  P) (hd_nat n)) of  Suc val \<Rightarrow> val |
        0 \<Rightarrow> hd_nat (the_nat (map_list_find_nat (nth_nat (Suc (Suc (Suc (Suc 0)))) P) (hd_nat n))))) ## map_initial_state P (tl_nat n))"

fun map_initial_state_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>  nat" where
"map_initial_state_acc P acc n = (if n = 0 then acc else map_initial_state_acc P ((prod_encode(hd_nat n, case (map_list_find_nat (nth_nat (Suc (Suc 0))  P) (hd_nat n)) of  Suc val \<Rightarrow> val |
        0 \<Rightarrow> hd_nat (the_nat (map_list_find_nat (nth_nat (Suc (Suc (Suc (Suc 0)))) P) (hd_nat n))))) ## acc )(tl_nat n))"

lemma submap_initial_state:
"map_initial_state P n  =  map_nat (\<lambda>v. prod_encode(v, case (map_list_find_nat (nth_nat (Suc (Suc 0))  P) v) of  Suc val \<Rightarrow> val |
        0 \<Rightarrow> hd_nat (the_nat (map_list_find_nat (nth_nat (Suc (Suc (Suc (Suc 0)))) P) v))) ) n "
  apply (induct P n rule:map_initial_state.induct)
  apply auto
  done

lemma map_initial_state_induct:
"map_initial_state_acc P acc n = map_acc  (\<lambda>v. prod_encode(v, case (map_list_find_nat (nth_nat (Suc (Suc 0))  P) v) of  Suc val \<Rightarrow> val |
        0 \<Rightarrow> hd_nat (the_nat (map_list_find_nat (nth_nat (Suc (Suc (Suc (Suc 0)))) P) v))) ) acc n "
  apply(induct P acc n rule:map_initial_state_acc.induct)
  apply auto
  done

definition map_initial_state_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_initial_state_tail P n = reverse_nat (map_initial_state_acc P 0 n)"

lemma subtail_map_initial_state:
" map_initial_state_tail P n = map_initial_state P n"
  using  map_initial_state_tail_def  map_initial_state_induct submap_initial_state
subtail_map by presburger

declare map_list_find_nat.simps [simp]

definition initial_state_nat::
  "nat \<Rightarrow> nat " where
"initial_state_nat P = SAS_Plus_Plus_State_To_SAS_Plus_nat (prod_encode(1,
  map_initial_state P (nth_nat 0 P)
))"

definition initial_state_tail::
  "nat \<Rightarrow> nat " where
"initial_state_tail P = SAS_Plus_Plus_State_To_SAS_Plus_tail (prod_encode(1,
  map_initial_state_tail P (nth_nat 0 P)
))"

lemma subtail_initial_state:
"initial_state_tail P = initial_state_nat P"

  using initial_state_nat_def initial_state_tail_def subtail_SAS_Plus_Plus_State_To_SAS_Plus
subtail_map_initial_state by presburger

lemma option_encode_case: "(case option_encode x of 0 \<Rightarrow>  t | Suc y \<Rightarrow> f y) =
 (case x of None \<Rightarrow> t | Some y \<Rightarrow> f y)  "
  apply (cases x)
   apply auto
  done

lemma some_case_unfold: "f a = Some y \<Longrightarrow> (case f a of None \<Rightarrow> None | Some t \<Rightarrow> Some (g t)) = Some (g y)"
  apply auto
  done

lemma lambda_case_simplifier:
assumes  "\<forall>x \<in> set (variables_ofl P). \<exists>t. map_list_find (range_ofl P) x = Some t \<and> t\<noteq>[]"
shows
" map (\<lambda>x. case map_list_find ((P)\<^sub>I\<^sub>+) x of
                    None \<Rightarrow>
                      prod_encode
                       (variable_encode x,
                        hd_nat
                         (the_nat
                           (option_encode
                             (case map_list_find (range_ofl P) x of None \<Rightarrow> None
                              | Some y \<Rightarrow>
                                  Some
                                   (list_encode (map domain_element_encode y))))))
                    | Some xa \<Rightarrow>
                        prod_encode (variable_encode x, domain_element_encode xa))
           ((P)\<^sub>\<V>\<^sub>+) =
 map (\<lambda>x. case map_list_find ((P)\<^sub>I\<^sub>+) x of
                    None \<Rightarrow>
                      prod_encode
                       (variable_encode x,
                        hd_nat
                         (the_nat
                           (option_encode
                             (Some
                                   (list_encode (map domain_element_encode  (the (map_list_find (range_ofl P) x) )))))))
                    | Some xa \<Rightarrow>
                        prod_encode (variable_encode x, domain_element_encode xa))
           ((P)\<^sub>\<V>\<^sub>+)
"
 using assms
  apply (induct "((P)\<^sub>\<V>\<^sub>+)" arbitrary: P )
   apply (simp add:  initial_state_list_def
  sas_assignment_list_encode_def
 flip:  subnat_SAS_Plus_Plus_State_To_SAS_Plus list_encode.simps(2))
 subgoal for a x P
    apply (auto simp add:eq_commute simp flip: list_encode.simps(2))
    apply (cases "map_list_find (range_ofl P) a ")
     apply simp
   subgoal for t aa
 apply (auto simp only:some_case_unfold option.case  option.the_def sub_thefn thefn.simps sub_hd
              simp flip: sas_assignment_encode.simps )
     done
   subgoal for t aa
     apply (metis (no_types, lifting) option.case_eq_if thef.simps(1) thef.simps(2))
     done
   done
  done

lemma lambda_case_simplifier2:
assumes  "\<forall>x \<in> set (variables_ofl P). \<exists>t. map_list_find (range_ofl P) x = Some t \<and> t\<noteq>[]"
shows
"map (\<lambda>x. case map_list_find ((P)\<^sub>I\<^sub>+) x of
                    None \<Rightarrow>
                      prod_encode
                       (variable_encode x,
                        head
                         (map domain_element_encode
                           (the (map_list_find (range_ofl P) x))))
                    | Some xa \<Rightarrow>
                        prod_encode (variable_encode x, domain_element_encode xa))
           ((P)\<^sub>\<V>\<^sub>+)
=
map (\<lambda>x. case map_list_find ((P)\<^sub>I\<^sub>+) x of
                    None \<Rightarrow>
                      prod_encode
                       (variable_encode x,
                        domain_element_encode (hd (
                           (the (map_list_find (range_ofl P) x)))))
                    | Some xa \<Rightarrow>
                        prod_encode (variable_encode x, domain_element_encode xa))
           ((P)\<^sub>\<V>\<^sub>+)

"
 using assms
  apply (induct "((P)\<^sub>\<V>\<^sub>+)" arbitrary: P )
  apply auto
  subgoal for a x P xa
    apply (cases "map_list_find (range_ofl P) xa")
     apply auto
    subgoal for aa
      apply (metis option.sel sub_head_map)
      done
    done
  done
lemma lambda_case_simplifier3:
assumes  "\<forall>x \<in> set (variables_ofl P). \<exists>t. map_list_find (range_ofl P) x = Some t \<and> t\<noteq>[]"
shows
"map (\<lambda>x. case map_list_find ((P)\<^sub>I\<^sub>+) x of
                    None \<Rightarrow>
                      prod_encode
                       (variable_encode x,
                        domain_element_encode (hd (
                           (the (map_list_find (range_ofl P) x)))))
                    | Some xa \<Rightarrow>
                        prod_encode (variable_encode x, domain_element_encode xa))
           ((P)\<^sub>\<V>\<^sub>+)

=

map (\<lambda>x. case map_list_find ((P)\<^sub>I\<^sub>+) x of
                    None \<Rightarrow>
                      prod_encode
                       (variable_encode x,
                        domain_element_encode (
                           (the (map_list_find (range_ofl P) x))!0))
                    | Some xa \<Rightarrow>
                        prod_encode (variable_encode x, domain_element_encode xa))
           ((P)\<^sub>\<V>\<^sub>+)

"
 using assms
  apply (induct "((P)\<^sub>\<V>\<^sub>+)" arbitrary: P )
  apply auto
  subgoal for a x P xa
    apply (cases "map_list_find (range_ofl P) xa")
     apply auto
    subgoal for aa
      apply (metis hd_conv_nth option.sel)
      done
    done
  done

lemma subnat_initial_state_helper:
  assumes  "\<forall>x \<in> set (variables_ofl P). \<exists>t. map_list_find (range_ofl P) x = Some t \<and> t\<noteq>[]"
  shows "initial_state_nat (list_problem_encode P)
  = sas_plus_assignment_list_encode (initial_state_list P)"
  apply (auto simp only: initial_state_nat_def
 submap_initial_state
  list_problem_encode_def sub_nth nth.simps sas_assignment_list_encode_def
  sas_assignment_encode.simps sub_map_list_find_nat sub_map map_map comp_def
    simp_sas_assignment_encode simp_vdlist_encode
)
  thm "option.case"
  apply (auto simp only: sub_map_list_find_nat  simp flip: comp_def map_map)
  using variable_inj apply (auto simp only: comp_def map_find_map)
  apply (auto simp add: map_find_map2
        option.case_distrib)
  apply (auto simp only: option_encode_case sub_the Case_def option.case)
  using assms apply (auto simp only: lambda_case_simplifier)
  apply (auto simp only:sub_thefn thefn.simps sub_hd initial_state_list_def
        islist_encode.simps dom_encode.simps sas_assignment_list_encode_def
          map_map comp_def sas_assignment_encode.simps option.case_distrib
      simp flip: subnat_SAS_Plus_Plus_State_To_SAS_Plus )
   apply (auto simp only: lambda_case_simplifier2 lambda_case_simplifier3)
  done

lemma inv_subnat_initial_state:
  assumes "is_valid_problem_sas_plus_plus (list_problem_to_problem P)"
  shows  "\<forall>x \<in> set (variables_ofl P). \<exists>t. map_list_find (range_ofl P) x = Some t \<and> t\<noteq>[]"
proof -
  obtain P' where def: "P' = list_problem_to_problem P" by simp
  then have "sas_plus_problem.variables_of P' = variables_ofl P " by simp
  moreover have "map_of (range_ofl P) = range_of P' " using def by simp
  moreover have "\<forall>x \<in> set (sas_plus_problem.variables_of P'). \<exists>t. (range_of P') x = Some t \<and> t \<noteq> []"
    by (metis assms def is_valid_problem_sas_plus_plus_then(1) option.collapse range_of_not_empty)
  ultimately show ?thesis by (metis sub_map_list_find)

qed

lemma subnat_initial_state:
  assumes "is_valid_problem_sas_plus_plus (list_problem_to_problem P)"
  shows "initial_state_nat (list_problem_encode P)
  = sas_plus_assignment_list_encode (initial_state_list P)"
  using assms inv_subnat_initial_state subnat_initial_state_helper
  by fast

definition SAS_Plus_Plus_To_SAS_Plus_list:: "(variable,domain_element)sas_plus_list_problem \<Rightarrow> (var,dom)sas_plus_list_problem" where
"SAS_Plus_Plus_To_SAS_Plus_list P = \<lparr> variables_ofl = Stage # (map Var ((P)\<^sub>\<V>\<^sub>+)),
      operators_ofl = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
        # (initialization_operators_list P)
        @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+)),
      initial_ofl = initial_state_list P ,
      goal_ofl = SAS_Plus_Plus_State_To_SAS_Plus_list (NonInit, ((P)\<^sub>G\<^sub>+)),
      range_ofl = (Stage, [Init,NonInit])#
           map  (\<lambda>(x,y). (x, map DE y)) (map (\<lambda>(x,y). (Var x, y)) (range_ofl P))\<rparr>"

lemma sublist_SAS_Plus_Plus_To_SAS_Plus_helper_apply:
"map_of ((Stage, [Init,NonInit])#
           map  (\<lambda>(x,y). (x, map DE y)) (map (\<lambda>(x,y). (Var x, y)) (range_ofl P))) k
=
 (((\<lambda>x. Some (map DE x)) \<circ>\<^sub>m (map_of (range_ofl P))
        \<circ>\<^sub>m (\<lambda>x. (case x of Var x \<Rightarrow> Some x | Stage \<Rightarrow> None)))(Stage \<mapsto> [Init, NonInit])) k
"
  apply (cases k)
   apply (auto simp add: map_of_map map_comp_def simp flip: map_map)
  subgoal for x1
    apply (cases "map_of (range_ofl P) x1")
     apply (auto)
    subgoal
    proof -
      assume asm: "k = Var x1" " map_of (range_ofl P) x1 = None"
      then have "\<forall>y. (x1,y) \<notin>  set (range_ofl P)"
        using weak_map_of_SomeI by force
      then have "\<forall>y. (Var x1,y) \<notin> set (map (\<lambda>(x, y). (Var x, y)) (range_ofl P)) "
        by auto
      thus " map_of (map (\<lambda>(x, y). (Var x, y)) (range_ofl P)) (Var x1) = None"
        by (meson map_of_SomeD thef.cases)
    qed
    subgoal for a
    proof -
      assume " k = Var x1"  "map_of (range_ofl P) x1 = Some a"
      then  have " map_of (map (\<lambda>(x, y). (Var x, y)) (range_ofl P)) (Var x1) = Some a"
        using map_of_mapk_SomeI inj_var by fast
      thus ?thesis by blast
    qed
    done
  done
lemma sublist_SAS_Plus_Plus_To_SAS_Plus_helper:
"map_of ((Stage, [Init,NonInit])#
           map  (\<lambda>(x,y). (x, map DE y)) (map (\<lambda>(x,y). (Var x, y)) (range_ofl P)))
=
 (((\<lambda>x. Some (map DE x)) \<circ>\<^sub>m (map_of (range_ofl P))
        \<circ>\<^sub>m (\<lambda>x. (case x of Var x \<Rightarrow> Some x | Stage \<Rightarrow> None)))(Stage \<mapsto> [Init, NonInit]))
"
  using sublist_SAS_Plus_Plus_To_SAS_Plus_helper_apply by fast

lemma sublist_SAS_Plus_Plus_To_SAS_Plus:
" list_problem_to_problem (SAS_Plus_Plus_To_SAS_Plus_list P) =
    SAS_Plus_Plus_To_SAS_Plus (list_problem_to_problem P)"
  apply (auto simp only: SAS_Plus_Plus_To_SAS_Plus_list_def list_problem_to_problem.simps
  sas_plus_problem.simps sas_plus_list_problem.simps)
  apply (auto simp only: sublist_initialization_operators
   sublist_initial_state sublist_SAS_Plus_Plus_State_To_SAS_Plus
        sublist_SAS_Plus_Plus_To_SAS_Plus_helper SAS_Plus_Plus_To_SAS_Plus_def
        sas_plus_problem.simps list_problem_to_problem.simps islist_to_map.simps

)
  done
lemma fst_vdlist_simp:"fst_nat (vdlist_encode x) = variable_encode (fst x)"
  apply (cases x)
  apply (auto simp add: sub_fst)
  done

lemma snd_vdlist_simp: "snd_nat (vdlist_encode x) = list_encode (map domain_element_encode (snd x))"
  apply (cases x)
  apply (auto simp add:sub_snd)
  done

fun map_sasp_to_sas_op :: "nat \<Rightarrow> nat" where
"map_sasp_to_sas_op n = (if n = 0 then 0 else (SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_nat (hd_nat n)) ## map_sasp_to_sas_op (tl_nat n))"

fun map_sasp_to_sas_op_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_sasp_to_sas_op_acc acc n = (if n = 0 then acc else map_sasp_to_sas_op_acc ((SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_tail (hd_nat n)) ## acc) (tl_nat n))"

lemma map_sasp_to_sas_op_induct:
"map_sasp_to_sas_op_acc acc n = map_acc SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_nat acc n"
  apply(induct acc n rule:map_sasp_to_sas_op_acc.induct)
  apply (auto simp add: subtail_SAS_Plus_Plus_Operator_To_SAS_Plus_Operator)
  done

lemma submap_sasp_to_sas_op:
"map_sasp_to_sas_op n = map_nat SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_nat n "
  apply (induct  n rule: map_sasp_to_sas_op.induct)
  apply auto
  done

definition map_sasp_to_sas_op_tail :: "nat \<Rightarrow> nat" where
"map_sasp_to_sas_op_tail n = reverse_nat (map_sasp_to_sas_op_acc 0 n)"

lemma subtail_map_sasp_to_sas_op:
"map_sasp_to_sas_op_tail n = map_sasp_to_sas_op n "
  using map_sasp_to_sas_op_tail_def  submap_sasp_to_sas_op  map_sasp_to_sas_op_induct
subtail_map by presburger

fun map_DE :: "nat \<Rightarrow> nat" where
"map_DE n = (if n = 0 then 0 else (Suc (Suc (hd_nat n))) ## map_DE (tl_nat n))"

fun map_DE_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_DE_acc acc n = (if n = 0 then acc else map_DE_acc ((Suc (Suc (hd_nat n))) ## acc) (tl_nat n))"

lemma submap_DE : "map_DE n =  map_nat (\<lambda>n. Suc (Suc n)) n"
  apply (induct n rule:map_DE.induct)
  apply auto
  done

lemma map_DE_induct :
"map_DE_acc acc n = map_acc (\<lambda>n. Suc (Suc n)) acc n "
  apply(induct acc n rule:map_DE_acc.induct)
  apply auto
  done

definition map_DE_tail :: "nat \<Rightarrow> nat" where
"map_DE_tail n = reverse_nat (map_DE_acc 0 n)"

lemma subtail_map_DE:
"map_DE_tail n = map_DE n "
  using map_DE_tail_def  map_DE_induct submap_DE subtail_map
  by presburger

fun map_var :: "nat \<Rightarrow> nat" where
"map_var n = (if n = 0 then 0 else ( prod_encode(Suc (fst_nat (hd_nat n)), snd_nat (hd_nat n))) ## map_var (tl_nat n) )"

fun map_var_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_var_acc acc n = (if n = 0 then acc else map_var_acc (( prod_encode(Suc (fst_nat (hd_nat n)), snd_nat (hd_nat n))) ## acc) (tl_nat n) )"

lemma map_var_induct:
"map_var_acc acc n = map_acc (\<lambda>n. prod_encode(Suc (fst_nat n), snd_nat n)) acc n"
  apply(induct acc n rule:map_var_acc.induct)
  apply auto
  done

lemma submap_var :
"map_var n = map_nat (\<lambda>n. prod_encode(Suc (fst_nat n), snd_nat n)) n"
  apply (induct n rule:map_var.induct)
  apply auto
  done

definition map_var_tail :: "nat \<Rightarrow> nat" where
"map_var_tail n = reverse_nat (map_var_acc 0 n)"

lemma subtail_map_var:
"map_var_tail n = map_var n"
  using map_var_tail_def submap_var map_var_induct subtail_map
  by presburger

fun map_var_DE :: "nat \<Rightarrow> nat" where
"map_var_DE n = (if n = 0 then 0 else (prod_encode(fst_nat (hd_nat n), map_DE (snd_nat (hd_nat n)))) ## map_var_DE (tl_nat n))"

fun map_var_DE_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_var_DE_acc acc n = (if n = 0 then acc else map_var_DE_acc ((prod_encode(fst_nat (hd_nat n), map_DE_tail (snd_nat (hd_nat n)))) ## acc )(tl_nat n))"

lemma map_var_DE_induct:
"map_var_DE_acc acc n = map_acc ( \<lambda>n. prod_encode(fst_nat n, map_DE (snd_nat n))) acc n "
  apply(induct acc n rule:map_var_DE_acc.induct)
  apply (auto simp add:subtail_map_DE)
  done

lemma submap_var_DE:
"map_var_DE n = map_nat  ( \<lambda>n. prod_encode(fst_nat n, map_DE (snd_nat n))) n"
  apply (induct n rule: map_var_DE.induct)
  apply auto
  done
definition map_var_DE_tail :: "nat \<Rightarrow> nat" where
"map_var_DE_tail n = reverse_nat (map_var_DE_acc 0 n)"

lemma subtail_map_var_DE:
"map_var_DE_tail n = map_var_DE n"
  using map_var_DE_tail_def submap_var_DE map_var_DE_induct
subtail_map by presburger

fun map_Suc :: "nat\<Rightarrow> nat" where
"map_Suc n = (if n = 0 then 0 else ((Suc (hd_nat n)) ## map_Suc (tl_nat n)))"

fun map_Suc_acc :: "nat \<Rightarrow> nat\<Rightarrow> nat" where
"map_Suc_acc acc n = (if n = 0 then acc  else map_Suc_acc ((Suc (hd_nat n)) ## acc) (tl_nat n))"

lemma submap_Suc :
"map_Suc n = map_nat Suc n"
  apply (induct n rule:map_Suc.induct)
  apply auto
  done
lemma map_Suc_induct :
"map_Suc_acc acc n = map_acc Suc acc n"
  apply(induct acc n rule:map_Suc_acc.induct)
  apply auto
  done

definition map_Suc_tail:: "nat\<Rightarrow> nat" where
"map_Suc_tail n = reverse_nat (map_Suc_acc 0 n)"

lemma subtail_map_Suc:
"map_Suc_tail n = map_Suc n"
  using map_Suc_induct submap_Suc map_Suc_tail_def subtail_map
  by presburger

definition SAS_Plus_Plus_To_SAS_Plus_nat:: " nat \<Rightarrow> nat " where
"SAS_Plus_Plus_To_SAS_Plus_nat P = ((0 ## (map_Suc (nth_nat 0 P)))##
      ( append_nat ((((prod_encode(0,Suc 0))##0) ## ((prod_encode(0,0))##0) ## 0 )
        ## (initialization_operators_nat P))
        (map_sasp_to_sas_op (nth_nat (Suc 0) P))) ##
      (initial_state_nat P)  ##
      (SAS_Plus_Plus_State_To_SAS_Plus_nat (prod_encode(0, (nth_nat (Suc (Suc (Suc 0))) P))))##
      ((prod_encode(0, ((Suc 0) ## 0 ##0)))##
           map_var_DE (map_var (nth_nat (Suc (Suc (Suc (Suc 0)))) P))) ## 0 )"

definition SAS_Plus_Plus_To_SAS_Plus_tail:: " nat \<Rightarrow> nat " where
"SAS_Plus_Plus_To_SAS_Plus_tail P = ((0 ## (map_Suc_tail (nth_nat 0 P)))##
      ( append_tail ((((prod_encode(0,Suc 0))##0) ## ((prod_encode(0,0))##0) ## 0 )
        ## (initialization_operators_tail P))
        (map_sasp_to_sas_op_tail (nth_nat (Suc 0) P))) ##
      (initial_state_tail P)  ##
      (SAS_Plus_Plus_State_To_SAS_Plus_tail (prod_encode(0, (nth_nat (Suc (Suc (Suc 0))) P))))##
      ((prod_encode(0, ((Suc 0) ## 0 ##0)))##
           map_var_DE_tail (map_var_tail (nth_nat (Suc (Suc (Suc (Suc 0)))) P))) ## 0 )"

lemma subtail_SAS_Plus_Plus_To_SAS_Plus:
"SAS_Plus_Plus_To_SAS_Plus_tail P = SAS_Plus_Plus_To_SAS_Plus_nat P"
  using SAS_Plus_Plus_To_SAS_Plus_nat_def
 SAS_Plus_Plus_To_SAS_Plus_tail_def
subtail_SAS_Plus_Plus_State_To_SAS_Plus
subtail_append
 subtail_initial_state
subtail_initialization_operators subtail_map_Suc subtail_map_sasp_to_sas_op subtail_map_var
 subtail_map_var_DE by presburger

lemma lambda_equals: " (\<lambda>x. case x of
                  (x1, x2) \<Rightarrow>
                    prod_encode
                     ((case x of (x1, x2) \<Rightarrow> Pair (Suc (variable_encode x1)))
                       (list_encode
                         (map (\<lambda>x. Suc (Suc (domain_element_encode x))) x2))))
=
      (\<lambda>x. case x of
                  (x1, x2) \<Rightarrow>
                    prod_encode
                     (Suc (variable_encode x1),
                      list_encode
                       (map (\<lambda>x. Suc (Suc (domain_element_encode x))) x2)))
"
  apply auto
  done
lemma subnat_SAS_Plus_Plus_To_SAS_Plus:
 assumes "is_valid_problem_sas_plus_plus (list_problem_to_problem P)"
 shows "SAS_Plus_Plus_To_SAS_Plus_nat (list_problem_encode P)
= list_problem_plus_encode (SAS_Plus_Plus_To_SAS_Plus_list P)"
  using assms
  apply (auto simp only: SAS_Plus_Plus_To_SAS_Plus_nat_def submap_Suc
  cons0 sub_cons sub_nth nth.simps sub_map sub_append submap_DE submap_var submap_var_DE
 submap_sasp_to_sas_op
        subnat_initialization_operators subnat_initial_state
 )
  apply (auto simp only:  list_problem_encode_def sub_nth nth.simps sub_map
          sub_append map_map comp_def sub_SAS_Plus_Plus_Operator_To_SAS_Plus_Operator
            sub_fst   fst_vdlist_simp  snd_vdlist_simp fst_def sub_snd snd_def
          SAS_Plus_Plus_To_SAS_Plus_list_def sas_plus_list_problem.simps list_problem_plus_encode_def
          list.simps sub_cons var_encode.simps operator_plus_encode_def sas_plus_operator.simps
          sas_plus_assignment_list_encode_def   sas_plus_assignment_encode.simps dom_encode.simps
          map_append
 )
  apply (auto simp only: subnat_SAS_Plus_Plus_State_To_SAS_Plus
          simp flip: dom_encode.simps islist_encode.simps

)
  apply (auto simp only: dom_encode.simps islist_encode.simps sas_plus_assignment_list_encode_def
        vdlist_plus_encode.simps prod.case_distrib )
  apply (auto simp add: comp_def  prod.case_distrib lambda_equals simp del:list_encode.simps)
  done

end


(*
 * @TAG(OTHER_LGPL)
 *)

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

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

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

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

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

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

header {* State Space Template *}
theory StateSpace imports Hoare
begin

record 'g state = "globals"::'g

definition
  upd_globals:: "('g \<Rightarrow> 'g) \<Rightarrow> ('g,'z) state_scheme \<Rightarrow> ('g,'z) state_scheme"
where
  "upd_globals upd s = s\<lparr>globals := upd (globals s)\<rparr>"

record ('g, 'n, 'val) stateSP = "'g state" +
  locals :: "'n \<Rightarrow> 'val"

lemma upd_globals_conv: "upd_globals f = (\<lambda>s. s\<lparr>globals := f (globals s)\<rparr>)"
  by (rule ext) (simp add: upd_globals_def)

end


(*  Title:      HOL/Library/RBT_Set.thy
    Author:     Ondrej Kuncar
*)

section {* Implementation of sets using RBT trees *}

theory RBT_Set
imports RBT Product_Lexorder
begin

(*
  Users should be aware that by including this file all code equations
  outside of List.thy using 'a list as an implementation of sets cannot be
  used for code generation. If such equations are not needed, they can be
  deleted from the code generator. Otherwise, a user has to provide their
  own equations using RBT trees.
*)

section {* Definition of code datatype constructors *}

definition Set :: "('a\<Colon>linorder, unit) rbt \<Rightarrow> 'a set"
  where "Set t = {x . RBT.lookup t x = Some ()}"

definition Coset :: "('a\<Colon>linorder, unit) rbt \<Rightarrow> 'a set"
  where [simp]: "Coset t = - Set t"

section {* Deletion of already existing code equations *}

lemma [code, code del]:
  "Set.empty = Set.empty" ..

lemma [code, code del]:
  "Set.is_empty = Set.is_empty" ..

lemma [code, code del]:
  "uminus_set_inst.uminus_set = uminus_set_inst.uminus_set" ..

lemma [code, code del]:
  "Set.member = Set.member" ..

lemma [code, code del]:
  "Set.insert = Set.insert" ..

lemma [code, code del]:
  "Set.remove = Set.remove" ..

lemma [code, code del]:
  "UNIV = UNIV" ..

lemma [code, code del]:
  "Set.filter = Set.filter" ..

lemma [code, code del]:
  "image = image" ..

lemma [code, code del]:
  "Set.subset_eq = Set.subset_eq" ..

lemma [code, code del]:
  "Ball = Ball" ..

lemma [code, code del]:
  "Bex = Bex" ..

lemma [code, code del]:
  "can_select = can_select" ..

lemma [code, code del]:
  "Set.union = Set.union" ..

lemma [code, code del]:
  "minus_set_inst.minus_set = minus_set_inst.minus_set" ..

lemma [code, code del]:
  "Set.inter = Set.inter" ..

lemma [code, code del]:
  "card = card" ..

lemma [code, code del]:
  "the_elem = the_elem" ..

lemma [code, code del]:
  "Pow = Pow" ..

lemma [code, code del]:
  "setsum = setsum" ..

lemma [code, code del]:
  "setprod = setprod" ..

lemma [code, code del]:
  "Product_Type.product = Product_Type.product"  ..

lemma [code, code del]:
  "Id_on = Id_on" ..

lemma [code, code del]:
  "Image = Image" ..

lemma [code, code del]:
  "trancl = trancl" ..

lemma [code, code del]:
  "relcomp = relcomp" ..

lemma [code, code del]:
  "wf = wf" ..

lemma [code, code del]:
  "Min = Min" ..

lemma [code, code del]:
  "Inf_fin = Inf_fin" ..

lemma [code, code del]:
  "INFIMUM = INFIMUM" ..

lemma [code, code del]:
  "Max = Max" ..

lemma [code, code del]:
  "Sup_fin = Sup_fin" ..

lemma [code, code del]:
  "SUPREMUM = SUPREMUM" ..

lemma [code, code del]:
  "(Inf :: 'a set set \<Rightarrow> 'a set) = Inf" ..

lemma [code, code del]:
  "(Sup :: 'a set set \<Rightarrow> 'a set) = Sup" ..

lemma [code, code del]:
  "sorted_list_of_set = sorted_list_of_set" ..

lemma [code, code del]:
  "List.map_project = List.map_project" ..

lemma [code, code del]:
  "List.Bleast = List.Bleast" ..

section {* Lemmas *}

subsection {* Auxiliary lemmas *}

lemma Set_set_keys: "Set x = dom (RBT.lookup x)"
by (auto simp: Set_def)

lemma finite_Set [simp, intro!]: "finite (Set x)"
by (simp add: Set_set_keys)

lemma set_keys: "Set t = set(RBT.keys t)"
by (simp add: Set_set_keys lookup_keys)

subsection {* fold and filter *}

lemma finite_fold_rbt_fold_eq:
  assumes "comp_fun_commute f"
  shows "Finite_Set.fold f A (set (RBT.entries t)) = RBT.fold (curry f) t A"
proof -
  have *: "remdups (RBT.entries t) = RBT.entries t"
    using distinct_entries distinct_map by (auto intro: distinct_remdups_id)
  show ?thesis using assms by (auto simp: fold_def_alt comp_fun_commute.fold_set_fold_remdups *)
qed

definition fold_keys :: "('a :: linorder \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, _) rbt \<Rightarrow> 'b \<Rightarrow> 'b"
  where [code_unfold]:"fold_keys f t A = RBT.fold (\<lambda>k _ t. f k t) t A"

lemma fold_keys_def_alt:
  "fold_keys f t s = List.fold f (RBT.keys t) s"
by (auto simp: fold_map o_def split_def fold_def_alt keys_def_alt fold_keys_def)

lemma finite_fold_fold_keys:
  assumes "comp_fun_commute f"
  shows "Finite_Set.fold f A (Set t) = fold_keys f t A"
using assms
proof -
  interpret comp_fun_commute f by fact
  have "set (RBT.keys t) = fst ` (set (RBT.entries t))" by (auto simp: fst_eq_Domain keys_entries)
  moreover have "inj_on fst (set (RBT.entries t))" using distinct_entries distinct_map by auto
  ultimately show ?thesis
    by (auto simp add: set_keys fold_keys_def curry_def fold_image finite_fold_rbt_fold_eq
      comp_comp_fun_commute)
qed

definition rbt_filter :: "('a :: linorder \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> 'a set" where
  "rbt_filter P t = RBT.fold (\<lambda>k _ A'. if P k then Set.insert k A' else A') t {}"

lemma Set_filter_rbt_filter:
  "Set.filter P (Set t) = rbt_filter P t"
by (simp add: fold_keys_def Set_filter_fold rbt_filter_def
  finite_fold_fold_keys[OF comp_fun_commute_filter_fold])

subsection {* foldi and Ball *}

lemma Ball_False: "RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t False = False"
by (induction t) auto

lemma rbt_foldi_fold_conj:
  "RBT_Impl.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t val = RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t val"
proof (induction t arbitrary: val)
  case (Branch c t1) then show ?case
    by (cases "RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t1 True") (simp_all add: Ball_False)
qed simp

lemma foldi_fold_conj: "RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t val = fold_keys (\<lambda>k s. s \<and> P k) t val"
unfolding fold_keys_def including rbt.lifting by transfer (rule rbt_foldi_fold_conj)

subsection {* foldi and Bex *}

lemma Bex_True: "RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t True = True"
by (induction t) auto

lemma rbt_foldi_fold_disj:
  "RBT_Impl.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t val = RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t val"
proof (induction t arbitrary: val)
  case (Branch c t1) then show ?case
    by (cases "RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t1 False") (simp_all add: Bex_True)
qed simp

lemma foldi_fold_disj: "RBT.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t val = fold_keys (\<lambda>k s. s \<or> P k) t val"
unfolding fold_keys_def including rbt.lifting by transfer (rule rbt_foldi_fold_disj)

subsection {* folding over non empty trees and selecting the minimal and maximal element *}

(** concrete **)

(* The concrete part is here because it's probably not general enough to be moved to RBT_Impl *)

definition rbt_fold1_keys :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a::linorder, 'b) RBT_Impl.rbt \<Rightarrow> 'a"
  where "rbt_fold1_keys f t = List.fold f (tl(RBT_Impl.keys t)) (hd(RBT_Impl.keys t))"

(* minimum *)

definition rbt_min :: "('a::linorder, unit) RBT_Impl.rbt \<Rightarrow> 'a"
  where "rbt_min t = rbt_fold1_keys min t"

lemma key_le_right: "rbt_sorted (Branch c lt k v rt) \<Longrightarrow> (\<And>x. x \<in>set (RBT_Impl.keys rt) \<Longrightarrow> k \<le> x)"
by  (auto simp: rbt_greater_prop less_imp_le)

lemma left_le_key: "rbt_sorted (Branch c lt k v rt) \<Longrightarrow> (\<And>x. x \<in>set (RBT_Impl.keys lt) \<Longrightarrow> x \<le> k)"
by (auto simp: rbt_less_prop less_imp_le)

lemma fold_min_triv:
  fixes k :: "_ :: linorder"
  shows "(\<forall>x\<in>set xs. k \<le> x) \<Longrightarrow> List.fold min xs k = k"
by (induct xs) (auto simp add: min_def)

lemma rbt_min_simps:
  "is_rbt (Branch c RBT_Impl.Empty k v rt) \<Longrightarrow> rbt_min (Branch c RBT_Impl.Empty k v rt) = k"
by (auto intro: fold_min_triv dest: key_le_right is_rbt_rbt_sorted simp: rbt_fold1_keys_def rbt_min_def)

fun rbt_min_opt where
  "rbt_min_opt (Branch c RBT_Impl.Empty k v rt) = k" |
  "rbt_min_opt (Branch c (Branch lc llc lk lv lrt) k v rt) = rbt_min_opt (Branch lc llc lk lv lrt)"

lemma rbt_min_opt_Branch:
  "t1 \<noteq> rbt.Empty \<Longrightarrow> rbt_min_opt (Branch c t1 k () t2) = rbt_min_opt t1"
by (cases t1) auto

lemma rbt_min_opt_induct [case_names empty left_empty left_non_empty]:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "P rbt.Empty"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t1 = rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t1 \<noteq> rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  shows "P t"
using assms
  apply (induction t)
  apply simp
  apply (case_tac "t1 = rbt.Empty")
  apply simp_all
done

lemma rbt_min_opt_in_set:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "t \<noteq> rbt.Empty"
  shows "rbt_min_opt t \<in> set (RBT_Impl.keys t)"
using assms by (induction t rule: rbt_min_opt.induct) (auto)

lemma rbt_min_opt_is_min:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "rbt_sorted t"
  assumes "t \<noteq> rbt.Empty"
  shows "\<And>y. y \<in> set (RBT_Impl.keys t) \<Longrightarrow> y \<ge> rbt_min_opt t"
using assms
proof (induction t rule: rbt_min_opt_induct)
  case empty
    then show ?case by simp
next
  case left_empty
    then show ?case by (auto intro: key_le_right simp del: rbt_sorted.simps)
next
  case (left_non_empty c t1 k v t2 y)
    then have "y = k \<or> y \<in> set (RBT_Impl.keys t1) \<or> y \<in> set (RBT_Impl.keys t2)" by auto
    with left_non_empty show ?case
    proof(elim disjE)
      case goal1 then show ?case
        by (auto simp add: rbt_min_opt_Branch intro: left_le_key rbt_min_opt_in_set)
    next
      case goal2 with left_non_empty show ?case by (auto simp add: rbt_min_opt_Branch)
    next
      case goal3 show ?case
      proof -
        from goal3 have "rbt_min_opt t1 \<le> k" by (simp add: left_le_key rbt_min_opt_in_set)
        moreover from goal3 have "k \<le> y" by (simp add: key_le_right)
        ultimately show ?thesis using goal3 by (simp add: rbt_min_opt_Branch)
      qed
    qed
qed

lemma rbt_min_eq_rbt_min_opt:
  assumes "t \<noteq> RBT_Impl.Empty"
  assumes "is_rbt t"
  shows "rbt_min t = rbt_min_opt t"
proof -
  from assms have "hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t) = RBT_Impl.keys t" by (cases t) simp_all
  with assms show ?thesis
    by (simp add: rbt_min_def rbt_fold1_keys_def rbt_min_opt_is_min
      Min.set_eq_fold [symmetric] Min_eqI rbt_min_opt_in_set)
qed

(* maximum *)

definition rbt_max :: "('a::linorder, unit) RBT_Impl.rbt \<Rightarrow> 'a"
  where "rbt_max t = rbt_fold1_keys max t"

lemma fold_max_triv:
  fixes k :: "_ :: linorder"
  shows "(\<forall>x\<in>set xs. x \<le> k) \<Longrightarrow> List.fold max xs k = k"
by (induct xs) (auto simp add: max_def)

lemma fold_max_rev_eq:
  fixes xs :: "('a :: linorder) list"
  assumes "xs \<noteq> []"
  shows "List.fold max (tl xs) (hd xs) = List.fold max (tl (rev xs)) (hd (rev xs))"
  using assms by (simp add: Max.set_eq_fold [symmetric])

lemma rbt_max_simps:
  assumes "is_rbt (Branch c lt k v RBT_Impl.Empty)"
  shows "rbt_max (Branch c lt k v RBT_Impl.Empty) = k"
proof -
  have "List.fold max (tl (rev(RBT_Impl.keys lt @ [k]))) (hd (rev(RBT_Impl.keys lt @ [k]))) = k"
    using assms by (auto intro!: fold_max_triv dest!: left_le_key is_rbt_rbt_sorted)
  then show ?thesis by (auto simp add: rbt_max_def rbt_fold1_keys_def fold_max_rev_eq)
qed

fun rbt_max_opt where
  "rbt_max_opt (Branch c lt k v RBT_Impl.Empty) = k" |
  "rbt_max_opt (Branch c lt k v (Branch rc rlc rk rv rrt)) = rbt_max_opt (Branch rc rlc rk rv rrt)"

lemma rbt_max_opt_Branch:
  "t2 \<noteq> rbt.Empty \<Longrightarrow> rbt_max_opt (Branch c t1 k () t2) = rbt_max_opt t2"
by (cases t2) auto

lemma rbt_max_opt_induct [case_names empty right_empty right_non_empty]:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "P rbt.Empty"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t2 = rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t2 \<noteq> rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  shows "P t"
using assms
  apply (induction t)
  apply simp
  apply (case_tac "t2 = rbt.Empty")
  apply simp_all
done

lemma rbt_max_opt_in_set:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "t \<noteq> rbt.Empty"
  shows "rbt_max_opt t \<in> set (RBT_Impl.keys t)"
using assms by (induction t rule: rbt_max_opt.induct) (auto)

lemma rbt_max_opt_is_max:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "rbt_sorted t"
  assumes "t \<noteq> rbt.Empty"
  shows "\<And>y. y \<in> set (RBT_Impl.keys t) \<Longrightarrow> y \<le> rbt_max_opt t"
using assms
proof (induction t rule: rbt_max_opt_induct)
  case empty
    then show ?case by simp
next
  case right_empty
    then show ?case by (auto intro: left_le_key simp del: rbt_sorted.simps)
next
  case (right_non_empty c t1 k v t2 y)
    then have "y = k \<or> y \<in> set (RBT_Impl.keys t2) \<or> y \<in> set (RBT_Impl.keys t1)" by auto
    with right_non_empty show ?case
    proof(elim disjE)
      case goal1 then show ?case
        by (auto simp add: rbt_max_opt_Branch intro: key_le_right rbt_max_opt_in_set)
    next
      case goal2 with right_non_empty show ?case by (auto simp add: rbt_max_opt_Branch)
    next
      case goal3 show ?case
      proof -
        from goal3 have "rbt_max_opt t2 \<ge> k" by (simp add: key_le_right rbt_max_opt_in_set)
        moreover from goal3 have "y \<le> k" by (simp add: left_le_key)
        ultimately show ?thesis using goal3 by (simp add: rbt_max_opt_Branch)
      qed
    qed
qed

lemma rbt_max_eq_rbt_max_opt:
  assumes "t \<noteq> RBT_Impl.Empty"
  assumes "is_rbt t"
  shows "rbt_max t = rbt_max_opt t"
proof -
  from assms have "hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t) = RBT_Impl.keys t" by (cases t) simp_all
  with assms show ?thesis
    by (simp add: rbt_max_def rbt_fold1_keys_def rbt_max_opt_is_max
      Max.set_eq_fold [symmetric] Max_eqI rbt_max_opt_in_set)
qed

(** abstract **)

context includes rbt.lifting begin
lift_definition fold1_keys :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> 'a"
  is rbt_fold1_keys .

lemma fold1_keys_def_alt:
  "fold1_keys f t = List.fold f (tl (RBT.keys t)) (hd (RBT.keys t))"
  by transfer (simp add: rbt_fold1_keys_def)

lemma finite_fold1_fold1_keys:
  assumes "semilattice f"
  assumes "\<not> RBT.is_empty t"
  shows "semilattice_set.F f (Set t) = fold1_keys f t"
proof -
  from `semilattice f` interpret semilattice_set f by (rule semilattice_set.intro)
  show ?thesis using assms
    by (auto simp: fold1_keys_def_alt set_keys fold_def_alt non_empty_keys set_eq_fold [symmetric])
qed

(* minimum *)

lift_definition r_min :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_min .

lift_definition r_min_opt :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_min_opt .

lemma r_min_alt_def: "r_min t = fold1_keys min t"
by transfer (simp add: rbt_min_def)

lemma r_min_eq_r_min_opt:
  assumes "\<not> (RBT.is_empty t)"
  shows "r_min t = r_min_opt t"
using assms unfolding is_empty_empty by transfer (auto intro: rbt_min_eq_rbt_min_opt)

lemma fold_keys_min_top_eq:
  fixes t :: "('a :: {linorder, bounded_lattice_top}, unit) rbt"
  assumes "\<not> (RBT.is_empty t)"
  shows "fold_keys min t top = fold1_keys min t"
proof -
  have *: "\<And>t. RBT_Impl.keys t \<noteq> [] \<Longrightarrow> List.fold min (RBT_Impl.keys t) top =
    List.fold min (hd(RBT_Impl.keys t) # tl(RBT_Impl.keys t)) top"
    by (simp add: hd_Cons_tl[symmetric])
  { fix x :: "_ :: {linorder, bounded_lattice_top}" and xs
    have "List.fold min (x#xs) top = List.fold min xs x"
    by (simp add: inf_min[symmetric])
  } note ** = this
  show ?thesis using assms
    unfolding fold_keys_def_alt fold1_keys_def_alt is_empty_empty
    apply transfer
    apply (case_tac t)
    apply simp
    apply (subst *)
    apply simp
    apply (subst **)
    apply simp
  done
qed

(* maximum *)

lift_definition r_max :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_max .

lift_definition r_max_opt :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_max_opt .

lemma r_max_alt_def: "r_max t = fold1_keys max t"
by transfer (simp add: rbt_max_def)

lemma r_max_eq_r_max_opt:
  assumes "\<not> (RBT.is_empty t)"
  shows "r_max t = r_max_opt t"
using assms unfolding is_empty_empty by transfer (auto intro: rbt_max_eq_rbt_max_opt)

lemma fold_keys_max_bot_eq:
  fixes t :: "('a :: {linorder, bounded_lattice_bot}, unit) rbt"
  assumes "\<not> (RBT.is_empty t)"
  shows "fold_keys max t bot = fold1_keys max t"
proof -
  have *: "\<And>t. RBT_Impl.keys t \<noteq> [] \<Longrightarrow> List.fold max (RBT_Impl.keys t) bot =
    List.fold max (hd(RBT_Impl.keys t) # tl(RBT_Impl.keys t)) bot"
    by (simp add: hd_Cons_tl[symmetric])
  { fix x :: "_ :: {linorder, bounded_lattice_bot}" and xs
    have "List.fold max (x#xs) bot = List.fold max xs x"
    by (simp add: sup_max[symmetric])
  } note ** = this
  show ?thesis using assms
    unfolding fold_keys_def_alt fold1_keys_def_alt is_empty_empty
    apply transfer
    apply (case_tac t)
    apply simp
    apply (subst *)
    apply simp
    apply (subst **)
    apply simp
  done
qed

end

section {* Code equations *}

code_datatype Set Coset

declare list.set[code] (* needed? *)

lemma empty_Set [code]:
  "Set.empty = Set RBT.empty"
by (auto simp: Set_def)

lemma UNIV_Coset [code]:
  "UNIV = Coset RBT.empty"
by (auto simp: Set_def)

lemma is_empty_Set [code]:
  "Set.is_empty (Set t) = RBT.is_empty t"
  unfolding Set.is_empty_def by (auto simp: fun_eq_iff Set_def intro: lookup_empty_empty[THEN iffD1])

lemma compl_code [code]:
  "- Set xs = Coset xs"
  "- Coset xs = Set xs"
by (simp_all add: Set_def)

lemma member_code [code]:
  "x \<in> (Set t) = (RBT.lookup t x = Some ())"
  "x \<in> (Coset t) = (RBT.lookup t x = None)"
by (simp_all add: Set_def)

lemma insert_code [code]:
  "Set.insert x (Set t) = Set (RBT.insert x () t)"
  "Set.insert x (Coset t) = Coset (RBT.delete x t)"
by (auto simp: Set_def)

lemma remove_code [code]:
  "Set.remove x (Set t) = Set (RBT.delete x t)"
  "Set.remove x (Coset t) = Coset (RBT.insert x () t)"
by (auto simp: Set_def)

lemma union_Set [code]:
  "Set t \<union> A = fold_keys Set.insert t A"
proof -
  interpret comp_fun_idem Set.insert
    by (fact comp_fun_idem_insert)
  from finite_fold_fold_keys[OF `comp_fun_commute Set.insert`]
  show ?thesis by (auto simp add: union_fold_insert)
qed

lemma inter_Set [code]:
  "A \<inter> Set t = rbt_filter (\<lambda>k. k \<in> A) t"
by (simp add: inter_Set_filter Set_filter_rbt_filter)

lemma minus_Set [code]:
  "A - Set t = fold_keys Set.remove t A"
proof -
  interpret comp_fun_idem Set.remove
    by (fact comp_fun_idem_remove)
  from finite_fold_fold_keys[OF `comp_fun_commute Set.remove`]
  show ?thesis by (auto simp add: minus_fold_remove)
qed

lemma union_Coset [code]:
  "Coset t \<union> A = - rbt_filter (\<lambda>k. k \<notin> A) t"
proof -
  have *: "\<And>A B. (-A \<union> B) = -(-B \<inter> A)" by blast
  show ?thesis by (simp del: boolean_algebra_class.compl_inf add: * inter_Set)
qed

lemma union_Set_Set [code]:
  "Set t1 \<union> Set t2 = Set (RBT.union t1 t2)"
by (auto simp add: lookup_union map_add_Some_iff Set_def)

lemma inter_Coset [code]:
  "A \<inter> Coset t = fold_keys Set.remove t A"
by (simp add: Diff_eq [symmetric] minus_Set)

lemma inter_Coset_Coset [code]:
  "Coset t1 \<inter> Coset t2 = Coset (RBT.union t1 t2)"
by (auto simp add: lookup_union map_add_Some_iff Set_def)

lemma minus_Coset [code]:
  "A - Coset t = rbt_filter (\<lambda>k. k \<in> A) t"
by (simp add: inter_Set[simplified Int_commute])

lemma filter_Set [code]:
  "Set.filter P (Set t) = (rbt_filter P t)"
by (auto simp add: Set_filter_rbt_filter)

lemma image_Set [code]:
  "image f (Set t) = fold_keys (\<lambda>k A. Set.insert (f k) A) t {}"
proof -
  have "comp_fun_commute (\<lambda>k. Set.insert (f k))" by default auto
  then show ?thesis by (auto simp add: image_fold_insert intro!: finite_fold_fold_keys)
qed

lemma Ball_Set [code]:
  "Ball (Set t) P \<longleftrightarrow> RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t True"
proof -
  have "comp_fun_commute (\<lambda>k s. s \<and> P k)" by default auto
  then show ?thesis
    by (simp add: foldi_fold_conj[symmetric] Ball_fold finite_fold_fold_keys)
qed

lemma Bex_Set [code]:
  "Bex (Set t) P \<longleftrightarrow> RBT.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t False"
proof -
  have "comp_fun_commute (\<lambda>k s. s \<or> P k)" by default auto
  then show ?thesis
    by (simp add: foldi_fold_disj[symmetric] Bex_fold finite_fold_fold_keys)
qed

lemma subset_code [code]:
  "Set t \<le> B \<longleftrightarrow> (\<forall>x\<in>Set t. x \<in> B)"
  "A \<le> Coset t \<longleftrightarrow> (\<forall>y\<in>Set t. y \<notin> A)"
by auto

lemma subset_Coset_empty_Set_empty [code]:
  "Coset t1 \<le> Set t2 \<longleftrightarrow> (case (RBT.impl_of t1, RBT.impl_of t2) of
    (rbt.Empty, rbt.Empty) => False |
    (_, _) => Code.abort (STR ''non_empty_trees'') (\<lambda>_. Coset t1 \<le> Set t2))"
proof -
  have *: "\<And>t. RBT.impl_of t = rbt.Empty \<Longrightarrow> t = RBT rbt.Empty"
    by (subst(asm) RBT_inverse[symmetric]) (auto simp: impl_of_inject)
  have **: "eq_onp is_rbt rbt.Empty rbt.Empty" unfolding eq_onp_def by simp
  show ?thesis
    by (auto simp: Set_def lookup.abs_eq[OF **] dest!: * split: rbt.split)
qed

text {* A frequent case -- avoid intermediate sets *}
lemma [code_unfold]:
  "Set t1 \<subseteq> Set t2 \<longleftrightarrow> RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> k \<in> Set t2) t1 True"
by (simp add: subset_code Ball_Set)

lemma card_Set [code]:
  "card (Set t) = fold_keys (\<lambda>_ n. n + 1) t 0"
  by (auto simp add: card.eq_fold intro: finite_fold_fold_keys comp_fun_commute_const)

lemma setsum_Set [code]:
  "setsum f (Set xs) = fold_keys (plus o f) xs 0"
proof -
  have "comp_fun_commute (\<lambda>x. op + (f x))" by default (auto simp: ac_simps)
  then show ?thesis
    by (auto simp add: setsum.eq_fold finite_fold_fold_keys o_def)
qed

lemma the_elem_set [code]:
  fixes t :: "('a :: linorder, unit) rbt"
  shows "the_elem (Set t) = (case RBT.impl_of t of
    (Branch RBT_Impl.B RBT_Impl.Empty x () RBT_Impl.Empty) \<Rightarrow> x
    | _ \<Rightarrow> Code.abort (STR ''not_a_singleton_tree'') (\<lambda>_. the_elem (Set t)))"
proof -
  {
    fix x :: "'a :: linorder"
    let ?t = "Branch RBT_Impl.B RBT_Impl.Empty x () RBT_Impl.Empty"
    have *:"?t \<in> {t. is_rbt t}" unfolding is_rbt_def by auto
    then have **:"eq_onp is_rbt ?t ?t" unfolding eq_onp_def by auto

    have "RBT.impl_of t = ?t \<Longrightarrow> the_elem (Set t) = x"
      by (subst(asm) RBT_inverse[symmetric, OF *])
        (auto simp: Set_def the_elem_def lookup.abs_eq[OF **] impl_of_inject)
  }
  then show ?thesis
    by(auto split: rbt.split unit.split color.split)
qed

lemma Pow_Set [code]:
  "Pow (Set t) = fold_keys (\<lambda>x A. A \<union> Set.insert x ` A) t {{}}"
by (simp add: Pow_fold finite_fold_fold_keys[OF comp_fun_commute_Pow_fold])

lemma product_Set [code]:
  "Product_Type.product (Set t1) (Set t2) =
    fold_keys (\<lambda>x A. fold_keys (\<lambda>y. Set.insert (x, y)) t2 A) t1 {}"
proof -
  have *:"\<And>x. comp_fun_commute (\<lambda>y. Set.insert (x, y))" by default auto
  show ?thesis using finite_fold_fold_keys[OF comp_fun_commute_product_fold, of "Set t2" "{}" "t1"]
    by (simp add: product_fold Product_Type.product_def finite_fold_fold_keys[OF *])
qed

lemma Id_on_Set [code]:
  "Id_on (Set t) =  fold_keys (\<lambda>x. Set.insert (x, x)) t {}"
proof -
  have "comp_fun_commute (\<lambda>x. Set.insert (x, x))" by default auto
  then show ?thesis
    by (auto simp add: Id_on_fold intro!: finite_fold_fold_keys)
qed

lemma Image_Set [code]:
  "(Set t) `` S = fold_keys (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A) t {}"
by (auto simp add: Image_fold finite_fold_fold_keys[OF comp_fun_commute_Image_fold])

lemma trancl_set_ntrancl [code]:
  "trancl (Set t) = ntrancl (card (Set t) - 1) (Set t)"
by (simp add: finite_trancl_ntranl)

lemma relcomp_Set[code]:
  "(Set t1) O (Set t2) = fold_keys
    (\<lambda>(x,y) A. fold_keys (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') t2 A) t1 {}"
proof -
  interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert)
  have *: "\<And>x y. comp_fun_commute (\<lambda>(w, z) A'. if y = w then Set.insert (x, z) A' else A')"
    by default (auto simp add: fun_eq_iff)
  show ?thesis using finite_fold_fold_keys[OF comp_fun_commute_relcomp_fold, of "Set t2" "{}" t1]
    by (simp add: relcomp_fold finite_fold_fold_keys[OF *])
qed

lemma wf_set [code]:
  "wf (Set t) = acyclic (Set t)"
by (simp add: wf_iff_acyclic_if_finite)

lemma Min_fin_set_fold [code]:
  "Min (Set t) =
  (if RBT.is_empty t
   then Code.abort (STR ''not_non_empty_tree'') (\<lambda>_. Min (Set t))
   else r_min_opt t)"
proof -
  have *: "semilattice (min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" ..
  with finite_fold1_fold1_keys [OF *, folded Min_def]
  show ?thesis
    by (simp add: r_min_alt_def r_min_eq_r_min_opt [symmetric])
qed

lemma Inf_fin_set_fold [code]:
  "Inf_fin (Set t) = Min (Set t)"
by (simp add: inf_min Inf_fin_def Min_def)

lemma Inf_Set_fold:
  fixes t :: "('a :: {linorder, complete_lattice}, unit) rbt"
  shows "Inf (Set t) = (if RBT.is_empty t then top else r_min_opt t)"
proof -
  have "comp_fun_commute (min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" by default (simp add: fun_eq_iff ac_simps)
  then have "t \<noteq> RBT.empty \<Longrightarrow> Finite_Set.fold min top (Set t) = fold1_keys min t"
    by (simp add: finite_fold_fold_keys fold_keys_min_top_eq)
  then show ?thesis
    by (auto simp add: Inf_fold_inf inf_min empty_Set[symmetric] r_min_eq_r_min_opt[symmetric] r_min_alt_def)
qed

definition Inf' :: "'a :: {linorder, complete_lattice} set \<Rightarrow> 'a" where [code del]: "Inf' x = Inf x"
declare Inf'_def[symmetric, code_unfold]
declare Inf_Set_fold[folded Inf'_def, code]

lemma INF_Set_fold [code]:
  fixes f :: "_ \<Rightarrow> 'a::complete_lattice"
  shows "INFIMUM (Set t) f = fold_keys (inf \<circ> f) t top"
proof -
  have "comp_fun_commute ((inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a) \<circ> f)"
    by default (auto simp add: fun_eq_iff ac_simps)
  then show ?thesis
    by (auto simp: INF_fold_inf finite_fold_fold_keys)
qed

lemma Max_fin_set_fold [code]:
  "Max (Set t) =
  (if RBT.is_empty t
   then Code.abort (STR ''not_non_empty_tree'') (\<lambda>_. Max (Set t))
   else r_max_opt t)"
proof -
  have *: "semilattice (max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" ..
  with finite_fold1_fold1_keys [OF *, folded Max_def]
  show ?thesis
    by (simp add: r_max_alt_def r_max_eq_r_max_opt [symmetric])
qed

lemma Sup_fin_set_fold [code]:
  "Sup_fin (Set t) = Max (Set t)"
by (simp add: sup_max Sup_fin_def Max_def)

lemma Sup_Set_fold:
  fixes t :: "('a :: {linorder, complete_lattice}, unit) rbt"
  shows "Sup (Set t) = (if RBT.is_empty t then bot else r_max_opt t)"
proof -
  have "comp_fun_commute (max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" by default (simp add: fun_eq_iff ac_simps)
  then have "t \<noteq> RBT.empty \<Longrightarrow> Finite_Set.fold max bot (Set t) = fold1_keys max t"
    by (simp add: finite_fold_fold_keys fold_keys_max_bot_eq)
  then show ?thesis
    by (auto simp add: Sup_fold_sup sup_max empty_Set[symmetric] r_max_eq_r_max_opt[symmetric] r_max_alt_def)
qed

definition Sup' :: "'a :: {linorder, complete_lattice} set \<Rightarrow> 'a" where [code del]: "Sup' x = Sup x"
declare Sup'_def[symmetric, code_unfold]
declare Sup_Set_fold[folded Sup'_def, code]

lemma SUP_Set_fold [code]:
  fixes f :: "_ \<Rightarrow> 'a::complete_lattice"
  shows "SUPREMUM (Set t) f = fold_keys (sup \<circ> f) t bot"
proof -
  have "comp_fun_commute ((sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a) \<circ> f)"
    by default (auto simp add: fun_eq_iff ac_simps)
  then show ?thesis
    by (auto simp: SUP_fold_sup finite_fold_fold_keys)
qed

lemma sorted_list_set[code]:
  "sorted_list_of_set (Set t) = RBT.keys t"
by (auto simp add: set_keys intro: sorted_distinct_set_unique)

lemma Bleast_code [code]:
 "Bleast (Set t) P = (case filter P (RBT.keys t) of
    x#xs \<Rightarrow> x |
    [] \<Rightarrow> abort_Bleast (Set t) P)"
proof (cases "filter P (RBT.keys t)")
  case Nil thus ?thesis by (simp add: Bleast_def abort_Bleast_def)
next
  case (Cons x ys)
  have "(LEAST x. x \<in> Set t \<and> P x) = x"
  proof (rule Least_equality)
    show "x \<in> Set t \<and> P x" using Cons[symmetric]
      by(auto simp add: set_keys Cons_eq_filter_iff)
    next
      fix y assume "y : Set t \<and> P y"
      then show "x \<le> y" using Cons[symmetric]
        by(auto simp add: set_keys Cons_eq_filter_iff)
          (metis sorted_Cons sorted_append sorted_keys)
  qed
  thus ?thesis using Cons by (simp add: Bleast_def)
qed

hide_const (open) RBT_Set.Set RBT_Set.Coset

end