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

section {* Lamport's "increment" example *}

theory Inc
imports 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 & y = # 0" and
  M1_def:        "M1      == ACT  x$ = Suc<$x> & y$ = $y" and
  M2_def:        "M2      == ACT  y$ = Suc<$y> & x$ = $x" and
  Phi_def:       "Phi     == TEMP Init InitPhi & [][M1 | M2]_(x,y)
                                 & WF(M1)_(x,y) & WF(M2)_(x,y)" and

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

  PsiInv1_def:  "PsiInv1  == PRED sem = # 1 & pc1 = #a & pc2 = #a" and
  PsiInv2_def:  "PsiInv2  == PRED sem = # 0 & pc1 = #a & (pc2 = #b | pc2 = #g)" and
  PsiInv3_def:  "PsiInv3  == PRED sem = # 0 & pc2 = #a & (pc1 = #b | pc1 = #g)" and
  PsiInv_def:   "PsiInv   == PRED (PsiInv1 | PsiInv2 | 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: "|- InitPsi --> PsiInv"
  by (auto simp: InitPsi_def PsiInv_defs)

lemma PsiInv_alpha1: "|- alpha1 & $PsiInv --> PsiInv$"
  by (auto simp: alpha1_def PsiInv_defs)

lemma PsiInv_alpha2: "|- alpha2 & $PsiInv --> PsiInv$"
  by (auto simp: alpha2_def PsiInv_defs)

lemma PsiInv_beta1: "|- beta1 & $PsiInv --> PsiInv$"
  by (auto simp: beta1_def PsiInv_defs)

lemma PsiInv_beta2: "|- beta2 & $PsiInv --> PsiInv$"
  by (auto simp: beta2_def PsiInv_defs)

lemma PsiInv_gamma1: "|- gamma1 & $PsiInv --> PsiInv$"
  by (auto simp: gamma1_def PsiInv_defs)

lemma PsiInv_gamma2: "|- gamma2 & $PsiInv --> PsiInv$"
  by (auto simp: gamma2_def PsiInv_defs)

lemma PsiInv_stutter: "|- unchanged (x,y,sem,pc1,pc2) & $PsiInv --> PsiInv$"
  by (auto simp: PsiInv_defs)

lemma PsiInv: "|- Psi --> []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 "|- Psi --> []PsiInv"
  by (auto_invariant simp: PsiInv_defs Psi_defs)

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

lemma Init_sim: "|- Psi --> Init InitPhi"
  by (auto simp: InitPhi_def Psi_def InitPsi_def Init_def)

lemma Step_sim: "|- Psi --> [][M1 | 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
         |- Psi --> 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: "|- [][(N1 | N2) & ~ beta1]_(x,y,sem,pc1,pc2) --> stable(pc1 = #b)"
  by (auto elim!: Stable squareE simp: Psi_defs)

lemma N1_enabled_at_g: "|- pc1 = #g --> 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:
  "|- [][(N1 | N2) & ~beta1]_(x,y,sem,pc1,pc2) & SF(N1)_(x,y,sem,pc1,pc2) & []#True
    --> (pc1 = #g ~> pc1 = #a)"
  apply (rule SF1)
    apply (tactic
      {* action_simp_tac (@{context} addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1 *})
   apply (tactic
      {* action_simp_tac (@{context} addsimps @{thm angle_def} :: @{thms Psi_defs}) [] [] 1 *})
  (* reduce |- []A --> <>Enabled B  to  |- A --> 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: "|- pc2 = #g --> 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:
  "|- [][(N1 | N2) & ~beta1]_(x,y,sem,pc1,pc2) & SF(N2)_(x,y,sem,pc1,pc2) & []#True
    --> (pc2 = #g ~> pc2 = #a)"
  apply (rule SF1)
  apply (tactic {* action_simp_tac (@{context} addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1 *})
  apply (tactic {* action_simp_tac (@{context} addsimps @{thm angle_def} :: @{thms Psi_defs})
    [] [] 1 *})
  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: "|- pc2 = #b --> 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:
  "|- [][(N1 | N2) & ~beta1]_(x,y,sem,pc1,pc2) & SF(N2)_(x,y,sem,pc1,pc2) & []#True
    --> (pc2 = #b ~> pc2 = #g)"
  apply (rule SF1)
    apply (tactic
      {* action_simp_tac (@{context} addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1 *})
   apply (tactic
     {* action_simp_tac (@{context} addsimps @{thm angle_def} :: @{thms Psi_defs}) [] [] 1 *})
  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:
  "|- [][(N1 | N2) & ~beta1]_(x,y,sem,pc1,pc2) & SF(N2)_(x,y,sem,pc1,pc2) & []#True
    --> (pc2 = #a | pc2 = #b | pc2 = #g ~> 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 ~> above. *)
lemma N2_live:
  "|- [][(N1 | N2) & ~beta1]_(x,y,sem,pc1,pc2) & SF(N2)_(x,y,sem,pc1,pc2)
    --> <>(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:
  "|- pc2 = #a & (PsiInv & pc1 = #a) --> 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:
  "|- []($PsiInv & [(N1 | N2) & ~beta1]_(x,y,sem,pc1,pc2))
         & SF(N1)_(x,y,sem,pc1,pc2) & [] SF(N2)_(x,y,sem,pc1,pc2)
         --> (pc1 = #a ~> pc1 = #b)"
  apply (rule SF1)
  apply (tactic {* action_simp_tac (@{context} addsimps @{thms Psi_defs}) [] [@{thm squareE}] 1 *})
  apply (tactic
    {* action_simp_tac (@{context} addsimps (@{thm angle_def} :: @{thms Psi_defs})) [] [] 1 *})
  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: "|- []($PsiInv & [(N1 | N2) & ~beta1]_(x,y,sem,pc1,pc2))
         & SF(N1)_(x,y,sem,pc1,pc2) & [] SF(N2)_(x,y,sem,pc1,pc2)
         --> (pc1 = #b | pc1 = #g | pc1 = #a ~> 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: "|- []($PsiInv & [(N1 | N2) & ~beta1]_(x,y,sem,pc1,pc2))
         & SF(N1)_(x,y,sem,pc1,pc2) & [] SF(N2)_(x,y,sem,pc1,pc2)
         --> <>(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: "|- pc1 = #b --> 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: "|- []($PsiInv & [(N1 | N2)]_(x,y,sem,pc1,pc2))
         & SF(N1)_(x,y,sem,pc1,pc2) & []SF(N2)_(x,y,sem,pc1,pc2)
         --> 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: "|- Psi --> 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 Integers
  imports
Main Archi "Word_Lib.Bitwise" "Word_Lib.Bits_Int"
begin

(** * Comparisons *)

datatype comparison =
    Ceq (* same *)
  | Cne (* different *)
  | Clt (* less than *)
  | Cle (* less than or equal *)
  | Cgt (* greater than *)
  | Cge (* greater than or equal *)

fun do_cmp :: "comparison \<Rightarrow> 'a::ord \<Rightarrow> 'a \<Rightarrow> bool" where
  "do_cmp Ceq x y = (x = y)"
| "do_cmp Cne x y = (x \<noteq> y)"
| "do_cmp Clt x y = (x < y)"
| "do_cmp Cle x y = (x \<le> y)"
| "do_cmp Cgt x y = (x > y)"
| "do_cmp Cge x y = (x \<ge> y)"

(*
  from here on out, the formalization diverges from CompCert
  to make use of the already existing Word_Lib
*)

type_synonym m_byte = "8 word"
type_synonym m_short = "16 word"
type_synonym m_int = "32 word"
type_synonym m_int64 = "64 word"
type_synonym m_ptrofs = "ptrsize word"

locale Make =
  fixes wt :: "'w::len itself"
begin
definition "wordsize \<equiv> LENGTH('w)"
definition "zwordsize \<equiv> int wordsize"

definition modulus :: int where "modulus \<equiv> 2 ^ wordsize"
definition "half_modulus \<equiv> modulus div 2"
definition "max_unsigned \<equiv> modulus - 1"
definition "max_signed \<equiv> half_modulus - 1"
definition "min_signed \<equiv> -half_modulus"

(** The [unsigned] and [signed] functions return the Coq integer corresponding
  to the given machine integer, interpreted as unsigned or signed
  respectively. *)

abbreviation unsigned :: "'w word \<Rightarrow> int" where
  "unsigned \<equiv> uint"
abbreviation signed :: "'w word \<Rightarrow> int" where
  "signed \<equiv> sint"

(** Conversely, [repr] takes a Coq integer and returns the corresponding
  machine integer.  The argument is treated modulo [modulus]. *)

abbreviation repr :: "int \<Rightarrow> 'w word" where
  "repr \<equiv> word_of_int"

definition "iwordsize \<equiv> repr zwordsize"
definition "zero \<equiv> 0"
definition "mone \<equiv> repr (-1)"

lemma repr_mod: "repr (i mod 2 ^ x) = repr i" if "x \<ge> LENGTH('w)"
  unfolding repr_def
  using that
  by transfer (metis bintrunc_bintrunc_ge no_bintr_alt1)

lemma unsigned_ge_neg[iff]: "i \<le> 0 \<Longrightarrow> i \<le> unsigned w"
  using dual_order.trans by auto

(** * Arithmetic and logical operations over machine integers *)

fun eq :: "'w word \<Rightarrow> 'w word \<Rightarrow> bool" where
  "eq x y = ((unsigned x) = (unsigned y))"

fun lt :: "'w word \<Rightarrow> 'w word \<Rightarrow> bool" where
  "lt x y = ((signed x) < (signed y))"

fun ltu :: "'w word \<Rightarrow> 'w word \<Rightarrow> bool" where
  "ltu x y = ((unsigned x) < (unsigned y))"

fun neg :: "'w word \<Rightarrow> 'w word" where
  "neg x = repr (- unsigned x)"

fun add :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "add x y = repr (unsigned x + unsigned y)"

fun sub :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "sub x y = repr (unsigned x - unsigned y)"

fun mul :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "mul x y = repr (unsigned x * unsigned y)"

fun divs :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "divs x y = repr ((signed x) div (signed y))"

fun mods :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "mods x y = repr ((signed x) mod (signed y))"

fun divu :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "divu x y = repr (unsigned x div unsigned y)"

fun modu :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "modu x y = repr ((unsigned x) mod (unsigned y))"

(** Bitwise boolean operations. *)

abbreviation and' :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "and' x y \<equiv> x AND y"

abbreviation or :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "or x y \<equiv> x OR y"

abbreviation xor :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "xor x y \<equiv> x XOR y"

abbreviation not :: "'w word \<Rightarrow> 'w word" where
  "not \<equiv> NOT"

(** Shifts and rotates. *)

fun shl :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "shl x y = x << (nat (uint y))"

fun shru :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "shru x y = x >> (nat (uint y))"

fun shr :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "shr x y = x >>> (nat (uint y))" (* Standard shr is signed in CompCert *)

fun rol :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "rol x y =
  (let n = nat ((unsigned y) mod zwordsize) in
  repr (((unsigned x) << n) OR ((unsigned x) >> (nat zwordsize - n))))"

fun ror :: "'w word \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "ror x y =
  (let n = nat ((unsigned y) mod zwordsize) in
  repr (((unsigned x) >> n) OR ((unsigned x) << (nat zwordsize - n))))"

(** Zero and sign extensions *)

fun zero_ext :: "'from::len itself \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "zero_ext from x = ucast (ucast x :: 'from word)"

fun sign_ext :: "'from::len itself \<Rightarrow> 'w word \<Rightarrow> 'w word" where
  "sign_ext from x = scast (ucast x :: 'from word)"

(** Comparisons *)

fun cmp :: "comparison \<Rightarrow> 'w word \<Rightarrow> 'w word \<Rightarrow> bool" where
  "cmp Ceq x y = eq x y"
| "cmp Cne x y = (\<not>eq x y)"
| "cmp Clt x y = lt x y"
| "cmp Cle x y = (\<not>lt y x)"
| "cmp Cgt x y = lt y x"
| "cmp Cge x y = (\<not>lt x y)"

fun cmpu :: "comparison \<Rightarrow> 'w word \<Rightarrow> 'w word \<Rightarrow> bool" where
  "cmpu Ceq x y = eq x y"
| "cmpu Cne x y = (\<not>eq x y)"
| "cmpu Clt x y = ltu x y"
| "cmpu Cle x y = (\<not>ltu y x)"
| "cmpu Cgt x y = ltu y x"
| "cmpu Cge x y = (\<not>ltu x y)"

end

global_interpretation Byte : Make "TYPE(8)"
  done
global_interpretation Short : Make "TYPE(16)"
  done
global_interpretation Int : Make "TYPE(32)"
  done

locale Make64 = Make "TYPE(64)"
begin
definition "iwordsize' \<equiv> Int.repr zwordsize"

(** Shifts with amount given as a 32-bit integer *)

fun shl' :: "64 word \<Rightarrow> 32 word \<Rightarrow> 64 word" where
  "shl' x y = x << (nat (Int.unsigned y))"

fun shru' :: "64 word \<Rightarrow> 32 word \<Rightarrow> 64 word" where
  "shru' x y = x >> (nat (Int.unsigned y))"

fun shr' :: "64 word \<Rightarrow> 32 word \<Rightarrow> 64 word" where
  "shr' x y = x >>> (nat (Int.unsigned y))"

fun rol' :: "64 word \<Rightarrow> 32 word \<Rightarrow> 64 word" where
  "rol' x y =
  (let n = nat ((Int.unsigned y) mod zwordsize) in
  repr (((unsigned x) << n) OR ((unsigned x) >> (nat zwordsize - n))))"

fun ror' :: "64 word \<Rightarrow> 32 word \<Rightarrow> 64 word" where
  "ror' x y =
  (let n = nat ((Int.unsigned y) mod zwordsize) in
  repr (((unsigned x) >> n) OR ((unsigned x) << (nat zwordsize - n))))"

(** Decomposing 64-bit ints as pairs of 32-bit ints *)

fun loword :: "64 word \<Rightarrow> 32 word" where
  "loword n = Int.repr (unsigned n)"

fun hiword :: "64 word \<Rightarrow> 32 word" where
  "hiword n = Int.repr (unsigned (shru n (repr Int.zwordsize)))"

fun ofwords :: "32 word \<Rightarrow> 32 word \<Rightarrow> 64 word" where
  "ofwords hi lo = or (shl (repr (Int.unsigned hi)) (repr Int.zwordsize)) (repr (Int.unsigned lo))"
end

global_interpretation Int64 : Make64
  done

locale Ptrofs' = u: Make "TYPE(ptrsize)"
begin
(* need to redefine so its visible on the outside ... *)
abbreviation unsigned :: "ptrsize word \<Rightarrow> int"
  where "unsigned \<equiv> u.unsigned"
abbreviation repr :: "int \<Rightarrow> ptrsize word"
  where "repr \<equiv> u.repr"

abbreviation "add \<equiv> u.add"
abbreviation "sub \<equiv> u.sub"

abbreviation "cmp \<equiv> u.cmp"
abbreviation "cmpu \<equiv> u.cmpu"

fun to_int where "to_int x = Int.repr (unsigned x)"
fun of_int where "of_int i = repr (Int.unsigned i)"
fun to_int64 where "to_int64 x = Int64.repr (unsigned x)"
fun of_int64 where "of_int64 i = repr (Int64.unsigned i)"
end

global_interpretation Ptrofs : Ptrofs' .

lemma word_mod[simp]: "x = 2^LENGTH('w::len) \<Longrightarrow> word_of_int (i mod x) = (word_of_int i :: ('w word))"
  using word_uint.Abs_norm by simp

end


theory segment
imports point
begin

(*Definition for Segment*)
definition segment :: "point2d \<Rightarrow> point2d \<Rightarrow> bool" where
"segment a b \<equiv> \<not> pointsEqual a b"

(*left corner of the segment*)
definition leftPSegment :: "point2d \<Rightarrow> point2d \<Rightarrow> point2d" where
  "xCoord A \<noteq> xCoord B \<Longrightarrow> leftPSegment A B \<equiv> (if (leftFrom A B) then A else B)"
(*right corner of the segment*)
definition rightPSegment :: "point2d \<Rightarrow> point2d \<Rightarrow> point2d" where
  "xCoord A \<noteq> xCoord B \<Longrightarrow> rightPSegment A B \<equiv> (if (leftFrom A B) then B else A)"
lemma leftPNotEqualRightP : "xCoord A \<noteq> xCoord B \<Longrightarrow> leftPSegment A B \<noteq> rightPSegment A B"
  by (auto simp add: rightPSegment_def leftPSegment_def)
lemma leftPRightPSimp[simp]: "xCoord p \<noteq> xCoord q \<Longrightarrow> p = leftPSegment p q \<Longrightarrow>
  q = rightPSegment p q"
  by (auto simp add: leftPSegment_def rightPSegment_def)
lemma leftPRightPSimp1[simp]: "xCoord p \<noteq> xCoord q \<Longrightarrow> q = rightPSegment p q \<Longrightarrow>
  p = leftPSegment p q"
  by (auto simp add: leftPSegment_def rightPSegment_def)
lemma leftPRightPSimp2[simp]: "leftFrom P Q \<Longrightarrow> P = leftPSegment P Q"
  by (auto simp add: leftFrom_def leftPSegment_def)
lemma leftPRightPSimp3[simp]: "leftFrom P Q \<Longrightarrow> Q = rightPSegment P Q"
  by (auto simp add: leftFrom_def)

(*pointOnSegment and signedArea*)
lemma pointOnSegment_noRightTurn : "A isBetween P R \<Longrightarrow> rightTurn A B P \<Longrightarrow>
  rightTurn A B R \<Longrightarrow> False"
  by (smt betweenSegment collinearTransitiv conflictingRightTurns2 leftRightTurn leftTurnsImplyBetween notBetween
  notRightTurn pointsEqualSame rightTurnRotate2 segment_def swapBetween)
lemma pointOnSegment_noRightTurn1 : "B isBetween P R \<Longrightarrow> rightTurn A B P \<Longrightarrow>
  rightTurn A B R \<Longrightarrow> False"
  by (meson betweenSegment isBetweenImpliesCollinear3 leftRightTurn leftTurnRotate2 leftTurnsImplyBetween
  newLeftTurn notBetween3)

(*Segment AB separates the points P and R when the endpoints of PR lie's on different sides of AB.*)
definition lineSeparate :: "point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "lineSeparate A B P R \<equiv> (leftTurn A B R  \<and> rightTurn A B P )\<or>(rightTurn A B R \<and> leftTurn A B P)"
lemma lineSeparateEq : "lineSeparate A B P R = (signedArea A B R * signedArea A B P < 0)"
  apply (simp add: lineSeparate_def colliniearRight, simp only: rightTurnEq)
by (metis colliniearRight leftTurn_def mult_less_0_iff notLeftTurn not_less_iff_gr_or_eq)
(*wenn lineSeparate true, dann müssen Strecken segmente sein*)
lemma lineSeparateSegment[intro]: "lineSeparate A B P R \<longrightarrow> segment P R"
  by (simp add: lineSeparate_def segment_def, metis conflictingRigthTurns)
lemma lineSeparateSegment1[intro]: "lineSeparate A B P R \<longrightarrow> segment A B"
  apply (simp add: lineSeparate_def segment_def rightTurn_def)
by (metis areaDoublePoint less_numeral_extra(3))
(*additional Lemmas*)
lemma lineSeparateSame1 [simp]:"\<not>lineSeparate A B A B" by (simp add: lineSeparate_def)
lemma lineSeparateSame2 [simp]:"\<not>lineSeparate A B B A" by (simp add: lineSeparate_def)
(*lineSeparate is symmetrical*)
lemma lineSeparateSym: "lineSeparate A B P R = lineSeparate B A P R"
  by (auto simp add: lineSeparate_def signedArea_def leftTurn_def rightTurn_def)
lemma lineSeparateSym1: "lineSeparate A B P R = lineSeparate A B R P"
 by (auto simp add: lineSeparate_def leftTurn_def)

(*(real)intersection between AB and PR Segment Segment*)
definition crossing ::  "point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "crossing A B P R \<equiv> (lineSeparate A B P R \<and> lineSeparate P R A B)"
lemma crossingSegment [intro]:"crossing A B P R \<longrightarrow> segment A B"
  apply (simp add: crossing_def segment_def lineSeparate_def rightTurn_def)
by (metis areaDoublePoint less_irrefl)
lemma crossingSegment1 [intro]:"crossing A B P R \<longrightarrow> segment P R"
  apply (simp add: crossing_def segment_def lineSeparate_def rightTurn_def)
by (metis areaDoublePoint2 less_numeral_extra(3))
(*crossing is symmetrical*)
lemma crossingSym: "crossing A B P R = crossing B A P R"
  by (auto simp add: crossing_def lineSeparate_def)
lemma crossingSym1: "crossing A B P R = crossing P R A B "
  by (auto simp add: crossing_def lineSeparate_def)
(*lemmas with crossing and collinear/leftTurn/rightTurn*)
lemma crossingCollinear [dest]: "crossing A B P R \<Longrightarrow> collinear A B P \<Longrightarrow> False"
  by (simp add: crossing_def, metis conflictingLeftTurns3 lineSeparate_def notRightTurn1)
lemma crossingRightTurn [dest] : "crossing A B P R \<Longrightarrow> rightTurn A B P \<and> rightTurn A B R \<Longrightarrow> False"
  by (simp add: crossing_def lineSeparate_def, metis conflictingRigthTurns)
lemma crossingLeftTurn [dest] : "crossing A B P R \<Longrightarrow> leftTurn A B P \<and> leftTurn A B R \<Longrightarrow> False"
  by (simp add: crossing_def lineSeparate_def, metis conflictingRigthTurns)
lemma notSelfCrossing[simp]: "\<not>crossing A B A B" by (simp add: crossing_def)
lemma notSelfCrossing1[simp]: "\<not>crossing A B B A" by (simp add: crossing_def)

(*intersection, even if endpoint is on segment*)
definition intersect :: "point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> point2d \<Rightarrow> bool" where
  "intersect A B P R \<equiv> crossing A B P R \<or>
  P isBetween A B \<or> R isBetween A B \<or> A isBetween P R \<or> B isBetween P R"
lemma notIntersectSame[simp]: "\<not>intersect A B A B"
  by (simp add: intersect_def)
lemma notIntersectSame1[simp]: "\<not>intersect A B B A"
  by (auto simp add: intersect_def segment_Sym)
lemma crossingIntersect [intro]: "crossing A B P R \<Longrightarrow> intersect A B P R"
  by (simp add: intersect_def crossingSegment1 crossingSegment)
(*intersection is symmetrical*)
lemma intersectSym: "intersect A B P R = intersect B A P R"
  using crossingSym intersect_def segment_def by auto
lemma intersectSym1 : "intersect A B P R = intersect P R A B"
  using crossingSym1 intersect_def by auto
lemma NotIntersectSym: "\<not>intersect A B P R \<Longrightarrow> \<not>intersect P R A B"
  using crossingSym1 intersect_def by auto

(*if the segments AB and PR intersect, then both corners of PR can not be on the same side of AB*)
lemma intersectRightTurn: "segment A B \<Longrightarrow> segment P R \<Longrightarrow> intersect A B P R \<Longrightarrow>
  rightTurn A B P \<and> rightTurn A B R \<Longrightarrow> False"
  apply (simp only: intersect_def, auto)
  using rightTurnRotate2 apply blast
  using rightTurnRotate2 apply blast
  apply (metis pointOnSegment_noRightTurn)
by (metis pointOnSegment_noRightTurn1)
lemma intersectRightTurn1 : "segment A B \<Longrightarrow> segment P R \<Longrightarrow> intersect A B P R \<Longrightarrow>
  rightTurn A R P \<and> rightTurn P B R \<Longrightarrow> False"
  apply (simp only:intersect_def, safe)
  apply (metis crossingRightTurn crossingSym crossingSym1 rightTurnRotate2)
  apply (metis intersectRightTurn intersect_def rightTurnRotate2 segment_Sym)
  apply (metis intersectRightTurn intersect_def rightTurnRotate2 segment_Sym)
  using collSwap isBetweenImpliesCollinear apply blast
by (metis conflictingRightTurns2  swapBetween rightTurnRotate2)

(*additional Lemmas for intersect*)
lemma intersectNotCollinear: "segment a b \<Longrightarrow> segment c d \<Longrightarrow> intersect a b c d \<Longrightarrow>
  \<not>collinear a b c \<Longrightarrow> a \<noteq> c \<and> b \<noteq> c "
  by (simp add: intersect_def, metis notCollThenDiffPoints)
lemma intersectNotCollinear1: "segment a b \<Longrightarrow> segment c d \<Longrightarrow> intersect a b c d \<Longrightarrow>
  \<not>collinear d c b \<Longrightarrow> \<not>collinear a c b  \<Longrightarrow> rightTurn a d b \<Longrightarrow> rightTurn a c b \<Longrightarrow> False"
  apply (simp add: intersect_def, safe)
  using lineSeparate_def apply auto[1]
  using collRotate isBetweenImpliesCollinear apply blast
  apply (meson collRotate notRightTurn isBetweenImpliesCollinear)
  apply (metis conflictingRigthTurns leftRightTurn newLeftTurn1 notCollThenLfOrRt1)
by (smt intersectRightTurn intersect_def leftRightTurn notRightTurn notRightTurn1 segment_Sym)
lemma intersectBetween: "segment A B \<Longrightarrow> segment B C \<Longrightarrow> A isBetween B C \<Longrightarrow> intersect A B B C"
  by (simp add: intersect_def)

(*evtl. noch nützrlich*)
(*formalizing Analytic Geometries. Pasch's axiom*)
(*lemma paschAxiom: "segment A C \<Longrightarrow> segment B C \<Longrightarrow> segment P B \<Longrightarrow> segment Q A \<Longrightarrow>
  P isBetween A C \<Longrightarrow> Q isBetween B C \<Longrightarrow>
  (\<exists> X. X isBetween P B \<and> X isBetween Q A)"
  apply (case_tac "A = C")
    apply (subgoal_tac "P = A")
    apply (rule_tac x="P" in exI, auto)
    apply (simp add: segment_def)
  apply (case_tac "B = C")
    apply (subgoal_tac "B = Q")
    apply (rule_tac x="P" in exI, simp add: segment_def)
    apply (simp add: segment_def)
  apply (case_tac "C = P")
    apply (rule_tac x="Q" in exI)
    apply auto[1]
  apply (case_tac "C = Q")
    apply (rule_tac x="P" in exI)
    apply auto[1]
  apply (case_tac "A = B")
    apply (rule_tac x="B" in exI)
    apply auto[1]
  apply (case_tac "collinear A C B")
    apply (subgoal_tac "collinear A P Q")
    apply (case_tac "C isBetween A B")
      apply (rule_tac x="C" in exI)
      apply (rule conjI)
      apply (simp add: isBetweenImpliesCollinear leftTurn_def leftTurnsImplyBetween notBetween2
        pointOnSegment_def pointsEqualArea rightTurn_def)
      apply (smt collRotate collinearTransitiv collinearTransitiv2 colliniearRight
        isBetweenImpliesCollinear3 isBetweenPointsDistinct leftTurnsImplyBetween notBetween3
        notLeftTurn swapBetween)
      apply (simp add: isBetweenImpliesCollinear leftTurn_def leftTurnsImplyBetween notBetween2
        pointOnSegment_def pointsEqualArea rightTurn_def)
      apply (smt collRotate collinearTransitiv collinearTransitiv2 colliniearRight
        isBetweenImpliesCollinear3 isBetweenPointsDistinct leftTurnsImplyBetween notBetween3
        notLeftTurn swapBetween)
    apply (case_tac "B isBetween A C")
      apply (rule_tac x="B" in exI)
      apply (rule conjI)
      apply (simp add: isBetweenImpliesCollinear leftTurn_def leftTurnsImplyBetween notBetween2
        pointOnSegment_def pointsEqualArea rightTurn_def)
      apply (simp add: isBetweenImpliesCollinear leftTurn_def leftTurnsImplyBetween notBetween  pointOnSegment_def pointsEqualArea rightTurn_def)
      apply (smt collRotate collinearTransitiv2 colliniearRight isBetweenImpliesCollinear3 leftTurnsImplyBetween notBetween2 notLeftTurn signedAreaRotate swapBetween)
      apply (simp add: isBetweenImpliesCollinear  leftTurn_def leftTurnsImplyBetween
        notBetween2  pointOnSegment_def pointsEqualArea rightTurn_def)
      apply (smt collRotate collinearTransitiv2 colliniearRight isBetweenImpliesCollinear3
        leftTurnsImplyBetween notBetween2 notLeftTurn signedAreaRotate swapBetween)
    apply (simp add: collinearTransitiv collinearTransitiv2 collinear_def
      isBetweenImpliesCollinear3 pointOnSegment_def)
    apply (metis cancel_comm_monoid_add_class.diff_cancel collinearTransitiv collinearTransitiv2
      collinear_def isBetweenImpliesCollinear3 mult.commute mult_zero_right)
  (*echter schnitt*)
oops*)

end


section \<open>Compiler Between Static Representations\<close>

theory Compiler
  imports Language Simulation
begin

definition option_comp :: "('a \<Rightarrow> 'b option) \<Rightarrow> ('c \<Rightarrow> 'a option) \<Rightarrow> 'c \<Rightarrow> 'b option" (infix "\<Lleftarrow>" 50) where
  "(f \<Lleftarrow> g) x \<equiv> Option.bind (g x) f"

context
  fixes f :: "('a \<Rightarrow> 'a option)"
begin

fun option_comp_pow :: "nat \<Rightarrow> 'a \<Rightarrow> 'a option" where
  "option_comp_pow 0 = (\<lambda>_. None)" |
  "option_comp_pow (Suc 0) = f" |
  "option_comp_pow (Suc n) = (option_comp_pow n \<Lleftarrow> f)"

end

locale compiler =
  L1: language step1 final1 load1 +
  L2: language step2 final2 load2 +
  backward_simulation step1 step2 final1 final2 order match
  for
    step1 and step2 and
    final1 and final2 and
    load1 :: "'prog1 \<Rightarrow> 'state1 option" and
    load2 :: "'prog2 \<Rightarrow> 'state2 option" and
    order :: "'index \<Rightarrow> 'index \<Rightarrow> bool" and
    match +
  fixes
    compile :: "'prog1 \<Rightarrow> 'prog2 option"
  assumes
    compile_load:
      "compile p1 = Some p2 \<Longrightarrow> load1 p1 = Some s1 \<Longrightarrow> \<exists>s2 i. load2 p2 = Some s2 \<and> match i s1 s2"
begin

text \<open>
The @{locale compiler} locale relates two languages, L1 and L2, by a backward simulation and provides a @{term compile} partial function from a concrete program in L1 to a concrete program in L2.
The only assumption is that a successful compilation results in a program which, when loaded, is equivalent to the loaded initial program.
\<close>

subsection \<open>Preservation of behaviour\<close>

corollary behaviour_preservation:
  assumes
    compiles: "compile p1 = Some p2" and
    loads: "load1 p1 = Some s1" "load2 p2 = Some s2" and
    behaves: "L2.behaves s2 b2" and
    not_wrong: "\<not> is_wrong b2"
  shows "\<exists>b1 i. L1.behaves s1 b1 \<and> rel_behaviour (match i) b1 b2"
proof -
  obtain i where "match i s1 s2"
    using compile_load[OF compiles] loads by auto
  then show ?thesis
    using simulation_behaviour[OF behaves not_wrong]
    by simp
qed

end

subsection \<open>Composition of compilers\<close>

lemma compiler_composition:
  assumes
    "compiler step1 step2 final1 final2 load1 load2 order1 match1 compile1" and
    "compiler step2 step3 final2 final3 load2 load3 order2 match2 compile2"
  shows "compiler step1 step3 final1 final3 load1 load3
    (lex_prodp order1\<^sup>+\<^sup>+ order2) (rel_comp match1 match2) (compile2 \<Lleftarrow> compile1)"
proof (rule compiler.intro)
  show "language step1 final1"
    using assms(1)[THEN compiler.axioms(1)] .
next
  show "language step3 final3"
    using assms(2)[THEN compiler.axioms(2)] .
next
  show "backward_simulation step1 step3 final1 final3
     (lex_prodp order1\<^sup>+\<^sup>+ order2) (rel_comp match1 match2)"
    using backward_simulation_composition[OF assms[THEN compiler.axioms(3)]] .
next
  show "compiler_axioms load1 load3 (rel_comp match1 match2) (compile2 \<Lleftarrow> compile1)"
  proof unfold_locales
    fix p1 p3 s1
    assume
      compile: "(compile2 \<Lleftarrow> compile1) p1 = Some p3" and
      load: "load1 p1 = Some s1"
    obtain p2 where "compile1 p1 = Some p2" and "compile2 p2 = Some p3"
      using compile by (auto simp: bind_eq_Some_conv option_comp_def)
    then obtain s2 i where "load2 p2 = Some s2" and "match1 i s1 s2"
      using assms(1)[THEN compiler.compile_load] load
      by blast
    moreover obtain s3 i' where "load3 p3 = Some s3" and "match2 i' s2 s3"
      using assms(2)[THEN compiler.compile_load, OF \<open>compile2 p2 = Some p3\<close> \<open>load2 p2 = Some s2\<close>]
      by auto
    ultimately show "\<exists>s3 i. load3 p3 = Some s3 \<and> rel_comp match1 match2 i s1 s3"
      unfolding rel_comp_def by auto
  qed
qed

lemma compiler_composition_pow:
  assumes
    "compiler step step final final load load order match compile"
  shows "compiler step step final final load load
    (lexp order\<^sup>+\<^sup>+) (rel_comp_pow match) (option_comp_pow compile n)"
proof (induction n rule: option_comp_pow.induct)
  case 1
  show ?case
    using assms
    by (auto intro: compiler.axioms compiler.intro compiler_axioms.intro backward_simulation_pow)
next
  case 2
  show ?case
  proof (rule compiler.intro)
    show "compiler_axioms load load (rel_comp_pow match) (option_comp_pow compile (Suc 0))"
    proof unfold_locales
      fix p1 p2 s1
      assume
        "option_comp_pow compile (Suc 0) p1 = Some p2" and
        "load p1 = Some s1"
      thus "\<exists>s2 i. load p2 = Some s2 \<and> rel_comp_pow match i s1 s2"
        using compiler.compile_load[OF assms(1)]
        by (metis option_comp_pow.simps(2) rel_comp_pow.simps(2))
    qed
  qed (auto intro: assms compiler.axioms backward_simulation_pow)
next
  case (3 n')
  show ?case
  proof (rule compiler.intro)
    show "compiler_axioms load load (rel_comp_pow match) (option_comp_pow compile (Suc (Suc n')))"
    proof unfold_locales
      fix p1 p3 s1
      assume
        "option_comp_pow compile  (Suc (Suc n')) p1 = Some p3" and
        "load p1 = Some s1"
      then obtain p2 where
        comp: "compile p1 = Some p2" and
        comp_IH: "option_comp_pow compile (Suc n') p2 = Some p3"
        by (auto simp: option_comp_def bind_eq_Some_conv)
      then obtain s2 i where "load p2 = Some s2" and "match i s1 s2"
        using compiler.compile_load[OF assms(1) _ \<open>load p1 = Some s1\<close>] by blast
      then obtain s3 i' where "load p3 = Some s3" and "rel_comp_pow match i' s2 s3"
        using compiler.compile_load[OF "3.IH" comp_IH] by blast
      moreover have "rel_comp_pow match (i # i') s1 s3"
        using \<open>match i s1 s2\<close> \<open>rel_comp_pow match i' s2 s3\<close>
        using rel_comp_pow.elims(2) by fastforce
      ultimately show "\<exists>s3 i. load p3 = Some s3 \<and> rel_comp_pow match i s1 s3"
        by auto
    qed
  qed (auto intro: assms compiler.axioms backward_simulation_pow)
qed

end


\<^marker>\<open>creator Florian Keßler\<close>

section "SAS++ to SAS+"

theory SAS_Plus_Plus_To_SAS_Plus imports "../SAS_Plus_Plus"
begin

text \<open> We give a reduction from SAS++ to SAS+. The challenge here is to replace the semantics of
       SAS++ that permit initial states with some variables unspecified to be guessed by the solver,
       by SAS+, where initial states need to specify all variables. We do this by constructing
       SAS+ problems where every solution plan is divided into two phases, first one where
       unspecified variables in the initial state are guessed, and the one where the SAS++ problem
       is simulated. \<close>

datatype 'v variable =  Var 'v | Stage
datatype 'd domain_element = DE 'd | Init | NonInit

type_synonym ('v, 'd) state = "('v, 'd) State_Variable_Representation.state"
type_synonym ('v, 'd) operator = "('v variable, 'd domain_element) sas_plus_operator"
type_synonym ('v, 'd) problem = "('v variable, 'd domain_element) sas_plus_problem"

definition SAS_Plus_Plus_State_To_SAS_Plus::
  "('d domain_element \<times> ('v, 'd) state) \<Rightarrow> ('v variable, 'd domain_element) state" where
"SAS_Plus_Plus_State_To_SAS_Plus is = ((\<lambda>x. Some (DE x)) \<circ>\<^sub>m (snd is)
  \<circ>\<^sub>m (\<lambda>x. (case x of Var x \<Rightarrow> Some x | Stage \<Rightarrow> None)))(Stage \<mapsto> (fst is))"

lemma SAS_Plus_Plus_State_To_SAS_Plus_eq_iff_snd_eq[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (i, s) = SAS_Plus_Plus_State_To_SAS_Plus (i, s')
  \<longleftrightarrow> s = s'"
  apply (auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def fun_eq_iff
      split: option.splits variable.splits)
  by (metis option.exhaust_sel)

lemma SAS_Plus_Plus_State_To_SAS_Plus_Stage[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (i, s) Stage = Some i"
  by (auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def)

lemma SAS_Plus_Plus_State_To_SAS_Plus_update_stage[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (a, s)(Stage \<mapsto> b) = SAS_Plus_Plus_State_To_SAS_Plus (b, s)"
  by (auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def fun_eq_iff)

lemma SAS_Plus_Plus_State_To_SAS_Plus_update_Var[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (i, s)(Var x \<mapsto> DE y)
    = SAS_Plus_Plus_State_To_SAS_Plus(i, s(x \<mapsto> y))"
  by (auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def fun_eq_iff
      split: option.splits variable.splits)

lemma SAS_Plus_Plus_State_To_SAS_Plus_map_le[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (a, s) \<subseteq>\<^sub>m m
    \<Longrightarrow> SAS_Plus_Plus_State_To_SAS_Plus (b, s) \<subseteq>\<^sub>m m(Stage \<mapsto> b)"
  by(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_le_def map_comp_def
      split: option.splits variable.splits)

lemma Stage_map_le_SAS_Plus_Plus_State_To_SAS_Plus[simp]:
  "[Stage \<mapsto> i] \<subseteq>\<^sub>m SAS_Plus_Plus_State_To_SAS_Plus (i, s)"
  by(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_le_def)

lemma Var_not_in_map_Var_iff[simp]: "Var x \<notin> Var ` S \<longleftrightarrow> x \<notin> S" by auto

lemma dom_of_SAS_Plus_Plus_State_To_SAS_Plus:
  "dom (SAS_Plus_Plus_State_To_SAS_Plus (i, s)) = { Stage } \<union> (Var ` dom s)"
  by(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def
      split: option.splits variable.splits)

lemma SAS_Plus_Plus_State_To_SAS_Plus_map_le_SAS_Plus_Plus_State_To_SAS_Plus[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (a, s1) \<subseteq>\<^sub>m SAS_Plus_Plus_State_To_SAS_Plus (b, s2)
    \<longleftrightarrow> (a = b \<and> s1 \<subseteq>\<^sub>m s2)"
  apply(auto simp: map_le_def dom_of_SAS_Plus_Plus_State_To_SAS_Plus)
   apply(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def split: option.splits)
  by force+

definition SAS_Plus_Plus_Operator_To_SAS_Plus_Operator::
  "('v, 'd) sas_plus_operator \<Rightarrow> ('v, 'd) operator" where
"SAS_Plus_Plus_Operator_To_SAS_Plus_Operator op =
  \<lparr> precondition_of = (Stage, NonInit) # (map (\<lambda> x. (Var (fst x), DE (snd x))) (precondition_of op)),
    effect_of = (map (\<lambda> x. (Var (fst x), DE (snd x))) (effect_of op))\<rparr>"

lemma dom_of_map_of_map[simp]:
  "dom (map_of (map (\<lambda>x. (Var (fst x), DE (snd x))) l)) = (\<lambda>x. Var (fst x)) ` set l"
  apply(induction l)
  apply(auto)
  by (metis (mono_tags, lifting) domD fst_conv imageI)

lemma map_of_map_eq_None_iff[simp]: "(map_of (map (\<lambda>x. (Var (fst x), DE (snd x))) l) (Var y) = None)
  \<longleftrightarrow> (y \<notin> fst ` set l)"
  apply(induction l)
  by(auto)

lemma map_of_map_eq_Some_iff[simp]: "(map_of (map (\<lambda>x. (Var (fst x), DE (snd x))) l) (Var x) = Some (DE y))
  \<longleftrightarrow> (map_of l x = Some y)"
  apply(induction l)
  by(auto)

lemma SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_applicable[simp]:
  "is_operator_applicable_in (SAS_Plus_Plus_State_To_SAS_Plus (i, s))
    (SAS_Plus_Plus_Operator_To_SAS_Plus_Operator op)
  \<longleftrightarrow> (i = NonInit \<and> is_operator_applicable_in s op)"
  apply(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def
      SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def)
    apply(simp_all add: map_le_def)
   apply(auto split: option.splits variable.splits)
    apply(frule map_of_SomeD)
    apply auto
  by (metis domI weak_map_of_SomeI)+

lemma SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_execute[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (i, s) ++ map_of (effect_of (SAS_Plus_Plus_Operator_To_SAS_Plus_Operator op))
  = SAS_Plus_Plus_State_To_SAS_Plus(i, s \<then>\<^sub>+ op)"
  using map_of_SomeD
  apply(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def fun_eq_iff map_add_def
      SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def split: option.splits variable.splits)
            apply force+
          prefer 9 using map_of_SomeD apply fastforce
  using map_of_map_eq_None_iff map_of_map_eq_Some_iff
  by (metis (mono_tags, lifting) map_of_eq_None_iff map_of_map_eq_Some_iff option.simps
      option.distinct domI  domIff option.simps)+

lemma execute_SAS_Plus_Plus_ops_in_SAS_Plus[simp]:
  "execute_serial_plan_sas_plus (SAS_Plus_Plus_State_To_SAS_Plus (NonInit, s))
    (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ops)
    = SAS_Plus_Plus_State_To_SAS_Plus (NonInit, execute_serial_plan_sas_plus s ops)"
  apply(induction ops arbitrary: s)
   apply(simp add: SAS_Plus_Plus_State_To_SAS_Plus_def
      SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def)
  by(auto simp: SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_applicable[simplified])

definition initialization_operators:: "('v, 'd) sas_plus_problem \<Rightarrow> ('v, 'd) operator list" where
"initialization_operators P =
  concat (map (\<lambda> v. (if v \<in> dom ((P)\<^sub>I\<^sub>+) then []
    else map (\<lambda> y. \<lparr> precondition_of = [(Stage, Init)],  effect_of = [(Var v, DE y)]\<rparr>)
      (the (range_of P v)))) ((P)\<^sub>\<V>\<^sub>+))"

lemma in_initialization_operators_iff:
  "\<lparr>precondition_of = [(Stage, Init)], effect_of = [(Var x, DE y)]\<rparr>
    \<in> set (initialization_operators P)
  \<longleftrightarrow> (x \<in> set ((P)\<^sub>\<V>\<^sub>+) \<and> ((P)\<^sub>I\<^sub>+) x = None \<and> y \<in> set (the (range_of P x)))"
  by(auto simp: initialization_operators_def)

lemma Stage_after_initialization_operator[simp]:
  "op \<in> set (initialization_operators P) \<Longrightarrow> (s ++ map_of (effect_of op)) Stage = s Stage"
  by(auto simp: initialization_operators_def)

definition initial_state::
  "('v, 'd) sas_plus_problem \<Rightarrow> ('v variable, 'd domain_element) state" where
"initial_state P = SAS_Plus_Plus_State_To_SAS_Plus (Init, (\<lambda> v.
  (if v \<in> set ((P)\<^sub>\<V>\<^sub>+) then Some (case ((P)\<^sub>I\<^sub>+) v of
        Some val \<Rightarrow> val |
        None \<Rightarrow> (the (range_of P v)) ! 0)
   else None)))"

definition SAS_Plus_Plus_To_SAS_Plus:: "('v, 'd) sas_plus_problem \<Rightarrow> ('v, 'd) problem" where
"SAS_Plus_Plus_To_SAS_Plus P = \<lparr> variables_of = Stage # (map Var ((P)\<^sub>\<V>\<^sub>+)),
      operators_of = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
        # (initialization_operators P)
        @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+)),
      initial_of = initial_state P ,
      goal_of = SAS_Plus_Plus_State_To_SAS_Plus (NonInit, ((P)\<^sub>G\<^sub>+)),
      range_of = ((\<lambda>x. Some (map DE x)) \<circ>\<^sub>m (range_of P)
        \<circ>\<^sub>m (\<lambda>x. (case x of Var x \<Rightarrow> Some x | Stage \<Rightarrow> None)))(Stage \<mapsto> [Init, NonInit])\<rparr>"

lemma SAS_Plus_Plus_To_SAS_Plus_valid:
  assumes "is_valid_problem_sas_plus_plus P"
  shows "is_valid_problem_sas_plus (SAS_Plus_Plus_To_SAS_Plus P)"
  using assms apply(auto simp: is_valid_problem_sas_plus_plus_def is_valid_problem_sas_plus_def
      SAS_Plus_Plus_To_SAS_Plus_def list_all_def is_valid_operator_sas_plus_def Let_def
      initialization_operators_def SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def ListMem_iff)
               apply auto
              apply fastforce
             apply fastforce
            apply fastforce
           apply fastforce
          apply blast
         apply blast
         apply(auto simp: initial_state_def map_comp_def SAS_Plus_Plus_State_To_SAS_Plus_def
        split: variable.splits if_splits option.splits)
  by (meson assms is_valid_problem_sas_plus_plus_then(1) range_of_not_empty)+

lemma stage_of_initial_state[simp]: "((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) Stage = Some Init"
  by(auto simp: SAS_Plus_Plus_To_SAS_Plus_def initial_state_def)

definition initialization_sequence:: "('v \<times> 'd) list \<Rightarrow> ('v, 'd) operator list" where
  "initialization_sequence vs = map (\<lambda>v. \<lparr> precondition_of = [(Stage, Init)],
      effect_of = [(Var (fst v), DE (snd v))]\<rparr>) vs"

lemma result_of_initialization_sequence[simp]:
  assumes "I Stage = Some Init"
    "distinct (map fst vs)"
  shows "execute_serial_plan_sas_plus I (initialization_sequence vs) =
  I ++ SAS_Plus_Plus_State_To_SAS_Plus (Init, map_of vs)"
using assms proof (induction vs arbitrary: I)
  case Nil
  then show ?case using Nil
    by (auto simp: initialization_sequence_def SAS_Plus_Plus_State_To_SAS_Plus_def map_add_def)
next
  case (Cons v vs)
  hence "execute_serial_plan_sas_plus I (initialization_sequence (v # vs))
    = execute_serial_plan_sas_plus (I(Var (fst v) \<mapsto> DE (snd v))) (initialization_sequence vs)"
    by (auto simp: initialization_sequence_def map_le_def)
  also have "... = I ++ SAS_Plus_Plus_State_To_SAS_Plus (Init, map_of (v # vs))" using Cons
    by(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_add_def fun_eq_iff map_comp_def
        rev_image_eqI split: option.splits variable.splits)
  ultimately show ?case by metis
qed

lemma initialization_sequence_chain_applicable_condition[simp]:
  assumes "s Stage = Some Init"
  shows "chain_applicable s (initialization_sequence vs)"
  using assms apply(induction vs arbitrary: s)
  by(auto simp:  initialization_sequence_def map_le_def)

lemma map_of_conact_map_cases_eq_Some[simp]:
  "map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = Some y
  \<longleftrightarrow> (x \<in> set l \<and> f x = y \<and> m x = None)"
proof
  assume "map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = Some y"
  then show "x \<in> set l \<and> f x = y \<and> m x = None"
    apply -
    apply(drule map_of_SomeD)
    by(auto)
next
  assume "x \<in> set l \<and> f x = y \<and> m x = None"
  hence "(x, y) \<in> set (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l))"
    by auto
  moreover have "\<forall>y'. (x, y') \<in> set (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l))
    \<longrightarrow> y' = f x" by auto
  ultimately show "map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = Some y"
    by (metis (no_types, lifting) map_of_SomeD weak_map_of_SomeI)
qed

lemma map_of_conact_map_cases_eq_None[simp]:
  "map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = None
  \<longleftrightarrow> (x \<notin> set l \<or> m x \<noteq> None)"
proof -
  have "(map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = None)
    = (\<not>(\<exists>y. map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = Some y))"
    by fastforce
  also have "... = (\<not>(\<exists>y. x \<in> set l \<and> f x = y \<and> m x = None))" by auto
  ultimately show ?thesis by simp
qed

lemma distinct_map_fst_concat[simp]:
  "distinct (map fst (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) (remdups l))))"
  apply(induction l)
  by(auto split: option.splits)

lemma length_concat_map[simp]:
  "length (concat (map (\<lambda>v. case m v of None \<Rightarrow> [f v] | Some _ \<Rightarrow> []) (remdups l))) \<le> length l"
  apply(induction l)
  by(auto split: option.splits)

subsection \<open>Correctness\<close>

lemma SAS_Plus_Plus_To_SAS_Plus:
  assumes "is_valid_problem_sas_plus_plus P"
    "is_serial_solution_for_problem_sas_plus_plus P plan"
  shows "\<exists>prefix. length prefix \<le> length ((P)\<^sub>\<V>\<^sub>+) + 1
    \<and> is_serial_solution_for_problem (SAS_Plus_Plus_To_SAS_Plus P)
        (prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))"
proof -
  obtain I where I_def: "((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I \<and> dom I = set ((P)\<^sub>\<V>\<^sub>+)
        \<and> (\<forall> v \<in> set ((P)\<^sub>\<V>\<^sub>+). the (I v) \<in> range_of' P v)
        \<and> ((P)\<^sub>G\<^sub>+) \<subseteq>\<^sub>m execute_serial_plan_sas_plus I plan
        \<and> list_all (\<lambda>op. ListMem op ((P)\<^sub>\<O>\<^sub>+)) plan" using assms
    by (auto simp: is_serial_solution_for_problem_sas_plus_plus_def Let_def)
  let ?P' = "SAS_Plus_Plus_To_SAS_Plus P"
  let ?missing_vs = "(concat (map (\<lambda>v. case ((P)\<^sub>I\<^sub>+) v of Some _ \<Rightarrow> [] |
    None \<Rightarrow> [(v, the (I v))]) (remdups ((P)\<^sub>\<V>\<^sub>+))))"
  let ?prefix' = "initialization_sequence ?missing_vs"
  let ?prefix = "?prefix' @ [\<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>]"
  have "execute_serial_plan_sas_plus ((?P')\<^sub>I\<^sub>+) ?prefix'
    = SAS_Plus_Plus_State_To_SAS_Plus (Init, I)" using I_def
    apply(auto simp: SAS_Plus_Plus_To_SAS_Plus_def SAS_Plus_Plus_State_To_SAS_Plus_def map_le_def
        initial_state_def map_add_def map_comp_def fun_eq_iff split: option.splits variable.splits)
    by (metis domI option.inject)
  hence "execute_serial_plan_sas_plus ((?P')\<^sub>I\<^sub>+)
    (?prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))
    = SAS_Plus_Plus_State_To_SAS_Plus (NonInit, execute_serial_plan_sas_plus I plan)" by auto
  hence "((?P')\<^sub>G\<^sub>+) \<subseteq>\<^sub>m execute_serial_plan_sas_plus ((?P')\<^sub>I\<^sub>+)
    (?prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))" using I_def
    apply(auto simp:  SAS_Plus_Plus_To_SAS_Plus_def SAS_Plus_Plus_State_To_SAS_Plus_def
        map_add_def map_comp_def split: option.splits variable.splits)
    apply(simp add: map_le_def fun_eq_iff)
    by (metis (no_types, lifting) domIff option.case_eq_if)
  hence "length ?prefix \<le> length ((P)\<^sub>\<V>\<^sub>+) + 1
    \<and> is_serial_solution_for_problem (SAS_Plus_Plus_To_SAS_Plus P)
        (?prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))"
    using I_def
    by(auto simp: is_serial_solution_for_problem_def Let_def in_initialization_operators_iff
        initialization_sequence_def ListMem_iff SAS_Plus_Plus_To_SAS_Plus_def range_of'_def
        list_all_def split: option.splits)
  thus ?thesis by blast
qed

lemma map_of_map_Stage[simp]:
  "map_of (map (\<lambda>x. (Var (fst x), DE (snd x))) l) Stage = None"
  apply(induction l)
  by(auto)

lemma chain_applicable_in_Stage_NonInit:
  "s Stage = Some NonInit \<Longrightarrow> chain_applicable s plan
  \<Longrightarrow> \<forall>op \<in> set plan. op \<in> set ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>\<O>\<^sub>+)
  \<Longrightarrow> \<forall>op \<in> set plan. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+))"
proof(induction plan arbitrary: s)
  case Nil
  then show ?case by auto
next
  case (Cons a plan)
  hence "a \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+))"
    "(s \<then>\<^sub>+ a) Stage = Some NonInit"
    using Cons
    by (auto simp: SAS_Plus_Plus_To_SAS_Plus_def map_le_def map_add_def option.case_eq_if
        SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def initialization_operators_def)
  thus ?case using Cons by auto
qed

lemma in_set_take_then: "op \<in> set (take k (a # as)) \<Longrightarrow> (op = a \<or> op \<in> set (take (k - 1) as))"
  by (metis empty_iff empty_set set_ConsD take_Cons')

lemma SAS_plus_plan_structure:
  assumes "s Stage = Some Init"
    "chain_applicable s plan"
    "execute_serial_plan_sas_plus s plan Stage = Some NonInit"
    "list_all (\<lambda>op. ListMem op ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>\<O>\<^sub>+) ) plan"
  shows "\<exists>k. k < length plan
    \<and> list_all (\<lambda>op. op \<in> set (initialization_operators P)) (take k plan)
    \<and> plan ! k = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
    \<and> list_all (\<lambda>op. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+)))
      (drop (k + 1) plan)"
using assms proof(induction plan arbitrary: s)
  case (Cons a plan)
  hence "a \<in> set (initialization_operators P)
    \<or> a = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
    \<or> a \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+))"
    by (auto simp: SAS_Plus_Plus_To_SAS_Plus_def ListMem_iff)
  thus ?case
  using Cons proof(elim disjE)
    assume *: "a \<in> set (initialization_operators P)"
    hence "(s ++ map_of (effect_of a)) Stage = Some Init" using Cons by simp
    then obtain k where "k < length plan
      \<and> list_all (\<lambda>op. op \<in> set (initialization_operators P)) (take k plan)
      \<and> plan ! k = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
      \<and> list_all (\<lambda>op. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+)))
      (drop (k + 1) plan)" using Cons apply(simp) by presburger
    thus ?thesis using Cons * by auto
  next
    assume *: "a = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>"
    hence "\<forall>op \<in> set plan. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+))"
      apply -
      apply(rule chain_applicable_in_Stage_NonInit[where ?s = "s ++ map_of(effect_of a)"])
      using Cons by (auto simp: list_all_def ListMem_iff)
    thus ?thesis using * by (auto simp: list_all_def)
  qed (auto simp: SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def list_all_def map_le_def)
qed auto

lemma result_of_initialization_operator:
  "is_valid_problem_sas_plus_plus P
    \<Longrightarrow> op \<in> set (initialization_operators P)
    \<Longrightarrow> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I
    \<Longrightarrow> (\<forall>v \<in> dom I. the (I v) \<in> \<R>\<^sub>+ P v)
    \<Longrightarrow> (\<exists>I'. (SAS_Plus_Plus_State_To_SAS_Plus (Init, I)) ++ map_of(effect_of op)
        = SAS_Plus_Plus_State_To_SAS_Plus (Init, I')
      \<and> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I' \<and> (\<forall>v \<in> dom I'. the (I' v) \<in> \<R>\<^sub>+ P v))"
  apply(auto simp: initialization_operators_def map_le_def range_of'_def dom_def ListMem_iff
       is_valid_problem_sas_plus_plus_def Let_def list_all_def split: if_splits option.splits)
   apply (meson domI domIff)
  by (metis option.sel option.simps)

lemma result_of_initialization_operators:
  "is_valid_problem_sas_plus_plus P
    \<Longrightarrow> list_all (\<lambda>op. op \<in> set (initialization_operators P)) ops
    \<Longrightarrow> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I
    \<Longrightarrow> (\<forall>v \<in> dom I. the (I v) \<in> \<R>\<^sub>+ P v)
    \<Longrightarrow> (\<exists>I'. execute_serial_plan_sas_plus (SAS_Plus_Plus_State_To_SAS_Plus (Init, I)) ops
        = SAS_Plus_Plus_State_To_SAS_Plus (Init, I')
      \<and> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I' \<and> (\<forall>v \<in> dom I'. the (I' v) \<in> \<R>\<^sub>+ P v))"
proof(induction ops arbitrary: I)
  case (Cons op ops)
  thus ?case using result_of_initialization_operator[OF Cons(2)] by force
qed auto

lemma list_all_in_map_set_then:
  "\<forall>a\<in>set as. a \<in> f ` S  \<Longrightarrow> (\<exists>bs. as = map f bs \<and> (\<forall>b \<in> set bs. b \<in> S))"
  apply(induction as)
   apply(auto)
  by (metis list.simps set_ConsD)

lemma result_of_initialization_operators_on_initial_state:
  "is_valid_problem_sas_plus_plus P
    \<Longrightarrow> list_all (\<lambda>op. op \<in> set (initialization_operators P)) ops
    \<Longrightarrow> (\<exists>I'. execute_serial_plan_sas_plus ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) ops
        = SAS_Plus_Plus_State_To_SAS_Plus (Init, I')
      \<and> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I' \<and> (\<forall>v \<in> dom I'. the (I' v) \<in> \<R>\<^sub>+ P v))"
  apply(simp add: SAS_Plus_Plus_To_SAS_Plus_def initial_state_def)
  apply(rule result_of_initialization_operators)
  apply(auto simp: list_all_def map_le_def is_valid_problem_sas_plus_plus_def Let_def ListMem_iff
      range_of'_def split: option.splits)
  by auto

lemma length_of_mapped: "l' = map f l \<Longrightarrow> length l' \<le> x \<Longrightarrow> length l \<le> x" by simp

lemma SAS_Plus_To_SAS_Plus_Plus:
  assumes "is_valid_problem_sas_plus_plus P"
    "is_serial_solution_for_problem (SAS_Plus_Plus_To_SAS_Plus P) plan"
  shows "\<exists>plan'. length plan' \<le> length plan
    \<and> is_serial_solution_for_problem_sas_plus_plus P plan'"
proof-
  let ?plan = "chain_applicable_prefix ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) plan"
  obtain k where k_def: "k < length ?plan
    \<and> list_all (\<lambda>op. op \<in> set (initialization_operators P)) (take k ?plan)
    \<and> ?plan ! k = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
    \<and> list_all (\<lambda>op. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+)))
      (drop (k + 1) ?plan)"
    using exE[OF SAS_plus_plan_structure[where ?s ="((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+)"
            and ?P = P and ?plan = ?plan]] assms set_of_chain_applicable_prefix
    by(force simp: is_serial_solution_for_problem_def list_all_def map_le_def Let_def
        execute_chain_applicable_prefix SAS_Plus_Plus_To_SAS_Plus_def initial_state_def ListMem_iff
        SAS_Plus_Plus_State_To_SAS_Plus_def)+

  let ?prefix = "take k ?plan"
  obtain I' where I'_def: "execute_serial_plan_sas_plus ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) ?prefix
        = SAS_Plus_Plus_State_To_SAS_Plus (Init, I')
      \<and> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I' \<and> (\<forall>v \<in> dom I'. the (I' v) \<in> \<R>\<^sub>+ P v)"
    using result_of_initialization_operators_on_initial_state assms k_def by blast
  moreover have  "dom (execute_serial_plan_sas_plus ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) ?prefix)
    = set ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>\<V>\<^sub>+)"
    apply(rule dom_of_execute_serial_plan_sas_plus)
    using SAS_Plus_Plus_To_SAS_Plus_valid assms k_def
    by(auto simp: list_all_def SAS_Plus_Plus_To_SAS_Plus_def initial_state_def
        SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def split: option.splits variable.splits)
  ultimately have dom_of_I': "dom I' = set ((P)\<^sub>\<V>\<^sub>+)"
    by (auto simp: dom_of_SAS_Plus_Plus_State_To_SAS_Plus SAS_Plus_Plus_To_SAS_Plus_def)

  have "\<exists>plan'. drop (k + 1) ?plan = map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan'
    \<and> (\<forall>op \<in> set plan'. op \<in> set ((P)\<^sub>\<O>\<^sub>+))"
    using k_def list_all_in_map_set_then by(auto simp: list_all_def)
  then obtain plan' where plan'_def: "map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan'
    = drop (k + 1) ?plan  \<and> (\<forall>op \<in> set plan'. op \<in> set ((P)\<^sub>\<O>\<^sub>+))" by fastforce

  have "?plan = ((take k ?plan)
    @ [\<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>]
    @ (drop (k + 1) ?plan))" using k_def
    by (metis One_nat_def add.right_neutral add_Suc_right append.assoc append_take_drop_id
        hd_drop_conv_nth take_hd_drop)
  hence "execute_serial_plan_sas_plus ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) ?plan
    = execute_serial_plan_sas_plus (SAS_Plus_Plus_State_To_SAS_Plus (Init, I'))
        ([\<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>]
        @ (drop (k + 1) ?plan))" using I'_def
    by (metis chain_applicable_append chain_applicable_prefix_chain_applicable
        execute_serial_plan_sas_plus_append)
  also have "... = SAS_Plus_Plus_State_To_SAS_Plus (NonInit, execute_serial_plan_sas_plus I' plan')"
    using plan'_def by auto (metis execute_SAS_Plus_Plus_ops_in_SAS_Plus)
  ultimately have "(P)\<^sub>G\<^sub>+ \<subseteq>\<^sub>m execute_serial_plan_sas_plus I' plan'"
    using assms(2) plan'_def
    by(auto simp: execute_chain_applicable_prefix is_serial_solution_for_problem_def
        SAS_Plus_Plus_To_SAS_Plus_def)
  hence "(P)\<^sub>I\<^sub>+ \<subseteq>\<^sub>m I' \<and> dom I' = set ((P)\<^sub>\<V>\<^sub>+)
        \<and> (\<forall> v \<in> set ((P)\<^sub>\<V>\<^sub>+). the (I' v) \<in> range_of' P v)
        \<and> (P)\<^sub>G\<^sub>+ \<subseteq>\<^sub>m execute_serial_plan_sas_plus I' plan'
        \<and> list_all (\<lambda>op. ListMem op ((P)\<^sub>\<O>\<^sub>+)) plan'"
    using plan'_def I'_def dom_of_I' by (auto simp: list_all_def ListMem_iff)
  hence "length plan' \<le> length plan
    \<and> is_serial_solution_for_problem_sas_plus_plus P plan'" using plan'_def
    apply (auto simp: is_serial_solution_for_problem_sas_plus_plus_def)
    using length_of_mapped length_of_chain_applicable_prefix le_add1 le_diff_conv le_trans
    by (metis (mono_tags, lifting) length_drop)
  thus ?thesis by blast
qed

end


section {*FUNCTION\_\_EPDAR\_\_EPDA\_RESTRICT*}
theory
  FUNCTION__EPDAR__EPDA_RESTRICT

imports
  PRJ_12_04_01_01__ENTRY

begin

lemma F_EPDA_R_preserves_valid_epda: "
  valid_epda G
  \<Longrightarrow> epda_initial G \<in> Q
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> valid_epda G'"
  apply(simp add: valid_epda_def F_EPDA_R_def valid_epda_step_label_def)
  apply(force)
  done

lemma F_EPDA_R_preserves_valid_pda: "
  valid_pda G
  \<Longrightarrow> epda_initial G \<in> Q
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> valid_pda G'"
  apply(simp add: valid_pda_def)
  apply(rule conjI)
   apply(rule F_EPDA_R_preserves_valid_epda)
     apply(force)
    apply(force)
   apply(force)
  apply(simp add: F_EPDA_R_def)
  apply(force)
  done

lemma F_EPDA_R_constructs_epda_sub: "
  valid_epda G
  \<Longrightarrow> epda_initial G \<in> Q
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epda_sub G' G"
  apply(simp add: epda_sub_def F_EPDA_R_def)
  apply(force)
  done

lemma F_EPDA_R_preserves_valid_dpda: "
  valid_dpda G
  \<Longrightarrow> epda_initial G \<in> Q
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> valid_dpda G'"
  apply(subgoal_tac "epda_sub G' G")
   prefer 2
   apply(rule F_EPDA_R_constructs_epda_sub)
     apply(simp add: valid_dpda_def valid_pda_def)
    apply(force)
   apply(force)
  apply(simp (no_asm) add: valid_dpda_def)
  apply(rule conjI)
   apply(simp add: valid_dpda_def)
   apply(rule F_EPDA_R_preserves_valid_pda)
     apply(force)
    apply(force)
   apply(force)
  apply(rule epda_sub_preserves_is_forward_edge_deterministic_accessible)
    apply(force)
   apply(rule F_EPDA_R_preserves_valid_pda)
     apply(simp add: valid_dpda_def valid_pda_def)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

lemma F_EPDA_R_preserves_valid_sdpda: "
  valid_simple_dpda G
  \<Longrightarrow> epda_initial G \<in> Q
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> valid_simple_dpda G'"
  apply(simp add: valid_simple_dpda_def)
  apply(rule conjI)
   apply(rule F_EPDA_R_preserves_valid_dpda)
     apply(force)
    apply(force)
   apply(force)
  apply(simp add: F_EPDA_R_def)
  apply(force)
  done

theorem F_EPDA_R_marked_language1: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH.marked_language G' \<subseteq> epdaH.marked_language G"
  apply(subgoal_tac "epda_initial G \<in> Q")
   prefer 2
   apply(rule_tac A="epdaH_accessible_states G" in set_mp)
    apply(force)
   apply(rule epda_initial_in_epdaH_accessible_states)
   apply(force)
  apply(rule epda_sub_preserves_epdaH_marked_language)
    apply(force)
   apply(rule_tac G="G" in F_EPDA_R_preserves_valid_epda)
     apply(force)
    prefer 2
    apply(force)
   apply(force)
  apply(rule F_EPDA_R_constructs_epda_sub)
    apply(force)
   prefer 2
   apply(force)
  apply(force)
  done

theorem F_EPDA_R_unmarked_language1: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH.unmarked_language G' \<subseteq> epdaH.unmarked_language G"
  apply(subgoal_tac "epda_initial G \<in> Q")
   prefer 2
   apply(rule_tac A="epdaH_accessible_states G" in set_mp)
    apply(force)
   apply(rule epda_initial_in_epdaH_accessible_states)
   apply(force)
  apply(rule epda_sub_preserves_epdaH_unmarked_language)
    apply(force)
   apply(rule_tac G="G" in F_EPDA_R_preserves_valid_epda)
     apply(force)
    prefer 2
    apply(force)
   apply(force)
  apply(rule F_EPDA_R_constructs_epda_sub)
    apply(force)
   prefer 2
   apply(force)
  apply(force)
  done

theorem F_EPDA_R_reflects_initial_derivations: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH.derivation_initial G' d
  \<Longrightarrow> epdaH.derivation_initial G d"
  apply(subgoal_tac "epda_initial G \<in> Q")
   prefer 2
   apply(rule_tac A="epdaH_accessible_states G" in set_mp)
    apply(force)
   apply(rule epda_initial_in_epdaH_accessible_states)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac Q="Q" in F_EPDA_R_preserves_valid_epda)
     apply(force)
    apply(force)
   apply(force)
  apply(simp add: epdaH.derivation_initial_def)
  apply(rule conjI)
   prefer 2
   apply(case_tac "d 0")
    apply(clarsimp)
   apply(rename_tac a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac a option conf)(*strict*)
   apply(clarsimp)
   apply(rename_tac conf)(*strict*)
   apply(simp add: epdaH_initial_configurations_def epdaH_configurations_def)
   apply(clarsimp)
   apply(simp add: F_EPDA_R_def valid_dpda_def valid_pda_def valid_epda_def)
  apply(simp (no_asm) add: epdaH.derivation_def)
  apply(clarsimp)
  apply(rename_tac i)(*strict*)
  apply(case_tac i)
   apply(rename_tac i)(*strict*)
   apply(clarsimp)
   apply(simp add: epdaH.derivation_def)
   apply(erule_tac x="0" in allE)+
   apply(clarsimp)
  apply(rename_tac i nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat)(*strict*)
  apply(case_tac "d (Suc nat)")
   apply(rename_tac nat)(*strict*)
   apply(force)
  apply(rename_tac nat a)(*strict*)
  apply(clarsimp)
  apply(case_tac a)
  apply(rename_tac nat a option conf)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat option conf)(*strict*)
  apply(subgoal_tac "X" for X)
   apply(rename_tac nat option conf)(*strict*)
   prefer 2
   apply(rule_tac
      d="d" and
      n="nat" and
      m="Suc nat"
      in epdaH.step_detail_before_some_position)
     apply(rename_tac nat option conf)(*strict*)
     apply(force)
    apply(rename_tac nat option conf)(*strict*)
    apply(force)
   apply(rename_tac nat option conf)(*strict*)
   apply(force)
  apply(rename_tac nat option conf)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat conf e1 e2 c1)(*strict*)
  apply(simp add: epdaH_step_relation_def)
  apply(clarsimp)
  apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
  apply(simp add: F_EPDA_R_def)
  done

theorem F_EPDA_R_marked_language2: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH.marked_language G \<subseteq> epdaH.marked_language G'"
  apply(subgoal_tac "epda_initial G \<in> Q")
   prefer 2
   apply(rule_tac A="epdaH_accessible_states G" in set_mp)
    apply(force)
   apply(rule epda_initial_in_epdaH_accessible_states)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac Q="Q" in F_EPDA_R_preserves_valid_epda)
     apply(force)
    apply(force)
   apply(force)
  apply(simp add: epdaH.marked_language_def)
  apply(clarsimp)
  apply(rename_tac x d)(*strict*)
  apply(rule_tac x="d" in exI)
  apply(rule context_conjI)
   apply(rename_tac x d)(*strict*)
   apply(simp add: epdaH.derivation_initial_def)
   apply(rule conjI)
    apply(rename_tac x d)(*strict*)
    prefer 2
    apply(case_tac "d 0")
     apply(rename_tac x d)(*strict*)
     apply(clarsimp)
    apply(rename_tac x d a)(*strict*)
    apply(clarsimp)
    apply(case_tac a)
    apply(rename_tac x d a option conf)(*strict*)
    apply(clarsimp)
    apply(rename_tac x d conf)(*strict*)
    apply(simp add: epdaH_initial_configurations_def epdaH_configurations_def)
    apply(clarsimp)
    apply(rename_tac x d)(*strict*)
    apply(simp add: F_EPDA_R_def valid_dpda_def valid_pda_def valid_epda_def)
   apply(rename_tac x d)(*strict*)
   apply(simp (no_asm) add: epdaH.derivation_def)
   apply(clarsimp)
   apply(rename_tac x d i)(*strict*)
   apply(case_tac i)
    apply(rename_tac x d i)(*strict*)
    apply(clarsimp)
    apply(rename_tac x d)(*strict*)
    apply(simp add: epdaH.derivation_def)
    apply(erule_tac x="0" in allE)+
    apply(clarsimp)
   apply(rename_tac x d i nat)(*strict*)
   apply(clarsimp)
   apply(rename_tac x d nat)(*strict*)
   apply(case_tac "d (Suc nat)")
    apply(rename_tac x d nat)(*strict*)
    apply(force)
   apply(rename_tac x d nat a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac x d nat a option conf)(*strict*)
   apply(clarsimp)
   apply(rename_tac x d nat option conf)(*strict*)
   apply(subgoal_tac "X" for X)
    apply(rename_tac x d nat option conf)(*strict*)
    prefer 2
    apply(rule_tac
      d="d" and
      n="nat" and
      m="Suc nat"
      in epdaH.step_detail_before_some_position)
      apply(rename_tac x d nat option conf)(*strict*)
      apply(force)
     apply(rename_tac x d nat option conf)(*strict*)
     apply(force)
    apply(rename_tac x d nat option conf)(*strict*)
    apply(force)
   apply(rename_tac x d nat option conf)(*strict*)
   apply(clarsimp)
   apply(rename_tac x d nat conf e1 e2 c1)(*strict*)
   apply(simp add: epdaH_step_relation_def)
   apply(clarsimp)
   apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
   apply(simp add: F_EPDA_R_def)
   apply(subgoal_tac "valid_epda_step_label G e2")
    apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
    prefer 2
    apply(simp add: valid_epda_def)
   apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
   apply(simp add: valid_epda_step_label_def)
   apply(clarsimp)
   apply(rule conjI)
    apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
    apply(rule_tac A="epdaH_accessible_edges G" in set_mp)
     apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
     apply(force)
    apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
    apply(simp add: epdaH_accessible_edges_def)
    apply(rule_tac x="d" in exI)
    apply(simp add: epdaH.derivation_initial_def)
    apply(force)
   apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
   apply(rule conjI)
    apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
    apply(rule_tac A="epdaH_accessible_states G" in set_mp)
     apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
     apply(force)
    apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
    apply(simp add: epdaH_accessible_states_def)
    apply(rule_tac x="d" in exI)
    apply(simp add: epdaH.derivation_initial_def)
    apply(rule_tac x="nat" in exI)
    apply(force)
   apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
   apply(rule_tac A="epdaH_accessible_states G" in set_mp)
    apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
    apply(force)
   apply(rename_tac x d nat conf e1 e2 c1 w)(*strict*)
   apply(simp add: epdaH_accessible_states_def)
   apply(rule_tac x="d" in exI)
   apply(simp add: epdaH.derivation_initial_def)
   apply(rule_tac x="Suc nat" in exI)
   apply(force)
  apply(rename_tac x d)(*strict*)
  apply(rule conjI)
   apply(rename_tac x d)(*strict*)
   apply(simp add: epdaH_marked_effect_def)
   apply(clarsimp)
   apply(rename_tac d i e c)(*strict*)
   apply(rule_tac x="i" in exI)
   apply(rule_tac x="e" in exI)
   apply(rule_tac x="c" in exI)
   apply(clarsimp)
   apply(simp add: epdaH_configurations_def epdaH_marking_configurations_def F_EPDA_R_def)
   apply(clarsimp)
   apply(rename_tac d i e q s h)(*strict*)
   apply(rule_tac A="epdaH_accessible_states G" in set_mp)
    apply(rename_tac d i e q s h)(*strict*)
    apply(force)
   apply(rename_tac d i e q s h)(*strict*)
   apply(simp add: epdaH_accessible_states_def)
   apply(rule_tac x="d" in exI)
   apply(simp add: epdaH.derivation_initial_def)
   apply(rule_tac x="i" in exI)
   apply(force)
  apply(rename_tac x d)(*strict*)
  apply(rule conjI)
   apply(rename_tac x d)(*strict*)
   apply(simp add: epdaH.derivation_initial_def)
  apply(rename_tac x d)(*strict*)
  apply(simp add: epdaH_marking_condition_def)
  apply(clarsimp)
  apply(rename_tac x d i e c)(*strict*)
  apply(subgoal_tac "c \<in> epdaH_configurations (F_EPDA_R G Q E)")
   apply(rename_tac x d i e c)(*strict*)
   prefer 2
   apply(rule epdaH.belongs_configurations)
    apply(rename_tac x d i e c)(*strict*)
    apply(rule epdaH.derivation_initial_belongs)
     apply(rename_tac x d i e c)(*strict*)
     apply(force)
    apply(rename_tac x d i e c)(*strict*)
    apply(force)
   apply(rename_tac x d i e c)(*strict*)
   apply(force)
  apply(rename_tac x d i e c)(*strict*)
  apply(subgoal_tac "c \<in> epdaH_marking_configurations (F_EPDA_R G Q E)")
   apply(rename_tac x d i e c)(*strict*)
   prefer 2
   apply(simp add: F_EPDA_R_def epdaH_marking_configurations_def epdaH_configurations_def)
   apply(clarsimp)
  apply(rename_tac x d i e c)(*strict*)
  apply(rule_tac x="i" in exI)
  apply(rule_tac x="e" in exI)
  apply(rule_tac x="c" in exI)
  apply(clarsimp)
  done

theorem F_EPDA_R_preserves_initial_derivations: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH.derivation_initial G d
  \<Longrightarrow> epdaH.derivation_initial G' d"
  apply(subgoal_tac "epda_initial G \<in> Q")
   prefer 2
   apply(rule_tac A="epdaH_accessible_states G" in set_mp)
    apply(force)
   apply(rule epda_initial_in_epdaH_accessible_states)
   apply(force)
  apply(simp add: epdaH.derivation_initial_def)
  apply(rule conjI)
   prefer 2
   apply(case_tac "d 0")
    apply(clarsimp)
   apply(rename_tac a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac a option conf)(*strict*)
   apply(clarsimp)
   apply(rename_tac conf)(*strict*)
   apply(simp add: epdaH_initial_configurations_def epdaH_configurations_def)
   apply(clarsimp)
   apply(simp add: F_EPDA_R_def valid_dpda_def valid_pda_def valid_epda_def)
  apply(simp (no_asm) add: epdaH.derivation_def)
  apply(clarsimp)
  apply(rename_tac i)(*strict*)
  apply(case_tac i)
   apply(rename_tac i)(*strict*)
   apply(clarsimp)
   apply(simp add: epdaH.derivation_def)
   apply(erule_tac x="0" in allE)+
   apply(clarsimp)
  apply(rename_tac i nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat)(*strict*)
  apply(case_tac "d (Suc nat)")
   apply(rename_tac nat)(*strict*)
   apply(force)
  apply(rename_tac nat a)(*strict*)
  apply(clarsimp)
  apply(case_tac a)
  apply(rename_tac nat a option conf)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat option conf)(*strict*)
  apply(subgoal_tac "X" for X)
   apply(rename_tac nat option conf)(*strict*)
   prefer 2
   apply(rule_tac
      d="d" and
      n="nat" and
      m="Suc nat"
      in epdaH.step_detail_before_some_position)
     apply(rename_tac nat option conf)(*strict*)
     apply(force)
    apply(rename_tac nat option conf)(*strict*)
    apply(force)
   apply(rename_tac nat option conf)(*strict*)
   apply(force)
  apply(rename_tac nat option conf)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat conf e1 e2 c1)(*strict*)
  apply(simp add: epdaH_step_relation_def)
  apply(clarsimp)
  apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
  apply(simp add: F_EPDA_R_def)
  apply(subgoal_tac "valid_epda_step_label G e2")
   apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
   prefer 2
   apply(simp add: valid_epda_def)
  apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
  apply(simp add: valid_epda_step_label_def)
  apply(clarsimp)
  apply(rule conjI)
   apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
   apply(rule_tac A="epdaH_accessible_edges G" in set_mp)
    apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
    apply(force)
   apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
   apply(simp add: epdaH_accessible_edges_def)
   apply(rule_tac x="d" in exI)
   apply(simp add: epdaH.derivation_initial_def)
   apply(force)
  apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
  apply(rule conjI)
   apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
   apply(rule_tac A="epdaH_accessible_states G" in set_mp)
    apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
    apply(force)
   apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
   apply(simp add: epdaH_accessible_states_def)
   apply(rule_tac x="d" in exI)
   apply(simp add: epdaH.derivation_initial_def)
   apply(rule_tac x="nat" in exI)
   apply(force)
  apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
  apply(rule_tac A="epdaH_accessible_states G" in set_mp)
   apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
   apply(force)
  apply(rename_tac nat conf e1 e2 c1 w)(*strict*)
  apply(simp add: epdaH_accessible_states_def)
  apply(rule_tac x="d" in exI)
  apply(simp add: epdaH.derivation_initial_def)
  apply(rule_tac x="Suc nat" in exI)
  apply(force)
  done

theorem F_EPDA_R_unmarked_language2: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH.unmarked_language G \<subseteq> epdaH.unmarked_language G'"
  apply(subgoal_tac "epda_initial G \<in> Q")
   prefer 2
   apply(rule_tac A="epdaH_accessible_states G" in set_mp)
    apply(force)
   apply(rule epda_initial_in_epdaH_accessible_states)
   apply(force)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac Q="Q" in F_EPDA_R_preserves_valid_epda)
     apply(force)
    apply(force)
   apply(force)
  apply(simp add: epdaH.unmarked_language_def)
  apply(clarsimp)
  apply(rename_tac x d)(*strict*)
  apply(rule_tac x="d" in exI)
  apply(rule context_conjI)
   apply(rename_tac x d)(*strict*)
   apply(rule F_EPDA_R_preserves_initial_derivations)
       apply(rename_tac x d)(*strict*)
       prefer 4
       apply(force)
      apply(rename_tac x d)(*strict*)
      apply(force)
     apply(rename_tac x d)(*strict*)
     apply(force)
    apply(rename_tac x d)(*strict*)
    apply(force)
   apply(rename_tac x d)(*strict*)
   apply(force)
  apply(rename_tac x d)(*strict*)
  apply(rule conjI)
   apply(rename_tac x d)(*strict*)
   apply(simp add: epdaH_unmarked_effect_def)
  apply(rename_tac x d)(*strict*)
  apply(simp add: epdaH.derivation_initial_def)
  done

lemma F_EPDA_R_livelock1: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH_livelock G
  \<Longrightarrow> epdaH_livelock G'"
  apply(simp add: epdaH_livelock_def)
  apply(clarsimp)
  apply(rename_tac d N)(*strict*)
  apply(rule_tac x="d" in exI)
  apply(clarsimp)
  apply(rule conjI)
   apply(rename_tac d N)(*strict*)
   apply(rule F_EPDA_R_preserves_initial_derivations)
       apply(rename_tac d N)(*strict*)
       prefer 4
       apply(force)
      apply(rename_tac d N)(*strict*)
      apply(force)
     apply(rename_tac d N)(*strict*)
     apply(force)
    apply(rename_tac d N)(*strict*)
    apply(force)
   apply(rename_tac d N)(*strict*)
   apply(force)
  apply(rename_tac d N)(*strict*)
  apply(force)
  done

lemma F_EPDA_R_livelock2: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH_livelock G'
  \<Longrightarrow> epdaH_livelock G"
  apply(simp add: epdaH_livelock_def)
  apply(clarsimp)
  apply(rename_tac d N)(*strict*)
  apply(rule_tac x="d" in exI)
  apply(clarsimp)
  apply(rule conjI)
   apply(rename_tac d N)(*strict*)
   apply(rule F_EPDA_R_reflects_initial_derivations)
       apply(rename_tac d N)(*strict*)
       prefer 5
       apply(force)
      apply(rename_tac d N)(*strict*)
      prefer 4
      apply(force)
     apply(rename_tac d N)(*strict*)
     apply(force)
    apply(rename_tac d N)(*strict*)
    apply(force)
   apply(rename_tac d N)(*strict*)
   apply(force)
  apply(rename_tac d N)(*strict*)
  apply(force)
  done

theorem F_EPDA_R_livelock: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH_livelock G = epdaH_livelock G'"
  apply(rule antisym)
   apply(simp add: F_EPDA_R_livelock2 F_EPDA_R_livelock1)
  apply(simp add: F_EPDA_R_livelock2 F_EPDA_R_livelock1)
  done

theorem F_EPDA_R_spec: "
  valid_epda G
  \<Longrightarrow> epdaH_accessible_states G \<subseteq> Q
  \<Longrightarrow> epdaH_accessible_edges G \<subseteq> E
  \<Longrightarrow> F_EPDA_R G Q E = G'
  \<Longrightarrow> epdaH.marked_language G = epdaH.marked_language G'
  \<and> epdaH.unmarked_language G = epdaH.unmarked_language G'
  \<and> valid_epda G'
  \<and> (valid_pda G \<longrightarrow> valid_pda G')
  \<and> (valid_dpda G \<longrightarrow> valid_dpda G')
  \<and> (valid_simple_dpda G \<longrightarrow> valid_simple_dpda G')
  \<and> (epdaH_livelock G \<longleftrightarrow> epdaH_livelock G')"
  apply(rule conjI)
   apply (metis F_EPDA_R_marked_language1 F_EPDA_R_marked_language2  set_eq_from_double_subseteq)
  apply(rule conjI)
   apply (metis F_EPDA_R_unmarked_language1 F_EPDA_R_unmarked_language2 set_eq_from_double_subseteq)
  apply(rule conjI)
   apply (metis F_EPDA_R_preserves_valid_dpda F_EPDA_R_preserves_valid_epda F_EPDA_R_preserves_valid_pda F_EPDA_R_preserves_valid_sdpda contra_subsetD epda_initial_in_epdaH_accessible_states)
  apply(rule conjI)
   apply (metis F_EPDA_R_preserves_valid_dpda F_EPDA_R_preserves_valid_epda F_EPDA_R_preserves_valid_pda F_EPDA_R_preserves_valid_sdpda contra_subsetD epda_initial_in_epdaH_accessible_states)
  apply(rule conjI)
   apply (metis F_EPDA_R_preserves_valid_dpda F_EPDA_R_preserves_valid_epda F_EPDA_R_preserves_valid_pda F_EPDA_R_preserves_valid_sdpda contra_subsetD epda_initial_in_epdaH_accessible_states)
  apply(rule conjI)
   apply (metis F_EPDA_R_preserves_valid_dpda F_EPDA_R_preserves_valid_epda F_EPDA_R_preserves_valid_pda F_EPDA_R_preserves_valid_sdpda contra_subsetD epda_initial_in_epdaH_accessible_states)
  apply(metis F_EPDA_R_livelock)
  done

definition F_EPDA_R__SpecInput :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> 'state set
  \<Rightarrow> ('state, 'event, 'stack) epda_step_label set
  \<Rightarrow> bool"
  where
    "F_EPDA_R__SpecInput G Q E \<equiv>
  valid_epda G
  \<and> epdaH_accessible_states G \<subseteq> Q
  \<and> epdaH_accessible_edges G \<subseteq> E"

definition F_EPDA_R__SpecOutput :: "
  ('stateA, 'event, 'stackA) epda
  \<Rightarrow> ('stateB, 'event, 'stackB) epda
  \<Rightarrow> bool"
  where
    "F_EPDA_R__SpecOutput Gi Go \<equiv>
  epdaH.marked_language Gi = epdaH.marked_language Go
  \<and> epdaH.unmarked_language Gi = epdaH.unmarked_language Go
  \<and> valid_epda Go
  \<and> (valid_pda Gi \<longrightarrow> valid_pda Go)
  \<and> (valid_dpda Gi \<longrightarrow> valid_dpda Go)
  \<and> (valid_simple_dpda Gi \<longrightarrow> valid_simple_dpda Go)
  \<and> (epdaH_livelock Gi \<longleftrightarrow> epdaH_livelock Go)"

theorem F_EPDA_R__SOUND: "
  F_EPDA_R__SpecInput G Q E
  \<Longrightarrow> F_EPDA_R__SpecOutput G (F_EPDA_R G Q E)"
  apply(simp add: F_EPDA_R__SpecOutput_def F_EPDA_R__SpecInput_def F_EPDA_R_spec)
  apply(rule_tac Q="Q" and E="E" in F_EPDA_R_spec)
     apply(force)
    apply(force)
   apply(force)
  apply(force)
  done

end