theory Reordering_Quantifiers
  imports Main "HOL-Eisbach.Eisbach"
begin

(* Printing util *)
ML \<open>
  fun pretty_cterm ctxt ctm = Syntax.pretty_term ctxt (Thm.term_of ctm)
  val string_of_cterm = Pretty.string_of oo pretty_cterm
  val string_of_term = Pretty.string_of oo Syntax.pretty_term
\<close>

ML_val \<open>tracing (Syntax.string_of_term @{context} @{term "a < b"})\<close>

ML_val \<open>tracing (ML_Syntax.print_term @{term "a < b"})\<close>

ML \<open>
  fun strip_prop (Const (@{const_name HOL.Trueprop}, _) $ t) = t
    | strip_prop t = t
\<close>

declare [[ML_print_depth = 50]]

ML \<open>
  signature QUANTIFIER1_DATA =
sig
  (*functionality*)
  (*terms to be moved around*)
  (*arguments: preceding quantifies, term under question, preceding terms*)
  val move: (term * string * typ) list -> term -> term list -> bool
  (*always move? if false then moves appear if a non-mover was encountered before*)
  val force_move: bool
  (*rotate quantifiers after moving*)
  val rotate: bool
  (*abstract syntax*)
  val dest_eq: term -> (term * term) option
  val dest_conj: term -> (term * term) option
  val dest_imp: term -> (term * term) option
  val conj: term
  val imp: term
  (*rules*)
  val iff_reflection: thm (* P <-> Q ==> P == Q *)
  val iffI: thm
  val iff_trans: thm
  val conjI: thm
  val conjE: thm
  val impI: thm
  val mp: thm
  val exI: thm
  val exE: thm
  val uncurry: thm (* P --> Q --> R ==> P & Q --> R *)
  val iff_allI: thm (* !!x. P x <-> Q x ==> (!x. P x) = (!x. Q x) *)
  val iff_exI: thm (* !!x. P x <-> Q x ==> (? x. P x) = (? x. Q x) *)
  val all_comm: thm (* (!x y. P x y) = (!y x. P x y) *)
  val ex_comm: thm (* (? x y. P x y) = (? y x. P x y) *)
end;

signature QUANTIFIER1 =
sig
  val prove_one_point_all_tac: Proof.context -> tactic
  val prove_one_point_ex_tac: Proof.context -> tactic
  val rearrange_all: Proof.context -> cterm -> thm option
  (* XXX Need to export this ?*)
  val rearrange_ex': Proof.context -> term -> thm option
  val rearrange_ex: Proof.context -> cterm -> thm option
  val rotate_ex: Proof.context -> cterm -> thm option
  val miniscope_ex: Proof.context -> cterm -> thm option
  val rotate_all: Proof.context -> cterm -> thm option
  val rearrange_ball: (Proof.context -> tactic) -> Proof.context -> cterm -> thm option
  val rearrange_bex: (Proof.context -> tactic) -> Proof.context -> cterm -> thm option
  val rearrange_Collect: (Proof.context -> tactic) -> Proof.context -> cterm -> thm option
end;

functor Quantifier(Data: QUANTIFIER1_DATA): QUANTIFIER1 =
struct

fun extract_conj trms fst xs t =
  (case Data.dest_conj t of
    NONE => NONE
  | SOME (P, Q) =>
      let
        val mover = Data.move xs P trms
      in
        if Data.force_move andalso mover then (if fst then NONE else SOME (xs, P, Q))
        else if Data.force_move andalso Data.move xs Q (P :: trms) then SOME (xs, Q, P)
        else if mover andalso not fst then SOME (xs, P, Q)
        else if
          not Data.force_move andalso (not mover orelse not fst) andalso Data.move xs Q (P :: trms)
          then SOME (xs, Q, P)
        else
          (case extract_conj trms (if Data.force_move then false else fst) xs P of
            SOME (xs, eq, P') => SOME (xs, eq, Data.conj $ P' $ Q)
          | NONE =>
              (case extract_conj (P :: trms)
                    (if Data.force_move then false else (fst andalso mover)) xs Q
               of
                SOME (xs, eq, Q') => SOME (xs, eq, Data.conj $ P $ Q')
              | NONE => NONE))
      end);
(* XXX This is not regularized with respect to term context *)
fun extract_imp fst xs t =
  (case Data.dest_imp t of
    NONE => NONE
  | SOME (P, Q) =>
      if Data.move xs P [] then (if fst then NONE else SOME (xs, P, Q))
      else
        (case extract_conj [] false xs P of
          SOME (xs, eq, P') => SOME (xs, eq, Data.imp $ P' $ Q)
        | NONE =>
            (case extract_imp false xs Q of
              NONE => NONE
            | SOME (xs, eq, Q') => SOME (xs, eq, Data.imp $ P $ Q'))));

fun extract_quant extract q =
  let
    fun exqu xs ((qC as Const (qa, _)) $ Abs (x, T, Q)) =
          if qa = q then exqu ((qC, x, T) :: xs) Q else NONE
      | exqu xs P = extract (if Data.force_move then null xs else true) xs P
  in exqu [] end;

fun prove_conv ctxt tu tac =
  let
    val (goal, ctxt') =
      yield_singleton (Variable.import_terms true) (Logic.mk_equals tu) ctxt;
    val thm =
      Goal.prove ctxt' [] [] goal
        (fn {context = ctxt'', ...} =>
          resolve_tac ctxt'' [Data.iff_reflection] 1 THEN tac ctxt'');
  in singleton (Variable.export ctxt' ctxt) thm end;

fun maybe_tac tac = if Data.rotate then tac else K all_tac;

fun qcomm_tac ctxt qcomm qI i =
  REPEAT_DETERM (maybe_tac (resolve_tac ctxt [qcomm]) i THEN resolve_tac ctxt [qI] i);

(* Proves (? x0..xn. ... & x0 = t & ...) = (? x1..xn x0. x0 = t & ... & ...)
   Better: instantiate exI
*)
local
  val excomm = Data.ex_comm RS Data.iff_trans;
in
  fun prove_rotate_ex_tac ctxt i = qcomm_tac ctxt excomm Data.iff_exI i
  fun prove_one_point_ex_tac ctxt =
    prove_rotate_ex_tac ctxt 1 THEN resolve_tac ctxt [Data.iffI] 1 THEN
    ALLGOALS
      (EVERY' [maybe_tac (eresolve_tac ctxt [Data.exE]),
        REPEAT_DETERM o eresolve_tac ctxt [Data.conjE],
        maybe_tac (resolve_tac ctxt [Data.exI]),
        DEPTH_SOLVE_1 o ares_tac ctxt [Data.conjI]])
end;

(* Proves (! x0..xn. (... & x0 = t & ...) --> P x0) =
          (! x1..xn x0. x0 = t --> (... & ...) --> P x0)
*)
local
  fun tac ctxt =
    SELECT_GOAL
      (EVERY1 [REPEAT o dresolve_tac ctxt [Data.uncurry],
        REPEAT o resolve_tac ctxt [Data.impI],
        eresolve_tac ctxt [Data.mp],
        REPEAT o eresolve_tac ctxt [Data.conjE],
        REPEAT o ares_tac ctxt [Data.conjI]]);
  val allcomm = Data.all_comm RS Data.iff_trans;
in
  fun prove_one_point_all_tac ctxt =
    EVERY1 [qcomm_tac ctxt allcomm Data.iff_allI,
      resolve_tac ctxt [Data.iff_allI],
      resolve_tac ctxt [Data.iffI], tac ctxt, tac ctxt];
end

(* Proves (! x0..xn. (... & x0 = t & ...) --> P x0) =
          (! x1..xn x0. x0 = t --> (... & ...) --> P x0)
*)
local
  val allcomm = Data.all_comm RS Data.iff_trans;
in
  fun prove_one_point_all_tac2 ctxt =
    EVERY1 [qcomm_tac ctxt allcomm Data.iff_allI,
      resolve_tac ctxt [Data.iff_allI],
      resolve_tac ctxt [Data.iffI], blast_tac ctxt, blast_tac ctxt];
end

fun renumber l u (Bound i) =
      Bound (if i < l orelse i > u then i else if i = u then l else i + 1)
  | renumber l u (s $ t) = renumber l u s $ renumber l u t
  | renumber l u (Abs (x, T, t)) = Abs (x, T, renumber (l + 1) (u + 1) t)
  | renumber _ _ atom = atom;

fun quantify qC x T xs P =
  let
    fun quant [] P = P
      | quant ((qC, x, T) :: xs) P = quant xs (qC $ Abs (x, T, P));
    val n = length xs;
    val Q = if n = 0 then P else renumber 0 n P;
  in if Data.rotate then quant xs (qC $ Abs (x, T, Q)) else qC $ Abs (x, T, quant xs P) end;

fun rearrange_all ctxt ct =
  (case Thm.term_of ct of
    F as (all as Const (q, _)) $ Abs (x, T, P) =>
      (case extract_quant extract_imp q P of
        NONE => NONE
      | SOME (xs, eq, Q) =>
          let val R = quantify all x T xs (Data.imp $ eq $ Q)
          in SOME (prove_conv ctxt (F, R) prove_one_point_all_tac) end)
  | _ => NONE);

fun rotate_all ctxt ct =
  let
    fun extract fst xs P =
      if fst then NONE else SOME (xs, P, P)
    in
  (case strip_prop (Thm.term_of ct) of
    F as (ex as Const (q, _)) $ Abs (x, T, P) =>
      (case extract_quant extract q P of
        NONE => NONE
      | SOME (xs, _, Q) =>
          let val R = quantify ex x T xs Q
          in SOME (prove_conv ctxt (F, R) prove_one_point_all_tac2) end)
  | _ => NONE) end;

fun rearrange_ball tac ctxt ct =
  (case Thm.term_of ct of
    F as Ball $ A $ Abs (x, T, P) =>
      (case extract_imp true [] P of
        NONE => NONE
      | SOME (xs, eq, Q) =>
          if not (null xs) then NONE
          else
            let val R = Data.imp $ eq $ Q
            in SOME (prove_conv ctxt (F, Ball $ A $ Abs (x, T, R)) tac) end)
  | _ => NONE);

fun rearrange_ex' ctxt trm =
  (case strip_prop trm of
    F as (ex as Const (q, _)) $ Abs (x, T, P) =>
      (case extract_quant (extract_conj []) q P of
        NONE => NONE
      | SOME (xs, eq, Q) =>
          let val R = quantify ex x T xs (Data.conj $ eq $ Q)
          in SOME (prove_conv ctxt (F, R) prove_one_point_ex_tac) end)
  | _ => NONE);

fun rearrange_ex ctxt = rearrange_ex' ctxt o Thm.term_of

fun rotate_ex ctxt ct =
  let
    fun extract fst xs P =
      if fst then NONE else SOME (xs, P, P)
    in
  (case strip_prop (Thm.term_of ct) of
    F as (ex as Const (q, _)) $ Abs (x, T, P) =>
      (case extract_quant extract q P of
        NONE => NONE
      | SOME (xs, _, Q) =>
          let val R = quantify ex x T xs Q
          in SOME (prove_conv ctxt (F, R) prove_one_point_ex_tac) end)
  | _ => NONE) end;

fun miniscope_ex ctxt ct =
  let
    fun extract fst xs t =
      case Data.dest_conj t of
        SOME (P, _) => if Data.move xs P [] andalso not fst then SOME (xs, t, t) else NONE
      | NONE => NONE
    in
  (case strip_prop (Thm.term_of ct) of
    F as (ex as Const (q, _)) $ Abs (x, T, P) =>
      (case extract_quant extract q P of
        NONE => NONE
      | SOME (xs, _, Q) =>
          let val R = quantify ex x T xs Q
          in SOME (prove_conv ctxt (F, R) prove_one_point_ex_tac) end)
  | _ => NONE) end;

fun rearrange_bex tac ctxt ct =
  (case Thm.term_of ct of
    F as Bex $ A $ Abs (x, T, P) =>
      (case extract_conj [] true [] P of
        NONE => NONE
      | SOME (xs, eq, Q) =>
          if not (null xs) then NONE
          else SOME (prove_conv ctxt (F, Bex $ A $ Abs (x, T, Data.conj $ eq $ Q)) tac))
  | _ => NONE);

fun rearrange_Collect tac ctxt ct =
  (case Thm.term_of ct of
    F as Collect $ Abs (x, T, P) =>
      (case extract_conj [] true [] P of
        NONE => NONE
      | SOME (_, eq, Q) =>
          let val R = Collect $ Abs (x, T, Data.conj $ eq $ Q)
          in SOME (prove_conv ctxt (F, R) tac) end)
  | _ => NONE);

end;

structure Quantifier1 = Quantifier
(
  (*abstract syntax*)
  fun dest_eq (Const(@{const_name HOL.eq},_) $ s $ t) = SOME (s, t)
    | dest_eq _ = NONE;
  fun dest_conj (Const(@{const_name HOL.conj},_) $ s $ t) = SOME (s, t)
    | dest_conj _ = NONE;
  fun dest_imp (Const(@{const_name HOL.implies},_) $ s $ t) = SOME (s, t)
    | dest_imp _ = NONE;
  val conj = HOLogic.conj
  val imp  = HOLogic.imp
  fun move xs eq _ =
  (case dest_eq eq of
    SOME (s, t) =>
      let val n = length xs in
        s = Bound n andalso not (loose_bvar1 (t, n)) orelse
        t = Bound n andalso not (loose_bvar1 (s, n))
      end
  | NONE => false);
  val force_move = true
  val rotate = true
  (*rules*)
  val iff_reflection = @{thm eq_reflection}
  val iffI = @{thm iffI}
  val iff_trans = @{thm trans}
  val conjI= @{thm conjI}
  val conjE= @{thm conjE}
  val impI = @{thm impI}
  val mp   = @{thm mp}
  val uncurry = @{thm uncurry}
  val exI  = @{thm exI}
  val exE  = @{thm exE}
  val iff_allI = @{thm iff_allI}
  val iff_exI = @{thm iff_exI}
  val all_comm = @{thm all_comm}
  val ex_comm = @{thm ex_comm}
);

(* loose_bvar2(t,k) iff t contains a 'loose' bound variable referring to
   a level below k. *)
fun loose_bvar2(Bound i,k) = i < k
  | loose_bvar2(f$t, k) = loose_bvar2(f,k) orelse loose_bvar2(t,k)
  | loose_bvar2(Abs(_,_,t),k) = loose_bvar2(t,k+1)
  | loose_bvar2 _ = false;

structure Quantifier2 = Quantifier
(
  (*abstract syntax*)
  fun dest_eq (Const(@{const_name HOL.eq},_) $ s $ t) = SOME (s, t)
    | dest_eq _ = NONE;
  fun dest_conj (Const(@{const_name HOL.conj},_) $ s $ t) = SOME (s, t)
    | dest_conj _ = NONE;
  fun dest_imp (Const(@{const_name HOL.implies},_) $ s $ t) = SOME (s, t)
    | dest_imp _ = NONE;
  val conj = HOLogic.conj
  val imp  = HOLogic.imp
  fun move xs t _ =
      let val n = length xs in
        loose_bvar1 (t, n) andalso not (loose_bvar2 (t, n))
      end
  val force_move = false
  val rotate = false
  (*rules*)
  val iff_reflection = @{thm eq_reflection}
  val iffI = @{thm iffI}
  val iff_trans = @{thm trans}
  val conjI= @{thm conjI}
  val conjE= @{thm conjE}
  val impI = @{thm impI}
  val mp   = @{thm mp}
  val uncurry = @{thm uncurry}
  val exI  = @{thm exI}
  val exE  = @{thm exE}
  val iff_allI = @{thm iff_allI}
  val iff_exI = @{thm iff_exI}
  val all_comm = @{thm all_comm}
  val ex_comm = @{thm ex_comm}
);

structure Quantifier3 = Quantifier
(
  (*abstract syntax*)
  fun dest_eq (Const(@{const_name HOL.eq},_) $ s $ t) = SOME (s, t)
    | dest_eq _ = NONE;
  fun dest_conj (Const(@{const_name HOL.conj},_) $ s $ t) = SOME (s, t)
    | dest_conj _ = NONE;
  fun dest_imp (Const(@{const_name HOL.implies},_) $ s $ t) = SOME (s, t)
    | dest_imp _ = NONE;
  val conj = HOLogic.conj
  val imp  = HOLogic.imp
  fun move xs t _ =
      let val n = length xs in
        loose_bvar1 (t, n) andalso not (loose_bvar (t, n + 1))
      end
  val force_move = false
  val rotate = false
  (*rules*)
  val iff_reflection = @{thm eq_reflection}
  val iffI = @{thm iffI}
  val iff_trans = @{thm trans}
  val conjI= @{thm conjI}
  val conjE= @{thm conjE}
  val impI = @{thm impI}
  val mp   = @{thm mp}
  val uncurry = @{thm uncurry}
  val exI  = @{thm exI}
  val exE  = @{thm exE}
  val iff_allI = @{thm iff_allI}
  val iff_exI = @{thm iff_exI}
  val all_comm = @{thm all_comm}
  val ex_comm = @{thm ex_comm}
);

signature Int_Param =
  sig
    val x : int
  end;

fun is_conj (Const(@{const_name HOL.conj},_) $ _ $ _) = true
    | is_conj _ = false;

functor Quantifier4 (to_move: Int_Param) = Quantifier
(
  (*abstract syntax*)
  fun dest_eq (Const(@{const_name HOL.eq},_) $ s $ t) = SOME (s, t)
    | dest_eq _ = NONE;
  fun dest_conj (Const(@{const_name HOL.conj},_) $ s $ t) = SOME (s, t)
    | dest_conj _ = NONE;
  fun dest_imp (Const(@{const_name HOL.implies},_) $ s $ t) = SOME (s, t)
    | dest_imp _ = NONE;
  val conj = HOLogic.conj
  val imp  = HOLogic.imp
  fun move _ P trms = length trms + 1 = to_move.x andalso not (is_conj P)
  val force_move = true
  val rotate = false
  (*rules*)
  val iff_reflection = @{thm eq_reflection}
  val iffI = @{thm iffI}
  val iff_trans = @{thm trans}
  val conjI= @{thm conjI}
  val conjE= @{thm conjE}
  val impI = @{thm impI}
  val mp   = @{thm mp}
  val uncurry = @{thm uncurry}
  val exI  = @{thm exI}
  val exE  = @{thm exE}
  val iff_allI = @{thm iff_allI}
  val iff_exI = @{thm iff_exI}
  val all_comm = @{thm all_comm}
  val ex_comm = @{thm ex_comm}
);

structure Quantifier5 = Quantifier
(
  (*abstract syntax*)
  fun dest_eq (Const(@{const_name HOL.eq},_) $ s $ t) = SOME (s, t)
    | dest_eq _ = NONE;
  fun dest_conj (Const(@{const_name HOL.conj},_) $ s $ t) = SOME (s, t)
    | dest_conj _ = NONE;
  fun dest_imp (Const(@{const_name HOL.implies},_) $ s $ t) = SOME (s, t)
    | dest_imp _ = NONE;
  val conj = HOLogic.conj
  val imp  = HOLogic.imp
  fun move _ t _ = is_conj t
  val force_move = true
  val rotate = false
  (*rules*)
  val iff_reflection = @{thm eq_reflection}
  val iffI = @{thm iffI}
  val iff_trans = @{thm trans}
  val conjI= @{thm conjI}
  val conjE= @{thm conjE}
  val impI = @{thm impI}
  val mp   = @{thm mp}
  val uncurry = @{thm uncurry}
  val exI  = @{thm exI}
  val exE  = @{thm exE}
  val iff_allI = @{thm iff_allI}
  val iff_exI = @{thm iff_exI}
  val all_comm = @{thm all_comm}
  val ex_comm = @{thm ex_comm}
);

structure Quantifier6 = Quantifier
(
  (*abstract syntax*)
  fun dest_eq (Const(@{const_name HOL.eq},_) $ s $ t) = SOME (s, t)
    | dest_eq _ = NONE;
  fun dest_conj (Const(@{const_name HOL.conj},_) $ s $ t) = SOME (s, t)
    | dest_conj _ = NONE;
  fun dest_imp (Const(@{const_name HOL.implies},_) $ s $ t) = SOME (s, t)
    | dest_imp _ = NONE;
  val conj = HOLogic.conj
  val imp  = HOLogic.imp
  fun move xs t _ =
      let val n = length xs in
        not (loose_bvar1 (t, n))
      end
  val force_move = true
  val rotate = true
  (*rules*)
  val iff_reflection = @{thm eq_reflection}
  val iffI = @{thm iffI}
  val iff_trans = @{thm trans}
  val conjI= @{thm conjI}
  val conjE= @{thm conjE}
  val impI = @{thm impI}
  val mp   = @{thm mp}
  val uncurry = @{thm uncurry}
  val exI  = @{thm exI}
  val exE  = @{thm exE}
  val iff_allI = @{thm iff_allI}
  val iff_exI = @{thm iff_exI}
  val all_comm = @{thm all_comm}
  val ex_comm = @{thm ex_comm}
);

structure Quantifier7 = Quantifier
(
  (*abstract syntax*)
  fun dest_eq (Const(@{const_name HOL.eq},_) $ s $ t) = SOME (s, t)
    | dest_eq _ = NONE;
  fun dest_conj (Const(@{const_name HOL.conj},_) $ s $ t) = SOME (s, t)
    | dest_conj _ = NONE;
  fun dest_imp (Const(@{const_name HOL.implies},_) $ s $ t) = SOME (s, t)
    | dest_imp _ = NONE;
  val conj = HOLogic.conj
  val imp  = HOLogic.imp
  fun move xs t _ =
      let val n = length xs in
        not (loose_bvar1 (t, n))
      end
  val force_move = true
  val rotate = true
  (*rules*)
  val iff_reflection = @{thm eq_reflection}
  val iffI = @{thm iffI}
  val iff_trans = @{thm trans}
  val conjI= @{thm conjI}
  val conjE= @{thm conjE}
  val impI = @{thm impI}
  val mp   = @{thm mp}
  val uncurry = @{thm uncurry}
  val exI  = @{thm exI}
  val exE  = @{thm exE}
  val iff_allI = @{thm iff_allI}
  val iff_exI = @{thm iff_exI}
  val all_comm = @{thm all_comm}
  val ex_comm = @{thm ex_comm}
);

\<close>

ML_val \<open>Quantifier1.rearrange_ex @{context} @{cterm "\<exists> a c. c < n \<and> a \<in> A"}\<close>
ML_val \<open>Quantifier1.rearrange_ex @{context} @{cterm "\<exists> a c. c < n \<and> a = b"}\<close>
ML_val \<open>Quantifier2.rearrange_ex @{context} @{cterm "\<exists> a c. a = b \<and> c < n"}\<close>
ML_val \<open>Quantifier1.rearrange_ex @{context} @{cterm "\<exists> a c. a = b \<and> c < n"}\<close>
ML_val \<open>Quantifier2.rearrange_ex @{context} @{cterm "\<exists> a c. c < n \<and> a = b"}\<close>
ML_val \<open>Quantifier2.rearrange_ex @{context} @{cterm "\<exists> a c. a < n \<and> a = b"}\<close>
ML_val \<open>Quantifier2.rearrange_ex @{context} @{cterm "\<exists> a c. a < n \<and> c < n \<and> a = b"}\<close>
ML_val \<open>Quantifier2.rearrange_ex @{context} @{cterm "\<exists> a c. c < n \<and> a > c"}\<close>
ML_val \<open>Quantifier3.rearrange_ex @{context} @{cterm "\<exists> a c. c < n \<and> a > c"}\<close>
ML_val \<open>Quantifier2.rearrange_ex @{context} @{cterm "\<exists> a c. c < n \<and> a > b"}\<close>
ML_val \<open>Quantifier2.rearrange_ex @{context} @{cterm "\<exists> a c. c < n \<and> (P a c \<and> a > b) \<and> Q c"}\<close>
ML_val \<open>Quantifier2.rearrange_ex @{context} @{cterm "finite {(a, c) | a c. c < n \<and> a \<in> A}"}\<close>
ML_val \<open>Quantifier2.rearrange_ex @{context} @{cterm "finite {t. \<exists> a c. a \<in> A \<and> c < n \<and> t = (a,c)}"}\<close>
ML_val \<open>Quantifier1.rotate_ex @{context} @{cterm "\<exists> a c. c < n \<and> a > b"}\<close>
ML_val \<open>Quantifier1.rotate_ex @{context} @{cterm "\<exists> a c d. c < n \<and> a > b \<and> P d"}\<close>
ML_val \<open>Quantifier1.rearrange_ex @{context} @{cterm "\<exists> a c. a < n \<and> c = b"}\<close>
ML_val \<open>Quantifier1.rearrange_ex @{context} @{cterm "\<forall> a. \<exists> c. a < n \<and> c = b"}\<close>
ML_val \<open>Quantifier1.rearrange_ex @{context} @{cterm "\<forall> a c. a < n \<and> c = b"}\<close>
ML_val \<open>Quantifier6.rearrange_ex @{context} @{cterm "\<exists> a b c. a < n \<and> b < 3 \<and> b > c"}\<close>
ML_val \<open>Quantifier6.rearrange_ex @{context} @{cterm "\<exists>b c. a < n \<and> b < 3 \<and> b > c"}\<close>
ML_val \<open>Quantifier7.miniscope_ex @{context} @{cterm "\<exists> a b c. a < n \<and> b < 3 \<and> b > c"}\<close>
ML_val \<open>Quantifier7.miniscope_ex @{context} @{cterm "\<exists>b c. a < n \<and> b < 3 \<and> b > c"}\<close>

simproc_setup ex_reorder ("\<exists>x. P x") = \<open>fn _ => Quantifier2.rearrange_ex\<close>
declare [[simproc del: ex_reorder]]
simproc_setup ex_reorder2 ("\<exists>x. P x") = \<open>fn _ => Quantifier3.rearrange_ex\<close>
declare [[simproc del: ex_reorder2]]
simproc_setup ex_reorder3 ("\<exists>x. P x") = \<open>fn _ => Quantifier6.rearrange_ex\<close>
declare [[simproc del: ex_reorder3]]
simproc_setup ex_reorder4 ("\<exists>x. P x") = \<open>fn _ => Quantifier7.miniscope_ex\<close>
declare [[simproc del: ex_reorder4]]

ML_val \<open>@{term "\<exists> a c. c < n \<and> a \<in> A"}\<close>

ML_val \<open>@{term "finite {(a, c). c < n \<and> a \<in> A}"}\<close>

ML_val \<open>@{term "finite {(a, c) | a c. c < n \<and> a \<in> A}"}\<close>

lemma
  fixes n :: nat
  assumes A: "finite A"
  shows "finite {(a, c). c < n \<and> a \<in> A}"
  using assms
    using [[simproc add: finite_Collect]]
    by simp

lemma
  fixes n :: nat
  assumes A: "finite A"
  shows "finite {(a, c) | a c. c < n \<and> a \<in> A}"
  using assms
  using [[simproc add: ex_reorder]]
    by simp

lemma
  fixes n :: nat
  assumes A: "finite A"
  shows "finite {t. \<exists> a c. a \<in> A \<and> c < n \<and> t = (a,c)}"
  apply simp
  using assms apply simp
  oops

lemma
  fixes n :: nat
  assumes A: "finite A"
  shows "finite {t. \<exists> a c. (t = (a,c) \<and> c < n) \<and> a \<in> A}"
      using [[simproc add: ex_reorder]]
  using [[simp_trace]] apply simp
  using assms by simp

lemma
  fixes n :: nat
  assumes A: "finite A"
  shows "finite {t. \<exists> a c. (t = (a,c) \<and> a \<in> A) \<and> c < n}"
  using [[simp_trace]] apply (simp del: Product_Type.Collect_case_prod)
  using assms by simp

lemma
  fixes n :: nat
  assumes A: "finite A"
  shows "finite {t. \<exists> a c. (a \<in> A \<and> t = (a,c)) \<and> c < n}"
  using [[simp_trace]] apply simp
  using assms by simp

lemma
  fixes n :: nat
  assumes A: "finite A"
  shows "finite {t. \<exists> a c. a \<in> A \<and> c < n \<and> t = (a,c)}"
  using [[simp_trace]] apply simp
  using assms by simp

lemma
  assumes A: "finite A"
  shows "finite {t. \<exists> a c. a \<in> A \<and> P c \<and> t = (a,c)}"
  using [[simp_trace]] apply simp
  using assms apply simp
  oops

ML \<open>
  fun rotate_quant reorder_thm n ctxt =
    let
      fun subst j =
        if j > n then K all_tac else
          (
            EqSubst.eqsubst_tac ctxt [j] [reorder_thm]
          ) THEN' subst (j + 1)
    in subst 1 end;
\<close>

ML_val Pretty.string_of
ML_val Syntax.pretty_term

ML \<open>
  fun rotate_ex_tac ctxt =
    let
      fun foc_tac {concl, ...} =
        case Quantifier1.rotate_ex ctxt concl of
          NONE => no_tac
        | SOME thm => rewrite_goals_tac ctxt [thm]
    in
      Subgoal.FOCUS foc_tac ctxt
    end;
\<close>

ML \<open>
  fun rotate_all_tac ctxt =
    let
      fun foc_tac {concl, ...} =
        case Quantifier1.rotate_all ctxt concl of
          NONE => no_tac
        | SOME thm => rewrite_goals_tac ctxt [thm]
    in
      Subgoal.FOCUS foc_tac ctxt
    end;
\<close>

ML \<open>
  fun rearrange_ex_tac ctxt =
    let
      fun foc_tac {concl, ...} =
        case Quantifier2.rearrange_ex ctxt concl of
          NONE => no_tac
        | SOME thm => rewrite_goals_tac ctxt [thm]
    in
      Subgoal.FOCUS foc_tac ctxt
    end;
\<close>

ML \<open>
  fun rearrange_ex_tac2 ctxt =
    let
      fun foc_tac {concl, ...} =
        case Quantifier3.rearrange_ex ctxt concl of
          NONE => no_tac
        | SOME thm => rewrite_goals_tac ctxt [thm]
    in
      Subgoal.FOCUS foc_tac ctxt
    end;
\<close>

(* XXX How to do this? *)
(*
ML \<open>
  fun rearrange_ex_tac2 n ctxt =
    let
      struct Quant = Quantifier4(val x = n);
      fun foc_tac {concl, ...} =
        case Quantifier4.rearrange_ex ctxt concl of
          NONE => no_tac
        | SOME thm => rewrite_goals_tac ctxt [thm]
    in
      Subgoal.FOCUS foc_tac ctxt
    end;
\<close>
*)

ML_val Abs

ML_val Conv.rewr_conv

ML \<open>

  fun strip_fin (Const (@{const_name "finite"}, _) $ (Const (@{const_name "Collect"}, _) $ t)) = t
    | strip_fin t = t

  fun wrap_fin tac ctxt = tac ctxt o strip_fin

  structure Quant2 = Quantifier4(val x = 2);
  structure Quant3 = Quantifier4(val x = 3);
  structure Quant4 = Quantifier4(val x = 4);
  structure Quant5 = Quantifier4(val x = 5);

  fun rearrange_ex_fixed_n rearrange_n ctxt =
    let
      fun foc_tac {concl, ...} =
        case rearrange_n ctxt concl of
          NONE => no_tac
        | SOME thm => rewrite_goals_tac ctxt [thm, @{thm HOL.conj_assoc} RS @{thm HOL.eq_reflection}]
    in
      Subgoal.FOCUS foc_tac ctxt
    end;

  val rearrange_ex_fixed_2 = rearrange_ex_fixed_n Quant2.rearrange_ex;
  val rearrange_ex_fixed_3 = rearrange_ex_fixed_n Quant3.rearrange_ex;
  val rearrange_ex_fixed_4 = rearrange_ex_fixed_n Quant4.rearrange_ex;
  val rearrange_ex_fixed_5 = rearrange_ex_fixed_n Quant5.rearrange_ex;

  (* val defer_ex = rearrange_ex_fixed_n (wrap_fin Quantifier5.rearrange_ex); *)

  fun CONV conv ctxt =
    let
      fun foc_tac {concl, ...} =
        rewrite_goals_tac ctxt [conv ctxt concl]
    in
      Subgoal.FOCUS foc_tac ctxt
    end;

  fun mk_conv f ctxt ct =
    case (f ctxt ct) of
      SOME thm => thm
    | _ => raise CTERM ("no conversion", [])

  fun success_conv cv ct =
    let
      val eq = cv ct
    in
      if Thm.is_reflexive eq then raise CTERM ("no conversion", []) else eq
    end

  fun mk_conv' f ctxt ct = the_default (Thm.reflexive ct) (f ctxt ct)
  val assoc_conv = Conv.rewr_conv (@{thm HOL.conj_assoc} RS @{thm HOL.eq_reflection})
  val comm_conv = Conv.rewr_conv (@{thm HOL.conj_commute} RS @{thm HOL.eq_reflection})
  fun wrap_conv f ctxt =
    success_conv (
      Conv.top_sweep_conv (fn ctxt => mk_conv f ctxt then_conv Conv.repeat_conv assoc_conv) ctxt
    )
  fun mk_tac conv ctxt = CONVERSION (Conv.concl_conv ~1 (Object_Logic.judgment_conv ctxt (conv ctxt)))

  val defer_conv = mk_conv Quantifier5.rearrange_ex
  val conv = wrap_conv Quantifier5.rearrange_ex
  fun defer_ex_tac ctxt = CONVERSION (Conv.params_conv ~1 (fn ctxt => Conv.concl_conv ~1 (conv ctxt)) ctxt)
  val defer_ex_tac = CONV conv
  fun defer_ex_tac ctxt i =
    CHANGED (mk_tac (fn ctxt => wrap_conv Quantifier5.rearrange_ex ctxt else_conv Conv.top_sweep_conv (K comm_conv) ctxt) ctxt i)
  val mini_ex_tac = mk_tac (wrap_conv Quantifier6.rearrange_ex)
  val mini_ex_tac2 = mk_tac (wrap_conv Quantifier7.miniscope_ex)

  val rearrange_ex_fixed_2 = mk_tac (wrap_conv Quant2.rearrange_ex);
  val rearrange_ex_fixed_3 = mk_tac (wrap_conv Quant3.rearrange_ex);
  val rearrange_ex_fixed_4 = mk_tac (wrap_conv Quant4.rearrange_ex);
  val rearrange_ex_fixed_5 = mk_tac (wrap_conv Quant5.rearrange_ex);
\<close>

ML_val Object_Logic.judgment_conv

ML_val \<open>defer_conv @{context} @{cterm "\<exists> a b c d. a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"}\<close>
ML_val \<open>assoc_conv @{cterm "(a < 1 \<and> b < 2) \<and> c < 3 \<and> d < 4"}\<close>
ML_val \<open>Conv.binder_conv (K assoc_conv) @{context} @{cterm "\<exists> a. (a < 1 \<and> b < 2) \<and> c < 3 \<and> d < 4"}\<close>
ML_val \<open>Conv.top_sweep_conv (K assoc_conv) @{context}
  @{cterm "\<exists> a b c d. (a < 1 \<and> b < 2) \<and> c < 3 \<and> d < 4"}\<close>
ML_val \<open>Conv.bottom_conv (K (Conv.try_conv assoc_conv)) @{context}
  @{cterm "\<exists> a b c d. (a < 1 \<and> b < 2) \<and> c < 3 \<and> d < 4"}\<close>
ML_val \<open>Conv.every_conv [defer_conv @{context}, Conv.try_conv assoc_conv]
  @{cterm "\<exists> a b c d. a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"}\<close>
ML_val \<open>conv @{context} @{cterm "\<exists> a b c d. a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"}\<close>
ML_val \<open>conv @{context} @{cterm "finite {t. \<exists> a b c d. a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4}"}\<close>
ML_val \<open>conv @{context} @{cterm "\<exists>a b c d. d = 4 \<and> c = 3 \<and> b < 2 \<and> a < 1"}\<close>

ML_val \<open>CONVERSION (Conv.concl_conv ~1 (conv @{context}))\<close>
ML_val Conv.concl_conv

ML_val \<open>Quantifier1.rotate_ex @{context} @{cterm "\<exists> a b c d. a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"}\<close>

ML_val \<open>Quantifier1.rotate_all @{context} @{cterm "\<forall> a b c d. a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"}\<close>

lemma
  "\<forall> a b c d. a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"
  apply (tactic \<open>rotate_all_tac @{context} 1\<close>)
  apply (tactic \<open>rotate_all_tac @{context} 1\<close>)
  apply (tactic \<open>rotate_all_tac @{context} 1\<close>)
  apply (tactic \<open>rotate_all_tac @{context} 1\<close>)
  apply (tactic \<open>rotate_all_tac @{context} 1\<close>)
  oops

lemmas a = HOL.refl[THEN eq_reflection]
lemmas b = enum_the_def[THEN eq_reflection]
ML_val \<open>Thm.is_reflexive @{thm a}\<close>
ML_val \<open>Thm.is_reflexive @{thm b}\<close>
lemma
  "\<exists> a b c d. a < 1 \<and> b < 2 \<and> c = 3 \<and> d = 4"
  apply (tactic \<open>rearrange_ex_fixed_2 @{context} 1\<close>)
  apply (tactic \<open>rearrange_ex_fixed_3 @{context} 1\<close>)
  apply (tactic \<open>rearrange_ex_fixed_4 @{context} 1\<close>)
  apply (tactic \<open>defer_ex_tac @{context} 1\<close>)
  apply (subst conj_assoc)+
  oops

  ML_val \<open>@{const_name finite}\<close>
  ML_val \<open>@{const_name Collect}\<close>
ML_val \<open>strip_fin @{term \<open>finite {t. \<exists>a b c d. a < 1 \<and> b < 2 \<and> c = 3 \<and> d = 4}\<close>}\<close>

lemma
  "finite {t. \<exists> a b c d. a < 1 \<and> b < 2 \<and> c = 3 \<and> d = 4}"
  apply (tactic \<open>rearrange_ex_fixed_2 @{context} 1\<close>)
  apply (tactic \<open>rearrange_ex_fixed_3 @{context} 1\<close>)
  apply (tactic \<open>rearrange_ex_fixed_4 @{context} 1\<close>)
  apply (tactic \<open>defer_ex_tac @{context} 1\<close>)
  oops

lemma
  "finite S \<Longrightarrow> finite {t. \<exists> a b c d. a < 1 \<and> b < 2 \<and> c = 3 \<and> d = 4}"
  apply (tactic \<open>rearrange_ex_fixed_2 @{context} 1\<close>)
  apply (tactic \<open>rearrange_ex_fixed_3 @{context} 1\<close>)
  apply (tactic \<open>rearrange_ex_fixed_4 @{context} 1\<close>)
  apply (tactic \<open>defer_ex_tac @{context} 1\<close>, simp only: conj_assoc)
  oops

lemma
  "finite S \<Longrightarrow> finite {t. \<exists> a b c d. P a b d \<and> c > 3}"
  apply (tactic \<open>defer_ex_tac @{context} 1\<close>)
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply (simp only: ex_simps)
  oops

lemma
  "\<exists> a b c d. d < 4 \<and> a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"
  using [[simproc add: ex_reorder3]]
  apply simp
  oops

lemma
  "\<exists> a b c d. d < 4 \<and> a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"
  using [[simproc add: ex_reorder4]]
  apply simp
  oops

lemma
  "\<exists> a b c d. d < 4 \<and> a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply simp
  oops

lemma
  "\<exists> a b c d. d < 4 \<and> a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"
  apply (tactic \<open>mini_ex_tac2 @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac2 @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac2 @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply simp
  apply (tactic \<open>mini_ex_tac @{context} 1\<close>)
  apply simp
  oops

lemma
  "\<exists> a c b d. d < 4 \<and> a < 1 \<and> b < 2 \<and> c < 3"
  apply simp
  oops

lemma
  "\<exists> a b c d. a < 1 \<and> b < 2 \<and> c < 3 \<and> d < 4"
  apply (tactic \<open>rotate_ex_tac @{context} 1\<close>)
  apply (tactic \<open>rotate_ex_tac @{context} 1\<close>)
  apply (tactic \<open>rotate_ex_tac @{context} 1\<close>)
  apply (tactic \<open>rotate_ex_tac @{context} 1\<close>)
  apply (tactic \<open>rotate_ex_tac @{context} 1\<close>)
  oops

lemma
  "\<exists> a b c d. b < 2 \<and> c < 3 \<and> d < 4 \<and> a < 1"
  apply (tactic \<open>rearrange_ex_tac @{context} 1\<close>)
  oops

lemma
  "\<exists> a b c d. b < 2 \<and> c < 3 \<and> d < 4 \<and> a < c"
  apply (tactic \<open>rearrange_ex_tac2 @{context} 1\<close>; simp only: conj_assoc)+
  oops

lemma
  "\<exists> a b c d. b < 2 \<and> c < 3 \<and> d < 4 \<and> a < c"
  apply (tactic \<open>rearrange_ex_tac2 @{context} 1\<close>; simp del: ex_simps)+
  oops

lemma
  "\<exists> a b c d. b < 2 \<and> c < 3 \<and> d < 4 \<and> a < c"
  apply (tactic \<open>rearrange_ex_tac2 @{context} 1\<close>)
  apply (simp del: ex_simps)
  apply (tactic \<open>rearrange_ex_tac2 @{context} 1\<close>)
  apply (simp del: ex_simps)
  apply (tactic \<open>rearrange_ex_tac2 @{context} 1\<close>)
  using [[simp_trace]]
  apply (simp del: ex_simps)
  oops

lemma finite_Collect_bounded_ex_4:
  assumes "finite {(a,b,c,d) . P a b c d}"
  shows
    "finite {x. \<exists>a b c d. P a b c d \<and> Q x a b c d}
    \<longleftrightarrow> (\<forall> a b c d. P a b c d \<longrightarrow> finite {x. Q x a b c d})"
proof -
  have *:
    "{x. \<exists>a b c d. P a b c d \<and> Q x a b c d}
    = {x. \<exists> t. t \<in> {(a,b,c,d). P a b c d} \<and> (\<exists>a b c d. t = (a, b, c, d) \<and> Q x a b c d)}"
    by simp
  show ?thesis apply (subst *)
    apply (subst finite_Collect_bounded_ex)
    using assms by simp+
oops

lemma finite_Collect_bounded_ex_4':
  assumes "finite {(a,b,c,d) | a b c d. P a b c d}"
  shows
    "finite {x. \<exists>a b c d. P a b c d \<and> Q x a b c d}
    \<longleftrightarrow> (\<forall> a b c d. P a b c d \<longrightarrow> finite {x. Q x a b c d})"
proof -
  have *:
    "{x. \<exists>a b c d. P a b c d \<and> Q x a b c d}
    = {x. \<exists> t. t \<in> {(a,b,c,d) | a b c d. P a b c d} \<and> (\<exists>a b c d. t = (a, b, c, d) \<and> Q x a b c d)}"
    by simp
  show ?thesis apply (subst *)
    apply (subst finite_Collect_bounded_ex)
    using assms by simp+
qed

lemma finite_Collect_bounded_ex_2 [simp]:
  assumes "finite {(a,b). P a b}"
  shows
    "finite {x. \<exists>a b. P a b \<and> Q x a b}
    \<longleftrightarrow> (\<forall> a b. P a b \<longrightarrow> finite {x. Q x a b})"
  using assms finite_Collect_bounded_ex[OF assms, where Q = "\<lambda> x. \<lambda> (a, b). Q x a b"]
  by clarsimp (* force, simp *)

lemma finite_Collect_bounded_ex_3 [simp]:
  assumes "finite {(a,b,c) . P a b c}"
  shows
    "finite {x. \<exists>a b c. P a b c \<and> Q x a b c}
    \<longleftrightarrow> (\<forall> a b c. P a b c \<longrightarrow> finite {x. Q x a b c})"
  using assms finite_Collect_bounded_ex
    [OF assms, where Q = "\<lambda> x. \<lambda> (a, b, c). Q x a b c"]
  by clarsimp

lemma finite_Collect_bounded_ex_4 [simp]:
  assumes "finite {(a,b,c,d) . P a b c d}"
  shows
    "finite {x. \<exists>a b c d. P a b c d \<and> Q x a b c d}
    \<longleftrightarrow> (\<forall> a b c d. P a b c d \<longrightarrow> finite {x. Q x a b c d})"
  using assms finite_Collect_bounded_ex[OF assms, where Q = "\<lambda> x. \<lambda> (a, b, c, d). Q x a b c d"]
  by clarsimp (* force, simp *)

lemma finite_Collect_bounded_ex_5 [simp]:
  assumes "finite {(a,b,c,d,e) . P a b c d e}"
  shows
    "finite {x. \<exists>a b c d e. P a b c d e \<and> Q x a b c d e}
    \<longleftrightarrow> (\<forall> a b c d e. P a b c d e \<longrightarrow> finite {x. Q x a b c d e})"
  using assms finite_Collect_bounded_ex
    [OF assms, where Q = "\<lambda> x. \<lambda> (a, b, c, d, e). Q x a b c d e"]
  by clarsimp (* force, simp *)

lemma finite_Collect_bounded_ex_6 [simp]:
  assumes "finite {(a,b,c,d,e,f) . P a b c d e f}"
  shows
    "finite {x. \<exists>a b c d e f. P a b c d e f \<and> Q x a b c d e f}
    \<longleftrightarrow> (\<forall> a b c d e f. P a b c d e f \<longrightarrow> finite {x. Q x a b c d e f})"
  using assms finite_Collect_bounded_ex
    [OF assms, where Q = "\<lambda> x. \<lambda> (a, b, c, d, e, f). Q x a b c d e f"]
  by clarsimp (* force, simp *)

lemma finite_Collect_bounded_ex_7 [simp]:
  assumes "finite {(a,b,c,d,e,f,g) . P a b c d e f g}"
  shows
    "finite {x. \<exists>a b c d e f g. P a b c d e f g \<and> Q x a b c d e f g}
    \<longleftrightarrow> (\<forall> a b c d e f g. P a b c d e f g \<longrightarrow> finite {x. Q x a b c d e f g})"
  using assms finite_Collect_bounded_ex
    [OF assms, where Q = "\<lambda> x. \<lambda> (a, b, c, d, e, f, g). Q x a b c d e f g"]
  by clarsimp (* force, simp *)

lemma finite_Collect_bounded_ex_8 [simp]:
  assumes "finite {(a,b,c,d,e,f,g,h) . P a b c d e f g h}"
  shows
    "finite {x. \<exists>a b c d e f g h. P a b c d e f g h \<and> Q x a b c d e f g h}
    \<longleftrightarrow> (\<forall> a b c d e f g h. P a b c d e f g h \<longrightarrow> finite {x. Q x a b c d e f g h})"
  using assms finite_Collect_bounded_ex
    [OF assms, where Q = "\<lambda> x. \<lambda> (a, b, c, d, e, f, g, h). Q x a b c d e f g h"]
  by clarsimp (* force, simp *)

lemma finite_Collect_bounded_ex_9 [simp]:
  assumes "finite {(a,b,c,d,e,f,g,h,i) . P a b c d e f g h i}"
  shows
    "finite {x. \<exists>a b c d e f g h i. P a b c d e f g h i \<and> Q x a b c d e f g h i}
    \<longleftrightarrow> (\<forall> a b c d e f g h i. P a b c d e f g h i \<longrightarrow> finite {x. Q x a b c d e f g h i})"
  using assms finite_Collect_bounded_ex
    [OF assms, where Q = "\<lambda> x. \<lambda> (a, b, c, d, e, f, g, h, i). Q x a b c d e f g h i"]
  by clarsimp (* force, simp *)

lemma finite_Collect_bounded_ex_10 [simp]:
  assumes "finite {(a,b,c,d,e,f,g,h,i,j) . P a b c d e f g h i j}"
  shows
    "finite {x. \<exists>a b c d e f g h i j. P a b c d e f g h i j \<and> Q x a b c d e f g h i j}
    \<longleftrightarrow> (\<forall> a b c d e f g h i j. P a b c d e f g h i j \<longrightarrow> finite {x. Q x a b c d e f g h i j})"
  using assms finite_Collect_bounded_ex
    [OF assms, where Q = "\<lambda> x. \<lambda> (a, b, c, d, e, f, g, h, i, j). Q x a b c d e f g h i j"]
  by clarsimp (* force, simp *)

ML \<open>fun mini_ex ctxt = SIMPLE_METHOD (mini_ex_tac ctxt 1)\<close>
ML \<open>fun defer_ex ctxt = SIMPLE_METHOD (defer_ex_tac ctxt 1)\<close>

method_setup mini_existential =
  \<open>Scan.succeed mini_ex\<close> \<open>Miniscope existential quantifiers\<close>
method_setup defer_existential =
  \<open>Scan.succeed defer_ex\<close> \<open>Rotate first conjunct under existential quantifiers to last position\<close>

method mini_ex = ((simp only: ex_simps[symmetric])?, mini_existential, (simp)?)
method defer_ex = ((simp only: ex_simps[symmetric])?, defer_existential, (simp)?)
method defer_ex' = (defer_existential, (simp)?)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Domain_T_cpo
imports Domain_T CPO
begin

(*****************************************************************

         1. Domain_T is a pointed cpo.
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

(*********************************************************
                      Bottom in Dom_T
 *********************************************************)
(* isabelle 2009-1
instance domT :: (type) bot0
by (intro_classes)

defs (overloaded)
  bottom_domT_def   :  "Bot == {<>}t"
*)

instantiation domT :: (type) bot0
begin

definition
  bottom_domT_def : "Bot == {<>}t"

instance ..

end

lemma bottom_domT : "Bot <= (T::'a domT)"
by (simp add: bottom_domT_def)

instance domT :: (type) bot
apply (intro_classes)
by (simp add: bottom_domT)

(**********************************************************
      lemmas used in a proof that domain_T is a cpo.
 **********************************************************)

(* UnionT Ts is an upper bound of Ts *)

lemma UnionT_isUB : "(UnionT Ts) isUB Ts"
apply (simp add: isUB_def)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (subgoal_tac "Ts ~= {}")
apply (simp)
apply (rule_tac x=y in bexI)
by (auto)

(* UnionT Ts is the least upper bound of Ts *)

lemma UnionT_isLUB : "Ts ~= {} ==> UnionT Ts isLUB Ts"
apply (simp add: isLUB_def UnionT_isUB)
apply (simp add: isUB_def)
apply (simp add: subdomT_iff)
apply (intro allI impI)
apply (erule bexE)
apply (drule_tac x="T" in spec)
by (simp)

(* the least upper bound of Ts is UnionT Ts *)

lemma isLUB_UnionT_only_if: "[| Ts ~= {} ; T isLUB Ts |] ==> T = UnionT Ts"
apply (insert UnionT_isLUB[of Ts])
apply (simp)
apply (rule LUB_unique)
by (simp_all)

(* iff *)

lemma isLUB_UnionT : "Ts ~= {} ==> (T isLUB Ts) = (T = UnionT Ts)"
apply (rule iffI)
apply (simp add: isLUB_UnionT_only_if)
apply (simp add: UnionT_isLUB)
done

(* LUB is UnionT Ts *)

lemma LUB_UnionT : "Ts ~= {} ==> LUB Ts = UnionT Ts"
by (simp add: isLUB_LUB UnionT_isLUB)

(**********************************************************
                 ( domT, <= ) is a CPO
 **********************************************************)

instance domT :: (type) cpo
apply (intro_classes)
apply (simp add: hasLUB_def)
apply (rule_tac x="UnionT X" in exI)
apply (simp add: directed_def UnionT_isLUB)
done

(**********************************************************
              ( domT, <= ) is a pointed CPO
 **********************************************************)

instance domT :: (type) cpo_bot
by (intro_classes)

(****************** to add them again ******************)

(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)

declare Sup_image_eq [simp]
declare Inf_image_eq [simp]

end


section \<open>Infrastructures\<close>
text \<open>The Isabelle Infrastructure framework supports the representation of infrastructures
as graphs with actors and policies attached to nodes. These infrastructures
are the {\it states} of the Kripke structure.
The transition between states is triggered by non-parametrized
actions @{text \<open>get, move, eval, put\<close>} executed by actors.
Actors are given by an abstract type @{text \<open>actor\<close>} and a function
@{text \<open>Actor\<close>} that creates elements of that type from identities
(of type @{text \<open>string\<close>}). Policies are given by pairs of predicates
(conditions) and sets of (enabled) actions.\<close>
subsection \<open>Actors, actions, and data labels\<close>
theory Infrastructure
  imports AT
begin
datatype action = get | move | eval | put

typedecl actor
type_synonym identity = string
consts Actor :: "string \<Rightarrow> actor"
type_synonym policy = "((actor \<Rightarrow> bool) * action set)"

definition ID :: "[actor, string] \<Rightarrow> bool"
  where "ID a s \<equiv> (a = Actor s)"
text \<open>The Decentralised Label Model (DLM) \<^cite>\<open>"ml:98"\<close> introduced the idea to
label data by owners and readers. We pick up this idea and formalize
a new type to encode the owner and the set of readers as a pair.
The first element is the owner of a data item, the second one is the
set of all actors that may access the data item.
This enables the unique security
labelling of data within the system additionally taking the ownership into
account.\<close>
type_synonym data = nat
type_synonym dlm = "actor * actor set"

subsection \<open>Infrastructure graphs and policies\<close>
text\<open>Actors are contained in an infrastructure graph. An @{text \<open>igraph\<close>} contains
a set of location pairs representing the topology of the infrastructure
as a graph of nodes and a list of actor identities associated to each node
(location) in the graph.
Also an @{text \<open>igraph\<close>} associates actors to a pair of string sets by
a pair-valued function whose first range component is a set describing
the credentials in the possession of an actor and the second component
is a set defining the roles the actor can take on. More importantly in this
context, an  @{text \<open>igraph\<close>} assigns locations to a pair of a string that defines
the state of the component and an element of type @{text \<open>(dlm * data) set\<close>}. This
set of labelled data may represent a condition on that data.
Corresponding projection functions for each of these components of an
@{text \<open>igraph\<close>} are provided; they are named @{text \<open>gra\<close>} for the actual set of pairs of
locations, @{text \<open>agra\<close>} for the actor map, @{text \<open>cgra\<close>} for the credentials,
and @{text \<open>lgra\<close>} for the state of a location and the data at that location.\<close>
datatype location = Location nat
  datatype igraph = Lgraph "(location * location)set" "location \<Rightarrow> identity set"
                           "actor \<Rightarrow> (string set * string set)"
                           "location \<Rightarrow> string * (dlm * data) set"
datatype infrastructure =
         Infrastructure "igraph"
                        "[igraph, location] \<Rightarrow> policy set"

primrec loc :: "location \<Rightarrow> nat"
where  "loc(Location n) = n"
primrec gra :: "igraph \<Rightarrow> (location * location)set"
where  "gra(Lgraph g a c l) = g"
primrec agra :: "igraph \<Rightarrow> (location \<Rightarrow> identity set)"
where  "agra(Lgraph g a c l) = a"
primrec cgra :: "igraph \<Rightarrow> (actor \<Rightarrow> string set * string set)"
where  "cgra(Lgraph g a c l) = c"
primrec lgra :: "igraph \<Rightarrow> (location \<Rightarrow> string * (dlm * data) set)"
where  "lgra(Lgraph g a c l) = l"

definition nodes :: "igraph \<Rightarrow> location set"
where "nodes g == { x. (? y. ((x,y): gra g) | ((y,x): gra g))}"

definition actors_graph :: "igraph \<Rightarrow> identity set"
where  "actors_graph g == {x. ? y. y : nodes g \<and> x \<in> (agra g y)}"

text \<open>There are projection functions text{@ \<open>graphI\<close>} and text{@ \<open>delta\<close>} when applied
to an infrastructure return the graph and the policy, respectively. Other projections
are introduced for the labels, the credential, and roles and to express their meaning.\<close>
primrec graphI :: "infrastructure \<Rightarrow> igraph"
where "graphI (Infrastructure g d) = g"
primrec delta :: "[infrastructure, igraph, location] \<Rightarrow> policy set"
where "delta (Infrastructure g d) = d"
primrec tspace :: "[infrastructure, actor ] \<Rightarrow> string set * string set"
  where "tspace (Infrastructure g d) = cgra g"
primrec lspace :: "[infrastructure, location ] \<Rightarrow> string * (dlm * data)set"
where "lspace (Infrastructure g d) = lgra g"

definition credentials :: "string set * string set \<Rightarrow> string set"
  where  "credentials lxl \<equiv> (fst lxl)"
definition has :: "[igraph, actor * string] \<Rightarrow> bool"
  where "has G ac \<equiv> snd ac \<in> credentials(cgra G (fst ac))"
definition roles :: "string set * string set \<Rightarrow> string set"
  where  "roles lxl \<equiv> (snd lxl)"
definition role :: "[igraph, actor * string] \<Rightarrow> bool"
  where "role G ac \<equiv> snd ac \<in> roles(cgra G (fst ac))"
definition isin :: "[igraph,location, string] \<Rightarrow> bool"
  where "isin G l s \<equiv> s = fst (lgra G l)"

text \<open>Predicates and projections for the labels to encode their meaning.\<close>
definition owner :: "dlm * data \<Rightarrow> actor" where "owner d \<equiv> fst(fst d)"
definition owns :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
  where "owns G l a d \<equiv> owner d = a"
definition readers :: "dlm * data \<Rightarrow> actor set"
  where "readers d \<equiv> snd (fst d)"

text \<open>The predicate @{text \<open>has_access\<close>} is true for owners or readers.\<close>
definition has_access :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
where "has_access G l a d \<equiv> owns G l a d \<or> a \<in> readers d"

(*
text \<open>Actors can delete data.\<close>
definition actor_can_delete ::   "[infrastructure, actor, location] \<Rightarrow> bool"
where actor_can_delete_def: "actor_can_delete I h l \<equiv>
                   (\<forall> as n. ((h, as), n) \<notin> (snd (lgra (graphI I) l)))"
*)
text \<open>We define a type of functions that preserves the security labeling and a
   corresponding function application  operator.\<close>
typedef label_fun = "{f :: dlm * data \<Rightarrow> dlm * data.
                        \<forall> x:: dlm * data. fst x = fst (f x)}"
  by (fastforce)

definition secure_process :: "label_fun \<Rightarrow> dlm * data \<Rightarrow> dlm * data" (infixr "\<Updown>" 50)
  where "f  \<Updown> d \<equiv> (Rep_label_fun f) d"

(* This part is relevant to model Insiders but is not needed for Infrastructures.

datatype psy_states = happy | depressed | disgruntled | angry | stressed
datatype motivations = financial | political | revenge | curious | competitive_advantage | power | peer_recognition

datatype actor_state = Actor_state "psy_states" "motivations set"
primrec motivation :: "actor_state \<Rightarrow> motivations set"
where "motivation  (Actor_state p m) =  m"
primrec psy_state :: "actor_state \<Rightarrow> psy_states"
where "psy_state  (Actor_state p m) = p"

definition tipping_point :: "actor_state \<Rightarrow> bool" where
  "tipping_point a \<equiv> ((motivation a \<noteq> {}) \<and> (happy \<noteq> psy_state a))"

consts astate :: "identity \<Rightarrow> actor_state"

(* Two versions of an impersonation predicate "a can act as b".
   The first one is stronger and allows substitution of the insider in any context;
   the second one is parameterized over a context predicate to describe this.   *)
definition UasI ::  "[identity, identity] \<Rightarrow> bool "
where "UasI a b \<equiv> (Actor a = Actor b) \<and> (\<forall> x y. x \<noteq> a \<and> y \<noteq> a \<and> Actor x = Actor y \<longrightarrow> x = y)"

definition UasI' ::  "[actor => bool, identity, identity] \<Rightarrow> bool "
where "UasI' P a b \<equiv> P (Actor b) \<longrightarrow> P (Actor a)"

definition Insider :: "[identity, identity set] \<Rightarrow> bool"
where "Insider a C \<equiv> (tipping_point (astate a) \<longrightarrow> (\<forall> b\<in>C. UasI a b))"

definition Insider' :: "[actor \<Rightarrow> bool, identity, identity set] \<Rightarrow> bool"
where "Insider' P a C \<equiv> (tipping_point (astate a) \<longrightarrow> (\<forall> b\<in>C. UasI' P a b \<and> inj_on Actor C))"
*)

text \<open>The predicate atI -- mixfix syntax @{text \<open>@\<^bsub>G\<^esub>\<close>} -- expresses that an actor (identity)
      is at a certain location in an igraph.\<close>
definition atI :: "[identity, igraph, location] \<Rightarrow> bool" ("_ @\<^bsub>(_)\<^esub> _" 50)
where "a @\<^bsub>G\<^esub> l \<equiv> a \<in> (agra G l)"

text \<open>Policies specify the expected behaviour of actors of an infrastructure.
They are defined by the @{text \<open>enables\<close>} predicate:
an actor @{text \<open>h\<close>} is enabled to perform an action @{text \<open>a\<close>}
in infrastructure @{text \<open>I\<close>}, at location @{text \<open>l\<close>}
if there exists a pair @{text \<open>(p,e)\<close>} in the local policy of @{text \<open>l\<close>}
(@{text \<open>delta I l\<close>} projects to the local policy) such that the action
@{text \<open>a\<close>} is a member of the action set @{text \<open>e\<close>} and the policy
predicate @{text \<open>p\<close>} holds for actor @{text \<open>h\<close>}.\<close>
definition enables :: "[infrastructure, location, actor, action] \<Rightarrow> bool"
where
"enables I l a a' \<equiv>  (\<exists> (p,e) \<in> delta I (graphI I) l. a' \<in> e \<and> p a)"

text \<open>The behaviour is the good behaviour, i.e. everything allowed by the policy of infrastructure I.\<close>
definition behaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "behaviour I \<equiv> {(t,a,a'). enables I t a a'}"

text \<open>The misbehaviour is the complement of the behaviour of an infrastructure I.\<close>
definition misbehaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "misbehaviour I \<equiv> -(behaviour I)"

subsection "State transition on infrastructures"
text \<open>The state transition defines how actors may act on infrastructures through actions
    within the boundaries of the policy. It is given as an inductive definition over the
    states which are infrastructures.  This state transition relation is dependent on actions but also on
    enabledness and the current state of the infrastructure.

    First we introduce some auxiliary functions dealing
    with repetitions in lists and actors moving in an igraph.\<close>
primrec jonce :: "['a, 'a list] \<Rightarrow> bool"
where
jonce_nil: "jonce a [] = False" |
jonce_cons: "jonce a (x#ls) = (if x = a then (a \<notin> (set ls)) else jonce a ls)"
(*
primrec nodup :: "['a, 'a list] \<Rightarrow> bool"
  where
    nodup_nil: "nodup a [] = True" |
    nodup_step: "nodup a (x # ls) = (if x = a then (a \<notin> (set ls)) else nodup a ls)"
*)
definition move_graph_a :: "[identity, location, location, igraph] \<Rightarrow> igraph"
where "move_graph_a n l l' g \<equiv> Lgraph (gra g)
                    (if n \<in> ((agra g) l) &  n \<notin> ((agra g) l') then
                     ((agra g)(l := (agra g l) - {n}))(l' := (insert n (agra g l')))
                     else (agra g))(cgra g)(lgra g)"

inductive state_transition_in :: "[infrastructure, infrastructure] \<Rightarrow> bool" ("(_ \<rightarrow>\<^sub>n _)" 50)
where
  move: "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; l \<in> nodes G; l' \<in> nodes G;
          (a) \<in> actors_graph(graphI I); enables I l' (Actor a) move;
         I' = Infrastructure (move_graph_a a l l' (graphI I))(delta I) \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| get : "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; a' @\<^bsub>G\<^esub> l; has G (Actor a, z);
        enables I l (Actor a) get;
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)
                           ((cgra G)(Actor a' :=
                                (insert z (fst(cgra G (Actor a'))), snd(cgra G (Actor a')))))
                           (lgra G))
                   (delta I)
         \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| get_data : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow>
        enables I l' (Actor a) get \<Longrightarrow>
       ((Actor a', as), n) \<in> snd (lgra G l') \<Longrightarrow> Actor a \<in> as \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)
                   ((lgra G)(l := (fst (lgra G l),
                                   snd (lgra G l)  \<union> {((Actor a', as), n)}))))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| process : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow>
        enables I l (Actor a) eval \<Longrightarrow>
       ((Actor a', as), n) \<in> snd (lgra G l) \<Longrightarrow> Actor a \<in> as \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)
                   ((lgra G)(l := (fst (lgra G l),
                    snd (lgra G l)  - {((Actor a', as), n)}
                    \<union> {(f :: label_fun) \<Updown> ((Actor a', as), n)}))))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| del_data : "G = graphI I \<Longrightarrow> a \<in> actors G \<Longrightarrow> l \<in> nodes G \<Longrightarrow>
       ((Actor a, as), n) \<in> snd (lgra G l) \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)
                   ((lgra G)(l := (fst (lgra G l), snd (lgra G l) - {((Actor a, as), n)}))))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| put : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> enables I l (Actor a) put \<Longrightarrow>
        I' = Infrastructure
                  (Lgraph (gra G)(agra G)(cgra G)
                          ((lgra G)(l := (s, snd (lgra G l) \<union> {((Actor a, as), n)}))))
                   (delta I)
          \<Longrightarrow> I \<rightarrow>\<^sub>n I'"

text \<open>Note that the type infrastructure can now be instantiated to the axiomatic type class
      @{text\<open>state\<close>} which enables the use of the underlying Kripke structures and CTL.\<close>
instantiation "infrastructure" :: state
begin
definition
   state_transition_infra_def: "(i \<rightarrow>\<^sub>i i') =  (i \<rightarrow>\<^sub>n (i' :: infrastructure))"

instance
  by (rule MC.class.MC.state.of_class.intro)

definition state_transition_in_refl ("(_ \<rightarrow>\<^sub>n* _)" 50)
where "s \<rightarrow>\<^sub>n* s' \<equiv> ((s,s') \<in> {(x,y). state_transition_in x y}\<^sup>*)"

end

lemma move_graph_eq: "move_graph_a a l l g = g"
  by (simp add: move_graph_a_def, case_tac g, force)

end


(*  Title:       Conflict analysis/Flowgraphs
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
section "Flowgraphs"
theory Flowgraph
imports Main Misc
begin
text_raw \<open>\label{thy:Flowgraph}\<close>

text \<open>
  We use a flowgraph-based program model that extends the one we used previously \<^cite>\<open>"LM07"\<close>.
  A program is represented as an edge annotated graph and a set of procedures. The nodes of the graph are partitioned by the procedures, i.e. every node belongs to exactly one procedure. There are no edges
  between nodes of different procedures. Every procedure has a distinguished entry and return node and a set of monitors it synchronizes on. Additionally, the program has a distinguished {\em main} procedure.
  The edges are annotated with statements. A statement is either a base statement, a procedure call or a thread creation (spawn). Procedure calls and thread creations refer to the called procedure or to the initial procedure
  of the spawned thread, respectively.

  We require that the main procedure and any initial procedure of a spawned thread does not to synchronize on any monitors. This avoids that spawning of a procedure together with entering a monitor is available in our
  model as an atomic step, which would be an unrealistic assumption for practical problems. Technically, our model would become strictly more powerful without this assumption.

  If we allowed this, our model would become strictly more powerful,
\<close>

subsection "Definitions"

datatype ('p,'ba) edgeAnnot = Base 'ba | Call 'p | Spawn 'p
type_synonym ('n,'p,'ba) edge = "('n \<times> ('p,'ba) edgeAnnot \<times> 'n)"

record ('n,'p,'ba,'m) flowgraph_rec =
  edges :: "('n,'p,'ba) edge set" \<comment> \<open>Set of annotated edges\<close>
  main :: "'p" \<comment> \<open>Main procedure\<close>
  entry :: "'p \<Rightarrow> 'n" \<comment> \<open>Maps a procedure to its entry point\<close>
  return :: "'p \<Rightarrow> 'n" \<comment> \<open>Maps a procedure to its return point\<close>
  mon :: "'p \<Rightarrow> 'm set" \<comment> \<open>Maps procedures to the set of monitors they allocate\<close>
  proc_of :: "'n \<Rightarrow> 'p" \<comment> \<open>Maps a node to the procedure it is contained in\<close>

definition
  "initialproc fg p == p=main fg \<or> (\<exists>u v. (u,Spawn p,v)\<in>edges fg)"

lemma main_is_initial[simp]: "initialproc fg (main fg)"
  by (unfold initialproc_def) simp

locale flowgraph =
  fixes fg :: "('n,'p,'ba,'m,'more) flowgraph_rec_scheme" (structure)
  (* Type annotation unnecessary, but perhaps makes it more readable
     for the unaware reader ;) *)
  \<comment> \<open>Edges are inside procedures only\<close>
  assumes edges_part: "(u,a,v)\<in>edges fg \<Longrightarrow> proc_of fg u = proc_of fg v"
  \<comment> \<open>The entry point of a procedure must be in that procedure\<close>
  assumes entry_valid[simp]: "proc_of fg (entry fg p) = p"
  \<comment> \<open>The return point of a procedure must be in that procedure\<close>
  assumes return_valid[simp]: "proc_of fg (return fg p) = p"
  \<comment> \<open>Initial procedures do not synchronize on any monitors\<close>
  assumes initial_no_mon[simp]: "initialproc fg p \<Longrightarrow> mon fg p = {}"

subsection "Basic properties"
lemma (in flowgraph) spawn_no_mon[simp]:
  "(u, Spawn p, v) \<in> edges fg \<Longrightarrow> mon fg p = {}"
  using initial_no_mon by (unfold initialproc_def, blast)
lemma (in flowgraph) main_no_mon[simp]: "mon fg (main fg) = {}"
  using initial_no_mon by (unfold initialproc_def, blast)

lemma (in flowgraph) entry_entry_same_proc[simp]:
  "entry fg p = entry fg p' \<Longrightarrow> p=p'"
  apply (subgoal_tac "proc_of fg (entry fg p) = proc_of fg (entry fg p')")
  apply (simp (no_asm_use))
  by simp

lemma (in flowgraph) return_return_same_proc[simp]:
  "return fg p = return fg p' \<Longrightarrow> p=p'"
  apply (subgoal_tac "proc_of fg (return fg p) = proc_of fg (entry fg p')")
  apply (simp (no_asm_use))
  by simp

subsection "Extra assumptions for flowgraphs"
text_raw \<open>\label{sec:Flowgraph:extra_asm}\<close>
text \<open>
  In order to simplify the definition of our restricted schedules (cf. Section~\ref{thy:Normalization}), we make some extra constraints on flowgraphs.
  Note that these are no real restrictions, as we can always rewrite flowgraphs to match these constraints, preserving the set of conflicts. We leave it to future work to consider such a rewriting formally.

  The background of this restrictions is that we want to start an execution of a thread with a procedure call that never returns. This will allow easier technical treatment in Section~\ref{thy:Normalization}. Here we enforce this
  semantic restrictions by syntactic properties of the flowgraph.
\<close>

text \<open>The return node of a procedure is called {\em isolated}, if it has no incoming edges and is different from the entry node. A procedure with an isolated return node will never return.
  See Section~\ref{sec:Normalization:eflowgraph} for a proof of this.\<close>
definition
  "isolated_ret fg p ==
    (\<forall>u l. \<not>(u,l,return fg p)\<in>edges fg) \<and> entry fg p \<noteq> return fg p"

text \<open>The following syntactic restrictions guarantee that each thread's execution starts with a non-returning call. See Section~\ref{sec:Normalization:eflowgraph} for a proof of this.\<close>
locale eflowgraph = flowgraph +
  \<comment> \<open>Initial procedure's entry node isn't equal to its return node\<close>
  assumes initial_no_ret: "initialproc fg p \<Longrightarrow> entry fg p \<noteq> return fg p"
  \<comment> \<open>The only outgoing edges of initial procedures' entry nodes are call edges to procedures with isolated return node\<close>
  assumes initial_call_no_ret: "\<lbrakk>initialproc fg p; (entry fg p,l,v)\<in>edges fg\<rbrakk>
    \<Longrightarrow> \<exists>p'. l=Call p' \<and> isolated_ret fg p'"

subsection \<open>Example Flowgraph\<close>
text_raw \<open>\label{sec:Flowgraph:ex_flowgraph}\<close>
text \<open>This section contains a check that there exists a (non-trivial) flowgraph, i.e. that the assumptions made in the \<open>flowgraph\<close> and \<open>eflowgraph\<close>
  locales are consistent and have at least one non-trivial model.\<close>
definition
  "example_fg == \<lparr>
    edges = {((0::nat,0::nat),Call 1,(0,1)), ((1,0),Spawn 0,(1,0)),
             ((1,0),Call 0, (1,0))},
    main = 0,
    entry = \<lambda>p. (p,0),
    return = \<lambda>p. (p,1),
    mon = \<lambda>p. if p=1 then {0} else {},
    proc_of= \<lambda> (p,x). p \<rparr>"

lemma exists_eflowgraph: "eflowgraph example_fg"
  apply (unfold_locales)
  apply (unfold example_fg_def)
  apply simp
  apply fast
  apply simp
  apply simp
  apply (simp add: initialproc_def)
  apply (simp add: initialproc_def)
  apply (simp add: initialproc_def isolated_ret_def)
  done

end


(* TODO: Rename. *)
theory Idk
  imports
    Walk
begin

context other
begin

definition tbd :: "('a, 'b) multigraph \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) edge \<Rightarrow> ('a, 'b) multigraph" where
  "tbd G X e \<equiv>
   {e'. \<exists>p u v. walk G p u v \<and>
                e \<in> set p \<and>
                e' \<in> set p \<and>
                set (tl (butlast (walk_vertices p u))) \<inter> X = {}}"

lemma tbd_subset:
  shows "tbd G X e \<subseteq> G"
  sorry

definition tbds :: "('a, 'b) multigraph \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) multigraph set" where
  "tbds G X \<equiv> {E. \<exists>e\<in>G. E = tbd G X e}"

lemma tbds_image_cong:
  shows "tbds G X = (tbd G X) ` G"
  by (auto simp add: tbds_def)

end

end


theory AxiomaticSoundProof
imports Main SC11 AxiomaticModel
begin

locale axiomaticProof = axiomaticModel
begin

definition locMentioned where
"locMentioned T rho = {loc . \<exists> t tid aid . t \<in> T \<and> rho t = Some (tid,aid,Create loc)}"

definition modificationOrder where
"modificationOrder T rho x = {(a,b) . a \<in> T \<and> b \<in> T \<and> a < b \<and>
          (\<exists> tid1 aid1 tid2 aid2 ac1 ac2 . rho a = Some (tid1,aid1, ac1) \<and> rho b = Some (tid2,aid2,ac2)
             \<and> isWrite ac1 \<and> isWrite ac2 \<and> acLoc ac1 = Some x \<and> acLoc ac2 = Some x)}"

(*first, we prove that our model satisfies modification rules on all locations of all threads
   it means that there is a modification order of writes on every location that no thread will violate. *)
lemma satMo : "\<forall> Tid T rho sb rf Locs . validExecution Tid T rho sb rf \<and> Locs = locMentioned T rho \<longrightarrow>
               (\<forall> S x tid a b t1 t2 . S = observeMem Tid T rho sb rf Locs \<and>
                    (tid,a,x,Some t1) \<in> S \<and> (tid,b,x,Some t2) \<in> S \<and> a < b
                  \<longrightarrow> (t1 = t2 \<or> (t1,t2) \<in> (modificationOrder T rho x)))"
  apply simp
  sorry

(* second, we show that our model satisfy SRA model, with satMo lemma and sb U rf U Ux mo is acyclic. *)
definition acqRelAbove where
"acqRelAbove T rho = (\<forall> a tid aid ac . a \<in> T \<and> rho a = Some (tid,aid,ac) \<and> \<not> isFenceLike ac
                     \<longrightarrow> hasAtLeastAcqRel ac)"

definition moUnion where
"moUnion T rho Locs = {(a,b) . (\<exists> x \<in> Locs . (a,b) \<in> modificationOrder T rho x)}"

definition sbUnion where
"sbUnion sb' Tid = {(a,b) . (\<exists> x \<in> Tid . (a,b) \<in> the (sb' x))}"

lemma sbRfMosAcyclic : "\<forall> Tid T rho sb rf Locs . validExecution Tid T rho sb rf \<and>
             acqRelAbove T rho \<longrightarrow> acyclic ((moUnion T rho Locs) \<union> sbUnion sb Tid \<union> rf)"
  sorry

(* definition and proof of the sat of SeqCst ops, atomicity is guaranteed since we do not
   split rmw to two different ops.
   Only need for coherence, sc and no-thin-air *)

definition onlySeq where
"onlySeq T rho = (\<forall> a tid aid ac or . a \<in> T \<and> rho a = Some (tid,aid,ac) \<and> acOrder ac = Some or
                     \<longrightarrow> or = SeqCst)"

definition rb where
"rb T rho rf' Locs = relcomp (converse rf') (moUnion T rho Locs)"

definition eco where
"eco T rho rf' Locs = trancl ((rb T rho rf' Locs) \<union> rf' \<union> (moUnion T rho Locs))"

fun rseMyModel where
"rseMyModel rho a b =
    (sameThread rho a b \<or> isRMWInTuple (rho b))"

fun rsMyModel where
"rsMyModel T rho mo' a_rel b =
   (isRelWrite rho a_rel \<and>
    ((b = a_rel) \<or>
      (rseMyModel rho a_rel b \<and> (a_rel,b) \<in> mo' \<and>
        (\<forall> c \<in> T . ((a_rel,c) \<in> mo' \<and> (c,b) \<in> mo') \<longrightarrow> rseMyModel rho a_rel c))))"

fun rsMyModelSet where
"rsMyModelSet T rho Locs =
 {(a,b) . a \<in> T \<and> b \<in> T \<and> rsMyModel T rho (moUnion T rho Locs) a b}"

fun hrsMyModel where
"hrsMyModel T rho mo' a b =
   ((a = b) \<or>
      (rseMyModel rho a b \<and> (a,b) \<in> mo' \<and>
        (\<forall> c \<in> T . ((a,c) \<in> mo' \<and> (c,b) \<in> mo') \<longrightarrow> rseMyModel rho a c)))"

fun hrsMyModelSet where
"hrsMyModelSet T rho Locs =
  {(a,b) . a \<in> T \<and> b \<in> T \<and> hrsMyModel T rho (moUnion T rho Locs) a b}"

fun swMyModel where
"swMyModel T rho sb' rf' rs hrs a b =
    (sameLocInTuple rho a b \<and>
     (( isRelWrite rho a \<and> isAcqRead rho b \<and> \<not> (sameThread rho a b) \<and>
          (\<exists> c \<in> T . (a,c) \<in> rs \<and> (c,b) \<in> rf' )) \<or>
        (\<not> (sameThread rho a b) \<and>
          isRealFenceInTuple rho a \<and> isRelWrite rho a \<and> isRealFenceInTuple rho b \<and> isAcqRead rho b \<and>
          (\<exists> x \<in> T . (\<exists> y \<in> T . sameLocInTuple rho x y \<and>
              isAtomicInTuple rho x \<and> isAtomicInTuple rho y \<and> isWriteInTuple (rho x) \<and>
              (a,x) \<in> sb' \<and> (y,b) \<in> sb' \<and>
              (\<exists> z \<in> T . (x,z) \<in> hrs \<and> (z,y) \<in> rf')))) \<or>
        (\<not> (sameThread rho a b) \<and>
          isRealFenceInTuple rho a \<and> isRelWrite rho a \<and> isAtomicInTuple rho b \<and> isAcqRead rho b \<and>
          (\<exists> x \<in> T . sameLocInTuple rho x b \<and>
            isAtomicInTuple rho x \<and> isWriteInTuple (rho x) \<and> (a,x) \<in> sb' \<and>
            (\<exists> z \<in> T . (x,z) \<in> hrs \<and> (z,b) \<in> rf' ) ) ) \<or>
        (\<not> (sameThread rho a b) \<and>
          isAtomicInTuple rho a \<and> isRelWrite rho a \<and>
          isRealFenceInTuple rho b \<and> isAcqRead rho b \<and>
          (\<exists> x \<in> T . sameLocInTuple rho a x \<and> isAtomicInTuple rho x \<and>
            (x,b) \<in> sb' \<and>
            (\<exists> z \<in> T . (a,z) \<in> rs \<and> (z,x) \<in> rf' ) ) )))"

fun swMyModelSet where
"swMyModelSet T rho sb' rf' Locs =
 {(a,b) . a \<in> T \<and> b \<in> T \<and> swMyModel T rho sb' rf' (rsMyModelSet T rho Locs) (hrsMyModelSet T rho Locs) a b}"

fun hbMyModelSet where
"hbMyModelSet T rho sb' rf' Locs = trancl (sb' \<union> swMyModelSet T rho sb' rf' Locs)"

lemma coherence : "\<forall> Tid T rho sb rf Locs . validExecution Tid T rho sb rf \<and> acqRelAbove T rho
                    \<longrightarrow> (\<forall> a \<in> T . (a,a) \<notin> (relcomp (hbMyModelSet T rho (sbUnion sb Tid) rf Locs) (eco T rho rf Locs)))"
  sorry

lemma noThinAir : "\<forall> Tid T rho sb rf Locs . validExecution Tid T rho sb rf \<and>
             acqRelAbove T rho \<longrightarrow> acyclic (sbUnion sb Tid \<union> rf)"
  apply simp
  sorry

end

end


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

theory L2Opt
imports L2Defs L2Peephole
begin

(* Flow-sensitive simplification rules for L2 programs. *)
named_theorems L2flow

(*
 * The monads "A" and "B" are equivalent under precondition "P".
 * Additionally, under this precondition, they always leave the
 * postcondition "Q" (normally) or "E" (if an exception occurs).
 *)
definition
  "monad_equiv P A B Q E \<equiv> (\<forall>s. P s \<longrightarrow> A s = B s) \<and> \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace>"

lemma monad_equivI [intro]:
  "\<lbrakk> \<And>s. P s \<Longrightarrow> A s = B s; \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace> \<rbrakk> \<Longrightarrow> monad_equiv P A B Q E"
  apply (clarsimp simp: monad_equiv_def)
  done

lemma monad_equiv_eqI [intro]:
  "\<lbrakk> \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace> \<rbrakk> \<Longrightarrow> monad_equiv P A A Q E"
  apply (clarsimp simp: monad_equiv_def)
  done

lemma monad_equiv_eq:
    "monad_equiv (\<lambda>_. True) A B X Y \<Longrightarrow> A = B"
  apply (rule ext)
  apply (clarsimp simp: monad_equiv_def)
  done

lemma monad_equiv_triv [L2flow]:
    "monad_equiv P A A (\<lambda>_ _. \<exists>s. P s) (\<lambda>_ _. \<exists>s. P s)"
  apply rule
  apply wp
  apply force
  done

lemma monad_equiv_symmetric:
  "monad_equiv P A B X Y = monad_equiv P B A X Y"
  apply (clarsimp simp: monad_equiv_def validE_def2 Ball_def split: sum.splits)
  apply force
  done

lemma monad_equivD: "\<lbrakk> monad_equiv P A B R E; P s \<rbrakk> \<Longrightarrow> A s = B s"
  apply (clarsimp simp: monad_equiv_def)
  done

(*
 * Show that under condition "P", the values "A" and "B" are equal.
 *
 * We use this to simplify expressions inside our monads in a (somewhat)
 * controlled fashion.
 *)
definition "simp_expr P A B \<equiv> P \<longrightarrow> A = B"

lemma simp_expr_triv: "simp_expr P A A"
  apply (clarsimp simp: simp_expr_def)
  done

lemma simp_expr_P_cong:
  "\<lbrakk> P = P' \<rbrakk> \<Longrightarrow> simp_expr P A B = simp_expr P' A B"
  apply (clarsimp simp: simp_expr_def)
  done

lemma simp_expr_rhs_cong [cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> B = B' \<rbrakk> \<Longrightarrow> simp_expr P A B = simp_expr P' A B'"
  apply (clarsimp simp: simp_expr_def simp_implies_def)
  done

lemma simp_expr_weaken:
  "\<lbrakk> simp_expr P A B; Q \<Longrightarrow> P \<rbrakk> \<Longrightarrow> simp_expr Q A B"
  apply (clarsimp simp: simp_expr_def)
  done

(*
 * Monad simplification rules.
 *
 * When solving "monad_equiv P A B R E", the l2_opt tactics assume that P is concrete;
 * to ensure this, monad_equiv rules should result in R being instantiated.
 * See e.g. monad_equiv_unreachable where we have to constrain the rule.
 *)

lemma monad_equiv_gets [L2flow]:
    "simp_expr True v v' \<Longrightarrow> monad_equiv P (L2_gets (\<lambda>s. v s) n) (L2_gets (\<lambda>s. v' s) n)
        (\<lambda>r s. P s \<and> r = v' s) (\<lambda>_ _. False)"
  apply rule
   apply (clarsimp simp: L2_defs simp_expr_def)+
  apply wpsimp
  done

lemma monad_equiv_throw [L2flow]:
    "simp_expr True v v' \<Longrightarrow>
       monad_equiv P (L2_throw v n) (L2_throw v' n) (\<lambda>_ _. False) (\<lambda>r s. P s \<and> r = v')"
  apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
  apply wp
  apply force
  done

lemma monad_equiv_guard:
    "\<lbrakk> \<And>s. simp_expr (P s) (G s) (G' s) \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_guard (\<lambda>s. G s)) (L2_guard (\<lambda>s. G' s)) (\<lambda>r s. P s \<and> G' s \<and> r = ()) (\<lambda>_ _. False)"
  apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
  apply rule
   apply (clarsimp simp: liftE_def guard_def bind_def in_return snd_return)
  apply wp
  apply force
  done

(* We use this weaker form of guard simplification to prevent bound
 * variables being expanded inside of guard statements. *)
lemma monad_equiv_guard' [L2flow]:
    "\<lbrakk> \<And>s. simp_expr True (G s) (G' s) \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_guard (\<lambda>s. G s)) (L2_guard (\<lambda>s. G' s)) (\<lambda>r s. P s \<and> G' s \<and> r = ()) (\<lambda>_ _. False)"
  apply (rule monad_equiv_guard)
  apply (rule simp_expr_weaken)
   apply assumption
  apply simp
  done

lemma monad_equiv_guard_False [L2flow]:
    "\<lbrakk> \<And>s. simp_expr (P s) False (G s) \<rbrakk>
          \<Longrightarrow> monad_equiv P (L2_guard G) (L2_fail) (\<lambda>_ _. False) (\<lambda>_ _. False)"
  apply (monad_eq simp: L2_defs monad_equiv_def simp_expr_def validE_def2)
  done

lemma monad_equiv_guard_True [L2flow]:
    "\<lbrakk> \<And>s. simp_expr (P s) True (G s) \<rbrakk>
          \<Longrightarrow> monad_equiv P (L2_guard G) L2_skip (\<lambda>r s. P s \<and> r = ()) (\<lambda>_ _. False)"
  apply (auto simp: L2_defs simp_expr_def guard_def liftE_def return_def returnOk_def bind_def validE_def valid_def)
  done

lemma monad_equiv_guard_conj [L2flow]:
    "\<lbrakk> monad_equiv P (L2_guard G1) G1' R1 E1;
       monad_equiv (\<lambda>s. R1 () s) (L2_guard G2) G2' R2 E2 \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_guard (\<lambda>s. G1 s \<and> G2 s)) (L2_seq G1' (\<lambda>_. G2')) (\<lambda>r s. R2 () s) (\<lambda>_ _. False)"
  apply (subst (asm) (1 2) monad_equiv_symmetric)
  apply (subst monad_equiv_symmetric)
  apply rule
   apply (monad_eq simp: L2_defs monad_equiv_def validE_def2 Bex_def Ball_def split: sum.splits)
   apply fast
  apply (monad_eq simp: monad_equiv_def L2_defs validE_def2 Ball_def split: sum.splits)
  apply fast
  done

lemma monad_equiv_unknown [L2flow]:
    "monad_equiv P (L2_unknown name) (L2_unknown name) (\<lambda>r s. P s) (\<lambda>_ _. False)"
  apply (clarsimp simp: monad_equiv_def L2_defs)
  apply (wp select_wp)
  apply force
  done

lemma monad_equiv_modify [L2flow]:
    "\<lbrakk> \<And>s. simp_expr True (m s) (m' s) \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_modify (\<lambda>s. m s)) (L2_modify (\<lambda>s. m' s)) (\<lambda>r s'. \<exists>s. P s \<and> m' s = s' \<and> r = ()) (\<lambda>_ _. False)"
  apply rule
   apply (clarsimp simp: L2_defs simp_expr_def liftE_def modify_def put_def get_def bind_def)
  apply (clarsimp simp: L2_defs simp_expr_def)
  apply wp
  apply force
  done

lemma monad_equiv_spec [L2flow]:
    "\<lbrakk> \<And>s s'. simp_expr True ((s, s') \<in> S) (S' s s') \<rbrakk> \<Longrightarrow>
        monad_equiv P (L2_spec S) (L2_spec ({(s, s'). S' s s'})) (\<lambda>r s. \<exists>s. P s) (\<lambda>_ _. False)"
  apply rule
   apply (clarsimp simp: L2_defs simp_expr_def liftE_def spec_def bind_def)
  apply (clarsimp simp: L2_defs)
  apply wp
  apply force
  done

lemma monad_equiv_fail [L2flow]:
    "monad_equiv P L2_fail L2_fail (\<lambda>_ _. False) (\<lambda>_ _. False)"
  apply (clarsimp simp: monad_equiv_def L2_defs)
  done

lemma monad_equiv_condition [L2flow]:
  "\<lbrakk> \<And>s. simp_expr True (C s) (C' s);
     monad_equiv (\<lambda>s. P s \<and> C' s) L L' QL EL;
     monad_equiv (\<lambda>s. P s \<and> \<not> C' s) R R' QR ER \<rbrakk> \<Longrightarrow>
   monad_equiv P (L2_condition (\<lambda>s. C s) L R) (L2_condition (\<lambda>s. C' s) L' R')
      (\<lambda>r s. \<exists>s. P s) \<comment> \<open>Deliberately weak to avoid exponential growth.\<close>
      (\<lambda>r s. \<exists>s. P s)"
  apply rule
   apply (monad_eq simp: L2_defs monad_equiv_def simp_expr_def split: condition_splits)
  apply (monad_eq simp: L2_defs monad_equiv_def validE_def2 split: condition_splits sum.splits)
  apply force
  done

lemma monad_equiv_condition_True [L2flow]:
  "\<lbrakk> \<And>s. simp_expr (P s) (C s) True;
     monad_equiv P L L' QL EL \<rbrakk> \<Longrightarrow>
     monad_equiv P (L2_condition C L R) L' QL EL"
  unfolding L2_defs condition_def
  apply (monad_eq simp: simp_expr_def monad_equiv_def validE_def2 Ball_def split: sum.splits)
  done

lemma monad_equiv_condition_False [L2flow]:
  "\<lbrakk> \<And>s. simp_expr (P s) (C s) False;
     monad_equiv P R R' QR ER \<rbrakk> \<Longrightarrow>
     monad_equiv P (L2_condition C L R) R' QR ER"
  unfolding L2_defs condition_def
  apply (monad_eq simp: simp_expr_def monad_equiv_def validE_def2 Ball_def split: sum.splits)
  done

(* C-parser sometimes generates boolean expressions like
     if P then (if P then 1 else 0) else Q
   This simplifies the branches. *)
lemma monad_equiv_gets_if [L2flow]:
   "\<lbrakk> \<And>s. simp_expr (P s) True (b s) \<rbrakk> \<Longrightarrow>
       monad_equiv P (L2_gets (\<lambda>s. if (b s) then L else R) f)
                     (L2_gets (\<lambda>s. L) f) (%r s. P s) (\<lambda>r s. False)"
   "\<lbrakk> \<And>s. simp_expr (P s) False (b s) \<rbrakk> \<Longrightarrow>
       monad_equiv P (L2_gets (\<lambda>s. if (b s) then L else R) f)
                     (L2_gets (\<lambda>s. R) f) (%r s. P s) (\<lambda>r s. False)"
  apply (monad_eq simp: L2_defs simp_expr_def monad_equiv_def
         validE_def valid_def split: sum.splits)+
  done

lemma monad_equiv_seq [L2flow]:
  "\<lbrakk> monad_equiv P A A' Q E;
     \<And>x. monad_equiv (Q x) (B x) (B' x) (R x) (E2 x) \<rbrakk> \<Longrightarrow>
   monad_equiv P (L2_seq A (\<lambda>x. B x)) (L2_seq A' (\<lambda>x. B' x)) (\<lambda>r s. \<exists>r'. R r' r s) (\<lambda>r s. \<exists>s. P s)"
  apply rule
   apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
   apply (rule bindE_apply_cong)
    apply simp
   apply (clarsimp simp: validE_def valid_def)
   apply force
  apply (clarsimp simp: monad_equiv_def L2_defs
               validE_def valid_def in_bindE simp_expr_def split: sum.splits)
  apply (erule allE, erule (1) impE)+
  apply fastforce
  done

lemma monad_equiv_catch [L2flow]:
  "\<lbrakk> monad_equiv P A A' Q E;
    \<And>x. monad_equiv (E x) (B x) (B' x) (Q' x) (E2 x) \<rbrakk> \<Longrightarrow>
   monad_equiv P (L2_catch A (\<lambda>x. B x)) (L2_catch A' (\<lambda>x. B' x)) (\<lambda>r s. \<exists>s. P s) (\<lambda>r s. \<exists>r'. E2 r' r s)"
  apply rule
   apply atomize
   apply (clarsimp simp: simp_expr_def L2_defs monad_equiv_def)
   apply (erule allE, erule impE, assumption)
   apply (clarsimp simp: validE_def2 split: sum.splits)
   apply (erule allE, erule impE, assumption)
   apply (rule monad_state_eqI)
     apply (clarsimp simp: in_handleE')
     apply force
    apply (clarsimp simp: in_handleE')
    apply force
   apply (fastforce simp: snd_handleE')
  apply (clarsimp simp: monad_equiv_def L2_defs
      validE_def valid_def simp_expr_def in_handleE' split: sum.splits)
  apply (erule allE, erule (1) impE)+
  apply fastforce
  done

lemma monad_equiv_cong:
  "\<lbrakk> \<And>s. P s = P' s;
     \<And>s. P s \<Longrightarrow> A s = A' s;
     \<And>s. P s \<Longrightarrow> B s = B' s;
     \<And>s s' r. P s \<Longrightarrow> Q r s' = Q' r s';
     \<And>s s' r. P s \<Longrightarrow> R r s' = R' r s' \<rbrakk> \<Longrightarrow>
   monad_equiv P A B Q R = monad_equiv P' A' B' Q' R'"
  apply atomize
  apply (clarsimp simp: monad_equiv_def validE_def valid_def split: sum.splits)
  apply (rule iffI)
   apply clarsimp
   apply fastforce
  apply clarsimp
  apply fastforce
  done

lemma monad_equiv_while [L2flow]:
  assumes cond_simp: "\<And>s r. simp_expr True (c r s) (c' r s)"
  assumes body_equiv: "\<And>r. monad_equiv (\<lambda>s. (\<exists>s'. P s') \<and> c' r s) (B r) (B' r) (Q r) (E r)"
  assumes init_simp: "\<And>s r. simp_expr True x x'"
  shows "monad_equiv P (L2_while (\<lambda>r s. c r s) B x n) (L2_while (\<lambda>r s. c' r s) B' x' n) (\<lambda>r s. \<not> c' r s \<and> (\<exists>x. P x)) (\<lambda>r s. \<exists>x. E x r s)"
  apply (insert cond_simp [unfolded simp_expr_def] init_simp [unfolded simp_expr_def])
  apply rule
   apply (clarsimp simp: L2_while_def)
   apply (rule whileLoopE_cong [THEN fun_cong, THEN fun_cong])
     apply force
    apply (cut_tac r=r in body_equiv)
    apply (clarsimp simp: monad_equiv_def)
    apply (erule allE, erule impE, auto)[1]
   apply simp
  apply (clarsimp simp: L2_while_def)
  apply (rule validE_whileLoopE [where I="\<lambda>r s. \<exists>s. P s"])
    apply force
   apply (cut_tac r=r in body_equiv)
   apply (clarsimp simp: validE_def valid_def monad_equiv_def split: sum.splits)
   apply blast
  apply simp
  done

lemma monad_equiv_recguard [L2flow]:
  "\<lbrakk> monad_equiv P B B' Q E \<rbrakk> \<Longrightarrow>
    monad_equiv P (L2_recguard a B) (L2_recguard a B') Q E"
  apply rule
   apply (clarsimp simp: L2_recguard_def monad_equiv_def valid_def validE_def
        split: sum.splits condition_splits)
  apply (clarsimp simp: L2_recguard_def monad_equiv_def valid_def validE_def in_fail
       split: sum.splits condition_splits)
  done

lemma monad_equiv_unreachable' [L2flow]:
  "monad_equiv (\<lambda>_. False) L (L2_gets (\<lambda>_. undefined) [''L2Opt_internal_var'']) Q R"
  by (simp add: monad_equiv_def)

(* avoid leaving schematic Q in goal *)
lemma monad_equiv_unreachable [L2flow]:
  "monad_equiv (\<lambda>_. False) L (L2_gets (\<lambda>_. undefined) [''L2Opt_internal_var'']) (\<lambda>_ _. False) R"
  by (rule monad_equiv_unreachable')

lemma monad_equiv_split [L2flow]:
  "\<lbrakk> \<And>a b. monad_equiv (P (a, b)) (X a b) (Y a b) (Q a b) (E a b) \<rbrakk> \<Longrightarrow>
    monad_equiv (P x) (case x of (a, b) \<Rightarrow> X a b) (case x of (a, b) \<Rightarrow> Y a b)
          (case x of (a, b) \<Rightarrow> Q a b) (case x of (a, b) \<Rightarrow> E a b)"
  apply (clarsimp simp: monad_equiv_def validE_def valid_def split_def)
  done

lemma simp_expr_solve_constant: "\<lbrakk> A \<Longrightarrow> B = C \<rbrakk> \<Longrightarrow> simp_expr A B C"
  by (clarsimp simp: simp_expr_def)

lemma monad_equiv_weaken_pre':
  "\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; monad_equiv P L R Q E \<rbrakk> \<Longrightarrow> monad_equiv P' L R Q E"
  by (fastforce simp: monad_equiv_def validE_def valid_def)

lemma monad_equiv_weaken_pre'':
  "\<lbrakk> P' \<equiv> P; monad_equiv P L R Q E \<rbrakk> \<Longrightarrow> monad_equiv P' L R Q E"
  by (fastforce simp: monad_equiv_def validE_def valid_def)

end