(** Lemmas and tactics for working with and solving goals related to
    non-membership in finite sets.  The main tactic of interest here
    is [notin_solve].

    Authors: Arthur Charguéraud and Brian Aydemir. *)

Set Implicit Arguments.
Require Import FSetInterface.

(* *********************************************************************** *)
(** * Implementation *)

Module Notin (X : FSetInterface.S).

Import X.

(* *********************************************************************** *)
(** ** Facts about set (non-)membership *)

Lemma in_singleton : forall x,
  In x (singleton x).
Proof.
  auto using singleton_2.
Qed.

Lemma notin_empty : forall x,
  ~ In x empty.
Proof.
  auto using empty_1.
Qed.

Lemma notin_union : forall x E F,
  ~ In x E -> ~ In x F -> ~ In x (union E F).
Proof.
  intros x E F H J K.
  destruct (union_1 K); intuition.
Qed.

Lemma elim_notin_union : forall x E F,
  ~ In x (union E F) -> (~ In x E) /\ (~ In x F).
Proof.
  intros x E F H. split; intros J; contradiction H.
  auto using union_2.
  auto using union_3.
Qed.

Lemma notin_singleton : forall x y,
  ~ E.eq x y -> ~ In x (singleton y).
Proof.
  intros x y H J. assert (K := singleton_1 J). intuition.
Qed.

Lemma elim_notin_singleton : forall x y,
  ~ In x (singleton y) -> ~ E.eq x y.
Proof.
  intros x y H J. contradiction H. auto using singleton_2.
Qed.

Lemma elim_notin_singleton' : forall x y,
  ~ In x (singleton y) -> x <> y.
Proof.
  intros. assert (~ E.eq x y). auto using singleton_2.
  intros J. subst. intuition.
Qed.

Lemma notin_singleton_swap : forall x y,
  ~ In x (singleton y) -> ~ In y (singleton x).
Proof.
  intros.
  assert (Q := elim_notin_singleton H).
  auto using singleton_1.
Qed.

(* *********************************************************************** *)
(** ** Rewriting non-membership facts *)

Lemma notin_singleton_rw : forall x y,
  ~ In x (singleton y) <-> ~ E.eq x y.
Proof.
  intros. split.
    auto using elim_notin_singleton.
    auto using notin_singleton.
Qed.

(* *********************************************************************** *)
(** ** Tactics *)

(** The tactic [notin_simpl_hyps] destructs all hypotheses of the form
    [(~ In x E)], where [E] is built using only [empty], [union], and
    [singleton]. *)

Ltac notin_simpl_hyps :=
  try match goal with
        | H: In ?x ?E -> False |- _ =>
          change (~ In x E) in H;
          notin_simpl_hyps
        | H: ~ In _ empty |- _ =>
          clear H;
          notin_simpl_hyps
        | H: ~ In ?x (singleton ?y) |- _ =>
          let F1 := fresh in
          let F2 := fresh in
          assert (F1 := @elim_notin_singleton x y H);
          assert (F2 := @elim_notin_singleton' x y H);
          clear H;
          notin_simpl_hyps
        | H: ~ In ?x (union ?E ?F) |- _ =>
          destruct (@elim_notin_union x E F H);
          clear H;
          notin_simpl_hyps
      end.

(** The tactic [notin_solve] solves goals of them form [(x <> y)] and
    [(~ In x E)] that are provable from hypotheses of the form
    destructed by [notin_simpl_hyps]. *)

Ltac notin_solve :=
  notin_simpl_hyps;
  repeat (progress (  apply notin_empty
                   || apply notin_union
                   || apply notin_singleton));
  solve [ trivial | congruence | intuition auto ].

(* *********************************************************************** *)
(** ** Examples and test cases *)

Lemma test_notin_solve_1 : forall x E F G,
  ~ In x (union E F) -> ~ In x G -> ~ In x (union E G).
Proof.
  intros. notin_solve.
Qed.

Lemma test_notin_solve_2 : forall x y E F G,
  ~ In x (union E (union (singleton y) F)) -> ~ In x G ->
  ~ In x (singleton y) /\ ~ In y (singleton x).
Proof.
  intros. split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_3 : forall x y,
  ~ E.eq x y -> ~ In x (singleton y) /\ ~ In y (singleton x).
Proof.
  intros. split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_4 : forall x y E F G,
  ~ In x (union E (union (singleton x) F)) -> ~ In y G.
Proof.
  intros. notin_solve.
Qed.

Lemma test_notin_solve_5 : forall x y E F,
  ~ In x (union E (union (singleton y) F)) -> ~ In y E ->
  ~ E.eq y x /\ ~ E.eq x y.
Proof.
  intros. split. notin_solve. notin_solve.
Qed.

End Notin.


Require Export CatSem.CAT.category (*functor*).

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section prod.

Variable obC: Type.
Variable morC: obC -> obC -> Type.

Class Cat_Prod (C:Cat_struct morC) := {
   product : obC -> obC -> obC;
   prl: forall a b, morC (product a b) a;
   prr: forall a b, morC (product a b) b;
   prod_mor: forall (a c d:obC) (f: morC a c)(g: morC a d),
       morC a (product c d);
   prod_mor_oid:> forall a c d,
       Proper (equiv ==> equiv ==> equiv) (@prod_mor a c d);
   prod_diag: forall (a c d: obC) (f:morC a c)(g:morC a d),
              (prod_mor f g) ;; prl c d == f /\
              (prod_mor f g) ;; prr c d == g;
   prod_mor_unique: forall (a c d:obC)
            (f:morC a c) (g:morC a d) (h':morC a (product c d)),
       h' ;; prl c d == f /\ h' ;; prr c d == g  ->
                 h' == prod_mor f g
}.

Lemma prod_prl (C : Cat_struct morC)(H:Cat_Prod C):
      forall (a c d: obC) (f:morC a c)(g:morC a d),
              (prod_mor f g) ;; prl c d == f.
Proof.
  intros;
  apply prod_diag.
Qed.

Lemma prod_prr (C:Cat_struct morC)(H:Cat_Prod C):
      forall (a c d: obC) (f:morC a c)(g:morC a d),
              (prod_mor f g) ;; prr c d == g.
Proof.
  intros;
  apply prod_diag.
Qed.

End prod.

Hint Rewrite prod_prl prod_prr : cat.
Hint Resolve prod_prl prod_prr : cat.

(** some useful constructions *)

(** given
    - [f: a -> b]
    - [g: a' -> b']
   we can have f x g: a x a' -> b x b' *)
Section prod_arrow.

Notation "a 'x' b" := (product a b) (at level 40).

Variable obC: Type.
Variable morC: obC -> obC -> Type.
Variable C: Cat_struct morC.
Variable H: Cat_Prod C.

Definition product_mor a a' b b' (f: morC a b) (g : morC a' b') :
  morC (a x a') (b x b') :=
     prod_mor (prl _ _ ;; f) (prr _ _ ;; g).

Notation "a 'X' b" := (product_mor a b) (at level 40).

Section product_mor_lemmata.

Variables a a' a'' b b' b'' c c' d e: obC.
(*
Lemma prod_mor_eq_product_mor (h:  morC (product b c) d)
                              (j: morC (product b c) e) :
 prod_mor h j == product_mor
*)

Lemma prod_mor_prod_mor (f: morC a b)(g: morC a c)
                        (h: morC (b x c) d)
                        (j: morC (b x c) e) :
  prod_mor f g ;; prod_mor h j ==
          prod_mor (prod_mor f g ;; h) (prod_mor f g ;; j).
Proof.
  intros f g h j.
  apply prod_mor_unique.
  split;
  rewrite assoc;
  cat.
Qed.

Lemma product_mor_product_mor (f: morC a a') (f': morC a' a'')
     (g: morC b b') (g': morC b' b''):
  (f ;; f') X (g ;; g') ==  f X g ;; f' X g'.
Proof.
  intros.
  unfold product_mor.
  apply hom_sym.
  apply prod_mor_unique.
  repeat rewrite assoc.
  repeat rewrite prod_prl.
  repeat rewrite prod_prr.
  repeat rewrite <- assoc.
  cat.
Qed.

Lemma product_mor_Proper:
     Proper (equiv ==> equiv ==> equiv) (@product_mor a a' b b').
Proof.
  unfold Proper;
  do 2 red.
  intros y z H' x0 y0 H0.
  unfold product_mor.
  apply prod_mor_unique.
  cat.
Qed.

Lemma product_mor_id: id a X id b == id _ .
Proof.
  unfold product_mor.
  apply hom_sym.
  apply prod_mor_unique.
  cat.
Qed.

Lemma prod_mor_product_mor (f: morC a b) (g: morC a c)
          (h: morC b b') (h': morC c c'):
  prod_mor f g ;; h X h' == prod_mor (f ;; h) (g ;; h').
Proof.
  intros f g h h'.
  unfold product_mor.
  apply prod_mor_unique.
  repeat rewrite assoc.
  rewrite prod_prl.
  rewrite prod_prr.
  repeat rewrite <- assoc.
  cat.
Qed.

End product_mor_lemmata.

End prod_arrow.

Existing Instance product_mor_Proper.

Section prod_assoc.

Variable obC: Type.
Variable morC: obC -> obC -> Type.
Variable C: Cat_struct morC.
Variable H: Cat_Prod C.

Variables a b c: obC.

Definition prod_assoc_l_r := prod_mor (prl _ _  ;; prl a b )
           (prod_mor (prl _ _ ;; prr _ _ ) (prr (product a b) c )).

Definition prod_assoc_r_l := prod_mor
        (prod_mor (prl a (product b c)) (prr _ _ ;; prl _ _  ) )
        (prr a (product b c) ;; prr b c ).

Lemma prod_assoc_r_l_l_r: prod_assoc_r_l ;; prod_assoc_l_r == id _ .
Proof.
  unfold prod_assoc_r_l,
         prod_assoc_l_r.
  rewrite prod_mor_prod_mor.
  rewrite <- assoc.
  rewrite prod_prl.
  rewrite prod_prl.
  apply hom_sym.
  apply prod_mor_unique.
  split; rewrite idl.
  repeat rewrite <- assoc;
  repeat rewrite prod_prl;
  cat.
  rewrite prod_mor_prod_mor.
  apply prod_mor_unique.
  split.
  rewrite <- assoc.
  rewrite prod_prl.
  rewrite prod_prr;
  cat.
  rewrite prod_prr.
  cat.
Qed.

Lemma prod_assoc_l_r_r_l : prod_assoc_l_r ;; prod_assoc_r_l == id _ .
Proof.
  unfold prod_assoc_r_l,
         prod_assoc_l_r.
  rewrite prod_mor_prod_mor.
  rewrite <- assoc.
  rewrite prod_prr.
  rewrite prod_prr.
  apply hom_sym.
  apply prod_mor_unique.
  split; rewrite idl.
  rewrite prod_mor_prod_mor.
  apply prod_mor_unique.
  split.
  rewrite prod_prl; cat.
  rewrite <- assoc.
  repeat rewrite prod_prr.
  cat.
  cat.
Qed.

End prod_assoc.

Hint Resolve prod_prl prod_prr : cat.
Hint Rewrite prod_prl prod_prr : cat.


Require Import ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma plusn0 n : n + 0 = n.
Proof.
  case: n.
  - done.
(* forall n : nat, S n + 0 = S n *)
  Restart.
  move: n.
  (**)
  Check nat_ind :
    forall P : nat -> Prop,
      P 0 ->
      (forall n : nat, P n -> P (S n)) ->
      forall n : nat, P n.
  (**)
  apply: nat_ind.                            (* elim の意味*)
  - done.
(* forall n : nat, n + 0 = n -> S n + 0 = S n *)
  (*
  - move=> n. rewrite /=. move=> ->. rewrite //.
  *)
  - move=> n /= -> //.
Qed.

(* 偶数の定義*)
Inductive even : nat -> Prop :=
| even_O : even O
| even_SS : forall n, even n -> even (S (S n)).

(* 帰納的述語を証明する定理*)
Theorem even_double n : even (n + n).
Proof.
  elim: n => /= [|n IH].
  - apply: even_O.
  - rewrite -plus_n_Sm.
      by apply: even_SS.
Qed.

(* 帰納的述語に対する帰納法もできる*)
Theorem even_plus m n : even m -> even n -> even (m + n).
Proof.
  elim: m => //=.
  Restart.
  move=> Hm Hn.
  elim: Hm => //= m' m'' IH.
    by apply: even_SS.
Qed.

(* 矛盾を導き出す*)
Theorem one_not_even : ~ even 1.
Proof.
  case.

  Restart.
  move H: 1 => one He.   (* move H: exp => pat はH: exp = pat を作る*)
  case: He H => //.

  Restart.
  move=> He.
  inversion He.
  Show Proof.      (* 証明が複雑で、SSReflect では様々な理由で避ける*)
Qed.

(* 等式を導き出す*)
Theorem eq_pred m n : S m = S n -> m = n.
Proof.
  case.                                     (* 等式を分解する*)
  done.
Qed.

Theorem contradict (P Q : Prop) : P -> ~P -> Q.
Proof. move=> p. elim. exact: p. Qed.

Module Odd.

  Inductive odd : nat -> Prop :=
  | odd_1 : odd 1
  | odd_SS : forall n, odd n -> odd (S (S n)).

  Theorem even_odd n : even n -> odd (S n).
  Proof.
    Check even_ind :
      forall P : nat -> Prop,
        P 0 ->
        (forall n : nat, even n -> P n -> P (S (S n))) ->
        forall n : nat, even n -> P n.
    Check (fun n => odd (S n)) : nat -> Prop.
    Check (@even_ind (fun n => odd (S n))) :
      odd 1 (* ★1 *) ->
      (forall n : nat, even n -> odd (S n) -> odd (S (S (S n)))) (* ★2 *) ->
      forall n : nat, even n -> odd (S n) (* ★3 *).
    apply: (@even_ind (fun n => odd (S n))).
    - (* 結果的に★1の命題を証明することになる模様。 *)
      by apply: odd_1.
    - (* 結果的に★2の命題を証明することになるらしい。 *)
      move=> n' Hevnn' HoddSn'.
      by apply: odd_SS.
    Restart.
    elim. (* 焦点の命題 even n (帰納的述語というらしい)についての帰納法
             こうすることにより、apply: (@even_ind (fun n => odd (S n))). を行っている模様。
             これにより、初期のゴールが証明され、代わりに2つの前提条件を証明することになる模様。
             (ここで、elim: n. とするとハマるので注意！) *)
    - (* 結果的に★1の命題を証明することになる模様。 *)
      by apply: odd_1.
    - (* 結果的に★2の命題を証明することになるらしい。 *)
      move=> n' Hevnn' HoddSn'.
      by apply: odd_SS.
  Qed.

  Theorem odd_even n : odd n -> even (S n).
  Proof.
    Check (@odd_ind (fun n => even (S n))) :
      even 2 (* ★1 *) ->
      (forall n : nat, odd n -> even (S n) -> even (S (S (S n)))) (* ★2 *) ->
      forall n : nat, odd n -> even (S n) (* ★3 *).
    elim.
    - (* ★1 *)
      by apply: (even_SS even_O).
    - (* ★2 *)
      move=> n' Hoddn' HevnSn'.
      by apply: even_SS.
  Qed.

  Theorem even_not_odd n : even n -> ~odd n.
  Proof.
    Check (@nat_ind (fun n => even n -> ~odd n)) :
      (even 0 -> ~ odd 0) (* ★1 *) ->
      (forall n : nat, (even n -> ~ odd n) -> even (S n) -> ~ odd (S n)) (* ★2 *) ->
      forall n : nat, even n -> ~ odd n (* ★3 *).
    elim: n.
    - (* ★1 *)
      move=> HevnO.
      by move/odd_even/one_not_even.
    - (* ★2 *)
      move=> n IHn HevnSn HoddSn.
      inversion HoddSn. (* SSReflectでは使用を避けないといけないタクティクを使ってしまった．．． *)
      + (* n = 0 *)
        rewrite -H0 in HevnSn.
        by move: one_not_even.
      + (* n > 0 *)
        apply odd_even in H0.
        rewrite H in H0.
        apply IHn in H0.
        (* inversion タクティクを使っても手詰まりになってきた．．． *)
    Restart.
    Check (@even_ind (fun n => ~odd n)) :
      ~ odd 0 (* ★1 *) ->
      (forall n : nat, even n -> ~ odd n -> ~ odd (S (S n))) (* ★2 *) ->
      forall n : nat, even n -> ~ odd n (* ★3 *).
    elim.
    - (* ★1 *)
      move/odd_even.
      by move: one_not_even.
    - (* ★2 *)
      move=> n' Hevnn' Hnoddn' HoddSSn'.
      inversion HoddSSn'. (* SSReflectでは使用を避けないといけないタクティクを使ってしまった．．． *)
      easy.
    (* 結果的に、この定理も elim: n. とするとハマるパターンの模様。 *)
  Qed.

End Odd.

Section SystemF.
  Definition Fand P Q := forall X : Prop, (P -> Q -> X) -> X.
  Definition For P Q := forall X : Prop, (P -> X) -> (Q -> X) -> X. (* andに見えるけどandではない。 *)
  Definition Ffalse := forall X : Prop, X. (* 何も証明を返さない *)
  Definition Ftrue := forall X : Prop, (X -> X). (* トートロジー、証明できるなら証明を返す *)
  Definition Feq T (x y : T) := forall P, P x <-> P y. (* ライプニッツの等式 *)
  Definition Fex T (P : T -> Prop) := forall X : Prop, (forall x, P x -> X) -> X.

  Theorem Fand_ok (P Q : Prop) : Fand P Q <-> P /\ Q.
  Proof.
    split => [pq | [p q] X].
    - split; by apply: pq.
    - by apply.
  Qed.

  (* 練習問題 *)
  Theorem For_ok (P Q : Prop) : For P Q <-> P \/ Q.
  Proof.
    split.
    - (* For P Q -> P \/ Q の証明 *)
      apply => [Hp | Hq].
      + (* Pが成り立つ場合 *)
        by left.
      + (* Qが成り立つ場合 *)
        by right.
    - (* For P Q <- P \/ Q の証明 *)
      case => [Hp | Hq] X Hpx Hqx.
      + (* Pが成り立つ場合 *)
        by apply: Hpx.
      + (* Qが成り立つ場合 *)
        by apply: Hqx.
  Qed.

  (* 練習問題 *)
  Theorem Ffalse_ok : Ffalse <-> False.
  Proof.
    split.
    - apply. (* これで1個目のゴールは消える。 *)
    - done. (* 2個目のゴールは自明。 *)
 (* split; last done.
    rewrite /Ffalse.
    by apply. *)
  Qed.

  (* 練習問題 *)
  Theorem Ftrue_ok : Ftrue <-> True.
  Proof.
    split.
    - by apply.
    - move=> _ X.
      by apply.
 (* split; first done. (* apply. move=> _. rewrite /Ftrue. move=> X. apply. *)
    by move=> _. *)
  Qed.

  (* SystemF は、古典論理ではなく、直観論理である点に注意 *)

  (* 練習問題 *)
  Theorem Feq_ok T (x y : T) : Feq x y <-> x = y.
  Proof.
    split.
    - (* Feq x y -> x = y の証明 *)
      (*
        rewrite /Feq.

        1 subgoal
        T : Type
        x, y : T
        ______________________________________(1/1)
        (forall P : T -> Prop, P x <-> P y) -> x = y

        1 subgoal
        T : Type
        x, y : T
        ______________________________________(1/1)
        forall _ : forall P : forall _ : T, Prop, iff (P x) (P y), eq x y

        Print eq. (* Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x *)
        Print iff. (* iff = fun A B : Prop => (A -> B) /\ (B -> A) : Prop -> Prop -> Prop *)
      *)
      move=> H.
      Check eq.
      Check eq x : T -> Prop.
      Check eq y : T -> Prop.
      Check H (eq x) : x = x <-> x = y.
      Check H (eq y) : y = x <-> y = y.
      move: (H (eq x)) => H_.
      (* ゴールが同値の場合はsplit、前提が同値の場合はcaseもしくはapply/ *)
      (* 場合1 *)
      case: H_ => H1 H2.
      by apply: H1.
      (* 場合2
      apply/H_. done. *)
   (* more: (H (eq x)) => [H' H''].
      by apply: H'. *)
    - (* Feq x y <- x = y の証明 *)
      (* move=> ->. rewrite /Feq. done. *)
      by move=> ->.
  Qed.

  (* 練習問題 *)
  Theorem Fex_ok T (P : T -> Prop) : Fex P <-> exists x, P x.
  Proof.
    split.
    rewrite /Fex.
    - (* Fex P -> exists x, P x の証明 *)
      apply.  move=> x Hpx.
      by exists x.
    - (* Fex P <- exists x, P x の証明 *)
      case. move=> x Hpx X H.
      by apply: (H x).
  Qed.

  Definition Nat := forall X : Prop, (X -> X) -> X -> X.
  Definition Zero : Nat := fun X f x => x.
  Definition Succ (N : Nat) : Nat := fun X f x => f (N X f x).
  Definition Plus (M N : Nat) : Nat := fun X f x => M X f (N X f x).
  Definition Mult (M N : Nat) : Nat := fun X f x => M X (N X f) x.

  (* 自己確認 ここから *)
  Check Succ : Nat -> Nat.
  Eval compute in (Succ Zero).
    (*  = fun (X : Prop) (f : X -> X) (x : X) => f x : Nat *)
  Eval compute in (Succ (Succ Zero)).
    (* = fun (X : Prop) (f : X -> X) (x : X) => f (f x) : Nat *)
  (* 自己確認 ここまで *)

  (* こちらの定義はより直感的*)
  Definition Plus' (M N : Nat) : Nat := M Nat Succ N. (* 1 をM 回足す*)
  Definition Mult' (M N : Nat) : Nat := M Nat (Plus' N) Zero. (* N をM 回足す*)

  (* 自己確認 ここから *)
  Check Nat : Prop.
  Check (forall X : Prop, (X -> X) -> X -> X). (* これを M とすると．．． *)
  Check (forall Nat : Prop, (Nat -> Nat) -> Nat -> Nat). (* これが (M Nat) になると思われる。 *)
  Check Succ : Nat -> Nat. (* Plus' の場合、これが (M Nat) の第1引数になると思われる。 *)
  (* 自己確認 ここまで *)

  Fixpoint Nat_of_nat n : Nat := (* 自然数をNat に変換*)
    match n with
      0   => Zero
    | S m => Succ (Nat_of_nat m)
    end.

  (* 自己確認 ここから *)
  Eval compute in Nat_of_nat 0. (* = fun (X : Prop) (_ : X -> X) (x : X) => x : Nat *)
  Eval compute in Nat_of_nat 1. (* = fun (X : Prop) (f : X -> X) (x : X) => f x : Nat *)
  Eval compute in Nat_of_nat 2. (* = fun (X : Prop) (f : X -> X) (x : X) => f (f x) : Nat *)
  (* 自己確認 ここまで *)

  (* Nat の元の等価性は適用された物を比較するべき*)
  Definition eq_Nat (M N : Nat) := forall X f x, M X f x = N X f x.
  Definition eq_Nat_fun F f := forall n,
      eq_Nat (F (Nat_of_nat n)) (Nat_of_nat (f n)).
  Definition eq_Nat_op Op op := forall m n,
      eq_Nat (Op (Nat_of_nat m) (Nat_of_nat n)) (Nat_of_nat (op m n)).

  Theorem Succ_ok : eq_Nat_fun Succ S.
  Proof.
    rewrite /eq_Nat_fun.
    (* 自己確認 ここから
      1 subgoal
      ______________________________________(1/1)
      forall n : nat, eq_Nat (Succ (Nat_of_nat n)) (Nat_of_nat (S n))

      elim.  (* n に関する帰納法となる模様。 *)

      2 subgoals
      ______________________________________(1/2)
      eq_Nat (Succ (Nat_of_nat 0)) (Nat_of_nat 1)
      ______________________________________(2/2)
      forall n : nat,
      eq_Nat (Succ (Nat_of_nat n)) (Nat_of_nat (S n)) ->
      eq_Nat (Succ (Nat_of_nat (S n))) (Nat_of_nat (S (S n)))

      Check nat_ind :
        forall P : nat -> Prop,
        P 0 ->
        (forall n : nat, P n -> P (S n)) ->
        forall n : nat, P n.
      Check (fun n => eq_Nat (Succ (Nat_of_nat n)) (Nat_of_nat (S n))) : nat -> Prop.
      Check (nat_ind (fun n => eq_Nat (Succ (Nat_of_nat n)) (Nat_of_nat (S n)))) :
        eq_Nat (Succ (Nat_of_nat 0)) (Nat_of_nat 1) (* ★1 *) ->
        (forall n : nat,
         eq_Nat (Succ (Nat_of_nat n)) (Nat_of_nat (S n)) ->
         eq_Nat (Succ (Nat_of_nat (S n))) (Nat_of_nat (S (S n)))) (* ★2 *) ->
        forall n : nat, eq_Nat (Succ (Nat_of_nat n)) (Nat_of_nat (S n)) (* ★3 *).
    自己確認 ここまで *)
    elim.
    - (* n = 0 *)
      rewrite /Succ.
      rewrite /=.
      rewrite /Succ /Zero.
      done.
    - (* n > 0 *)
      move=> n IHn.
      rewrite /=.
      done. (* IHnを使わなくても証明できる模様。 *)
    Restart.
    by elim.
  Qed. (* 実は自明*)

  Theorem Plus_ok : eq_Nat_op Plus plus.
  Proof.
    rewrite /eq_Nat_op /Plus /eq_Nat.
    move=> m n X f x.
    elim: m x.
    - (* m = 0 *)
      move=> x.
      rewrite /=.
      rewrite /Zero.
      by [].
    - (* m > 0 *)
      move=> m IH x.
      rewrite /=.
      (* 自己確認 ここから
        by rewrite /Succ -IH.  (* これだけで証明完了する模様。 *)
      自己確認 ここまで *)
      (* 自己確認 ここから
        1 subgoal
        n : nat
        X : Prop
        f : X -> X
        m : nat
        IH : forall x : X, Nat_of_nat m f (Nat_of_nat n f x) = Nat_of_nat (m + n) f x
        x : X
        ______________________________________(1/1)
        Succ (Nat_of_nat m) f (Nat_of_nat n f x) = Succ (Nat_of_nat (m + n)) f x

        Check Succ_ok : eq_Nat_fun Succ S.  (* Succ_ok の中身。 *)

        eq_Nat_fun =  (* 関数を2つもらって、命題を返す関数らしい。 *)
        fun (F : Nat -> Nat) (f : nat -> nat) =>
        forall n : nat, eq_Nat (F (Nat_of_nat n)) (Nat_of_nat (f n))
             : (Nat -> Nat) -> (nat -> nat) -> Prop

        eq_Nat_fun Succ S =  (* 関数 Succ と、関数 S を渡すと、命題が返る模様。 *)
        forall n : nat, eq_Nat (Succ (Nat_of_nat n)) (Nat_of_nat (S n))
             : Prop
      自己確認 ここまで *)
      rewrite Succ_ok.  (* 左辺の Succ (Nat_of_nat m) ... を、Nat_of_nat (S m) ... に書き換える模様。 *)
      rewrite /=.  (* これを行うと、直前で行った rewrite が元に戻ってしまう模様。 *)
      rewrite [in RHS]/Succ.
      rewrite -IH.
      (* 自己確認 ここから
        rewrite /Succ.  (* こうしてみると、左辺と右辺が等しいことが自分にもわかる。 *)
      自己確認 ここまで *)
      by [].
    Restart.
    move=> m n X f x.
    elim: m x => //= m IH x.
      by rewrite Succ_ok /= [in RHS]/Succ -IH.
  Qed.

  Theorem Mult_ok : eq_Nat_op Mult mult.
  Proof.
    rewrite /eq_Nat_op /Mult /eq_Nat.  (* これは蛇足だが、自分にとっては必要。 *)
    move=> m n X f x.
    elim: m x => //= m IH x.
    rewrite Succ_ok.
    Check Plus_ok : eq_Nat_op Plus Nat.add.
    rewrite -[in RHS]Plus_ok.
    rewrite /Plus.
    rewrite -IH.
    rewrite /=.
    Check Succ.
    rewrite /Succ.
    done.
    Restart.
    move=> m n X f x.
    elim: m x => //= m IH x.
    by rewrite -[in RHS]Plus_ok /Plus -IH.
  Qed.

  Definition Pow (M N : Nat) := fun X => N _ (M X). (* M のN 乗*)
  Fixpoint pow m n :=
    match n with
      0   => 1
    | S n => m * pow m n
    end.

  (* 自己確認 ここから
  Eval compute in (Pow (Succ (Succ Zero)) (Succ (Succ (Succ Zero)))).
  (*
     = fun (X : Prop) (x : X -> X) (x0 : X) => x (x (x (x (x (x (x (x x0)))))))
     : forall X : Prop, (X -> X) -> X -> X

  Pow (Succ (Succ Zero)) (Succ (Succ (Succ Zero)))
  = fun X => (Succ (Succ (Succ Zero))) _ ((Succ (Succ Zero)) X)
  = fun X => (fun (X' : Prop) (x : X' -> X') (x0 : X') => x (x (x x0))) _
               ((fun (X'' : Prop) (x : X'' -> X'') (x0 : X'') => x (x x0)) X)
  = fun X => (fun (X' : Prop) (x : X' -> X') (x0 : X') => x (x (x x0))) _
               (fun (x : X -> X) (x0 : X) => x (x x0))
  ここで、
    fun (x : X -> X) (x0 : X) => x (x x0)
  を
    func2
  とでもおいてみると．．．
  = fun X => (fun (x : _ -> _) (x0 : _) => x (x (x x0))) func2
  = fun X => (fun (x0 : X) => func2 (func2 (func2 x0)))
  のようになって、x : X -> X を2回適用する関数を3回適用することになり、
  2の3乗が求められるのだろうか？
  *)
     自己確認 ここまで *)

  Lemma Nat_of_nat_eq : forall n X f1 f2 x,
      (forall y, f1 y = f2 y) ->
      @Nat_of_nat n X f1 x = @Nat_of_nat n X f2 x.
  Proof.
    move=> n X f1 f2 x H.
    elim: n.
    - (* n = 0 *)
      rewrite /=.
      rewrite /Zero.
      by [].
    - (* n > 0 *)
      move=> n IHn.
      rewrite /=.
      rewrite /Succ.
      rewrite IHn.
      by apply: H.
    Restart.
    move=> n X f1 f2 x H.
    elim: n => //= n IHn.
    by rewrite /Succ IHn H.
  Qed.

  Theorem Pow_ok : eq_Nat_op Pow pow.
  Proof.
    rewrite /eq_Nat_op => m n.
    rewrite /eq_Nat => X f x.
    elim: n x.
    - (* n = 0 *)
      rewrite /=.
      rewrite /Pow.
      rewrite /Succ.
      rewrite /Zero.
      done.
    - (* n > 0 *)
      move=> n IHn x.
      rewrite /=.
      rewrite -Mult_ok.
      rewrite /Mult.
      rewrite /Pow.
      rewrite /Succ.
      rewrite /Pow in IHn.
      apply: Nat_of_nat_eq => y.
      rewrite (IHn y).
      done.
    Restart.
    rewrite /eq_Nat_op => m n.
    rewrite /eq_Nat => X f x.
    elim: n x => //= n IHn x.
    rewrite /Pow in IHn.
    rewrite -Mult_ok /Mult /Pow /Succ.
    apply: Nat_of_nat_eq => y.
    by rewrite (IHn y).
  Qed.

  Section ProdSum.                     (* 値の対と直和も定義できます*)

    Variables X Y : Prop.
    Definition Prod := forall Z : Prop, (X -> Y -> Z) -> Z.
    Definition Pair (x : X) (y : Y) : Prod := fun Z f => f x y.
    Definition Fst (p : Prod) := p _ (fun x y => x).
    Definition Snd (p : Prod) := p _ (fun x y => y).
    Definition Sum := forall Z : Prop, (X -> Z) -> (Y -> Z) -> Z.
    Definition InL x : Sum := fun Z f g => f x.
    Definition InR x : Sum := fun Z f g => g x.

  End ProdSum.

  (* 自己確認　ここから *)
  Check Prod : (Prop -> Prop -> Prop).
  (*
  Variables X Y : Prop.
  Check Prod X Y : Prop.
  *)
  Check Pair : forall X Y : Prop, X -> Y -> Prod X Y.
  Check Fst  : forall X Y : Prop, Prod X Y -> X.
  Check Snd  : forall X Y : Prop, Prod X Y -> Y.
  Check Sum  : (Prop -> Prop -> Prop).
  (*
  Variables X Y : Prop.
  Check Sum X Y : Prop.
  *)
  Check InL  : forall X Y : Prop, X -> Sum X Y.
  Check InR  : forall X Y : Prop, Y -> Sum X Y.
  (* 自己確認　ここまで *)

  Arguments Pair [X Y]. Arguments Fst [X Y]. Arguments Snd [X Y].
  Arguments InL [X] Y. Arguments InR X [Y]. (* 型引数を省略できるようにする*)

  Definition Pred (N : Nat) :=         (* 前者関数の定義は工夫が必要*)
    Fst (N _ (fun p : Prod Nat Nat => Pair (Snd p) (Succ (Snd p)))
           (Pair Zero Zero)).

  (* 自己確認　ここから *)
  Check Pred : Nat -> Nat.
  Check (Pair Zero Zero) : Prod Nat Nat.
  Check (Snd (Pair Zero Zero)) : Nat.
  Check (Succ (Snd (Pair Zero Zero))) : Nat.
  Print Nat.
  (* Nat = forall X : Prop, (X -> X) -> X -> X : Prop *)
  Eval compute in Succ Zero.
  (* = fun (X : Prop) (f : X -> X) (x : X) => f x : Nat *)
  Eval compute in Succ (Succ Zero).
  (* = fun (X : Prop) (f : X -> X) (x : X) => f (f x) : Nat *)

  Eval compute in (Pred Zero).
  (* = fun (X : Prop) (_ : X -> X) (x : X) => x : Nat *)
  Eval compute in (pred 0).
  (* = 0 : nat *)

  Eval compute in (Pred (Succ Zero)).
  (* = fun (X : Prop) (_ : X -> X) (x : X) => x : Nat *)
  Eval compute in (pred (S 0)).
  (* = 0 : nat *)

  Eval compute in (Pred (Succ (Succ Zero))).
  (* = fun (X : Prop) (f : X -> X) (x : X) => f x : Nat *)
  Eval compute in (pred (S (S 0))).
  (* = 1 : nat *)
  (* 自己確認　ここまで *)

  Theorem Pred_ok : eq_Nat_fun Pred pred.
  Proof.
    rewrite /eq_Nat_fun => n.
    elim: n.
    - (* n = 0 *)
      rewrite /Pred.
      rewrite /=.
      rewrite {1}/Zero.
      rewrite /Fst /Pair.
      done.
    - (* n > 0 *)
      move=> n IHn.
      rewrite /=.
    Restart.
    (*
      ここから、須原さんの証明を真似してみたら、証明が完了した！
      凄い！
      いきなり帰納法を適用するのではなく、下ごしらえしなければいけないのがわからなかった！
      しかも、Succの定義を展開して、相当複雑な形になったのに、IHnでrewriteできるなんて、
      とても気づかない！
    *)
    case => //= n X f x.
    rewrite /Pred.
    elim: n => //= n IHn.
    rewrite /Succ.
    rewrite -IHn.
    done.
    Restart.
    case. (* nについての場合分けらしい。 *)
    - (* n = 0 *)
      rewrite /=.
      rewrite /Pred /Zero /=.
      rewrite /Pair /=.
      rewrite /Fst /=.  (* ここまでくると、左辺と右辺が等しいことが自明になる。 *)
      done.
    - (* n > 0 *)
      rewrite /=.
      move=> n X f x.
      rewrite /Pred /=.
      elim: n.
      + (* n = 0 *)
        rewrite /=.
        rewrite /Fst /Succ /Zero /Prod /Pair /=.
        rewrite /Snd /=.  (* ここまでくると、左辺と右辺が等しいことが自明になる。 *)
        done.
      + (* n > 0 *)
        rewrite /=.
        move=> n IHn.
        rewrite [RHS]/Succ.
        rewrite -IHn.  (* 左辺と右辺が、かなりよく似た形になってきた模様。 *)

        rewrite /Fst /Succ /Prod /Snd /Pair /Zero /=.
        (*
          とても複雑な式だが、同じように見える。
        *)

        done.
  Qed.

  (* NatをSetで定義し直したNat'を作る。 *)
  Definition Nat' := forall X : Set, (X -> X) -> X -> X.
  Check Nat' : Set.
  (* ZeroをNat'で定義し直したZero'を作る。 *)
  Definition Zero' : Nat' := fun X f x => x.
  Check Zero' : Nat'.
  (* SuccをNat'で定義し直したSucc'を作る。 *)
  Definition Succ' (N : Nat') : Nat' := fun X f x => f (N X f x).
  Check Succ' : Nat' -> Nat'.
  (* Nat_of_natをNat'で定義し直したNat_of_nat'を作る。 *)
  Fixpoint Nat_of_nat' n : Nat' := (* 自然数をNat に変換*)
    match n with
      0   => Zero'
    | S m => Succ' (Nat_of_nat' m)
    end.

  (* Nat がSet で定義されているときだけ証明可能*)
  Lemma Nat_of_nat_ok : forall n, @Nat_of_nat' n _ S O = n.
  Proof.
    elim.
    - (* n = 0 *)
      rewrite /=.
      rewrite /Zero'.
      done.
    - (* n > 0 *)
      move=> n IHn.
      rewrite /=.
      rewrite /Succ'.
      rewrite IHn.
      done.
    Restart.
    elim => //= n IHn.
    by rewrite /Succ' IHn.
  Qed.

End SystemF.


(** * Perm: Basic Techniques for Comparisons and Permutations *)

(** Consider these algorithms and data structures:
    - sort a sequence of numbers
    - finite maps from numbers to (arbitrary-type) data
    - finite maps from any ordered type to (arbitrary-type) data
    - priority queues: finding/deleting the highest number in a set

    To prove the correctness of such programs, we need to reason about
    comparisons, and about whether two collections have the same
    contents.  In this chapter, we introduce some techniques for
    reasoning about:

    - less-than comparisons on natural numbers, and
    - permutations (rearrangements of lists).

    In later chapters, we'll apply these proof techniques to reasoning
    about algorithms and data structures. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** In this volume, we're going to import the definitions and theorems
    we need directly from Coq's standard library, rather than from
    chapters in Volume 1.  You should not notice much difference,
    though, because we've been careful to name our own definitions and
    theorems the same as their counterparts in the standard
    library. *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.  (* for manual grading *)
From Coq Require Export Bool.Bool.
From Coq Require Export Arith.Arith.
From Coq Require Export Arith.EqNat.
From Coq Require Export Lia.
From Coq Require Export Lists.List.
Export ListNotations.
From Coq Require Export Permutation.

(* ################################################################# *)
(** * The Less-Than Order on the Natural Numbers *)

(** In our proofs about searching and sorting algorithms, we
    often have to reason about the less-than order on natural numbers.
    Recall that the Coq standard library contains both propositional
    and Boolean less-than operators on natural numbers.  We write [x <
    y] for the proposition that [x] is less than [y]: *)

Locate "_ < _". (* "x < y" := lt x y *)
Check lt : nat -> nat -> Prop.

(** And we write [x <? y] for the computation that returns [true] or
    [false] depending on whether [x] is less than [y]: *)

Locate "_ <? _". (* x <? y  := Nat.ltb x y *)
Check Nat.ltb : nat -> nat -> bool.

(** Operation [<] is a reflection of [<?], as discussed in
    [Logic] and [IndProp]. The [Nat] module has a
    theorem showing how they relate: *)

Check Nat.ltb_lt : forall n m : nat, (n <? m) = true <-> n < m.

(** The [Nat] module contains a synonym for [lt]. *)

Print Nat.lt. (* Nat.lt = lt *)

(** For unknown reasons, [Nat] does not define [>=?] or [>?].  So we
    define them here: *)

Definition geb (n m : nat) := m <=? n.
Hint Unfold geb : core.
Infix ">=?" := geb (at level 70) : nat_scope.

Definition gtb (n m : nat) := m <? n.
Hint Unfold gtb : core.
Infix ">?" := gtb (at level 70) : nat_scope.

(* ================================================================= *)
(** ** The Lia Tactic *)

(** Reasoning about inequalities by hand can be a little painful. Luckily, Coq
    provides a tactic called [lia] that is quite helpful. *)

Theorem lia_example1:
 forall i j k,
    i < j ->
    ~ (k - 3 <= j) ->
   k > i.
Proof.
  intros.

(** The hard way to prove this is by hand. *)

  (* try to remember the name of the lemma about negation and [<=] *)
  Search (~ _ <= _ -> _).
  apply not_le in H0.
  (* try to remember the name of the transitivity lemma about [>] *)
  Search (_ > _ -> _ > _ -> _ > _).
  apply gt_trans with j.
  apply gt_trans with (k-3).
  (* Is [k] greater than [k-3]? On the integers, sure. But we're working
     with natural numbers, which truncate subtraction at zero. *)
Abort.

Theorem truncated_subtraction: ~ (forall k:nat, k > k - 3).
Proof.
  intros contra.
  (* [specialize] applies a hypothesis to an argument *)
  specialize (contra 0).
  simpl in contra.
  inversion contra.
Qed.

(** Since subtraction is truncated, does [lia_example1] actually hold?
    It does. Let's try again, the hard way, to find the proof. *)

Theorem lia_example1:
 forall i j k,
    i < j ->
    ~ (k - 3 <= j) ->
   k > i.
Proof. (* try again! *)
  intros.
  apply not_le in H0.
  unfold gt in H0.
  unfold gt.
  (* try to remember the name ... *)
  Search (_ < _ -> _ <= _ -> _ < _).
  apply lt_le_trans with j.
  apply H.
  apply le_trans with (k-3).
  Search (_ < _ -> _ <= _).
  apply lt_le_weak.
  auto.
  apply le_minus.
Qed.

(** That was tedious.  Here's a much easier way: *)

Theorem lia_example2:
 forall i j k,
    i < j ->
    ~ (k - 3 <= j) ->
   k > i.
Proof.
  intros.
  lia.
Qed.

(** Lia is a decision procedure for integer linear arithemetic.
    The [lia] tactic was made available by importing [Lia] at the
    beginning of the file.  The tactic
    works with Coq types [Z] and [nat], and these operators: [<] [=] [>]
    [<=] [>=] [+] [-] [~], as well as multiplication by small integer
    literals (such as 0,1,2,3...), and some uses of [\/], [/\], and [<->].

    Lia does not "understand" other operators.  It treats
    expressions such as [f x y] as variables.  That is, it
    can prove [f x y > a * b -> f x y + 3 >= a * b], in the same way it
    would prove [u > v -> u + 3 >= v].
*)

Theorem lia_example_3 : forall (f : nat -> nat -> nat) a b x y,
    f x y > a * b -> f x y + 3 >= a * b.
Proof.
  intros. lia.
Qed.

(* ################################################################# *)
(** * Swapping *)

(** Consider trying to sort a list of natural numbers.  As a small piece of
    a sorting algorithm, we might need to swap the first two elements of a list
    if they are out of order. *)

Definition maybe_swap (al: list nat) : list nat :=
  match al with
  | a :: b :: ar => if a >? b then b :: a :: ar else a :: b :: ar
  | _ => al
  end.

Example maybe_swap_123:
  maybe_swap [1; 2; 3] = [1; 2; 3].
Proof. reflexivity. Qed.

Example maybe_swap_321:
  maybe_swap [3; 2; 1] = [2; 3; 1].
Proof. reflexivity. Qed.

(** Applying [maybe_swap] twice should give the same result as applying it once.
    That is, [maybe_swap] is _idempotent_. *)

Theorem maybe_swap_idempotent: forall al,
    maybe_swap (maybe_swap al) = maybe_swap al.
Proof.
  intros [ | a [ | b al]]; simpl; try reflexivity.
  destruct (a >? b) eqn:H1; simpl.
  - destruct (b >? a) eqn:H2; simpl.
    + (** Now what?  We have a contradiction in the hypotheses: it
          cannot hold that [a] is less than [b] and [b] is less than
          [a].  Unfortunately, [lia] cannot immediately show that
          for us, because it reasons about comparisons in [Prop] not
          [bool]. *)
      Fail lia.
Abort.

(** Of course we could finish the proof by reasoning directly about
    inequalities in [bool].  But this situation is going to occur
    repeatedly in our study of sorting. *)

(** Let's set up some machinery to enable using [lia] on boolean
    tests. *)

(* ================================================================= *)
(** ** Reflection *)

(** The [reflect] type, defined in the standard library (and presented
    in [IndProp]), relates a proposition to a Boolean. That is,
    a value of type [reflect P b] contains a proof of [P] if [b] is
    [true], or a proof of [~ P] if [b] is [false]. *)

Print reflect.

(*
Inductive reflect (P : Prop) : bool -> Set :=
  | ReflectT :   P -> reflect P true
  | ReflectF : ~ P -> reflect P false
 *)

(** The standard library proves a theorem that says if [P] is provable
    whenever [b = true] is provable, then [P] reflects [b]. *)

Check iff_reflect : forall (P : Prop) (b : bool),
    P <-> b = true -> reflect P b.

(** Using that theorem, we can quickly prove that the propositional
    (in)equality operators are reflections of the Boolean
    operators. *)

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

Lemma gtb_reflect : forall x y, reflect (x > y) (x >? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.

Lemma geb_reflect : forall x y, reflect (x >= y) (x >=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

(** Here's an example of how you could use these lemmas.  Suppose you
    have this simple program, [(if a <? 5 then a else 2)], and you
    want to prove that it evaluates to a number smaller than 6.  You
    can use [ltb_reflect] "by hand": *)

Example reflect_example1: forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros a.
  (* The next two lines aren't strictly necessary, but they
     help make it clear what [destruct] does. *)
  assert (R: reflect (a < 5) (a <? 5)) by apply ltb_reflect.
  remember (a <? 5) as guard.
  destruct R as [H|H] eqn:HR.
  * (* ReflectT *) lia.
  * (* ReflectF *) lia.
Qed.

(** For the [ReflectT] constructor, the guard [a <? 5] must be equal
    to [true]. The [if] expression in the goal has already been
    simplified to take advantage of that fact. Also, for [ReflectT] to
    have been used, there must be evidence [H] that [a < 5] holds.
    From there, all that remains is to show [a < 5] entails [a < 6].
    The [lia] tactic, which is capable of automatically proving some
    theorems about inequalities, succeeds.

    For the [ReflectF] constructor, the guard [a <? 5] must be equal
    to [false]. So the [if] expression simplifies to [2 < 6], which is
    immediately provable by [lia]. *)

(** A less didactic version of the above proof wouldn't do the
    [assert] and [remember]: we can directly skip to [destruct]. *)

Example reflect_example1': forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros a. destruct (ltb_reflect a 5); lia.
Qed.

(** But even that proof is a little unsatisfactory. The original expression,
    [a <? 5], is not perfectly apparent from the expression [ltb_reflect a 5]
    that we pass to [destruct]. *)

(** It would be nice to be able to just say something like [destruct
    (a <? 5)] and get the reflection "for free."  That's what we'll
    engineer, next. *)

(* ================================================================= *)
(** ** A Tactic for Boolean Destruction *)

(** We're now going to build a tactic that you'll want to _use_, but
    you won't need to understand the details of how to _build_ it
    yourself.

    Let's put several of these [reflect] lemmas into a Hint database.
    We call it [bdestruct], because we'll use it in our
    boolean-destruction tactic: *)

Hint Resolve ltb_reflect leb_reflect gtb_reflect geb_reflect eqb_reflect : bdestruct.

(** Here is the tactic, the body of which you do not need to
    understand.  Invoking [bdestruct] on Boolean expression [b] does
    the same kind of reasoning we did above: reflection and
    destruction.  It also attempts to simplify negations involving
    inequalities in hypotheses. *)

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [ auto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

(** This tactic makes quick, easy-to-read work of our running example. *)

Example reflect_example2: forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros.
  bdestruct (a <? 5);  (* instead of: [destruct (ltb_reflect a 5)]. *)
  lia.
Qed.

(* ================================================================= *)
(** ** Finishing the [maybe_swap] Proof *)

(** Now that we have [bdestruct], we can finish the proof of [maybe_swap]'s
    idempotence. *)

Theorem maybe_swap_idempotent: forall al,
    maybe_swap (maybe_swap al) = maybe_swap al.
Proof.
  intros [ | a [ | b al]]; simpl; try reflexivity.
  bdestruct (a >? b); simpl.
  (** Note how [a > b] is a hypothesis, rather than [a >? b = true]. *)
  - bdestruct (b >? a); simpl.
    + (** [lia] can take care of the contradictory propositional inequalities. *)
      lia.
    + reflexivity.
  - bdestruct (a >? b); simpl.
    + lia.
    + reflexivity.
Qed.

(** When proving theorems about a program that uses Boolean
    comparisons, use [bdestruct] followed by [lia], rather than
    [destruct] followed by application of various theorems about
    Boolean operators. *)

(* ################################################################# *)
(** * Permutations *)

(** Another useful fact about [maybe_swap] is that it doesn't add or
    remove elements from the list: it only reorders them.  That is,
    the output list is a permutation of the input.  List [al] is a
    _permutation_ of list [bl] if the elements of [al] can be
    reordered to get the list [bl].  Note that reordering does not
    permit adding or removing duplicate elements. *)

(** Coq's [Permutation] library has an inductive definition of
    permutations. *)

Print Permutation.

(*
 Inductive Permutation {A : Type} : list A -> list A -> Prop :=
  | perm_nil : Permutation [] []
  | perm_skip : forall (x : A) (l l' : list A),
                Permutation l l' ->
                Permutation (x :: l) (x :: l')
  | perm_swap : forall (x y : A) (l : list A),
                Permutation (y :: x :: l) (x :: y :: l)
  | perm_trans : forall l l' l'' : list A,
                 Permutation l l' ->
                 Permutation l' l'' ->
                 Permutation l l''.
 *)

(** You might wonder, "is that really the right definition?"  And
    indeed, it's important that we get a right definition, because
    [Permutation] is going to be used in our specifications of
    searching and sorting algorithms.  If we have the wrong
    specification, then all our proofs of "correctness" will be
    useless.

    It's not obvious that this is indeed the right specification of
    permutations. (It happens to be, but that's not obvious.) To gain
    confidence that we have the right specification, let's use it
    prove some properties that permutations ought to have. *)

(** **** Exercise: 2 stars, standard (Permutation_properties)

    Think of some desirable properties of the [Permutation] relation
    and write them down informally in English, or a mix of Coq and
    English.  Here are four to get you started:

     - 1. If [Permutation al bl], then [length al = length bl].
     - 2. If [Permutation al bl], then [Permutation bl al].
     - 3. [[1;1]] is NOT a permutation of [[1;2]].
     - 4. [[1;2;3;4]] IS a permutation of [[3;4;2;1]].

   YOUR TASK: Add three more properties. Write them here: *)

(** Now, let's examine all the theorems in the Coq library about
    permutations: *)

Search Permutation.  (* Browse through the results of this query! *)

(** Which of the properties that you wrote down above have already
    been proved as theorems by the Coq library developers?  Answer
    here:

*)
(* Do not modify the following line: *)
Definition manual_grade_for_Permutation_properties : option (nat*string) := None.
(** [] *)

(** Let's use the permutation theorems in the library to prove the
    following theorem. *)

Example butterfly: forall b u t e r f l y : nat,
  Permutation ([b;u;t;t;e;r]++[f;l;y]) ([f;l;u;t;t;e;r]++[b;y]).
Proof.
  intros.
  (** Let's group [[u;t;t;e;r]] together on both sides.  Tactic
      [change t with u] replaces [t] with [u].  Terms [t] and [u] must
      be _convertible_, here meaning that they evaluate to the same
      term. *)
  change [b;u;t;t;e;r] with ([b]++[u;t;t;e;r]).
  change [f;l;u;t;t;e;r] with ([f;l]++[u;t;t;e;r]).

  (** We don't actually need to know the list elements in
      [[u;t;t;e;r]].  Let's forget about them and just remember them
      as a variable named [utter]. *)
  remember [u;t;t;e;r] as utter. clear Hequtter.

  (** Likewise, let's group [[f;l]] and remember it as a variable. *)
  change [f;l;y] with ([f;l]++[y]).
  remember [f;l] as fl. clear Heqfl.

  (** Next, let's cancel [fl] from both sides.  In order to do that,
      we need to bring it to the beginning of each list. For the right
      list, that follows easily from the associativity of [++].  *)
  replace ((fl ++ utter) ++ [b;y]) with (fl ++ utter ++ [b;y])
    by apply app_assoc.

  (** But for the left list, we can't just use associativity.
      Instead, we need to reason about permutations and use some
      library theorems. *)
  apply perm_trans with (fl ++ [y] ++ ([b] ++ utter)).
  - replace (fl ++ [y] ++ [b] ++ utter) with ((fl ++ [y]) ++ [b] ++ utter).
    + apply Permutation_app_comm.
    + rewrite <- app_assoc. reflexivity.

  - (** A library theorem will now help us cancel [fl]. *)
    apply Permutation_app_head.

  (** Next let's cancel [utter]. *)
    apply perm_trans with (utter ++ [y] ++ [b]).
    + replace ([y] ++ [b] ++ utter) with (([y] ++ [b]) ++ utter).
      * apply Permutation_app_comm.
      * rewrite app_assoc. reflexivity.
    + apply Permutation_app_head.

      (** Finally we're left with just [y] and [b]. *)
      apply perm_swap.
Qed.

(** That example illustrates a general method for proving permutations
    involving cons [::] and append [++]:

    - Identify some portion appearing in both sides.
    - Bring that portion to the front on each side using lemmas such
      as [Permutation_app_comm] and [perm_swap], with generous use of
      [perm_trans].
    - Use [Permutation_app_head] to cancel an appended head.  You can
      also use [perm_skip] to cancel a single element. *)

(** **** Exercise: 3 stars, standard (permut_example)

    Use the permutation rules in the library to prove the following
    theorem.  The following [Check] commands are a hint about useful
    lemmas.  You don't need all of them, and depending on your
    approach you will find some lemmas to be more useful than others.
    Use [Search] to find others, if you like. *)

Check perm_skip.
Check perm_trans.
Check Permutation_refl.
Check Permutation_app_comm.
Check app_assoc.
Check app_nil_r.
Check app_comm_cons.

Example permut_example: forall (a b: list nat),
  Permutation (5 :: 6 :: a ++ b) ((5 :: b) ++ (6 :: a ++ [])).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (not_a_permutation)

    Prove that [[1;1]] is not a permutation of [[1;2]].
    Hints are given as [Check] commands. *)

Check Permutation_cons_inv.
Check Permutation_length_1_inv.

Example not_a_permutation:
  ~ Permutation [1;1] [1;2].
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Correctness of [maybe_swap] *)

(** Now we can prove that [maybe_swap] is a permutation: it reorders
    elements but does not add or remove any. *)

Theorem maybe_swap_perm: forall al,
  Permutation al (maybe_swap al).
Proof.
  (* WORKED IN CLASS *)
  unfold maybe_swap.
  destruct al as [ | a [ | b al]].
  - simpl. apply perm_nil.
  - apply Permutation_refl.
  - bdestruct (a >? b).
    + apply perm_swap.
    + apply Permutation_refl.
Qed.

(** And, we can prove that [maybe_swap] permutes elements such that
    the first is less than or equal to the second. *)

Definition first_le_second (al: list nat) : Prop :=
  match al with
  | a :: b :: _ => a <= b
  | _ => True
  end.

Theorem maybe_swap_correct: forall al,
    Permutation al (maybe_swap al)
    /\ first_le_second (maybe_swap al).
Proof.
  intros. split.
  - apply maybe_swap_perm.
  - (* WORKED IN CLASS *)
    unfold maybe_swap.
    destruct al as [ | a [ | b al]]; simpl; auto.
    bdestruct (a >? b); simpl; lia.
Qed.

(* ################################################################# *)
(** * An Inversion Tactic *)

(** Coq's [inversion H] tactic is so good at extracting
    information from the hypothesis [H] that [H] sometimes becomes
    completely redundant, and one might as well [clear] it from the
    goal.  Then, since the [inversion] typically creates some equality
    facts, why not [subst]?  Tactic [inv] does just that. *)

Ltac inv H := inversion H; clear H; subst.

(** **** Exercise: 3 stars, standard (Forall_perm) *)

(** [Forall] is Coq library's version of the [All] proposition defined
    in [Logic], but defined as an inductive proposition rather
    than a fixpoint.  Prove this lemma by induction.  You will need to
    decide what to induct on: [al], [bl], [Permutation al bl], and
    [Forall f al] are possibilities. *)

Theorem Forall_perm: forall {A} (f: A -> Prop) al bl,
  Permutation al bl ->
  Forall f al -> Forall f bl.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Summary: Comparisons and Permutations *)

(** To prove correctness of algorithms for sorting and searching,
    we'll reason about comparisons and permutations using the tools
    developed in this chapter.  The [maybe_swap] program is a tiny
    little example of a sorting program.  The proof style in
    [maybe_swap_correct] will be applied (at a larger scale) in
    the next few chapters. *)

(* 2022-08-08 17:36 *)


Require Import FP.Core.
Require Import FP.Data.List.
Require Import FP.Data.Product.
Require Import FP.Classes.Lattice.
Require Import FP.Classes.Monad.

Inductive member {A:qtype} : dom A -> dom (list A) -> Prop :=
  | HeadMember : forall x y xs, x ≃ y -> member y (x∷xs)
  | TailMember : forall x x' xs, member x xs -> member x (x'∷xs).
Infix "∈" := member.
Notation "x ∉ xs" := (not (x ∈ xs)).

Inductive subset {A:qtype} : relation (dom (list A)) :=
  | NullPermutation : forall ys, subset nil ys
  | ConsPermutation : forall x xs ys, x ∈ ys -> subset xs ys -> subset (x∷xs) ys.
Infix "⊆" := subset (at level 50, no associativity).

Inductive unique {A:qtype} : dom (list A) -> Prop :=
  | NullUnique : unique nil
  | ConsUnique : forall x xs, x ∉ xs -> unique xs -> unique (x∷xs).

Definition equiv {A} (xs ys:dom (list A)) := xs ⊆ ys /\ ys ⊆ xs.

Inductive v_listSet A := v_ListSet
  { v_listSetData : dom (list A)
  ; v_listSetUnique : unique v_listSetData
  }.
Arguments v_ListSet {A} _ _.
Arguments v_listSetData {A} _.
Arguments v_listSetUnique {A} _.

Instance : forall A, Eqv (dom A) -> Eqv (v_listSet A) :=
  { eqv xs ys := equiv (v_listSetData xs) (v_listSetData ys) }.
Admitted.

Instance : forall A, Lte (dom A) -> Lte (v_listSet A) :=
  { lte xs ys := subset (v_listSetData xs) (v_listSetData ys) }.
Admitted.

Definition listSet (A:qtype) : qtype := {| qdom := v_listSet A |}.

Definition sempty {A} : dom (listSet A) := undefined.
Definition sinsert {A} : dom (A ⇒ listSet A ⇒ listSet A) := undefined.
Definition siter {A B} : dom (listSet A ⇒ (A ⇒ B) ⇒ (B ⇒ B ⇒ B) ⇒ B) := undefined.
Definition sjoins {A B} `{! Lattice B } : dom (listSet A ⇒ (A ⇒ B) ⇒ B) := λ xs f →
  siter ∙ xs ∙ f ∙ join.
Definition ssingleton {A} : dom (A ⇒ listSet A) := λ x → sinsert ∙ x ∙ sempty.

Instance : forall A, Lattice (listSet A).
Admitted.
Instance : Monad listSet.
Admitted.
Instance : MonadPlus listSet.
Admitted.


(* homework11_\u8d75\u5b81_10151590121_1216 *)Set Warnings "-notation-overridden,-parsing".
Add LoadPath "coq/coq_project".Require Export IndProp.Require Export Rel.(* 1 *)(** **** Exercise: 2 stars, optional (le_antisymmetric)  *)Theorem le_antisymmetric :  antisymmetric le.Proof.
  unfold antisymmetric.
  intros a b Ha Hb.
  inversion Ha as [| m H'].
  - reflexivity.
  - Print le_trans.
    assert(S m <= m). {
    apply le_trans with a.
    rewrite H.
    + assumption.
    + assumption. }
    apply le_Sn_n in H0.
    inversion H0.
Qed. (* 2 *)(** **** Exercise: 2 stars, optional (le_step)  *)Theorem le_step : forall n m p,  n < m ->  m <= S p ->  n <= p.Proof.  intros n m p Hnm Hmp. Print lt. unfold lt in Hnm.  assert (S n <= S p).  {    apply le_trans with m.     - assumption.    - assumption.  }  apply le_S_n.  assumption.Qed.(* 3 *)(** **** Exercise: 2 stars, optional (rsc_trans)  *)Lemma rsc_trans :  forall (X:Type) (R: relation X) (x y z : X),      clos_refl_trans_1n R x y  ->      clos_refl_trans_1n R y z ->      clos_refl_trans_1n R x z.Proof.  intros X R  x y z Hxy Hyz.
  induction Hxy as [x| x y y' Rxy Hyy].
  - assumption.
  - apply rt1n_trans with y.
    + assumption.
    + apply IHHyy in Hyz. apply Hyz.Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** ** Matric computation *)

Require Import Arith Omega Eqdep_dec ZArith.

Require Import utils_tac gcd prime binomial sums.

Set Implicit Arguments.

Section rings.

  Variable (R : Type) (Rzero Rone : R) (Rplus Rmult Rminus : R -> R -> R) (Ropp : R -> R)
           (R_is_ring : ring_theory Rzero Rone Rplus Rmult Rminus Ropp eq).

  Infix "⊕" := Rplus (at level 50, left associativity).
  Infix "⊗" := Rmult (at level 40, left associativity).

  Notation z := Rzero.
  Notation o := Rone.
  Notation "∸" := Ropp.

  (* ⊕  ⊗  ∸ *)

  (* We use the magical parameterized ring tactic *)

  Add Ring Rring : R_is_ring.

  (* ⊕  ⊗  ∸ *)

  (*   ( a b )   <-> (a,b,c,d)
       ( c d )                    *)

  Definition M22 := (R * R * R * R)%type.
  Definition ID_22 : M22 := (o,z,z,o).
  Definition ZE_22 : M22 := (z,z,z,z).

  Definition PL22 : M22 -> M22 -> M22.
  Proof.
    intros (((a,b),c),d) (((a',b'),c'),d').
    exact (a⊕a',b⊕b',
           c⊕c',d⊕d').
  Defined.

  Infix "⊞" := PL22 (at level 50, left associativity).

  Definition MI22 : M22 -> M22.
  Proof.
    intros (((a,b),c),d).
    exact (∸a,∸b,
           ∸c,∸d).
  Defined.

  Notation "⊟" := MI22.

  Fact M22_equal (a b c d a' b' c' d' : R) : a = a' -> b = b' -> c = c' -> d = d' -> (a,b,c,d) = (a',b',c',d').
  Proof. intros; subst; trivial. Qed.

  Fact M22plus_zero : forall m, ZE_22 ⊞ m = m.
  Proof.
    intros (((a,b),c),d); apply M22_equal; ring.
  Qed.

  Fact M22plus_comm  : forall x y, x ⊞ y = y ⊞ x.
  Proof.
    intros (((a,b),c),d) (((a',b'),c'),d'); apply M22_equal; ring.
  Qed.

  Fact M22plus_assoc  : forall x y u, x ⊞ (y ⊞ u) = x ⊞ y ⊞ u.
  Proof.
    intros (((a,b),c),d) (((a',b'),c'),d') (((a'',b''),c''),d''); simpl; apply M22_equal; ring.
  Qed.

  Fact M22minus : forall x, x ⊞ ⊟ x = ZE_22.
  Proof.
    intros (((a,b),c),d); apply M22_equal; ring.
  Qed.

  Fact M22plus_cancel : forall x a b, x ⊞ a = x ⊞ b -> a = b.
  Proof.
    intros x a b H.
    rewrite <- (M22plus_zero a), <- (M22minus x), (M22plus_comm x),
            <- M22plus_assoc, H, M22plus_assoc,
            (M22plus_comm _ x), M22minus, M22plus_zero.
    trivial.
  Qed.

  Theorem M22plus_monoid : monoid_theory PL22 ZE_22.
  Proof.
    exists.
    + apply M22plus_zero.
    + intro; rewrite M22plus_comm; apply M22plus_zero.
    + intros; apply M22plus_assoc.
  Qed.

  Definition MU22 : M22 -> M22 -> M22.
  Proof.
    intros (((a,b),c),d) (((a',b'),c'),d').
    exact (a⊗a' ⊕ b⊗c' , a⊗b' ⊕ b⊗d',
           c⊗a' ⊕ d⊗c' , c⊗b' ⊕ d⊗d' ).
  Defined.

  Infix "⊠" := MU22 (at level 40, left associativity).

  Tactic Notation "myauto" integer(n) := do n intros (((?&?)&?)&?); apply M22_equal; ring.

  Fact M22mult_one_l : forall x, ID_22 ⊠ x = x.
  Proof. myauto 1. Qed.

  Fact M22mult_one_r : forall x, x ⊠ ID_22 = x.
  Proof. myauto 1. Qed.

  Fact M22mult_assoc : forall x y u, x ⊠ (y ⊠ u) = x ⊠ y ⊠ u.
  Proof. myauto 3. Qed.

  Fact M22_mult_distr_l : forall x y u, x ⊠ (y⊞u) = x⊠y ⊞ x⊠u.
  Proof. myauto 3. Qed.

  Fact M22_mult_distr_r : forall x y u, (y⊞u) ⊠ x = y⊠x ⊞ u⊠x.
  Proof. myauto 3. Qed.

  Theorem M22mult_monoid : monoid_theory MU22 ID_22.
  Proof.
    exists.
    + apply M22mult_one_l.
    + apply M22mult_one_r.
    + apply M22mult_assoc.
  Qed.

  Fact M22_opp_mult_l : forall x y, (⊟ x) ⊠ y = ⊟ (x ⊠ y).
  Proof. myauto 2. Qed.

  Fact M22_opp_mult_r : forall x y, x ⊠ (⊟y) = ⊟ (x ⊠ y).
  Proof. myauto 2. Qed.

  Definition M22scal (k : R) : M22 -> M22.
  Proof.
    intros (((u,v),w),z).
    exact (k⊗u,k⊗v,k⊗w,k⊗z).
  Defined.

  Fact M22scal_mult k1 k2 : forall x, M22scal k1 (M22scal k2 x) = M22scal (k1⊗k2) x.
  Proof. myauto 1. Qed.

  Fact M22scal_PL22 k : forall x y, M22scal k (x ⊞ y) = M22scal k x ⊞ M22scal k y.
  Proof. myauto 2. Qed.

  Fact M22scal_MI22 : forall x, M22scal (∸o) x = ⊟x.
  Proof. myauto 1. Qed.

  Fact M22scal_zero : forall x, M22scal z x = ZE_22.
  Proof. myauto 1. Qed.

  Fact M22scal_MU22_l k : forall x y, M22scal k (x ⊠ y) = M22scal k x ⊠ y.
  Proof. myauto 2. Qed.

  Fact M22scal_MU22_r k : forall x y, M22scal k (x ⊠ y) = x ⊠ M22scal k y.
  Proof. myauto 2. Qed.

  Fact mscal_M22scal n x : mscal PL22 ZE_22 n x = M22scal (mscal Rplus Rzero n Rone) x.
  Proof.
    induction n as [ | n IHn ].
    + do 2 rewrite mscal_0; revert x; myauto 1.
    + do 2 rewrite mscal_S.
      rewrite IHn; clear IHn.
      revert x; myauto 1.
  Qed.

  (* M22 is NOT a ring because mult is not commutative *)

  (* ⊕  ⊗  ∸    ⊞ ⊠ ⊟ *)

  Definition Det22 : M22 -> R.
  Proof.
    intros (((a,b),c),d).
    exact (a⊗d ⊕ ∸(b⊗c)).
  Defined.

  Fact Det22_scal k : forall x, Det22 (M22scal k x) = (k ⊗ k) ⊗ Det22 x.
  Proof. intros (((?,?),?),?); simpl; ring. Qed.

  Fact Det22_mult : forall x y, Det22 (x⊠y) = Det22 x ⊗ Det22 y.
  Proof. intros (((?,?),?),?) (((?,?),?),?); simpl; ring. Qed.

  Notation expo22 := (mscal MU22 ID_22).
  Notation expoR := (mscal Rmult o).

  Fact expo22_scal k n U : expo22 n (M22scal k U) = M22scal (expoR n k) (expo22 n U).
  Proof.
    induction n as [ | n IHn ].
    + do 3 rewrite mscal_0; apply M22_equal; ring.
    + do 3 rewrite mscal_S.
      rewrite IHn.
      rewrite <- M22scal_MU22_l, <- M22scal_MU22_r.
      rewrite M22scal_mult; auto.
  Qed.

  Fact Det22_expo n x : Det22 (expo22 n x) = expoR n (Det22 x).
  Proof.
    induction n as [ | n IHn ].
    + do 2 rewrite mscal_0; simpl; ring.
    + do 2 rewrite mscal_S.
      rewrite Det22_mult, IHn; ring.
  Qed.

  Fact Diag22_expo n x y : expo22 n (x,z,z,y) = (expoR n x,Rzero,Rzero,expoR n y).
  Proof.
    induction n as [ | n IHn ]; try (simpl; auto; fail).
    do 3 rewrite mscal_S; rewrite IHn.
    apply M22_equal; ring.
  Qed.

  Fact MU22_Diag22 a b c d x y : (a,b,c,d) ⊠ (x,z,z,y) = (a⊗x,b⊗y,c⊗x,d⊗y).
  Proof. apply M22_equal; ring. Qed.

  (* We also the to lift the Z -> Zp morphism to M22 matrices *)

  Fact M22_proj12 a1 b1 c1 d1 a2 b2 c2 d2 : (a1,b1,c1,d1) = (a2,b2,c2,d2) :> M22 -> c1 = c2.
  Proof. inversion 1; auto. Qed.

End rings.

Section ring_morphism.

  Variable (X : Type) (zX oX : X) (pX mX : X -> X -> X) (oppX : X -> X)
           (Y : Type) (zY oY : Y) (pY mY : Y -> Y -> Y) (oppY : Y -> Y).

  Variable phi : X -> Y.

  Notation "〚 x 〛" := (phi x).

  Record ring_morphism : Prop := mk_ring_morph {
    morph_z : 〚 zX 〛= zY;
    morph_o : 〚 oX 〛= oY;
    morph_plus : forall x y, 〚 pX x y 〛= pY 〚 x 〛〚 y 〛;
    morph_mult : forall x y, 〚 mX x y 〛= mY 〚 x 〛〚 y 〛;
    morph_opp : forall x, 〚 oppX x 〛= oppY 〚 x 〛;
  }.

  Hypothesis Hphi : ring_morphism.

  Definition morph22 : M22 X -> M22 Y.
  Proof.
    intros (((a,b),c),d).
    exact (〚 a 〛, 〚 b 〛,
           〚 c 〛, 〚 d 〛).
  Defined.

  Tactic Notation "myauto" integer(n) := do n intros (((?&?)&?)&?); apply M22_equal; ring.

  Fact PL22_morph : forall x y, morph22 (PL22 pX x y) = PL22 pY (morph22 x) (morph22 y).
  Proof.
    destruct Hphi.
    do 2 intros (((?&?)&?)&?); apply M22_equal; auto.
  Qed.

  Fact MU22_morph : forall x y, morph22 (MU22 pX mX x y) = MU22 pY mY (morph22 x) (morph22 y).
  Proof.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    do 2 intros (((?&?)&?)&?); apply M22_equal;
      repeat rewrite G3; repeat rewrite G4; auto.
  Qed.

  Fact MI22_morph : forall x, morph22 (MI22 oppX x) = MI22 oppY (morph22 x).
  Proof.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    do 1 intros (((?&?)&?)&?); apply M22_equal;
      repeat rewrite G3; repeat rewrite G4; auto.
  Qed.

  Fact M22scal_morph : forall k x, morph22 (M22scal mX k x) = M22scal mY 〚 k 〛 (morph22 x).
  Proof.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    intros k (((?&?)&?)&?); apply M22_equal; auto.
  Qed.

  Fact Det22_morph : forall x, 〚 Det22 pX mX oppX x 〛= Det22 pY mY oppY (morph22 x).
  Proof.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    intros (((?&?)&?)&?); simpl.
    rewrite G3, G6, G4, G4; auto.
  Qed.

  Fact expo22_morph n x : morph22 (mscal (MU22 pX mX) (ID_22 zX oX) n x)
                        = mscal (MU22 pY mY) (ID_22 zY oY) n (morph22 x).
  Proof.
    destruct Hphi as [ G1 G2 G3 G4 G6 ].
    induction n as [ | n IHn ].
    + do 2 rewrite mscal_0; apply M22_equal; auto.
    + do 2 rewrite mscal_S.
      rewrite MU22_morph, IHn; auto.
  Qed.

End ring_morphism.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                   Solange Coupet-Grimal & Line Jakubiec                  *)
(*                                                                          *)
(*                                                                          *)
(*              Laboratoire d'Informatique de Marseille                     *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lim.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              May 30th 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                          Dependent_lists.v                               *)
(****************************************************************************)

Require Export Eqdep.
Require Export Arith.

Global Set Asymmetric Patterns.
Section Dependent_lists.

  Variable A : Set.

  Inductive list : nat -> Set :=
    | nil : list 0
    | cons : forall n : nat, A -> list n -> list (S n).

  Definition eq_list := eq_dep nat list.

  Definition hd (n : nat) (l : list n) : Exc A :=
    match l in (list m) return (Exc A) with
    | nil => error
    | cons p a l' => value a
    end.

  Definition head (n : nat) (l : list n) :=
    match l in (list p) return (0 < p -> A) with
    | nil =>
        (* nil*)
        fun h : 0 < 0 => False_rec A (lt_irrefl 0 h)
        (*cons p a l' *)
    | cons p a l' => fun h : 0 < S p => a
    end.

  Definition Head (n : nat) (l : list (S n)) := head (S n) l (lt_O_Sn n).

  Definition tl (n : nat) (l : list n) : list (pred n) :=
    match l in (list m) return (list (pred m)) with
    | nil => nil
    | cons p a l' => l'
    end.

  Lemma empty_dep : forall (n : nat) (l : list n), n = 0 -> eq_list 0 nil n l.
  unfold eq_list in |- *; intros n l.
  dependent inversion_clear l; auto.
  intros H; absurd (S n0 = 0); auto.
  Qed.

  Hint Resolve empty_dep.

  Lemma empty : forall l : list 0, nil = l.
  intros l.
  apply (eq_dep_eq nat list 0).
  apply empty_dep; auto.
  Qed.

  Hint Resolve empty.

  Remark non_empty_dep :
   forall n m : nat,
   m = S n ->
   forall l : list (S n),
   {h : A &  {t : list n | eq_list (S n) l (S n) (cons n h t)}}.
  intros n m H l.
  generalize H; clear H.
  dependent inversion_clear l
   with
    (fun (n' : nat) (l : list n') =>
     m = n' -> {a : A &  {l' : list n | eq_list n' l (S n) (cons n a l')}}).
  unfold eq_list in |- *.
  intros H; exists a; exists l0; auto.

  Defined.

  Lemma non_empty :
   forall (n : nat) (l : list (S n)),
   {a : A &  {t : list n | l = cons n a t}}.
  intros n l.
  cut
   (sigS
      (fun a : A =>
       sig (fun t : list n => eq_list (S n) l (S n) (cons n a t)))).
  intros H; elim H; clear H.
  intros a H; elim H; clear H.
  intros t H.
  exists a; exists t.
  apply eq_dep_eq with (U := nat) (P := list) (p := S n).
  unfold eq_list in H; auto.
  apply (non_empty_dep n (S n)); auto.
  Defined.

  Lemma split_list :
   forall (n : nat) (l : list (S n)),
   l = cons n (head (S n) l (lt_O_Sn n)) (tl (S n) l).
  intros n l.
  elim (non_empty n l).
  intros h H; elim H; clear H.
  intros t e.
  rewrite e; simpl in |- *.
  auto.
  Qed.

  Definition Hd (n : nat) (l : list (S n)) :=
    let (a, P) return A := non_empty n l in a.

  Lemma Non_empty_Hd :
   forall (n : nat) (a : A) (l : list n), Hd n (cons n a l) = a.
  intros n a l; unfold Hd in |- *.
  elim (non_empty n (cons n a l)).
  intros x H; elim H.
  clear H; intros X H.
  injection H; auto.
  Qed.

End Dependent_lists.

Hint Resolve empty_dep empty non_empty Non_empty_Hd.

Fixpoint map (A B : Set) (f : A -> B) (n : nat) (l : list A n) {struct l} :
 list B n :=
  match l in (list _ x) return (list B x) with
  | nil =>
      (*(nil A)*)  nil B
      (*(cons A p a t*)
  | cons p a t => cons B p (f a) (map A B f p t)
  end.

(**********************************************************************)


(* This file is part of the Linear Logic  formalization in Coq: https://github.com/meta-logic/coq-ll *)

(** ** Sets, Decidable Sets and Polarities
*)

Require Import PeanoNat.

(** Just a set *)

Module Type Eqset.
  Parameter A : Type.
End Eqset.

(** A set with decidable equality
 *)
Module Type Eqset_dec <: Eqset.
  Parameter A : Type.
  Parameter eqA_dec : forall x y : A, {x = y} + {x <> y}.
End Eqset_dec.

(** A set with decidable equality and a function defining which atoms are positive
 *)

Module Type Eqset_dec_pol <: Eqset_dec.
  Parameter A : Type.
  Parameter eqA_dec : forall x y : A, {x = y} + {x <> y}.
  Parameter isPositive : nat -> bool.
End Eqset_dec_pol.

(** An example of Eqset_dec_pol *)
Module NatSet <: Eqset_dec_pol.
  Definition A := nat.
  Definition eqA_dec := Nat.eq_dec.
  Fixpoint isPositive (n:nat) :=
    match n with
    | 0%nat => false
    | 1%nat => true
    | S (S n) => isPositive n
    end.
End NatSet.


Require Import ZF ZFnats.

(***************************************************************************)
(* Elementary inductive types: *)

Definition UNIT := succ zero.
Lemma unit_typ : zero ∈ UNIT.
unfold UNIT.
apply succ_intro1.
reflexivity.
Qed.

Lemma unit_elim : forall p, p ∈ UNIT -> p == zero.
unfold UNIT; intros.
elim le_case with (1:=H); intros; trivial.
elim empty_ax with p; trivial.
Qed.

Definition BOOL := succ (succ zero).
Definition TRUE := zero.
Definition FALSE := succ zero.

Lemma true_typ : TRUE ∈ BOOL.
unfold TRUE, BOOL.
apply succ_intro2.
apply succ_intro1.
reflexivity.
Qed.

Lemma false_typ : FALSE ∈ BOOL.
unfold FALSE, BOOL.
apply succ_intro1.
reflexivity.
Qed.

Lemma bool_elim : forall b, b ∈ BOOL -> b == TRUE \/ b == FALSE.
unfold BOOL, TRUE, FALSE; intros.
elim le_case with (1:=H); intros; auto.
elim le_case with (1:=H0); intros; auto.
elim empty_ax with (1:=H1).
Qed.

Definition EQ A x y :=
  cond_set (x ∈ A /\ x == y) (singl empty).

Instance EQ_morph : Proper (eq_set ==> eq_set ==> eq_set ==> eq_set) EQ.
do 4 red; intros.
unfold EQ.
rewrite H; rewrite H0; rewrite H1; reflexivity.
Qed.

Definition REFL := empty.

Lemma refl_typ : forall A x, x ∈ A -> REFL ∈ EQ A x x.
unfold EQ, REFL; intros.
apply subset_intro; auto with *.
apply singl_intro.
Qed.

(* Rk: this property implies K (p ∈ EQ A x x -> p == REFL) *)
Lemma EQ_elim : forall A x y p,
  p ∈ EQ A x y -> x ∈ A /\ x == y /\ p == REFL.
unfold EQ; intros.
rewrite cond_set_ax in H; destruct H.
apply singl_elim in H.
destruct H0; auto.
Qed.

Lemma EQ_ind : forall A P,
  Proper (eq_set ==> eq_set ==> iff) P ->
  forall x y p, P x REFL -> p ∈ EQ A x y -> P y p.
intros.
apply EQ_elim in H1.
revert H0; apply H.
 symmetry; apply H1.
 apply H1.
Qed.


Require Import Relations.
Require Import Setoid.

(* Module is a mere abelian group,with operation add,neg. *)

Class Module
{T:Set}
(eqT:T->T->Prop)
(addT:T->T->T)
(negT:T->T)
(zeroT:T)
:=
{
equivT:Equivalence eqT
;well_addT:forall a1 a2 b1 b2:T,
eqT a1 a2->eqT b1 b2->
eqT(addT a1 b1)(addT a2 b2)
;well_negT:forall a1 a2:T,
eqT a1 a2->eqT(negT a1)(negT a2)
;comm_addT:forall a b:T,
eqT(addT a b)(addT b a)
;add_0:forall a:T,
eqT(addT a zeroT)a
;add_neg:forall a:T,
eqT(addT a (negT a))zeroT
;assoc_addT:forall a b c:T,
eqT (addT(addT a b)c)(addT a (addT b c))
}.

Print Equivalence.
Print Equivalence_Reflexive.
Print Reflexive.
Add Parametric Relation
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
(Mod:Module eqT addT negT zeroT):
T (eqT:T->T->Prop)
 reflexivity proved by (@Equivalence_Reflexive _ _ equivT)
 symmetry proved by (@Equivalence_Symmetric _ _ equivT)
 transitivity proved by (@Equivalence_Transitive _ _ equivT)
 as T_setoid.

Record Morph
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
(MA:Module eqA addA negA zeroA)
(MB:Module eqB addB negB zeroB):=
mkMorph
{
func:TA->TB
;map_0:eqB (func zeroA)zeroB
;map_hom_add:forall a1 a2:TA,
eqB(func (addA a1 a2))
(addB (func a1)(func a2))
;map_hom_neg:forall a:TA,
eqB (func (negA a))(negB(func a))
;well_morph:forall a1 a2:TA,
eqA a1 a2->eqB (func a1)(func a2)
}.
Add Parametric Morphism
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
(Mod:Module eqT addT negT zeroT):
addT with signature (eqT==>eqT==>eqT) as well_addT_x.
intros.
apply well_addT.
exact H.
exact H0.
Qed.
Add Parametric Morphism
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
(MOd:Module eqT addT negT zeroT):
negT with signature (eqT==>eqT) as well_negT_x.
exact well_negT.
Qed.

Module ModTheo.

Theorem neg_zero
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
(Mod:Module eqT addT negT zeroT)
:eqT(negT zeroT)zeroT.
rewrite <-(add_0 (negT zeroT)).
rewrite comm_addT.
exact (add_neg zeroT).
Qed.

Theorem rm_common
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
:forall Mod:Module eqT addT negT zeroT,
forall a b c:T,
eqT (addT b a)(addT c a)->eqT b c.
intros.
assert (forall x:T,eqT x (addT (addT x a)(negT a))).
intros.
rewrite assoc_addT.
rewrite add_neg.
rewrite add_0.
reflexivity.
rewrite (H0 b).
rewrite (H0 c).
rewrite H.
reflexivity.
Qed.

Add Parametric Morphism
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB):
(func MA MB f) with signature (eqA==>eqB) as well_morph_x.
intros.
apply well_morph.
exact H.
Qed.

Theorem swap_2_in_4
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
{Mod:Module eqT addT negT zeroT}
:forall a b c d:T,
eqT (addT (addT a b)(addT c d))
(addT (addT a c)(addT b d)).
intros.
rewrite assoc_addT.
rewrite <-(assoc_addT b).
rewrite (comm_addT b c).
rewrite assoc_addT.
rewrite <-(assoc_addT a).
reflexivity.
Qed.

End ModTheo.

Definition ZeroMorph
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
(MA:Module eqA addA negA zeroA)
(MB:Module eqB addB negB zeroB):
Morph MA MB
:=
{|
func := fun _ : TA => zeroB;
map_0 := reflexivity zeroB;
map_hom_add := fun _ _ : TA =>
               Morphisms.trans_sym_co_inv_impl_morphism
                 (Equivalence_PER (T_setoid MB)) (addB zeroB zeroB) zeroB
                 (add_0 zeroB) (reflexivity zeroB);
map_hom_neg := fun _ : TA =>
               symmetry (x:=negB zeroB) (y:=zeroB) (ModTheo.neg_zero MB);
well_morph := fun (a1 a2 : TA) (_ : eqA a1 a2) => reflexivity zeroB |}.

Definition EqualMorph
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f g:Morph MA MB):Prop:=
forall a:TA,
eqB (func MA MB f a)
(func MA MB g a).

Theorem EquivMorph
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
:Equivalence EqualMorph.
split.
unfold Reflexive;intros;
unfold EqualMorph;
intros;reflexivity.
unfold Symmetric;unfold EqualMorph.
intros.
symmetry;apply H.
unfold Transitive;unfold EqualMorph.
intros.
rewrite H.
apply H0.
Qed.

Definition monomorph

{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB)
:Prop:=
forall a:TA,
eqB (func MA MB f a)zeroB
->eqA a zeroA.
Theorem monomorph_variant
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB)
:monomorph f<->
(forall a t:TA,
eqB (func MA MB f t)(func MA MB f a)
<->eqA t a).
split.
intros.
split;intro.

apply (ModTheo.rm_common MA(negA a)).
rewrite add_neg.
apply H.
rewrite (map_hom_add MA MB f t (negA a))  .
rewrite H0.
rewrite map_hom_neg.
apply add_neg.
rewrite H0;reflexivity.
intros.
unfold monomorph.
intros.
apply H.
rewrite map_0.
apply H0.
Qed.

Definition IdentityMorph
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
(Mod:Module eqT addT negT zeroT):
Morph Mod Mod
:=
{|
func := fun a : T => a;
map_0 := reflexivity zeroT;
map_hom_add := fun a1 a2 : T => reflexivity (addT a1 a2);
map_hom_neg := fun a : T => reflexivity (negT a);
well_morph := fun (a1 a2 : T) (H : eqT a1 a2) => H |}.
(*refine (mkMorph
T T eqT eqT addT addT negT negT zeroT zeroT Mod Mod
  (fun a:T=>a:T) _ _ _ _).
reflexivity.
reflexivity.
reflexivity.
auto.
Qed.*)
Print IdentityMorph.

Theorem identity_mono
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
{Mod:Module eqT addT negT zeroT}
:monomorph (IdentityMorph Mod).
unfold monomorph.
unfold IdentityMorph.
unfold func.
auto.
Qed.

Definition epimorph
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB)
:Prop:=
forall b:TB,exists a:TA,
eqB(func MA MB f a)b.
Theorem identity_epi
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
{Mod:Module eqT addT negT zeroT}
:epimorph (IdentityMorph Mod).
unfold epimorph.
unfold func;unfold IdentityMorph.
intro b;exists b;reflexivity.
Qed.

Notation "[ f , a ]":=(func _ _ f a).

Definition isin_kernel
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB)
(a:TA)
:Prop:=eqB [f ,a ]zeroB.
Print isin_kernel .

Definition kernel
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB)
:Set:={a:TA|isin_kernel f a}.

Theorem mono_kernel
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB)
:monomorph f<->(forall a:TA,isin_kernel f a<->eqA a zeroA).
split.
intro.
unfold monomorph in H.
intro;split.
apply H.
intro.
unfold isin_kernel.
rewrite H0.
apply map_0.
intro.
unfold monomorph.
apply H.
Qed.
Definition isin_image
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB)
(b:TB)
:Prop:=exists a:TA,
eqB[f,a]b.

Definition exact_3
{TA TB TC:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{eqC:TC->TC->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{addC:TC->TC->TC}
{negA:TA->TA}
{negB:TB->TB}
{negC:TC->TC}
{zeroA:TA}
{zeroB:TB}
{zeroC:TC}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
{MC:Module eqC addC negC zeroC}
(f:Morph MA MB)
(g:Morph MB MC)
:Prop:=forall b:TB,
isin_kernel g b<->isin_image f b.
Definition ZeroModule:Module
(fun _ _:unit=>True)
(fun _ _:unit=>tt)
(fun _:unit=>tt)
tt.
split.
split.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
Qed.

Theorem mono_0AB
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
:forall(f:Morph MA MB),
exact_3 (ZeroMorph ZeroModule MA)
f<->monomorph f.
intros.
split.
unfold exact_3.
intros.
unfold monomorph.
intros.
unfold isin_kernel in H.
unfold isin_image in H.
apply H in H0.
elim H0.
unfold func.
unfold ZeroMorph.
intros.
rewrite <-H1.
reflexivity.
unfold monomorph.
unfold exact_3.
intros.
split.
intro.
exists tt.
unfold func.
unfold ZeroMorph.
symmetry.
apply H.
apply H0.
intro.
elim H0.
intro x.
unfold func.
unfold ZeroMorph.
intro.
unfold isin_kernel.
rewrite <-H1.
apply map_0.
Qed.

Definition cokernel
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB)
:Module
(fun b1 b2:TB=>isin_image f (addB b1 (negB b2)))
addB
negB
zeroB.
split.
split.
unfold Reflexive.
intro.
unfold isin_image.
exists zeroA.
rewrite add_neg.
apply map_0.
unfold Symmetric.
unfold isin_image.
intros.
elim H.
intros.
exists (negA x0).

auto.
rewrite map_hom_neg.
rewrite H0.
Theorem neg_add
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
:forall Mod:Module eqT addT negT zeroT,
forall a b:T,
eqT (negT (addT a b))(addT (negT a)(negT b)).
intros.
apply (ModTheo.rm_common Mod (addT a b)).
rewrite comm_addT.
rewrite add_neg.
rewrite assoc_addT.
rewrite (comm_addT a b) .
rewrite <-(assoc_addT (negT b)).
rewrite (comm_addT (negT b)).
rewrite add_neg.
rewrite comm_addT.
rewrite <-(comm_addT a).
rewrite add_0.
rewrite add_neg.
reflexivity.
Qed.

rewrite (neg_add MB x (negB y)).
Theorem neg_neg
{T:Set}
{eqT:T->T->Prop}
{addT:T->T->T}
{negT:T->T}
{zeroT:T}
{Mod:Module eqT addT negT zeroT}:
forall a:T,
eqT (negT (negT a))a.
intros.
apply (ModTheo.rm_common Mod (negT a) (negT (negT a)) a).
rewrite comm_addT.
rewrite add_neg.
rewrite add_neg.
reflexivity.
Qed.
rewrite neg_neg.
rewrite comm_addT.
reflexivity.
unfold Transitive.
intros. elim H. elim H0;intros.
exists (addA x1 x0).
rewrite map_hom_add.
rewrite H1;rewrite H2.
rewrite assoc_addT.
rewrite <-(assoc_addT (negB y)).
rewrite (comm_addT (negB y)).
rewrite add_neg.
rewrite (comm_addT zeroB).
rewrite add_0.
reflexivity.
intros.
elim H;elim H0;intros.
exists (addA x0 x).
rewrite map_hom_add.
rewrite H1;rewrite H2.
rewrite (neg_add MB a2 b2).
apply ModTheo.swap_2_in_4.
intros.
elim H;intros.
exists (negA x).
rewrite neg_neg.
rewrite map_hom_neg.
rewrite H0.
rewrite (neg_add MB a1).
rewrite neg_neg.
reflexivity.
intros.
exists zeroA.
rewrite (comm_addT a).
rewrite add_neg.
apply map_0.
intros.
exists zeroA.
rewrite add_0.
rewrite add_neg.
apply map_0.
intros. exists zeroA.
rewrite add_neg;rewrite (ModTheo.neg_zero MB).
rewrite add_0;apply map_0.
intros.
exists zeroA.
rewrite (assoc_addT a b c).
rewrite add_neg.
apply map_0.
Qed.

Print ZeroMorph.

Definition compmorph
{TA TB TC:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{eqC:TC->TC->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{addC:TC->TC->TC}
{negA:TA->TA}
{negB:TB->TB}
{negC:TC->TC}
{zeroA:TA}
{zeroB:TB}
{zeroC:TC}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
{MC:Module eqC addC negC zeroC}
(g:Morph MB MC)
(f:Morph MA MB)
:Morph MA MC
(*apply (mkMorph TA TC _ _ _ _ _
_ zeroA zeroC MA MC(fun a:TA=>[g,[f,a]])).

intros.
rewrite map_0.
apply map_0.
intros.
rewrite map_hom_add.
rewrite map_hom_add.
reflexivity.
intros.
rewrite map_hom_neg;rewrite map_hom_neg;reflexivity.
intros.
rewrite H;reflexivity.
Qed.
Print compmorph.*)
:={|
func := fun a : TA => [g, [f, a]];
map_0 := Morphisms.trans_co_eq_inv_impl_morphism PER_Transitive
           [g, [f, zeroA]] [g, zeroB]
           (ModTheo.well_morph_x_Proper g [f, zeroA] zeroB (map_0 MA MB f))
           zeroC zeroC (Morphisms.eq_proper_proxy TC zeroC) (map_0 MB MC g);
map_hom_add := fun a1 a2 : TA =>
               Morphisms.trans_co_eq_inv_impl_morphism PER_Transitive
                 [g, [f, addA a1 a2]] [g, addB [f, a1] [f, a2]]
                 (ModTheo.well_morph_x_Proper g [f, addA a1 a2]
                    (addB [f, a1] [f, a2]) (map_hom_add MA MB f a1 a2))
                 (addC [g, [f, a1]] [g, [f, a2]])
                 (addC [g, [f, a1]] [g, [f, a2]])
                 (Morphisms.eq_proper_proxy TC
                    (addC [g, [f, a1]] [g, [f, a2]]))
                 (Morphisms.trans_co_eq_inv_impl_morphism PER_Transitive
                    [g, addB [f, a1] [f, a2]]
                    (addC [g, [f, a1]] [g, [f, a2]])
                    (map_hom_add MB MC g [f, a1] [f, a2])
                    (addC [g, [f, a1]] [g, [f, a2]])
                    (addC [g, [f, a1]] [g, [f, a2]])
                    (Morphisms.eq_proper_proxy TC
                       (addC [g, [f, a1]] [g, [f, a2]]))
                    (reflexivity (addC [g, [f, a1]] [g, [f, a2]])));
map_hom_neg := fun a : TA =>
               Morphisms.trans_co_eq_inv_impl_morphism PER_Transitive
                 [g, [f, negA a]] [g, negB [f, a]]
                 (ModTheo.well_morph_x_Proper g [f, negA a] (negB [f, a])
                    (map_hom_neg MA MB f a)) (negC [g, [f, a]])
                 (negC [g, [f, a]])
                 (Morphisms.eq_proper_proxy TC (negC [g, [f, a]]))
                 (Morphisms.trans_co_eq_inv_impl_morphism PER_Transitive
                    [g, negB [f, a]] (negC [g, [f, a]])
                    (map_hom_neg MB MC g [f, a]) (negC [g, [f, a]])
                    (negC [g, [f, a]])
                    (Morphisms.eq_proper_proxy TC (negC [g, [f, a]]))
                    (reflexivity (negC [g, [f, a]])));
well_morph := fun (a1 a2 : TA) (H : eqA a1 a2) =>
              Morphisms.trans_co_eq_inv_impl_morphism PER_Transitive
                [g, [f, a1]] [g, [f, a2]]
                (ModTheo.well_morph_x_Proper g [f, a1] [f, a2]
                   (ModTheo.well_morph_x_Proper f a1 a2 H)) [g, [f, a2]]
                [g, [f, a2]] (Morphisms.eq_proper_proxy TC [g, [f, a2]])
                (reflexivity [g, [f, a2]]) |}.

Theorem mono_comp
{TA TB TC:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{eqC:TC->TC->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{addC:TC->TC->TC}
{negA:TA->TA}
{negB:TB->TB}
{negC:TC->TC}
{zeroA:TA}
{zeroB:TB}
{zeroC:TC}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
{MC:Module eqC addC negC zeroC}
(f:Morph MA MB)
(g:Morph MB MC)
:
(monomorph (compmorph g f)->monomorph f)
/\(monomorph f/\monomorph g->monomorph(compmorph g f)).
split.
unfold monomorph.
unfold compmorph.
simpl.
intro.
intros.
apply H.
rewrite H0.
apply map_0.
unfold monomorph.
unfold compmorph.
simpl.
intros.

apply H;apply H;apply H0.
Qed.

Definition KernelModule
{TA TB:Set}
{eqA:TA->TA->Prop}
{eqB:TB->TB->Prop}
{addA:TA->TA->TA}
{addB:TB->TB->TB}
{negA:TA->TA}
{negB:TB->TB}
{zeroA:TA}
{zeroB:TB}
{MA:Module eqA addA negA zeroA}
{MB:Module eqB addB negB zeroB}
(f:Morph MA MB):Module (T:=kernel f)
eqA addA negA zeroA.

Definition ker_morph
{TL1 TL2 TM1 TM2:Set}
{eqL1:TL1->TL1->Prop}
{eqL2:TL2->TL2->Prop}
{eqM1:TM1->TM1->Prop}
{eqM2;TM2->TM2->Prop}
{addL1:TL1->TL1->TL1}
{addL2:TL2->TL2->TL2}
{addM1:TM1->TM1->TM1}
{addM2:TM2->TM2->TM2}
{negL1:TL1->TL1}
{negL2:TL2->TL2}
{negM1:TM1->TM1}
{negM2:TM2->TM2}
{zeroL1:TL1}
{zeroL2:TL2}
{zeroM1:TM1}
{zeroM2:TM2}
{ML1:Module eqL1 addL1 negL1 zeroL1}
{ML2:Module eqL2 addL2 negL2 zeroL2}
{MM1:Module eqM1 addM1 negM1 zeroM1}
{MM2:Module eqM2 addM2 negM2 zeroM2}
(f1:Morph ML1 ML2)
(g1:Morph MM1 MM2)
(v1:Morph ML1 MM1)
(v2:Morph ML2 MM2)
:Morph


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Separation.

(* 由A中那些自己不属于自己的元素组成的集合 *)
Definition 罗素集 := λ A, {x ∊ A | x ∉ x}.

Theorem 罗素集性质 : ∀ A, 罗素集 A ∉ A.
Proof.
  intros.
  排中 (罗素集 A ∈ 罗素集 A) as [正|反].
  - apply 分离除去 in 正 as [属父 条件].
    exfalso. apply 条件. now apply 分离介入.
  - intros 属父. apply 反. now apply 分离介入.
Qed.

Theorem 无大全集 : ¬ ∃ A, ∀ x, x ∈ A.
Proof.
  intros [A H]. eapply 罗素集性质. apply H.
Qed.


Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import Coq.Program.Equality.
Require Import SystemF.
Require Import Extended.

(* Notes:

The syntax is encoded using Charguéraud's Locally nameless representation:

http://www.chargueraud.org/softs/ln/

We annotate the Coq theorems with the corresponding lemmas/theorems in the paper.
The reader can just look for:

Lemma 4

for example, to look for the proof of lemma 4 in the paper.
This top-level Coq script only re-states the lemmas/theorems formulated in the paper,
which have been proven in other sub-scripts.

All lemmas and theorems are complete: there are no uses of admit or Admitted,
with the exceptions of "sound_sub" due to a technical limitation.

*)

Module MDisjointPolymorphism
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module MExtended := MExtended(VarTyp)(set).
Export MExtended.

(* Lemma 2: Subtyping reflexivity *)

Lemma subyping_reflexivity : forall A, PType A -> Sub A A.
Proof. intros; apply sound_sub; now apply usub_refl. Qed.

(* Lemma 3: Subtyping transitivity *)

Lemma subtyping_transitivity : forall B A C : PTyp, PType C -> Sub A B -> Sub B C -> Sub A C.
Proof.
  intros B A C HPT HS1 HS2. apply complete_sub in HS1. apply complete_sub in HS2.
  apply sound_sub; eapply usub_trans; eauto.
Qed.

(* Lemma 4: Covariance of disjointness *)

Lemma covariance_disjointness :
  forall Gamma A B C, PType C -> Ortho Gamma A B -> Sub B C -> Ortho Gamma A C.
Proof.
  intros Gamma A B C HT HO HS; apply complete_sub in HS; eapply Ortho_usub_trans; eauto.
Qed.

(* Lemma 5: Disjointness is stable under substitution *)

Lemma disjointness_stable_substitution :
  forall a C Gamma D A B,
    not (In a (fv_ptyp C)) ->
    WFEnv (subst_env Gamma a C) ->
    WFEnv Gamma ->
    MapsTo Gamma a D ->
    Ortho Gamma C D ->
    Ortho Gamma A B ->
    PType C ->
    PType A ->
    PType B ->
    Ortho (subst_env Gamma a C) (subst_typ_source a C A) (subst_typ_source a C B).
Proof. apply ortho_subst. Qed.

(* Lemma 6: Types are stable under substitution *)

Lemma types_stable_substitution :
  forall A a B Gamma C, not (In a (fv_ptyp B)) ->
               MapsTo Gamma a C ->
               WFEnv (subst_env Gamma a B) ->
               Ortho Gamma B C ->
               WFTyp Gamma B ->
               WFTyp Gamma A ->
               WFTyp (subst_env Gamma a B) (subst_typ_source a B A).
Proof. apply subst_source_wf_typ. Qed.

(* Lemma 7: Well-formed typing *)

Lemma wellformed_typing :
  forall Gamma e A E dir, has_type_source_alg Gamma e dir A E -> WFTyp Gamma A.
Proof. apply typing_wf_source_alg. Qed.

(* Lemma 8: Subtyping rules produce type-correct coercions *)

Lemma subtype_correct_coercions :
  forall Gamma A1 A2 E, sub A1 A2 E ->
               WFEnv Gamma ->
               WFTyp Gamma A1 ->
               WFTyp Gamma A2 ->
               has_type_st (∥ Gamma ∥) E (STFun (|A1|) (|A2|)) .
Proof. apply type_correct_coercions. Qed.

(* Lemma 9: Unique subtyping contributor *)

Lemma unique_subtyping_contributor :
  forall Gamma A1 A2 B, WFTyp Gamma A1 ->
               WFTyp Gamma A2 ->
               ~ TopLike B ->
               Ortho Gamma A1 A2 ->
               Sub (And A1 A2) B ->
               not (Sub A1 B /\ Sub A2 B).
Proof. apply uniquesub. Qed.

(* Lemma 10: Unique coercion *)

Lemma unique_coercion :
  forall A B E1 E2 Gamma, WFTyp Gamma A ->
                 WFTyp Gamma B ->
                 sub A B E1 ->
                 sub A B E2 -> E1 = E2.
Proof. intros; eapply sub_coherent; [ apply H | apply H0 | | ]; eauto. Qed.

(* Theorem 1: Type preservation *)

Lemma type_preservation :
  forall e ty dir E (Gamma : context TyEnvSource) (H : has_type_source_alg Gamma e dir ty E),
  has_type_st (∥ Gamma ∥) E (|ty|).
Proof. apply type_preservation. Qed.

(* Theorem 3: Uniqueness of type-inference *)

Lemma uniqueness_type_inference :
  forall Gamma e A1 A2 E1 E2, has_type_source_alg Gamma e Inf A1 E1 ->
                     has_type_source_alg Gamma e Inf A2 E2 ->
                     A1 = A2.
Proof. intros; eapply typ_inf_unique; eauto. Qed.

(* Theorem 4: Unique elaboration *)

Lemma unique_elaboration :
  forall Gamma e d A E1 E2, has_type_source_alg Gamma e d A E1 ->
                   has_type_source_alg Gamma e d A E2 ->
                   E1 = E2.
Proof. intros; eapply typ_coherence; eauto. Qed.

End MDisjointPolymorphism.


Require Utf8.

Require Import S00_setoid_basics S01_Wty S30_IdType.

(* Basics on the identity type of W-types  *)

Section IdWty.
  Context {X : Set}{Y : X → Set}.

  Definition Wty_node_eq {w w' : Wty Y}
    : w == w' → Wty_node Y w == Wty_node Y w'
    := Identity_congr (Wty_node Y) w w'.

  Definition Wty_ist_eq {w w' : Wty Y}(r : w == w')
    : Wty_ist w == Wty_ist w' · Y•ᵐ(Wty_node_eq r).

    destruct r. apply rfl.
  Defined.

  Definition isIdWty_aux (z z' : sigT (λ x, Y x → Wty Y))
    : ∀ r : z == z', sup Y (projT1 z) (projT2 z) == sup Y (projT1 z') (projT2 z').

    intro r. apply (ap (f := λ z, sup Y (projT1 z) (projT2 z)) r).
  Defined.

  Definition isIdWty {x x' : X}{f : Y x → Wty Y}{f' : Y x' → Wty Y}
    : ∀ p : x == x', f == f' · Y•ᵐp → sup Y x f == sup Y x' f'.

    intros p q. apply (isIdWty_aux (existT _ x f) (existT _ x' f')).
    apply extΣ. exists p. cbn. apply domtransp. apply q.
  Defined.

  Definition ηWty : ∀ w, sup Y (Wty_node Y w) (Wty_ist w) == w.

    intros [x f]. apply rfl.
  Defined.
End IdWty.


Require Import HoTT.
From GR.bicategories Require Import
     general_category.
From GR.bicategories.bicategory Require Import
     bicategory
     bicategory_laws.

Section OpBiCategory.
  Variable (C : BiCategory).

  Definition op₂_hom (X Y : C) : PreCategory
    := @Build_PreCategory
         (C⟦X,Y⟧)
         (fun f g => g ==> f)
         (fun f => id₂ f)
         (fun _ _ _ α β => β ∘ α)
         (fun _ _ _ _ α β γ => (vcomp_assoc α β γ)^)
         (fun _ _ α => vcomp_right_identity α)
         (fun _ _ β => vcomp_left_identity β)
         _.

  Definition op2_d : BiCategory_d.
  Proof.
    make_bicategory.
    - exact C.
    - exact op₂_hom.
    - exact (fun X => id₁ X).
    - intros X Y Z [f₁ f₂] ; cbn.
      exact (f₁ · f₂).
    - intros X Y Z [f₁ f₂] [g₁ g₂] [η₁ η₂] ; simpl in *.
      exact (η₁ * η₂).
    - intros X Y f ; simpl in *.
      apply left_unit_inv .
    - intros X Y f ; simpl in *.
      apply left_unit.
    - intros X Y f ; simpl in *.
      apply right_unit_inv.
    - intros X Y f ; simpl in *.
      apply right_unit.
    - intros W X Y Z h g f ; simpl in *.
      apply assoc_inv.
    - intros W X Y Z h g f ; simpl in *.
      apply assoc.
  Defined.

  Definition op2_is_bicategory : is_bicategory op2_d.
  Proof.
    make_is_bicategory.
    - intros X Y Z [g f] ; simpl in *.
      apply hcomp_id₂.
    - intros X Y Z [f₁ f₂] [g₁ g₂] [h₁ h₂] [η₁ η₂] [ε₁ ε₂] ; simpl in *.
      apply interchange.
    - intros X Y f g η ; simpl in *.
      exact (left_unit_inv_natural _)^.
    - intros X Y f g η ; simpl in *.
      exact (left_unit_natural _)^.
    - intros X Y f g η ; simpl in *.
      exact (right_unit_inv_natural _)^.
    - intros X Y f g η ; simpl in *.
      exact (right_unit_natural _)^.
    - intros X Y f ; simpl in *.
      apply left_unit_left.
    - intros X Y f ; simpl in *.
      apply left_unit_right.
    - intros X Y f ; simpl in *.
      apply right_unit_left.
    - intros X Y f ; simpl in *.
      apply right_unit_right.
    - intros W X Y Z h₁ h₂ g₁ g₂ f₁ f₂ ηh ηg ηf ; simpl in *.
      exact (assoc_inv_natural _ _ _)^.
    - intros W X Y Z h₁ h₂ g₁ g₂ f₁ f₂ ηh ηg ηf ; simpl in *.
      exact (assoc_natural _ _ _)^.
    - intros W X Y Z f g h ; simpl in *.
      apply assoc_left.
    - intros W X Y Z f g h ; simpl in *.
      apply assoc_right.
    - intros X Y Z g f ; simpl in *.
      apply triangle_r_inv.
    - intros V W X Y Z k h g f ; simpl in *.
      rewrite <- !vcomp_assoc.
      apply inverse_pentagon.
  Qed.

  Definition op2 : BiCategory
    := Build_BiCategory op2_d op2_is_bicategory.
End OpBiCategory.