(*  Title:      HOL/Auth/Kerberos_BAN.thy
    Author:     Giampaolo Bella, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section\<open>The Kerberos Protocol, BAN Version\<close>

theory Kerberos_BAN imports Public begin

text\<open>From page 251 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426

  Confidentiality (secrecy) and authentication properties are also
  given in a termporal version: strong guarantees in a little abstracted
  - but very realistic - model.
\<close>

(* Temporal model of accidents: session keys can be leaked
                                ONLY when they have expired *)

consts

    (*Duration of the session key*)
    sesKlife   :: nat

    (*Duration of the authenticator*)
    authlife :: nat

text\<open>The ticket should remain fresh for two journeys on the network at least\<close>
specification (sesKlife)
  sesKlife_LB [iff]: "2 \<le> sesKlife"
    by blast

text\<open>The authenticator only for one journey\<close>
specification (authlife)
  authlife_LB [iff]:    "authlife \<noteq> 0"
    by blast

abbreviation
  CT :: "event list \<Rightarrow> nat" where
  "CT == length "

abbreviation
  expiredK :: "[nat, event list] \<Rightarrow> bool" where
  "expiredK T evs == sesKlife + T < CT evs"

abbreviation
  expiredA :: "[nat, event list] \<Rightarrow> bool" where
  "expiredA T evs == authlife + T < CT evs"

definition
 (* A is the true creator of X if she has sent X and X never appeared on
    the trace before this event. Recall that traces grow from head. *)
  Issues :: "[agent, agent, msg, event list] \<Rightarrow> bool"
             ("_ Issues _ with _ on _") where
   "A Issues B with X on evs =
      (\<exists>Y. Says A B Y \<in> set evs \<and> X \<in> parts {Y} \<and>
        X \<notin> parts (spies (takeWhile (\<lambda>z. z  \<noteq> Says A B Y) (rev evs))))"

definition
 (* Yields the subtrace of a given trace from its beginning to a given event *)
  before :: "[event, event list] \<Rightarrow> event list" ("before _ on _")
  where "before ev on evs = takeWhile (\<lambda>z. z \<noteq> ev) (rev evs)"

definition
 (* States than an event really appears only once on a trace *)
  Unique :: "[event, event list] \<Rightarrow> bool" ("Unique _ on _")
  where "Unique ev on evs = (ev \<notin> set (tl (dropWhile (\<lambda>z. z \<noteq> ev) evs)))"

inductive_set bankerberos :: "event list set"
 where

   Nil:  "[] \<in> bankerberos"

 | Fake: "\<lbrakk> evsf \<in> bankerberos;  X \<in> synth (analz (spies evsf)) \<rbrakk>
          \<Longrightarrow> Says Spy B X # evsf \<in> bankerberos"

 | BK1:  "\<lbrakk> evs1 \<in> bankerberos \<rbrakk>
          \<Longrightarrow> Says A Server \<lbrace>Agent A, Agent B\<rbrace> # evs1
                \<in>  bankerberos"

 | BK2:  "\<lbrakk> evs2 \<in> bankerberos;  Key K \<notin> used evs2; K \<in> symKeys;
             Says A' Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs2 \<rbrakk>
          \<Longrightarrow> Says Server A
                (Crypt (shrK A)
                   \<lbrace>Number (CT evs2), Agent B, Key K,
                    (Crypt (shrK B) \<lbrace>Number (CT evs2), Agent A, Key K\<rbrace>)\<rbrace>)
                # evs2 \<in> bankerberos"

 | BK3:  "\<lbrakk> evs3 \<in> bankerberos;
             Says S A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
               \<in> set evs3;
             Says A Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs3;
             \<not> expiredK Tk evs3 \<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>Ticket, Crypt K \<lbrace>Agent A, Number (CT evs3)\<rbrace> \<rbrace>
               # evs3 \<in> bankerberos"

 | BK4:  "\<lbrakk> evs4 \<in> bankerberos;
             Says A' B \<lbrace>(Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>),
                         (Crypt K \<lbrace>Agent A, Number Ta\<rbrace>) \<rbrace> \<in> set evs4;
             \<not> expiredK Tk evs4;  \<not> expiredA Ta evs4 \<rbrakk>
          \<Longrightarrow> Says B A (Crypt K (Number Ta)) # evs4
                \<in> bankerberos"

        (*Old session keys may become compromised*)
 | Oops: "\<lbrakk> evso \<in> bankerberos;
         Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
               \<in> set evso;
             expiredK Tk evso \<rbrakk>
          \<Longrightarrow> Notes Spy \<lbrace>Number Tk, Key K\<rbrace> # evso \<in> bankerberos"

declare Says_imp_knows_Spy [THEN parts.Inj, dest]
declare parts.Body [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un [dest]

text\<open>A "possibility property": there are traces that reach the end.\<close>
lemma "\<lbrakk>Key K \<notin> used []; K \<in> symKeys\<rbrakk>
       \<Longrightarrow> \<exists>Timestamp. \<exists>evs \<in> bankerberos.
             Says B A (Crypt K (Number Timestamp))
                  \<in> set evs"
apply (cut_tac sesKlife_LB)
apply (intro exI bexI)
apply (rule_tac [2]
           bankerberos.Nil [THEN bankerberos.BK1, THEN bankerberos.BK2,
                             THEN bankerberos.BK3, THEN bankerberos.BK4])
apply (possibility, simp_all (no_asm_simp) add: used_Cons)
done

subsection\<open>Lemmas for reasoning about predicate "Issues"\<close>

lemma spies_Says_rev: "spies (evs @ [Says A B X]) = insert X (spies evs)"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
done

lemma spies_Gets_rev: "spies (evs @ [Gets A X]) = spies evs"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
done

lemma spies_Notes_rev: "spies (evs @ [Notes A X]) =
          (if A\<in>bad then insert X (spies evs) else spies evs)"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
done

lemma spies_evs_rev: "spies evs = spies (rev evs)"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a")
apply (simp_all (no_asm_simp) add: spies_Says_rev spies_Gets_rev spies_Notes_rev)
done

lemmas parts_spies_evs_revD2 = spies_evs_rev [THEN equalityD2, THEN parts_mono]

lemma spies_takeWhile: "spies (takeWhile P evs) \<subseteq> spies evs"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
txt\<open>Resembles \<open>used_subset_append\<close> in theory Event.\<close>
done

lemmas parts_spies_takeWhile_mono = spies_takeWhile [THEN parts_mono]

text\<open>Lemmas for reasoning about predicate "before"\<close>
lemma used_Says_rev: "used (evs @ [Says A B X]) = parts {X} \<union> (used evs)"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply auto
done

lemma used_Notes_rev: "used (evs @ [Notes A X]) = parts {X} \<union> (used evs)"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply auto
done

lemma used_Gets_rev: "used (evs @ [Gets B X]) = used evs"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply auto
done

lemma used_evs_rev: "used evs = used (rev evs)"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply (simp add: used_Says_rev)
apply (simp add: used_Gets_rev)
apply (simp add: used_Notes_rev)
done

lemma used_takeWhile_used [rule_format]:
      "x \<in> used (takeWhile P X) \<longrightarrow> x \<in> used X"
apply (induct_tac "X")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply (simp_all add: used_Nil)
apply (blast dest!: initState_into_used)+
done

lemma set_evs_rev: "set evs = set (rev evs)"
apply auto
done

lemma takeWhile_void [rule_format]:
      "x \<notin> set evs \<longrightarrow> takeWhile (\<lambda>z. z \<noteq> x) evs = evs"
apply auto
done

(**** Inductive proofs about bankerberos ****)

text\<open>Forwarding Lemma for reasoning about the encrypted portion of message BK3\<close>
lemma BK3_msg_in_parts_spies:
     "Says S A (Crypt KA \<lbrace>Timestamp, B, K, X\<rbrace>) \<in> set evs
      \<Longrightarrow> X \<in> parts (spies evs)"
apply blast
done

lemma Oops_parts_spies:
     "Says Server A (Crypt (shrK A) \<lbrace>Timestamp, B, K, X\<rbrace>) \<in> set evs
      \<Longrightarrow> K \<in> parts (spies evs)"
apply blast
done

text\<open>Spy never sees another agent's shared key! (unless it's bad at start)\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> bankerberos \<Longrightarrow> (Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"
apply (erule bankerberos.induct)
apply (frule_tac [7] Oops_parts_spies)
apply (frule_tac [5] BK3_msg_in_parts_spies, simp_all, blast+)
done

lemma Spy_analz_shrK [simp]:
     "evs \<in> bankerberos \<Longrightarrow> (Key (shrK A) \<in> analz (spies evs)) = (A \<in> bad)"
apply auto
done

lemma Spy_see_shrK_D [dest!]:
     "\<lbrakk> Key (shrK A) \<in> parts (spies evs);
                evs \<in> bankerberos \<rbrakk> \<Longrightarrow> A\<in>bad"
apply (blast dest: Spy_see_shrK)
done

lemmas Spy_analz_shrK_D = analz_subset_parts [THEN subsetD, THEN Spy_see_shrK_D,  dest!]

text\<open>Nobody can have used non-existent keys!\<close>
lemma new_keys_not_used [simp]:
    "\<lbrakk>Key K \<notin> used evs; K \<in> symKeys; evs \<in> bankerberos\<rbrakk>
     \<Longrightarrow> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule bankerberos.induct)
apply (frule_tac [7] Oops_parts_spies)
apply (frule_tac [5] BK3_msg_in_parts_spies, simp_all)
txt\<open>Fake\<close>
apply (force dest!: keysFor_parts_insert)
txt\<open>BK2, BK3, BK4\<close>
apply (force dest!: analz_shrK_Decrypt)+
done

subsection\<open>Lemmas concerning the form of items passed in messages\<close>

text\<open>Describes the form of K, X and K' when the Server sends this message.\<close>
lemma Says_Server_message_form:
     "\<lbrakk> Says Server A (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
         \<in> set evs; evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> K' = shrK A \<and> K \<notin> range shrK \<and>
          Ticket = (Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>) \<and>
          Key K \<notin> used(before
                  Says Server A (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
                  on evs) \<and>
          Tk = CT(before
                  Says Server A (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
                  on evs)"
unfolding before_def
apply (erule rev_mp)
apply (erule bankerberos.induct, simp_all add: takeWhile_tail)
apply auto
 apply (metis length_rev set_rev takeWhile_void used_evs_rev)+
done

text\<open>If the encrypted message appears then it originated with the Server
  PROVIDED that A is NOT compromised!
  This allows A to verify freshness of the session key.
\<close>
lemma Kab_authentic:
     "\<lbrakk> Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>
           \<in> parts (spies evs);
         A \<notin> bad;  evs \<in> bankerberos \<rbrakk>
       \<Longrightarrow> Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
             \<in> set evs"
apply (erule rev_mp)
apply (erule bankerberos.induct)
apply (frule_tac [7] Oops_parts_spies)
apply (frule_tac [5] BK3_msg_in_parts_spies, simp_all, blast)
done

text\<open>If the TICKET appears then it originated with the Server\<close>
text\<open>FRESHNESS OF THE SESSION KEY to B\<close>
lemma ticket_authentic:
     "\<lbrakk> Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace> \<in> parts (spies evs);
         B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
       \<Longrightarrow> Says Server A
            (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K,
                          Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>\<rbrace>)
           \<in> set evs"
apply (erule rev_mp)
apply (erule bankerberos.induct)
apply (frule_tac [7] Oops_parts_spies)
apply (frule_tac [5] BK3_msg_in_parts_spies, simp_all, blast)
done

text\<open>EITHER describes the form of X when the following message is sent,
  OR     reduces it to the Fake case.
  Use \<open>Says_Server_message_form\<close> if applicable.\<close>
lemma Says_S_message_form:
     "\<lbrakk> Says S A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
            \<in> set evs;
         evs \<in> bankerberos \<rbrakk>
 \<Longrightarrow> (K \<notin> range shrK \<and> X = (Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>))
          | X \<in> analz (spies evs)"
apply (case_tac "A \<in> bad")
apply (force dest!: Says_imp_spies [THEN analz.Inj])
apply (frule Says_imp_spies [THEN parts.Inj])
apply (blast dest!: Kab_authentic Says_Server_message_form)
done

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (spies evs)) \<Longrightarrow>
  Key K \<in> analz (spies evs)

 A more general formula must be proved inductively.

****)

text\<open>Session keys are not used to encrypt other session keys\<close>
lemma analz_image_freshK [rule_format (no_asm)]:
     "evs \<in> bankerberos \<Longrightarrow>
   \<forall>K KK. KK \<subseteq> - (range shrK) \<longrightarrow>
          (Key K \<in> analz (Key`KK \<union> (spies evs))) =
          (K \<in> KK | Key K \<in> analz (spies evs))"
apply (erule bankerberos.induct)
apply (drule_tac [7] Says_Server_message_form)
apply (erule_tac [5] Says_S_message_form [THEN disjE], analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
     "\<lbrakk> evs \<in> bankerberos;  KAB \<notin> range shrK \<rbrakk> \<Longrightarrow>
      (Key K \<in> analz (insert (Key KAB) (spies evs))) =
      (K = KAB | Key K \<in> analz (spies evs))"
apply (simp only: analz_image_freshK analz_image_freshK_simps)
done

text\<open>The session key K uniquely identifies the message\<close>
lemma unique_session_keys:
     "\<lbrakk> Says Server A
           (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>) \<in> set evs;
         Says Server A'
          (Crypt (shrK A') \<lbrace>Number Tk', Agent B', Key K, X'\<rbrace>) \<in> set evs;
         evs \<in> bankerberos \<rbrakk> \<Longrightarrow> A=A' \<and> Tk=Tk' \<and> B=B' \<and> X = X'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule bankerberos.induct)
apply (frule_tac [7] Oops_parts_spies)
apply (frule_tac [5] BK3_msg_in_parts_spies, simp_all)
txt\<open>BK2: it can't be a new key\<close>
apply blast
done

lemma Server_Unique:
     "\<lbrakk> Says Server A
            (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
        evs \<in> bankerberos \<rbrakk> \<Longrightarrow>
   Unique Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
   on evs"
apply (erule rev_mp, erule bankerberos.induct, simp_all add: Unique_def)
apply blast
done

subsection\<open>Non-temporal guarantees, explicitly relying on non-occurrence of
oops events - refined below by temporal guarantees\<close>

text\<open>Non temporal treatment of confidentiality\<close>

text\<open>Lemma: the session key sent in msg BK2 would be lost by oops
    if the spy could see it!\<close>
lemma lemma_conf [rule_format (no_asm)]:
     "\<lbrakk> A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
  \<Longrightarrow> Says Server A
          (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K,
                            Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>\<rbrace>)
         \<in> set evs \<longrightarrow>
      Key K \<in> analz (spies evs) \<longrightarrow> Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<in> set evs"
apply (erule bankerberos.induct)
apply (frule_tac [7] Says_Server_message_form)
apply (frule_tac [5] Says_S_message_form [THEN disjE])
apply (simp_all (no_asm_simp) add: analz_insert_eq analz_insert_freshK pushes)
txt\<open>Fake\<close>
apply spy_analz
txt\<open>BK2\<close>
apply (blast intro: parts_insertI)
txt\<open>BK3\<close>
apply (case_tac "Aa \<in> bad")
 prefer 2 apply (blast dest: Kab_authentic unique_session_keys)
apply (blast dest: Says_imp_spies [THEN analz.Inj] Crypt_Spy_analz_bad elim!: MPair_analz)
txt\<open>Oops\<close>
apply (blast dest: unique_session_keys)
done

text\<open>Confidentiality for the Server: Spy does not see the keys sent in msg BK2
as long as they have not expired.\<close>
lemma Confidentiality_S:
     "\<lbrakk> Says Server A
          (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (spies evs)"
apply (frule Says_Server_message_form, assumption)
apply (blast intro: lemma_conf)
done

text\<open>Confidentiality for Alice\<close>
lemma Confidentiality_A:
     "\<lbrakk> Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (spies evs)"
apply (blast dest!: Kab_authentic Confidentiality_S)
done

text\<open>Confidentiality for Bob\<close>
lemma Confidentiality_B:
     "\<lbrakk> Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
          \<in> parts (spies evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (spies evs)"
apply (blast dest!: ticket_authentic Confidentiality_S)
done

text\<open>Non temporal treatment of authentication\<close>

text\<open>Lemmas \<open>lemma_A\<close> and \<open>lemma_B\<close> in fact are common to both temporal and non-temporal treatments\<close>
lemma lemma_A [rule_format]:
     "\<lbrakk> A \<notin> bad; B \<notin> bad; evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow>
         Key K \<notin> analz (spies evs) \<longrightarrow>
         Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
         \<in> set evs \<longrightarrow>
          Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (spies evs) \<longrightarrow>
         Says A B \<lbrace>X, Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace>
             \<in> set evs"
apply (erule bankerberos.induct)
apply (frule_tac [7] Oops_parts_spies)
apply (frule_tac [5] Says_S_message_form)
apply (frule_tac [6] BK3_msg_in_parts_spies, analz_mono_contra)
apply (simp_all (no_asm_simp) add: all_conj_distrib)
txt\<open>Fake\<close>
apply blast
txt\<open>BK2\<close>
apply (force dest: Crypt_imp_invKey_keysFor)
txt\<open>BK3\<close>
apply (blast dest: Kab_authentic unique_session_keys)
done

lemma lemma_B [rule_format]:
     "\<lbrakk> B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (spies evs) \<longrightarrow>
          Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
          \<in> set evs \<longrightarrow>
          Crypt K (Number Ta) \<in> parts (spies evs) \<longrightarrow>
          Says B A (Crypt K (Number Ta)) \<in> set evs"
apply (erule bankerberos.induct)
apply (frule_tac [7] Oops_parts_spies)
apply (frule_tac [5] Says_S_message_form)
apply (drule_tac [6] BK3_msg_in_parts_spies, analz_mono_contra)
apply (simp_all (no_asm_simp) add: all_conj_distrib)
txt\<open>Fake\<close>
apply blast
txt\<open>BK2\<close>
apply (force dest: Crypt_imp_invKey_keysFor)
txt\<open>BK4\<close>
apply (blast dest: ticket_authentic unique_session_keys
                   Says_imp_spies [THEN analz.Inj] Crypt_Spy_analz_bad)
done

text\<open>The "r" suffix indicates theorems where the confidentiality assumptions are relaxed by the corresponding arguments.\<close>

text\<open>Authentication of A to B\<close>
lemma B_authenticates_A_r:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (spies evs);
         Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>  \<in> parts (spies evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                     Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
apply (blast dest!: ticket_authentic
          intro!: lemma_A
          elim!: Confidentiality_S [THEN [2] rev_notE])
done

text\<open>Authentication of B to A\<close>
lemma A_authenticates_B_r:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (spies evs);
        Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs"
apply (blast dest!: Kab_authentic
          intro!: lemma_B elim!: Confidentiality_S [THEN [2] rev_notE])
done

lemma B_authenticates_A:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (spies evs);
         Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>  \<in> parts (spies evs);
        Key K \<notin> analz (spies evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                     Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
apply (blast dest!: ticket_authentic intro!: lemma_A)
done

lemma A_authenticates_B:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (spies evs);
        Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs"
apply (blast dest!: Kab_authentic intro!: lemma_B)
done

subsection\<open>Temporal guarantees, relying on a temporal check that insures that
no oops event occurred. These are available in the sense of goal availability\<close>

text\<open>Temporal treatment of confidentiality\<close>

text\<open>Lemma: the session key sent in msg BK2 would be EXPIRED
    if the spy could see it!\<close>
lemma lemma_conf_temporal [rule_format (no_asm)]:
     "\<lbrakk> A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
  \<Longrightarrow> Says Server A
          (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K,
                            Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>\<rbrace>)
         \<in> set evs \<longrightarrow>
      Key K \<in> analz (spies evs) \<longrightarrow> expiredK Tk evs"
apply (erule bankerberos.induct)
apply (frule_tac [7] Says_Server_message_form)
apply (frule_tac [5] Says_S_message_form [THEN disjE])
apply (simp_all (no_asm_simp) add: less_SucI analz_insert_eq analz_insert_freshK pushes)
txt\<open>Fake\<close>
apply spy_analz
txt\<open>BK2\<close>
apply (blast intro: parts_insertI less_SucI)
txt\<open>BK3\<close>
apply (metis Crypt_Spy_analz_bad Kab_authentic Says_imp_analz_Spy
          Says_imp_parts_knows_Spy analz.Snd less_SucI unique_session_keys)
txt\<open>Oops: PROOF FAILS if unsafe intro below\<close>
apply (blast dest: unique_session_keys intro!: less_SucI)
done

text\<open>Confidentiality for the Server: Spy does not see the keys sent in msg BK2
as long as they have not expired.\<close>
lemma Confidentiality_S_temporal:
     "\<lbrakk> Says Server A
          (Crypt K' \<lbrace>Number T, Agent B, Key K, X\<rbrace>) \<in> set evs;
         \<not> expiredK T evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (spies evs)"
apply (frule Says_Server_message_form, assumption)
apply (blast intro: lemma_conf_temporal)
done

text\<open>Confidentiality for Alice\<close>
lemma Confidentiality_A_temporal:
     "\<lbrakk> Crypt (shrK A) \<lbrace>Number T, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
         \<not> expiredK T evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (spies evs)"
apply (blast dest!: Kab_authentic Confidentiality_S_temporal)
done

text\<open>Confidentiality for Bob\<close>
lemma Confidentiality_B_temporal:
     "\<lbrakk> Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
          \<in> parts (spies evs);
        \<not> expiredK Tk evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (spies evs)"
apply (blast dest!: ticket_authentic Confidentiality_S_temporal)
done

text\<open>Temporal treatment of authentication\<close>

text\<open>Authentication of A to B\<close>
lemma B_authenticates_A_temporal:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (spies evs);
         Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
         \<in> parts (spies evs);
         \<not> expiredK Tk evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                     Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
apply (blast dest!: ticket_authentic
          intro!: lemma_A
          elim!: Confidentiality_S_temporal [THEN [2] rev_notE])
done

text\<open>Authentication of B to A\<close>
lemma A_authenticates_B_temporal:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (spies evs);
         Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>
         \<in> parts (spies evs);
         \<not> expiredK Tk evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs"
apply (blast dest!: Kab_authentic
          intro!: lemma_B elim!: Confidentiality_S_temporal [THEN [2] rev_notE])
done

subsection\<open>Treatment of the key distribution goal using trace inspection. All
guarantees are in non-temporal form, hence non available, though their temporal
form is trivial to derive. These guarantees also convey a stronger form of
authentication - non-injective agreement on the session key\<close>

lemma B_Issues_A:
     "\<lbrakk> Says B A (Crypt K (Number Ta)) \<in> set evs;
         Key K \<notin> analz (spies evs);
         A \<notin> bad;  B \<notin> bad; evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> B Issues A with (Crypt K (Number Ta)) on evs"
unfolding Issues_def
apply (rule exI)
apply (rule conjI, assumption)
apply (simp (no_asm))
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule bankerberos.induct, analz_mono_contra)
apply (simp_all (no_asm_simp))
txt\<open>fake\<close>
apply blast
txt\<open>K4 obviously is the non-trivial case\<close>
apply (simp add: takeWhile_tail)
apply (blast dest: ticket_authentic parts_spies_takeWhile_mono [THEN subsetD] parts_spies_evs_revD2 [THEN subsetD] intro: A_authenticates_B_temporal)
done

lemma A_authenticates_and_keydist_to_B:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (spies evs);
        Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
         Key K \<notin> analz (spies evs);
         A \<notin> bad;  B \<notin> bad; evs \<in> bankerberos \<rbrakk>
      \<Longrightarrow> B Issues A with (Crypt K (Number Ta)) on evs"
apply (blast dest!: A_authenticates_B B_Issues_A)
done

lemma A_Issues_B:
     "\<lbrakk> Says A B \<lbrace>Ticket, Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace>
           \<in> set evs;
         Key K \<notin> analz (spies evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
   \<Longrightarrow> A Issues B with (Crypt K \<lbrace>Agent A, Number Ta\<rbrace>) on evs"
unfolding Issues_def
apply (rule exI)
apply (rule conjI, assumption)
apply (simp (no_asm))
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule bankerberos.induct, analz_mono_contra)
apply (simp_all (no_asm_simp))
txt\<open>fake\<close>
apply blast
txt\<open>K3 is the non trivial case\<close>
apply (simp add: takeWhile_tail)
apply auto (*Technically unnecessary, merely clarifies the subgoal as it is presemted in the book*)
apply (blast dest: Kab_authentic Says_Server_message_form parts_spies_takeWhile_mono [THEN subsetD] parts_spies_evs_revD2 [THEN subsetD]
             intro!: B_authenticates_A)
done

lemma B_authenticates_and_keydist_to_A:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (spies evs);
        Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>  \<in> parts (spies evs);
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerberos \<rbrakk>
   \<Longrightarrow> A Issues B with (Crypt K \<lbrace>Agent A, Number Ta\<rbrace>) on evs"
apply (blast dest: B_authenticates_A A_Issues_B)
done

end


(*  Title:      FOLP/IFOLP.thy
    Author:     Martin D Coen, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Intuitionistic First-Order Logic with Proofs\<close>

theory IFOLP
imports Pure
begin

ML_file \<open>~~/src/Tools/misc_legacy.ML\<close>

setup Pure_Thy.old_appl_syntax_setup
setup \<open>Proofterm.set_preproc (Proof_Rewrite_Rules.standard_preproc [])\<close>

class "term"
default_sort "term"

typedecl p
typedecl o

consts
      (*** Judgements ***)
 Proof          ::   "[o,p]=>prop"
 EqProof        ::   "[p,p,o]=>prop"    ("(3_ /= _ :/ _)" [10,10,10] 5)

      (*** Logical Connectives -- Type Formers ***)
 eq             ::      "['a,'a] => o"  (infixl "=" 50)
 True           ::      "o"
 False          ::      "o"
 conj           ::      "[o,o] => o"    (infixr "&" 35)
 disj           ::      "[o,o] => o"    (infixr "|" 30)
 imp            ::      "[o,o] => o"    (infixr "-->" 25)
      (*Quantifiers*)
 All            ::      "('a => o) => o"        (binder "ALL " 10)
 Ex             ::      "('a => o) => o"        (binder "EX " 10)
      (*Rewriting gadgets*)
 NORM           ::      "o => o"
 norm           ::      "'a => 'a"

      (*** Proof Term Formers: precedence must exceed 50 ***)
 tt             :: "p"
 contr          :: "p=>p"
 fst            :: "p=>p"
 snd            :: "p=>p"
 pair           :: "[p,p]=>p"           ("(1<_,/_>)")
 split          :: "[p, [p,p]=>p] =>p"
 inl            :: "p=>p"
 inr            :: "p=>p"
 "when"         :: "[p, p=>p, p=>p]=>p"
 lambda         :: "(p => p) => p"      (binder "lam " 55)
 App            :: "[p,p]=>p"           (infixl "`" 60)
 alll           :: "['a=>p]=>p"         (binder "all " 55)
 app            :: "[p,'a]=>p"          (infixl "^" 55)
 exists         :: "['a,p]=>p"          ("(1[_,/_])")
 xsplit         :: "[p,['a,p]=>p]=>p"
 ideq           :: "'a=>p"
 idpeel         :: "[p,'a=>p]=>p"
 nrm            :: p
 NRM            :: p

syntax "_Proof" :: "[p,o]=>prop"    ("(_ /: _)" [51, 10] 5)

parse_translation \<open>
  let fun proof_tr [p, P] = Syntax.const \<^const_syntax>\<open>Proof\<close> $ P $ p
  in [(\<^syntax_const>\<open>_Proof\<close>, K proof_tr)] end
\<close>

(*show_proofs = true displays the proof terms -- they are ENORMOUS*)
ML \<open>val show_proofs = Attrib.setup_config_bool \<^binding>\<open>show_proofs\<close> (K false)\<close>

print_translation \<open>
  let
    fun proof_tr' ctxt [P, p] =
      if Config.get ctxt show_proofs then Syntax.const \<^syntax_const>\<open>_Proof\<close> $ p $ P
      else P
  in [(\<^const_syntax>\<open>Proof\<close>, proof_tr')] end
\<close>

(**** Propositional logic ****)

(*Equality*)
(* Like Intensional Equality in MLTT - but proofs distinct from terms *)

axiomatization where
ieqI:      "ideq(a) : a=a" and
ieqE:      "[| p : a=b;  !!x. f(x) : P(x,x) |] ==> idpeel(p,f) : P(a,b)"

(* Truth and Falsity *)

axiomatization where
TrueI:     "tt : True" and
FalseE:    "a:False ==> contr(a):P"

(* Conjunction *)

axiomatization where
conjI:     "[| a:P;  b:Q |] ==> <a,b> : P&Q" and
conjunct1: "p:P&Q ==> fst(p):P" and
conjunct2: "p:P&Q ==> snd(p):Q"

(* Disjunction *)

axiomatization where
disjI1:    "a:P ==> inl(a):P|Q" and
disjI2:    "b:Q ==> inr(b):P|Q" and
disjE:     "[| a:P|Q;  !!x. x:P ==> f(x):R;  !!x. x:Q ==> g(x):R
           |] ==> when(a,f,g):R"

(* Implication *)

axiomatization where
impI:      "\<And>P Q f. (!!x. x:P ==> f(x):Q) ==> lam x. f(x):P-->Q" and
mp:        "\<And>P Q f. [| f:P-->Q;  a:P |] ==> f`a:Q"

(*Quantifiers*)

axiomatization where
allI:      "\<And>P. (!!x. f(x) : P(x)) ==> all x. f(x) : ALL x. P(x)" and
spec:      "\<And>P f. (f:ALL x. P(x)) ==> f^x : P(x)"

axiomatization where
exI:       "p : P(x) ==> [x,p] : EX x. P(x)" and
exE:       "[| p: EX x. P(x);  !!x u. u:P(x) ==> f(x,u) : R |] ==> xsplit(p,f):R"

(**** Equality between proofs ****)

axiomatization where
prefl:     "a : P ==> a = a : P" and
psym:      "a = b : P ==> b = a : P" and
ptrans:    "[| a = b : P;  b = c : P |] ==> a = c : P"

axiomatization where
idpeelB:   "[| !!x. f(x) : P(x,x) |] ==> idpeel(ideq(a),f) = f(a) : P(a,a)"

axiomatization where
fstB:      "a:P ==> fst(<a,b>) = a : P" and
sndB:      "b:Q ==> snd(<a,b>) = b : Q" and
pairEC:    "p:P&Q ==> p = <fst(p),snd(p)> : P&Q"

axiomatization where
whenBinl:  "[| a:P;  !!x. x:P ==> f(x) : Q |] ==> when(inl(a),f,g) = f(a) : Q" and
whenBinr:  "[| b:P;  !!x. x:P ==> g(x) : Q |] ==> when(inr(b),f,g) = g(b) : Q" and
plusEC:    "a:P|Q ==> when(a,%x. inl(x),%y. inr(y)) = a : P|Q"

axiomatization where
applyB:     "[| a:P;  !!x. x:P ==> b(x) : Q |] ==> (lam x. b(x)) ` a = b(a) : Q" and
funEC:      "f:P ==> f = lam x. f`x : P"

axiomatization where
specB:      "[| !!x. f(x) : P(x) |] ==> (all x. f(x)) ^ a = f(a) : P(a)"

(**** Definitions ****)

definition Not :: "o => o"  ("~ _" [40] 40)
  where not_def: "~P == P-->False"

definition iff :: "[o,o] => o"  (infixr "<->" 25)
  where "P<->Q == (P-->Q) & (Q-->P)"

(*Unique existence*)
definition Ex1 :: "('a => o) => o"  (binder "EX! " 10)
  where ex1_def: "EX! x. P(x) == EX x. P(x) & (ALL y. P(y) --> y=x)"

(*Rewriting -- special constants to flag normalized terms and formulae*)
axiomatization where
norm_eq: "nrm : norm(x) = x" and
NORM_iff:        "NRM : NORM(P) <-> P"

(*** Sequent-style elimination rules for & --> and ALL ***)

schematic_goal conjE:
  assumes "p:P&Q"
    and "!!x y.[| x:P; y:Q |] ==> f(x,y):R"
  shows "?a:R"
  apply (rule assms(2))
   apply (rule conjunct1 [OF assms(1)])
  apply (rule conjunct2 [OF assms(1)])
  done

schematic_goal impE:
  assumes "p:P-->Q"
    and "q:P"
    and "!!x. x:Q ==> r(x):R"
  shows "?p:R"
  apply (rule assms mp)+
  done

schematic_goal allE:
  assumes "p:ALL x. P(x)"
    and "!!y. y:P(x) ==> q(y):R"
  shows "?p:R"
  apply (rule assms spec)+
  done

(*Duplicates the quantifier; for use with eresolve_tac*)
schematic_goal all_dupE:
  assumes "p:ALL x. P(x)"
    and "!!y z.[| y:P(x); z:ALL x. P(x) |] ==> q(y,z):R"
  shows "?p:R"
  apply (rule assms spec)+
  done

(*** Negation rules, which translate between ~P and P-->False ***)

schematic_goal notI:
  assumes "!!x. x:P ==> q(x):False"
  shows "?p:~P"
  unfolding not_def
  apply (assumption | rule assms impI)+
  done

schematic_goal notE: "p:~P \<Longrightarrow> q:P \<Longrightarrow> ?p:R"
  unfolding not_def
  apply (drule (1) mp)
  apply (erule FalseE)
  done

(*This is useful with the special implication rules for each kind of P. *)
schematic_goal not_to_imp:
  assumes "p:~P"
    and "!!x. x:(P-->False) ==> q(x):Q"
  shows "?p:Q"
  apply (assumption | rule assms impI notE)+
  done

(* For substitution int an assumption P, reduce Q to P-->Q, substitute into
   this implication, then apply impI to move P back into the assumptions.*)
schematic_goal rev_mp: "[| p:P;  q:P --> Q |] ==> ?p:Q"
  apply (assumption | rule mp)+
  done

(*Contrapositive of an inference rule*)
schematic_goal contrapos:
  assumes major: "p:~Q"
    and minor: "!!y. y:P==>q(y):Q"
  shows "?a:~P"
  apply (rule major [THEN notE, THEN notI])
  apply (erule minor)
  done

(** Unique assumption tactic.
    Ignores proof objects.
    Fails unless one assumption is equal and exactly one is unifiable
**)

ML \<open>
local
  fun discard_proof \<^Const_>\<open>Proof for P _\<close> = P;
in
fun uniq_assume_tac ctxt =
  SUBGOAL
    (fn (prem,i) =>
      let val hyps = map discard_proof (Logic.strip_assums_hyp prem)
          and concl = discard_proof (Logic.strip_assums_concl prem)
      in
          if exists (fn hyp => hyp aconv concl) hyps
          then case distinct (op =) (filter (fn hyp => Term.could_unify (hyp, concl)) hyps) of
                   [_] => assume_tac ctxt i
                 |  _  => no_tac
          else no_tac
      end);
end;
\<close>

(*** Modus Ponens Tactics ***)

(*Finds P-->Q and P in the assumptions, replaces implication by Q *)
ML \<open>
  fun mp_tac ctxt i =
    eresolve_tac ctxt [@{thm notE}, make_elim @{thm mp}] i  THEN  assume_tac ctxt i
\<close>
method_setup mp = \<open>Scan.succeed (SIMPLE_METHOD' o mp_tac)\<close>

(*Like mp_tac but instantiates no variables*)
ML \<open>
  fun int_uniq_mp_tac ctxt i =
    eresolve_tac ctxt [@{thm notE}, @{thm impE}] i  THEN  uniq_assume_tac ctxt i
\<close>

(*** If-and-only-if ***)

schematic_goal iffI:
  assumes "!!x. x:P ==> q(x):Q"
    and "!!x. x:Q ==> r(x):P"
  shows "?p:P<->Q"
  unfolding iff_def
  apply (assumption | rule assms conjI impI)+
  done

schematic_goal iffE:
  assumes "p:P <-> Q"
    and "!!x y.[| x:P-->Q; y:Q-->P |] ==> q(x,y):R"
  shows "?p:R"
  apply (rule conjE)
   apply (rule assms(1) [unfolded iff_def])
  apply (rule assms(2))
   apply assumption+
  done

(* Destruct rules for <-> similar to Modus Ponens *)

schematic_goal iffD1: "[| p:P <-> Q; q:P |] ==> ?p:Q"
  unfolding iff_def
  apply (rule conjunct1 [THEN mp], assumption+)
  done

schematic_goal iffD2: "[| p:P <-> Q; q:Q |] ==> ?p:P"
  unfolding iff_def
  apply (rule conjunct2 [THEN mp], assumption+)
  done

schematic_goal iff_refl: "?p:P <-> P"
  apply (rule iffI)
   apply assumption+
  done

schematic_goal iff_sym: "p:Q <-> P ==> ?p:P <-> Q"
  apply (erule iffE)
  apply (rule iffI)
   apply (erule (1) mp)+
  done

schematic_goal iff_trans: "[| p:P <-> Q; q:Q<-> R |] ==> ?p:P <-> R"
  apply (rule iffI)
   apply (assumption | erule iffE | erule (1) impE)+
  done

(*** Unique existence.  NOTE THAT the following 2 quantifications
   EX!x such that [EX!y such that P(x,y)]     (sequential)
   EX!x,y such that P(x,y)                    (simultaneous)
 do NOT mean the same thing.  The parser treats EX!x y.P(x,y) as sequential.
***)

schematic_goal ex1I:
  assumes "p:P(a)"
    and "!!x u. u:P(x) ==> f(u) : x=a"
  shows "?p:EX! x. P(x)"
  unfolding ex1_def
  apply (assumption | rule assms exI conjI allI impI)+
  done

schematic_goal ex1E:
  assumes "p:EX! x. P(x)"
    and "!!x u v. [| u:P(x);  v:ALL y. P(y) --> y=x |] ==> f(x,u,v):R"
  shows "?a : R"
  apply (insert assms(1) [unfolded ex1_def])
  apply (erule exE conjE | assumption | rule assms(1))+
  apply (erule assms(2), assumption)
  done

(*** <-> congruence rules for simplification ***)

(*Use iffE on a premise.  For conj_cong, imp_cong, all_cong, ex_cong*)
ML \<open>
fun iff_tac ctxt prems i =
    resolve_tac ctxt (prems RL [@{thm iffE}]) i THEN
    REPEAT1 (eresolve_tac ctxt [asm_rl, @{thm mp}] i)
\<close>

method_setup iff =
  \<open>Attrib.thms >> (fn prems => fn ctxt => SIMPLE_METHOD' (iff_tac ctxt prems))\<close>

schematic_goal conj_cong:
  assumes "p:P <-> P'"
    and "!!x. x:P' ==> q(x):Q <-> Q'"
  shows "?p:(P&Q) <-> (P'&Q')"
  apply (insert assms(1))
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

schematic_goal disj_cong:
  "[| p:P <-> P'; q:Q <-> Q' |] ==> ?p:(P|Q) <-> (P'|Q')"
  apply (erule iffE disjE disjI1 disjI2 | assumption | rule iffI | mp)+
  done

schematic_goal imp_cong:
  assumes "p:P <-> P'"
    and "!!x. x:P' ==> q(x):Q <-> Q'"
  shows "?p:(P-->Q) <-> (P'-->Q')"
  apply (insert assms(1))
  apply (assumption | rule iffI impI | erule iffE | mp | iff assms)+
  done

schematic_goal iff_cong:
  "[| p:P <-> P'; q:Q <-> Q' |] ==> ?p:(P<->Q) <-> (P'<->Q')"
  apply (erule iffE | assumption | rule iffI | mp)+
  done

schematic_goal not_cong:
  "p:P <-> P' ==> ?p:~P <-> ~P'"
  apply (assumption | rule iffI notI | mp | erule iffE notE)+
  done

schematic_goal all_cong:
  assumes "!!x. f(x):P(x) <-> Q(x)"
  shows "?p:(ALL x. P(x)) <-> (ALL x. Q(x))"
  apply (assumption | rule iffI allI | mp | erule allE | iff assms)+
  done

schematic_goal ex_cong:
  assumes "!!x. f(x):P(x) <-> Q(x)"
  shows "?p:(EX x. P(x)) <-> (EX x. Q(x))"
  apply (erule exE | assumption | rule iffI exI | mp | iff assms)+
  done

(*NOT PROVED
ML_Thms.bind_thm ("ex1_cong", prove_goal (the_context ())
    "(!!x.f(x):P(x) <-> Q(x)) ==> ?p:(EX! x.P(x)) <-> (EX! x.Q(x))"
 (fn prems =>
  [ (REPEAT   (eresolve_tac [ex1E, spec RS mp] 1 ORELSE ares_tac [iffI,ex1I] 1
      ORELSE   mp_tac 1
      ORELSE   iff_tac prems 1)) ]))
*)

(*** Equality rules ***)

lemmas refl = ieqI

schematic_goal subst:
  assumes prem1: "p:a=b"
    and prem2: "q:P(a)"
  shows "?p : P(b)"
  apply (rule prem2 [THEN rev_mp])
  apply (rule prem1 [THEN ieqE])
  apply (rule impI)
  apply assumption
  done

schematic_goal sym: "q:a=b ==> ?c:b=a"
  apply (erule subst)
  apply (rule refl)
  done

schematic_goal trans: "[| p:a=b;  q:b=c |] ==> ?d:a=c"
  apply (erule (1) subst)
  done

(** ~ b=a ==> ~ a=b **)
schematic_goal not_sym: "p:~ b=a ==> ?q:~ a=b"
  apply (erule contrapos)
  apply (erule sym)
  done

schematic_goal ssubst: "p:b=a \<Longrightarrow> q:P(a) \<Longrightarrow> ?p:P(b)"
  apply (drule sym)
  apply (erule subst)
  apply assumption
  done

(*A special case of ex1E that would otherwise need quantifier expansion*)
schematic_goal ex1_equalsE: "[| p:EX! x. P(x);  q:P(a);  r:P(b) |] ==> ?d:a=b"
  apply (erule ex1E)
  apply (rule trans)
   apply (rule_tac [2] sym)
   apply (assumption | erule spec [THEN mp])+
  done

(** Polymorphic congruence rules **)

schematic_goal subst_context: "[| p:a=b |]  ==>  ?d:t(a)=t(b)"
  apply (erule ssubst)
  apply (rule refl)
  done

schematic_goal subst_context2: "[| p:a=b;  q:c=d |]  ==>  ?p:t(a,c)=t(b,d)"
  apply (erule ssubst)+
  apply (rule refl)
  done

schematic_goal subst_context3: "[| p:a=b;  q:c=d;  r:e=f |]  ==>  ?p:t(a,c,e)=t(b,d,f)"
  apply (erule ssubst)+
  apply (rule refl)
  done

(*Useful with eresolve_tac for proving equalties from known equalities.
        a = b
        |   |
        c = d   *)
schematic_goal box_equals: "[| p:a=b;  q:a=c;  r:b=d |] ==> ?p:c=d"
  apply (rule trans)
   apply (rule trans)
    apply (rule sym)
    apply assumption+
  done

(*Dual of box_equals: for proving equalities backwards*)
schematic_goal simp_equals: "[| p:a=c;  q:b=d;  r:c=d |] ==> ?p:a=b"
  apply (rule trans)
   apply (rule trans)
    apply (assumption | rule sym)+
  done

(** Congruence rules for predicate letters **)

schematic_goal pred1_cong: "p:a=a' ==> ?p:P(a) <-> P(a')"
  apply (rule iffI)
   apply (tactic \<open>
     DEPTH_SOLVE (assume_tac \<^context> 1 ORELSE eresolve_tac \<^context> [@{thm subst}, @{thm ssubst}] 1)\<close>)
  done

schematic_goal pred2_cong: "[| p:a=a';  q:b=b' |] ==> ?p:P(a,b) <-> P(a',b')"
  apply (rule iffI)
   apply (tactic \<open>
     DEPTH_SOLVE (assume_tac \<^context> 1 ORELSE eresolve_tac \<^context> [@{thm subst}, @{thm ssubst}] 1)\<close>)
  done

schematic_goal pred3_cong: "[| p:a=a';  q:b=b';  r:c=c' |] ==> ?p:P(a,b,c) <-> P(a',b',c')"
  apply (rule iffI)
   apply (tactic \<open>
     DEPTH_SOLVE (assume_tac \<^context> 1 ORELSE eresolve_tac \<^context> [@{thm subst}, @{thm ssubst}] 1)\<close>)
  done

lemmas pred_congs = pred1_cong pred2_cong pred3_cong

(*special case for the equality predicate!*)
lemmas eq_cong = pred2_cong [where P = "(=)"]

(*** Simplifications of assumed implications.
     Roy Dyckhoff has proved that conj_impE, disj_impE, and imp_impE
     used with mp_tac (restricted to atomic formulae) is COMPLETE for
     intuitionistic propositional logic.  See
   R. Dyckhoff, Contraction-free sequent calculi for intuitionistic logic
    (preprint, University of St Andrews, 1991)  ***)

schematic_goal conj_impE:
  assumes major: "p:(P&Q)-->S"
    and minor: "!!x. x:P-->(Q-->S) ==> q(x):R"
  shows "?p:R"
  apply (assumption | rule conjI impI major [THEN mp] minor)+
  done

schematic_goal disj_impE:
  assumes major: "p:(P|Q)-->S"
    and minor: "!!x y.[| x:P-->S; y:Q-->S |] ==> q(x,y):R"
  shows "?p:R"
  apply (tactic \<open>DEPTH_SOLVE (assume_tac \<^context> 1 ORELSE
      resolve_tac \<^context> [@{thm disjI1}, @{thm disjI2}, @{thm impI},
        @{thm major} RS @{thm mp}, @{thm minor}] 1)\<close>)
  done

(*Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since Q must be provable -- backtracking needed.  *)
schematic_goal imp_impE:
  assumes major: "p:(P-->Q)-->S"
    and r1: "!!x y.[| x:P; y:Q-->S |] ==> q(x,y):Q"
    and r2: "!!x. x:S ==> r(x):R"
  shows "?p:R"
  apply (assumption | rule impI major [THEN mp] r1 r2)+
  done

(*Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since ~P must be provable -- backtracking needed.  *)
schematic_goal not_impE:
  assumes major: "p:~P --> S"
    and r1: "!!y. y:P ==> q(y):False"
    and r2: "!!y. y:S ==> r(y):R"
  shows "?p:R"
  apply (assumption | rule notI impI major [THEN mp] r1 r2)+
  done

(*Simplifies the implication.   UNSAFE.  *)
schematic_goal iff_impE:
  assumes major: "p:(P<->Q)-->S"
    and r1: "!!x y.[| x:P; y:Q-->S |] ==> q(x,y):Q"
    and r2: "!!x y.[| x:Q; y:P-->S |] ==> r(x,y):P"
    and r3: "!!x. x:S ==> s(x):R"
  shows "?p:R"
  apply (assumption | rule iffI impI major [THEN mp] r1 r2 r3)+
  done

(*What if (ALL x.~~P(x)) --> ~~(ALL x.P(x)) is an assumption? UNSAFE*)
schematic_goal all_impE:
  assumes major: "p:(ALL x. P(x))-->S"
    and r1: "!!x. q:P(x)"
    and r2: "!!y. y:S ==> r(y):R"
  shows "?p:R"
  apply (assumption | rule allI impI major [THEN mp] r1 r2)+
  done

(*Unsafe: (EX x.P(x))-->S  is equivalent to  ALL x.P(x)-->S.  *)
schematic_goal ex_impE:
  assumes major: "p:(EX x. P(x))-->S"
    and r: "!!y. y:P(a)-->S ==> q(y):R"
  shows "?p:R"
  apply (assumption | rule exI impI major [THEN mp] r)+
  done

schematic_goal rev_cut_eq:
  assumes "p:a=b"
    and "!!x. x:a=b ==> f(x):R"
  shows "?p:R"
  apply (rule assms)+
  done

lemma thin_refl: "!!X. [|p:x=x; PROP W|] ==> PROP W" .

ML_file \<open>hypsubst.ML\<close>

ML \<open>
structure Hypsubst = Hypsubst
(
  (*Take apart an equality judgement; otherwise raise Match!*)
  fun dest_eq \<^Const_>\<open>Proof for \<^Const_>\<open>eq _ for t u\<close> _\<close> = (t, u);

  val imp_intr = @{thm impI}

  (*etac rev_cut_eq moves an equality to be the last premise. *)
  val rev_cut_eq = @{thm rev_cut_eq}

  val rev_mp = @{thm rev_mp}
  val subst = @{thm subst}
  val sym = @{thm sym}
  val thin_refl = @{thm thin_refl}
);
open Hypsubst;
\<close>

ML_file \<open>intprover.ML\<close>

(*** Rewrite rules ***)

schematic_goal conj_rews:
  "?p1 : P & True <-> P"
  "?p2 : True & P <-> P"
  "?p3 : P & False <-> False"
  "?p4 : False & P <-> False"
  "?p5 : P & P <-> P"
  "?p6 : P & ~P <-> False"
  "?p7 : ~P & P <-> False"
  "?p8 : (P & Q) & R <-> P & (Q & R)"
  apply (tactic \<open>fn st => IntPr.fast_tac \<^context> 1 st\<close>)+
  done

schematic_goal disj_rews:
  "?p1 : P | True <-> True"
  "?p2 : True | P <-> True"
  "?p3 : P | False <-> P"
  "?p4 : False | P <-> P"
  "?p5 : P | P <-> P"
  "?p6 : (P | Q) | R <-> P | (Q | R)"
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)+
  done

schematic_goal not_rews:
  "?p1 : ~ False <-> True"
  "?p2 : ~ True <-> False"
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)+
  done

schematic_goal imp_rews:
  "?p1 : (P --> False) <-> ~P"
  "?p2 : (P --> True) <-> True"
  "?p3 : (False --> P) <-> True"
  "?p4 : (True --> P) <-> P"
  "?p5 : (P --> P) <-> True"
  "?p6 : (P --> ~P) <-> ~P"
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)+
  done

schematic_goal iff_rews:
  "?p1 : (True <-> P) <-> P"
  "?p2 : (P <-> True) <-> P"
  "?p3 : (P <-> P) <-> True"
  "?p4 : (False <-> P) <-> ~P"
  "?p5 : (P <-> False) <-> ~P"
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)+
  done

schematic_goal quant_rews:
  "?p1 : (ALL x. P) <-> P"
  "?p2 : (EX x. P) <-> P"
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)+
  done

(*These are NOT supplied by default!*)
schematic_goal distrib_rews1:
  "?p1 : ~(P|Q) <-> ~P & ~Q"
  "?p2 : P & (Q | R) <-> P&Q | P&R"
  "?p3 : (Q | R) & P <-> Q&P | R&P"
  "?p4 : (P | Q --> R) <-> (P --> R) & (Q --> R)"
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)+
  done

schematic_goal distrib_rews2:
  "?p1 : ~(EX x. NORM(P(x))) <-> (ALL x. ~NORM(P(x)))"
  "?p2 : ((EX x. NORM(P(x))) --> Q) <-> (ALL x. NORM(P(x)) --> Q)"
  "?p3 : (EX x. NORM(P(x))) & NORM(Q) <-> (EX x. NORM(P(x)) & NORM(Q))"
  "?p4 : NORM(Q) & (EX x. NORM(P(x))) <-> (EX x. NORM(Q) & NORM(P(x)))"
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)+
  done

lemmas distrib_rews = distrib_rews1 distrib_rews2

schematic_goal P_Imp_P_iff_T: "p:P ==> ?p:(P <-> True)"
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)
  done

schematic_goal not_P_imp_P_iff_F: "p:~P ==> ?p:(P <-> False)"
  apply (tactic \<open>IntPr.fast_tac \<^context> 1\<close>)
  done

end


theory prop_12
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun map2 :: "('a => 'b) => 'a list => 'b list" where
  "map2 x (Nil2) = Nil2"
  | "map2 x (Cons2 z xs) = Cons2 (x z) (map2 x xs)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  (*hipster map2 drop *)
  theorem x0 :
    "(drop n (map2 f xs)) = (map2 f (drop n xs))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Subst
  imports Main Seq2less Subseq
begin

(* Substitutions of one element in a sequence *)

(* lt_all *)

lemma subst_lt_all:
  "le3 x y \<and> lt_all y t \<longrightarrow> lt_all x t"
  apply (induction t arbitrary: x y )
  apply simp
  by auto

lemma subst_first_lt_all:
  "le3 y x \<and> lt_all p (y#t) \<longrightarrow> lt_all p (x#t)"
  apply (induction t arbitrary: p x y )
  by auto

lemma subst_last_lt_all:
  "le3 y x \<and> lt_all p (s@[y]) \<longrightarrow> lt_all p (s@[x])"
  apply (induction s arbitrary: p x y )
  by auto

lemma subst_mid_lt_all:
  "le3 y x \<and> lt_all p (s@y#t) \<longrightarrow> lt_all p (s@x#t)"
  apply (induction s arbitrary: p x y )
  by auto

lemma subst_first_lt_all_1:
  "lt p x \<and> lt_all p (y#s) \<longrightarrow> lt_all p (x#s)"
  apply (induction s arbitrary: x y )
  by auto

lemma subst_last_lt_all_1:
  "lt p x \<and> lt_all p (s@[y]) \<longrightarrow> lt_all p (s@[x])"
  apply (induction s arbitrary: x y )
  by auto

lemma subst_mid_lt_all_1:
  "lt p x \<and> lt_all p (s@y#t) \<longrightarrow> lt_all p (s@x#t)"
  apply (induction s arbitrary: x y )
  by auto

(* is_2less *)

lemma subst_first_is_2less:
  "le3 x y \<and> is_2less (y#t) \<longrightarrow> is_2less (x#t)"
  apply (induction t arbitrary: x y )
  apply simp
  by auto

lemma subst_last_is_2less:
  "le3 y x \<and> is_2less (s@[y]) \<longrightarrow> is_2less (s@[x])"
  apply (induction s arbitrary: x y)
  apply simp
  using subseq_lt_all subst_last_lt_all
  by (metis append_Cons is_2less.simps(2))

lemma subst_mid_is_2less:
  "le3 x y \<and> gt_all x s \<and> is_2less (s@y#t) \<longrightarrow> is_2less (s@x#t)"
  apply (induction s arbitrary: x y)
  apply simp
  using subst_lt_all apply blast
  by (metis append_Cons gt_all.simps(2) is_2less.simps(2) subseq_remove_first subst_mid_lt_all_1)

lemma subst_first_is_2less_1:
  "lt_all x t \<and> is_2less (y#t) \<longrightarrow> is_2less (x#t)"
  apply (induction t arbitrary: x y )
  by auto

lemma subst_last_is_2less_1:
  "gt_all x s \<and> is_2less (s@[y]) \<longrightarrow> is_2less (s@[x])"
  apply (induction s arbitrary: x y)
  apply simp
  using subseq_prefix valid_candidate
  by blast

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)

theory More_MPoly_Type
imports MPoly_Type
begin

abbreviation "lookup == Poly_Mapping.lookup"
abbreviation "keys == Poly_Mapping.keys"

section "MPpoly Mapping extenion"

lemma lookup_Abs_poly_mapping_when_finite:
assumes "finite S"
shows "lookup (Abs_poly_mapping (\<lambda>x. f x when x\<in>S)) = (\<lambda>x. f x when x\<in>S)"
proof -
  have "finite {x. (f x when x\<in>S) \<noteq> 0}" using assms by auto
  then show ?thesis using lookup_Abs_poly_mapping by fast
qed

definition remove_key::"'a \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::monoid_add) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b)" where
  "remove_key k0 f = Abs_poly_mapping (\<lambda>k. lookup f k when k \<noteq> k0)"

lemma remove_key_lookup:
  "lookup (remove_key k0 f) k = (lookup f k when k \<noteq> k0)"
unfolding remove_key_def using finite_subset by (simp add: lookup_Abs_poly_mapping)

lemma remove_key_keys: "keys f - {k} = keys (remove_key k f)" (is "?A = ?B")
proof (rule antisym; rule subsetI)
  fix x assume "x \<in> ?A"
  then show "x \<in> ?B" using remove_key_lookup lookup_not_eq_zero_eq_in_keys DiffD1 DiffD2 insertCI
    by (metis (mono_tags, lifting) when_def)
next
  fix x assume "x \<in> ?B"
  then have "lookup (remove_key k f) x \<noteq> 0"  by blast
  then show "x \<in> ?A"
    by (simp add: lookup_not_eq_zero_eq_in_keys remove_key_lookup)
qed

lemma remove_key_sum: "remove_key k f + Poly_Mapping.single k (lookup f k) = f"
proof -
  {
  fix k'
  have rem:"(lookup f k' when k' \<noteq> k) = lookup (remove_key k f) k'"
    using when_def by (simp add: remove_key_lookup)
  have sin:"(lookup f k when k'=k) =  lookup (Poly_Mapping.single k (lookup f k)) k'"
    by (simp add: lookup_single_not_eq when_def)
  have "lookup f k' = (lookup f k' when k' \<noteq> k) + ((lookup f k) when k'=k)"
    unfolding when_def by fastforce
  with rem sin have "lookup f k' = lookup ((remove_key k f) + Poly_Mapping.single k (lookup f k)) k'"
    using lookup_add by metis
  }
  then show ?thesis by (metis poly_mapping_eqI)
qed

lemma remove_key_single[simp]: "remove_key v (Poly_Mapping.single v n) = 0"
proof -
 have 0:"\<And>k. (lookup (Poly_Mapping.single v n) k when k \<noteq> v) = 0" by (simp add: lookup_single_not_eq when_def)
 show ?thesis unfolding remove_key_def 0
   by auto
qed

lemma remove_key_add: "remove_key v m + remove_key v m' = remove_key v (m + m')"
  by (rule poly_mapping_eqI; simp add: lookup_add remove_key_lookup when_add_distrib)

lemma poly_mapping_induct [case_names single sum]:
fixes P::"('a, 'b::monoid_add) poly_mapping \<Rightarrow> bool"
assumes single:"\<And>k v. P (Poly_Mapping.single k v)"
and sum:"(\<And>f g k v. P f \<Longrightarrow> P g \<Longrightarrow> g = (Poly_Mapping.single k v) \<Longrightarrow> k \<notin> keys f \<Longrightarrow> P (f+g))"
shows "P f" using finite_keys[of f]
proof (induction "keys f" arbitrary: f rule: finite_induct)
  case (empty)
  then show ?case using single[of _ 0] by (metis (full_types) aux empty_iff not_in_keys_iff_lookup_eq_zero single_zero)
next
  case (insert k K f)
  obtain f1 f2 where f12_def: "f1 = remove_key k f" "f2 = Poly_Mapping.single k (lookup f k)" by blast
  have "P f1"
  proof -
    have "Suc (card (keys f1)) = card (keys f)"
      using remove_key_keys finite_keys f12_def(1) by (metis (no_types) Diff_insert_absorb card_insert_disjoint insert.hyps(2) insert.hyps(4))
    then show ?thesis using insert lessI by (metis Diff_insert_absorb f12_def(1) remove_key_keys)
  qed
  have "P f2" by (simp add: single f12_def(2))
  have "f1 + f2 = f" using remove_key_sum f12_def by auto
  have "k \<notin> keys f1" using remove_key_keys f12_def by fast
  then show ?case using \<open>P f1\<close> \<open>P f2\<close> sum[of f1 f2 k "lookup f k"] \<open>f1 + f2 = f\<close> f12_def by auto
qed

lemma map_lookup:
assumes "g 0 = 0"
shows "lookup (Poly_Mapping.map g f) x = g ((lookup f) x)"
proof -
  have "(g (lookup f x) when lookup f x \<noteq> 0) = g (lookup f x)"
    by (metis (mono_tags, lifting) assms when_def)
  then have "(g (lookup f x) when x \<in> keys f) = g (lookup f x)"
    using lookup_not_eq_zero_eq_in_keys [of f] by simp
  then show ?thesis
    by (simp add: Poly_Mapping.map_def map_fun_def in_keys_iff)
qed

lemma keys_add:
assumes "keys f \<inter> keys g = {}"
shows "keys f \<union> keys g = keys (f+g)"
proof
  have "keys f \<subseteq> keys (f+g)"
  proof
    fix x assume "x\<in>keys f"
    then have "lookup (f+g) x = lookup f x " by (metis add.right_neutral assms disjoint_iff_not_equal not_in_keys_iff_lookup_eq_zero plus_poly_mapping.rep_eq)
    then show "x\<in>keys (f+g)" using \<open>x\<in>keys f\<close> by (metis not_in_keys_iff_lookup_eq_zero)
  qed
  moreover have "keys g \<subseteq> keys (f+g)"
  proof
    fix x assume "x\<in>keys g"
    then have "lookup (f+g) x = lookup g x "  by (metis IntI add.left_neutral assms empty_iff not_in_keys_iff_lookup_eq_zero plus_poly_mapping.rep_eq)
    then show "x\<in>keys (f+g)" using \<open>x\<in>keys g\<close> by (metis not_in_keys_iff_lookup_eq_zero)
  qed
  ultimately show "keys f \<union> keys g \<subseteq> keys (f+g)" by simp
next
  show "keys (f + g) \<subseteq> keys f \<union> keys g" by (simp add: keys_add)
qed

lemma fun_when:
"f 0 = 0 \<Longrightarrow> f (a when P) = (f a when P)" by (simp add: when_def)

section "MPoly extension"

lemma coeff_all_0:"(\<And>m. coeff p m = 0) \<Longrightarrow> p=0"
  by (metis aux coeff_def mapping_of_inject zero_mpoly.rep_eq)

definition vars::"'a::zero mpoly \<Rightarrow> nat set" where
  "vars p = \<Union> (keys ` keys (mapping_of p))"

lemma vars_finite: "finite (vars p)" unfolding vars_def by auto

lemma vars_monom_single: "vars (monom (Poly_Mapping.single v k) a) \<subseteq> {v}"
proof
  fix w assume "w \<in> vars (monom (Poly_Mapping.single v k) a)"
  then have "w = v" using vars_def by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq monom.rep_eq)
  then show "w \<in> {v}" by auto
qed

lemma vars_monom_keys:
assumes "a\<noteq>0"
shows "vars (monom m a) = keys m"
proof (rule antisym; rule subsetI)
  fix w assume "w \<in> vars (monom m a)"
  then have "lookup m w \<noteq> 0" using vars_def by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq monom.rep_eq)
  then show "w \<in> keys m" by (meson lookup_not_eq_zero_eq_in_keys)
next
  fix w assume "w \<in> keys m"
  then have "lookup m w \<noteq> 0" by (meson lookup_not_eq_zero_eq_in_keys)
  then show "w \<in> vars (monom m a)" unfolding vars_def using assms by (metis UN_iff lookup_not_eq_zero_eq_in_keys lookup_single_eq monom.rep_eq)
qed

lemma vars_monom_subset:
shows "vars (monom m a) \<subseteq> keys m"
  by (cases "a=0"; simp add: vars_def vars_monom_keys)

lemma vars_monom_single_cases: "vars (monom (Poly_Mapping.single v k) a) = (if k=0 \<or> a=0 then {} else {v})"
proof(cases "k=0")
  assume "k=0"
  then have "(Poly_Mapping.single v k) = 0" by simp
  then have "vars (monom (Poly_Mapping.single v k) a) = {}"
    by (metis (mono_tags, lifting) single_zero singleton_inject subset_singletonD vars_monom_single zero_neq_one)
  then show ?thesis using \<open>k=0\<close> by auto
next
  assume "k\<noteq>0"
  then show ?thesis
  proof (cases "a=0")
    assume "a=0"
    then have "monom (Poly_Mapping.single v k) a = 0" by (metis monom.abs_eq monom_zero single_zero)
    then show ?thesis by (metis (mono_tags, hide_lams) \<open>k \<noteq> 0\<close> \<open>a=0\<close> monom.abs_eq single_zero singleton_inject subset_singletonD vars_monom_single)
  next
    assume "a\<noteq>0"
    then have "v \<in> vars (monom (Poly_Mapping.single v k) a)" by (simp add: \<open>k \<noteq> 0\<close> vars_def)
    then show ?thesis using \<open>a\<noteq>0\<close> \<open>k \<noteq> 0\<close> vars_monom_single by fastforce
  qed
qed

lemma vars_monom:
assumes "a\<noteq>0"
shows "vars (monom m (1::'a::zero_neq_one)) = vars (monom m (a::'a))"
  unfolding vars_monom_keys[OF assms] using vars_monom_keys[of 1] one_neq_zero by blast

lemma vars_add: "vars (p1 + p2) \<subseteq> vars p1 \<union> vars p2"
proof
  fix w assume "w \<in> vars (p1 + p2)"
  then obtain m where "w \<in> keys m" "m \<in> keys (mapping_of (p1 + p2))" by (metis UN_E vars_def)
  then have "m \<in> keys (mapping_of (p1)) \<union> keys (mapping_of (p2))"
    by (metis Poly_Mapping.keys_add plus_mpoly.rep_eq subset_iff)
  then show "w \<in> vars p1 \<union> vars p2" using vars_def \<open>w \<in> keys m\<close> by fastforce
qed

lemma vars_mult: "vars (p*q) \<subseteq> vars p \<union> vars q"
proof
  fix x assume "x\<in>vars (p*q)"
  then obtain m where "m\<in>keys (mapping_of (p*q))" "x\<in>keys m"
    using vars_def  by blast
  then have "m\<in>keys (mapping_of p * mapping_of q)"
    by (simp add: times_mpoly.rep_eq)
  then obtain a b where "m=a + b" "a \<in> keys (mapping_of p)" "b \<in> keys (mapping_of q)"
    using keys_mult by blast
  then have "x \<in> keys a \<union> keys b"
    using Poly_Mapping.keys_add \<open>x \<in> keys m\<close> by force
  then show "x \<in> vars p \<union> vars q" unfolding vars_def
    using \<open>a \<in> keys (mapping_of p)\<close> \<open>b \<in> keys (mapping_of q)\<close> by blast
qed

lemma vars_add_monom:
assumes "p2 = monom m a" "m \<notin> keys (mapping_of p1)"
shows "vars (p1 + p2) = vars p1 \<union> vars p2"
proof -
  have "keys (mapping_of p2) \<subseteq> {m}" using monom_def keys_single assms by auto
  have "keys (mapping_of (p1+p2)) = keys (mapping_of p1) \<union> keys (mapping_of p2)"
    using keys_add by (metis Int_insert_right_if0 \<open>keys (mapping_of p2) \<subseteq> {m}\<close> assms(2) inf_bot_right plus_mpoly.rep_eq subset_singletonD)
  then show ?thesis unfolding vars_def by simp
qed

lemma vars_setsum: "finite S \<Longrightarrow> vars (\<Sum>m\<in>S. f m) \<subseteq> (\<Union>m\<in>S. vars (f m))"
proof (induction S rule:finite_induct)
  case empty
  then show ?case by (metis UN_empty eq_iff monom_zero sum.empty single_zero vars_monom_single_cases)
next
  case (insert s S)
  then have "vars (sum f (insert s S)) = vars (f s + sum f S)" by (metis sum.insert)
  also have "... \<subseteq> vars (f s) \<union> vars (sum f S)" by (simp add: vars_add)
  also have "... \<subseteq> (\<Union>m\<in>insert s S. vars (f m))" using insert.IH by auto
  finally show ?case by metis
qed

lemma coeff_monom: "coeff (monom m a) m' = (a when m'=m)"
  by (simp add: coeff_def lookup_single_not_eq when_def)

lemma coeff_add: "coeff p m + coeff q m = coeff (p+q) m"
  by (simp add: coeff_def lookup_add plus_mpoly.rep_eq)

lemma coeff_eq: "coeff p = coeff q \<longleftrightarrow> p=q" by (simp add: coeff_def lookup_inject mapping_of_inject)

lemma coeff_monom_mult: "coeff ((monom m' a)  * q) (m' + m)  = a * coeff q m"
  unfolding coeff_def times_mpoly.rep_eq lookup_mult mapping_of_monom lookup_single when_mult
  Sum_any_when_equal' Groups.cancel_semigroup_add_class.add_left_cancel by metis

lemma one_term_is_monomial:
assumes "card (keys (mapping_of p)) \<le> 1"
obtains m where "p = monom m (coeff p m)"
proof (cases "keys (mapping_of p) = {}")
  case True
  then show ?thesis using aux coeff_def empty_iff mapping_of_inject mapping_of_monom not_in_keys_iff_lookup_eq_zero single_zero by (metis (no_types) that)
next
  case False
  then obtain m where "keys (mapping_of p) = {m}" using assms by (metis One_nat_def Suc_leI antisym card_0_eq card_eq_SucD finite_keys neq0_conv)
  have "p = monom m (coeff p m)"
    unfolding mapping_of_inject[symmetric]
    by (rule poly_mapping_eqI, metis (no_types, lifting) \<open>keys (mapping_of p) = {m}\<close>
    coeff_def keys_single lookup_single_eq  mapping_of_monom not_in_keys_iff_lookup_eq_zero
    singletonD)
  then show ?thesis ..
qed

(* remove_term is eventually unnessecary *)
definition remove_term::"(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a::zero mpoly \<Rightarrow> 'a mpoly" where
  "remove_term m0 p = MPoly (Abs_poly_mapping (\<lambda>m. coeff p m when m \<noteq> m0))"

lemma remove_term_coeff: "coeff (remove_term m0 p) m = (coeff p m when m \<noteq> m0)"
proof -
  have "{m. (coeff p m when m \<noteq> m0) \<noteq> 0} \<subseteq> {m. coeff p m \<noteq> 0}" by auto
  then have "finite {m. (coeff p m when m \<noteq> m0) \<noteq> 0}" unfolding coeff_def using finite_subset by auto
  then have "lookup (Abs_poly_mapping (\<lambda>m. coeff p m when m \<noteq> m0)) m = (coeff p m when m \<noteq> m0)" using lookup_Abs_poly_mapping by fastforce
  then show ?thesis unfolding remove_term_def using coeff_def by (metis (mono_tags, lifting) Quotient_mpoly Quotient_rep_abs_fold_unmap)
qed

lemma coeff_keys: "m \<in> keys (mapping_of p) \<longleftrightarrow> coeff p m \<noteq> 0"
  by (simp add: coeff_def in_keys_iff)

lemma remove_term_keys:
shows "keys (mapping_of p) - {m} = keys (mapping_of (remove_term m p))" (is "?A = ?B")
proof
  show "?A \<subseteq> ?B"
  proof
    fix m' assume "m'\<in>?A"
    then show "m' \<in> ?B" by (simp add: coeff_keys remove_term_coeff)
  qed
  show "?B \<subseteq> ?A"
  proof
    fix m' assume "m'\<in> ?B"
    then show "m' \<in> ?A" by (simp add: coeff_keys remove_term_coeff)
  qed
qed

lemma remove_term_sum: "remove_term m p + monom m (coeff p m) = p"
proof -
  have "coeff p = (\<lambda>m'. (coeff p m' when m' \<noteq> m) + ((coeff p m) when m'=m))" unfolding when_def by fastforce
  moreover have "coeff (remove_term m p + monom m (coeff p m)) = ..."
    using remove_term_coeff coeff_monom coeff_add by (metis (no_types))
  ultimately show ?thesis using coeff_eq by auto
qed

lemma mpoly_induct [case_names monom sum]:
assumes monom:"\<And>m a. P (monom m a)"
and sum:"(\<And>p1 p2 m a. P p1 \<Longrightarrow> P p2 \<Longrightarrow> p2 = (monom m a) \<Longrightarrow> m \<notin> keys (mapping_of p1) \<Longrightarrow> P (p1+p2))"
shows "P p" using assms
  using poly_mapping_induct[of "\<lambda>p :: (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a. P (MPoly p)"] MPoly_induct monom.abs_eq plus_mpoly.abs_eq
  by (metis (no_types) MPoly_inverse UNIV_I)

lemma monom_pow:"monom (Poly_Mapping.single v n0) a ^ n = monom (Poly_Mapping.single v (n0*n)) (a ^ n)"
apply (induction n)
apply auto
by (metis (no_types, lifting) mult_monom single_add)

lemma insertion_fun_single: "insertion_fun f (\<lambda>m. (a when (Poly_Mapping.single (v::nat) (n::nat)) = m)) = a * f v ^ n" (is "?i = _")
proof -
  have setsum_single:"\<And> a f. (\<Sum>m\<in>{a}. f m) = f a"
   by (metis add.right_neutral empty_Diff finite.emptyI sum.empty sum.insert_remove)

  have 1:"?i = (\<Sum>m. (a when Poly_Mapping.single v n = m) * (\<Prod>v. f v ^ lookup m v))"
    unfolding insertion_fun_def by metis
  have "\<forall>m. m \<noteq> Poly_Mapping.single v n \<longrightarrow> (a when Poly_Mapping.single v n = m) = 0" by simp

  have "(\<Sum>m\<in>{Poly_Mapping.single v n}. (a when Poly_Mapping.single v n = m) * (\<Prod>v. f v ^ lookup m v)) = ?i"
    unfolding 1 when_mult unfolding when_def by auto
  then have 2:"?i = a * (\<Prod>va. f va ^ lookup (Poly_Mapping.single v n) va)"
    unfolding setsum_single[of "\<lambda>m. (a when Poly_Mapping.single v n = m) * (\<Prod>v. f v ^ lookup m v)" "Poly_Mapping.single k v"]
    by auto
  have "\<forall>v0. v0\<noteq>v \<longrightarrow> lookup (Poly_Mapping.single v n) v0 = 0" by (simp add: lookup_single_not_eq)
  then have "\<forall>va. va\<noteq>v \<longrightarrow> f va ^ lookup (Poly_Mapping.single v n) va = 1"  by simp
  then have "a * (\<Prod>va\<in>{v}. f va ^ lookup (Poly_Mapping.single v n) va) = ?i" unfolding 2
    using Prod_any.expand_superset[of "{v}" "\<lambda>va. f va ^ lookup (Poly_Mapping.single v n) va", simplified]
    by fastforce
  then show ?thesis by simp
qed

lemma insertion_single[simp]: "insertion f (monom (Poly_Mapping.single (v::nat) (n::nat)) a) = a * f v ^ n"
  using insertion_fun_single  Sum_any.cong insertion.rep_eq insertion_aux.rep_eq insertion_fun_def
  mapping_of_monom single.rep_eq by (metis (no_types, lifting))

lemma insertion_fun_irrelevant_vars:
fixes p::"((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a::comm_ring_1)"
assumes "\<And>m v. p m \<noteq> 0 \<Longrightarrow> lookup m v \<noteq> 0 \<Longrightarrow> f v = g v"
shows "insertion_fun f p = insertion_fun g p"
proof -
  {
    fix m::"nat\<Rightarrow>\<^sub>0nat"
    assume "p m \<noteq> 0"
    then have "(\<Prod>v. f v ^ lookup m v) = (\<Prod>v. g v ^ lookup m v)"
      using assms by (metis power_0)
  }
  then show ?thesis unfolding insertion_fun_def by (metis (no_types, lifting) mult_not_zero)
qed

lemma insertion_aux_irrelevant_vars:
fixes p::"((nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_ring_1)"
assumes "\<And>m v. lookup p m \<noteq> 0 \<Longrightarrow> lookup m v \<noteq> 0 \<Longrightarrow> f v = g v"
shows "insertion_aux f p = insertion_aux g p"
  using insertion_fun_irrelevant_vars[of "lookup p" f g] assms
  by (metis insertion_aux.rep_eq)

lemma insertion_irrelevant_vars:
fixes p::"'a::comm_ring_1 mpoly"
assumes "\<And>v. v\<in>vars p \<Longrightarrow> f v = g v"
shows "insertion f p = insertion g p"
proof -
  {
    fix m v assume "lookup (mapping_of p) m \<noteq> 0" "lookup m v \<noteq> 0"
    then have "v \<in> vars p" unfolding vars_def by (meson UN_I lookup_not_eq_zero_eq_in_keys)
    then have "f v = g v" using assms by auto
  }
  then show ?thesis
    unfolding insertion_def using insertion_aux_irrelevant_vars[of "mapping_of p"]
    by (metis insertion.rep_eq insertion_def)
qed

section "Nested MPoly"

definition reduce_nested_mpoly::"'a::comm_ring_1 mpoly mpoly \<Rightarrow> 'a mpoly" where
  "reduce_nested_mpoly pp = insertion (\<lambda>v. monom (Poly_Mapping.single v 1) 1) pp"

lemma reduce_nested_mpoly_sum:
fixes p1::"'a::comm_ring_1 mpoly mpoly"
shows "reduce_nested_mpoly (p1 + p2) = reduce_nested_mpoly p1 + reduce_nested_mpoly p2"
  by (simp add: insertion_add reduce_nested_mpoly_def)

lemma reduce_nested_mpoly_prod:
fixes p1::"'a::comm_ring_1 mpoly mpoly"
shows "reduce_nested_mpoly (p1 * p2) = reduce_nested_mpoly p1 * reduce_nested_mpoly p2"
  by (simp add: insertion_mult reduce_nested_mpoly_def)

lemma reduce_nested_mpoly_0:
shows "reduce_nested_mpoly 0 = 0" by (simp add: reduce_nested_mpoly_def)

lemma insertion_nested_poly:
fixes pp::"'a::comm_ring_1 mpoly mpoly"
shows "insertion f (insertion (\<lambda>v. monom 0 (f v)) pp) = insertion f (reduce_nested_mpoly pp)"
proof (induction pp rule:mpoly_induct)
  case (monom m a)
  then show ?case
  proof (induction m arbitrary:a rule:poly_mapping_induct)
    case (single v n)
    show ?case unfolding reduce_nested_mpoly_def
      apply (simp add: insertion_mult monom_pow)
      using monom_pow[of 0 0 "f v" n] apply simp
      using insertion_single[of f 0 0] by auto
  next
    case (sum m1 m2 k v)
    then have "insertion f (insertion (\<lambda>v. monom 0 (f v)) (monom m1 a * monom m2 1))
             = insertion f (reduce_nested_mpoly (monom m1 a * monom m2 1))" unfolding reduce_nested_mpoly_prod insertion_mult by metis
    then show ?case using mult_monom[of m1 a m2 1] by auto
  qed
next
  case (sum p1 p2 m a)
  then show ?case by (simp add: reduce_nested_mpoly_sum insertion_add)
qed

definition extract_var::"'a::comm_ring_1 mpoly \<Rightarrow> nat \<Rightarrow> 'a::comm_ring_1 mpoly mpoly" where
"extract_var p v = (\<Sum>m. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"

lemma extract_var_finite_set:
assumes "{m'. coeff p m' \<noteq> 0} \<subseteq> S"
assumes "finite S"
shows "extract_var p v = (\<Sum>m\<in>S. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
proof-
  {
    fix m' assume "coeff p m' = 0"
    then have "monom (remove_key v m') (monom (Poly_Mapping.single v (lookup m' v)) (coeff p m')) = 0"
      using monom.abs_eq monom_zero single_zero by metis
  }
  then have 0:"{a. monom (remove_key v a) (monom (Poly_Mapping.single v (lookup a v)) (coeff p a)) \<noteq> 0} \<subseteq> S"
    using \<open>{m'. coeff p m' \<noteq> 0} \<subseteq> S\<close> by fastforce
  then show ?thesis
    unfolding extract_var_def using Sum_any.expand_superset [OF \<open>finite S\<close> 0] by metis
qed

lemma extract_var_non_zero_coeff: "extract_var p v = (\<Sum>m\<in>{m'. coeff p m' \<noteq> 0}. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
  using extract_var_finite_set  coeff_def finite_lookup order_refl by (metis (no_types, lifting) Collect_cong sum.cong)

lemma extract_var_sum: "extract_var (p+p') v = extract_var p v + extract_var p' v"
proof -
  define S where "S = {m. coeff p m \<noteq> 0} \<union> {m. coeff p' m \<noteq> 0} \<union> {m. coeff (p+p') m \<noteq> 0}"
  have subsets:"{m. coeff p m \<noteq> 0} \<subseteq> S" "{m. coeff p' m \<noteq> 0} \<subseteq> S" "{m. coeff (p+p') m \<noteq> 0} \<subseteq> S"
    unfolding S_def by auto
  have "finite S" unfolding S_def using coeff_def finite_lookup
    by (metis (mono_tags) Collect_disj_eq finite_Collect_disjI)
  then show ?thesis  unfolding
    extract_var_finite_set[OF subsets(1) \<open>finite S\<close>]
    extract_var_finite_set[OF subsets(2) \<open>finite S\<close>]
    extract_var_finite_set[OF subsets(3) \<open>finite S\<close>]
    coeff_add[symmetric] monom_add sum.distrib
    by metis
qed

lemma extract_var_monom:
shows "extract_var (monom m a) v = monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) a)"
proof (cases "a = 0")
  assume "a \<noteq> 0"
  have 0:"{m'. coeff (monom m a) m' \<noteq> 0} = {m}"
    unfolding coeff_monom using \<open>a \<noteq> 0\<close> by auto
  show ?thesis
    unfolding extract_var_non_zero_coeff unfolding 0 unfolding coeff_monom
    using sum.insert[OF finite.emptyI, unfolded sum.empty add.right_neutral] when_def
    by auto
next
  assume "a = 0"
  have 0:"{m'. coeff (monom m a) m' \<noteq> 0} = {}"
    unfolding coeff_monom using \<open>a = 0\<close> by auto
  show ?thesis unfolding extract_var_non_zero_coeff 0
    using \<open>a = 0\<close> monom.abs_eq monom_zero sum.empty single_zero by (metis (no_types, lifting))
qed

lemma extract_var_monom_mult:
shows "extract_var (monom (m+m') (a*b)) v = extract_var (monom m a) v * extract_var (monom m' b) v"
unfolding extract_var_monom remove_key_add lookup_add single_add mult_monom by auto

lemma extract_var_single: "extract_var (monom (Poly_Mapping.single v n) a) v = monom 0 (monom (Poly_Mapping.single v n) a)"
unfolding extract_var_monom by simp

lemma extract_var_single':
assumes "v \<noteq> v'"
shows "extract_var (monom (Poly_Mapping.single v n) a) v' = monom (Poly_Mapping.single v n) (monom 0 a)"
unfolding extract_var_monom using assms by (metis add.right_neutral lookup_single_not_eq remove_key_sum single_zero)

lemma reduce_nested_mpoly_extract_var:
fixes p::"'a::comm_ring_1 mpoly"
shows "reduce_nested_mpoly (extract_var p v) = p"
proof (induction p rule:mpoly_induct)
  case (monom m a)
  then show ?case
  proof (induction m arbitrary:a rule:poly_mapping_induct)
    case (single v' n)
    show ?case
    proof (cases "v' = v")
      case True
      then show ?thesis
        by (metis (no_types, lifting) insertion_single mult.right_neutral power_0
        reduce_nested_mpoly_def single_zero extract_var_single)
    next
      case False
      then show ?thesis unfolding extract_var_single'[OF False] reduce_nested_mpoly_def insertion_single
        by (simp add: monom_pow mult_monom)
    qed
  next
    case (sum m m' v n a)
    then show ?case
      using extract_var_monom_mult[of m m' a 1] reduce_nested_mpoly_prod by (metis mult.right_neutral mult_monom)
  qed
next
  case (sum p1 p2 m a)
  then show ?case unfolding extract_var_sum reduce_nested_mpoly_sum by auto
qed

lemma vars_extract_var_subset: "vars (extract_var p v) \<subseteq> vars p"
proof
  have "finite {m'. coeff p m' \<noteq> 0}" by (simp add: coeff_def)
  fix x assume "x \<in> vars (extract_var p v)"
  then have "x \<in> vars (\<Sum>m\<in>{m'. coeff p m' \<noteq> 0}. monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
    unfolding extract_var_non_zero_coeff by metis
  then have "x \<in> (\<Union>m\<in>{m'. coeff p m' \<noteq> 0}. vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m))))"
    using vars_setsum[OF \<open>finite {m'. coeff p m' \<noteq> 0}\<close>] by auto
  then obtain m where "m\<in>{m'. coeff p m' \<noteq> 0}" "x \<in> vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
    by blast
  show "x \<in> vars p" by (metis (mono_tags, lifting) DiffD1 UN_I \<open>m \<in> {m'. coeff p m' \<noteq> 0}\<close>
    \<open>x \<in> vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))\<close>
    coeff_keys mem_Collect_eq remove_key_keys subsetCE vars_def vars_monom_subset)
qed

lemma v_not_in_vars_extract_var: "v \<notin> vars (extract_var p v)"
proof -
  have "finite {m'. coeff p m' \<noteq> 0}" by (simp add: coeff_def)
  have "\<And>m. m\<in>{m'. coeff p m' \<noteq> 0} \<Longrightarrow> v \<notin> vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m)))"
    by (metis Diff_iff remove_key_keys singletonI subsetCE vars_monom_subset)
  then have "v \<notin> (\<Union>m\<in>{m'. coeff p m' \<noteq> 0}. vars (monom (remove_key v m) (monom (Poly_Mapping.single v (lookup m v)) (coeff p m))))"
    by simp
  then show ?thesis
   unfolding extract_var_non_zero_coeff using vars_setsum[OF \<open>finite {m'. coeff p m' \<noteq> 0}\<close>] by blast
qed

lemma vars_coeff_extract_var: "vars (coeff (extract_var p v) j) \<subseteq> {v}"
proof (induction p rule:mpoly_induct)
  case (monom m a)
  then show ?case unfolding extract_var_monom coeff_monom vars_monom_single_cases
    by (metis monom_zero single_zero vars_monom_single when_def)
next
  case (sum p1 p2 m a)
  then show ?case unfolding extract_var_sum coeff_add[symmetric]
    by (metis (no_types, lifting) Un_insert_right insert_absorb2 subset_insertI2 subset_singletonD sup_bot.right_neutral vars_add)
qed

definition replace_coeff
where "replace_coeff f p = MPoly (Abs_poly_mapping (\<lambda>m. f (lookup (mapping_of p) m)))"

lemma coeff_replace_coeff:
assumes "f 0 = 0"
shows "coeff (replace_coeff f p) m = f (coeff p m)"
proof -
  have 0:"finite {m. f (lookup (mapping_of p) m) \<noteq> 0}"
    unfolding coeff_def[symmetric] by (metis (mono_tags, lifting) Collect_mono assms(1) coeff_def finite_lookup finite_subset)+
  then show ?thesis unfolding replace_coeff_def coeff_def using lookup_Abs_poly_mapping[OF 0]
    by (metis (mono_tags, lifting) Quotient_mpoly Quotient_rep_abs_fold_unmap)
qed

lemma replace_coeff_monom:
assumes "f 0 = 0"
shows "replace_coeff f (monom m a) = monom m (f a)"
  unfolding replace_coeff_def
  unfolding  mapping_of_inject[symmetric] lookup_inject[symmetric] apply (rule HOL.ext)
  unfolding lookup_single  mapping_of_monom fun_when[of f, OF \<open>f 0 = 0\<close>]
  by (metis coeff_def coeff_monom lookup_single lookup_single_not_eq monom.abs_eq single.abs_eq)

lemma replace_coeff_add:
assumes "f 0 = 0"
assumes "\<And>a b. f (a+b) = f a + f b"
shows "replace_coeff f (p1 + p2) = replace_coeff f p1 + replace_coeff f p2"
proof -
  have "finite {m. f (lookup (mapping_of p1) m) \<noteq> 0}"
       "finite {m. f (lookup (mapping_of p2) m) \<noteq> 0}"
    unfolding coeff_def[symmetric] by (metis (mono_tags, lifting) Collect_mono assms(1) coeff_def finite_lookup finite_subset)+
  then show ?thesis
    unfolding replace_coeff_def plus_mpoly.rep_eq unfolding Poly_Mapping.plus_poly_mapping.rep_eq
    unfolding assms(2) plus_mpoly.abs_eq using Poly_Mapping.plus_poly_mapping.abs_eq[unfolded eq_onp_def] by fastforce
qed

lemma insertion_replace_coeff:
fixes pp::"'a::comm_ring_1 mpoly mpoly"
shows "insertion f (replace_coeff (insertion f) pp) = insertion f (reduce_nested_mpoly pp)"
proof (induction pp rule:mpoly_induct)
  case (monom m a)
  then show ?case
  proof (induction m arbitrary:a rule:poly_mapping_induct)
    case (single v n)
    show ?case unfolding reduce_nested_mpoly_def  unfolding replace_coeff_monom[of "insertion f", OF insertion_zero]
      insertion_single insertion_mult using insertion_single by (simp add: monom_pow)
  next
    case (sum m1 m2 k v)
    have "replace_coeff (insertion f) (monom m1 a * monom m2 1) = replace_coeff (insertion f) (monom m1 a) * replace_coeff (insertion f) (monom m2 1)"
      by (simp add: mult_monom replace_coeff_monom)
    then have "insertion f (replace_coeff (insertion f) (monom m1 a * monom m2 1)) = insertion f (reduce_nested_mpoly (monom m1 a * monom m2 1))"
      unfolding reduce_nested_mpoly_prod insertion_mult
      by (simp add: insertion_mult sum.IH(1) sum.IH(2))
    then show ?case using mult_monom[of m1 a m2 1] by auto
  qed
next
  case (sum p1 p2 m a)
  then show ?case using reduce_nested_mpoly_sum insertion_add
    replace_coeff_add[of "insertion f", OF insertion_zero insertion_add] by metis
qed

lemma replace_coeff_extract_var_cong:
assumes "f v = g v"
shows "replace_coeff (insertion f) (extract_var p v) = replace_coeff (insertion g) (extract_var p v)"
  by (induction p rule:mpoly_induct;simp add: assms extract_var_monom replace_coeff_monom
  extract_var_sum insertion_add replace_coeff_add)

lemma vars_replace_coeff:
assumes "f 0 = 0"
shows "vars (replace_coeff f p) \<subseteq> vars p"
  unfolding vars_def apply (rule subsetI) unfolding mem_simps(8) coeff_keys
  using assms coeff_replace_coeff by (metis coeff_keys)

(* Polynomial functions *)

definition polyfun :: "nat set \<Rightarrow> ((nat \<Rightarrow> 'a::comm_semiring_1) \<Rightarrow> 'a) \<Rightarrow> bool"
  where "polyfun N f = (\<exists>p. vars p \<subseteq> N \<and> (\<forall>x. insertion x p = f x))"

lemma polyfunI: "(\<And>P. (\<And>p. vars p \<subseteq> N \<Longrightarrow> (\<And>x. insertion x p = f x) \<Longrightarrow> P) \<Longrightarrow> P) \<Longrightarrow> polyfun N f"
  unfolding polyfun_def by metis

lemma polyfun_subset: "N\<subseteq>N' \<Longrightarrow> polyfun N f \<Longrightarrow> polyfun N' f"
  unfolding polyfun_def by blast

lemma polyfun_const: "polyfun N (\<lambda>_. c)"
proof -
  have "\<And>x. insertion x (monom 0 c) = c" using insertion_single by (metis insertion_one monom_one mult.commute mult.right_neutral single_zero)
  then show ?thesis unfolding polyfun_def by (metis (full_types) empty_iff keys_single single_zero subsetI subset_antisym vars_monom_subset)
qed

lemma polyfun_add:
assumes "polyfun N f" "polyfun N g"
shows "polyfun N (\<lambda>x. f x + g x)"
proof -
  obtain p1 p2 where "vars p1 \<subseteq> N" "\<forall>x. insertion x p1 = f x"
                     "vars p2 \<subseteq> N" "\<forall>x. insertion x p2 = g x"
    using polyfun_def assms by metis
  then have "vars (p1 + p2) \<subseteq> N" "\<forall>x. insertion x (p1 + p2) = f x + g x"
    using vars_add using Un_iff subsetCE subsetI apply blast
    by (simp add: \<open>\<forall>x. insertion x p1 = f x\<close> \<open>\<forall>x. insertion x p2 = g x\<close> insertion_add)
  then show ?thesis using polyfun_def by blast
qed

lemma polyfun_mult:
assumes "polyfun N f" "polyfun N g"
shows "polyfun N (\<lambda>x. f x * g x)"
proof -
  obtain p1 p2 where "vars p1 \<subseteq> N" "\<forall>x. insertion x p1 = f x"
                     "vars p2 \<subseteq> N" "\<forall>x. insertion x p2 = g x"
    using polyfun_def assms by metis
  then have "vars (p1 * p2) \<subseteq> N" "\<forall>x. insertion x (p1 * p2) = f x * g x"
    using vars_mult using Un_iff subsetCE subsetI apply blast
    by (simp add: \<open>\<forall>x. insertion x p1 = f x\<close> \<open>\<forall>x. insertion x p2 = g x\<close> insertion_mult)
  then show ?thesis using polyfun_def by blast
qed

lemma polyfun_Sum:
assumes "finite I"
assumes "\<And>i. i\<in>I \<Longrightarrow> polyfun N (f i)"
shows "polyfun N (\<lambda>x. \<Sum>i\<in>I. f i x)"
  using assms
  apply (induction I rule:finite_induct)
  apply (simp add: polyfun_const)
  using comm_monoid_add_class.sum.insert polyfun_add by fastforce

lemma polyfun_Prod:
assumes "finite I"
assumes "\<And>i. i\<in>I \<Longrightarrow> polyfun N (f i)"
shows "polyfun N (\<lambda>x. \<Prod>i\<in>I. f i x)"
  using assms
  apply (induction I rule:finite_induct)
  apply (simp add: polyfun_const)
  using comm_monoid_add_class.sum.insert polyfun_mult by fastforce

lemma polyfun_single:
assumes "i\<in>N"
shows "polyfun N (\<lambda>x. x i)"
proof -
  have "\<forall>f. insertion f (monom (Poly_Mapping.single i 1) 1) = f i" using insertion_single by simp
  then show ?thesis unfolding polyfun_def
    using vars_monom_single[of i 1 1] One_nat_def assms singletonD subset_eq
    by blast
qed

end