/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Properties of the binary representation of integers.
-/
import data.num.basic data.num.bitwise algebra.ordered_ring
       tactic.interactive data.int.basic data.nat.gcd

namespace pos_num
  variables {α : Type*}

  @[simp] theorem cast_one [has_zero α] [has_one α] [has_add α] : ((1 : pos_num) : α) = 1 := rfl
  @[simp] theorem cast_one' [has_zero α] [has_one α] [has_add α] : (pos_num.one : α) = 1 := rfl
  @[simp] theorem cast_bit0 [has_zero α] [has_one α] [has_add α] (n : pos_num) : (n.bit0 : α) = _root_.bit0 n := rfl
  @[simp] theorem cast_bit1 [has_zero α] [has_one α] [has_add α] (n : pos_num) : (n.bit1 : α) = _root_.bit1 n := rfl

  @[simp] theorem cast_to_nat [add_monoid α] [has_one α] : ∀ n : pos_num, ((n : ℕ) : α) = n
  | 1        := nat.cast_one
  | (bit0 p) := (nat.cast_bit0 _).trans $ congr_arg _root_.bit0 p.cast_to_nat
  | (bit1 p) := (nat.cast_bit1 _).trans $ congr_arg _root_.bit1 p.cast_to_nat

  @[simp] theorem to_nat_to_int (n : pos_num) : ((n : ℕ) : ℤ) = n :=
  by rw [← int.nat_cast_eq_coe_nat, cast_to_nat]

  @[simp] theorem cast_to_int [add_group α] [has_one α] (n : pos_num) : ((n : ℤ) : α) = n :=
  by rw [← to_nat_to_int, int.cast_coe_nat, cast_to_nat]

  theorem succ_to_nat : ∀ n, (succ n : ℕ) = n + 1
  | 1        := rfl
  | (bit0 p) := rfl
  | (bit1 p) := (congr_arg _root_.bit0 (succ_to_nat p)).trans $
    show ↑p + 1 + ↑p + 1 = ↑p + ↑p + 1 + 1, by simp

  theorem one_add (n : pos_num) : 1 + n = succ n := by cases n; refl
  theorem add_one (n : pos_num) : n + 1 = succ n := by cases n; refl

  @[simp] theorem add_to_nat : ∀ m n, ((m + n : pos_num) : ℕ) = m + n
  | 1        b        := by rw [one_add b, succ_to_nat, add_comm]; refl
  | a        1        := by rw [add_one a, succ_to_nat]; refl
  | (bit0 a) (bit0 b) := (congr_arg _root_.bit0 (add_to_nat a b)).trans $
    show ((a + b) + (a + b) : ℕ) = (a + a) + (b + b), by simp
  | (bit0 a) (bit1 b) := (congr_arg _root_.bit1 (add_to_nat a b)).trans $
    show ((a + b) + (a + b) + 1 : ℕ) = (a + a) + (b + b + 1), by simp
  | (bit1 a) (bit0 b) := (congr_arg _root_.bit1 (add_to_nat a b)).trans $
    show ((a + b) + (a + b) + 1 : ℕ) = (a + a + 1) + (b + b), by simp
  | (bit1 a) (bit1 b) :=
    show (succ (a + b) + succ (a + b) : ℕ) = (a + a + 1) + (b + b + 1),
    by rw [succ_to_nat, add_to_nat]; simp

  theorem add_succ : ∀ (m n : pos_num), m + succ n = succ (m + n)
  | 1        b        := by simp [one_add]
  | (bit0 a) 1        := congr_arg bit0 (add_one a)
  | (bit1 a) 1        := congr_arg bit1 (add_one a)
  | (bit0 a) (bit0 b) := rfl
  | (bit0 a) (bit1 b) := congr_arg bit0 (add_succ a b)
  | (bit1 a) (bit0 b) := rfl
  | (bit1 a) (bit1 b) := congr_arg bit1 (add_succ a b)

  theorem bit0_of_bit0 : Π n, _root_.bit0 n = bit0 n
  | 1        := rfl
  | (bit0 p) := congr_arg bit0 (bit0_of_bit0 p)
  | (bit1 p) := show bit0 (succ (_root_.bit0 p)) = _, by rw bit0_of_bit0; refl

  theorem bit1_of_bit1 (n : pos_num) : _root_.bit1 n = bit1 n :=
  show _root_.bit0 n + 1 = bit1 n, by rw [add_one, bit0_of_bit0]; refl

  @[simp] theorem mul_to_nat (m) : ∀ n, ((m * n : pos_num) : ℕ) = m * n
  | 1        := (mul_one _).symm
  | (bit0 p) := show (↑(m * p) + ↑(m * p) : ℕ) = ↑m * (p + p), by rw [mul_to_nat, left_distrib]
  | (bit1 p) := (add_to_nat (bit0 (m * p)) m).trans $
    show (↑(m * p) + ↑(m * p) + ↑m : ℕ) = ↑m * (p + p) + m, by rw [mul_to_nat, left_distrib]

  theorem to_nat_pos : ∀ n : pos_num, (n : ℕ) > 0
  | 1        := zero_lt_one
  | (bit0 p) := let h := to_nat_pos p in add_pos h h
  | (bit1 p) := nat.succ_pos _

  theorem cmp_to_nat_lemma {m n : pos_num} : (m:ℕ) < n → (bit1 m : ℕ) < bit0 n :=
  show (m:ℕ) < n → (m + m + 1 + 1 : ℕ) ≤ n + n,
  by intro h; rw [nat.add_right_comm m m 1, add_assoc]; exact add_le_add h h

  theorem cmp_swap (m) : ∀n, (cmp m n).swap = cmp n m :=
  by induction m with m IH m IH; intro n;
     cases n with n n; try {unfold cmp}; try {refl}; rw ←IH; cases cmp m n; refl

  theorem cmp_to_nat : ∀ (m n), (ordering.cases_on (cmp m n) ((m:ℕ) < n) (m = n) ((m:ℕ) > n) : Prop)
  | 1        1        := rfl
  | (bit0 a) 1        := let h : (1:ℕ) ≤ a := to_nat_pos a in add_le_add h h
  | (bit1 a) 1        := nat.succ_lt_succ $ to_nat_pos $ bit0 a
  | 1        (bit0 b) := let h : (1:ℕ) ≤ b := to_nat_pos b in add_le_add h h
  | 1        (bit1 b) := nat.succ_lt_succ $ to_nat_pos $ bit0 b
  | (bit0 a) (bit0 b) := begin
      have := cmp_to_nat a b, revert this, cases cmp a b; dsimp; intro,
      { exact add_lt_add this this },
      { rw this },
      { exact add_lt_add this this }
    end
  | (bit0 a) (bit1 b) := begin dsimp [cmp],
      have := cmp_to_nat a b, revert this, cases cmp a b; dsimp; intro,
      { exact nat.le_succ_of_le (add_lt_add this this) },
      { rw this, apply nat.lt_succ_self },
      { exact cmp_to_nat_lemma this }
    end
  | (bit1 a) (bit0 b) := begin dsimp [cmp],
      have := cmp_to_nat a b, revert this, cases cmp a b; dsimp; intro,
      { exact cmp_to_nat_lemma this },
      { rw this, apply nat.lt_succ_self },
      { exact nat.le_succ_of_le (add_lt_add this this) },
    end
  | (bit1 a) (bit1 b) := begin
      have := cmp_to_nat a b, revert this, cases cmp a b; dsimp; intro,
      { exact nat.succ_lt_succ (add_lt_add this this) },
      { rw this },
      { exact nat.succ_lt_succ (add_lt_add this this) }
    end

  @[simp] theorem lt_to_nat {m n : pos_num} : (m:ℕ) < n ↔ m < n :=
  show (m:ℕ) < n ↔ cmp m n = ordering.lt, from
  match cmp m n, cmp_to_nat m n with
  | ordering.lt, h := by simp at h; simp [h]
  | ordering.eq, h := by simp at h; simp [h, lt_irrefl]; exact dec_trivial
  | ordering.gt, h := by simp [not_lt_of_gt h]; exact dec_trivial
  end

  @[simp] theorem le_to_nat {m n : pos_num} : (m:ℕ) ≤ n ↔ m ≤ n :=
  by rw ← not_lt; exact not_congr lt_to_nat

end pos_num

namespace num
  variables {α : Type*}
  open pos_num

  theorem add_zero (n : num) : n + 0 = n := by cases n; refl
  theorem zero_add (n : num) : 0 + n = n := by cases n; refl

  theorem add_one : ∀ n : num, n + 1 = succ n
  | 0       := rfl
  | (pos p) := by cases p; refl

  theorem add_succ : ∀ (m n : num), m + succ n = succ (m + n)
  | 0       n       := by simp [zero_add]
  | (pos p) 0       := show pos (p + 1) = succ (pos p + 0),
                       by rw [pos_num.add_one, add_zero]; refl
  | (pos p) (pos q) := congr_arg pos (pos_num.add_succ _ _)

  @[simp] theorem add_of_nat (m) : ∀ n, ((m + n : ℕ) : num) = m + n
  | 0     := (add_zero _).symm
  | (n+1) := show ((m + n : ℕ) + 1 : num) = m + (↑ n + 1),
             by rw [add_one, add_one, add_succ, add_of_nat]

  theorem bit0_of_bit0 : ∀ n : num, bit0 n = n.bit0
  | 0       := rfl
  | (pos p) := congr_arg pos p.bit0_of_bit0

  theorem bit1_of_bit1 : ∀ n : num, bit1 n = n.bit1
  | 0       := rfl
  | (pos p) := congr_arg pos p.bit1_of_bit1

  @[simp] theorem cast_zero [has_zero α] [has_one α] [has_add α] :
    ((0 : num) : α) = 0 := rfl

  @[simp] theorem cast_zero' [has_zero α] [has_one α] [has_add α] :
    (num.zero : α) = 0 := rfl

  @[simp] theorem cast_one [has_zero α] [has_one α] [has_add α] :
    ((1 : num) : α) = 1 := rfl

  @[simp] theorem cast_pos [has_zero α] [has_one α] [has_add α]
    (n : pos_num) : (num.pos n : α) = n := rfl

  theorem succ'_to_nat : ∀ n, (succ' n : ℕ) = n + 1
  | 0       := (_root_.zero_add _).symm
  | (pos p) := pos_num.succ_to_nat _

  theorem succ_to_nat (n) : (succ n : ℕ) = n + 1 := succ'_to_nat n

  @[simp] theorem cast_to_nat [add_monoid α] [has_one α] : ∀ n : num, ((n : ℕ) : α) = n
  | 0       := nat.cast_zero
  | (pos p) := p.cast_to_nat

  @[simp] theorem to_nat_to_int (n : num) : ((n : ℕ) : ℤ) = n :=
  by rw [← int.nat_cast_eq_coe_nat, cast_to_nat]

  @[simp] theorem cast_to_int [add_group α] [has_one α] (n : num) : ((n : ℤ) : α) = n :=
  by rw [← to_nat_to_int, int.cast_coe_nat, cast_to_nat]

  @[simp] theorem to_of_nat : Π (n : ℕ), ((n : num) : ℕ) = n
  | 0     := rfl
  | (n+1) := by rw [nat.cast_add_one, add_one, succ_to_nat, to_of_nat]

  @[simp] theorem of_nat_cast [add_monoid α] [has_one α] (n : ℕ) : ((n : num) : α) = n :=
  by rw [← cast_to_nat, to_of_nat]

  theorem of_nat_inj {m n : ℕ} : (m : num) = n ↔ m = n :=
  ⟨λ h, function.injective_of_left_inverse to_of_nat h, congr_arg _⟩

  @[simp] theorem add_to_nat : ∀ m n, ((m + n : num) : ℕ) = m + n
  | 0       0       := rfl
  | 0       (pos q) := (_root_.zero_add _).symm
  | (pos p) 0       := rfl
  | (pos p) (pos q) := pos_num.add_to_nat _ _

  @[simp] theorem mul_to_nat : ∀ m n, ((m * n : num) : ℕ) = m * n
  | 0       0       := rfl
  | 0       (pos q) := (zero_mul _).symm
  | (pos p) 0       := rfl
  | (pos p) (pos q) := pos_num.mul_to_nat _ _

  theorem cmp_to_nat : ∀ (m n), (ordering.cases_on (cmp m n) ((m:ℕ) < n) (m = n) ((m:ℕ) > n) : Prop)
  | 0       0       := rfl
  | 0       (pos b) := to_nat_pos _
  | (pos a) 0       := to_nat_pos _
  | (pos a) (pos b) :=
    by { have := pos_num.cmp_to_nat a b; revert this; dsimp [cmp];
         cases pos_num.cmp a b, exacts [id, congr_arg pos, id] }

  @[simp] theorem lt_to_nat {m n : num} : (m:ℕ) < n ↔ m < n :=
  show (m:ℕ) < n ↔ cmp m n = ordering.lt, from
  match cmp m n, cmp_to_nat m n with
  | ordering.lt, h := by simp at h; simp [h]
  | ordering.eq, h := by simp at h; simp [h, lt_irrefl]; exact dec_trivial
  | ordering.gt, h := by simp [not_lt_of_gt h]; exact dec_trivial
  end

  @[simp] theorem le_to_nat {m n : num} : (m:ℕ) ≤ n ↔ m ≤ n :=
  by rw ← not_lt; exact not_congr lt_to_nat

end num

namespace pos_num
  @[simp] theorem of_to_nat : Π (n : pos_num), ((n : ℕ) : num) = num.pos n
  | 1        := rfl
  | (bit0 p) :=
    show ↑(p + p : ℕ) = num.pos p.bit0,
    by rw [num.add_of_nat, of_to_nat];
      exact congr_arg num.pos p.bit0_of_bit0
  | (bit1 p) :=
    show ((p + p : ℕ) : num) + 1 = num.pos p.bit1,
    by rw [num.add_of_nat, of_to_nat];
      exact congr_arg num.pos p.bit1_of_bit1
end pos_num

namespace num

  @[simp] theorem of_to_nat : Π (n : num), ((n : ℕ) : num) = n
  | 0           := rfl
  | (pos p) := p.of_to_nat

  theorem to_nat_inj {m n : num} : (m : ℕ) = n ↔ m = n :=
  ⟨λ h, function.injective_of_left_inverse of_to_nat h, congr_arg _⟩

  meta def transfer_rw : tactic unit :=
  `[repeat {rw ← to_nat_inj <|> rw ← lt_to_nat <|> rw ← le_to_nat},
    repeat {rw add_to_nat <|> rw mul_to_nat <|> rw cast_one <|> rw cast_zero}]

  meta def transfer : tactic unit := `[intros, transfer_rw, try {simp}]

  instance : comm_semiring num :=
  by refine {
    add      := (+),
    zero     := 0,
    zero_add := zero_add,
    add_zero := add_zero,
    mul      := (*),
    one      := 1, .. }; try {transfer}; simp [mul_add, mul_left_comm, mul_comm]

  instance : ordered_cancel_comm_monoid num :=
  { add_left_cancel            := by {intros a b c, transfer_rw, apply add_left_cancel},
    add_right_cancel           := by {intros a b c, transfer_rw, apply add_right_cancel},
    lt                         := (<),
    lt_iff_le_not_le           := by {intros a b, transfer_rw, apply lt_iff_le_not_le},
    le                         := (≤),
    le_refl                    := by transfer,
    le_trans                   := by {intros a b c, transfer_rw, apply le_trans},
    le_antisymm                := by {intros a b, transfer_rw, apply le_antisymm},
    add_le_add_left            := by {intros a b h c, revert h, transfer_rw, exact λ h, add_le_add_left h c},
    le_of_add_le_add_left      := by {intros a b c, transfer_rw, apply le_of_add_le_add_left},
    ..num.comm_semiring }

  instance : decidable_linear_ordered_semiring num :=
  { le_total                   := by {intros a b, transfer_rw, apply le_total},
    zero_lt_one                := dec_trivial,
    mul_le_mul_of_nonneg_left  := by {intros a b c, transfer_rw, apply mul_le_mul_of_nonneg_left},
    mul_le_mul_of_nonneg_right := by {intros a b c, transfer_rw, apply mul_le_mul_of_nonneg_right},
    mul_lt_mul_of_pos_left     := by {intros a b c, transfer_rw, apply mul_lt_mul_of_pos_left},
    mul_lt_mul_of_pos_right    := by {intros a b c, transfer_rw, apply mul_lt_mul_of_pos_right},
    decidable_lt               := num.decidable_lt,
    decidable_le               := num.decidable_le,
    decidable_eq               := num.decidable_eq,
    ..num.comm_semiring, ..num.ordered_cancel_comm_monoid }

  @[simp] theorem dvd_to_nat (m n : num) : (m : ℕ) ∣ n ↔ m ∣ n :=
  ⟨λ ⟨k, e⟩, ⟨k, by rw [← of_to_nat n, e]; simp⟩,
   λ ⟨k, e⟩, ⟨k, by simp [e]⟩⟩

end num

namespace pos_num
  variables {α : Type*}
  open num

  theorem to_nat_inj {m n : pos_num} : (m : ℕ) = n ↔ m = n :=
  ⟨λ h, num.pos.inj $ by rw [← pos_num.of_to_nat, ← pos_num.of_to_nat, h],
   congr_arg _⟩

  theorem pred'_to_nat : ∀ n, (pred' n : ℕ) = nat.pred n
  | 1        := rfl
  | (bit0 n) :=
    have nat.succ ↑(pred' n) = ↑n,
    by rw [pred'_to_nat n, nat.succ_pred_eq_of_pos (to_nat_pos n)],
    match pred' n, this : ∀ k : num, nat.succ ↑k = ↑n →
      ↑(num.cases_on k 1 bit1 : pos_num) = nat.pred (_root_.bit0 n) with
    | 0, (h : ((1:num):ℕ) = n) := by rw ← to_nat_inj.1 h; refl
    | num.pos p, (h : nat.succ ↑p = n) :=
      by rw ← h; exact (nat.succ_add p p).symm
    end
  | (bit1 n) := rfl

  @[simp] theorem pred'_succ' (n) : pred' (succ' n) = n :=
  num.to_nat_inj.1 $ by rw [pred'_to_nat, succ'_to_nat,
    nat.add_one, nat.pred_succ]

  @[simp] theorem succ'_pred' (n) : succ' (pred' n) = n :=
  to_nat_inj.1 $ by rw [succ'_to_nat, pred'_to_nat,
    nat.add_one, nat.succ_pred_eq_of_pos (to_nat_pos _)]

  theorem size_to_nat : ∀ n, (size n : ℕ) = nat.size n
  | 1        := nat.size_one.symm
  | (bit0 n) := by rw [size, succ_to_nat, size_to_nat, cast_bit0,
                       nat.size_bit0 $ ne_of_gt $ to_nat_pos n]
  | (bit1 n) := by rw [size, succ_to_nat, size_to_nat, cast_bit1,
                       nat.size_bit1]

  theorem size_eq_nat_size : ∀ n, (size n : ℕ) = nat_size n
  | 1        := rfl
  | (bit0 n) := by rw [size, succ_to_nat, nat_size, size_eq_nat_size]
  | (bit1 n) := by rw [size, succ_to_nat, nat_size, size_eq_nat_size]

  theorem nat_size_to_nat (n) : nat_size n = nat.size n :=
  by rw [← size_eq_nat_size, size_to_nat]

  theorem nat_size_pos (n) : 0 < nat_size n :=
  by cases n; apply nat.succ_pos

  meta def transfer_rw : tactic unit :=
  `[repeat {rw ← to_nat_inj <|> rw ← lt_to_nat <|> rw ← le_to_nat},
    repeat {rw add_to_nat <|> rw mul_to_nat <|> rw cast_one <|> rw cast_zero}]

  meta def transfer : tactic unit := `[intros, transfer_rw, try {simp [mul_comm, mul_left_comm]}]

  instance : add_comm_semigroup pos_num :=
  by refine {add := (+), ..}; transfer

  instance : comm_monoid pos_num :=
  by refine {mul := (*), one := 1, ..}; transfer

  instance : distrib pos_num :=
  by refine {add := (+), mul := (*), ..}; {transfer, simp [mul_add, mul_comm]}

  instance : decidable_linear_order pos_num :=
  { lt              := (<),
    lt_iff_le_not_le := by {intros a b, transfer_rw, apply lt_iff_le_not_le},
    le              := (≤),
    le_refl         := by transfer,
    le_trans        := by {intros a b c, transfer_rw, apply le_trans},
    le_antisymm     := by {intros a b, transfer_rw, apply le_antisymm},
    le_total        := by {intros a b, transfer_rw, apply le_total},
    decidable_lt    := by apply_instance,
    decidable_le    := by apply_instance,
    decidable_eq    := by apply_instance }

  @[simp] theorem cast_to_num (n : pos_num) : ↑n = num.pos n :=
  by rw [← cast_to_nat, ← of_to_nat n]

  theorem bit_to_nat (b n) : (bit b n : ℕ) = nat.bit b n :=
  by cases b; refl

  @[simp] theorem cast_add [add_monoid α] [has_one α] (m n) : ((m + n : pos_num) : α) = m + n :=
  by rw [← cast_to_nat, add_to_nat, nat.cast_add, cast_to_nat, cast_to_nat]

  @[simp] theorem cast_succ [add_monoid α] [has_one α] (n : pos_num) : (succ n : α) = n + 1 :=
  by rw [← add_one, cast_add, cast_one]

  @[simp] theorem cast_inj [add_monoid α] [has_one α] [char_zero α] {m n : pos_num} : (m:α) = n ↔ m = n :=
  by rw [← cast_to_nat m, ← cast_to_nat n, nat.cast_inj, to_nat_inj]

  theorem one_le_cast [linear_ordered_semiring α] (n : pos_num) : (1 : α) ≤ n :=
  by rw [← cast_to_nat, ← nat.cast_one, nat.cast_le]; apply to_nat_pos

  theorem cast_pos [linear_ordered_semiring α] (n : pos_num) : (n : α) > 0 :=
  lt_of_lt_of_le zero_lt_one (one_le_cast n)

  @[simp] theorem cast_mul [semiring α] (m n) : ((m * n : pos_num) : α) = m * n :=
  by rw [← cast_to_nat, mul_to_nat, nat.cast_mul, cast_to_nat, cast_to_nat]

  theorem cmp_eq (m n) : cmp m n = ordering.eq ↔ m = n :=
  begin
    have := cmp_to_nat m n,
    cases cmp m n; simp at this ⊢; try {exact this};
    { simp [show m ≠ n, from λ e, by rw e at this; exact lt_irrefl _ this] }
  end

  @[simp] theorem cast_lt [linear_ordered_semiring α] {m n : pos_num} : (m:α) < n ↔ m < n :=
  by rw [← cast_to_nat m, ← cast_to_nat n, nat.cast_lt, lt_to_nat]

  @[simp] theorem cast_le [linear_ordered_semiring α] {m n : pos_num} : (m:α) ≤ n ↔ m ≤ n :=
  by rw ← not_lt; exact not_congr cast_lt

end pos_num

namespace num
  variables {α : Type*}
  open pos_num

  theorem bit_to_nat (b n) : (bit b n : ℕ) = nat.bit b n :=
  by cases b; cases n; refl

  theorem cast_succ' [add_monoid α] [has_one α] (n) : (succ' n : α) = n + 1 :=
  by rw [← pos_num.cast_to_nat, succ'_to_nat, nat.cast_add_one, cast_to_nat]

  theorem cast_succ [add_monoid α] [has_one α] (n) : (succ n : α) = n + 1 := cast_succ' n

  @[simp] theorem cast_add [semiring α] (m n) : ((m + n : num) : α) = m + n :=
  by rw [← cast_to_nat, add_to_nat, nat.cast_add, cast_to_nat, cast_to_nat]

  @[simp] theorem cast_bit0 [semiring α] (n : num) : (n.bit0 : α) = _root_.bit0 n :=
  by rw [← bit0_of_bit0, _root_.bit0, cast_add]; refl

  @[simp] theorem cast_bit1 [semiring α] (n : num) : (n.bit1 : α) = _root_.bit1 n :=
  by rw [← bit1_of_bit1, _root_.bit1, bit0_of_bit0, cast_add, cast_bit0]; refl

  @[simp] theorem cast_mul [semiring α] : ∀ m n, ((m * n : num) : α) = m * n
  | 0       0       := (zero_mul _).symm
  | 0       (pos q) := (zero_mul _).symm
  | (pos p) 0       := (mul_zero _).symm
  | (pos p) (pos q) := pos_num.cast_mul _ _

  theorem size_to_nat : ∀ n, (size n : ℕ) = nat.size n
  | 0       := nat.size_zero.symm
  | (pos p) := p.size_to_nat

  theorem size_eq_nat_size : ∀ n, (size n : ℕ) = nat_size n
  | 0       := rfl
  | (pos p) := p.size_eq_nat_size

  theorem nat_size_to_nat (n) : nat_size n = nat.size n :=
  by rw [← size_eq_nat_size, size_to_nat]

  @[simp] theorem of_nat'_eq : ∀ n, num.of_nat' n = n :=
  nat.binary_rec rfl $ λ b n IH, begin
    rw of_nat' at IH ⊢,
    rw [nat.binary_rec_eq, IH],
    { cases b; simp [nat.bit, bit0_of_bit0, bit1_of_bit1] },
    { refl }
  end

  theorem zneg_to_znum (n : num) : -n.to_znum = n.to_znum_neg := by cases n; refl
  theorem zneg_to_znum_neg (n : num) : -n.to_znum_neg = n.to_znum := by cases n; refl

  theorem to_znum_inj {m n : num} : m.to_znum = n.to_znum ↔ m = n :=
  ⟨λ h, by cases m; cases n; cases h; refl, congr_arg _⟩

  @[simp] theorem cast_to_znum [has_zero α] [has_one α] [has_add α] [has_neg α] :
    ∀ n : num, (n.to_znum : α) = n
  | 0           := rfl
  | (num.pos p) := rfl

  @[simp] theorem cast_to_znum_neg [add_group α] [has_one α] :
    ∀ n : num, (n.to_znum_neg : α) = -n
  | 0           := neg_zero.symm
  | (num.pos p) := rfl

  @[simp] theorem add_to_znum (m n : num) : num.to_znum (m + n) = m.to_znum + n.to_znum :=
  by cases m; cases n; refl

end num

namespace pos_num
  open num

  theorem pred_to_nat {n : pos_num} (h : n > 1) : (pred n : ℕ) = nat.pred n :=
  begin
    unfold pred,
    have := pred'_to_nat n,
    cases e : pred' n,
    { have : (1:ℕ) ≤ nat.pred n :=
        nat.pred_le_pred ((@cast_lt ℕ _ _ _).2 h),
      rw [← pred'_to_nat, e] at this,
      exact absurd this dec_trivial },
    { rw [← pred'_to_nat, e], refl }
  end

  theorem sub'_one (a : pos_num) : sub' a 1 = (pred' a).to_znum :=
  by cases a; refl

  theorem one_sub' (a : pos_num) : sub' 1 a = (pred' a).to_znum_neg :=
  by cases a; refl

  theorem lt_iff_cmp {m n} : m < n ↔ cmp m n = ordering.lt := iff.rfl

  theorem le_iff_cmp {m n} : m ≤ n ↔ cmp m n ≠ ordering.gt :=
  not_congr $ lt_iff_cmp.trans $
  by rw ← cmp_swap; cases cmp m n; exact dec_trivial

end pos_num

namespace num
  variables {α : Type*}
  open pos_num

  theorem pred_to_nat : ∀ (n : num), (pred n : ℕ) = nat.pred n
  | 0       := rfl
  | (pos p) := by rw [pred, pos_num.pred'_to_nat]; refl

  theorem ppred_to_nat : ∀ (n : num), coe <$> ppred n = nat.ppred n
  | 0       := rfl
  | (pos p) := by rw [ppred, option.map_some, nat.ppred_eq_some.2];
    rw [pos_num.pred'_to_nat, nat.succ_pred_eq_of_pos (pos_num.to_nat_pos _)]; refl

  theorem cmp_swap (m n) : (cmp m n).swap = cmp n m :=
  by cases m; cases n; try {unfold cmp}; try {refl}; apply pos_num.cmp_swap

  theorem cmp_eq (m n) : cmp m n = ordering.eq ↔ m = n :=
  begin
    have := cmp_to_nat m n,
    cases cmp m n; simp at this ⊢; try {exact this};
    { simp [show m ≠ n, from λ e, by rw e at this; exact lt_irrefl _ this] }
  end

  @[simp] theorem cast_lt [linear_ordered_semiring α] {m n : num} : (m:α) < n ↔ m < n :=
  by rw [← cast_to_nat m, ← cast_to_nat n, nat.cast_lt, lt_to_nat]

  @[simp] theorem cast_le [linear_ordered_semiring α] {m n : num} : (m:α) ≤ n ↔ m ≤ n :=
  by rw ← not_lt; exact not_congr cast_lt

  @[simp] theorem cast_inj [linear_ordered_semiring α] {m n : num} : (m:α) = n ↔ m = n :=
  by rw [← cast_to_nat m, ← cast_to_nat n, nat.cast_inj, to_nat_inj]

  theorem lt_iff_cmp {m n} : m < n ↔ cmp m n = ordering.lt := iff.rfl

  theorem le_iff_cmp {m n} : m ≤ n ↔ cmp m n ≠ ordering.gt :=
  not_congr $ lt_iff_cmp.trans $
  by rw ← cmp_swap; cases cmp m n; exact dec_trivial

  theorem bitwise_to_nat {f : num → num → num} {g : bool → bool → bool}
    (p : pos_num → pos_num → num)
    (gff : g ff ff = ff)
    (f00 : f 0 0 = 0)
    (f0n : ∀ n, f 0 (pos n) = cond (g ff tt) (pos n) 0)
    (fn0 : ∀ n, f (pos n) 0 = cond (g tt ff) (pos n) 0)
    (fnn : ∀ m n, f (pos m) (pos n) = p m n)
    (p11 : p 1 1 = cond (g tt tt) 1 0)
    (p1b : ∀ b n, p 1 (pos_num.bit b n) = bit (g tt b) (cond (g ff tt) (pos n) 0))
    (pb1 : ∀ a m, p (pos_num.bit a m) 1 = bit (g a tt) (cond (g tt ff) (pos m) 0))
    (pbb : ∀ a b m n, p (pos_num.bit a m) (pos_num.bit b n) = bit (g a b) (p m n))
    : ∀ m n : num, (f m n : ℕ) = nat.bitwise g m n :=
  begin
    intros, cases m with m; cases n with n;
    try { change zero with 0 };
    try { change ((0:num):ℕ) with 0 },
    { rw [f00, nat.bitwise_zero]; refl },
    { unfold nat.bitwise, rw [f0n, nat.binary_rec_zero],
      cases g ff tt; refl },
    { unfold nat.bitwise,
      generalize h : (pos m : ℕ) = m', revert h,
      apply nat.bit_cases_on m' _, intros b m' h,
      rw [fn0, nat.binary_rec_eq, nat.binary_rec_zero, ←h],
      cases g tt ff; refl,
      apply nat.bitwise_bit_aux gff },
    { rw fnn,
      have : ∀b (n : pos_num), (cond b ↑n 0 : ℕ) = ↑(cond b (pos n) 0 : num) :=
        by intros; cases b; refl,
      induction m with m IH m IH generalizing n; cases n with n n,
      any_goals { change one with 1 },
      any_goals { change pos 1 with 1 },
      any_goals { change pos_num.bit0 with pos_num.bit ff },
      any_goals { change pos_num.bit1 with pos_num.bit tt },
      any_goals { change ((1:num):ℕ) with nat.bit tt 0 },
      all_goals {
        repeat {
          rw show ∀ b n, (pos (pos_num.bit b n) : ℕ) = nat.bit b ↑n,
             by intros; cases b; refl },
        rw nat.bitwise_bit },
      any_goals { assumption },
      any_goals { rw [nat.bitwise_zero, p11], cases g tt tt; refl },
      any_goals { rw [nat.bitwise_zero_left, this, ← bit_to_nat, p1b] },
      any_goals { rw [nat.bitwise_zero_right _ gff, this, ← bit_to_nat, pb1] },
      all_goals { rw [← show ∀ n, ↑(p m n) = nat.bitwise g ↑m ↑n, from IH],
        rw [← bit_to_nat, pbb] } }
  end

  @[simp] theorem lor_to_nat   : ∀ m n, (lor    m n : ℕ) = nat.lor    m n :=
  by apply bitwise_to_nat (λx y, pos (pos_num.lor x y)); intros; try {cases a}; try {cases b}; refl
  @[simp] theorem land_to_nat  : ∀ m n, (land   m n : ℕ) = nat.land   m n :=
  by apply bitwise_to_nat pos_num.land; intros; try {cases a}; try {cases b}; refl
  @[simp] theorem ldiff_to_nat : ∀ m n, (ldiff  m n : ℕ) = nat.ldiff  m n :=
  by apply bitwise_to_nat pos_num.ldiff; intros; try {cases a}; try {cases b}; refl
  @[simp] theorem lxor_to_nat  : ∀ m n, (lxor   m n : ℕ) = nat.lxor   m n :=
  by apply bitwise_to_nat pos_num.lxor; intros; try {cases a}; try {cases b}; refl

  @[simp] theorem shiftl_to_nat (m n) : (shiftl m n : ℕ) = nat.shiftl m n :=
  begin
    cases m; dunfold shiftl, {symmetry, apply nat.zero_shiftl},
    simp, induction n with n IH, {refl},
    simp [pos_num.shiftl, nat.shiftl_succ], rw ←IH
  end

  @[simp] theorem shiftr_to_nat (m n) : (shiftr m n : ℕ) = nat.shiftr m n :=
  begin
    cases m with m; dunfold shiftr, {symmetry, apply nat.zero_shiftr},
    induction n with n IH generalizing m, {cases m; refl},
    cases m with m m; dunfold pos_num.shiftr,
    { rw [nat.shiftr_eq_div_pow], symmetry, apply nat.div_eq_of_lt,
      exact @nat.pow_lt_pow_of_lt_right 2 dec_trivial 0 (n+1) (nat.succ_pos _) },
    { transitivity, apply IH,
      change nat.shiftr m n = nat.shiftr (bit1 m) (n+1),
      rw [add_comm n 1, nat.shiftr_add],
      apply congr_arg (λx, nat.shiftr x n), unfold nat.shiftr,
      change (bit1 ↑m : ℕ) with nat.bit tt m,
      rw nat.div2_bit },
    { transitivity, apply IH,
      change nat.shiftr m n = nat.shiftr (bit0 m) (n + 1),
      rw [add_comm n 1, nat.shiftr_add],
      apply congr_arg (λx, nat.shiftr x n), unfold nat.shiftr,
      change (bit0 ↑m : ℕ) with nat.bit ff m,
      rw nat.div2_bit }
  end

  @[simp] theorem test_bit_to_nat (m n) : test_bit m n = nat.test_bit m n :=
  begin
    cases m with m; unfold test_bit nat.test_bit,
    { change (zero : nat) with 0, rw nat.zero_shiftr, refl },
    induction n with n IH generalizing m;
    cases m; dunfold pos_num.test_bit, {refl},
    { exact (nat.bodd_bit _ _).symm },
    { exact (nat.bodd_bit _ _).symm },
    { change ff = nat.bodd (nat.shiftr 1 (n + 1)),
      rw [add_comm, nat.shiftr_add], change nat.shiftr 1 1 with 0,
      rw nat.zero_shiftr; refl },
    { change pos_num.test_bit m n = nat.bodd (nat.shiftr (nat.bit tt m) (n + 1)),
      rw [add_comm, nat.shiftr_add], unfold nat.shiftr,
      rw nat.div2_bit, apply IH },
    { change pos_num.test_bit m n = nat.bodd (nat.shiftr (nat.bit ff m) (n + 1)),
      rw [add_comm, nat.shiftr_add], unfold nat.shiftr,
      rw nat.div2_bit, apply IH },
  end

end num

namespace znum
  variables {α : Type*}
  open pos_num

  @[simp] theorem cast_zero [has_zero α] [has_one α] [has_add α] [has_neg α] :
    ((0 : znum) : α) = 0 := rfl

  @[simp] theorem cast_zero' [has_zero α] [has_one α] [has_add α] [has_neg α] :
    (znum.zero : α) = 0 := rfl

  @[simp] theorem cast_one [has_zero α] [has_one α] [has_add α] [has_neg α] :
    ((1 : znum) : α) = 1 := rfl

  @[simp] theorem cast_pos [has_zero α] [has_one α] [has_add α] [has_neg α]
    (n : pos_num) : (pos n : α) = n := rfl

  @[simp] theorem cast_neg [has_zero α] [has_one α] [has_add α] [has_neg α]
    (n : pos_num) : (neg n : α) = -n := rfl

  @[simp] theorem cast_zneg [add_group α] [has_one α] : ∀ n, ((-n : znum) : α) = -n
  | 0       := neg_zero.symm
  | (pos p) := rfl
  | (neg p) := (neg_neg _).symm

  theorem neg_zero : (-0 : znum) = 0 := rfl
  theorem zneg_pos (n : pos_num) : -pos n = neg n := rfl
  theorem zneg_neg (n : pos_num) : -neg n = pos n := rfl
  theorem zneg_zneg (n : znum) : - -n = n := by cases n; refl
  theorem zneg_bit1 (n : znum) : -n.bit1 = (-n).bitm1 := by cases n; refl
  theorem zneg_bitm1 (n : znum) : -n.bitm1 = (-n).bit1 := by cases n; refl

  theorem zneg_succ (n : znum) : -n.succ = (-n).pred :=
  by cases n; try {refl}; rw [succ, num.zneg_to_znum_neg]; refl

  theorem zneg_pred (n : znum) : -n.pred = (-n).succ :=
  by rw [← zneg_zneg (succ (-n)), zneg_succ, zneg_zneg]

  @[simp] theorem neg_of_int : ∀ n, ((-n : ℤ) : znum) = -n
  | (n+1:ℕ) := rfl
  | 0       := rfl
  | -[1+n]  := (zneg_zneg _).symm

  @[simp] theorem abs_to_nat : ∀ n, (abs n : ℕ) = int.nat_abs n
  | 0       := rfl
  | (pos p) := congr_arg int.nat_abs p.to_nat_to_int
  | (neg p) := show int.nat_abs ((p:ℕ):ℤ) = int.nat_abs (- p),
    by rw [p.to_nat_to_int, int.nat_abs_neg]

  @[simp] theorem abs_to_znum : ∀ n : num, abs n.to_znum = n
  | 0           := rfl
  | (num.pos p) := rfl

  @[simp] theorem cast_to_int [add_group α] [has_one α] : ∀ n : znum, ((n : ℤ) : α) = n
  | 0       := rfl
  | (pos p) := by rw [cast_pos, cast_pos, pos_num.cast_to_int]
  | (neg p) := by rw [cast_neg, cast_neg, int.cast_neg, pos_num.cast_to_int]

  theorem bit0_of_bit0 : ∀ n : znum, _root_.bit0 n = n.bit0
  | 0       := rfl
  | (pos a) := congr_arg pos a.bit0_of_bit0
  | (neg a) := congr_arg neg a.bit0_of_bit0

  theorem bit1_of_bit1 : ∀ n : znum, _root_.bit1 n = n.bit1
  | 0       := rfl
  | (pos a) := congr_arg pos a.bit1_of_bit1
  | (neg a) := show pos_num.sub' 1 (_root_.bit0 a) = _,
    by rw [pos_num.one_sub', a.bit0_of_bit0]; refl

  @[simp] theorem cast_bit0 [add_group α] [has_one α] :
    ∀ n : znum, (n.bit0 : α) = bit0 n
  | 0       := (add_zero _).symm
  | (pos p) := by rw [znum.bit0, cast_pos, cast_pos]; refl
  | (neg p) := by rw [znum.bit0, cast_neg, cast_neg, pos_num.cast_bit0,
                      _root_.bit0, _root_.bit0, neg_add_rev]

  @[simp] theorem cast_bit1 [add_group α] [has_one α] :
    ∀ n : znum, (n.bit1 : α) = bit1 n
  | 0       := by simp [znum.bit1, _root_.bit1, _root_.bit0]
  | (pos p) := by rw [znum.bit1, cast_pos, cast_pos]; refl
  | (neg p) := begin
      rw [znum.bit1, cast_neg, cast_neg],
      cases e : pred' p;
      have : p = _ := (succ'_pred' p).symm.trans
        (congr_arg num.succ' e),
      { change p=1 at this, subst p,
        simp [_root_.bit1, _root_.bit0] },
      { rw [num.succ'] at this, subst p,
        have : (↑(-↑a:ℤ) : α) = -1 + ↑(-↑a + 1 : ℤ), {simp},
        simpa [_root_.bit1, _root_.bit0, -add_comm] },
    end

  @[simp] theorem cast_bitm1 [add_group α] [has_one α]
    (n : znum) : (n.bitm1 : α) = bit0 n - 1 :=
  begin
    conv { to_lhs, rw ← zneg_zneg n },
    rw [← zneg_bit1, cast_zneg, cast_bit1],
    have : ((-1 + n + n : ℤ) : α) = (n + n + -1 : ℤ), {simp},
    simpa [_root_.bit1, _root_.bit0, -add_comm]
  end

  theorem add_zero (n : znum) : n + 0 = n := by cases n; refl
  theorem zero_add (n : znum) : 0 + n = n := by cases n; refl

  theorem add_one : ∀ n : znum, n + 1 = succ n
  | 0       := rfl
  | (pos p) := congr_arg pos p.add_one
  | (neg p) := by cases p; refl

end znum

namespace pos_num
  variables {α : Type*}

  theorem cast_to_znum : ∀ n : pos_num, (n : znum) = znum.pos n
  | 1        := rfl
  | (bit0 p) := (znum.bit0_of_bit0 p).trans $ congr_arg _ (cast_to_znum p)
  | (bit1 p) := (znum.bit1_of_bit1 p).trans $ congr_arg _ (cast_to_znum p)

  theorem cast_sub' [add_group α] [has_one α] : ∀ m n : pos_num, (sub' m n : α) = m - n
  | a        1        := by rw [sub'_one, num.cast_to_znum,
                                ← num.cast_to_nat, pred'_to_nat, ← nat.sub_one];
                            simp [pos_num.cast_pos]
  | 1        b        := by rw [one_sub', num.cast_to_znum_neg, ← neg_sub, neg_inj',
                                ← num.cast_to_nat, pred'_to_nat, ← nat.sub_one];
                            simp [pos_num.cast_pos]
  | (bit0 a) (bit0 b) := begin
      rw [sub', znum.cast_bit0, cast_sub'],
      have : ((a + -b + (a + -b) : ℤ) : α) = a + a + (-b + -b), {simp},
      simpa [_root_.bit0, -add_left_comm]
    end
  | (bit0 a) (bit1 b) := begin
      rw [sub', znum.cast_bitm1, cast_sub'],
      have : ((-b + (a + (-b + -1)) : ℤ) : α) = (a + -1 + (-b + -b):ℤ), {simp},
      simpa [_root_.bit1, _root_.bit0, -add_left_comm, -add_comm]
    end
  | (bit1 a) (bit0 b) := begin
      rw [sub', znum.cast_bit1, cast_sub'],
      have : ((-b + (a + (-b + 1)) : ℤ) : α) = (a + 1 + (-b + -b):ℤ), {simp},
      simpa [_root_.bit1, _root_.bit0, -add_left_comm, -add_comm]
    end
  | (bit1 a) (bit1 b) := begin
      rw [sub', znum.cast_bit0, cast_sub'],
      have : ((-b + (a + -b) : ℤ) : α) = a + (-b + -b), {simp},
      simpa [_root_.bit1, _root_.bit0, -add_left_comm, add_neg_cancel_left]
    end

  theorem to_nat_eq_succ_pred (n : pos_num) : (n:ℕ) = n.pred' + 1 :=
  by rw [← num.succ'_to_nat, n.succ'_pred']

  theorem to_int_eq_succ_pred (n : pos_num) : (n:ℤ) = (n.pred' : ℕ) + 1 :=
  by rw [← n.to_nat_to_int, to_nat_eq_succ_pred]; refl

end pos_num

namespace num
  variables {α : Type*}

  @[simp] theorem cast_sub' [add_group α] [has_one α] : ∀ m n : num, (sub' m n : α) = m - n
  | 0       0       := (sub_zero _).symm
  | (pos a) 0       := (sub_zero _).symm
  | 0       (pos b) := (zero_sub _).symm
  | (pos a) (pos b) := pos_num.cast_sub' _ _

  @[simp] theorem of_nat_to_znum : ∀ n : ℕ, to_znum n = n
  | 0     := rfl
  | (n+1) := by rw [nat.cast_add_one, nat.cast_add_one,
    znum.add_one, add_one, ← of_nat_to_znum]; cases (n:num); refl

  @[simp] theorem of_nat_to_znum_neg (n : ℕ) : to_znum_neg n = -n :=
  by rw [← of_nat_to_znum, zneg_to_znum]

  theorem mem_of_znum' : ∀ {m : num} {n : znum}, m ∈ of_znum' n ↔ n = to_znum m
  | 0       0      := ⟨λ _, rfl, λ _, rfl⟩
  | (pos m) 0      := ⟨λ h, by cases h, λ h, by cases h⟩
  | m (znum.pos p) := option.some_inj.trans $
    by cases m; split; intro h; try {cases h}; refl
  | m (znum.neg p) := ⟨λ h, by cases h, λ h, by cases m; cases h⟩

  theorem of_znum'_to_nat : ∀ (n : znum), coe <$> of_znum' n = int.to_nat' n
  | 0            := rfl
  | (znum.pos p) := show _ = int.to_nat' p, by rw [← pos_num.to_nat_to_int p]; refl
  | (znum.neg p) := congr_arg (λ x, int.to_nat' (-x)) $
    show ((p.pred' + 1 : ℕ) : ℤ) = p, by rw ← succ'_to_nat; simp

  @[simp] theorem of_znum_to_nat : ∀ (n : znum), (of_znum n : ℕ) = int.to_nat n
  | 0            := rfl
  | (znum.pos p) := show _ = int.to_nat p, by rw [← pos_num.to_nat_to_int p]; refl
  | (znum.neg p) := congr_arg (λ x, int.to_nat (-x)) $
    show ((p.pred' + 1 : ℕ) : ℤ) = p, by rw ← succ'_to_nat; simp

  @[simp] theorem cast_of_znum [add_group α] [has_one α] (n : znum) :
    (of_znum n : α) = int.to_nat n :=
  by rw [← cast_to_nat, of_znum_to_nat]

  @[simp] theorem sub_to_nat (m n) : ((m - n : num) : ℕ) = m - n :=
  show (of_znum _ : ℕ) = _, by rw [of_znum_to_nat, cast_sub',
    ← to_nat_to_int, ← to_nat_to_int, int.to_nat_sub]

end num

namespace znum
  variables {α : Type*}

  @[simp] theorem cast_add [add_group α] [has_one α] : ∀ m n, ((m + n : znum) : α) = m + n
  | 0       a       := by cases a; exact (_root_.zero_add _).symm
  | b       0       := by cases b; exact (_root_.add_zero _).symm
  | (pos a) (pos b) := pos_num.cast_add _ _
  | (pos a) (neg b) := pos_num.cast_sub' _ _
  | (neg a) (pos b) := (pos_num.cast_sub' _ _).trans $
    show ↑b + -↑a = -↑a + ↑b, by rw [← pos_num.cast_to_int a, ← pos_num.cast_to_int b,
      ← int.cast_neg, ← int.cast_add (-a)]; simp
  | (neg a) (neg b) := show -(↑(a + b) : α) = -a + -b, by rw [
    pos_num.cast_add, neg_eq_iff_neg_eq, neg_add_rev, neg_neg, neg_neg,
    ← pos_num.cast_to_int a, ← pos_num.cast_to_int b, ← int.cast_add]; simp

  @[simp] theorem cast_succ [add_group α] [has_one α] (n) : ((succ n : znum) : α) = n + 1 :=
  by rw [← add_one, cast_add, cast_one]

  @[simp] theorem mul_to_int : ∀ m n, ((m * n : znum) : ℤ) = m * n
  | 0       a       := by cases a; exact (_root_.zero_mul _).symm
  | b       0       := by cases b; exact (_root_.mul_zero _).symm
  | (pos a) (pos b) := pos_num.cast_mul a b
  | (pos a) (neg b) := show -↑(a * b) = ↑a * -↑b, by rw [pos_num.cast_mul, neg_mul_eq_mul_neg]
  | (neg a) (pos b) := show -↑(a * b) = -↑a * ↑b, by rw [pos_num.cast_mul, neg_mul_eq_neg_mul]
  | (neg a) (neg b) := show ↑(a * b) = -↑a * -↑b, by rw [pos_num.cast_mul, neg_mul_neg]

  theorem cast_mul [ring α] (m n) : ((m * n : znum) : α) = m * n :=
  by rw [← cast_to_int, mul_to_int, int.cast_mul, cast_to_int, cast_to_int]

  @[simp] theorem of_to_int : Π (n : znum), ((n : ℤ) : znum) = n
  | 0       := rfl
  | (pos a) := by rw [cast_pos, ← pos_num.cast_to_nat,
    int.cast_coe_nat', ← num.of_nat_to_znum, pos_num.of_to_nat]; refl
  | (neg a) := by rw [cast_neg, neg_of_int, ← pos_num.cast_to_nat,
    int.cast_coe_nat', ← num.of_nat_to_znum_neg, pos_num.of_to_nat]; refl

  @[simp] theorem to_of_int : Π (n : ℤ), ((n : znum) : ℤ) = n
  | (n : ℕ) := by rw [int.cast_coe_nat,
    ← num.of_nat_to_znum, num.cast_to_znum, ← num.cast_to_nat,
    int.nat_cast_eq_coe_nat, num.to_of_nat]
  | -[1+ n] := by rw [int.cast_neg_succ_of_nat, cast_zneg,
    add_one, cast_succ, int.neg_succ_of_nat_eq,
    ← num.of_nat_to_znum, num.cast_to_znum, ← num.cast_to_nat,
    int.nat_cast_eq_coe_nat, num.to_of_nat]

  theorem to_int_inj {m n : znum} : (m : ℤ) = n ↔ m = n :=
  ⟨λ h, function.injective_of_left_inverse of_to_int h, congr_arg _⟩

  @[simp] theorem of_int_cast [add_group α] [has_one α] (n : ℤ) : ((n : znum) : α) = n :=
  by rw [← cast_to_int, to_of_int]

  @[simp] theorem of_nat_cast [add_group α] [has_one α] (n : ℕ) : ((n : znum) : α) = n :=
  of_int_cast n

  @[simp] theorem of_int'_eq : ∀ n, znum.of_int' n = n
  | (n : ℕ) := to_int_inj.1 $ by simp [znum.of_int']
  | -[1+ n] := to_int_inj.1 $ by simp [znum.of_int']

  theorem cmp_to_int : ∀ (m n), (ordering.cases_on (cmp m n) ((m:ℤ) < n) (m = n) ((m:ℤ) > n) : Prop)
  | 0       0       := rfl
  | (pos a) (pos b) := begin
      have := pos_num.cmp_to_nat a b; revert this; dsimp [cmp];
      cases pos_num.cmp a b; dsimp;
      [simp, exact congr_arg pos, simp [gt]]
    end
  | (neg a) (neg b) := begin
      have := pos_num.cmp_to_nat b a; revert this; dsimp [cmp];
      cases pos_num.cmp b a; dsimp;
      [simp, simp {contextual := tt}, simp [gt]]
    end
  | (pos a) 0       := pos_num.cast_pos _
  | (pos a) (neg b) := lt_trans (neg_lt_zero.2 $ pos_num.cast_pos _) (pos_num.cast_pos _)
  | 0       (neg b) := neg_lt_zero.2 $ pos_num.cast_pos _
  | (neg a) 0       := neg_lt_zero.2 $ pos_num.cast_pos _
  | (neg a) (pos b) := lt_trans (neg_lt_zero.2 $ pos_num.cast_pos _) (pos_num.cast_pos _)
  | 0       (pos b) := pos_num.cast_pos _

  @[simp] theorem lt_to_int {m n : znum} : (m:ℤ) < n ↔ m < n :=
  show (m:ℤ) < n ↔ cmp m n = ordering.lt, from
  match cmp m n, cmp_to_int m n with
  | ordering.lt, h := by simp at h; simp [h]
  | ordering.eq, h := by simp at h; simp [h, lt_irrefl]; exact dec_trivial
  | ordering.gt, h := by simp [not_lt_of_gt h]; exact dec_trivial
  end

  @[simp] theorem le_to_int {m n : znum} : (m:ℤ) ≤ n ↔ m ≤ n :=
  by rw ← not_lt; exact not_congr lt_to_int

  @[simp] theorem cast_lt [linear_ordered_ring α] {m n : znum} : (m:α) < n ↔ m < n :=
  by rw [← cast_to_int m, ← cast_to_int n, int.cast_lt, lt_to_int]

  @[simp] theorem cast_le [linear_ordered_ring α] {m n : znum} : (m:α) ≤ n ↔ m ≤ n :=
  by rw ← not_lt; exact not_congr cast_lt

  @[simp] theorem cast_inj [linear_ordered_ring α] {m n : znum} : (m:α) = n ↔ m = n :=
  by rw [← cast_to_int m, ← cast_to_int n, int.cast_inj, to_int_inj]

  meta def transfer_rw : tactic unit :=
  `[repeat {rw ← to_int_inj <|> rw ← lt_to_int <|> rw ← le_to_int},
    repeat {rw cast_add <|> rw mul_to_int <|> rw cast_one <|> rw cast_zero}]

  meta def transfer : tactic unit := `[intros, transfer_rw, try {simp [mul_comm, mul_left_comm]}]

  instance : decidable_linear_order znum :=
  { lt               := (<),
    lt_iff_le_not_le := by {intros a b, transfer_rw, apply lt_iff_le_not_le},
    le               := (≤),
    le_refl          := by transfer,
    le_trans         := by {intros a b c, transfer_rw, apply le_trans},
    le_antisymm      := by {intros a b, transfer_rw, apply le_antisymm},
    le_total         := by {intros a b, transfer_rw, apply le_total},
    decidable_eq     := znum.decidable_eq,
    decidable_le     := znum.decidable_le,
    decidable_lt     := znum.decidable_lt }

  instance : add_comm_group znum :=
  { add              := (+),
    add_assoc        := by transfer,
    zero             := 0,
    zero_add         := zero_add,
    add_zero         := add_zero,
    add_comm         := by transfer,
    neg              := has_neg.neg,
    add_left_neg     := by transfer }

  instance : decidable_linear_ordered_comm_ring znum :=
  { mul              := (*),
    mul_assoc        := by transfer,
    one              := 1,
    one_mul          := by transfer,
    mul_one          := by transfer,
    left_distrib     := by {transfer, simp [mul_add]},
    right_distrib    := by {transfer, simp [mul_add, mul_comm]},
    mul_comm         := by transfer,
    zero_ne_one      := dec_trivial,
    add_le_add_left  := by {intros a b h c, revert h, transfer_rw, exact λ h, add_le_add_left h c},
    add_lt_add_left  := by {intros a b h c, revert h, transfer_rw, exact λ h, add_lt_add_left h c},
    mul_pos          := by {intros a b, transfer_rw, apply mul_pos},
    mul_nonneg       := by {intros x y,
      change 0 ≤ x → 0 ≤ y → 0 ≤ x * y,
      transfer_rw, apply mul_nonneg},
    zero_lt_one      := dec_trivial,
    ..znum.decidable_linear_order, ..znum.add_comm_group }

  @[simp] theorem dvd_to_int (m n : znum) : (m : ℤ) ∣ n ↔ m ∣ n :=
  ⟨λ ⟨k, e⟩, ⟨k, by rw [← of_to_int n, e]; simp⟩,
   λ ⟨k, e⟩, ⟨k, by simp [e]⟩⟩

end znum

namespace pos_num

  theorem divmod_to_nat_aux {n d : pos_num} {q r : num}
    (h₁ : (r:ℕ) + d * _root_.bit0 q = n)
    (h₂ : (r:ℕ) < 2 * d) :
    ((divmod_aux d q r).2 + d * (divmod_aux d q r).1 : ℕ) = ↑n ∧
    ((divmod_aux d q r).2 : ℕ) < d :=
  begin
    unfold divmod_aux,
    have : ∀ {r₂}, num.of_znum' (num.sub' r (num.pos d)) = some r₂ ↔ (r : ℕ) = r₂ + d,
    { intro r₂,
      apply num.mem_of_znum'.trans,
      rw [← znum.to_int_inj, num.cast_to_znum,
        num.cast_sub', sub_eq_iff_eq_add, ← int.coe_nat_inj'],
      simp },
    cases e : num.of_znum' (num.sub' r (num.pos d)) with r₂;
      simp [divmod_aux],
    { refine ⟨h₁, lt_of_not_ge (λ h, _)⟩,
      cases nat.le.dest h with r₂ e',
      rw [← num.to_of_nat r₂, add_comm] at e',
      cases e.symm.trans (this.2 e'.symm) },
    { have := this.1 e,
      split,
      { rwa [_root_.bit1, add_comm _ 1, mul_add, mul_one,
          ← add_assoc, ← this] },
      { rwa [this, two_mul, add_lt_add_iff_right] at h₂ } }
  end

  theorem divmod_to_nat (d n : pos_num) :
    (n / d : ℕ) = (divmod d n).1 ∧
    (n % d : ℕ) = (divmod d n).2 :=
  begin
    rw nat.div_mod_unique (pos_num.cast_pos _),
    induction n with n IH n IH,
    { exact divmod_to_nat_aux (by simp; refl)
        (nat.mul_le_mul_left 2
          (pos_num.cast_pos d : (0 : ℕ) < d)) },
    { unfold divmod,
      cases divmod d n with q r, simp only [divmod] at IH ⊢,
      apply divmod_to_nat_aux; simp,
      { rw [_root_.bit1, _root_.bit1, add_right_comm,
          bit0_eq_two_mul ↑n, ← IH.1,
          mul_add, ← bit0_eq_two_mul,
          mul_left_comm, ← bit0_eq_two_mul] },
      { rw ← bit0_eq_two_mul,
        exact nat.bit1_lt_bit0 IH.2 } },
    { unfold divmod,
      cases divmod d n with q r, simp only [divmod] at IH ⊢,
      apply divmod_to_nat_aux; simp,
      { rw [bit0_eq_two_mul ↑n, ← IH.1,
          mul_add, ← bit0_eq_two_mul,
          mul_left_comm, ← bit0_eq_two_mul] },
      { rw ← bit0_eq_two_mul,
        exact nat.bit0_lt IH.2 } }
  end

  @[simp] theorem div'_to_nat (n d) : (div' n d : ℕ) = n / d :=
  (divmod_to_nat _ _).1.symm

  @[simp] theorem mod'_to_nat (n d) : (mod' n d : ℕ) = n % d :=
  (divmod_to_nat _ _).2.symm

end pos_num

namespace num

  @[simp] theorem div_to_nat : ∀ n d, ((n / d : num) : ℕ) = n / d
  | 0       0       := rfl
  | 0       (pos d) := (nat.zero_div _).symm
  | (pos n) 0       := (nat.div_zero _).symm
  | (pos n) (pos d) := pos_num.div'_to_nat _ _

  @[simp] theorem mod_to_nat : ∀ n d, ((n % d : num) : ℕ) = n % d
  | 0       0       := rfl
  | 0       (pos d) := (nat.zero_mod _).symm
  | (pos n) 0       := (nat.mod_zero _).symm
  | (pos n) (pos d) := pos_num.mod'_to_nat _ _

  theorem gcd_to_nat_aux : ∀ {n} {a b : num},
    a ≤ b → (a * b).nat_size ≤ n → (gcd_aux n a b : ℕ) = nat.gcd a b
  | 0            0       b       ab h := (nat.gcd_zero_left _).symm
  | 0            (pos a) 0       ab h := (not_lt_of_ge ab).elim rfl
  | 0            (pos a) (pos b) ab h :=
    (not_lt_of_le h).elim $ pos_num.nat_size_pos _
  | (nat.succ n) 0       b       ab h := (nat.gcd_zero_left _).symm
  | (nat.succ n) (pos a) b       ab h := begin
    simp [gcd_aux],
    rw [nat.gcd_rec, gcd_to_nat_aux, mod_to_nat], {refl},
    { rw [← le_to_nat, mod_to_nat],
      exact le_of_lt (nat.mod_lt _ (pos_num.cast_pos _)) },
    rw [nat_size_to_nat, mul_to_nat, nat.size_le] at h ⊢,
    rw [mod_to_nat, mul_comm],
    rw [nat.pow_succ, ← nat.mod_add_div b (pos a)] at h,
    refine lt_of_mul_lt_mul_right (lt_of_le_of_lt _ h) (nat.zero_le 2),
    rw [mul_two, mul_add],
    refine add_le_add_left (nat.mul_le_mul_left _
      (le_trans (le_of_lt (nat.mod_lt _ (pos_num.cast_pos _))) _)) _,
    suffices : 1 ≤ _, simpa using nat.mul_le_mul_left (pos a) this,
    rw [nat.le_div_iff_mul_le _ _ a.cast_pos, one_mul],
    exact le_to_nat.2 ab
  end

  @[simp] theorem gcd_to_nat : ∀ a b, (gcd a b : ℕ) = nat.gcd a b :=
  have ∀ a b : num, (a * b).nat_size ≤ a.nat_size + b.nat_size,
  begin
    intros,
    simp [nat_size_to_nat],
    rw [nat.size_le, nat.pow_add],
    exact mul_lt_mul'' (nat.lt_size_self _)
      (nat.lt_size_self _) (nat.zero_le _) (nat.zero_le _)
  end,
  begin
    intros, unfold gcd, split_ifs,
    { exact gcd_to_nat_aux h (this _ _) },
    { rw nat.gcd_comm,
      exact gcd_to_nat_aux (le_of_not_le h) (this _ _) }
  end

  theorem dvd_iff_mod_eq_zero {m n : num} : m ∣ n ↔ n % m = 0 :=
  by rw [← dvd_to_nat, nat.dvd_iff_mod_eq_zero,
    ← to_nat_inj, mod_to_nat]; refl

  instance : decidable_rel ((∣) : num → num → Prop)
  | a b := decidable_of_iff' _ dvd_iff_mod_eq_zero

end num

namespace znum

  @[simp] theorem div_to_int : ∀ n d, ((n / d : znum) : ℤ) = n / d
  | 0       0       := rfl
  | 0       (pos d) := (int.zero_div _).symm
  | 0       (neg d) := (int.zero_div _).symm
  | (pos n) 0       := (int.div_zero _).symm
  | (neg n) 0       := (int.div_zero _).symm
  | (pos n) (pos d) := (num.cast_to_znum _).trans $
    by rw ← num.to_nat_to_int; simp
  | (pos n) (neg d) := (num.cast_to_znum_neg _).trans $
    by rw ← num.to_nat_to_int; simp
  | (neg n) (pos d) := show - _ = (-_/↑d), begin
      rw [n.to_int_eq_succ_pred, d.to_int_eq_succ_pred,
        ← pos_num.to_nat_to_int, num.succ'_to_nat,
        num.div_to_nat],
      change -[1+ n.pred' / ↑d] = -[1+ n.pred' / (d.pred' + 1)],
      rw d.to_nat_eq_succ_pred
    end
  | (neg n) (neg d) := show ↑(pos_num.pred' n / num.pos d).succ' = (-_ / -↑d), begin
      rw [n.to_int_eq_succ_pred, d.to_int_eq_succ_pred,
        ← pos_num.to_nat_to_int, num.succ'_to_nat,
        num.div_to_nat],
      change (nat.succ (_/d) : ℤ) = nat.succ (n.pred'/(d.pred' + 1)),
      rw d.to_nat_eq_succ_pred
    end

  @[simp] theorem mod_to_int : ∀ n d, ((n % d : znum) : ℤ) = n % d
  | 0       d := (int.zero_mod _).symm
  | (pos n) d := (num.cast_to_znum _).trans $
    by rw [← num.to_nat_to_int, cast_pos, num.mod_to_nat,
      ← pos_num.to_nat_to_int, abs_to_nat]; refl
  | (neg n) d := (num.cast_sub' _ _).trans $
    by rw [← num.to_nat_to_int, cast_neg, ← num.to_nat_to_int,
      num.succ_to_nat, num.mod_to_nat, abs_to_nat,
      ← int.sub_nat_nat_eq_coe, n.to_int_eq_succ_pred]; refl

  @[simp] theorem gcd_to_nat (a b) : (gcd a b : ℕ) = int.gcd a b :=
  (num.gcd_to_nat _ _).trans $ by simpa

  theorem dvd_iff_mod_eq_zero {m n : znum} : m ∣ n ↔ n % m = 0 :=
  by rw [← dvd_to_int, int.dvd_iff_mod_eq_zero,
    ← to_int_inj, mod_to_int]; refl

  instance : decidable_rel ((∣) : znum → znum → Prop)
  | a b := decidable_of_iff' _ dvd_iff_mod_eq_zero

end znum


import M4R.Algebra.Ring.Ideal

namespace M4R
  namespace Ideal
    def subtype_subset [Ring α] {S : Set (Ideal α)} : S → S → Prop := fun (x y : S) => x.val ⊆ y.val
    local infix:50 " ≤ " => subtype_subset

    def of_subtype_set {s : Set α} (ss : Set ↑s) : Set α := {x | ∃ y ∈ ss, y.val = x}
    theorem of_subtype_set.subset {s : Set α} (ss : Set ↑s) : (of_subtype_set ss) ⊆ s := by
      intro _ ⟨⟨_, ys⟩, _, hyx⟩
      rw [←hyx]; exact ys

    theorem ideal_zorn [Ring α] (S : Set (Ideal α)) (h : ∀ c : Set (Ideal α), c ⊆ S →
      Zorn.Chain Subset.subset c → ∃ ub ∈ S, ∀ a ∈ c, a ⊆ ub) : ∃ m ∈ S, ∀ a ∈ S, m ⊆ a → a = m := by
        have : ∀ c : Set S, Zorn.Chain subtype_subset c → ∃ ub : S, ∀ a ∈ c, a ≤ ub := fun c hc =>
          have : Zorn.Chain Subset.subset (of_subtype_set c) := by
            intro x xc y yc hxy
            let ⟨a, ac, hax⟩ := xc
            let ⟨b, bc, hbx⟩ := yc
            have := hc a ac b bc (fun hab => hxy (by rw [←hax, ←hbx]; exact congrArg Subtype.val hab))
            rw [←hax, ←hbx]; exact this
          have ⟨ub, ubS, hub⟩ := h (of_subtype_set c) (of_subtype_set.subset c) this
          ⟨⟨ub, ubS⟩, fun ⟨a, aS⟩ ac => hub a ⟨⟨a, aS⟩, ac, rfl⟩⟩
        let ⟨⟨m, mS⟩, hm⟩ := Zorn.lemma_eq (@subtype_subset _ _ S) this
          Subset.trans (fun hab hbc => Set.elementExt (Ideal.antisymm hab hbc))
        exact ⟨m, mS, fun a as hma =>
          have := hm ⟨a, as⟩ hma
          congrArg Subtype.val this⟩

    def ideal_chain [Ring α] (S : Set (Ideal α)) (hS : Nonempty S) (hc : Zorn.Chain Subset.subset S) : Ideal α where
      subset := ⋃₀ (Set.toSetSet S Ideal.subset)
      has_zero :=
        let ⟨x, xS⟩ := Classical.choice hS
        ⟨x.subset, ⟨x, xS, rfl⟩, x.has_zero⟩
      add_closed := by
        intro a b ⟨i, ⟨I, IS, Ii⟩, ai⟩ ⟨j, ⟨J, JS, Jj⟩, bj⟩
        cases Classical.em (I = J) with
        | inl h =>
          rw [←Ii] at ai; rw [←h] at Jj; rw [←Jj] at bj
          exact ⟨I.subset, ⟨I, IS, rfl⟩, I.add_closed ai bj⟩
        | inr h =>
          cases hc I IS J JS h with
          | inl h =>
            rw [←Ii] at ai; rw [←Jj] at bj
            exact ⟨J.subset, ⟨J, JS, rfl⟩, J.add_closed (h ai) bj⟩
          | inr h =>
            rw [←Ii] at ai; rw [←Jj] at bj
            exact ⟨I.subset, ⟨I, IS, rfl⟩, I.add_closed ai (h bj)⟩
      mul_closed := by
        intro a b ⟨i, ⟨I, IS, Ii⟩, bi⟩
        rw [←Ii] at bi
        exact ⟨I.subset, ⟨I, IS, rfl⟩, I.mul_closed a bi⟩

    theorem ideal_chain_subset [Ring α] (S : Set (Ideal α)) {I : Ideal α} (IS : I ∈ S)
      (hc : Zorn.Chain Subset.subset S) : I ⊆ ideal_chain S ⟨I, IS⟩ hc :=
        fun x xI => ⟨I.subset, ⟨I, IS, rfl⟩, xI⟩

    theorem ideal_chain_proper [Ring α] (S : Set (Ideal α)) (hS : Nonempty S) (hc : Zorn.Chain Subset.subset S) :
      (∀ I ∈ S, I.proper_ideal) → (ideal_chain S hS hc).proper_ideal := by
        intro h hU
        let ⟨_, ⟨I, IS, hI⟩, hIu⟩ := is_unit_ideal.mp hU
        rw [←hI] at hIu
        exact absurd (is_unit_ideal.mpr hIu) (h I IS)

    theorem ideal_chain_disjoint [Ring α] (S : Set (Ideal α)) (hS : Nonempty S) (hc : Zorn.Chain Subset.subset S) (S' : Set α) :
      (∀ I ∈ S, Set.disjoint I.subset S') → (Set.disjoint (ideal_chain S hS hc).subset S') := by
        intro h
        apply Set.disjoint.elementwise.mpr
        intro x ⟨y, ⟨J, JS, hJy⟩, xy⟩; rw [←hJy] at xy
        exact Set.disjoint.elementwise.mp (h J JS) x xy
  end Ideal
end M4R


import .basic
import data.set

open_locale classical

namespace pregeom
namespace pullback

variables {T : Type*} {S : Type*} (f : S → T)

include f
/-- The has_cl instance for the pullback by f. -/
def has_cl_instance [has_cl T] : has_cl S := ⟨λ A, f ⁻¹' (cl (f '' A))⟩

/-- The pregeom instance for the pullback by f. -/
def pregeom_instance [pregeom T] : pregeom S :=
{
  inclusive := λ A a ha,
  begin
    change f _ ∈ cl _,
    apply inclusive,
    use a,
    simpa,
  end,
  monotone := λ A B inc a ha,
  begin
    change f _ ∈ _,
    have : f '' A ≤ f '' B, by tidy,
    apply monotone this,
    simpa,
  end,
  idempotent := λ A,
  begin
    change f ⁻¹' cl (f '' ( f ⁻¹' _) ) = f ⁻¹' _,
    tidy,
    {  replace a : f x ∈ cl (cl (f '' A)),
      { refine monotone _ a,
        tidy, },
      rwa idempotent at a, },
    {  apply inclusive,
      refine ⟨x,_,by refl⟩,
      simpa, }
  end,
  exchange := λ x y S h1 h2,
  begin
    change f y ∈ _,
    change f x ∉ _ at h2,
    change f x ∈ _ at h1,
    rw set.image_insert_eq at *,
    exact exchange h1 h2,
  end,
  finchar := λ x U hx,
  begin
    suffices : ∀ {C : finset T}, (↑C ≤ f '' U → ∃ D : finset S, finset.image f D = C ∧ ↑D ≤ U),
    { rcases finchar hx with ⟨A, h1, h2⟩,
      rcases this h1 with ⟨B, h3, h4⟩,
      refine ⟨B,h4,_⟩,
      change f x ∈ _,
      rwa [←finset.coe_image,h3], },
    refine finset.induction (by finish) _,
    { intros t E ht ind h,
      rw finset.coe_insert at h,
      have : ↑E ≤ f '' U, by {intros e he, apply h, finish},
      rcases ind this with ⟨D,h1,h2⟩,
      have : t ∈ f '' U, by {apply h, finish},
      rcases this with ⟨s,hs,rfl⟩,
      use insert s D,
      tidy, }
  end,
  ..show has_cl S, by exact has_cl_instance f
}

def pcl [has_cl T] : set S → set S := (has_cl_instance f).cl

@[simp]
lemma image_pcl [has_cl T] {A : set S} : f '' (pcl f A) = (set.range f) ∩ (cl (f '' A)) :=
begin
  change f '' (f ⁻¹' _) = _,
  rw set.image_preimage_eq_inter_range,
  finish,
end

end pullback

namespace geom
namespace pullback

variables {T : Type*} {S : Type*} (f : S → T)

include f
open function

/-- If f is injective, and T is a geometry, then the pullback by f : S → T is a geometry. -/
def geom_instance [geometry T] : injective f → geometry S := λ inj,
{
  cl_singleton := λ x,
  begin
    change f ⁻¹' _ = _,
    rw [set.image_singleton, geometry.cl_singleton],
    rw [←set.image_singleton, set.preimage_image_eq],
    assumption,
  end,
  cl_empty :=
  begin
    change f ⁻¹' _ = _,
    rw [set.image_empty, geometry.cl_empty, set.preimage_empty],
  end,
  ..show pregeom S, by exact pullback.pregeom_instance f
}

end pullback
end geom
end pregeom


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/
import order.galois_connection

/-!
# Relations

This file defines bundled relations. A relation between `α` and `β` is a function `α → β → Prop`.
Relations are also known as set-valued functions, or partial multifunctions.

## Main declarations

* `rel α β`: Relation between `α` and `β`.
* `rel.inv`: `r.inv` is the `rel β α` obtained by swapping the arguments of `r`.
* `rel.dom`: Domain of a relation. `x ∈ r.dom` iff there exists `y` such that `r x y`.
* `rel.codom`: Codomain, aka range, of a relation. `y ∈ r.codom` iff there exists `x` such that
  `r x y`.
* `rel.comp`: Relation composition. Note that the arguments order follows the `category_theory/`
  one, so `r.comp s x z ↔ ∃ y, r x y ∧ s y z`.
* `rel.image`: Image of a set under a relation. `r.image s` is the set of `f x` over all `x ∈ s`.
* `rel.preimage`: Preimage of a set under a relation. Note that `r.preimage = r.inv.image`.
* `rel.core`: Core of a set. For `s : set β`, `r.core s` is the set of `x : α` such that all `y`
  related to `x` are in `s`.
* `rel.restrict_domain`: Domain-restriction of a relation to a subtype.
* `function.graph`: Graph of a function as a relation.
-/

variables {α β γ : Type*}

/-- A relation on `α` and `β`, aka a set-valued function, aka a partial multifunction --/
@[derive complete_lattice, derive inhabited]
def rel (α β : Type*) := α → β → Prop

namespace rel

variables {δ : Type*} (r : rel α β)

/-- The inverse relation : `r.inv x y ↔ r y x`. Note that this is *not* a groupoid inverse. -/
def inv : rel β α := flip r

lemma inv_def (x : α) (y : β) : r.inv y x ↔ r x y := iff.rfl

lemma inv_inv : inv (inv r) = r := by { ext x y, reflexivity }

/-- Domain of a relation -/
def dom := {x | ∃ y, r x y}

lemma dom_mono {r s : rel α β} (h : r ≤ s) : dom r ⊆ dom s :=
λ a ⟨b, hx⟩, ⟨b, h a b hx⟩

/-- Codomain aka range of a relation -/
def codom := {y | ∃ x, r x y}

lemma codom_inv : r.inv.codom = r.dom := by { ext x y, reflexivity }

lemma dom_inv : r.inv.dom = r.codom := by { ext x y, reflexivity}

/-- Composition of relation; note that it follows the `category_theory/` order of arguments. -/
def comp (r : rel α β) (s : rel β γ) : rel α γ :=
λ x z, ∃ y, r x y ∧ s y z

local infixr ` ∘ ` := rel.comp

lemma comp_assoc (r : rel α β) (s : rel β γ) (t : rel γ δ) :
  (r ∘ s) ∘ t = r ∘ s ∘ t :=
begin
  unfold comp, ext x w, split,
  { rintros ⟨z, ⟨y, rxy, syz⟩, tzw⟩, exact ⟨y, rxy, z, syz, tzw⟩ },
  rintros ⟨y, rxy, z, syz, tzw⟩, exact ⟨z, ⟨y, rxy, syz⟩, tzw⟩
end

@[simp]
lemma comp_right_id (r : rel α β) : r ∘ @eq β = r :=
by { unfold comp, ext y, simp }

@[simp]
lemma comp_left_id (r : rel α β) : @eq α ∘ r = r :=
by { unfold comp, ext x, simp }

lemma inv_id : inv (@eq α) = @eq α :=
by { ext x y, split; apply eq.symm }

lemma inv_comp (r : rel α β) (s : rel β γ) : inv (r ∘ s) = inv s ∘ inv r :=
by { ext x z, simp [comp, inv, flip, and.comm] }

/-- Image of a set under a relation -/
def image (s : set α) : set β := {y | ∃ x ∈ s, r x y}

lemma mem_image (y : β) (s : set α) : y ∈ image r s ↔ ∃ x ∈ s, r x y :=
iff.rfl

lemma image_subset : ((⊆) ⇒ (⊆)) r.image r.image :=
λ s t h y ⟨x, xs, rxy⟩, ⟨x, h xs, rxy⟩

lemma image_mono : monotone r.image := r.image_subset

lemma image_inter (s t : set α) : r.image (s ∩ t) ⊆ r.image s ∩ r.image t :=
r.image_mono.map_inf_le s t

lemma image_union (s t : set α) : r.image (s ∪ t) = r.image s ∪ r.image t :=
le_antisymm
  (λ y ⟨x, xst, rxy⟩, xst.elim (λ xs, or.inl ⟨x, ⟨xs, rxy⟩⟩) (λ xt, or.inr ⟨x, ⟨xt, rxy⟩⟩))
  (r.image_mono.le_map_sup s t)

@[simp]
lemma image_id (s : set α) : image (@eq α) s = s :=
by { ext x, simp [mem_image] }

lemma image_comp (s : rel β γ) (t : set α) : image (r ∘ s) t = image s (image r t) :=
begin
  ext z, simp only [mem_image, comp], split,
  { rintros ⟨x, xt, y, rxy, syz⟩, exact ⟨y, ⟨x, xt, rxy⟩, syz⟩ },
  rintros ⟨y, ⟨x, xt, rxy⟩, syz⟩, exact ⟨x, xt, y, rxy, syz⟩
end

lemma image_univ : r.image set.univ = r.codom := by { ext y, simp [mem_image, codom] }

/-- Preimage of a set under a relation `r`. Same as the image of `s` under `r.inv` -/
def preimage (s : set β) : set α := r.inv.image s

lemma mem_preimage (x : α) (s : set β) : x ∈ r.preimage s ↔ ∃ y ∈ s, r x y :=
iff.rfl

lemma preimage_def (s : set β) : preimage r s = {x | ∃ y ∈ s, r x y} :=
set.ext $ λ x, mem_preimage _ _ _

lemma preimage_mono {s t : set β} (h : s ⊆ t) : r.preimage s ⊆ r.preimage t :=
image_mono _ h

lemma preimage_inter (s t : set β) : r.preimage (s ∩ t) ⊆ r.preimage s ∩ r.preimage t :=
image_inter _ s t

lemma preimage_union (s t : set β) : r.preimage (s ∪ t) = r.preimage s ∪ r.preimage t :=
image_union _ s t

lemma preimage_id (s : set α) : preimage (@eq α) s = s :=
by simp only [preimage, inv_id, image_id]

lemma preimage_comp (s : rel β γ) (t : set γ) :
  preimage (r ∘ s) t = preimage r (preimage s t) :=
by simp only [preimage, inv_comp, image_comp]

lemma preimage_univ : r.preimage set.univ = r.dom :=
by { rw [preimage, image_univ, codom_inv] }

/-- Core of a set `s : set β` w.r.t `r : rel α β` is the set of `x : α` that are related *only*
to elements of `s`. Other generalization of `function.preimage`. -/
def core (s : set β) := {x | ∀ y, r x y → y ∈ s}

lemma mem_core (x : α) (s : set β) : x ∈ r.core s ↔ ∀ y, r x y → y ∈ s :=
iff.rfl

lemma core_subset : ((⊆) ⇒ (⊆)) r.core r.core :=
λ s t h x h' y rxy, h (h' y rxy)

lemma core_mono : monotone r.core := r.core_subset

lemma core_inter (s t : set β) : r.core (s ∩ t) = r.core s ∩ r.core t :=
set.ext (by simp [mem_core, imp_and_distrib, forall_and_distrib])

lemma core_union (s t : set β) : r.core s ∪ r.core t ⊆ r.core (s ∪ t) :=
r.core_mono.le_map_sup s t

@[simp] lemma core_univ : r.core set.univ = set.univ := set.ext (by simp [mem_core])

lemma core_id (s : set α) : core (@eq α) s = s :=
by simp [core]

lemma core_comp (s : rel β γ) (t : set γ) :
  core (r ∘ s) t = core r (core s t) :=
begin
  ext x, simp [core, comp], split,
  { exact λ h y rxy z, h z y rxy },
  { exact λ h z y rzy, h y rzy z }
end

/-- Restrict the domain of a relation to a subtype. -/
def restrict_domain (s : set α) : rel {x // x ∈ s} β :=
λ x y, r x.val y

theorem image_subset_iff (s : set α) (t : set β) : image r s ⊆ t ↔ s ⊆ core r t :=
iff.intro
  (λ h x xs y rxy, h ⟨x, xs, rxy⟩)
  (λ h y ⟨x, xs, rxy⟩, h xs y rxy)

end rel

namespace function

/-- The graph of a function as a relation. -/
def graph (f : α → β) : rel α β := λ x y, f x = y

end function

namespace set

-- TODO: if image were defined with bounded quantification in corelib, the next two would
-- be definitional

lemma image_eq (f : α → β) (s : set α) : f '' s = (function.graph f).image s :=
by simp [set.image, function.graph, rel.image]

lemma preimage_eq (f : α → β) (s : set β) :
  f ⁻¹' s = (function.graph f).preimage s :=
by simp [set.preimage, function.graph, rel.preimage, rel.inv, flip, rel.image]

lemma preimage_eq_core (f : α → β) (s : set β) :
  f ⁻¹' s = (function.graph f).core s :=
 by simp [set.preimage, function.graph, rel.core]

end set


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.int.cast.lemmas
import data.nat.cast.prod

/-!
# The product of two `add_group_with_one`s.

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
-/

namespace prod

variables {α β : Type*} [add_group_with_one α] [add_group_with_one β]

instance : add_group_with_one (α × β) :=
{ int_cast := λ n, (n, n),
  int_cast_of_nat := λ _, by simp; refl,
  int_cast_neg_succ_of_nat := λ _, by simp; refl,
  .. prod.add_monoid_with_one, .. prod.add_group }

@[simp] lemma fst_int_cast (n : ℤ) : (n : α × β).fst = n := rfl

@[simp] lemma snd_int_cast (n : ℤ) : (n : α × β).snd = n := rfl

end prod


/-
Ideas about a maze game, from the Xena Discord.
-/
import tactic -- I don't even know if I need this

/-
This is an example level of a puzzle game.

AB
CD
 E

01
23
 4

Can people write computer programs in Lean which solve
levels like this?

Can people write computer programs in Python which design
levels like this?

The below is Lean 3 code.
Can stuff like this be made to work in Lean 4? I have
Lean 4 working on my laptop, it's usable, but you have
to learn the emacs interface. Is there any way to make
this easier for people wanting to transition from VS Code?
-/

/-- Solver docs : Terms of type `maze` are rooms in the game. -/
def maze := ℕ
-- Lean remarks:
-- this definition is an implementation detail.
-- This type will be made irreducible at the end.

-- Let's now make the interface for `maze`.
namespace maze

def mk (n : ℕ) : maze := n

/-- The map. Interface will be unknown to player -/
inductive can_escape : maze → Prop
| have_escaped : can_escape $ mk 4
| N1 : can_escape (mk 0) → can_escape (mk 2)
| N2 : can_escape (mk 1) → can_escape (mk 3)
| N3 : can_escape (mk 3) → can_escape (mk 4)
| S1 : can_escape (mk 2) → can_escape (mk 0)
| S2 : can_escape (mk 3) → can_escape (mk 1)
| S3 : can_escape (mk 4) → can_escape (mk 3)
| E1 : can_escape (mk 1) → can_escape (mk 0)
| E2 : can_escape (mk 3) → can_escape (mk 2)
| W1 : can_escape (mk 0) → can_escape (mk 1)
| W2 : can_escape (mk 2) → can_escape (mk 3)

@[reducible] def goal : Prop := can_escape (mk 0)
def hint : can_escape (mk 4) := can_escape.have_escaped

end maze

namespace tactic.interactive

--open maze.can_escape

open tactic

meta def n :=
`[apply maze.can_escape.N1 <|> apply maze.can_escape.N2 <|> apply maze.can_escape.N3 <|> fail "you cannot go north"]

meta def s :=
`[apply maze.can_escape.S1 <|> apply maze.can_escape.S2 <|> apply maze.can_escape.S3 <|> fail "you cannot go south"]

meta def e :=
`[apply maze.can_escape.E1 <|> apply maze.can_escape.E2 <|> fail "you cannot go east"]

meta def w :=
`[apply maze.can_escape.W1 <|> apply maze.can_escape.W2 <|> fail "you cannot go west"]

meta def out := `[apply maze.can_escape.have_escaped <|> fail "you are not at the exit"]

-- hand-generated solver
meta def xyzzy :=
`[ {s,e,s, out} <|> {s,s,out} <|> {e,s,out} <|> {s,out} <|> {out} ]

end tactic.interactive


import game.world_04_power
namespace mynat

example (P Q : Type) (p : P) (h : P → Q) : Q := begin[nat_num_game]
  exact h p,
end

example : mynat → mynat := begin[nat_num_game]
  intro p,
  exact 3 * p + 2,
end

example (P Q R S T U: Type) (p : P) (h : P → Q) (i : Q → R) (j : Q → T) (k : S → T) (l : T → U) : U := begin[nat_num_game]
  apply l ∘ j ∘ h,
  exact p,
end

example (P Q : Type) : P → (Q → P) := begin[nat_num_game]
  intros p _,
  exact p,
end

example (P Q R : Type) : (P → (Q → R)) → ((P → Q) → (P → R)) := begin[nat_num_game]
  intros f g p,
  apply f p,
  apply g p,
end

example (P Q F : Type) : (P → Q) → ((Q → F) → (P → F)) := begin[nat_num_game]
  intros g h,
  apply h ∘ g,
end

example (P Q : Type) : (P → Q) → ((Q → empty) → (P → empty)) := begin[nat_num_game]
  intros f g,
  exact g ∘ f,
end

example (A B C D E F G H I J K L : Type)
    (f1 : A → B) (f2 : B → E) (f3 : E → D) (f4 : D → A) (f5 : E → F) (f6 : F → C) (f7 : B → C) (f8 : F → G)
    (f9 : G → J) (f10 : I → J) (f11 : J → I) (f12 : I → H) (f13 : E → H) (f14 : H → K) (f15 : I → L)
    : A → L := begin[nat_num_game]
  apply f15 ∘ f11 ∘ f9 ∘ f8 ∘ f5 ∘ f2 ∘ f1,
end

end mynat


/-
Copyright (c) 2022 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/

import order.succ_pred.basic
import topology.order.basic
import topology.metric_space.metrizable_uniformity

/-!
# Instances related to the discrete topology

We prove that the discrete topology is
* first-countable,
* second-countable for an encodable type,
* equal to the order topology in linear orders which are also `pred_order` and `succ_order`,
* metrizable.

When importing this file and `data.nat.succ_pred`, the instances `second_countable_topology ℕ`
and `order_topology ℕ` become available.

-/

open order set topological_space filter

variables {α : Type*} [topological_space α]

@[priority 100]
instance discrete_topology.first_countable_topology [discrete_topology α] :
  first_countable_topology α :=
{ nhds_generated_countable := by { rw nhds_discrete, exact is_countably_generated_pure } }

@[priority 100]
instance discrete_topology.second_countable_topology_of_encodable
  [hd : discrete_topology α] [encodable α] :
  second_countable_topology α :=
begin
  haveI : ∀ (i : α), second_countable_topology ↥({i} : set α),
    from λ i, { is_open_generated_countable :=
      ⟨{univ}, countable_singleton _, by simp only [eq_iff_true_of_subsingleton]⟩, },
  exact second_countable_topology_of_countable_cover (singletons_open_iff_discrete.mpr hd)
    (Union_of_singleton α),
end

lemma bot_topological_space_eq_generate_from_of_pred_succ_order {α} [partial_order α]
  [pred_order α] [succ_order α] [no_min_order α] [no_max_order α] :
  (⊥ : topological_space α) = generate_from {s | ∃ a, s = Ioi a ∨ s = Iio a} :=
begin
  refine (eq_bot_of_singletons_open (λ a, _)).symm,
  have h_singleton_eq_inter : {a} = Iio (succ a) ∩ Ioi (pred a),
  { suffices h_singleton_eq_inter' : {a} = Iic a ∩ Ici a,
      by rw [h_singleton_eq_inter', ←Ioi_pred, ←Iio_succ],
    rw [inter_comm, Ici_inter_Iic, Icc_self a], },
  rw h_singleton_eq_inter,
  apply is_open.inter,
  { exact is_open_generate_from_of_mem ⟨succ a, or.inr rfl⟩, },
  { exact is_open_generate_from_of_mem ⟨pred a, or.inl rfl⟩, },
end

lemma discrete_topology_iff_order_topology_of_pred_succ' [partial_order α]
  [pred_order α] [succ_order α] [no_min_order α] [no_max_order α] :
  discrete_topology α ↔ order_topology α :=
begin
  refine ⟨λ h, ⟨_⟩, λ h, ⟨_⟩⟩,
  { rw h.eq_bot,
    exact bot_topological_space_eq_generate_from_of_pred_succ_order, },
  { rw h.topology_eq_generate_intervals,
    exact bot_topological_space_eq_generate_from_of_pred_succ_order.symm, },
end

@[priority 100]
instance discrete_topology.order_topology_of_pred_succ' [h : discrete_topology α] [partial_order α]
  [pred_order α] [succ_order α] [no_min_order α] [no_max_order α] :
  order_topology α :=
discrete_topology_iff_order_topology_of_pred_succ'.1 h

lemma linear_order.bot_topological_space_eq_generate_from
  {α} [linear_order α] [pred_order α] [succ_order α] :
  (⊥ : topological_space α) = generate_from {s | ∃ a, s = Ioi a ∨ s = Iio a} :=
begin
  refine (eq_bot_of_singletons_open (λ a, _)).symm,
  have h_singleton_eq_inter : {a} = Iic a ∩ Ici a,
    by rw [inter_comm, Ici_inter_Iic, Icc_self a],
  by_cases ha_top : is_top a,
  { rw [ha_top.Iic_eq, inter_comm, inter_univ] at h_singleton_eq_inter,
    by_cases ha_bot : is_bot a,
    { rw ha_bot.Ici_eq at h_singleton_eq_inter,
      rw h_singleton_eq_inter,
      apply is_open_univ, },
    { rw is_bot_iff_is_min at ha_bot,
      rw ←Ioi_pred_of_not_is_min ha_bot at h_singleton_eq_inter,
      rw h_singleton_eq_inter,
      exact is_open_generate_from_of_mem ⟨pred a, or.inl rfl⟩, }, },
  { rw is_top_iff_is_max at ha_top,
    rw ←Iio_succ_of_not_is_max ha_top at h_singleton_eq_inter,
    by_cases ha_bot : is_bot a,
    { rw [ha_bot.Ici_eq, inter_univ] at h_singleton_eq_inter,
      rw h_singleton_eq_inter,
      exact is_open_generate_from_of_mem ⟨succ a, or.inr rfl⟩, },
    { rw is_bot_iff_is_min at ha_bot,
      rw ←Ioi_pred_of_not_is_min ha_bot at h_singleton_eq_inter,
      rw h_singleton_eq_inter,
      apply is_open.inter,
      { exact is_open_generate_from_of_mem ⟨succ a, or.inr rfl⟩ },
      { exact is_open_generate_from_of_mem ⟨pred a, or.inl rfl⟩ } } },
end

lemma discrete_topology_iff_order_topology_of_pred_succ
  [linear_order α] [pred_order α] [succ_order α] :
  discrete_topology α ↔ order_topology α :=
begin
  refine ⟨λ h, ⟨_⟩, λ h, ⟨_⟩⟩,
  { rw h.eq_bot,
    exact linear_order.bot_topological_space_eq_generate_from, },
  { rw h.topology_eq_generate_intervals,
    exact linear_order.bot_topological_space_eq_generate_from.symm, },
end

@[priority 100]
instance discrete_topology.order_topology_of_pred_succ [h : discrete_topology α] [linear_order α]
  [pred_order α] [succ_order α] :
  order_topology α :=
discrete_topology_iff_order_topology_of_pred_succ.mp h

@[priority 100]
instance discrete_topology.metrizable_space [discrete_topology α] : metrizable_space α :=
begin
  unfreezingI { obtain rfl := discrete_topology.eq_bot α },
  exact @uniform_space.metrizable_space α ⊥ (is_countably_generated_principal _) _,
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johannes Hölzl
-/
import data.list.basic

universes u v w z

open nat function
variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type z}

namespace list

/- forall₂ -/

variables {r : α → β → Prop} {p : γ → δ → Prop}
open relator

mk_iff_of_inductive_prop list.forall₂ list.forall₂_iff

@[simp] theorem forall₂_cons {R : α → β → Prop} {a b l₁ l₂} :
  forall₂ R (a::l₁) (b::l₂) ↔ R a b ∧ forall₂ R l₁ l₂ :=
⟨λ h, by cases h with h₁ h₂; split; assumption, λ ⟨h₁, h₂⟩, forall₂.cons h₁ h₂⟩

theorem forall₂.imp {R S : α → β → Prop}
  (H : ∀ a b, R a b → S a b) {l₁ l₂}
  (h : forall₂ R l₁ l₂) : forall₂ S l₁ l₂ :=
by induction h; constructor; solve_by_elim

lemma forall₂.mp {r q s : α → β → Prop} (h : ∀a b, r a b → q a b → s a b) :
  ∀{l₁ l₂}, forall₂ r l₁ l₂ → forall₂ q l₁ l₂ → forall₂ s l₁ l₂
| []      []      forall₂.nil           forall₂.nil           := forall₂.nil
| (a::l₁) (b::l₂) (forall₂.cons hr hrs) (forall₂.cons hq hqs) :=
  forall₂.cons (h a b hr hq) (forall₂.mp hrs hqs)

lemma forall₂.flip : ∀{a b}, forall₂ (flip r) b a → forall₂ r a b
| _ _                 forall₂.nil          := forall₂.nil
| (a :: as) (b :: bs) (forall₂.cons h₁ h₂) := forall₂.cons h₁ h₂.flip

lemma forall₂_same {r : α → α → Prop} : ∀{l}, (∀x∈l, r x x) → forall₂ r l l
| []      _ := forall₂.nil
| (a::as) h := forall₂.cons
    (h _ (mem_cons_self _ _))
    (forall₂_same $ assume a ha, h a $ mem_cons_of_mem _ ha)

lemma forall₂_refl {r} [is_refl α r] (l : list α) : forall₂ r l l :=
forall₂_same $ assume a h, is_refl.refl _

lemma forall₂_eq_eq_eq : forall₂ ((=) : α → α → Prop) = (=) :=
begin
  funext a b, apply propext,
  split,
  { assume h, induction h, {refl}, simp only [*]; split; refl },
  { assume h, subst h, exact forall₂_refl _ }
end

@[simp, priority 900] lemma forall₂_nil_left_iff {l} : forall₂ r nil l ↔ l = nil :=
⟨λ H, by cases H; refl, by rintro rfl; exact forall₂.nil⟩

@[simp, priority 900] lemma forall₂_nil_right_iff {l} : forall₂ r l nil ↔ l = nil :=
⟨λ H, by cases H; refl, by rintro rfl; exact forall₂.nil⟩

lemma forall₂_cons_left_iff {a l u} :
  forall₂ r (a::l) u ↔ (∃b u', r a b ∧ forall₂ r l u' ∧ u = b :: u') :=
iff.intro
  (assume h, match u, h with (b :: u'), forall₂.cons h₁ h₂ := ⟨b, u', h₁, h₂, rfl⟩ end)
  (assume h, match u, h with _, ⟨b, u', h₁, h₂, rfl⟩ := forall₂.cons h₁ h₂ end)

lemma forall₂_cons_right_iff {b l u} :
  forall₂ r u (b::l) ↔ (∃a u', r a b ∧ forall₂ r u' l ∧ u = a :: u') :=
iff.intro
  (assume h, match u, h with (b :: u'), forall₂.cons h₁ h₂ := ⟨b, u', h₁, h₂, rfl⟩ end)
  (assume h, match u, h with _, ⟨b, u', h₁, h₂, rfl⟩ := forall₂.cons h₁ h₂ end)

lemma forall₂_and_left {r : α → β → Prop} {p : α → Prop} :
  ∀l u, forall₂ (λa b, p a ∧ r a b) l u ↔ (∀a∈l, p a) ∧ forall₂ r l u
| []     u := by simp only [forall₂_nil_left_iff, forall_prop_of_false (not_mem_nil _),
    imp_true_iff, true_and]
| (a::l) u := by simp only [forall₂_and_left l, forall₂_cons_left_iff, forall_mem_cons,
    and_assoc, and_comm, and.left_comm, exists_and_distrib_left.symm]

@[simp] lemma forall₂_map_left_iff {f : γ → α} :
  ∀{l u}, forall₂ r (map f l) u ↔ forall₂ (λc b, r (f c) b) l u
| []     _ := by simp only [map, forall₂_nil_left_iff]
| (a::l) _ := by simp only [map, forall₂_cons_left_iff, forall₂_map_left_iff]

@[simp] lemma forall₂_map_right_iff {f : γ → β} :
  ∀{l u}, forall₂ r l (map f u) ↔ forall₂ (λa c, r a (f c)) l u
| _ []     := by simp only [map, forall₂_nil_right_iff]
| _ (b::u) := by simp only [map, forall₂_cons_right_iff, forall₂_map_right_iff]

lemma left_unique_forall₂' (hr : left_unique r) :
  ∀{a b c}, forall₂ r a b → forall₂ r c b → a = c
| a₀ nil a₁ forall₂.nil forall₂.nil := rfl
| (a₀::l₀) (b::l) (a₁::l₁) (forall₂.cons ha₀ h₀) (forall₂.cons ha₁ h₁) :=
  hr.unique ha₀ ha₁ ▸ left_unique_forall₂' h₀ h₁ ▸ rfl

lemma left_unique_forall₂ (hr : left_unique r) : left_unique (forall₂ r) :=
⟨@left_unique_forall₂' _ _ _ hr⟩

lemma right_unique_forall₂' (hr : right_unique r) : ∀{a b c}, forall₂ r a b → forall₂ r a c → b = c
| nil a₀ a₁ forall₂.nil forall₂.nil := rfl
| (b::l) (a₀::l₀) (a₁::l₁) (forall₂.cons ha₀ h₀) (forall₂.cons ha₁ h₁) :=
  hr.unique ha₀ ha₁ ▸ right_unique_forall₂' h₀ h₁ ▸ rfl

lemma right_unique_forall₂ (hr : right_unique r) : right_unique (forall₂ r) :=
⟨@right_unique_forall₂' _ _ _ hr⟩

lemma bi_unique_forall₂ (hr : bi_unique r) : bi_unique (forall₂ r) :=
@@bi_unique.mk _ (left_unique_forall₂ hr.1) (right_unique_forall₂ hr.2)

theorem forall₂_length_eq {R : α → β → Prop} :
  ∀ {l₁ l₂}, forall₂ R l₁ l₂ → length l₁ = length l₂
| _ _ forall₂.nil          := rfl
| _ _ (forall₂.cons h₁ h₂) := congr_arg succ (forall₂_length_eq h₂)

theorem forall₂_zip {R : α → β → Prop} :
  ∀ {l₁ l₂}, forall₂ R l₁ l₂ → ∀ {a b}, (a, b) ∈ zip l₁ l₂ → R a b
| _ _ (forall₂.cons h₁ h₂) x y (or.inl rfl) := h₁
| _ _ (forall₂.cons h₁ h₂) x y (or.inr h₃) := forall₂_zip h₂ h₃

theorem forall₂_iff_zip {R : α → β → Prop} {l₁ l₂} : forall₂ R l₁ l₂ ↔
  length l₁ = length l₂ ∧ ∀ {a b}, (a, b) ∈ zip l₁ l₂ → R a b :=
⟨λ h, ⟨forall₂_length_eq h, @forall₂_zip _ _ _ _ _ h⟩,
 λ h, begin
  cases h with h₁ h₂,
  induction l₁ with a l₁ IH generalizing l₂,
  { cases length_eq_zero.1 h₁.symm, constructor },
  { cases l₂ with b l₂; injection h₁ with h₁,
    exact forall₂.cons (h₂ $ or.inl rfl) (IH h₁ $ λ a b h, h₂ $ or.inr h) }
end⟩

theorem forall₂_take {R : α → β → Prop} :
  ∀ n {l₁ l₂}, forall₂ R l₁ l₂ → forall₂ R (take n l₁) (take n l₂)
| 0 _ _ _ := by simp only [forall₂.nil, take]
| (n+1) _ _ (forall₂.nil) := by simp only [forall₂.nil, take]
| (n+1) _ _ (forall₂.cons h₁ h₂) := by simp [and.intro h₁ h₂, forall₂_take n]

theorem forall₂_drop {R : α → β → Prop} :
  ∀ n {l₁ l₂}, forall₂ R l₁ l₂ → forall₂ R (drop n l₁) (drop n l₂)
| 0 _ _ h := by simp only [drop, h]
| (n+1) _ _ (forall₂.nil) := by simp only [forall₂.nil, drop]
| (n+1) _ _ (forall₂.cons h₁ h₂) := by simp [and.intro h₁ h₂, forall₂_drop n]

theorem forall₂_take_append {R : α → β → Prop} (l : list α) (l₁ : list β) (l₂ : list β)
  (h : forall₂ R l (l₁ ++ l₂)) : forall₂ R (list.take (length l₁) l) l₁ :=
have h': forall₂ R (take (length l₁) l) (take (length l₁) (l₁ ++ l₂)),
from forall₂_take (length l₁) h,
by rwa [take_left] at h'

theorem forall₂_drop_append {R : α → β → Prop} (l : list α) (l₁ : list β) (l₂ : list β)
  (h : forall₂ R l (l₁ ++ l₂)) : forall₂ R (list.drop (length l₁) l) l₂ :=
have h': forall₂ R (drop (length l₁) l) (drop (length l₁) (l₁ ++ l₂)),
from forall₂_drop (length l₁) h,
by rwa [drop_left] at h'

lemma rel_mem (hr : bi_unique r) : (r ⇒ forall₂ r ⇒ iff) (∈) (∈)
| a b h [] [] forall₂.nil := by simp only [not_mem_nil]
| a b h (a'::as) (b'::bs) (forall₂.cons h₁ h₂) := rel_or (rel_eq hr h h₁) (rel_mem h h₂)

lemma rel_map : ((r ⇒ p) ⇒ forall₂ r ⇒ forall₂ p) map map
| f g h [] [] forall₂.nil := forall₂.nil
| f g h (a::as) (b::bs) (forall₂.cons h₁ h₂) := forall₂.cons (h h₁) (rel_map @h h₂)

lemma rel_append : (forall₂ r ⇒ forall₂ r ⇒ forall₂ r) append append
| [] [] h l₁ l₂ hl := hl
| (a::as) (b::bs) (forall₂.cons h₁ h₂) l₁ l₂ hl := forall₂.cons h₁ (rel_append h₂ hl)

lemma rel_join : (forall₂ (forall₂ r) ⇒ forall₂ r) join join
| [] [] forall₂.nil := forall₂.nil
| (a::as) (b::bs) (forall₂.cons h₁ h₂) := rel_append h₁ (rel_join h₂)

lemma rel_bind : (forall₂ r ⇒ (r ⇒ forall₂ p) ⇒ forall₂ p) list.bind list.bind :=
assume a b h₁ f g h₂, rel_join (rel_map @h₂ h₁)

lemma rel_foldl : ((p ⇒ r ⇒ p) ⇒ p ⇒ forall₂ r ⇒ p) foldl foldl
| f g hfg _ _ h _ _ forall₂.nil := h
| f g hfg x y hxy _ _ (forall₂.cons hab hs) := rel_foldl @hfg (hfg hxy hab) hs

lemma rel_foldr : ((r ⇒ p ⇒ p) ⇒ p ⇒ forall₂ r ⇒ p) foldr foldr
| f g hfg _ _ h _ _ forall₂.nil := h
| f g hfg x y hxy _ _ (forall₂.cons hab hs) := hfg hab (rel_foldr @hfg hxy hs)

lemma rel_filter {p : α → Prop} {q : β → Prop} [decidable_pred p] [decidable_pred q]
  (hpq : (r ⇒ (↔)) p q) :
  (forall₂ r ⇒ forall₂ r) (filter p) (filter q)
| _ _ forall₂.nil := forall₂.nil
| (a::as) (b::bs) (forall₂.cons h₁ h₂) :=
  begin
    by_cases p a,
    { have : q b, { rwa [← hpq h₁] },
      simp only [filter_cons_of_pos _ h, filter_cons_of_pos _ this, forall₂_cons, h₁, rel_filter h₂,
        and_true], },
    { have : ¬ q b, { rwa [← hpq h₁] },
      simp only [filter_cons_of_neg _ h, filter_cons_of_neg _ this, rel_filter h₂], },
  end

theorem filter_map_cons (f : α → option β) (a : α) (l : list α) :
  filter_map f (a :: l) = option.cases_on (f a) (filter_map f l) (λb, b :: filter_map f l) :=
begin
  generalize eq : f a = b,
  cases b,
  { rw filter_map_cons_none _ _ eq },
  { rw filter_map_cons_some _ _ _ eq },
end

lemma rel_filter_map : ((r ⇒ option.rel p) ⇒ forall₂ r ⇒ forall₂ p) filter_map filter_map
| f g hfg _ _ forall₂.nil := forall₂.nil
| f g hfg (a::as) (b::bs) (forall₂.cons h₁ h₂) :=
  by rw [filter_map_cons, filter_map_cons];
  from match f a, g b, hfg h₁ with
  | _, _, option.rel.none := rel_filter_map @hfg h₂
  | _, _, option.rel.some h := forall₂.cons h (rel_filter_map @hfg h₂)
  end

@[to_additive]
lemma rel_prod [monoid α] [monoid β]
  (h : r 1 1) (hf : (r ⇒ r ⇒ r) (*) (*)) : (forall₂ r ⇒ r) prod prod :=
rel_foldl hf h

/-- Given a relation `r`, `sublist_forall₂ r l₁ l₂` indicates that there is a sublist of `l₂` such
  that `forall₂ r l₁ l₂`. -/
inductive sublist_forall₂ (r : α → β → Prop) : list α → list β → Prop
| nil {l} : sublist_forall₂ [] l
| cons {a₁ a₂ l₁ l₂} : r a₁ a₂ → sublist_forall₂ l₁ l₂ →
  sublist_forall₂ (a₁ :: l₁) (a₂ :: l₂)
| cons_right {a l₁ l₂} : sublist_forall₂ l₁ l₂ → sublist_forall₂ l₁ (a :: l₂)

lemma sublist_forall₂_iff {l₁ : list α} {l₂ : list β} :
  sublist_forall₂ r l₁ l₂ ↔ ∃ l, forall₂ r l₁ l ∧ l <+ l₂ :=
begin
  split; intro h,
  { induction h with _ a b l1 l2 rab rll ih b l1 l2 hl ih,
    { exact ⟨nil, forall₂.nil, nil_sublist _⟩ },
    { obtain ⟨l, hl1, hl2⟩ := ih,
      refine ⟨b :: l, forall₂.cons rab hl1, cons_sublist_cons b hl2⟩ },
    { obtain ⟨l, hl1, hl2⟩ := ih,
      exact ⟨l, hl1, hl2.trans (sublist.cons _ _ _ (sublist.refl _))⟩ } },
  { obtain ⟨l, hl1, hl2⟩ := h,
    revert l₁,
    induction hl2 with _ _ _ _ ih _ _ _ _ ih; intros l₁ hl1,
    { rw [forall₂_nil_right_iff.1 hl1],
      exact sublist_forall₂.nil },
    { exact sublist_forall₂.cons_right (ih hl1) },
    { cases hl1 with _ _ _ _ hr hl _,
      exact sublist_forall₂.cons hr (ih hl) } }
end

variable {ra : α → α → Prop}

instance sublist_forall₂.is_refl [is_refl α ra] :
  is_refl (list α) (sublist_forall₂ ra) :=
⟨λ l, sublist_forall₂_iff.2 ⟨l, forall₂_refl l, sublist.refl l⟩⟩

instance sublist_forall₂.is_trans [is_trans α ra] :
  is_trans (list α) (sublist_forall₂ ra) :=
⟨λ a b c, begin
  revert a b,
  induction c with _ _ ih,
  { rintros _ _ h1 (_ | _ | _),
    exact h1 },
  { rintros a b h1 h2,
    cases h2 with _ _ _ _ _ hbc tbc _ _ y1 btc,
    { cases h1,
      exact sublist_forall₂.nil },
    { cases h1 with _ _ _ _ _ hab tab _ _ _ atb,
      { exact sublist_forall₂.nil },
      { exact sublist_forall₂.cons (trans hab hbc) (ih _ _ tab tbc) },
      { exact sublist_forall₂.cons_right (ih _ _ atb tbc) } },
    { exact sublist_forall₂.cons_right (ih _ _ h1 btc), } }
end⟩

lemma sublist.sublist_forall₂ {l₁ l₂ : list α} (h : l₁ <+ l₂) (r : α → α → Prop) [is_refl α r] :
  sublist_forall₂ r l₁ l₂ :=
sublist_forall₂_iff.2 ⟨l₁, forall₂_refl l₁, h⟩

lemma tail_sublist_forall₂_self [is_refl α ra] (l : list α) :
  sublist_forall₂ ra l.tail l :=
l.tail_sublist.sublist_forall₂ ra

end list