theory Calc_Mem_Imp_Hoare_Example
  imports Calc_Mem_Imp "../../Hoare/Hoare_Step" "../../Hoare/Hoare_Lift"
    "../../Language_Components/Mem/Mem_Simple"
    "../../Lifter/Auto_Lifter_Proofs" "../../Composition/Composition_Lifter"
    "Calc_Mem_Imp_Hoare"
begin

(* final definitions that perhaps should be in mem_simple (TODO) *)

(* Deriving a set of Hoare logic rules useful for reasoning about imperative code in Imp.
 * then, proceeding with an example.
 *)

abbreviation sems where
"sems \<equiv> {calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l}"

abbreviation sems_nos where
"sems_nos \<equiv> {calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l}"

definition sem_final' :: "syn \<Rightarrow> ('s, _) state \<Rightarrow> ('s, _) state" where
"sem_final' =
  pcomps [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]"

(*lemma idea:
  - if, for each syntax, we can show one function is dominant
  - then we know sups_pres
  - maybe this is actually the best way to do it.
  - what about building this argument up from sub-sets?
    - might be ok if all languages leave things unchanged for other syntax.
*)
(*
lemma dominant_sups_pres2 ::
  assumes "f \<downharpoonleft> {} x"
*)

(*
ok, so... how can we do this?
sups_pres of e.g. calc and mem...
- dominance
- need a nice way to "walk the tree" of liftings and compare priorities
*)

(*
(* New idea: have a lifting for use in theorems about the state. *)
(* in this case we can just use mem_lift1 I think. *)

lemma calc_sem_l_valid :
  ""
*)

lemma sups_pres_calc :
  "sups_pres {calc_sem_l} (\<lambda> _ . ok_S)"
  using sups_pres_singletonI
  by auto

lemma pres :
"sups_pres sems (\<lambda> _ . ok_S)"
  by(rule sups_pres_finite_all; auto)

(* concrete state *)
type_synonym cstate = "(syn, unit) Mem_Simple.state"

definition start_state :: "syn gensyn \<Rightarrow> (syn, unit) Mem_Simple.state" where
"start_state prog =
  ( Swr [prog]
  , mdp 0 (Some (mdt None))
  , Swr 0, Swr 0, Swr 0, Swr 0
  , Swr empty
  , ())"

definition state_mem where
"state_mem st =
  (case st of
    (_, _, _, _, _, _, m, _) \<Rightarrow> m)"

definition prog_mini :: "syn gensyn" where
"prog_mini =  G (Sc (Cnum 42)) []
"

(* first test: a simple arithmetic *)
definition prog0 :: "syn gensyn" where
"prog0 =
  G (Ss Sseq)
  [ G (Sc (Cnum 42)) []
  , G (Sm (Swrite (STR ''A'') Reg_c)) []
  ]"

definition prog00 :: "syn gensyn" where
"prog00 =
  G (Sb (Seqz)) []
  "

(* multiplication as repeated addition *)
(* start with c = 0
 * add arg1 to c
 * decrement arg2 *)

definition prog1 :: "int \<Rightarrow> int \<Rightarrow> syn gensyn" where
"prog1 i1 i2 =
  G (Ss Sseq)
  [ G (Sc (Cnum i1)) []
  , G (Sm (Swrite (STR ''arg1'') (Reg_c))) []
  , G (Sc (Cnum i2)) []
  , G (Sm (Swrite (STR ''arg2'') (Reg_c))) []
  , G (Sc (Cnum 1)) []
  , G (Sm (Swrite (STR ''one'') (Reg_c))) []
  , G (Sc (Cnum 0)) []
  , G (Sm (Swrite (STR ''acc'') (Reg_c))) []

  , G (Sm (Sread (STR ''arg2'') (Reg_c))) []
  , G (Sb Sgtz) []

  , G (Si SwhileC)
    [ G (Ss Sseq)
      [G (Sm (Sread (STR ''arg1'') (Reg_a))) []
      , G (Sm (Sread (STR ''acc'') (Reg_b))) []
      , G (Sc Cadd) []
      , G (Sm (Swrite (STR ''acc'') (Reg_c))) []
      , G (Sm (Sread (STR ''arg2'') (Reg_a))) []
      , G (Sm (Sread (STR ''one'') (Reg_b))) []
      , G (Sc Csub) []
      , G (Sm (Swrite (STR ''arg2'') (Reg_c))) []
      , G (Sm (Sread (STR ''arg2'') (Reg_c))) []
      , G (Sb Sgtz) []
      ]
    ]
  ]
"

(*
term "sem_run sem_final"

value "sem_run sem_final 100 (start_state prog0)"

value "sem_run (pcomps [calc_sem_l, mem_sem_l, seq_sem_l, cond_sem_l]) 100 (start_state prog_mini)"

value "sem_run sem_final 100 (start_state prog_mini)"

value "sem_run sem_final 100 (start_state (prog1 2 3))"
*)

definition oalist_check' :: "('a :: linorder * 'b md_triv option md_prio) list \<Rightarrow> bool"
  where
"oalist_check' l =
  list_all
    (\<lambda> x . case x of
      (k, mdp _ (Some (mdt _))) \<Rightarrow> True
      | _ \<Rightarrow> False ) l"

lift_definition oalist_check :: "('a :: linorder, 'b md_triv option md_prio) oalist \<Rightarrow> bool"
is oalist_check' .

fun oalist_unwrap' ::
"('a :: linorder * 'b md_triv option md_prio) list \<Rightarrow>
 ('a :: linorder * 'b) list option"
where
"oalist_unwrap' [] = Some []"
| "oalist_unwrap' (h#t) =
  (case h of
    (k, mdp _ (Some (mdt v))) \<Rightarrow>
      (case oalist_unwrap' t of
        Some t' \<Rightarrow> Some ((k, v)#t')
        | None \<Rightarrow> None)
    | _ \<Rightarrow> None)"

lemma oalist_unwrap'_keys :
  "oalist_unwrap' l = Some l' \<Longrightarrow>
   map fst l = map fst l'"
proof(induction l arbitrary: l')
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then show ?case
    by(auto split: prod.splits option.splits md_triv.splits md_prio.splits)
qed

lift_definition oalist_unwrap ::
"('a :: linorder, 'b md_triv option md_prio) oalist \<Rightarrow>
 ('a :: linorder, 'b ) oalist option"
is oalist_unwrap'
proof-
  fix list :: "('a :: linorder * 'b md_triv option md_prio) list"
  assume H : "strict_order (map fst list)"

  show "pred_option (\<lambda>xs. strict_order (map fst xs))
        (oalist_unwrap' list)"
    using H oalist_unwrap'_keys[of list]
    by(auto simp add: pred_option_def)
qed

lemma prog1_spec :
  assumes Hi1 : "0 < i1" (* TODO: this should be \<le>, but for (i think) a technical reason this makes things hard (existential quantifier related problems) *)
  assumes Hi2 : "0 \<le> i2"

(* prog1 *)
(*
arg1 := i1
arg2 := i2
one := 1
acc := 0
while (arg2 > 0) {
  acc := acc + arg1
  arg2 := arg2 - one
}

*)

shows "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state))| {~ (\<lambda> st . st \<in> ok_S) ~}
                   [prog1 i1 i2]
                   {~ (\<lambda> st . st \<in> ok_S \<and>
                      (case st of
                        (reg_flag, reg_c, reg_a, reg_b, mem, xz) \<Rightarrow>
                          (case mem of
                            (mdp p (Some (mdt mem'))) \<Rightarrow> get mem'(STR ''acc'') = Some (i1 * i2)
                            | _ \<Rightarrow> False)))
  ~}"
(*
  using HTS_imp_HT''[where l' = calc_trans, where x = "Calc_Mem_Imp.syn.Sc (Cnum i1)"
        , unfolded calc_trans.simps, OF HCalc_Cnum]
*)
proof-
  fix gs P z l

  have 1: "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, ('x )) state))| {~(\<lambda> st . st \<in> ok_S) ~}
[ G (Sc (Cnum i1)) []]
  {~(\<lambda> st . st \<in> ok_S \<and>
    (case st of (reg_flag, reg_c, reg_a, reg_b, mem, xz) \<Rightarrow>
      (case reg_c of mdp p reg_c' \<Rightarrow> reg_c' = Some (mdt i1))))~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, ('x)) state))| {~ ?P0 ~}
[ G (Sc (Cnum i1)) []]
  {~ ?P1~}")

    apply(rule HT'Conseq)
      apply(rule_tac P' = "\<lambda> _ . True" in Calc_Final)
       apply(fast) apply(fast)
    apply(force  simp add: calc_lift'_def schem_lift_defs merge_l_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S)
     apply(fast)
    apply(force  simp add: calc_lift'_def schem_lift_defs merge_l_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S)
    done

  have 2 : "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, ('x)) state))|
    {~ ?P1 ~}
    [G (Sm (Swrite (STR ''arg1'') (Reg_c))) []]
{~(\<lambda>st. st \<in> ok_S \<and> (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
                      (case m of
                        mdp p (Some (mdt m')) \<Rightarrow> get m' (STR ''arg1'') = Some i1
                         | _ \<Rightarrow> False)))~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P1 ~}
    [G (Sm (Swrite (STR ''arg1'') (Reg_c))) []]
  {~ ?P2 ~}")

    apply(rule HT'Conseq)
      apply(rule_tac
 P = ?P1
and P' = "\<lambda> st . case st of (_, x, _, _) \<Rightarrow> x = i1"
in  Mem_Write_Final
;
fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
LNew_def)

     apply(fast)

      apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def)

    done

(* TODO: need assumption about mem being empty? *)
  have 3: "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?P2~}
[ G (Sc (Cnum i2)) []]
  {~(\<lambda> st . ?P2 st \<and> (case st of (reg_flag, reg_c, reg_a, reg_b, mem, xz) \<Rightarrow>
      (case reg_c of mdp p reg_c' \<Rightarrow> reg_c' = Some (mdt i2))))~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?P2 ~}
[ G (Sc (Cnum i2)) []]
  {~ ?P3~}")
    apply(rule HT'Conseq)
      apply(rule_tac P = ?P2 and P' = "\<lambda> _ . True" in Calc_Final)
       apply(fast) apply(fast)

      apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
    done

  have 4 : "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P3 ~}
    [G (Sm (Swrite (STR ''arg2'') (Reg_c))) []]
{~(\<lambda>st. st \<in> ok_S \<and> (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
                      (case m of
                        mdp p (Some (mdt m')) \<Rightarrow>
                          get m' (STR ''arg1'') = Some i1 \<and> get m' (STR ''arg2'') = Some i2
                         | _ \<Rightarrow> False)))~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P3 ~}
    [G (Sm (Swrite (STR ''arg2'') (Reg_c))) []]
  {~ ?P4 ~}")

    apply(rule HT'Conseq)
      apply(rule_tac P = ?P3
and P' = "\<lambda> st . case st of (_, x, _, _, m) \<Rightarrow> x = i2 \<and> get m (STR ''arg1'') = Some i1"
  in Mem_Write_Final)
       apply(fast)

      apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
(* YOU ARE HERE. *)
(* wat *)
  apply(auto simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq
split:md_triv.splits)
    done

  have 5 : "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P4 ~}
    [G (Calc_Mem_Imp.syn.Sc (Cnum 1)) []]
{~(\<lambda>st. st \<in> ok_S \<and> ?P4 st \<and> (case st of (reg_flag, reg_c, reg_a, reg_b, mem, xz) \<Rightarrow>
      (case reg_c of mdp p reg_c \<Rightarrow> reg_c = Some (mdt 1))))~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P4 ~}
    _
  {~ ?P5 ~}")

    apply(rule HT'Conseq)
      apply(rule_tac P = ?P4
and P' = "\<lambda> _ . True"
  in Calc_Final)
       apply(fast)

      apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

    done

  have 6 : "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P5 ~}
    [G (Calc_Mem_Imp.syn.Sm (Swrite STR ''one'' Reg_c)) []]
{~(\<lambda>st. st \<in> ok_S \<and> (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
                      (case m of
                        mdp p (Some (mdt m')) \<Rightarrow>
                          get m' (STR ''arg1'') = Some i1 \<and> get m' (STR ''arg2'') = Some i2 \<and> get m' (STR ''one'') = Some 1
                         | _ \<Rightarrow> False)))~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P5 ~}
    _
  {~ ?P6 ~}")

    apply(rule HT'Conseq)
    apply(rule_tac P = ?P5
and P' = "\<lambda> st . case st of (_, x, _, _, m) \<Rightarrow> x = 1 \<and> get m (STR ''arg1'') = Some i1 \<and> get m (STR ''arg2'') = Some i2"
in Mem_Write_Final)
       apply(fast)

      apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq
split: md_triv.splits)

    done

  have 7 : "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, ('x)) state))|
    {~ ?P6 ~}
    [G (Calc_Mem_Imp.syn.Sc (Cnum 0)) []]
{~(\<lambda>st. st \<in> ok_S \<and> ?P6 st \<and> (case st of (reg_flag, reg_c, reg_a, reg_b, mem, xz) \<Rightarrow>
      (case reg_c of mdp p reg_c \<Rightarrow> reg_c = Some (mdt 0))))~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P6 ~}
    _
  {~ ?P7 ~}")
    apply(rule HT'Conseq)
      apply(rule_tac P = ?P6
and P' = "\<lambda> _ . True"
  in Calc_Final)
       apply(fast)

      apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

    done

  have 8 : "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P7 ~}
    [G (Calc_Mem_Imp.syn.Sm (Swrite STR ''acc'' Reg_c)) []]
{~(\<lambda>st. st \<in> ok_S \<and> (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
                      (case m of
                        mdp p (Some (mdt m')) \<Rightarrow>
                          get m' (STR ''arg1'') = Some i1 \<and> get m' (STR ''arg2'') = Some i2 \<and> get m' (STR ''one'') = Some 1 \<and> get m' (STR ''acc'') = Some 0
                         | _ \<Rightarrow> False)))~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P7 ~}
    _
  {~ ?P8 ~}")

    apply(rule HT'Conseq)
    apply(rule_tac P = ?P7
and P' = "\<lambda> st . case st of (_, x, _, _, m) \<Rightarrow> x = 0 \<and> get m (STR ''arg1'') = Some i1
          \<and> get m (STR ''arg2'') = Some i2
          \<and> get m (STR ''one'') = Some 1"

in Mem_Write_Final)
       apply(fast)

      apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(auto simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq)

    done

(* TODO: we need to strengthen mem_read_final
along the same lines as mem_write_final. *)
  have 9 : "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P8 ~}
    [G (Calc_Mem_Imp.syn.Sm (Sread STR ''arg2'' Reg_c)) []]
{~ (\<lambda> st . st \<in> ok_S \<and> (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
                      (case m of
                        mdp p (Some (mdt m')) \<Rightarrow>
                          get m' (STR ''arg1'') = Some i1 \<and> get m' (STR ''arg2'') = Some i2 \<and> get m' (STR ''one'') = Some 1 \<and> get m' (STR ''acc'') = Some 0
                         | _ \<Rightarrow> False) \<and>
                      (case reg_c of
                        mdp p (Some (mdt x)) \<Rightarrow> x = i2
                        | _ \<Rightarrow> False))) ~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P8 ~}
    _
  {~ ?P9 ~}")

    apply(rule HT'Conseq)
    apply(rule_tac P = ?P8
and P' = "\<lambda> st . (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m) \<Rightarrow>
                      get m (STR ''arg1'') = Some i1
          \<and> get m (STR ''arg2'') = Some i2
          \<and> get m (STR ''one'') = Some 1
          \<and> get m (STR ''acc'') = Some 0)"
in Mem_Read_Final)

       apply(fast)

      apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

      apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

(*
  apply(fastforce simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def oalist_map_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
*)

    apply(clarify)

  apply(simp add: calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq
split: md_triv.splits)

    apply(clarify)

    apply(simp split: md_prio.splits md_triv.splits option.splits)

    done

(* establishing the invariant. *)
(*
invariant: acc = i1 * (arg2 - i2)
*)

  have 10 : "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|
    {~ ?P9 ~}
    [G (Sb Sgtz) []]
    {~ (\<lambda> st . st \<in> ok_S \<and> (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
                      (case m of
                        mdp p (Some (mdt m')) \<Rightarrow>
                          get m' (STR ''arg1'') = Some i1 \<and> get m' (STR ''arg2'') = Some i2 \<and> get m' (STR ''one'') = Some 1 \<and> get m' (STR ''acc'') = Some 0 \<and>
                         (case reg_flag of
                          mdp p (Some (mdt reg_flag')) \<Rightarrow>
                            (reg_flag' = 0 \<and> i2 \<le> 0) \<or> (reg_flag' = 1 \<and> i2 > 0)
                          | _ \<Rightarrow> False)
                         | _ \<Rightarrow> False))) ~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))|{~ ?P9 ~}
    [G (Sb Sgtz) []]
    {~ ?P10 ~}")
    apply(rule HT'Conseq)
    apply(rule_tac P = ?P9 and P' = "\<lambda> st . (case st of (b, x) \<Rightarrow> x = i2)"
in Cond_Final)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
    apply(clarify)
  apply(simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def cond_sem_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
    apply(clarify)
    apply(case_tac "(0 < i2)")
  apply(simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def cond_sem_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def cond_sem_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
    done

  obtain Inv :: "('x :: {Bogus,Okay,Mergeableb,Pordc_all, Pordps}) Mem_Simple.state1 \<Rightarrow> bool" where Inv_def :
  "Inv = (\<lambda> st . st \<in> ok_S \<and> (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
                      (case m of
                        mdp p (Some (mdt m')) \<Rightarrow>
                          (\<exists> (idx :: int) . get m' (STR ''arg1'') = Some i1 \<and>
                                       get m' (STR ''arg2'') = Some idx \<and>
                                       get m' (STR ''one'') = Some 1 \<and>
                                       get m' (STR ''acc'') = Some (i1 * (i2 - idx)) \<and>
                                       i2 \<ge> idx \<and>
                                       (case reg_flag of mdp p (Some (mdt reg_flag')) \<Rightarrow>
                                         ((reg_flag' = 1 \<and> idx > 0) \<or> (reg_flag' = 0 \<and> idx = 0))
                                         | _ \<Rightarrow> False))
                        | _ \<Rightarrow> False)))"
    by simp

  have Inv_10 :
    "\<And> st . (?P10 st) \<Longrightarrow>
  Inv st"
    using Hi2 unfolding Inv_def
    by(auto split: md_triv.splits md_prio.splits option.splits)

(* while loop body *)
  have Body1 :
"|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ (\<lambda> st .
                  Inv st \<and>
                  (case st of (mdp p (Some (mdt reg_flag')), _) \<Rightarrow>
                    reg_flag' \<noteq> 0
                   | _ \<Rightarrow> False)) ~}
  [G (Calc_Mem_Imp.syn.Sm (Sread STR ''arg1'' Reg_a)) []]
  {~ (\<lambda> st . st \<in> ok_S \<and> (case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case reg_a of
        mdp p (Some (mdt reg_a')) \<Rightarrow> reg_a' = i1 \<and>
        (case m of
          mdp p (Some (mdt m')) \<Rightarrow>
            (\<exists> idx .
get m' (STR ''arg1'') = Some i1 \<and>
get m' (STR ''arg2'') = Some idx \<and>
                     get m' (STR ''one'') = Some 1 \<and>
                     get m' (STR ''acc'') = Some (i1 * (i2 - idx)) \<and>
                     i2 \<ge> idx \<and>idx > 0)
          | _ \<Rightarrow> False)
        | _ \<Rightarrow> False))) ~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?B0 ~} _ {~ ?B1 ~}")
    apply(rule HT'Conseq)
    apply(rule_tac P = ?B0
and P' = "\<lambda> st . (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m) \<Rightarrow>
                     reg_flag = 1 \<and>
                     (\<exists> (idx :: int) . get m (STR ''arg1'') = Some i1 \<and>
                                 get m (STR ''arg2'') = Some idx \<and>
                                 get m (STR ''one'') = Some 1 \<and>
                                 get m (STR ''acc'') = Some (i1 * (i2 - idx)) \<and>
                                 i2 \<ge> idx \<and>idx > 0))"
in Mem_Read_Final)

  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force  simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(force  simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

  apply(fastforce simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def cond_sem_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits option.splits)

    done

(*
(\<lambda> st . st \<in> ok_S \<and> (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
                      (case m of
                        mdp p (Some (mdt m')) \<Rightarrow>
                          (\<exists> idx . get m' (STR ''arg1'') = Some i1 \<and>
                                       get m' (STR ''arg2'') = Some idx \<and>
                                       get m' (STR ''one'') = Some 1 \<and>
                                       get m' (STR ''acc'') = Some (i1 * (i2 - idx)) \<and>
                                       i2 \<ge> idx \<and>idx \<ge> 0))))
*)
  have Body2 :
"|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?B1 ~}
  [G (Calc_Mem_Imp.syn.Sm (Sread STR ''acc'' Reg_b)) []]
  {~ (\<lambda> st . ?B1 st \<and> (case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case reg_b of
        mdp p (Some (mdt reg_b')) \<Rightarrow>
        (case m of
          mdp p (Some (mdt m')) \<Rightarrow>
            (\<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = i1 * (i2 - idx) \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some idx \<and>
            get m' (STR ''acc'') = Some (i1 * (i2 - idx)))
                      | _ \<Rightarrow> False)
                    | _ \<Rightarrow> False))) ~}"

(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ _ ~} _ {~ ?B2 ~}")
    apply(rule HT'Conseq)
    apply(rule_tac P = ?B1
and P' = "\<lambda> st . (case st of
                     (reg_flag, reg_c, reg_a, reg_b,  m) \<Rightarrow>
                     (\<exists> idx . get m (STR ''arg1'') = Some i1 \<and> i1 = reg_a \<and>
                                 get m (STR ''arg2'') = Some idx \<and>
                                 get m (STR ''one'') = Some 1 \<and>
                                 get m (STR ''acc'') = Some (i1 * (i2 - idx)) \<and>
                                 i2 \<ge> idx \<and>idx > 0))"
in Mem_Read_Final)

  apply(force  simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def cond_sem_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

    apply(clarify)

  apply(simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
      apply(clarify)
  apply(simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
     apply(clarify)
  apply(simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

    apply(clarify)

     apply(
 simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits option.splits)

    apply(clarify)
    apply(blast)

    done

  have Body3 :
(*
"|(sem_final :: (syn \<Rightarrow> (syn, (_ :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state))| {~ ?B2 ~}
  [G (Calc_Mem_Imp.syn.Sc Cadd) []]
  {~ (\<lambda> st . st \<in> ok_S \<and>(case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c'))) \<Rightarrow>
        (case m of
          mdp p (Some (mdt m')) \<Rightarrow>
            (\<exists> idx . reg_c' = i1 * (i2 - idx) + i1 \<and>
                     reg_a' = i1 \<and> reg_b' = i1 * (i2 - idx) \<and>  get m' (STR ''acc'') = Some (i1 * (i2 - idx)) \<and>
                     i2 \<ge> idx \<and> idx \<ge> 0)
          | _ \<Rightarrow> False)
        | _ \<Rightarrow> False))) ~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, (_ :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state))| {~ _ ~} _ {~ ?B3 ~}")
*)
(*
"|(sem_final :: (syn \<Rightarrow> (syn, (_ :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state))| {~ ?B2 ~}
  [G (Calc_Mem_Imp.syn.Sc Cadd) []]
  {~ (\<lambda> st . ?B2 st \<and>(case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c'))) \<Rightarrow>
        (case m of
          mdp p (Some (mdt m')) \<Rightarrow>
            (\<exists> (idx :: int) . reg_c' = i1 + i1 * (i2 - idx) \<and>
                     reg_a' = i1 \<and> reg_b' = i1 * (i2 - idx) \<and>
                     get m' (STR ''acc'') = Some (i1 * (i2 - idx)) \<and>
                     get m' (STR ''arg2'') = Some idx \<and>
                     i2 \<ge> idx \<and> idx \<ge> 0)
          | _ \<Rightarrow> False)
        | _ \<Rightarrow> False))) ~}"
*)
(*
"|(sem_final :: (syn \<Rightarrow> (syn, (_ :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state))| {~ ?B2 ~}
  [G (Calc_Mem_Imp.syn.Sc Cadd) []]
  {~ (\<lambda> st . ?B2 st \<and>(case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c'))) \<Rightarrow>
        reg_a' = i1 \<and>
         (\<exists> (idx :: int) . i2 \<ge> idx \<and> idx > 0 \<and> reg_b' = i1 * (i2 - idx) \<and> reg_c' = i1 + i1 * (i2 - idx))
        | _ \<Rightarrow> False))) ~}"
*)
(*maybe we need a different calc rule(unchanged stuff *)
"|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?B2 ~}
  [G (Calc_Mem_Imp.syn.Sc Cadd) []]
  {~ (\<lambda> st . ?B2 st \<and>(case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c'))) \<Rightarrow>
        reg_c' = reg_a' + reg_b'
                | _ \<Rightarrow> False))) ~}"

(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ _ ~} _ {~ ?B3 ~}")

    apply(rule HT'Conseq)
(*
    apply(rule_tac P = ?B2
and P' = "\<lambda> _ . True"
in Calc_Final)
*)
(* TODO: looks like we actually do need a fact about the rest of the state
remaining unchanged. (this is in cases like arith, for instance, we need
to show a sort of "frame" where everything not in calc is unchanged *)

(*
    apply(rule_tac P = ?B2
and P' = "\<lambda> st . case st of (reg_a, reg_b, reg_c) \<Rightarrow>
          reg_a = i1 \<and>
          (\<exists> (idx :: int) . i2 \<ge> idx \<and> idx > 0 \<and> reg_b = i1 * (i2 - idx))"
in Calc_Final)
*)
    apply(rule_tac Add_Final_Strong[of "?B2" "\<lambda> st . case st of (reg_a, reg_b, reg_c) \<Rightarrow>
          reg_a = i1 \<and>
          (\<exists> (idx :: int) . i2 \<ge> idx \<and> idx > 0 \<and> reg_b = i1 * (i2 - idx))"])

(*
    apply(rule_tac P = ?B2
and P' = "\<lambda> st . case st of (reg_a, reg_b, reg_c) \<Rightarrow>
          reg_a = i1 \<and>
          (\<exists> (idx :: int) . i2 \<ge> idx \<and> idx > 0 \<and> reg_b = i1 * (i2 - idx) \<and>
          (\<forall> st_big st0 . ?B2 st_big \<longrightarrow>
             (case LOut mem_lift1 (Sread STR ''acc'' Reg_b) st_big of
                     (reg_flag, reg_c, reg_a, reg_b',  m) \<Rightarrow>
(reg_b = reg_b' \<longrightarrow>
                     get m (STR ''arg2'') = Some idx))))"
in Add_Final)
*)

  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

    apply(insert Hi2)
    apply(insert Hi1)
    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
      apply(clarify)
    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
      apply(clarify)

    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
    apply(clarify)

    apply(simp)
    apply(insert Hi2)
    apply(insert Hi1)

  apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

    apply(clarify)
    apply(simp (no_asm_simp))
(* begin experiment *)

(* end experiment *)
  apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def split: md_triv.splits
)
    done

  have Body4 :
"|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?B3 ~}
  [G (Calc_Mem_Imp.syn.Sm (Swrite STR ''acc'' Reg_c)) []]
  {~ (\<lambda> st .  st \<in> ok_S \<and> (case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c, m) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c')), mdp _ (Some (mdt m'))) \<Rightarrow>
        \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = i1 * (i2 - idx) \<and> reg_c' = i1 + i1 * (i2 - idx) \<and> reg_a' = i1 \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some idx \<and>
            get m' (STR ''one'') = Some (1) \<and>
            get m' (STR ''acc'') = Some ( i1 + i1 * (i2 - idx))
        | _ \<Rightarrow> False))) ~}"

(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ _ ~} _ {~ ?B4 ~}")

    apply(rule HT'Conseq)
(*
    apply(rule_tac P = ?B2
and P' = "\<lambda> _ . True"
in Calc_Final)
*)
    apply(rule_tac P = ?B3
and P' = "\<lambda> st . case st of (reg_flag', reg_c', reg_a', reg_b', m') \<Rightarrow>
            \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = i1 * (i2 - idx) \<and> reg_c' = i1 + i1 * (i2 - idx) \<and> reg_a' = i1 \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some idx \<and>
            get m' (STR ''acc'') = Some ( i1 * (i2 - idx)) \<and>
 get m' (STR ''one'') = Some (1)"
in Mem_Write_Final)

  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq get_update
split: md_triv.splits)
    done

  have Body5 :
    "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?B4 ~}
  [G (Calc_Mem_Imp.syn.Sm (Sread STR ''arg2'' Reg_a)) []]
  {~ (\<lambda> st .  st \<in> ok_S \<and> (case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c, m) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c')), mdp _ (Some (mdt m'))) \<Rightarrow>
        \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = i1 * (i2 - idx) \<and> reg_c' = i1 + i1 * (i2 - idx) \<and> reg_a' = idx \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some idx \<and>
            get m' (STR ''one'') = Some (1) \<and>
            get m' (STR ''acc'') = Some ( i1 + i1 * (i2 - idx))
        | _ \<Rightarrow> False))) ~}"

(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ _ ~} _ {~ ?B5 ~}")
    apply(rule HT'Conseq)
    apply(rule_tac P = ?B4
and P' = "\<lambda> st . case st of (reg_flag', reg_c', reg_a', reg_b', m') \<Rightarrow>
            \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = i1 * (i2 - idx) \<and> reg_c' = i1 + i1 * (i2 - idx) \<and> reg_a' = i1 \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some idx \<and>
            get m' (STR ''acc'') = Some (i1 + i1 * (i2 - idx)) \<and>
 get m' (STR ''one'') = Some (1)"
in Mem_Read_Final)

  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq get_update
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq get_update
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq get_update
split: md_triv.splits)
    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
      apply(clarify)
    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
      apply(clarify)

    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
    apply(auto split: option.splits)
    done

  have Body6 :
    "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?B5 ~}
  [G (Calc_Mem_Imp.syn.Sm (Sread STR ''one'' Reg_b)) []]
  {~ (\<lambda> st .  st \<in> ok_S \<and> (case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c, m) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c')), mdp _ (Some (mdt m'))) \<Rightarrow>
        \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = 1 \<and> reg_c' = i1 + i1 * (i2 - idx) \<and> reg_a' = idx \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some idx \<and>
            get m' (STR ''one'') = Some (1) \<and>
            get m' (STR ''acc'') = Some ( i1 + i1 * (i2 - idx))
        | _ \<Rightarrow> False))) ~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ _ ~} _ {~ ?B6 ~}")
    apply(rule HT'Conseq)
    apply(rule_tac P = ?B5
and P' = "\<lambda> st . case st of (reg_flag', reg_c', reg_a', reg_b', m') \<Rightarrow>
            \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = i1 * (i2 - idx) \<and> reg_c' = i1 + i1 * (i2 - idx) \<and> reg_a' = idx \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some idx \<and>
            get m' (STR ''acc'') = Some (i1 + i1 * (i2 - idx)) \<and>
 get m' (STR ''one'') = Some (1)"
in Mem_Read_Final)

  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq get_update
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq get_update
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq get_update
split: md_triv.splits)
    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
      apply(clarify)
    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
      apply(clarify)

    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
    apply(auto split: option.splits)
    done

  have Body7 :
    "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?B6 ~}
  [G (Calc_Mem_Imp.syn.Sc Csub) []]
  {~ (\<lambda> st .  st \<in> ok_S \<and> (case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c, m) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c')), mdp _ (Some (mdt m'))) \<Rightarrow>
        \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = 1 \<and> reg_c' = idx - 1 \<and> reg_a' = idx \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some idx \<and>
            get m' (STR ''one'') = Some (1) \<and>
            get m' (STR ''acc'') = Some ( i1 + i1 * (i2 - idx))
        | _ \<Rightarrow> False))) ~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ _ ~} _ {~ ?B7 ~}")
    apply(rule HT'Conseq)
    apply(rule_tac P = ?B6
and P' = "\<lambda> st . case st of (reg_a', reg_b', reg_c') \<Rightarrow>
            \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = 1  \<and> reg_a' = idx"
in Sub_Final_Strong)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

    apply(insert Hi2)
    apply(insert Hi1)
    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
      apply(clarify)
    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits md_prio.splits)
     apply(clarify)

    apply(simp)
    apply(clarify)
    apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
    apply(clarify)

  apply(simp add: Inv_def cond_lift'_def calc_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

    done

    have Body8 :
    "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?B7 ~}
  [G (Calc_Mem_Imp.syn.Sm (Swrite STR ''arg2'' Reg_c)) []]
  {~ (\<lambda> st .  st \<in> ok_S \<and> (case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c, m) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c')), mdp _ (Some (mdt m'))) \<Rightarrow>
        \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = 1 \<and> reg_c' = idx - 1 \<and> reg_a' = idx \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some (idx - 1) \<and>
            get m' (STR ''one'') = Some (1) \<and>
            get m' (STR ''acc'') = Some ( i1 + i1 * (i2 - idx))
        | _ \<Rightarrow> False))) ~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ _ ~} _ {~ ?B8 ~}")
      apply(rule_tac HT'Conseq)
    apply(rule_tac P = ?B7
and P' = "\<lambda> st . case st of (reg_flag', reg_c', reg_a', reg_b', m') \<Rightarrow>
            \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = 1 \<and> reg_c' = idx - 1 \<and> reg_a' = idx \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some idx \<and>
            get m' (STR ''acc'') = Some ( i1 + i1 * (i2 - idx))\<and>
 get m' (STR ''one'') = Some (1)"
in Mem_Write_Final)

  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def get_update_neq get_delete_neq get_update
split: md_triv.splits)
      done

    have Body9 :
    "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn,'x) state))| {~ ?B8 ~}
  [G (Calc_Mem_Imp.syn.Sm (Sread STR ''arg2'' Reg_c)) []]
  {~ (\<lambda> st .  st \<in> ok_S \<and> (case st of (reg_flag, reg_c, reg_a, reg_b,  m, xz) \<Rightarrow>
      (case (reg_a, reg_b, reg_c, m) of
        (mdp _ (Some (mdt reg_a')), mdp _ (Some (mdt reg_b')), mdp _ (Some (mdt reg_c')), mdp _ (Some (mdt m'))) \<Rightarrow>
        \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = 1 \<and> reg_c' = idx - 1 \<and> reg_a' = idx \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some (idx - 1) \<and>
            get m' (STR ''one'') = Some (1) \<and>
            get m' (STR ''acc'') = Some ( i1 + i1 * (i2 - idx))
        | _ \<Rightarrow> False))) ~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ _ ~} _ {~ ?B9 ~}")
      apply(rule_tac HT'Conseq)
    apply(rule_tac P = ?B8
and P' = "\<lambda> st . case st of (reg_flag', reg_c', reg_a', reg_b', m') \<Rightarrow>
            \<exists> (idx :: int) . i2 \<ge>  idx \<and> idx > 0 \<and> reg_b' = 1 \<and> reg_c' = idx - 1 \<and> reg_a' = idx \<and>
            get m' (STR ''arg1'') = Some i1 \<and>
            get m' (STR ''arg2'') = Some (idx - 1) \<and>
            get m' (STR ''acc'') = Some ( i1 + i1 * (i2 - idx))\<and>
 get m' (STR ''one'') = Some (1)"
in Mem_Read_Final)

  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)

    apply(clarify)

     apply(
 simp add: Inv_def cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits option.splits)

      done

    have Helper : "\<And> (x :: int) (y :: int) . x + x * y = x * (1 + y)"
    proof-
      fix x y :: int
      show "x + x * y = x * (1 + y)"
        using int_distrib
        by auto
    qed

    have Body10:
    "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ ?B9 ~}
  [G (Sb Sgtz) []]
  {~ Inv ~}"
(is "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ _ ~} _ {~ _ ~}")
      apply(rule_tac HT'Conseq)
        apply(rule_tac
P = ?B9 and
P' = "\<lambda> st . (case st of (b, x) \<Rightarrow> \<exists> idx . i2 \<ge>  idx \<and> idx > 0 \<and> x = (idx - 1))" in
 Gtz_Final_Strong)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(force simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
  apply(simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def cond_sem_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def
split: md_triv.splits)
      apply(clarify)
  apply(simp add: cond_lift'_def schem_lift_defs merge_l_def mem_lift1_def
mem_sem_lifting_inner_def Inv_def
fst_l_def snd_l_def prio_l_def option_l_def triv_l_def
option_ok_S prod_ok_S prio_ok_S triv_ok_S oalist_ok_S
 LNew_def int_distrib
split: md_triv.splits)
      done

      have Conclusion :
        "\<And> st . Inv st \<Longrightarrow>
         get_cond st = Some False \<Longrightarrow>
    (case st of (_, _, _, _, mdp p (Some (mdt m')), _) \<Rightarrow> get m' (STR ''acc'') = Some (i1 * i2)
     | _ \<Rightarrow> False
      )"
    using Hi1 Hi2 unfolding Inv_def
    apply(auto simp add: get_cond_def split: md_triv.splits md_prio.splits)
    apply(case_tac x2a; simp)
    apply(case_tac a; simp)
    apply(case_tac x2; simp)
    apply(case_tac ad; simp)
    apply(case_tac "xa = 0"; simp)
    done

  show "|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~ (\<lambda> st . st \<in> ok_S) ~}
                   [prog1 i1 i2]
                   {~ (\<lambda> st . st \<in> ok_S \<and>
                      (case st of
                        (reg_flag, reg_c, reg_a, reg_b, mem, xz) \<Rightarrow>
                          (case mem of
                            (mdp p (Some (mdt mem'))) \<Rightarrow> get mem'(STR ''acc'') = Some (i1 * i2)
                            | _ \<Rightarrow> False)))
  ~}"
    unfolding prog1_def
  proof(rule HxSeq)
    show "(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state)) = pcomps [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]"
      using sem_final_def by simp
  next
    show "seq_sem_l_gen seq_trans = seq_sem_l_gen seq_trans"
      by simp
  next
    show "sups_pres (set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]) (\<lambda>_. ok_S)"
      by(rule sups_pres_finite_all; auto)
  next
    show "seq_sem_l \<in> set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]"
      by auto
  next
    show "seq_sem_l_gen
     seq_trans \<downharpoonleft> set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l] {Ss Sseq}"
      using seq_dom unfolding sems_def seq_sem_l_def
      by(auto)
  next
    show "seq_trans (Ss Sseq) = Sseq"
      by auto
  next
    show
"|(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state))| {~(\<lambda>st. st \<in> ok_S)~} [G (Sc (Cnum i1)) [],
      G (Sm (Swrite STR ''arg1'' Reg_c)) [], G (Sc (Cnum i2)) [],
      G (Sm (Swrite STR ''arg2'' Reg_c)) [], G (Sc (Cnum 1)) [],
      G (Sm (Swrite STR ''one'' Reg_c)) [], G (Sc (Cnum 0)) [],
      G (Sm (Swrite STR ''acc'' Reg_c)) [],
      G (Sm (Sread STR ''arg2'' Reg_c)) [], G (Sb Sgtz) [],
      G (Si SwhileC)
       [G (Ss Sseq)
         [G (Sm (Sread STR ''arg1'' Reg_a)) [],
          G (Sm (Sread STR ''acc'' Reg_b)) [], G (Sc Cadd) [],
          G (Sm (Swrite STR ''acc'' Reg_c)) [],
          G (Sm (Sread STR ''arg2'' Reg_a)) [],
          G (Sm (Sread STR ''one'' Reg_b)) [], G (Sc Csub) [],
          G (Sm (Swrite STR ''arg2'' Reg_c)) [],
          G (Sm (Sread STR ''arg2'' Reg_c)) [],
          G (Sb Sgtz)
           []]]] {~(\<lambda>st. st \<in> ok_S \<and>
                          (case st of
                           (reg_flag, reg_c, reg_a, reg_b,
                            mdp p None, xz) \<Rightarrow>
                             False
                           | (reg_flag, reg_c, reg_a, reg_b,
                              mdp p (Some (mdt mem')), xz) \<Rightarrow>
                               get mem' STR ''acc'' =
                               Some (i1 * i2)))~}"
      apply(rule HT'Cons)
(* TODO: is our loop invariant correct? *)

       apply(rule 1)
      apply(rule HT'Cons)
       apply(rule 2)
      apply(rule HT'Cons)
       apply(rule 3)
      apply(rule HT'Cons)
       apply(rule 4)
      apply(rule HT'Cons)
       apply(rule 5)
      apply(rule HT'Cons)
       apply(rule 6)
      apply(rule HT'Cons)
       apply(rule 7)
      apply(rule HT'Cons)
       apply(rule 8)
      apply(rule HT'Cons)
       apply(rule 9)
      apply(rule HT'Cons)
       apply(rule 10)

    proof(rule_tac HT'Conseq[OF HxWhileC, where P' = Inv])
      show "(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn, 'x) state)) = pcomps [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]"
        using sem_final_def by simp
    next
      show "lift_map_t_s imp_trans imp_sem_lifting_gen imp_toggle imp_ctl_sem = lift_map_t_s imp_trans imp_sem_lifting_gen imp_toggle imp_ctl_sem"
        unfolding imp_sem_lifting_spec_def
        by simp
    next
      show "imp_toggle (Si SwhileC) = True"
        by simp
    next
      show "sups_pres (set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l])
     (\<lambda>_. ok_S)"
        by(rule sups_pres_finite_all; auto)
    next
      show "imp_sem_l \<in> set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]"
        by simp
    next
      show "lift_map_t_s imp_trans imp_sem_lifting_gen imp_toggle
      imp_ctl_sem \<downharpoonleft> set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l,
                        seq_sem_l] {Si SwhileC}"
      proof(rule dominant_syn_subset)
        show "lift_map_t_s imp_trans imp_sem_lifting_gen imp_toggle
         imp_ctl_sem \<downharpoonleft> set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l,
                            seq_sem_l] {x. imp_toggle x = True}"
          using imp_dom_all unfolding imp_sem_l_def imp_sem_lifting_spec_def sems_def
          by auto
      next
        show "{Si SwhileC} \<subseteq> {x. imp_toggle x = True}"
          by simp
      qed
    next
      show "imp_trans (Si SwhileC) = SwhileC" by simp
    next
(*      show "\<And> st . (Inv) st \<Longrightarrow> get_cond st \<noteq> None" *)
      show "|sem_final| {~(\<lambda>st. Inv st \<and>
                         get_cond st =
                         Some
                          True)~} [G (Ss Sseq)
                                    [G (Sm (Sread STR ''arg1'' Reg_a)) [],
                                     G (Sm (Sread STR ''acc'' Reg_b)) [], G (Sc Cadd) [],
                                     G (Sm (Swrite STR ''acc'' Reg_c)) [],
                                     G (Sm (Sread STR ''arg2'' Reg_a)) [],
                                     G (Sm (Sread STR ''one'' Reg_b)) [], G (Sc Csub) [],
                                     G (Sm (Swrite STR ''arg2'' Reg_c)) [],
                                     G (Sm (Sread STR ''arg2'' Reg_c)) [],
                                     G (Sb Sgtz) []]] {~Inv~}"
      proof(rule HxSeq)
        show "(sem_final :: (syn \<Rightarrow> (syn, ('x :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> (syn,'x) state)) = pcomps [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]"
          using sem_final_def by simp
      next
        show "seq_sem_l_gen seq_trans = seq_sem_l_gen seq_trans"
          by simp
      next
        show "sups_pres (set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]) (\<lambda>_. ok_S)"
          by(rule sups_pres_finite_all; auto)
      next
        show "seq_sem_l \<in> set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]"
          by auto
      next
        show "seq_sem_l_gen
         seq_trans \<downharpoonleft> set [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l] {Ss Sseq}"
          using seq_dom unfolding sems_def seq_sem_l_def
          by(auto)
      next
        show "seq_trans (Ss Sseq) = Sseq"
          by auto
      next
        show "|sem_final| {~(\<lambda>st. Inv st \<and>
                             get_cond st =
                             Some
                              True)~} [G (Sm (Sread STR ''arg1'' Reg_a)) [],
                                       G (Sm (Sread STR ''acc'' Reg_b)) [], G (Sc Cadd) [],
                                       G (Sm (Swrite STR ''acc'' Reg_c)) [],
                                       G (Sm (Sread STR ''arg2'' Reg_a)) [],
                                       G (Sm (Sread STR ''one'' Reg_b)) [], G (Sc Csub) [],
                                       G (Sm (Swrite STR ''arg2'' Reg_c)) [],
                                       G (Sm (Sread STR ''arg2'' Reg_c)) [],
                                       G (Sb Sgtz) []] {~Inv~}"
          apply(rule HT'Cons[of _ _ _ ?B1])
           apply(rule HT'Conseq[where Q' = ?B1])
             apply(rule Body1)

            apply(case_tac st; clarsimp)
            apply(case_tac ae; clarsimp)
            apply(case_tac x2; clarsimp)
             apply(simp add: get_cond_def)
          apply(case_tac a; clarsimp)
            apply(simp add: get_cond_def )

          apply(fastforce)

          apply(rule HT'Cons)
           apply(rule Body2)
          apply(rule HT'Cons)
            apply(rule Body3)
          apply(rule HT'Cons)
          apply(rule Body4)
          apply(rule HT'Cons)
          apply(rule Body5)
          apply(rule HT'Cons)
          apply(rule Body6)
          apply(rule HT'Cons)
          apply(rule Body7)
          apply(rule HT'Cons)
          apply(rule Body8)
          apply(rule HT'Cons)
          apply(rule Body9)
          apply(rule HT'Cons)
          apply(rule Body10)
          apply(rule HT'Nil)
          done
      qed
    next
      fix st
      assume "Inv st"
      then show "get_cond st \<noteq> None"
        unfolding Inv_def
        by(auto simp add: get_cond_def
          ok_S_defs
           split: md_prio.splits option.splits md_triv.splits)
    next
      fix p p' x rest
      assume "Inv (mdp p x, rest)"
      then show "Inv (mdp p' x, rest)"
        apply(simp add: Inv_def)
        apply(auto split: prod.splits md_prio.splits option.splits md_triv.splits)

         apply(simp add: Inv_def ok_S_defs split: md_prio.splits option.splits md_triv.splits)

        apply(rule_tac x = idx in exI)
        apply(drule_tac x = p in spec)
        apply(clarsimp)
        apply(drule_tac x = x2 in spec)
        apply(case_tac x2)
         apply(clarsimp)
         apply(fastforce simp add: Inv_def ok_S_defs split: md_prio.splits option.splits md_triv.splits)

        apply(clarsimp)
        apply(case_tac x2a)
        apply(clarsimp)
        done
    next
      fix st
      show "st \<in> ok_S \<and>
          (case st of (reg_flag, reg_c, reg_a, reg_b, mdp p None, xz) \<Rightarrow> False
           | (reg_flag, reg_c, reg_a, reg_b, mdp p (Some (mdt m')), xz) \<Rightarrow>
               get m' STR ''arg1'' = Some i1 \<and>
               get m' STR ''arg2'' = Some i2 \<and>
               get m' STR ''one'' = Some 1 \<and>
               get m' STR ''acc'' = Some 0 \<and>
               (case reg_flag of mdp p None \<Rightarrow> False
                | mdp p (Some (mdt reg_flag')) \<Rightarrow> reg_flag' = 0 \<and> i2 \<le> 0 \<or> reg_flag' = 1 \<and> 0 < i2)) \<Longrightarrow>
          Inv st"
        unfolding Inv_def
        using Hi1 Hi2
        by(cases st; auto split: md_prio.splits option.splits md_triv.splits)
    next
      fix st
      assume "Inv st \<and> get_cond st = Some False"

      hence Fin : "Inv st" "get_cond st = Some False"
        by auto

      have Ok : "st \<in> ok_S"
        using Fin(1)
        by(auto simp add: Inv_def)

      show "st \<in> ok_S \<and>
          (case st of (reg_flag, reg_c, reg_a, reg_b, mdp p None, xz) \<Rightarrow> False
           | (reg_flag, reg_c, reg_a, reg_b, mdp p (Some (mdt mem')), xz) \<Rightarrow>
               get mem' STR ''acc'' = Some (i1 * i2))"
        using Conclusion[OF Fin(1) Fin(2)] Ok
        by auto
    qed
  qed
qed
end


(*
 * Copyright 2014, NICTA
 *
 * 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_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Sep_Attribs
imports Separation_Algebra Sep_Tactic_Helpers
begin

text{* Beyond the tactics above, there is also a set of attributes implemented to make proving
       things in separation logic easier. These rules should be considered internals and are not
       intended for direct use. *}

lemma sep_curry_atomised: "\<lbrakk>(\<And>s. (P \<and>* Q) s \<longrightarrow> R s); P s \<rbrakk> \<Longrightarrow> (Q \<longrightarrow>* R) s"
  by (clarsimp simp: sep_conj_sep_impl)

lemma sep_remove_pure_imp_sep_imp: "( P \<longrightarrow>* (\<lambda>s. P' \<longrightarrow> Q s)) s \<Longrightarrow> P' \<Longrightarrow> (P \<longrightarrow>* Q) s"
  by (clarsimp)

lemma sep_backward: "\<lbrakk>\<And>s. P s \<longrightarrow> (Q \<and>* T) s; (P \<and>* (Q \<longrightarrow>* R)) s \<rbrakk> \<Longrightarrow> (T \<and>* R) s"
  by (metis sep_conj_commute sep_conj_impl1 sep_mp_frame)

lemma sep_remove_conj: "\<lbrakk>(P \<and>* R) s ; Q\<rbrakk> \<Longrightarrow> ((\<lambda>s. P s \<and> Q) \<and>* R) s "
  apply (clarsimp)
  done

lemma curry: "(P \<longrightarrow> Q \<longrightarrow> R) \<Longrightarrow> (P \<and> Q) \<longrightarrow> R"
  apply (safe)
  done

ML {*
local
  fun atomize_thm ctxt thm = Conv.fconv_rule (Object_Logic.atomize ctxt) thm
  fun setup_simpset ctxt = put_simpset HOL_basic_ss ctxt addsimps [(sym OF [@{thm sep_conj_assoc}])]
  fun simp ctxt thm = simplify (setup_simpset ctxt) thm

  fun REPEAT_TRYOF_N _ thm2 0 = thm2
    | REPEAT_TRYOF_N thm1 thm2 n = REPEAT_TRYOF_N thm1 (thm1 OF [thm2]) (n-1)

  fun REPEAT_TRYOF'_N thm1 _    0 = thm1
    | REPEAT_TRYOF'_N thm1 thm2 n = REPEAT_TRYOF'_N (thm1 OF [thm2]) thm2 (n-1)

  fun attribute_thm ctxt thm  thm' =
    REPEAT_TRYOF_N @{thm sep_remove_pure_imp_sep_imp} (thm OF [atomize_thm ctxt thm']) (Thm.nprems_of thm' - 1)

  fun attribute_thm' thm ctxt thm' =
    thm OF [REPEAT_TRYOF_N @{thm curry} (thm' |> atomize_thm ctxt o simp ctxt) (Thm.nprems_of thm' - 1)]

in

(*
 By attributing a theorem with [sep_curry], we can now take a rule (A \<and>* B) \<Longrightarrow> C and turn it into A \<Longrightarrow> (B \<longrightarrow>* C)
*)

fun sep_curry_inner ctxt = attribute_thm ( ctxt) @{thm sep_curry_atomised}
val sep_curry = Thm.rule_attribute [] (fn ctxt => sep_curry_inner (Context.proof_of ctxt))

(*
 The attribute sep_back takes a rule of the form A \<Longrightarrow> B and returns a rule (A \<and>* (B \<longrightarrow>* R)) \<Longrightarrow> R.
 The R then matches with any conclusion. If the theorem is of form (A \<and>* B) \<Longrightarrow> C, it is advised to
 use sep_curry on the theorem first, and then sep_back. This aids sep_cancel in simplifying the result.
*)

fun backward ctxt thm =
  REPEAT_TRYOF'_N (attribute_thm' @{thm sep_backward} ctxt thm) @{thm sep_remove_conj} (Thm.nprems_of thm - 1)

fun backward' ctxt thm = backward (Context.proof_of ctxt) thm

val sep_backward = Thm.rule_attribute [] (backward')

end
*}

attribute_setup sep_curry =  {* Scan.succeed sep_curry *}
attribute_setup sep_backward =  {* Scan.succeed sep_backward *}

end


section \<open>Operation Identification Phase\<close>
theory Sepref_Id_Op
imports
  Main
  Automatic_Refinement.Refine_Lib
  Automatic_Refinement.Autoref_Tagging
  "Refine_Imperative_HOL.Named_Theorems_Rev"
begin

text \<open>
  The operation identification phase is adapted from the Autoref tool.
  The basic idea is to have a type system, which works on so called
  interface types (also called conceptual types). Each conceptual type
  denotes an abstract data type, e.g., set, map, priority queue.

  Each abstract operation, which must be a constant applied to its arguments,
  is assigned a conceptual type. Additionally, there is a set of
  {\emph pattern rewrite rules},
  which are applied to subterms before type inference takes place, and
  which may be backtracked over.
  This way, encodings of abstract operations in Isabelle/HOL, like
  @{term [source] "\<lambda>_. None"} for the empty map,
  or @{term [source] "fun_upd m k (Some v)"} for map update, can be rewritten
  to abstract operations, and get properly typed.
\<close>

subsection "Proper Protection of Term"
text \<open> The following constants are meant to encode abstraction and
  application as proper HOL-constants, and thus avoid strange effects with
  HOL's higher-order unification heuristics and automatic
  beta and eta-contraction.

  The first step of operation identification is to protect the term
  by replacing all function applications and abstractions be
  the constants defined below.
\<close>

definition [simp]: "PROTECT2 x (y::prop) \<equiv> x"
consts DUMMY :: "prop"

abbreviation PROTECT2_syn ("'(#_#')") where "PROTECT2_syn t \<equiv> PROTECT2 t DUMMY"

abbreviation (input)ABS2 :: "('a\<Rightarrow>'b)\<Rightarrow>'a\<Rightarrow>'b" (binder "\<lambda>\<^sub>2" 10)
  where "ABS2 f \<equiv> (\<lambda>x. PROTECT2 (f x) DUMMY)"

lemma beta: "(\<lambda>\<^sub>2x. f x)$x \<equiv> f x" by simp

text \<open>
  Another version of @{const "APP"}. Treated like @{const APP} by our tool.
  Required to avoid infinite pattern rewriting in some cases, e.g., map-lookup.
\<close>

definition APP' (infixl "$''" 900) where [simp, autoref_tag_defs]: "f$'a \<equiv> f a"

text \<open>
  Sometimes, whole terms should be protected from being processed by our tool.
  For example, our tool should not look into numerals. For this reason,
  the @{text "PR_CONST"} tag indicates terms that our tool shall handle as
  atomic constants, an never look into them.

  The special form @{text "UNPROTECT"} can be used inside pattern rewrite rules.
  It has the effect to revert the protection from its argument, and then wrap
  it into a @{text "PR_CONST"}.
\<close>
definition [simp, autoref_tag_defs]: "PR_CONST x \<equiv> x" \<comment> \<open>Tag to protect constant\<close>
definition [simp, autoref_tag_defs]: "UNPROTECT x \<equiv> x" \<comment> \<open>Gets
  converted to @{term PR_CONST}, after unprotecting its content\<close>

subsection {* Operation Identification *}

text \<open> Indicator predicate for conceptual typing of a constant \<close>
definition intf_type :: "'a \<Rightarrow> 'b itself \<Rightarrow> bool" (infix "::\<^sub>i" 10) where
  [simp]: "c::\<^sub>iI \<equiv> True"

lemma itypeI: "c::\<^sub>iI" by simp
lemma itypeI': "intf_type c TYPE('T)" by (rule itypeI)

lemma itype_self: "(c::'a) ::\<^sub>i TYPE('a)" by simp

definition CTYPE_ANNOT :: "'b \<Rightarrow> 'a itself \<Rightarrow> 'b" (infix ":::\<^sub>i" 10) where
  [simp]: "c:::\<^sub>iI \<equiv> c"

text \<open> Wrapper predicate for an conceptual type inference \<close>
definition ID :: "'a \<Rightarrow> 'a \<Rightarrow> 'c itself \<Rightarrow> bool"
  where [simp]: "ID t t' T \<equiv> t=t'"

subsubsection {* Conceptual Typing Rules *}

lemma ID_unfold_vars: "ID x y T \<Longrightarrow> x\<equiv>y" by simp
lemma ID_PR_CONST_trigger: "ID (PR_CONST x) y T \<Longrightarrow> ID (PR_CONST x) y T" .

lemma pat_rule:
  "\<lbrakk> p\<equiv>p'; ID p' t' T \<rbrakk> \<Longrightarrow> ID p t' T" by simp

lemma app_rule:
  "\<lbrakk> ID f f' TYPE('a\<Rightarrow>'b); ID x x' TYPE('a)\<rbrakk> \<Longrightarrow> ID (f$x) (f'$x') TYPE('b)"
  by simp

lemma app'_rule:
  "\<lbrakk> ID f f' TYPE('a\<Rightarrow>'b); ID x x' TYPE('a)\<rbrakk> \<Longrightarrow> ID (f$'x) (f'$x') TYPE('b)"
  by simp

lemma abs_rule:
  "\<lbrakk> \<And>x x'. ID x x' TYPE('a) \<Longrightarrow> ID (t x) (t' x x') TYPE('b) \<rbrakk> \<Longrightarrow>
    ID (\<lambda>\<^sub>2x. t x) (\<lambda>\<^sub>2x'. t' x' x') TYPE('a\<Rightarrow>'b)"
  by simp

lemma id_rule: "c::\<^sub>iI \<Longrightarrow> ID c c I" by simp

lemma annot_rule: "ID t t' I \<Longrightarrow> ID (t:::\<^sub>iI) t' I"
  by simp

lemma fallback_rule:
  "ID (c::'a) c TYPE('c)"
  by simp

lemma unprotect_rl1: "ID (PR_CONST x) t T \<Longrightarrow> ID (UNPROTECT x) t T"
  by simp

subsection \<open> ML-Level code \<close>
ML \<open>
infix 0 THEN_ELSE_COMB'

signature ID_OP_TACTICAL = sig
  val SOLVE_FWD: tactic' -> tactic'
  val DF_SOLVE_FWD: bool -> tactic' -> tactic'
end

structure Id_Op_Tactical :ID_OP_TACTICAL = struct

  fun SOLVE_FWD tac i st = SOLVED' (
    tac
    THEN_ALL_NEW_FWD (SOLVE_FWD tac)) i st

  (* Search for solution with DFS-strategy. If dbg-flag is given,
    return sequence of stuck states if no solution is found.
  *)
  fun DF_SOLVE_FWD dbg tac = let
    val stuck_list_ref = Unsynchronized.ref []

    fun stuck_tac _ st = if dbg then (
      stuck_list_ref := st :: !stuck_list_ref;
      Seq.empty
    ) else Seq.empty

    fun rec_tac i st = (
        (tac THEN_ALL_NEW_FWD (SOLVED' rec_tac))
        ORELSE' stuck_tac
      ) i st

    fun fail_tac _ _ = if dbg then
      Seq.of_list (rev (!stuck_list_ref))
    else Seq.empty
  in
    rec_tac ORELSE' fail_tac
  end

end
\<close>

named_theorems_rev id_rules "Operation identification rules"
named_theorems_rev pat_rules "Operation pattern rules"
named_theorems_rev def_pat_rules "Definite operation pattern rules (not backtracked over)"

ML \<open>

  structure Id_Op = struct

    fun id_a_conv cnv ct = case Thm.term_of ct of
      @{mpat "ID _ _ _"} => Conv.fun_conv (Conv.fun_conv (Conv.arg_conv cnv)) ct
    | _ => raise CTERM("id_a_conv",[ct])

    fun
      protect env (@{mpat "?t:::\<^sub>i?I"}) = let
        val t = protect env t
      in
        @{mk_term env: "?t:::\<^sub>i?I"}
      end
    | protect _ (t as @{mpat "PR_CONST _"}) = t
    | protect env (t1$t2) = let
        val t1 = protect env t1
        val t2 = protect env t2
      in
        @{mk_term env: "?t1.0 $ ?t2.0"}
      end
    | protect env (Abs (x,T,t)) = let
        val env' = T::env
        val t = protect env' t
        val t = @{mk_term env': "PROTECT2 ?t DUMMY"}
      in
        Abs (x,T,t)
      end
    (* TODO: Avoiding mk_term with loose vars under \<lambda>! Fix that!
    | protect env (Abs (x,T,t)) = let
        val t = protect (T::env) t
      in
        @{mk_term env: "\<lambda>v_x::?'v_T. PROTECT2 ?t DUMMY"}
      end
    *)
    | protect _ t = t

    fun protect_conv ctxt = Refine_Util.f_tac_conv ctxt
      (protect [])
      (simp_tac
        (put_simpset HOL_basic_ss ctxt addsimps @{thms PROTECT2_def APP_def}) 1)

    fun unprotect_conv ctxt
      = Simplifier.rewrite (put_simpset HOL_basic_ss ctxt
        addsimps @{thms PROTECT2_def APP_def})

    fun do_unprotect_tac ctxt =
      resolve_tac ctxt @{thms unprotect_rl1} THEN'
      CONVERSION (Refine_Util.HOL_concl_conv (fn ctxt => id_a_conv (unprotect_conv ctxt)) ctxt)

    val cfg_id_debug =
      Attrib.setup_config_bool @{binding id_debug} (K false)

    val cfg_id_trace_fallback =
      Attrib.setup_config_bool @{binding id_trace_fallback} (K false)

    fun dest_id_rl thm = case Thm.concl_of thm of
      @{mpat (typs) "Trueprop (?c::\<^sub>iTYPE(?'v_T))"} => (c,T)
    | _ => raise THM("dest_id_rl",~1,[thm])

    val add_id_rule = snd oo Thm.proof_attributes [Named_Theorems_Rev.add @{named_theorems_rev id_rules}]

    datatype id_tac_mode = Init | Step | Normal | Solve

    fun id_tac ss ctxt = let
      open Id_Op_Tactical
      val certT = Thm.ctyp_of ctxt
      val cert = Thm.cterm_of ctxt

      val thy = Proof_Context.theory_of ctxt

      val id_rules = Named_Theorems_Rev.get ctxt @{named_theorems_rev id_rules}
      val pat_rules = Named_Theorems_Rev.get ctxt @{named_theorems_rev pat_rules}
      val def_pat_rules = Named_Theorems_Rev.get ctxt @{named_theorems_rev def_pat_rules}

      val rl_net = Tactic.build_net (
        (pat_rules |> map (fn thm => thm RS @{thm pat_rule}))
        @ @{thms annot_rule app_rule app'_rule abs_rule}
        @ (id_rules |> map (fn thm => thm RS @{thm id_rule}))
      )

      val def_rl_net = Tactic.build_net (
        (def_pat_rules |> map (fn thm => thm RS @{thm pat_rule}))
      )

      val id_pr_const_rename_tac =
          resolve_tac ctxt @{thms ID_PR_CONST_trigger} THEN'
          Subgoal.FOCUS (fn { context=ctxt, prems, ... } =>
            let
              fun is_ID @{mpat "Trueprop (ID _ _ _)"} = true | is_ID _ = false
              val prems = filter (Thm.prop_of #> is_ID) prems
              val eqs = map (fn thm => thm RS @{thm ID_unfold_vars}) prems
              val conv = Conv.rewrs_conv eqs
              val conv = fn ctxt => (Conv.top_sweep_conv (K conv) ctxt)
              val conv = fn ctxt => Conv.fun2_conv (Conv.arg_conv (conv ctxt))
              val conv = Refine_Util.HOL_concl_conv conv ctxt
            in CONVERSION conv 1 end
          ) ctxt THEN'
          resolve_tac ctxt @{thms id_rule} THEN'
          resolve_tac ctxt id_rules

      val ityping = id_rules
        |> map dest_id_rl
        |> filter (is_Const o #1)
        |> map (apfst (#1 o dest_Const))
        |> Symtab.make_list

      val has_type = Symtab.defined ityping

      fun mk_fallback name cT =
        case try (Sign.the_const_constraint thy) name of
          SOME T => try (Thm.instantiate'
                          [SOME (certT cT), SOME (certT T)] [SOME (cert (Const (name,cT)))])
                        @{thm fallback_rule}
        | NONE => NONE

      fun trace_fallback thm =
        Config.get ctxt cfg_id_trace_fallback
        andalso let
          open Pretty
          val p = block [str "ID_OP: Applying fallback rule: ", Thm.pretty_thm ctxt thm]
        in
          string_of p |> tracing;
          false
        end

      val fallback_tac = CONVERSION Thm.eta_conversion THEN' IF_EXGOAL (fn i => fn st =>
        case Logic.concl_of_goal (Thm.prop_of st) i of
          @{mpat "Trueprop (ID (mpaq_STRUCT (mpaq_Const ?name ?cT)) _ _)"} => (
            if not (has_type name) then
              case mk_fallback name cT of
                SOME thm => (trace_fallback thm; resolve_tac ctxt [thm] i st)
              | NONE => Seq.empty
            else Seq.empty
          )
        | _ => Seq.empty)

      val init_tac = CONVERSION (
        Refine_Util.HOL_concl_conv (fn ctxt => (id_a_conv (protect_conv ctxt)))
          ctxt
      )

      val step_tac = (FIRST' [
        assume_tac ctxt,
        eresolve_tac ctxt @{thms id_rule},
        resolve_from_net_tac ctxt def_rl_net,
        resolve_from_net_tac ctxt rl_net,
        id_pr_const_rename_tac,
        do_unprotect_tac ctxt,
        fallback_tac])

      val solve_tac = DF_SOLVE_FWD (Config.get ctxt cfg_id_debug) step_tac

    in
      case ss of
        Init => init_tac
      | Step => step_tac
      | Normal => init_tac THEN' solve_tac
      | Solve => solve_tac

    end

  end

\<close>

subsection \<open>Default Setup\<close>

subsubsection \<open>Numerals\<close>
(* TODO: Either remove, or also add numerals 0 and 1! *)
lemma pat_numeral[def_pat_rules]: "numeral$x \<equiv> UNPROTECT (numeral$x)" by simp

lemma id_nat_const[id_rules]: "(PR_CONST (a::nat)) ::\<^sub>i TYPE(nat)" by simp
lemma id_int_const[id_rules]: "(PR_CONST (a::int)) ::\<^sub>i TYPE(int)" by simp

(*subsection \<open>Example\<close>
schematic_lemma
  "ID (\<lambda>a b. (b(1::int\<mapsto>2::nat) |`(-{3})) a, Map.empty, \<lambda>a. case a of None \<Rightarrow> Some a | Some _ \<Rightarrow> None) (?c) (?T::?'d itself)"
  (*"TERM (?c,?T)"*)
  using [[id_debug]]
  apply (tactic {* Id_Op.id_tac Id_Op.Normal @{context} 1  *})
  done
*)

end


(*  Title:      JinjaThreads/J/WWellForm.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section \<open>Weak well-formedness of Jinja programs\<close>

theory WWellForm
imports
  "../Common/WellForm"
  Expr
begin

definition
  wwf_J_mdecl :: "'addr J_prog \<Rightarrow> cname \<Rightarrow> 'addr J_mb mdecl \<Rightarrow> bool"
where
  "wwf_J_mdecl P C  \<equiv>  \<lambda>(M,Ts,T,(pns,body)).
  length Ts = length pns \<and> distinct pns \<and> this \<notin> set pns \<and> fv body \<subseteq> {this} \<union> set pns"

lemma wwf_J_mdecl[simp]:
  "wwf_J_mdecl P C (M,Ts,T,pns,body) =
  (length Ts = length pns \<and> distinct pns \<and> this \<notin> set pns \<and> fv body \<subseteq> {this} \<union> set pns)"
(*<*)by(simp add:wwf_J_mdecl_def)(*>*)

abbreviation wwf_J_prog :: "'addr J_prog \<Rightarrow> bool"
where "wwf_J_prog == wf_prog wwf_J_mdecl"

end


section\<open>The Axiom of Infinity in $M[G]$\<close>
theory Infinity_Axiom
  imports Pairing_Axiom Union_Axiom Separation_Axiom
begin

context G_generic begin

interpretation mg_triv: M_trivial"##M[G]"
  using transitivity_MG zero_in_MG generic Union_MG pairing_in_MG
  by unfold_locales auto

lemma infinity_in_MG : "infinity_ax(##M[G])"
proof -
  from infinity_ax obtain I where
    Eq1: "I\<in>M" "0 \<in> I" "\<forall>y\<in>M. y \<in> I \<longrightarrow> succ(y) \<in> I"
    unfolding infinity_ax_def  by auto
  then
  have "check(I) \<in> M"
    using check_in_M by simp
  then
  have "I\<in> M[G]"
    using valcheck generic one_in_G one_in_P GenExtI[of "check(I)" G] by simp
  with \<open>0\<in>I\<close>
  have "0\<in>M[G]" using transitivity_MG by simp
  with \<open>I\<in>M\<close>
  have "y \<in> M" if "y \<in> I" for y
    using  transitivity[OF _ \<open>I\<in>M\<close>] that by simp
  with \<open>I\<in>M[G]\<close>
  have "succ(y) \<in> I \<inter> M[G]" if "y \<in> I" for y
    using that Eq1 transitivity_MG by blast
  with Eq1 \<open>I\<in>M[G]\<close> \<open>0\<in>M[G]\<close>
  show ?thesis
    unfolding infinity_ax_def by auto
qed

end (* G_generic' *)
end


theory DP_CRelVS_Ext
  imports "transform/Transform_Cmd"
begin

notation fun_app_lifted (infixl "." 999)
notation Transfer.Rel ("Rel")

thm map_cong
lemma mapT_cong:
  assumes "xs = ys" "\<And>x. x\<in>set ys \<Longrightarrow> f x = g x"
  shows "map\<^sub>T . \<langle>f\<rangle> . \<langle>xs\<rangle> = map\<^sub>T . \<langle>g\<rangle> . \<langle>ys\<rangle>"
  unfolding map\<^sub>T_def
  unfolding assms(1)
  using assms(2) by (induction ys) (auto simp: return_app_return)

thm fold_cong
lemma foldT_cong:
  assumes "xs = ys" "\<And>x. x\<in>set ys \<Longrightarrow> f x = g x"
  shows "fold\<^sub>T . \<langle>f\<rangle> . \<langle>xs\<rangle> = fold\<^sub>T . \<langle>g\<rangle> . \<langle>ys\<rangle>"
  unfolding fold\<^sub>T_def
  unfolding assms(1)
  using assms(2) by (induction ys) (auto simp: return_app_return)

lemma abs_unit_cong:
  (* for lazy checkmem *)
  assumes "x = y"
  shows "(\<lambda>_::unit. x) = (\<lambda>_. y)"
  using assms ..

lemma App_cong:
  assumes "f x = g y"
  shows "App f x = App g y"
  unfolding App_def using assms .

lemmas [fundef_cong] =
  return_app_return_cong
  ifT_cong
  mapT_cong
  foldT_cong
  abs_unit_cong
  App_cong

context dp_consistency begin
context includes lifting_syntax begin

named_theorems dp_match_rule

lemma refl2:
  "is_equality R \<Longrightarrow> Rel R x x"
  unfolding is_equality_def Rel_def by simp

lemma rel_fun2:
  assumes "is_equality R0" "\<And>x. Rel R1 (f x) (g x)"
  shows "Rel (rel_fun R0 R1) f g"
  using assms unfolding is_equality_def Rel_def by auto

thm if_cong
lemma if\<^sub>T_cong2:
  assumes "Rel (=) b c" "c \<Longrightarrow> Rel (crel_vs R) x x\<^sub>T" "\<not>c \<Longrightarrow> Rel (crel_vs R) y y\<^sub>T"
  shows "Rel (crel_vs R) (if (Wrap b) then x else y) (if\<^sub>T \<langle>c\<rangle> x\<^sub>T y\<^sub>T)"
  using assms unfolding if\<^sub>T_def left_identity Rel_def Wrap_def
  by (auto split: if_split)

lemma if\<^sub>T_cong2':
  assumes "c \<Longrightarrow> Rel (crel_vs R) x x\<^sub>T" "\<not>c \<Longrightarrow> Rel (crel_vs R) y y\<^sub>T"
  shows "Rel (crel_vs R) (if Wrap c then x else y) (if\<^sub>T \<langle>c\<rangle> x\<^sub>T y\<^sub>T)"
  apply (rule if\<^sub>T_cong2[OF _ assms])
    apply (auto simp: Rel_def)
  done

(*

thm map_cong
lemma map1T_cong:
  assumes "xs = ys" "\<And>x. x\<in>set ys \<Longrightarrow> f\<^sub>T . \<langle>x\<rangle> = g\<^sub>T . \<langle>x\<rangle>"
  shows "map1\<^sub>T . f\<^sub>T . \<langle>xs\<rangle> = map1\<^sub>T . g\<^sub>T . \<langle>ys\<rangle>"
  unfolding map1\<^sub>T_def
  unfolding assms(1)
  using assms(2) apply (induction ys) apply (auto simp: return_app_return)
  subgoal
    apply (rule state.expand)
    apply (rule ext)
    unfolding fun_app_lifted_def
    unfolding bind_def return_def
    apply (auto split: prod.splits)
*)
lemma map\<^sub>T_transfer2:
  "Rel (crel_vs ((R0 ===>\<^sub>T R1) ===>\<^sub>T list_all2 R0 ===>\<^sub>T list_all2 R1)) map map\<^sub>T"
  unfolding Rel_def by (fact map\<^sub>T_transfer)

lemma map\<^sub>T_cong2:
  assumes
    "is_equality R"
    "Rel R xs ys"
    "\<And>x. x\<in>set ys \<Longrightarrow> Rel (crel_vs S) (f x) (f\<^sub>T' x)"
  shows "Rel (crel_vs (list_all2 S)) (App (App map (Wrap f)) (Wrap xs)) (map\<^sub>T . \<langle>f\<^sub>T'\<rangle> . \<langle>ys\<rangle>)"
  unfolding map\<^sub>T_def
  unfolding return_app_return
  unfolding assms(2)[unfolded Rel_def assms(1)[unfolded is_equality_def]]
  using assms(3)
  unfolding Rel_def Wrap_def App_def
  apply (induction ys)
  apply (tactic \<open>Transform_Tactic.unfold_dp_defs_tac @{context} true true 1\<close>)
  subgoal premises by transfer_prover
  subgoal premises prems for a ys
    apply (tactic \<open>Transform_Tactic.unfold_dp_defs_tac @{context} true true 1\<close>)
    apply (unfold return_app_return Wrap_App_Wrap)
    supply [transfer_rule] =
      prems(2)[OF list.set_intros(1)]
      prems(1)[OF prems(2)[OF list.set_intros(2)], simplified]
    by transfer_prover
  done

lemma map\<^sub>T_cong2':
  assumes
    "\<And>x. x\<in>set xs \<Longrightarrow> Rel (crel_vs S) (f x) (f\<^sub>T' x)"
  shows "Rel (crel_vs (list_all2 S)) (map f xs) (map\<^sub>T . \<langle>f\<^sub>T'\<rangle> . \<langle>xs\<rangle>)"
  apply (rule map\<^sub>T_cong2[OF is_equality_eq _ assms, unfolded Wrap_def App_def])
   apply (auto simp: Rel_def)
  done

lemma fold\<^sub>T_transfer2:
  "Rel (crel_vs ((R0 ===>\<^sub>T R1 ===>\<^sub>T R1) ===>\<^sub>T list_all2 R0 ===>\<^sub>T R1 ===>\<^sub>T R1)) fold fold\<^sub>T"
  unfolding Rel_def by (fact fold\<^sub>T_transfer)

lemma fold\<^sub>T_cong2:
  assumes
    "is_equality R"
    "Rel R xs ys"
    "\<And>x. x\<in>set ys \<Longrightarrow> Rel (crel_vs (S ===> crel_vs S)) (f x) (f\<^sub>T' x)"
  shows
    "Rel (crel_vs (S ===> crel_vs S)) (fold f xs) (fold\<^sub>T . \<langle>f\<^sub>T'\<rangle> . \<langle>ys\<rangle>)"
  unfolding fold\<^sub>T_def
  unfolding return_app_return
  unfolding assms(2)[unfolded Rel_def assms(1)[unfolded is_equality_def]]
  using assms(3)
  unfolding Rel_def
  apply (induction ys)
  apply (tactic \<open>Transform_Tactic.unfold_dp_defs_tac @{context} true true 1\<close>)
  subgoal premises by transfer_prover
  subgoal premises prems for a ys
    apply (tactic \<open>Transform_Tactic.unfold_dp_defs_tac @{context} true true 1\<close>)
    apply (unfold return_app_return Wrap_App_Wrap)
    supply [transfer_rule] =
      prems(2)[OF list.set_intros(1)]
      prems(1)[OF prems(2)[OF list.set_intros(2)], simplified]
    by transfer_prover
  done

thm BNF_Fixpoint_Base.case_prod_transfer
lemma prod_case_transfer2:
  assumes
    "Rel (R0 ===> R1 ===> crel_vs S) f g"
  shows "Rel (rel_prod R0 R1 ===> crel_vs S) (case_prod f) (case_prod g)"
  supply [transfer_rule] = assms[unfolded Rel_def]
  unfolding Rel_def by transfer_prover

lemma prod_case_cong2:
  assumes
    "is_equality R"
    "Rel R x y"
    "\<And>u v. y = (u, v) \<Longrightarrow> Rel (crel_vs S) (f u v) (g u v)"
  shows "Rel (crel_vs S) (case_prod f x) (\<langle>case_prod g\<rangle> . \<langle>y\<rangle>)"
  unfolding return_app_return
  using assms by (auto simp: is_equality_def Rel_def split: prod.split)

thm option.case_transfer
lemma option_case_transfer2:
  assumes
    "Rel (crel_vs S) f0 g0"
    "Rel (R ===> crel_vs S) f1 g1"
  shows "Rel (rel_option R ===> crel_vs S) (case_option f0 f1) (case_option g0 g1)"
  supply [transfer_rule] = assms[unfolded Rel_def]
  unfolding Rel_def by transfer_prover

thm option.case_cong
lemma option_case_cong2:
  assumes
    "is_equality R"
    "Rel R x y"
    "y = None \<Longrightarrow> Rel (crel_vs S) f0 g0"
    "\<And>x2. y = Some x2 \<Longrightarrow> Rel (crel_vs S) (f1 x2) (g1 x2)"
  shows "Rel (crel_vs S) (case_option f0 f1 x) (\<langle>case_option g0 g1\<rangle> . \<langle>y\<rangle>)"
  unfolding return_app_return
  using assms by (auto simp: is_equality_def Rel_def split: option.split)

thm list.case_transfer
lemma list_case_transfer2:
  assumes
    "Rel (crel_vs S) f0 g0"
    "Rel (R ===> list_all2 R ===> crel_vs S) f1 g1"
  shows "Rel (list_all2 R ===> crel_vs S) (case_list f0 f1) (case_list g0 g1)"
  supply [transfer_rule] = assms[unfolded Rel_def]
  unfolding Rel_def by transfer_prover

thm list.case_cong
lemma list_case_cong2:
  assumes
    "is_equality R"
    "Rel R x y"
    "x = Nil \<Longrightarrow> Rel (crel_vs S) f0 g0"
    "\<And>x2 x2s. x = x2#x2s \<Longrightarrow> Rel (crel_vs S) (f1 x2 x2s) (g1 x2 x2s)"
  shows "Rel (crel_vs S) (case_list f0 f1 x) (\<langle>case_list g0 g1\<rangle> . \<langle>y\<rangle>)"
  unfolding return_app_return
  using assms by (auto simp: is_equality_def Rel_def split: list.split)

lemmas [dp_match_rule] =
  map\<^sub>T_cong2
  fold\<^sub>T_cong2
  if\<^sub>T_cong2

lemmas [dp_match_rule] =
  prod_case_cong2
  prod_case_transfer2
  option_case_cong2
  option_case_transfer2
  list_case_cong2
  list_case_transfer2

lemmas [dp_match_rule] =
  crel_vs_return
  crel_vs_fun_app
  rel_fun2
  refl2

lemmas [dp_match_rule] =
  map\<^sub>T_transfer2
  fold\<^sub>T_transfer2

thm dp_match_rule

end (* lifting_syntax *)
end (* dp_consistency *)

no_notation fun_app_lifted (infixl "." 999)
no_notation Transfer.Rel ("Rel")
end (* theory *)