/-
This file translates the autogenerated data and constraints to the form used in the formalization.
-/
import starkware.cairo.lean.semantics.air_encoding.constraints_autogen
import starkware.cairo.lean.semantics.air_encoding.constraints
import starkware.cairo.lean.semantics.air_encoding.memory
import starkware.cairo.lean.semantics.air_encoding.range_check

open_locale classical big_operators

noncomputable theory

variables {F : Type*} [field F] [fintype F]

/- interpreting instruction constraints -/

def cpu__decode.to_instruction_constraints {c : columns F} (cd : cpu__decode c)
    (j : nat) :
  instruction_constraints
    (c.cpu__decode__instruction (j * 16))                          -- inst
    (c.cpu__decode__off1 (j * 16))                                 -- off_op0_tilde
    (c.cpu__decode__off2 (j * 16))                                 -- off_op1_tilde
    (c.cpu__decode__off0 (j * 16))                                 -- off_dst_tilde
    (λ k : fin 16, c.cpu__decode__opcode_rc__column (j * 16 + k))  -- f_tilde
    :=
{ h_instruction :=
    begin
      dsimp,
      have := cd.opcode_rc_input (j * 16) (by simp),
      rw [eq_of_sub_eq_zero this, add_zero],
      ring
    end,
  h_bit :=
    begin
      intro k, dsimp [tilde_type.to_f, column.off],
      have : ↑(k.succ) = ↑k + 1, by simp,
      rw [this, mul_sub, add_zero, add_zero, ←add_assoc, mul_one],
      have : ¬(j * 16 + ↑k) % 16 = 15,
      { rw [add_comm, nat.add_mul_mod_self_right], apply ne_of_lt,
        rw [nat.mod_eq_of_lt (lt_trans k.prop (nat.lt_succ_self _))],
        apply k.prop },
      have h := cd.opcode_rc__bit (j * 16 + k) this,
      rw [←two_mul, column.off] at h,
      exact h,
    end,
  h_last_value :=
    begin
      dsimp,
      have : (j * 16 + 15) % 16 = 15,
      { rw [add_comm, nat.add_mul_mod_self_right, nat.mod_eq_of_lt (nat.lt_succ_self _)] },
      exact cd.opcode_rc__zero (j * 16 + 15) this
    end }

 /- interpreting execution step constraints -/

def cpu__operands.to_step_constraints {c : columns F} {inp : input_data F} (ops : cpu__operands c)
    (upd : cpu__update_registers inp c) (opcodes : cpu__opcodes c)
    (j : ℕ) (hj : j ≠ inp.trace_length / 16 - 1) :
  step_constraints
    (c.cpu__decode__off1 (j * 16))                                 -- off_op0_tilde
    (c.cpu__decode__off2 (j * 16))                                 -- off_op1_tilde
    (c.cpu__decode__off0 (j * 16))                                 -- off_dst_tilde
    (λ k : fin 16, c.cpu__decode__opcode_rc__column (j * 16 + k))  -- f_tilde
    (c.cpu__registers__fp (j * 16))                                -- fp
    (c.cpu__registers__ap (j * 16))                                -- ap
    (c.cpu__decode__pc (j * 16))                                   -- pc
    (c.cpu__registers__fp ((j + 1) * 16))                          -- next fp
    (c.cpu__registers__ap ((j + 1) * 16))                          -- next ap
    (c.cpu__decode__pc ((j + 1) * 16))                             -- next pc
    (c.cpu__operands__mem_dst__addr (j * 16))                      -- dst_addr
    (c.cpu__operands__mem_op0__addr (j * 16))                      -- op0_addr
    (c.cpu__operands__mem_op1__addr (j * 16))                      -- op1_addr
    (c.cpu__operands__mem_dst__value (j * 16))                     -- dst
    (c.cpu__operands__mem_op0__value (j * 16))                     -- op0
    (c.cpu__operands__mem_op1__value (j * 16))                     -- op1
    :=
have h0 : (j * 16 % 16 = 0), by simp,
have h1 : ¬ (j * 16 = 16 * (inp.trace_length / 16 - 1)),
  by { rwa [mul_comm, mul_right_inj' _], norm_num },
{ mul := c.cpu__operands__ops_mul (j * 16),
  res := c.cpu__operands__res (j * 16),
  t0 := c.cpu__update_registers__update_pc__tmp0 (j * 16),
  t1 := c.cpu__update_registers__update_pc__tmp1 (j * 16),
  h_dst_addr :=
    begin
      simp [tilde_type.f_dst_reg, tilde_type.to_f, column.off, two_mul],
      have h := ops.mem_dst_addr _ h0,
      simp [column.off] at h,
      rw [sub_eq_zero] at h,
      rw ←sub_eq_iff_eq_add.mpr h.symm,
      ring
    end,
  h_op0_addr :=
    begin
      simp [tilde_type.f_op0_reg, tilde_type.to_f, column.off, two_mul],
      have h := ops.mem0_addr _ h0,
      simp [column.off] at h,
      rw [sub_eq_zero] at h,
      rw ←sub_eq_iff_eq_add.mpr h.symm,
      ring
    end,
  h_op1_addr :=
    begin
      have coe3 : ↑(3 : fin 15) = 3 := fin.coe_eq_val _,
      have coe4 : ↑(4 : fin 15) = 4 := fin.coe_eq_val _,
      simp [tilde_type.f_op1_imm, tilde_type.f_op1_ap, tilde_type.f_op1_fp,
        tilde_type.to_f, column.off, two_mul, coe3, coe4],
      have h := ops.mem1_addr _ h0,
      simp [column.off] at h,
      rw [sub_eq_zero] at h,
      rw ←sub_eq_iff_eq_add.mpr h.symm,
      ring,
    end,
  h_mul := eq_of_sub_eq_zero (ops.ops_mul _ h0),
  h_res :=
    begin
      have coe5 : ↑(5 : fin 15) = 5 := fin.coe_eq_val _,
      have coe6 : ↑(6 : fin 15) = 6 := fin.coe_eq_val _,
      have coe9 : ↑(9 : fin 15) = 9 := fin.coe_eq_val _,
      simp [tilde_type.f_pc_jnz, tilde_type.f_res_add, tilde_type.f_res_mul,
        tilde_type.to_f, column.off, coe5, coe6, coe9, two_mul],
      have h := ops.res _ h0,
      rw [sub_eq_zero] at h,
      transitivity,
      apply h,
      norm_num, ring,
    end,
  h_t0_eq :=
    begin
      simp [tilde_type.f_pc_jnz, tilde_type.to_f, column.off, two_mul],
      exact eq_of_sub_eq_zero (upd.update_pc__tmp0 _ ⟨h0, h1⟩)
    end,
  h_t1_eq := eq_of_sub_eq_zero (upd.update_pc__tmp1 _ ⟨h0, h1⟩),
  h_next_pc_eq :=
    begin
      have coe9 : ↑(9 : fin 15) = 9 := fin.coe_eq_val _,
      dsimp,
      simp only [tilde_type.f_pc_jnz, tilde_type.f_op1_imm, tilde_type.to_f, column.off, coe9,
        two_mul, add_zero, fin.coe_two, fin.coe_succ, fin.coe_cast_succ, add_mul],
      have h := upd.update_pc__pc_cond_positive _ ⟨h0, h1⟩,
      convert h using 2,
      simp [column.off], ring
    end,
  h_next_pc_eq' :=
    begin
      dsimp,
      have coe7 : ↑(7 : fin 15) = 7 := fin.coe_eq_val _,
      have coe8 : ↑(8 : fin 15) = 8 := fin.coe_eq_val _,
      have coe9 : ↑(9 : fin 15) = 9 := fin.coe_eq_val _,
      rw ←upd.update_pc__pc_cond_negative _ ⟨h0, h1⟩,
      simp [tilde_type.f_pc_jnz, tilde_type.f_pc_jump_abs, tilde_type.f_pc_jump_rel,
        tilde_type.f_op1_imm, tilde_type.to_f, column.off, coe7, coe8, coe9,
        two_mul, add_zero, add_mul, fin.coe_two, fin.coe_succ, fin.coe_cast_succ],
      ring
    end,
  h_opcode_call :=
    begin
      rw ←opcodes.call__push_fp _ h0,
      dsimp,
      simp only [tilde_type.f_opcode_call, tilde_type.to_f, column.off, add_zero, fin.coe_succ,
        fin.coe_cast_succ, ←two_mul],
      refl
    end,
  h_opcode_call' :=
    begin
      have coe12 : ↑(12 : fin 15) = 12 := fin.coe_eq_val _,
      rw ←opcodes.call__push_pc _ h0,
      dsimp,
      simp only [tilde_type.f_opcode_call, tilde_type.f_op1_imm, tilde_type.to_f, column.off,
        add_zero, fin.coe_succ, fin.coe_cast_succ, ←two_mul, coe12],
      ring
    end,
  h_opcode_assert_eq :=
    begin
      have coe14 : ↑(14 : fin 15) = 14 := fin.coe_eq_val _,
      rw ←opcodes.assert_eq__assert_eq _ h0,
      dsimp,
      simp only [tilde_type.f_opcode_assert_eq, tilde_type.to_f, column.off, add_zero, fin.coe_succ,
        fin.coe_cast_succ, ←two_mul, coe14]
    end,
  h_next_ap :=
    begin
      have coe10 : ↑(10 : fin 15) = 10 := fin.coe_eq_val _,
      have coe11 : ↑(11 : fin 15) = 11 := fin.coe_eq_val _,
      have coe12 : ↑(12 : fin 15) = 12 := fin.coe_eq_val _,
      dsimp,
      simp only [add_mul, one_mul, column.off, add_zero],
      transitivity,
      { exact eq_of_sub_eq_zero (upd.update_ap__ap_update _ ⟨h0, h1⟩) },
      simp only [tilde_type.f_opcode_call, tilde_type.f_ap_add, tilde_type.f_ap_add1,
        tilde_type.to_f, column.off, fin.coe_succ, fin.coe_cast_succ, coe10, coe11, coe12,
        ←two_mul],
      norm_num, ring
    end,
  h_next_fp :=
    begin
      have coe12 : ↑(12 : fin 15) = 12 := fin.coe_eq_val _,
      have coe13 : ↑(13 : fin 15) = 13 := fin.coe_eq_val _,
      dsimp,
      simp only [add_mul, one_mul, column.off, add_zero],
      transitivity,
      { exact eq_of_sub_eq_zero (upd.update_fp__fp_update _ ⟨h0, h1⟩) },
      simp only [tilde_type.f_opcode_call, tilde_type.f_opcode_ret,
        tilde_type.to_f, column.off, fin.coe_succ, fin.coe_cast_succ,
        coe12, coe13, ←two_mul],
      norm_num, ring
    end }

/-
interpreting range check constraints

Note: there are inp.trace_length / 16 - 1 steps (so the execution trace, including
the last step, has length inp.trace_length / 16), but there are inp.trace_length / 16
many 16-bit range-checked elements.
-/

def rc16.to_range_check_constraints
  {c : columns F}
  {ci : columns_inter F}
  {inp : input_data F}
  {pd : public_data F}
  (rc16 : rc16 inp pd c ci)
  (trace_length_pos : inp.trace_length > 0)
  (public_memory_prod_eq_one : pd.rc16__perm__public_memory_prod = 1)
  (trace_length_le_char : inp.trace_length ≤ ring_char F) :
  range_check_constraints
    (inp.trace_length / 16 - 1)                               -- T
    (inp.trace_length / 16)                                   -- rc16_len
    (λ j, c.cpu__decode__off1 (j * 16))                       -- off_op0_tilde : fin T → F
    (λ j, c.cpu__decode__off2 (j * 16))                       -- off_op1_tilde : fin T → F
    (λ j, c.cpu__decode__off0 (j * 16))                       -- off_dst_tilde : fin T → F
    (λ j, c.rc_builtin__inner_rc (j * 16))                    -- rc16_val      : fin rc16_len → F
    pd.rc_min
    pd.rc_max :=
have h : ∀ j : ℕ, ∀ i : fin (inp.trace_length / 16 - 1),
           j < 16 → (↑i * 16 + j) < inp.trace_length - 1 + 1,
  begin
    rintros j ⟨i, ilt⟩ jlt,
    rw nat.sub_add_cancel trace_length_pos,
    apply lt_of_lt_of_le (add_lt_add_left jlt _),
    suffices : (i + 1) * 16 ≤ inp.trace_length, by rwa [add_mul] at this,
    apply le_trans (nat.mul_le_mul_right _ _) (nat.div_mul_le_self _ 16),
    exact lt_of_lt_of_le ilt (nat.pred_le _)
  end,
have h' : ∀ j : ℕ, ∀ i : fin (inp.trace_length / 16),
           j < 16 → (↑i * 16 + j) < inp.trace_length - 1 + 1,
  begin
    rintros j ⟨i, ilt⟩ jlt,
    rw nat.sub_add_cancel trace_length_pos,
    apply lt_of_lt_of_le (add_lt_add_left jlt _),
    suffices : (i + 1) * 16 ≤ inp.trace_length, by rwa [add_mul] at this,
    apply le_trans (nat.mul_le_mul_right _ _) (nat.div_mul_le_self _ 16),
    exact nat.succ_le_of_lt ilt
  end,
{ n  := inp.trace_length - 1,
  a  := λ i, c.rc16_pool i,
  a' := λ i, c.rc16__sorted i,
  p  := λ i, ci.rc16__perm__cum_prod0 i,
  z  := pd.rc16__perm__interaction_elm,
  embed_off_op0 := λ i, ⟨↑i * 16 + 8, h 8 i (by norm_num)⟩,
  embed_off_op1 := λ i, ⟨↑i * 16 + 4, h 4 i (by norm_num)⟩,
  embed_off_dst := λ i, ⟨↑i * 16, h 0 i (by norm_num)⟩,
  embed_rc16_vals := λ i, ⟨↑i * 16 + 12, h' 12 i (by norm_num)⟩,
  h_embed_op0   := λ i, rfl,
  h_embed_op1   := λ i, rfl,
  h_embed_dst   := λ i, rfl,
  h_embed_rc16  := λ i, rfl,
  h_continuity  :=
    begin
      intro i,
      rw [←rc16.diff_is_bit _ (ne_of_lt i.is_lt), mul_sub, mul_one],
      simp, refl
    end,
  h_initial :=
    begin
      rw [←sub_eq_zero, ←rc16.perm__init0 _ rfl],
      simp [column.off], abel
    end,
  h_cumulative :=
    begin
      intro i,
      rw [←sub_eq_zero, ←rc16.perm__step0 _ (ne_of_lt i.is_lt)],
      simp [column.off]
    end,
  h_final  := (eq_of_sub_eq_zero (rc16.perm__last _ rfl)).trans public_memory_prod_eq_one,
  h_rc_min := eq_of_sub_eq_zero $ rc16.minimum _ rfl,
  h_rc_max := eq_of_sub_eq_zero $ rc16.maximum _ rfl,
  h_n_lt   :=
    begin
      apply nat.lt_of_succ_le,
      rw [nat.succ_eq_add_one, nat.sub_add_cancel trace_length_pos],
      exact trace_length_le_char
    end }

/- interpreting memory constraints -/

def memory.to_memory_block_constraints
    {inp : input_data F} {pd : public_data F} {c : columns F} {ci : columns_inter F}
    (h_mem_star :
      let z     := pd.memory__multi_column_perm__perm__interaction_elm,
          alpha := pd.memory__multi_column_perm__hash_interaction_elm0,
          p     := pd.memory__multi_column_perm__perm__public_memory_prod,
          dom_m_star := { x // option.is_some (inp.m_star x) } in
       p * ∏ a : dom_m_star, (z - (a.val + alpha * mem_val a)) = z^(fintype.card dom_m_star))
    (m : memory inp pd c ci) :
  memory_block_constraints
    (inp.trace_length / 2 - 1)         -- n
    (λ i, c.mem_pool__addr (2 * i))    -- a
    (λ i, c.mem_pool__value (2 * i))   -- v
    inp.m_star
    :=
have h0 : ∀ j : fin (inp.trace_length / 2 - 1), ↑j * 2 % 2 = 0, by intro j; simp,
have h1 : ∀ j : fin (inp.trace_length / 2 - 1), ¬ (↑j * 2 = 2 * (inp.trace_length / 2 - 1)),
  begin
    rintros ⟨j, jlt⟩,
    have hj : j ≠ inp.trace_length / 2 - 1 := ne_of_lt jlt,
    rwa [mul_comm, mul_right_inj' _], norm_num
  end,
{ a'    := (λ j, c.column20 (2 * j)),
  v'    := (λ j, c.column20 (2 * j + 1)),
  p     := (λ j, ci.column24_inter1 (2 * j)),
  alpha := pd.memory__multi_column_perm__hash_interaction_elm0,
  z     := pd.memory__multi_column_perm__perm__interaction_elm,
  h_continuity :=
    begin
      intro j,
      rw [←m.diff_is_bit (↑j * 2) ⟨h0 j, h1 j⟩, mul_comm 2],
      simp [column.off, add_mul, mul_comm 2], ring
    end,
  h_single_valued :=
    begin
      intro j,
      apply neg_inj.mp,
      rw [neg_zero, ←m.is_func (↑j * 2) ⟨h0 j, h1 j⟩],
      simp [column.off, add_mul, mul_add, mul_comm 2, add_assoc], norm_num,
      ring
    end,
  h_initial :=
    begin
      rw [←sub_eq_zero, ←m.multi_column_perm__perm__init0 _ rfl],
      simp [column.off], ring
    end,
  h_cumulative :=
    begin
      intro j,
      rw [←sub_eq_zero, ←m.multi_column_perm__perm__step0 (↑j * 2) ⟨h0 j, h1 j⟩],
      simp [column.off, add_mul, mul_add, mul_comm 2, add_assoc]
    end,
  h_final :=
    begin
      apply eq.trans _ h_mem_star,
      rw [←eq_of_sub_eq_zero (m.multi_column_perm__perm__last _ rfl)],
      refl
    end }

/- interpreting range check builtin constraints -/

/-- Use 8 16-bit range-checked elements for each 128-bit range-checked element -/
def rc_to_rc16 {inp : input_data F} :
  fin (inp.trace_length / 128) → fin 8 → fin (inp.trace_length / 16) :=
λ i j, ⟨i * 8 + j,
  begin
    cases i with i hi,
    cases j with j hj,
    calc
      ↑i * 8 + ↑j < (i + 1) * 8 :
        by { rw [add_mul, one_mul], apply add_lt_add_left hj }
      ... = ((i + 1) * 8 * 16) / 16 :
        by { rw nat.mul_div_cancel, norm_num }
      ... ≤ inp.trace_length / 16 :
        by { apply nat.div_le_div_right, rw mul_assoc, norm_num,
              rw ← nat.le_div_iff_mul_le, exact nat.succ_le_of_lt hi, norm_num }
  end⟩

def rc_builtin.to_rc_builtin_constraints
    {inp : input_data F} {pd : public_data F} {c : columns F}
    (rcb : rc_builtin inp pd c) :
  rc_builtin_constraints
    (inp.trace_length / 16)
    (pd.initial_rc_addr)
    (inp.trace_length / 128)
    (λ j, c.rc_builtin__inner_rc (j * 16))
    (λ j, c.rc_builtin__mem__addr (j * 128))
    (λ j, c.rc_builtin__mem__value (j * 128))
    rc_to_rc16 :=
{ h_rc_init_addr := λ h, eq_of_sub_eq_zero (rcb.init_addr _ rfl),
  h_rc_addr_step :=
    begin
      intros i hi,
      have := rcb.addr_step (i * 128),
      simp [column.off, nat.succ_eq_add_one, add_mul, one_mul, add_assoc],
      norm_num,
      convert eq_of_sub_eq_zero (this _), simp,
      rw [mul_comm _ 128, nat.mul_right_inj (show 0 < 128, by norm_num)],
      contrapose! hi,
      rw [hi, nat.succ_eq_add_one],
      apply le_tsub_add
    end,
  h_rc_value :=
    begin
      intro i,
      have := rcb.value (i * 128),
      simp at this,
      rw [columns.rc_builtin__mem__value, ←eq_of_sub_eq_zero this],
      simp only [rc_to_rc16, column.off, columns.rc_builtin__inner_rc],
      iterate 14 { congr' 1 };
       { simp [column.off, add_mul, mul_assoc], congr' 1, try { norm_num } }
    end   }

theorem card_dom_aux {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length) :
  4 * fintype.card { x // option.is_some (inp.m_star x) } ≤ inp.trace_length / 2 - 1 :=
begin
  apply nat.le_pred_of_lt,
  apply nat.lt_of_succ_le,
  rw [nat.le_div_iff_mul_le' (show 0 < 2, by norm_num), nat.succ_mul, mul_comm, ←mul_assoc],
  norm_num,
  exact h_card
end

def embed_mem {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (a : mem_dom inp.m_star) :
     fin (inp.trace_length / 2 - 1 + 1) :=
let i := (fintype.equiv_fin { x // option.is_some (inp.m_star x) }).to_fun a in
  ⟨4 * i.val + 1,
  nat.succ_lt_succ (lt_of_lt_of_le (nat.mul_lt_mul_of_pos_left i.is_lt (by norm_num))
    (card_dom_aux h_card))⟩

def public_memory.to_memory_embedding_constraints
    {c : columns F} {inp : input_data F}
    (pm : public_memory c)
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length) :
  memory_embedding_constraints
    (inp.trace_length / 16 - 1)                               -- T
    (inp.trace_length / 128)                                  -- rc_len
    (λ j, c.cpu__decode__pc (j * 16))                         -- pc
    (λ j, c.cpu__decode__instruction (j * 16))                -- inst
    (λ j, c.cpu__operands__mem_dst__addr (j * 16))            -- dst_addr
    (λ j, c.cpu__operands__mem_dst__value (j * 16))           -- dst
    (λ j, c.cpu__operands__mem_op0__addr (j * 16))            -- op0_addr
    (λ j, c.cpu__operands__mem_op0__value (j * 16))           -- op0
    (λ j, c.cpu__operands__mem_op1__addr (j * 16))            -- op1_addr
    (λ j, c.cpu__operands__mem_op1__value (j * 16))           -- op1
    (λ j, c.rc_builtin__mem__addr (j * 128))                  -- rc_addr
    (λ j, c.rc_builtin__mem__value (j * 128))                 -- rc
    inp.m_star                                                -- mem_star
    (inp.trace_length / 2 - 1)                                -- n
    (λ i, c.mem_pool__addr (2 * i))                           -- a
    (λ i, c.mem_pool__value (2 * i))                          -- v
    :=
have h : ∀ j : ℕ, ∀ i : fin (inp.trace_length / 16 - 1), j < 8 →
    (↑i * 8 + j) < inp.trace_length / 2 - 1 + 1,
  begin
    rintros j ⟨i, ilt⟩ jlt,
    apply nat.lt_succ_of_le,
    apply nat.le_pred_of_lt,
    have : i * 8 + j < (i + 1) * 8,
    { rw [add_mul, one_mul], exact add_lt_add_left jlt _ },
    apply lt_of_lt_of_le this,
    rw [nat.le_div_iff_mul_le' (show 0 < 2, by norm_num), mul_assoc],
    norm_num,
    rw [←nat.le_div_iff_mul_le' (show 0 < 16, by norm_num)],
    apply nat.succ_le_of_lt,
    exact lt_of_lt_of_le ilt (nat.pred_le _)
  end,
have h1 : ∀ i : fin (inp.trace_length / 128),
    (↑i * 64 + 51) < inp.trace_length / 2 - 1 + 1,
  begin
    rintros ⟨i, ilt⟩,
    apply nat.lt_succ_of_le,
    apply nat.le_pred_of_lt,
    have : i * 64 + 51 < (i + 1) * 64,
    { rw add_mul, apply add_lt_add_left, norm_num },
    apply lt_of_lt_of_le this,
    apply le_trans (nat.mul_le_mul_right _ (nat.succ_le_of_lt ilt)),
    rw [nat.le_div_iff_mul_le' (show 0 < 2, by norm_num), mul_assoc],
    norm_num,
    apply nat.div_mul_le_self
  end,
have jaux : ∀ j : fin (inp.trace_length / 16 - 1), (j : ℕ) * 8 = 4 * (2 * j),
  by { intro j, rw [←mul_assoc, mul_comm (4 * 2)], refl },
{ embed_inst := λ i, ⟨↑i * 8 + 0, h 0 i (by norm_num)⟩,
  embed_dst  := λ i, ⟨↑i * 8 + 4, h 4 i (by norm_num)⟩,
  embed_op0  := λ i, ⟨↑i * 8 + 2, h 2 i (by norm_num)⟩,
  embed_op1  := λ i, ⟨↑i * 8 + 6, h 6 i (by norm_num)⟩,
  embed_rc   := λ i, ⟨↑i * 64 + 51, h1 i⟩,
  embed_mem  := embed_mem h_card,
  h_embed_pc       := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_inst     := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_dst_addr := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_dst      := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_op0_addr := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_op0      := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_op1_addr := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_op1      := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_rc_addr  := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_rc       := by { intro i, dsimp [column.off], congr' 1, ring },
  h_embed_dom      :=
    begin
      intro a, simp [column.off],
      apply pm.addr_zero, simp, rw [←mul_assoc],
      exact nat.mul_mod_right _ _
    end,
  h_embed_val :=
    begin
      intro a, simp [column.off],
      apply pm.value_zero, simp, rw [←mul_assoc],
      exact nat.mul_mod_right _ _
    end,
  h_embed_mem_inj :=
    begin
      intros a1 a2, dsimp [embed_mem],
      rw [fin.eq_iff_veq, add_left_inj 1, mul_right_inj' (show 4 ≠ 0, by norm_num), ←fin.ext_iff],
      apply equiv.injective
    end,
  h_embed_mem_disj_inst :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp at h',
      have := congr_arg (λ n, n % 4) h', dsimp [embed_mem] at this,
      rw [add_comm, add_comm _ 0, jaux, nat.add_mul_mod_self_left,
       nat.add_mul_mod_self_left] at this,
      norm_num at this
    end,
  h_embed_mem_disj_dst :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp  [embed_mem] at h',
      have := congr_arg (λ n, n % 4) h', dsimp at this,
      rw [add_comm, add_comm _ 4, jaux, nat.add_mul_mod_self_left,
       nat.add_mul_mod_self_left] at this,
      norm_num at this
    end,
  h_embed_mem_disj_op0 :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp  [embed_mem] at h',
      have := congr_arg (λ n, n % 4) h', dsimp at this,
      rw [add_comm, add_comm _ 2, jaux, nat.add_mul_mod_self_left,
       nat.add_mul_mod_self_left] at this,
      norm_num at this
    end,
  h_embed_mem_disj_op1 :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp  [embed_mem] at h',
      have := congr_arg (λ n, n % 4) h', dsimp at this,
      rw [add_comm, add_comm _ 6, jaux, nat.add_mul_mod_self_left,
       nat.add_mul_mod_self_left] at this,
      norm_num at this
    end,
  h_embed_mem_disj_rc :=
    begin
      intros a j h',
      rw [fin.eq_iff_veq] at h', dsimp  [embed_mem] at h',
      have jaux' : 64 = 16 * 4, by norm_num,
      have := congr_arg (λ n, n % 4) h', dsimp at this,
      rw [add_comm, add_comm _ 51, nat.add_mul_mod_self_left] at this,
      simp only [jaux', ←mul_assoc] at this,
      norm_num at this
    end }

/- putting it all together -/

def input_data.to_input_data_aux (inp : input_data F) (pd : public_data F)
  (rc_max_lt : pd.rc_max < 2^16)
  (rc_min_le : pd.rc_min ≤ pd.rc_max) : input_data_aux F :=
{ T := inp.trace_length / 16 - 1,
  rc16_len := inp.trace_length / 16,
  rc_len := inp.trace_length / 128,
  pc_I := inp.initial_pc,
  pc_F := inp.final_pc,
  ap_I := inp.initial_ap,
  ap_F := inp.final_ap,
  mem_star := inp.m_star,
  rc_min := pd.rc_min,
  rc_max := pd.rc_max,
  initial_rc_addr := pd.initial_rc_addr,
  rc_to_rc16 := rc_to_rc16,
  h_rc_lt := rc_max_lt,
  h_rc_le := rc_min_le }

def to_constraints {inp : input_data F} {pd : public_data F} {c : columns F} {ci : columns_inter F}
    /- autogenerated constraints -/
    (cd      : cpu__decode c)
    (ops     : cpu__operands c)
    (upd     : cpu__update_registers inp c)
    (opcodes : cpu__opcodes c)
    (m       : memory inp pd c ci)
    (rc      : rc16 inp pd c ci)
    (pm      : public_memory c)
    (rcb     : rc_builtin inp pd c)
    (iandf : toplevel_constraints inp c)
    /- extra assumptions -/
    (h_mem_star :
      let z     := pd.memory__multi_column_perm__perm__interaction_elm,
          alpha := pd.memory__multi_column_perm__hash_interaction_elm0,
          p     := pd.memory__multi_column_perm__perm__public_memory_prod,
          dom_m_star := { x // option.is_some (inp.m_star x) } in
       p * ∏ a : dom_m_star, (z - (a.val + alpha * mem_val a)) = z^(fintype.card dom_m_star))
    (h_card_dom : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (public_memory_prod_eq_one : pd.rc16__perm__public_memory_prod = 1)
    (rc_max_lt : pd.rc_max < 2^16)
    (rc_min_le : pd.rc_min ≤ pd.rc_max)
    (trace_length_le_char : inp.trace_length ≤ ring_char F) :
  constraints (inp.to_input_data_aux pd rc_max_lt rc_min_le) :=
have trace_length_pos : inp.trace_length > 0,
  from lt_of_lt_of_le (nat.zero_lt_succ _) h_card_dom,
{ fp := λ j, c.cpu__registers__fp (j * 16),
  ap := λ j, c.cpu__registers__ap (j * 16),
  pc := λ j, c.cpu__decode__pc (j * 16),
  inst := λ j, c.cpu__decode__instruction (j * 16),
  off_op0_tilde := λ j, c.cpu__decode__off1 (j * 16),
  off_op1_tilde := λ j, c.cpu__decode__off2 (j * 16),
  off_dst_tilde := λ j, c.cpu__decode__off0 (j * 16),
  rc16_val      := λ j, c.rc_builtin__inner_rc (j * 16),
  f_tilde := λ j k, c.cpu__decode__opcode_rc__column (j * 16 + k),
  dst_addr := λ j, c.cpu__operands__mem_dst__addr (j * 16),
  dst := λ j, c.cpu__operands__mem_dst__value (j * 16),
  op0_addr := λ j, c.cpu__operands__mem_op0__addr (j * 16),
  op0 := λ j, c.cpu__operands__mem_op0__value (j * 16),
  op1_addr := λ j, c.cpu__operands__mem_op1__addr (j * 16),
  op1 := λ j, c.cpu__operands__mem_op1__value (j * 16),
  rc_addr := λj, c.rc_builtin__mem__addr (j * 128),
  rc_val := λj, c.rc_builtin__mem__value (j * 128),
  h_pc_I := eq_of_sub_eq_zero (iandf.initial_pc _ rfl),
  h_ap_I := eq_of_sub_eq_zero (iandf.initial_ap _ rfl),
  h_fp_I := eq_of_sub_eq_zero (iandf.initial_fp _ rfl),
  h_pc_F := by { rw mul_comm _ 16, exact eq_of_sub_eq_zero (iandf.final_pc _ rfl) },
  h_ap_F := by { rw mul_comm _ 16, exact eq_of_sub_eq_zero (iandf.final_ap _ rfl) },
  mc := { n := inp.trace_length / 2 - 1,
          a := λ i, c.mem_pool__addr (2 * i),
          v := λ i, c.mem_pool__value (2 * i),
          em := pm.to_memory_embedding_constraints h_card_dom,
          mb := m.to_memory_block_constraints h_mem_star,
          h_n_lt :=
            begin
              apply lt_of_lt_of_le _ trace_length_le_char,
              apply nat.lt_of_succ_le,
              rw [nat.sub_one, nat.succ_pred_eq_of_pos],
              { apply  nat.div_le_self },
              apply nat.div_pos _ (show 0 < 2, by norm_num),
              apply le_trans _ h_card_dom,
              apply le_add_left (le_refl _),
            end},
  rc := rc.to_range_check_constraints trace_length_pos public_memory_prod_eq_one
          trace_length_le_char,
  ic := λ i, cd.to_instruction_constraints i,
  sc := λ i, by { rw fin.coe_succ, exact ops.to_step_constraints upd opcodes i (ne_of_lt i.is_lt) },
  rcb := rcb.to_rc_builtin_constraints
}

/- probabilistic constraints -/

def bad1 {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c19 c20 : column F) : finset F :=
bad_set_1
  (real_a inp.m_star (λ i, c19 (2 * i))     (embed_mem h_card))
  (real_v inp.m_star (λ i, c19 (2 * i + 1)) (embed_mem h_card))
  (λ j, c20 (2 * ↑j))
  (λ j, c20 (2 * ↑j + 1))

def bad2 {inp : input_data F} (pd : public_data F)
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c19 c20 : column F) : finset F :=
bad_set_2
  (real_a inp.m_star (λ i, c19 (2 * i))     (embed_mem h_card))
  (real_v inp.m_star (λ i, c19 (2 * i + 1)) (embed_mem h_card))
  (λ j, c20 (2 * ↑j))
  (λ j, c20 (2 * ↑j + 1))
  pd.memory__multi_column_perm__hash_interaction_elm0

def bad3 (inp : input_data F) (c0 c2 : column F) : finset F :=
bad_set_3
  (λ (i : fin (inp.trace_length - 1 + 1)), c0 i)
  (λ (i : fin (inp.trace_length - 1 + 1)), c2 i)

lemma trace_length_div_two_pos {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length) :
  inp.trace_length / 2 > 0 :=
begin
  apply nat.div_pos _ (show 0 < 2, by norm_num),
  apply le_trans _ h_card,
  apply le_add_left (le_refl _)
end

theorem bad1_bound {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c19 c20 : column F) :
  (bad1 h_card c19 c20).card ≤ (inp.trace_length / 2)^2 :=
begin
  transitivity,
  apply card_bad_set_1_le,
  rw [nat.sub_add_cancel, pow_two],
  apply trace_length_div_two_pos h_card
end

theorem bad2_bound {inp : input_data F} (pd : public_data F)
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c19 c20 : column F) :
  (bad2 pd h_card c19 c20).card ≤ inp.trace_length / 2 :=
begin
  transitivity,
  apply card_bad_set_2_le,
  rw nat.sub_add_cancel,
  apply trace_length_div_two_pos h_card
end

theorem bad3_bound {inp : input_data F}
    (h_card : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
    (c0 c2 : column F) :
  (bad3 inp c0 c2).card ≤ inp.trace_length :=
begin
  transitivity,
  apply card_bad_set_3_le,
  rw nat.sub_add_cancel,
  exact lt_of_lt_of_le (nat.zero_lt_succ _) h_card
end


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Simon Hudon, Scott Morrison
-/

import Mathlib.Control.Basic
import Mathlib.Logic.Equiv.Defs

/-!

# Functors can be applied to `Equiv`s.

```
def functor.map_equiv (f : Type u → Type v) [functor f] [LawfulFunctor f] :
  α ≃ β → f α ≃ f β
```

-/

open Equiv

namespace Functor

variable (f : Type u → Type v) [Functor f] [LawfulFunctor f]

/-- Apply a functor to an `Equiv`. -/
def map_equiv (h : α ≃ β) : f α ≃ f β where
  toFun    := map h
  invFun   := map h.symm
  left_inv x := by simp [map_map]
  right_inv x := by simp [map_map]

@[simp]
lemma map_equiv_apply (h : α ≃ β) (x : f α) :
  (map_equiv f h : f α ≃ f β) x = map h x := rfl

@[simp]
lemma map_equiv_symm_apply (h : α ≃ β) (y : f β) :
  (map_equiv f h : f α ≃ f β).symm y = map h.symm y := rfl

end Functor


import category_theory.isomorphism

import .colimits

/-

* Notation and lemmas for categories with `has_coproducts`.

* Construction of pushouts in terms of coproducts and coequalizers.

-/

open set

open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace category_theory

universes v u

section initial
variables {C : Type u} [category.{v} C]
variable [has_initial_object.{v} C]

def initial : C := has_initial_object.initial_object.{v}.ob

instance : has_emptyc C := ⟨initial⟩

def initial.induced (a : C) : ∅ ⟶ a :=
has_initial_object.initial_object.is_initial_object.induced

notation `!` a := initial.induced a

def initial.uniqueness {a : C} (k k' : ∅ ⟶ a) : k = k' :=
has_initial_object.initial_object.is_initial_object.uniqueness k k'

-- This instance tends not to be very useful because `congr` generates
-- a congruence lemma which is too general, and does not "know" that
-- the domain is ∅.
instance initial_hom.subsingleton (a : C) : subsingleton (∅ ⟶ a) := ⟨initial.uniqueness⟩

end initial

section coproduct
variables {C : Type u} [category.{v} C]
variable [has_coproducts.{v} C]

-- The (chosen) coproduct of two objects.
def coprod (a₀ a₁ : C) :=
(has_coproducts.coproduct.{v} a₀ a₁).ob

infix ` ⊔ ` := coprod

-- The "left" inclusion.
def i₀ {a₀ a₁ : C} : a₀ ⟶ a₀ ⊔ a₁ :=
(has_coproducts.coproduct.{v} a₀ a₁).map₀

-- The "right" inclusion.
def i₁ {a₀ a₁ : C} : a₁ ⟶ a₀ ⊔ a₁ :=
(has_coproducts.coproduct.{v} a₀ a₁).map₁

-- The map out of a coproduct induced by a map on each summand.
def coprod.induced {a₀ a₁ b : C} (f₀ : a₀ ⟶ b) (f₁ : a₁ ⟶ b) : a₀ ⊔ a₁ ⟶ b :=
(has_coproducts.coproduct.{v} a₀ a₁).is_coproduct.induced f₀ f₁

def coprod.induced_Is_equiv {a₀ a₁ b : C} :
  Is_equiv (λ p : (a₀ ⟶ b) × (a₁ ⟶ b), coprod.induced p.1 p.2) :=
{ e := ((has_coproducts.coproduct a₀ a₁).is_coproduct.universal b).e.symm,
  h := by funext p; cases p; refl }

@[simp] lemma coprod.induced_commutes₀ {a₀ a₁ b : C} (f₀ : a₀ ⟶ b) (f₁ : a₁ ⟶ b) :
  coprod.induced f₀ f₁ ∘ i₀ = f₀ :=
(has_coproducts.coproduct.{v} a₀ a₁).is_coproduct.induced_commutes₀ f₀ f₁

@[simp] lemma coprod.induced_commutes₁ {a₀ a₁ b : C} (f₀ : a₀ ⟶ b) (f₁ : a₁ ⟶ b) :
  coprod.induced f₀ f₁ ∘ i₁ = f₁ :=
(has_coproducts.coproduct.{v} a₀ a₁).is_coproduct.induced_commutes₁ f₀ f₁

def coprod.fold (a : C) : a ⊔ a ⟶ a :=
coprod.induced (𝟙 a) (𝟙 a)

@[simp] lemma coprod.fold_i₀ {a : C} : coprod.fold a ∘ i₀ = 𝟙 a :=
coprod.induced_commutes₀ _ _

@[simp] lemma coprod.fold_i₁ {a : C} : coprod.fold a ∘ i₁ = 𝟙 a :=
coprod.induced_commutes₁ _ _

-- This is a kind of "co-extensionality" lemma; does that count?
@[ext] lemma coprod.uniqueness {a₀ a₁ b : C} {k k' : a₀ ⊔ a₁ ⟶ b}
  (e₀ : k ∘ i₀ = k' ∘ i₀) (e₁ : k ∘ i₁ = k' ∘ i₁) : k = k' :=
(has_coproducts.coproduct.{v} a₀ a₁).is_coproduct.uniqueness e₀ e₁

lemma coprod.ext {a₀ a₁ b : C} {k k' : a₀ ⊔ a₁ ⟶ b} :
  k = k' ↔ k ∘ i₀ = k' ∘ i₀ ∧ k ∘ i₁ = k' ∘ i₁ :=
iff.intro (assume h, by rw h; simp) (assume ⟨h₀, h₁⟩, coprod.uniqueness h₀ h₁)

-- Similarly, this is a "co-eta reduction".
@[simp] lemma coprod.eta {a₀ a₁ b : C} {k : a₀ ⊔ a₁ ⟶ b} :
  coprod.induced (k ∘ i₀) (k ∘ i₁) = k :=
coprod.uniqueness (by simp) (by simp)

def coprod_of_maps {a₀ a₁ b₀ b₁ : C} (f₀ : a₀ ⟶ b₀) (f₁ : a₁ ⟶ b₁) : a₀ ⊔ a₁ ⟶ b₀ ⊔ b₁ :=
coprod.induced (i₀ ∘ f₀) (i₁ ∘ f₁)

@[simp] lemma coprod_of_maps_commutes₀ {a₀ a₁ b₀ b₁ : C} {f₀ : a₀ ⟶ b₀} {f₁ : a₁ ⟶ b₁} :
  coprod_of_maps f₀ f₁ ∘ i₀ = i₀ ∘ f₀ :=
coprod.induced_commutes₀ _ _

@[simp] lemma coprod_of_maps_commutes₁ {a₀ a₁ b₀ b₁ : C} {f₀ : a₀ ⟶ b₀} {f₁ : a₁ ⟶ b₁} :
  coprod_of_maps f₀ f₁ ∘ i₁ = i₁ ∘ f₁ :=
coprod.induced_commutes₁ _ _

def isomorphic_coprod_of_Is_coproduct {a₀ a₁ b : C} {f₀ : a₀ ⟶ b} {f₁ : a₁ ⟶ b}
  (h : Is_coproduct f₀ f₁) : iso (a₀ ⊔ a₁) b :=
{ hom := coprod.induced f₀ f₁,
  inv := h.induced i₀ i₁,
  hom_inv_id' := by apply coprod.uniqueness; { rw ←assoc, simp },
  inv_hom_id' := by apply h.uniqueness; { rw ←assoc, simp } }

def coprod_of_isomorphisms {a₀ a₁ b₀ b₁ : C} (j₀ : iso a₀ b₀) (j₁ : iso a₁ b₁) :
  iso (a₀ ⊔ a₁) (b₀ ⊔ b₁) :=
{ hom := coprod_of_maps j₀.hom j₁.hom,
  inv := coprod_of_maps j₀.inv j₁.inv,
  hom_inv_id' := by apply coprod.uniqueness; rw ←assoc; simp,
  inv_hom_id' := by apply coprod.uniqueness; rw ←assoc; simp }

variables [has_initial_object.{v} C]

def coprod_initial_right (a : C) : a ≅ a ⊔ ∅ :=
{ hom := i₀,
  inv := coprod.induced (𝟙 a) (! a),
  hom_inv_id' := by simp,
  inv_hom_id' :=
    by apply coprod.uniqueness; try { apply initial.uniqueness };
       rw ←assoc; simp }

@[simp] lemma coprod_initial_right_hom {a : C} : (coprod_initial_right a).hom = i₀ :=
rfl

def coprod_initial_left (a : C) : a ≅ ∅ ⊔ a :=
{ hom := i₁,
  inv := coprod.induced (! a) (𝟙 a),
  hom_inv_id' := by simp,
  inv_hom_id' :=
    by apply coprod.uniqueness; try { apply initial.uniqueness };
       rw ←assoc; simp }

@[simp] lemma coprod_initial_left_hom {a : C} : (coprod_initial_left a).hom = i₁ :=
rfl

end coproduct

section pushout_induced_eq
parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c c' : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)

lemma pushout_induced_eq_iff {x : C} {h₀ : b₀ ⟶ x} {h₁ : b₁ ⟶ x} {k : c ⟶ x} {e}
  (H₀ : h₀ = g₀ ≫ k) (H₁ : h₁ = g₁ ≫ k) : po.induced h₀ h₁ e = k :=
by apply po.uniqueness; simp [H₀, H₁]

end pushout_induced_eq

section pushout_induced_comp
parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c c' : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)

lemma pushout_induced_comp {x y : C} {h₀ : b₀ ⟶ x} {h₁ : b₁ ⟶ x} {k : x ⟶ y} {e} :
  k ∘ po.induced h₀ h₁ e = po.induced (k ∘ h₀) (k ∘ h₁)
    (by rw [←assoc, ←assoc, e]) :=
by apply po.uniqueness; rw ←assoc; simp

end pushout_induced_comp

section pushouts_from_coequalizers
parameters {C : Type u} [category.{v} C] [has_coproducts.{v} C]

section construction
parameters {a b₀ b₁ b c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁} {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c}

def Is_pushout_of_Is_coequalizer
  (H : Is_coequalizer (i₀ ∘ f₀) (i₁ ∘ f₁) (coprod.induced g₀ g₁)) :
  Is_pushout f₀ f₁ g₀ g₁ :=
Is_pushout.mk'
  (begin convert H.commutes using 1; rw assoc; simp end)
  (λ x h₀ h₁ e, H.induced (coprod.induced h₀ h₁)
    (begin rw [assoc, assoc], simpa using e end))
  (assume x h₀ h₁ e,
    -- Weird trick to avoid repeating the proof argument
    (λ p, let K := H.induced (coprod.induced h₀ h₁) p in calc
      K ∘ g₀ = K ∘ (coprod.induced g₀ g₁ ∘ i₀)  : by simp
      ...    = (K ∘ coprod.induced g₀ g₁) ∘ i₀  : by rw assoc
      ...    = h₀ : by simp) _)
  (assume x h₀ h₁ e,
    (λ p, let K := H.induced (coprod.induced h₀ h₁) p in calc
      K ∘ g₁ = K ∘ (coprod.induced g₀ g₁ ∘ i₁)  : by simp
      ...    = (K ∘ coprod.induced g₀ g₁) ∘ i₁  : by rw assoc
      ...    = h₁ : by simp) _)
  (assume x k k' e₀ e₁, H.uniqueness $ coprod.uniqueness
    (by rw [←assoc, ←assoc]; simpa using e₀)
    (by rw [←assoc, ←assoc]; simpa using e₁))

def pushout_of_coequalizer (E : coequalizer (i₀ ∘ f₀) (i₁ ∘ f₁)) : pushout f₀ f₁ :=
{ ob := E.ob,
  map₀ := E.map ∘ i₀,
  map₁ := E.map ∘ i₁,
  is_pushout := by
    apply Is_pushout_of_Is_coequalizer; convert E.is_coequalizer; simp }

end construction

def has_pushouts_of_has_coequalizers_and_coproducts [has_coequalizers.{v} C] :
  has_pushouts.{v} C :=
{ pushout := λ a b₀ b₁ f₀ f₁,
    pushout_of_coequalizer $ has_coequalizers.coequalizer (i₀ ∘ f₀) (i₁ ∘ f₁) }

end pushouts_from_coequalizers

section uniqueness_of_initial_objects
parameters {C : Type u} [category.{v} C]
parameters {a : C} (init : Is_initial_object.{v} a)
parameters {a' : C} (init' : Is_initial_object.{v} a')

def initial_object.unique : iso a a' :=
{ hom := init.induced,
  inv := init'.induced,
  hom_inv_id' := init.uniqueness _ _,
  inv_hom_id' := init'.uniqueness _ _ }

end uniqueness_of_initial_objects

section uniqueness_of_pushouts

parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c c' : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)
parameters {g'₀ : b₀ ⟶ c'} {g'₁ : b₁ ⟶ c'} (po' : Is_pushout f₀ f₁ g'₀ g'₁)

@[reducible] private def h : c ⟶ c' := po.induced g'₀ g'₁ po'.commutes
@[reducible] private def h' : c' ⟶ c := po'.induced g₀ g₁ po.commutes

def pushout.unique : iso c c' :=
{ hom := h,
  inv := h',
  hom_inv_id' := by apply po.uniqueness; {rw ←category.assoc, simp},
  inv_hom_id' := by apply po'.uniqueness; {rw ←category.assoc, simp} }

@[simp] lemma pushout.unique_commutes₀ : pushout.unique.hom ∘ g₀ = g'₀ :=
by apply po.induced_commutes₀

@[simp] lemma pushout.unique_commutes₁ : pushout.unique.hom ∘ g₁ = g'₁ :=
by apply po.induced_commutes₁

end uniqueness_of_pushouts

local notation [parsing_only] a ` ~~ ` b := Bij_on _ a b

section refl
parameters {C : Type u} [category.{v} C]
parameters {a b : C} (f : a ⟶ b)

def Is_pushout.refl : Is_pushout f (𝟙 a) (𝟙 b) f :=
Is_pushout.mk $ λ x,
  Bij_on.mk
    { to_fun := λ h, ⟨(h ∘ 𝟙 b, h ∘ f), by simp⟩,
      inv_fun := λ p, ⟨p.val.1, trivial⟩,
      left_inv := assume h, by simp,
      right_inv := assume ⟨⟨pv1, pv2⟩, pp⟩, by simpa using pp }
    (assume h, rfl)

end refl

section isomorphic

parameters {C : Type u} [category.{v} C]

-- TODO: Move this somewhere?
def precomposition_bij {a' a x : C} (i : iso a' a) :
  Bij_on (λ (k : a ⟶ x), (k ∘ i.hom : a' ⟶ x)) univ univ :=
Bij_on.of_equiv $ show (a ⟶ x) ≃ (a' ⟶ x), from
{ to_fun := λ k, k ∘ i.hom,
  inv_fun := λ k', k' ∘ i.inv,
  left_inv := λ k, by simp,
  right_inv := λ k', by simp }

parameters {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)
parameters {a' b'₀ b'₁ : C} (f'₀ : a' ⟶ b'₀) (f'₁ : a' ⟶ b'₁)
parameters (i : iso a' a) (j₀ : iso b'₀ b₀) (j₁ : iso b'₁ b₁)
parameters (e₀ : f₀ ∘ i.hom = j₀.hom ∘ f'₀) (e₁ : f₁ ∘ i.hom = j₁.hom ∘ f'₁)

include e₀ e₁
def Is_pushout_of_isomorphic : Is_pushout f'₀ f'₁ (g₀ ∘ j₀.hom) (g₁ ∘ j₁.hom) :=
Is_pushout.mk $ λ x,
  have _ := calc
  univ ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁}
       : po.universal x
  ...  ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | (p.1 ∘ j₀.hom) ∘ f'₀ = (p.2 ∘ j₁.hom) ∘ f'₁}
       : begin
           convert Bij_on.refl _, funext p, apply propext,
           rw [←assoc, ←assoc, ←e₀, ←e₁], simp [cancel_epi],
         end
  ...  ~~ {p : (b'₀ ⟶ x) × (b'₁ ⟶ x) | p.1 ∘ f'₀ = p.2 ∘ f'₁}
       : Bij_on.restrict''
           (Bij_on.prod' (precomposition_bij j₀) (precomposition_bij j₁))
           {p | p.1 ∘ f'₀ = p.2 ∘ f'₁},
  by convert this; funext; simp
omit e₀ e₁

parameters {c' : C} (k : iso c c')

def Is_pushout_of_isomorphic' : Is_pushout f₀ f₁ (k.hom ∘ g₀) (k.hom ∘ g₁) :=
Is_pushout.mk $ λ x,
  have _ := calc
  univ ~~ univ
       : precomposition_bij k
  ...  ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁ }
       : po.universal x,
  by convert this; funext; simp

end isomorphic

section pushout_tranpose

parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)

def Is_pushout.transpose : Is_pushout f₁ f₀ g₁ g₀ :=
Is_pushout.mk $ λ x, calc
  univ ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁}
       : po.universal x
  ...  ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.2 ∘ f₁ = p.1 ∘ f₀}
       : begin convert Bij_on.refl _; ext p; split; exact eq.symm, end
  ...  ~~ {p' : (b₁ ⟶ x) × (b₀ ⟶ x) | p'.1 ∘ f₁ = p'.2 ∘ f₀}
       : Bij_on.restrict_equiv (equiv.prod_comm _ _)
           {p' | p'.1 ∘ f₁ = p'.2 ∘ f₀}

parameters {c' : C} {g₀' : b₀ ⟶ c'} {g₁' : b₁ ⟶ c'}
parameters (po' : Is_pushout f₁ f₀ g₁' g₀')
def Is_pushout.iso_transpose : c ≅ c' :=
pushout.unique po.transpose po'

@[simp] lemma Is_pushout.iso_transpose_map₀ : g₀ ≫ (po.iso_transpose po').hom = g₀' :=
by apply pushout.unique_commutes₁

@[simp] lemma Is_pushout.iso_transpose_map₁ : g₁ ≫ (po.iso_transpose po').hom = g₁' :=
by apply pushout.unique_commutes₀

lemma Is_pushout.transpose_induced {x : C} {h₀ : b₀ ⟶ x} {h₁ : b₁ ⟶ x} {e : f₀ ≫ h₀ = f₁ ≫ h₁} :
  (po.iso_transpose po').hom ≫ po'.induced h₁ h₀ e.symm = po.induced h₀ h₁ e :=
begin
  symmetry,
  apply pushout_induced_eq_iff; rw ←assoc; simp
end

end pushout_tranpose

section pushout_initial
parameters {C : Type u} [category.{v} C]
parameters {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c}

-- TODO: Somehow prove these two simultaneously?
def Is_pushout_of_Is_coproduct_of_Is_initial (copr : Is_coproduct g₀ g₁)
  (h : Is_initial_object.{v} a) : Is_pushout f₀ f₁ g₀ g₁ :=
Is_pushout.mk $ λ x, calc
  univ ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | true}
       : Bij_on.of_Is_equiv (copr.universal x)
  ...  ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁}
       : by convert Bij_on.refl _; ext p; change (_ = _) ↔ true;
            simp; apply h.uniqueness

def Is_coproduct_of_Is_pushout_of_Is_initial (po : Is_pushout f₀ f₁ g₀ g₁)
  (h : Is_initial_object.{v} a) : Is_coproduct g₀ g₁ :=
have _ := λ x, calc
  univ ~~ {p : (b₀ ⟶ x) × (b₁ ⟶ x) | p.1 ∘ f₀ = p.2 ∘ f₁}
       : po.universal x
  ...  ~~ (univ : set ((b₀ ⟶ x) × (b₁ ⟶ x)))
       : begin
           convert Bij_on.refl _, symmetry, rw ←univ_subset_iff,
           intros p _, apply h.uniqueness
         end,
Is_coproduct.mk $ λ x, (this x).Is_equiv

end pushout_initial

section coprod_of_pushouts

parameters {C : Type u} [category.{v} C] [has_coproducts.{v} C]
parameters {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
parameters {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)
parameters {a' b₀' b₁' c' : C} {f₀' : a' ⟶ b₀'} {f₁' : a' ⟶ b₁'}
parameters {g₀' : b₀' ⟶ c'} {g₁' : b₁' ⟶ c'} (po' : Is_pushout f₀' f₁' g₀' g₁')
include po po'

def Is_pushout_coprod :
  Is_pushout
    (coprod_of_maps f₀ f₀') (coprod_of_maps f₁ f₁')
    (coprod_of_maps g₀ g₀') (coprod_of_maps g₁ g₁') :=
Is_pushout.mk $ λ x,
  have _ := calc
  univ ~~ (univ : set ((c ⟶ x) × (c' ⟶ x)))
       : Bij_on.of_Is_equiv ((has_coproducts.coproduct c c').is_coproduct.universal x)
  ...  ~~ {pp : ((b₀ ⟶ x) × (b₁ ⟶ x)) × ((b₀' ⟶ x) × (b₁' ⟶ x))
          | pp.1.1 ∘ f₀ = pp.1.2 ∘ f₁ ∧ pp.2.1 ∘ f₀' = pp.2.2 ∘ f₁'}
       :
  begin
    convert Bij_on.prod (po.universal x) (po'.universal x),
    ext p, simp
  end
  ...  ~~ {qq : ((b₀ ⟶ x) × (b₀' ⟶ x)) × ((b₁ ⟶ x) × (b₁' ⟶ x))
          | qq.1.1 ∘ f₀ = qq.2.1 ∘ f₁ ∧ qq.1.2 ∘ f₀' = qq.2.2 ∘ f₁'}
       : Bij_on.restrict_equiv
           { to_fun := λ (pp : ((b₀ ⟶ x) × (b₁ ⟶ x)) × ((b₀' ⟶ x) × (b₁' ⟶ x))), ((pp.1.1, pp.2.1), (pp.1.2, pp.2.2)),
             inv_fun := λ qq, ⟨⟨qq.1.1, qq.2.1⟩, ⟨qq.1.2, qq.2.2⟩⟩,
             left_inv := assume ⟨⟨_,_⟩,⟨_,_⟩⟩, rfl,
             right_inv := assume ⟨⟨_,_⟩,⟨_,_⟩⟩, rfl }
           {qq : ((b₀ ⟶ x) × (b₀' ⟶ x)) × ((b₁ ⟶ x) × (b₁' ⟶ x))
          | qq.1.1 ∘ f₀ = qq.2.1 ∘ f₁ ∧ qq.1.2 ∘ f₀' = qq.2.2 ∘ f₁'}
  ...  ~~ {qq : ((b₀ ⟶ x) × (b₀' ⟶ x)) × ((b₁ ⟶ x) × (b₁' ⟶ x))
          | coprod.induced qq.1.1 qq.1.2 ∘ coprod_of_maps f₀ f₀' =
            coprod.induced qq.2.1 qq.2.2 ∘ coprod_of_maps f₁ f₁' }
       :
  begin
    convert Bij_on.refl _,
    ext qq, change _ = _ ↔ _ = _ ∧ _ = _,
    rw [coprod.ext, ←assoc, ←assoc, ←assoc, ←assoc],
    simp
  end
  ...  ~~ {qq : (b₀ ⊔ b₀' ⟶ x) × (b₁ ⊔ b₁' ⟶ x)
          | qq.1 ∘ coprod_of_maps f₀ f₀' = qq.2 ∘ coprod_of_maps f₁ f₁'}
       : Bij_on.restrict''
           (Bij_on.prod'
             (Bij_on.of_Is_equiv coprod.induced_Is_equiv)
             (Bij_on.of_Is_equiv coprod.induced_Is_equiv))
           {qq : (b₀ ⊔ b₀' ⟶ x) × (b₁ ⊔ b₁' ⟶ x)
           | qq.1 ∘ coprod_of_maps f₀ f₀' = qq.2 ∘ coprod_of_maps f₁ f₁'},
  begin
    convert this,
    funext k, apply prod.ext; apply coprod.uniqueness;
    { change _ ∘ _ ∘ _ = _ ∘ _, simp [coproduct_comparison],
      rw ←assoc, simp, refl },
  end

end coprod_of_pushouts

section pushout_i

parameters {C : Type u} [category.{v} C] [has_coproducts.{v} C]
-- Obviously we shouldn't really need C to have an initial object here, but oh well
parameters [has_initial_object.{v} C]
parameters {a b c : C} (f : a ⟶ b)

/-
  a → a ⊔ c
  ↓     ↓
  b → b ⊔ c
-/

def Is_pushout_i₀ : Is_pushout f i₀ i₀ (coprod_of_maps f (𝟙 c)) :=
let po := Is_pushout_coprod (Is_pushout.refl f) (Is_pushout.refl (! c)).transpose in
by convert Is_pushout_of_isomorphic po f i₀
     (coprod_initial_right a) (coprod_initial_right b) (iso.refl _) _ _; simp

/-
  a → c ⊔ a
  ↓     ↓
  b → c ⊔ b
-/

def Is_pushout_i₁ : Is_pushout f i₁ i₁ (coprod_of_maps (𝟙 c) f) :=
let po := Is_pushout_coprod (Is_pushout.refl (! c)).transpose (Is_pushout.refl f) in
by convert Is_pushout_of_isomorphic po f i₁
     (coprod_initial_left a) (coprod_initial_left b) (iso.refl _) _ _; simp

end pushout_i

section pushout_swap
parameters {C : Type u} [category.{v} C]
parameters {a b c : C} {f : a ⟶ b} {g₀ g₁ : b ⟶ c} (po : Is_pushout f f g₀ g₁)

def Is_pushout.swap : c ⟶ c := po.induced g₁ g₀ po.commutes.symm

def Is_pushout.swap_iso : c ≅ c :=
{ hom := po.swap,
  inv := po.swap,
  hom_inv_id' := by apply po.uniqueness; unfold Is_pushout.swap; rw ←assoc; simp,
  inv_hom_id' := by apply po.uniqueness; unfold Is_pushout.swap; rw ←assoc; simp }

@[simp] def Is_pushout.induced_swap {x} {h₀ h₁ : b ⟶ x} {p p'} :
  po.induced h₀ h₁ p ∘ po.swap = po.induced h₁ h₀ p' :=
by apply po.uniqueness; unfold Is_pushout.swap; rw ←assoc; simp

end pushout_swap

section pushout_of_maps
parameters {C : Type u} [category.{v} C]
variables {a b₀ b₁ c : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
variables {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} (po : Is_pushout f₀ f₁ g₀ g₁)
variables {a' b₀' b₁' c' : C} {f₀' : a' ⟶ b₀'} {f₁' : a' ⟶ b₁'}
variables {g₀' : b₀' ⟶ c'} {g₁' : b₁' ⟶ c'} (po' : Is_pushout f₀' f₁' g₀' g₁')
variables {a'' b₀'' b₁'' c'' : C} {f₀'' : a'' ⟶ b₀''} {f₁'' : a'' ⟶ b₁''}
variables {g₀'' : b₀'' ⟶ c''} {g₁'' : b₁'' ⟶ c''} (po'' : Is_pushout f₀'' f₁'' g₀'' g₁'')
variables (ha : a ⟶ a') (hb₀ : b₀ ⟶ b₀') (hb₁ : b₁ ⟶ b₁')
variables (h₀ : hb₀ ∘ f₀ = f₀' ∘ ha) (h₁ : hb₁ ∘ f₁ = f₁' ∘ ha)
variables (ka : a' ⟶ a'') (kb₀ : b₀' ⟶ b₀'') (kb₁ : b₁' ⟶ b₁'')
variables (k₀ : kb₀ ∘ f₀' = f₀'' ∘ ka) (k₁ : kb₁ ∘ f₁' = f₁'' ∘ ka)

include po po' h₀ h₁

def pushout_of_maps : c ⟶ c' :=
po.induced (g₀' ∘ hb₀) (g₁' ∘ hb₁)
  (by rw [←assoc, ←assoc, h₀, h₁]; simp [po'.commutes])

omit po po' h₀ h₁

lemma induced_pushout_of_maps {x : C} {k₀ : b₀' ⟶ x} {k₁ : b₁' ⟶ x} {e} :
  po'.induced k₀ k₁ e ∘ pushout_of_maps po po' ha hb₀ hb₁ h₀ h₁ = po.induced (k₀ ∘ hb₀) (k₁ ∘ hb₁)
    (by rw [←assoc, ←assoc, h₀, h₁]; simp [e]) :=
begin
  unfold pushout_of_maps,
  apply po.uniqueness; { rw ←assoc, simp }
end

@[simp] lemma pushout_of_maps_commutes₀ : pushout_of_maps po po' ha hb₀ hb₁ h₀ h₁ ∘ g₀ = g₀' ∘ hb₀ :=
by simp [pushout_of_maps]

@[simp] lemma pushout_of_maps_commutes₁ : pushout_of_maps po po' ha hb₀ hb₁ h₀ h₁ ∘ g₁ = g₁' ∘ hb₁ :=
by simp [pushout_of_maps]

lemma pushout_of_maps_id : pushout_of_maps po po (𝟙 a) (𝟙 b₀) (𝟙 b₁) (by simp) (by simp) = 𝟙 _ :=
by apply pushout_induced_eq_iff; simp

lemma pushout_of_maps_comp :
  pushout_of_maps po po'' (ha ≫ ka) (hb₀ ≫ kb₀) (hb₁ ≫ kb₁)
    (by rw [←assoc, h₀, assoc, k₀, ←assoc]) (by rw [←assoc, h₁, assoc, k₁, ←assoc]) =
  pushout_of_maps po po' ha hb₀ hb₁ h₀ h₁ ≫ pushout_of_maps po' po'' ka kb₀ kb₁ k₀ k₁ :=
by apply pushout_induced_eq_iff; rw ←assoc; simp

end pushout_of_maps

end category_theory


import tactic
import category_theory.functor
import data.W.basic
import category_theory.closed.types
import algebra.category.CommRing.basic
import algebra.category.Module.basic

universes u v w x

open category_theory
--W

variables {𝒞 : Type u} [category.{v} 𝒞]

@[protect_proj] class struc (F : 𝒞 → Type w) :=
( hom : Π {A B : 𝒞} (f : A ⟶ B) (a : F A) (b : F B), Type x )
( id : Π {A : 𝒞} (a : F A), hom (𝟙 A) a a )
( comp : Π {A B C : 𝒞} {a : F A} {b : F B} {c : F C}
    {f : A ⟶ B} {g : B ⟶ C} (f' : hom f a b) (g' : hom g b c)
    {h : A ⟶ C} (H : f ≫ g = h), hom h a c )
( id_comp : Π {A B : 𝒞} {f : A ⟶ B} {a : F A} {b : F B}
    (f' : hom f a b), comp (id a) f' (category.id_comp f) = f' )
( comp_id : Π {A B : 𝒞} {f : A ⟶ B} {a : F A} {b : F B}
    (f' : hom f a b), comp f' (id b) (category.comp_id f) = f' )
( assoc : Π {A B C D : 𝒞} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
    {a : F A} {b : F B} {c : F C} {d : F D}
    (f' : hom f a b) (g' : hom g b c) (h' : hom h c d),
    comp (comp f' g' rfl) h' rfl = comp f' (comp g' h' rfl)
      (category.assoc _ _ _).symm )

-- @[protect_proj] class GS (F : 𝒞 → Type w) :=
-- ( hom : Π {A B : 𝒞} (f : A ⟶ B) (a : F A) (b : F B), Type x )
-- ( id : Π {A : 𝒞} (a b : F A) (h : a = b) (f : A ⟶ A) (hf : f = 𝟙 A), hom f a b )

attribute [simp] struc.id_comp struc.comp_id

namespace struc

variables (F : 𝒞 → Type w) [struc F]

lemma assoc_left {A B C D : 𝒞} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
    {a : F A} {b : F B} {c : F C} {d : F D}
    (f' : struc.hom f a b) (g' : struc.hom g b c) (h' : struc.hom h c d)
    (i : A ⟶ C) (k : A ⟶ D)
    (hi : f ≫ g = i) (hk : i ≫ h = k) :
    struc.comp (struc.comp f' g' hi) h' hk = struc.comp f'
      (struc.comp g' h' rfl) (by rw [← hk, ← hi, category.assoc]) :=
begin
  substs i k,
  rw struc.assoc,
end

lemma comp_eq_cast {A B C : 𝒞} {f : A ⟶ B} {g : B ⟶ C}
  {a : F A} {b : F B} {c : F C} (f' : struc.hom f a b) (g' : struc.hom g b c)
  (i : A ⟶ C) (hi : f ≫ g = i)
  (j : A ⟶ C) (hj : f ≫ g = j) :
  struc.comp f' g' hi = cast (by substs i j) (struc.comp f' g' hj) :=
begin
  substs i j, refl
end

lemma assoc_left' {A B C D : 𝒞} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
    {a : F A} {b : F B} {c : F C} {d : F D}
    (f' : struc.hom f a b) (g' : struc.hom g b c) (h' : struc.hom h c d)
    (i : A ⟶ C) (k : A ⟶ D)
    (hi : f ≫ g = i) (hk : i ≫ h = k) :
    struc.comp (struc.comp f' g' hi) h' hk = cast (by rw [← hk, ← hi, category.assoc])
      (struc.comp f' (struc.comp g' h' rfl) rfl)  :=
begin
  rw struc.assoc_left,
  substs i k,
  rw [comp_eq_cast]
end

lemma id_comp' {A B : 𝒞} {f : A ⟶ B} (g : A ⟶ B) {a : F A} {b : F B}
  (h : 𝟙 A ≫ f = g) (f' : struc.hom f a b) :
  struc.comp (struc.id a) f' h = cast (by rw [← h, category.id_comp]) f' :=
begin
  rw [category.id_comp] at h,
  subst h,
  simp
end

lemma comp_id' {A B : 𝒞} {f : A ⟶ B} (g : A ⟶ B) {a : F A} {b : F B}
  (h : f ≫ 𝟙 B = g) (f' : struc.hom f a b) :
  struc.comp f' (struc.id b) h = cast (by rw [← h, category.comp_id]) f' :=
begin
  rw [category.comp_id] at h,
  subst h,
  simp
end

instance  : category_struct (sigma F) :=
{ hom := λ A B, Σ (f : A.1 ⟶ B.1), struc.hom f A.2 B.2,
  id := λ A, ⟨𝟙 A.1, struc.id A.2⟩,
  comp := λ A B C f g, ⟨f.1 ≫ g.1, struc.comp f.2 g.2 rfl⟩ }

@[simp] lemma comp_fst {A B C : sigma F} (f : A ⟶ B) (g : B ⟶ C) :
  (f ≫ g).fst = f.1 ≫ g.1 := rfl

@[simp] lemma comp_snd {A B C : sigma F} (f : A ⟶ B) (g : B ⟶ C) :
  (f ≫ g).snd = struc.comp f.2 g.2 rfl := rfl

@[simp] lemma id_fst {A : sigma F} : sigma.fst (𝟙 A) = 𝟙 A.1 := rfl

@[simp] lemma id_snd {A : sigma F} : sigma.snd (𝟙 A) = struc.id A.2 := rfl

instance sigma.category : category (sigma F) :=
{ id_comp' := λ A B f, sigma.ext (category.id_comp _) $
    by simp [struc.id_comp'],
  comp_id' := λ A B f, sigma.ext (category.comp_id _) $
    by simp [struc.comp_id'],
  assoc' := λ A B C D f g h, sigma.ext (category.assoc _ _ _) $
    by simp [assoc_left'] }

instance (X : 𝒞) : category_struct (F X) :=
{ hom := λ A B, struc.hom (𝟙 X) A B,
  id := λ A, struc.id A,
  comp := λ A B C f g, (struc.comp f g (category.id_comp _)) }

instance (X : 𝒞) : category (F X) :=
{ id_comp' := λ A B f, struc.id_comp _,
  comp_id' := λ A B f, struc.comp_id _,
  assoc' := λ A B C D f g h,
    show (f ≫ g) ≫ h = f ≫ g ≫ h,
      begin
        dsimp [category_struct.comp],
        rw [struc.assoc_left],
        congr' 2; simp
      end }

def forget : sigma F ⥤ 𝒞 :=
{ obj := sigma.fst,
  map := λ _ _, sigma.fst }

def thing (X : 𝒞) : F X ⥤ sigma F :=
{ obj := λ A, ⟨X, A⟩,
  map := λ A B f, ⟨𝟙 X, f⟩,
  map_id' := λ A, rfl,
  map_comp' := λ A B C f g, sigma.ext
    (by simp) begin simp only [comp_snd],
       rw [struc.comp_eq_cast F f g (𝟙 X ≫ 𝟙 X) rfl (𝟙 X)
         (category.comp_id _)],
       symmetry,
       rw [← cast_eq_iff_heq],
       simp, refl,
       simp,
     end }

instance inst1 (F : 𝒞 ⥤ Type) : struc F.obj :=
{ hom := λ A B f a b, plift (F.map f a = b),
  id := λ A a, ⟨by simp⟩,
  comp := λ A B C a b c f g h₁ h₂ _ h, ⟨by simp [← h, F.map_comp, h₁.down, h₂.down]⟩,
  assoc := λ _ _ _ _ _ _ _ _ _ _ _ h₁ h₂ h₃,
    begin simp [h₁.down, h₂.down, h₃.down] end,
  id_comp := λ _ _ _ _ _ h,
    begin simp [h.down] end,
  comp_id := λ _ _ _ _ _ h,
    begin simp [h.down] end }

-- instance inst2 (F : 𝒞 ⥤ Typeᵒᵖ) : struc (λ x, (F.obj x).unop) :=
-- { hom := λ A B f a b, plift ((F.map f).unop b = a),
--   id := λ A a, ⟨by simp⟩,
--   comp := λ A B C a b c f g h₁ h₂, ⟨by simp [F.map_comp, h₁.down, h₂.down]⟩,
--   assoc := λ _ _ _ _ _ _ _ _ _ _ _ h₁ h₂ h₃,
--     begin refine heq_of_cast_eq _ _;
--       simp [h₁.down, h₂.down, h₃.down] end,
--   id_comp := λ _ _ _ _ _ h,
--     begin refine heq_of_cast_eq _ _; simp [h.down] end,
--   comp_id := λ _ _ _ _ _ h,
--     begin refine heq_of_cast_eq _ _; simp [h.down] end }

example : struc (λ R : Ring, Module R) :=
{ hom := λ R S f M₁ M₂, M₁ →ₛₗ[f] M₂,
  id := λ R M, linear_map.id,
  comp := λ R S T M₁ M₂ M₃ f g f' g' _ h,
    @linear_map.comp _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ⟨h⟩ g' f',
  id_comp := λ R S f M₁ M₂ f', begin
      cases f', cases f, refl
    end,
  comp_id := λ R S f M₁ M₂ f', begin
      cases f', cases f, refl,
    end,
  assoc := λ R S T U f g h M₁ M₂ M₃ M₄ f' g' h',
    begin
      cases f, cases g, cases h, cases f', cases g', cases h',
      refl
    end }

example (F : 𝒞 ⥤ Type) (G : 𝒞 → Type) [struc G] : struc (λ A : 𝒞, F.obj A → G A) :=
{ hom := λ X Y f x y, Π (a : F.obj X) (b : F.obj Y), struc.hom f (x a) (y (F.map f a)),
  id := λ X x a, cast (by simp) (struc.id (x a)),
  comp := λ X Y Z x y z f g f' g' _ h a, struc.comp (f' a)
    (g' (F.map f a)) _,
  id_comp := λ X Y f x y f', begin
      apply function.hfunext,
      { refl },
      { intros a a' h,
        rw [heq_iff_eq] at h,
        subst a',
        refine cast_eq_iff_heq.1 _,
        simp,
        simp, admit }
    end,
  comp_id := sorry,
  assoc := λ W X Y Z f g h w x y z f' g' h',
    begin
      apply function.hfunext,
    { refl },
    { intros a a' h,
      rw [heq_iff_eq] at h,
      subst a',
      dsimp,
      admit }

    end }

def pi.struc (F : 𝒞 ⥤ Type) (G : (Σ A : 𝒞, F.obj A) → Type) [struc G] :
  struc (λ A : 𝒞, Π a : F.obj A, G ⟨A, a⟩) :=
{ hom := λ X Y f x y, Π (a : F.obj X),
    @struc.hom _ _ G _ ⟨X, a⟩ ⟨Y, F.map f a⟩ ⟨f, ⟨rfl⟩⟩ (x a) (y (F.map f a)),
  id := λ X x a, by convert @struc.id _ _ G _ ⟨X, a⟩ (x a); simp,
  comp := sorry,
  id_comp := sorry,
  comp_id := sorry,
  assoc := sorry }

-- Maybe think about W.

end struc


import data.cpi.species

namespace cpi

/-- A concretion represents the potential for a species to interact with another.
    -/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive concretion (ℍ : Type) (ω : context) : context → ℕ → ℕ → Type
| apply {Γ} {b} (bs : vector (name Γ) b) (y : ℕ)
  : species ℍ ω (context.extend y Γ)
  → concretion Γ b y
| parallel₁ {Γ} {b y} : concretion Γ b y → species ℍ ω Γ → concretion Γ b y
| parallel₂ {Γ} {b y} : species ℍ ω Γ → concretion Γ b y → concretion Γ b y
| restriction {Γ} {b y} (M : affinity ℍ)
  : concretion (context.extend M.arity Γ) b y
  → concretion Γ b y

notation `#(` b ` ; ` y `)` A := concretion.apply b y A

reserve infixr ` |₁ ` :50
reserve infixr ` |₂ ` :50

infixr ` |₁ ` := concretion.parallel₁
infixr ` |₂ ` := concretion.parallel₂

notation `ν'(` M `) ` A := concretion.restriction M A

variables {ℍ : Type} {ω : context}

namespace concretion

/-- Convert a concretion to a string. Can use `repr` normally. -/
protected def to_string [has_repr ℍ]: ∀ {Γ} {b y} , concretion ℍ ω Γ b y → string
| ._ ._ ._ (concretion.apply bs y A') := "(" ++ repr bs.val ++ ";" ++ repr y ++ ")" ++ repr A'
| ._ ._ ._ (F |₁ A') := "(" ++ to_string F ++ " | " ++ repr A' ++ ")"
| ._ ._ ._ (A' |₂ F) := "(" ++ repr A' ++ " | " ++ to_string F ++ ")"
| ._ ._ ._ (ν'(M) A') := "(ν ?)(" ++ to_string A' ++ ")"

instance [has_repr ℍ] {b y} {Γ} : has_repr (concretion ℍ ω b y Γ) := ⟨ concretion.to_string ⟩

section free
  /-- Determine whether a level occurs within a concretion. -/
  def free_in : ∀ {Γ} {b y} (l : level Γ) (F : concretion ℍ ω Γ b y), Prop
  | Γ b y l (#(bs; _) A) := (∃ b ∈ bs.val, l ∈ b) ∨ level.extend l ∈ A
  | Γ b y l (F |₁ A) := free_in l F ∨ l ∈ A
  | Γ b y l (A |₂ F) := l ∈ A ∨ free_in l F
  | Γ b y l (ν'(M) F) := free_in (level.extend l) F

  instance {Γ} {b y} : has_mem (level Γ) (concretion ℍ ω Γ b y) := ⟨ free_in ⟩

  private def free_in_decide : ∀ {Γ} {b y} (l : level Γ) (F : concretion ℍ ω Γ b y), decidable (free_in l F)
  | Γ b y l (#(bs; _) A) := by { unfold free_in, apply_instance }
  | Γ b y l (F |₁ A) := @or.decidable _ _ (free_in_decide l F) _
  | Γ b y l (A |₂ F) := @or.decidable _ _ _ (free_in_decide l F)
  | Γ b y l (ν'(M) F) := free_in_decide (level.extend l) F

  instance free_in.decidable {Γ} {b y} {l} {F : concretion ℍ ω Γ b y} : decidable (l ∈ F)
    := free_in_decide l F
end free

section rename
  /-- Rename a concretion. -/
  def rename : ∀ {Γ Δ} {b y} (ρ : name Γ → name Δ), concretion ℍ ω Γ b y → concretion ℍ ω Δ b y
  | Γ Δ b y ρ (#(bs; _) A) := #( vector.map ρ bs; y) species.rename (name.ext ρ) A
  | Γ Δ b y ρ (F |₁ A) := rename ρ F |₁ species.rename ρ A
  | Γ Δ b y ρ (A |₂ F) := species.rename ρ A |₂ rename ρ F
  | Γ Δ b y ρ (ν'(M) A) := ν'(M) (rename (name.ext ρ) A)

  lemma rename_id
    : ∀ {Γ} {b y} (F : concretion ℍ ω Γ b y)
    , rename id F = F
  | Γ b ._ (#(⟨ list, n ⟩; y) A) := begin
      simp only [rename, vector.map, list.map_id, subtype.mk_eq_mk],
      rw name.ext_id,
      from ⟨ rfl, species.rename_id A ⟩
    end
  | Γ b y (F |₁ A) := begin
      simp only [rename],
      from ⟨ rename_id F, species.rename_id A ⟩
    end
  | Γ b y (A |₂ F) := begin
      simp only [rename],
      from ⟨ species.rename_id A, rename_id F ⟩
    end
  | Γ b y (ν'(M) F) := begin
      simp only [rename], rw name.ext_id,
      from ⟨ rfl, heq_of_eq (rename_id F) ⟩,
    end

  lemma rename_compose :
    ∀ {Γ Δ η} {b y} (ρ : name Γ → name Δ) (σ : name Δ → name η) (A : concretion ℍ ω Γ b y)
    , rename σ (rename ρ A) = rename (σ ∘ ρ) A
  | Γ Δ η b ._ ρ σ (#(⟨ elem, n ⟩; y) A) := begin
      unfold rename vector.map,
      rw [species.rename_compose _ _ A, name.ext_comp],
      simp
    end
  | Γ Δ η b y ρ σ (F |₁ A) := begin
      unfold rename,
      rw [rename_compose ρ σ F, species.rename_compose ρ σ A]
    end
  | Γ Δ η b y ρ σ (A |₂ F) := begin
      unfold rename,
      rw [rename_compose ρ σ F, species.rename_compose ρ σ A]
    end
  | Γ Δ η b y ρ σ (ν'(M) A) := begin
      unfold rename,
      rw [rename_compose (name.ext ρ) (name.ext σ) A, name.ext_comp]
    end

end rename

end concretion

/-- A quotient of all equivalent concretions. -/
@[nolint has_inhabited_instance]
def concretion' (ℍ : Type) (ω Γ : context) (b y : ℕ) [r : setoid (concretion ℍ ω Γ b y)]
  := quotient r

end cpi

#lint-


/- Observable events, execution traces, and semantics of external calls. -/

import .globalenvs .memory

namespace events
open integers word floats ast globalenvs values memory
     ast.typ memory.perm_kind

/- * Events and traces -/

/- The observable behaviour of programs is stated in terms of
  input/output events, which represent the actions of the program
  that the external world can observe.  CompCert leaves much flexibility as to
  the exact content of events: the only requirement is that they
  do not expose memory states nor pointer values
  (other than pointers to global variables), because these
  are not preserved literally during compilation.  For concreteness,
  we use the following type for events.  Each event represents either:

- A system call (e.g. an input/output operation), recording the
  name of the system call, its parameters, and its result.

- A volatile load from a global memory location, recording the chunk
  and address being read and the value just read.

- A volatile store to a global memory location, recording the chunk
  and address being written and the value stored there.

- An annotation, recording the text of the annotation and the values
  of the arguments.

  The values attached to these events are of the following form.
  As mentioned above, we do not expose pointer values directly.
  Pointers relative to a global variable are shown with the name
  of the variable instead of the block identifier.
-/

inductive eventval : Type
| EVint        : int32 → eventval
| EVlong       : int64 → eventval
| EVfloat      : float → eventval
| EVsingle     : float32 → eventval
| EVptr_global : ident → ptrofs → eventval
open eventval

inductive event : Type
| syscall : string → list eventval → eventval → event
| vload   : memory_chunk → ident → ptrofs → eventval → event
| vstore  : memory_chunk → ident → ptrofs → eventval → event
| annot   : string → list eventval → event

/- * Relating values and event values -/

namespace eventval

def type : eventval → typ
| (EVint _)          := Tint
| (EVlong _)         := Tlong
| (EVfloat _)        := Tfloat
| (EVsingle _)       := Tsingle
| (EVptr_global _ _) := Tptr

/- Symbol environment used to translate between global variable names and their block identifiers. -/

section
variable (ge : Senv)

/- Translation between values and event values. -/

def to_val : eventval → option val
| (EVint i)             := some (Vint i)
| (EVlong i)            := some (Vlong i)
| (EVfloat f)           := some (Vfloat f)
| (EVsingle f)          := some (Vsingle f)
| (EVptr_global id ofs) :=
  do guard (Senv.public_symbol ge id),
     b ← Senv.find_symbol ge id,
     return (Vptr b ofs)

def matchv (ev : eventval) (t : typ) (v : val) : Prop :=
ev.type = t ∧ ev.to_val ge = some v

def list_match (evl : list eventval) (tl : list typ) (vl : list val) : Prop :=
evl.map type = tl ∧ mmap (to_val ge) evl = some vl

/- Some properties of these translation predicates. -/

lemma match_type {ev ty v} : matchv ge ev ty v → val.has_type v ty := sorry'

lemma match_lessdef {ev ty v1 v2} :
  matchv ge ev ty v1 → val.lessdef v1 v2 → matchv ge ev ty v2 := sorry'

lemma list_match_lessdef {evl tyl vl1} :
  list_match ge evl tyl vl1 →
  ∀ vl2, list.forall2 val.lessdef vl1 vl2 → list_match ge evl tyl vl2 := sorry'

/- Determinism -/

lemma match_determ_1 {ev ty v1 v2} :
  matchv ge ev ty v1 → matchv ge ev ty v2 → v1 = v2 := sorry'

lemma match_determ_2 {ev1 ev2 ty v} :
  matchv ge ev1 ty v → matchv ge ev2 ty v → ev1 = ev2 := sorry'

lemma list_match_determ_2 {evl1 tyl vl} :
  list_match ge evl1 tyl vl →
  ∀ evl2, list_match ge evl2 tyl vl → evl1 = evl2 := sorry'

/- Validity -/

def valid : eventval → bool
| (EVptr_global id ofs) := Senv.public_symbol ge id
| _                     := tt

lemma match_receptive {ev1 ty v1 ev2} :
  matchv ge ev1 ty v1 →
  valid ge ev1 → valid ge ev2 → type ev1 = type ev2 →
  ∃ v2, matchv ge ev2 ty v2 := sorry'

lemma match_valid {ev ty v} :
  matchv ge ev ty v → valid ge ev := sorry'

lemma match_same_type {ev1 ty v1 ev2 v2} :
  matchv ge ev1 ty v1 → matchv ge ev2 ty v2 → type ev1 = type ev2 := sorry'

end
end eventval

/- Invariance under changes to the global environment -/

section eventval_inv

parameters {ge1 ge2 : Senv}
parameter (public_preserved : ∀ id,
  Senv.public_symbol ge2 id = Senv.public_symbol ge1 id)

lemma eventval_valid_preserved {ev} :
  eventval.valid ge1 ev → eventval.valid ge2 ev := sorry'

parameter (symbols_preserved : ∀ id,
  Senv.find_symbol ge2 id = Senv.find_symbol ge1 id)

lemma eventval_match_preserved {ev ty v} :
  eventval.matchv ge1 ev ty v → eventval.matchv ge2 ev ty v := sorry'

lemma eventval_list_match_preserved :
  ∀ evl tyl vl,
  eventval.list_match ge1 evl tyl vl → eventval.list_match ge2 evl tyl vl := sorry'

end eventval_inv

/- Compatibility with memory injections -/

section eventval_inject

parameter (f : block → option (block × ℤ))
parameters (ge1 ge2 : Senv)

def symbols_inject : Prop :=
   (∀ id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id)
∧ (∀ id b1 b2 delta,
     f b1 = some (b2, delta) → Senv.find_symbol ge1 id = some b1 →
     delta = 0 ∧ Senv.find_symbol ge2 id = some b2)
∧ (∀ id b1,
     Senv.public_symbol ge1 id = tt → Senv.find_symbol ge1 id = some b1 →
     ∃ b2, f b1 = some (b2, 0) ∧ Senv.find_symbol ge2 id = some b2)
∧ (∀ b1 b2 delta,
     f b1 = some (b2, delta) →
     Senv.block_is_volatile ge2 b2 = Senv.block_is_volatile ge1 b1)

parameter symb_inj : symbols_inject

lemma eventval_match_inject {ev ty v1 v2} :
  eventval.matchv ge1 ev ty v1 → val.inject f v1 v2 → eventval.matchv ge2 ev ty v2 := sorry'

lemma eventval_match_inject_2 :
  ∀ ev ty v1,
  eventval.matchv ge1 ev ty v1 →
  ∃ v2, eventval.matchv ge2 ev ty v2 ∧ val.inject f v1 v2 := sorry'

lemma eventval_list_match_inject {evl tyl vl1} :
  eventval.list_match ge1 evl tyl vl1 →
  ∀ vl2, list.forall2 (val.inject f) vl1 vl2 → eventval.list_match ge2 evl tyl vl2 := sorry'

end eventval_inject

/- * Matching traces. -/

section match_traces

parameter ge : Senv

/- Matching between traces corresponding to single transitions.
  Arguments (provided by the program) must be equal.
  Results (provided by the outside world) can vary as long as they
  can be converted safely to values. -/

def match_events : event → event → Prop
| (event.syscall id args res1)    (event.syscall id' args' res2)      :=
  id = id' ∧ args = args' ∧ res1.valid ge ∧ res2.valid ge ∧ res1.type = res2.type
| (event.vload chunk id ofs res1) (event.vload chunk' id' ofs' res2)  :=
  chunk = chunk' ∧ id = id' ∧ ofs = ofs' ∧ res1.valid ge ∧ res2.valid ge ∧ res1.type = res2.type
| (event.vstore chunk id ofs arg) (event.vstore chunk' id' ofs' arg') :=
  chunk = chunk' ∧ id = id' ∧ ofs = ofs' ∧ arg = arg'
| (event.annot id args)           (event.annot id' args')             :=
  id = id' ∧ args = args'
| _                               _                                   := false

inductive match_traces : list event → list event → Prop
| nil : match_traces [] []
| evt (e1 e2) : match_events e1 e2 → match_traces [e1] [e2]

end match_traces

/- Invariance by change of global environment -/

lemma match_traces_preserved {ge1 ge2}
  (public_preserved : ∀ id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id)
  {t1 t2} : match_traces ge1 t1 t2 → match_traces ge2 t1 t2 := sorry'

/- An output trace is a trace composed only of output events,
  that is, events that do not take any result from the outside world. -/

def output_event : event → bool
| (event.vstore _ _ _ _) := tt
| (event.annot _ _)      := tt
| _                      := ff

def output_trace (t : list event) : bool := t.all output_event

/- * Semantics of external functions -/

/- For each external function, its behavior is defined by a predicate relating:
- the global symbol environment
- the values of the arguments passed to this function
- the memory state before the call
- the result value of the call
- the memory state after the call
- the trace generated by the call (can be empty).
-/

def extcall_sem : Type := Senv → list val → mem → list event → val → mem → Prop

/- We now specify the expected properties of this predicate. -/

def loc_out_of_bounds (m : mem) (b : block) (ofs : ℕ) : Prop :=
  ¬ perm m b ofs Max Nonempty

def loc_not_writable (m : mem) (b : block) (ofs : ℕ) : Prop :=
  ¬ perm m b ofs Max Writable

def loc_unmapped (f : meminj) (b : block) (ofs : ℕ) : Prop :=
  f b = none

def loc_out_of_reach (f : meminj) (m : mem) (b : block) (ofs : ℕ) : Prop :=
  ∀ b0 delta,
  f b0 = some (b, delta) → ¬ perm_Z m b0 (ofs - delta) Max Nonempty

def inject_separated (f f' : meminj) (m1 m2 : mem) : Prop :=
  ∀ b1 b2 delta,
  f b1 = none → f' b1 = some (b2, delta) →
  ¬ valid_block m1 b1 ∧ ¬ valid_block m2 b2

structure extcall_properties (sem : extcall_sem) (sg : signature) : Prop :=
/- The return value of an external call must agree with its signature. -/
(well_typed :
  ∀ ge vargs m1 t vres m2,
  sem ge vargs m1 t vres m2 →
  vres.has_type (proj_sig_res sg))

/- The semantics is invariant under change of global environment that preserves symbols. -/
(symbols_preserved :
  ∀ ge1 ge2 vargs m1 t vres m2,
  Senv.equiv ge1 ge2 →
  sem ge1 vargs m1 t vres m2 →
  sem ge2 vargs m1 t vres m2)

/- External calls cannot invalidate memory blocks.  (Remember that
  freeing a block does not invalidate its block identifier.) -/
(valid_block :
  ∀ ge vargs m1 t vres m2 b,
  sem ge vargs m1 t vres m2 →
  valid_block m1 b → valid_block m2 b)

/- External calls cannot increase the max permissions of a valid block.
    They can decrease the max permissions, e.g. by freeing. -/
(max_perm :
  ∀ ge vargs m1 t vres m2 b ofs p,
  sem ge vargs m1 t vres m2 →
  memory.valid_block m1 b → perm m2 b ofs Max p → perm m1 b ofs Max p)

/- External call cannot modify memory unless they have [Max, Writable]
   permissions. -/
(readonly :
  ∀ ge vargs m1 t vres m2,
  sem ge vargs m1 t vres m2 →
  unchanged_on (loc_not_writable m1) m1 m2)

/- External calls must commute with memory extensions, in the
  following sense. -/
(mem_extends :
  ∀ ge vargs m1 t vres m2 m1' vargs',
  sem ge vargs m1 t vres m2 →
  extends' m1 m1' →
  list.forall2 lessdef vargs vargs' →
  ∃ vres', ∃ m2',
      sem ge vargs' m1' t vres' m2'
  ∧ lessdef vres vres'
  ∧ extends' m2 m2'
  ∧ unchanged_on (loc_out_of_bounds m1) m1' m2')

/- External calls must commute with memory injections,
  in the following sense. -/
(mem_inject :
  ∀ ge1 ge2 vargs m1 t vres m2 f m1' vargs',
  symbols_inject f ge1 ge2 →
  sem ge1 vargs m1 t vres m2 →
  inject f m1 m1' →
  list.forall2 (val.inject f) vargs vargs' →
  ∃ f', ∃ vres', ∃ m2',
      sem ge2 vargs' m1' t vres' m2'
  ∧ inject f' vres vres'
  ∧ inject f' m2 m2'
  ∧ unchanged_on (loc_unmapped f) m1 m2
  ∧ unchanged_on (loc_out_of_reach f m1) m1' m2'
  ∧ inject_incr f f'
  ∧ inject_separated f f' m1 m1')

/- External calls produce at most one event. -/
(trace_length :
  ∀ ge vargs m t vres m',
  sem ge vargs m t vres m' → t.length ≤ 1)

/- External calls must be receptive to changes of traces by another, matching trace. -/
(receptive :
  ∀ ge vargs m t1 vres1 m1 t2,
  sem ge vargs m t1 vres1 m1 → match_traces ge t1 t2 →
  ∃ vres2 m2, sem ge vargs m t2 vres2 m2)

/- External calls must be deterministic up to matching between traces. -/
(determ :
  ∀ ge vargs m t1 vres1 m1 t2 vres2 m2,
  sem ge vargs m t1 vres1 m1 → sem ge vargs m t2 vres2 m2 →
  match_traces ge t1 t2 ∧ (t1 = t2 → vres1 = vres2 ∧ m1 = m2))

/- * Semantics of volatile memory accesses -/

inductive volatile_load (ge) (chunk : memory_chunk) (m b ofs) :
    list event → val → Prop
| volatile_load_vol (id ev v) :
    Senv.block_is_volatile ge b = tt →
    Senv.find_symbol ge id = some b →
    eventval.matchv ge ev chunk.type v →
    volatile_load [event.vload chunk id ofs ev] (load_result chunk v)
| volatile_load_nonvol (v) :
    Senv.block_is_volatile ge b = ff →
    load chunk m b (unsigned ofs) = some v →
    volatile_load [] v

inductive volatile_store (ge) (chunk : memory_chunk) (m b ofs v) :
    list event → mem → Prop
| volatile_store_vol (id ev) :
    Senv.block_is_volatile ge b = tt →
    Senv.find_symbol ge id = some b →
    eventval.matchv ge ev chunk.type (load_result chunk v) →
    volatile_store [event.vstore chunk id ofs ev] m
| volatile_store_nonvol (m') :
    Senv.block_is_volatile ge b = ff →
    store chunk m b (unsigned ofs) v = some m' →
    volatile_store [] m'

/- ** Semantics of volatile loads -/

inductive volatile_load_sem (chunk : memory_chunk) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (b ofs m t v) :
  volatile_load ge chunk m b ofs t v →
  volatile_load_sem [Vptr b ofs] m t v m.

lemma volatile_load_preserved {ge1 ge2 chunk m b ofs t v} :
  Senv.equiv ge1 ge2 →
  volatile_load ge1 chunk m b ofs t v →
  volatile_load ge2 chunk m b ofs t v := sorry'

lemma volatile_load_extends {ge chunk m b ofs t v m'} :
  volatile_load ge chunk m b ofs t v →
  extends' m m' →
  ∃ v', volatile_load ge chunk m' b ofs t v' ∧ lessdef v v' := sorry'

lemma volatile_load_inject {ge1 ge2 f chunk m b ofs t v b' ofs' m'} :
  symbols_inject f ge1 ge2 →
  volatile_load ge1 chunk m b ofs t v →
  inject f (Vptr b ofs) (Vptr b' ofs') →
  inject f m m' →
  ∃ v', volatile_load ge2 chunk m' b' ofs' t v' ∧ inject f v v' := sorry'

lemma volatile_load_receptive {ge chunk m b ofs t1 t2 v1} :
  volatile_load ge chunk m b ofs t1 v1 → match_traces ge t1 t2 →
  ∃ v2, volatile_load ge chunk m b ofs t2 v2 := sorry'

lemma volatile_load_ok {chunk} :
  extcall_properties (volatile_load_sem chunk)
  ⟨[Tptr], some chunk.type, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of volatile stores -/

inductive volatile_store_sem (chunk : memory_chunk) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (b ofs m1 v t m2) :
  volatile_store ge chunk m1 b ofs v t m2 →
  volatile_store_sem [Vptr b ofs, v] m1 t Vundef m2.

lemma volatile_store_preserved {ge1 ge2 chunk m1 b ofs v t m2} :
  Senv.equiv ge1 ge2 →
  volatile_store ge1 chunk m1 b ofs v t m2 →
  volatile_store ge2 chunk m1 b ofs v t m2 := sorry'

lemma volatile_store_readonly {ge chunk1 m1 b1 ofs1 v t m2} :
  volatile_store ge chunk1 m1 b1 ofs1 v t m2 →
  unchanged_on (loc_not_writable m1) m1 m2 := sorry'

lemma volatile_store_extends {ge chunk m1 b ofs v t m2 m1' v'} :
  volatile_store ge chunk m1 b ofs v t m2 →
  extends' m1 m1' →
  lessdef v v' →
  ∃ m2',
     volatile_store ge chunk m1' b ofs v' t m2'
  ∧ extends' m2 m2'
  ∧ unchanged_on (loc_out_of_bounds m1) m1' m2' := sorry'

lemma volatile_store_inject {ge1 ge2 f chunk m1 b ofs v t m2 m1' b' ofs' v'} :
  symbols_inject f ge1 ge2 →
  volatile_store ge1 chunk m1 b ofs v t m2 →
  inject f (Vptr b ofs) (Vptr b' ofs') →
  inject f v v' →
  inject f m1 m1' →
  ∃ m2',
       volatile_store ge2 chunk m1' b' ofs' v' t m2'
    ∧ inject f m2 m2'
    ∧ unchanged_on (loc_unmapped f) m1 m2
    ∧ unchanged_on (loc_out_of_reach f m1) m1' m2' := sorry'

lemma volatile_store_receptive {ge chunk m b ofs v t1 m1 t2} :
  volatile_store ge chunk m b ofs v t1 m1 → match_traces ge t1 t2 → t1 = t2 := sorry'

lemma volatile_store_ok {chunk} :
  extcall_properties (volatile_store_sem chunk) ⟨[Tptr, chunk.type], none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of dynamic memory allocation (malloc) -/

inductive extcall_malloc_sem (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (sz : ptrofs) (m m' : mem) :
  store Mptr (m.alloc 0 (unsigned sz + Mptr.size)) m.nextblock 0 (Vptrofs sz) = some m' →
  extcall_malloc_sem [Vptrofs sz] m [] (Vptr m.nextblock Mptr.size) m'

lemma extcall_malloc_ok :
  extcall_properties extcall_malloc_sem ⟨[Tptr], some Tptr, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of dynamic memory deallocation (free) -/

inductive extcall_free_sem (ge : Senv) :
              list val → mem → list event → val → mem → Prop
| mk (b) (lo : ptrofs) (sz m m') :
  load Mptr m b (unsigned lo - Mptr.size) = some (Vptrofs sz) →
  unsigned sz > 0 →
  free m b (unsigned lo - Mptr.size) (unsigned lo + unsigned sz) = some m' →
  extcall_free_sem [Vptr b lo] m [] Vundef m'

lemma extcall_free_ok :
  extcall_properties extcall_free_sem ⟨[Tptr], none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of [memcpy] operations. -/

inductive extcall_memcpy_sem (sz al : ℕ) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (bdst bsrc) (odst osrc : ptrofs) (m bytes m') :
  al = 1 ∨ al = 2 ∨ al = 4 ∨ al = 8 → al ∣ sz →
  (sz > 0 → al ∣ unsigned osrc ∧ al ∣ unsigned odst) →
  bsrc ≠ bdst ∨ unsigned osrc = unsigned odst
                ∨ unsigned osrc + sz ≤ unsigned odst
                ∨ unsigned odst + sz ≤ unsigned osrc →
  load_bytes m bsrc (unsigned osrc) sz = some bytes →
  store_bytes m bdst (unsigned odst) bytes = some m' →
  extcall_memcpy_sem [Vptr bdst odst, Vptr bsrc osrc] m [] Vundef m'

lemma extcall_memcpy_ok (sz al) :
  extcall_properties (extcall_memcpy_sem sz al) ⟨[Tptr, Tptr], none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of annotations. -/

inductive extcall_annot_sem (text : string) (targs : list typ) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (vargs m args) : eventval.list_match ge args targs vargs →
  extcall_annot_sem vargs m [event.annot text args] Vundef m

lemma extcall_annot_ok (text targs) :
  extcall_properties (extcall_annot_sem text targs) ⟨targs, none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

inductive extcall_annot_val_sem (text : string) (targ : typ) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (varg m arg) :
  eventval.matchv ge arg targ varg →
  extcall_annot_val_sem [varg] m [event.annot text [arg]] varg m

lemma extcall_annot_val_ok (text targ) :
  extcall_properties (extcall_annot_val_sem text targ) ⟨[targ], some targ, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

inductive extcall_debug_sem (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (vargs m) : extcall_debug_sem vargs m [] Vundef m

lemma extcall_debug_ok (targs) :
  extcall_properties extcall_debug_sem ⟨targs, none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of external functions. -/

/- For functions defined outside the program ([EF_external],
  [EF_builtin] and [EF_runtime]), we do not define their
  semantics, but only assume that it satisfies
  [extcall_properties]. -/

constant external_functions_sem : string → signature → extcall_sem

constant external_functions_properties {id sg} :
  extcall_properties (external_functions_sem id sg) sg

/- We treat inline assembly similarly. -/

constant inline_assembly_sem : string → signature → extcall_sem

constant inline_assembly_properties {id sg} :
  extcall_properties (inline_assembly_sem id sg) sg

/- ** Combined semantics of external calls -/

/- Combining the semantics given above for the various kinds of external calls,
  we define the predicate [external_call] that relates:
- the external function being invoked
- the values of the arguments passed to this function
- the memory state before the call
- the result value of the call
- the memory state after the call
- the trace generated by the call (can be empty).

This predicate is used in the semantics of all CompCert languages. -/

noncomputable def external_call : external_function → extcall_sem
| (EF_external name sg)      := external_functions_sem name sg
| (EF_builtin name sg)       := external_functions_sem name sg
| (EF_runtime name sg)       := external_functions_sem name sg
| (EF_vload chunk)           := volatile_load_sem chunk
| (EF_vstore chunk)          := volatile_store_sem chunk
| EF_malloc                  := extcall_malloc_sem
| EF_free                    := extcall_free_sem
| (EF_memcpy sz al)          := extcall_memcpy_sem sz al
| (EF_annot txt targs)       := extcall_annot_sem txt targs
| (EF_annot_val txt targ)    := extcall_annot_val_sem txt targ
| (EF_inline_asm txt sg clb) := inline_assembly_sem txt sg
| (EF_debug kind txt targs)  := extcall_debug_sem

theorem external_call_spec (ef) :
  extcall_properties (external_call ef) (ef_sig ef) := sorry'

def external_call_well_typed        (ef) := (external_call_spec ef).well_typed
def external_call_symbols_preserved (ef) := (external_call_spec ef).symbols_preserved
def external_call_valid_block       (ef) := (external_call_spec ef).valid_block
def external_call_max_perm          (ef) := (external_call_spec ef).max_perm
def external_call_readonly          (ef) := (external_call_spec ef).readonly
def external_call_mem_extends       (ef) := (external_call_spec ef).mem_extends
def external_call_mem_inject_gen    (ef) := (external_call_spec ef).mem_inject
def external_call_trace_length      (ef) := (external_call_spec ef).trace_length
def external_call_receptive         (ef) := (external_call_spec ef).receptive
def external_call_determ            (ef) := (external_call_spec ef).determ

/- Corollary of [external_call_valid_block]. -/

lemma external_call_nextblock (ef ge vargs m1 t vres m2) :
  external_call ef ge vargs m1 t vres m2 →
  m1.nextblock ≤ m2.nextblock := sorry'

/- Special case of [external_call_mem_inject_gen] (for backward compatibility) -/

def meminj_preserves_globals {F V} (ge : Genv F V) (f : block → option (block × ℤ)) : Prop :=
     (∀ id b, Genv.find_symbol ge id = some b → f b = some (b, 0))
  ∧ (∀ b gv, Genv.find_var_info ge b = some gv → f b = some (b, 0))
  ∧ (∀ b1 b2 delta gv, Genv.find_var_info ge b2 = some gv → f b1 = some (b2, delta) → b2 = b1)

lemma external_call_mem_inject {ef F V} {ge : Genv F V} {vargs m1 t vres m2 f m1' vargs'} :
  meminj_preserves_globals ge f →
  external_call ef ge vargs m1 t vres m2 →
  inject f m1 m1' →
  list.forall2 (val.inject f) vargs vargs' →
  ∃ f' vres' m2',
     external_call ef ge vargs' m1' t vres' m2'
    ∧ inject f' vres vres'
    ∧ inject f' m2 m2'
    ∧ unchanged_on (loc_unmapped f) m1 m2
    ∧ unchanged_on (loc_out_of_reach f m1) m1' m2'
    ∧ inject_incr f f'
    ∧ inject_separated f f' m1 m1' := sorry'

/- Corollaries of [external_call_determ]. -/

lemma external_call_match_traces {ef ge vargs m t1 vres1 m1 t2 vres2 m2} :
  external_call ef ge vargs m t1 vres1 m1 →
  external_call ef ge vargs m t2 vres2 m2 →
  match_traces ge t1 t2 := sorry'

lemma external_call_deterministic {ef ge vargs m t vres1 m1 vres2 m2} :
  external_call ef ge vargs m t vres1 m1 →
  external_call ef ge vargs m t vres2 m2 →
  vres1 = vres2 ∧ m1 = m2 := sorry'

/- * Evaluation of builtin arguments -/

section eval_builtin_arg

parameters {A : Type} (ge : Senv) (e : A → val) (sp : val) (m : mem)

def eval_builtin_arg : builtin_arg A → option val
| (BA x) := some (e x)
| (BA_int n) := some (Vint n)
| (BA_long n) := some (Vlong n)
| (BA_float n) := some (Vfloat n)
| (BA_single n) := some (Vsingle n)
| (BA_loadstack chunk ofs) := loadv chunk m (offset_ptr sp ofs)
| (BA_addrstack ofs) := some (offset_ptr sp ofs)
| (BA_loadglobal chunk id ofs) := loadv chunk m (Senv.symbol_address ge id ofs)
| (BA_addrglobal id ofs) := some (Senv.symbol_address ge id ofs)
| (BA_splitlong hi lo) :=
  do vhi ← eval_builtin_arg hi,
     vlo ← eval_builtin_arg lo,
     return (long_of_words vhi vlo)

def eval_builtin_args (al : list (builtin_arg A)) : option (list val) :=
mmap eval_builtin_arg al

end eval_builtin_arg

/- Invariance by change of global environment. -/

section eval_builtin_arg_preserved

parameters {A F1 V1 F2 V2 : Type} {ge1 : Genv F1 V1} {ge2 : Genv F2 V2}
           (e : A → val) (sp : val) (m : mem)

parameter (symbols_preserved : ∀ id, Genv.find_symbol ge2 id = Genv.find_symbol ge1 id)

lemma eval_builtin_arg_preserved {a v} :
  eval_builtin_arg ge1 e sp m a = some v → eval_builtin_arg ge2 e sp m a = some v := sorry'

lemma eval_builtin_args_preserved {al vl} :
  eval_builtin_args ge1 e sp m al = some vl → eval_builtin_args ge2 e sp m al = some vl := sorry'

end eval_builtin_arg_preserved

/- Compatibility with the "is less defined than" relation. -/

section eval_builtin_arg_lessdef

parameters {A : Type} (ge : Senv) {e1 e2 : A → val} (sp : val) {m1 m2 : mem}

parameter env_lessdef : ∀ x, val.lessdef (e1 x) (e2 x)
parameter mem_extends : extends' m1 m2

lemma eval_builtin_arg_lessdef {a v1} :
  eval_builtin_arg ge e1 sp m1 a = some v1 →
  ∃ v2, eval_builtin_arg ge e2 sp m2 a = some v2 ∧ lessdef v1 v2 := sorry'

lemma eval_builtin_args_lessdef {al vl1} :
  eval_builtin_args ge e1 sp m1 al = some vl1 →
  ∃ vl2, eval_builtin_args ge e2 sp m2 al = some vl2 ∧ list.forall2 lessdef vl1 vl2 := sorry'

end eval_builtin_arg_lessdef

end events