(*  Title:      HOL/Metis_Examples/Message.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Metis example featuring message authentication.
*)

section \<open>Metis Example Featuring Message Authentication\<close>

theory Message
imports Main
begin

declare [[metis_new_skolem]]

lemma strange_Un_eq [simp]: "A \<union> (B \<union> A) = B \<union> A"
by (metis Un_commute Un_left_absorb)

type_synonym key = nat

consts
  all_symmetric :: bool        \<comment>\<open>true if all keys are symmetric\<close>
  invKey        :: "key=>key"  \<comment>\<open>inverse of a symmetric key\<close>

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric --> invKey = id"
by (metis id_apply)

text\<open>The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa\<close>

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

datatype  \<comment>\<open>We allow any number of friendly agents\<close>
  agent = Server | Friend nat | Spy

datatype
     msg = Agent  agent     \<comment>\<open>Agent names\<close>
         | Number nat       \<comment>\<open>Ordinary integers, timestamps, ...\<close>
         | Nonce  nat       \<comment>\<open>Unguessable nonces\<close>
         | Key    key       \<comment>\<open>Crypto keys\<close>
         | Hash   msg       \<comment>\<open>Hashing\<close>
         | MPair  msg msg   \<comment>\<open>Compound messages\<close>
         | Crypt  key msg   \<comment>\<open>Encryption, public- or shared-key\<close>

text\<open>Concrete syntax: messages appear as \<open>\<lbrace>A,B,NA\<rbrace>\<close>, etc...\<close>
syntax
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")
translations
  "\<lbrace>x, y, z\<rbrace>"   == "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
  "\<lbrace>x, y\<rbrace>"      == "CONST MPair x y"

definition HPair :: "[msg,msg] => msg" ("(4Hash[_] /_)" [0, 1000]) where
    \<comment>\<open>Message Y paired with a MAC computed with the help of X\<close>
    "Hash[X] Y == \<lbrace> Hash\<lbrace>X,Y\<rbrace>, Y\<rbrace>"

definition keysFor :: "msg set => key set" where
    \<comment>\<open>Keys useful to decrypt elements of a message set\<close>
  "keysFor H == invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsubsection\<open>Inductive Definition of All Parts" of a Message\<close>

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> X \<in> parts H"
  | Snd:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

lemma parts_mono: "G \<subseteq> H ==> parts(G) \<subseteq> parts(H)"
apply auto
apply (erule parts.induct)
   apply (metis parts.Inj set_rev_mp)
  apply (metis parts.Fst)
 apply (metis parts.Snd)
by (metis parts.Body)

text\<open>Equations hold because constructors are injective.\<close>
lemma Friend_image_eq [simp]: "(Friend x \<in> Friend`A) = (x:A)"
by (metis agent.inject image_iff)

lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x \<in> A)"
by (metis image_iff msg.inject(4))

lemma Nonce_Key_image_eq [simp]: "Nonce x \<notin> Key`A"
by (metis image_iff msg.distinct(23))

subsubsection\<open>Inverse of keys\<close>

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K = K')"
by (metis invKey)

subsection\<open>keysFor operator\<close>

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

text\<open>Monotonicity\<close>
lemma keysFor_mono: "G \<subseteq> H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert \<lbrace>X,Y\<rbrace> H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection\<open>Inductive relation "parts"\<close>

lemma MPair_parts:
     "[| \<lbrace>X,Y\<rbrace> \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!] parts.Body [dest!]
text\<open>NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  \<open>MPair_parts\<close> is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.\<close>

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct)
apply blast+
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

text\<open>WARNING: loops if H = {Y}, therefore must not be repeated!\<close>
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
apply (erule parts.induct)
apply fast+
done

subsubsection\<open>Unions\<close>

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
apply (subst insert_is_Un [of _ H])
apply (simp only: parts_Un)
done

lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
by (metis Un_commute Un_empty_left Un_empty_right Un_insert_left Un_insert_right parts_Un)

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]: "parts(\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))"
by (intro equalityI parts_UN_subset1 parts_UN_subset2)

text\<open>Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!\<close>

text\<open>This allows \<open>blast\<close> to simplify occurrences of
  @{term "parts(G\<union>H)"} in the assumption.\<close>
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) = (G \<subseteq> parts H)"
apply (rule iffI)
apply (metis Un_absorb1 Un_subset_iff parts_Un parts_increasing)
apply (metis parts_idem parts_mono)
done

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (blast dest: parts_mono)

lemma parts_cut: "[|Y\<in> parts (insert X G);  X\<in> parts H|] ==> Y\<in> parts(G \<union> H)"
by (metis (no_types) Un_insert_left Un_insert_right insert_absorb le_supE
          parts_Un parts_idem parts_increasing parts_trans)

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) =
          insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Body)
done

lemma parts_insert_MPair [simp]:
     "parts (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done

lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n --> Nonce n \<notin> parts {msg}"
apply (induct_tac "msg")
apply (simp_all add: parts_insert2)
apply (metis Suc_n_not_le_n)
apply (metis le_trans linorder_linear)
done

subsection\<open>Inductive relation "analz"\<close>

text\<open>Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.\<close>

inductive_set
  analz :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] :    "X \<in> H ==> X \<in> analz H"
  | Fst:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> X \<in> analz H"
  | Snd:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "[|Crypt K X \<in> analz H; Key(invKey K): analz H|] ==> X \<in> analz H"

text\<open>Monotonicity; Lemma 1 of Lowe's paper\<close>
lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd)
done

text\<open>Making it safe speeds up proofs\<close>
lemma MPair_analz [elim!]:
     "[| \<lbrace>X,Y\<rbrace> \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
apply (rule equalityI)
apply (metis analz_subset_parts parts_subset_iff)
apply (metis analz_increasing parts_mono)
done

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection\<open>General equational properties\<close>

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

text\<open>Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other\<close>
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

text\<open>Can only pull out Keys if they are not needed to decrypt the rest\<close>
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

text\<open>Can pull out enCrypted message if the Key is not known\<close>
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)

done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

text\<open>Case analysis: either the message is secure, or it is not! Effective,
but can cause subgoals to blow up! Use with \<open>if_split\<close>; apparently
\<open>split_tac\<close> does not cope with patterns such as @{term"analz (insert
(Crypt K X) H)"}\<close>
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

text\<open>This rule supposes "for the sake of argument" that we have the key.\<close>
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

subsubsection\<open>Idempotence and transitivity\<close>

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_subset_iff [simp]: "(analz G \<subseteq> analz H) = (G \<subseteq> analz H)"
apply (rule iffI)
apply (iprover intro: subset_trans analz_increasing)
apply (frule analz_mono, simp)
done

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

declare analz_trans[intro]

lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (metis analz_idem analz_increasing analz_mono insert_absorb insert_mono insert_subset)

text\<open>This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated.\<close>
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)

text\<open>A congruence rule for "analz"\<close>

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' |]
      ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply simp
apply (metis Un_absorb2 Un_commute Un_subset_iff Un_upper1 Un_upper2 analz_mono)
done

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H'
               |] ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

text\<open>If there are no pairs or encryptions then analz does nothing\<close>
lemma analz_trivial:
     "[| \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

text\<open>These two are obsolete (with a single Spy) but cost little to prove...\<close>
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])

subsection\<open>Inductive relation "synth"\<close>

text\<open>Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.\<close>

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> \<lbrace>X,Y\<rbrace> \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

text\<open>Monotonicity\<close>
lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
  by (auto, erule synth.induct, auto)

text\<open>NO \<open>Agent_synth\<close>, as any Agent name can be synthesized.
  The same holds for @{term Number}\<close>
inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"
inductive_cases Key_synth   [elim!]: "Key K \<in> synth H"
inductive_cases Hash_synth  [elim!]: "Hash X \<in> synth H"
inductive_cases MPair_synth [elim!]: "\<lbrace>X,Y\<rbrace> \<in> synth H"
inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection\<open>Unions\<close>

text\<open>Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.\<close>
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (metis insert_iff insert_subset subset_insertI synth.Inj synth_mono)

subsubsection\<open>Idempotence and transitivity\<close>

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, blast+)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
apply (rule iffI)
apply (iprover intro: subset_trans synth_increasing)
apply (frule synth_mono, simp add: synth_idem)
done

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (metis insert_absorb insert_mono insert_subset synth_idem synth_increasing synth_mono)

lemma Agent_synth [simp]: "Agent A \<in> synth H"
by blast

lemma Number_synth [simp]: "Number n \<in> synth H"
by blast

lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast

lemma Crypt_synth_eq [simp]:
     "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection\<open>Combinations of parts, analz and synth\<close>

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (metis UnCI)
apply (metis MPair_synth UnCI UnE insert_absorb insert_subset parts.Fst parts_increasing)
apply (metis MPair_synth UnCI UnE insert_absorb insert_subset parts.Snd parts_increasing)
apply (metis Body Crypt_synth UnCI UnE insert_absorb insert_subset parts_increasing)
apply (metis Un_subset_iff parts_increasing parts_mono synth_increasing)
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (rule equalityI)
apply (metis analz_idem analz_subset_cong order_eq_refl)
apply (metis analz_increasing analz_subset_cong order_eq_refl)
done

declare analz_mono [intro] analz.Fst [intro] analz.Snd [intro] Un_least [intro]

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
apply (metis UnCI UnE Un_commute analz.Inj)
apply (metis MPair_synth UnCI UnE Un_commute analz.Fst analz.Inj)
apply (metis MPair_synth UnCI UnE Un_commute analz.Inj analz.Snd)
apply (blast intro: analz.Decrypt)
apply blast
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
proof -
  have "\<forall>x\<^sub>2 x\<^sub>1. synth x\<^sub>1 \<union> analz (x\<^sub>1 \<union> x\<^sub>2) = analz (synth x\<^sub>1 \<union> x\<^sub>2)" by (metis Un_commute analz_synth_Un)
  hence "\<forall>x\<^sub>1. synth x\<^sub>1 \<union> analz x\<^sub>1 = analz (synth x\<^sub>1 \<union> {})" by (metis Un_empty_right)
  hence "\<forall>x\<^sub>1. synth x\<^sub>1 \<union> analz x\<^sub>1 = analz (synth x\<^sub>1)" by (metis Un_empty_right)
  hence "\<forall>x\<^sub>1. analz x\<^sub>1 \<union> synth x\<^sub>1 = analz (synth x\<^sub>1)" by (metis Un_commute)
  thus "analz (synth H) = analz H \<union> synth H" by metis
qed

subsubsection\<open>For reasoning about the Fake rule in traces\<close>

lemma parts_insert_subset_Un: "X \<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
proof -
  assume "X \<in> G"
  hence "\<forall>x\<^sub>1. G \<subseteq> x\<^sub>1 \<longrightarrow> X \<in> x\<^sub>1 " by auto
  hence "\<forall>x\<^sub>1. X \<in> G \<union> x\<^sub>1" by (metis Un_upper1)
  hence "insert X H \<subseteq> G \<union> H" by (metis Un_upper2 insert_subset)
  hence "parts (insert X H) \<subseteq> parts (G \<union> H)" by (metis parts_mono)
  thus "parts (insert X H) \<subseteq> parts G \<union> parts H" by (metis parts_Un)
qed

lemma Fake_parts_insert:
     "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
proof -
  assume A1: "X \<in> synth (analz H)"
  have F1: "\<forall>x\<^sub>1. analz x\<^sub>1 \<union> synth (analz x\<^sub>1) = analz (synth (analz x\<^sub>1))"
    by (metis analz_idem analz_synth)
  have F2: "\<forall>x\<^sub>1. parts x\<^sub>1 \<union> synth (analz x\<^sub>1) = parts (synth (analz x\<^sub>1))"
    by (metis parts_analz parts_synth)
  have F3: "X \<in> synth (analz H)" using A1 by metis
  have "\<forall>x\<^sub>2 x\<^sub>1::msg set. x\<^sub>1 \<le> sup x\<^sub>1 x\<^sub>2" by (metis inf_sup_ord(3))
  hence F4: "\<forall>x\<^sub>1. analz x\<^sub>1 \<subseteq> analz (synth x\<^sub>1)" by (metis analz_synth)
  have F5: "X \<in> synth (analz H)" using F3 by metis
  have "\<forall>x\<^sub>1. analz x\<^sub>1 \<subseteq> synth (analz x\<^sub>1)
         \<longrightarrow> analz (synth (analz x\<^sub>1)) = synth (analz x\<^sub>1)"
    using F1 by (metis subset_Un_eq)
  hence F6: "\<forall>x\<^sub>1. analz (synth (analz x\<^sub>1)) = synth (analz x\<^sub>1)"
    by (metis synth_increasing)
  have "\<forall>x\<^sub>1. x\<^sub>1 \<subseteq> analz (synth x\<^sub>1)" using F4 by (metis analz_subset_iff)
  hence "\<forall>x\<^sub>1. x\<^sub>1 \<subseteq> analz (synth (analz x\<^sub>1))" by (metis analz_subset_iff)
  hence "\<forall>x\<^sub>1. x\<^sub>1 \<subseteq> synth (analz x\<^sub>1)" using F6 by metis
  hence "H \<subseteq> synth (analz H)" by metis
  hence "H \<subseteq> synth (analz H) \<and> X \<in> synth (analz H)" using F5 by metis
  hence "insert X H \<subseteq> synth (analz H)" by (metis insert_subset)
  hence "parts (insert X H) \<subseteq> parts (synth (analz H))" by (metis parts_mono)
  hence "parts (insert X H) \<subseteq> parts H \<union> synth (analz H)" using F2 by metis
  thus "parts (insert X H) \<subseteq> synth (analz H) \<union> parts H" by (metis Un_commute)
qed

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X: synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (blast dest: Fake_parts_insert [THEN subsetD, dest])

declare synth_mono [intro]

lemma Fake_analz_insert:
     "X \<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
by (metis Un_commute Un_insert_left Un_insert_right Un_upper1 analz_analz_Un
          analz_mono analz_synth_Un insert_absorb)

lemma Fake_analz_insert_simpler:
     "X \<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H) ")
apply (metis Un_commute analz_analz_Un analz_synth_Un)
by (metis Un_upper1 Un_upper2 analz_mono insert_absorb insert_subset)

end


(*  Title:       Executable multivariate polynomials
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2010 Christian Sternagel and René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

header {* Strongly Normalizing Orders *}

theory SN_Orders
imports Abstract_Rewriting
begin

text {*
We define several classes of orders which are used to build ordered semirings.
Note that we do not use Isabelle's preorders since the condition
   $x > y = x \geq y \wedge  y \not\geq x$
   is sometimes not applicable. E.g., for $\delta$-orders over the rationals
   we have $0.2 \geq 0.1 \wedge 0.1 \not\geq 0.2$, but $0.2 >_\delta 0.1$ does not
   hold if $\delta$ is larger than $0.1$.
*}
class non_strict_order = ord +
  assumes ge_refl: "x \<ge> (x :: 'a)"
  and ge_trans[trans]: "\<lbrakk>x \<ge> y; (y :: 'a) \<ge> z\<rbrakk> \<Longrightarrow> x \<ge> z"
  and max_comm: "max x y = max y x"
  and max_ge_x[intro]: "max x y \<ge> x"
  and max_id: "x \<ge> y \<Longrightarrow> max x y = x"
  and max_mono: "x \<ge> y \<Longrightarrow> max z x \<ge> max z y"
begin
lemma max_ge_y[intro]: "max x y \<ge> y"
  unfolding max_comm[of x y] ..

lemma max_mono2: "x \<ge> y \<Longrightarrow> max x z \<ge> max y z"
  unfolding max_comm[of _ z] by (rule max_mono)
end

class ordered_ab_semigroup = non_strict_order + ab_semigroup_add + monoid_add +
  assumes plus_left_mono: "x \<ge> y \<Longrightarrow>  x + z \<ge> y + z"

lemma plus_right_mono: "y \<ge> (z :: 'a :: ordered_ab_semigroup) \<Longrightarrow> x + y \<ge> x + z"
  by (simp add: add.commute[of x], rule plus_left_mono, auto)

class ordered_semiring_0 = ordered_ab_semigroup + semiring_0 +
 assumes times_left_mono: "z \<ge> 0 \<Longrightarrow> x \<ge> y \<Longrightarrow> x * z \<ge> y * z"
     and times_right_mono: "x \<ge> 0 \<Longrightarrow> y \<ge> z \<Longrightarrow> x * y \<ge> x * z"
     and times_left_anti_mono: "x \<ge> y \<Longrightarrow> 0 \<ge> z \<Longrightarrow> y * z \<ge> x * z"

class ordered_semiring_1 = ordered_semiring_0 + semiring_1 +
  assumes one_ge_zero: "1 \<ge> 0"

text {*
   We do not use a class to define order-pairs of a strict and a weak-order
   since often we
   have parametric strict orders, e.g. on rational numbers there are several orders
   $>$ where $x > y = x \geq y + \delta$ for some parameter $\delta$
*}
locale order_pair =
  fixes gt :: "'a :: {non_strict_order,zero} \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succ>" 50)
  and default :: "'a"
  assumes compat[trans]: "\<lbrakk>x \<ge> y; y \<succ> z\<rbrakk> \<Longrightarrow> x \<succ> z"
  and compat2[trans]: "\<lbrakk>x \<succ> y; y \<ge> z\<rbrakk> \<Longrightarrow> x \<succ> z"
  and gt_imp_ge: "x \<succ> y \<Longrightarrow> x \<ge> y"
  and default_ge_zero: "default \<ge> 0"
begin
lemma gt_trans[trans]: "\<lbrakk>x \<succ> y; y \<succ> z\<rbrakk> \<Longrightarrow> x \<succ> z"
  by (rule compat[OF gt_imp_ge])
end

locale one_mono_ordered_semiring_1 = order_pair gt
  for gt :: "'a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succ>" 50) +
  assumes plus_gt_left_mono: "x \<succ> y \<Longrightarrow> x + z \<succ> y + z"
  and default_gt_zero: "default \<succ> 0"
begin

lemma plus_gt_both_mono: "x \<succ> y \<Longrightarrow> a \<succ> b \<Longrightarrow> x + a \<succ> y + b"
  by (rule gt_trans[OF plus_gt_left_mono plus_gt_right_mono])
end

locale SN_one_mono_ordered_semiring_1 = one_mono_ordered_semiring_1 + order_pair +
  assumes SN: "SN {(x,y) . y \<ge> 0 \<and> x \<succ> y}"

locale SN_strict_mono_ordered_semiring_1 = SN_one_mono_ordered_semiring_1 +
  fixes mono :: "'a :: ordered_semiring_1 \<Rightarrow> bool"
  assumes mono: "\<lbrakk>mono x; y \<succ> z; x \<ge> 0\<rbrakk> \<Longrightarrow> x * y \<succ> x * z"

locale both_mono_ordered_semiring_1 = order_pair gt
  for gt :: "'a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succ>" 50) +
  fixes arc_pos :: "'a \<Rightarrow> bool"
  assumes plus_gt_both_mono: "\<lbrakk>x \<succ> y; z \<succ> u\<rbrakk> \<Longrightarrow> x + z \<succ> y + u"
  and times_gt_left_mono: "x \<succ> y \<Longrightarrow> x * z \<succ> y * z"
  and times_gt_right_mono: "y \<succ> z \<Longrightarrow> x * y \<succ> x * z"
  and zero_leastI: "x \<succ> 0"
  and zero_leastII: "0 \<succ> x \<Longrightarrow> x = 0"
  and zero_leastIII: "(x :: 'a) \<ge> 0"
  and arc_pos_one: "arc_pos (1 :: 'a)"
  and arc_pos_default: "arc_pos default"
  and arc_pos_zero: "\<not> arc_pos 0"
  and arc_pos_plus: "arc_pos x \<Longrightarrow> arc_pos (x + y)"
  and arc_pos_mult: "\<lbrakk>arc_pos x; arc_pos y\<rbrakk> \<Longrightarrow> arc_pos (x * y)"
  and not_all_ge: "\<And> c d. arc_pos d \<Longrightarrow> \<exists> e. e \<ge> 0 \<and> arc_pos e \<and> \<not> (c \<ge> d * e)"
begin
lemma max0_id: "max 0 (x :: 'a) = x"
  unfolding max_comm[of 0]
  by (rule max_id[OF zero_leastIII])
end

locale SN_both_mono_ordered_semiring_1 = both_mono_ordered_semiring_1 +
  assumes SN: "SN {(x,y) . arc_pos y \<and> x \<succ> y}"

locale weak_SN_strict_mono_ordered_semiring_1 =
  fixes weak_gt :: "'a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool"
   and  default :: "'a"
   and  mono :: "'a \<Rightarrow> bool"
  assumes weak_gt_mono: "\<forall> x y. (x,y) \<in> set xys \<longrightarrow> weak_gt x y \<Longrightarrow> \<exists> gt. SN_strict_mono_ordered_semiring_1  default gt mono \<and> (\<forall> x y. (x,y) \<in> set xys \<longrightarrow> gt x y)"

locale weak_SN_both_mono_ordered_semiring_1 =
  fixes weak_gt :: "'a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool"
   and  default :: "'a"
   and  arc_pos :: "'a \<Rightarrow> bool"
  assumes weak_gt_both_mono: "\<forall> x y. (x,y) \<in> set xys \<longrightarrow> weak_gt x y \<Longrightarrow> \<exists> gt. SN_both_mono_ordered_semiring_1 default gt arc_pos \<and> (\<forall> x y. (x,y) \<in> set xys \<longrightarrow> gt x y)"

class poly_carrier = ordered_semiring_1 + comm_semiring_1

locale poly_order_carrier = SN_one_mono_ordered_semiring_1 default gt
  for default :: "'a :: poly_carrier" and gt (infix "\<succ>" 50) +
  fixes power_mono :: "bool"
  and   discrete :: "bool"
  assumes times_gt_mono: "\<lbrakk>y \<succ> z; x \<ge> 1\<rbrakk> \<Longrightarrow> y * x \<succ> z * x"
  and power_mono: "power_mono \<Longrightarrow> x \<succ> y \<Longrightarrow> y \<ge> 0 \<Longrightarrow> n \<ge> 1 \<Longrightarrow> x ^ n \<succ> y ^ n"
  and discrete: "discrete \<Longrightarrow> x \<ge> y \<Longrightarrow> \<exists> k. x = ((op + 1)^^k) y"

class large_ordered_semiring_1 = poly_carrier +
  assumes ex_large_of_nat: "\<exists> x. of_nat x \<ge> y"

context ordered_semiring_1
begin
lemma pow_mono: assumes ab: "a \<ge> b" and b: "b \<ge> 0"
  shows "a ^ n \<ge> b ^ n \<and> b ^ n \<ge> 0"
proof (induct n)
  case 0
  show ?case by (auto simp: ge_refl one_ge_zero)
next
  case (Suc n)
  hence abn: "a ^ n \<ge> b ^ n" and bn: "b ^ n \<ge> 0" by auto
  have bsn: "b ^ Suc n \<ge> 0" unfolding power_Suc
    using times_left_mono[OF bn b] by auto
  have "a ^ Suc n = a * a ^ n" unfolding power_Suc by simp
  also have "... \<ge> b * a ^ n"
    by (rule times_left_mono[OF ge_trans[OF abn bn] ab])
  also have "b * a ^ n \<ge> b * b ^ n"
    by (rule times_right_mono[OF b abn])
  finally show ?case using bsn unfolding power_Suc by simp
qed

lemma pow_ge_zero[intro]: assumes a: "a \<ge> (0 :: 'a)"
  shows "a ^ n \<ge> 0"
proof (induct n)
  case 0
  from one_ge_zero show ?case by simp
next
  case (Suc n)
  show ?case using times_left_mono[OF Suc a] by simp
qed
end

lemma of_nat_ge_zero[intro,simp]: "of_nat n \<ge> (0 :: 'a :: ordered_semiring_1)"
proof (induct n)
  case 0
  show ?case by (simp add: ge_refl)
next
  case (Suc n)
  from plus_right_mono[OF Suc, of 1] have "of_nat (Suc n) \<ge> (1 :: 'a)" by simp
  also have "(1 :: 'a) \<ge> 0" using one_ge_zero .
  finally show ?case .
qed

lemma mult_ge_zero[intro]: "(a :: 'a :: ordered_semiring_1) \<ge> 0 \<Longrightarrow> b \<ge> 0 \<Longrightarrow> a * b \<ge> 0"
  using times_left_mono[of b 0 a] by auto

lemma pow_mono_one: assumes a: "a \<ge> (1 :: 'a :: ordered_semiring_1)"
  shows "a ^ n \<ge> 1"
proof (induct n)
  case (Suc n)
  show ?case unfolding power_Suc
    using ge_trans[OF times_right_mono[OF ge_trans[OF a one_ge_zero] Suc], of 1]
    a
    by (auto simp: field_simps)
qed (auto simp: ge_refl)

lemma pow_mono_exp: assumes a: "a \<ge> (1 :: 'a :: ordered_semiring_1)"
  shows "n \<ge> m \<Longrightarrow> a ^ n \<ge> a ^ m"
proof (induct m arbitrary: n)
  case 0
  show ?case using pow_mono_one[OF a] by auto
next
  case (Suc m nn)
  then obtain n where nn: "nn = Suc n" by (cases nn, auto)
  note Suc = Suc[unfolded nn]
  hence rec: "a ^ n \<ge> a ^ m" by auto
  show ?case unfolding nn power_Suc
    by (rule times_right_mono[OF ge_trans[OF a one_ge_zero] rec])
qed

lemma mult_ge_one[intro]: assumes a: "(a :: 'a :: ordered_semiring_1) \<ge> 1"
  and b: "b \<ge> 1"
  shows "a * b \<ge> 1"
proof -
  from ge_trans[OF b one_ge_zero] have b0: "b \<ge> 0" .
  from times_left_mono[OF b0 a] have "a * b \<ge> b" by simp
  from ge_trans[OF this b] show ?thesis .
qed

lemma listsum_ge_mono: fixes as :: "('a :: ordered_semiring_0) list"
  assumes "length as = length bs"
  and "\<And> i. i < length bs \<Longrightarrow> as ! i \<ge> bs ! i"
  shows "listsum as \<ge> listsum bs"
  using assms
proof (induct as arbitrary: bs)
  case (Nil bs)
  from Nil(1) show ?case by (simp add: ge_refl)
next
  case (Cons a as bbs)
  from Cons(2) obtain b bs where bbs: "bbs = b # bs" and len: "length as = length bs" by (cases bbs, auto)
  note ge = Cons(3)[unfolded bbs]
  {
    fix i
    assume "i < length bs"
    hence "Suc i < length (b # bs)" by simp
    from ge[OF this] have "as ! i \<ge> bs ! i" by simp
  }
  from Cons(1)[OF len this] have IH: "listsum as \<ge> listsum bs" .
  from ge[of 0] have ab: "a \<ge> b" by simp
  from ge_trans[OF plus_left_mono[OF ab] plus_right_mono[OF IH]]
  show ?case unfolding bbs  by simp
qed

lemma listsum_ge_0_nth: fixes xs :: "('a :: ordered_semiring_0)list"
  assumes ge: "\<And> i. i < length xs \<Longrightarrow> xs ! i \<ge> 0"
  shows "listsum xs \<ge> 0"
proof -
  let ?l = "replicate  (length xs) (0 :: 'a)"
  have "length xs = length ?l" by simp
  from listsum_ge_mono[OF this] ge have "listsum xs \<ge> listsum ?l" by simp
  also have "listsum ?l = 0" using listsum_0[of ?l] by auto
  finally show ?thesis .
qed

lemma listsum_ge_0: fixes xs :: "('a :: ordered_semiring_0)list"
  assumes ge: "\<And> x. x \<in> set xs \<Longrightarrow> x \<ge> 0"
  shows "listsum xs \<ge> 0"
  by (rule listsum_ge_0_nth, insert ge[unfolded set_conv_nth], auto)

lemma foldr_max: "a \<in> set as \<Longrightarrow> foldr max as b \<ge> (a :: 'a :: ordered_ab_semigroup)"
proof (induct as arbitrary: b)
  case Nil thus ?case by simp
next
  case (Cons c as)
  show ?case
  proof (cases "a = c")
    case True
    show ?thesis unfolding True by auto
  next
    case False
    with Cons have "foldr max as b \<ge> a" by auto
    from ge_trans[OF _ this] show ?thesis by auto
  qed
qed

lemma of_nat_mono[intro]: assumes "n \<ge> m" shows "(of_nat n :: 'a :: ordered_semiring_1) \<ge> of_nat m"
proof -
  let ?n = "of_nat :: nat \<Rightarrow> 'a"
  from assms
  show ?thesis
  proof (induct m arbitrary: n)
    case 0
    show ?case by auto
  next
    case (Suc m nn)
    then obtain n where nn: "nn = Suc n" by (cases nn, auto)
    note Suc = Suc[unfolded nn]
    hence rec: "?n n \<ge> ?n m" by simp
    show ?case unfolding nn of_nat_Suc
      by (rule plus_right_mono[OF rec])
  qed
qed

text {* non infinitesmal is the same as in the CADE07 bounded increase paper *}

definition non_inf :: "'a rel \<Rightarrow> bool"
 where "non_inf r \<equiv> \<forall> a f. \<exists> i. (f i, f (Suc i)) \<notin> r \<or> (f i, a) \<notin> r"

lemma non_infI[intro]: assumes "\<And> a f. \<lbrakk> \<And> i. (f i, f (Suc i)) \<in> r\<rbrakk> \<Longrightarrow> \<exists> i. (f i, a) \<notin> r"
  shows "non_inf r"
  using assms unfolding non_inf_def by blast

lemma non_infE[elim]: assumes "non_inf r" and "\<And> i. (f i, f (Suc i)) \<notin> r \<or> (f i, a) \<notin> r \<Longrightarrow> P"
  shows P
  using assms unfolding non_inf_def by blast

lemma non_inf_image:
  assumes ni: "non_inf r" and image: "\<And> a b. (a,b) \<in> s \<Longrightarrow> (f a, f b) \<in> r"
  shows "non_inf s"
proof
  fix a g
  assume s: "\<And> i. (g i, g (Suc i)) \<in> s"
  def h \<equiv> "f o g"
  from image[OF s] have h: "\<And> i. (h i, h (Suc i)) \<in> r" unfolding h_def comp_def .
  from non_infE[OF ni, of h] have "\<And> a. \<exists> i. (h i, a) \<notin> r" using h by blast
  thus "\<exists>i. (g i, a) \<notin> s" using image unfolding h_def comp_def by blast
qed

lemma SN_imp_non_inf: "SN r \<Longrightarrow> non_inf r"
  by (intro non_infI, auto)

lemma non_inf_imp_SN_bound: "non_inf r \<Longrightarrow> SN {(a,b). (b,c) \<in> r \<and> (a,b) \<in> r}"
  by (rule, auto)

end


theory Collecting
imports Complete_Lattice Big_Step ACom
begin

subsection "The generic Step function"

notation
  sup (infixl "\<squnion>" 65) and
  inf (infixl "\<sqinter>" 70) and
  bot ("\<bottom>") and
  top ("\<top>")

context
  fixes f :: "vname \<Rightarrow> aexp \<Rightarrow> 'a \<Rightarrow> 'a::sup"
  fixes g :: "bexp \<Rightarrow> 'a \<Rightarrow> 'a"
begin
fun Step :: "'a \<Rightarrow> 'a acom \<Rightarrow> 'a acom" where
"Step S (SKIP {Q}) = (SKIP {S})" |
"Step S (x ::= e {Q}) =
  x ::= e {f x e S}" |
"Step S (C1;; C2) = Step S C1;; Step (post C1) C2" |
"Step S (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) =
  IF b THEN {g b S} Step P1 C1 ELSE {g (Not b) S} Step P2 C2
  {post C1 \<squnion> post C2}" |
"Step S ({I} WHILE b DO {P} C {Q}) =
  {S \<squnion> post C} WHILE b DO {g b I} Step P C {g (Not b) I}"
end

lemma strip_Step[simp]: "strip(Step f g S C) = strip C"
by(induct C arbitrary: S) auto

subsection "Collecting Semantics of Commands"

subsubsection "Annotated commands as a complete lattice"

instantiation acom :: (order) order
begin

definition less_eq_acom :: "('a::order)acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"C1 \<le> C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p \<le> anno C2 p)"

definition less_acom :: "'a acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"less_acom x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof (standard, goal_cases)
  case 1 show ?case by(simp add: less_acom_def)
next
  case 2 thus ?case by(auto simp: less_eq_acom_def)
next
  case 3 thus ?case by(fastforce simp: less_eq_acom_def size_annos)
next
  case 4 thus ?case
    by(fastforce simp: le_antisym less_eq_acom_def size_annos
         eq_acom_iff_strip_anno)
qed

end

lemma less_eq_acom_annos:
  "C1 \<le> C2 \<longleftrightarrow> strip C1 = strip C2 \<and> list_all2 (op \<le>) (annos C1) (annos C2)"
by(auto simp add: less_eq_acom_def anno_def list_all2_conv_all_nth size_annos_same2)

lemma SKIP_le[simp]: "SKIP {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = SKIP {S'} \<and> S \<le> S')"
by (cases c) (auto simp:less_eq_acom_def anno_def)

lemma Assign_le[simp]: "x ::= e {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = x ::= e {S'} \<and> S \<le> S')"
by (cases c) (auto simp:less_eq_acom_def anno_def)

lemma Seq_le[simp]: "C1;;C2 \<le> C \<longleftrightarrow> (\<exists>C1' C2'. C = C1';;C2' \<and> C1 \<le> C1' \<and> C2 \<le> C2')"
apply (cases C)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

lemma If_le[simp]: "IF b THEN {p1} C1 ELSE {p2} C2 {S} \<le> C \<longleftrightarrow>
  (\<exists>p1' p2' C1' C2' S'. C = IF b THEN {p1'} C1' ELSE {p2'} C2' {S'} \<and>
     p1 \<le> p1' \<and> p2 \<le> p2' \<and> C1 \<le> C1' \<and> C2 \<le> C2' \<and> S \<le> S')"
apply (cases C)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

lemma While_le[simp]: "{I} WHILE b DO {p} C {P} \<le> W \<longleftrightarrow>
  (\<exists>I' p' C' P'. W = {I'} WHILE b DO {p'} C' {P'} \<and> C \<le> C' \<and> p \<le> p' \<and> I \<le> I' \<and> P \<le> P')"
apply (cases W)
apply(auto simp: less_eq_acom_annos list_all2_append size_annos_same2)
done

lemma mono_post: "C \<le> C' \<Longrightarrow> post C \<le> post C'"
using annos_ne[of C']
by(auto simp: post_def less_eq_acom_def last_conv_nth[OF annos_ne] anno_def
     dest: size_annos_same)

definition Inf_acom :: "com \<Rightarrow> 'a::complete_lattice acom set \<Rightarrow> 'a acom" where
"Inf_acom c M = annotate (\<lambda>p. INF C:M. anno C p) c"

global_interpretation
  Complete_Lattice "{C. strip C = c}" "Inf_acom c" for c
proof (standard, goal_cases)
  case 1 thus ?case
    by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_lower)
next
  case 2 thus ?case
    by(auto simp: Inf_acom_def less_eq_acom_def size_annos intro:INF_greatest)
next
  case 3 thus ?case by(auto simp: Inf_acom_def)
qed

subsubsection "Collecting semantics"

definition "step = Step (\<lambda>x e S. {s(x := aval e s) |s. s : S}) (\<lambda>b S. {s:S. bval b s})"

definition CS :: "com \<Rightarrow> state set acom" where
"CS c = lfp c (step UNIV)"

lemma mono2_Step: fixes C1 C2 :: "'a::semilattice_sup acom"
  assumes "!!x e S1 S2. S1 \<le> S2 \<Longrightarrow> f x e S1 \<le> f x e S2"
          "!!b S1 S2. S1 \<le> S2 \<Longrightarrow> g b S1 \<le> g b S2"
  shows "C1 \<le> C2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> Step f g S1 C1 \<le> Step f g S2 C2"
proof(induction S1 C1 arbitrary: C2 S2 rule: Step.induct)
  case 1 thus ?case by(auto)
next
  case 2 thus ?case by (auto simp: assms(1))
next
  case 3 thus ?case by(auto simp: mono_post)
next
  case 4 thus ?case
    by(auto simp: subset_iff assms(2))
      (metis mono_post le_supI1 le_supI2)+
next
  case 5 thus ?case
    by(auto simp: subset_iff assms(2))
      (metis mono_post le_supI1 le_supI2)+
qed

lemma mono2_step: "C1 \<le> C2 \<Longrightarrow> S1 \<subseteq> S2 \<Longrightarrow> step S1 C1 \<le> step S2 C2"
unfolding step_def by(rule mono2_Step) auto

lemma mono_step: "mono (step S)"
by(blast intro: monoI mono2_step)

lemma strip_step: "strip(step S C) = strip C"
by (induction C arbitrary: S) (auto simp: step_def)

lemma lfp_cs_unfold: "lfp c (step S) = step S (lfp c (step S))"
apply(rule lfp_unfold[OF _  mono_step])
apply(simp add: strip_step)
done

lemma CS_unfold: "CS c = step UNIV (CS c)"
by (metis CS_def lfp_cs_unfold)

lemma strip_CS[simp]: "strip(CS c) = c"
by(simp add: CS_def index_lfp[simplified])

subsubsection "Relation to big-step semantics"

lemma asize_nz: "asize(c::com) \<noteq> 0"
by (metis length_0_conv length_annos_annotate annos_ne)

lemma post_Inf_acom:
  "\<forall>C\<in>M. strip C = c \<Longrightarrow> post (Inf_acom c M) = \<Inter>(post ` M)"
apply(subgoal_tac "\<forall>C\<in>M. size(annos C) = asize c")
 apply(simp add: post_anno_asize Inf_acom_def asize_nz neq0_conv[symmetric])
apply(simp add: size_annos)
done

lemma post_lfp: "post(lfp c f) = (\<Inter>{post C|C. strip C = c \<and> f C \<le> C})"
by(auto simp add: lfp_def post_Inf_acom)

lemma big_step_post_step:
  "\<lbrakk> (c, s) \<Rightarrow> t;  strip C = c;  s \<in> S;  step S C \<le> C \<rbrakk> \<Longrightarrow> t \<in> post C"
proof(induction arbitrary: C S rule: big_step_induct)
  case Skip thus ?case by(auto simp: strip_eq_SKIP step_def post_def)
next
  case Assign thus ?case
    by(fastforce simp: strip_eq_Assign step_def post_def)
next
  case Seq thus ?case
    by(fastforce simp: strip_eq_Seq step_def post_def last_append annos_ne)
next
  case IfTrue thus ?case apply(auto simp: strip_eq_If step_def post_def)
    by (metis (lifting,full_types) mem_Collect_eq set_mp)
next
  case IfFalse thus ?case apply(auto simp: strip_eq_If step_def post_def)
    by (metis (lifting,full_types) mem_Collect_eq set_mp)
next
  case (WhileTrue b s1 c' s2 s3)
  from WhileTrue.prems(1) obtain I P C' Q where "C = {I} WHILE b DO {P} C' {Q}" "strip C' = c'"
    by(auto simp: strip_eq_While)
  from WhileTrue.prems(3) `C = _`
  have "step P C' \<le> C'"  "{s \<in> I. bval b s} \<le> P"  "S \<le> I"  "step (post C') C \<le> C"
    by (auto simp: step_def post_def)
  have "step {s \<in> I. bval b s} C' \<le> C'"
    by (rule order_trans[OF mono2_step[OF order_refl `{s \<in> I. bval b s} \<le> P`] `step P C' \<le> C'`])
  have "s1: {s:I. bval b s}" using `s1 \<in> S` `S \<subseteq> I` `bval b s1` by auto
  note s2_in_post_C' = WhileTrue.IH(1)[OF `strip C' = c'` this `step {s \<in> I. bval b s} C' \<le> C'`]
  from WhileTrue.IH(2)[OF WhileTrue.prems(1) s2_in_post_C' `step (post C') C \<le> C`]
  show ?case .
next
  case (WhileFalse b s1 c') thus ?case
    by (force simp: strip_eq_While step_def post_def)
qed

lemma big_step_lfp: "\<lbrakk> (c,s) \<Rightarrow> t;  s \<in> S \<rbrakk> \<Longrightarrow> t \<in> post(lfp c (step S))"
by(auto simp add: post_lfp intro: big_step_post_step)

lemma big_step_CS: "(c,s) \<Rightarrow> t \<Longrightarrow> t : post(CS c)"
by(simp add: CS_def big_step_lfp)

end


(*  Title:       Executable multivariate polynomials
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2010 Christian Sternagel and René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section \<open>Strongly Normalizing Orders\<close>

theory SN_Orders
imports Abstract_Rewriting
begin

text \<open>
We define several classes of orders which are used to build ordered semirings.
Note that we do not use Isabelle's preorders since the condition
   $x > y = x \geq y \wedge  y \not\geq x$
   is sometimes not applicable. E.g., for $\delta$-orders over the rationals
   we have $0.2 \geq 0.1 \wedge 0.1 \not\geq 0.2$, but $0.2 >_\delta 0.1$ does not
   hold if $\delta$ is larger than $0.1$.
\<close>
class non_strict_order = ord +
  assumes ge_refl: "x \<ge> (x :: 'a)"
  and ge_trans[trans]: "\<lbrakk>x \<ge> y; (y :: 'a) \<ge> z\<rbrakk> \<Longrightarrow> x \<ge> z"
  and max_comm: "max x y = max y x"
  and max_ge_x[intro]: "max x y \<ge> x"
  and max_id: "x \<ge> y \<Longrightarrow> max x y = x"
  and max_mono: "x \<ge> y \<Longrightarrow> max z x \<ge> max z y"
begin
lemma max_ge_y[intro]: "max x y \<ge> y"
  unfolding max_comm[of x y] ..

lemma max_mono2: "x \<ge> y \<Longrightarrow> max x z \<ge> max y z"
  unfolding max_comm[of _ z] by (rule max_mono)
end

class ordered_ab_semigroup = non_strict_order + ab_semigroup_add + monoid_add +
  assumes plus_left_mono: "x \<ge> y \<Longrightarrow>  x + z \<ge> y + z"

lemma plus_right_mono: "y \<ge> (z :: 'a :: ordered_ab_semigroup) \<Longrightarrow> x + y \<ge> x + z"
  by (simp add: add.commute[of x], rule plus_left_mono, auto)

class ordered_semiring_0 = ordered_ab_semigroup + semiring_0 +
 assumes times_left_mono: "z \<ge> 0 \<Longrightarrow> x \<ge> y \<Longrightarrow> x * z \<ge> y * z"
     and times_right_mono: "x \<ge> 0 \<Longrightarrow> y \<ge> z \<Longrightarrow> x * y \<ge> x * z"
     and times_left_anti_mono: "x \<ge> y \<Longrightarrow> 0 \<ge> z \<Longrightarrow> y * z \<ge> x * z"

class ordered_semiring_1 = ordered_semiring_0 + semiring_1 +
  assumes one_ge_zero: "1 \<ge> 0"

text \<open>
   We do not use a class to define order-pairs of a strict and a weak-order
   since often we
   have parametric strict orders, e.g. on rational numbers there are several orders
   $>$ where $x > y = x \geq y + \delta$ for some parameter $\delta$
\<close>
locale order_pair =
  fixes gt :: "'a :: {non_strict_order,zero} \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succ>" 50)
  and default :: "'a"
  assumes compat[trans]: "\<lbrakk>x \<ge> y; y \<succ> z\<rbrakk> \<Longrightarrow> x \<succ> z"
  and compat2[trans]: "\<lbrakk>x \<succ> y; y \<ge> z\<rbrakk> \<Longrightarrow> x \<succ> z"
  and gt_imp_ge: "x \<succ> y \<Longrightarrow> x \<ge> y"
  and default_ge_zero: "default \<ge> 0"
begin
lemma gt_trans[trans]: "\<lbrakk>x \<succ> y; y \<succ> z\<rbrakk> \<Longrightarrow> x \<succ> z"
  by (rule compat[OF gt_imp_ge])
end

locale one_mono_ordered_semiring_1 = order_pair gt
  for gt :: "'a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succ>" 50) +
  assumes plus_gt_left_mono: "x \<succ> y \<Longrightarrow> x + z \<succ> y + z"
  and default_gt_zero: "default \<succ> 0"
begin

lemma plus_gt_both_mono: "x \<succ> y \<Longrightarrow> a \<succ> b \<Longrightarrow> x + a \<succ> y + b"
  by (rule gt_trans[OF plus_gt_left_mono plus_gt_right_mono])
end

locale SN_one_mono_ordered_semiring_1 = one_mono_ordered_semiring_1 + order_pair +
  assumes SN: "SN {(x,y) . y \<ge> 0 \<and> x \<succ> y}"

locale SN_strict_mono_ordered_semiring_1 = SN_one_mono_ordered_semiring_1 +
  fixes mono :: "'a :: ordered_semiring_1 \<Rightarrow> bool"
  assumes mono: "\<lbrakk>mono x; y \<succ> z; x \<ge> 0\<rbrakk> \<Longrightarrow> x * y \<succ> x * z"

locale both_mono_ordered_semiring_1 = order_pair gt
  for gt :: "'a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succ>" 50) +
  fixes arc_pos :: "'a \<Rightarrow> bool"
  assumes plus_gt_both_mono: "\<lbrakk>x \<succ> y; z \<succ> u\<rbrakk> \<Longrightarrow> x + z \<succ> y + u"
  and times_gt_left_mono: "x \<succ> y \<Longrightarrow> x * z \<succ> y * z"
  and times_gt_right_mono: "y \<succ> z \<Longrightarrow> x * y \<succ> x * z"
  and zero_leastI: "x \<succ> 0"
  and zero_leastII: "0 \<succ> x \<Longrightarrow> x = 0"
  and zero_leastIII: "(x :: 'a) \<ge> 0"
  and arc_pos_one: "arc_pos (1 :: 'a)"
  and arc_pos_default: "arc_pos default"
  and arc_pos_zero: "\<not> arc_pos 0"
  and arc_pos_plus: "arc_pos x \<Longrightarrow> arc_pos (x + y)"
  and arc_pos_mult: "\<lbrakk>arc_pos x; arc_pos y\<rbrakk> \<Longrightarrow> arc_pos (x * y)"
  and not_all_ge: "\<And> c d. arc_pos d \<Longrightarrow> \<exists> e. e \<ge> 0 \<and> arc_pos e \<and> \<not> (c \<ge> d * e)"
begin
lemma max0_id: "max 0 (x :: 'a) = x"
  unfolding max_comm[of 0]
  by (rule max_id[OF zero_leastIII])
end

locale SN_both_mono_ordered_semiring_1 = both_mono_ordered_semiring_1 +
  assumes SN: "SN {(x,y) . arc_pos y \<and> x \<succ> y}"

locale weak_SN_strict_mono_ordered_semiring_1 =
  fixes weak_gt :: "'a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool"
   and  default :: "'a"
   and  mono :: "'a \<Rightarrow> bool"
  assumes weak_gt_mono: "\<forall> x y. (x,y) \<in> set xys \<longrightarrow> weak_gt x y \<Longrightarrow> \<exists> gt. SN_strict_mono_ordered_semiring_1  default gt mono \<and> (\<forall> x y. (x,y) \<in> set xys \<longrightarrow> gt x y)"

locale weak_SN_both_mono_ordered_semiring_1 =
  fixes weak_gt :: "'a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool"
   and  default :: "'a"
   and  arc_pos :: "'a \<Rightarrow> bool"
  assumes weak_gt_both_mono: "\<forall> x y. (x,y) \<in> set xys \<longrightarrow> weak_gt x y \<Longrightarrow> \<exists> gt. SN_both_mono_ordered_semiring_1 default gt arc_pos \<and> (\<forall> x y. (x,y) \<in> set xys \<longrightarrow> gt x y)"

class poly_carrier = ordered_semiring_1 + comm_semiring_1

locale poly_order_carrier = SN_one_mono_ordered_semiring_1 default gt
  for default :: "'a :: poly_carrier" and gt (infix "\<succ>" 50) +
  fixes power_mono :: "bool"
  and   discrete :: "bool"
  assumes times_gt_mono: "\<lbrakk>y \<succ> z; x \<ge> 1\<rbrakk> \<Longrightarrow> y * x \<succ> z * x"
  and power_mono: "power_mono \<Longrightarrow> x \<succ> y \<Longrightarrow> y \<ge> 0 \<Longrightarrow> n \<ge> 1 \<Longrightarrow> x ^ n \<succ> y ^ n"
  and discrete: "discrete \<Longrightarrow> x \<ge> y \<Longrightarrow> \<exists> k. x = (((+) 1)^^k) y"

class large_ordered_semiring_1 = poly_carrier +
  assumes ex_large_of_nat: "\<exists> x. of_nat x \<ge> y"

context ordered_semiring_1
begin
lemma pow_mono: assumes ab: "a \<ge> b" and b: "b \<ge> 0"
  shows "a ^ n \<ge> b ^ n \<and> b ^ n \<ge> 0"
proof (induct n)
  case 0
  show ?case by (auto simp: ge_refl one_ge_zero)
next
  case (Suc n)
  hence abn: "a ^ n \<ge> b ^ n" and bn: "b ^ n \<ge> 0" by auto
  have bsn: "b ^ Suc n \<ge> 0" unfolding power_Suc
    using times_left_mono[OF bn b] by auto
  have "a ^ Suc n = a * a ^ n" unfolding power_Suc by simp
  also have "... \<ge> b * a ^ n"
    by (rule times_left_mono[OF ge_trans[OF abn bn] ab])
  also have "b * a ^ n \<ge> b * b ^ n"
    by (rule times_right_mono[OF b abn])
  finally show ?case using bsn unfolding power_Suc by simp
qed

lemma pow_ge_zero[intro]: assumes a: "a \<ge> (0 :: 'a)"
  shows "a ^ n \<ge> 0"
proof (induct n)
  case 0
  from one_ge_zero show ?case by simp
next
  case (Suc n)
  show ?case using times_left_mono[OF Suc a] by simp
qed
end

lemma of_nat_ge_zero[intro,simp]: "of_nat n \<ge> (0 :: 'a :: ordered_semiring_1)"
proof (induct n)
  case 0
  show ?case by (simp add: ge_refl)
next
  case (Suc n)
  from plus_right_mono[OF Suc, of 1] have "of_nat (Suc n) \<ge> (1 :: 'a)" by simp
  also have "(1 :: 'a) \<ge> 0" using one_ge_zero .
  finally show ?case .
qed

lemma mult_ge_zero[intro]: "(a :: 'a :: ordered_semiring_1) \<ge> 0 \<Longrightarrow> b \<ge> 0 \<Longrightarrow> a * b \<ge> 0"
  using times_left_mono[of b 0 a] by auto

lemma pow_mono_one: assumes a: "a \<ge> (1 :: 'a :: ordered_semiring_1)"
  shows "a ^ n \<ge> 1"
proof (induct n)
  case (Suc n)
  show ?case unfolding power_Suc
    using ge_trans[OF times_right_mono[OF ge_trans[OF a one_ge_zero] Suc], of 1]
    a
    by (auto simp: field_simps)
qed (auto simp: ge_refl)

lemma pow_mono_exp: assumes a: "a \<ge> (1 :: 'a :: ordered_semiring_1)"
  shows "n \<ge> m \<Longrightarrow> a ^ n \<ge> a ^ m"
proof (induct m arbitrary: n)
  case 0
  show ?case using pow_mono_one[OF a] by auto
next
  case (Suc m nn)
  then obtain n where nn: "nn = Suc n" by (cases nn, auto)
  note Suc = Suc[unfolded nn]
  hence rec: "a ^ n \<ge> a ^ m" by auto
  show ?case unfolding nn power_Suc
    by (rule times_right_mono[OF ge_trans[OF a one_ge_zero] rec])
qed

lemma mult_ge_one[intro]: assumes a: "(a :: 'a :: ordered_semiring_1) \<ge> 1"
  and b: "b \<ge> 1"
  shows "a * b \<ge> 1"
proof -
  from ge_trans[OF b one_ge_zero] have b0: "b \<ge> 0" .
  from times_left_mono[OF b0 a] have "a * b \<ge> b" by simp
  from ge_trans[OF this b] show ?thesis .
qed

lemma sum_list_ge_mono: fixes as :: "('a :: ordered_semiring_0) list"
  assumes "length as = length bs"
  and "\<And> i. i < length bs \<Longrightarrow> as ! i \<ge> bs ! i"
  shows "sum_list as \<ge> sum_list bs"
  using assms
proof (induct as arbitrary: bs)
  case (Nil bs)
  from Nil(1) show ?case by (simp add: ge_refl)
next
  case (Cons a as bbs)
  from Cons(2) obtain b bs where bbs: "bbs = b # bs" and len: "length as = length bs" by (cases bbs, auto)
  note ge = Cons(3)[unfolded bbs]
  {
    fix i
    assume "i < length bs"
    hence "Suc i < length (b # bs)" by simp
    from ge[OF this] have "as ! i \<ge> bs ! i" by simp
  }
  from Cons(1)[OF len this] have IH: "sum_list as \<ge> sum_list bs" .
  from ge[of 0] have ab: "a \<ge> b" by simp
  from ge_trans[OF plus_left_mono[OF ab] plus_right_mono[OF IH]]
  show ?case unfolding bbs  by simp
qed

lemma sum_list_ge_0_nth: fixes xs :: "('a :: ordered_semiring_0)list"
  assumes ge: "\<And> i. i < length xs \<Longrightarrow> xs ! i \<ge> 0"
  shows "sum_list xs \<ge> 0"
proof -
  let ?l = "replicate  (length xs) (0 :: 'a)"
  have "length xs = length ?l" by simp
  from sum_list_ge_mono[OF this] ge have "sum_list xs \<ge> sum_list ?l" by simp
  also have "sum_list ?l = 0" using sum_list_0[of ?l] by auto
  finally show ?thesis .
qed

lemma sum_list_ge_0: fixes xs :: "('a :: ordered_semiring_0)list"
  assumes ge: "\<And> x. x \<in> set xs \<Longrightarrow> x \<ge> 0"
  shows "sum_list xs \<ge> 0"
  by (rule sum_list_ge_0_nth, insert ge[unfolded set_conv_nth], auto)

lemma foldr_max: "a \<in> set as \<Longrightarrow> foldr max as b \<ge> (a :: 'a :: ordered_ab_semigroup)"
proof (induct as arbitrary: b)
  case Nil thus ?case by simp
next
  case (Cons c as)
  show ?case
  proof (cases "a = c")
    case True
    show ?thesis unfolding True by auto
  next
    case False
    with Cons have "foldr max as b \<ge> a" by auto
    from ge_trans[OF _ this] show ?thesis by auto
  qed
qed

lemma of_nat_mono[intro]: assumes "n \<ge> m" shows "(of_nat n :: 'a :: ordered_semiring_1) \<ge> of_nat m"
proof -
  let ?n = "of_nat :: nat \<Rightarrow> 'a"
  from assms
  show ?thesis
  proof (induct m arbitrary: n)
    case 0
    show ?case by auto
  next
    case (Suc m nn)
    then obtain n where nn: "nn = Suc n" by (cases nn, auto)
    note Suc = Suc[unfolded nn]
    hence rec: "?n n \<ge> ?n m" by simp
    show ?case unfolding nn of_nat_Suc
      by (rule plus_right_mono[OF rec])
  qed
qed

text \<open>non infinitesmal is the same as in the CADE07 bounded increase paper\<close>

definition non_inf :: "'a rel \<Rightarrow> bool"
 where "non_inf r \<equiv> \<forall> a f. \<exists> i. (f i, f (Suc i)) \<notin> r \<or> (f i, a) \<notin> r"

lemma non_infI[intro]: assumes "\<And> a f. \<lbrakk> \<And> i. (f i, f (Suc i)) \<in> r\<rbrakk> \<Longrightarrow> \<exists> i. (f i, a) \<notin> r"
  shows "non_inf r"
  using assms unfolding non_inf_def by blast

lemma non_infE[elim]: assumes "non_inf r" and "\<And> i. (f i, f (Suc i)) \<notin> r \<or> (f i, a) \<notin> r \<Longrightarrow> P"
  shows P
  using assms unfolding non_inf_def by blast

lemma non_inf_image:
  assumes ni: "non_inf r" and image: "\<And> a b. (a,b) \<in> s \<Longrightarrow> (f a, f b) \<in> r"
  shows "non_inf s"
proof
  fix a g
  assume s: "\<And> i. (g i, g (Suc i)) \<in> s"
  define h where "h = f o g"
  from image[OF s] have h: "\<And> i. (h i, h (Suc i)) \<in> r" unfolding h_def comp_def .
  from non_infE[OF ni, of h] have "\<And> a. \<exists> i. (h i, a) \<notin> r" using h by blast
  thus "\<exists>i. (g i, a) \<notin> s" using image unfolding h_def comp_def by blast
qed

lemma SN_imp_non_inf: "SN r \<Longrightarrow> non_inf r"
  by (intro non_infI, auto)

lemma non_inf_imp_SN_bound: "non_inf r \<Longrightarrow> SN {(a,b). (b,c) \<in> r \<and> (a,b) \<in> r}"
  by (rule, auto)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Alignment With Definitions from HOL-Algebra\<close>
theory HOL_Algebra_Alignment_Orders
  imports
    "HOL-Algebra.Order"
    HOL_Alignment_Orders
begin

named_theorems HOL_Algebra_order_alignment

context equivalence
begin

lemma reflexive_on_carrier [HOL_Algebra_order_alignment]:
  "reflexive_on (carrier S) (.=)"
  by blast

lemma transitive_on_carrier [HOL_Algebra_order_alignment]:
  "transitive_on (carrier S) (.=)"
  using trans by blast

lemma preorder_on_carrier [HOL_Algebra_order_alignment]:
  "preorder_on (carrier S) (.=)"
  using reflexive_on_carrier transitive_on_carrier by blast

lemma symmetric_on_carrier [HOL_Algebra_order_alignment]:
  "symmetric_on (carrier S) (.=)"
  using sym by blast

lemma partial_equivalence_rel_on_carrier [HOL_Algebra_order_alignment]:
  "partial_equivalence_rel_on (carrier S) (.=)"
  using transitive_on_carrier symmetric_on_carrier by blast

lemma equivalence_rel_on_carrier [HOL_Algebra_order_alignment]:
  "equivalence_rel_on (carrier S) (.=)"
  using reflexive_on_carrier partial_equivalence_rel_on_carrier by blast

end

lemma equivalence_iff_equivalence_rel_on_carrier [HOL_Algebra_order_alignment]:
  "equivalence S \<longleftrightarrow> equivalence_rel_on (carrier S) (.=\<^bsub>S\<^esub>)"
  using equivalence.equivalence_rel_on_carrier
  by (blast dest: intro!: equivalence.intro dest: symmetric_onD transitive_onD)

context partial_order
begin

lemma reflexive_on_carrier [HOL_Algebra_order_alignment]:
  "reflexive_on (carrier L) (\<sqsubseteq>)"
  by blast

lemma transitive_on_carrier [HOL_Algebra_order_alignment]:
  "transitive_on (carrier L) (\<sqsubseteq>)"
  using le_trans by blast

lemma preorder_on_carrier [HOL_Algebra_order_alignment]:
  "preorder_on (carrier L) (\<sqsubseteq>)"
  using reflexive_on_carrier transitive_on_carrier by blast

lemma antisymmetric_on_carrier [HOL_Algebra_order_alignment]:
  "antisymmetric_on (carrier L) (\<sqsubseteq>)"
  by blast

lemma partial_order_on_carrier [HOL_Algebra_order_alignment]:
  "partial_order_on (carrier L) (\<sqsubseteq>)"
  using preorder_on_carrier antisymmetric_on_carrier by blast

end

end