theory Lehmer
imports
  Main
  "HOL-Number_Theory.Residues"
begin

section \<open>Lehmer's Theorem\<close>
text_raw \<open>\label{sec:lehmer}\<close>

text \<open>
  In this section we prove Lehmer's Theorem~\<^cite>\<open>"lehmer1927fermat_converse"\<close> and its converse.
  These two theorems characterize a necessary and complete criterion for primality. This criterion
  is the basis of the Lucas-Lehmer primality test and the primality certificates of
  Pratt~\<^cite>\<open>"pratt1975certificate"\<close>.
\<close>

lemma mod_1_coprime_nat:
  "coprime a b" if "0 < n" "[a ^ n = 1] (mod b)" for a b :: nat
proof -
  from that coprime_1_left have "coprime (a ^ n) b"
    using cong_imp_coprime cong_sym by blast
  with \<open>0 < n\<close> show ?thesis
    by simp
qed

text \<open>
  This is a weak variant of Lehmer's theorem: All numbers less then @{term "p - 1 :: nat"}
  must be considered.
\<close>

lemma lehmers_weak_theorem:
  assumes "2 \<le> p"
  assumes min_cong1: "\<And>x. 0 < x \<Longrightarrow> x < p - 1 \<Longrightarrow> [a ^ x \<noteq> 1] (mod p)"
  assumes cong1: "[a ^ (p - 1) = 1] (mod p)"
  shows "prime p"
proof (rule totient_imp_prime)
  from \<open>2 \<le> p\<close> cong1 have "coprime a p"
    by (intro mod_1_coprime_nat[of "p - 1"]) auto
  then have "[a ^ totient p = 1] (mod p)"
    by (intro euler_theorem) auto
  then have "totient p \<ge> p - 1 \<or> totient p = 0"
    using min_cong1[of "totient p"] by fastforce
  moreover have "totient p > 0"
    using \<open>2 \<le> p\<close> by simp
  moreover from \<open>p \<ge> 2\<close> have "totient p < p" by (intro totient_less) auto
  ultimately show "totient p = p - 1" by presburger
qed (insert \<open>p \<ge> 2\<close>, auto)

lemma prime_factors_elem:
  fixes n :: nat assumes "1 < n" shows "\<exists>p. p \<in> prime_factors n"
  using assms by (cases "prime n") (auto simp: prime_factors_dvd prime_factor_nat)

lemma cong_pow_1_nat:
  "[a ^ x = 1] (mod b)" if "[a = 1] (mod b)" for a b :: nat
  using cong_pow [of a 1 b x] that by simp

lemma cong_gcd_eq_1_nat:
  fixes a b :: nat
  assumes "0 < m" and cong_props: "[a ^ m = 1] (mod b)" "[a ^ n = 1] (mod b)"
  shows "[a ^ gcd m n = 1] (mod b)"
proof -
  obtain c d where gcd: "m * c = n * d + gcd m n" using bezout_nat[of m n] \<open>0 < m\<close>
    by auto
  have cong_m: "[a ^ (m * c) = 1] (mod b)" and cong_n: "[a ^ (n * d) = 1] (mod b)"
    using cong_props by (simp_all only: cong_pow_1_nat power_mult)
  have "[1 * a ^ gcd m n = a ^ (n * d) * a ^ gcd m n] (mod b)"
    by (rule cong_scalar_right, rule cong_sym) (fact cong_n)
  also have "[a ^ (n * d) * a ^ gcd m n = a ^ (m * c)] (mod b)"
    using gcd by (simp add: power_add)
  also have "[a ^ (m * c) = 1] (mod b)" using cong_m by simp
  finally show "[a ^ gcd m n = 1] (mod b)" by simp
qed

lemma One_leq_div:
  "1 < b div a" if "a dvd b" "a < b" for a b :: nat
  using that by (metis dvd_div_mult_self mult.left_neutral mult_less_cancel2)

theorem lehmers_theorem:
  assumes "2 \<le> p"
  assumes pf_notcong1: "\<And>x. x \<in> prime_factors (p - 1) \<Longrightarrow> [a ^ ((p - 1) div x) \<noteq> 1] (mod p)"
  assumes cong1: "[a ^ (p - 1) = 1] (mod p)"
  shows "prime p"
proof cases
  assume "[a = 1] (mod p)" with \<open>2 \<le>p\<close> pf_notcong1 show ?thesis
    by (metis cong_pow_1_nat less_diff_conv linorder_neqE_nat linorder_not_less
      one_add_one prime_factors_elem two_is_prime_nat)
next
  assume A_notcong_1: "[a \<noteq> 1] (mod p)"
  { fix x assume "0 < x" "x < p - 1"
    have "[a ^ x \<noteq> 1] (mod p)"
    proof
      assume "[a ^ x = 1] (mod p)"
      then have gcd_cong_1: "[a ^ gcd x (p - 1) = 1] (mod p)"
        by (rule cong_gcd_eq_1_nat[OF \<open>0 < x\<close> _ cong1])

      have "gcd x (p - 1) = p - 1"
      proof (rule ccontr)
        assume "\<not>?thesis"
        then have gcd_p1: "gcd x (p - 1) dvd (p - 1)" "gcd x (p - 1) < p - 1"
          using gcd_le2_nat[of "p - 1" x] \<open>2 \<le> p\<close> by (simp, linarith)

        define c where "c = (p - 1) div (gcd x (p - 1))"
        then have p_1_eq: "p - 1 = gcd x (p - 1) * c" unfolding c_def using gcd_p1
          by (metis dvd_mult_div_cancel)

        from gcd_p1 have "1 < c" unfolding c_def by (rule One_leq_div)
        then obtain q where q_pf: "q \<in> prime_factors c"
          using prime_factors_elem by auto
        then have "q dvd c" by auto

        have "q \<in> prime_factors (p - 1)" using q_pf \<open>1 < c\<close> \<open>2 \<le> p\<close>
          by (subst p_1_eq) (simp add: prime_factors_product)
        moreover
        have "[a ^ ((p - 1) div q) = 1] (mod p)"
          by (subst p_1_eq,subst dvd_div_mult_self[OF \<open>q dvd c\<close>,symmetric])
             (simp del: One_nat_def add: power_mult gcd_cong_1 cong_pow_1_nat)
        ultimately
        show False using pf_notcong1 by metis
      qed
      then show False using \<open>x < p - 1\<close>
        by (metis \<open>0 < x\<close> gcd_le1_nat gr_implies_not0 linorder_not_less)
    qed
  }
  with lehmers_weak_theorem[OF \<open>2 \<le> p\<close> _ cong1] show ?thesis by metis
qed

text \<open>
  The converse of Lehmer's theorem is also true.
\<close>

lemma converse_lehmer_weak:
 assumes prime_p: "prime p"
 shows "\<exists> a. [a^(p - 1) = 1] (mod p) \<and> (\<forall> x . 0 < x \<longrightarrow> x \<le> p - 2 \<longrightarrow> [a^x \<noteq> 1] (mod p))
             \<and> a > 0 \<and> a < p"
 proof -
   have "p \<ge> 2" by (rule prime_ge_2_nat[OF prime_p])
   obtain a where a:"a \<in> {1 .. p - 1} \<and> {1 .. p - 1} = {a^i mod p | i . i \<in> UNIV}"
    using residue_prime_mult_group_has_gen[OF prime_p] by blast
  {
   { fix x::nat assume x:"0 < x \<and> x \<le> p - 2 \<and> [a^x = 1] (mod p)"
     have "{a^i mod p| i. i \<in> UNIV} = {a^i mod p | i. 0 < i \<and> i \<le> x}"
     proof
      show "{a ^ i mod p | i. 0 < i \<and> i \<le> x} \<subseteq> {a ^ i mod p | i. i \<in> UNIV}" by blast
      { fix y assume y:"y \<in> {a^i mod p| i . i \<in> UNIV}"
        then obtain i where i:"y = a^i mod p" by auto
        define q r where "q = i div x" and "r = i mod x"
        have "i = q*x + r" by (simp add: r_def q_def)
        hence y_q_r:"y = (((a ^ (q*x)) mod p) * ((a ^ r) mod p)) mod p"
          by (simp add: i power_add mod_mult_eq)
        have "a ^ (q*x) mod p = (a ^ x mod p) ^ q mod p"
          by (simp add: power_mod mult.commute power_mult[symmetric])
        then have y_r:"y = a ^ r mod p" using \<open>p\<ge>2\<close> x
          by (simp add: cong_def y_q_r)
        have "y \<in> {a ^ i mod p | i. 0 < i \<and> i \<le> x}"
        proof (cases)
          assume "r = 0"
          then have "y = a^x mod p" using \<open>p\<ge>2\<close> x
            by (simp add: cong_def y_r)
          thus ?thesis using x by blast
        next
          assume "r \<noteq> 0"
          thus ?thesis using x by (auto simp add: y_r r_def)
        qed
      }
      thus " {a ^ i mod p|i. i \<in> UNIV} \<subseteq> {a ^ i mod p | i. 0 < i \<and> i \<le> x}" by auto
    qed
    note X = this

    have "p - 1 = card {1 .. p - 1}" by auto
    also have "{1 .. p - 1} = {a^i mod p | i. 1 \<le> i \<and> i \<le> x}" using X a by auto
    also have "\<dots> = (\<lambda> i. a^i mod p) ` {1..x}" by auto
    also have "card \<dots> \<le> p - 2"
      using Finite_Set.card_image_le[of "{1..x}" "\<lambda> i. a^i mod p"] x by auto
    finally have False using \<open>2 \<le> p\<close> by arith
   }
   hence "\<forall> x . 0 < x \<longrightarrow> x \<le> p - 2 \<longrightarrow> [a^x \<noteq> 1] (mod p)" by auto
 } note a_is_gen = this
 {
    assume "a>1"
    have "\<not> p dvd a "
    proof (rule ccontr)
      assume "\<not> \<not> p dvd a"
      hence "p dvd a" by auto
      have "p \<le> a" using dvd_nat_bounds[OF _ \<open>p dvd a\<close>] a by simp
      thus False using \<open>a>1\<close> a by force
    qed
    hence "coprime a p"
      using prime_imp_coprime_nat [OF prime_p] by (simp add: ac_simps)
    then have "[a ^ totient p = 1] (mod p)"
      by (rule euler_theorem)
    also from prime_p have "totient p = p - 1"
      by (rule totient_prime)
    finally have "[a ^ (p - 1) = 1] (mod p)" .
  }
  hence "[a^(p - 1) = 1] (mod p)" using a by fastforce
  thus ?thesis using a_is_gen a by auto
 qed

theorem converse_lehmer:
 assumes prime_p:"prime(p)"
 shows "\<exists> a . [a^(p - 1) = 1] (mod p) \<and>
              (\<forall> q. q \<in> prime_factors (p - 1) \<longrightarrow> [a^((p - 1) div q) \<noteq> 1] (mod p))
              \<and> a > 0 \<and> a < p"
 proof -
  have "p \<ge> 2" by (rule prime_ge_2_nat[OF prime_p])
  obtain a where a:"[a^(p - 1) = 1] (mod p) \<and> (\<forall> x . 0 < x \<longrightarrow> x \<le> p - 2 \<longrightarrow> [a^x \<noteq> 1] (mod p))
                    \<and> a > 0 \<and> a < p"
    using converse_lehmer_weak[OF prime_p] by blast
  { fix q assume q:"q \<in> prime_factors (p - 1)"
    hence "0 < q \<and> q \<le> p - 1" using \<open>p\<ge>2\<close>
      by (auto simp add: dvd_nat_bounds prime_factors_gt_0_nat)
    hence "(p - 1) div q \<ge> 1" using div_le_mono[of "q" "p - 1" q] div_self[of q] by simp
    have "q \<ge> 2" using q by (auto intro: prime_ge_2_nat)
    hence "(p - 1) div q < p - 1" using \<open>p \<ge> 2\<close> by simp
    hence "[a^((p - 1) div q) \<noteq> 1] (mod p)" using a \<open>(p - 1) div q \<ge> 1\<close>
      by (auto simp add: Suc_diff_Suc less_eq_Suc_le)
  }
  thus ?thesis using a by auto
 qed

end


theory MIPS
  imports Word_Lib.Word_Lib
begin

type_synonym reg = \<open>5 word\<close>
type_synonym w = \<open>32 word\<close>
type_synonym imm = \<open>16 word\<close>
type_synonym J_operand = \<open>26 word\<close>
type_synonym shamt = \<open>5 word\<close>
type_synonym byte = \<open>8 word\<close>
type_synonym pc = \<open>30 word\<close>

datatype ALU_op =
  OP_ADD | OP_SUB | OP_AND | OP_OR | OP_XOR | OP_NOR |
  OP_SLT | OP_SLTU

primrec is_bitwise_op where
  \<open>is_bitwise_op OP_ADD  = False\<close> |
  \<open>is_bitwise_op OP_SUB  = False\<close> |
  \<open>is_bitwise_op OP_AND  = True \<close> |
  \<open>is_bitwise_op OP_OR   = True \<close> |
  \<open>is_bitwise_op OP_XOR  = True \<close> |
  \<open>is_bitwise_op OP_NOR  = True \<close> |
  \<open>is_bitwise_op OP_SLT  = False\<close> |
  \<open>is_bitwise_op OP_SLTU = False\<close>

datatype shift_op =
  OP_SLL | OP_SRL | OP_SRA

datatype br_pred2 = EQ | NE
datatype br_pred1 = LEZ | GTZ

primrec ALU_op_fn :: \<open>ALU_op \<Rightarrow> w \<Rightarrow> w \<Rightarrow> w\<close> where
  \<open>ALU_op_fn OP_ADD = (+)\<close> |
  \<open>ALU_op_fn OP_SUB = (-)\<close> |
  \<open>ALU_op_fn OP_AND = (AND)\<close> |
  \<open>ALU_op_fn OP_OR = (OR)\<close> |
  \<open>ALU_op_fn OP_XOR = (XOR)\<close> |
  \<open>ALU_op_fn OP_NOR a b = NOT (a OR b)\<close> |
  \<open>ALU_op_fn OP_SLT  a b = (if a <s b then 1 else 0)\<close> |
  \<open>ALU_op_fn OP_SLTU a b = (if a < b then 1 else 0)\<close>

primrec shift_op_fn :: \<open>shift_op \<Rightarrow> w \<Rightarrow> 5 word \<Rightarrow> w\<close> where
  \<open>shift_op_fn OP_SLL a b = a <<  unat b\<close> |
  \<open>shift_op_fn OP_SRL a b = a >>  unat b\<close> |
  \<open>shift_op_fn OP_SRA a b = a >>> unat b\<close>

datatype mem_req_size = BYTE | HALF | WORD

datatype inst =
  Inst_ALU_R ALU_op reg reg reg | (* op  rd, rs, rt *)
  Inst_ALU_I ALU_op reg reg imm | (* op  rt, rs, imm *)
  Inst_Shift_R shift_op reg reg reg | (* op  rd, rt, rs *)
  Inst_Shift_I shift_op reg reg shamt | (* op  rd, rt, shamt *)
  Inst_LUI reg imm | (* LUI  rt, imm *)
  Inst_J J_operand |
  Inst_JAL J_operand |
  Inst_JR reg | (* JR  rs *)
  Inst_JALR reg reg | (* JALR  rd, rs *)
  Inst_Branch br_pred2 reg reg imm | (* op  rs, rt, imm *)
  Inst_Branch1 br_pred1 reg imm | (* op  rs, imm *)
  Inst_Load mem_req_size bool reg reg imm |
  Inst_Store mem_req_size reg reg imm |
  Inst_Undef

primrec br_pred2_fn :: \<open>br_pred2 \<Rightarrow> w \<Rightarrow> w \<Rightarrow> bool\<close> where
  \<open>br_pred2_fn EQ = (=)\<close> |
  \<open>br_pred2_fn NE = (\<noteq>)\<close>

primrec br_pred1_fn :: \<open>br_pred1 \<Rightarrow> w \<Rightarrow> bool\<close> where
  \<open>br_pred1_fn LEZ = (\<lambda>a. sint a \<le> 0)\<close> |
  \<open>br_pred1_fn GTZ = (\<lambda>a. sint a > 0)\<close>

type_synonym regfile = \<open>reg \<Rightarrow> w\<close>

record 'm isa_state =
  PC :: pc
  Regs :: regfile
  Mem :: 'm

definition read_rf :: \<open>reg \<Rightarrow> regfile \<Rightarrow> w\<close> where
  \<open>read_rf a rf \<equiv> if a = 0 then 0 else rf a\<close>

definition write_rf :: \<open>reg \<Rightarrow> w \<Rightarrow> regfile \<Rightarrow> regfile\<close> where
  \<open>write_rf a d rf \<equiv> if a = 0 then rf else rf(a:=d)\<close>

type_synonym imem = \<open>pc \<Rightarrow> w\<close>

locale mips =
  fixes load :: "32 word \<Rightarrow> mem_req_size \<Rightarrow> 'm \<Rightarrow> 32 word"
  fixes store :: "32 word \<Rightarrow> mem_req_size \<Rightarrow> 32 word \<Rightarrow> 'm \<Rightarrow> 'm"

begin

definition load_ext :: \<open>w \<Rightarrow> mem_req_size \<Rightarrow> bool \<Rightarrow> 'm \<Rightarrow> w\<close> where
  \<open>load_ext addr sz sign m \<equiv>
     let data = load addr sz m in
     case sz of
       BYTE \<Rightarrow>
         if sign then (scast (ucast data ::  8 word) :: w)
                 else (ucast (ucast data ::  8 word) :: w) |
       HALF \<Rightarrow>
         if sign then (scast (ucast data :: 16 word) :: w)
                 else (ucast (ucast data :: 16 word) :: w) |
       WORD \<Rightarrow> data\<close>

(*
definition align4 :: \<open>w \<Rightarrow> w\<close> where
  \<open>align4 addr = addr AND -4\<close>
*)

(*
definition load_byte :: \<open>memory \<Rightarrow> w \<Rightarrow> w\<close> where
  \<open>load_byte m addr = ucast (m addr)\<close>

definition load_word :: \<open>memory \<Rightarrow> w \<Rightarrow> w\<close> where
  \<open>load_word m addr \<equiv> word_rcat
   [m (align addr OR 3),
    m (align addr OR 2),
    m (align addr OR 1),
    m (align addr     )]\<close>

definition store_byte :: \<open>memory \<Rightarrow> w \<Rightarrow> w \<Rightarrow> memory\<close> where
  \<open>store_byte m addr data \<equiv> m(addr := ucast data)\<close>

definition store_word :: \<open>memory \<Rightarrow> w \<Rightarrow> w \<Rightarrow> memory\<close> where
  \<open>store_word m addr data \<equiv>
   m(align addr      := ucast (data      ),
     align addr OR 1 := ucast (data >>  8),
     align addr OR 2 := ucast (data >> 16),
     align addr OR 3 := ucast (data >> 24))\<close>
*)

definition sext :: \<open>imm \<Rightarrow> w\<close> where \<open>sext = scast\<close>

definition jump_dest :: \<open>pc \<Rightarrow> J_operand \<Rightarrow> pc\<close> where
  \<open>jump_dest pc imm \<equiv> word_cat (slice 26 (pc + 1) :: 4 word) imm\<close>

definition ret_addr :: \<open>pc \<Rightarrow> w\<close> where
  \<open>ret_addr pc = word_cat (pc+2) (0::2 word)\<close>

inductive isa_step :: \<open>'m isa_state \<Rightarrow> inst \<Rightarrow> 'm isa_state \<Rightarrow> bool\<close> ("_ \<midarrow>_\<rightarrow> _" [81,0,81] 80) where
ALU_R:
  \<open>t = s\<lparr>PC := PC s + 1, Regs := write_rf rd (ALU_op_fn op (read_rf rs (Regs s)) (read_rf rt (Regs s))) (Regs s)\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_ALU_R op rd rs rt\<rightarrow> t\<close> |
ALU_I:
  \<open>t = s\<lparr>PC := PC s + 1, Regs := write_rf rt (ALU_op_fn op (read_rf rs (Regs s)) (if is_bitwise_op op then ucast imm else scast imm)) (Regs s)\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_ALU_I op rt rs imm\<rightarrow> t\<close> |
Shift_R:
  \<open>t = s\<lparr>PC := PC s + 1, Regs := write_rf rd (shift_op_fn op (read_rf rt (Regs s)) (ucast (read_rf rs (Regs s)))) (Regs s)\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_Shift_R op rd rt rs\<rightarrow> t\<close> |
Shift_I:
  \<open>t = s\<lparr>PC := PC s + 1, Regs := write_rf rd (shift_op_fn op (read_rf rt (Regs s)) shamt) (Regs s)\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_Shift_I op rd rt shamt\<rightarrow> t\<close> |
LUI:
  \<open>t = s\<lparr>PC := PC s + 1, Regs := write_rf rt (word_cat imm (0::16 word)) (Regs s)\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_LUI rt imm\<rightarrow> t\<close> |
J:
  \<open>t = s\<lparr>PC := jump_dest (PC s) imm\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_J imm\<rightarrow> t\<close> |
JAL:
  \<open>t = s\<lparr>PC := jump_dest (PC s) imm, Regs := write_rf 31 (ret_addr (PC s)) (Regs s)\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_JAL imm\<rightarrow> t\<close> |
JR:
  \<open>t = s\<lparr>PC := slice 2 (read_rf rs (Regs s))\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_JR rs\<rightarrow> t\<close> |
JALR:
  \<open>t = s\<lparr>PC := slice 2 (read_rf rs (Regs s)), Regs := write_rf rd (ret_addr (PC s)) (Regs s)\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_JALR rd rs\<rightarrow> t\<close> |
Branch_taken:
  \<open>br_pred2_fn pred (read_rf rs (Regs s)) (read_rf rt (Regs s)) \<Longrightarrow>
   t = s\<lparr>PC := PC s + 1 + scast imm\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_Branch pred rs rt imm\<rightarrow> t\<close> |
Branch_not_taken:
  \<open>\<not> br_pred2_fn pred (read_rf rs (Regs s)) (read_rf rt (Regs s)) \<Longrightarrow>
   t = s\<lparr>PC := PC s + 1\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_Branch pred rs rt imm\<rightarrow> t\<close> |
Branch1_taken:
  \<open>br_pred1_fn pred (read_rf rs (Regs s)) \<Longrightarrow>
   t = s\<lparr>PC := PC s + 1 + scast imm\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_Branch1 pred rs imm\<rightarrow> t\<close> |
Branch1_not_taken:
  \<open>\<not> br_pred1_fn pred (read_rf rs (Regs s)) \<Longrightarrow>
   t = s\<lparr>PC := PC s + 1\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_Branch1 pred rs imm\<rightarrow> t\<close> |
Load:
  \<open>t = s\<lparr>PC := PC s + 1, Regs := write_rf rt (load_ext (read_rf rs (Regs s) + sext imm) sz sign (Mem s)) (Regs s)\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_Load sz sign rt rs imm\<rightarrow> t\<close> |
Store:
  \<open>t = s\<lparr>PC := PC s + 1, Mem := store (read_rf rs (Regs s) + sext imm) sz (read_rf rt (Regs s)) (Mem s)\<rparr> \<Longrightarrow>
   s \<midarrow>Inst_Store sz rt rs imm\<rightarrow> t\<close> |
Undef:
  \<open>s \<midarrow>Inst_Undef\<rightarrow> t\<close>

definition decode :: \<open>w \<Rightarrow> inst\<close> where
  \<open>decode inst \<equiv>
     let opcode = slice 26 inst :: 6 word in
     if opcode = 0 then
       case (slice 21 inst :: 5 word, slice 16 inst :: 5 word, slice 11 inst, slice 6 inst :: 5 word, ucast inst :: 6 word) of (rs, rt, rd, shamt, funct) \<Rightarrow>
       if funct =  0 then Inst_Shift_I OP_SLL rd rt shamt else
       if funct =  2 then Inst_Shift_I OP_SRL rd rt shamt else
       if funct =  3 then Inst_Shift_I OP_SRA rd rt shamt else
       if funct =  4 then Inst_Shift_R OP_SLL rd rt rs else
       if funct =  6 then Inst_Shift_R OP_SRL rd rt rs else
       if funct =  7 then Inst_Shift_R OP_SRA rd rt rs else
       if funct =  8 then Inst_JR rs else
       if funct =  9 then Inst_JALR rd rs else
\<comment> \<open>a number of instructions omitted here\<close>
       if funct = 32 then Inst_ALU_R OP_ADD  rd rs rt else
       if funct = 33 then Inst_ALU_R OP_ADD  rd rs rt else \<comment> \<open>exceptions not supported for now\<close>
       if funct = 34 then Inst_ALU_R OP_SUB  rd rs rt else
       if funct = 35 then Inst_ALU_R OP_SUB  rd rs rt else
       if funct = 36 then Inst_ALU_R OP_AND  rd rs rt else
       if funct = 37 then Inst_ALU_R OP_OR   rd rs rt else
       if funct = 38 then Inst_ALU_R OP_XOR  rd rs rt else
       if funct = 39 then Inst_ALU_R OP_NOR  rd rs rt else
       if funct = 42 then Inst_ALU_R OP_SLT  rd rs rt else
       if funct = 43 then Inst_ALU_R OP_SLTU rd rs rt else
       Inst_Undef
    else
    if opcode = 2 then let imm = ucast inst :: J_operand in Inst_J imm else
    if opcode = 3 then let imm = ucast inst :: J_operand in Inst_JAL imm else
    case (slice 21 inst :: 5 word, slice 16 inst :: 5 word, ucast inst :: 16 word) of (rs, rt, imm) \<Rightarrow>
    if opcode =  4 then Inst_Branch EQ rs rt imm else \<comment> \<open>BEQ\<close>
    if opcode =  5 then Inst_Branch NE rs rt imm else \<comment> \<open>BNE\<close>
    if opcode =  6 then Inst_Branch1 LEZ rs imm else \<comment> \<open>BLEZ\<close>
    if opcode =  7 then Inst_Branch1 GTZ rs imm else \<comment> \<open>BGTZ\<close>
    if opcode =  8 then Inst_ALU_I OP_ADD  rt rs imm else
    if opcode =  9 then Inst_ALU_I OP_ADD  rt rs imm else \<comment> \<open>ADDU\<close>
    if opcode = 10 then Inst_ALU_I OP_SLT  rt rs imm else
    if opcode = 11 then Inst_ALU_I OP_SLTU rt rs imm else
    if opcode = 12 then Inst_ALU_I OP_AND  rt rs imm else
    if opcode = 13 then Inst_ALU_I OP_OR   rt rs imm else
    if opcode = 14 then Inst_ALU_I OP_XOR  rt rs imm else
    if opcode = 15 then Inst_LUI rt imm else
    if opcode = 32 then Inst_Load BYTE True  rt rs imm else \<comment> \<open>LB\<close>
    if opcode = 33 then Inst_Load HALF True  rt rs imm else \<comment> \<open>LH\<close>
    if opcode = 34 then Inst_Load WORD False rt rs imm else \<comment> \<open>LW\<close>
    if opcode = 36 then Inst_Load BYTE False rt rs imm else \<comment> \<open>LBU\<close>
    if opcode = 37 then Inst_Load HALF False rt rs imm else \<comment> \<open>LHU\<close>
    if opcode = 40 then Inst_Store BYTE rt rs imm else \<comment> \<open>SB\<close>
    if opcode = 41 then Inst_Store HALF rt rs imm else \<comment> \<open>SH\<close>
    if opcode = 43 then Inst_Store WORD rt rs imm else \<comment> \<open>SW\<close>
    Inst_Undef\<close>

(*
inductive (* exec im init n fin *) exec :: \<open>imem \<Rightarrow> 'm isa_state \<Rightarrow> nat \<Rightarrow> 'm isa_state \<Rightarrow> bool\<close>
  for im :: imem
  where
    exec0:
    \<open>exec im s 0 s\<close> |
    execS:
    \<open>step s (decode (im (PC s))) s' \<Longrightarrow> exec im s' n t \<Longrightarrow> exec im s (Suc n) t\<close>
*)

definition \<open>exec im s t \<equiv> s \<midarrow>decode (im (PC s))\<rightarrow> t\<close>

(*
lemma \<open>s \<midarrow>decode 0\<rightarrow> t \<Longrightarrow> t = s\<lparr>PC := PC s + 1\<rparr>\<close>
  apply(simp add: decode_def)
  apply(erule isa_step.cases, auto)
  apply(simp add: write_rf_def read_rf_def)
  done
*)

end (* locale *)

end (* theory *)


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: Positive_New.thy                                                     *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)
(* LAST REVIEWED: 14 Sept 2017 *)

section {* Positive Subtypes *}

theory Positive_New
imports Two Continuum
  "../axiomatic/theories/utils/Infinity"
  "~~/src/HOL/Library/Countable"
begin

text {* Move this instantiation to a more suitable place in the hierarchy. *}

subclass (in infinite) two
apply (intro_classes)
apply (rule disjI1)
apply (rule local.infinite_UNIV)
done

subsection {* Type Definition *}

typedef (overloaded) 'a::"{zero, linorder}" pos = "{x::'a. x \<ge> 0}"
apply (rule_tac x = "0" in exI)
apply (clarsimp)
done

setup_lifting type_definition_pos

subsection {* Instantiations *}

instantiation pos :: ("{zero, linorder}") zero
begin
lift_definition zero_pos :: "'a pos"
is "0 :: 'a" ..
instance ..
end

instantiation pos :: ("{zero, linorder}") linorder
begin
lift_definition less_eq_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> bool"
is "op \<le> :: 'a \<Rightarrow> 'a \<Rightarrow> bool" .
lift_definition less_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> bool"
is "op < :: 'a \<Rightarrow> 'a \<Rightarrow> bool" .
instance
apply (intro_classes; transfer)
apply (auto)
done
end

instance pos :: ("{zero, linorder, no_top}") no_top
apply (intro_classes)
apply (transfer)
apply (clarsimp)
apply (meson gt_ex less_imp_le order.strict_trans1)
done

instance pos :: ("{zero, linorder, no_top}") infinite
apply (intro_classes)
apply (rule notI)
apply (subgoal_tac "\<forall>x::'a pos. x \<le> Max UNIV")
using gt_ex leD apply (blast)
apply (simp)
done

(*<*)
(* Removed as clashing with the instantiation of @{class continuum}. *)

(*
instance pos :: ("{zero, linorder, countable}") countable
apply (intro_classes)
apply (rule_tac x = "to_nat o Rep_pos" in exI)
apply (rule inj_comp)
apply (clarsimp)
apply (rule injI)
apply (simp add: Rep_pos_inject)
done
*)
(*>*)

instantiation pos :: (linordered_semidom) linordered_semidom
begin
lift_definition one_pos :: "'a pos"
is "1 :: 'a" by (simp)
lift_definition plus_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
is "op +" by (simp)
lift_definition minus_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
is "\<lambda>x y. if y \<le> x then x - y else 0"
  by (simp add: add_le_imp_le_diff)
lift_definition times_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
is "op *" by (simp)
instance
apply (intro_classes; transfer; simp?)
apply (simp add: add.assoc)
apply (simp add: add.commute)
apply (safe; clarsimp?) [1]
apply (simp add: diff_diff_add)
apply (metis add_left_mono le_add_diff_inverse)
apply (simp add: add.commute add_le_imp_le_diff)
apply (metis add_increasing2 antisym linear)
apply (simp add: mult.assoc)
apply (simp add: mult.commute)
apply (simp add: comm_semiring_class.distrib)
apply (simp add: mult_strict_left_mono)
apply (safe; clarsimp?) [1]
apply (simp add: right_diff_distrib')
apply (simp add: mult_left_mono)
using mult_left_le_imp_le apply (fastforce)
apply (simp add: distrib_left)
done
end

instantiation pos :: ("linordered_field") semidom_divide
begin
lift_definition divide_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
is "op div" by (simp)
instance
apply (intro_classes; transfer)
apply (simp_all)
done
end

subsection {* Continuum Closure *}

lemma ge_num_infinite_if_no_top:
"infinite {x::'a::{linorder, no_top}. n \<le> x}"
apply (clarsimp)
-- {* From the assumption that the set is finite. *}
apply (subgoal_tac "\<exists>y::'a. Max {x. n \<le> x} < y")
apply (clarsimp)
apply (metis Max_ge leD mem_Collect_eq order.strict_implies_order order_refl order_trans)
using gt_ex apply (blast)
done

lemma less_zero_ordLeq_ge_zero:
"|{x::'a::{ordered_ab_group_add}. x < 0}| \<le>o |{x::'a. 0 \<le> x}|"
apply (rule_tac f = "uminus" in surj_imp_ordLeq)
apply (simp add: image_def)
apply (clarsimp)
apply (rule_tac x = "- x" in exI)
apply (simp)
done

instance pos :: ("{zero, linorder, no_top}") two ..

text {* The next theorem is not entirely trivial to prove! *}

instance pos :: ("{linordered_ab_group_add, no_top, continuum}") continuum
apply (intro_classes)
apply (case_tac "countable (UNIV :: 'a set)")
-- {* Subgoal 1 (Easy Case) *}
apply (rule disjI1)
apply (subgoal_tac "\<exists>to_nat::'a \<Rightarrow> nat. inj to_nat")
-- {* Subgoal 1.1 *}
apply (clarsimp)
apply (thin_tac "countable UNIV")
apply (rule_tac x = "to_nat o Rep_pos" in exI)
apply (rule inj_comp)
apply (assumption)
apply (meson Positive_New.pos.Rep_pos_inject injI)
-- {* Subgoal 1.2 *}
apply (blast)
-- {* Subgoal 2 (Difficult Case) *}
apply (rule disjI2)
apply (subst sym [OF equal_card_bij_betw])
apply (rule equal_card_intro)
apply (subgoal_tac "|UNIV::'a pos set| =o |{x::'a. 0 \<le> x}|")
-- {* Subgoal 2.1 *}
apply (erule ordIso_transitive)
apply (rule ordIso_symmetric)
apply (subgoal_tac "|UNIV::nat set set| =o |UNIV::'a set|")
-- {* Subgoal 2.1.1 *}
apply (erule ordIso_transitive)
apply (subgoal_tac "(UNIV::'a set) = {x.0 \<le> x} \<union> {x. x < 0}")
-- {* Subgoal 2.1.1.1 *}
apply (erule ssubst)
apply (rule card_of_Un_infinite_simps(1))
apply (rule ge_num_infinite_if_no_top)
apply (rule less_zero_ordLeq_ge_zero)
-- {* Subgoal 2.1.1.2 *}
apply (auto)
-- {* Subgoal 2.1.2 *}
apply (rule_tac f = "from_nat_set" in card_of_ordIsoI)
apply (rule_tac bij_betwI'; clarsimp?)
-- {* This is the only place where @{term "countable UNIV"} is needed. *}
apply (metis bij_betw_imp_surj from_nat_set_def surj_f_inv_f to_nat_set_bij)
apply (rule_tac x = "to_nat_set y" in exI)
apply (clarsimp)
-- {* Subgoal 2.2 *}
apply (rule_tac f = "Rep_pos" in card_of_ordIsoI)
apply (rule_tac bij_betwI'; clarsimp?)
apply (simp add: Positive_New.pos.Rep_pos_inject)
using Positive_New.pos.Rep_pos apply (blast)
apply (rule_tac x = "Abs_pos y" in exI)
apply (simp add: Positive_New.pos.Abs_pos_inverse)
done
end


theory Monoidal_Category
  imports Natural_Transformations

begin

section \<open>Binary endofunctors\<close>

locale biEndoFunctor =
A: category domain codomain composition nonex +
AxA: productCategory domain codomain composition nonex domain codomain composition nonex +
AxAxA: productCategory domain codomain composition nonex AxA.Dom AxA.Cod AxA.Composition AxA.Nonex +
BiF: biFunctor domain codomain composition nonex domain codomain composition nonex domain codomain composition nonex T
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  T :: "'a * 'a \<Rightarrow> 'a"

begin

lemma True
  nitpick [satisfy, user_axioms, expect=genuine, card 'a=2,card 'b=4,card 'c=8] oops

definition TTA
  where "TTA x \<equiv> T (T (fst x, fst (snd x)), snd (snd x))"

lemma TTA_is_functor:
  shows "functorCat AxAxA.Dom AxAxA.Cod AxAxA.Composition AxAxA.Nonex domain codomain composition nonex TTA"
  using TTA_def
  apply unfold_locales
  apply (metis AxA.Ex AxAxA.Ex BiF.ntExists prod.collapse)
  apply (metis AxA.Ex AxAxA.Ex BiF.reflects_morp prod.collapse)
  apply (metis AxA.Ex BiF.nntExists BiF.pres1 fst_conv snd_conv)
  apply (metis AxA.Ex BiF.nntExists BiF.pres2 fst_conv snd_conv)
  by (metis AxA.Ex BiF.nntExists BiF.pres3 fst_conv snd_conv)

lemma TTA_simp [simp]:
  shows "(TTA (x,y,z)) \<cong> (T (T (x,y),z))"
  by (simp add: TTA_def)

definition TAT
  where "TAT x \<equiv> T (fst x, T (fst (snd x), snd (snd x)))"

lemma TAT_is_functor:
  shows "functorCat AxAxA.Dom AxAxA.Cod AxAxA.Composition AxAxA.Nonex domain codomain composition nonex TAT"
  using TAT_def
  apply unfold_locales
  apply (metis AxA.Ex AxAxA.Ex BiF.ntExists prod.collapse)
  apply (metis AxA.Ex AxAxA.Ex BiF.reflects_morp prod.collapse)
  apply (metis AxA.Ex BiF.nntExists BiF.pres1 fst_conv snd_conv)
  apply (metis AxA.Ex BiF.nntExists BiF.pres2 fst_conv snd_conv)
  by (metis AxA.Ex BiF.nntExists BiF.pres3 fst_conv snd_conv)

lemma TAT_simp [simp]:
  shows "TAT (x,y,z) \<cong> T (x, T (y,z))"
  by (simp add: TAT_def)

definition tensor_wl_object
  where "tensor_wl_object a \<equiv> \<lambda>x. T (a,x)"

end

locale biAopAEndoFunctor =
A: category domain codomain composition nonex +
Aop: opposite_category domain codomain composition nonex +
AopxA: productCategory Aop.domop Aop.codop Aop.compositionop nonex domain codomain composition nonex +
BiF: biFunctor Aop.domop Aop.codop Aop.compositionop nonex domain codomain composition nonex domain codomain composition nonex Il
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  Il :: "'a * 'a \<Rightarrow> 'a"
begin

end

section \<open>Monoidal category\<close>

locale Monoidal_Category =
A: category domain codomain composition nonex +
AxA: productCategory domain codomain composition nonex domain codomain composition nonex +
AxAxA: productCategory domain codomain composition nonex AxA.Dom AxA.Cod AxA.Composition AxA.Nonex +
T: biEndoFunctor domain codomain composition nonex T +
\<alpha>: naturalIsomorphism AxAxA.Dom AxAxA.Cod AxAxA.Composition AxAxA.Nonex domain codomain composition nonex T.TTA T.TAT \<alpha> +
\<mu>: naturalIsomorphism domain codomain composition nonex domain codomain composition nonex "\<lambda>x::'a. T (\<e>,x)" A.map \<mu> +
\<rho>: naturalIsomorphism domain codomain composition nonex domain codomain composition nonex "\<lambda>x::'a. T (x,\<e>)" A.map \<rho>
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  T :: "'a * 'a \<Rightarrow> 'a" and
  \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a" and
  \<mu> :: "'a \<Rightarrow> 'a" and
  \<rho> :: "'a \<Rightarrow> 'a" and
  \<e> :: "'a" +
assumes
  unit_object: "A.IdEx \<e>" and
  triangle: "((A.Id x) \<and> (A.Id y)) \<longrightarrow> (((T (x, (\<mu> y)))\<cdot>(\<alpha>(x,\<e>,y))) \<cong> (T(\<rho> x,y)))" and
  pentagon: "((A.Id x) \<and> (A.Id y) \<and> (A.Id z) \<and> (A.Id w))
             \<longrightarrow> (((T (x,\<alpha>(y,z,w))) \<cdot> ((\<alpha>(x,T(y,z),w)) \<cdot> (T(\<alpha>(x,y,z),w)))) \<cong> (\<alpha>(x,y,T(z,w))) \<cdot> (\<alpha>(T(x,y),z,w)))"

begin

(* lemma True
  nitpick [satisfy, user_axioms, expect=genuine] oops *)

abbreviation TensorProd (infix "\<otimes>" 56)
  where "x\<otimes>y \<equiv> T(x,y)"

abbreviation from_hom_seta ("(_):(_)\<rightarrow>\<^sub>A(_)")
  where "(x:a\<rightarrow>\<^sub>Ab) \<equiv> A.from_hom_seta x a b"

lemma tensor_arrow[simp]:
  assumes "A.from_hom_set x a b" and "A.from_hom_set y c d"
  shows "A.from_hom_set (x\<otimes>y) (a\<otimes>c) (b\<otimes>d)"
  by (metis A.from_hom_set_def AxA.Ex T.BiF.ntExists T.BiF.pres1 T.BiF.pres2 assms(1) assms(2) fst_conv snd_conv)

lemma tensor_arrow_2[simp]:
  assumes "E x" and "E y"
  shows "E (x\<otimes>y)"
  using AxA.Ex T.BiF.ntExists assms(1) assms(2) by blast

lemma tensor_domain[simp]:
  assumes "A.from_hom_set x a b" and "A.from_hom_set y c d"
  shows "(domain (x\<otimes>y)) \<simeq> (a\<otimes>c)"
  by (metis A.from_hom_set_def T.BiF.pres1 assms(1) assms(2) fst_conv snd_conv tensor_arrow_2)

lemma tensor_codomain[simp]:
  assumes "A.from_hom_set x a b" and "A.from_hom_set y c d"
  shows "(codomain (x\<otimes>y)) \<simeq> (b\<otimes>d)"
  by (metis A.from_hom_set_def T.BiF.pres2 assms(1) assms(2) fst_conv snd_conv tensor_arrow_2)

lemma tensor_ide[simp]:
  assumes "A.Id(x)" and "A.Id(y)"
  shows "A.Id (x\<otimes>y)"
  by (meson A.Id_def A.Id_hom A.S1 AxA.Ex T.BiF.nntExists assms(1) assms(2) tensor_arrow)

lemma tensor_interchange:
  assumes "E (x\<cdot>y)" and "E (x'\<cdot>y')"
  shows "((x\<otimes>x')\<cdot>(y\<otimes>y')) \<cong> x\<cdot>y\<otimes>x'\<cdot>y'"
  using T.BiF.pres3 assms(1) assms(2) by auto

lemma tensor_iso[simp]:
  assumes "Iso\<^sub>a x" and "Iso\<^sub>a y" and "E x" and "E y"
  shows "Iso\<^sub>a (x\<otimes>y)"
  by (smt A.Ex_two_ob1 A.Ex_two_ob2 A.Id_ex A.S4 A.S5 A.dom_of_comp AxA.Ex T.BiF.ntExists assms(1) assms(2) tensor_ide tensor_interchange)

lemma tensor_iso2[simp]:
  assumes "Iso x" and "Iso y" and "E x" and "E y"
  shows "Iso (x\<otimes>y)"
  using A.Iso_def assms(1) assms(2) assms(3) assms(4) tensor_iso by auto

lemma tensor_morph:
  assumes "f:a\<rightarrow>\<^sub>Aa'" and "A.IdEx b" and "x:(T(a',b))\<rightarrow>\<^sub>Ac"
  shows "(x\<cdot>(f\<otimes>b)):(a\<otimes>b)\<rightarrow>\<^sub>Ac"
  by (metis (no_types, hide_lams) A.S3 A.cod_dom A.cod_of_comp A.dom_of_comp A.from_hom_set_def assms(1) assms(2) assms(3) tensor_codomain tensor_domain)

lemma unit_tensor1:
  assumes "A.IdEx a" and "A.IdEx b" and "A.isomorphic a b"
  shows "A.isomorphic (a\<otimes>\<e>) (b\<otimes>\<e>)"
proof-
  have 1: "A.isomorphic (a\<otimes>\<e>) a"
    by (metis (no_types, hide_lams) A.ExDomCod(2) A.Iso_a A.cod_dom A.map_def \<rho>.F.pres1 \<rho>.\<eta>.presCod \<rho>.\<eta>.presDom \<rho>.comp_iso assms(1) tensor_arrow_2 unit_object)
  also have 2: "A.isomorphic (b\<otimes>\<e>) b"
    by (metis A.ExDomCod(2) A.Iso_a A.cod_dom A.map_def \<rho>.F.pres1 \<rho>.\<eta>.presCod \<rho>.\<eta>.presDom \<rho>.comp_iso assms(2) tensor_arrow_2 unit_object)
  ultimately have 3: "A.isomorphic (a\<otimes>\<e>) (b\<otimes>\<e>)" using assms(3) oops

interpretation \<mu>_inv: inverse_natural_tr domain codomain composition nonex domain codomain composition nonex "\<lambda>x::'a. T (\<e>,x)" A.map \<mu>
  by (simp add: \<mu>.naturalIsomorphism_axioms nat_transform_impl_inverse)

interpretation \<rho>_inv: inverse_natural_tr domain codomain composition nonex domain codomain composition nonex "\<lambda>x::'a. T (x,\<e>)" A.map \<rho>
  by (simp add: \<rho>.naturalIsomorphism_axioms nat_transform_impl_inverse)

interpretation \<alpha>_inv: inverse_natural_tr AxAxA.Dom AxAxA.Cod AxAxA.Composition AxAxA.Nonex domain codomain composition nonex T.TTA T.TAT \<alpha>
  by (simp add: \<alpha>.naturalIsomorphism_axioms nat_transform_impl_inverse)

abbreviation \<mu>_inv ("\<mu>\<^sup>-\<^sup>1")
  where "\<mu>\<^sup>-\<^sup>1 \<equiv> \<mu>_inv.map"

abbreviation \<rho>_inv ("\<rho>\<^sup>-\<^sup>1")
  where "\<rho>\<^sup>-\<^sup>1 \<equiv> \<rho>_inv.map"

abbreviation \<alpha>_inv ("\<alpha>\<^sup>-\<^sup>1")
  where "\<alpha>\<^sup>-\<^sup>1 \<equiv> \<alpha>_inv.map"

end

section \<open>Braided monoidal category\<close>

locale Braiding =
A: category domain codomain composition nonex +
AxA: productCategory domain codomain composition nonex domain codomain composition nonex +
AxAxA: productCategory domain codomain composition nonex AxA.Dom AxA.Cod AxA.Composition AxA.Nonex +
T: biEndoFunctor domain codomain composition nonex T +
\<alpha>: naturalIsomorphism AxAxA.Dom AxAxA.Cod AxAxA.Composition AxAxA.Nonex domain codomain composition nonex T.TTA T.TAT \<alpha> +
Br: naturalIsomorphism AxA.Dom AxA.Cod AxA.Composition AxA.Nonex domain codomain composition nonex T T.BiF.Exch \<gamma> +
\<alpha>_inv: inverse_natural_tr AxAxA.Dom AxAxA.Cod AxAxA.Composition AxAxA.Nonex domain codomain composition nonex T.TTA T.TAT \<alpha> +
Br_inv: inverse_natural_tr AxA.Dom AxA.Cod AxA.Composition AxA.Nonex domain codomain composition nonex T T.BiF.Exch \<gamma>
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  T :: "'a * 'a \<Rightarrow> 'a" and
  \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a" and
  \<gamma> :: "'a * 'a \<Rightarrow> 'a" +
assumes
  hexagon1: "((A.Id x) \<and> (A.Id y) \<and> (A.Id z)) \<longrightarrow> ((\<alpha>(y,z,x) \<cdot> (\<gamma>(x,T(y,z)) \<cdot> \<alpha>(x,y,z))) \<cong>
             (T(y,\<gamma>(x,z)) \<cdot> (\<alpha>(y,x,z) \<cdot> T(\<gamma>(x,y),z))))" and
  hexagon2: "((A.Id x) \<and> (A.Id y) \<and> (A.Id z)) \<longrightarrow> ((\<alpha>_inv.map(z,x,y) \<cdot> (\<gamma>(T(x,y),z) \<cdot> \<alpha>_inv.map(x,y,z))) \<cong>
             (T(\<gamma>(x,z),y) \<cdot> (\<alpha>_inv.map(x,z,y) \<cdot> T(x,\<gamma>(y,z)))))"
begin

end

locale Braided_Mon_Cat =
  M: Monoidal_Category domain codomain composition nonex T \<alpha> \<mu> \<rho> \<e> +
  Braid: Braiding domain codomain composition nonex T \<alpha> \<gamma>
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  T :: "'a * 'a \<Rightarrow> 'a" and
  \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a" and
  \<mu> :: "'a \<Rightarrow> 'a" and
  \<rho> :: "'a \<Rightarrow> 'a" and
  \<e> :: "'a" and
  \<gamma> :: "'a * 'a \<Rightarrow> 'a"
begin

end

section \<open>Symmetric monoidal category\<close>

locale Symmetry =
Braid: Braiding domain codomain composition nonex T \<alpha> \<gamma>
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  T :: "'a * 'a \<Rightarrow> 'a" and
  \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a" and
  \<gamma> :: "'a * 'a \<Rightarrow> 'a" +
assumes
  symmetry: "((Braid.A.Id a) \<and> (Braid.A.Id b)) \<longrightarrow> (\<gamma>(b,a) \<cong> Braid.Br_inv.map(a,b))"

begin

end

locale Symmetric_Mon_Cat =
  M: Monoidal_Category domain codomain composition nonex T \<alpha> \<mu> \<rho> \<e> +
  Sym: Symmetry domain codomain composition nonex T \<alpha> \<gamma>
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  T :: "'a * 'a \<Rightarrow> 'a" and
  \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a" and
  \<mu> :: "'a \<Rightarrow> 'a" and
  \<rho> :: "'a \<Rightarrow> 'a" and
  \<e> :: "'a" and
  \<gamma> :: "'a * 'a \<Rightarrow> 'a"
begin

lemma Dom:
  assumes "M.A.Id a" and "M.A.Id b"
  shows "(dom (\<gamma>(a,b))) \<cong> T(a,b)"
  by (metis M.A.Id_ex M.A.S1 M.AxA.Ex M.T.BiF.pres1 M.T.BiF.reflects_morp Sym.Braid.Br.\<eta>.presDom assms(1) assms(2) fst_conv snd_conv)

lemma Dom_simp[simp]:
  assumes "M.A.IdEx a" and "M.A.IdEx b"
  shows "(dom (\<gamma>(a,b))) = T(a,b)"
  using Dom M.A.Id_ex2 assms(1) assms(2) by auto

lemma Cod:
  assumes "M.A.Id a" and "M.A.Id b"
  shows "(cod (\<gamma>(a,b))) \<cong> T(b,a)"
  by (metis M.A.Dom_I M.A.I_hom M.A.Id_ex M.A.S2 M.A.from_hom_set_def M.AxA.Ex M.T.BiF.pres2 M.T.BiF.reflects_morp Sym.Braid.Br.\<eta>.presCod assms(1) assms(2) fst_conv snd_conv)

lemma Cod_simp[simp]:
  assumes "M.A.IdEx a" and "M.A.IdEx b"
  shows "(cod (\<gamma>(a,b))) = T(b,a)"
  using Cod M.A.Id_ex2 assms(1) assms(2) by auto

lemma Inverses1[simp]:
  assumes "M.A.IdEx a" and "M.A.IdEx b"
  shows "\<gamma>(a,b)\<cdot>\<gamma>(b,a) \<simeq> T(b,a)"
  by (smt Cod_simp Dom_simp M.A.Id_ex M.A.Id_ex2 M.A.S3 M.A.dom_of_comp M.A.invcheck2 M.AxA.Ex2 M.tensor_arrow_2 Sym.Braid.Br.\<eta>.ntExists Sym.Braid.Br.comp_iso Sym.Braid.Br_inv.identity_under_map Sym.symmetry assms(1) assms(2) fst_conv snd_conv)

end

end