theory Set_Example
  imports Sepreftime

begin

fun makeset where
  "makeset (S,[]) = S" |
  "makeset (S,(x#xs)) = makeset (insert x S, xs)"

lemma makeset_set_aux: "makeset (S,xs) = S \<union> set xs"
  apply(induct xs arbitrary: S) by auto

corollary Z: "makeset ({},xs) = set xs" using makeset_set_aux by fast

fun t_insert :: "nat \<Rightarrow> nat" where "t_insert n = 3*n"
fun t_makeset :: "nat \<Rightarrow> nat" where "t_makeset n = n * t_insert n"

definition "makeset_SPEC xs = SPECT [set xs \<mapsto> t_makeset (length xs)]"

definition "makeset_impl xs \<equiv> do {
      as \<leftarrow> RETURNT xs;
      S \<leftarrow> RETURNT {};
      s \<leftarrow> RETURNT (S,xs);
      r \<leftarrow> whileT (\<lambda>(S,as). as \<noteq> [])
        (\<lambda>(S,as). do {
               (*   ASSERT (as\<noteq>[]);
                  ASSERT (length as \<le> length xs);*)
                  x \<leftarrow> RETURNT (hd as);
                  as' \<leftarrow> RETURNT (tl as);
                  S' \<leftarrow> REST [insert x S \<mapsto> t_insert (length xs)];
                  RETURNT (S',as')
          } ) s;
      RETURNT (fst r)
    }"

thm whileT_rule'''
(*
lemma ASSERT_bindT: "ASSERT B \<bind> f = SPECT M \<longleftrightarrow> (B \<and> f () = SPECT M)"
  unfolding ASSERT_def iASSERT_def by simp

*)

lemma k: "y\<noteq>[] \<Longrightarrow> makeset (insert (hd y) x, tl y) = makeset (x, y)"
  apply (cases y) by auto

lemma "makeset_impl xs \<le> makeset_SPEC xs"
  unfolding makeset_SPEC_def makeset_impl_def apply simp

  apply(rule Refinement_by_T)
  apply (simp only: T_bindT)
  apply(simp only: T_RETURNT)
  apply(rule T_conseq4)
   apply(rule whileT_rule'''[where I="\<lambda>s. if makeset s = makeset ({},xs) then Some (length (snd s) * t_insert (length xs) ) else None" ])
  apply simp
  subgoal (* progress *)
    apply(auto split: prod.splits)
    apply(auto simp add: ASSERT_bindT)
    sorry
  subgoal (* IS *)
    apply (auto split: if_splits)
  apply (simp only: T_bindT)
  apply(simp only: T_RETURNT)
    apply(simp only: T_REST)
    apply(subst k) apply simp apply simp
    apply(auto simp: mm3_def mm2_def)
    by (simp add: left_diff_distrib')
   apply simp
  (* post condition *)
  apply (auto   split: if_splits)
  unfolding Z apply simp apply simp
  unfolding mm3_def by simp

end


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

  Project: Refining Authenticated Key Agreement with Strong Adversaries

  Module:  Messages.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Messages.thy 133008 2017-01-17 13:53:14Z csprenge $
  Author:  Joseph Lallemand, INRIA Nancy <joseph.lallemand@loria.fr>
           Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Message datatype and quotient construction based on Diffie-Hellman
  equational theory.

  Copyright (c) 2015-2016 Joseph Lallemand and Christoph Sprenger
  Licence: LGPL

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

section \<open>Message definitions\<close>

theory Messages
imports Main
begin

(****************************************************************************************)
subsection \<open>Messages\<close>
(****************************************************************************************)

text \<open>Agents\<close>
datatype
  agent = Agent nat

text \<open>Nonces\<close>
typedecl fid_t

datatype fresh_t =
  mk_fresh "fid_t" "nat"      (infixr "$" 65)

fun fid :: "fresh_t \<Rightarrow> fid_t" where
  "fid (f $ n) = f"

fun num :: "fresh_t \<Rightarrow> nat" where
  "num (f $ n) = n"

datatype
  nonce_t =
    nonce_fresh "fresh_t"
  | nonce_atk "nat"

text \<open>Keys\<close>
datatype ltkey =
  sharK "agent" "agent"
| publK "agent"
| privK "agent"

datatype ephkey =
  epublK nonce_t
| eprivK nonce_t

datatype tag = insec | auth | confid | secure

text \<open>Messages\<close>

datatype cmsg =
  cAgent "agent"
| cNumber "nat"
| cNonce "nonce_t"
| cLtK "ltkey"
| cEphK "ephkey"
| cPair cmsg cmsg
| cEnc cmsg cmsg
| cAenc cmsg cmsg
| cSign cmsg cmsg
| cHash cmsg
| cTag tag
| cExp cmsg cmsg

fun catomic :: "cmsg \<Rightarrow> bool"
where
  "catomic (cAgent _) = True"
| "catomic (cNumber _) = True"
| "catomic (cNonce _) = True"
| "catomic (cLtK _) = True"
| "catomic (cEphK _) = True"
| "catomic (cTag _) = True"
|" catomic _ = False"

inductive eq :: "cmsg \<Rightarrow> cmsg \<Rightarrow> bool"
where
\<comment> \<open>equations\<close>
  Permute [intro]:"eq (cExp (cExp a b) c) (cExp (cExp a c) b)"
\<comment> \<open>closure by context\<close>
 | Tag[intro]: "eq (cTag t) (cTag t)"
 | Agent[intro]: "eq (cAgent A) (cAgent A)"
 | Nonce[intro]:"eq (cNonce x) (cNonce x)"
 | Number[intro]:"eq (cNumber x) (cNumber x)"
 | LtK[intro]:"eq (cLtK x) (cLtK x)"
 | EphK[intro]:"eq (cEphK x) (cEphK x)"
 | Pair[intro]:"eq a b \<Longrightarrow> eq c d \<Longrightarrow> eq (cPair a c) (cPair b d)"
 | Enc[intro]:"eq a b \<Longrightarrow> eq c d \<Longrightarrow> eq (cEnc a c) (cEnc b d)"
 | Aenc[intro]:"eq a b \<Longrightarrow> eq c d \<Longrightarrow> eq (cAenc a c) (cAenc b d)"
 | Sign[intro]:"eq a b \<Longrightarrow> eq c d \<Longrightarrow> eq (cSign a c) (cSign b d)"
 | Hash[intro]:"eq a b \<Longrightarrow> eq (cHash a) (cHash b)"
 | Exp[intro]:"eq a b \<Longrightarrow> eq c d \<Longrightarrow> eq (cExp a c) (cExp b d)"
\<comment> \<open>reflexive closure is not needed here because the context closure implies it\<close>
\<comment> \<open>symmetric closure is not needed as it is easier to include equations in both directions\<close>
\<comment> \<open>transitive closure\<close>
 | Tr[intro]: "eq a b \<Longrightarrow> eq b c \<Longrightarrow> eq a c"

lemma eq_sym: "eq a b \<longleftrightarrow> eq b a"
by (auto elim: eq.induct)

lemma eq_Sym [intro]: "eq a b \<Longrightarrow> eq b a"
by (auto elim: eq.induct)

lemma eq_refl [simp, intro]: "eq a a"
by (induction a, auto)

text \<open>inductive cases; keep the transitivity case, so we prove the the right lemmas by hand.\<close>
lemma eq_Number: "eq (cNumber N) y \<Longrightarrow>  y = cNumber N"
  by (induction "cNumber N" y rule: eq.induct, auto)
lemma eq_Agent: "eq (cAgent A) y \<Longrightarrow>  y = cAgent A"
  by (induction "cAgent A" y rule: eq.induct, auto)
lemma eq_Nonce: "eq (cNonce N) y \<Longrightarrow>  y = cNonce N"
  by (induction "cNonce N" y rule: eq.induct, auto)
lemma eq_LtK: "eq (cLtK N) y \<Longrightarrow>  y = cLtK N"
  by (induction "cLtK N" y rule: eq.induct, auto)
lemma eq_EphK: "eq (cEphK N) y \<Longrightarrow>  y = cEphK N"
  by (induction "cEphK N" y rule: eq.induct, auto)
lemma eq_Tag: "eq (cTag N) y \<Longrightarrow>  y = cTag N"
  by (induction "cTag N" y rule: eq.induct, auto)
lemma eq_Hash: "eq (cHash X) y \<Longrightarrow> \<exists>Y. y = cHash Y \<and> eq X Y"
  by (drule eq.induct [where P="\<lambda>x. \<lambda>y. \<forall> X. x = cHash X \<longrightarrow> (\<exists>Y. y = cHash Y \<and> eq X Y)"],
      auto elim!:Tr)
lemma eq_Pair: "eq (cPair X Y) y \<Longrightarrow>  \<exists> X' Y'. y = cPair X' Y' \<and> eq X X' \<and> eq Y Y'"
  apply (drule eq.induct [where
    P="\<lambda>x. \<lambda>y. \<forall> X Y. x = cPair X Y \<longrightarrow> (\<exists> X' Y'. y = cPair X' Y' \<and> eq X X' \<and> eq Y Y')"])
  apply (auto elim!: Tr)
done
lemma eq_Enc: "eq (cEnc X Y) y \<Longrightarrow>  \<exists> X' Y'. y = cEnc X' Y' \<and> eq X X' \<and> eq Y Y'"
  apply (drule eq.induct [where
    P="\<lambda>x. \<lambda>y. \<forall> X Y. x = cEnc X Y \<longrightarrow> (\<exists> X' Y'. y = cEnc X' Y' \<and> eq X X' \<and> eq Y Y')"])
  apply (auto elim!: Tr)
done
lemma eq_Aenc: "eq (cAenc X Y) y \<Longrightarrow>  \<exists> X' Y'. y = cAenc X' Y' \<and> eq X X' \<and> eq Y Y'"
  apply (drule eq.induct [where
    P="\<lambda>x. \<lambda>y. \<forall> X Y. x = cAenc X Y \<longrightarrow> (\<exists> X' Y'. y = cAenc X' Y' \<and> eq X X' \<and> eq Y Y')"])
  apply (auto elim!: Tr)
done
lemma eq_Sign: "eq (cSign X Y) y \<Longrightarrow>  \<exists> X' Y'. y = cSign X' Y' \<and> eq X X' \<and> eq Y Y'"
  apply (drule eq.induct [where
    P="\<lambda>x. \<lambda>y. \<forall> X Y. x = cSign X Y \<longrightarrow> (\<exists> X' Y'. y = cSign X' Y' \<and> eq X X' \<and> eq Y Y')"])
  apply (auto elim!: Tr)
done
lemma eq_Exp: "eq (cExp X Y) y \<Longrightarrow>  \<exists> X' Y'. y = cExp X' Y'"
  apply (drule eq.induct [where
    P="\<lambda>x. \<lambda>y. \<forall> X Y. x = cExp X Y \<longrightarrow> (\<exists> X' Y'. y = cExp X' Y')"])
  apply (auto elim!: Tr)
done

lemmas eqD_aux = eq_Number eq_Agent eq_Nonce eq_LtK eq_EphK eq_Tag
                    eq_Hash eq_Pair eq_Enc eq_Aenc eq_Sign eq_Exp
lemmas eqD [dest] = eqD_aux eqD_aux [OF eq_Sym]

text \<open>Quotient construction\<close>

quotient_type msg = cmsg / eq
morphisms Re Ab
by (auto simp add:equivp_def)

lift_definition Number :: "nat \<Rightarrow> msg" is cNumber by -
lift_definition Nonce :: "nonce_t \<Rightarrow> msg" is cNonce by -
lift_definition Agent :: "agent \<Rightarrow> msg" is cAgent by -
lift_definition LtK :: "ltkey \<Rightarrow> msg" is cLtK by -
lift_definition EphK :: "ephkey \<Rightarrow> msg" is cEphK by -
lift_definition Pair :: "msg \<Rightarrow> msg \<Rightarrow> msg" is cPair by auto
lift_definition Enc :: "msg \<Rightarrow> msg \<Rightarrow> msg" is cEnc by auto
lift_definition Aenc :: "msg \<Rightarrow> msg \<Rightarrow> msg" is cAenc by auto
lift_definition Exp :: "msg \<Rightarrow> msg \<Rightarrow> msg" is cExp by auto
lift_definition Tag :: "tag \<Rightarrow> msg" is cTag by -
lift_definition Hash :: "msg \<Rightarrow> msg" is cHash by auto
lift_definition Sign :: "msg \<Rightarrow> msg \<Rightarrow> msg" is cSign by auto

lemmas msg_defs =
  Agent_def Number_def Nonce_def LtK_def EphK_def Pair_def
  Enc_def Aenc_def Exp_def Hash_def Tag_def Sign_def

text \<open>Commutativity of exponents\<close>

lemma permute_exp [simp]: "Exp (Exp X Y) Z = Exp (Exp X Z) Y"
by (transfer, auto)

lift_definition atomic :: "msg \<Rightarrow> bool" is catomic by (erule eq.induct, auto)

abbreviation
  composed :: "msg \<Rightarrow> bool" where
  "composed X \<equiv> \<not>atomic X"

lemma atomic_Agent [simp, intro]: "atomic (Agent X)" by (transfer, auto)
lemma atomic_Tag [simp, intro]: "atomic (Tag X)" by (transfer, auto)
lemma atomic_Nonce [simp, intro]: "atomic (Nonce X)" by (transfer, auto)
lemma atomic_Number [simp, intro]: "atomic (Number X)" by (transfer, auto)
lemma atomic_LtK [simp, intro]: "atomic (LtK X)" by (transfer, auto)
lemma atomic_EphK [simp, intro]: "atomic (EphK X)" by (transfer, auto)

lemma non_atomic_Pair [simp]: "\<not>atomic (Pair x y)" by (transfer, auto)
lemma non_atomic_Enc [simp]: "\<not>atomic (Enc x y)" by (transfer, auto)
lemma non_atomic_Aenc [simp]: "\<not>atomic (Aenc x y)" by (transfer, auto)
lemma non_atomic_Sign [simp]: "\<not>atomic (Sign x y)" by (transfer, auto)
lemma non_atomic_Exp [simp]: "\<not>atomic (Exp x y)" by (transfer, auto)
lemma non_atomic_Hash [simp]: "\<not>atomic (Hash x)" by (transfer, auto)

lemma Nonce_Nonce: "(Nonce X = Nonce X') = (X = X')" by transfer auto
lemma Nonce_Agent: "Nonce X \<noteq> Agent X'" by transfer auto
lemma Nonce_Number: "Nonce X \<noteq> Number X'" by transfer auto
lemma Nonce_Hash: "Nonce X \<noteq> Hash  X'" by transfer auto
lemma Nonce_Tag: "Nonce X \<noteq> Tag  X'" by transfer auto
lemma Nonce_EphK: "Nonce X \<noteq> EphK  X'" by transfer auto
lemma Nonce_LtK: "Nonce X \<noteq> LtK  X'" by transfer auto
lemma Nonce_Pair: "Nonce X \<noteq> Pair  X' Y'" by transfer auto
lemma Nonce_Enc: "Nonce X \<noteq> Enc  X' Y'" by transfer auto
lemma Nonce_Aenc: "Nonce X \<noteq> Aenc  X' Y'" by transfer auto
lemma Nonce_Sign: "Nonce X \<noteq> Sign  X' Y'" by transfer auto
lemma Nonce_Exp: "Nonce X \<noteq> Exp  X' Y'" by transfer auto

lemma Agent_Nonce: "Agent X \<noteq> Nonce  X'" by transfer auto
lemma Agent_Agent: "(Agent X = Agent X') = (X = X')" by transfer auto
lemma Agent_Number: "Agent X \<noteq> Number  X'" by transfer auto
lemma Agent_Hash: "Agent X \<noteq> Hash  X'" by transfer auto
lemma Agent_Tag: "Agent X \<noteq> Tag  X'" by transfer auto
lemma Agent_EphK: "Agent X \<noteq> EphK  X'" by transfer auto
lemma Agent_LtK: "Agent X \<noteq> LtK  X'" by transfer auto
lemma Agent_Pair: "Agent X \<noteq> Pair  X' Y'" by transfer auto
lemma Agent_Enc: "Agent X \<noteq> Enc  X' Y'" by transfer auto
lemma Agent_Aenc: "Agent X \<noteq> Aenc  X' Y'" by transfer auto
lemma Agent_Sign: "Agent X \<noteq> Sign  X' Y'" by transfer auto
lemma Agent_Exp: "Agent X \<noteq> Exp  X' Y'" by transfer auto

lemma Number_Nonce: "Number X \<noteq> Nonce  X'" by transfer auto
lemma Number_Agent: "Number X \<noteq> Agent  X'" by transfer auto
lemma Number_Number: "(Number X = Number X') = (X = X')" by transfer auto
lemma Number_Hash: "Number X \<noteq> Hash  X'" by transfer auto
lemma Number_Tag: "Number X \<noteq> Tag  X'" by transfer auto
lemma Number_EphK: "Number X \<noteq> EphK  X'" by transfer auto
lemma Number_LtK: "Number X \<noteq> LtK  X'" by transfer auto
lemma Number_Pair: "Number X \<noteq> Pair  X' Y'" by transfer auto
lemma Number_Enc: "Number X \<noteq> Enc  X' Y'" by transfer auto
lemma Number_Aenc: "Number X \<noteq> Aenc  X' Y'" by transfer auto
lemma Number_Sign: "Number X \<noteq> Sign  X' Y'" by transfer auto
lemma Number_Exp: "Number X \<noteq> Exp  X' Y'" by transfer auto

lemma Hash_Nonce: "Hash X \<noteq> Nonce  X'" by transfer auto
lemma Hash_Agent: "Hash X \<noteq> Agent  X'" by transfer auto
lemma Hash_Number: "Hash X \<noteq> Number  X'" by transfer auto
lemma Hash_Hash: "(Hash X = Hash X') = (X = X')" by transfer auto
lemma Hash_Tag: "Hash X \<noteq> Tag  X'" by transfer auto
lemma Hash_EphK: "Hash X \<noteq> EphK  X'" by transfer auto
lemma Hash_LtK: "Hash X \<noteq> LtK  X'" by transfer auto
lemma Hash_Pair: "Hash X \<noteq> Pair  X' Y'" by transfer auto
lemma Hash_Enc: "Hash X \<noteq> Enc  X' Y'" by transfer auto
lemma Hash_Aenc: "Hash X \<noteq> Aenc  X' Y'" by transfer auto
lemma Hash_Sign: "Hash X \<noteq> Sign  X' Y'" by transfer auto
lemma Hash_Exp: "Hash X \<noteq> Exp  X' Y'" by transfer auto

lemma Tag_Nonce: "Tag X \<noteq> Nonce  X'" by transfer auto
lemma Tag_Agent: "Tag X \<noteq> Agent  X'" by transfer auto
lemma Tag_Number: "Tag X \<noteq> Number  X'" by transfer auto
lemma Tag_Hash: "Tag X \<noteq> Hash  X'" by transfer auto
lemma Tag_Tag: "(Tag X = Tag X') = (X = X')" by transfer auto
lemma Tag_EphK: "Tag X \<noteq> EphK  X'" by transfer auto
lemma Tag_LtK: "Tag X \<noteq> LtK  X'" by transfer auto
lemma Tag_Pair: "Tag X \<noteq> Pair  X' Y'" by transfer auto
lemma Tag_Enc: "Tag X \<noteq> Enc  X' Y'" by transfer auto
lemma Tag_Aenc: "Tag X \<noteq> Aenc  X' Y'" by transfer auto
lemma Tag_Sign: "Tag X \<noteq> Sign  X' Y'" by transfer auto
lemma Tag_Exp: "Tag X \<noteq> Exp  X' Y'" by transfer auto

lemma EphK_Nonce: "EphK X \<noteq> Nonce  X'" by transfer auto
lemma EphK_Agent: "EphK X \<noteq> Agent  X'" by transfer auto
lemma EphK_Number: "EphK X \<noteq> Number  X'" by transfer auto
lemma EphK_Hash: "EphK X \<noteq> Hash  X'" by transfer auto
lemma EphK_Tag: "EphK X \<noteq> Tag  X'" by transfer auto
lemma EphK_EphK: "(EphK X = EphK X') = (X = X')" by transfer auto
lemma EphK_LtK: "EphK X \<noteq> LtK  X'" by transfer auto
lemma EphK_Pair: "EphK X \<noteq> Pair  X' Y'" by transfer auto
lemma EphK_Enc: "EphK X \<noteq> Enc  X' Y'" by transfer auto
lemma EphK_Aenc: "EphK X \<noteq> Aenc  X' Y'" by transfer auto
lemma EphK_Sign: "EphK X \<noteq> Sign  X' Y'" by transfer auto
lemma EphK_Exp: "EphK X \<noteq> Exp  X' Y'" by transfer auto

lemma LtK_Nonce: "LtK X \<noteq> Nonce  X'" by transfer auto
lemma LtK_Agent: "LtK X \<noteq> Agent  X'" by transfer auto
lemma LtK_Number: "LtK X \<noteq> Number  X'" by transfer auto
lemma LtK_Hash: "LtK X \<noteq> Hash  X'" by transfer auto
lemma LtK_Tag: "LtK X \<noteq> Tag  X'" by transfer auto
lemma LtK_EphK: "LtK X \<noteq> EphK  X'" by transfer auto
lemma LtK_LtK: "(LtK X = LtK X') = (X = X')" by transfer auto
lemma LtK_Pair: "LtK X \<noteq> Pair  X' Y'" by transfer auto
lemma LtK_Enc: "LtK X \<noteq> Enc  X' Y'" by transfer auto
lemma LtK_Aenc: "LtK X \<noteq> Aenc  X' Y'" by transfer auto
lemma LtK_Sign: "LtK X \<noteq> Sign  X' Y'" by transfer auto
lemma LtK_Exp: "LtK X \<noteq> Exp  X' Y'" by transfer auto

lemma Pair_Nonce: "Pair X Y \<noteq> Nonce  X'" by transfer auto
lemma Pair_Agent: "Pair X Y \<noteq> Agent  X'" by transfer auto
lemma Pair_Number: "Pair X Y \<noteq> Number  X'" by transfer auto
lemma Pair_Hash: "Pair X Y \<noteq> Hash  X'" by transfer auto
lemma Pair_Tag: "Pair X Y \<noteq> Tag  X'" by transfer auto
lemma Pair_EphK: "Pair X Y \<noteq> EphK  X'" by transfer auto
lemma Pair_LtK: "Pair X Y \<noteq> LtK  X'" by transfer auto
lemma Pair_Pair: "(Pair X Y = Pair X' Y') = (X = X' \<and> Y = Y')" by transfer auto
lemma Pair_Enc: "Pair X Y \<noteq> Enc  X' Y'" by transfer auto
lemma Pair_Aenc: "Pair X Y \<noteq> Aenc  X' Y'" by transfer auto
lemma Pair_Sign: "Pair X Y \<noteq> Sign  X' Y'" by transfer auto
lemma Pair_Exp: "Pair X Y \<noteq> Exp  X' Y'" by transfer auto

lemma Enc_Nonce: "Enc X Y \<noteq> Nonce  X'" by transfer auto
lemma Enc_Agent: "Enc X Y \<noteq> Agent  X'" by transfer auto
lemma Enc_Number: "Enc X Y \<noteq> Number  X'" by transfer auto
lemma Enc_Hash: "Enc X Y \<noteq> Hash  X'" by transfer auto
lemma Enc_Tag: "Enc X Y \<noteq> Tag  X'" by transfer auto
lemma Enc_EphK: "Enc X Y \<noteq> EphK  X'" by transfer auto
lemma Enc_LtK: "Enc X Y \<noteq> LtK  X'" by transfer auto
lemma Enc_Pair: "Enc X Y \<noteq> Pair  X' Y'" by transfer auto
lemma Enc_Enc: "(Enc X Y = Enc X' Y') = (X = X' \<and> Y = Y')" by transfer auto
lemma Enc_Aenc: "Enc X Y \<noteq> Aenc  X' Y'" by transfer auto
lemma Enc_Sign: "Enc X Y \<noteq> Sign  X' Y'" by transfer auto
lemma Enc_Exp: "Enc X Y \<noteq> Exp  X' Y'" by transfer auto

lemma Aenc_Nonce: "Aenc X Y \<noteq> Nonce  X'" by transfer auto
lemma Aenc_Agent: "Aenc X Y \<noteq> Agent  X'" by transfer auto
lemma Aenc_Number: "Aenc X Y \<noteq> Number  X'" by transfer auto
lemma Aenc_Hash: "Aenc X Y \<noteq> Hash  X'" by transfer auto
lemma Aenc_Tag: "Aenc X Y \<noteq> Tag  X'" by transfer auto
lemma Aenc_EphK: "Aenc X Y \<noteq> EphK  X'" by transfer auto
lemma Aenc_LtK: "Aenc X Y \<noteq> LtK  X'" by transfer auto
lemma Aenc_Pair: "Aenc X Y \<noteq> Pair  X' Y'" by transfer auto
lemma Aenc_Enc: "Aenc X Y \<noteq> Enc  X' Y'" by transfer auto
lemma Aenc_Aenc: "(Aenc X Y = Aenc X' Y') = (X = X' \<and> Y = Y')" by transfer auto
lemma Aenc_Sign: "Aenc X Y \<noteq> Sign  X' Y'" by transfer auto
lemma Aenc_Exp: "Aenc X Y \<noteq> Exp  X' Y'" by transfer auto

lemma Sign_Nonce: "Sign X Y \<noteq> Nonce  X'" by transfer auto
lemma Sign_Agent: "Sign X Y \<noteq> Agent  X'" by transfer auto
lemma Sign_Number: "Sign X Y \<noteq> Number  X'" by transfer auto
lemma Sign_Hash: "Sign X Y \<noteq> Hash  X'" by transfer auto
lemma Sign_Tag: "Sign X Y \<noteq> Tag  X'" by transfer auto
lemma Sign_EphK: "Sign X Y \<noteq> EphK  X'" by transfer auto
lemma Sign_LtK: "Sign X Y \<noteq> LtK  X'" by transfer auto
lemma Sign_Pair: "Sign X Y \<noteq> Pair  X' Y'" by transfer auto
lemma Sign_Enc: "Sign X Y \<noteq> Enc  X' Y'" by transfer auto
lemma Sign_Aenc: "Sign X Y \<noteq> Aenc  X' Y'" by transfer auto
lemma Sign_Sign: "(Sign X Y = Sign X' Y') = (X = X' \<and> Y = Y')" by transfer auto
lemma Sign_Exp: "Sign X Y \<noteq> Exp  X' Y'" by transfer auto

lemma Exp_Nonce: "Exp X Y \<noteq> Nonce  X'" by transfer auto
lemma Exp_Agent: "Exp X Y \<noteq> Agent  X'" by transfer auto
lemma Exp_Number: "Exp X Y \<noteq> Number  X'" by transfer auto
lemma Exp_Hash: "Exp X Y \<noteq> Hash  X'" by transfer auto
lemma Exp_Tag: "Exp X Y \<noteq> Tag  X'" by transfer auto
lemma Exp_EphK: "Exp X Y \<noteq> EphK  X'" by transfer auto
lemma Exp_LtK: "Exp X Y \<noteq> LtK  X'" by transfer auto
lemma Exp_Pair: "Exp X Y \<noteq> Pair  X' Y'" by transfer auto
lemma Exp_Enc: "Exp X Y \<noteq> Enc  X' Y'" by transfer auto
lemma Exp_Aenc: "Exp X Y \<noteq> Aenc  X' Y'" by transfer auto
lemma Exp_Sign: "Exp X Y \<noteq> Sign  X' Y'" by transfer auto

lemmas msg_inject [iff, induct_simp] =
  Nonce_Nonce Agent_Agent Number_Number Hash_Hash Tag_Tag EphK_EphK LtK_LtK
  Pair_Pair Enc_Enc Aenc_Aenc Sign_Sign

lemmas msg_distinct [simp, induct_simp] =
  Nonce_Agent Nonce_Number Nonce_Hash Nonce_Tag Nonce_EphK Nonce_LtK Nonce_Pair
  Nonce_Enc Nonce_Aenc Nonce_Sign Nonce_Exp
  Agent_Nonce Agent_Number Agent_Hash Agent_Tag Agent_EphK Agent_LtK Agent_Pair
  Agent_Enc Agent_Aenc Agent_Sign Agent_Exp
  Number_Nonce Number_Agent Number_Hash Number_Tag Number_EphK Number_LtK
  Number_Pair Number_Enc Number_Aenc Number_Sign Number_Exp
  Hash_Nonce Hash_Agent Hash_Number Hash_Tag Hash_EphK Hash_LtK Hash_Pair
  Hash_Enc Hash_Aenc Hash_Sign Hash_Exp
  Tag_Nonce Tag_Agent Tag_Number Tag_Hash Tag_EphK Tag_LtK Tag_Pair
  Tag_Enc Tag_Aenc Tag_Sign Tag_Exp
  EphK_Nonce EphK_Agent EphK_Number EphK_Hash EphK_Tag EphK_LtK EphK_Pair
  EphK_Enc EphK_Aenc EphK_Sign EphK_Exp
  LtK_Nonce LtK_Agent LtK_Number LtK_Hash LtK_Tag LtK_EphK LtK_Pair
  LtK_Enc LtK_Aenc LtK_Sign LtK_Exp
  Pair_Nonce Pair_Agent Pair_Number Pair_Hash Pair_Tag Pair_EphK Pair_LtK
  Pair_Enc Pair_Aenc Pair_Sign Pair_Exp
  Enc_Nonce Enc_Agent Enc_Number Enc_Hash Enc_Tag Enc_EphK Enc_LtK Enc_Pair
  Enc_Aenc Enc_Sign Enc_Exp
  Aenc_Nonce Aenc_Agent Aenc_Number Aenc_Hash Aenc_Tag Aenc_EphK Aenc_LtK
  Aenc_Pair Aenc_Enc Aenc_Sign Aenc_Exp
  Sign_Nonce Sign_Agent Sign_Number Sign_Hash Sign_Tag Sign_EphK Sign_LtK
  Sign_Pair Sign_Enc Sign_Aenc Sign_Exp
  Exp_Nonce Exp_Agent Exp_Number Exp_Hash Exp_Tag Exp_EphK Exp_LtK Exp_Pair
  Exp_Enc Exp_Aenc Exp_Sign

consts Ngen :: nat
abbreviation "Gen \<equiv> Number Ngen"
abbreviation "cGen \<equiv> cNumber Ngen"

abbreviation
  "InsecTag \<equiv> Tag insec"

abbreviation
  "AuthTag \<equiv> Tag auth"

abbreviation
  "ConfidTag \<equiv> Tag confid"

abbreviation
  "SecureTag \<equiv> Tag secure"

abbreviation
  "Tags \<equiv> range Tag"

abbreviation
  NonceF :: "fresh_t \<Rightarrow> msg" where
  "NonceF N \<equiv> Nonce (nonce_fresh N)"

abbreviation
  NonceA :: "nat \<Rightarrow> msg" where
  "NonceA N \<equiv> Nonce (nonce_atk N)"

abbreviation
  shrK :: "agent \<Rightarrow> agent \<Rightarrow> msg" where
  "shrK A B \<equiv> LtK (sharK A B)"

abbreviation
  pubK :: "agent \<Rightarrow> msg" where
  "pubK A \<equiv> LtK (publK A)"

abbreviation
  priK :: "agent \<Rightarrow> msg" where
  "priK A \<equiv> LtK (privK A)"

abbreviation
  epubK :: "nonce_t \<Rightarrow> msg" where
  "epubK N \<equiv> EphK (epublK N)"

abbreviation
  epriK :: "nonce_t \<Rightarrow> msg" where
  "epriK N \<equiv> EphK (eprivK N)"

abbreviation
  epubKF :: "fresh_t \<Rightarrow> msg" where
  "epubKF N \<equiv> EphK (epublK (nonce_fresh N))"

abbreviation
  epriKF :: "fresh_t \<Rightarrow> msg" where
  "epriKF N \<equiv> EphK (eprivK (nonce_fresh N))"

abbreviation
  epubKA :: "nat \<Rightarrow> msg" where
  "epubKA N \<equiv> EphK (epublK (nonce_atk N))"

abbreviation
  epriKA :: "nat \<Rightarrow> msg" where
  "epriKA N \<equiv> EphK (eprivK (nonce_atk N))"

text\<open>Concrete syntax: messages appear as <A,B,NA>, etc...\<close>

syntax
  "_MTuple"      :: "['a, args] \<Rightarrow> 'a * 'b"       ("(2\<langle>_,/ _\<rangle>)")
translations
  "\<langle>x, y, z\<rangle>" \<rightleftharpoons> "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
  "\<langle>x, y\<rangle>"    \<rightleftharpoons> "CONST Pair x y"

text \<open>hash macs\<close>
abbreviation
  hmac :: "msg \<Rightarrow> msg \<Rightarrow> msg" where
  "hmac M K \<equiv> Hash \<langle>M, K\<rangle>"

text \<open>recover some kind of injectivity for Exp\<close>
lemma eq_expgen:
  "eq X Y \<Longrightarrow> (\<forall> X'. X = cExp cGen X' \<longrightarrow> (\<exists> Z. Y = (cExp cGen Z) \<and> eq X' Z)) \<and>
              (\<forall> Y'. Y = cExp cGen Y' \<longrightarrow> (\<exists> Z. X = (cExp cGen Z) \<and> eq Y' Z))"
by (erule eq.induct, auto elim!: Tr)

lemma Exp_Gen_inj: "Exp Gen X = Exp Gen Y \<Longrightarrow> X = Y"
by (transfer, auto dest: eq_expgen)

lemma eq_expexpgen:
  "eq X Y \<Longrightarrow> (\<forall> X' X''. X = cExp (cExp cGen X') X'' \<longrightarrow>
                (\<exists> Y' Y''. Y = cExp (cExp cGen Y') Y'' \<and>
                   ((eq X' Y' \<and> eq X'' Y'') \<or> (eq X' Y'' \<and> eq X'' Y'))))"
apply (erule eq.induct, simp_all)
apply ((drule eq_expgen)+, force)
apply (auto, blast+)
done

lemma Exp_Exp_Gen_inj:
  "Exp (Exp Gen X) X' = Z \<Longrightarrow>
   (\<exists> Y Y'. Z = Exp (Exp Gen Y) Y' \<and> ((X = Y \<and> X' = Y') \<or> (X = Y' \<and> X' = Y)))"
by (transfer, auto dest: eq_expexpgen)

lemma Exp_Exp_Gen_inj2:
  "Exp (Exp Gen X) X' = Exp Z Y' \<Longrightarrow>
  (Y' = X \<and> Z = Exp Gen X') \<or> (Y' = X' \<and> Z = Exp Gen X)"
apply (transfer, auto)
apply (drule eq_expexpgen, auto)+
done

end


header {* Functor Class *}

theory Functor
imports TypeApp Coerce
keywords "tycondef" :: thy_decl and "\<cdot>"
begin

subsection {* Class definition *}

text {* Here we define the @{text functor} class, which models the
Haskell class \texttt{Functor}. For technical reasons, we split the
definition of @{text functor} into two separate classes: First, we
introduce @{text prefunctor}, which only requires @{text fmap} to
preserve the identity function, and not function composition. *}

text {* The Haskell class \texttt{Functor f} fixes a polymorphic
function \texttt{fmap :: (a -> b) -> f a -> f b}. Since functions in
Isabelle type classes can only mention one type variable, we have the
@{text prefunctor} class fix a function @{text fmapU} that fixes both
of the polymorphic types to be the universal domain. We will use the
coercion operator to recover a polymorphic @{text fmap}. *}

text {* The single axiom of the @{text prefunctor} class is stated in
terms of the HOLCF constant @{text isodefl}, which relates a function
@{text "f :: 'a \<rightarrow> 'a"} with a deflation @{text "t :: udom defl"}:
@{thm isodefl_def [of f t, no_vars]}. *}

class prefunctor = "tycon" +
  fixes fmapU :: "(udom \<rightarrow> udom) \<rightarrow> udom\<cdot>'a \<rightarrow> udom\<cdot>'a::tycon"
  assumes isodefl_fmapU:
    "isodefl (fmapU\<cdot>(cast\<cdot>t)) (TC('a::tycon)\<cdot>t)"

text {* The @{text functor} class extends @{text prefunctor} with an
axiom stating that @{text fmapU} preserves composition. *}

class "functor" = prefunctor +
  assumes fmapU_fmapU [coerce_simp]:
    "\<And>f g (xs::udom\<cdot>'a::tycon).
      fmapU\<cdot>f\<cdot>(fmapU\<cdot>g\<cdot>xs) = fmapU\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"

text {* We define the polymorphic @{text fmap} by coercion from @{text
fmapU}, then we proceed to derive the polymorphic versions of the
functor laws. *}

definition fmap :: "('a \<rightarrow> 'b) \<rightarrow> 'a\<cdot>'f \<rightarrow> 'b\<cdot>'f::functor"
  where "fmap = coerce\<cdot>(fmapU :: _ \<rightarrow> udom\<cdot>'f \<rightarrow> udom\<cdot>'f)"

subsection {* Polymorphic functor laws *}

lemma fmapU_eq_fmap: "fmapU = fmap"
by (simp add: fmap_def eta_cfun)

lemma fmap_eq_fmapU: "fmap = fmapU"
  by (simp only: fmapU_eq_fmap)

lemma cast_TC:
  "cast\<cdot>(TC('f)\<cdot>t) = emb oo fmapU\<cdot>(cast\<cdot>t) oo PRJ(udom\<cdot>'f::prefunctor)"
by (rule isodefl_fmapU [unfolded isodefl_def])

lemma isodefl_cast: "isodefl (cast\<cdot>t) t"
by (simp add: isodefl_def)

lemma cast_cast_below1: "A \<sqsubseteq> B \<Longrightarrow> cast\<cdot>A\<cdot>(cast\<cdot>B\<cdot>x) = cast\<cdot>A\<cdot>x"
by (intro deflation_below_comp1 deflation_cast monofun_cfun_arg)

lemma cast_cast_below2: "A \<sqsubseteq> B \<Longrightarrow> cast\<cdot>B\<cdot>(cast\<cdot>A\<cdot>x) = cast\<cdot>A\<cdot>x"
by (intro deflation_below_comp2 deflation_cast monofun_cfun_arg)

lemma isodefl_fmap:
  assumes "isodefl d t"
  shows "isodefl (fmap\<cdot>d :: 'a\<cdot>'f \<rightarrow> _) (TC('f::functor)\<cdot>t)"
proof -
  have deflation_d: "deflation d"
    using assms by (rule isodefl_imp_deflation)
  have cast_t: "cast\<cdot>t = emb oo d oo prj"
    using assms unfolding isodefl_def .
  have t_below: "t \<sqsubseteq> DEFL('a)"
    apply (rule cast_below_imp_below)
    apply (simp only: cast_t cast_DEFL)
    apply (simp add: cfun_below_iff deflation.below [OF deflation_d])
    done
  have fmap_eq: "fmap\<cdot>d = PRJ('a\<cdot>'f) oo cast\<cdot>(TC('f)\<cdot>t) oo emb"
    by (simp add: fmap_def coerce_cfun cast_TC cast_t prj_emb cfcomp1)
  show ?thesis
    apply (simp add: fmap_eq isodefl_def cfun_eq_iff emb_prj)
    apply (simp add: DEFL_app)
    apply (simp add: cast_cast_below1 monofun_cfun t_below)
    apply (simp add: cast_cast_below2 monofun_cfun t_below)
    done
qed

lemma fmap_ID [simp]: "fmap\<cdot>ID = ID"
apply (rule isodefl_DEFL_imp_ID)
apply (subst DEFL_app)
apply (rule isodefl_fmap)
apply (rule isodefl_ID_DEFL)
done

lemma fmap_ident [simp]: "fmap\<cdot>(\<Lambda> x. x) = ID"
by (simp add: ID_def [symmetric])

lemma coerce_coerce_eq_fmapU_cast [coerce_simp]:
  fixes xs :: "udom\<cdot>'f::functor"
  shows "COERCE('a\<cdot>'f, udom\<cdot>'f)\<cdot>(COERCE(udom\<cdot>'f, 'a\<cdot>'f)\<cdot>xs) =
    fmapU\<cdot>(cast\<cdot>DEFL('a))\<cdot>xs"
by (simp add: coerce_def emb_prj DEFL_app cast_TC)

lemma fmap_fmap:
  fixes xs :: "'a\<cdot>'f::functor" and g :: "'a \<rightarrow> 'b" and f :: "'b \<rightarrow> 'c"
  shows "fmap\<cdot>f\<cdot>(fmap\<cdot>g\<cdot>xs) = fmap\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
unfolding fmap_def
by (simp add: coerce_simp)

lemma fmap_cfcomp: "fmap\<cdot>(f oo g) = fmap\<cdot>f oo fmap\<cdot>g"
by (simp add: cfcomp1 fmap_fmap eta_cfun)

subsection {* Derived properties of @{text fmap} *}

text {* Other theorems about @{text fmap} can be derived using only
the abstract functor laws. *}

lemma deflation_fmap:
  "deflation d \<Longrightarrow> deflation (fmap\<cdot>d)"
 apply (rule deflation.intro)
  apply (simp add: fmap_fmap deflation.idem eta_cfun)
 apply (subgoal_tac "fmap\<cdot>d\<cdot>x \<sqsubseteq> fmap\<cdot>ID\<cdot>x", simp)
 apply (rule monofun_cfun_fun, rule monofun_cfun_arg)
 apply (erule deflation.below_ID)
done

lemma ep_pair_fmap:
  "ep_pair e p \<Longrightarrow> ep_pair (fmap\<cdot>e) (fmap\<cdot>p)"
 apply (rule ep_pair.intro)
  apply (simp add: fmap_fmap ep_pair.e_inverse)
 apply (simp add: fmap_fmap)
 apply (rule_tac y="fmap\<cdot>ID\<cdot>y" in below_trans)
  apply (rule monofun_cfun_fun)
  apply (rule monofun_cfun_arg)
  apply (rule cfun_belowI, simp)
  apply (erule ep_pair.e_p_below)
 apply simp
done

lemma fmap_strict:
  fixes f :: "'a \<rightarrow> 'b"
  assumes "f\<cdot>\<bottom> = \<bottom>" shows "fmap\<cdot>f\<cdot>\<bottom> = (\<bottom>::'b\<cdot>'f::functor)"
proof (rule bottomI)
  have "fmap\<cdot>f\<cdot>(\<bottom>::'a\<cdot>'f) \<sqsubseteq> fmap\<cdot>f\<cdot>(fmap\<cdot>\<bottom>\<cdot>(\<bottom>::'b\<cdot>'f))"
    by (simp add: monofun_cfun)
  also have "... = fmap\<cdot>(\<Lambda> x. f\<cdot>(\<bottom>\<cdot>x))\<cdot>(\<bottom>::'b\<cdot>'f)"
    by (simp add: fmap_fmap)
  also have "... \<sqsubseteq> fmap\<cdot>ID\<cdot>\<bottom>"
    by (simp add: monofun_cfun assms del: fmap_ID)
  also have "... = \<bottom>"
    by simp
  finally show "fmap\<cdot>f\<cdot>\<bottom> \<sqsubseteq> (\<bottom>::'b\<cdot>'f::functor)" .
qed

subsection {* Proving that @{text "fmap\<cdot>coerce = coerce"} *}

lemma fmapU_cast_eq:
  "fmapU\<cdot>(cast\<cdot>A) =
    PRJ(udom\<cdot>'f) oo cast\<cdot>(TC('f::functor)\<cdot>A) oo emb"
by (subst cast_TC, rule cfun_eqI, simp)

lemma fmapU_cast_DEFL:
  "fmapU\<cdot>(cast\<cdot>DEFL('a)) =
    PRJ(udom\<cdot>'f) oo cast\<cdot>DEFL('a\<cdot>'f::functor) oo emb"
by (simp add: fmapU_cast_eq DEFL_app)

lemma coerce_functor: "COERCE('a\<cdot>'f, 'b\<cdot>'f::functor) = fmap\<cdot>coerce"
apply (rule cfun_eqI, rename_tac xs)
apply (simp add: fmap_def coerce_cfun)
apply (simp add: coerce_def)
apply (simp add: cfcomp1)
apply (simp only: emb_prj)
apply (subst fmapU_fmapU [symmetric])
apply (simp add: fmapU_cast_DEFL)
apply (simp add: emb_prj)
apply (simp add: cast_cast_below1 cast_cast_below2)
done

subsection {* Lemmas for reasoning about coercion *}

lemma fmapU_cast_coerce [coerce_simp]:
  fixes m :: "'a\<cdot>'f::functor"
  shows "fmapU\<cdot>(cast\<cdot>DEFL('a))\<cdot>(COERCE('a\<cdot>'f, udom\<cdot>'f)\<cdot>m) =
    COERCE('a\<cdot>'f, udom\<cdot>'f)\<cdot>m"
by (simp add: coerce_functor cast_DEFL fmapU_eq_fmap fmap_fmap eta_cfun)

lemma coerce_fmap [coerce_simp]:
  fixes xs :: "'a\<cdot>'f::functor" and f :: "'a \<rightarrow> 'b"
  shows "COERCE('b\<cdot>'f, 'c\<cdot>'f)\<cdot>(fmap\<cdot>f\<cdot>xs) = fmap\<cdot>(\<Lambda> x. COERCE('b,'c)\<cdot>(f\<cdot>x))\<cdot>xs"
by (simp add: coerce_functor fmap_fmap)

lemma fmap_coerce [coerce_simp]:
  fixes xs :: "'a\<cdot>'f::functor" and f :: "'b \<rightarrow> 'c"
  shows "fmap\<cdot>f\<cdot>(COERCE('a\<cdot>'f, 'b\<cdot>'f)\<cdot>xs) = fmap\<cdot>(\<Lambda> x. f\<cdot>(COERCE('a,'b)\<cdot>x))\<cdot>xs"
by (simp add: coerce_functor fmap_fmap)

subsection {* Configuration of Domain package *}

text {* We make various theorem declarations to enable Domain
  package definitions that involve @{text "tycon"} application. *}

setup {* Domain_Take_Proofs.add_rec_type (@{type_name app}, [true, false]) *}

declare DEFL_app [domain_defl_simps]
declare fmap_ID [domain_map_ID]
declare deflation_fmap [domain_deflation]
declare isodefl_fmap [domain_isodefl]

subsection {* Configuration of the Tycon package *}

text {* We now set up a new type definition command, which is used for
  defining new @{text tycon} instances. The @{text tycondef} command
  is implemented using much of the same code as the Domain package,
  and supports a similar input syntax. It automatically generates a
  @{text prefunctor} instance for each new type. (The user must
  provide a proof of the composition law to obtain a @{text functor}
  class instance.) *}

ML_file "tycondef.ML"

end


theory Regex_ACIDZ
  imports "HOL-Library.Confluent_Quotient"
begin

datatype (discs_sels) 'a rexp = Zero | Eps | Atom 'a
  | Alt "'a rexp" "'a rexp" | Conc "'a rexp" "'a rexp" | Star "'a rexp"

fun elim_zeros where
  "elim_zeros (Alt r s) =
    (let r' = elim_zeros r; s' = elim_zeros s in
     if r' = Zero then s' else if s' = Zero then r' else Alt r' s')"
| "elim_zeros (Conc r s) = (let r' = elim_zeros r in if r' = Zero then Zero else Conc r' s)"
| "elim_zeros r = r"

fun distribute where
  "distribute t (Alt r s) = Alt (distribute t r) (distribute t s)"
| "distribute t (Conc r s) = Conc (distribute s r) t"
| "distribute t r = Conc r t"

inductive ACIDZ (infix "~" 64) where
  a1: "Alt (Alt r s) t ~ Alt r (Alt s t)"
| a2: "Alt r (Alt s t) ~ Alt (Alt r s) t"
| c: "Alt r s ~ Alt s r"
| i: "r ~ Alt r r"
| z: "r ~ s \<Longrightarrow> r ~ elim_zeros s"
| d: "Conc r t ~ distribute t r"
| R: "r ~ r"
| A: "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> Alt r s ~ Alt r' s'"
| C: "r ~ r' \<Longrightarrow> Conc r s ~ Conc r' s"

inductive_cases ACIDZ_AltE[elim]: "Alt r s ~ t"
inductive_cases ACIDZ_ConcE[elim]: "Conc r s ~ t"
inductive_cases ACIDZ_StarE[elim]: "Star r ~ t"

declare ACIDZ.intros[intro]

abbreviation ACIDZcl (infix "~~" 64) where "(~~) \<equiv> equivclp (~)"

lemma map_rexp_distribute[simp]: "map_rexp f (distribute t r) = distribute (map_rexp f t) (map_rexp f r)"
  by (induct r arbitrary: t) auto

lemma set_rexp_distribute[simp]: "set_rexp (distribute t r) = set_rexp r \<union> set_rexp t"
  by (induct r arbitrary: t) auto

lemma Zero_eq_map_rexp_iff[simp]:
  "Zero = map_rexp f x \<longleftrightarrow> x = Zero"
  "map_rexp f x = Zero \<longleftrightarrow> x = Zero"
  by (cases x; auto)+

lemma Alt_eq_map_rexp_iff:
  "Alt r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  "map_rexp f x = Alt r s \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  by (cases x; auto)+

lemma map_rexp_elim_zeros[simp]: "map_rexp f (elim_zeros r) = elim_zeros (map_rexp f r)"
  by (induct r rule: elim_zeros.induct) (auto simp: Let_def)

lemma set_rexp_elim_zeros: "set_rexp (elim_zeros r) \<subseteq> set_rexp r"
  by (induct r rule: elim_zeros.induct) (auto simp: Let_def)

lemma ACIDZ_map_respects:
  fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
  assumes "r ~ s"
  shows "map_rexp f r ~ map_rexp f s"
  using assms by (induct r s rule: ACIDZ.induct) (auto simp: Let_def)

lemma ACIDZcl_map_respects:
  fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
  assumes "r ~~ s"
  shows "map_rexp f r ~~ map_rexp f s"
  using assms by (induct rule: equivclp_induct) (auto intro: ACIDZ_map_respects equivclp_trans)

lemma finite_set_rexp: "finite (set_rexp r)"
  by (induct r) auto

lemma ACIDZ_set_rexp: "r ~ s \<Longrightarrow> set_rexp s \<subseteq> set_rexp r"
  by (induct r s rule: ACIDZ.induct) (auto dest: set_mp[OF set_rexp_elim_zeros] simp: Let_def)

lemma ACIDZ_set_rexp': "(~)\<^sup>*\<^sup>* r s \<Longrightarrow> set_rexp s \<subseteq> set_rexp r"
  by (induct rule: rtranclp.induct) (auto dest: ACIDZ_set_rexp)

lemma Conc_eq_map_rexp_iff:
  "Conc r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  "map_rexp f x = Conc r s \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
  by (cases x; auto)+

lemma Star_eq_map_rexp_iff:
  "Star r = map_rexp f x \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
  "map_rexp f x = Star r \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
  by (cases x; auto)+

lemma AAA: "(~)\<^sup>*\<^sup>* r  r' \<Longrightarrow> (~)\<^sup>*\<^sup>* s s' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Alt r s) (Alt r' s')"
proof (induct r r' rule: rtranclp.induct)
  case (rtrancl_refl r)
  then show ?case
    by (induct s s' rule: rtranclp.induct)
      (auto elim!: rtranclp.rtrancl_into_rtrancl)
next
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
qed

lemma CCC: "(~)\<^sup>*\<^sup>* r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Conc r s) (Conc r' s)"
proof (induct r r' rule: rtranclp.induct)
  case (rtrancl_refl r)
  then show ?case
    by simp
next
  case (rtrancl_into_rtrancl a b c)
  then show ?case
    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
qed

lemma map_rexp_ACIDZ_inv: "map_rexp f x ~ y \<Longrightarrow> \<exists>z. (~)\<^sup>*\<^sup>* x z \<and> y = map_rexp f z"
proof (induct "map_rexp f x" y arbitrary: x rule: ACIDZ.induct)
  case (a1 r s t)
  then obtain r' s' t' where "x = Alt (Alt r' s') t'"
    "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
    by (auto simp: Alt_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "Alt r' (Alt s' t')"]) auto
next
  case (a2 r s t)
  then obtain r' s' t' where "x = Alt r' (Alt s' t')"
    "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
    by (auto simp: Alt_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "Alt (Alt r' s') t'"]) auto
next
  case (c r s)
  then obtain r' s' where "x = Alt r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Alt_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "Alt s' r'"]) auto
next
  case (i r)
  then show ?case
    by (intro exI[of _ "Alt r r"]) auto
next
  case (z r)
  then show ?case
    by (metis ACIDZ.z R map_rexp_elim_zeros rtranclp.simps)
next
  case (d r s)
  then obtain r' s' where "x = Conc r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Conc_eq_map_rexp_iff)
  then show ?case
    by (intro exI[of _ "distribute s' r'"]) auto
next
  case (R r)
  then show ?case by (auto intro: exI[of _ r])
next
  case (A r rr s ss)
  then obtain r' s' where "x = Alt r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Alt_eq_map_rexp_iff)
  moreover from A(2)[OF this(2)[symmetric]] A(4)[OF this(3)[symmetric]] obtain rr' ss' where
    "(~)\<^sup>*\<^sup>* r' rr'" "rr = map_rexp f rr'" "(~)\<^sup>*\<^sup>* s' ss'" "ss = map_rexp f ss'"
    by blast
  ultimately show ?case using A(1,3)
    by (intro exI[of _ "Alt rr' ss'"]) (auto intro!: AAA)
next
  case (C r rr s)
  then obtain r' s' where "x = Conc r' s'"
    "map_rexp f r' = r" "map_rexp f s' = s"
    by (auto simp: Conc_eq_map_rexp_iff)
  moreover from C(2)[OF this(2)[symmetric]] obtain rr' where
    "(~)\<^sup>*\<^sup>* r' rr'" "rr = map_rexp f rr'"
    by blast
  ultimately show ?case using C(1,3)
    by (intro exI[of _ "Conc rr' s'"]) (auto intro!: CCC)
qed

lemma reflclp_ACIDZ: "(~)\<^sup>=\<^sup>= = (~)"
  unfolding fun_eq_iff
  by auto

lemma elim_zeros_distribute_Zero: "elim_zeros r = Zero \<Longrightarrow> elim_zeros (distribute t r) = Zero"
  by (induct r arbitrary: t) (auto simp: Let_def split: if_splits)

lemma elim_zeros_ACIDZ_Zero: "r ~ s \<Longrightarrow> elim_zeros r = Zero \<Longrightarrow> elim_zeros s = Zero"
  by (induct r s rule: ACIDZ.induct) (auto simp: Let_def elim_zeros_distribute_Zero split: if_splits)

lemma AZZ[simp]: "Alt Zero Zero ~ Zero"
  by (metis elim_zeros.simps(3) elim_zeros_ACIDZ_Zero i z)

lemma elim_zeros_idem[simp]: "elim_zeros (elim_zeros r) = elim_zeros r"
  by (induct r rule: elim_zeros.induct) (auto simp: Let_def)

lemma elim_zeros_distribute_idem: "elim_zeros (distribute s (elim_zeros r)) = elim_zeros (distribute s r)"
  by (induct r arbitrary: s rule: elim_zeros.induct) (auto simp: Let_def)

lemma zz: "r ~ s \<Longrightarrow> t = elim_zeros s \<Longrightarrow> r ~ t"
  by (metis z)

lemma elim_zeros_ACIDZ1: "r ~ s \<Longrightarrow> elim_zeros r ~ elim_zeros s"
proof (induct r s rule: ACIDZ.induct)
  case (c r s)
  then show ?case by (auto simp: Let_def)
next
  case (d r t)
  then show ?case
    by (smt (verit, ccfv_SIG) ACIDZ.d R elim_zeros.simps(2) elim_zeros_distribute_Zero elim_zeros_distribute_idem z)
next
  case (A r r' s s')
  then show ?case
    by (auto 0 2 simp: Let_def dest: elim_zeros_ACIDZ_Zero elim: zz[OF ACIDZ.A])
next
  case (C r r' s)
  then show ?case
    by (smt (verit, best) ACIDZ.C R elim_zeros.simps(2) elim_zeros_ACIDZ_Zero z)
qed (auto simp: Let_def)

lemma AA': "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> t = elim_zeros (Alt r' s') \<Longrightarrow> Alt r s ~ t"
  by (auto simp del: elim_zeros.simps)

lemma distribute_ACIDZ1: "r ~ r' \<Longrightarrow> distribute s r ~ elim_zeros (distribute s r')"
proof (induct r r' arbitrary: s rule: ACIDZ.induct)
  case (A r r' s s' u)
  from A(2,4)[of u] show ?case
    by (auto simp: Let_def elim: zz[OF ACIDZ.A])
next
  case (C r r' s)
  then show ?case
    by (smt (verit, best) ACIDZ.C distribute.simps(2,3) elim_zeros.simps(2,3) z)
qed (auto simp del: elim_zeros.simps simp: elim_zeros_distribute_idem)

lemma elim_zeros_ACIDZ: "r ~ s \<Longrightarrow> (~)\<^sup>*\<^sup>* (elim_zeros r) (elim_zeros s)"
  using elim_zeros_ACIDZ1 by blast

lemma elim_zeros_ACIDZ_rtranclp: "(~)\<^sup>*\<^sup>* r s \<Longrightarrow> (~)\<^sup>*\<^sup>* (elim_zeros r) (elim_zeros s)"
  by (induct rule: rtranclp_induct) (auto elim!: rtranclp_trans elim_zeros_ACIDZ)

lemma distribute_ACIDZ: "(~) r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* (distribute s r) (elim_zeros (distribute s r'))"
  by (metis distribute_ACIDZ1 rtranclp.simps)

lemma ACIDZ_elim_zeros: "(~) r s \<Longrightarrow> elim_zeros r = Zero \<Longrightarrow> elim_zeros s = Zero"
  by (meson elim_zeros_ACIDZ1 elim_zeros_ACIDZ_Zero)

lemma ACIDZ_elim_zeros_rtranclp:
  "(~)\<^sup>*\<^sup>* r s \<Longrightarrow> elim_zeros r = Zero \<Longrightarrow> elim_zeros s = Zero"
  by (induct rule: rtranclp_induct) (auto elim: ACIDZ_elim_zeros)

lemma Alt_elim_zeros[simp]:
  "Alt (elim_zeros r) s ~ elim_zeros (Alt r s)"
  "Alt r (elim_zeros s) ~ elim_zeros (Alt r s)"
  by (smt (verit, ccfv_threshold) ACIDZ.simps elim_zeros.simps(1) elim_zeros_idem)+

lemma strong_confluentp_ACIDZ: "strong_confluentp (~)"
proof (rule strong_confluentpI, unfold reflclp_ACIDZ)
  fix x y z :: "'a rexp"
  assume "x ~ y" "x ~ z"
  then show "\<exists>u. (~)\<^sup>*\<^sup>* y u \<and> z ~ u"
  proof (induct x y arbitrary: z rule: ACIDZ.induct)
    case (a1 r s t)
    then show ?case
      by (auto intro: AAA converse_rtranclp_into_rtranclp)
  next
    case (a2 r s t)
    then show ?case
      by (auto intro: AAA converse_rtranclp_into_rtranclp)
  next
    case (c r s)
    then show ?case
      by (cases rule: ACIDZ.cases)
        (auto 0 4 intro: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ R], rotated]
          converse_rtranclp_into_rtranclp[where r="(~)", OF ACIDZ.c])
  next
    case (i r)
    then show ?case
      by (auto intro: AAA)
  next
    case (z r s)
    then show ?case
      by (meson ACIDZ.z elim_zeros_ACIDZ_rtranclp)
  next
    case (d r s t)
    then show ?case
      by (induct "Conc r s" t rule: ACIDZ.induct)
        (force intro: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ z], rotated]
          exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ z[OF elim_zeros_ACIDZ1]], rotated]
          distribute_ACIDZ1 elim!: rtranclp_trans)+
  next
    case (R r)
    then show ?case
      by auto
  next
    note A1 = ACIDZ.A[OF _ R]
    note A2 = ACIDZ.A[OF R]
    case (A r r' s s')
    from A(5,1-4) show ?case
    proof (induct "Alt r s" z rule: ACIDZ.induct)
      case inner: (a1 r'' s'')
      from A(1,3) show ?case
        unfolding inner.hyps[symmetric]
      proof (induct "Alt r'' s''" r' rule: ACIDZ.induct[consumes 1, case_names Xa1 Xa2 Xc Xi Xz Xd XR XA XC])
        case Xa1
        with A(3) show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
           (metis A1 a1 a2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case Xa2
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
            (metis a1 A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case Xc
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
            (metis a1 c A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case Xi
        then show ?case
          apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACIDZ.A[OF i ACIDZ.A[OF i]]], rotated])
          apply (rule converse_rtranclp_into_rtranclp, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply blast
          done
      next
        case Xz
        with A show ?case
          by (auto elim!: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ z], rotated]
            converse_rtranclp_into_rtranclp[rotated, OF elim_zeros_ACIDZ_rtranclp]
            simp del: elim_zeros.simps)
      qed auto
    next
      case inner: (a2 s'' t'')
      from A(3,1) show ?case
        unfolding inner.hyps[symmetric]
      proof (induct "Alt s'' t''" s' rule: ACIDZ.induct[consumes 1, case_names Xa1 Xa2 Xc Xi Xz Xd XR XA XC])
        case Xa1
        with A(3) show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
            (metis a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case Xa2
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
            (metis a1 a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case Xc
        then show ?case
          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
            (metis a2 c A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
      next
        case Xi
        then show ?case
          apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACIDZ.A[OF ACIDZ.A[OF _ i] i]], rotated])
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A2, rule a1)
          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
          apply (rule converse_rtranclp_into_rtranclp, rule a2)
          apply blast
          done
      next
        case Xz
        then show ?case
          by (auto elim!: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ z], rotated]
            converse_rtranclp_into_rtranclp[rotated, OF elim_zeros_ACIDZ_rtranclp]
            simp del: elim_zeros.simps)
      qed auto
    next
      case (z rs) with A show ?case
        by (auto elim!: rtranclp_trans
          intro!: exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ elim_zeros_ACIDZ1], rotated])
    qed (auto 5 0 intro: AAA)
  next
    case (C r r' s s')
    from C(3,1-2) show ?case
      by (induct "Conc r s" s' rule: ACIDZ.induct)
        (auto intro: CCC elim!: rtranclp_trans
          exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ elim_zeros_ACIDZ1], rotated]
          exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ distribute_ACIDZ1], rotated])
  qed
qed

lemma confluent_quotient_ACIDZ:
  "confluent_quotient (~) (~~) (~~) (~~) (~~) (~~)
     (map_rexp fst) (map_rexp snd) (map_rexp fst) (map_rexp snd)
     rel_rexp rel_rexp rel_rexp set_rexp set_rexp"
  by unfold_locales
    (auto 4 4 dest: ACIDZ_set_rexp' simp: rexp.in_rel rexp.rel_compp dest: map_rexp_ACIDZ_inv intro: rtranclp_into_equivclp
      intro: equivpI reflpI sympI transpI ACIDZcl_map_respects
      strong_confluentp_imp_confluentp[OF strong_confluentp_ACIDZ])

lemma wide_intersection_finite_ACIDZ: "wide_intersection_finite (~~) map_rexp set_rexp"
  by unfold_locales
    (auto intro: ACIDZcl_map_respects rexp.map_cong simp: rexp.map_id rexp.set_map finite_set_rexp)

inductive ACIDZEQ (infix "\<approx>" 64) where
  a: "Alt (Alt r s) t \<approx> Alt r (Alt s t)"
| c: "Alt r s \<approx> Alt s r"
| i: "Alt r r \<approx> r"
| cz: "Conc Zero r \<approx> Zero"
| az: "Alt Zero r \<approx> r"
| d: "Conc (Alt r s) t \<approx> Alt (Conc r t) (Conc s t)"
| A: "r \<approx> r' \<Longrightarrow> s \<approx> s' \<Longrightarrow> Alt r s \<approx> Alt r' s'"
| C: "r \<approx> r' \<Longrightarrow> Conc r s \<approx> Conc r' s"
| r: "r \<approx> r"
| s: "r \<approx> s \<Longrightarrow> s \<approx> r"
| t: "r \<approx> s \<Longrightarrow> s \<approx> t \<Longrightarrow> r \<approx> t"

context begin

private lemma AA: "r ~~ r' \<Longrightarrow> s ~~ s' \<Longrightarrow> Alt r s ~~ Alt r' s'"
proof (induct rule: equivclp_induct)
  case base
  then show ?case
    by (induct rule: equivclp_induct) (auto elim!: equivclp_trans)
next
  case (step s t)
  then show ?case
    by (auto elim!: equivclp_trans)
qed

private lemma CC: "r ~~ r' \<Longrightarrow> Conc r s ~~ Conc r' s"
proof (induct rule: equivclp_induct)
  case base
  then show ?case
    by simp
next
  case (step s t)
  then show ?case
    by (auto elim!: equivclp_trans)
qed

private lemma CZ: "Conc Zero r ~~ Zero"
  by (metis R distribute.simps(3) elim_zeros.simps(3) elim_zeros_distribute_Zero r_into_equivclp z)

private lemma AZ: "Alt Zero r ~~ r"
  by (smt (verit, ccfv_threshold) converse_r_into_equivclp converse_rtranclp_into_rtranclp
    elim_zeros.simps(1) elim_zeros.simps(3) equivclp_def symclpI1 z R)

private lemma D: "Conc (Alt r s) t ~~ Alt (Conc r t) (Conc s t)"
  by (smt (verit, ccfv_threshold) AA ACIDZ.d converse_r_into_equivclp distribute.simps(1)
    equivclp_sym rtranclp.simps rtranclp_equivclp)

lemma ACIDZEQ_le_ACIDZcl: "r \<approx> s \<Longrightarrow> r ~~ s"
  by (induct r s rule: ACIDZEQ.induct) (auto intro: AA CC AZ CZ D equivclp_sym equivclp_trans)

end

lemma ACIDZEQ_z[simp]: "r \<approx> elim_zeros r"
  by (induct r rule: elim_zeros.induct) (auto 0 3 intro: ACIDZEQ.intros simp: Let_def)

lemma ACIDZEQ_d[simp]: "Conc r s \<approx> distribute s r"
  by (induct s r rule: distribute.induct) (auto 0 3 intro: ACIDZEQ.intros)

lemma ACIDZ_le_ACIDZEQ: "r ~ s \<Longrightarrow> r \<approx> s"
  by (induct r s rule: ACIDZ.induct) (auto 0 2 intro: ACIDZEQ.intros simp: Let_def)

lemma ACIDZcl_le_ACIDZEQ: "r ~~ s \<Longrightarrow> r \<approx> s"
  by (induct rule: equivclp_induct) (auto 0 3 intro: ACIDZEQ.intros ACIDZ_le_ACIDZEQ)

lemma ACIDZEQ_alt: "(\<approx>) = (~~)"
  by (simp add: ACIDZEQ_le_ACIDZcl ACIDZcl_le_ACIDZEQ antisym predicate2I)

quotient_type 'a rexp_ACIDZ = "'a rexp" / "(\<approx>)"
  unfolding ACIDZEQ_alt by (auto intro!: equivpI reflpI sympI transpI)

lift_bnf 'a rexp_ACIDZ
  unfolding ACIDZEQ_alt
  subgoal for A Q by (rule confluent_quotient.subdistributivity[OF confluent_quotient_ACIDZ])
  subgoal for Ss by (elim wide_intersection_finite.wide_intersection[OF wide_intersection_finite_ACIDZ])
  done

datatype ldl = Prop string | And ldl ldl | Not ldl | Match "ldl rexp_ACIDZ"

end