Require Import List ListDec Arith.
Import ListNotations.

Section card.
Variable X : Type.
Variable P: X -> Prop.

Class enum := {
  enumeration: list X;
  enum_spec: forall x, P x <-> In x enumeration;
  enum_nodup: NoDup enumeration
}.
Coercion enumeration: enum >-> list.

Definition count (e: enum) := length enumeration.
Inductive card n := cardI e: count e = n -> card n.

Lemma card_well_defined: forall n m, card n -> card m -> n = m.
Proof.
  intros n m [e1 H1] [e2 H2]. subst n m.
  apply PeanoNat.Nat.le_antisymm.
  - apply NoDup_incl_length.
    + apply enum_nodup.
    + intros x H. apply enum_spec. apply enum_spec in H. exact H.
  - apply NoDup_incl_length.
    + apply enum_nodup.
    + intros x H. apply enum_spec. apply enum_spec in H. exact H.
Qed.

End card.
Arguments enum {X}.
Arguments card {X}.

Definition all X := fun (x:X) => True.

(* ** Counting three things *)
Variant three := a | b | c.
Lemma decThree: forall (x y : three), {x = y} + {x <> y}.
Proof. decide equality. Defined.
#[export] Instance three_enum: enum (all three).
Proof.
  exists (a::b::c::nil).
  - intros []; compute; tauto.
  - apply <- (NoDup_count_occ decThree).
    intros []; reflexivity.
Defined.

Goal card (all three) 3.
Proof. econstructor. reflexivity. Qed.

(* ** Counting combinations of things *)
Fixpoint combinations {A : Type} (l: list A) d :=
match d with
| 0 => [[]]
| S d => map (fun '(x, combination) => x::combination)
             (list_prod l (combinations l d))
end.

Compute combinations three_enum 4.

Lemma combinations_length {A : Type} (l: list A) d:
  length (combinations l d) = (length l)^d.
Proof.
  induction d; [ reflexivity | ].
  cbn. now rewrite map_length, prod_length, IHd.
Qed.

(* ** sequences without repetitions *)
Section seq_no_rep.
Variable X : Type.
Variable n : nat.
Definition P : list X -> Prop := fun l => NoDup l /\ length l = n.

#[export] Instance seq_no_rep_enum: enum P.
Proof.
  unfold P. induction n as [| n' IH].
  - exists [[]].
    + intros l. split.
      * intros [H0 H1%length_zero_iff_nil]. rewrite H1. now left.
      * intros H. destruct H as [<- | []].
        split; constructor.
    + constructor; [apply in_nil | constructor].
  -
Abort.

End seq_no_rep.


From mathcomp Require Import all_ssreflect.

Check nat_eqType.
Print Canonical Projections.
Compute Equality.sort nat_eqType.           (* nat *)
Compute Monoid.operator addn_monoid.        (* addn *)

(* 5.8 The generic theory of “big” operators *)

Fixpoint iota m n :=
  if n is u.+1 then
    m :: iota m.+1 u
  else
    [::].
Compute iota 3 5.                           (* = [:: 3; 4; 5; 6; 7] *)

Reserved Notation "\sum''_ ( m <= i < n ) F"
         (at level 41, F at level 41, i, m, n at level 50,
          format "'[' \sum''_ ( m  <=  i  <  n ) '/  '  F ']'").

Reserved Notation "\sum'_ ( m <= i < n | P ) F"
         (at level 41, F at level 41, i, m, n at level 50,
          format "'[' \sum'_ ( m  <=  i  <  n | P ) '/  '  F ']'").

Reserved Notation "\sum'_ ( m <= i < n ) F"
         (at level 41, F at level 41, i, m, n at level 50,
          format "'[' \sum'_ ( m  <=  i  <  n ) '/  '  F ']'").

Reserved Notation "\big [ op / idx ]_ ( i <- r | P ) F"
         (at level 36, F at level 36, op, idx at level 10, i, r at level 50,
          format "'[' \big [ op / idx ]_ ( i  <-  r  |  P ) '/  '  F ']'").

Reserved Notation "\big [ op / idx ]_ ( i <- r ) F"
         (at level 36, F at level 36, op, idx at level 10, i, r at level 50,
          format "'[' \big [ op / idx ]_ ( i  <-  r ) '/  '  F ']'").

Reserved Notation "\big [ op / idx ]_ ( m <= i < n | P ) F"
         (at level 36, F at level 36, op, idx at level 10, m, i, n at level 50,
          format "'[' \big [ op / idx ]_ ( m  <=  i  <  n  |  P )  F ']'").

Reserved Notation "\big [ op / idx ]_ ( m <= i < n ) F"
         (at level 36, F at level 36, op, idx at level 10, m, i, n at level 50,
          format "'[' \big [ op / idx ]_ ( m  <=  i  <  n )  F ']'").

Reserved Notation "\sum_ ( m <= i < n | P ) F"
         (at level 41, F at level 41, i, m, n at level 50,
          format "'[' \sum_ ( m  <=  i  <  n | P ) '/  '  F ']'").

Reserved Notation "\sum_ ( m <= i < n ) F"
         (at level 41, F at level 41, i, m, n at level 50,
          format "'[' \sum_ ( m  <=  i  <  n ) '/  '  F ']'").

(* 1.7 Iterators in mathematics *)
(* もっとも簡単な定義 *)

Notation "\sum''_ ( m <= i < n ) F" :=
  (foldr (fun i a => F + a) 0 (iota m (n - m))).

(* 5.8 The generic theory of “big” operators *)

Definition index_iota m n :=                (* U(i=m, i<n)、n は含まない！ *)
  iota m (n - m).

Compute index_iota 3 5.                     (* = [:: 3; 4] = U(i=3, i<5) ... *)

Definition bigop' {R I : Type}
           (idx : R)                        (* 初期値 *)
           (op : R -> R -> R)               (* big-opに対するsmall-op *)
           (r : seq I)                      (* リスト *)
           (P : pred I)                     (* 取出す条件、引数はi (I -> bool) *)
           (F : I -> R) :                   (* 個別の処理、引数はi *)
  R :=                                      (* 結果 *)
  foldr (fun (i : I) (x : R) => if P i then op (F i) x else x) idx r.

Local Notation "+%N" :=
  addn (at level 0, only parsing).

Notation "\sum'_ ( m <= i < n | P ) F":=
  (bigop' 0%N +%N (index_iota m n) P F%N) : nat_scope.

Notation "\sum'_ ( m <= i < n ) F":=
  (bigop' 0%N +%N (index_iota m n) true F%N) : nat_scope.

(* 5.9 Stable notations for big operators *)
(* To solve these problems 以降を抜粋する。 *)
(* やっていることは同じ。 *)

Inductive bigbody {R I : Type} :=
  BigBody of I & (R -> R -> R) & bool & R.

Definition sum_odd_def_body i :=            (* 例 *)
  BigBody i addn (odd i) i.

Definition applybig {R I} (body : @bigbody R I) acc :=
  let: BigBody _ op b v := body in
  if b then op v acc else acc.

Definition bigop {R I} idx r (body : I -> @bigbody R I) :=
  foldr (applybig \o body) idx r.

Notation "\big [ op / idx ]_ ( i <- r | P ) F" :=
  (bigop idx r (fun i => BigBody i op P F)) : big_scope.

Notation "\big [ op / idx ]_ ( i <- r ) F" :=
  (bigop idx r (fun i => BigBody i op true F)) : big_scope.

Notation "\big [ op / idx ]_ ( m <= i < n | P ) F" :=
  (\big[op/idx]_(i <- index_iota m n | P) F) : big_scope.

Notation "\big [ op / idx ]_ ( m <= i < n ) F" :=
  (\big[op/idx]_(i <- index_iota m n) F) : big_scope.

Local Notation "+%N" :=
  addn (at level 0, only parsing).

Local Notation "*%N" :=
  muln (at level 10, only parsing).

Notation "\sum_ ( m <= i < n | P ) F":=
  (\big[+%N/0%N]_(m <= i < n | P) F%N) : nat_scope.
(*
  (bigop 0%N (index_iota m n) (fun i => BigBody i addn P F%N)) : nat_scope.
*)

Notation "\sum_ ( m <= i < n ) F":=
  (\big[+%N/0%N]_(m <= i < n) F%N) : nat_scope.
(*
  (bigop 0%N (index_iota m n) (fun i => BigBody i addn true F%N)) : nat_scope.
*)

(* *********** *)
(* テストと証明 *)
(* *********** *)

Eval compute in \sum_(1 <= i < 5) (i * 2 - 1). (* = 16 : nat *)
Eval compute in \sum_(1 <= i < 5) i.           (* = 10 : nat *)

(* small-op (\sum_ の addn) はモノイドでなければならない。 *)
Lemma mul1m {T : Type} (idm : T) (mul : Monoid.law idm) : left_id idm mul.
Proof.
    by case mul.
Qed.

Lemma mulm1 {T : Type} (idm : T) (mul : Monoid.law idm) : right_id idm mul.
Proof.
    by case mul.
Qed.

Lemma mulmA {T : Type} (idm : T) (mul : Monoid.law idm) :
  associative mul.
Proof.
    by case mul.
Qed.

(* *********************** *)
(* 条件式を個別の項に移す。 *)
(* *********************** *)
Lemma big_mkcond {I R : Type} (idx : R) (op : Monoid.law idx)
      (r : seq I) (P : pred I) (F : I -> R) :
  \big[op/idx]_(i <- r | P i) F i =
  \big[op/idx]_(i <- r) (if P i then F i else idx).
 (*
  bigop idx r (fun i => @BigBody R I i op (P i) (F i)) =
  bigop idx r (fun i => @BigBody R I i op true (if P i then F i else idx)).
*)
Proof.
  elim: r => //= i r ->.
  case P => //=.
  by rewrite mul1m.
Qed.

Lemma big_cat {I R : Type} (idx : R) (op : Monoid.law idx)
      (r1 r2 : seq I) (P : pred I) (F : I -> R) :
  \big[op/idx]_(i <- r1 ++ r2 | P i) F i =
  op (\big[op/idx]_(i <- r1 | P i) F i) (\big[op/idx]_(i <- r2 | P i) F i).
Proof.
  elim: r1 => /= [|i' r1 ->]; rewrite (mul1m, mulmA).
  - done.
  - by case: (P i').
Qed.

Lemma big_cat_nat {R : Type} (idx : R) (op : Monoid.law idx)
      (m n p : nat) (P : pred nat) (F : nat -> R) :
  m <= n -> n <= p ->
  \big[op/idx]_(m <= i < p | P i) F i =
  op (\big[op/idx]_(m <= i < n | P i) F i) (\big[op/idx]_(n <= i < p | P i) F i).
Proof.
  move=> le_mn le_np.
  rewrite -big_cat.
  rewrite -{2}(subnKC le_mn) -iota_add subnDA.
  now rewrite subnKC // leq_sub.
Qed.

Lemma big_ltn {R : Type} (idx : R) (op : Monoid.law idx)
      (m n : nat) (F : nat -> R) :
  m < n ->
  \big[op/idx]_(m <= i < n) F i = op (F m) (\big[op/idx]_(m.+1 <= i < n) F i).
Proof.
  Admitted.

Lemma big_geq {R : Type} (idx : R) (op : Monoid.law idx)
      (m n : nat) (P : pred nat) (F : nat -> R) :
  m >= n -> \big[op/idx]_(m <= i < n | P i) F i = idx.
Proof.
    by move=> ge_m_n; rewrite /index_iota (eqnP ge_m_n).
Qed.

Lemma big_nat1 {R : Type} (idx : R) (op : Monoid.law idx)
      (n : nat) (F : nat -> R) :
  \big[op/idx]_(n <= i < n.+1) F i = F n.
Proof.
  by rewrite big_ltn // big_geq // mulm1.
Qed.

(* ********************************* *)
(* 右側（大きい値）をBigOPの外に出す。 *)
(* ********************************* *)
Lemma big_nat_recr {R : Type} (idx : R) (op : Monoid.law idx)
      (n m : nat) (F : nat -> R) :
    m <= n ->
    \big[op/idx]_(m <= i < n.+1) F i =
    op (\big[op/idx]_(m <= i < n) F i) (F n).
(*
    bigop idx (index_iota m n.+1) (fun i => @BigBody R nat i op true (F i)) =
    op (bigop idx (index_iota m n) (fun i => BigBody i op true (F i))) (F n).
*)
Proof.
  move=> lemn.
  Check (big_cat_nat idx op m n n.+1 (fun i => true) F).
  rewrite (big_cat_nat idx op m n n.+1 (fun i => true) F).
  - Check big_nat1.
      by rewrite big_nat1.
  - done.
  - done.
Qed.

(* **** *)
(* 証明 *)
(* **** *)

Lemma sum_odd_3 : \sum_(0 <= i < 3.*2 | odd i) i = 3^2.
Proof.
  by rewrite big_mkcond big_nat_recr //=.
Qed.

Lemma test : \sum_(0 <= i < 6) i= (\sum_(0 <= i < 5) i) + 5.
Proof.
    by apply: big_nat_recr.
Qed.

(* Exercise 16. Sum of 2n odd numbers *)

Lemma sum_odd n : \sum_(0 <= i < n.*2 | odd i) i = n^2.
Proof.
  elim: n => [|n IHn].
  - done.
  - rewrite doubleS.
    rewrite big_mkcond.
    rewrite big_nat_recr.
    rewrite big_nat_recr.
    rewrite -big_mkcond.
    rewrite /=.
    rewrite IHn.
    rewrite odd_double.
    rewrite /=.
    rewrite addn0.
    rewrite -addnn.
    rewrite -!mulnn.
    ring.

  Restart.

  elim: n => [|n IHn]; first done.
  rewrite doubleS big_mkcond 2?big_nat_recr // -big_mkcond /=.
  rewrite {}IHn odd_double /= addn0 -addnn -!mulnn; ring.
Qed.

(* END *)


From Coq Require Import Relations.
From Coq Require Import Relations.Relation_Operators.
From KBase Require Import Tactics.

Section Definitions.

Context {A : Type}.

(* Most of this file is inspired by "Confluence and Normalization in Reduction Systems Lecture Notes"
   by Gert Smolka of Saarland University. December 16, 2015
   https://www.ps.uni-saarland.de/courses/sem-ws15/ars.pdf *)

Definition joinable (R : relation A) (x y : A) : Prop :=
  exists z, R x z /\ R y z.

Definition diamond (R : relation A) : Prop :=
  forall x y z, R x y -> R x z -> joinable R y z.

Definition confluent (R : relation A) : Prop :=
  diamond (clos_refl_trans_1n A R).

Definition semi_confluent (R : relation A) : Prop :=
  forall x y z,
    R x y ->
    clos_refl_trans_1n A R x z ->
    joinable (clos_refl_trans_1n A R) y z.

Definition locally_confluent (R : relation A) : Prop :=
  forall x y z,
    R x y ->
    R x z ->
    joinable (clos_refl_trans_1n A R) y z.

Definition reducible (R : relation A) (x : A) : Prop :=
  exists z, R x z.

Definition normal (R : relation A) (x : A) : Prop :=
  ~ (reducible R x).

Definition terminal (R : relation A) (x y : A) : Prop :=
  clos_refl_trans_1n A R x y /\ normal R y.

  (* Weak normalization *)
Definition WN (R : relation A) (x : A) : Prop :=
  exists z, terminal R x z.

  (* Strong normalization *)
Inductive SN (R : relation A) (x : A) : Prop :=
  | sn_intro : (forall y, R x y -> SN R y) -> SN R x.

Definition terminating (R : relation A) : Prop :=
    forall x, SN R x.

Fixpoint apply_n (n : nat) (f : A -> A) : A -> A :=
  match n with
    | 0 => fun x => x
    | S n => fun x => f (apply_n n f x)
  end.

Definition triangle_op (R : relation A) (f : A -> A) : Prop :=
    forall x y, R x y -> R y (f x).

End Definitions.

#[global] Hint Resolve clos_rt1n_step : KBaseHints.
#[global] Hint Resolve rt1n_refl : KBaseHints.

Theorem clos_rt1n_trans : forall (A : Type) (R : relation A) x y z,
  clos_refl_trans_1n A R x y ->
  clos_refl_trans_1n A R y z ->
  clos_refl_trans_1n A R x z.
Proof.
  intros A R x y z x_y y_z;
  apply clos_rt_rt1n;
  apply clos_rt1n_rt in x_y;
  apply clos_rt1n_rt in y_z;
  eauto using rt_trans.
Qed.

Theorem clos_rt1n_right : forall (A : Type) (R : relation A) x y z,
  clos_refl_trans_1n A R x y ->
  R y z ->
  clos_refl_trans_1n A R x z.
Proof.
  intros A R x y z x_y y_z;
  apply (clos_rt1n_trans A R x y z); auto using clos_rt1n_step.
Qed.

#[global] Hint Extern 1 (clos_refl_trans_1n ?A ?R ?x ?z) =>
  match goal with
  | H1: clos_refl_trans_1n A R x ?y,
    H2: clos_refl_trans_1n A R ?y z |- _ => exact (clos_rt1n_trans A R x y z H1 H2)
  | H: R x ?y |- _ => apply (rt1n_trans A R x y z H)
  | H: clos_refl_trans_1n A R ?y z |- _ => apply (rt1n_trans A R x y z)
  | H: R ?y z |- _ => apply (clos_rt1n_right A R x y z)
  end : KBaseHints.

Section Properties.
  Context {A : Type}.

  (* Facts about clos_refl_trans_1n *)

  Theorem idempotence_rt : forall (R : relation A),
    same_relation A (clos_refl_trans_1n A R)
      (clos_refl_trans_1n A (clos_refl_trans_1n A R)).
  Proof.
    split; intros x y x_y.
    - crush.
    - induction x_y; crush.
  Qed.
  #[local] Hint Resolve idempotence_rt : KBaseHints.

  Theorem monotonicity_rt : forall R1 R2,
    inclusion A R1 R2 ->
    inclusion A (clos_refl_trans_1n A R1) (clos_refl_trans_1n A R2).
  Proof.
    unfold inclusion;
    intros R1 R2 H x y x_y;
    induction x_y; crush; autoSpecialize; crush.
  Qed.
  #[local] Hint Resolve monotonicity_rt : KBaseHints.

  Theorem preserve_rt : forall (R : relation A) (f : A -> A) x y,
    (forall x y, R x y -> R (f x) (f y)) ->
    clos_refl_trans_1n A R x y -> clos_refl_trans_1n A R (f x) (f y).
  Proof.
    intros R f x y H x_y;
    induction x_y; crush.
  Qed.

  Theorem preserve_rt_left : forall (R : relation A) (f : A -> A -> A) x1 x2 z,
    (forall x1 x2 z, R x1 x2 -> R (f x1 z) (f x2 z)) ->
    clos_refl_trans_1n A R x1 x2 ->
    clos_refl_trans_1n A R (f x1 z) (f x2 z).
  Proof.
    intros R f x1 x2 z HLeft x1_x2.
    exact (preserve_rt R (fun x => f x z) x1 x2
      (fun x1 x2 x1_x2 => HLeft x1 x2 z x1_x2) x1_x2).
  Qed.
  #[local] Hint Resolve preserve_rt_left : KBaseHints.

  Theorem preserve_rt_right : forall (R : relation A) (f : A -> A -> A) x z1 z2,
    (forall x z1 z2, R z1 z2 -> R (f x z1) (f x z2)) ->
    clos_refl_trans_1n A R z1 z2 ->
    clos_refl_trans_1n A R (f x z1) (f x z2).
  Proof.
    intros R f x z1 z2 HRight z1_z2;
    exact (preserve_rt R (fun z => f x z) z1 z2
      (fun z1 z2 z1_z2 => HRight x z1 z2 z1_z2) z1_z2).
  Qed.
  #[local] Hint Resolve preserve_rt_right : KBaseHints.

  Theorem preserve_rt_para : forall (R : relation A) (f : A -> A -> A) x1 x2 z1 z2,
    (forall x1 x2 z, R x1 x2 -> R (f x1 z) (f x2 z)) ->
    (forall x z1 z2, R z1 z2 -> R (f x z1) (f x z2)) ->
    clos_refl_trans_1n A R x1 x2 ->
    clos_refl_trans_1n A R z1 z2 ->
    clos_refl_trans_1n A R (f x1 z1) (f x2 z2).
  Proof.
    intros R f x1 x2 z1 z2 HLeft HRight x1_x2 z1_z2;
    pose proof (preserve_rt_left R f x1 x2 z1 HLeft  x1_x2) as H1;
    pose proof (preserve_rt_right R f x2 z1 z2 HRight  z1_z2) as H2.
    crush.
  Qed.

  (* Facts about confluence and friend *)

  Theorem confluent_semi_confluent : forall (R : relation A),
  confluent R -> semi_confluent R.
  Proof.
    intros R C x y1 y2 x_y1 x_y2;
    destruct (C x y1 y2 (clos_rt1n_step _ _ _ _ x_y1) x_y2);
    ecrush.
  Qed.

  Theorem semi_confluent_confluent : forall (R : relation A),
  semi_confluent R -> confluent R.
  Proof.
    unfold semi_confluent.
    intros R D x y1 y2 y1H; generalize dependent y2.
    induction y1H as [x | x y z x_y y_z H];
    intros y2 x_y2; unfold joinable.
    - ecrush.
    - destruct (D x y y2 x_y x_y2) as [u [y_u y2_u]];
      destruct (H u y_u) as [v [z_v u_v]];
      ecrush.
  Qed.
  #[local] Hint Resolve semi_confluent_confluent : KBaseHints.

  Lemma diamond_semi_confluent : forall (R : relation A),
    diamond R ->
    semi_confluent R.
  Proof.
    intros R D x y1 y2 x_y1 x_y2; generalize dependent y1;
    induction x_y2 as [x | x y2 z2 x_y2 y2_z2 H];
    intros y1 x_y1; unfold joinable.
    - ecrush.
    - destruct (D x y1 y2 x_y1 x_y2) as [u [y1_u y2_u]].
      destruct (H u y2_u);
      ecrush.
  Qed.
  #[local] Hint Resolve diamond_semi_confluent : KBaseHints.

  Lemma sandwich_same_rt : forall R1 R2,
    inclusion A R1 R2 ->
    inclusion A R2 (clos_refl_trans_1n A R1) ->
    same_relation A (clos_refl_trans_1n A R1) (clos_refl_trans_1n A R2).
  Proof.
    intros R1 R2 H1 H2;
    pose proof (monotonicity_rt R1 R2 H1) as H3;
    pose proof (monotonicity_rt R2 (clos_refl_trans_1n A R1) H2) as H4;
    pose proof (idempotence_rt R1) as [_ H5];
    split; ecrush.
  Qed.
  #[local] Hint Resolve sandwich_same_rt : KBaseHints.

  Lemma sandwich_confluence : forall R1 R2,
    inclusion A R1 R2 ->
    inclusion A R2 (clos_refl_trans_1n A R1) ->
    confluent R1 <-> confluent R2.
  Proof.
    intros R1 R2 R1inR2 R2inR1rt;
    destruct (sandwich_same_rt _ _ R1inR2 R2inR1rt) as [H1 H2];
    split;
    intros C x y z x_y x_z; unfold joinable.
    - assert (x_y_1 : clos_refl_trans_1n A R1 x y) by crush.
      assert (x_z_1 : clos_refl_trans_1n A R1 x z) by crush.
      destruct (C x y z x_y_1 x_z_1).
      ecrush.
    - assert (x_y_2 : clos_refl_trans_1n A R2 x y) by crush.
      assert (x_z_2 : clos_refl_trans_1n A R2 x z) by crush.
      destruct (C x y z x_y_2 x_z_2).
      ecrush.
  Qed.
  #[local] Hint Resolve sandwich_confluence : KBaseHints.

  Lemma sandwich_diamond : forall R1 R2,
    inclusion A R1 R2 ->
    inclusion A R2 (clos_refl_trans_1n A R1) ->
    diamond R2 -> confluent R1.
  Proof.
    intros R1 R2 H1 H2 D;
    assert (H : confluent R2) by crush;
    pose proof (sandwich_confluence R1 R2 H1 H2) as H3;
    crush.
  Qed.
  #[local] Hint Resolve sandwich_diamond : KBaseHints.

  Theorem confluent_locally_confluent : forall (R : relation A),
  confluent R -> locally_confluent R.
  Proof.
    intros R C x y1 y2 x_y1 x_y2;
    destruct (C x y1 y2 (clos_rt1n_step _ _ _ _ x_y1) (clos_rt1n_step _ _ _ _ x_y2));
    ecrush.
  Qed.

  (* Facts about reducibility, normal forms and friends *)

  Theorem nf_terminal : forall (R : relation A) x,
    normal R x -> terminal R x x.
  Proof.
    unfold terminal; crush.
  Qed.
  #[local] Hint Resolve nf_terminal : KBaseHints.

  Theorem nf_rt_equal : forall (R : relation A) x y,
    normal R x ->
    clos_refl_trans_1n A R x y -> x = y.
  Proof.
    unfold normal; unfold reducible;
    intros R x H y x_y; induction x_y; crush;
    exfalso; eauto.
  Qed.
  #[local] Hint Resolve nf_rt_equal : KBaseHints.

  Theorem nf_terminal_equal : forall (R : relation A) x y,
    normal R x ->
    terminal R x y -> x = y.
  Proof.
    unfold terminal; ecrush.
  Qed.
  #[local] Hint Resolve nf_terminal_equal : KBaseHints.

  Theorem terminal_step : forall (R : relation A) x y z,
    R x y -> terminal R y z -> terminal R x z.
  Proof.
    unfold terminal; ecrush.
  Qed.

  Lemma normal_step_false : forall (R : relation A) x y,
    normal R x -> R x y -> False.
  Proof.
    unfold normal; unfold reducible; intros; ecrush.
  Qed.
  #[local] Hint Resolve normal_step_false : KBaseHints.

  Theorem confluent_unique_nf : forall (R : relation A),
    confluent R ->
    forall x y z, terminal R x y -> terminal R x z -> y = z.
  Proof.
    intros R C x y z Ty Tz.
    destruct Ty as [x_y nfy].
    destruct Tz as [x_z nfz].
    destruct (C x y z x_y x_z) as [u [y_u z_u]].
    rewrite (nf_rt_equal R y u nfy y_u).
    rewrite (nf_rt_equal R z u nfz z_u).
    auto.
  Qed.

  Theorem terminating_confluence : forall (R : relation A),
    terminating R ->
    locally_confluent R ->
    confluent R.
  Proof.
    intros R SNR C x; induction (SNR x) as [x H1 H2];
    intros y z x_y x_z; unfold joinable;
    destruct x_y as [| y y1 x_y y_y1 ].
    - ecrush.
    - destruct x_z as [| z z1 x_z z_z1].
      * ecrush.
      * destruct (C x y z x_y x_z) as [u [y_u z_u]].
        destruct (H2 y x_y y1 u y_y1 y_u) as [y' [y1_y' u_y']].
        destruct (H2 z x_z z1 u z_z1 z_u) as [z' [z1_z' z_z']].
        assert (H3 : clos_refl_trans_1n A R y z') by crush.
        assert (H4 : clos_refl_trans_1n A R y y') by crush.
        destruct (H2 y x_y z' y' H3 H4) as [t [z'_t y'_t]].
        exists t; crush.
  Qed.

  (* Facts triangle operators and normalizer *)

  Theorem triangle_diamond : forall (R : relation A) (f : A -> A),
    triangle_op R f ->
    diamond R.
  Proof.
    unfold triangle_op;
    intros R f Tf x y z x_y x_z;
    exists (f x); crush.
  Qed.
  #[local] Hint Resolve triangle_diamond : KBaseHints.

  Theorem triangle_confluent : forall (R1 R2 : relation A) (f : A -> A),
    inclusion A R1 R2 ->
    inclusion A R2 (clos_refl_trans_1n A R1) ->
    triangle_op R2 f ->
    confluent R1.
  Proof.
    ecrush.
  Qed.

End Properties.

#[global]
Hint Resolve
  idempotence_rt
  monotonicity_rt
  preserve_rt
  preserve_rt_left
  preserve_rt_right
  preserve_rt_para
  diamond_semi_confluent
  semi_confluent_confluent
  nf_terminal
  normal_step_false
  confluent_unique_nf
  terminating_confluence
  nf_terminal_equal
  nf_rt_equal
  triangle_confluent
  triangle_diamond
  sandwich_diamond
  sandwich_confluence
  sandwich_same_rt : KBaseHints.

#[global]
Hint Unfold joinable reducible normal terminal WN : KBaseHints.

#[global]
Hint Extern 1 (terminal ?R ?x ?z) =>
match goal with
  | H: terminal ?R ?y z |- _ => apply (terminal_step R x y z)
  | H: R x ?y |- _ => apply (terminal_step R x y z H)
  end : KBaseHints.


(**********************************************************************)
(*  v      *   Burrows-Wheeler transform defined in Coq.              *)
(* <O___,, *   Coquistadores  -  Copyright (c) 2017                   *)
(*   \VV/  ************************************************************)
(*    //   *   Authors:   Alan Padilla Chua, Hanlin He                *)
(*         *              Paul Parrot, Sourav Dasgupta                *)
(**********************************************************************)

Require Import List Nat Arith.
Require Import Ascii String.
Require Import Datatypes.
Require Import FunctionalExtensionality.

(*Local Open Scope char_scope.*)
Local Open Scope string_scope.
Open Scope bool_scope.

(** Define type for [char], [str], [str_matrix]. *)
Definition char := option nat.
Definition str := nat -> char.
Definition str_matrix := nat -> str.

Definition eqdec (A:Type) := forall x y:A, {x=y}+{x<>y}.

(** A generic "update" function for mapping "nat -> A". *)
(* Note: The definition might be generalized again to update mapping "A -> B",
 * but it would require to implement or pass as input an alternative comparing
 * function other than "Nat.eqb". *)

Definition update {A : Type} (f : nat -> A) (x: nat) (y: A) : nat -> A :=
  fun (n : nat) => if Nat.eq_dec n x then y else f n.

(** Transform a string to a list of ascii. *)
Fixpoint string_to_list (s : string): list ascii :=
  match s with
  | EmptyString => nil
  | String h t => h :: string_to_list t
  end.

(** Map ascii to nat in a list. *)
Fixpoint ascii_to_nat_list (l : list ascii) : list char :=
  match l with
  | nil => nil
  | h :: t => Some (nat_of_ascii h) :: ascii_to_nat_list t
  end.

(** Transform a nat list to a index -> nat mapping, i.e. nat -> option nat. *)
Fixpoint list_to_map (l : list char) (start_index : nat) : str :=
  match l with
  | nil => fun _ => None
  | h :: t => update (list_to_map t (S start_index)) start_index h
  end.

(** Use function defined above, generate a index to nat mapping from given string. *)
Definition string_to_map (word : string) : str :=
  list_to_map (ascii_to_nat_list (string_to_list word)) O.

(** helper functions **)
(* "option_ascii_of_nat_option : option nat -> option ascii" using library function "ascii_of_nat : nat -> ascii". *)
Definition option_ascii_of_nat_option (n : char) : option ascii :=
  match n with
  | None => None
  | Some n' => Some (ascii_of_nat n')
  end.
(* "option_nat_of_ascii_option : option ascii -> option nat" using library function "nat_of_ascii : ascii -> nat". *)
Definition option_nat_of_ascii_option (a : option ascii) : char :=
  match a with
  | None => None
  | Some a' => Some (nat_of_ascii a')
  end.

(*  Alternative definition of "string_to_map", which use library function
    "get : nat -> string -> option ascii" directly. *)
Definition string_to_map' (word : string) : str :=
  fun n => option_nat_of_ascii_option (get n word).

(*  Mirror theorem for "ascii_nat_embedding" with option. *)
Theorem ascii_nat_embedding_option :
  forall a : option ascii, option_ascii_of_nat_option (option_nat_of_ascii_option a) = a.
Proof.
  intros.
  destruct a.
  - simpl. rewrite -> ascii_nat_embedding. reflexivity.
  - simpl. reflexivity.
Qed.

(** Test "string_to_map". **)
Definition hello_world_str := "Hello World!".
Definition cat_str := "Cat".

Definition hello_world := string_to_map hello_world_str.
Definition hello_world_length := String.length hello_world_str.

Definition cat := string_to_map cat_str.
Definition cat_length := String.length cat_str.

(** Prove that if given "list_to_map" a different index, to get the same element,
    the parameter to the mapping should change the same difference. *)
Lemma list_to_map_index_difference:
  forall (l : list char) (m n : nat),
    (list_to_map l m) n = (list_to_map l (S m)) (S n).
Proof.
  induction l; intros; simpl.
  - reflexivity.
  - unfold update. simpl. destruct (Nat.eq_dec n m).
    + reflexivity.
    + specialize (IHl (S m) n). exact IHl.
Qed.

(** Prove that if prepend a character to a string, to get the same character again,
    increase the index by 1. *)
Lemma prepend_string_to_map:
  forall (s : string) (n : nat) (a : ascii),
    string_to_map s n = string_to_map (String a s) (S n).
Proof.
  unfold string_to_map.
  induction s; induction n; simpl; unfold update; simpl.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - rewrite list_to_map_index_difference. reflexivity.
Qed.

(** Prove the "string_to_map" create right mapping. **)
Theorem String_to_Map:
  forall (s : string) (n : nat),
    option_ascii_of_nat_option (string_to_map s n) = String.get n s.
Proof.
  induction s; intro n.
  - simpl. reflexivity.
  - destruct n; simpl.
    + rewrite -> ascii_nat_embedding. reflexivity.
    + rewrite <- prepend_string_to_map. specialize (IHs n). exact IHs.
Qed.

(** Prove the "string_to_map'" create right mapping, might be trivial. **)
Theorem String_to_Map':
  forall (s : string) (n : nat),
    option_ascii_of_nat_option (string_to_map' s n) = String.get n s.
Proof.
  induction s; intros; simpl.
  - reflexivity.
  - induction n; unfold string_to_map'; simpl.
    + rewrite -> ascii_nat_embedding. reflexivity.
    + rewrite -> ascii_nat_embedding_option. reflexivity.
Qed.

(* Following implementation relies on length of the string,
which is hard to compute directly from the mapping,
so the previously computed value used here (not good). *)

(* Right-shift a mapping by one and return a new mapping. *)
Definition right_shift (m : str) (l : nat) : str :=
  fun n =>
    match n with
    | O => m l
    | S n' => m n'
    end.

Example hello_world_r1 := right_shift hello_world hello_world_length.
Example hello_world_r2 := right_shift hello_world_r1 hello_world_length.
Example hello_world_r3 := right_shift hello_world_r2 hello_world_length.
Example hello_world_r4 := right_shift hello_world_r3 hello_world_length.
Example hello_world_r5 := right_shift hello_world_r4 hello_world_length.

Compute option_ascii_of_nat_option (hello_world_r1 0).
Compute option_ascii_of_nat_option (hello_world_r2 1).
Compute option_ascii_of_nat_option (hello_world_r3 1).
Compute option_ascii_of_nat_option (hello_world_r4 1).
Compute option_ascii_of_nat_option (hello_world_r5 1).

(** String start with index 0. *)

(** Get the first letter. *)
Definition first (m : str) : char := m O.

(** Get the last letter. *)
Definition last (m : str) (length : nat) : char :=
  match length with
  | O => None
  | S length' => m length'
  end.

Eval compute in last hello_world hello_world_length.

(* functional extensionality *)

(** Generate right-shift permutation matrix of the string mapping. **)
(*  Helper recursion definition, which keeps a constant length through recursion. *)
Fixpoint map_to_conjugacy' (m : str) (l length: nat) := (* Define the actual recursive function, induction on l. *)
    match l with
    | O => update (fun _ _ => None) O m
    | S l' => let l'_conjugacy := map_to_conjugacy' m l' length in
              update l'_conjugacy l (right_shift (l'_conjugacy l') length)
    end.

Definition map_to_conjugacy (m : str) (length: nat) : str_matrix :=
  map_to_conjugacy' m length length.

Example hello_world_matrix := map_to_conjugacy hello_world hello_world_length.

Compute option_ascii_of_nat_option (hello_world_matrix 0 0).
Compute option_ascii_of_nat_option (hello_world_matrix 1 0).
Compute option_ascii_of_nat_option (hello_world_matrix 2 0).
Compute option_ascii_of_nat_option (hello_world_matrix 3 0).
Compute option_ascii_of_nat_option (hello_world_matrix 3 2).
Compute option_ascii_of_nat_option (hello_world_matrix 3 3).

(** Extract the last column from the matrix. **)
(* Originally both "r" and "c" were passed as parameter, and induction on r.
 * Now only length is passed, and internally a constant "last_col_index" was kept,
 * and induction directly on length. *)

Fixpoint lasts' (matrix : str_matrix) (row length : nat) :=
  match row with
  | O => update (fun _ => None) O (matrix O length)
  | S row' => update (lasts' matrix row' length) row (matrix row length)
  end.

Definition lasts (matrix : str_matrix) (length : nat) : str :=
  lasts' matrix length length.

Example last_col := lasts hello_world_matrix hello_world_length.

Compute option_ascii_of_nat_option (last_col 0).
Compute option_ascii_of_nat_option (last_col 1).
Compute option_ascii_of_nat_option (last_col 2).
Compute option_ascii_of_nat_option (last_col 3).
Compute option_ascii_of_nat_option (last_col 11).

Fixpoint map_to_string' (len : nat) (i : nat) (map : str) : string :=
  match len with
  | O => EmptyString
  | S len' => match option_ascii_of_nat_option (map i) with
              | Some a => String a (map_to_string' len' (S i) map)
              | None => map_to_string' len' (S i) map
              end
  end.

Definition map_to_string (len : nat) (map : str) : string :=
  map_to_string' len (S O) map.

Eval compute in map_to_string hello_world_length last_col.

(** Define whether two [str]s are reverse of each other at lenght "n". *)
Definition reverse_str (n : nat) (f1 f2 : str) : Prop :=
  forall (n1 n2: nat), n1 + n2 = n <-> f1 n1 = f2 n2.

(** Define whether two [str]s are the same. *)
Definition same_str (f1 f2 : str) : Prop :=
  forall (n : nat), f1 n = f2 n.

(** Prove that the last column of the right-shift permutation matrix is the reverse of the original string mapping. **)
Theorem last_col_reverse:
  forall (s : string) (l : nat) (m : nat -> option nat),
    l = String.length s -> m = string_to_map s -> reverse_str l m (lasts (map_to_conjugacy m l) l).
Proof.
  intros.
  unfold map_to_conjugacy.
  unfold lasts.
Abort.

(** Final BWT implementation taking a sort function as input. *)
Definition bwt (s : string) (sort: (nat -> nat -> option nat) -> (nat ->  nat -> option nat)) : string :=
  let s_length := String.length s in
  let s_map := string_to_map s in
  let s_matrix := map_to_conjugacy s_map s_length in
  let sorted_matrix := sort s_matrix in
  map_to_string s_length (lasts sorted_matrix s_length).

(* An example bwt without sorting. *)
Eval compute in bwt hello_world_str (fun x => x).

(** Option nat order. *)
Definition optnat_leq (x y : option nat) :=
  match y with None => True | Some n =>
    match x with None => False | Some m => m <= n end
  end.

(** Option nat equility. *)
Definition optnat_eqb (a1 a2 : option nat) :=
  match a1, a2 with
  | None, None => True
  | None, _ => False
  | _, None => False
  | Some a1', Some a2' => Nat.eqb a1' a2' = true
  end.

(** Generic sequence leq ordering. *)
Fixpoint leq_seq {A:Type} (eq leq : A -> A -> Prop) (k : nat) (s1 s2 : nat -> A) : Prop :=
  match k with
  | O => leq (s1 O) (s2 O)
  | S m => (eq (s1 O) (s2 O) /\ leq_seq eq leq m (fun i => s1 (S i)) (fun i => s2 (S i)))
            \/ leq (s1 O) (s2 O)
  end.

(** Generic sequence equility based on leq. *)
Fixpoint eq_seq {A:Type} (eq : A -> A -> Prop) (k : nat) (s1 s2 : nat -> A) : Prop :=
  match k with
  | O => eq (s1 O) (s2 O)
  | S m => eq (s1 O) (s2 O) /\ eq_seq eq m (fun i => s1 (S i)) (fun i => s2 (S i))
  end.

(** Option nat sequence leq ordering based on leq_seq. *)
Definition leq_optnatctx (k : nat) (s1 s2 : str) : Prop :=
  leq_seq optnat_eqb optnat_leq k s1 s2.

(** Option nat sequence equility  based on eq_seq. *)
Definition eq_optnatctx (k : nat) (s1 s2 : str) : Prop :=
  eq_seq optnat_eqb k s1 s2.

(** String matrix sequence equility  based on eq_seq. *)
Definition eq_matrix (k : nat) (s1 s2 : str_matrix) : Prop :=
  eq_seq (eq_optnatctx k) k s1 s2.

(** String leq ordering for all context. *)
Definition leq_optnatseq s1 s2 := forall k, leq_optnatctx k s1 s2.

(** The image of function f is sorted with respect to order relation R. *)
Definition sorted {A:Type} (R: A -> A -> Prop) (f: nat -> A) :=
  forall i, R (f i) (f (S i)).

(* If relation R is reflexive and transitive, then image(f)'s ordering is also transitive. *)
Definition reflexive {A:Type} (R: A -> A -> Prop) :=
  forall a, R a a.

Definition transitive {A:Type} (R: A -> A -> Prop) :=
  forall a c b, R a b -> R b c -> R a c.

Theorem sorted_transitive {A:Type}
  (R: A -> A -> Prop) (RE: reflexive R) (TR: transitive R) :
  forall (f: nat -> A) (SRT: sorted R f) i j, i <= j -> R (f i) (f j).
Proof.
  intros f SRT i j. revert i. induction j; intros; inversion H.
    apply RE.
    apply RE.
    eapply TR. apply IHj. assumption. apply SRT.
Qed.

(* Permutation functions are injective and surjective. *)
Definition injective {A B:Type} (f: A -> B) :=
  forall i j, f i = f j -> i=j.

Definition surjective {A B:Type} (f: A -> B) :=
  forall j, exists i, f i = j.

Definition bijective {A B:Type} (f: A -> B) :=
  injective f /\ surjective f.

(* Return the character at position i of string m *)
Definition lambda (m:nat -> option nat) (i:nat) := m i.

(* Returns the position of an alphabet 'char' in string 'm' of length 'length' *)
Fixpoint get_pos (eq:eqdec (option nat)) (m:nat -> option nat) (length:nat) (char: option nat) : nat :=
  match length with
  |0 => if (eq (m 0) char) then 0 else (S length)
  |S l => if (eq (m length) char) then length else (get_pos eq m l char)
  end.

(* Introduce sorted string as assumption, not sort it inside. *)
Definition pi (eq:eqdec (option nat)) (length:nat) (m sorted_m: str) : (nat -> nat):=
fun (x:nat) => get_pos eq (sorted_m) length (m x).

Definition context (k:nat) (m: nat -> (option nat)) : (nat -> (option nat)) :=
fun (x:nat) => if (x <? k) then (m x) else None.

(* Use [pi'] instead of [pi]. *)
Fixpoint inverse_bwt' (eq:eqdec (option nat)) (tot_length:nat) (i k:nat) (m sorted_m :nat -> (option nat)) : (nat-> nat) :=
let p' := (pi eq k m sorted_m) in
let f := fun _ => (S tot_length) in
match k with
|O => f
|S l => let rec :=  (inverse_bwt' eq tot_length i l m sorted_m) in
       update rec k (p'(rec l)) (*  (lambda m ((pi eq l sort rec) k))   *)
end.

(** Use [inverse_bwt']. *)
Definition inverse_bwt (eq:eqdec (option nat)) (tot_length:nat) (i k:nat) (m sorted_m: str) :=
fun n => lambda m (inverse_bwt' eq tot_length i k m sorted_m n).

(* We tried to define what is a sorted string and string matrix. *)
Definition sorted_str (m m_sorted: str) (k : nat) : Prop := True.
Definition sorted_matrix (matrix : str_matrix) (k : nat) : Prop := True.

(* Length is then a property like the following: *)
Definition haslen {A:Type} (f : nat -> option A) (len: nat) :=
  (*forall i, len <= i <-> f i = None.*)
  forall l, l > len -> f l = None.

Definition prepend (s : str) (c : option nat) : str :=
  fun n =>
    match n with
    | O => c
    | S n' => s n'
    end.

Definition concat (s1 s2: str) (l1 l2 : nat) : str :=
  fun n => if leb n l1 then s1 n else s2 (n - l1).

(** Right shift is equivalent with prepend last letter. *)
Lemma context_k (w: str_matrix) (L : str) (length : nat) :
  forall (k i : nat),
    k <= length ->
    i <= length ->
    same_str (context (S k) (right_shift (w i) length)) (prepend (context k (w i)) (lambda L i)).
Proof.
  induction k.
  - intros. unfold right_shift.
Admitted.

Definition right_shift_matrix (w: str_matrix) (length : nat) : str_matrix :=
  fun n => right_shift (w n) length.

Lemma Right_Shift (w : str_matrix) (length : nat) (sort : nat -> str_matrix -> str_matrix) :
  forall t ,
    t < length ->
    sorted (leq_optnatctx t) w ->
    eq_matrix (S t) (sort 1 (right_shift_matrix w length)) (sort (S t) (right_shift_matrix w length)).
Proof.
Admitted.

Lemma sort_matrix (w: str_matrix) (length : nat) (k : nat) (sort : nat -> str_matrix -> str_matrix) (pi : nat -> nat) :
  sorted_matrix w k ->
  forall (n : nat), same_str (sort (S k) (right_shift_matrix w length) n) (right_shift (w (pi n)) length).
Proof.
Admitted.

Theorem matrix (w1 w2 : str_matrix) (L L_sorted: str) (length : nat) (eq:eqdec (option nat)) (k : nat) :
  forall (i: nat) ,
    i <= length ->
    haslen L length ->
    haslen L_sorted length ->
    sorted (leq_optnatctx k) w1 ->
    sorted (leq_optnatctx (S k)) w2 ->
    same_str L (lasts w1 length) ->
    sorted_str L L_sorted length ->
    forall x : nat, x <= k -> same_str (context x (w1 i)) (inverse_bwt eq length i x L L_sorted).
Proof.
  induction x.
  intros.
  unfold same_str.
  unfold context.
  unfold inverse_bwt.
  intro n. destruct n; simpl.
  unfold lambda. rewrite H0. reflexivity. auto.
  unfold lambda. rewrite H0. reflexivity. auto.
Abort.


(* Exercise 119 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_119 : ~~A -> ~~(A \/ B).
Proof.
imp_i a1.
neg_i (~A) a2.
hyp a1.
neg_i (A \/ B) a3.
hyp a2.
dis_i1.
hyp a3.
Qed.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <aciclo@gmail.com>                                        *)
(*                                        Computer Science Department, USTC   *)
(*                                                                            *)
(*           Hui Zhang <sa512073@mail.ustc.edu.cn>                            *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

(* Version 0.1 *)

Require Export Bool.
Require Import Arith.

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

Theorem nat_eq_dec : forall a b : nat, {a = b} + {a <> b}.
Proof.
  intros; compare a b; auto.
Qed.

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

Fixpoint blt_nat (n m : nat) {struct n} : bool :=
  match n, m with
  | O, O => false
  | O, S _ => true
  | S _, O => false
  | S n', S m' => blt_nat n' m'
  end.

Lemma blt_irrefl :
  forall a : nat, blt_nat a a = false.
Proof.
  induction a; simpl; auto.
Qed.

Lemma blt_irrefl_Prop :
  forall a : nat, ~ (blt_nat a a = true).
Proof.
  induction a; simpl; auto.
Qed.

Lemma blt_asym :
  forall a b : nat, blt_nat a b = true
    -> blt_nat b a = false.
Proof.
  double induction a b; simpl; intros; auto.
Qed.

Lemma blt_O_Sn :
  forall n : nat, blt_nat O (S n) = true.
Proof.
  induction n; simpl; auto.
Qed.

Lemma blt_n_O : forall n,
  blt_nat n O = false.
Proof.
  induction n; simpl; auto.
Qed.

Lemma not_blt_n_O :
  forall n : nat, ~ (blt_nat n 0 = true).
Proof.
  induction n; simpl; auto.
Qed.

Lemma blt_true_lt :
  forall a b : nat, blt_nat a b = true -> a < b.
Proof.
  double induction a b; simpl; intros;
    auto with arith; try discriminate.
Qed.

Lemma blt_false_le :
  forall n m, blt_nat n m = false -> m <= n.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma le_blt_false :
  forall n m, n <= m -> blt_nat m n = false.
Proof.
  double induction n m; simpl; intros;
    auto with arith.
  destruct (lt_n_O _ H0).
Qed.

Lemma lt_blt_true :
  forall a b : nat, a < b -> blt_nat a b = true.
Proof.
  double induction a b; simpl; intros;
    auto with arith.
  destruct (lt_irrefl 0 H).
  destruct (lt_n_O (S n) H0).
Qed.

Lemma blt_n_Sn :
  forall n : nat, blt_nat n (S n) = true.
Proof.
  induction n; simpl; intros; auto with arith.
Qed.

Lemma blt_S_eq :
  forall a b, blt_nat a b = blt_nat (S a) (S b).
Proof.
  trivial.
Qed.

Lemma blt_n_Sm :
  forall n m, blt_nat n m = true
    -> blt_nat n (S m) = true.
Proof.
  double induction n m; simpl; intros; auto with arith.
  discriminate.
Qed.

Lemma blt_n_mk :
  forall n m k, blt_nat n m = true
    -> blt_nat n (m + k) = true.
Proof.
  double induction n m; simpl; intros;
    auto with arith;  discriminate.
Qed.

Lemma blt_n_km :
  forall n m k, blt_nat n m = true
    -> blt_nat n (k + m) = true.
Proof.
  double induction n m; simpl; intros;
    auto with arith; try discriminate.
  replace (k + (S n0)) with ((S n0) + k);
    [idtac | auto with arith].
  simpl. trivial.
  replace (k + (S n0)) with ((S n0) + k);
    [idtac | auto with arith].
  simpl.
  replace (n0 + k) with (k + n0);
    [idtac | auto with arith].
  apply H0; trivial.
Qed.

Lemma blt_nat_dec : forall a b,
  {blt_nat a b = true} + {blt_nat a b = false}.
Proof.
  double induction a b; simpl; intros; try tauto || auto.
Qed.

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

Definition ble_nat (n m : nat) : bool :=
  match blt_nat m n with
    | true => false
    | false => true
  end.

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

Fixpoint beq_nat (n m : nat)  {struct n} : bool :=
  match n, m with
  | O, O => true
  | O, S _ => false
  | S _, O => false
  | S n1, S m1 => beq_nat n1 m1
  end.

Lemma beq_refl : forall m, beq_nat m m = true.
Proof.
  induction m; simpl; intros; auto.
Qed.

Lemma beq_trans : forall m n k, beq_nat m n = true
  -> beq_nat n k = true
  -> beq_nat m k = true.
Proof.
  induction m; induction n; destruct k;
    simpl; intros; discriminate || auto.
  eapply IHm; eauto.
Qed.

Lemma beq_sym : forall m n b,
  beq_nat m n = b -> beq_nat n m = b.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma beq_sym2 : forall m n,
  beq_nat m n = beq_nat n m.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma beq_true_eq :
  forall n m, beq_nat n m = true
    -> n = m.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma beq_false_neq :
  forall n m, beq_nat n m = false
    -> ~ (n = m).
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma eq_beq_true :
  forall n m, n = m
    -> beq_nat n m = true.
Proof.
  double induction n m; simpl; intros;
    auto with arith; discriminate.
Qed.

Lemma neq_beq_false :
  forall n m, ~ (n = m)
    -> beq_nat n m = false.
Proof.
  double induction n m; simpl; intros;
    auto with arith.
  destruct (H (refl_equal _)).
Qed.

Lemma beq_nat_dec : forall a b,
  {beq_nat a b = true} + {beq_nat a b = false}.
Proof.
  double induction a b; simpl; intros; try tauto || auto.
Qed.

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

Lemma blt_t_beq_f :
  forall m n, blt_nat m n = true
    -> beq_nat m n = false.
Proof.
  double induction n m; simpl; intros; auto with arith.
Qed.

Lemma bgt_t_beq_f :
  forall m n, blt_nat n m = true
    -> beq_nat m n = false.
Proof.
  double induction m n; simpl; intros; auto with arith.
Qed.

Lemma beq_t_blt_f :
  forall m n, beq_nat m n = true
    -> blt_nat m n = false.
Proof.
  double induction m n; simpl; intros; auto with arith.
Qed.

Lemma beq_t_bgt_f :
  forall m n, beq_nat m n = true
    -> blt_nat n m = false.
Proof.
  double induction n m; simpl; intros; auto with arith.
Qed.

Lemma blt_S_dec :
  forall n m,
    blt_nat n (S m) = true
    -> blt_nat n m = true \/ beq_nat n m = true.
Proof.
  intros n m H.
  assert (Hx:=blt_true_lt _ _ H).
  apply lt_n_Sm_le in Hx.
  apply le_lt_or_eq_iff in Hx.
  destruct Hx.
    left.
    apply lt_blt_true; trivial.
  right.
  apply eq_beq_true; trivial.
Qed.

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

Definition max_nat (m n : nat) : nat :=
  if blt_nat m n then n else m.

Lemma max_nat_elim_l : forall m n : nat,
  m <= max_nat m n.
Proof.
  unfold max_nat; intros m n.
  destruct (blt_nat_dec m n) as [Hb | Hb]; rewrite Hb.
  assert (Hb' := blt_true_lt m n Hb).
  auto with arith.
  auto with arith.
Qed.

Lemma max_nat_elim_r : forall m n : nat,
  n <= max_nat m n.
Proof.
  unfold max_nat; intros m n.
  destruct (blt_nat_dec m n) as [Hb | Hb]; rewrite Hb.
  auto with arith.
  assert (Hb' := blt_false_le m n Hb).
  auto with arith.
Qed.

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

Ltac rewrite_bnat t :=
  match type of t with
    | blt_nat ?a ?b = ?c => rewrite t
    | beq_nat ?a ?b = ?c => rewrite t
  end.

Ltac rewrite_bnat_H t H :=
  match type of t with
    | blt_nat ?a ?b = ?c => rewrite t in H
    | beq_nat ?a ?b = ?c => rewrite t in H
  end.

Ltac rewrite_bnat_all t :=
  match goal with
    | |- context[(blt_nat ?a ?b)] => rewrite_bnat t; rewrite_bnat_all t
    | H : context[(blt_nat ?a ?b)] |- _ => rewrite_bnat_H t H; rewrite_bnat_all t
    | |- context[(beq_nat ?a ?b)] => rewrite_bnat t; rewrite_bnat_all t
    | H : context[(beq_nat ?a ?b)] |- _ => rewrite_bnat_H t H; rewrite_bnat_all t
    | _ => idtac
  end.

Ltac simplbnat :=
  match goal with
    (* blt rewrite directly *)
    | [H : blt_nat ?x ?y = ?f
      |- context [(blt_nat ?x ?y)]] =>
       rewrite H; simplbnat
    | [H : blt_nat ?x ?y = ?f,
       H0 : context [(blt_nat ?x ?y)]
      |- _ ] =>
       rewrite H in H0; simplbnat

    (* beq rewrite directly *)
    | [H : beq_nat ?x ?y = ?f
      |- context [(beq_nat ?x ?y)]] =>
       rewrite H; simplbnat
    | [H : beq_nat ?x ?y = ?f,
       H0 : context [(beq_nat ?x ?y)] |- _ ] =>
       rewrite H in H0; simplbnat

    (* blt -> beq *)
    | [H : blt_nat ?x ?y = true
      |- context[(beq_nat ?x ?y)]] =>
      rewrite (blt_t_beq_f x y H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context[(beq_nat ?x ?y)] |- _ ] =>
      rewrite (blt_t_beq_f x y H) in H0; simplbnat

    (* bgt -> beq *)
    | [H : blt_nat ?y ?x = true
      |- context[(beq_nat ?x ?y)]] =>
      rewrite (bgt_t_beq_f x y H); simplbnat
    | [H : blt_nat ?y ?x = true,
       H0 : context[(beq_nat ?x ?y)] |- _ ] =>
      rewrite (bgt_t_beq_f x y H) in H0; simplbnat

    (* beq -> blt *)
    | [H : beq_nat ?y ?x = true
      |- context[(blt_nat ?x ?y)]] =>
      rewrite (beq_t_blt_f x y H); simplbnat
    | [H : beq_nat ?y ?x = true,
       H0 : context[(blt_nat ?x ?y)] |- _ ] =>
      rewrite (beq_t_blt_f x y H) in H0; simplbnat

    (* beq -> bgt *)
    | [H : beq_nat ?y ?x = true
      |- context[(blt_nat ?y ?x)]] =>
      rewrite (beq_t_bgt_f x y H); simplbnat
    | [H : beq_nat ?y ?x = true,
       H0 : context[(blt_nat ?y ?x)] |- _ ] =>
      rewrite (beq_t_bgt_f x y H) in H0; simplbnat

    (* blt_irrefl *)
    | [ |- context [blt_nat ?x ?x]] =>
      rewrite (blt_irrefl x); simplbnat
    | [H : context [blt_nat ?x ?x] |- _ ] =>
      rewrite (blt_irrefl x) in H; simplbnat

    (* blt_asym *)
    | [H : blt_nat ?x ?y = true
      |- context [blt_nat ?y ?x]] =>
      rewrite (blt_asym x y H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context [blt_nat ?y ?x] |- _ ] =>
      rewrite (blt_asym x y H) in H0; simplbnat

    (* blt_O_Sn *)
    | [ |- context [(blt_nat O (S ?x))]] =>
      rewrite (blt_O_Sn x); simplbnat
    | [H : context [(blt_nat O (S ?x))] |- _ ] =>
      rewrite (blt_O_Sn x) in H; simplbnat

    (* blt_n_O *)
    | [ |- context [(blt_nat ?x O)]] =>
      rewrite (blt_n_O x); simplbnat
    | [H : context [(blt_nat ?x O)] |- _ ] =>
      rewrite (blt_n_O x) in H; simplbnat

    (* blt_n_Sn *)
    | [ |- context [(blt_nat ?x (S ?x))]] =>
      rewrite (blt_n_Sn x); simplbnat
    | [H : context [(blt_nat ?x (S ?x))] |- _ ] =>
      rewrite (blt_n_Sn x) in H; simplbnat

    (* blt_S_eq *)
    | [ |- context [(blt_nat (S ?x) (S ?y))]] =>
      rewrite <- (blt_S_eq x y); simplbnat
    | [H : context [(blt_nat (S ?x) (S ?y))] |- _ ] =>
      rewrite <- (blt_S_eq x y) in H; simplbnat

    (* blt_n_Sm *)
    | [H : blt_nat ?x ?y = true
      |- context [(blt_nat ?x (S ?y))]] =>
      rewrite (blt_n_Sm x y H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context [(blt_nat ?x (S ?y))] |- _ ] =>
      rewrite <- (blt_n_Sm x y H) in H0; simplbnat

    (* blt_n_mk *)
    | [H : blt_nat ?x ?y = true
      |- context [(blt_nat ?x (?y + ?k))]] =>
      rewrite (blt_n_mk x y k H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context [(blt_nat ?x (?y + ?k))] |- _ ] =>
      rewrite <- (blt_n_mk x y k H) in H0; simplbnat

    (* blt_n_km *)
    | [H : blt_nat ?x ?y = true
      |- context [(blt_nat ?x (?k + ?y))]] =>
      rewrite (blt_n_km x y k H); simplbnat
    | [H : blt_nat ?x ?y = true,
       H0 : context [(blt_nat ?x (?k + ?y))] |- _ ] =>
      rewrite <- (blt_n_km x y k H) in H0; simplbnat

    (* beq_refl *)
    | [ |- context [(beq_nat ?x ?x)] ] =>
      rewrite (beq_refl x); simplbnat
    | [H : context [(beq_nat ?x ?x)] |- _ ] =>
      rewrite (beq_refl x) in H; simplbnat

    (* beq_sym *)
    | [ H : beq_nat ?x ?y = ?b
        |- context [(beq_nat ?y ?x)] ] =>
      rewrite (beq_sym x y b H); simplbnat
    | [H : beq_nat ?x ?y = ?b,
       H0 : context [(beq_nat ?y ?x)] |- _ ] =>
      rewrite (beq_sym x y b H) in H0; simplbnat

    | [ H : ?x <> ?y |- context [(beq_nat ?x ?y)] ] =>
      rewrite (neq_beq_false x y H); simplbnat
    | [ H : ?x <> ?y,
        H0 : context [(beq_nat ?x ?y)] |- _ ] =>
      rewrite (neq_beq_false x y H) in H0; simplbnat

    | [ H : ?y <> ?x |- context [(beq_nat ?x ?y)] ] =>
      rewrite (neq_beq_false x y (sym_not_eq H)); simplbnat
    | [ H : ?y <> ?x,
        H0 : context [(beq_nat ?x ?y)] |- _ ] =>
      rewrite (neq_beq_false x y (sym_not_eq H)) in H0; simplbnat

    | [H : ?x = ?x |- _ ] => clear H; simplbnat
    | [H : true = false |- _ ] => discriminate H
    | [H : false = true |- _ ] => discriminate H
    | _ => idtac
  end.

Tactic Notation "bnat simpl" := simplbnat.

Ltac desbnatH H :=
  match goal with
    | H : blt_nat ?a ?b = true |- _ =>
        generalize (blt_true_lt a b H); clear H; intro H

    | H : blt_nat ?a ?b = false |- _ =>
        generalize (blt_false_le a b H); clear H; intro H

    | H : beq_nat ?a ?b = true |- _ =>
        generalize (beq_true_eq a b H); clear H; intro H

    | H : beq_nat ?a ?b = false |- _ =>
        generalize (beq_false_neq a b H); clear H; intro H

    | _ => fail 1 "not bnat found"
  end.

Ltac desbnat :=
  match goal with
    | H : blt_nat ?a ?b = true |- _ =>
        generalize (blt_true_lt a b H); clear H; intro H; desbnat

    | H : blt_nat ?a ?b = false |- _ =>
        generalize (blt_false_le a b H); clear H; intro H; desbnat

    | H : beq_nat ?a ?b = true |- _ =>
        generalize (beq_true_eq a b H); clear H; intro H; desbnat

    | H : beq_nat ?a ?b = false |- _ =>
        generalize (beq_false_neq a b H); clear H; intro H; desbnat

    | _ => idtac
  end.

Ltac conbnat :=
  match goal with
    | |- blt_nat ?a ?b = true =>
        apply (lt_blt_true a b)

    | |- blt_nat ?a ?b = false =>
        apply (le_blt_false b a)

    | |- beq_nat ?a ?b = true =>
        apply (eq_beq_true a b)

    | |- beq_nat ?a ?b = false =>
        apply (neq_beq_false a b)

    | _ => fail 1 "the goal is not bnat"
  end.

Ltac solvebnat :=
  desbnat; conbnat; auto with arith.

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

Tactic Notation "rewbnat" constr (t) :=
  match t with
    | beq_nat ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [solvebnat | rewrite Hb; clear Hb])
    | blt_nat ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [solvebnat | rewrite Hb; clear Hb])
    | _ =>
      match type of t with
        | beq_nat ?x ?y = true => rewrite (beq_true_eq x y t)
        | _ => rewrite t
      end
  end.

Tactic Notation "rewbnat" constr (t) "in" hyp (H) :=
  match t with
    | beq_nat ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [solvebnat | rewrite Hb in H; clear Hb])
    | blt_nat ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [solvebnat | rewrite Hb in H; clear Hb])
    | _ =>
      match type of t with
        | beq_nat ?x ?y = true => rewrite (beq_true_eq x y t) in H
        | _ => rewrite t in H
      end
  end.

Tactic Notation "assertbnat" constr (t) :=
  let Hb := fresh "Hb" in (
    match t with
      | beq_nat ?x ?y = ?f =>
        (assert (Hb : t);
            [solvebnat | idtac])
      | blt_nat ?x ?y = ?f =>
        (assert (Hb : t);
            [solvebnat | idtac])
      | _ => fail 1 "t must be a blt_nat or beq_nat equation"
    end).

Ltac discribnat :=
  desbnat; subst;
  match goal with
    | H : ?x <> ?x |- _ => destruct (H (refl_equal x))
    | H : ?x = ?y |- _ => discriminate
    | H : ?x < ?x |- _ => destruct (lt_irrefl x H)
    | H : ?x < O |- _ => destruct (lt_n_O x H)
    | H : beq_nat ?x ?x = false |- _ =>
      desbnatH H; destruct (H (refl_equal x))
    | _ => elimtype False;
        auto with arith || fail 1 "no discriminatable hypothesis"
  end.

Ltac substbnat_all := desbnat; subst.

Ltac substbnat_one f := desbnat; subst f.

Tactic Notation "substbnat" := substbnat_all.

Tactic Notation "substbnat" constr (f) := substbnat_one f.

(*
Section test.

Variables (a b c d e f g : nat).
Hypotheses
  (H0 : beq_nat a b = true)
  (H1 : blt_nat c b = true)
  (H2 : blt_nat b a = true)
  (H3 : beq_nat a b = true)
  (H4 : beq_nat a b = true)
  (H5 : if beq_nat a b then True else False)
.

Goal if beq_nat a b then True else False.
simplbnat.
rewrite_bnat_all H0.
substbnat.
rewbnat H0 in H3.
invbnat.
bnat2nat.
omega.
simplbnat.

End test. *)

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

Ltac decbeqnat x y :=
  let Hb := fresh "Hb" in
    (destruct (beq_nat_dec x y) as [Hb | Hb]; simplbnat).

Ltac decbltnat x y :=
  let Hb := fresh "Hb" in
    (destruct (blt_nat_dec x y) as [Hb | Hb]; simplbnat).

(* *********************************************************** *)
(* deprecate *)

Tactic Notation "repbnat" constr (t1) "with" constr (t2) :=
  replace t1 with t2; [idtac | desbnat; auto with arith].

Tactic Notation "repbnat" constr (t1) "with" constr (t2) "in" hyp (H) :=
  replace t1 with t2 in H; [idtac | desbnat; auto with arith].

Tactic Notation "bool_destruct" hyp (H) "as" simple_intropattern (pat) :=
  let H0 := fresh "H" in
    (rename H into H0;
    match type of (H0) with
      | (andb ?a ?b = true) =>
        destruct (andb_prop a b H0) as pat; clear H0
      | (orb ?a ?b = true) =>
        destruct (orb_prop a b H0) as pat; clear H0
      | _ => fail "not destructable"
    end).


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

Require Import Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac utils_nat gcd sums pos vec.

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Notation power := (mscal mult 1).

Section div_mult.

  Variable (p q : nat) (Hp : p <> 0) (Hq : q <> 0).

  Fact div_rem_mult n : div n (p*q) = div (div n p) q /\ rem n (p*q) = rem n p + p*rem (div n p) q.
  Proof using Hp Hq.
    assert (p*q <> 0) as Hpq.
    { intros E; apply mult_is_O in E; lia. }
    apply div_rem_uniq with (p := p*q); auto.
    + generalize (div_rem_spec1 n p)
                 (div_rem_spec1 (div n p) q)
                 (div_rem_spec1 n (p*q)); intros H1 H2 H3.
      rewrite <- H3; rewrite H1 at 1; rewrite H2 at 1; ring.
    + apply div_rem_spec2; auto.
    + generalize (div_rem_spec2 n Hp)
                 (div_rem_spec2 (div n p) Hq); intros H1 H2.
      replace q with (1+(q-1)) at 2 by lia.
      rewrite Nat.mul_add_distr_l.
      apply plus_lt_le_compat; try lia.
      apply mult_le_compat; lia.
  Qed.

  Corollary div_mult n : div n (p*q) = div (div n p) q.
  Proof using Hp Hq. apply div_rem_mult. Qed.

  Corollary rem_mult n : rem n (p*q) = rem n p + p*rem (div n p) q.
  Proof using Hp Hq. apply div_rem_mult. Qed.

End div_mult.

Section nat_nat2_bij.

  (* An easy to implement bijection nat <-> nat * nat *)

  Let decomp_recomp_full n : n <> 0 -> { a & { b | n = power a 2 * (2*b+1) } }.
  Proof.
    induction on n as IHn with measure n; intros Hn.
    generalize (euclid_2_div n); intros (H1 & H2).
    case_eq (rem n 2).
    + intros H.
      destruct (IHn (div n 2)) as (a & b & H3); try lia.
      exists (S a), b.
      rewrite H1, H, H3, power_S; ring.
    + intros [ | [ | k ] ] Hk; try lia.
      exists 0, (div n 2); rewrite power_0.
      rewrite H1 at 1; rewrite Hk; ring.
  Qed.

  Definition decomp_l n := projT1 (@decomp_recomp_full (S n) (Nat.neq_succ_0 _)).
  Definition decomp_r n := proj1_sig (projT2 (@decomp_recomp_full (S n) (Nat.neq_succ_0 _))).

  Fact decomp_lr_spec n : S n = power (decomp_l n) 2 * (2 * (decomp_r n) + 1).
  Proof. apply (proj2_sig (projT2 (@decomp_recomp_full (S n) (Nat.neq_succ_0 _)))). Qed.

  Definition recomp a b := power a 2 * (2*b+1) - 1.

  Fact recomp_decomp n : n = recomp (decomp_l n) (decomp_r n).
  Proof. unfold recomp; rewrite <- decomp_lr_spec; lia. Qed.

  Let power_mult_lt_inj a1 b1 a2 b2 : a1 < a2 -> power a1 2 * (2*b1+1) <> power a2 2 * b2.
  Proof.
    intros H1 H.
    replace a2 with (a1+(S (a2-a1-1))) in H by lia.
    rewrite power_plus in H.
    rewrite <- mult_assoc, Nat.mul_cancel_l in H.
    2: generalize (power2_gt_0 a1); lia.
    revert H; rewrite power_S, <- mult_assoc.
    generalize (power (a2-a1-1) 2*b1); intros; lia.
  Qed.

  Let comp_gt a b : power a 2 *(2*b+1) <> 0.
  Proof.
    intros E; apply mult_is_O in E.
    generalize (power2_gt_0 a); intros; lia.
  Qed.

  Fact decomp_uniq a1 b1 a2 b2 : power a1 2 * (2*b1+1) = power a2 2 * (2*b2+1) -> a1 = a2 /\ b1 = b2.
  Proof.
    intros H.
    destruct (lt_eq_lt_dec a1 a2) as [ [ H1 | H1 ] | H1 ].
    + exfalso; revert H; apply power_mult_lt_inj; auto.
    + split; auto; subst a2.
      rewrite Nat.mul_cancel_l in H; try lia.
      generalize (power2_gt_0 a1); lia.
    + exfalso; symmetry in H.
      revert H; apply power_mult_lt_inj; auto.
  Qed.

  Let decomp_lr_recomp a b : decomp_l (recomp a b) = a /\ decomp_r (recomp a b) = b.
  Proof.
    apply decomp_uniq; symmetry.
    replace (power a 2 * (2*b+1)) with (S (recomp a b)).
    + apply decomp_lr_spec.
    + unfold recomp; generalize (power a 2 * (2*b+1)) (comp_gt a b); intros; lia.
  Qed.

  Fact decomp_l_recomp a b : decomp_l (recomp a b) = a.
  Proof. apply decomp_lr_recomp. Qed.

  Fact decomp_r_recomp a b : decomp_r (recomp a b) = b.
  Proof. apply decomp_lr_recomp. Qed.

End nat_nat2_bij.

Fixpoint inject n (v : vec nat n) : nat :=
  match v with
    | vec_nil => 0
    | x##v    => recomp x (inject v)
  end.

Fixpoint project n : nat -> vec nat n :=
  match n with
    | 0   => fun _ => vec_nil
    | S n => fun x => decomp_l x ## project _ (decomp_r x)
  end.

Fact project_inject n v : project _ (@inject n v) = v.
Proof.
  induction v as [ | n x v IHv ]; simpl; auto.
  rewrite decomp_l_recomp, decomp_r_recomp; f_equal; trivial.
Qed.


Require Export BaseLists Filter.

(** *** Element removal *)

Section Removal.
  Variable X : eqType.
  Implicit Types (x y: X) (A B: list X).

  Definition rem A x : list X :=
    filter (fun z => Dec (z <> x)) A.

  Lemma in_rem_iff x A y :
    x el rem A y <-> x el A /\ x <> y.
  Proof.
    unfold rem. rewrite in_filter_iff, Dec_reflect. tauto.
  Qed.

  Lemma rem_not_in x y A :
    x = y \/ ~ x el A -> ~ x el rem A y.
  Proof.
    unfold rem. rewrite in_filter_iff, Dec_reflect. tauto.
  Qed.

  Lemma rem_incl A x :
    rem A x <<= A.
  Proof.
    apply filter_incl.
  Qed.

  Lemma rem_mono A B x :
    A <<= B -> rem A x <<= rem B x.
  Proof.
    apply filter_mono.
  Qed.

  Lemma rem_cons A B x :
    A <<= B -> rem (x::A) x <<= B.
  Proof.
    intros E y F. apply E. apply in_rem_iff in F.
    destruct F as [[|]]; congruence.
  Qed.

  Lemma rem_cons' A B x y :
    x el B -> rem A y <<= B -> rem (x::A) y <<= B.
  Proof.
    intros E F u G.
    apply in_rem_iff in G as [[[]|G] H]. exact E.
    apply F. apply in_rem_iff. auto.
  Qed.

  Lemma rem_in x y A :
    x el rem A y -> x el A.
  Proof.
    apply rem_incl.
  Qed.

  Lemma rem_neq x y A :
    x <> y -> x el A -> x el rem A y.
  Proof.
    intros E F. apply in_rem_iff. auto.
  Qed.

  Lemma rem_app x A B :
    x el A -> B <<= A ++ rem B x.
  Proof.
    intros E y F. decide (x=y) as [[]|]; auto using rem_neq.
  Qed.

  Lemma rem_app' x A B C :
    rem A x <<= C -> rem B x <<= C -> rem (A ++ B) x <<= C.
  Proof.
    unfold rem; rewrite filter_app; auto.
  Qed.

  Lemma rem_equi x A :
    x::A === x::rem A x.
  Proof.
    split; intros y;
    intros [[]|E]; decide (x=y) as [[]|D];
    eauto using rem_in, rem_neq.
  Qed.

  Lemma rem_comm A x y :
    rem (rem A x) y = rem (rem A y) x.
  Proof.
    apply filter_comm.
  Qed.

  Lemma rem_fst x A :
    rem (x::A) x = rem A x.
  Proof.
    unfold rem. rewrite filter_fst'; auto.
  Qed.

  Lemma rem_fst' x y A :
    x <> y -> rem (x::A) y = x::rem A y.
  Proof.
    intros E. unfold rem. rewrite filter_fst; auto.
  Qed.

  Lemma rem_id x A :
    ~ x el A -> rem A x = A.
  Proof.
    intros D. apply filter_id. intros y E.
    apply Dec_reflect. congruence.
  Qed.

  Lemma rem_reorder x A :
    x el A -> A === x :: rem A x.
  Proof.
    intros D. rewrite <- rem_equi. apply equi_push, D.
  Qed.

  Lemma rem_inclr A B x :
    A <<= B -> ~ x el A -> A <<= rem B x.
  Proof.
    intros D E y F. apply in_rem_iff.
    intuition; subst; auto.
  Qed.

End Removal.

Hint Resolve rem_not_in rem_incl rem_mono rem_cons rem_cons' rem_app rem_app' rem_in rem_neq rem_inclr.


(* ###################################################################### *)
(* taken from http://www.cis.upenn.edu/~rrand/popl_2016/ *)
(** * Proofs and Programs *)

(** (We use [admit] and [Admitted] to hide solutions from exercises.) *)

Axiom admit : forall {T}, T.

(** Everything in Coq is built from scratch -- even booleans!
    Fortunately, they are already provided by the Coq standard
    library, but we'll review their definition here to get familiar
    with the basic features of the system. *)

(** [Inductive] is Coq's way of defining an algebraic datatype.  Its
    syntax is similar to OCaml's ([type]) or Haskell's ([data]). Here,
    we define [bool] as a simple algebraic datatype. *)

Module Bool.

Inductive bool : Type :=
| true : bool
| false : bool.

(** **** Exercise: 1 star (trivalue)  *)
(** Define a three-valued data type, representing ternary logic.  Here
    something can be true, false and unknown. *)

Inductive trivalue : Type :=
| tru : trivalue
| fals : trivalue
| unknown : trivalue.
(** [] *)

(** We can write functions that operate on [bool]s by simple pattern
    matching, using the [match] keyword. *)

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

(** We can pattern-match on multiple arguments simultaneously, and
    also use "_" as a wildcard pattern. *)

Definition orb (b1 b2: bool) : bool :=
  match b1, b2 with
  | false, false => false
  | _, _ => true
  end.

Print orb.

(** We can also use an [if] statement, which matches on the first
    constructor of any two-constructor datatype, in our definition. *)

Definition andb (b1 b2: bool) : bool :=
  if b1 then b2 else false.

(** Let's test our functions. The [Compute] command tells Coq to
    evaluate an expression and print the result on the screen.*)

Compute (negb true).
Compute (orb true false).
Compute (andb true false).

(** **** Exercise: 1 star (xor)  *)
(** Define xor (exclusive or). *)

Definition xorb (b1 b2 : bool) : bool :=
  match b1, b2 with
  | false, false => false
  | true, true => false
  | _, _ => true
  end.
(* FILL IN HERE *)

Compute (xorb true true).
(** [] *)

(** What makes Coq different from normal functional programming
    languages is that it allows us to formally _prove_ that our
    programs satisfy certain properties. The system mechanically
    verifies these proofs to ensure that they are correct.

    We use [Lemma], [Theorem] and [Example] to write logical
    statements. Coq requires us to prove these statements using
    _tactics_, which are commands that manipulate formulas using basic
    logic rules. Here's an example showing some basic tactics in
    action. *)

(** New tactics
    -----------

    - [intros]: Introduce variables into the context, giving them
      names.

    - [simpl]: Simplify the goal.

    - [reflexivity]: Prove that some expression [x] is equal to itself. *)

Example andb_false_l : forall b, andb false b = false.
Proof.
(* WORKED IN CLASS *)
  intros b. (* introduce the variable b *)
  simpl. (* simplify the expression *)
  reflexivity. (* solve for x = x *)
Qed.

(** **** Exercise: 1 star (orb_true_l)  *)
Theorem orb_true_l :
  forall b, orb true b = true.
Proof.
intros b.
simpl.
reflexivity.
(* FILL IN HERE *) Qed.
(** [] *)

(** Some proofs require case analysis. In Coq, this is done with the
    [destruct] tactic. *)

(** New tactic
    ----------

    - [destruct]: Consider all possible constructors of an inductive
      data type, generating subgoals that need to be solved
      separately. *)

(*  FULL: Here's an example of [destruct] in action. *)

Lemma orb_true_r : forall b : bool, orb b true = true.
(* Here we explicitly annotate b with its type, even though Coq could infer it. *)
Proof.
(* WORKED IN CLASS *)
  intros b.
  simpl. (* This doesn't do anything, since orb pattern matches on the
  first variable first. *)
  destruct b. (* Do case analysis on b *)
  + (* We use the "bullets" '+' '-' and '*' to delimit subgoals *)
    (* true case *)
    simpl.
    reflexivity.
  + (* false case *)
    simpl.
    reflexivity.
Qed.

(** We can call [destruct] as many times as we want, generating deeper subgoals. *)

Theorem andb_commutative : forall b1 b2 : bool, andb b1 b2 = andb b2 b1.
Proof.
(* WORKED IN CLASS *)
  intros b1 b2.
  destruct b1.
  + destruct b2.
    - simpl. reflexivity.
    - simpl. reflexivity. (* bullets need to be consistent *)

(** Alternatively, if all the subgoals are solved the same way, we can
    use the [;] operator to execute a tactic on _all_ the generated
    subgoals, like this: *)

  + destruct b2; simpl; reflexivity.
Qed.

(** **** Exercise: 1 star (andb_false_r)  *)
(** Show that b AND false is always false  *)

Theorem andb_false_r : forall b: bool, andb b false = false.
Proof.
intros b.
destruct b; simpl; reflexivity.
(* FILL IN HERE *) Qed.
(** [] *)

(** **** Exercise: 1 star (xorb_b_neg_b)  *)
(** Show that b xor (not b) is always true. *)

Theorem xorb_b_neg_b : forall b: bool, xorb b (negb b) = true.
Proof.
intros b.
destruct b; simpl; reflexivity.
(* FILL IN HERE *) Qed.

(** Sometimes, we want to show a result that requires hypotheses. In
    Coq, [P -> Q] means that [P] implies [Q], or that [Q] is true
    whenever [P] is. We can use [->] multiple times to express that
    more than one hypothesis are needed; the syntax is similar to how
    we write multiple-argument functions in OCaml or Haskell. For
    example: *)

Theorem rewrite_example : forall b1 b2 b3 b4,
  b1 = b4 ->
  b2 = b3 ->
  andb b1 b2 = andb b3 b4.

(** We can use the [intros] tactic to give hypotheses names,
    bringing them into the proof context. *)

Proof.
  intros b1 b2 b3 b4 eq14 eq23.

(** Now, our context has two hypotheses: [eq14], which states
    that [b1 = b4], and [eq23], stating that [b2 = b3].

     Here are some tactics for using hypotheses and previously proved
    results: *)

(** New tactics
    -----------

    - [rewrite]: Replace one side of an equation by the other.

    - [apply]: Suppose that the current goal is [Q]. If [H : Q], then
      [apply H] solves the goal. If [H : P -> Q], then [apply H]
      replaces [Q] by [P] in the goal. If [H] has multiple hypotheses,
      [H : P1 -> P2 -> ... -> Pn -> Q], then [apply H] generates one
      subgoal for each [Pi]. *)

  rewrite eq14. (* replace b1 with b4 in the goal *)
  rewrite <- eq23. (* replace b3 with b2 in the goal. *)
  apply andb_commutative. (* solve using our earlier theorem *)
Qed.

(** **** Exercise: 1 star (xorb_same)  *)
(** Show that if [b1 = b2] then b1 xor b2 is false. *)

Theorem xorb_same : forall b1 b2: bool, b1 = b2 -> xorb b1 b2 = false.
Proof.
intros b1 b2 eq.
rewrite eq.
destruct b2; simpl; reflexivity.
(* FILL IN HERE *) Qed.

End Bool.

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

(** We will use the following option to make polymorphism more
    convenient. *)

Set Implicit Arguments.

(** * Lists *)

(** We will now shift gears and study more interesting functional
    programs; namely, programs that manipulate _lists_. *)

Module List.

(** Here's a polymorphic definition of a [list] type in Coq: *)

Inductive list (T : Type) :=
| nil : list T
| cons : T -> list T -> list T.

(** Here's how we define a function to append two lists.
    Note that we declare the type parameter T. *)

Fixpoint app T (l1 l2 : list T) : list T :=
  match l1 with
  | nil _ => l2
  | cons h t  => cons h (app t l2)
  end.

(** Coq comes with a syntax extension mechanism for defining custom
    notations. Without getting into details, here's how we can give
    familiar syntax for lists. *)

Notation "h :: t" := (cons h t) (at level 60, right associativity).
Notation "[ ]" := (nil _).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y [] ) ..).
Notation "l1 ++ l2" := (app l1 l2) (at level 60, right associativity).

(** Since [nil] can potentially be of any type, we add an underscore
    to tell Coq to infer the type from the context. *)

(** We can now check the types of expressions involving lists. *)

Check [].
Check true :: [].
Check [true ; false].
Check [true ; false] ++ [false].

(** And compute the last. *)
Compute [true ; false] ++ [false].

(** Note that we can use define notations and functions
    simultaneously: *)

Reserved Notation "l1 @ l2" (at level 60).
Fixpoint app' T (l1 l2 : list T) : list T :=
  match l1 with
  | [] => l2
  | h :: t  => h :: (t @ l2)
  end

  where "l1 @ l2" := (app' l1 l2).

(** **** Exercise: 1 star (snoc)  *)
(** Define [snoc], which adds an element to the end of a list. *)

Fixpoint snoc T (l : list T) (x : T) : list T :=
  (l ++ (x :: [])).

(** It is easy to show that appending [nil] to the left of a list
    yields the original list.  *)

Lemma app_nil_l: forall T (l : list T), [] ++ l  = l.
Proof.
(* WORKED IN CLASS *)
  intros T l.
  simpl.
  reflexivity.
Qed.

(** Showing the symmetric result is more difficult
    since it doesn't follow by simplification alone. *)

Lemma app_nil_r: forall T (l : list T), l ++ []  = l.
Proof.
  intros T l.
  simpl. (* Does nothing *)
  destruct l as [| h t]. (* Notice the [as] clause, which allows us
                            to name constructor arguments. *)
  + simpl.
    reflexivity.
  + simpl. (* no way to proceed... *)

(** The problem is that we can only prove the result for [h::t]
    if we already know that it is valid for [t]. We need a bigger
    hammer here... *)

(** New tactic
    ----------

    - [induction]: Argue by induction. It works as [destruct], but
    additionally giving us an inductive hypothesis in the inductive
    case. *)
Restart.
  intros T l.
  induction l as [| h t IH]. (* Note the additional name [IH], given to our
                                inductive hypothesis *)
  + simpl.
    reflexivity.
  + simpl.
    rewrite IH.
    reflexivity.
Qed.

(** As a rule of thumb, when proving some property of a recursive
    function, it is a good idea to do induction on the recursive
    argument of the function. For instance, let's show that [app] is
    associative: *)

Lemma app_assoc :
  forall T (l1 l2 l3 : list T),
    l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
(* WORKED IN CLASS *)
  intros T l1 l2 l3.
  induction l1 as [|h1 t1 IH]. (* l1 is the right choice here, since [app] is defined
                                  by recursion on the first argument. *)
  - (* [] *)
    simpl.
    reflexivity.
  - (* h1 :: t1 *)
    simpl.
    rewrite IH.
    reflexivity.
Qed.

(** Exercise: Try to do induction on [l2] and [l3] in the
    above proof, and see where it fails. *)

(** **** Exercise: 2 stars (snoc_app)  *)
(** Prove that [snoc l x] is equivalent to appending [x] to the end of
    [l]. *)

Lemma snoc_app : forall T (l : list T) (x : T), snoc l x = l ++ [x].
Proof.
intros.
induction l.
 - simpl; reflexivity.
 -
  simpl. reflexivity.
(* FILL IN HERE *) Qed.
(** [] *)

(** The natural numbers are defined in Coq's standard library as follows:

    Inductive nat : Type :=
      | O : nat
      | S : nat -> nat.

    where [S] stands for "Successor".

    Coq prints [S (S (S O))] as "3", as you might expect.

*)

Set Printing All.

Check 0.
Check 2.
Check 2 + 2.

Unset Printing All.

Check S (S (S O)).
Check 2 + 3.
Compute 2 + 3.

(** Now we can define the [length] function: *)

Fixpoint length T (l : list T) :=
  match l with
  | [] => 0
  | h :: t => 1 + length t
  end.

Compute length [1; 1; 1].

(** **** Exercise: 3 stars (app_length)  *)

Lemma app_length : forall T (l1 l2 : list T),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
intros.
induction l1.
induction length.
simpl; reflexivity.
simpl; reflexivity.

simpl; rewrite IHl1.
reflexivity.
(* FILL IN HERE *) Qed.

(** Often we find ourselves needing to reason about _contradictory_
    hypotheses. Whenever we have a hypothesis that equates two
    expressions that start with different constructors, we can use the
    [discriminate] tactic to prune that subgoal.

    This is a particular case of what is known as _the principle of
    explosion_, which states that a contradiction implies anything. *)

(** New Tactic
    ----------

    - [discriminate]: Looks for an equation between terms starting
      with different constructors, and solves the current goal. *)

(* Let's try to prove that if [l1 ++ l2 = []] then [l1] is [[]] *)

Lemma app_eq_nil_l : forall T (l1 l2 : list T),
  l1 ++ l2 = [] -> l1 = [].
Proof.
(* WORKED IN CLASS *)
  intros T l1 l2 H.
  destruct l1 as [| h t].
  + (* [] *)
    reflexivity.
  + (* h :: t *)
    simpl in H.
    discriminate.
Qed.

(** **** Exercise: 2 stars (app_eq_nil_r)  *)
(** Prove the same about [l2]. *)

Lemma plus_nil_r : forall T (l1 l2 : list T),
  l1 ++ l2 = [] -> l2 = [].
Proof.
intros T l1 l2 H.
destruct l1 as [| h t].
 + apply H.
 + simpl in H.
   discriminate.
(* FILL IN HERE *) Qed.
(** [] *)

(** Coq, like many other proof assistants, requires functions to
    be _total_ and defined for all possible inputs; in particular,
    recursive functions are always required to terminate.

    Since there is no general algorithm for deciding whether a
    function is terminating or not, Coq needs to settle for an
    incomplete class of recursive functions that is easy to show
    terminating. This means that, although every recursive function
    accepted by Coq is terminating, there are many recursive functions
    that always terminate but are not accepted by Coq, because it
    isn't "smart enough" to realize that they indeed terminate.

    The criterion adopted by Coq for deciding whether to accept a
    definition or not is _structural recursion_: All recursive calls
    must be performed on _sub-terms_ of the original argument.

    Note that the definition of _sub-terms_ used in context is purely syntactic
    hence the following definition fails.

**)

Fail Fixpoint shuffle T (l1 l2 : list T) :=
  match l1 with
  | [] => l2
  | h :: t => h :: shuffle l2 t
  end.

(** The [Fail] keyword instructs Coq to ignore a command when it
    fails, but to fail if the command succeeds. It is useful for
    showing certain pieces of code that are not accepted by the
    language.

    In this case, we can rewrite [shuffle] so that it is accepted by
    Coq's termination checker: *)

Fixpoint shuffle T (l1 l2 : list T) :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | h1 :: t1, h2 :: t2 => h1 :: h2 :: shuffle t1 t2
  end.

Print shuffle.

(** Let's define list reversal function and prove some of its basic
    properties. *)

Fixpoint rev T (l : list T) :=
  match l with
  | [] => []
  | h :: t => (rev t) ++ [h]
  end.

Lemma rev_app : forall T (l1 l2 : list T), rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
(* WORKED IN CLASS *)
  intros T l1 l2.
  induction l1 as [|h t IH].
  + simpl.
    rewrite app_nil_r.
    reflexivity.
  + simpl.
    rewrite IH.
    rewrite app_assoc.
    reflexivity.
Qed.

(** **** Exercise: 2 stars (rev_app)  *)
(** Using [rev_app], prove that reversing a list twice results in the
    same list. *)

Lemma rev_involutive : forall T (l : list T), rev (rev l) = l.
Proof.
intros.
induction l as [| h t H].
 + simpl; reflexivity.
 + simpl. rewrite rev_app. rewrite H. simpl. reflexivity.

(* FILL IN HERE *) Qed.

(** Notice that the definition of list reversal given above runs in
    quadratic time. Here is a tail-recursive equivalent that runs in
    linear time. *)

Fixpoint tr_rev_aux T (l acc : list T) : list T :=
  match l with
  | [] => acc
  | x :: l => tr_rev_aux l (x :: acc)
  end.

Definition tr_rev T (l: list T) := tr_rev_aux l [].

(** Here, [acc] is an accumulator argument that holds the portion of
    the list that we have reversed so far. Let's prove that [tr_rev]
    is equivalent to [rev]. For this we will need another tactic: *)

(** New Tactic
    ----------

    - [unfold]: Calling [unfold foo] expands the definition of [foo]
      in the goal.
*)

Lemma tr_rev_eq_rev_try_one :
  forall T (l : list T),
    tr_rev l = rev l.
Proof.
  intros T l.
  unfold tr_rev.
  induction l as [| h t IH].
  + simpl.
    reflexivity.
  + simpl.
    (* and now we're stuck... *)
Abort.

(** The problem is that the result we are trying to prove is not
    general enough. We will need the following auxiliary lemma: *)

Lemma tr_rev_aux_eq_rev :
  forall T (l1 l2 : list T),
    tr_rev_aux l1 l2 = rev l1 ++ l2.
Proof.
  intros T l1 l2.
  induction l1 as [|x l1 IH].
  - simpl. reflexivity.
  - simpl.

(** Our inductive hypothesis is too weak to proceed. We want
    [tr_rev_aux l1 l2 = rev l1 ++ l2] for all [l2]. Let's try again
    from the start. *)

Restart.
  intros T l1. (* Now we don't introduce l2, leaving it general. *)
  induction l1 as [|x l1 IH].
  - intros l2. simpl. reflexivity.
  - intros l2. (* Behold our induction hypothesis! *)
    simpl.
    rewrite IH.

(** We can use the [SearchAbout] command to look up lemmas that can be
    used with certain expressions ([C-c C-a C-a] in Proof General). *)

    SearchAbout (_ ++ _ ++ _).
    rewrite <- app_assoc.
    simpl.
    reflexivity.
Qed.

(** Our result follows easily: *)

Lemma tr_rev_eq_rev :
  forall T (l : list T),
    tr_rev l = rev l.
Proof.
(* WORKED IN CLASS *)
  intros T l.
  unfold tr_rev.
  rewrite tr_rev_aux_eq_rev.
  SearchAbout (_ ++ []).
  apply app_nil_r.
Qed.

End List.

(** You may have noticed that several of the proofs in this section,
    particularly regarding the associativity of the append function,
    closely resemble proofs about arithmetic. You might also be interested
    in Coq for its ability to prove results in mathematics. The
    material in this section should be sufficient for you to start
    formulating theorems about the natural numbers, such as the
    commutativity, associativity and distributivity of addition and
    multiplication.

    As noted above, the natural numbers are defined as follows:

    Inductive nat : Type :=
      | O : nat
      | S : nat -> nat.

    From there you can define +, -, *, /, ^ etc. We encourage you to
    start on your own, but to help we've included a module on arithmetic
    We hope you enjoy.

*)


From CoqAlgs Require Export Sorting.Sort.
From CoqAlgs Require Export ListLemmas.
From CoqAlgs Require Export PairingHeap.

Set Implicit Arguments.

Fixpoint fromList {A : Type} (cmp : A -> A -> bool) (l : list A) : PairingHeap A :=
match l with
    | [] => empty
    | h :: t => insert cmp h (fromList cmp t)
end.

Function toList
  {A : Type} (p : A -> A -> bool) (h : PairingHeap A) {measure size h}: list A :=
match extractMin p h with
    | None => []
    | Some (m, h') => m :: toList p h'
end.
Proof.
  destruct h; cbn; intros; subst; inv teq.
    rewrite size_mergePairs. apply le_n.
Defined.

Definition pairingSort (A : Type) (p : A -> A -> bool) (l : list A) : list A :=
  toList p (fromList p l).

(** Properties of [fromList]. *)

Lemma Elem_fromList :
  forall (A : Type) (cmp : A -> A -> bool) (x : A) (l : list A),
    Elem x (fromList cmp l) <-> In x l.
Proof.
  induction l as [| h t].
    split; inv 1.
    simpl. rewrite Elem_insert, IHt. firstorder.
Qed.

Lemma isHeap_fromList :
  forall (A : Ord) (l : list A),
    isHeap cmp (fromList cmp l).
Proof.
  induction l as [| h t]; cbn.
    constructor.
    apply isHeap_insert. assumption.
Qed.

Lemma countTree_fromList :
  forall (A : Type) (cmp : A -> A -> bool) (p : A -> bool) (l : list A),
    countTree p (fromList cmp l) = count p l.
Proof.
  induction l as [| h t].
    cbn. reflexivity.
    cbn. destruct (fromList cmp t) eqn: Heq.
      cbn in *. unfold id. destruct (p h); lia.
      rewrite <- IHt. destruct (cmp h a); cbn; destruct (p h), (p a); unfold id; lia.
Qed.

(** Properties of [toList]. *)

Lemma countTree_toList :
  forall (A : Type) (cmp : A -> A -> comparison) (p : A -> bool) (h : PairingHeap A),
    (*isHeap cmp h ->*) countTree p h = count p (toList cmp h).
Proof.
  intros until h.
  functional induction toList cmp h.
    destruct h; inv e.
    destruct h; inv e. cbn. rewrite <- IHl, countTree_mergePairs. reflexivity.
Qed.

Lemma Sorted_toList :
  forall (A : Ord) (h : PairingHeap A),
    isHeap cmp h -> Sorted cmp (toList cmp h).
Proof.
  intros. functional induction toList cmp h.
    constructor.
    rewrite toList_equation in *. destruct h'; cbn in *; constructor.
      eapply extractMin_spec; eauto. erewrite Elem_extractMin; eauto. cbn. assumption.
      eapply IHl, isHeap_extractMin; eauto.
Qed.

(** Properties of [pairingSort]. *)

Theorem Sorted_pairingSort :
  forall (A : Ord) (l : list A),
    Sorted cmp (pairingSort cmp l).
Proof.
  intros. unfold pairingSort.
  apply Sorted_toList, isHeap_fromList.
Qed.

Lemma perm_pairingSort :
  forall (A : Type) (cmp : A -> A -> comparison) (l : list A),
    perm (pairingSort cmp l) l.
Proof.
  unfold perm, pairingSort. intros.
  rewrite <- countTree_toList, countTree_fromList.
    reflexivity.
Qed.

Theorem Permutation_pairingSort :
  forall {A : Ord} (l : list A),
    Permutation (pairingSort cmp l) l.
Proof.
  intros. apply perm_Permutation, perm_pairingSort.
Qed.

#[export]
Instance Sort_pairingSort (A : Ord) : Sort cmp :=
{
    sort := pairingSort cmp;
    Sorted_sort := Sorted_pairingSort A;
    Permutation_sort := Permutation_pairingSort;
}.


From mathcomp Require Import ssreflect ssrbool eqtype.

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

Lemma and_true_l (a b : bool) : a && b = true -> a = true.
Proof. by case: a. Qed.

Lemma and_true_r (a b : bool) : a && b = true -> b = true.
Proof. by case: a. Qed.

Lemma and_true (a b : bool) : a && b = true -> a = true /\ b = true.
Proof. by case: a. Qed.

Lemma and_false (a b : bool) : a && b = false -> a = false \/ b = false.
Proof.
  case/nandP => H.
  - left; exact: (negbTE H).
  - right; exact: (negbTE H).
Qed.

Lemma neq_sym (T : eqType) (x y : T) : (x != y) = (y != x).
Proof.
  case H: (x == y) => /=.
  - rewrite eq_sym in H. rewrite H. reflexivity.
  - rewrite eq_sym in H. rewrite H. reflexivity.
Qed.

Lemma expand_eq (b1 b2 : bool) : (b1 == b2) = ((b1 || ~~ b2) && (~~ b1 || b2)).
Proof. by case: b1; case: b2. Qed.

Lemma expand_neq (b1 b2 : bool) : (b1 != b2) = ((b1 || b2) && (~~ b1 || ~~ b2)).
Proof. by case: b1; case: b2. Qed.

Lemma neg_eq (b1 b2 : bool) : (~~ b1 == ~~ b2) = (b1 == b2).
Proof. by case: b1; case: b2. Qed.


(**
The situation:
1. There are 5 houses in five different colors.
2. In each house lives a person with a different nationality.
3. These five owners drink a certain type of beverage, smoke a certain brand of cigar and keep a certain pet.
4. No owners have the same pet, smoke the same brand of cigar or drink the same beverage.

How do we encode these rules into Coq?

The situation stipulates that each person has a different house, drinks a different beverage,
own a different pet and smokes a different type of cigar. Thus we can have a function type for each
attribute that takes in the nationality and outputs the attribute. Then we require for different nationalities,
the attribute output must be distinct.

Hints:
1. the Brit lives in the red house
2. the Swede keeps dogs as pets
3. the Dane drinks tea
4. the green house is on the left of the white house
5. the green house's owner drinks coffee
6. the person who smokes Pall Mall rears birds
7. the owner of the yellow house smokes Dunhill
8. the man living in the center house drinks milk
9. the Norwegian lives in the first house
10. the man who smokes blends lives next to the one who keeps cats
11. the man who keeps horses lives next to the man who smokes Dunhill
12. the owner who smokes BlueMaster drinks beer
13. the German smokes Prince
14. the Norwegian lives next to the blue house
15. the man who smokes blend has a neighbor who drinks water

*)

Inductive nationality : Type :=
  | British : nationality
  | Swedish : nationality
  | Danish : nationality
  | Norwegian : nationality
  | German : nationality.

Inductive pet : Type :=
  | Dog : pet
  | Cat : pet
  | Bird : pet
  | Horse : pet
  | Fish : pet.

Inductive beverage : Type :=
  | tea : beverage
  | coffee : beverage
  | milk : beverage
  | beer : beverage
  | water : beverage.

Inductive house : Type :=
  | red : house
  | green : house
  | white : house
  | yellow : house
  | blue : house.

Inductive cigar : Type :=
  | PallMall : cigar
  | Dunhill : cigar
  | BlueMaster : cigar
  | Prince : cigar
  | Blend : cigar.


Set Implicit Arguments.

Inductive AExp : Type :=
| ANum   : nat    -> AExp
| APlus  : AExp -> AExp -> AExp
| AMinus : AExp -> AExp -> AExp
| AMult  : AExp -> AExp -> AExp.

Inductive BExp : Type :=
| BTrue  : BExp
| BFalse : BExp
| BLess  : AExp -> AExp -> BExp.

Notation "e1 :<: e2" := (BLess e1 e2) (at level 40, left associativity).
Notation "e1 :+: e2" := (APlus e1 e2) (at level 40, left associativity).
Notation "e1 :-: e2" := (AMinus e1 e2) (at level 40, left associativity).
Notation "e1 :*: e2" := (AMult e1 e2) (at level 40, left associativity).

Fixpoint aeval (e : AExp) : nat :=
  match e with
  | ANum n       => n
  | APlus e1 e2  => aeval e1 + aeval e2
  | AMinus e1 e2 => aeval e1 - aeval e2
  | AMult e1 e2  => aeval e1 * aeval e2
  end.

Fixpoint beval (e : BExp) : bool :=
  match e with
  | BTrue       => true
  | BFalse      => false
  | BLess e1 e2 => Nat.leb (aeval e1) (aeval e2)
  end.


Set Implicit Arguments.
Set Strict Implicit.

Section PairWF.
  Variables T U : Type.
  Variable RT : T -> T -> Prop.
  Variable RU : U -> U -> Prop.

  Inductive R_pair : T * U -> T * U -> Prop :=
  | L : forall l l' r r',
    RT l l' -> R_pair (l,r) (l',r')
  | R : forall l r r',
    RU r r' -> R_pair (l,r) (l,r').

  Hypothesis wf_RT : well_founded RT.
  Hypothesis wf_RU : well_founded RU.

  Theorem wf_R_pair : well_founded R_pair.
  Proof.
    red. intro x.
    destruct x. generalize dependent u.
    apply (well_founded_ind wf_RT (fun t => forall u : U, Acc R_pair (t, u))) .
    do 2 intro.

    apply (well_founded_ind wf_RU (fun u => Acc R_pair (x,u))). intros.
    constructor. destruct y.
    remember (t0,u). remember (x,x0). inversion 1; subst;
    inversion H4; inversion H3; clear H4 H3; subst; eauto.
  Defined.
End PairWF.

Inductive R_nat : nat -> nat -> Prop :=
| R_S : forall n, R_nat n (S n).

Theorem wf_R_nat : well_founded R_nat.
Proof.
  red; induction a; constructor; intros.
    inversion H.
    inversion H; subst; auto.
Defined.

Fixpoint guard A (R : A -> A -> Prop) (n : nat) (wfR : well_founded R)
  {struct n}: well_founded R :=
  match n with
    | 0 => wfR
    | S n => fun x => Acc_intro x (fun y _ => guard n (guard n wfR) y)
  end.


From smpl Require Import Smpl.
Require Import Omega Lia.
Require Export Psatz Arith.
Require Export RelationClasses Morphisms.

(* Congruence Lemmatas over nat*)
Instance add_le_mono : Proper (le ==> le ==> le) plus.
Proof. repeat intro. now apply Nat.add_le_mono. Qed.

Instance mult_le_mono : Proper (le ==> le ==> le) mult.
Proof. repeat intro. now apply Nat.mul_le_mono. Qed.

Instance max_le_mono : Proper (le ==> le ==> le) max.
Proof. repeat intro. repeat eapply Nat.max_case_strong;lia. Qed.

Instance max'_le_mono : Proper (le ==> le ==> le) Init.Nat.max.
Proof. repeat intro. repeat eapply Nat.max_case_strong;lia. Qed.

Instance S_le_mono : Proper (le ==> le) S.
Proof. repeat intro. lia. Qed.


From Coq Require Import Bool ZArith Znumtheory micromega.Lia.

From BY Require Import Zpower_nat InductionPrinciples Hierarchy.Definitions Impl Hierarchy.BigOp.

Local Open Scope Z_scope.

Import Z.

Lemma mod_lemma a b (H : b <= a < 2*b) : a mod b = a - b.
Proof.
  symmetry; destruct (Z_le_dec b 0); [apply mod_unique_neg with 1|apply mod_unique_pos with 1]; lia. Qed.

Lemma mod_half a b (H : 0 < b <= a) : a mod b <= a / 2.
Proof.
  pose proof (mod_pos_bound a b ltac:(lia)).
  pose proof (mul_succ_div_gt a 2 ltac:(lia)).
  destruct (ltb_spec b (succ (a / 2))).
  + lia.
  + assert (a < 2*b) by lia.
    rewrite mod_lemma; lia. Qed.

Lemma log2_half a (H : 0 < a) : log2 (a / 2) = log2 a - 1 \/ a = 1.
Proof.
  rewrite <- div2_div, div2_spec, log2_shiftr by assumption.
  unfold max; destruct (compare_spec 0 (log2 a - 1)); auto.
  - right; assert (log2 a = 0) by (pose proof log2_nonneg a; lia).
    apply log2_null in H1; lia. Qed.

Lemma even_mul_2_l a : even (2 * a) = true.
Proof. rewrite even_mul; reflexivity. Qed.

Lemma even_mul_2_r a : even (a * 2) = true.
Proof. rewrite mul_comm; apply even_mul_2_l. Qed.

Lemma even_divide a : even a = true <-> (2 | a).
Proof.
  split.
  - intros. apply even_spec in H. destruct H as [x]. exists x; lia.
  - intros [x ->]. apply even_mul_2_r. Qed.

Lemma odd_gcd a : odd a = true <-> gcd a 2 = 1.
Proof.
  split; intros.
  - rewrite odd_spec in H. rewrite <- Zodd_equiv in H. apply Zodd_ex in H.
    destruct H. rewrite H. rewrite gcd_comm.
    rewrite add_comm, mul_comm. rewrite gcd_add_mult_diag_r. reflexivity.
  - apply gcd_bezout in H. destruct H. destruct H.
    apply (f_equal odd) in H.
    rewrite odd_add, !odd_mul in H. simpl in H.
    destruct (odd a); rewrite !andb_false_r in H; easy. Qed.

Lemma odd_rel_prime a : odd a = true <-> rel_prime a 2.
Proof. pose proof Zgcd_1_rel_prime a 2; pose proof odd_gcd a; tauto. Qed.

Lemma rel_prime_pow a b n (Hn : (1 <= n)%nat) : rel_prime a b <-> rel_prime a (b ^+ n).
Proof.
  split; intro.
  - induction n.
    + apply rel_prime_sym; apply rel_prime_1.
    + destruct n.
      * rewrite Zpower_nat_1_r; assumption.
      * rewrite Zpower_nat_succ_r; apply rel_prime_mult. assumption.
        apply IHn; lia.
  - apply rel_prime_sym. apply rel_prime_div with (b ^+ n). apply rel_prime_sym.
    assumption. red. exists (b ^+ (n - 1)). rewrite mul_comm, mul_base_pull. reflexivity. lia. Qed.

Lemma odd_rel_prime_pow a n (Hn : (1 <= n)%nat): odd a = true <-> rel_prime a (2 ^+ n).
Proof. pose proof rel_prime_pow a 2 n Hn. pose proof odd_rel_prime a. tauto. Qed.

Lemma odd_pow2 n (H : (0 < n)%nat) : odd (2 ^+ n) = false.
Proof.
  rewrite mul_base_pull; [|lia]; rewrite odd_mul; reflexivity. Qed.

Lemma odd_mod_pow2 a n (H : (0 < n)%nat) : odd (a mod 2 ^+ n) = odd a.
Proof.
  rewrite Zdiv.Zmod_eq_full, odd_sub, odd_mul, odd_pow2, andb_false_r, xorb_false_r. reflexivity.
  lia. apply Zpower_nat_nonzero. lia. Qed.

Lemma mod_equiv a b m (H : m <> 0) : a mod m = b mod m <-> (m | a - b).
Proof.
  split; intros.
  - apply Zmod_divide. lia.
    rewrite Zminus_mod. replace (a mod m - (b mod m)) with 0 by lia.
    reflexivity.
  - destruct H0. replace b with (a - x * m) by lia.
    rewrite <- Zminus_mod_idemp_r, mod_mul, sub_0_r. reflexivity. lia. Qed.

Lemma even_div a : even a = true <-> (2 | a).
Proof.
  split; intros.
  - apply  Zeven_bool_iff in H; apply Zeven_ex in H. destruct H as [x]; exists x; lia.
  - destruct H as [x]; rewrite H, even_mul, orb_true_r; reflexivity. Qed.

Lemma divide_lemma a b c (Hc : 0 < c) (Hcb : (c | b)) : (a | b / c) <-> (c * a | b).
Proof.
  split; intros Habc.
  - unfold divide in Habc. unfold divide.
    destruct Habc as [k H]. exists k. replace (k * _) with (c * (b / c)) by lia.
    rewrite <- Zdivide_Zdiv_eq by assumption. reflexivity.
  - unfold divide in Habc. unfold divide.
    destruct Habc as [k H]. exists k. replace b with (k * a * c) by lia.
    rewrite Z.div_mul. reflexivity. lia. Qed.

Lemma log2_div a p (Ha : 0 < a) (Hp : 1 < p) : log2 (a / p) <= log2 a - 1 \/ a = 1.
Proof.
  pose proof log2_half a ltac:(lia).
  destruct H; [left|right; assumption].
  pose proof div_le_compat_l a 2 p ltac:(lia) ltac:(lia).
  pose proof log2_le_mono (a / p) (a / 2) ltac:(assumption). lia. Qed.

Lemma odd_nonzero g : odd g = true -> g <> 0.
Proof. intros H Hg; subst; inversion H. Qed.

Lemma odd_divide a b : odd b = true -> (a | b) -> odd a = true.
Proof.
  intros.
  destruct (odd a) eqn:E.
  - reflexivity.
  - rewrite <- negb_even in E. apply negb_false_iff in E. apply even_div in E.
    destruct E as [x]. destruct H0 as [z].
    assert (2 | b).  exists (z * x).  lia. apply even_div in H2. rewrite <- negb_odd in H2.
    apply negb_true_iff in H2. congruence. Qed.

Lemma gcd_odd_r a b : odd b = true -> odd (gcd a b) = true.
Proof. intros; eapply odd_divide. apply H. apply gcd_divide_r. Qed.

Lemma gcd_odd_l a b : odd a = true -> odd (gcd a b) = true.
Proof. intros; eapply odd_divide. apply H. apply gcd_divide_l. Qed.

Lemma divide_mul_l_l a b c : (a * b | c) -> (a | c).
Proof. intros [x]; exists (b * x); lia. Qed.

Lemma divide_mul_l_r a b c : (a * b | c) -> (b | c).
Proof. intros [x]; exists (a * x); lia. Qed.

Lemma mod2_dec a : { a mod 2 = 0 } + { a mod 2 = 1 }.
Proof. pose proof Zmod_even a; destruct (even a); auto. Qed.

Lemma min (f : nat -> Z) (H0 : f 0%nat <> 0) (H : exists N, f N = 0) :
  exists K, f K <> 0 /\ f (S K) = 0.
Proof.
  destruct H as [N].
  induction N.
  - lia.
  - destruct (eqb_spec (f N) 0).
    + apply IHN. assumption.
    + exists N. split.
      * assumption.
      * apply H. Qed.

Lemma gcd_rel_prime a b c : gcd a b = 1 -> gcd a c = gcd a (b * c).
Proof.
  intros. symmetry. apply gcd_unique.
  - apply gcd_nonneg.
  - apply gcd_divide_l.
  - apply divide_mul_r. apply gcd_divide_r.
  - intros q qa qbc.
    apply gauss in qbc.
    + apply gcd_greatest; assumption.
    + apply Zgcd_1_rel_prime. apply rel_prime_div with (p:=a).
      apply Zgcd_1_rel_prime. assumption. assumption. Qed.

Notation big_sum := (big_op op1 0)%RI.

Lemma big_sum_bound n f :
  (forall i, (i <= n)%nat -> (1 <= f i)%nat) -> (n <= big_sum f 0 n)%nat.
Proof.
  induction n; intros.
  - cbn. lia.
  - assert (forall i : nat, i <= n -> 1 <= f i)%nat by (intros; apply H; lia).
    apply IHn in H0. rewrite big_op_S_r by lia.
    assert (1 <= f n)%nat by (apply H; lia). cbn in *. lia. Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.saccheri.

Section rah_thales_postulate.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma rah__thales_postulate : postulate_of_right_saccheri_quadrilaterals -> thales_postulate.
Proof.
  intros rah A B C M HM HCong.
  destruct (col_dec A B C).
  { destruct (eq_dec_points A B).
      treat_equalities; Perp.
    destruct (l7_20 M A C); [ColR|Cong|..].
      subst; Perp.
    assert (B = C) by (apply l7_9 with M A; Midpoint).
    subst; Perp.
  }
  apply (t22_17__rah _ _ _ M); assumption.
Qed.

End rah_thales_postulate.


(* A tiny example of Coq code *)

Section EXAMPLE.
   Variables A B C : Prop.
   Theorem example : (A -> B) -> (B -> C) -> A -> C.
   Proof.
       intros H H' HA. apply H'. apply H. assumption.
   Qed.

   Definition example' : (A -> B) -> (B -> C) -> A -> C :=
       fun (H : A -> B) (H' : B -> C) (HA : A) => H' (H HA).
   Print example.
End EXAMPLE.


Require Import RBT.General.Basic.
Require Import RBT.General.BinaryTree.

Class WithKey (Node Key: Type): Type :=
  key: Node -> Key.

Section SearchTree.

Context {Node Key: Type} {WK: WithKey Node Key} {OK: ComputableTotalOrder Key}.

Inductive SearchTree': Key -> tree Node -> Key -> Prop :=
| ST_E : forall lo hi, lo < hi -> SearchTree' lo E hi
| ST_T: forall lo l x r hi,
    SearchTree' lo l (key x) ->
    SearchTree'  (key x) r hi ->
    SearchTree' lo (T l x r) hi.

Inductive SearchTree: tree Node -> Prop :=
| ST_intro: forall t lo hi, SearchTree' lo t hi -> SearchTree t.

Inductive SearchTree_half : Key -> list (half_tree Node) -> Key ->  Prop :=
| ST_nil : forall lo hi, lo < hi -> SearchTree_half lo nil hi
| ST_cons_LH : forall lo hi l x tree,
  SearchTree_half lo l hi -> lo < key x -> key x < hi -> SearchTree' lo tree (key x) ->
  SearchTree_half (key x) (LH x tree :: l) hi
  (* TODO: (lo < key x) not necessary *)
| ST_cons_RH : forall  lo  hi l x tree,
  SearchTree_half lo l hi -> lo < key x -> key x < hi -> SearchTree' (key x) tree hi ->
  SearchTree_half lo (RH tree x :: l) (key x).
  (* TODO: (key x < hi) not necessary *)

End SearchTree.