(* Title: thys/Abacus_Hoare.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
   Modifications: Franz Regensburger (FABR) 04/2022
      added comments and lemmas for clarification
 *)

section \<open>Hoare Rules for Abacus Programs\<close>

theory Abacus_Hoare
  imports Abacus
begin

type_synonym abc_assert = "nat list \<Rightarrow> bool"

definition
  assert_imp :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" ("_ \<mapsto> _" [0, 0] 100)
  where
    "assert_imp P Q \<equiv> \<forall>xs. P xs \<longrightarrow> Q xs"

fun abc_holds_for :: "(nat list \<Rightarrow> bool) \<Rightarrow> (nat \<times> nat list) \<Rightarrow> bool" ("_ abc'_holds'_for _" [100, 99] 100)
  where
    "P abc_holds_for (s, lm) = P lm"

(* Hoare Rules *)
(* halting case *)
(*consts abc_Hoare_halt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> abc_assert \<Rightarrow> bool" ("(\<lbrace>(1_)\<rbrace>/ (_)/ \<lbrace>(1_)\<rbrace>)" 50)*)

fun abc_final :: "(nat \<times> nat list) \<Rightarrow> abc_prog \<Rightarrow> bool"
  where
    "abc_final (s, lm) p = (s = length p)"

fun abc_notfinal :: "abc_conf \<Rightarrow> abc_prog \<Rightarrow> bool"
  where
    "abc_notfinal (s, lm) p = (s < length p)"

(* SPIKE: added by FABR:

  The definitions for abc_final and abc_notfinal are somewhat surprising.
  It is easy to build an abacus program p that jumps to a state length p < s

  Thus, there are programs, that may reach a configuration that is neither abc_final nor abc_notfinal.

  We add a definition abc_out_of_prog and provide a witness for our conjecture.

 *)

fun abc_out_of_prog :: "abc_conf \<Rightarrow> abc_prog \<Rightarrow> bool"
  where
    "abc_out_of_prog (s, lm) p = (length p < s)"

definition abcP_out_of_pgm_ex :: abc_prog
  where
   "abcP_out_of_pgm_ex = [Dec 0 41, Inc 1, Goto 0]"

(* ABC program abcP_out_of_pgm_ex can reach state 41, which is out of program *)

lemma "abc_steps_l (0,[5,3]) abcP_out_of_pgm_ex (10 +6) = (41, [0, 8])"
  by (simp add: abc_steps_l.simps abc_step_l.simps abc_fetch.simps abc_lm_v.simps abc_lm_s.simps
                numeral_eqs_upto_12
                abcP_out_of_pgm_ex_def )

lemma "abc_out_of_prog (abc_steps_l (0,[5,3]) abcP_out_of_pgm_ex (10 +6)) abcP_out_of_pgm_ex"
  by (simp add: abc_steps_l.simps abc_step_l.simps abc_fetch.simps  abc_lm_v.simps abc_lm_s.simps
                numeral_eqs_upto_12
                abcP_out_of_pgm_ex_def )

(* From the properties abc_notfinal cf p, abc_final cf p, abc_out_of_prog cf holds
 *   always one of these exlusively holds (the other two are ruled out)
 *)

lemma "abc_notfinal cf p \<or> abc_final cf p \<or> abc_out_of_prog cf p"
  by (metis (full_types) abc_final.elims(3) abc_notfinal.elims(3) abc_out_of_prog.elims(3)  not_less_iff_gr_or_eq prod.sel(1))

lemma "\<lbrakk> length p \<noteq> 0; abc_notfinal cf p \<rbrakk> \<Longrightarrow> \<not> abc_final cf p \<and> \<not> abc_out_of_prog cf p"
  by (metis abc_final.simps abc_notfinal.elims(2) abc_out_of_prog.simps less_Suc_eq nat_neq_iff not_less_eq)

lemma "\<lbrakk> length p \<noteq> 0; abc_final cf p \<rbrakk> \<Longrightarrow> \<not> abc_notfinal cf p \<and> \<not> abc_out_of_prog cf p"
  by (metis abc_final.elims(2) abc_final.simps abc_notfinal.elims(2) abc_out_of_prog.simps nat_neq_iff)

lemma "\<lbrakk> length p \<noteq> 0; abc_out_of_prog cf p \<rbrakk> \<Longrightarrow> \<not> abc_notfinal cf p \<and> \<not> abc_final cf p"
  by (metis abc_final.simps abc_notfinal.simps abc_out_of_prog.simps less_iff_Suc_add less_imp_add_positive less_not_refl not_less_eq old.prod.exhaust)

(* END SPIKE: added by FABR *)

definition
  abc_Hoare_halt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> abc_assert \<Rightarrow> bool" ("(\<lbrace>(1_)\<rbrace>/ (_)/ \<lbrace>(1_)\<rbrace>)" 50)
  where
    "abc_Hoare_halt P p Q \<equiv> \<forall>lm. P lm \<longrightarrow> (\<exists>n. abc_final (abc_steps_l (0, lm) p n) p \<and> Q abc_holds_for (abc_steps_l (0, lm) p n))"

lemma abc_Hoare_haltI:
  assumes "\<And>lm. P lm \<Longrightarrow> \<exists>n. abc_final (abc_steps_l (0, lm) p n) p \<and> Q abc_holds_for (abc_steps_l (0, lm) p n)"
  shows " \<lbrace>P\<rbrace> (p::abc_prog) \<lbrace>Q\<rbrace> "
  unfolding abc_Hoare_halt_def
  using assms by auto

(*
  \<lbrace>P\<rbrace> A \<lbrace>Q\<rbrace>   \<lbrace>Q\<rbrace> B \<lbrace>S\<rbrace>
  -----------------------------------------
  \<lbrace>P\<rbrace> A [+] B \<lbrace>S\<rbrace>
*)

(* Added by FABR for clarification and presentation in classes *)

fun app_mopup :: "tprog0 \<Rightarrow> nat \<Rightarrow> tprog0"
  where
    "app_mopup tp n = tp @ shift (mopup_n_tm n) (length tp div 2)"

lemma compile_correct_halt_2:
  assumes compile: "tp = tm_of ap"
    and abc_halt: "abc_steps_l (0, ns) ap stp = (length ap, am)"
    and rs_loc: "n < length am"
  shows "\<exists>stp i j. steps0 (Suc 0, [Bk,Bk], <ns::nat list>) (app_mopup tp n) stp = (0, Bk\<up>i, <abc_lm_v am n> @ Bk\<up>j)"
proof -
  have crsp: "crsp (layout_of ap) (0, ns) (Suc 0, [Bk,Bk], <ns::nat list>) []"
    by (auto simp add: start_of.simps crsp.simps)
  with assms have "\<exists> stp i j. steps (Suc 0, [Bk,Bk], <ns::nat list>) (tp @ shift (mopup_n_tm n) (length tp div 2), 0) stp
                     = (0, Bk\<up>i @ Bk # Bk # [], Oc\<up>Suc (abc_lm_v am n) @ Bk\<up>j)"
    using compile_correct_halt by simp
  then have "\<exists>stp i j. steps (Suc 0, [Bk,Bk], <ns::nat list>) (tp @ shift (mopup_n_tm n) (length tp div 2), 0) stp
                     = (0, Bk\<up>i, Oc\<up>Suc (abc_lm_v am n) @ Bk\<up>j)"
    by (metis replicate_app_Cons_same replicate_append_same take_suc)
  then show ?thesis
    by (simp add: tape_of_nat_def)
qed

lemma compile_correct_halt_3:
  assumes compile: "tp = tm_of ap"
    and abc_halt: "abc_steps_l (0, ns) ap stp = (length ap, am)"
    and rs_loc: "n < length am"
  shows "\<exists>stp i j. steps0 (Suc 0, [], <ns::nat list>) (app_mopup tp n) stp = (0, Bk\<up>i, <abc_lm_v am n> @ Bk\<up>j)"
  using steps_left_tape_ShrinkBkCtx_to_NIL compile_correct_halt_2
  by (metis abc_halt compile replicate_Suc replicate_once rs_loc take_suc)

lemma compile_correct_halt_4:
  assumes compile: "tp = tm_of ap"
    and abc_halt: "abc_steps_l (0, ns) ap stp = (length ap, am)"
    and rs_loc: "n < length am"
  shows "TMC_yields_num_res (app_mopup tp n) ns (abc_lm_v am n)"
  unfolding TMC_yields_num_res_def
  using compile_correct_halt_3
  by (metis One_nat_def abc_halt compile rs_loc)

(* Abacus program ap executed with initial memory ns yields result n in register r *)

definition ABC_yields_res :: "abc_prog \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "ABC_yields_res ap ns n r \<equiv>
           (\<exists>stp am.  abc_steps_l (0, ns) ap stp = (length ap, am) \<and>
                       r < length am \<and> (abc_lm_v am r = n))"

definition ABC_loops_on :: "abc_prog \<Rightarrow> nat list \<Rightarrow>  bool"
  where "ABC_loops_on ap ns \<equiv>
          \<forall>stp. abc_notfinal (abc_steps_l (0, ns) ap stp) ap"

theorem ABC_yields_res_imp_TMC_yields_num_res:
  assumes "tp = tm_of ap"
    and   "ABC_yields_res ap ns n r"
  shows   "TMC_yields_num_res (app_mopup tp r) ns n"
proof -
  from \<open>ABC_yields_res ap ns n r\<close>
  have "\<exists>stp am. abc_steps_l (0, ns) ap stp = (length ap, am) \<and>
                 r < length am \<and> (abc_lm_v am r = n)"
    unfolding ABC_yields_res_def
    by auto
  then obtain stp am where
    w_stp_am: "abc_steps_l (0, ns) ap stp = (length ap, am) \<and>
               r < length am \<and> (abc_lm_v am r = n)" by blast
  have "TMC_yields_num_res (app_mopup tp r) ns (abc_lm_v am r)"
  proof (rule compile_correct_halt_4)
    from assms show "tp = tm_of ap" by auto
  next
    from w_stp_am
    show "r < length am"
      by auto
  next
    from w_stp_am
    show "abc_steps_l (0, ns) ap stp = (length ap, am)"
      by auto
  qed
  with w_stp_am  show "TMC_yields_num_res (app_mopup tp r) ns n" by auto
qed

lemma abc_unhalt_2:
  assumes compile: "tp = tm_of ap"
  and notfinal: "\<forall>stp. abc_notfinal (abc_steps_l (0, ns) ap stp) ap"
shows "\<forall>stp.\<not> is_final (steps0 (Suc 0, [Bk,Bk], <ns::nat list>) (app_mopup tp r) stp)"
proof -
  have "\<forall>stp.\<not> is_final (steps (1, [Bk,Bk], <ns::nat list>) (tp @ shift (mopup_n_tm r) (length tp div 2), 0) stp)"
  proof (rule  compile_correct_unhalt)
    show "layout_of ap = layout_of ap" by auto
  next
    from compile show "tp = tm_of ap" by auto
  next
    show "length tp div 2 = length tp div 2" by auto
  next
    show "crsp (layout_of ap) (0, ns) (1, [Bk, Bk], <ns::nat list>) []"
      by (auto simp add: start_of.simps crsp.simps)
  next
    from notfinal show " \<forall>stp. case abc_steps_l (0, ns) ap stp of (as, am) \<Rightarrow> as < length ap"
      by (metis abc_notfinal.elims(2) case_prodI2 prod.sel(1))
  qed
  then show ?thesis by auto
qed

theorem ABC_loops_imp_TMC_loops:
  assumes "tp = tm_of ap"
    and   "ABC_loops_on ap ns"
  shows   "TMC_loops (app_mopup tp r) ns"
proof -
  have "\<forall>stp.\<not> is_final (steps0 (Suc 0, [Bk,Bk], <ns::nat list>) (app_mopup tp r) stp)"
  proof (rule abc_unhalt_2)
    from \<open>tp = tm_of ap\<close>
    show "tp = tm_of ap" by auto
  next
    from \<open>ABC_loops_on ap ns\<close>
    show "\<forall>stp. abc_notfinal (abc_steps_l (0, ns) ap stp) ap"
      unfolding ABC_loops_on_def by auto
  qed
  have "\<forall>stp. \<not> is_final (steps0 (Suc 0, [], <ns>) (app_mopup tp r) stp)"
  proof
    fix stp
    show "\<not> is_final (steps0 (Suc 0, [], <ns>) (app_mopup tp r) stp)"
    proof
      assume "is_final (steps0 (Suc 0, [], <ns>) (app_mopup tp r) stp)"
      then have "\<exists>ltap rtap. steps0 (Suc 0, Bk \<up>0, <ns>) (app_mopup tp r) stp = (0, ltap, rtap)"
        using is_final.elims(2) replicate_empty by fastforce
      then obtain ltap rtap where
        "steps0 (Suc 0, Bk \<up>0, <ns>) (app_mopup tp r) stp = (0, ltap, rtap)" by blast
      then have   "\<exists>z3. z3 \<le> 0 + 2 \<and>
        steps0 (Suc 0, Bk\<up>(0 + 2), <ns>)  (app_mopup tp r) stp = (0,ltap @ Bk\<up>z3 ,rtap)"
        using steps_left_tape_EnlargeBkCtx_arbitrary_CL
        by (metis add.left_neutral add_2_eq_Suc' append_Nil)
      then have "is_final (steps0 (Suc 0, [Bk,Bk], <ns>) (app_mopup tp r) stp)"
        using One_nat_def add_2_eq_Suc' add_Suc_shift is_finalI length_replicate list.size(3)
          list.size(4) plus_1_eq_Suc replicate_Suc replicate_once by force
      with \<open>\<forall>stp. \<not> is_final (steps0 (Suc 0, [Bk, Bk], <ns>) (app_mopup tp r) stp)\<close>
      show False by auto
    qed
  qed
  then show "TMC_loops (app_mopup tp r) ns"
    unfolding TMC_loops_def
    by simp
qed

(* END Added by FABR for clarification and presentation in classes *)

definition
  abc_Hoare_unhalt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> bool" ("(\<lbrace>(1_)\<rbrace>/ (_)) \<up>" 50)
  where
    "abc_Hoare_unhalt P p \<equiv> \<forall>args. P args \<longrightarrow> (\<forall>n. abc_notfinal (abc_steps_l (0, args) p n) p)"

lemma abc_Hoare_unhaltI:
  assumes "\<And>args n. P args \<Longrightarrow> abc_notfinal (abc_steps_l (0, args) p n) p"
  shows "\<lbrace>P\<rbrace> (p::abc_prog) \<up>"
  unfolding abc_Hoare_unhalt_def
  using assms by auto

fun abc_inst_shift :: "abc_inst \<Rightarrow> nat \<Rightarrow> abc_inst"
  where
    "abc_inst_shift (Inc m) n = Inc m" |
    "abc_inst_shift (Dec m e) n = Dec m (e + n)" |
    "abc_inst_shift (Goto m) n = Goto (m + n)"

fun abc_shift :: "abc_inst list \<Rightarrow> nat \<Rightarrow> abc_inst list"
  where
    "abc_shift xs n = map (\<lambda> x. abc_inst_shift x n) xs"

fun abc_comp :: "abc_inst list \<Rightarrow> abc_inst list \<Rightarrow>
                           abc_inst list" (infixl "[+]" 99)
  where
    "abc_comp al bl = (let al_len = length al in
                           al @ abc_shift bl al_len)"

lemma abc_comp_first_step_eq_pre:
  "s < length A
 \<Longrightarrow> abc_step_l (s, lm) (abc_fetch s (A [+] B)) =
    abc_step_l (s, lm) (abc_fetch s A)"
  by(simp add: abc_step_l.simps abc_fetch.simps nth_append)

lemma abc_before_final:
  "\<lbrakk>abc_final (abc_steps_l (0, lm) p n) p; p \<noteq> []\<rbrakk>
  \<Longrightarrow> \<exists> n'. abc_notfinal (abc_steps_l (0, lm) p n') p \<and>
            abc_final (abc_steps_l (0, lm) p (Suc n')) p"
proof(induct n)
  case 0
  thus "?thesis"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: " \<lbrakk>abc_final (abc_steps_l (0, lm) p n) p; p \<noteq> []\<rbrakk> \<Longrightarrow>
    \<exists>n'. abc_notfinal (abc_steps_l (0, lm) p n') p \<and> abc_final (abc_steps_l (0, lm) p (Suc n')) p"
    by fact
  have final: "abc_final (abc_steps_l (0, lm) p (Suc n)) p" by fact
  have notnull: "p \<noteq> []" by fact
  show "?thesis"
  proof(cases "abc_final (abc_steps_l (0, lm) p n) p")
    case True
    have "abc_final (abc_steps_l (0, lm) p n) p" by fact
    then have "\<exists>n'. abc_notfinal (abc_steps_l (0, lm) p n') p \<and> abc_final (abc_steps_l (0, lm) p (Suc n')) p"
      using ind notnull
      by simp
    thus "?thesis"
      by simp
  next
    case False
    have "\<not> abc_final (abc_steps_l (0, lm) p n) p" by fact
    from final this have "abc_notfinal (abc_steps_l (0, lm) p n) p"
      by(case_tac "abc_steps_l (0, lm) p n", simp add: abc_step_red2
          abc_step_l.simps abc_fetch.simps split: if_splits)
    thus "?thesis"
      using final
      by(rule_tac x = n in exI, simp)
  qed
qed

lemma abc_comp_first_steps_eq_pre:
  assumes notfinal: "abc_notfinal (abc_steps_l (0, lm)  A n) A"
    and notnull: "A \<noteq> []"
  shows "abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
  using notfinal
proof(induct n)
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: "abc_notfinal (abc_steps_l (0, lm) A n) A \<Longrightarrow> abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
    by fact
  have h: "abc_notfinal (abc_steps_l (0, lm) A (Suc n)) A" by fact
  then have a: "abc_notfinal (abc_steps_l (0, lm) A n) A"
    by(simp add: notfinal_Suc)
  then have b: "abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
    using ind by simp
  obtain s lm' where c: "abc_steps_l (0, lm) A n = (s, lm')"
    by (metis prod.exhaust)
  then have d: "s < length A \<and> abc_steps_l (0, lm) (A [+] B) n = (s, lm')"
    using a b by simp
  thus "?case"
    using c
    by(simp add: abc_step_red2 abc_fetch.simps abc_step_l.simps nth_append)
qed

declare abc_shift.simps[simp del] abc_comp.simps[simp del]
lemma halt_steps2: "st \<ge> length A \<Longrightarrow> abc_steps_l (st, lm) A stp = (st, lm)"
  apply(induct stp)
  by(simp_all add: abc_step_red2 abc_steps_l.simps abc_step_l.simps abc_fetch.simps)

lemma halt_steps: "abc_steps_l (length A, lm) A n = (length A, lm)"
  apply(induct n, simp add: abc_steps_l.simps)
  apply(simp add: abc_step_red2 abc_step_l.simps nth_append abc_fetch.simps)
  done

lemma abc_steps_add:
  "abc_steps_l (as, lm) ap (m + n) =
         abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
  apply(induct m arbitrary: n as lm, simp add: abc_steps_l.simps)
proof -
  fix m n as lm
  assume ind:
    "\<And>n as lm. abc_steps_l (as, lm) ap (m + n) =
                   abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
  show "abc_steps_l (as, lm) ap (Suc m + n) =
             abc_steps_l (abc_steps_l (as, lm) ap (Suc m)) ap n"
    apply(insert ind[of as lm "Suc n"], simp)
    apply(insert ind[of as lm "Suc 0"], simp add: abc_steps_l.simps)
    apply(case_tac "(abc_steps_l (as, lm) ap m)", simp)
    apply(simp add: abc_steps_l.simps)
    apply(case_tac "abc_step_l (a, b) (abc_fetch a ap)",
        simp add: abc_steps_l.simps)
    done
qed

lemma equal_when_halt:
  assumes exc1: "abc_steps_l (s, lm) A na = (length A, lma)"
    and exc2: "abc_steps_l (s, lm) A nb = (length A, lmb)"
  shows "lma = lmb"
proof(cases "na > nb")
  case True
  then obtain d where "na = nb + d"
    by (metis add_Suc_right less_iff_Suc_add)
  thus "?thesis" using assms halt_steps
    by(simp add: abc_steps_add)
next
  case False
  then obtain d where "nb = na + d"
    by (metis add.comm_neutral less_imp_add_positive nat_neq_iff)
  thus "?thesis" using assms halt_steps
    by(simp add: abc_steps_add)
qed

lemma abc_comp_first_steps_halt_eq':
  assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
    and notnull: "A \<noteq> []"
  shows "\<exists> n'. abc_steps_l (0, lm) (A [+] B) n' = (length A, lm')"
proof -
  have "\<exists> n'. abc_notfinal (abc_steps_l (0, lm) A n') A \<and>
    abc_final (abc_steps_l (0, lm) A (Suc n')) A"
    using assms
    by(rule_tac n = n in abc_before_final, simp_all)
  then obtain na where a:
    "abc_notfinal (abc_steps_l (0, lm) A na) A \<and>
            abc_final (abc_steps_l (0, lm) A (Suc na)) A" ..
  obtain sa lma where b: "abc_steps_l (0, lm) A na = (sa, lma)"
    by (metis prod.exhaust)
  then have c: "abc_steps_l (0, lm) (A [+] B) na = (sa, lma)"
    using a abc_comp_first_steps_eq_pre[of lm A na B] assms
    by simp
  have d: "sa < length A" using b a by simp
  then have e: "abc_step_l (sa, lma) (abc_fetch sa (A [+] B)) =
    abc_step_l (sa, lma) (abc_fetch sa A)"
    by(rule_tac abc_comp_first_step_eq_pre)
  from a have "abc_steps_l (0, lm) A (Suc na) = (length A, lm')"
    using final equal_when_halt
    by(case_tac "abc_steps_l (0, lm) A (Suc na)" , simp)
  then have "abc_steps_l (0, lm) (A [+] B) (Suc na) = (length A, lm')"
    using a b c e
    by(simp add: abc_step_red2)
  thus "?thesis"
    by blast
qed

lemma abc_exec_null: "abc_steps_l sam [] n = sam"
  apply(cases sam)
  apply(induct n)
   apply(auto simp: abc_step_red2)
   apply(auto simp: abc_step_l.simps abc_steps_l.simps abc_fetch.simps)
  done

lemma abc_comp_first_steps_halt_eq:
  assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
  shows "\<exists> n'. abc_steps_l (0, lm) (A [+] B) n' = (length A, lm')"
  using final
  apply(case_tac "A = []")
   apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps abc_exec_null)
  apply(rule_tac abc_comp_first_steps_halt_eq', simp_all)
  done

lemma abc_comp_second_step_eq:
  assumes exec: "abc_step_l (s, lm) (abc_fetch s B) = (sa, lma)"
  shows "abc_step_l (s + length A, lm) (abc_fetch (s + length A) (A [+] B))
         = (sa + length A, lma)"
  using assms
  apply(auto simp: abc_step_l.simps abc_fetch.simps nth_append abc_comp.simps abc_shift.simps split : if_splits )
  apply(case_tac [!] "B ! s", auto simp: Let_def)
  done

lemma abc_comp_second_steps_eq:
  assumes exec: "abc_steps_l (0, lm) B n = (sa, lm')"
  shows "abc_steps_l (length A, lm) (A [+] B) n = (sa + length A, lm')"
  using assms
proof(induct n arbitrary: sa lm')
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: "\<And>sa lm'. abc_steps_l (0, lm) B n = (sa, lm') \<Longrightarrow>
    abc_steps_l (length A, lm) (A [+] B) n = (sa + length A, lm')" by fact
  have exec: "abc_steps_l (0, lm) B (Suc n) = (sa, lm')" by fact
  obtain sb lmb where a: " abc_steps_l (0, lm) B n = (sb, lmb)"
    by (metis prod.exhaust)
  then have "abc_steps_l (length A, lm) (A [+] B) n = (sb + length A, lmb)"
    using ind by simp
  moreover have "abc_step_l (sb + length A, lmb) (abc_fetch (sb + length A) (A [+] B)) = (sa + length A, lm') "
    using a exec abc_comp_second_step_eq
    by(simp add: abc_step_red2)
  ultimately show "?case"
    by(simp add: abc_step_red2)
qed

lemma length_abc_comp[simp, intro]:
  "length (A [+] B) = length A + length B"
  by(auto simp: abc_comp.simps abc_shift.simps)

lemma abc_Hoare_plus_halt :
  assumes A_halt : "\<lbrace>P\<rbrace> (A::abc_prog) \<lbrace>Q\<rbrace>"
    and B_halt : "\<lbrace>Q\<rbrace> (B::abc_prog) \<lbrace>S\<rbrace>"
  shows "\<lbrace>P\<rbrace> (A [+] B) \<lbrace>S\<rbrace>"
proof(rule_tac abc_Hoare_haltI)
  fix lm
  assume a: "P lm"
  then obtain na lma where
    "abc_final (abc_steps_l (0, lm) A na) A"
    and b: "abc_steps_l (0, lm) A na = (length A, lma)"
    and c: "Q abc_holds_for (length A, lma)"
    using A_halt unfolding abc_Hoare_halt_def
    by (metis (full_types) abc_final.simps abc_holds_for.simps prod.exhaust)
  have "\<exists> n. abc_steps_l (0, lm) (A [+] B) n = (length A, lma)"
    using abc_comp_first_steps_halt_eq b
    by(simp)
  then obtain nx where h1: "abc_steps_l (0, lm) (A [+] B) nx = (length A, lma)" ..
  from c have "Q lma"
    using c unfolding abc_holds_for.simps
    by simp
  then obtain nb lmb where
    "abc_final (abc_steps_l (0, lma) B nb) B"
    and d: "abc_steps_l (0, lma) B nb = (length B, lmb)"
    and e: "S abc_holds_for (length B, lmb)"
    using B_halt unfolding abc_Hoare_halt_def
    by (metis (full_types) abc_final.simps abc_holds_for.simps prod.exhaust)
  have h2: "abc_steps_l (length A, lma) (A [+] B) nb = (length B + length A, lmb)"
    using d abc_comp_second_steps_eq
    by simp
  thus "\<exists>n. abc_final (abc_steps_l (0, lm) (A [+] B) n) (A [+] B) \<and>
    S abc_holds_for abc_steps_l (0, lm) (A [+] B) n"
    using h1 e
    by(rule_tac x = "nx + nb" in exI, simp add: abc_steps_add)
qed

lemma abc_unhalt_append_eq:
  assumes unhalt: "\<lbrace>P\<rbrace> (A::abc_prog) \<up>"
    and P: "P args"
  shows "abc_steps_l (0, args) (A [+] B) stp = abc_steps_l (0, args) A stp"
proof(induct stp)
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc stp)
  have ind: "abc_steps_l (0, args) (A [+] B) stp = abc_steps_l (0, args) A stp"
    by fact
  obtain s nl where a: "abc_steps_l (0, args) A stp = (s, nl)"
    by (metis prod.exhaust)
  then have b: "s < length A"
    using unhalt P
    apply(auto simp: abc_Hoare_unhalt_def)
    by (metis abc_notfinal.simps)
  thus "?case"
    using a ind
    by(simp add: abc_step_red2 abc_step_l.simps abc_fetch.simps nth_append abc_comp.simps)
qed

lemma abc_Hoare_plus_unhalt1:
  "\<lbrace>P\<rbrace> (A::abc_prog) \<up> \<Longrightarrow> \<lbrace>P\<rbrace> (A [+] B) \<up>"
  apply(rule abc_Hoare_unhaltI)
  apply(subst abc_unhalt_append_eq,force,force)
  by (metis (mono_tags, lifting) abc_notfinal.elims(3) abc_notfinal.simps add_diff_inverse_nat
      abc_Hoare_unhalt_def le_imp_less_Suc length_abc_comp not_less_eq order_refl trans_le_add1)

lemma notfinal_all_before:
  "\<lbrakk>abc_notfinal (abc_steps_l (0, args) A x) A; y\<le>x \<rbrakk>
  \<Longrightarrow> abc_notfinal (abc_steps_l (0, args) A y) A "
  apply(subgoal_tac "\<exists> d. x = y + d", auto)
   apply(cases "abc_steps_l (0, args) A y",simp)
   apply(rule classical, simp add: abc_steps_add leI halt_steps2)
  by arith

lemma abc_Hoare_plus_unhalt2':
  assumes unhalt: "\<lbrace>Q\<rbrace> (B::abc_prog) \<up>"
    and halt: "\<lbrace>P\<rbrace> (A::abc_prog) \<lbrace>Q\<rbrace>"
    and notnull: "A \<noteq> []"
    and P: "P args"
  shows "abc_notfinal (abc_steps_l (0, args) (A [+] B) n) (A [+] B)"
proof -
  obtain st nl stp where a: "abc_final (abc_steps_l (0, args) A stp) A"
    and b: "Q abc_holds_for (length A, nl)"
    and c: "abc_steps_l (0, args) A stp = (st, nl)"
    using halt P unfolding abc_Hoare_halt_def
    by (metis abc_holds_for.simps prod.exhaust)
  obtain stpa where d:
    "abc_notfinal (abc_steps_l (0, args) A stpa) A \<and> abc_final (abc_steps_l (0, args) A (Suc stpa)) A"
    using abc_before_final[of args A stp,OF a notnull] by metis
  thus "?thesis"
  proof(cases "n < Suc stpa")
    case True
    have h: "n < Suc stpa" by fact
    then have "abc_notfinal (abc_steps_l (0, args) A n) A"
      using d
      by(rule_tac notfinal_all_before, auto)
    moreover then have "abc_steps_l (0, args) (A [+] B) n = abc_steps_l (0, args) A n"
      using notnull
      by(rule_tac abc_comp_first_steps_eq_pre, simp_all)
    ultimately show "?thesis"
      by(case_tac "abc_steps_l (0, args) A n", simp)
  next
    case False
    have "\<not> n < Suc stpa" by fact
    then obtain d where i1: "n = Suc stpa + d"
      by (metis add_Suc less_iff_Suc_add not_less_eq)
    have "abc_steps_l (0, args) A (Suc stpa) = (length A, nl)"
      using d a c
      apply(case_tac "abc_steps_l (0, args) A stp", simp add: equal_when_halt)
      by(case_tac "abc_steps_l (0, args) A (Suc stpa)", simp add: equal_when_halt)
    moreover have  "abc_steps_l (0, args) (A [+] B) stpa = abc_steps_l (0, args) A stpa"
      using notnull d
      by(rule_tac abc_comp_first_steps_eq_pre, simp_all)
    ultimately have i2: "abc_steps_l (0, args) (A [+] B) (Suc stpa) = (length A, nl)"
      using d
      apply(case_tac "abc_steps_l (0, args) A stpa", simp)
      by(simp add: abc_step_red2 abc_steps_l.simps abc_fetch.simps abc_comp.simps nth_append)
    obtain s' nl' where i3:"abc_steps_l (0, nl) B d = (s', nl')"
      by (metis prod.exhaust)
    then have i4: "abc_steps_l (0, args) (A [+] B) (Suc stpa + d) = (length A + s', nl')"
      using i2  apply(simp only: abc_steps_add)
      using abc_comp_second_steps_eq[of nl B d s' nl']
      by simp
    moreover have "s' < length B"
      using unhalt b i3
      apply(simp add: abc_Hoare_unhalt_def)
      apply(erule_tac x = nl in allE, simp)
      by(erule_tac x = d in allE, simp)
    ultimately show "?thesis"
      using i1
      by(simp)
  qed
qed

lemma abc_comp_null_left[simp]: "[] [+] A = A"
proof(induct A)
  case (Cons a A)
  then show ?case
    apply(cases a)
    by(auto simp: abc_comp.simps abc_shift.simps)
qed (auto simp: abc_comp.simps abc_shift.simps)

lemma abc_comp_null_right[simp]: "A [+] [] = A"
proof(induct A)
  case (Cons a A)
  then show ?case
    apply(cases a)
    by(auto simp: abc_comp.simps abc_shift.simps)
qed (auto simp: abc_comp.simps abc_shift.simps)

lemma abc_Hoare_plus_unhalt2:
  "\<lbrakk>\<lbrace>Q\<rbrace> (B::abc_prog)\<up>; \<lbrace>P\<rbrace> (A::abc_prog) \<lbrace>Q\<rbrace>\<rbrakk>\<Longrightarrow> \<lbrace>P\<rbrace> (A [+] B) \<up>"
  apply(case_tac "A = []")
   apply(simp add: abc_Hoare_halt_def abc_Hoare_unhalt_def abc_exec_null)
  apply(rule_tac abc_Hoare_unhaltI)
  apply(erule_tac abc_Hoare_plus_unhalt2', simp)
   apply(simp, simp)
  done

end


section \<open>Recoverable Data Types\<close>

theory RDR
imports Main Sequences
begin

subsection \<open>The pre-RDR locale contains definitions later used in the RDR locale
  to state the properties of RDRs\<close>

locale pre_RDR = Sequences +
  fixes \<delta>::"'a \<Rightarrow> ('b \<times> 'c) \<Rightarrow> 'a" (infix "\<bullet>" 65)
  and \<gamma>::"'a \<Rightarrow> ('b \<times> 'c) \<Rightarrow> 'd"
  and bot::'a ("\<bottom>")
begin

fun exec::"'a \<Rightarrow> ('b\<times>'c)list \<Rightarrow> 'a" (infix "\<star>" 65) where
  "exec s Nil = s"
| "exec s (rs#r) = (exec s rs) \<bullet> r"

definition less_eq (infix "\<preceq>" 50) where
  "less_eq s s' \<equiv> \<exists> rs . s' = (s\<star>rs)"

definition less (infix "\<prec>" 50) where
  "less s s' \<equiv> less_eq s s' \<and> s \<noteq> s'"

definition is_lb where
  "is_lb s s1 s2 \<equiv> s \<preceq> s2 \<and> s \<preceq> s1"

definition is_glb where
  "is_glb s s1 s2 \<equiv> is_lb s s1 s2 \<and> (\<forall> s' . is_lb s' s1 s2 \<longrightarrow> s' \<preceq> s)"

definition contains where
  "contains s r \<equiv> \<exists> rs . r \<in> set rs \<and> s = (\<bottom> \<star> rs)"

definition inf  (infix "\<sqinter>" 65) where
  "inf s1 s2 \<equiv> THE s . is_glb s s1 s2"

subsection \<open>Useful Lemmas in the pre-RDR locale\<close>

lemma exec_cons:
  "s \<star> (rs # r)= (s \<star> rs) \<bullet> r" by simp

lemma exec_append:
  "(s \<star> rs) \<star> rs'  = s \<star> (rs@rs')"
proof (induct rs')
  show "(s \<star> rs) \<star> []  = s \<star> (rs@[])" by simp
next
  fix rs' r
  assume ih:"(s \<star> rs) \<star> rs'  = s \<star> (rs@rs')"
  thus "(s \<star> rs) \<star> (rs'#r)  = s \<star> (rs @ (rs'#r))"
    by (metis append_Cons exec_cons)
qed

lemma trans:
  assumes "s1 \<preceq> s2" and "s2 \<preceq> s3"
  shows "s1 \<preceq> s3" using assms
    by (auto simp add:less_eq_def, metis exec_append)

lemma contains_star:
  fixes s r rs
  assumes "contains s r"
  shows "contains (s \<star> rs) r"
proof (induct rs)
  case Nil
  show "contains (s \<star> []) r" using assms by auto
next
  case (Cons r' rs)
  with this obtain rs' where 1:"s \<star> rs = \<bottom> \<star> rs'" and 2:"r \<in> set rs'"
    by (auto simp add:contains_def)
  have 3:"s \<star> (rs#r') = \<bottom>\<star>(rs'#r')" using 1 by fastforce
  show "contains (s \<star> (rs#r')) r" using 2 3
    by (auto simp add:contains_def) (metis exec_cons rev_subsetD set_subset_Cons)
qed

lemma preceq_star: "s \<star> (rs#r) \<preceq> s' \<Longrightarrow> s \<star> rs \<preceq> s'"
by (metis pre_RDR.exec.simps(1) pre_RDR.exec.simps(2) pre_RDR.less_eq_def trans)

end

subsection \<open>The RDR locale\<close>

locale RDR = pre_RDR +
  assumes idem1:"contains s r \<Longrightarrow> s \<bullet> r = s"
  and idem2:"\<And> s r r' . fst r \<noteq> fst r' \<Longrightarrow> \<gamma> s r = \<gamma> ((s \<bullet> r) \<bullet> r') r"
  and antisym:"\<And> s1 s2 . s1 \<preceq> s2 \<and> s2 \<preceq> s1 \<Longrightarrow> s1 = s2"
  and glb_exists:"\<And> s1 s2 . \<exists> s . is_glb s s1 s2"
  and consistency:"\<And>s1 s2 s3 rs . s1 \<preceq> s2 \<Longrightarrow> s2 \<preceq> s3 \<Longrightarrow> s3 = s1 \<star> rs
    \<Longrightarrow> \<exists> rs' rs'' . s2 = s1 \<star> rs' \<and> s3 = s2 \<star> rs''
      \<and> set rs' \<subseteq> set rs \<and> set rs'' \<subseteq> set rs"
  and bot:"\<And> s . \<bottom> \<preceq> s"
begin

lemma inf_glb:"is_glb (s1 \<sqinter> s2) s1 s2"
proof -
  { fix s s'
    assume "is_glb s s1 s2" and "is_glb s' s1 s2"
    hence "s = s'" using antisym by (auto simp add:is_glb_def is_lb_def) }
    from this and glb_exists show ?thesis
      by (auto simp add:inf_def, metis (lifting) theI')
qed

sublocale ordering less_eq less
proof
  fix s
  show "s \<preceq> s"
  by (metis exec.simps(1) less_eq_def)
next
  fix s s'
  show "s \<prec> s' = (s \<preceq> s' \<and> s \<noteq> s')"
  by (auto simp add:less_def)
next
  fix s s'
  assume "s \<preceq> s'" and "s' \<preceq> s"
  thus "s = s'"
  using antisym by auto
next
  fix s1 s2 s3
  assume "s1 \<preceq> s2" and "s2 \<preceq> s3"
  thus "s1 \<preceq> s3"
  using trans by blast
qed

sublocale semilattice_set inf
proof
  fix s
  show "s \<sqinter> s = s"
    using inf_glb
    by (metis antisym is_glb_def is_lb_def refl)
next
  fix s1 s2
  show "s1 \<sqinter> s2 = (s2 \<sqinter> s1)"
    using inf_glb
    by (smt antisym is_glb_def pre_RDR.is_lb_def)
next
  fix s1 s2 s3
  show "(s1 \<sqinter> s2) \<sqinter> s3 = (s1 \<sqinter> (s2 \<sqinter> s3))"
    using inf_glb
    by(auto simp add:is_glb_def is_lb_def, smt antisym trans)
qed

sublocale semilattice_order_set inf less_eq less
proof
  fix s s'
  show "s \<preceq> s' = (s = s \<sqinter> s')"
  by (metis antisym idem inf_glb pre_RDR.is_glb_def pre_RDR.is_lb_def)
next
  fix s s'
  show "s \<prec> s' = (s = s \<sqinter> s' \<and> s \<noteq> s')"
  by (metis inf_glb local.antisym local.refl pre_RDR.is_glb_def pre_RDR.is_lb_def pre_RDR.less_def)
qed

notation F ("\<Sqinter> _" [99])

subsection \<open>Some useful lemmas\<close>

lemma idem_star:
fixes r s rs
assumes "contains s r"
shows "s \<star> rs = s \<star> (filter (\<lambda> x . x \<noteq> r) rs)"
proof (induct rs)
  case Nil
  show "s \<star> [] = s \<star> (filter (\<lambda> x . x \<noteq> r) [])"
    using assms by auto
next
  case (Cons r' rs)
  have 1:"contains (s \<star> rs) r" using assms and contains_star by auto
  show "s \<star> (rs#r') = s \<star> (filter (\<lambda> x . x \<noteq> r) (rs#r'))"
  proof (cases "r' = r")
    case True
    hence "s \<star> (rs#r') = s \<star> rs" using idem1 1 by auto
    thus ?thesis using Cons by simp
  next
    case False
    thus ?thesis using Cons by auto
  qed
qed

lemma idem_star2:
  fixes s rs'
  shows "\<exists> rs' . s \<star> rs = s \<star> rs' \<and> set rs' \<subseteq> set rs
    \<and> (\<forall> r \<in> set rs' . \<not> contains s r)"
proof (induct rs)
  case Nil
  thus "\<exists> rs' . s \<star> [] = s \<star> rs' \<and> set rs' \<subseteq> set []
    \<and> (\<forall> r \<in> set rs' . \<not> contains s r)" by force
next
  case (Cons r rs)
  obtain rs' where 1:"s \<star> rs = s \<star> rs'" and 2:"set rs' \<subseteq> set rs"
  and 3:"\<forall> r \<in> set rs' . \<not> contains s r" using Cons(1) by blast
  show "\<exists> rs' . s \<star> (rs#r) = s \<star> rs' \<and> set rs' \<subseteq> set (rs#r)
    \<and> (\<forall> r \<in> set rs' . \<not> contains s r)"
  proof (cases "contains s r")
    case True
    have "s\<star>(rs#r) = s\<star>rs'"
    proof -
      have "s \<star> (rs#r) = s\<star>rs" using True
        by (metis contains_star exec_cons idem1)
      moreover
      have "s \<star> (rs'#r) = s\<star>rs'" using True
        by (metis contains_star exec_cons idem1)
      ultimately show ?thesis using 1 by simp
    qed
    moreover have "set rs' \<subseteq> set (rs#r)" using 2
      by (simp, metis subset_insertI2)
    moreover have "\<forall> r \<in> set rs' . \<not> contains s r"
      using 3 by assumption
    ultimately show ?thesis by blast
  next
    case False
    have "s\<star>(rs#r) = s\<star>(rs'#r)" using 1 by simp
    moreover
    have "set (rs'#r) \<subseteq> set (rs#r)" using 2 by auto
    moreover have "\<forall> r \<in> set (rs'#r) . \<not> contains s r"
      using 3 False by auto
    ultimately show ?thesis by blast
  qed
qed

lemma idem2_star:
assumes "contains s r"
and "\<And> r' . r' \<in> set rs \<Longrightarrow> fst r' \<noteq> fst r"
shows "\<gamma> s r = \<gamma> (s \<star> rs) r" using assms
proof (induct rs)
  case Nil
  show "\<gamma> s r = \<gamma> (s \<star> []) r" by simp
next
  case (Cons r' rs)
  thus "\<gamma> s r = \<gamma> (s \<star> (rs#r')) r"
    using assms by auto
      (metis contains_star fst_conv idem1 idem2 prod.exhaust)
qed

lemma glb_common:
fixes s1 s2 s rs1 rs2
assumes "s1 = s \<star> rs1" and "s2 = s \<star> rs2"
shows "\<exists> rs . s1 \<sqinter> s2 = s \<star> rs \<and> set rs \<subseteq> set rs1 \<union> set rs2"
proof -
  have 1:"s \<preceq> s1" and 2:"s \<preceq> s2" using assms by (auto simp add:less_eq_def)
  hence 3:"s \<preceq> s1 \<sqinter> s2" by (metis inf_glb is_lb_def pre_RDR.is_glb_def)
  have 4:"s1 \<sqinter> s2 \<preceq> s1" by (metis cobounded1)
  show ?thesis using 3 4 assms(1) and consistency by blast
qed

lemma glb_common_set:
fixes ss s0 rset
assumes "finite ss"  and "ss \<noteq> {}"
and "\<And> s . s \<in> ss \<Longrightarrow> \<exists> rs . s = s0 \<star> rs \<and> set rs \<subseteq> rset"
shows "\<exists> rs . \<Sqinter> ss = s0 \<star> rs \<and> set rs \<subseteq> rset"
using assms
proof (induct ss rule:finite_ne_induct)
  case (singleton s)
  obtain rs where "s = s0 \<star> rs \<and> set rs \<subseteq> rset" using singleton by force
  moreover have "\<Sqinter> {s} = s" using singleton by auto
  ultimately show "\<exists> rs . \<Sqinter> {s} = s0 \<star> rs \<and> set rs \<subseteq> rset" by blast
next
  case (insert s ss)
  have 1:"\<And> s' . s' \<in> ss \<Longrightarrow> \<exists> rs . s' = s0 \<star> rs \<and> set rs \<subseteq> rset"
    using insert(5) by force
  obtain rs where 2:"\<Sqinter> ss = s0 \<star> rs" and 3:"set rs \<subseteq> rset"
    using insert(4) 1 by blast
  obtain rs' where 4:"s = s0 \<star> rs'"and 5:"set rs' \<subseteq> rset"
    using insert(5) by blast
  have 6:"\<Sqinter> (insert s ss) = s \<sqinter> (\<Sqinter> ss)"
    by (metis insert.hyps(1-3) insert_not_elem)
  obtain rs'' where 7:"\<Sqinter> (insert s ss) = s0 \<star> rs''"
    and 8:"set rs'' \<subseteq> set rs' \<union> set rs"
    using glb_common 2 4 6 by force
  have 9:"set rs'' \<subseteq> rset" using 3 5 8 by blast
  show "\<exists> rs . \<Sqinter> (insert s ss) = s0 \<star> rs \<and> set rs \<subseteq> rset"
    using 7 9 by blast
qed

end

end


theory Refinement
imports Setup
begin

section \<open>Program and datatype refinement \label{sec:refinement}\<close>

text \<open>
  Code generation by shallow embedding (cf.~\secref{sec:principle})
  allows to choose code equations and datatype constructors freely,
  given that some very basic syntactic properties are met; this
  flexibility opens up mechanisms for refinement which allow to extend
  the scope and quality of generated code dramatically.
\<close>

subsection \<open>Program refinement\<close>

text \<open>
  Program refinement works by choosing appropriate code equations
  explicitly (cf.~\secref{sec:equations}); as example, we use Fibonacci
  numbers:
\<close>

fun %quote fib :: "nat \<Rightarrow> nat" where
    "fib 0 = 0"
  | "fib (Suc 0) = Suc 0"
  | "fib (Suc (Suc n)) = fib n + fib (Suc n)"

text \<open>
  \noindent The runtime of the corresponding code grows exponential due
  to two recursive calls:
\<close>

text %quote \<open>
  @{code_stmts fib constant: fib (Haskell)}
\<close>

text \<open>
  \noindent A more efficient implementation would use dynamic
  programming, e.g.~sharing of common intermediate results between
  recursive calls.  This idea is expressed by an auxiliary operation
  which computes a Fibonacci number and its successor simultaneously:
\<close>

definition %quote fib_step :: "nat \<Rightarrow> nat \<times> nat" where
  "fib_step n = (fib (Suc n), fib n)"

text \<open>
  \noindent This operation can be implemented by recursion using
  dynamic programming:
\<close>

lemma %quote [code]:
  "fib_step 0 = (Suc 0, 0)"
  "fib_step (Suc n) = (let (m, q) = fib_step n in (m + q, m))"
  by (simp_all add: fib_step_def)

text \<open>
  \noindent What remains is to implement \<^const>\<open>fib\<close> by \<^const>\<open>fib_step\<close> as follows:
\<close>

lemma %quote [code]:
  "fib 0 = 0"
  "fib (Suc n) = fst (fib_step n)"
  by (simp_all add: fib_step_def)

text \<open>
  \noindent The resulting code shows only linear growth of runtime:
\<close>

text %quote \<open>
  @{code_stmts fib constant: fib fib_step (Haskell)}
\<close>

subsection \<open>Datatype refinement\<close>

text \<open>
  Selecting specific code equations \emph{and} datatype constructors
  leads to datatype refinement.  As an example, we will develop an
  alternative representation of the queue example given in
  \secref{sec:queue_example}.  The amortised representation is
  convenient for generating code but exposes its \qt{implementation}
  details, which may be cumbersome when proving theorems about it.
  Therefore, here is a simple, straightforward representation of
  queues:
\<close>

datatype %quote 'a queue = Queue "'a list"

definition %quote empty :: "'a queue" where
  "empty = Queue []"

primrec %quote enqueue :: "'a \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
  "enqueue x (Queue xs) = Queue (xs @ [x])"

fun %quote dequeue :: "'a queue \<Rightarrow> 'a option \<times> 'a queue" where
    "dequeue (Queue []) = (None, Queue [])"
  | "dequeue (Queue (x # xs)) = (Some x, Queue xs)"

text \<open>
  \noindent This we can use directly for proving;  for executing,
  we provide an alternative characterisation:
\<close>

definition %quote AQueue :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a queue" where
  "AQueue xs ys = Queue (ys @ rev xs)"

code_datatype %quote AQueue

text \<open>
  \noindent Here we define a \qt{constructor} \<^const>\<open>AQueue\<close> which
  is defined in terms of \<open>Queue\<close> and interprets its arguments
  according to what the \emph{content} of an amortised queue is supposed
  to be.

  The prerequisite for datatype constructors is only syntactical: a
  constructor must be of type \<open>\<tau> = \<dots> \<Rightarrow> \<kappa> \<alpha>\<^sub>1 \<dots> \<alpha>\<^sub>n\<close> where \<open>{\<alpha>\<^sub>1, \<dots>, \<alpha>\<^sub>n}\<close> is exactly the set of \emph{all} type variables in
  \<open>\<tau>\<close>; then \<open>\<kappa>\<close> is its corresponding datatype.  The
  HOL datatype package by default registers any new datatype with its
  constructors, but this may be changed using @{command_def
  code_datatype}; the currently chosen constructors can be inspected
  using the @{command print_codesetup} command.

  Equipped with this, we are able to prove the following equations
  for our primitive queue operations which \qt{implement} the simple
  queues in an amortised fashion:
\<close>

lemma %quote empty_AQueue [code]:
  "empty = AQueue [] []"
  by (simp add: AQueue_def empty_def)

lemma %quote enqueue_AQueue [code]:
  "enqueue x (AQueue xs ys) = AQueue (x # xs) ys"
  by (simp add: AQueue_def)

lemma %quote dequeue_AQueue [code]:
  "dequeue (AQueue xs []) =
    (if xs = [] then (None, AQueue [] [])
    else dequeue (AQueue [] (rev xs)))"
  "dequeue (AQueue xs (y # ys)) = (Some y, AQueue xs ys)"
  by (simp_all add: AQueue_def)

text \<open>
  \noindent It is good style, although no absolute requirement, to
  provide code equations for the original artefacts of the implemented
  type, if possible; in our case, these are the datatype constructor
  \<^const>\<open>Queue\<close> and the case combinator \<^const>\<open>case_queue\<close>:
\<close>

lemma %quote Queue_AQueue [code]:
  "Queue = AQueue []"
  by (simp add: AQueue_def fun_eq_iff)

lemma %quote case_queue_AQueue [code]:
  "case_queue f (AQueue xs ys) = f (ys @ rev xs)"
  by (simp add: AQueue_def)

text \<open>
  \noindent The resulting code looks as expected:
\<close>

text %quote \<open>
  @{code_stmts empty enqueue dequeue Queue case_queue (SML)}
\<close>

text \<open>
  The same techniques can also be applied to types which are not
  specified as datatypes, e.g.~type \<^typ>\<open>int\<close> is originally specified
  as quotient type by means of @{command_def typedef}, but for code
  generation constants allowing construction of binary numeral values
  are used as constructors for \<^typ>\<open>int\<close>.

  This approach however fails if the representation of a type demands
  invariants; this issue is discussed in the next section.
\<close>

subsection \<open>Datatype refinement involving invariants \label{sec:invariant}\<close>

text \<open>
  Datatype representation involving invariants require a dedicated
  setup for the type and its primitive operations.  As a running
  example, we implement a type \<^typ>\<open>'a dlist\<close> of lists consisting
  of distinct elements.

  The specification of \<^typ>\<open>'a dlist\<close> itself can be found in theory
  \<^theory>\<open>HOL-Library.Dlist\<close>.

  The first step is to decide on which representation the abstract
  type (in our example \<^typ>\<open>'a dlist\<close>) should be implemented.
  Here we choose \<^typ>\<open>'a list\<close>.  Then a conversion from the concrete
  type to the abstract type must be specified, here:
\<close>

text %quote \<open>
  \<^term_type>\<open>Dlist\<close>
\<close>

text \<open>
  \noindent Next follows the specification of a suitable \emph{projection},
  i.e.~a conversion from abstract to concrete type:
\<close>

text %quote \<open>
  \<^term_type>\<open>list_of_dlist\<close>
\<close>

text \<open>
  \noindent This projection must be specified such that the following
  \emph{abstract datatype certificate} can be proven:
\<close>

lemma %quote [code abstype]:
  "Dlist (list_of_dlist dxs) = dxs"
  by (fact Dlist_list_of_dlist)

text \<open>
  \noindent Note that so far the invariant on representations
  (\<^term_type>\<open>distinct\<close>) has never been mentioned explicitly:
  the invariant is only referred to implicitly: all values in
  set \<^term>\<open>{xs. list_of_dlist (Dlist xs) = xs}\<close> are invariant,
  and in our example this is exactly \<^term>\<open>{xs. distinct xs}\<close>.

  The primitive operations on \<^typ>\<open>'a dlist\<close> are specified
  indirectly using the projection \<^const>\<open>list_of_dlist\<close>.  For
  the empty \<open>dlist\<close>, \<^const>\<open>Dlist.empty\<close>, we finally want
  the code equation
\<close>

text %quote \<open>
  \<^term>\<open>Dlist.empty = Dlist []\<close>
\<close>

text \<open>
  \noindent This we have to prove indirectly as follows:
\<close>

lemma %quote [code]:
  "list_of_dlist Dlist.empty = []"
  by (fact list_of_dlist_empty)

text \<open>
  \noindent This equation logically encodes both the desired code
  equation and that the expression \<^const>\<open>Dlist\<close> is applied to obeys
  the implicit invariant.  Equations for insertion and removal are
  similar:
\<close>

lemma %quote [code]:
  "list_of_dlist (Dlist.insert x dxs) = List.insert x (list_of_dlist dxs)"
  by (fact list_of_dlist_insert)

lemma %quote [code]:
  "list_of_dlist (Dlist.remove x dxs) = remove1 x (list_of_dlist dxs)"
  by (fact list_of_dlist_remove)

text \<open>
  \noindent Then the corresponding code is as follows:
\<close>

text %quote \<open>
  @{code_stmts Dlist.empty Dlist.insert Dlist.remove list_of_dlist (SML)}
\<close>

text \<open>
  See further \<^cite>\<open>"Haftmann-Kraus-Kuncar-Nipkow:2013:data_refinement"\<close>
  for the meta theory of datatype refinement involving invariants.

  Typical data structures implemented by representations involving
  invariants are available in the library, theory \<^theory>\<open>HOL-Library.Mapping\<close>
  specifies key-value-mappings (type \<^typ>\<open>('a, 'b) mapping\<close>);
  these can be implemented by red-black-trees (theory \<^theory>\<open>HOL-Library.RBT\<close>).
\<close>

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory MapOps
imports Main
begin
(*>*)

subsection\<open>Finite map operations\<close>

text\<open>

\label{sec:kbps-theory-map-ops}

The algorithm represents an automaton as a pair of maps, which we
capture abstractly with a record and a predicate:

\<close>

record ('m, 'k, 'e) MapOps =
  empty :: "'m"
  lookup :: "'m \<Rightarrow> 'k \<rightharpoonup> 'e"
  update :: "'k \<Rightarrow> 'e \<Rightarrow> 'm \<Rightarrow> 'm"

definition
  MapOps :: "('k \<Rightarrow> 'kabs) \<Rightarrow> 'kabs set \<Rightarrow> ('m, 'k, 'e) MapOps \<Rightarrow> bool"
where
  "MapOps \<alpha> d ops \<equiv>
      (\<forall>k. \<alpha> k \<in> d \<longrightarrow> lookup ops (empty ops) k = None)
    \<and> (\<forall>e k k' M. \<alpha> k \<in> d \<and> \<alpha> k' \<in> d
        \<longrightarrow> lookup ops (update ops k e M) k'
          = (if \<alpha> k' = \<alpha> k then Some e else lookup ops M k'))"
(*<*)

lemma MapOpsI[intro]:
  "\<lbrakk> \<And>k. \<alpha> k \<in> d \<Longrightarrow> lookup ops (empty ops) k = None;
     \<And>e k k' M. \<lbrakk> \<alpha> k \<in> d; \<alpha> k' \<in> d \<rbrakk> \<Longrightarrow>
                 lookup ops (update ops k e M) k'
              = (if \<alpha> k' = \<alpha> k then Some e else lookup ops M k') \<rbrakk>
     \<Longrightarrow> MapOps \<alpha> d ops"
  unfolding MapOps_def by blast

lemma MapOps_emptyD:
  "\<lbrakk> \<alpha> k \<in> d; MapOps \<alpha> d ops \<rbrakk> \<Longrightarrow> lookup ops (empty ops) k = None"
  unfolding MapOps_def by simp

lemma MapOps_lookup_updateD:
  "\<lbrakk> \<alpha> k \<in> d; \<alpha> k' \<in> d; MapOps \<alpha> d ops \<rbrakk> \<Longrightarrow> lookup ops (update ops k e M) k' = (if \<alpha> k' = \<alpha> k then Some e else lookup ops M k')"
  unfolding MapOps_def by simp

(*>*)

text\<open>

The function @{term "\<alpha>"} abstracts concrete keys of type @{typ "'k"},
and the parameter @{term "d"} specifies the valid abstract keys.

This approach has the advantage over a locale that we can pass records
to functions, while for a locale we would need to pass the three
functions separately (as in the DFS theory of \S\ref{sec:dfs}).

We use the following function to test for membership in the domain of
the map:

\<close>

definition isSome :: "'a option \<Rightarrow> bool" where
  "isSome opt \<equiv> case opt of None \<Rightarrow> False | Some _ \<Rightarrow> True"
(*<*)

lemma isSome_simps[simp]:
  "\<And>x. isSome (Some x)"
  "\<And>x. \<not> isSome x \<longleftrightarrow> x = None"
  unfolding isSome_def by (auto split: option.split)

lemma isSome_eq:
  "isSome x \<longleftrightarrow> (\<exists>y. x = Some y)"
  unfolding isSome_def by (auto split: option.split)

lemma isSomeE: "\<lbrakk> isSome x; \<And>s. x = Some s \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  unfolding isSome_def by (cases x) auto

end
(*>*)


section \<open> Hat Functions \<close>

theory Triangular_Function
imports
 "HOL-Analysis.Equivalence_Lebesgue_Henstock_Integration"
 Grid
begin

lemma continuous_on_max[continuous_intros]:
  fixes f :: "_ \<Rightarrow> 'a::linorder_topology"
  shows "continuous_on S f \<Longrightarrow> continuous_on S g \<Longrightarrow> continuous_on S (\<lambda>x. max (f x) (g x))"
  by (auto simp: continuous_on_def intro: tendsto_max)

definition \<phi> :: "(nat \<times> int) \<Rightarrow> real \<Rightarrow> real" where
  "\<phi> \<equiv> (\<lambda>(l,i) x. max 0 (1 - \<bar> x * 2^(l + 1) - real_of_int i \<bar>))"

definition \<Phi> :: "(nat \<times> int) list \<Rightarrow> (nat \<Rightarrow> real) \<Rightarrow> real" where
  "\<Phi> p x = (\<Prod>d<length p. \<phi> (p ! d) (x d))"

definition l2_\<phi> where
  "l2_\<phi> p1 p2 = (\<integral>x. \<phi> p1 x * \<phi> p2 x \<partial>lborel)"

definition l2 where
  "l2 a b = (\<integral>x. \<Phi> a x * \<Phi> b x \<partial>(\<Pi>\<^sub>M d\<in>{..<length a}. lborel))"

lemma measurable_\<phi>[measurable]: "\<phi> p \<in> borel_measurable borel"
  by (cases p) (simp add: \<phi>_def)

lemma \<phi>_nonneg: "0 \<le> \<phi> p x"
  by (simp add: \<phi>_def split: prod.split)

lemma \<phi>_zero_iff:
  "\<phi> (l,i) x = 0 \<longleftrightarrow> x \<notin> {real_of_int (i - 1) / 2^(l + 1) <..< real_of_int (i + 1) / 2^(l + 1)}"
  by (auto simp: \<phi>_def field_simps split: split_max)

lemma \<phi>_zero: "x \<notin> {real_of_int (i - 1) / 2^(l + 1) <..< real_of_int (i + 1) / 2^(l + 1)} \<Longrightarrow> \<phi> (l,i) x = 0"
  unfolding \<phi>_zero_iff by simp

lemma \<phi>_eq_0: assumes x: "x < 0 \<or> 1 < x" and i: "0 < i" "i < 2^Suc l" shows "\<phi> (l, i) x = 0"
  using x
proof
  assume "x < 0"
  also have "0 \<le> real_of_int (i - 1) / 2^(l + 1)"
    using i by (auto simp: field_simps)
  finally show ?thesis
    by (auto intro!: \<phi>_zero simp: field_simps)
next
  have "real_of_int (i + 1) / 2^(l + 1) \<le> 1"
    using i by (subst divide_le_eq_1_pos) (auto simp del: of_int_add power_Suc)
  also assume "1 < x"
  finally show ?thesis
    by (auto intro!: \<phi>_zero simp: field_simps)
qed

lemma ix_lt: "p \<in> sparsegrid dm lm \<Longrightarrow> d < dm \<Longrightarrow> ix p d < 2^(lv p d + 1)"
  unfolding sparsegrid_def lgrid_def
  using grid_estimate[of d "start dm" p "{0 ..< dm}"] by auto

lemma ix_gt: "p \<in> sparsegrid dm lm \<Longrightarrow> d < dm \<Longrightarrow> 0 < ix p d"
  unfolding sparsegrid_def lgrid_def
  using grid_estimate[of d "start dm" p "{0 ..< dm}"] by auto

lemma \<Phi>_eq_0: assumes x: "\<exists>d<length p. x d < 0 \<or> 1 < x d" and p: "p \<in> sparsegrid dm lm" shows "\<Phi> p x = 0"
  unfolding \<Phi>_def
proof (rule prod_zero)
  from x guess d ..
  with p[THEN ix_lt, of d] p[THEN ix_gt, of d] p
  show "\<exists>a\<in>{..<length p}. \<phi> (p ! a) (x a) = 0"
    apply (cases "p!d")
    apply (intro bexI[of _ d])
    apply (auto intro!: \<phi>_eq_0 simp: sparsegrid_length ix_def lv_def)
    done
qed simp

lemma \<phi>_left_support':
  "x \<in> {real_of_int (i - 1) / 2^(l + 1) .. real_of_int i / 2^(l + 1)} \<Longrightarrow> \<phi> (l,i) x = 1 + x * 2^(l + 1) - real_of_int i"
  by (auto simp: \<phi>_def field_simps split: split_max)

lemma \<phi>_left_support: "x \<in> {-1 .. 0::real} \<Longrightarrow> \<phi> (l,i) ((x + real_of_int i) / 2^(l + 1)) = 1 + x"
  by (auto simp: \<phi>_def field_simps split: split_max)

lemma \<phi>_right_support':
  "x \<in> {real_of_int i / 2^(l + 1) .. real_of_int (i + 1) / 2^(l + 1)} \<Longrightarrow> \<phi> (l,i) x = 1 - x * 2^(l + 1) + real_of_int i"
  by (auto simp: \<phi>_def field_simps split: split_max)

lemma \<phi>_right_support:
  "x \<in> {0 .. 1::real} \<Longrightarrow> \<phi> (l,i) ((x + real i) / 2^(l + 1)) = 1 - x"
  by (auto simp: \<phi>_def field_simps split: split_max)

lemma integrable_\<phi>: "integrable lborel (\<phi> p)"
proof (induct p)
  case (Pair l i)
  have "integrable lborel (\<lambda>x. indicator {real_of_int (i - 1) / 2^(l + 1) .. real_of_int (i + 1) / 2^(l + 1)} x *\<^sub>R \<phi> (l, i) x)"
    unfolding \<phi>_def by (intro borel_integrable_compact) (auto intro!: continuous_intros)
  then show ?case
    by (rule integrable_cong[THEN iffD1, rotated -1]) (auto simp: \<phi>_zero_iff)
qed

lemma integrable_\<phi>2: "integrable lborel (\<lambda>x. \<phi> p x * \<phi> q x)"
proof (cases p q rule: prod.exhaust[case_product prod.exhaust])
  case (Pair_Pair l i l' i')
  have "integrable lborel
      (\<lambda>x. indicator {real_of_int (i - 1) / 2^(l + 1) .. real_of_int (i + 1) / 2^(l + 1)} x *\<^sub>R (\<phi> (l, i) x * \<phi> (l', i') x))"
    unfolding \<phi>_def by (intro borel_integrable_compact) (auto intro!: continuous_intros)
  then show ?thesis unfolding Pair_Pair
    by (rule integrable_cong[THEN iffD1, rotated -1]) (auto simp: \<phi>_zero_iff)
qed

lemma l2_\<phi>I_DERIV:
  assumes n: "\<And> x. x \<in> { (real_of_int i' - 1) / 2^(l' + 1) .. real_of_int i' / 2^(l' + 1) } \<Longrightarrow>
    DERIV \<Phi>_n x :> (\<phi> (l', i') x * \<phi> (l, i) x)" (is "\<And> x. x \<in> {?a..?b} \<Longrightarrow> DERIV _ _ :> ?P x")
    and p: "\<And> x. x \<in> { real_of_int i' / 2^(l' + 1) .. (real_of_int i' + 1) / 2^(l' + 1) } \<Longrightarrow>
    DERIV \<Phi>_p x :> (\<phi> (l', i') x * \<phi> (l, i) x)" (is "\<And> x. x \<in> {?b..?c} \<Longrightarrow> _")
  shows "l2_\<phi> (l', i') (l, i) = (\<Phi>_n ?b - \<Phi>_n ?a) + (\<Phi>_p ?c - \<Phi>_p ?b)"
proof -
  have "has_bochner_integral lborel
      (\<lambda>x. ?P x * indicator {?a..?b} x + ?P x * indicator {?b..?c} x)
      ((\<Phi>_n ?b - \<Phi>_n ?a) + (\<Phi>_p ?c - \<Phi>_p ?b))"
    by (intro has_bochner_integral_add has_bochner_integral_FTC_Icc_nonneg n p)
       (auto simp: \<phi>_nonneg field_simps)
  then have "has_bochner_integral lborel?P ((\<Phi>_n ?b - \<Phi>_n ?a) + (\<Phi>_p ?c - \<Phi>_p ?b))"
    by (rule has_bochner_integral_discrete_difference[where X="{?b}", THEN iffD1, rotated -1])
       (auto simp: power_add intro!: \<phi>_zero integral_cong split: split_indicator)
  then show ?thesis by (simp add: has_bochner_integral_iff l2_\<phi>_def)
qed

lemma l2_eq: "length a = length b \<Longrightarrow> l2 a b = (\<Prod>d<length a. l2_\<phi> (a!d) (b!d))"
  unfolding l2_def l2_\<phi>_def \<Phi>_def
  apply (simp add: prod.distrib[symmetric])
proof (rule product_sigma_finite.product_integral_prod)
  show "product_sigma_finite (\<lambda>d. lborel)" ..
qed (auto intro: integrable_\<phi>2)

lemma l2_when_disjoint:
  assumes "l \<le> l'"
  defines "d == l' - l"
  assumes "(i + 1) * 2^d < i' \<or> i' < (i - 1) * 2^d" (is "?right \<or> ?left")
  shows "l2_\<phi> (l', i') (l, i) = 0"
proof -
  let ?sup = "\<lambda>l i. {real_of_int (i - 1) / 2^(l + 1) <..< real_of_int (i + 1) / 2^(l + 1)}"

  have l': "l' = l + d"
    using assms by simp
  have *: "\<And>i l. 2 ^ l = real_of_int (2 ^ l::int)"
    by simp
  have [arith]: "0 < (2^d::int)"
    by simp

  from \<open>?right \<or> ?left\<close> \<open>l \<le> l'\<close> have empty_support: "?sup l i \<inter> ?sup l' i' = {}"
    by (auto simp add: min_def max_def divide_simps l' power_add * of_int_mult[symmetric]
                simp del: of_int_diff of_int_add of_int_mult of_int_power)
       (simp_all add: field_simps)
  then have "\<And>x. \<phi> (l', i') x * \<phi> (l, i) x = 0"
    unfolding \<phi>_zero_iff mult_eq_0_iff by blast
  then show ?thesis
    by (simp add: l2_\<phi>_def del: mult_eq_0_iff vector_space_over_itself.scale_eq_0_iff)
qed

lemma l2_commutative: "l2_\<phi> p q = l2_\<phi> q p"
  by (simp add: l2_\<phi>_def mult.commute)

lemma l2_when_same: "l2_\<phi> (l, i) (l, i) = 1/3 / 2^l"
proof (subst l2_\<phi>I_DERIV)
  let ?l = "(2 :: real)^(l + 1)"
  let ?in = "real_of_int i - 1"
  let ?ip = "real_of_int i + 1"
  let ?\<phi> = "\<phi> (l,i)"
  let ?\<phi>2 = "\<lambda>x. ?\<phi> x * ?\<phi> x"

  { fix x assume "x \<in> {?in / ?l .. real_of_int i / ?l}"
    hence \<phi>_eq: "?\<phi> x = ?l * x  - ?in" using \<phi>_left_support' by auto
    show "DERIV (\<lambda>x. x^3 / 3 * ?l^2 + x * ?in^2 - x^2/2 * 2 * ?l * ?in) x :> ?\<phi>2 x"
      by (auto intro!: derivative_eq_intros simp add: power2_eq_square field_simps \<phi>_eq) }

  { fix x assume "x \<in> {real_of_int i / ?l .. ?ip / ?l}"
    hence \<phi>_eq: "?\<phi> x = ?ip - ?l * x" using \<phi>_right_support' by auto
    show "DERIV (\<lambda>x. x^3 / 3 * ?l^2 + x * ?ip^2 - x^2/2 * 2 * ?l * ?ip) x :> ?\<phi>2 x"
      by (auto intro!: derivative_eq_intros simp add: power2_eq_square field_simps \<phi>_eq) }
qed (simp_all add: field_simps power_eq_if[of _ 2] power_eq_if[of _ 3])

lemma l2_when_left_child:
  assumes "l < l'"
  and i'_bot: "i' > (i - 1) * 2^(l' - l)"
  and i'_top: "i' < i * 2^(l' - l)"
  shows "l2_\<phi> (l', i') (l, i) = (1 + real_of_int i' / 2^(l' - l) - real_of_int i) / 2^(l' + 1)"
proof (subst l2_\<phi>I_DERIV)
  let ?l' = "(2 :: real)^(l' + 1)"
  let ?in' = "real_of_int i' - 1"
  let ?ip' = "real_of_int i' + 1"
  let ?l = "(2 :: real)^(l + 1)"
  let ?i = "real_of_int i - 1"
  let ?\<phi>' = "\<phi> (l',i')"
  let ?\<phi> = "\<phi> (l, i)"
  let "?\<phi>2 x" = "?\<phi>' x * ?\<phi> x"
  define \<Phi>_n where "\<Phi>_n x = x^3 / 3 * ?l' * ?l + x * ?i * ?in' - x^2 / 2 * (?in' * ?l + ?i * ?l')" for x
  define \<Phi>_p where "\<Phi>_p x = x^2 / 2 * (?ip' * ?l + ?i * ?l') - x^3 / 3 * ?l' * ?l - x * ?i * ?ip'" for x

  have level_diff: "2^(l' - l) = 2^l' / (2^l :: real)" using power_diff[of "2::real" l l'] \<open>l < l'\<close> by auto

  { fix x assume x: "x \<in> {?in' / ?l' .. ?ip' / ?l'}"
    have "?i * 2^(l' - l) \<le> ?in'"
      using i'_bot int_less_real_le by auto
    hence "?i / ?l \<le> ?in' / ?l'"
      using level_diff by (auto simp: field_simps)
    hence "?i / ?l \<le> x" using x by auto
    moreover
    have "?ip' \<le> real_of_int i * 2^(l' - l)"
      using i'_top int_less_real_le by auto
    hence ip'_le_i: "?ip' / ?l' \<le> real_of_int i / ?l"
      using level_diff by (auto simp: field_simps)
    hence "x \<le> real_of_int i / ?l" using x by auto
    ultimately have "?\<phi> x = ?l * x  - ?i" using \<phi>_left_support' by auto
  } note \<phi>_eq = this

  { fix x assume x: "x \<in> {?in' / ?l' .. real_of_int i' / ?l'}"
    hence \<phi>'_eq: "?\<phi>' x = ?l' * x  - ?in'" using \<phi>_left_support' by auto
    from x have x': "x \<in> {?in' / ?l' .. ?ip' / ?l'}" by (auto simp add: field_simps)
    show "DERIV \<Phi>_n x :> ?\<phi>2 x" unfolding \<phi>_eq[OF x'] \<phi>'_eq \<Phi>_n_def
      by (auto intro!: derivative_eq_intros simp add: power2_eq_square algebra_simps) }

  { fix x assume x: "x \<in> {real_of_int i' / ?l' .. ?ip' / ?l'}"
    hence \<phi>'_eq: "?\<phi>' x = ?ip' - ?l' * x" using \<phi>_right_support' by auto
    from x have x': "x \<in> {?in' / ?l' .. ?ip' / ?l'}" by (simp add: field_simps)
    show "DERIV \<Phi>_p x :> ?\<phi>2 x" unfolding \<phi>_eq[OF x'] \<phi>'_eq \<Phi>_p_def
      by (auto intro!: derivative_eq_intros simp add: power2_eq_square algebra_simps) }
qed (simp_all add: field_simps power_eq_if[of _ 2] power_eq_if[of _ 3] power_diff[of "2::real", OF _ \<open>l < l'\<close>[THEN less_imp_le]] )

lemma l2_when_right_child:
  assumes "l < l'"
  and i'_bot: "i' > i * 2^(l' - l)"
  and i'_top: "i' < (i + 1) * 2^(l' - l)"
  shows "l2_\<phi> (l', i') (l, i) = (1 - real_of_int i' / 2^(l' - l) + real_of_int i) / 2^(l' + 1)"
proof (subst l2_\<phi>I_DERIV)
  let ?l' = "(2 :: real)^(l' + 1)"
  let ?in' = "real_of_int i' - 1"
  let ?ip' = "real_of_int i' + 1"
  let ?l = "(2 :: real)^(l + 1)"
  let ?i = "real_of_int i + 1"
  let ?\<phi>' = "\<phi> (l',i')"
  let ?\<phi> = "\<phi> (l, i)"
  let ?\<phi>2 = "\<lambda>x. ?\<phi>' x * ?\<phi> x"
  define \<Phi>_n where "\<Phi>_n x = x^2 / 2 * (?in' * ?l + ?i * ?l') - x^3 / 3 * ?l' * ?l - x * ?i * ?in'" for x
  define \<Phi>_p where "\<Phi>_p x = x^3 / 3 * ?l' * ?l + x * ?i * ?ip' - x^2 / 2 * (?ip' * ?l + ?i * ?l')" for x

  have level_diff: "2^(l' - l) = 2^l' / (2^l :: real)" using power_diff[of "2::real" l l'] \<open>l < l'\<close> by auto

  { fix x assume x: "x \<in> {?in' / ?l' .. ?ip' / ?l'}"
    have "real_of_int i * 2^(l' - l) \<le> ?in'"
      using i'_bot int_less_real_le by auto
    hence "real_of_int i / ?l \<le> ?in' / ?l'"
      using level_diff by (auto simp: field_simps)
    hence "real_of_int i / ?l \<le> x" using x by auto
    moreover
    have "?ip' \<le> ?i * 2^(l' - l)"
      using i'_top int_less_real_le by auto
    hence ip'_le_i: "?ip' / ?l' \<le> ?i / ?l"
      using level_diff by (auto simp: field_simps)
    hence "x \<le> ?i / ?l" using x by auto
    ultimately have "?\<phi> x = ?i - ?l * x" using \<phi>_right_support' by auto
  } note \<phi>_eq = this

  { fix x assume x: "x \<in> {?in' / ?l' .. real_of_int i' / ?l'}"
    hence \<phi>'_eq: "?\<phi>' x = ?l' * x  - ?in'" using \<phi>_left_support' by auto

    from x have x': "x \<in> {?in' / ?l' .. ?ip' / ?l'}" by (simp add: field_simps)
    show "DERIV \<Phi>_n x :> ?\<phi>2 x" unfolding \<Phi>_n_def \<phi>_eq[OF x'] \<phi>'_eq
      by (auto intro!: derivative_eq_intros simp add: simp add: power2_eq_square algebra_simps) }

  { fix x assume x: "x \<in> {real_of_int i' / ?l' .. ?ip' / ?l'}"
    hence \<phi>'_eq: "?\<phi>' x = ?ip' - ?l' * x" using \<phi>_right_support' by auto
    from x have x': "x \<in> {?in' / ?l' .. ?ip' / ?l'}" by (auto simp: field_simps)
    show "DERIV \<Phi>_p x :> ?\<phi>2 x" unfolding \<phi>_eq[OF x'] \<phi>'_eq \<Phi>_p_def
      by (auto intro!: derivative_eq_intros simp add: power2_eq_square algebra_simps) }
qed (simp_all add: field_simps power_eq_if[of _ 2] power_eq_if[of _ 3] power_diff[of "2::real", OF _ \<open>l < l'\<close>[THEN less_imp_le]] )

lemma level_shift: "lc > l \<Longrightarrow> (x :: real) / 2 ^ (lc - Suc l) = x * 2 / 2 ^ (lc - l)"
  by (auto simp add: power_diff)

lemma l2_child: assumes "d < length b"
  and p_grid: "p \<in> grid (child b dir d) ds" (is "p \<in> grid ?child ds")
  shows "l2_\<phi> (p ! d) (b ! d) = (1 - real_of_int (sgn dir) * (real_of_int (ix p d) / 2^(lv p d - lv b d) - real_of_int (ix b d))) /
                                 2^(lv p d + 1)"
proof -
  have "lv ?child d \<le> lv p d" using \<open>d < length b\<close> and p_grid
    using grid_single_level by auto
  hence "lv b d < lv p d" using \<open>d < length b\<close> and p_grid
    using child_lv by auto

  let ?i_c = "ix ?child d" and ?l_c = "lv ?child d"
  let ?i_p = "ix p d" and ?l_p = "lv p d"
  let ?i_b = "ix b d" and ?l_b = "lv b d"

  have "(2::int) * 2^(?l_p - ?l_c) = 2^Suc (?l_p - ?l_c)" by auto
  also have "\<dots> = 2^(Suc ?l_p - ?l_c)"
  proof -
    have "Suc (?l_p - ?l_c) = Suc ?l_p - ?l_c"
      using \<open>lv ?child d \<le> lv p d\<close> by auto
    thus ?thesis by auto
  qed
  also have "\<dots> = 2^(?l_p - ?l_b)"
    using \<open>d < length b\<close> and \<open>lv b d < lv p d\<close>
    by (auto simp add: child_def lv_def)
  finally have level: "2^(?l_p - ?l_b) = (2::int) * 2^(?l_p - ?l_c)" ..

  from \<open>d < length b\<close> and p_grid
  have range_left: "?i_p > (?i_c - 1) * 2^(?l_p - ?l_c)" and
       range_right: "?i_p < (?i_c + 1) * 2^(?l_p - ?l_c)"
    using grid_estimate by auto

  show ?thesis
  proof (cases dir)
    case left
    with child_ix_left[OF \<open>d < length b\<close>]
    have "(?i_b - 1) * 2^(?l_p - ?l_b) = (?i_c - 1) * 2^(?l_p - ?l_c)" and
      "?i_b * 2^(?l_p - ?l_b) = (?i_c + 1) * 2^(?l_p - ?l_c)" using level by auto
    hence "?i_p > (?i_b - 1) * 2^(?l_p - ?l_b)" and
      "?i_p < ?i_b * 2^(?l_p - ?l_b)"
      using range_left and range_right by auto
    with \<open>?l_b < ?l_p\<close>
    have "l2_\<phi> (?l_p, ?i_p) (?l_b, ?i_b) =
          (1 + real_of_int ?i_p / 2^(?l_p - ?l_b) - real_of_int ?i_b) / 2^(?l_p + 1)"
      by (rule l2_when_left_child)
    thus ?thesis using left by (auto simp add: ix_def lv_def)
  next
    case right
    hence "?i_c = 2 * ?i_b + 1" using child_ix_right and \<open>d < length b\<close> by auto
    hence "?i_b * 2^(?l_p - ?l_b) = (?i_c - 1) * 2^(?l_p - ?l_c)" and
      "(?i_b + 1) * 2^(?l_p - ?l_b) = (?i_c + 1) * 2^(?l_p - ?l_c)" using level by auto
    hence "?i_p > ?i_b * 2^(?l_p - ?l_b)" and
      "?i_p < (?i_b + 1) * 2^(?l_p - ?l_b)"
      using range_left and range_right by auto
    with \<open>?l_b < ?l_p\<close>
    have "l2_\<phi> (?l_p, ?i_p) (?l_b, ?i_b) =
          (1 - real_of_int ?i_p / 2^(?l_p - ?l_b) + real_of_int ?i_b) / 2^(?l_p + 1)"
      by (rule l2_when_right_child)
    thus ?thesis using right by (auto simp add: ix_def lv_def)
  qed
qed

lemma l2_same: "l2_\<phi> (p!d) (p!d) = 1/3 / 2^(lv p d)"
proof -
  have "l2_\<phi> (p!d) (p!d) = l2_\<phi> (lv p d, ix p d) (lv p d, ix p d)"
    by (auto simp add: lv_def ix_def)
  thus ?thesis using l2_when_same by auto
qed

lemma l2_disjoint: assumes "d < length b" and "p \<in> grid b {d}" and "p' \<in> grid b {d}"
  and "p' \<notin> grid p {d}" and "lv p' d \<ge> lv p d"
  shows "l2_\<phi> (p' ! d) (p ! d) = 0"
proof -
  have range: "ix p' d > (ix p d + 1) * 2^(lv p' d - lv p d) \<or> ix p' d < (ix p d - 1) * 2^(lv p' d - lv p d)"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    hence "ix p' d \<le> (ix p d + 1) * 2^(lv p' d - lv p d)" and "ix p' d \<ge> (ix p d - 1) * 2^(lv p' d - lv p d)" by auto
    with \<open>p' \<in> grid b {d}\<close> and \<open>p \<in> grid b {d}\<close> and \<open>lv p' d \<ge> lv p d\<close> and \<open>d < length b\<close>
    have "p' \<in> grid p {d}" using grid_part[where p=p and b=b and d=d and p'=p'] by auto
    with \<open>p' \<notin> grid p {d}\<close> show False by auto
  qed

  have "l2_\<phi> (p' ! d) (p ! d) = l2_\<phi> (lv p' d, ix p' d) (lv p d, ix p d)" by (auto simp add: ix_def lv_def)
  also have "\<dots> = 0" using range and \<open>lv p' d \<ge> lv p d\<close> and l2_when_disjoint by auto
  finally show ?thesis .
qed

lemma l2_down2:
  fixes pc pd p
  assumes "d < length pd"
  assumes pc_in_grid: "pc \<in> grid (child pd dir d) {d}"
  assumes pd_is_child: "pd = child p dir d" (is "pd = ?pd")
  shows "l2_\<phi> (pc ! d) (pd ! d) / 2 = l2_\<phi> (pc ! d) (p ! d)"
proof -
  have "d < length p" using pd_is_child \<open>d < length pd\<close> by auto

  moreover
  have "pc \<in> grid ?pd {d}" using pd_is_child and grid_child and pc_in_grid by auto
  hence "lv p d < lv pc d" using grid_child_level and \<open>d < length pd\<close> and pd_is_child by auto

  moreover
  have "real_of_int (sgn dir) * real_of_int (sgn dir) = 1" by (cases dir, auto)

  ultimately show ?thesis
    unfolding l2_child[OF \<open>d < length pd\<close> pc_in_grid]
              l2_child[OF \<open>d < length p\<close> \<open>pc \<in> grid ?pd {d}\<close>]
    using child_lv and child_ix and pd_is_child and level_shift
    by (auto simp add: algebra_simps diff_divide_distrib add_divide_distrib)
qed

lemma l2_zigzag:
  assumes "d < length p" and p_child: "p = child p_p dir d"
  and p'_grid: "p' \<in> grid (child p (inv dir) d) {d}"
  and ps_intro: "child p (inv dir) d = child ps dir d" (is "?c_p = ?c_ps")
  shows "l2_\<phi> (p' ! d) (p_p ! d) = l2_\<phi> (p' ! d) (ps ! d) + l2_\<phi> (p' ! d) (p ! d) / 2"
proof -
  have "length p = length ?c_p" by auto
  also have "\<dots> = length ?c_ps" using ps_intro by auto
  finally have "length p = length ps" using ps_intro by auto
  hence "d < length p_p" using p_child and \<open>d < length p\<close> by auto

  moreover
  from ps_intro have "ps = p[d := (lv p d, ix p d - sgn dir)]" by (rule child_neighbour)
  hence "lv ps d = lv p d" and "real_of_int (ix ps d) = real_of_int (ix p d) - real_of_int (sgn dir)"
    using lv_def and ix_def and \<open>length p = length ps\<close> and \<open>d < length p\<close> by auto

  moreover
  have "d < length ps" and *: "p' \<in> grid (child ps dir d) {d}"
    using p'_grid ps_intro \<open>length p = length ps\<close> \<open>d < length p\<close> by auto

  have "p' \<in> grid p {d}" using p'_grid and grid_child by auto
  hence p_p_grid: "p' \<in> grid (child p_p dir d) {d}" using p_child by auto
  hence "lv p' d > lv p_p d" using grid_child_level and \<open>d < length p_p\<close> by auto

  moreover
  have "real_of_int (sgn dir) * real_of_int (sgn dir) = 1" by (cases dir, auto)

  ultimately show ?thesis
    unfolding l2_child[OF \<open>d < length p\<close> p'_grid] l2_child[OF \<open>d < length ps\<close> *]
              l2_child[OF \<open>d < length p_p\<close> p_p_grid]
    using child_lv and child_ix and p_child level_shift
    by (auto simp add: add_divide_distrib algebra_simps diff_divide_distrib)
qed

end