theory DerivationsSlim
imports
  HOL_ext
  Hints
  Protocol
  ExecMessage
begin

chapter{* Security Proofs *}

section{* Networked Transition Systems *}

types 's nts = "'s \<times> ('s \<times> execmsg option \<times> 's \<times> execmsg option) set"

section{* Standard Execution Model *}

inductive_set
  dy    :: "'s nts \<Rightarrow> ('s list \<times> execmsg set) set"
  for P :: "'s nts"
where
  init : "([fst P], {}) \<in> dy P"
| proto:
  "\<lbrakk> (tr@[s], M) \<in> dy P;
     Option.set inp \<subseteq> M;
     (s, inp, s', out) \<in> snd P
   \<rbrakk> \<Longrightarrow>
     (tr@[s,s'], M \<union> Option.set out) \<in> dy P"
| infer:
  "\<lbrakk> (tr, M) \<in> dy P;
     m \<in> infer M
   \<rbrakk> \<Longrightarrow>
     (tr, insert m M) \<in> dy P"

section{* Derivations *}

datatype 's node = State "nat \<times> 's" | Msg execmsg

types 's dependencies = "('s node \<times> 's node) set"

types 's derivation = "('s list \<times> 's dependencies)"

fun analz :: "execmsg set \<Rightarrow> 's node set \<Rightarrow> execmsg \<Rightarrow> 's dependencies"
where
  "analz M N (Tup x y) =
    (if (Tup x y \<in> M)
        then {}
        else N \<times> {Msg (Tup x y)} \<union> analz M N x \<union> analz M N y
    )"
| "analz M N (Enc m k) =
    (if (Enc m k \<in> M)
       then {}
       else
         N \<times> {Msg (Enc m k)} \<union>
         (if (inv k \<in> M)
            then analz M {Msg (Enc m k), Msg (inv k)} m
            else {}
         )
    )"
| "analz M N m =
    (if m \<in> M then {} else N \<times> {Msg m})"

definition knows :: "'s dependencies \<Rightarrow> execmsg set"
where "knows D \<equiv> {m. Msg m \<in> Range D}"

inductive_set
  derivs :: "'s nts \<Rightarrow> 's derivation set"
  for P      :: "'s nts"
where
  init: "([fst P], {}) \<in> derivs P"

| proto:
  "\<lbrakk> (tr@[s], D) \<in> derivs P;
     Option.set inp \<subseteq> knows D;
     (s, inp, s', out) \<in> snd P
   \<rbrakk> \<Longrightarrow>
     ( tr@[s,s']
     , D \<union>
       (Msg ` Option.set inp) \<times>  {State (Suc (length tr), s')} \<union>
       UNION (Option.set out) (analz (knows D) {State (Suc (length tr), s')})
     ) \<in> derivs P"

| hash:
  "\<lbrakk> (tr, D) \<in> derivs P;
     m \<in> knows D;
     Hash m \<notin> knows D
   \<rbrakk> \<Longrightarrow>
     (tr, insert (Msg m, Msg (Hash m)) D) \<in> derivs P"

| tuple:
  "\<lbrakk> (tr, D) \<in> derivs P;
     x \<in> knows D;
     y \<in> knows D;
     Tup x y \<notin> knows D
   \<rbrakk> \<Longrightarrow>
     (tr, {Msg x, Msg y} \<times> {Msg (Tup x y)} \<union> D) \<in> derivs P"
| enc:
  "\<lbrakk> (tr, D) \<in> derivs P;
     m \<in> knows D;
     k \<in> knows D;
     Enc m k \<notin> knows D
   \<rbrakk> \<Longrightarrow>
     (tr, {Msg m, Msg k} \<times> {Msg (Enc m k)} \<union> D) \<in> derivs P"

lemma in_analz_imp_Msg2:
 "(x,y) \<in> analz M N m \<Longrightarrow> \<exists> m'. y = Msg m'"
 by (induct m arbitrary: N) (auto split: if_splits)

lemma in_Range_analzE: "
  \<lbrakk> x \<in> Range (analz M N m);
    \<And> m'. x = Msg m' \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by(auto dest!: in_analz_imp_Msg2)

locale derivation =
  fixes P  :: "'s nts"
  and   tr :: "'s list"
  and   D  :: "'s dependencies"
  assumes derivable: "(tr, D) \<in> derivs P"
begin

text{* A local variant of the induction rule of @{term "reachable"}. *}
lemmas derivs_induct = derivs.induct
  [ OF derivable
  , rule_format
  , consumes 0
  , case_names init proto hash tuple encr
  ]

lemma State2_to_trace:
  "(x, State (i, s)) \<in> D \<Longrightarrow> i < length tr"
  "(x, State (i, s)) \<in> D \<Longrightarrow> tr ! i = s"
by (induct rule: derivs_induct)
   (auto simp: nth_append dest: in_analz_imp_Msg2)

lemmas State2_index_in_trace  = State2_to_trace(1)
lemmas State2_state_nth_trace = State2_to_trace(2)

lemma (in -) in_knowsD: "m \<in> knows D \<Longrightarrow> \<exists> x. (x, Msg m) \<in> D"
  by (auto simp: knows_def Range_iff)

lemma (in -) knows_iff: "(m \<in> knows D) = (\<exists> x. (x, Msg m) \<in> D)"
  by (auto simp: knows_def Range_iff)

lemma (in -) analz_Msg1_imp_Msg2:
  "\<lbrakk> (Msg m, y) \<in> analz M N m'; N \<noteq> {} \<rbrakk> \<Longrightarrow>
   m \<in> M \<or> Msg m \<in> N \<or> (\<exists> x. (x, Msg m) \<in> analz M N m')"
proof(induct m' arbitrary: N y)
  case (Tup m1 m2) thus ?case
    apply(clarsimp split: if_splits)
    apply(erule disjE)
    apply(clarsimp)
    apply(erule disjE)
    apply(frule Tup)
    apply(auto)
    apply(frule Tup)
    apply(auto)
    done
next
  case (Enc em ek) thus ?case
    apply(clarsimp split: if_splits)
    apply(erule disjE)
    apply(clarsimp)
    apply(frule Enc(1))
    apply(safe) defer 1
    apply(auto)
    done
qed auto

lemma Msg1_imp_Msg2:
  "(Msg m, y) \<in> D \<Longrightarrow> \<exists> x. (x, Msg m) \<in> D"
proof(induct rule: derivs_induct)
  case (proto tr s D inp s' out) thus ?case
    by (fastsimp dest!: in_knowsD analz_Msg1_imp_Msg2)+
qed (fastsimp dest!: in_knowsD)+

definition derivOrd
where "derivOrd = (D \<union>
                   { (State (i, tr ! i), State (Suc i, tr ! Suc i))
                   | i. Suc i < length tr }
                  )\<^sup>+"

lemma (in - ) irr_insert_tranclD:
  "\<lbrakk> (x,x) \<in> (insert (a,b) R)\<^sup>+; (b,a) \<notin> R\<^sup>+; (x,x) \<notin> R\<^sup>+ \<rbrakk> \<Longrightarrow> a = b"
  apply(clarsimp simp: trancl_insert)
  apply(subgoal_tac "(b,a) \<in>  R\<^sup>*")
  apply(simp add: rtrancl_eq_or_trancl)
  apply(fastsimp intro: rtrancl_trans)
  done

lemma (in -) in_trancl_into_r1: "(x,y) \<in> R\<^sup>+ \<Longrightarrow> \<exists> z. (x,z) \<in> R"
  by(drule DomainI, simp add: Domain_iff)

lemma derivOrd_irr:
  "(x, x) \<notin> derivOrd"
unfolding derivOrd_def
proof(induct rule: derivs_induct)
  case init thus ?case by simp
next
  case (hash tr D m)
  then interpret this_deriv: derivation P tr D by unfold_locales
  from hash show ?case
    apply(clarsimp)
    apply(drule irr_insert_tranclD)
    apply(auto dest!: in_trancl_into_r1 this_deriv.Msg1_imp_Msg2
                simp: knows_iff)
    done
next
  case (tuple tr D mx my)
  then interpret this_deriv: derivation P tr D by unfold_locales
  from tuple show ?case
    apply(clarsimp)
    apply(drule irr_insert_tranclD)
    apply(simp_all)
    apply(fastsimp dest!: in_trancl_into_r1 this_deriv.Msg1_imp_Msg2
                simp: knows_iff)
    apply(clarsimp)
    apply(drule irr_insert_tranclD)
    apply(simp_all)
    apply(fastsimp dest!: in_trancl_into_r1 this_deriv.Msg1_imp_Msg2
                simp: knows_iff)
    done
next
  case (encr tr D m k)
  then interpret this_deriv: derivation P tr D by unfold_locales
  from encr show ?case
    apply(clarsimp)
    apply(drule irr_insert_tranclD)
    apply(simp_all)
    apply(fastsimp dest!: in_trancl_into_r1 this_deriv.Msg1_imp_Msg2
                simp: knows_iff)
    apply(clarsimp)
    apply(drule irr_insert_tranclD)
    apply(simp_all)
    apply(fastsimp dest!: in_trancl_into_r1 this_deriv.Msg1_imp_Msg2
                simp: knows_iff)
    done
next
  case (proto tr s D inp s' out) thus ?case
    apply(clarsimp)
    apply(case_tac inp)
    apply(simp)
    apply(case_tac out)
    apply(simp)
    (* proceed by arguing about the individual inserts and that
       none is introducing a cycle.
    *)
    sorry
qed

lemma derivOrd_trans:
  "\<lbrakk> (x,y) \<in> derivOrd; (y,z) \<in> derivOrd \<rbrakk> \<Longrightarrow> (x,z) \<in> derivOrd"
  unfolding derivOrd_def by (auto intro!: trancl_trans)

lemma derivOrd_asymD:
  "(x,y) \<in> derivOrd \<Longrightarrow> (y,x) \<notin> derivOrd"
  by(auto dest: derivOrd_trans simp: derivOrd_irr)

lemma (in -) finite_analz [intro!]:
  "finite N \<Longrightarrow> finite (analz M N m)"
  by (induct m arbitrary: N) auto

(* MISSING in Isabelle library *)
lemma (in -) Option_finite_set [iff]:
  "finite (Option.set x)"
  by (cases x) (auto)

lemma finite_D:
  "finite D"
  by (induct rule: derivs_induct) auto

lemma derivOrd_finite:
  "finite derivOrd"
proof -
  have "{i. Suc i < length tr} \<subseteq> {i. i < length tr}" by clarsimp
  hence "finite {i. Suc i < length tr}"
    by (auto dest!: finite_subset intro!: finite_Collect_less_nat)
  thus ?thesis using finite_D unfolding derivOrd_def
    by (auto simp: finite_trancl)
qed

lemma derivOrd_trancl [simp]:
  "derivOrd\<^sup>+ = derivOrd"
  unfolding derivOrd_def by auto

lemma derivOrd_wf: "wf derivOrd"
  by (auto intro!: finite_acyclic_wf derivOrd_finite acyclicI
             simp: derivOrd_irr)

end

section{* Relating the two models *}

lemma dy_conv_derivs:
  "{ (tr, M)       | tr M M'. M \<subseteq> M' \<and> (tr, M) \<in> dy P     } =
   { (tr, knows D) | tr D.             (tr, D) \<in> derivs P }"
  oops

(* MOVE *)
lemma acyclic_empty [iff]: "acyclic {}"
  by (simp add: acyclic_def)

lemma knows_empty [iff]: "knows {} = {}"
  by (auto simp: knows_def)

(*
lemma in_derivsE [elim!]:
  "\<lbrakk> (tr, D) \<in> derivs P;
     \<And> M D'. \<lbrakk> (tr, D') \<in> derivs P;
                D = D' - (Msg ` M) \<times> UNIV - UNIV \<times> (Msg ` M);
                sound (tr, D)
              \<rbrakk> \<Longrightarrow> Q
   \<rbrakk> \<Longrightarrow> Q"
  by(auto simp: derivs_def)

lemma knows_cases: "\<lbrakk> (tr, D) \<in> derivs P; m \<in> knows D \<rbrakk> \<Longrightarrow> R"
  apply(clarsimp)
  apply(drule derivs.cases)
  apply(simp_all)
  oops
*)

lemma knows_union [simp]: "knows (M \<union> N) = knows M \<union> knows N"
  by (auto simp: knows_def)

lemma knows_insert_Msg [simp]: "knows (insert (x, Msg m) D) = insert m (knows D)"
  by(auto simp: knows_def)

lemma knows_insert_State [simp]: "knows (insert (x, State s) D) = knows D"
  by(auto simp: knows_def)

lemma in_knows_times: "M \<noteq> {} \<Longrightarrow> (m \<in> knows (M \<times> N)) = (Msg m \<in> N)"
  by (auto simp: knows_iff)

lemma knows_analz: "\<lbrakk> m \<notin> M; N \<noteq> {} \<rbrakk> \<Longrightarrow> m \<in> knows (analz M N m)"
  by (induct m arbitrary: N) (auto simp: knows_iff)

lemma analz_antimono: "M \<subseteq> M' \<Longrightarrow> analz M' N m \<subseteq> analz M N m"
  apply(safe)
  apply(induct m arbitrary: N)
  apply(auto split: if_splits)
  oops (* not true as check for inverse keys runs on the same set *)

lemma (in derivation) knows_analz_closed:
  "\<lbrakk> m \<in> knows D; x \<in> knows (analz (knows D) N m) \<rbrakk> \<Longrightarrow> x \<in> knows D"
proof(induct rule: derivs_induct)
  case init thus ?case by simp
next
  case (hash tr D m') thus ?case
    apply(auto)
    oops (* not true as new keys could be added *)

lemma (in derivation) knows_pairParts_closed:
  "\<lbrakk> m \<in> knows D; x \<in> pairParts m \<rbrakk> \<Longrightarrow> x \<in> knows D"
proof(induct rule: derivs_induct)
  case tuple thus ?case sorry
next
  case proto thus ?case sorry
qed auto

lemma (in derivation)
  assumes m: "m \<in> infer M"
  and     M: "M \<subseteq> knows D"
  shows "\<exists>D'. (tr, D \<union> D') \<in> derivs P \<and> m \<in> knows (D \<union> D') \<and>
              (\<forall> x \<in> M. m \<notin> knows D')"
  (is "\<exists>D'. ?extension D D' m")
using m M derivable
proof(induct arbitrary: D rule: infer.induct)
  case (Inj m D)
  hence "?extension D {} m" by auto
  thus ?case by fast
next
  case (Fst x y D) then
  obtain D' where ext: "?extension D D' \<lbrace>x, y\<rbrace>" by fastsimp
  then interpret ext_deriv: derivation P tr "D \<union> D'"
    by unfold_locales auto
  from ext have "?extension D D' x"
    apply -
    apply(rule conjI, simp)
    apply(rule conjI)
    apply(rule ext_deriv.knows_pairParts_closed)
    apply(force)
    apply(simp)
    apply(erule conjE)+

    oops

  (* DEEP Problems with the current explicit model:

       1. Analyzing a message further with keys learned later is not
          possible \<Rightarrow> attacks are missed.

       2. Adding a separate analyze step helps but destroys the property
          that the inversion rules of the inductive set correspond directly
          to the decryption chain rule.

       3. The approach with late checking of soundness requires us to build
          a labeled graph where messages can be learned multiple times.
          Otherwise, we cannot decide later how to learn a message concretely.

     \<Longrightarrow> A small step model as we had it is probably better
  *)

next
  case (Tup x y) thus ?case
    apply(clarsimp)
    apply(rule exI, rule conjI)
    apply(rule derivs.tuple[of tr D _ x y], assumption+)
    oops

lemma dy_imp_derivs:
  "(tr, M) \<in> dy P \<Longrightarrow>
   \<exists> D. (tr, D) \<in> derivs P \<and> M \<subseteq> knows D
  "
proof(induct rule: dy.induct)
  case init thus ?case by(auto intro!: derivs.init)
next
  case (proto tr s M inp s' out) thus ?case
    apply(clarsimp)
    apply(rule exI, rule conjI)
    apply(rule_tac inp=inp in derivs.proto)
    apply(auto intro!: knows_analz)
    done
next
  case (infer tr M m)
  then obtain D where the_deriv: "(tr, D) \<in> derivs P" "M \<subseteq> knows D"
    by auto
  have " \<lbrakk> m \<in> infer M; M \<subseteq> knows D; (tr, D) \<in> derivs P \<rbrakk> \<Longrightarrow>
         \<exists>D'. (tr, D' \<union> D) \<in> derivs P \<and> m \<in> knows (D \<union> D') \<and>
              (\<forall> x \<in> M. m \<notin> knows D')"
  proof(induct arbitrary: D rule: infer.induct)
    case Inj thus ?case
      apply -
      apply(rule_tac x="{}" in exI)
      apply(auto)
      done
  next
    case (Tup x y) thus ?case
      apply(clarsimp)
      apply(rule exI, rule conjI)
      apply(rule derivs.tuple[of tr D _ x y], assumption+)
      oops

section{* Properties of the derivations *}

fun add_index :: "nat \<Rightarrow> 'a list \<Rightarrow> (nat \<times> 'a) list"
where
  "add_index i []     = []"
| "add_index i (x#xs) = (i,x) # add_index (Suc i) xs"

definition deps :: "'s derivation \<Rightarrow> 's dependencies"
where "deps dr \<equiv> case dr of (tr, D) \<Rightarrow>
         D \<union> { (x,y) | x y. listOrd (add_index 0 tr) (State x) (State y)}"

section{* Executing Protocol Scripts *}

types threadpool = "tid \<rightharpoonup> (rolestep list \<times> rolestep list)"

types state = "threadpool \<times> store"

definition proto2nts :: "proto \<Rightarrow> state option nts"
where "proto2nts P =
  ( None
  , ({ ( None, None, Some (th, st), None)
     | th st.
       (\<forall> i done todo. th i = Some (done,todo) \<longrightarrow>
                                done = [] \<and> todo \<in> P) \<and>
       (\<forall> a i. st (AVar a, i) \<in> Compromised \<union> Uncompromised)
     }
     \<union>
     { (s, None, s, Some m)
     | s m.
       m \<in> IK0
     }
     \<union>
     (\<Union> R \<in> P.
       { ( Some (th, st)
         , Some (inst st i pt)
         , Some (th(i\<mapsto> (done @ [Recv l pt], todo)), st)
         , None
         )
       | th st i l pt done todo.
         th i = Some (done, Recv l pt # todo)
       }
     )
     \<union>
     (\<Union> R \<in> P.
       { ( Some (th, st)
         , None
         , Some (th(i\<mapsto> (done @ [Send l pt], todo)), st)
         , Some (inst st i pt)
         )
       | th st i l pt done todo.
         th i = Some (done, Send l pt # todo)
       }
     )
    )
  )
"

(* OOOOOOOOOOOOOOOOOOOOLDDDDDDDDDDDDDDDDDDDDDDDD *)

term "undefined"
thm the_def
thm
thm undefined_def

types explicit_trace = "rawevent list"
types execstep = "tid \<times> rolestep"

fun knows :: "explicit_trace \<Rightarrow> execmsg set"
where
  "knows [] = {}"
| "knows (Learns M # t) = M \<union> knows t"
| "knows (Step estep # t) = knows t"

fun steps :: "explicit_trace \<Rightarrow> execstep set"
where
  "steps [] = {}"
| "steps (Learns M # t) = steps t"
| "steps (Step estep # t) = insert estep (steps t)"

types state = "explicit_trace \<times> threadpool \<times> store"

inductive_set
  reachable :: "proto \<Rightarrow> state set"
  for P     :: "proto"
where
  init:  "\<lbrakk> \<forall> i done todo. r i = Some (done,todo) \<longrightarrow>
                             done = [] \<and> todo \<in> P;
            \<forall> a i. s (AVar a, i) \<in> Compromised \<union> Uncompromised
          \<rbrakk>
          \<Longrightarrow> ([Learns IK0], r, s) \<in> reachable P"

| send:  "\<lbrakk> (t, r, s) \<in> reachable P;
            r i = Some (done, Send l pt # todo);
            m = inst s i pt
          \<rbrakk>
          \<Longrightarrow> (t @ [Step (i, Send l pt),
                    Learns (pairParts m - knows t)]
              , r(i \<mapsto> (done @ [Send l pt], todo))
              , s) \<in> reachable P"

| recv:  "\<lbrakk> (t, r, s) \<in> reachable P;
            r i = Some (done, Recv l pt # todo);
            inst s i pt \<in> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Step (i, Recv l pt)]
              , r(i \<mapsto> (done @ [Recv l pt], todo))
              , s) \<in> reachable P"

| hash:  "\<lbrakk> (t, r, s) \<in> reachable P;
            m \<in> knows t;
            Hash m \<notin> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Learns {Hash m}], r, s) \<in> reachable P"

| tuple: "\<lbrakk> (t, r, s) \<in> reachable P;
            x \<in> knows t;
            y \<in> knows t;
            Tup x y \<notin> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Learns {Tup x y}], r, s) \<in> reachable P"

| encr:  "\<lbrakk> (t, r, s) \<in> reachable P;
            m \<in> knows t;
            k \<in> knows t;
            Enc m k \<notin> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Learns {Enc m k}], r, s) \<in> reachable P"

| decr:  "\<lbrakk> (t, r, s) \<in> reachable P;
            Enc m k \<in> knows t;
            inv k \<in> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Learns (pairParts m - knows t)], r, s) \<in> reachable P"

locale reachable_state =  wf_proto +
  fixes t :: explicit_trace
  and   r :: threadpool
  and   s :: store
  assumes reachable [simp,intro!]: "(t,r,s) \<in> reachable P"
begin
  text{* A local variant of the induction rule of @{term "reachable"}. *}
  lemmas reachable_induct = reachable.induct
    [ OF reachable
    , rule_format
    , consumes 0
    , case_names init send recv hash tuple encr decr
    ]
end

text{* An extension of the reachable state locale denoting
       an individual thread and its state. *}

locale reachable_thread = reachable_state +
  fixes i      :: "tid"
    and "done" :: "rolestep list"
    and todo   :: "rolestep list"
  assumes thread_exists: "r i = Some (done, todo)"
begin

  text{* The thread state is built such that @{term "done @ todo"} is
         always a role of @{term P}. *}

  lemma role_in_P:
    "done @ todo \<in> P"
  using thread_exists
  proof (induct arbitrary: i "done" todo rule: reachable_induct)
  qed (fastsimp split: if_splits)+

end

text{* Importing all lemmas of the wellformed role locale for
the term @{term "done @ todo"}. *}
sublocale reachable_thread \<subseteq> wf_role "done @ todo"
  by (rule wf_roles[OF role_in_P])

subsection{* Basic Properties *}

lemma knowsI: "\<lbrakk> Learns M \<in> set t; m \<in> M \<rbrakk> \<Longrightarrow> m \<in> knows t"
  by(induct t rule: knows.induct, auto)

lemma knowsD: "m \<in> knows t \<Longrightarrow> \<exists> M. Learns M \<in> set t \<and> m \<in> M"
  by(induct t rule: steps.induct, auto)

lemma knows_append [simp]:
  "knows (xs@ys) = knows xs \<union> knows ys"
  by(induct xs rule: knows.induct, auto)

lemma stepsI: "Step estep \<in> set t \<Longrightarrow> estep \<in> steps t"
  by(induct t rule: steps.induct, auto)

lemma stepsD: "estep \<in> steps t \<Longrightarrow> Step estep \<in> set t"
  by(induct t rule: steps.induct, auto)

lemma Step_in_set_conv [simp]:
  "(Step estep \<in> set t) = (estep \<in> steps t)"
  by(auto intro!: stepsI stepsD)

lemma steps_append [simp]:
  "steps (t@t') = steps t \<union> steps t'"
  by(induct t rule: steps.induct, auto)

subsection{* Thread Execution *}

lemma (in reachable_state) step_in_dom:
  "(i, step) \<in> steps t \<Longrightarrow> i \<in> dom r"
proof (induct rule: reachable_induct) qed auto

context reachable_thread
begin

lemma in_dom_r [iff]: "i \<in> dom r"
  by (auto intro!: thread_exists)

lemma distinct_done [iff]: "distinct done"
using distinct by auto

lemma distinct_todo [iff]: "distinct todo"
using distinct by auto

lemma in_steps_eq_in_done:
  "((i, step) \<in> steps t) = (step \<in> set done)"
proof -
  have
    "((i, step) \<in> steps t) =
    (\<exists> done todo. r i = Some (done, todo) \<and> step \<in> set done)"
  proof(induct arbitrary: i "done" todo rule: reachable_induct)
    case (init r s i) thus ?case by fastsimp
  qed auto
  thus ?thesis using thread_exists by auto
qed

lemmas steps_in_done [elim!] = iffD1[OF in_steps_eq_in_done, rule_format]
lemmas done_in_steps [elim!] = iffD2[OF in_steps_eq_in_done, rule_format]

lemma todo_notin_stepsD:
  "step \<in> set todo \<Longrightarrow> (i, step) \<notin> steps t"
using distinct by(auto dest!: steps_in_done)

lemmas todo_notin_stepsE = notE[OF todo_notin_stepsD, rule_format]

lemma listOrd_done_imp_listOrd_trace:
  "listOrd done prev step \<Longrightarrow>
   listOrd t (Step (i, prev)) (Step (i, step))"
using thread_exists
proof(induct arbitrary: i "done" todo rule: reachable_induct)
  case (init r s i "done" todo) thus ?case
    by fastsimp
next
  case (send t r s i "done" l msg todo m i' done' todo')
  then interpret this_thread:
    reachable_thread P t r s i "done" "Send l msg # todo"
    by unfold_locales auto
  from send show ?case
    by(auto split: if_splits)
next
  case (recv t r s i "done" l msg todo i' done' todo')
  then interpret this_thread:
    reachable_thread P t r s i "done" "Recv l msg # todo"
    by unfold_locales auto
  from recv show ?case
    by(auto split: if_splits)
qed auto

lemma listOrd_role_imp_listOrd_trace:
  "\<lbrakk> (i, step) \<in> steps t; listOrd (done @ todo) prev step \<rbrakk>
  \<Longrightarrow> listOrd t (Step (i, prev)) (Step (i, step))"
using distinct
by (fastsimp dest: in_set_listOrd2 listOrd_done_imp_listOrd_trace)

end

subsection{* Variable Substitutions *}

context reachable_state
begin

lemma inst_AVar_cases:
  "s (AVar v, i) \<in> Uncompromised \<or> s (AVar v, i) \<in> Compromised"
  by (induct rule: reachable_induct) (fastsimp+)

lemma inst_AVar_in_IK0:
 "s (AVar v, i) \<in> IK0"
using inst_AVar_cases[of v i]
by (auto simp: IK0_def Uncompromised_def Compromised_def)

lemma knows_IK0: "m \<in> IK0 \<Longrightarrow> m \<in> knows t"
  by(induct rule: reachable_induct, auto)

lemma inst_AVar_in_knows [iff]:
  "s (AVar a, i) \<in> knows t"
  by (rule knows_IK0[OF inst_AVar_in_IK0])

end (* reachable_state *)

(* TODO: Move *)
lemma MVar_in_FV_conv_FMV [iff]:
  "(MVar v \<in> FV pt) = (v \<in> FMV pt)"
  by(induct pt, auto, case_tac varid, auto)

context reachable_state
begin

lemma send_step_FV:
  assumes thread_exists: "r i = Some (done, Send l msg # todo)"
  and FV: "MVar n \<in> FV msg"
  shows "\<exists> l' msg'. (i, Recv l' msg') \<in> steps t \<and>  MVar n \<in> FV msg'"
proof -
  interpret this_thread: reachable_thread P t r s i "done" "Send l msg # todo"
    using thread_exists by unfold_locales auto
  let ?role = "done @ Send l msg # todo"
  have "Send l msg \<in> set ?role" by simp
  then obtain l' msg'
    where "listOrd ?role (Recv l' msg') (Send l msg)"
    and "MVar n \<in> FV msg'"
    using FV by(fast dest!: this_thread.Send_FV)
  thus ?thesis using this_thread.distinct
    by(auto dest: in_set_listOrd1 in_set_listOrd2)
qed

end

subsubsection{* The Effect of a Step on the Intruder Knowledge *}

context reachable_state
begin

lemma SendD:
  "(i, Send lbl pt) \<in> steps t \<Longrightarrow>
   inst s i pt \<in> knows t"
proof(induct rule: reachable_induct)
qed auto

end

subsection{* Almost Distinct Traces *}

fun distinct' :: "explicit_trace \<Rightarrow> bool"
where
  "distinct' [] = True"
| "distinct' (Learns M # t) =
     ((\<forall> m \<in> M. m \<notin> knows t) \<and> distinct' t)"
| "distinct' (Step estep # t) =
     ((estep \<notin> steps t) \<and> distinct' t)"

lemma distinct'_append [simp]:
  "distinct' (t@t') =
   (distinct' t \<and> distinct' t' \<and>
    (knows t \<inter> knows t' = {}) \<and> (steps t \<inter> steps t' = {}))"
proof (induct t rule: distinct'.induct)
qed (auto intro!: knowsI)

lemma distinct'_singleton [iff]: "distinct' [x]"
by (cases x) auto

lemma (in reachable_state) distinct'_trace [iff]:
  "distinct' t"
proof(induct rule: reachable_induct)
  case (recv t r s i "done" l msg todo)
  then interpret this_thread:
    reachable_thread P t r s i "done" "Recv l msg # todo"
    by unfold_locales auto
  show ?case using `distinct' t` and this_thread.distinct
    by(auto dest!: this_thread.steps_in_done)
next
  case (send t r s i "done" l msg todo m)
  then interpret this_thread:
    reachable_thread P t r s i "done" "Send l msg # todo"
    by unfold_locales auto
  show ?case using `distinct' t` and this_thread.distinct
    by(auto dest!: this_thread.steps_in_done)
qed auto

subsection{* Happens-Before Order *}

datatype event = St "tid \<times> rolestep" | Ln execmsg

fun predOrd :: "explicit_trace \<Rightarrow> event \<Rightarrow> event \<Rightarrow> bool"
where
  "predOrd []             x y = False"
| "predOrd (Learns M # xs) x y =
     ((x \<in> Ln ` M \<and> (y \<in> Ln ` knows xs \<or> y \<in> St ` steps xs)) \<or>
      predOrd xs x y)"
| "predOrd (Step estep # xs) x y =
     ((x = St estep \<and> (y \<in> Ln ` knows xs \<or> y \<in> St ` steps xs)) \<or>
      predOrd xs x y)"

definition predEqOrd :: "explicit_trace \<Rightarrow> event \<Rightarrow> event \<Rightarrow> bool"
where "predEqOrd t x y = ((x = y) \<or> predOrd t x y)"

lemma predOrd_singleton [simp]: "\<not> predOrd [a] x y"
by (cases a) auto

lemma in_knows_predOrd1: "predOrd t (Ln x) y \<Longrightarrow> x \<in> knows t"
proof (induct t)
  case (Cons e t) thus ?case by (cases e) auto
qed auto

lemma in_knows_predOrd2: "predOrd t x (Ln y) \<Longrightarrow> y \<in> knows t"
proof (induct t)
  case (Cons e t) thus ?case by (cases e) auto
qed auto

lemma in_steps_predOrd1: "predOrd t (St x) y \<Longrightarrow> x \<in> steps t"
proof (induct t)
  case (Cons e t) thus ?case by (cases e) auto
qed auto

lemma in_steps_predOrd2: "predOrd t x (St y) \<Longrightarrow> y \<in> steps t"
proof (induct t)
  case (Cons e t) thus ?case by (cases e) auto
qed auto

lemmas event_predOrdI =
  in_knows_predOrd1 in_knows_predOrd2
  in_steps_predOrd1 in_steps_predOrd2

lemma in_set_predOrd1:
  "predOrd t x y \<Longrightarrow> x \<in> Ln ` knows t \<or> x \<in> St ` steps t"
by (induct t x y rule: predOrd.induct) auto

lemma in_set_predOrd2:
  "predOrd t x y \<Longrightarrow> y \<in> Ln ` knows t \<or> y \<in> St ` steps t"
by (induct t x y rule: predOrd.induct) auto

lemma listOrd_imp_predOrd:
  "listOrd t (Step e) (Step e') \<Longrightarrow> predOrd t (St e) (St e')"
by (induct t rule: steps.induct) (auto dest!: stepsI)

lemma predOrd_append [simp]:
  "predOrd (xs@ys) x y =
   (predOrd xs x y \<or> predOrd ys x y \<or>
   ((x \<in> Ln ` knows xs \<or> x \<in> St ` steps xs) \<and>
    (y \<in> Ln ` knows ys \<or> y \<in> St ` steps ys)))"
  apply(induct xs x y rule: predOrd.induct)
  apply(simp_all)
  apply(blast+)
  done

lemma predOrd_distinct'_irr [simp]:
  "distinct' t \<Longrightarrow> \<not>predOrd t x x"
  apply(induct t, auto)
  apply(case_tac x, auto)
  apply(case_tac a, auto)
  apply(case_tac a, auto)
  done

lemma predOrd_distinct'_trans:
  "\<lbrakk> predOrd t x y; predOrd t y z; distinct' t \<rbrakk>
   \<Longrightarrow> predOrd t x z"
  apply(induct t x y rule: predOrd.induct)
  apply(auto dest: in_set_predOrd1 in_set_predOrd2)
  done

lemma predOrd_distinct'_asymD:
  "\<lbrakk> predOrd t x y; distinct' t \<rbrakk> \<Longrightarrow> \<not> predOrd t y x"
  apply(induct t x y rule: predOrd.induct)
  apply(auto dest: in_set_predOrd1 in_set_predOrd2)
  done

sublocale reachable_state \<subseteq> beforeOrd: order "predEqOrd t" "predOrd t"
  apply(unfold_locales)
  apply(auto simp: predEqOrd_def
          dest: predOrd_distinct'_asymD
         intro: predOrd_distinct'_trans)
  done

abbreviation (in reachable_state)
  "pred'"   (infixl "\<prec>" 50) where "pred' \<equiv> predOrd t"

abbreviation (in reachable_state)
  "predEq'" (infixl "\<preceq>" 50) where "predEq' \<equiv>  predEqOrd t"

lemma predOrd_conv:
  "predOrd xs x y =
  (\<exists> ys zs. xs = ys @ zs \<and>
            (x \<in> Ln ` knows ys \<or> x \<in> St ` steps ys) \<and>
            (y \<in> Ln ` knows zs \<or> y \<in> St ` steps zs))"
  (is "?pred xs = (\<exists> ys zs. ?decomp xs ys zs)")
proof -
  { assume "?pred xs"
    hence "\<exists> ys zs. ?decomp xs ys zs"
    proof (induct xs)
      case Nil thus ?case by simp
    next
      case (Cons e xs) thus ?case
      proof(cases e)
	case (Step st) thus ?thesis
	proof(cases "x = St st")
	  case True hence "?decomp (e#xs) [e] xs"
	    using Step Cons by auto
	  thus ?thesis by blast
	next
	  case False
	  hence "predOrd xs x y"
	    using Step Cons by auto
	  then obtain ys zs where "?decomp xs ys zs"
	    using Cons by auto
	  hence "?decomp (e#xs) (e#ys) zs"
	    using Step Cons by auto
	  thus ?thesis by blast
	qed
      next
	case (Learns M) thus ?thesis
	proof(cases "\<exists> m \<in> M. x = Ln m")
	  case True
	  then obtain m where "m \<in> M" and "x = Ln m"
	    by auto
	  hence "?decomp (e#xs) [e] xs"
	    using Learns Cons by auto
	  thus ?thesis by blast
	next
	  case False
	  hence "predOrd xs x y"
	    using Learns Cons by auto
	  then obtain ys zs where "?decomp xs ys zs"
	    using Cons by auto
	  hence "?decomp (e#xs) (e#ys) zs"
	    using Learns Cons by auto
	  thus ?thesis by blast
	qed
      qed
    qed
  }
  moreover
  { assume "\<exists> ys zs. ?decomp xs ys zs"
    hence "?pred xs"
    proof (induct xs)
      case Nil thus ?case by simp
    next
      case (Cons e xs)
      then obtain ys zs where decomp1: "?decomp (e#xs) ys zs"
	by blast
      hence "ys = [] \<and> e # xs = zs \<or> (\<exists>ys'. e # ys' = ys \<and> xs = ys' @ zs)"
	(is "?nil \<or> ?non_nil")
	by (simp add: Cons_eq_append_conv)
      moreover
      { assume ?nil hence ?case using decomp1 by auto }
      moreover
      { assume ?non_nil
	then obtain ys' where decomp2: "ys = e # ys'" and "xs = ys' @ zs"
	  by auto
	hence ?case
	proof(cases e)
	  case (Step st) thus ?thesis
	  proof(cases "x = St st")
	    case True thus ?thesis
	      using Step decomp1 decomp2 by auto
	  next
	    case False
	    hence "?decomp xs ys' zs"
	      using Step decomp1 decomp2 by auto
	    hence "predOrd xs x y"
	      using Cons by auto
	    thus ?thesis
	      using Step by auto
	  qed
	next
	  case (Learns M) thus ?thesis
	  proof(cases "\<exists> m \<in> M. x = Ln m")
	    case True thus ?thesis
	      using Learns decomp1 decomp2 by auto
	  next
	    case False
	    hence "?decomp xs ys' zs"
	      using Learns decomp1 decomp2 by auto
	    hence "predOrd xs x y"
	      using Cons by auto
	    thus ?thesis
	      using Learns by auto
	  qed
	qed
      }
      ultimately show ?case by fast
    qed
  }
  ultimately show ?thesis by fast
qed

subsection{* Input Terms *}

context reachable_state
begin

lemma knows_pairParts_closed:
  "m \<in> knows t \<Longrightarrow> pairParts m \<subseteq> knows t"
proof(induct arbitrary: m rule: reachable_induct)
  case init thus ?case by(auto simp: IK0_def)
next
  case send thus ?case by(auto dest: pairParts_idemD)
next
  case decr thus ?case by(auto dest: pairParts_idemD)
next
  case tuple thus ?case by fastsimp
qed auto

lemmas knows_pairParts_closedD =
  subsetD[OF knows_pairParts_closed, rule_format]

lemmas rev_knows_pairParts_closedD =
  rev_subsetD[OF _ knows_pairParts_closed, rule_format]

lemma pairParts_before:
  "\<lbrakk> predOrd t (Ln m) y; m' \<in> pairParts m \<rbrakk> \<Longrightarrow>
   predOrd t (Ln m') y"
proof(induct rule: reachable_induct)
  case (hash t r s msg)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from hash show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (encr t r s msg key)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from encr show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (tuple t r s msg1 msg2)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from tuple show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (decr t r s msg key)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from decr show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (send t r s i "done" l msg todo msg)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from send show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (recv t r s i "done" l msg todo)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from recv show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (init r s) thus ?case by simp
qed

lemma Ln_before_inp:
  "(i, Recv l pt) \<in> steps t \<Longrightarrow>
   Ln (inst s i pt) \<prec> St (i, Recv l pt)"
proof(induct arbitrary: i l pt rule: reachable_induct)
qed auto

lemmas knows_inp = in_knows_predOrd1[OF Ln_before_inp, rule_format]

text{* Three of the lemmas for the reasoning technique. *}
lemmas Input = Ln_before_inp

lemma split_before:
  "Ln (Tup m m') \<prec> y \<Longrightarrow> Ln m \<prec> y \<and> Ln m' \<prec> y"
  by (fastsimp intro: pairParts_before)

lemma split_knows:
  "Tup m m' \<in> knows t \<Longrightarrow> m \<in> knows t \<and> m' \<in> knows t"
  by (fastsimp intro: knows_pairParts_closedD)

end

subsection{* Case Distinction on Learning Messages *}

text{* Note that the hints are logically equal to true. Thus they have no logical
  content. However they are placed here to track the individual cases when
  computing the decryption chains for a concrete message and protocol.
*}
fun decrChain :: "string \<Rightarrow> explicit_trace \<Rightarrow> event set \<Rightarrow> execmsg \<Rightarrow> execmsg \<Rightarrow> bool"
where
  "decrChain path t from (Enc msg key) m =
   ( ( m = Enc msg key \<and> (\<forall> f \<in> from. predOrd t f (Ln m)) \<and>
       hint ''decrChainPath'' path
     ) \<or>
     ( (\<forall> f \<in> from. predOrd t f (Ln (Enc msg key))) \<and>
       decrChain (path@''E'') t {Ln (Enc msg key), Ln (inv key)} msg m  )
   )"
| "decrChain path t from (Tup x y) m =
   ( ( m = Tup x y \<and> (\<forall> f \<in> from. predOrd t f (Ln m)) \<and>
       hint ''decrChainPath'' path
     ) \<or>
     decrChain (path@''L'') t from x m \<or>
     decrChain (path@''R'') t from y m
   )"
| "decrChain path t from msg m =
   ( m = msg \<and> (\<forall> f \<in> from. predOrd t f (Ln m)) \<and>
     hint ''decrChainPath'' path
   )"

lemma decrChain_append:
  "decrChain path t from msg m \<Longrightarrow> decrChain path (t@t') from msg m"
  by (induct path t "from" msg m rule: decrChain.induct) auto

lemma decrChain_unpair:
  "\<lbrakk> m' \<in> pairParts m; m' \<in> M;
     \<forall> f \<in> from. f \<in> Ln ` knows t \<or> f \<in> St ` steps t
   \<rbrakk> \<Longrightarrow> decrChain path (t@[Learns M]) from m m'"
by (induct m arbitrary: path M) (auto simp: remove_hints)

lemma decrChain_decrypt:
  "\<lbrakk> decrChain path t from msg (Enc m k);
     Enc m k \<in> knows t; inv k \<in> knows t;
     m' \<in> pairParts m; m' \<notin> knows t \<rbrakk> \<Longrightarrow>
   decrChain path' (t @ [Learns (pairParts m - knows t)]) from msg m'"
proof(induct msg arbitrary: path path' "from")
  case (Enc msg key)
  hence from_before [simp]:
    "\<forall>f\<in>from. predOrd t f (Ln (Enc msg key))" by auto
  have "m = msg \<and> k = key \<or>
    decrChain (path@''E'') t {Ln (Enc msg key), Ln (Message.inv key)} msg (Enc m k)"
    (is "?here \<or> ?nested")
    using Enc by auto
  moreover
  { assume "?here"
    hence "?case"
    proof(cases "m' = Enc m k")
      case True thus ?thesis
	using `?here` Enc by fastsimp
    next
      case False thus ?thesis
	using `?here` Enc
	by(auto intro!: decrChain_unpair)
    qed
  }
  moreover
  { assume "?nested"
    hence "?case" using Enc
      by (fastsimp dest!: Enc(2))
  }
  ultimately show ?case by fast
qed auto

lemma (in reachable_state) knows_cases_raw:
  assumes knows: "m' \<in> knows t"
  shows
   "(m' \<in> IK0) \<or>
    (\<exists> m.   m' = Hash m   \<and> Ln m \<prec> Ln (Hash m)) \<or>
    (\<exists> m k. m' = Enc  m k \<and> Ln m \<prec> Ln (Enc m k) \<and> Ln k \<prec> Ln (Enc m k)) \<or>
    (\<exists> x y. m' = Tup  x y \<and> Ln x \<prec> Ln (Tup x y) \<and> Ln y \<prec> Ln (Tup x y)) \<or>
    (\<exists> i done todo. r i = Some (done, todo) \<and>
       (\<exists> l pt.
          Send l pt \<in> set done \<and>
          decrChain [] t {St (i, Send l pt)} (inst s i pt) m'
       )
    )"
  (is "?cases m' t r s")
proof -
  --{* Prove cases transfer lemma for trace extension *}
  { fix m' t t' r s
    let ?thesis = "?cases m' (t@t') r s"
    assume "?cases m' t r s" (is "?ik0 \<or> ?hash \<or> ?enc \<or> ?tup \<or> ?chain t r s")
    moreover
    { assume "?ik0"  hence "?thesis" by blast }    moreover
    { assume "?hash" hence "?thesis" by fastsimp } moreover
    { assume "?enc"  hence "?thesis" by fastsimp } moreover
    { assume "?tup"  hence "?thesis" by fastsimp } moreover
    { assume "?chain t r s"
      hence "?chain (t@t') r s"
	by (fastsimp intro!: decrChain_append)
      hence "?thesis" by blast
    }
    ultimately have ?thesis by fast
  }
  note cases_appendI_trace = this

  --{* Prove actual thesis *}
  from knows show ?thesis
  proof (induct arbitrary: m' rule: reachable_induct)
    case init thus ?case by simp
  next
    case (hash t r s m)
    let ?t' = "t @ [Learns {Hash m}]"
    note IH = hash(2)
    have "m' \<in> knows t \<or> m' = Hash m" (is "?old \<or> ?new")
      using hash by fastsimp
    moreover
    { assume "?new" hence ?case
	using `m \<in> knows t` by fastsimp
    }
    moreover
    { assume "?old"
      hence ?case by (fastsimp intro!: IH cases_appendI_trace)
    }
    ultimately show ?case by fast
  next
    case (encr t r s m k)
    let ?t' = "t @ [Learns {Enc m k}]"
    note IH = encr(2)
    have "m' \<in> knows t \<or> m' = Enc m k" (is "?old \<or> ?new")
      using encr by fastsimp
    moreover
    { assume "?new" hence ?case
	using `m \<in> knows t` and `k \<in> knows t` by fastsimp
    }
    moreover
    { assume "?old"
      hence ?case by (fast intro!: IH cases_appendI_trace)
    }
    ultimately show ?case by fast
  next
    case (tuple t r s x y)
    let ?t' = "t @ [Learns {Tup x y}]"
    note IH = tuple(2)
    have "m' \<in> knows t \<or> m' = Tup x y" (is "?old \<or> ?new")
      using tuple by fastsimp
    moreover
    { assume "?new" hence ?case
	using `x \<in> knows t` and `y \<in> knows t` by fastsimp
    }
    moreover
    { assume "?old"
      hence ?case by (fast intro!: IH cases_appendI_trace)
    }
    ultimately show ?case by fast
  next
    case (recv t r s i "done" l pt todo)
    hence "?cases m' t r s" (is "?ik0 \<or> ?hash \<or> ?enc \<or> ?tup \<or> ?chain t r s")
      by clarsimp
    moreover
    { assume "?ik0"  hence "?case" by blast    } moreover
    { assume "?hash" hence "?case" by fastsimp } moreover
    { assume "?enc"  hence "?case" by fastsimp } moreover
    { assume "?tup"  hence "?case" by fastsimp } moreover
    { let ?t' = "t@[Step (i, Recv l pt)]"
      and ?r' = "r(i \<mapsto> (done @ [Recv l pt], todo))"
      assume "?chain t r s" then
      obtain i' done' todo' l' pt'
	where thread': "r i' = Some (done', todo')"
	and send: "Send l' pt' \<in> set done'"
	and chain: "decrChain [] t {St (i', Send l' pt')} (inst s i' pt') m'"
	by auto
      then interpret th1: reachable_thread P t r s i' done' todo'
	using recv by unfold_locales auto
      moreover
      obtain done'' todo''
	where "Send l' pt' \<in> set done''"
	and "?r' i' = Some (done'', todo'')"
	using `r i = Some (done, Recv l pt # todo)` thread' send
	by (cases "i = i'") (fastsimp+)
      ultimately
      have "?chain ?t' ?r' s"
	using chain
	apply-
	apply(rule exI)+
	apply(rule conjI, assumption)
	by(fastsimp intro!: decrChain_append)+
      hence "?case" by auto
    }
    ultimately show ?case by fast
  next
    case (send t r s i "done" l pt todo m)
    then interpret th1:
      reachable_thread P t r s i "done" "Send l pt # todo"
      by unfold_locales
    let ?r' = "r(i \<mapsto> (done @ [Send l pt], todo))"
    let ?m  = "inst s i pt"
    let ?t' = "(t @ [Step (i, Send l pt)]) @ [Learns (pairParts ?m - knows t)]"
    have "m' \<in> knows t \<or> m' \<in> pairParts m \<and> m' \<notin> knows t" (is "?old \<or> ?new")
      using send by fastsimp
    moreover
    { assume "?new"
      hence "m' \<in> pairParts (inst s i pt)" and "m' \<notin> knows t"
	using `m = inst s i pt` by auto
      hence "decrChain [] ?t' {St (i, Send l pt)} ?m m'"
	by (fastsimp intro!: decrChain_unpair)
      moreover
      have "?r' i = Some (done @ [Send l pt], todo)"
	using th1.thread_exists by auto
      ultimately
      have ?case using `m = inst s i pt`
	apply-
	apply(rule disjI2)+
	apply(rule exI)+
	apply(rule conjI, assumption)
	apply(auto)
	done
    }
    moreover
    { assume "?old"
      hence "?cases m' t r s" (is "?ik0 \<or> ?hash \<or> ?enc \<or> ?tup \<or> ?chain t r s")
	using send by clarsimp
      moreover
      { assume "?ik0"  hence "?case" by blast    } moreover
      { assume "?hash" hence "?case" by fastsimp } moreover
      { assume "?enc"  hence "?case" by fastsimp } moreover
      { assume "?tup"  hence "?case" by fastsimp } moreover
      { assume "?chain t r s" then
	obtain i' done' todo' l' pt'
	  where thread': "r i' = Some (done', todo')"
	  and send: "Send l' pt' \<in> set done'"
	  and chain: "decrChain [] t {St (i', Send l' pt')} (inst s i' pt') m'"
	  by auto
	obtain done'' todo''
	  where "Send l' pt' \<in> set done''"
	  and "(r(i \<mapsto> (done @ [Send l pt], todo))) i' = Some (done'', todo'')"
	  using `r i = Some (done, Send l pt # todo)` thread' send
	  by (cases "i = i'") (fastsimp+)
	hence "?chain ?t' ?r' s"
	  using chain
	  apply-
	  apply(rule exI)+
	  apply(rule conjI, assumption)
	  by(fastsimp intro!: decrChain_append)+
	hence "?case" using `m = inst s i pt` by auto
      }
      ultimately have ?case by fast
    }
    ultimately show ?case by fast
  next
    case (decr t r s m k)
    then interpret s1: reachable_state P t r s
      by unfold_locales
    let ?t' = "t @ [Learns (pairParts m - knows t)]"
    note IH = decr(2)
    have "m' \<in> knows t \<or> m' \<in> pairParts m \<and> m' \<notin> knows t" (is "?old \<or> ?new")
      using decr by fastsimp
    moreover
    { assume "?new"
      hence "m' \<in> pairParts m" and "m' \<notin> knows t" by auto
      have
	"predOrd t (Ln m) (Ln (Enc m k)) \<and> predOrd t (Ln k) (Ln (Enc m k)) \<or>
        (\<exists>i done todo. r i = Some (done, todo) \<and>
          (\<exists>l pt. Send l pt \<in> set done \<and>
                  decrChain [] t {St (i, Send l pt)} (inst s i pt) (Enc m k)))"
	(is "?fake_enc \<or> ?chain t (Enc m k)")
	using IH[OF `Enc m k \<in> knows t`] by auto
      moreover
      { assume "?fake_enc"
	hence "?case" using `?new`
	  by (auto dest!: in_knows_predOrd1 s1.rev_knows_pairParts_closedD)
      }
      moreover
      { assume "?chain t (Enc m k)" then
	obtain i' done' todo' l' pt'
	  where thread': "r i' = Some (done', todo')"
	  and send: "Send l' pt' \<in> set done'"
	  and chain: "decrChain [] t {St (i', Send l' pt')} (inst s i' pt') (Enc m k)"
	  by auto
	moreover
	hence "decrChain [] ?t' {St (i', Send l' pt')} (inst s i' pt') m'"
	  using `?new` `Enc m k \<in> knows t` `inv k \<in> knows t`
	  by (fastsimp intro!: decrChain_decrypt)
	ultimately
	have "?chain ?t' m'" by fastsimp
	hence "?case" by blast
      }
      ultimately have ?case by fast
    }
    moreover
    { assume "?old"
      hence ?case by (fast intro!: IH cases_appendI_trace)
    }
    ultimately show ?case by fast thm decr
  qed
qed

end


(*  Title:      ZF/Constructible/Datatype_absolute.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Absoluteness Properties for Recursive Datatypes\<close>

theory Datatype_absolute imports Eclose_Absolute begin

locale M_datatypes = M_trancl +
 assumes list_replacement1:
   "M(A) ==> iterates_replacement(M, is_list_functor(M,A), 0)"
  and list_replacement2:
   "M(A) ==> strong_replacement(M,
         \<lambda>n y. n\<in>nat & is_iterates(M, is_list_functor(M,A), 0, n, y))"
  and formula_replacement1:
   "iterates_replacement(M, is_formula_functor(M), 0)"
  and formula_replacement2:
   "strong_replacement(M,
         \<lambda>n y. n\<in>nat & is_iterates(M, is_formula_functor(M), 0, n, y))"
  and nth_replacement:
   "M(l) ==> iterates_replacement(M, %l t. is_tl(M,l,t), l)"

subsubsection\<open>Absoluteness of the List Construction\<close>

lemma (in M_datatypes) list_replacement2':
  "M(A) ==> strong_replacement(M, \<lambda>n y. n\<in>nat & y = (\<lambda>X. {0} + A * X)^n (0))"
apply (insert list_replacement2 [of A])
apply (rule strong_replacement_cong [THEN iffD1])
apply (rule conj_cong [OF iff_refl iterates_abs [of "is_list_functor(M,A)"]])
apply (simp_all add: list_replacement1 relation1_def)
done

lemma (in M_datatypes) list_closed [intro,simp]:
     "M(A) ==> M(list(A))"
apply (insert list_replacement1)
by  (simp add: RepFun_closed2 list_eq_Union
               list_replacement2' relation1_def
               iterates_closed [of "is_list_functor(M,A)"])

text\<open>WARNING: use only with \<open>dest:\<close> or with variables fixed!\<close>
lemmas (in M_datatypes) list_into_M = transM [OF _ list_closed]

lemma (in M_datatypes) list_N_abs [simp]:
     "[|M(A); n\<in>nat; M(Z)|]
      ==> is_list_N(M,A,n,Z) \<longleftrightarrow> Z = list_N(A,n)"
apply (insert list_replacement1)
apply (simp add: is_list_N_def list_N_def relation1_def nat_into_M
                 iterates_abs [of "is_list_functor(M,A)" _ "\<lambda>X. {0} + A*X"])
done

lemma (in M_datatypes) list_N_closed [intro,simp]:
     "[|M(A); n\<in>nat|] ==> M(list_N(A,n))"
apply (insert list_replacement1)
apply (simp add: is_list_N_def list_N_def relation1_def nat_into_M
                 iterates_closed [of "is_list_functor(M,A)"])
done

lemma (in M_datatypes) mem_list_abs [simp]:
     "M(A) ==> mem_list(M,A,l) \<longleftrightarrow> l \<in> list(A)"
apply (insert list_replacement1)
apply (simp add: mem_list_def list_N_def relation1_def list_eq_Union
                 iterates_closed [of "is_list_functor(M,A)"])
done

lemma (in M_datatypes) list_abs [simp]:
     "[|M(A); M(Z)|] ==> is_list(M,A,Z) \<longleftrightarrow> Z = list(A)"
apply (simp add: is_list_def, safe)
apply (rule M_equalityI, simp_all)
done

subsubsection\<open>Absoluteness of Formulas\<close>

lemma (in M_datatypes) formula_replacement2':
  "strong_replacement(M, \<lambda>n y. n\<in>nat & y = (\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X))^n (0))"
apply (insert formula_replacement2)
apply (rule strong_replacement_cong [THEN iffD1])
apply (rule conj_cong [OF iff_refl iterates_abs [of "is_formula_functor(M)"]])
apply (simp_all add: formula_replacement1 relation1_def)
done

lemma (in M_datatypes) formula_closed [intro,simp]:
     "M(formula)"
apply (insert formula_replacement1)
apply  (simp add: RepFun_closed2 formula_eq_Union
                  formula_replacement2' relation1_def
                  iterates_closed [of "is_formula_functor(M)"])
done

lemmas (in M_datatypes) formula_into_M = transM [OF _ formula_closed]

lemma (in M_datatypes) formula_N_abs [simp]:
     "[|n\<in>nat; M(Z)|]
      ==> is_formula_N(M,n,Z) \<longleftrightarrow> Z = formula_N(n)"
apply (insert formula_replacement1)
apply (simp add: is_formula_N_def formula_N_def relation1_def nat_into_M
                 iterates_abs [of "is_formula_functor(M)" _
                                  "\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X)"])
done

lemma (in M_datatypes) formula_N_closed [intro,simp]:
     "n\<in>nat ==> M(formula_N(n))"
apply (insert formula_replacement1)
apply (simp add: is_formula_N_def formula_N_def relation1_def nat_into_M
                 iterates_closed [of "is_formula_functor(M)"])
done

lemma (in M_datatypes) mem_formula_abs [simp]:
     "mem_formula(M,l) \<longleftrightarrow> l \<in> formula"
apply (insert formula_replacement1)
apply (simp add: mem_formula_def relation1_def formula_eq_Union formula_N_def
                 iterates_closed [of "is_formula_functor(M)"])
done

lemma (in M_datatypes) formula_abs [simp]:
     "[|M(Z)|] ==> is_formula(M,Z) \<longleftrightarrow> Z = formula"
apply (simp add: is_formula_def, safe)
apply (rule M_equalityI, simp_all)
done

lemma (in M_datatypes) length_abs [simp]:
     "[|M(A); l \<in> list(A); n \<in> nat|] ==> is_length(M,A,l,n) \<longleftrightarrow> n = length(l)"
apply (subgoal_tac "M(l) & M(n)")
 prefer 2 apply (blast dest: transM)
apply (simp add: is_length_def)
apply (blast intro: list_imp_list_N nat_into_Ord list_N_imp_eq_length
             dest: list_N_imp_length_lt)
done

definition
  is_nth :: "[i=>o,i,i,i] => o" where
    "is_nth(M,n,l,Z) ==
      \<exists>X[M]. is_iterates(M, is_tl(M), l, n, X) & is_hd(M,X,Z)"

lemma (in M_datatypes) nth_abs [simp]:
     "[|M(A); n \<in> nat; l \<in> list(A); M(Z)|]
      ==> is_nth(M,n,l,Z) \<longleftrightarrow> Z = nth(n,l)"
apply (subgoal_tac "M(l)")
 prefer 2 apply (blast intro: transM)
apply (simp add: is_nth_def nth_eq_hd_iterates_tl nat_into_M
                 tl'_closed iterates_tl'_closed
                 iterates_abs [OF _ relation1_tl] nth_replacement)
done

lemma (in M_datatypes) depth_abs [simp]:
     "[|p \<in> formula; n \<in> nat|] ==> is_depth(M,p,n) \<longleftrightarrow> n = depth(p)"
apply (subgoal_tac "M(p) & M(n)")
 prefer 2 apply (blast dest: transM)
apply (simp add: is_depth_def)
apply (blast intro: formula_imp_formula_N nat_into_Ord formula_N_imp_eq_depth
             dest: formula_N_imp_depth_lt)
done

subsubsection\<open>\<^term>\<open>is_formula_case\<close>: relativization of \<^term>\<open>formula_case\<close>\<close>

definition
 is_formula_case ::
    "[i=>o, [i,i,i]=>o, [i,i,i]=>o, [i,i,i]=>o, [i,i]=>o, i, i] => o" where
  \<comment> \<open>no constraint on non-formulas\<close>
  "is_formula_case(M, is_a, is_b, is_c, is_d, p, z) ==
      (\<forall>x[M]. \<forall>y[M]. finite_ordinal(M,x) \<longrightarrow> finite_ordinal(M,y) \<longrightarrow>
                      is_Member(M,x,y,p) \<longrightarrow> is_a(x,y,z)) &
      (\<forall>x[M]. \<forall>y[M]. finite_ordinal(M,x) \<longrightarrow> finite_ordinal(M,y) \<longrightarrow>
                      is_Equal(M,x,y,p) \<longrightarrow> is_b(x,y,z)) &
      (\<forall>x[M]. \<forall>y[M]. mem_formula(M,x) \<longrightarrow> mem_formula(M,y) \<longrightarrow>
                     is_Nand(M,x,y,p) \<longrightarrow> is_c(x,y,z)) &
      (\<forall>x[M]. mem_formula(M,x) \<longrightarrow> is_Forall(M,x,p) \<longrightarrow> is_d(x,z))"

lemma (in M_datatypes) formula_case_abs [simp]:
     "[| Relation2(M,nat,nat,is_a,a); Relation2(M,nat,nat,is_b,b);
         Relation2(M,formula,formula,is_c,c); Relation1(M,formula,is_d,d);
         p \<in> formula; M(z) |]
      ==> is_formula_case(M,is_a,is_b,is_c,is_d,p,z) \<longleftrightarrow>
          z = formula_case(a,b,c,d,p)"
apply (simp add: formula_into_M is_formula_case_def)
apply (erule formula.cases)
   apply (simp_all add: Relation1_def Relation2_def)
done

lemma (in M_datatypes) formula_case_closed [intro,simp]:
  "[|p \<in> formula;
     \<forall>x[M]. \<forall>y[M]. x\<in>nat \<longrightarrow> y\<in>nat \<longrightarrow> M(a(x,y));
     \<forall>x[M]. \<forall>y[M]. x\<in>nat \<longrightarrow> y\<in>nat \<longrightarrow> M(b(x,y));
     \<forall>x[M]. \<forall>y[M]. x\<in>formula \<longrightarrow> y\<in>formula \<longrightarrow> M(c(x,y));
     \<forall>x[M]. x\<in>formula \<longrightarrow> M(d(x))|] ==> M(formula_case(a,b,c,d,p))"
by (erule formula.cases, simp_all)

subsubsection \<open>Absoluteness for \<^term>\<open>formula_rec\<close>: Final Results\<close>

definition
  is_formula_rec :: "[i=>o, [i,i,i]=>o, i, i] => o" where
    \<comment> \<open>predicate to relativize the functional \<^term>\<open>formula_rec\<close>\<close>
   "is_formula_rec(M,MH,p,z)  ==
      \<exists>dp[M]. \<exists>i[M]. \<exists>f[M]. finite_ordinal(M,dp) & is_depth(M,p,dp) &
             successor(M,dp,i) & fun_apply(M,f,p,z) & is_transrec(M,MH,i,f)"

text\<open>Sufficient conditions to relativize the instance of \<^term>\<open>formula_case\<close>
      in \<^term>\<open>formula_rec\<close>\<close>
lemma (in M_datatypes) Relation1_formula_rec_case:
     "[|Relation2(M, nat, nat, is_a, a);
        Relation2(M, nat, nat, is_b, b);
        Relation2 (M, formula, formula,
           is_c, \<lambda>u v. c(u, v, h`succ(depth(u))`u, h`succ(depth(v))`v));
        Relation1(M, formula,
           is_d, \<lambda>u. d(u, h ` succ(depth(u)) ` u));
        M(h) |]
      ==> Relation1(M, formula,
                         is_formula_case (M, is_a, is_b, is_c, is_d),
                         formula_rec_case(a, b, c, d, h))"
apply (simp (no_asm) add: formula_rec_case_def Relation1_def)
apply (simp)
done

text\<open>This locale packages the premises of the following theorems,
      which is the normal purpose of locales.  It doesn't accumulate
      constraints on the class \<^term>\<open>M\<close>, as in most of this development.\<close>
locale Formula_Rec = M_eclose + M_datatypes +
  fixes a and is_a and b and is_b and c and is_c and d and is_d and MH
  defines
      "MH(u::i,f,z) ==
        \<forall>fml[M]. is_formula(M,fml) \<longrightarrow>
             is_lambda
         (M, fml, is_formula_case (M, is_a, is_b, is_c(f), is_d(f)), z)"

  assumes a_closed: "[|x\<in>nat; y\<in>nat|] ==> M(a(x,y))"
      and a_rel:    "Relation2(M, nat, nat, is_a, a)"
      and b_closed: "[|x\<in>nat; y\<in>nat|] ==> M(b(x,y))"
      and b_rel:    "Relation2(M, nat, nat, is_b, b)"
      and c_closed: "[|x \<in> formula; y \<in> formula; M(gx); M(gy)|]
                     ==> M(c(x, y, gx, gy))"
      and c_rel:
         "M(f) ==>
          Relation2 (M, formula, formula, is_c(f),
             \<lambda>u v. c(u, v, f ` succ(depth(u)) ` u, f ` succ(depth(v)) ` v))"
      and d_closed: "[|x \<in> formula; M(gx)|] ==> M(d(x, gx))"
      and d_rel:
         "M(f) ==>
          Relation1(M, formula, is_d(f), \<lambda>u. d(u, f ` succ(depth(u)) ` u))"
      and fr_replace: "n \<in> nat ==> transrec_replacement(M,MH,n)"
      and fr_lam_replace:
           "M(g) ==>
            strong_replacement
              (M, \<lambda>x y. x \<in> formula &
                  y = \<langle>x, formula_rec_case(a,b,c,d,g,x)\<rangle>)"

lemma (in Formula_Rec) formula_rec_case_closed:
    "[|M(g); p \<in> formula|] ==> M(formula_rec_case(a, b, c, d, g, p))"
by (simp add: formula_rec_case_def a_closed b_closed c_closed d_closed)

lemma (in Formula_Rec) formula_rec_lam_closed:
    "M(g) ==> M(Lambda (formula, formula_rec_case(a,b,c,d,g)))"
by (simp add: lam_closed2 fr_lam_replace formula_rec_case_closed)

lemma (in Formula_Rec) MH_rel2:
     "relation2 (M, MH,
             \<lambda>x h. Lambda (formula, formula_rec_case(a,b,c,d,h)))"
apply (simp add: relation2_def MH_def, clarify)
apply (rule lambda_abs2)
apply (rule Relation1_formula_rec_case)
apply (simp_all add: a_rel b_rel c_rel d_rel formula_rec_case_closed)
done

lemma (in Formula_Rec) fr_transrec_closed:
    "n \<in> nat
     ==> M(transrec
          (n, \<lambda>x h. Lambda(formula, formula_rec_case(a, b, c, d, h))))"
by (simp add: transrec_closed [OF fr_replace MH_rel2]
              nat_into_M formula_rec_lam_closed)

text\<open>The main two results: \<^term>\<open>formula_rec\<close> is absolute for \<^term>\<open>M\<close>.\<close>
theorem (in Formula_Rec) formula_rec_closed:
    "p \<in> formula ==> M(formula_rec(a,b,c,d,p))"
by (simp add: formula_rec_eq fr_transrec_closed
              transM [OF _ formula_closed])

theorem (in Formula_Rec) formula_rec_abs:
  "[| p \<in> formula; M(z)|]
   ==> is_formula_rec(M,MH,p,z) \<longleftrightarrow> z = formula_rec(a,b,c,d,p)"
by (simp add: is_formula_rec_def formula_rec_eq transM [OF _ formula_closed]
              transrec_abs [OF fr_replace MH_rel2] depth_type
              fr_transrec_closed formula_rec_lam_closed eq_commute)

end


theory Prelude_Maybe
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
     \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
     \"notNot1\", \"notNot2\", \"EqualTDef\", \"EqualSymDef\",
     \"EqualReflex\", \"EqualTransT\", \"DiffDef\", \"DiffSymDef\",
     \"DiffTDef\", \"DiffFDef\", \"TE1\", \"TE2\", \"TE3\", \"TE4\",
     \"IUE1\", \"IUE2\", \"IBE1\", \"IBE2\", \"IBE3\", \"IBE4\",
     \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\", \"IOE01\", \"IOE02\",
     \"IOE03\", \"IOE04\", \"IOE05\", \"IOE06\", \"IOE07\", \"IOE08\",
     \"IOE09\", \"LeIrreflexivity\", \"LeTAsymmetry\",
     \"LeTTransitive\", \"LeTTotal\", \"GeDef\", \"GeIrreflexivity\",
     \"GeTAsymmetry\", \"GeTTransitive\", \"GeTTotal\", \"LeqDef\",
     \"LeqReflexivity\", \"LeqTTransitive\", \"LeqTTotal\", \"GeqDef\",
     \"GeqReflexivity\", \"GeqTTransitive\", \"GeqTTotal\",
     \"EqTSOrdRel\", \"EqFSOrdRel\", \"EqTOrdRel\", \"EqFOrdRel\",
     \"EqTOrdTSubstE\", \"EqTOrdFSubstE\", \"EqTOrdTSubstD\",
     \"EqTOrdFSubstD\", \"LeTGeFEqFRel\", \"LeFGeTEqTRel\",
     \"LeTGeTRel\", \"LeFGeFRel\", \"LeqTGetTRel\", \"LeqFGetFRel\",
     \"GeTLeTRel\", \"GeFLeFRel\", \"GeqTLeqTRel\", \"GeqFLeqFRel\",
     \"LeqTGeFRel\", \"LeqFGeTRel\", \"GeTLeFEqFRel\", \"GeFLeTEqTRel\",
     \"GeqTLeFRel\", \"GeqFLeTRel\", \"LeqTLeTEqTRel\",
     \"LeqFLeFEqFRel\", \"GeqTGeTEqTRel\", \"GeqFGeFEqFRel\",
     \"LeTGeqFRel\", \"GeTLeqFRel\", \"LeLeqDiff\", \"CmpLTDef\",
     \"CmpEQDef\", \"CmpGTDef\", \"MaxYDef\", \"MaxXDef\", \"MinXDef\",
     \"MinYDef\", \"MaxSym\", \"MinSym\", \"TO1\", \"TO2\", \"TO3\",
     \"TO4\", \"TO5\", \"TO6\", \"TO7\", \"IUO01\", \"IUO02\",
     \"IUO03\", \"IUO04\", \"IUO05\", \"IUO06\", \"IUO07\", \"IOO13\",
     \"IOO14\", \"IOO15\", \"IOO16\", \"IOO17\", \"IOO18\", \"IOO19\",
     \"IOO20\", \"IOO21\", \"IOO22\", \"IOO23\", \"IOO24\", \"IOO25\",
     \"IOO26\", \"IOO27\", \"IOO28\", \"IOO29\", \"IOO30\", \"IOO31\",
     \"IOO32\", \"IOO33\", \"IBO5\", \"IBO6\", \"IBO7\", \"IBO8\",
     \"IBO9\", \"IBO10\", \"IBO11\", \"IBO12\", \"MaybeJustDef\",
     \"MaybeNothingDef\", \"IME01\", \"IME03\", \"IMO01\", \"IMO02\",
     \"IME02\", \"IMO03\", \"IMO04\", \"IMO05\", \"IMO06\", \"IMO07\",
     \"IMO08\", \"IMO09\", \"IMO10\", \"IMO11\", \"IMO12\"]"

typedecl Bool
typedecl Unit
typedecl X_Nat

datatype Ordering = EQ | GT | LT
datatype 'a Maybe = X_Just 'a ("Just/'(_')" [3] 999) | Nothing

consts
Not__X :: "bool => bool" ("(Not''/ _)" [56] 56)
X__XAmpXAmp__X :: "bool => bool => bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a partial => 'a partial => bool" ("(_/ ==''/ _)" [54,54] 52)
X__XGtXEq__X :: "'a partial => 'a partial => bool" ("(_/ >=''/ _)" [54,54] 52)
X__XGt__X :: "'a partial => 'a partial => bool" ("(_/ >''/ _)" [54,54] 52)
X__XLtXEq__X :: "'a partial => 'a partial => bool" ("(_/ <=''/ _)" [54,54] 52)
X__XLt__X :: "'a partial => 'a partial => bool" ("(_/ <''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a partial => 'a partial => bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "bool => bool => bool" ("(_/ ||/ _)" [54,54] 52)
X_max :: "'a partial => 'a partial => 'a partial"
X_min :: "'a partial => 'a partial => 'a partial"
compare :: "'a partial => 'a partial => Ordering partial"
maybe :: "'b partial => ('a partial => 'b partial) => 'a Maybe partial => 'b partial"
otherwiseH :: "bool"

axioms
NotFalse [rule_format] : "Not' False"

NotTrue [rule_format] : "~ Not' True"

AndFalse [rule_format] : "ALL x. ~ False && x"

AndTrue [rule_format] : "ALL x. True && x = x"

AndSym [rule_format] : "ALL x. ALL y. x && y = y && x"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH"

NotFalse1 [rule_format] : "ALL x. Not' x = (~ x)"

NotTrue1 [rule_format] : "ALL x. ~ Not' x = x"

notNot1 [rule_format] : "ALL x. (~ x) = Not' x"

notNot2 [rule_format] : "ALL x. (~ ~ x) = (~ Not' x)"

EqualTDef [rule_format] : "ALL x. ALL y. x = y --> x ==' y"

EqualSymDef [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL x. x ==' x"

EqualTransT [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & y ==' z --> x ==' z"

DiffDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

DiffSymDef [rule_format] : "ALL x. ALL y. x /= y = y /= x"

DiffTDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

DiffFDef [rule_format] : "ALL x. ALL y. (~ x /= y) = x ==' y"

TE1 [rule_format] : "ALL x. ALL y. ~ x ==' y --> ~ x = y"

TE2 [rule_format] : "ALL x. ALL y. Not' (x ==' y) = (~ x ==' y)"

TE3 [rule_format] : "ALL x. ALL y. (~ Not' (x ==' y)) = x ==' y"

TE4 [rule_format] : "ALL x. ALL y. (~ x ==' y) = (~ x ==' y)"

IUE1 [rule_format] : "makePartial () ==' makePartial ()"

IUE2 [rule_format] : "~ makePartial () /= makePartial ()"

IBE1 [rule_format] : "makePartial () ==' makePartial ()"

IBE2 [rule_format] : "undefinedOp ==' undefinedOp"

IBE3 [rule_format] : "~ undefinedOp ==' makePartial ()"

IBE4 [rule_format] : "~ makePartial () ==' undefinedOp"

IBE5 [rule_format] : "makePartial () /= undefinedOp"

IBE6 [rule_format] : "undefinedOp /= makePartial ()"

IBE7 [rule_format] : "Not' (makePartial () ==' undefinedOp)"

IBE8 [rule_format] : "~ Not' Not' (makePartial () ==' undefinedOp)"

IOE01 [rule_format] : "makePartial LT ==' makePartial LT"

IOE02 [rule_format] : "makePartial EQ ==' makePartial EQ"

IOE03 [rule_format] : "makePartial GT ==' makePartial GT"

IOE04 [rule_format] : "~ makePartial LT ==' makePartial EQ"

IOE05 [rule_format] : "~ makePartial LT ==' makePartial GT"

IOE06 [rule_format] : "~ makePartial EQ ==' makePartial GT"

IOE07 [rule_format] : "makePartial LT /= makePartial EQ"

IOE08 [rule_format] : "makePartial LT /= makePartial GT"

IOE09 [rule_format] : "makePartial EQ /= makePartial GT"

LeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y --> ~ x <' y"

LeTAsymmetry [rule_format] : "ALL x. ALL y. x <' y --> ~ y <' x"

LeTTransitive [rule_format] :
"ALL x. ALL y. ALL z. x <' y & y <' z --> x <' z"

LeTTotal [rule_format] :
"ALL x. ALL y. (x <' y | y <' x) | x ==' y"

GeDef [rule_format] : "ALL x. ALL y. x >' y = y <' x"

GeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y --> ~ x >' y"

GeTAsymmetry [rule_format] : "ALL x. ALL y. x >' y --> ~ y >' x"

GeTTransitive [rule_format] :
"ALL x. ALL y. ALL z. (x >' y) && (y >' z) --> x >' z"

GeTTotal [rule_format] :
"ALL x. ALL y. ((x >' y) || (y >' x)) || (x ==' y)"

LeqDef [rule_format] :
"ALL x. ALL y. x <=' y = (x <' y) || (x ==' y)"

LeqReflexivity [rule_format] : "ALL x. x <=' x"

LeqTTransitive [rule_format] :
"ALL x. ALL y. ALL z. (x <=' y) && (y <=' z) --> x <=' z"

LeqTTotal [rule_format] :
"ALL x. ALL y. (x <=' y) && (y <=' x) = x ==' y"

GeqDef [rule_format] :
"ALL x. ALL y. x >=' y = (x >' y) || (x ==' y)"

GeqReflexivity [rule_format] : "ALL x. x >=' x"

GeqTTransitive [rule_format] :
"ALL x. ALL y. ALL z. (x >=' y) && (y >=' z) --> x >=' z"

GeqTTotal [rule_format] :
"ALL x. ALL y. (x >=' y) && (y >=' x) = x ==' y"

EqTSOrdRel [rule_format] :
"ALL x. ALL y. x ==' y = (~ x <' y & ~ x >' y)"

EqFSOrdRel [rule_format] :
"ALL x. ALL y. (~ x ==' y) = (x <' y | x >' y)"

EqTOrdRel [rule_format] :
"ALL x. ALL y. x ==' y = (x <=' y & x >=' y)"

EqFOrdRel [rule_format] :
"ALL x. ALL y. (~ x ==' y) = (x <=' y | x >=' y)"

EqTOrdTSubstE [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & y <' z --> x <' z"

EqTOrdFSubstE [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & ~ y <' z --> ~ x <' z"

EqTOrdTSubstD [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & z <' y --> z <' x"

EqTOrdFSubstD [rule_format] :
"ALL x. ALL y. ALL z. x ==' y & ~ z <' y --> ~ z <' x"

LeTGeFEqFRel [rule_format] :
"ALL x. ALL y. x <' y = (~ x >' y & ~ x ==' y)"

LeFGeTEqTRel [rule_format] :
"ALL x. ALL y. (~ x <' y) = (x >' y | x ==' y)"

LeTGeTRel [rule_format] : "ALL x. ALL y. x <' y = y >' x"

LeFGeFRel [rule_format] : "ALL x. ALL y. (~ x <' y) = (~ y >' x)"

LeqTGetTRel [rule_format] : "ALL x. ALL y. x <=' y = y >=' x"

LeqFGetFRel [rule_format] :
"ALL x. ALL y. (~ x <=' y) = (~ y >=' x)"

GeTLeTRel [rule_format] : "ALL x. ALL y. x >' y = y <' x"

GeFLeFRel [rule_format] : "ALL x. ALL y. (~ x >' y) = (~ y <' x)"

GeqTLeqTRel [rule_format] : "ALL x. ALL y. x >=' y = y <=' x"

GeqFLeqFRel [rule_format] :
"ALL x. ALL y. (~ x >=' y) = (~ y <=' x)"

LeqTGeFRel [rule_format] : "ALL x. ALL y. x <=' y = (~ x >' y)"

LeqFGeTRel [rule_format] : "ALL x. ALL y. (~ x <=' y) = x >' y"

GeTLeFEqFRel [rule_format] :
"ALL x. ALL y. x >' y = (~ x <' y & ~ x ==' y)"

GeFLeTEqTRel [rule_format] :
"ALL x. ALL y. (~ x >' y) = (x <' y | x ==' y)"

GeqTLeFRel [rule_format] : "ALL x. ALL y. x >=' y = (~ x <' y)"

GeqFLeTRel [rule_format] : "ALL x. ALL y. (~ x >=' y) = x <' y"

LeqTLeTEqTRel [rule_format] :
"ALL x. ALL y. x <=' y = (x <' y | x ==' y)"

LeqFLeFEqFRel [rule_format] :
"ALL x. ALL y. (~ x <=' y) = (~ x <' y & ~ x ==' y)"

GeqTGeTEqTRel [rule_format] :
"ALL x. ALL y. x >=' y = (x >' y | x ==' y)"

GeqFGeFEqFRel [rule_format] :
"ALL x. ALL y. (~ x >=' y) = (~ x >' y & ~ x ==' y)"

LeTGeqFRel [rule_format] : "ALL x. ALL y. x <' y = (~ x >=' y)"

GeTLeqFRel [rule_format] : "ALL x. ALL y. x >' y = (~ x <=' y)"

LeLeqDiff [rule_format] :
"ALL x. ALL y. x <' y = (x <=' y) && (x /= y)"

CmpLTDef [rule_format] :
"ALL x. ALL y. compare x y ==' makePartial LT = x <' y"

CmpEQDef [rule_format] :
"ALL x. ALL y. compare x y ==' makePartial EQ = x ==' y"

CmpGTDef [rule_format] :
"ALL x. ALL y. compare x y ==' makePartial GT = x >' y"

MaxYDef [rule_format] : "ALL x. ALL y. X_max x y ==' y = x <=' y"

MaxXDef [rule_format] : "ALL x. ALL y. X_max x y ==' x = y <=' x"

MinXDef [rule_format] : "ALL x. ALL y. X_min x y ==' x = x <=' y"

MinYDef [rule_format] : "ALL x. ALL y. X_min x y ==' y = y <=' x"

MaxSym [rule_format] :
"ALL x. ALL y. X_max x y ==' y = X_max y x ==' y"

MinSym [rule_format] :
"ALL x. ALL y. X_min x y ==' y = X_min y x ==' y"

TO1 [rule_format] : "ALL x. ALL y. (x ==' y | x <' y) = x <=' y"

TO2 [rule_format] : "ALL x. ALL y. x ==' y --> ~ x <' y"

TO3 [rule_format] :
"ALL x. ALL y. Not' Not' (x <' y) | Not' (x <' y)"

TO4 [rule_format] : "ALL x. ALL y. x <' y --> Not' (x ==' y)"

TO5 [rule_format] :
"ALL w. ALL x. ALL y. ALL z. (x <' y & y <' z) & z <' w --> x <' w"

TO6 [rule_format] : "ALL x. ALL z. z <' x --> Not' (x <' z)"

TO7 [rule_format] : "ALL x. ALL y. x <' y = y >' x"

IUO01 [rule_format] : "makePartial () <=' makePartial ()"

IUO02 [rule_format] : "~ makePartial () <' makePartial ()"

IUO03 [rule_format] : "makePartial () >=' makePartial ()"

IUO04 [rule_format] : "~ makePartial () >' makePartial ()"

IUO05 [rule_format] :
"X_max (makePartial ()) (makePartial ()) ==' makePartial ()"

IUO06 [rule_format] :
"X_min (makePartial ()) (makePartial ()) ==' makePartial ()"

IUO07 [rule_format] :
"compare (makePartial ()) (makePartial ()) ==' makePartial EQ"

IOO13 [rule_format] : "makePartial LT <' makePartial EQ"

IOO14 [rule_format] : "makePartial EQ <' makePartial GT"

IOO15 [rule_format] : "makePartial LT <' makePartial GT"

IOO16 [rule_format] : "makePartial LT <=' makePartial EQ"

IOO17 [rule_format] : "makePartial EQ <=' makePartial GT"

IOO18 [rule_format] : "makePartial LT <=' makePartial GT"

IOO19 [rule_format] : "makePartial EQ >=' makePartial LT"

IOO20 [rule_format] : "makePartial GT >=' makePartial EQ"

IOO21 [rule_format] : "makePartial GT >=' makePartial LT"

IOO22 [rule_format] : "makePartial EQ >' makePartial LT"

IOO23 [rule_format] : "makePartial GT >' makePartial EQ"

IOO24 [rule_format] : "makePartial GT >' makePartial LT"

IOO25 [rule_format] :
"X_max (makePartial LT) (makePartial EQ) ==' makePartial EQ"

IOO26 [rule_format] :
"X_max (makePartial EQ) (makePartial GT) ==' makePartial GT"

IOO27 [rule_format] :
"X_max (makePartial LT) (makePartial GT) ==' makePartial GT"

IOO28 [rule_format] :
"X_min (makePartial LT) (makePartial EQ) ==' makePartial LT"

IOO29 [rule_format] :
"X_min (makePartial EQ) (makePartial GT) ==' makePartial EQ"

IOO30 [rule_format] :
"X_min (makePartial LT) (makePartial GT) ==' makePartial LT"

IOO31 [rule_format] :
"compare (makePartial LT) (makePartial LT) ==' makePartial EQ"

IOO32 [rule_format] :
"compare (makePartial EQ) (makePartial EQ) ==' makePartial EQ"

IOO33 [rule_format] :
"compare (makePartial GT) (makePartial GT) ==' makePartial EQ"

IBO5 [rule_format] : "undefinedOp <' makePartial ()"

IBO6 [rule_format] : "~ undefinedOp >=' makePartial ()"

IBO7 [rule_format] : "makePartial () >=' undefinedOp"

IBO8 [rule_format] : "~ makePartial () <' undefinedOp"

IBO9 [rule_format] :
"X_max undefinedOp (makePartial ()) ==' makePartial ()"

IBO10 [rule_format] :
"X_min undefinedOp (makePartial ()) ==' undefinedOp"

IBO11 [rule_format] :
"compare (makePartial ()) (makePartial ()) ==' makePartial EQ"

IBO12 [rule_format] :
"compare undefinedOp undefinedOp ==' makePartial EQ"

MaybeJustDef [rule_format] :
"ALL f.
 ALL x.
 ALL y.
 maybe y f
 (restrictOp (makePartial (Just(makeTotal x))) (defOp x)) =
 f x"

MaybeNothingDef [rule_format] :
"ALL f. ALL y. maybe y f (makePartial Nothing) = y"

IME01 [rule_format] :
"ALL x.
 ALL y.
 restrictOp (makePartial (Just(makeTotal x))) (defOp x) =='
 restrictOp (makePartial (Just(makeTotal y))) (defOp y) =
 x ==' y"

IME03 [rule_format] :
"ALL x.
 ~
 restrictOp (makePartial (Just(makeTotal x))) (defOp x) =='
 makePartial Nothing"

IMO01 [rule_format] :
"ALL x.
 makePartial Nothing <'
 restrictOp (makePartial (Just(makeTotal x))) (defOp x)"

IMO02 [rule_format] :
"ALL x.
 ALL y.
 restrictOp (makePartial (Just(makeTotal x))) (defOp x) <'
 restrictOp (makePartial (Just(makeTotal y))) (defOp y) =
 x <' y"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare OtherwiseDef [simp]
declare NotTrue1 [simp]
declare EqualReflex [simp]
declare IUE1 [simp]
declare IUE2 [simp]
declare IBE1 [simp]
declare IBE2 [simp]
declare IBE3 [simp]
declare IBE4 [simp]
declare IBE5 [simp]
declare IBE6 [simp]
declare IBE7 [simp]
declare IBE8 [simp]
declare IOE01 [simp]
declare IOE02 [simp]
declare IOE03 [simp]
declare IOE04 [simp]
declare IOE05 [simp]
declare IOE06 [simp]
declare IOE07 [simp]
declare IOE08 [simp]
declare IOE09 [simp]
declare LeIrreflexivity [simp]
declare LeTAsymmetry [simp]
declare GeIrreflexivity [simp]
declare GeTAsymmetry [simp]
declare GeTTransitive [simp]
declare GeTTotal [simp]
declare LeqReflexivity [simp]
declare LeqTTransitive [simp]
declare LeqTTotal [simp]
declare GeqReflexivity [simp]
declare GeqTTransitive [simp]
declare GeqTTotal [simp]
declare CmpLTDef [simp]
declare CmpEQDef [simp]
declare CmpGTDef [simp]
declare MaxYDef [simp]
declare MaxXDef [simp]
declare MinXDef [simp]
declare MinYDef [simp]
declare TO2 [simp]
declare TO4 [simp]
declare TO6 [simp]
declare IUO01 [simp]
declare IUO02 [simp]
declare IUO03 [simp]
declare IUO04 [simp]
declare IUO05 [simp]
declare IUO06 [simp]
declare IUO07 [simp]
declare IOO13 [simp]
declare IOO14 [simp]
declare IOO15 [simp]
declare IOO16 [simp]
declare IOO17 [simp]
declare IOO18 [simp]
declare IOO19 [simp]
declare IOO20 [simp]
declare IOO21 [simp]
declare IOO22 [simp]
declare IOO23 [simp]
declare IOO24 [simp]
declare IOO25 [simp]
declare IOO26 [simp]
declare IOO27 [simp]
declare IOO28 [simp]
declare IOO29 [simp]
declare IOO30 [simp]
declare IOO31 [simp]
declare IOO32 [simp]
declare IOO33 [simp]
declare IBO5 [simp]
declare IBO6 [simp]
declare IBO7 [simp]
declare IBO8 [simp]
declare IBO9 [simp]
declare IBO10 [simp]
declare IBO11 [simp]
declare IBO12 [simp]
declare MaybeJustDef [simp]
declare MaybeNothingDef [simp]
declare IME01 [simp]
declare IME03 [simp]
declare IMO01 [simp]
declare IMO02 [simp]

theorem IME02 : "makePartial Nothing ==' makePartial Nothing"
by (auto)

ML "Header.record \"IME02\""

theorem IMO03 :
"ALL x.
 ~
 makePartial Nothing >='
 restrictOp (makePartial (Just(makeTotal x))) (defOp x)"
apply(simp add: GeqDef OrDef GeDef)
done

ML "Header.record \"IMO03\""

theorem IMO04 :
"ALL x.
 restrictOp (makePartial (Just(makeTotal x))) (defOp x) >='
 makePartial Nothing"
apply(simp add: GeqDef OrDef GeDef)
done

ML "Header.record \"IMO04\""

theorem IMO05 :
"ALL x.
 ~
 restrictOp (makePartial (Just(makeTotal x))) (defOp x) <'
 makePartial Nothing"
by (auto)

ML "Header.record \"IMO05\""

theorem IMO06 :
"ALL x.
 compare (makePartial Nothing)
 (restrictOp (makePartial (Just(makeTotal x))) (defOp x))
 ==' makePartial EQ =
 makePartial Nothing =='
 restrictOp (makePartial (Just(makeTotal x))) (defOp x)"
by (auto)

ML "Header.record \"IMO06\""

theorem IMO07 :
"ALL x.
 compare (makePartial Nothing)
 (restrictOp (makePartial (Just(makeTotal x))) (defOp x))
 ==' makePartial LT =
 makePartial Nothing <'
 restrictOp (makePartial (Just(makeTotal x))) (defOp x)"
by (auto)

ML "Header.record \"IMO07\""

theorem IMO08 :
"ALL x.
 compare (makePartial Nothing)
 (restrictOp (makePartial (Just(makeTotal x))) (defOp x))
 ==' makePartial GT =
 makePartial Nothing >'
 restrictOp (makePartial (Just(makeTotal x))) (defOp x)"
apply(rule allI)+
apply(simp add: GeDef)
done

ML "Header.record \"IMO08\""

theorem IMO09 :
"ALL x.
 makePartial Nothing <='
 restrictOp (makePartial (Just(makeTotal x))) (defOp x) =
 X_max (makePartial Nothing)
 (restrictOp (makePartial (Just(makeTotal x))) (defOp x))
 ==' restrictOp (makePartial (Just(makeTotal x))) (defOp x)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO09\""

theorem IMO10 :
"ALL x.
 restrictOp (makePartial (Just(makeTotal x))) (defOp x) <='
 makePartial Nothing =
 X_max (makePartial Nothing)
 (restrictOp (makePartial (Just(makeTotal x))) (defOp x))
 ==' makePartial Nothing"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO10\""

theorem IMO11 :
"ALL x.
 makePartial Nothing <='
 restrictOp (makePartial (Just(makeTotal x))) (defOp x) =
 X_min (makePartial Nothing)
 (restrictOp (makePartial (Just(makeTotal x))) (defOp x))
 ==' makePartial Nothing"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO11\""

theorem IMO12 :
"ALL x.
 restrictOp (makePartial (Just(makeTotal x))) (defOp x) <='
 makePartial Nothing =
 X_min (makePartial Nothing)
 (restrictOp (makePartial (Just(makeTotal x))) (defOp x))
 ==' restrictOp (makePartial (Just(makeTotal x))) (defOp x)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IMO12\""

end