(*  Title:      HOL/TLA/Inc/Inc.thy
    Author:     Stephan Merz, University of Munich
*)

section \<open>Lamport's "increment" example\<close>

theory Inc
imports "HOL-TLA.TLA"
begin

(* program counter as an enumeration type *)
datatype pcount = a | b | g

axiomatization
  (* program variables *)
  x :: "nat stfun" and
  y :: "nat stfun" and
  sem :: "nat stfun" and
  pc1 :: "pcount stfun" and
  pc2 :: "pcount stfun" and

  (* names of actions and predicates *)
  M1 :: action and
  M2 :: action and
  N1 :: action and
  N2 :: action and
  alpha1 :: action and
  alpha2 :: action and
  beta1 :: action and
  beta2 :: action and
  gamma1 :: action and
  gamma2 :: action and
  InitPhi :: stpred and
  InitPsi :: stpred and
  PsiInv :: stpred and
  PsiInv1 :: stpred and
  PsiInv2 :: stpred and
  PsiInv3 :: stpred and

  (* temporal formulas *)
  Phi :: temporal and
  Psi :: temporal
where
  (* the "base" variables, required to compute enabledness predicates *)
  Inc_base:      "basevars (x, y, sem, pc1, pc2)" and

  (* definitions for high-level program *)
  InitPhi_def:   "InitPhi == PRED x = # 0 \<and> y = # 0" and
  M1_def:        "M1      == ACT  x$ = Suc<$x> \<and> y$ = $y" and
  M2_def:        "M2      == ACT  y$ = Suc<$y> \<and> x$ = $x" and
  Phi_def:       "Phi     == TEMP Init InitPhi \<and> \<box>[M1 \<or> M2]_(x,y)
                                 \<and> WF(M1)_(x,y) \<and> WF(M2)_(x,y)" and

  (* definitions for low-level program *)
  InitPsi_def:   "InitPsi == PRED pc1 = #a \<and> pc2 = #a
                                 \<and> x = # 0 \<and> y = # 0 \<and> sem = # 1" and
  alpha1_def:    "alpha1  == ACT  $pc1 = #a \<and> pc1$ = #b \<and> $sem = Suc<sem$>
                                 \<and> unchanged(x,y,pc2)" and
  alpha2_def:    "alpha2  == ACT  $pc2 = #a \<and> pc2$ = #b \<and> $sem = Suc<sem$>
                                 \<and> unchanged(x,y,pc1)" and
  beta1_def:     "beta1   == ACT  $pc1 = #b \<and> pc1$ = #g \<and> x$ = Suc<$x>
                                 \<and> unchanged(y,sem,pc2)" and
  beta2_def:     "beta2   == ACT  $pc2 = #b \<and> pc2$ = #g \<and> y$ = Suc<$y>
                                 \<and> unchanged(x,sem,pc1)" and
  gamma1_def:    "gamma1  == ACT  $pc1 = #g \<and> pc1$ = #a \<and> sem$ = Suc<$sem>
                                 \<and> unchanged(x,y,pc2)" and
  gamma2_def:    "gamma2  == ACT  $pc2 = #g \<and> pc2$ = #a \<and> sem$ = Suc<$sem>
                                 \<and> unchanged(x,y,pc1)" and
  N1_def:        "N1      == ACT  (alpha1 \<or> beta1 \<or> gamma1)" and
  N2_def:        "N2      == ACT  (alpha2 \<or> beta2 \<or> gamma2)" and
  Psi_def:       "Psi     == TEMP Init InitPsi
                               \<and> \<box>[N1 \<or> N2]_(x,y,sem,pc1,pc2)
                               \<and> SF(N1)_(x,y,sem,pc1,pc2)
                               \<and> SF(N2)_(x,y,sem,pc1,pc2)" and

  PsiInv1_def:  "PsiInv1  == PRED sem = # 1 \<and> pc1 = #a \<and> pc2 = #a" and
  PsiInv2_def:  "PsiInv2  == PRED sem = # 0 \<and> pc1 = #a \<and> (pc2 = #b \<or> pc2 = #g)" and
  PsiInv3_def:  "PsiInv3  == PRED sem = # 0 \<and> pc2 = #a \<and> (pc1 = #b \<or> pc1 = #g)" and
  PsiInv_def:   "PsiInv   == PRED (PsiInv1 \<or> PsiInv2 \<or> PsiInv3)"

lemmas PsiInv_defs = PsiInv_def PsiInv1_def PsiInv2_def PsiInv3_def
lemmas Psi_defs = Psi_def InitPsi_def N1_def N2_def alpha1_def alpha2_def
  beta1_def beta2_def gamma1_def gamma2_def

(*** Invariant proof for Psi: "manual" proof proves individual lemmas ***)

lemma PsiInv_Init: "\<turnstile> InitPsi \<longrightarrow> PsiInv"
  by (auto simp: InitPsi_def PsiInv_defs)

lemma PsiInv_alpha1: "\<turnstile> alpha1 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: alpha1_def PsiInv_defs)

lemma PsiInv_alpha2: "\<turnstile> alpha2 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: alpha2_def PsiInv_defs)

lemma PsiInv_beta1: "\<turnstile> beta1 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: beta1_def PsiInv_defs)

lemma PsiInv_beta2: "\<turnstile> beta2 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: beta2_def PsiInv_defs)

lemma PsiInv_gamma1: "\<turnstile> gamma1 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: gamma1_def PsiInv_defs)

lemma PsiInv_gamma2: "\<turnstile> gamma2 \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: gamma2_def PsiInv_defs)

lemma PsiInv_stutter: "\<turnstile> unchanged (x,y,sem,pc1,pc2) \<and> $PsiInv \<longrightarrow> PsiInv$"
  by (auto simp: PsiInv_defs)

lemma PsiInv: "\<turnstile> Psi \<longrightarrow> \<box>PsiInv"
  apply (invariant simp: Psi_def)
   apply (force simp: PsiInv_Init [try_rewrite] Init_def)
  apply (auto intro: PsiInv_alpha1 [try_rewrite] PsiInv_alpha2 [try_rewrite]
    PsiInv_beta1 [try_rewrite] PsiInv_beta2 [try_rewrite] PsiInv_gamma1 [try_rewrite]
    PsiInv_gamma2 [try_rewrite] PsiInv_stutter [try_rewrite]
    simp add: square_def N1_def N2_def)
  done

(* Automatic proof works too, but it make take a while on a slow machine.
   More realistic examples require user guidance anyway.
*)

lemma "\<turnstile> Psi \<longrightarrow> \<box>PsiInv"
  by (auto_invariant simp: PsiInv_defs Psi_defs)

(**** Step simulation ****)

lemma Init_sim: "\<turnstile> Psi \<longrightarrow> Init InitPhi"
  by (auto simp: InitPhi_def Psi_def InitPsi_def Init_def)

lemma Step_sim: "\<turnstile> Psi \<longrightarrow> \<box>[M1 \<or> M2]_(x,y)"
  by (auto simp: square_def M1_def M2_def Psi_defs elim!: STL4E [temp_use])

(**** Proof of fairness ****)

(*
   The goal is to prove Fair_M1 far below, which asserts
         \<turnstile> Psi \<longrightarrow> WF(M1)_(x,y)
   (the other fairness condition is symmetrical).

   The strategy is to use WF2 (with beta1 as the helpful action). Proving its
   temporal premise needs two auxiliary lemmas:
   1. Stuck_at_b: control can only proceed at pc1 = b by executing beta1
   2. N1_live: the first component will eventually reach b

   Lemma 1 is easy, lemma 2 relies on the invariant, the strong fairness
   of the semaphore, and needs auxiliary lemmas that ensure that the second
   component will eventually release the semaphore. Most of the proofs of
   the auxiliary lemmas are very similar.
*)

lemma Stuck_at_b: "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not> beta1]_(x,y,sem,pc1,pc2) \<longrightarrow> stable(pc1 = #b)"
  by (auto elim!: Stable squareE simp: Psi_defs)

lemma N1_enabled_at_g: "\<turnstile> pc1 = #g \<longrightarrow> Enabled (<N1>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = gamma1 in enabled_mono)
   apply (enabled Inc_base)
  apply (force simp: gamma1_def)
  apply (force simp: angle_def gamma1_def N1_def)
  done

lemma g1_leadsto_a1:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box>#True
    \<longrightarrow> (pc1 = #g \<leadsto> pc1 = #a)"
  apply (rule SF1)
    apply (tactic
      \<open>action_simp_tac (\<^context> addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1\<close>)
   apply (tactic
      \<open>action_simp_tac (\<^context> addsimps @{thm angle_def} :: @{thms Psi_defs}) [] [] 1\<close>)
  (* reduce \<turnstile> \<box>A \<longrightarrow> \<diamond>Enabled B  to  \<turnstile> A \<longrightarrow> Enabled B *)
  apply (auto intro!: InitDmd_gen [temp_use] N1_enabled_at_g [temp_use]
    dest!: STL2_gen [temp_use] simp: Init_def)
  done

(* symmetrical for N2, and similar for beta2 *)
lemma N2_enabled_at_g: "\<turnstile> pc2 = #g \<longrightarrow> Enabled (<N2>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = gamma2 in enabled_mono)
  apply (enabled Inc_base)
   apply (force simp: gamma2_def)
  apply (force simp: angle_def gamma2_def N2_def)
  done

lemma g2_leadsto_a2:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N2)_(x,y,sem,pc1,pc2) \<and> \<box>#True
    \<longrightarrow> (pc2 = #g \<leadsto> pc2 = #a)"
  apply (rule SF1)
  apply (tactic \<open>action_simp_tac (\<^context> addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1\<close>)
  apply (tactic \<open>action_simp_tac (\<^context> addsimps @{thm angle_def} :: @{thms Psi_defs})
    [] [] 1\<close>)
  apply (auto intro!: InitDmd_gen [temp_use] N2_enabled_at_g [temp_use]
    dest!: STL2_gen [temp_use] simp add: Init_def)
  done

lemma N2_enabled_at_b: "\<turnstile> pc2 = #b \<longrightarrow> Enabled (<N2>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = beta2 in enabled_mono)
   apply (enabled Inc_base)
   apply (force simp: beta2_def)
  apply (force simp: angle_def beta2_def N2_def)
  done

lemma b2_leadsto_g2:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N2)_(x,y,sem,pc1,pc2) \<and> \<box>#True
    \<longrightarrow> (pc2 = #b \<leadsto> pc2 = #g)"
  apply (rule SF1)
    apply (tactic
      \<open>action_simp_tac (\<^context> addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1\<close>)
   apply (tactic
     \<open>action_simp_tac (\<^context> addsimps @{thm angle_def} :: @{thms Psi_defs}) [] [] 1\<close>)
  apply (auto intro!: InitDmd_gen [temp_use] N2_enabled_at_b [temp_use]
    dest!: STL2_gen [temp_use] simp: Init_def)
  done

(* Combine above lemmas: the second component will eventually reach pc2 = a *)
lemma N2_leadsto_a:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N2)_(x,y,sem,pc1,pc2) \<and> \<box>#True
    \<longrightarrow> (pc2 = #a \<or> pc2 = #b \<or> pc2 = #g \<leadsto> pc2 = #a)"
  apply (auto intro!: LatticeDisjunctionIntro [temp_use])
    apply (rule LatticeReflexivity [temp_use])
   apply (rule LatticeTransitivity [temp_use])
  apply (auto intro!: b2_leadsto_g2 [temp_use] g2_leadsto_a2 [temp_use])
  done

(* Get rid of disjunction on the left-hand side of \<leadsto> above. *)
lemma N2_live:
  "\<turnstile> \<box>[(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2) \<and> SF(N2)_(x,y,sem,pc1,pc2)
    \<longrightarrow> \<diamond>(pc2 = #a)"
  apply (auto simp: Init_defs intro!: N2_leadsto_a [temp_use, THEN [2] leadsto_init [temp_use]])
  apply (case_tac "pc2 (st1 sigma)")
    apply auto
  done

(* Now prove that the first component will eventually reach pc1 = b from pc1 = a *)

lemma N1_enabled_at_both_a:
  "\<turnstile> pc2 = #a \<and> (PsiInv \<and> pc1 = #a) \<longrightarrow> Enabled (<N1>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = alpha1 in enabled_mono)
  apply (enabled Inc_base)
   apply (force simp: alpha1_def PsiInv_defs)
  apply (force simp: angle_def alpha1_def N1_def)
  done

lemma a1_leadsto_b1:
  "\<turnstile> \<box>($PsiInv \<and> [(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2))
         \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box> SF(N2)_(x,y,sem,pc1,pc2)
         \<longrightarrow> (pc1 = #a \<leadsto> pc1 = #b)"
  apply (rule SF1)
  apply (tactic \<open>action_simp_tac (\<^context> addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1\<close>)
  apply (tactic
    \<open>action_simp_tac (\<^context> addsimps (@{thm angle_def} :: @{thms Psi_defs})) [] [] 1\<close>)
  apply (clarsimp intro!: N1_enabled_at_both_a [THEN DmdImpl [temp_use]])
  apply (auto intro!: BoxDmd2_simple [temp_use] N2_live [temp_use]
    simp: split_box_conj more_temp_simps)
  done

(* Combine the leadsto properties for N1: it will arrive at pc1 = b *)

lemma N1_leadsto_b: "\<turnstile> \<box>($PsiInv \<and> [(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2))
         \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box> SF(N2)_(x,y,sem,pc1,pc2)
         \<longrightarrow> (pc1 = #b \<or> pc1 = #g \<or> pc1 = #a \<leadsto> pc1 = #b)"
  apply (auto intro!: LatticeDisjunctionIntro [temp_use])
    apply (rule LatticeReflexivity [temp_use])
   apply (rule LatticeTransitivity [temp_use])
    apply (auto intro!: a1_leadsto_b1 [temp_use] g1_leadsto_a1 [temp_use]
      simp: split_box_conj)
  done

lemma N1_live: "\<turnstile> \<box>($PsiInv \<and> [(N1 \<or> N2) \<and> \<not>beta1]_(x,y,sem,pc1,pc2))
         \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box> SF(N2)_(x,y,sem,pc1,pc2)
         \<longrightarrow> \<diamond>(pc1 = #b)"
  apply (auto simp: Init_defs intro!: N1_leadsto_b [temp_use, THEN [2] leadsto_init [temp_use]])
  apply (case_tac "pc1 (st1 sigma)")
    apply auto
  done

lemma N1_enabled_at_b: "\<turnstile> pc1 = #b \<longrightarrow> Enabled (<N1>_(x,y,sem,pc1,pc2))"
  apply clarsimp
  apply (rule_tac F = beta1 in enabled_mono)
   apply (enabled Inc_base)
   apply (force simp: beta1_def)
  apply (force simp: angle_def beta1_def N1_def)
  done

(* Now assemble the bits and pieces to prove that Psi is fair. *)

lemma Fair_M1_lemma: "\<turnstile> \<box>($PsiInv \<and> [(N1 \<or> N2)]_(x,y,sem,pc1,pc2))
         \<and> SF(N1)_(x,y,sem,pc1,pc2) \<and> \<box>SF(N2)_(x,y,sem,pc1,pc2)
         \<longrightarrow> SF(M1)_(x,y)"
  apply (rule_tac B = beta1 and P = "PRED pc1 = #b" in SF2)
   (* action premises *)
     apply (force simp: angle_def M1_def beta1_def)
  apply (force simp: angle_def Psi_defs)
  apply (force elim!: N1_enabled_at_b [temp_use])
    (* temporal premise: use previous lemmas and simple TL *)
  apply (force intro!: DmdStable [temp_use] N1_live [temp_use] Stuck_at_b [temp_use]
    elim: STL4E [temp_use] simp: square_def)
  done

lemma Fair_M1: "\<turnstile> Psi \<longrightarrow> WF(M1)_(x,y)"
  by (auto intro!: SFImplWF [temp_use] Fair_M1_lemma [temp_use] PsiInv [temp_use]
    simp: Psi_def split_box_conj [temp_use] more_temp_simps)

end


theory BlexerSimp
  imports Blexer
begin

fun distinctWith :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a list"
  where
  "distinctWith [] eq acc = []"
| "distinctWith (x # xs) eq acc =
     (if (\<exists> y \<in> acc. eq x y) then distinctWith xs eq acc
      else x # (distinctWith xs eq ({x} \<union> acc)))"

fun eq1 ("_ ~1 _" [80, 80] 80) where
  "AZERO ~1 AZERO = True"
| "(AONE bs1) ~1 (AONE bs2) = True"
| "(ACHAR bs1 c) ~1 (ACHAR bs2 d) = (if c = d then True else False)"
| "(ASEQ bs1 ra1 ra2) ~1 (ASEQ bs2 rb1 rb2) = (ra1 ~1 rb1 \<and> ra2 ~1 rb2)"
| "(AALTs bs1 []) ~1 (AALTs bs2 []) = True"
| "(AALTs bs1 (r1 # rs1)) ~1 (AALTs bs2 (r2 # rs2)) = (r1 ~1 r2 \<and> (AALTs bs1 rs1) ~1 (AALTs bs2 rs2))"
| "(ASTAR bs1 r1) ~1 (ASTAR bs2 r2) = r1 ~1 r2"
| "(ANTIMES bs1 r1 n1) ~1 (ANTIMES bs2 r2 n2) = (r1 ~1 r2 \<and> n1 = n2)"
| "_ ~1 _ = False"

lemma eq1_L:
  assumes "x ~1 y"
  shows "L (erase x) = L (erase y)"
  using assms
  apply(induct rule: eq1.induct)
  apply(auto elim: eq1.elims)
  apply presburger
  done

fun flts :: "arexp list \<Rightarrow> arexp list"
  where
  "flts [] = []"
| "flts (AZERO # rs) = flts rs"
| "flts ((AALTs bs  rs1) # rs) = (map (fuse bs) rs1) @ flts rs"
| "flts (r1 # rs) = r1 # flts rs"

fun bsimp_ASEQ :: "bit list \<Rightarrow> arexp \<Rightarrow> arexp \<Rightarrow> arexp"
  where
  "bsimp_ASEQ _ AZERO _ = AZERO"
| "bsimp_ASEQ _ _ AZERO = AZERO"
| "bsimp_ASEQ bs1 (AONE bs2) r2 = fuse (bs1 @ bs2) r2"
| "bsimp_ASEQ bs1 r1 r2 = ASEQ  bs1 r1 r2"

lemma bsimp_ASEQ0[simp]:
  shows "bsimp_ASEQ bs r1 AZERO = AZERO"
  by (case_tac r1)(simp_all)

lemma bsimp_ASEQ1:
  assumes "r1 \<noteq> AZERO" "r2 \<noteq> AZERO" "\<nexists>bs. r1 = AONE bs"
  shows "bsimp_ASEQ bs r1 r2 = ASEQ bs r1 r2"
  using assms
  apply(induct bs r1 r2 rule: bsimp_ASEQ.induct)
  apply(auto)
  done

lemma bsimp_ASEQ2[simp]:
  shows "bsimp_ASEQ bs1 (AONE bs2) r2 = fuse (bs1 @ bs2) r2"
  by (case_tac r2) (simp_all)

fun bsimp_AALTs :: "bit list \<Rightarrow> arexp list \<Rightarrow> arexp"
  where
  "bsimp_AALTs _ [] = AZERO"
| "bsimp_AALTs bs1 [r] = fuse bs1 r"
| "bsimp_AALTs bs1 rs = AALTs bs1 rs"

fun bsimp :: "arexp \<Rightarrow> arexp"
  where
  "bsimp (ASEQ bs1 r1 r2) = bsimp_ASEQ bs1 (bsimp r1) (bsimp r2)"
| "bsimp (AALTs bs1 rs) = bsimp_AALTs bs1 (distinctWith (flts (map bsimp rs)) eq1 {}) "
| "bsimp r = r"

fun
  bders_simp :: "arexp \<Rightarrow> string \<Rightarrow> arexp"
where
  "bders_simp r [] = r"
| "bders_simp r (c # s) = bders_simp (bsimp (bder c r)) s"

definition blexer_simp where
 "blexer_simp r s \<equiv> if bnullable (bders_simp (intern r) s) then
                    decode (bmkeps (bders_simp (intern r) s)) r else None"

lemma bders_simp_append:
  shows "bders_simp r (s1 @ s2) = bders_simp (bders_simp r s1) s2"
  apply(induct s1 arbitrary: r s2)
  apply(simp_all)
  done

lemma bmkeps_fuse:
  assumes "bnullable r"
  shows "bmkeps (fuse bs r) = bs @ bmkeps r"
  using assms
  apply(induct r rule: bnullable.induct)
        apply(auto)
  apply (metis append.assoc bmkeps_retrieve bmkeps_retrieve_AALTs bnullable.simps(4))
  done

lemma bmkepss_fuse:
  assumes "bnullables rs"
  shows "bmkepss (map (fuse bs) rs) = bs @ bmkepss rs"
  using assms
  apply(induct rs arbitrary: bs)
  apply(auto simp add: bmkeps_fuse bnullable_fuse)
  done

lemma bder_fuse:
  shows "bder c (fuse bs a) = fuse bs  (bder c a)"
  apply(induct a arbitrary: bs c)
  apply(simp_all)
  done

inductive
  rrewrite:: "arexp \<Rightarrow> arexp \<Rightarrow> bool" ("_ \<leadsto> _" [99, 99] 99)
and
  srewrite:: "arexp list \<Rightarrow> arexp list \<Rightarrow> bool" (" _ s\<leadsto> _" [100, 100] 100)
where
  bs1: "ASEQ bs AZERO r2 \<leadsto> AZERO"
| bs2: "ASEQ bs r1 AZERO \<leadsto> AZERO"
| bs3: "ASEQ bs1 (AONE bs2) r \<leadsto> fuse (bs1@bs2) r"
| bs4: "r1 \<leadsto> r2 \<Longrightarrow> ASEQ bs r1 r3 \<leadsto> ASEQ bs r2 r3"
| bs5: "r3 \<leadsto> r4 \<Longrightarrow> ASEQ bs r1 r3 \<leadsto> ASEQ bs r1 r4"
| bs6: "AALTs bs [] \<leadsto> AZERO"
| bs7: "AALTs bs [r] \<leadsto> fuse bs r"
| bs10: "rs1 s\<leadsto> rs2 \<Longrightarrow> AALTs bs rs1 \<leadsto> AALTs bs rs2"
| ss1:  "[] s\<leadsto> []"
| ss2:  "rs1 s\<leadsto> rs2 \<Longrightarrow> (r # rs1) s\<leadsto> (r # rs2)"
| ss3:  "r1 \<leadsto> r2 \<Longrightarrow> (r1 # rs) s\<leadsto> (r2 # rs)"
| ss4:  "(AZERO # rs) s\<leadsto> rs"
| ss5:  "(AALTs bs1 rs1 # rsb) s\<leadsto> ((map (fuse bs1) rs1) @ rsb)"
| ss6:  "L (erase a2) \<subseteq> L (erase a1) \<Longrightarrow> (rsa@[a1]@rsb@[a2]@rsc) s\<leadsto> (rsa@[a1]@rsb@rsc)"

inductive
  rrewrites:: "arexp \<Rightarrow> arexp \<Rightarrow> bool" ("_ \<leadsto>* _" [100, 100] 100)
where
  rs1[intro, simp]:"r \<leadsto>* r"
| rs2[intro]: "\<lbrakk>r1 \<leadsto>* r2; r2 \<leadsto> r3\<rbrakk> \<Longrightarrow> r1 \<leadsto>* r3"

inductive
  srewrites:: "arexp list \<Rightarrow> arexp list \<Rightarrow> bool" ("_ s\<leadsto>* _" [100, 100] 100)
where
  sss1[intro, simp]:"rs s\<leadsto>* rs"
| sss2[intro]: "\<lbrakk>rs1 s\<leadsto> rs2; rs2 s\<leadsto>* rs3\<rbrakk> \<Longrightarrow> rs1 s\<leadsto>* rs3"

lemma r_in_rstar : "r1 \<leadsto> r2 \<Longrightarrow> r1 \<leadsto>* r2"
  using rrewrites.intros(1) rrewrites.intros(2) by blast

lemma rs_in_rstar:
  shows "r1 s\<leadsto> r2 \<Longrightarrow> r1 s\<leadsto>* r2"
  using rrewrites.intros(1) rrewrites.intros(2) by blast

lemma rrewrites_trans[trans]:
  assumes a1: "r1 \<leadsto>* r2"  and a2: "r2 \<leadsto>* r3"
  shows "r1 \<leadsto>* r3"
  using a2 a1
  apply(induct r2 r3 arbitrary: r1 rule: rrewrites.induct)
  apply(auto)
  done

lemma srewrites_trans[trans]:
  assumes a1: "r1 s\<leadsto>* r2"  and a2: "r2 s\<leadsto>* r3"
  shows "r1 s\<leadsto>* r3"
  using a1 a2
  apply(induct r1 r2 arbitrary: r3 rule: srewrites.induct)
   apply(auto)
  done

lemma contextrewrites0:
  "rs1 s\<leadsto>* rs2 \<Longrightarrow> AALTs bs rs1 \<leadsto>* AALTs bs rs2"
  apply(induct rs1 rs2 rule: srewrites.inducts)
   apply simp
  using bs10 r_in_rstar rrewrites_trans by blast

lemma contextrewrites1:
  "r \<leadsto>* r' \<Longrightarrow> AALTs bs (r # rs) \<leadsto>* AALTs bs (r' # rs)"
  apply(induct r r' rule: rrewrites.induct)
   apply simp
  using bs10 ss3 by blast

lemma srewrite1:
  shows "rs1 s\<leadsto> rs2 \<Longrightarrow> (rs @ rs1) s\<leadsto> (rs @ rs2)"
  apply(induct rs)
   apply(auto)
  using ss2 by auto

lemma srewrites1:
  shows "rs1 s\<leadsto>* rs2 \<Longrightarrow> (rs @ rs1) s\<leadsto>* (rs @ rs2)"
  apply(induct rs1 rs2 rule: srewrites.induct)
   apply(auto)
  using srewrite1 by blast

lemma srewrite2:
  shows  "r1 \<leadsto> r2 \<Longrightarrow> True"
  and "rs1 s\<leadsto> rs2 \<Longrightarrow> (rs1 @ rs) s\<leadsto>* (rs2 @ rs)"
  apply(induct rule: rrewrite_srewrite.inducts)
  apply(auto)
  apply (metis append_Cons append_Nil srewrites1)
  apply(meson srewrites.simps ss3)
  apply (meson srewrites.simps ss4)
  apply (meson srewrites.simps ss5)
  by (metis append_Cons append_Nil srewrites.simps ss6)

lemma srewrites3:
  shows "rs1 s\<leadsto>* rs2 \<Longrightarrow> (rs1 @ rs) s\<leadsto>* (rs2 @ rs)"
  apply(induct rs1 rs2 arbitrary: rs rule: srewrites.induct)
   apply(auto)
  by (meson srewrite2(2) srewrites_trans)

(*
lemma srewrites4:
  assumes "rs3 s\<leadsto>* rs4" "rs1 s\<leadsto>* rs2"
  shows "(rs1 @ rs3) s\<leadsto>* (rs2 @ rs4)"
  using assms
  apply(induct rs3 rs4 arbitrary: rs1 rs2 rule: srewrites.induct)
  apply (simp add: srewrites3)
  using srewrite1 by blast
*)

lemma srewrites6:
  assumes "r1 \<leadsto>* r2"
  shows "[r1] s\<leadsto>* [r2]"
  using assms
  apply(induct r1 r2 rule: rrewrites.induct)
   apply(auto)
  by (meson srewrites.simps srewrites_trans ss3)

lemma srewrites7:
  assumes "rs3 s\<leadsto>* rs4" "r1 \<leadsto>* r2"
  shows "(r1 # rs3) s\<leadsto>* (r2 # rs4)"
  using assms
  by (smt (verit, best) append_Cons append_Nil srewrites1 srewrites3 srewrites6 srewrites_trans)

lemma ss6_stronger_aux:
  shows "(rs1 @ rs2) s\<leadsto>* (rs1 @ distinctWith rs2 eq1 (set rs1))"
  apply(induct rs2 arbitrary: rs1)
  apply(auto)
  prefer 2
  apply(drule_tac x="rs1 @ [a]" in meta_spec)
  apply(simp)
  apply(drule_tac x="rs1" in meta_spec)
  apply(subgoal_tac "(rs1 @ a # rs2) s\<leadsto>* (rs1 @ rs2)")
  using srewrites_trans apply blast
  apply(subgoal_tac "\<exists>rs1a rs1b. rs1 = rs1a @ [x] @ rs1b")
  prefer 2
  apply (simp add: split_list)
  apply(erule exE)+
  apply(simp)
  using eq1_L rs_in_rstar ss6 by force

lemma ss6_stronger:
  shows "rs1 s\<leadsto>* distinctWith rs1 eq1 {}"
  by (metis append_Nil list.set(1) ss6_stronger_aux)

lemma rewrite_preserves_fuse:
  shows "r2 \<leadsto> r3 \<Longrightarrow> fuse bs r2 \<leadsto> fuse bs r3"
  and   "rs2 s\<leadsto> rs3 \<Longrightarrow> map (fuse bs) rs2 s\<leadsto>* map (fuse bs) rs3"
proof(induct rule: rrewrite_srewrite.inducts)
  case (bs3 bs1 bs2 r)
  then show ?case
    by (metis fuse.simps(5) fuse_append rrewrite_srewrite.bs3)
next
  case (bs7 bs r)
  then show ?case
    by (metis fuse.simps(4) fuse_append rrewrite_srewrite.bs7)
next
  case (ss2 rs1 rs2 r)
  then show ?case
    using srewrites7 by force
next
  case (ss3 r1 r2 rs)
  then show ?case by (simp add: r_in_rstar srewrites7)
next
  case (ss5 bs1 rs1 rsb)
  then show ?case
    apply(simp)
    by (metis (mono_tags, lifting) comp_def fuse_append map_eq_conv rrewrite_srewrite.ss5 srewrites.simps)
next
  case (ss6 a1 a2 rsa rsb rsc)
  then show ?case
    apply(simp only: map_append)
    by (smt (verit, best) erase_fuse list.simps(8) list.simps(9) rrewrite_srewrite.ss6 srewrites.simps)
qed (auto intro: rrewrite_srewrite.intros)

lemma rewrites_fuse:
  assumes "r1 \<leadsto>* r2"
  shows "fuse bs r1 \<leadsto>* fuse bs r2"
using assms
apply(induction r1 r2 arbitrary: bs rule: rrewrites.induct)
apply(auto intro: rewrite_preserves_fuse rrewrites_trans)
done

lemma star_seq:
  assumes "r1 \<leadsto>* r2"
  shows "ASEQ bs r1 r3 \<leadsto>* ASEQ bs r2 r3"
using assms
apply(induct r1 r2 arbitrary: r3 rule: rrewrites.induct)
apply(auto intro: rrewrite_srewrite.intros)
done

lemma star_seq2:
  assumes "r3 \<leadsto>* r4"
  shows "ASEQ bs r1 r3 \<leadsto>* ASEQ bs r1 r4"
  using assms
apply(induct r3 r4 arbitrary: r1 rule: rrewrites.induct)
apply(auto intro: rrewrite_srewrite.intros)
done

lemma continuous_rewrite:
  assumes "r1 \<leadsto>* AZERO"
  shows "ASEQ bs1 r1 r2 \<leadsto>* AZERO"
using assms bs1 star_seq by blast

(*
lemma continuous_rewrite2:
  assumes "r1 \<leadsto>* AONE bs"
  shows "ASEQ bs1 r1 r2 \<leadsto>* (fuse (bs1 @ bs) r2)"
  using assms  by (meson bs3 rrewrites.simps star_seq)
*)

lemma bsimp_aalts_simpcases:
  shows "AONE bs \<leadsto>* bsimp (AONE bs)"
  and   "AZERO \<leadsto>* bsimp AZERO"
  and   "ACHAR bs c \<leadsto>* bsimp (ACHAR bs c)"
  by (simp_all)

lemma bsimp_AALTs_rewrites:
  shows "AALTs bs1 rs \<leadsto>* bsimp_AALTs bs1 rs"
  by (smt (verit) bs6 bs7 bsimp_AALTs.elims rrewrites.simps)

lemma trivialbsimp_srewrites:
  "\<lbrakk>\<And>x. x \<in> set rs \<Longrightarrow> x \<leadsto>* f x \<rbrakk> \<Longrightarrow> rs s\<leadsto>* (map f rs)"
  apply(induction rs)
   apply simp
  apply(simp)
  using srewrites7 by auto

lemma fltsfrewrites: "rs s\<leadsto>* flts rs"
  apply(induction rs rule: flts.induct)
  apply(auto intro: rrewrite_srewrite.intros)
  apply (meson srewrites.simps srewrites1 ss5)
  using rs1 srewrites7 apply presburger
  using srewrites7 apply force
  apply (simp add: srewrites7)
   apply(simp add: srewrites7)
  by (simp add: srewrites7)

lemma bnullable0:
shows "r1 \<leadsto> r2 \<Longrightarrow> bnullable r1 = bnullable r2"
  and "rs1 s\<leadsto> rs2 \<Longrightarrow> bnullables rs1 = bnullables rs2"
  apply(induct rule: rrewrite_srewrite.inducts)
  apply(auto simp add:  bnullable_fuse)
   apply (meson UnCI bnullable_fuse imageI)
  using bnullable_correctness nullable_correctness by blast

lemma rewritesnullable:
  assumes "r1 \<leadsto>* r2"
  shows "bnullable r1 = bnullable r2"
using assms
  apply(induction r1 r2 rule: rrewrites.induct)
  apply simp
  using bnullable0(1) by auto

lemma rewrite_bmkeps_aux:
  shows "r1 \<leadsto> r2 \<Longrightarrow> (bnullable r1 \<and> bnullable r2 \<Longrightarrow> bmkeps r1 = bmkeps r2)"
  and   "rs1 s\<leadsto> rs2 \<Longrightarrow> (bnullables rs1 \<and> bnullables rs2 \<Longrightarrow> bmkepss rs1 = bmkepss rs2)"
proof (induct rule: rrewrite_srewrite.inducts)
  case (bs3 bs1 bs2 r)
  then show ?case by (simp add: bmkeps_fuse)
next
  case (bs7 bs r)
  then show ?case by (simp add: bmkeps_fuse)
next
  case (ss3 r1 r2 rs)
  then show ?case
    using bmkepss.simps bnullable0(1) by presburger
next
  case (ss5 bs1 rs1 rsb)
  then show ?case
    apply (simp add: bmkepss1 bmkepss2 bmkepss_fuse bnullable_fuse)
    apply(case_tac rs1)
     apply(auto simp add: bnullable_fuse)
    apply (metis bmkeps_retrieve bmkeps_retrieve_AALTs bnullable.simps(4))
    apply (metis bmkeps_retrieve bmkeps_retrieve_AALTs bnullable.simps(4))
    apply (metis bmkeps_retrieve bmkeps_retrieve_AALTs bnullable.simps(4))
    by (metis bmkeps_retrieve bmkeps_retrieve_AALTs bnullable.simps(4))
next
  case (ss6 a1 a2 rsa rsb rsc)
  then show ?case
    by (smt (verit, best) Nil_is_append_conv bmkepss1 bmkepss2 bnullable_correctness in_set_conv_decomp list.distinct(1) list.set_intros(1) nullable_correctness set_ConsD subsetD)
next
  case (bs10 rs1 rs2 bs)
  then show ?case
    by (metis bmkeps_retrieve bmkeps_retrieve_AALTs bnullable.simps(4))
qed (auto)

lemma rewrites_bmkeps:
  assumes "r1 \<leadsto>* r2" "bnullable r1"
  shows "bmkeps r1 = bmkeps r2"
  using assms
proof(induction r1 r2 rule: rrewrites.induct)
  case (rs1 r)
  then show "bmkeps r = bmkeps r" by simp
next
  case (rs2 r1 r2 r3)
  then have IH: "bmkeps r1 = bmkeps r2" by simp
  have a1: "bnullable r1" by fact
  have a2: "r1 \<leadsto>* r2" by fact
  have a3: "r2 \<leadsto> r3" by fact
  have a4: "bnullable r2" using a1 a2 by (simp add: rewritesnullable)
  then have "bmkeps r2 = bmkeps r3"
    using a3 bnullable0(1) rewrite_bmkeps_aux(1) by blast
  then show "bmkeps r1 = bmkeps r3" using IH by simp
qed

lemma rewrites_to_bsimp:
  shows "r \<leadsto>* bsimp r"
proof (induction r rule: bsimp.induct)
  case (1 bs1 r1 r2)
  have IH1: "r1 \<leadsto>* bsimp r1" by fact
  have IH2: "r2 \<leadsto>* bsimp r2" by fact
  { assume as: "bsimp r1 = AZERO \<or> bsimp r2 = AZERO"
    with IH1 IH2 have "r1 \<leadsto>* AZERO \<or> r2 \<leadsto>* AZERO" by auto
    then have "ASEQ bs1 r1 r2 \<leadsto>* AZERO"
      by (metis bs2 continuous_rewrite rrewrites.simps star_seq2)
    then have "ASEQ bs1 r1 r2 \<leadsto>* bsimp (ASEQ bs1 r1 r2)" using as by auto
  }
  moreover
  { assume "\<exists>bs. bsimp r1 = AONE bs"
    then obtain bs where as: "bsimp r1 = AONE bs" by blast
    with IH1 have "r1 \<leadsto>* AONE bs" by simp
    then have "ASEQ bs1 r1 r2 \<leadsto>* fuse (bs1 @ bs) r2" using bs3 star_seq by blast
    with IH2 have "ASEQ bs1 r1 r2 \<leadsto>* fuse (bs1 @ bs) (bsimp r2)"
      using rewrites_fuse by (meson rrewrites_trans)
    then have "ASEQ bs1 r1 r2 \<leadsto>* bsimp (ASEQ bs1 (AONE bs) r2)" by simp
    then have "ASEQ bs1 r1 r2 \<leadsto>* bsimp (ASEQ bs1 r1 r2)" by (simp add: as)
  }
  moreover
  { assume as1: "bsimp r1 \<noteq> AZERO" "bsimp r2 \<noteq> AZERO" and as2: "(\<nexists>bs. bsimp r1 = AONE bs)"
    then have "bsimp_ASEQ bs1 (bsimp r1) (bsimp r2) = ASEQ bs1 (bsimp r1) (bsimp r2)"
      by (simp add: bsimp_ASEQ1)
    then have "ASEQ bs1 r1 r2 \<leadsto>* bsimp_ASEQ bs1 (bsimp r1) (bsimp r2)" using as1 as2 IH1 IH2
      by (metis rrewrites_trans star_seq star_seq2)
    then have "ASEQ bs1 r1 r2 \<leadsto>* bsimp (ASEQ bs1 r1 r2)" by simp
  }
  ultimately show "ASEQ bs1 r1 r2 \<leadsto>* bsimp (ASEQ bs1 r1 r2)" by blast
next
  case (2 bs1 rs)
  have IH: "\<And>x. x \<in> set rs \<Longrightarrow> x \<leadsto>* bsimp x" by fact
  then have "rs s\<leadsto>* (map bsimp rs)" by (simp add: trivialbsimp_srewrites)
  also have "... s\<leadsto>* flts (map bsimp rs)" by (simp add: fltsfrewrites)
  also have "... s\<leadsto>* distinctWith (flts (map bsimp rs)) eq1 {}" by (simp add: ss6_stronger)
  finally have "AALTs bs1 rs \<leadsto>* AALTs bs1 (distinctWith (flts (map bsimp rs)) eq1 {})"
    using contextrewrites0 by auto
  also have "... \<leadsto>* bsimp_AALTs  bs1 (distinctWith (flts (map bsimp rs)) eq1 {})"
    by (simp add: bsimp_AALTs_rewrites)
  finally show "AALTs bs1 rs \<leadsto>* bsimp (AALTs bs1 rs)" by simp
qed (simp_all)

lemma to_zero_in_alt:
  shows "AALT bs (ASEQ [] AZERO r) r2 \<leadsto> AALT bs AZERO r2"
  by (simp add: bs1 bs10 ss3)

lemma  bder_fuse_list:
  shows "map (bder c \<circ> fuse bs1) rs1 = map (fuse bs1 \<circ> bder c) rs1"
  apply(induction rs1)
  apply(simp_all add: bder_fuse)
  done

lemma map1:
  shows "(map f [a]) = [f a]"
  by (simp)

lemma rewrite_preserves_bder:
  shows "r1 \<leadsto> r2 \<Longrightarrow> (bder c r1) \<leadsto>* (bder c r2)"
  and   "rs1 s\<leadsto> rs2 \<Longrightarrow> map (bder c) rs1 s\<leadsto>* map (bder c) rs2"
proof(induction rule: rrewrite_srewrite.inducts)
  case (bs1 bs r2)
  then show ?case
    by (simp add: continuous_rewrite)
next
  case (bs2 bs r1)
  then show ?case
    apply(auto)
    apply (meson bs6 contextrewrites0 rrewrite_srewrite.bs2 rs2 ss3 ss4 sss1 sss2)
    by (simp add: r_in_rstar rrewrite_srewrite.bs2)
next
  case (bs3 bs1 bs2 r)
  then show ?case
    apply(simp)

    by (metis (no_types, lifting) bder_fuse bs10 bs7 fuse_append rrewrites.simps ss4 to_zero_in_alt)
next
  case (bs4 r1 r2 bs r3)
  have as: "r1 \<leadsto> r2" by fact
  have IH: "bder c r1 \<leadsto>* bder c r2" by fact
  from as IH show "bder c (ASEQ bs r1 r3) \<leadsto>* bder c (ASEQ bs r2 r3)"
    by (metis bder.simps(5) bnullable0(1) contextrewrites1 rewrite_bmkeps_aux(1) star_seq)
next
  case (bs5 r3 r4 bs r1)
  have as: "r3 \<leadsto> r4" by fact
  have IH: "bder c r3 \<leadsto>* bder c r4" by fact
  from as IH show "bder c (ASEQ bs r1 r3) \<leadsto>* bder c (ASEQ bs r1 r4)"
    apply(simp)
    apply(auto)
    using contextrewrites0 r_in_rstar rewrites_fuse srewrites6 srewrites7 star_seq2 apply presburger
    using star_seq2 by blast
next
  case (bs6 bs)
  then show ?case
    using rrewrite_srewrite.bs6 by force
next
  case (bs7 bs r)
  then show ?case
    by (simp add: bder_fuse r_in_rstar rrewrite_srewrite.bs7)
next
  case (bs10 rs1 rs2 bs)
  then show ?case
    using contextrewrites0 by force
next
  case ss1
  then show ?case by simp
next
  case (ss2 rs1 rs2 r)
  then show ?case
    by (simp add: srewrites7)
next
  case (ss3 r1 r2 rs)
  then show ?case
    by (simp add: srewrites7)
next
  case (ss4 rs)
  then show ?case
    using rrewrite_srewrite.ss4 by fastforce
next
  case (ss5 bs1 rs1 rsb)
  then show ?case
    apply(simp)
    using bder_fuse_list map_map rrewrite_srewrite.ss5 srewrites.simps by blast
next
  case (ss6 a1 a2 bs rsa rsb)
  then show ?case
    apply(simp only: map_append map1)
    apply(rule srewrites_trans)
    apply(rule rs_in_rstar)
    apply(rule_tac rrewrite_srewrite.ss6)
    using Der_def der_correctness apply auto[1]
    by blast
qed

lemma rewrites_preserves_bder:
  assumes "r1 \<leadsto>* r2"
  shows "bder c r1 \<leadsto>* bder c r2"
using assms
apply(induction r1 r2 rule: rrewrites.induct)
apply(simp_all add: rewrite_preserves_bder rrewrites_trans)
done

lemma central:
  shows "bders r s \<leadsto>* bders_simp r s"
proof(induct s arbitrary: r rule: rev_induct)
  case Nil
  then show "bders r [] \<leadsto>* bders_simp r []" by simp
next
  case (snoc x xs)
  have IH: "\<And>r. bders r xs \<leadsto>* bders_simp r xs" by fact
  have "bders r (xs @ [x]) = bders (bders r xs) [x]" by (simp add: bders_append)
  also have "... \<leadsto>* bders (bders_simp r xs) [x]" using IH
    by (simp add: rewrites_preserves_bder)
  also have "... \<leadsto>* bders_simp (bders_simp r xs) [x]" using IH
    by (simp add: rewrites_to_bsimp)
  finally show "bders r (xs @ [x]) \<leadsto>* bders_simp r (xs @ [x])"
    by (simp add: bders_simp_append)
qed

lemma main_aux:
  assumes "bnullable (bders r s)"
  shows "bmkeps (bders r s) = bmkeps (bders_simp r s)"
proof -
  have "bders r s \<leadsto>* bders_simp r s" by (rule central)
  then
  show "bmkeps (bders r s) = bmkeps (bders_simp r s)" using assms
    by (rule rewrites_bmkeps)
qed

theorem main_blexer_simp:
  shows "blexer r s = blexer_simp r s"
  unfolding blexer_def blexer_simp_def
  by (metis central main_aux rewritesnullable)

theorem blexersimp_correctness:
  shows "lexer r s = blexer_simp r s"
  using blexer_correctness main_blexer_simp by simp

unused_thms

end


theory SmallStepEvaluate
imports "../Typecheck"
begin

inductive evaluate :: "expr \<Rightarrow> expr \<Rightarrow> bool" (infix "\<leadsto>" 60) where
  ev_app1 [simp]: "e\<^sub>1 \<leadsto> e\<^sub>1' \<Longrightarrow> App e\<^sub>1 e\<^sub>2 \<leadsto> App e\<^sub>1' e\<^sub>2"
| ev_app2 [simp]: "App (Abs t e\<^sub>1) e\<^sub>2 \<leadsto> Let e\<^sub>2 e\<^sub>1"
| ev_app_let [simp]: "is_value e\<^sub>1\<^sub>2 \<Longrightarrow> App (Let e\<^sub>1\<^sub>1 e\<^sub>1\<^sub>2) e\<^sub>2 \<leadsto> Let e\<^sub>1\<^sub>1 (App e\<^sub>1\<^sub>2 (incr\<^sub>e\<^sub>e 0 e\<^sub>2))"
| ev_let1 [simp]: "e\<^sub>2 \<leadsto> e\<^sub>2' \<Longrightarrow> Let e\<^sub>1 e\<^sub>2 \<leadsto> Let e\<^sub>1 e\<^sub>2'"
| ev_let2 [simp]: "e\<^sub>1 \<leadsto> e\<^sub>1' \<Longrightarrow> head_var e\<^sub>2 = Some 0 \<Longrightarrow> Let e\<^sub>1 e\<^sub>2 \<leadsto> Let e\<^sub>1' e\<^sub>2"
| ev_let3 [simp]: "is_value e\<^sub>1 \<Longrightarrow> head_var e\<^sub>2 = Some 0 \<Longrightarrow>
    Let e\<^sub>1 e\<^sub>2 \<leadsto> Let e\<^sub>1 (subst\<^sub>e\<^sub>e 0 (incr\<^sub>e\<^sub>e 0 e\<^sub>1) e\<^sub>2)"
| ev_proj1 [simp]: "e \<leadsto> e' \<Longrightarrow> Proj e l \<leadsto> Proj e' l"
| ev_proj2 [simp]: "lookup fs l = Some x \<Longrightarrow> Proj (Rec fs) l \<leadsto> Var x"
| ev_proj_let [simp]: "is_value e\<^sub>2 \<Longrightarrow> Proj (Let e\<^sub>1 e\<^sub>2) l \<leadsto> Let e\<^sub>1 (Proj e\<^sub>2 l)"
| ev_case1 [simp]: "e \<leadsto> e' \<Longrightarrow> Case e t cs \<leadsto> Case e' t cs"
| ev_case2 [simp]: "lookup cs l = Some e \<Longrightarrow> Case (Inj l ts x) t cs \<leadsto> Let (Var x) e"
| ev_case_let [simp]: "is_value e\<^sub>2 \<Longrightarrow>
    Case (Let e\<^sub>1 e\<^sub>2) t cs \<leadsto> Let e\<^sub>1 (Case e\<^sub>2 t (map (incr\<^sub>e\<^sub>e (Suc 0)) cs))"
| ev_unfold1 [simp]: "e \<leadsto> e' \<Longrightarrow> Unfold t e \<leadsto> Unfold t e'"
| ev_unfold2 [simp]: "Unfold t (Fold t e) \<leadsto> Var e"
| ev_unfold_let [simp]: "is_value e\<^sub>2 \<Longrightarrow> Unfold t (Let e\<^sub>1 e\<^sub>2) \<leadsto> Let e\<^sub>1 (Unfold t e\<^sub>2)"
| ev_tyapp1 [simp]: "e \<leadsto> e' \<Longrightarrow> TyApp e t \<leadsto> TyApp e' t"
| ev_tyapp2 [simp]: "TyApp (TyAbs k e) t \<leadsto> subst\<^sub>t\<^sub>e 0 t e"
| ev_tyapp_let [simp]: "is_value e\<^sub>2 \<Longrightarrow> TyApp (Let e\<^sub>1 e\<^sub>2) t \<leadsto> Let e\<^sub>1 (TyApp e\<^sub>2 t)"
| ev_tylet [simp]: "TyLet t e \<leadsto> subst\<^sub>t\<^sub>e 0 t e"

lemma progress': "\<Delta>,\<Gamma> \<turnstile> e : t \<Longrightarrow>
  is_value e \<or> (\<exists>e'. e \<leadsto> e') \<or> (\<exists>x < length \<Gamma>. head_var e = Some x)"
    and "\<Delta>,\<Gamma> \<turnstile>\<^sub>c cs : ts \<rightarrow> t \<Longrightarrow> l < length ts \<Longrightarrow> \<exists>c. lookup cs l = Some c"
  proof (induction \<Delta> \<Gamma> e t and \<Delta> \<Gamma> cs ts t arbitrary: and l rule: typecheck_typecheck_cs.inducts)
  case tc_var
    thus ?case by (metis lookup_less_than head_var.simps(1))
  next case tc_app
    thus ?case by (metis canonical_arrow ev_app1 ev_app2 ev_app_let head_var.simps(3))
  next case (tc_let \<Delta> \<Gamma> e\<^sub>1 t\<^sub>1 e\<^sub>2 t\<^sub>2)
    thus ?case
      proof (cases "is_value e\<^sub>2")
      case False note F = False
        thus ?thesis
          proof (cases "\<exists>e\<^sub>2'. e\<^sub>2 \<leadsto> e\<^sub>2'")
          case False
            with tc_let F obtain x where X: "x < Suc (length \<Gamma>) \<and> head_var e\<^sub>2 = Some x" by fastforce
            thus ?thesis
              proof (cases x)
              case 0
                with X show ?thesis
                  proof (cases "is_value e\<^sub>1")
                  case False
                    with tc_let X 0 ev_let2 show ?thesis by fastforce
                  qed (metis ev_let3)
              qed simp_all
          qed (metis ev_let1)
      qed simp_all
  next case tc_proj
    thus ?case
      by (metis canonical_record ev_proj1 ev_proj2 ev_proj_let lookup_in_tc head_var.simps(6))
  next case tc_case
    thus ?case by (metis canonical_variant ev_case1 ev_case2 ev_case_let head_var.simps(8))
  next case tc_unfold
    thus ?case by (metis canonical_inductive ev_unfold1 ev_unfold2 ev_unfold_let head_var.simps(10))
  next case tc_tyapp
    thus ?case by simp (metis canonical_forall ev_tyapp1 ev_tyapp2 ev_tyapp_let)
  next case tc_tylet
    thus ?case by (metis ev_tylet)
  next case tcc_cons
    thus ?case by (induction l) simp_all
  qed simp_all

theorem progress: "\<Delta>,[] \<turnstile> e : t \<Longrightarrow> is_value e \<or> (\<exists>e'. e \<leadsto> e')"
  using progress' by fastforce

theorem preservation: "e \<leadsto> e' \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile> e : t \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile> e' : t"
  proof (induction e e' arbitrary: \<Delta> \<Gamma> t rule: evaluate.induct)
  case (ev_proj2 l xs x)
    hence "lookup \<Gamma> x = Some t" by fastforce
    thus ?case by simp
  next case (ev_case2 cs l e ts x t')
    then obtain tt where "(lookup \<Gamma> x = Some tt) \<and> lookup ts l = Some tt \<and>
      (\<forall>tt \<in> set ts. \<Delta> \<turnstile>\<^sub>k tt : Star) \<and> (\<Delta>,\<Gamma> \<turnstile>\<^sub>c cs : ts \<rightarrow> t') \<and> t' = t" by fastforce
    moreover with ev_case2 have "\<Delta>,insert_at 0 tt \<Gamma> \<turnstile> e : t" by fastforce
    ultimately show ?case by (metis tc_let tc_var)
  next case (ev_tyapp2 k e t')
    then obtain tt where T: "(insert_at 0 k \<Delta>,map (incr\<^sub>t\<^sub>t 0) \<Gamma> \<turnstile> e : tt) \<and> (\<Delta> \<turnstile>\<^sub>k t' : k) \<and>
      t = subst\<^sub>t\<^sub>t 0 t' tt" by fastforce
    moreover hence "\<Delta>,map (subst\<^sub>t\<^sub>t 0 t') (map (incr\<^sub>t\<^sub>t 0) \<Gamma>) \<turnstile> subst\<^sub>t\<^sub>e 0 t' e : subst\<^sub>t\<^sub>t 0 t' tt"
      using tc_subst\<^sub>t\<^sub>e by fastforce
    ultimately show ?case by simp
  qed fastforce+

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory word_abs_cases imports
  "AutoCorres.AutoCorres"
begin

(* extra optimization for word_abs (currently does not work) *)
lemma INT_MIN_MAX_smod: "\<And>a b :: int. \<lbrakk> INT_MIN \<le> b; b \<le> INT_MAX; b \<noteq> 0 \<rbrakk> \<Longrightarrow> INT_MIN \<le> a smod b \<and> a smod b \<le> INT_MAX"
  apply (case_tac "b > 0")
   apply (rule conjI)
    apply (case_tac "a \<ge> 0")
     apply (frule_tac a = a and b = b in smod_int_compares(2))
      apply assumption
     apply (simp add: INT_MIN_def)
    apply (subgoal_tac "0 \<ge> a")
     apply (frule_tac a = a and b = b in smod_int_compares(3))
      apply assumption
     apply (simp add: INT_MIN_def INT_MAX_def)
    apply arith
   apply (case_tac "a \<ge> 0")
    apply (frule_tac a = a and b = b in smod_int_compares(1))
     apply assumption
    apply arith
   apply (subgoal_tac "0 \<ge> a")
    apply (frule_tac a = a and b = b in smod_int_compares(4))
     apply assumption
    apply arith
   apply arith
  apply (subgoal_tac "0 > b")
   apply (rule conjI)
    apply (case_tac "a \<ge> 0")
     apply (frule_tac a = a and b = b in smod_int_compares(6))
      apply assumption
     apply simp
    apply (subgoal_tac "0 \<ge> a")
     apply (frule_tac a = a and b = b in smod_int_compares(8))
      apply assumption
     apply (simp add: INT_MIN_def)
    apply arith
   apply (case_tac "a \<ge> 0")
    apply (frule_tac a = a and b = b in smod_int_compares(5))
     apply assumption
    apply (simp add: INT_MIN_def INT_MAX_def)
   apply (subgoal_tac "0 \<ge> a")
    apply (frule_tac a = a and b = b in smod_int_compares(7))
     apply assumption
    apply (simp add: INT_MAX_def)
   apply arith
  apply arith
  done
lemma [unfolded INT_MIN_def INT_MAX_def, simplified, L2flow]:
  "simp_expr (INT_MIN \<le> b \<and> b \<le> INT_MAX \<and> b \<noteq> 0) (INT_MIN \<le> a smod b) True"
  by (simp add: simp_expr_def INT_MIN_MAX_smod)
lemma [unfolded INT_MIN_def INT_MAX_def, simplified, L2flow]:
  "simp_expr (INT_MIN \<le> b \<and> b \<le> INT_MAX \<and> b \<noteq> 0) (a smod b \<le> INT_MAX) True"
  by (simp add: simp_expr_def INT_MIN_MAX_smod)

external_file "word_abs_cases.c"
install_C_file "word_abs_cases.c"
autocorres [
  unsigned_word_abs = callee_flat_u_abs
             caller_flat_u_aa
             caller_flat_u_an
] "word_abs_cases.c"

context word_abs_cases begin

  declare K_bind_def[simp del]

  thm callee_flat_s'_def caller_flat_s'_def

  thm callee_flat_u_abs'_def callee_flat_u_noabs'_def
  thm caller_flat_u_aa'_def caller_flat_u_an'_def caller_flat_u_na'_def caller_flat_u_nn'_def

  thm callee_deep_s'.simps caller_deep_s'_def

  thm mutual_s1'.simps mutual_s2'.simps

  thm cross'_def gcd_s_rec'.simps gcd_s_loop'_def

  lemma int_max: "2147483647 \<le> a \<Longrightarrow> sint (n :: sword32) \<le> a"
    using INT_MIN_MAX_lemmas(10)[where s = n, unfolded INT_MAX_def]
    by arith
  lemma int_min: "a \<le> -2147483648 \<Longrightarrow> a \<le> sint (n :: sword32)"
    using INT_MIN_MAX_lemmas(11)[where s = n, unfolded INT_MIN_def]
    by arith
  lemma oguard_True: "(\<And>s. P s) \<Longrightarrow> DO oguard P; f OD = f"
    by (monad_eq simp: oguard_def obind_def K_bind_def)

  thm gcd_s_loop'_def gcd_s_loop'_def [simplified int_min int_max oguard_True]

  thm sum'_def sum'_def[simplified, folded INT_MAX_def[simplified] INT_MIN_def[simplified]]
end

end