(*  Title:       A Shorter Compiler Correctness Proof for Language IMP
    Author:      Pasquale Noce
                 Software Engineer at HID Global, Italy
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at hidglobal dot com
*)

section "Compiler correctness"

theory Compiler2
  imports Compiler
begin

subsection "Preliminary definitions and lemmas"

text \<open>
Now everything is ready for the compiler correctness proof. First, two predicates are introduced,
@{text execl} and @{text execl_all}, both taking as inputs a program, i.e. a list of instructions,
@{text P} and a list of program configurations @{text cfs}, and respectively denoted using notations
@{text "P \<Turnstile> cfs"} and @{text "P \<Turnstile> cfs\<box>"}. In more detail:

  \<^item> @{text "P \<Turnstile> cfs"} means that program @{text P} \emph{may} transform each configuration within
@{text cfs} into the subsequent one, if any (word \emph{may} reflects the fact that programs can be
non-deterministic in this case study).
\\Thus, @{text execl} formalizes the notion of a \emph{small-step} program execution.

  \<^item> @{text "P \<Turnstile> cfs\<box>"} reinforces @{text "P \<Turnstile> cfs"} by additionally requiring that @{text cfs} be
nonempty, the initial program counter be zero (viz. execution starts from the first instruction in
@{text P}), and the final program counter falls outside @{text P} (viz. execution terminates).
\\Thus, @{text execl_all} formalizes the notion of a \emph{complete small-step} program execution,
so that assumptions @{text "acomp a \<Turnstile> cfs\<box>"}, @{text "bcomp x \<Turnstile> cfs\<box>"}, @{text "ccomp c \<Turnstile> cfs\<box>"}
will be used in the compiler correctness proofs for arithmetic/boolean expressions and commands.

Moreover, predicates @{text apred}, @{text bpred}, and @{text cpred} are defined to capture the link
between the initial and the final configuration upon the execution of an arithmetic expression, a
boolean expression, and a whole program, respectively, and abbreviation @{text off} is introduced as
a commodity to shorten the subsequent formal text.

\null
\<close>

fun execl :: "instr list \<Rightarrow> config list \<Rightarrow> bool" (infix "\<Turnstile>" 55) where
"P \<Turnstile> cf # cf' # cfs = (P \<turnstile> cf \<rightarrow> cf' \<and> P \<Turnstile> cf' # cfs)" |
"P \<Turnstile> _ = True"

definition execl_all :: "instr list \<Rightarrow> config list \<Rightarrow> bool" ("(_/ \<Turnstile>/ _\<box>)" 55) where
"P \<Turnstile> cfs\<box> \<equiv> P \<Turnstile> cfs \<and> cfs \<noteq> [] \<and>
  fst (cfs ! 0) = 0 \<and> fst (cfs ! (length cfs - 1)) \<notin> {0..<size P}"

definition apred :: "aexp \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" where
"apred \<equiv> \<lambda>a (pc, s, stk) (pc', s', stk').
  pc' = pc + size (acomp a) \<and> s' = s \<and> stk' = aval a s # stk"

definition bpred :: "bexp \<times> bool \<times> int \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" where
"bpred \<equiv> \<lambda>(b, f, i) (pc, s, stk) (pc', s', stk').
  pc' = pc + size (bcomp (b, f, i)) + (if bval b s = f then i else 0) \<and>
    s' = s \<and> stk' = stk"

definition cpred :: "com \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" where
"cpred \<equiv> \<lambda>c (pc, s, stk) (pc', s', stk').
  pc' = pc + size (ccomp c) \<and> (c, s) \<Rightarrow> s' \<and> stk' = stk"

abbreviation off :: "instr list \<Rightarrow> config \<Rightarrow> config" where
"off P cf \<equiv> (fst cf - size P, snd cf)"

text \<open>
\null

Next, some lemmas about @{const [source] execl} and @{const execl_all} are proven. In more detail,
given a program @{text P} and a list of configurations @{text cfs} such that @{prop "P \<Turnstile> cfs"}:

  \<^item> Lemma @{text execl_next} states that for any configuration in @{text cfs} but the last one, the
subsequent configuration must result from the execution of the referenced instruction of @{text P}
in that configuration.
\\Thus, @{text execl_next} permits to reproduce the execution of a single instruction.

  \<^item> Lemma @{text execl_last} states that a configuration in @{text cfs} whose program counter falls
outside @{text P} must be the last one in @{text cfs}.
\\Thus, @{text execl_last} permits to infer the completion of program execution.

  \<^item> Lemma @{text execl_drop} states that @{prop "P \<Turnstile> drop n cfs"} for any natural number @{text n},
and will be used to prove compiler correctness for loops by induction over the length of the list of
configurations @{text cfs}.

Furthermore, some other lemmas enabling to prove compiler correctness automatically for constructors
@{const N}, @{const V} (arithmetic expressions), @{const Bc} (boolean expressions) and @{const SKIP}
(commands) are also proven.

\null
\<close>

lemma iexec_offset_aux:
 "(i :: int) + 1 - j = i - j + 1 \<and> i + j - k + 1 = i - k + j + 1"
by simp

lemma iexec_offset [intro]:
 "(ins, pc, s, stk) \<mapsto> (pc', s', stk') \<Longrightarrow>
    (ins, pc - i, s, stk) \<mapsto> (pc' - i, s', stk')"
by (erule iexec.cases, auto simp: iexec_offset_aux)

lemma execl_next:
 "\<lbrakk>P \<Turnstile> cfs; k < length cfs; k \<noteq> length cfs - 1\<rbrakk> \<Longrightarrow>
    (P !! fst (cfs ! k), cfs ! k) \<mapsto> cfs ! Suc k"
by (induction cfs arbitrary: k rule: execl.induct, auto
 simp: nth_Cons exec1_def split: nat.split)

lemma execl_last:
 "\<lbrakk>P \<Turnstile> cfs; k < length cfs; fst (cfs ! k) \<notin> {0..<size P}\<rbrakk> \<Longrightarrow>
    length cfs - 1 = k"
by (induction cfs arbitrary: k rule: execl.induct, auto
 simp: nth_Cons exec1_def split: nat.split_asm)

lemma execl_drop:
 "P \<Turnstile> cfs \<Longrightarrow> P \<Turnstile> drop n cfs"
by (induction cfs arbitrary: n rule: execl.induct,
 simp_all add: drop_Cons split: nat.split)

lemma execl_all_N [simplified, intro]:
 "[LOADI i] \<Turnstile> cfs\<box> \<Longrightarrow> apred (N i) (cfs ! 0) (cfs ! (length cfs - 1))"
by (clarsimp simp: execl_all_def apred_def, cases "cfs ! 0",
 subgoal_tac "length cfs - 1 = 1", frule_tac [!] execl_next,
 ((rule ccontr)?, fastforce, (rule execl_last)?)+)

lemma execl_all_V [simplified, intro]:
 "[LOAD x] \<Turnstile> cfs\<box> \<Longrightarrow> apred (V x) (cfs ! 0) (cfs ! (length cfs - 1))"
by (clarsimp simp: execl_all_def apred_def, cases "cfs ! 0",
 subgoal_tac "length cfs - 1 = 1", frule_tac [!] execl_next,
 ((rule ccontr)?, fastforce, (rule execl_last)?)+)

lemma execl_all_Bc [simplified, intro]:
 "\<lbrakk>if v = f then [JMP i] else [] \<Turnstile> cfs\<box>; 0 \<le> i\<rbrakk> \<Longrightarrow>
    bpred (Bc v, f, i) (cfs ! 0) (cfs ! (length cfs - 1))"
by (clarsimp simp: execl_all_def bpred_def split: if_split_asm, cases "cfs ! 0",
 subgoal_tac "length cfs - 1 = 1", frule_tac [1-2] execl_next,
 ((rule ccontr)?, force, (rule execl_last)?)+, rule execl.cases [of "([], cfs)"],
 auto simp: exec1_def)

lemma execl_all_SKIP [simplified, intro]:
 "[] \<Turnstile> cfs\<box> \<Longrightarrow> cpred SKIP (cfs ! 0) (cfs ! (length cfs - 1))"
by (rule execl.cases [of "([], cfs)"], auto simp: execl_all_def exec1_def cpred_def)

text \<open>
\null

Next, lemma @{text execl_all_sub} is proven. It states that, if @{prop "P @ P' x @ P'' \<Turnstile> cfs\<box>"},
configuration @{text cf} within @{text cfs} refers to the start of program @{text "P' x"}, and the
initial and the final configuration in every complete execution of @{text "P' x"} satisfy predicate
@{text "Q x"}, then there exists a configuration @{text cf'} in @{text cfs} such that @{text cf} and
@{text cf'} satisfy @{text "Q x"}.
\\Thus, this lemma permits to reproduce the execution of a subprogram, particularly:

  \<^item> a compiled arithmetic expression @{text a}, where @{prop "Q = apred"} and @{prop "x = a"},

  \<^item> a compiled boolean expression @{text b}, where @{prop "Q = bpred"} and @{prop "x = (b, f, i)"}
(given a flag @{text f} and a jump offset @{text i}), and

  \<^item> a compiled command @{text c}, where @{prop "Q = cpred"} and @{prop "x = c"}.

Furthermore, lemma @{text execl_all_sub2} is derived from @{text execl_all_sub} to enable a shorter
symbolical execution of two consecutive subprograms.

\null
\<close>

lemma execl_sub_aux:
 "\<lbrakk>\<And>m n. \<forall>k \<in> {m..<n}. Q P' (((pc, s, stk) # cfs) ! k) \<Longrightarrow> P' \<Turnstile>
    map (off P) (case m of 0 \<Rightarrow> (pc, s, stk) # take n cfs | Suc m \<Rightarrow> F cfs m n);
    \<forall>k \<in> {m..<n+m+length cfs'}. Q P' ((cfs' @ (pc, s, stk) # cfs) ! (k-m))\<rbrakk> \<Longrightarrow>
  P' \<Turnstile> (pc - size P, s, stk) # map (off P) (take n cfs)"
  (is "\<lbrakk>\<And>_ _. \<forall>k \<in> _. Q P' (?F k) \<Longrightarrow> _; \<forall>k \<in> ?A. Q P' (?G k)\<rbrakk> \<Longrightarrow> _")
by (subgoal_tac "\<forall>k \<in> {0..<n}. Q P' (?F k)", fastforce, subgoal_tac
 "\<forall>k \<in> {0..<n}. k + m + length cfs' \<in> ?A \<and> ?F k = ?G (k + m + length cfs')",
 fastforce, simp add: nth_append)

lemma execl_sub:
 "\<lbrakk>P @ P' @ P'' \<Turnstile> cfs; \<forall>k \<in> {m..<n}.
     size P \<le> fst (cfs ! k) \<and> fst (cfs ! k) - size P < size P'\<rbrakk> \<Longrightarrow>
   P' \<Turnstile> map (off P) (drop m (take (Suc n) cfs))"
  (is "\<lbrakk>_; \<forall>k \<in> _. ?P P' cfs k\<rbrakk> \<Longrightarrow> P' \<Turnstile> map _ (?F cfs m (Suc n))")
proof (induction cfs arbitrary: m n rule: execl.induct [of _ P'], auto
 simp: take_Cons drop_Cons exec1_def split: nat.split, force, force, force,
 erule execl_sub_aux [where m = 0], subst append_Cons [of _ "[]"], simp,
 erule execl_sub_aux [where m = "Suc 0" and cfs' = "[]"], simp)
  fix P' pc s stk cfs m n
  let ?cf = "(pc, s, stk) :: config"
  assume "\<And>m n. \<forall>k \<in> {m..<n}. ?P P' (?cf # cfs) k \<Longrightarrow> P' \<Turnstile>
    map (off P) (case m of 0 \<Rightarrow> ?cf # take n cfs | Suc m \<Rightarrow> ?F cfs m n)"
  moreover assume "\<forall>k \<in> {Suc (Suc m)..<Suc n}. ?P P' cfs (k - Suc (Suc 0))"
  hence "\<forall>k \<in> {Suc m..<n}. ?P P' (?cf # cfs) k"
    by force
  ultimately show "P' \<Turnstile> map (off P) (?F cfs m n)"
    by fastforce
qed

lemma execl_all_sub [rule_format]:
  assumes
    A: "P @ P' x @ P'' \<Turnstile> cfs\<box>" and
    B: "k < length cfs" and
    C: "fst (cfs ! k) = size P" and
    D: "\<forall>cfs. P' x \<Turnstile> cfs\<box> \<longrightarrow> Q x (cfs ! 0) (cfs ! (length cfs - 1))"
  shows "\<exists>k' < length cfs. Q x (off P (cfs ! k)) (off P (cfs ! k'))"
proof -
  let ?P = "\<lambda>k. size P \<le> fst (cfs ! k) \<and> fst (cfs ! k) - size P < size (P' x)"
  let ?A = "{k'. k' \<in> {k..<length cfs} \<and> \<not> ?P k'}"
  have E: "Min ?A \<in> ?A"
    using A and B by (rule_tac Min_in, simp_all add: execl_all_def,
     rule_tac exI [of _ "length cfs - 1"], auto)
  hence "map (off P) (drop k (take (Suc (Min ?A)) cfs)) ! 0 = off P (cfs ! k)"
    (is "?cfs ! _ = _")
    by auto
  moreover have "length cfs \<le> Suc (Min ?A) \<longrightarrow> Min ?A = length cfs - 1"
    using E by auto
  with A and B and E have F: "?cfs ! (length ?cfs - 1) = off P (cfs ! Min ?A)"
    by (subst nth_map, auto simp: min_def execl_all_def, arith)
  hence "?cfs \<noteq> [] \<and> fst (?cfs ! (length ?cfs - 1)) \<notin> {0..<size (P' x)}"
    using E by (auto simp: min_def)
  moreover have "\<not> (\<exists>k'. k' \<in> {k'. k' \<in> {k..<Min ?A} \<and> \<not> ?P k'})"
    by (rule notI, erule exE, frule rev_subsetD [of _ _ ?A], rule subsetI,
     insert E, simp, subgoal_tac "finite ?A", drule Min_le, force+)
  hence "P' x \<Turnstile> ?cfs"
    using A by (subst (asm) execl_all_def, rule_tac execl_sub, blast+)
  ultimately have "Q x (?cfs ! 0) (?cfs ! (length ?cfs - 1))"
    using C and D by (auto simp: execl_all_def)
  thus ?thesis
    using E and F by (rule_tac exI [of _ "Min ?A"], auto)
qed

lemma execl_all_sub2:
  assumes
    A: "P x @ P' x' @ P'' \<Turnstile> cfs\<box>"
      (is "?P \<Turnstile> _\<box>") and
    B: "\<And>cfs. P x \<Turnstile> cfs\<box> \<Longrightarrow> (\<lambda>(pc, s, stk) (pc', s', stk').
      pc' = pc + size (P x) + I s \<and> Q s s' \<and> stk' = F s stk)
        (cfs ! 0) (cfs ! (length cfs - 1))"
      (is "\<And>cfs. _ \<Longrightarrow> ?Q x (cfs ! 0) (cfs ! (length cfs - 1))") and
    C: "\<And>cfs. P' x' \<Turnstile> cfs\<box> \<Longrightarrow> (\<lambda>(pc, s, stk) (pc', s', stk').
      pc' = pc + size (P' x') + I' s \<and> Q' s s' \<and> stk' = F' s stk)
        (cfs ! 0) (cfs ! (length cfs - 1))"
      (is "\<And>cfs. _ \<Longrightarrow> ?Q' x' (cfs ! 0) (cfs ! (length cfs - 1))") and
    D: "I (fst (snd (cfs ! 0))) = 0"
  shows "\<exists>k < length cfs. \<exists>t. (\<lambda>(pc, s, stk) (pc', s', stk').
    pc = 0 \<and> pc' = size (P x) + size (P' x') + I' t \<and> Q s t \<and> Q' t s' \<and>
      stk' = F' t (F s stk)) (cfs ! 0) (cfs ! k)"
by (subgoal_tac "[] @ ?P \<Turnstile> cfs\<box>", drule execl_all_sub [where k = 0 and Q = ?Q],
 insert A B, (clarsimp simp: execl_all_def)+, insert A C D, drule execl_all_sub
 [where Q = ?Q'], simp+, clarify, rule exI, rule conjI, simp, rule exI, auto)

subsection "Main theorem"

text \<open>
It is time to prove compiler correctness. First, lemmas @{text acomp_acomp}, @{text bcomp_bcomp} are
derived from @{thm [source] execl_all_sub2} to reproduce the execution of two consecutive compiled
arithmetic expressions (possibly generated by both @{const acomp} and @{const bcomp}) and boolean
expressions (possibly generated by @{const bcomp}), respectively. Subsequently, the correctness of
@{const acomp} and @{const bcomp} is proven in lemmas @{text acomp_correct}, @{text bcomp_correct}.

\null
\<close>

lemma acomp_acomp:
 "\<lbrakk>acomp a\<^sub>1 @ acomp a\<^sub>2 @ P \<Turnstile> cfs\<box>;
    \<And>cfs. acomp a\<^sub>1 \<Turnstile> cfs\<box> \<Longrightarrow> apred a\<^sub>1 (cfs ! 0) (cfs ! (length cfs - 1));
    \<And>cfs. acomp a\<^sub>2 \<Turnstile> cfs\<box> \<Longrightarrow> apred a\<^sub>2 (cfs ! 0) (cfs ! (length cfs - 1))\<rbrakk> \<Longrightarrow>
  case cfs ! 0 of (pc, s, stk) \<Rightarrow> pc = 0 \<and> (\<exists>k < length cfs. cfs ! k =
    (size (acomp a\<^sub>1 @ acomp a\<^sub>2), s, aval a\<^sub>2 s # aval a\<^sub>1 s # stk))"
by (drule execl_all_sub2 [where I = "\<lambda>s. 0" and I' = "\<lambda>s. 0" and Q = "\<lambda>s s'. s' = s"
 and Q' = "\<lambda>s s'. s' = s" and F = "\<lambda>s stk. aval a\<^sub>1 s # stk"
 and F' = "\<lambda>s stk. aval a\<^sub>2 s # stk"], auto simp: apred_def)

lemma bcomp_bcomp:
 "\<lbrakk>bcomp (b\<^sub>1, f\<^sub>1, i\<^sub>1) @ bcomp (b\<^sub>2, f\<^sub>2, i\<^sub>2) \<Turnstile> cfs\<box>;
    \<And>cfs. bcomp (b\<^sub>1, f\<^sub>1, i\<^sub>1) \<Turnstile> cfs\<box> \<Longrightarrow>
      bpred (b\<^sub>1, f\<^sub>1, i\<^sub>1) (cfs ! 0) (cfs ! (length cfs - 1));
    \<And>cfs. bcomp (b\<^sub>2, f\<^sub>2, i\<^sub>2) \<Turnstile> cfs\<box> \<Longrightarrow>
      bpred (b\<^sub>2, f\<^sub>2, i\<^sub>2) (cfs ! 0) (cfs ! (length cfs - 1))\<rbrakk> \<Longrightarrow>
  case cfs ! 0 of (pc, s, stk) \<Rightarrow> pc = 0 \<and> (bval b\<^sub>1 s \<noteq> f\<^sub>1 \<longrightarrow>
    (\<exists>k < length cfs. cfs ! k = (size (bcomp (b\<^sub>1, f\<^sub>1, i\<^sub>1) @ bcomp (b\<^sub>2, f\<^sub>2, i\<^sub>2)) +
      (if bval b\<^sub>2 s = f\<^sub>2 then i\<^sub>2 else 0), s, stk)))"
by (clarify, rule conjI, simp add: execl_all_def, rule impI, subst (asm) append_Nil2
 [symmetric], drule execl_all_sub2 [where I = "\<lambda>s. if bval b\<^sub>1 s = f\<^sub>1 then i\<^sub>1 else 0"
 and I' = "\<lambda>s. if bval b\<^sub>2 s = f\<^sub>2 then i\<^sub>2 else 0" and Q = "\<lambda>s s'. s' = s"
 and Q' = "\<lambda>s s'. s' = s" and F = "\<lambda>s stk. stk" and F' = "\<lambda>s stk. stk"],
 auto simp: bpred_def)

lemma acomp_correct [simplified, intro]:
 "acomp a \<Turnstile> cfs\<box> \<Longrightarrow> apred a (cfs ! 0) (cfs ! (length cfs - 1))"
proof (induction a arbitrary: cfs, simp_all, frule_tac [3] acomp_acomp, auto)
  fix a\<^sub>1 a\<^sub>2 cfs s stk k
  assume A: "acomp a\<^sub>1 @ acomp a\<^sub>2 @ [ADD] \<Turnstile> cfs\<box>"
    (is "?ca\<^sub>1 @ ?ca\<^sub>2 @ ?i \<Turnstile> _\<box>")
  assume B: "k < length cfs" and
    C: "cfs ! k = (size ?ca\<^sub>1 + size ?ca\<^sub>2, s, aval a\<^sub>2 s # aval a\<^sub>1 s # stk)"
  hence "cfs ! Suc k = (size (?ca\<^sub>1 @ ?ca\<^sub>2 @ ?i), s, aval (Plus a\<^sub>1 a\<^sub>2) s # stk)"
    using A by (insert execl_next [of "?ca\<^sub>1 @ ?ca\<^sub>2 @ ?i" cfs k],
     simp add: execl_all_def, drule_tac impI, auto)
  thus "apred (Plus a\<^sub>1 a\<^sub>2) (0, s, stk) (cfs ! (length cfs - Suc 0))"
    using A and B and C by (insert execl_last [of "?ca\<^sub>1 @ ?ca\<^sub>2 @ ?i" cfs "Suc k"],
     simp add: execl_all_def apred_def, drule_tac impI, auto)
qed

lemma bcomp_correct [simplified, intro]:
 "\<lbrakk>bcomp x \<Turnstile> cfs\<box>; 0 \<le> snd (snd x)\<rbrakk> \<Longrightarrow> bpred x (cfs ! 0) (cfs ! (length cfs - 1))"
proof (induction x arbitrary: cfs rule: bcomp.induct, simp_all add: Let_def,
 frule_tac [4] acomp_acomp, frule_tac [3] bcomp_bcomp, auto, force simp: bpred_def)
  fix b\<^sub>1 b\<^sub>2 f i cfs s stk
  assume A: "bcomp (b\<^sub>1, False, size (bcomp (b\<^sub>2, f, i)) + (if f then 0 else i)) @
    bcomp (b\<^sub>2, f, i) \<Turnstile> cfs\<box>"
    (is "bcomp (_, _, ?n + ?i) @ ?cb \<Turnstile> _\<box>")
  moreover assume B: "cfs ! 0 = (0, s, stk)" and
   "\<And>cb cfs. \<lbrakk>cb = ?cb; bcomp (b\<^sub>1, False, ?n + ?i) \<Turnstile> cfs\<box>\<rbrakk> \<Longrightarrow>
      bpred (b\<^sub>1, False, ?n + ?i) (cfs ! 0) (cfs ! (length cfs - Suc 0))"
  ultimately have "\<exists>k < length cfs. bpred (b\<^sub>1, False, ?n + ?i)
    (off [] (cfs ! 0)) (off [] (cfs ! k))"
    by (rule_tac execl_all_sub, auto simp: execl_all_def)
  moreover assume C: "\<not> bval b\<^sub>1 s"
  ultimately obtain k where D: "k < length cfs" and
    E: "cfs ! k = (size (bcomp (b\<^sub>1, False, ?n + ?i)) + ?n + ?i, s, stk)"
    using B by (auto simp: bpred_def)
  assume "0 \<le> i"
  thus "bpred (And b\<^sub>1 b\<^sub>2, f, i) (0, s, stk) (cfs ! (length cfs - Suc 0))"
    using A and C and D and E by (insert execl_last, auto simp:
     execl_all_def bpred_def Let_def)
next
  fix b\<^sub>1 b\<^sub>2 f i cfs s stk k
  assume A: "bcomp (b\<^sub>1, False, size (bcomp (b\<^sub>2, f, i)) + (if f then 0 else i)) @
    bcomp (b\<^sub>2, f, i) \<Turnstile> cfs\<box>"
    (is "?cb\<^sub>1 @ ?cb\<^sub>2 \<Turnstile> _\<box>")
  assume "k < length cfs" and "0 \<le> i" and "bval b\<^sub>1 s" and
   "cfs ! k = (size ?cb\<^sub>1 + size ?cb\<^sub>2 + (if bval b\<^sub>2 s = f then i else 0), s, stk)"
  thus "bpred (And b\<^sub>1 b\<^sub>2, f, i) (0, s, stk) (cfs ! (length cfs - Suc 0))"
    using A by (insert execl_last, auto simp: execl_all_def bpred_def Let_def)
next
  fix a\<^sub>1 a\<^sub>2 f i cfs s stk k
  assume A: "acomp a\<^sub>1 @ acomp a\<^sub>2 @
    (if f then [JMPLESS i] else [JMPGE i]) \<Turnstile> cfs\<box>"
    (is "?ca\<^sub>1 @ ?ca\<^sub>2 @ ?i \<Turnstile> _\<box>")
  assume B: "k < length cfs" and
    C: "cfs ! k = (size ?ca\<^sub>1 + size ?ca\<^sub>2, s, aval a\<^sub>2 s # aval a\<^sub>1 s # stk)"
  hence D: "cfs ! Suc k =
    (size (?ca\<^sub>1 @ ?ca\<^sub>2 @ ?i) + (if bval (Less a\<^sub>1 a\<^sub>2) s = f then i else 0), s, stk)"
    using A by (insert execl_next [of "?ca\<^sub>1 @ ?ca\<^sub>2 @ ?i" cfs k],
     simp add: execl_all_def, drule_tac impI, auto split: if_split_asm)
  assume "0 \<le> i"
  with A and B and C and D have "length cfs - 1 = Suc k"
    by (rule_tac execl_last, auto simp: execl_all_def, simp split: if_split_asm)
  thus "bpred (Less a\<^sub>1 a\<^sub>2, f, i) (0, s, stk) (cfs ! (length cfs - Suc 0))"
    using D by (simp add: bpred_def)
qed

text \<open>
\null

Next, lemmas @{text bcomp_ccomp}, @{text ccomp_ccomp} are derived to reproduce the execution of a
compiled boolean expression followed by a compiled command and of two consecutive compiled commands,
respectively (possibly generated by @{const ccomp}). Then, compiler correctness for loops and for
all commands is proven in lemmas @{text while_correct} and @{text ccomp_correct}, respectively by
induction over the length of the list of configurations and by structural induction over commands.

\null
\<close>

lemma bcomp_ccomp:
 "\<lbrakk>bcomp (b, f, i) @ ccomp c @ P \<Turnstile> cfs\<box>; 0 \<le> i;
    \<And>cfs. ccomp c \<Turnstile> cfs\<box> \<Longrightarrow> cpred c (cfs ! 0) (cfs ! (length cfs - 1))\<rbrakk> \<Longrightarrow>
  case cfs ! 0 of (pc, s, stk) \<Rightarrow> pc = 0 \<and> (bval b s \<noteq> f \<longrightarrow>
    (\<exists>k < length cfs. case cfs ! k of (pc', s', stk') \<Rightarrow>
      pc' = size (bcomp (b, f, i) @ ccomp c) \<and> (c, s) \<Rightarrow> s' \<and> stk' = stk))"
by (clarify, rule conjI, simp add: execl_all_def, rule impI, drule execl_all_sub2
 [where I = "\<lambda>s. if bval b s = f then i else 0" and I' = "\<lambda>s. 0"
 and Q = "\<lambda>s s'. s' = s" and Q' = "\<lambda>s s'. (c, s) \<Rightarrow> s'" and F = "\<lambda>s stk. stk"
 and F' = "\<lambda>s stk. stk"], insert bcomp_correct [of "(b, f, i)"],
 auto simp: bpred_def cpred_def)

lemma ccomp_ccomp:
 "\<lbrakk>ccomp c\<^sub>1 @ ccomp c\<^sub>2 \<Turnstile> cfs\<box>;
    \<And>cfs. ccomp c\<^sub>1 \<Turnstile> cfs\<box> \<Longrightarrow> cpred c\<^sub>1 (cfs ! 0) (cfs ! (length cfs - 1));
    \<And>cfs. ccomp c\<^sub>2 \<Turnstile> cfs\<box> \<Longrightarrow> cpred c\<^sub>2 (cfs ! 0) (cfs ! (length cfs - 1))\<rbrakk> \<Longrightarrow>
  case cfs ! 0 of (pc, s, stk) \<Rightarrow> pc = 0 \<and> (\<exists>k < length cfs. \<exists>t.
    case cfs ! k of (pc', s', stk') \<Rightarrow> pc' = size (ccomp c\<^sub>1 @ ccomp c\<^sub>2) \<and>
      (c\<^sub>1, s) \<Rightarrow> t \<and> (c\<^sub>2, t) \<Rightarrow> s' \<and> stk' = stk)"
by (subst (asm) append_Nil2 [symmetric], drule execl_all_sub2 [where I = "\<lambda>s. 0"
 and I' = "\<lambda>s. 0" and Q = "\<lambda>s s'. (c\<^sub>1, s) \<Rightarrow> s'" and Q' = "\<lambda>s s'. (c\<^sub>2, s) \<Rightarrow> s'"
 and F = "\<lambda>s stk. stk" and F' = "\<lambda>s stk. stk"], auto simp: cpred_def, force)

lemma while_correct [simplified, intro]:
 "\<lbrakk>bcomp (b, False, size (ccomp c) + 1) @ ccomp c @
    [JMP (- (size (bcomp (b, False, size (ccomp c) + 1) @ ccomp c) + 1))] \<Turnstile> cfs\<box>;
    \<And>cfs. ccomp c \<Turnstile> cfs\<box> \<Longrightarrow> cpred c (cfs ! 0) (cfs ! (length cfs - 1))\<rbrakk> \<Longrightarrow>
  cpred (WHILE b DO c) (cfs ! 0) (cfs ! (length cfs - Suc 0))"
  (is "\<lbrakk>?cb @ ?cc @ [JMP (- ?n)] \<Turnstile> _\<box>; \<And>_. _ \<Longrightarrow> _\<rbrakk> \<Longrightarrow> ?Q cfs")
proof (induction cfs rule: length_induct, frule bcomp_ccomp, auto)
  fix cfs s stk
  assume A: "?cb @ ?cc @ [JMP (- size ?cb - size ?cc - 1)] \<Turnstile> cfs\<box>"
  hence "\<exists>k < length cfs. bpred (b, False, size (ccomp c) + 1)
    (off [] (cfs ! 0)) (off [] (cfs ! k))"
    by (rule_tac execl_all_sub, auto simp: execl_all_def)
  moreover assume B: "\<not> bval b s" and "cfs ! 0 = (0, s, stk)"
  ultimately obtain k where "k < length cfs" and "cfs ! k = (?n, s, stk)"
    by (auto simp: bpred_def)
  thus "cpred (WHILE b DO c) (0, s, stk) (cfs ! (length cfs - Suc 0))"
    using A and B by (insert execl_last, auto simp: execl_all_def cpred_def Let_def)
next
  fix cfs s s' stk k
  assume A: "?cb @ ?cc @ [JMP (- size ?cb - size ?cc - 1)] \<Turnstile> cfs\<box>"
    (is "?P \<Turnstile> _\<box>")
  assume B: "k < length cfs" and "cfs ! k = (size ?cb + size ?cc, s', stk)"
  moreover from this have C: "k \<noteq> length cfs - 1"
    using A by (rule_tac notI, simp add: execl_all_def)
  ultimately have D: "cfs ! Suc k = (0, s', stk)"
    using A by (insert execl_next [of ?P cfs k], auto simp: execl_all_def)
  moreover have E: "Suc k + (length (drop (Suc k) cfs) - 1) = length cfs - 1"
    (is "Suc k + (length ?cfs - 1) = _")
    using B and C by simp
  ultimately have "?P \<Turnstile> ?cfs\<box>"
    using A and B and C by (auto simp: execl_all_def intro: execl_drop)
  moreover assume "\<forall>cfs'. length cfs' < length cfs \<longrightarrow> ?P \<Turnstile> cfs'\<box> \<longrightarrow> ?Q cfs'"
  hence "length ?cfs < length cfs \<longrightarrow> ?P \<Turnstile> ?cfs\<box> \<longrightarrow> ?Q ?cfs" ..
  ultimately have "cpred (WHILE b DO c) (cfs ! Suc k) (cfs ! (length cfs - 1))"
    using B and C and E by simp
  moreover assume "bval b s" and "(c, s) \<Rightarrow> s'"
  ultimately show "cpred (WHILE b DO c) (0, s, stk) (cfs ! (length cfs - Suc 0))"
    using D by (auto simp: cpred_def)
qed

lemma ccomp_correct:
 "ccomp c \<Turnstile> cfs\<box> \<Longrightarrow> cpred c (cfs ! 0) (cfs ! (length cfs - 1))"
proof (induction c arbitrary: cfs, simp_all add: Let_def, frule_tac [4] bcomp_ccomp,
 frule_tac [3] ccomp_ccomp, auto)
  fix a x cfs
  assume A: "acomp a @ [STORE x] \<Turnstile> cfs\<box>"
  hence "\<exists>k < length cfs. apred a (off [] (cfs ! 0)) (off [] (cfs ! k))"
    by (rule_tac execl_all_sub, auto simp: execl_all_def)
  moreover obtain s stk where B: "cfs ! 0 = (0, s, stk)"
    using A by (cases "cfs ! 0", simp add: execl_all_def)
  ultimately obtain k where C: "k < length cfs" and
    D: "cfs ! k = (size (acomp a), s, aval a s # stk)"
    by (auto simp: apred_def)
  hence "cfs ! Suc k = (size (acomp a) + 1, s(x := aval a s), stk)"
    using A by (insert execl_next [of "acomp a @ [STORE x]" cfs k],
     simp add: execl_all_def, drule_tac impI, auto)
  thus "cpred (x ::= a) (cfs ! 0) (cfs ! (length cfs - Suc 0))"
    using A and B and C and D by (insert execl_last [of "acomp a @ [STORE x]"
     cfs "Suc k"], simp add: execl_all_def cpred_def, drule_tac impI, auto)
next
  fix c\<^sub>1 c\<^sub>2 cfs s s' t stk k
  assume "ccomp c\<^sub>1 @ ccomp c\<^sub>2 \<Turnstile> cfs\<box>" and "k < length cfs" and
   "cfs ! k = (size (ccomp c\<^sub>1) + size (ccomp c\<^sub>2), s', stk)"
  moreover assume "(c\<^sub>1, s) \<Rightarrow> t" and "(c\<^sub>2, t) \<Rightarrow> s'"
  ultimately show "cpred (c\<^sub>1;; c\<^sub>2) (0, s, stk) (cfs ! (length cfs - Suc 0))"
    by (insert execl_last, auto simp: execl_all_def cpred_def)
next
  fix b c\<^sub>1 c\<^sub>2 cfs s stk
  assume A: "bcomp (b, False, size (ccomp c\<^sub>1) + 1) @ ccomp c\<^sub>1 @
    JMP (size (ccomp c\<^sub>2)) # ccomp c\<^sub>2 \<Turnstile> cfs\<box>"
    (is "bcomp ?x @ ?cc\<^sub>1 @ _ # ?cc\<^sub>2 \<Turnstile> _\<box>")
  let ?P = "bcomp ?x @ ?cc\<^sub>1 @ [JMP (size ?cc\<^sub>2)]"
  have "\<exists>k < length cfs. bpred ?x (off [] (cfs ! 0)) (off [] (cfs ! k))"
    using A by (rule_tac execl_all_sub, auto simp: execl_all_def)
  moreover assume B: "\<not> bval b s" and "cfs ! 0 = (0, s, stk)"
  ultimately obtain k where C: "k < length cfs" and D: "cfs ! k = (size ?P, s, stk)"
    by (force simp: bpred_def)
  assume "\<And>cfs. ?cc\<^sub>2 \<Turnstile> cfs\<box> \<Longrightarrow> cpred c\<^sub>2 (cfs ! 0) (cfs ! (length cfs - Suc 0))"
  hence "\<exists>k' < length cfs. cpred c\<^sub>2 (off ?P (cfs ! k)) (off ?P (cfs ! k'))"
    using A and C and D by (rule_tac execl_all_sub [where P'' = "[]"], auto)
  then obtain k' where "k' < length cfs" and "case cfs ! k' of (pc', s', stk') \<Rightarrow>
    pc' = size (?P @ ?cc\<^sub>2) \<and> (c\<^sub>2, s) \<Rightarrow> s' \<and> stk' = stk"
    using D by (fastforce simp: cpred_def)
  thus "cpred (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (0, s, stk) (cfs ! (length cfs - Suc 0))"
    using A and B by (insert execl_last, auto simp: execl_all_def cpred_def Let_def)
next
  fix b c\<^sub>1 c\<^sub>2 cfs s s' stk k
  assume A: "bcomp (b, False, size (ccomp c\<^sub>1) + 1) @ ccomp c\<^sub>1 @
    JMP (size (ccomp c\<^sub>2)) # ccomp c\<^sub>2 \<Turnstile> cfs\<box>"
    (is "?cb @ ?cc\<^sub>1 @ ?i # ?cc\<^sub>2 \<Turnstile> _\<box>")
  assume B: "k < length cfs" and C: "cfs ! k = (size ?cb + size ?cc\<^sub>1, s', stk)"
  hence D: "cfs ! Suc k = (size (?cb @ ?cc\<^sub>1 @ ?i # ?cc\<^sub>2), s', stk)"
    (is "_ = (size ?P, _, _)")
    using A by (insert execl_next [of ?P cfs k], simp add: execl_all_def,
     drule_tac impI, auto)
  assume "bval b s" and "(c\<^sub>1, s) \<Rightarrow> s'"
  thus "cpred (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (0, s, stk) (cfs ! (length cfs - Suc 0))"
    using A and B and C and D by (insert execl_last [of ?P cfs "Suc k"],
     simp add: execl_all_def cpred_def Let_def, drule_tac impI, auto)
next
  fix c\<^sub>1 c\<^sub>2 cfs
  assume A: "JMPND (size (ccomp c\<^sub>1) + 1) # ccomp c\<^sub>1 @
    JMP (size (ccomp c\<^sub>2)) # ccomp c\<^sub>2 \<Turnstile> cfs\<box>"
    (is "JMPND (?n\<^sub>1 + 1) # ?cc\<^sub>1 @ JMP ?n\<^sub>2 # ?cc\<^sub>2 \<Turnstile> _\<box>")
  let ?P = "JMPND (?n\<^sub>1 + 1) # ?cc\<^sub>1 @ [JMP ?n\<^sub>2]"
  assume
    B: "\<And>cfs. ?cc\<^sub>1 \<Turnstile> cfs\<box> \<Longrightarrow> cpred c\<^sub>1 (cfs ! 0) (cfs ! (length cfs - Suc 0))" and
    C: "\<And>cfs. ?cc\<^sub>2 \<Turnstile> cfs\<box> \<Longrightarrow> cpred c\<^sub>2 (cfs ! 0) (cfs ! (length cfs - Suc 0))"
  from A obtain s stk where D: "cfs ! 0 = (0, s, stk)"
    by (cases "cfs ! 0", simp add: execl_all_def)
  with A have "cfs ! 1 = (1, s, stk) \<or> cfs ! 1 = (?n\<^sub>1 + 2, s, stk)"
    by (insert execl_next [of "?P @ ?cc\<^sub>2" cfs 0], simp add: execl_all_def,
     drule_tac impI, auto)
  moreover {
    assume E: "cfs ! 1 = (1, s, stk)"
    hence "\<exists>k < length cfs. cpred c\<^sub>1 (off [hd ?P] (cfs ! 1)) (off [hd ?P] (cfs ! k))"
      using A and B by (rule_tac execl_all_sub, auto simp: execl_all_def)
    then obtain k where "k < length cfs" and "case cfs ! k of (pc', s', stk') \<Rightarrow>
      pc' = ?n\<^sub>1 + 1 \<and> (c\<^sub>1, s) \<Rightarrow> s' \<and> stk' = stk"
      using E by (fastforce simp: cpred_def)
    moreover from this have "case cfs ! Suc k of (pc', s', stk') \<Rightarrow>
      pc' = ?n\<^sub>1 + ?n\<^sub>2 + 2 \<and> (c\<^sub>1, s) \<Rightarrow> s' \<and> stk' = stk"
      using A by (insert execl_next [of "?P @ ?cc\<^sub>2" cfs k], simp add: execl_all_def,
       drule_tac impI, auto)
    ultimately have "cpred (c\<^sub>1 OR c\<^sub>2) (cfs ! 0) (cfs ! (length cfs - Suc 0))"
      using A and D by (insert execl_last [of "?P @ ?cc\<^sub>2" cfs "Suc k"],
       simp add: execl_all_def cpred_def split_def Let_def, drule_tac impI, auto)
  }
  moreover {
    assume E: "cfs ! 1 = (?n\<^sub>1 + 2, s, stk)"
    with A and C have "\<exists>k<length cfs. cpred c\<^sub>2 (off ?P (cfs!1)) (off ?P (cfs!k))"
      by (rule_tac execl_all_sub [where P'' = "[]"], auto simp: execl_all_def)
    then obtain k where "k < length cfs" and "case cfs ! k of (pc', s', stk') \<Rightarrow>
      pc' = ?n\<^sub>1 + ?n\<^sub>2 + 2 \<and> (c\<^sub>2, s) \<Rightarrow> s' \<and> stk' = stk"
      using E by (fastforce simp: cpred_def)
    with A and D have "cpred (c\<^sub>1 OR c\<^sub>2) (cfs ! 0) (cfs ! (length cfs - Suc 0))"
      by (insert execl_last, auto simp: execl_all_def cpred_def Let_def)
  }
  ultimately show "cpred (c\<^sub>1 OR c\<^sub>2) (cfs ! 0) (cfs ! (length cfs - Suc 0))" ..
qed

text \<open>
\null

Finally, the main compiler correctness theorem, expressed using predicate @{const exec}, is proven.
First, @{prop "P \<turnstile> cf \<rightarrow>* cf'"} is shown to imply the existence of a nonempty list of configurations
@{text cfs} such that @{prop "P \<Turnstile> cfs"}, whose initial and final configurations match @{text cf}
and @{text cf'}, respectively. Then, the main theorem is derived as a straightforward consequence of
this lemma and of the previous lemma @{thm [source] ccomp_correct}.

\null
\<close>

lemma exec_execl [dest!]:
 "P \<turnstile> cf \<rightarrow>* cf' \<Longrightarrow> \<exists>cfs. P \<Turnstile> cfs \<and> cfs \<noteq> [] \<and> hd cfs = cf \<and> last cfs = cf'"
by (erule star.induct, force, erule exE, rule list.exhaust, blast,
 simp del: last.simps, rule exI, subst execl.simps(1), simp)

theorem ccomp_exec:
 "ccomp c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp c), s', stk') \<Longrightarrow> (c, s) \<Rightarrow> s' \<and> stk' = stk"
by (insert ccomp_correct, force simp: hd_conv_nth last_conv_nth execl_all_def cpred_def)

end


theory Remdups_Example
  imports Set_Impl

begin

subsection "remdups"

fun remdups' where
  "remdups' ac [] = ac"
| "remdups' ac (x#xs) = (if x\<in>set ac then remdups' ac xs
                                       else remdups' (ac@[x]) xs)"

fun remdups2 where
  "remdups2 ac S [] = ac"
| "remdups2 ac S (x#xs) = (if x\<in>set ac then remdups' ac xs
                                       else remdups' (ac@[x]) xs)"

definition rd_t :: "nat\<Rightarrow>nat" where
  "rd_t n = set_init_t + n * (set_ins_t n + set_mem_t n + 0 + 0 + 0 + 10)"

definition "rd_SPEC as \<equiv> SPECT [remdups' [] as \<mapsto> rd_t (length as)]"

definition rd_impl1 :: "nat list \<Rightarrow> (nat list) nrest" where
  "rd_impl1 as = do {
          ys \<leftarrow> RETURNT [];
          S \<leftarrow> set_init_SPEC;
          zs \<leftarrow> RETURNT as;
          (zs,ys,S) \<leftarrow> whileT (\<lambda>(xs,ys,S). length xs > 0)
            (\<lambda>(xs,ys,S). do {
                          ASSERT (length xs > 0);
                          ASSERT (length xs + length ys \<le> length as);
                          ASSERT (card S \<le> length ys);
                          x \<leftarrow> RETURNT (hd xs);
                          xs \<leftarrow> RETURNT (tl xs);
                          b \<leftarrow> set_mem_SPEC x S;
                          (if b
  then  RETURNT (xs,ys,S)
  else do { S \<leftarrow> set_ins_SPEC x S;
            ys \<leftarrow> RETURNT (x#ys); (* SPECT [x#ys\<mapsto> 10]; *)
            RETURNT (xs,ys,S)
  } ) }) (zs,ys,S);
          RETURNT ys
      }"

(*

definition rd_impl1 :: "nat list \<Rightarrow> (nat list) nrest" where
  "rd_impl1 as = do {
          ys \<leftarrow> RETURNT [];
          S \<leftarrow> set_init_SPEC;
          zs \<leftarrow> RETURNT as;
          St' \<leftarrow> RETURNT (ys,S);
          St \<leftarrow> RETURNT (zs,St');
          End \<leftarrow> whileT (\<lambda>(xs,ys,S). length xs > 0)
            (\<lambda>(xs,ys,S). do {
                          ASSERT (length xs > 0);
                          ASSERT (length xs + length ys \<le> length as);
                          ASSERT (card S \<le> length ys);
                          x \<leftarrow> RETURNT (hd xs);
                          xs \<leftarrow> RETURNT (tl xs);
                          b \<leftarrow> set_mem_SPEC x S;
                          (if b
  then  RETURNT (xs,ys,S)
  else do { S \<leftarrow> set_ins_SPEC x S;
            ys \<leftarrow> RETURNT (x#ys); (* SPECT [x#ys\<mapsto> 10]; *)
            RETURNT (xs,ys,S)
  } ) }) St;
            End' \<leftarrow> RETURNT (snd End);
            RETURNT (fst End)
      }"
*)

lemma rd_impl1_refines: "rd_impl1 as \<le> rd_SPEC as" sorry

lemma hn_ctxt_triple: "\<And>A B C .
    hn_ctxt (\<lambda>(c1, c2, c3) (a1, a2, a3). A c1 a1  * B c2 a2 * C c3 a3 ) (c1, c2, c3) (a1, a2, a3)
    = hn_ctxt A c1 a1 * hn_ctxt B c2 a2 * hn_ctxt C c3 a3"
  unfolding hn_ctxt_def by simp

lemma hn_ctxt_triple'': "\<And>A B C .
    hn_ctxt (\<lambda>(c1, c2, c3) (a1, a2, a3). A c1 a1  * B c2 a2 * C c3 a3 ) s s'
    = hn_ctxt A (fst s) (fst s') * hn_ctxt B (fst (snd s)) (fst (snd s')) * hn_ctxt C (snd (snd s)) (snd (snd s'))"
  unfolding hn_ctxt_def
  by (simp add: case_prod_beta')

lemma hn_ctxt_triple': "hn_val Id as as * (hn_val Id x x' * hn_ctxt rbt_map_assn' xa S') \<Longrightarrow>\<^sub>A
       hn_ctxt (\<lambda>(c1, c2, c3) (a1, a2, a3). pure Id c1 a1 * (pure Id c2 a2 * rbt_map_assn' c3 a3)) (as, x, xa) (as, x', S')"
  unfolding hn_ctxt_def by simp

lemma add_triv: "\<And>B C x. hn_ctxt (pure Id) x x * B \<Longrightarrow>\<^sub>A C \<Longrightarrow> B \<Longrightarrow>\<^sub>A C"
  unfolding hn_ctxt_def pure_def
  using assn_times_comm entails_pure by fastforce

lemma hd_entails:
  "hn_val Id (a::nat list) ab \<Longrightarrow>\<^sub>A hn_ctxt (pure Id) (hd a) (hd ab)"
  unfolding hn_ctxt_def
  by (metis entails_def entails_pure' pair_in_Id_conv pure_app_eq)

lemma zuf: "\<up> True * true =  true"
  by (simp add: abel_semigroup.commute assn_ext mult.abel_semigroup_axioms)

lemma hn_refine_hd: " hn_refine (hn_val Id s' s)
           (ureturn (hd s))
       (hn_val Id s' s)
       (pure Id) (RETURNT (hd s'))"
  unfolding hn_refine_def apply (auto simp: zuf mult.assoc  execute_ureturn pure_def hn_ctxt_def)
   apply(rule exI[where x=0]) apply (auto simp: zero_enat_def relH_def )
    using models_in_range top_assn_rule
    by (metis (full_types) mod_false zuf)

lemma hn_refine_length: " hn_refine (hn_val Id xs' xs)
           (ureturn (length xs))
       (hn_val Id xs' xs)
       (pure Id) (RETURNT (length xs'))"
  unfolding hn_refine_def apply (auto simp: zuf mult.assoc  execute_ureturn pure_def hn_ctxt_def)
   apply(rule exI[where x=0]) apply (auto simp: zero_enat_def relH_def )
    using models_in_range top_assn_rule
    by (metis (full_types) mod_false zuf)

lemma hn_refine_tl: " hn_refine (hn_val Id s' s)
           (ureturn (tl s))
       (hn_val Id s' s)
       (pure Id) (RETURNT (tl s'))"
  unfolding hn_refine_def apply (auto simp: zuf mult.assoc  execute_ureturn pure_def hn_ctxt_def)
   apply(rule exI[where x=0]) apply (auto simp: zero_enat_def relH_def )
    using models_in_range top_assn_rule
    by (metis (full_types) mod_false zuf)

lemma hnr_cons_rule: " hn_refine (hn_val Id xs' xs * hn_val Id x' x)
           (ureturn (x#xs))
       (hn_val Id xs' xs * hn_val Id x' x)
       (pure Id) (RETURNT (x'#xs'))"
  unfolding hn_refine_def apply (auto simp: zuf mult.assoc  execute_ureturn pure_def hn_ctxt_def)
   apply(rule exI[where x=0]) apply (auto simp: zero_enat_def relH_def )
  using models_in_range top_assn_rule by blast

lemma hn_refine_less: " hn_refine (hn_val nat_rel s' s * hn_val nat_rel x' x)
           (ureturn (x < s))
       (hn_val nat_rel s' s * hn_val nat_rel x' x)
       (pure bool_rel) (RETURNT (x' < s'))"
  unfolding hn_refine_def apply (auto simp: zuf mult.assoc  execute_ureturn pure_def hn_ctxt_def)
   apply(rule exI[where x=0]) apply (auto simp: zero_enat_def relH_def )
    using models_in_range top_assn_rule by blast

lemma manual1: "
  hn_val Id a ab \<Longrightarrow>\<^sub>A hn_val Id a (XX x' x'a (fst s) (fst (snd s)) (snd (snd s))) \<Longrightarrow>
   XX = (\<lambda>x' x'a ab ac ba. X x' x'a (ab, ac, ba)) \<Longrightarrow>
hn_val Id a ab \<Longrightarrow>\<^sub>A hn_val Id a (X x' x'a s)" by auto

schematic_goal "f a = f (?X (a,b,c))"
  by simp

schematic_goal "hn_val Id a ab \<Longrightarrow>\<^sub>A hn_val Id a (?S x' x'a (ab, ac, ba))"
  apply(rule entails_triv)      done

schematic_goal "\<And>ab ac ba. f ab = f (?S (ab, ac, ba))"
  apply(rule refl)      oops

lemma rewr: "P (S' a b c) \<Longrightarrow> S' = (\<lambda>a b c. S (a,b,c)) \<Longrightarrow> P (S (a,b,c))"
  by auto

schematic_goal "\<And>ab ac ba. f ab = f (?S (ab, ac, ba))"
  apply(rule rewr )
  apply(rule refl) apply sim      oops

schematic_goal "\<And>x x' xa x'a a aa b ab ac ba.
       RETURNT x \<le> RETURNT [] \<Longrightarrow>
       RETURNT xa \<le> set_init_SPEC \<Longrightarrow> a \<noteq> [] \<Longrightarrow> length a + length aa \<le> length as \<Longrightarrow> card b \<le> length aa \<Longrightarrow> hn_val Id a ab \<Longrightarrow>\<^sub>A hn_val Id a (?s73 x' x'a (ab, ac, ba))"
  apply(rule entails_triv)      oops

subsection \<open>Product Types\<close>
text \<open>Some notion for product types is already defined here, as it is used
  for currying and uncurrying, which is fundamental for the sepref tool\<close>
definition prod_assn :: "('a1\<Rightarrow>'c1\<Rightarrow>assn) \<Rightarrow> ('a2\<Rightarrow>'c2\<Rightarrow>assn)
  \<Rightarrow> 'a1*'a2 \<Rightarrow> 'c1*'c2 \<Rightarrow> assn" where
  "prod_assn P1 P2 a c \<equiv> case (a,c) of ((a1,a2),(c1,c2)) \<Rightarrow>
  P1 a1 c1 * P2 a2 c2"

notation prod_assn (infixr "\<times>\<^sub>a" 70)

lemma prod_assn_pure_conv[simp]: "prod_assn (pure R1) (pure R2) = pure (R1 \<times>\<^sub>r R2)"
  by (auto simp: pure_def prod_assn_def pure_conj intro!: ext)

lemma prod_assn_pair_conv[simp]:
  "prod_assn A B (a1,b1) (a2,b2) = A a1 a2 * B b1 b2"
  unfolding prod_assn_def by auto

lemma prod_assn_true[simp]: "prod_assn (\<lambda>_ _. true) (\<lambda>_ _. true) = (\<lambda>_ _. true)"
  by (auto intro!: ext simp: hn_ctxt_def prod_assn_def)

lemma prod_assn_ctxt: "prod_assn A1 A2 x y = z \<Longrightarrow> hn_ctxt (prod_assn A1 A2) x y = z"
  by (simp add: hn_ctxt_def)

lemma hn_case_prod':
  assumes FR: "\<Gamma>\<Longrightarrow>\<^sub>thn_ctxt (prod_assn P1 P2) p' p * \<Gamma>1"
  assumes Pair: "\<And>a1 a2 a1' a2'. \<lbrakk>p'=(a1',a2')\<rbrakk>
    \<Longrightarrow> hn_refine (hn_ctxt P1 a1' a1 * hn_ctxt P2 a2' a2 * \<Gamma>1 * hn_invalid (prod_assn P1 P2) p' p) (f a1 a2)
          (hn_ctxt P1' a1' a1 * hn_ctxt P2' a2' a2 * hn_ctxt XX1 p' p * \<Gamma>1') R (f' a1' a2')"
  shows "hn_refine \<Gamma> (case_prod f p) (hn_ctxt (prod_assn P1' P2') p' p * \<Gamma>1')
    R (case_prod (\<lambda>a b. f' a b) p')" (is "?G \<Gamma>")
    apply1 (rule hn_refine_cons_pre[OF FR])
    apply1 extract_hnr_invalids
    apply1 (cases p; cases p'; simp add: prod_assn_pair_conv[THEN prod_assn_ctxt])
    apply (rule hn_refine_cons[OF _ Pair _ entt_refl])
  subgoal
    apply (simp add: hn_ctxt_def entailst_def)
          apply(rule ent_true_drop(2))
          apply(rule ent_true_drop(2)) apply(rule entails_triv) done
    applyS simp
      subgoal
        apply  (simp add: hn_ctxt_def entailst_def mult.assoc)
    apply(rule match_first)
    apply(rule match_first) apply(rotatel)
    apply(rule match_first)  by simp
      done

    term "pure (Id) \<times>\<^sub>a  pure (Id) \<times>\<^sub>a  rbt_map_assn'"
  (* nat list \<times> nat list \<times> nat set \<Rightarrow> ?'a23 \<Rightarrow> assn *)

lemma hn_ctxt_prod_split: "hn_ctxt (A \<times>\<^sub>a B) (a, b) (a', b') = hn_ctxt A a a' * hn_ctxt B b b'"
  by (simp add: prod_assn_def hn_ctxt_def)

lemma hn_ctxt_prod_split': "hn_ctxt (A \<times>\<^sub>a B) (a, b) s' = hn_ctxt A a (fst s') * hn_ctxt B b (snd s')"
  by (simp add: prod_assn_def hn_ctxt_def  case_prod_beta')

lemma hn_ctxt_prod_split'': "s'=(a',b') \<Longrightarrow> hn_ctxt (A \<times>\<^sub>a B) (a, b) s' = hn_ctxt A a a' * hn_ctxt B b b'"
  by (simp add: prod_assn_def hn_ctxt_def  case_prod_beta')

lemma t: "true = true * true"
  by simp

lemma or_merge: "((B1 * C1) \<or>\<^sub>A (B1 * C2)) = (B1) * (C1 \<or>\<^sub>A C2)"
  apply(rule ent_iffI)
  subgoal  by (simp add: ent_disjE match_first)
  subgoal   sorry
  oops
lemma "A * ((B1 * C1) \<or>\<^sub>A (B1 * C2)) = (A * B1) * (C1 \<or>\<^sub>A C2)"
  apply (simp add: assn_times_assoc or_merge)
  oops

lemma or_merge: "((B1 * C1) \<or>\<^sub>A (B1 * C2)) \<Longrightarrow>\<^sub>A (B1) * (C1 \<or>\<^sub>A C2)"
  by (simp add: ent_disjE match_first)

lemma or_merge_succ_step: "A * ((B1 * C1) \<or>\<^sub>A (B1 * C2)) \<Longrightarrow>\<^sub>A gr A B1 * (C1 \<or>\<^sub>A C2)"
  apply (simp add: assn_times_assoc gr_def )
  apply(rule match_first) using or_merge by auto

lemma or_merge_rotatel: "A * ((B1 * C1) \<or>\<^sub>A (B2 * C2)) \<Longrightarrow>\<^sub>A A * ((C1 * B1) \<or>\<^sub>A (B2 * C2))"
  apply(rule match_first)
  by (simp add: assn_times_comm entails_triv)
lemma or_merge_rotater: "A * ((B1 * C1) \<or>\<^sub>A (B2 * C2)) \<Longrightarrow>\<^sub>A A * ((B1 * C1) \<or>\<^sub>A (C2 * B2))"
  apply(rule match_first)
  by (simp add: assn_times_comm entails_triv)

lemma addemp_triv: "emp * A \<Longrightarrow>\<^sub>A B \<Longrightarrow> A \<Longrightarrow>\<^sub>A B"
  by simp

lemma invalid_pure_recover: "invalid_assn (pure R) x y = pure R x y * true"
  apply (rule ent_iffI)
  subgoal
    apply (rule entailsI)
    unfolding invalid_assn_def
    by (auto simp: pure_def assn_times_comm)
  subgoal
    unfolding invalid_assn_def
    apply (auto simp: pure_def)
    using entailsI entails_frame by fastforce
  done

lemma hn_invalid_prod_split: "hn_invalid (A \<times>\<^sub>a B) (a, b) (a', b')
      \<Longrightarrow>\<^sub>A hn_invalid A a a' * hn_invalid B b b'"
  apply(auto simp: hn_ctxt_def invalid_assn_def  )
  by (smt SepLogic_Misc.mod_pure_star_dist entails_def merge_true_star mod_starD mult.left_commute mult_commute_abs)

lemma forward_ent: "A \<Longrightarrow>\<^sub>A A' \<Longrightarrow> A' * B \<Longrightarrow>\<^sub>A C \<Longrightarrow> A * B \<Longrightarrow>\<^sub>A C"
  using entails_frame' by blast

lemma forward_ent_snd: "B \<Longrightarrow>\<^sub>A B' \<Longrightarrow> A * B' \<Longrightarrow>\<^sub>A C \<Longrightarrow> A * B \<Longrightarrow>\<^sub>A C"
  using forward_ent left_move_back by blast

lemma underA: "A \<Longrightarrow>\<^sub>A A' \<Longrightarrow> A \<or>\<^sub>A B \<Longrightarrow>\<^sub>A A' \<or>\<^sub>A B"
    using ent_disjE ent_disjI1_direct ent_disjI2_direct ent_trans by blast

lemma underB: "B \<Longrightarrow>\<^sub>A B' \<Longrightarrow> A \<or>\<^sub>A B \<Longrightarrow>\<^sub>A A \<or>\<^sub>A B'"
  using ent_disjE ent_disjI1_direct ent_disjI2_direct ent_trans by blast

definition "asd = (\<lambda>x y. true)"
lemma U: "hn_val Id a b \<Longrightarrow>\<^sub>A hn_ctxt asd a b"
  by(auto simp: hn_ctxt_def asd_def)
schematic_goal "hn_val Id a b \<Longrightarrow>\<^sub>A hn_ctxt asd a (?p927 b)"
  apply (rule U) oops

schematic_goal "hn_ctxt (\<lambda>x y. true) a b \<Longrightarrow>\<^sub>A hn_ctxt ?R a b"
  by(rule entails_triv)

schematic_goal "hn_ctxt asd a b \<Longrightarrow>\<^sub>A hn_ctxt asd a ?x"
  apply (rule entails_triv)
  thm entails_triv oops

schematic_goal "hn_ctxt asd a b \<Longrightarrow>\<^sub>A hn_ctxt asd a (?x::?'a)"
  by (rule entails_triv)

schematic_goal "hn_ctxt (pure Id) a a1a \<Longrightarrow>\<^sub>A hn_ctxt ?R a (?S a1a a2a)"
  apply(rule entails_triv) oops

lemma b: "RETURNT (case s' of (xs, ys, S) \<Rightarrow> 0 < length xs)
    = (case s' of (xs, ys, S) \<Rightarrow> do { x \<leftarrow> RETURNT 0; y \<leftarrow> RETURNT (length xs); RETURNT (x < y) })"
  apply auto unfolding RETURNT_def by(auto simp: prod.case_distrib)

thm invalid_pure_recover
lemma invalid_pure_recover': "hn_invalid (pure Id) a1'a a1a
      = hn_ctxt (pure Id) a1'a a1a * true"
  unfolding hn_ctxt_def by(simp add: invalid_pure_recover)

schematic_goal rd_hnr:
  "hn_refine emp (?C::?'a Heap) ?G ?R (rd_impl1 as)" using [[goals_limit = 3]]
  unfolding rd_impl1_def
  apply(rule hnr_bind)
    focus (* line 1 *)
      apply(rule hnr_uRETURN_pure[where R=Id])
      apply simp
    solved

  apply(rule hnr_bind)
    focus (* line 2 *)
      apply simp
      apply(rule hnr_frame)
      apply(rule set_init_hnr')

     apply(simp add: entailst_def) apply(rule match_rest) apply simp
    solved

  apply(rule hnr_bind)
    focus (* line 3 *)
      apply(rule hnr_frame[OF hnr_uRETURN_pure[where R=Id]]) apply simp
      apply(simp) apply(rule entt_refl)
    solved

  apply(rule hnr_bind)
    focus (* the while loop *)
    unfolding whileT_I' unfolding WHILEIT_to_monadic
(*      apply(rule hn_monadic_WHILE_aux[where Rs="\<lambda>(c1,c2,c3) (a1,a2,a3). (pure Id) c1 a1 * (pure Id) c2 a2 * rbt_map_assn' c3 a3"])
  unfolding entailst_def
          apply rotatel apply(rule match_first)
          apply(rule ent_true_drop(2))
          apply rotatel apply(rule add_triv[where x=as])
          apply(rule hn_ctxt_triple')
  unfolding hn_ctxt_triple''
 *)
    apply(rule hn_monadic_WHILE_aux[where \<Gamma>="emp" and Rs="pure (Id) \<times>\<^sub>a  (pure (Id) \<times>\<^sub>a  rbt_map_assn')"])
    focus (* WHILE: precondition *)
  unfolding entailst_def apply(simp  )
           apply(rule ent_true_drop(2))
           apply(subst hn_ctxt_prod_split'') prefer 2
            apply(subst hn_ctxt_prod_split'') prefer 2
      apply rotater apply(rule match_first)  apply(rule match_first)  apply(rule entails_triv)
      apply (rule refl) apply (rule refl)
    solved
    focus  (* WHILE: loop guard *)
      unfolding b
      (* split case_prod *)
      apply(rule hn_case_prod')
      focus (* 1st prod frame *)
           unfolding entailst_def  apply rotatel apply(rule match_first)
          apply(rule match_rest) apply simp
      solved
      apply(rule hn_refine_cons_post')
      apply(rule hn_case_prod')
      focus (* 2nd prod frame *)
      unfolding entailst_def  apply rotatel  apply(rule match_first)
           apply(rule match_rest) apply simp
      solved
      (* While: guard: code *)
       focus

      apply(rule hnr_bind) (* bind Wg1 *)
      focus (* While: guard: first return *)
      apply(rule hnr_frame[OF hnr_uRETURN_pure[where R=Id]])
       apply simp
      unfolding entailst_def apply rotater apply rotatel apply rotatel apply (rule match_first)
      apply rotater
           apply(rule ent_true_drop(2))
      apply(rule entails_triv)
      solved

      apply(rule hnr_bind) (* bind Wg2 *)
      focus (* While: guard: second return *)
      apply(rule hnr_frame[OF hn_refine_length])
        apply simp apply (simp add: entailst_def)
      apply(rule ent_true_drop(2))
      apply rotatel apply rotater apply(rule match_first)
      apply (rule entails_triv)
      solved

      focus (* While: guard: less *)
      apply(rule hnr_frame[OF hn_refine_less])
  apply (simp add: entailst_def)
      apply(rule ent_true_drop(2))
      apply rotater apply rotatel apply rotatel apply rotatel apply rotatel apply rotatel apply rotatel
      apply (rule match_first)  apply rotatel  apply rotatel  apply rotatel
      apply (rule match_first)
      apply (rule entails_triv)
      solved

      focus (* IMP of bind Wg2 *)
        apply (simp add: entailst_def)
      apply(rule ent_true_drop(2))
      apply rotater   apply rotatel      apply rotatel apply rotatel apply rotatel
      apply rotatel     apply(rule match_first) apply(rule entails_triv)
      solved

      focus (* IMP of bind Wg1 *)
      apply rotater  apply rotater apply rotater  apply rotater
      apply (rule match_first) apply rotatel apply rotatel
      apply rotater apply rotater apply rotater apply (rule match_first)
      apply rotater apply rotater  apply (rule match_first)
      apply(rule addemp_triv)
      apply rotatel apply (rule match_first)
      apply(rule ent_true_drop(2)) apply simp apply (rule entails_triv)
      solved
      solved

      apply rotatel apply rotatel apply (rule match_first) apply (rule match_first)
      apply (rule match_rest)
      apply(rule ent_true_drop(2)) apply (rule entails_triv)
      solved (* WHILE: loop guard *)

      focus (* While : guard frame *)
      apply(simp add: entailst_def)
      apply(rule ent_true_drop(2))
      apply(rule entails_triv)
      solved

   focus (* WHILE: the loop body *)
      apply(rule hn_case_prod')
      focus (* 1st prod frame *)
          unfolding entailst_def
          apply rotatel apply(rule match_first) apply(rule match_rest) apply simp
      solved
          apply(rule hn_refine_cons_post')
          focus (* post R *)
          apply(rule hn_case_prod')
      focus (* 2nd prod frame *)
          unfolding entailst_def
          apply rotatel  apply (rule match_first) apply(rule ent_true_drop_fst) apply(rule ent_true_drop(2))
          apply (rule entails_triv)
      solved
      focus (* code *)
        apply(rule hnr_ASSERT)
        apply(rule hnr_ASSERT)
        apply(rule hnr_ASSERT)

       apply(rule hnr_bind[where Rh="pure Id"])  (* bind Wb1 *)
      focus (* the hd operation *)
          apply(rule hnr_frame[OF hn_refine_hd])
            apply(simp add: entailst_def) apply rotatel apply rotatel apply rotatel apply rotater apply (rule match_first)
  apply rotater
            apply(rule ent_true_drop(2)) apply (rule entails_triv)
     solved (* the hd operation *)

     focus (* prog after hd *)
       apply(rule hnr_bind[where Rh="pure Id"])  (* bind Wb2 *)
      focus (* the tl operation *)
          apply(rule hnr_frame[OF hn_refine_tl])
             apply(simp add: entailst_def mult.assoc) apply rotater apply rotatel apply rotatel    apply rotatel  apply rotatel
                apply (rule match_first)
  apply rotater
            apply(rule ent_true_drop(2)) apply (rule entails_triv)
      solved (* the tl operation *)

     focus (* prog after tl *)
    apply(rule hnr_bind )     (* bind Wb3 *)
    focus (* the \<in> operation *)
      apply(rule hnr_frame)
               apply(rule set_mem_hnr')
        apply(simp add: entailst_def)
            apply(rule ent_true_drop(2))
              apply rotater   apply rotatel apply rotatel apply rotatel
          apply(rule isolate_first) apply(simp add: hn_ctxt_def) apply(rule entails_triv)
             apply rotatel apply rotatel apply rotatel
          apply(rule match_first)
              apply (rule entails_triv)
      solved (* the \<in> operation *)

     focus (* prog after \<in> *)
      focus (* the if Block *)
             apply(rule hnr_If')
                apply rotater apply rotatel apply rotatel apply rotatel apply rotatel apply rotatel apply rotatel apply rotatel
                apply(rule isolate_first)
  apply(simp add: hn_ctxt_def Y'_def pure_def   )
                 apply(rule entails_triv)
  apply rotater
            apply(rule ent_true_drop(2))
                apply (rule entails_triv)

      focus (* 1st if-branch (element already in list ) *)
               apply(rule hnr_frame)
                apply(rule hnr_uRETURN_pass)

               apply(simp add: entailst_def)
  apply rotater apply rotatel apply swapl apply swapl
  apply swapl apply swapl  apply swapl apply swapl
               apply swapl apply swapl  apply swapl apply takel apply takel
  apply(rule isolate_first)
                apply(simp add:  gr_def     )
                apply(subst hn_ctxt_prod_split'') prefer 2
  apply(simp add: mult.assoc) apply rotatel
  apply(rule match_first)
                apply(subst hn_ctxt_prod_split'') prefer 2 apply rotatel
  apply(rule match_first) apply(simp add: hn_ctxt_def) apply(rule entails_triv)
  apply simp apply simp
  apply rotater
            apply(rule ent_true_drop(2))
                apply (rule entails_triv)
      solved (* 1st if-branch *)

      focus  (* 2nd if-branch (element should be added ) *)

  apply (rule hnr_bind)
  (* \<rightarrow> add element into Set *)
  apply (rule hnr_frame)
  apply(rule set_ins_hnr')
                apply(simp add: entailst_def)
            apply(rule ent_true_drop(2))
                apply rotater apply rotatel apply rotatel apply rotatel apply rotatel apply rotatel
            apply(rule match_first)
                apply(rule match_first)
                apply (rule entails_triv)

               apply (rule hnr_bind)
  (* \<rightarrow> append element *)

  apply (simp)
  apply (rule hnr_frame)
  apply(rule hnr_cons_rule)
                apply(simp add: entailst_def)
            apply(rule ent_true_drop(2))
                 apply rotater apply taker apply rotatel apply rotatel apply swapl apply swapl
                 apply swapl  apply takel apply (rule isolate_first)
                  apply(simp add: gr_def)  apply (rule match_first)
                  apply (rule entails_triv) apply(rule entails_triv)

  (* \<rightarrow> return result *)
  apply (rule hnr_frame)
                 apply(rule hnr_uRETURN_pass)

               apply(simp add: entailst_def)
            apply(rule ent_true_drop(2))
                apply rotater apply rotatel apply rotatel apply rotatel apply rotatel apply rotatel
                apply swapl   apply swapl apply takel apply takel
                apply (rule isolate_first)
  apply(simp only: gr_def)
                apply(subst hn_ctxt_prod_split'') prefer 2
  apply(simp add: mult.assoc)
  apply(rule match_first)
                apply(subst hn_ctxt_prod_split'') prefer 2
  apply(rule match_first) apply(simp add: hn_ctxt_def) apply(rule entails_triv)
  apply simp apply simp
                apply (rule entails_triv)
               apply rotatel apply rotatel apply rotatel apply rotatel apply rotatel apply rotatel
               apply rotater apply(simp add: mult.assoc)
  apply(rule forward_ent[OF hn_invalid_prod_split]) apply rotatel
               apply(rule forward_ent[OF hn_invalid_prod_split])

  apply(simp add: mult.assoc)
               apply(rule match_first)
  apply rotater
            apply(rule ent_true_drop(2))
               apply(rule entails_triv)

            apply(rule ent_true_drop(2))
  apply rotater
               apply(rule match_first)
      apply(rule entails_triv)
      solved (* 2nd if-branch *)

            apply(rule ent_true_drop(2))
             apply(rule entails_triv)
  solved (* the if Block *)
  solved (* prog after \<in> *)

  focus (* IMP of bind Wb3: merge the heap or *)
          unfolding mult.assoc
            apply(rule addemp_triv)
            apply(rule ent_trans[OF or_merge_rotatel])
  apply(simp only: mult.assoc)
            apply(rule ent_trans[OF or_merge_succ_step])
            apply(rule ent_trans[OF or_merge_succ_step])
            apply(rule ent_trans[OF or_merge_succ_step])
            apply(rule ent_trans[OF or_merge_succ_step])
            apply(rule ent_trans[OF or_merge_rotatel])
            apply(rule ent_trans[OF or_merge_rotater])
  apply(simp only: mult.assoc)
            apply(rule ent_trans[OF or_merge_succ_step])
    (* too lazy here to do the rest *)

  (* TODO: recover xd *)
            apply(rule forward_ent_snd)
             apply(rule ent_trans) apply(rule underA[OF hn_invalid_prod_split])

  apply(simp only: mult.assoc)
             apply(rule addemp_triv)
            apply(rule ent_trans[OF or_merge_succ_step])
            apply(rule forward_ent_snd)
             apply(rule ent_trans) apply(rule underA[OF hn_invalid_prod_split])
              apply(simp add:   invalid_pure_recover')
  apply(rule underB)
              apply(rule addemp_triv) apply rotatel
               apply(rule entails_triv)
  apply(simp only: mult.assoc)
             apply(rule ent_trans[OF or_merge_succ_step])
             apply(rule entails_triv)

            apply(rule forward_ent_snd)
            apply(rule forward_ent_snd)
              apply(rule entails_true)
            apply(rule entails_triv)

            apply rotater
  apply(simp add: gr_def mult.assoc)
            apply(rule isolate_first)
             apply(simp add: hn_ctxt_def pure_def) apply(rule entails_triv)
  apply rotater
  apply rotatel  apply rotatel  apply rotatel  apply rotatel  apply rotatel apply rotatel
            apply(rule ent_true_drop_fst)
            apply(rule ent_true_drop(2))
            apply(rule entails_triv)
  solved (* IMP of bind Wb3: merge the heap or *)
  solved (* prog after tl *)

  focus (* IMP of bind Wb2 *)

  (* after *)
  apply rotater apply rotatel apply rotatel apply rotatel apply rotatel
  apply(rule match_first)
  apply rotater
            apply(rule ent_true_drop(2))
           apply(rule entails_triv)
  solved (* IMP of bind Wb2 *)
  solved (* prog after hd *)

          focus (* IMP of bind Wb1 *)
          unfolding mult.assoc
            apply(rule match_first)
              apply rotater
            apply(rule match_first) apply rotater
          apply rotatel apply rotatel apply(rule match_first)

          apply(rule forward_ent[OF entails_true])
          apply rotater apply(rule isolate_first)
          apply(simp add: hn_ctxt_def) apply(rule entails_triv)

            apply(rule ent_true_drop(2))
          apply(rule entails_triv)
          solved (* IMP of bind Wb1 *)
          solved  (* code *)
          solved  (* post R *)
          focus (* post I *)
            apply rotater apply(rule match_first)
            apply rotater apply rotater apply rotater
              apply(rule addemp_triv) apply rotatel apply(rule match_first)
            apply(rule addemp_triv) apply(rule isolate_first)
            apply(simp add: hn_ctxt_def) apply(rule entails_triv)
              apply(rule ent_true_drop(2))
            apply(rule entails_triv)
          solved (* post I *)
  solved  (* WHILE: the loop body *)
          apply (simp add: entailst_def)
          apply(rule ent_true_drop(2))
          apply (simp add: hn_ctxt_def)
          solved (* the while loop *)

   focus (* finally return result *)

      (* split case_prod *)
      apply(rule hn_case_prod')
      focus (* 1st prod frame *)
           unfolding entailst_def  apply rotatel apply rotatel apply(rule isolate_first)
           apply(rule entails_triv)
                  apply(rule match_rest) apply simp
      solved
      apply(rule hn_refine_cons_post')
      apply(rule hn_case_prod')
      focus (* 2nd prod frame *)
      unfolding entailst_def  apply rotatel apply(rule match_first)
           apply(rule match_rest) apply simp
      solved

      apply(rule hn_refine_cons_post')
       apply(rule hnr_frame)
         apply(rule hnr_uRETURN_pass) unfolding entailst_def mult.assoc
        apply rotater apply(rule isolate_first)
      (* shit happening here *)apply(rule entails_triv)
      apply rotater  apply(rule match_rest) apply simp

      unfolding mult.assoc
       apply rotater apply(rule match_first)
       apply rotatel apply rotatel apply rotatel apply rotatel apply (rule match_first)
       apply rotater  apply rotater apply(rule match_first)
       apply(rule match_rest) apply simp

      apply rotater apply(rule match_first)
      apply rotatel apply rotatel apply (rule match_first)
      apply rotater apply rotater apply (rule match_first)
      apply (rule match_rest) apply simp
  solved (* finally return result *)

      unfolding mult.assoc apply rotater apply (rule match_first)
         apply rotater apply (rule match_rest) apply simp
      apply rotatel
      apply simp
        apply(rule ent_trans[OF hn_invalid_prod_split])
        apply rotater apply(rule match_first)
        apply rotater apply(rule match_rest) apply simp

       apply(rule ent_trans[OF hn_invalid_prod_split])
       apply rotatel apply rotater apply (rule match_first)
       apply rotater apply(rule match_rest) apply simp

      apply rotater
      apply(rule addemp_triv)
      apply rotatel apply(rule match_first)
      apply rotater apply(rule match_rest) apply simp

      done

notepad begin
  fix as :: "nat list"
  let ?P = "\<lambda>as.  ureturn [] \<bind>
                     (\<lambda>x'. tree_empty \<bind>
                           (\<lambda>x'a. ureturn as \<bind>
                                  (\<lambda>x'b. heap_WHILET (\<lambda>s. case s of (a1, a1a, a2a) \<Rightarrow> ureturn 0 \<bind> (\<lambda>x'c. ureturn (length a1) \<bind> (\<lambda>x'd. ureturn (x'c < x'd))))
                                          (\<lambda>s. case s of
                                               (a1, a1a, a2a) \<Rightarrow>
                                                 ureturn (hd a1) \<bind>
                                                 (\<lambda>x'c. ureturn (tl a1) \<bind>
                                                        (\<lambda>x'd. RBTree_Impl.rbt_search x'c a2a \<bind>
                                                               (\<lambda>x'e. if x'e = Some () then ureturn (x'd, a1a, a2a)
                                                                      else RBTree_Impl.rbt_insert x'c () a2a \<bind> (\<lambda>x'f. ureturn (x'c # a1a) \<bind> (\<lambda>x'g. ureturn (x'd, x'g, x'f)))))))
                                          (x'b, x', x'a) \<bind>
                                         (\<lambda>x'c. case x'c of
                                                (a1, a1a, a2a) \<Rightarrow> ureturn a1a))))"

  from   extract_cost_ub[OF hnr_refine[OF rd_impl1_refines rd_hnr, unfolded rd_SPEC_def], where Cost_ub="rd_t (length as)", of as]
  have 1: " <$(rd_t (length as))> ?P as <\<lambda>r. emp * (\<exists>\<^sub>Ara. pure Id ra r * \<up> (ra = remdups' [] as))>\<^sub>t" by simp

  have " <$(rd_t (length as))> ?P as <\<lambda>r. \<up> (r = remdups' [] as)>\<^sub>t" apply(rule post_rule)
    apply(rule 1)
    apply (auto simp add: pure_def)
    by (metis (mono_tags, lifting) entail_equiv_backward entails_ex entails_frame entails_pure)

end

end


theory TermRewrites
  imports Semantics.IRTreeEvalThms Semantics.TreeToGraphThms

begin

(*
typedef Substitution = "{\<sigma> :: string \<Rightarrow> IRExpr option . finite (dom \<sigma>)}"
proof -
  have "finite(dom(Map.empty)) \<and> ran Map.empty = {}" by auto
  then show ?thesis
    by fastforce
qed
*)

fun expr_at_node :: "IRGraph \<Rightarrow> ID \<Rightarrow> IRExpr"
  (infix "@@" 50) where
  "expr_at_node g n = (SOME e . (g \<turnstile> n \<simeq> e))"

lemma expr_at_node: "g \<turnstile> n \<simeq> e \<Longrightarrow> g \<turnstile> n \<simeq> (g @@ n)"
  using expr_at_node.simps repDet
  by (simp add: someI)

lemma graph_refinement:
  "graph_refinement g1 g2 \<Longrightarrow> (\<forall>n m p v. n \<in> ids g1 \<longrightarrow> ([g1, m, p] \<turnstile> n \<mapsto> v) \<longrightarrow> ([g2, m, p] \<turnstile> n \<mapsto> v))"
  unfolding graph_refinement_def expr_at_node.simps
  apply auto[1]
  using expr_at_node.simps encodeeval_def graph_refinement_def le_expr_def
  by (meson term_graph_evaluation)

datatype SubValue = SubExpr(s_expr: IRExpr) | SubConst(s_val: Value)

typedef Substitution = "{s :: String.literal \<rightharpoonup> SubValue . finite (dom s)}"
  using finite_dom_map_of by blast

setup_lifting type_definition_Substitution

lift_definition subst :: "(String.literal \<times> SubValue) list \<Rightarrow> Substitution"
  is "map_of"
  by (simp add: finite_dom_map_of)

lift_definition subst_set :: "Substitution \<Rightarrow> (String.literal \<times> SubValue) set"
  is "Map.graph" .

lemma subst_reconstruct:
  "distinct (map fst x) \<Longrightarrow> set x = subst_set (subst x)"
  by (simp add: graph_map_of_if_distinct_dom subst.rep_eq subst_set.rep_eq)

lift_definition dom :: "Substitution \<Rightarrow> String.literal set"
  is Map.dom .

lift_definition maps_to :: "Substitution \<Rightarrow> String.literal \<Rightarrow> SubValue option"
  is "\<lambda> \<sigma> x . \<sigma> x" .

code_datatype subst Abs_Substitution

lemma dom_code[code]: "dom (subst m) = set (map fst m)"
  by (simp add: dom.rep_eq dom_map_of_conv_image_fst subst.rep_eq)

lemma in_dom: "x \<in> dom \<sigma> \<Longrightarrow> maps_to \<sigma> x \<noteq> None"
  by (simp add: dom.rep_eq domIff maps_to.rep_eq)

fun substitute :: "Substitution \<Rightarrow> IRExpr \<Rightarrow> IRExpr" (infix "$" 60) where
  "substitute \<sigma> (UnaryExpr op e) = UnaryExpr op (\<sigma> $ e)" |
  "substitute \<sigma> (BinaryExpr op e1 e2) = BinaryExpr op (\<sigma> $ e1) (\<sigma> $ e2)" |
  "substitute \<sigma> (ConditionalExpr b e1 e2) = ConditionalExpr (\<sigma> $ b) (\<sigma> $ e1) (\<sigma> $ e2)" |
  "substitute \<sigma> (ParameterExpr i s) = ParameterExpr i s" |
  "substitute \<sigma> (LeafExpr n s) = LeafExpr n s" |
  "substitute \<sigma> (ConstantExpr v) = ConstantExpr v" |
  "substitute \<sigma> (ConstantVar x) =
      (case maps_to \<sigma> x of Some (SubConst v) \<Rightarrow> ConstantExpr v | _ \<Rightarrow> ConstantVar x)" |
  "substitute \<sigma> (VariableExpr x s) =
      (case maps_to \<sigma> x of None \<Rightarrow> (VariableExpr x s) | Some (SubExpr y) \<Rightarrow> y)"

lift_definition union :: "Substitution \<Rightarrow> Substitution \<Rightarrow> Substitution"
  is "\<lambda>\<sigma>1 \<sigma>2. \<sigma>1 ++ \<sigma>2"
  by simp

(*fun union :: "Substitution \<Rightarrow> Substitution \<Rightarrow> Substitution" where
  "union \<sigma>1 \<sigma>2 = Abs_Substitution (\<lambda>name. if maps_to \<sigma>1 name = None then maps_to \<sigma>2 name else maps_to \<sigma>1 name)"
*)

lemma not_empty_has_member:
  assumes "xs \<noteq> []"
  shows "\<exists> k v. List.member xs (k, v)"
  using assms apply (cases xs; auto)
  by (meson member_rec(1))

value "map_of ([(x, xv1), (y, yv)] @ [(z, zv), (x, xv2)]) x"

lemma equal_mapping_implies_equal:
  assumes "\<forall>k. maps_to \<sigma>1 k = maps_to \<sigma>2 k"
  shows "\<sigma>1 = \<sigma>2"
  using assms unfolding maps_to_def using Rep_Substitution
  by (metis Rep_Substitution_inverse ext id_def map_fun_apply)

(*
lemma
  "maps_to (union (subst \<sigma>1) (subst \<sigma>2)) k = maps_to (subst (\<sigma>1 @ \<sigma>2)) k"
  (is "maps_to ?union k = maps_to ?add k")
proof (cases "\<exists> v. List.member \<sigma>1 (k, v)"; cases "\<exists> v. List.member \<sigma>2 (k, v)")
  case True \<comment>\<open>key has mapping in both\<close>
  then show ?thesis sorry
next
  case False \<comment>\<open>key in \<sigma>1 but not \<sigma>2\<close>
  then show ?thesis sorry
next
  \<comment>\<open>key in \<sigma>2 but not \<sigma>1\<close>
  assume a1: "\<nexists>v. List.member \<sigma>1 (k, v)"
  assume a2: "\<exists>v. List.member \<sigma>2 (k, v)"
  obtain v where v: "List.member \<sigma>2 (k, v)"
    using a2 by auto
  from a1 v have "maps_to ?add k = Some v"
    unfolding maps_to_def subst_def using map_of_append sledgehammer
  then show ?thesis sorry
next
  \<comment>\<open>key in neither\<close>
  assume a1: "\<nexists>v. List.member \<sigma>1 (k, v)"
  assume a2: "\<nexists>v. List.member \<sigma>2 (k, v)"
  from a1 a2 have "maps_to ?add k = None"
    by (metis domD in_set_member map_add_dom_app_simps(2) map_of_SomeD map_of_append maps_to.rep_eq opt_to_list.cases option.discI subst.rep_eq)
  then show ?thesis
    by (metis map_add_None map_of_append maps_to.rep_eq subst.rep_eq union.rep_eq)
qed
*)

lemma union_code[code]:
  "union (subst \<sigma>1) (subst \<sigma>2) = (subst (\<sigma>2 @ \<sigma>1))"
  (is "?union = ?add")
  using map_of_append unfolding subst_def union_def
  using subst.abs_eq subst.rep_eq by auto

(*
proof (cases "\<sigma>1 = []")
  case True
  then show ?thesis
    by (metis Rep_Substitution_inverse append.right_neutral append_Nil map_of_append subst.rep_eq union.rep_eq)
next
  case False
  then obtain k v where v: "List.member \<sigma>1 (k, v)"
    using not_empty_has_member by blast
  show ?thesis
  proof (cases "\<exists>v. List.member \<sigma>2 (k, v)")
    case True
    obtain v' where v': "List.member \<sigma>2 (k, v')"
      using True
      by blast
    have rhs: "maps_to (?add) k = Some v"
      using v v' unfolding maps_to_def subst_def sorry
    have lhs: "maps_to (?union) k = Some v"
      sorry
    from lhs rhs have "maps_to (?add) k = maps_to (?union) k"
      sorry
    then show ?thesis using equal_mapping_implies_equal sorry
  next
    case False
    then show ?thesis
      by simp
  qed
qed

  apply (induction \<sigma>1; induction \<sigma>2; auto)
  apply (metis append_Nil map_of_append subst.abs_eq subst.rep_eq)
  apply (metis map_of_append self_append_conv subst.abs_eq subst.rep_eq)
   apply (metis append_Nil map_of_append subst.abs_eq subst.rep_eq)
  sorry
*)

fun compatible :: "Substitution \<Rightarrow> Substitution \<Rightarrow> bool" where
  "compatible \<sigma>1 \<sigma>2 = (\<forall>x \<in> dom \<sigma>1. maps_to \<sigma>2 x \<noteq> None \<longrightarrow> maps_to \<sigma>1 x = maps_to \<sigma>2 x)"

fun substitution_union :: "Substitution option \<Rightarrow> Substitution option \<Rightarrow> Substitution option" (infix "\<uplus>" 70) where
  "substitution_union s1 s2 =
      (case s1 of
       None \<Rightarrow> None |
       Some \<sigma>1 \<Rightarrow>
           (case s2 of
            None \<Rightarrow> None |
            Some \<sigma>2 \<Rightarrow> (if compatible \<sigma>1 \<sigma>2 then Some (union \<sigma>1 \<sigma>2) else None)
           )
      )"

(*lemma "sup x y = x"*)

definition EmptySubstitution :: "Substitution" where
  "EmptySubstitution = subst []"

fun match :: "IRExpr \<Rightarrow> IRExpr \<Rightarrow> Substitution option" where
  "match (UnaryExpr op e) (UnaryExpr op' e') =
      (if op = op' then match e e' else None)" |
  "match (BinaryExpr op e1 e2) (BinaryExpr op' e1' e2') =
      (if op = op' then (match e1 e1') \<uplus> (match e2 e2') else None)" |
  "match (ConditionalExpr b e1 e2) (ConditionalExpr b' e1' e2') =
      (match b b') \<uplus> ((match e1 e1') \<uplus> (match e2 e2'))" |
  "match (ParameterExpr i1 s1) (ParameterExpr i2 s2) =
      (if i1 = i2 \<and> s1 = s2 then Some EmptySubstitution else None)" |
  "match (LeafExpr n1 s1) (LeafExpr n2 s2) =
      (if n1 = n2 \<and> s1 = s2 then Some EmptySubstitution else None)" |
  "match (ConstantExpr v1) (ConstantExpr v2) =
      (if v1 = v2 then Some EmptySubstitution else None)" |
  "match (ConstantVar name) (ConstantExpr v) =
      Some (subst [(name, (SubConst v))])" |
  "match (VariableExpr name s) e =
      Some (subst [(name, (SubExpr e))])" |
  "match _ _ = None"

fun vars :: "IRExpr \<Rightarrow> String.literal fset" where
  "vars (UnaryExpr op e) = vars e" |
  "vars (BinaryExpr op e1 e2) = vars e1 |\<union>| vars e2" |
  "vars (ConditionalExpr b e1 e2) = vars b |\<union>| vars e1 |\<union>| vars e2" |
  "vars (ParameterExpr i s) = {||}" |
  "vars (LeafExpr n s) = {||}" |
  "vars (ConstantExpr v) = {||}" |
  "vars (ConstantVar x) = {|x|}" |
  "vars (VariableExpr x s) = {|x|}"

typedef Rewrite = "{ (e1,e2,cond) :: IRExpr \<times> IRExpr \<times> (Substitution \<Rightarrow> bool) | e1 e2 cond . vars e2 |\<subseteq>| vars e1 }"
proof -
  have "\<exists>v. vars (ConstantExpr v) |\<subseteq>| vars (ConstantExpr v)" by simp
  then show ?thesis
    by blast
qed

setup_lifting type_definition_Rewrite

fun construct_rewrite :: "IRExpr \<times> IRExpr \<times> (Substitution \<Rightarrow> bool) \<Rightarrow> Rewrite option" where
  "construct_rewrite (e1, e2, cond) =
    (if vars e2 |\<subseteq>| vars e1 then Some (Abs_Rewrite (e1, e2, cond)) else None)"

code_datatype Abs_Rewrite

lemma "Abs_Rewrite (Rep_Rewrite r) = r"
  by (simp add: Rep_Rewrite_inverse)

lemma [code]: "Rep_Rewrite (Abs_Rewrite (e1, e2)) = (e1, e2)"
  sorry

fun rewrite :: "Rewrite \<Rightarrow> IRExpr \<Rightarrow> IRExpr option" where
  "rewrite r e = (let (e1,e2,cond) = Rep_Rewrite r in
                   (case match e1 e of
                    Some \<sigma> \<Rightarrow>
                      (if cond \<sigma> then Some (\<sigma> $ e2) else None) |
                    None \<Rightarrow> None))"

definition rewrite_valid :: "Rewrite \<Rightarrow> bool" where
  "rewrite_valid r = (let (e1,e2,cond) = Rep_Rewrite r in
    (\<forall>\<sigma> e. is_ground e \<longrightarrow> match e1 e = Some \<sigma> \<longrightarrow> (e \<ge> (\<sigma> $ e2))))"

definition rewrite_valid_rep :: "IRExpr \<Rightarrow> IRExpr \<Rightarrow> bool" where
  "rewrite_valid_rep e1 e2 = (vars e1 |\<subseteq>| vars e2 \<longrightarrow> (\<forall>\<sigma> e.  match e1 e = Some \<sigma> \<longrightarrow> (e \<ge> (\<sigma> $ e2))))"

definition IntStamp32 :: Stamp where
  "IntStamp32 = IntegerStamp 32 (fst (bit_bounds 32)) (snd (bit_bounds 32))"

fun pattern_depth :: "IRExpr \<Rightarrow> nat" where
  "pattern_depth (UnaryExpr op e) = 1 + pattern_depth e" |
  "pattern_depth (BinaryExpr op e1 e2) = 1 + max (pattern_depth e1) (pattern_depth e2)" |
  "pattern_depth (ConditionalExpr b e1 e2) = 1 + max (pattern_depth b) (max (pattern_depth e1) (pattern_depth e2))" |
  "pattern_depth (ParameterExpr i s) = 1" |
  "pattern_depth (LeafExpr n s) = 1" |
  "pattern_depth (ConstantExpr v) = 1" |
  "pattern_depth (ConstantVar x) = 0" |
  "pattern_depth (VariableExpr x s) = 0"

value "pattern_depth (ConstantExpr (IntVal 32 0))"
value "pattern_depth (VariableExpr (STR ''x'') VoidStamp)"
value "pattern_depth (UnaryExpr UnaryAbs (ConstantExpr (IntVal 32 0)))"
value "pattern_depth (UnaryExpr UnaryAbs (VariableExpr (STR ''x'') VoidStamp))"
value "pattern_depth (UnaryExpr UnaryAbs (UnaryExpr UnaryNot (VariableExpr (STR ''x'') VoidStamp)))"
value "pattern_depth (BinaryExpr BinAdd (UnaryExpr UnaryNot (VariableExpr (STR ''x'') VoidStamp)) (VariableExpr (STR ''x'') VoidStamp))"
value "pattern_depth (BinaryExpr BinAdd (UnaryExpr UnaryNot (ConstantExpr (IntVal 32 0))) (VariableExpr (STR ''x'') VoidStamp))"
value "pattern_depth (BinaryExpr BinAdd (VariableExpr (STR ''x'') VoidStamp) (VariableExpr (STR ''x'') VoidStamp))"

(*fun fresh :: "String.literal \<Rightarrow> IRExpr \<Rightarrow> String.literal" where
  "fresh var e = var"*)

type_synonym VarName = "String.literal"

datatype PatternExpr =
    UnaryPattern IRUnaryOp VarName
  | BinaryPattern IRBinaryOp VarName VarName
  | ConditionalPattern VarName VarName VarName
  | VariablePattern VarName

type_synonym Vars = "VarName fset"

(*
function fresh :: "VarName \<Rightarrow> Vars \<Rightarrow> VarName" where
  "fresh var s = (if var |\<in>| s then fresh (var + (STR ''z'')) s else var)"
   apply force
  by fastforce

lemma fresh_var_code [code]:
  "fresh var s = (if var |\<in>| s then fresh (var + (STR ''z'')) s else (var))"
  sorry
*)

type_synonym Scope = "Vars \<times> (VarName \<Rightarrow> VarName option)"

function fresh :: "VarName \<Rightarrow> Scope \<Rightarrow> Scope \<times> VarName" where
  "fresh var s =
    (if var |\<in>| (fst s) then fresh (var + (STR ''z'')) s else (((fst s) |\<union>| {|var|}, snd s), var))"
   apply force
  by fastforce

lemma fresh_var_code [code]:
  "fresh var s = (if var |\<in>| (fst s) then fresh (var + (STR ''z'')) s else (((fst s) |\<union>| {|var|}, snd s), var))"
  sorry

(*
typedef PatternExpr = "{ e :: IRExpr . pattern_depth e \<le> 1 }"
  by (metis mem_Collect_eq pattern_depth.simps(8) zero_le)

code_datatype Abs_PatternExpr
*)

datatype MATCH =
    match VarName PatternExpr |
    equality VarName VarName ("_ == _") |
    seq MATCH MATCH ("_; _") |
    noop

datatype CODE =
    code MATCH IRExpr ("_ ? _")

type_synonym VariablePairs = "(VarName \<times> VarName) list"

type_synonym Symbols = "VariablePairs \<times> Vars"

value
  "(match (STR ''e'') (BinaryPattern BinAdd (STR ''ea'') (STR ''eb''));
   (match (STR ''ea'') (BinaryPattern BinSub (STR ''eaa'') (STR ''eab''));
   ((STR ''eab'') == (STR ''eb'')))) ? (VariableExpr (STR ''ea'') default_stamp)"

definition var :: "string \<Rightarrow> IRExpr" where
  "var v = (VariableExpr (String.implode v) VoidStamp)"

(*
definition la :: "(VarName \<Rightarrow> 'a) \<Rightarrow> (Vars \<Rightarrow> VarName \<times> Vars) \<Rightarrow> (Vars \<Rightarrow> 'a \<times> Vars)" (infix "\<langle>" 65)
  where
  "la f f' s = (f (fst (f' s)), snd (f' s))"

definition ra :: "(Vars \<Rightarrow> ('b \<Rightarrow> 'a) \<times> Vars) \<Rightarrow> (Vars \<Rightarrow> ('b \<times> Vars)) \<Rightarrow> (Vars \<Rightarrow> 'a \<times> Vars)" (infix "\<rangle>" 60)
  where
  "ra f f' s = ((fst (f s)) (fst (f' s)), snd (f s))"

fun test :: "IRExpr \<Rightarrow> Vars \<Rightarrow> MATCH \<times> Vars" where
  "test (UnaryExpr op e) =
    match \<langle> fresh STR ''e'' \<rangle>
      UnaryPattern op \<langle> fresh STR ''ea''" |
  "test (BinaryExpr op e1 e2) =
    match \<langle> fresh STR ''e'' \<rangle>
      (BinaryPattern op \<langle> fresh STR ''ea'' \<rangle> (fresh STR ''eb''))" |
  "test (ConditionalExpr b e1 e2) =
    match \<langle> fresh STR ''e'' \<rangle>
      ((ConditionalPattern \<langle> fresh STR ''ea'' \<rangle> (fresh STR ''eb'')) \<rangle> (fresh STR ''ec''))"
*)

definition la :: "('b \<Rightarrow> 'a) \<Rightarrow> (Scope \<Rightarrow> Scope \<times> 'b) \<Rightarrow> (Scope \<Rightarrow> Scope \<times> 'a)" (infix "\<langle>" 65)
  where
  "la f f' s = (fst (f' s), f (snd (f' s)))"

(*
definition ra :: "('b \<Rightarrow> 'a) \<Rightarrow> (Scope \<Rightarrow> Scope \<times> 'b) \<Rightarrow> (Scope \<Rightarrow> Scope \<times> 'a)" (infix "\<rangle>" 54)
  where
  "ra f f' s = ((fst (f' (s))), f (snd (f' s)))"
*)

definition ra :: "(Scope \<Rightarrow> Scope \<times> ('b \<Rightarrow> 'a)) \<Rightarrow> (Scope \<Rightarrow> Scope \<times> 'b) \<Rightarrow> (Scope \<Rightarrow> Scope \<times> 'a)" (infix "\<rangle>" 54)
  where
  "ra f f' s = ((fst (f' (fst (f s)))), (snd (f s)) (snd (f' (fst (f s)))))"

definition join :: "('b \<Rightarrow> 'c \<times> MATCH) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> 'a \<times> MATCH) \<Rightarrow> 'b \<Rightarrow> 'a \<times> MATCH" (infix "|>" 53) where
  "join x y s =
    (let (lhs_scope, lhs_match) = x s in
    (let (rhs_scope, rhs_match) = (y s lhs_scope) in
    (rhs_scope, (lhs_match; rhs_match))))"

abbreviation decend where
  "decend f e v \<equiv> (\<lambda>s s'. f e (snd (fresh v s)) s')"

value "match \<langle> fresh STR ''e''"

fun register_name where
  "register_name (s, m) vn v = (s, m(vn:=Some v))"

fun match_pattern :: "IRExpr \<Rightarrow> VarName \<Rightarrow> Scope \<Rightarrow> Scope \<times> MATCH" where
  "match_pattern (UnaryExpr op e) v =
    match v \<langle>
      (UnaryPattern op \<langle> fresh STR ''a'')
    |> decend match_pattern e STR ''a''
    " |
  "match_pattern (BinaryExpr op e1 e2) v =
    (match v \<langle>
      (BinaryPattern op \<langle> fresh STR ''a'' \<rangle> fresh STR ''b'')
    |> decend match_pattern e1 STR ''a'')
    |> decend match_pattern e2 STR ''b''" |
  "match_pattern (ConditionalExpr b e1 e2) v =
    ((match v \<langle>
      ((ConditionalPattern \<langle> fresh STR ''a'' \<rangle> fresh STR ''b'') \<rangle> fresh STR ''c'')
    |> decend match_pattern b STR ''a'')
    |> decend match_pattern e1 STR ''b'')
    |> decend match_pattern e2 STR ''c''" |
  "match_pattern (VariableExpr vn st) v =
    (\<lambda>s. (case (snd s) vn of
      None \<Rightarrow> (register_name s vn v, noop) |
      Some v' \<Rightarrow> (register_name s vn v, v' == v)))"

fun expr_result :: "IRExpr \<Rightarrow> Scope \<Rightarrow> IRExpr" where
  "expr_result (UnaryExpr op e) s =
    UnaryExpr op (expr_result e s)" |
  "expr_result (BinaryExpr op e1 e2) s =
    BinaryExpr op (expr_result e1 s) (expr_result e2 s)" |
  "expr_result (ConditionalExpr b e1 e2) s =
    ConditionalExpr (expr_result b s) (expr_result e1 s) (expr_result e2 s)" |
  "expr_result (VariableExpr vn st) (s, m) =
    (case m vn of None \<Rightarrow> VariableExpr vn st
                | Some v' \<Rightarrow> VariableExpr v' st)" |
  "expr_result e v = e"

fun generate :: "IRExpr \<Rightarrow> IRExpr \<Rightarrow> MATCH \<times> IRExpr" where
  "generate p r =
    (let (s, m) = match_pattern p STR ''e'' ({||}, (\<lambda>x. None))
     in (m, expr_result r s))"

value
  "generate
    (UnaryExpr UnaryNot
      (UnaryExpr UnaryNot (var ''x'')))
    (var ''x'')"

value
  "generate
    (BinaryExpr BinAdd
      (BinaryExpr BinSub (var ''x'') (var ''y''))
      (var ''y''))
    (var ''x'')"

code_printing
  type_constructor MATCH \<rightharpoonup> (Scala) "MATCH"
  | constant match \<rightharpoonup> (Scala) "match"
  | constant seq \<rightharpoonup> (Scala) "seq"
  | constant noop \<rightharpoonup> (Scala) "noop"
  | constant equality \<rightharpoonup> (Scala) "=="

definition redundant_sub where
  "redundant_sub = generate
    (BinaryExpr BinAdd
      (BinaryExpr BinSub (var ''x'') (var ''y''))
      (var ''y''))
    (var ''x'')"

definition redundant_sub_gen where
  "redundant_sub_gen = ((((MATCH.match STR ''e''
   (BinaryPattern BinAdd STR ''a''
     STR ''b''); MATCH.match STR ''a''
                  (BinaryPattern BinSub STR ''az'' STR ''bz'')); noop); noop); STR ''bz'' == STR ''b'',
  VariableExpr STR ''az'' VoidStamp)"

export_code redundant_sub in Scala
export_code redundant_sub_gen in Scala

(*
fun generate :: "Vars \<Rightarrow> IRExpr \<times> IRExpr \<times> (Substitution \<Rightarrow> bool) \<Rightarrow> MATCH" where
  "generate s (UnaryExpr op e, e', f) =
    (let
      used = s |\<union>| {|(fresh (STR ''e'') s), (fresh (STR ''ea'') s)|}
     in
        ((match (fresh (STR ''e'') s) (UnaryPattern op (fresh (STR ''ea'') s)));
        (generate used (e, e', f))))" |
  "generate s (BinaryExpr op e1 e2, e', f) =
    (let
      used = (s |\<union>| {|(fresh STR ''e'' s), (fresh STR ''ea'' s), (fresh STR ''eb'' s)|})
     in
        (((match (fresh STR ''e'' s)
            (BinaryPattern op (fresh (STR ''ea'') s) (fresh (STR ''eb'') s)));
        (generate used (e1, e', f)));
        (generate used (e2, e', f))))" |
  "generate s (ConditionalExpr b e1 e2, e', f) =
    (let
      used = (s |\<union>| {|(fresh STR ''e'' s), (fresh STR ''ea'' s), (fresh STR ''eb'' s), (fresh STR ''ec'' s)|})
     in
        (((match (fresh STR ''e'' s)
              (ConditionalPattern (fresh (STR ''ea'') s) (fresh (STR ''eb'') s) (fresh (STR ''ec'') s)));
          ((generate used (b, e', f));
          ((generate used (e1, e', f));
           (generate used (e2, e', f)))))))" |
  "generate s (e, e', f) = match (fresh STR ''e'' s) (VariablePattern STR ''e'')"

value "generate {||} (BinaryExpr BinAdd (var ''x'') (var ''y''), var ''x'', \<lambda>x. True)"

value
  "generate {||}
    (BinaryExpr BinAdd
      (BinaryExpr BinSub x y)
       y,
     x, \<lambda>x. True)"

value
  "generate {||}
    (BinaryExpr BinAdd
      (BinaryExpr BinSub (var ''x'') (var ''y''))
      (var ''y''),
     (var ''x''), \<lambda>x. True)"

fun replace :: "MatchRules \<Rightarrow> IRExpr \<Rightarrow> IRExpr option" where
  "replace (match_pattern p) e = (if (match (Rep_PatternExpr p) e \<noteq> None) then Some e else None) " |
  "replace (ground g) e = Some g" |
  "replace (conditional c t f) e = (if (replace c e) \<noteq> None then (replace t e) else (replace f e))" |
  "replace (fail) e = None"

(*
  "generate (ConditionalExpr b e1 e2) = 1 + max (pattern_depth b) (max (pattern_depth e1) (pattern_depth e2))" |
  "generate (ParameterExpr i s) = 1" |
  "generate (LeafExpr n s) = 1" |
  "generate (ConstantExpr v) = 1" |
  "generate (ConstantVar x) = 0" |
  "generate (VariableExpr x s) = 0"*)
code_datatype Abs_PatternExpr
code_datatype Abs_GroundExpr

value "generate {} ( (VariableExpr (STR ''x'') VoidStamp), (ConstantExpr (IntVal 32 0)), \<lambda>_.True)"
(*
value "replace (generate ( (VariableExpr (STR ''x'') VoidStamp), (ConstantExpr (IntVal32 0)), \<lambda>_.True)) (ConstantExpr (IntVal32 0))"
*)

value "generate ((ConstantExpr (IntVal 32 0)), (ConstantExpr (IntVal 32 0)), \<lambda>_.True)"
value "generate ((UnaryExpr UnaryAbs (ConstantExpr (IntVal 32 0))), (ConstantExpr (IntVal 32 0)), \<lambda>_.True)"
value "generate ((UnaryExpr UnaryAbs (VariableExpr (STR ''x'') VoidStamp)), (ConstantExpr (IntVal 32 0)), \<lambda>_.True)"

(*
definition f where "f = generate ((BinaryExpr BinAnd
    (BinaryExpr BinOr (VariableExpr STR ''x'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1))))
      (VariableExpr STR ''y'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1)))))
    (VariableExpr STR ''z'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1))))),
   (BinaryExpr BinAnd (VariableExpr STR ''x'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1))))
    (VariableExpr STR ''z'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1))))), (\<lambda>_.True))"

export_code f in SML
value "f"*)

definition example_rewrite :: Rewrite where
  "example_rewrite = TermRewrites.Rewrite.Abs_Rewrite
  (BinaryExpr BinAnd
    (BinaryExpr BinOr (VariableExpr STR ''x'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1))))
      (VariableExpr STR ''y'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1)))))
    (VariableExpr STR ''z'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1)))),
   BinaryExpr BinAnd (VariableExpr STR ''x'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1))))
    (VariableExpr STR ''z'' (IntegerStamp 1 (fst (bit_bounds 1)) (snd (bit_bounds 1)))),
   \<lambda>x. True)"

lift_definition generate_rewrite :: "Rewrite \<Rightarrow> MatchRules"
  is generate .

value "generate_rewrite example_rewrite"

experiment begin
lemma match_succeeds:
  assumes "match e1 e = Some \<sigma>"
  shows "\<sigma> $ e1 = e"
  and "fset (vars e1) = dom \<sigma>"
  using assms
   apply (induct e1 e arbitrary: \<sigma> rule: match.induct; auto)
                 apply (meson option.distinct(1))+
  sorry

definition isIntExpr :: "IRExpr \<Rightarrow> bool" where
  "isIntExpr e = (\<forall>m p v. ([m, p] \<turnstile> e \<mapsto> v) \<longrightarrow> is_IntVal v)"

lemma int_add_preserve:
  assumes "isIntExpr ex"
  assumes "isIntExpr ey"
  shows "isIntExpr (BinaryExpr BinAdd ex ey)"
  sorry

lemma valid_constant: "valid_value (IntVal 32 v) (constantAsStamp (IntVal 32 v))"
  sorry

lemma int_constant: "isIntExpr (ConstantExpr (IntVal 32 v))"
  sorry

lemma "isIntExpr e \<Longrightarrow> (\<exists>v. \<forall>m p. [m, p] \<turnstile> e \<mapsto> IntVal 32 v)"
  sorry

lemma var_x:
  assumes "\<forall>e \<sigma>. match (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))) e = Some \<sigma>"
  shows "STR ''x'' |\<in>| vars (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0)))"
    using vars.simps by simp

lemma domx:
  assumes "match (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))) e = Some \<sigma>"
  shows "STR ''x'' \<in> dom \<sigma>"
    using match_succeeds(2) var_x sorry(*
    by (metis assms insertI1 insert_is_Un vars.simps(2) vars.simps(8))*)

lemma zero_helper_x:
  assumes "match (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))) e = Some \<sigma>"
  shows "maps_to \<sigma> STR ''x'' \<noteq> None"
  using domx in_dom assms by presburger

lemma zero_identity:
  "rewrite_valid_rep (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0)))
                     (VariableExpr STR ''x'' IntStamp32)"
proof -
  have pv: "\<forall>vx. intval_add (IntVal 32 vx) (IntVal 32 0) = IntVal 32 vx"
    using intval_add.simps
    using valid_constant by auto
  have vvx: "valid_value (IntVal 32 0) (constantAsStamp (IntVal 32 0))"
    using valid_constant by blast
  have eval0: "\<forall>m p. [m, p] \<turnstile> ConstantExpr (IntVal 32 0) \<mapsto> (IntVal 32 0)"
    using ConstantExpr vvx
    using wf_value_def by blast
  have eval_add: "\<forall>ex. isIntExpr ex \<longrightarrow>
    (\<forall>m p vx. ([m, p] \<turnstile> ex \<mapsto> IntVal 32 vx) \<longrightarrow>
      ([m, p] \<turnstile> BinaryExpr BinAdd ex (ConstantExpr (IntVal 32 0)) \<mapsto> (IntVal 32 vx)))"
    by (metis BinaryExpr Value.distinct(1) bin_eval.simps(1) eval0 pv)
  have add_eval: "\<forall>ex. isIntExpr ex \<longrightarrow>
      (\<forall>m p v. ([m, p] \<turnstile> BinaryExpr BinAdd ex (ConstantExpr (IntVal 32 0)) \<mapsto> v) \<longrightarrow>
               [m, p] \<turnstile> ex \<mapsto> v)"
    using eval_add evalDet sorry
  have add_refine: "\<forall>ex. isIntExpr ex \<longrightarrow>
      BinaryExpr BinAdd ex (ConstantExpr (IntVal 32 0)) \<ge> ex"
    unfolding le_expr_def
    using add_eval by blast
  have add_refine_substit: "\<forall>\<sigma> ex. \<sigma> STR ''x'' = SubExpr ex \<and> isIntExpr ex \<longrightarrow>
        BinaryExpr BinAdd ex (ConstantExpr (IntVal 32 0)) \<ge> ex"
    using add_refine by blast
  have add_substit: "\<forall>\<sigma> ex. maps_to \<sigma> STR ''x'' = Some (SubExpr ex) \<and> isIntExpr ex \<longrightarrow>
        \<sigma> $ (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))) \<ge> ex"
    using add_refine_substit by fastforce
  have match_e: "\<forall>e \<sigma>. match (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))) e = (Some \<sigma>) \<longrightarrow>
         (e = \<sigma> $ (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))))"
    using match_succeeds match.simps(7) by presburger
  have v: " vars (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))) |\<subseteq>| vars (VariableExpr STR ''x'' IntStamp32)"
    using vars.simps  by simp
  have "\<forall>\<sigma> e. vars (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))) |\<subseteq>| vars (VariableExpr STR ''x'' IntStamp32) \<longrightarrow>
        match (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))) e = Some \<sigma> \<longrightarrow>
        \<sigma> $ VariableExpr STR ''x'' IntStamp32 \<le> e"
    apply simp
    using match_e add_substit  sorry
  have dom: "\<forall>e \<sigma>. match (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0))) e = Some \<sigma> \<longrightarrow>
            fset (vars (BinaryExpr BinAdd (VariableExpr STR ''x'' IntStamp32) (ConstantExpr (IntVal 32 0)))) \<subseteq> dom \<sigma>"
    using match_succeeds by (metis dual_order.refl)

  show ?thesis
    unfolding rewrite_valid_rep_def
    sorry
qed
end
*)

end