Require Import PeanoNat.

Require Import Coq.Init.Wf.
Require Import Coq.Arith.Wf_nat.
Require Import Wellfounded.Inverse_Image.

Require Import Lt.

Require Import wf_cruft.

Ltac dismiss := eexists; reflexivity.  (* used to finish a goal {y | y = ...} in the obvious way *)

Section Euclid.

  Definition absdiff a b := max a b - min a b.

  Definition ltnz (ab' ab : nat * nat) :=
    let (a', b') := ab' in
    let (a, b) := ab in
    b <> 0 /\ (b' = 0 \/ max a' b' < max a b).

  Require Import Wellfounded.Lexicographic_Product.
  Require Import Relations.Relation_Operators.

  Check wf_symprod.
  Check symprod.

  Definition measure1 (ab : nat*nat) :=
    match ab with
    | (_, 0) => 0
    | (0, _) => 1
    | _ => 2
    end.
  Definition measure2 (ab : nat*nat) := let (a,b) := ab in max a b.

  Definition measure12 ab := (measure1 ab, measure2 ab).

  Print sigT.
  Definition lt12 ab' ab := lexprod_pair _ _ lt lt (measure12 ab') (measure12 ab).

  Lemma lt12_wf : well_founded lt12.
    apply wf_inverse_image with (f := measure12).
    - apply wf_lexprod_pair; apply lt_wf.
  Defined.

  Notation "A <>? B" := (negb (Nat.eqb A B)) (at level 70).

  Definition measure1' (ab : nat*nat) := let (a,b) := ab in b <>? 0.
  Definition measure2' (ab : nat*nat) := let (a,b) := ab in a <>? 0.
  Definition measure3' (ab : nat*nat) := let (a,b) := ab in max a b.

  Definition measure123' (ab : nat*nat) := (measure1' ab, measure2' ab, measure3' ab).

  Definition bool_lt a b := a = false /\ b = true.

  Let f := (fun (b:bool) => if b then 1 else 0).  (* used for following proof *)

  Lemma bool_lt_wf : well_founded bool_lt.
    Check ltof.
    apply wf_prune with (R := ltof bool f).
    - destruct a,b; unfold bool_lt; intro H; destruct H; try (discriminate H || discriminate H0). constructor.
    - apply wf_inverse_image with (f := f).
      Check lt_wf.
      apply lt_wf.
  Defined.

  Definition lt123' ab' ab := lexprod_triple _ _ _ bool_lt bool_lt lt (measure123' ab') (measure123' ab).

  Lemma lt123'_wf : well_founded lt123'.
    apply wf_inverse_image with (f := measure123').
    apply wf_lexprod_triple; apply bool_lt_wf || apply lt_wf.
  Defined.

  Lemma ltnz_wf : well_founded ltnz.
    eapply wf_elax with (P := fun x => snd x = 0) (R := fun x y => max (fst x) (snd x) < max (fst y) (snd y)).
    - intro; apply Nat.eq_dec.
    - case a,b; unfold PR; simpl. tauto.
    - apply well_founded_ltof.
  Defined.

  Require Import Compare_dec.

  Lemma neq_minmax_gt {a b} : a <> b -> max a b > min a b.
    intro neq.
    destruct (lt_eq_lt_dec a b); try destruct s; try tauto.  (* a = b is impossible *)
    - (* a < b *)
      rewrite max_r, min_l; try ( apply Le.le_Sn_le; assumption ).
      assumption.
    - (* b < a *)
      rewrite max_l, min_r; try ( apply Le.le_Sn_le; assumption ).
      assumption.
  Qed.

  Lemma neq_absdiff_nz {a b} : a <> b -> absdiff a b <> 0.
    intro neq.
    apply Nat.sub_gt.
    apply neq_minmax_gt.
    assumption.
  Qed.

  Lemma S_not_eq n m : S n <> S m -> n <> m.
    intros K H.
    absurd (S n = S m).
    - assumption.
    - rewrite H; reflexivity.
  Qed.

  Lemma eq_absdiff_z {a} : absdiff a a = 0.
    unfold absdiff.
    rewrite min_l, max_l; try constructor.
    apply Nat.sub_diag.
  Qed.

  Require Import Psatz.

  Lemma absdiff_0_n n : absdiff 0 n = n.
    unfold absdiff; lia.
  Qed.

  Definition gcd : forall (a b : nat), nat.
    intros.
    refine (Fix lt123'_wf (fun _ => nat)

                (fun (ab:nat*nat) gcd' =>
                   (let '(a,b) as k := ab return (ab = k -> _) in
                    fun Hab =>
                    match b as k return (b = k -> _) with
                    | O => fun _ => a
                    | S _ => fun Hb => gcd' (absdiff a b, min a b) _
                    end eq_refl) eq_refl

           ) (a, b)).

    (* Extract the whole thing as a lemma so that it does not get expanded
     * when unfolding gcd *)
    Lemma gcd_d a b ab (Hab : ab = (a, b)) n (Hb : b = S n) : lt123' (absdiff a b, min a b) ab.
      subst.
      destruct a as [|a'].
      + (* a = 0 /\ b <> 0 *)
        apply left_lex, left_lex. simpl.
        red; split; reflexivity.     (* first component of measure123' is decreasing *)
      + (* a <> 0 /\ b <> 0 *)
        red.
        case (Nat.eq_dec a' n).
        * intro; subst. simpl.   (* a = b *)
          apply left_lex, right_lex. simpl. rewrite eq_absdiff_z. simpl.
          red; split; reflexivity.   (* second component is decreasing *)
        * intro a_neq_b.                             (* a <> b *)
          subst.
          unfold measure123'.
          simpl. replace (_ <>? 0) with true.
          (**) apply right_lex.      (* third component is decreasing *)
               unfold absdiff; lia.  (* <- very impressive *)
          (**) symmetry.
               rewrite Bool.negb_true_iff. (* negb b = true  -->  b = false *)
               rewrite Nat.eqb_neq.        (* (n =? m) = false  -->  n <> m *)
               auto using neq_absdiff_nz.
    Defined.

    apply (gcd_d a b ab Hab n Hb).
  Defined.

  Lemma gcd_unroll_once a b :
    gcd a b = match b with
              | 0 => a
              | S _ => gcd (absdiff a b) (min a b)
              end.
    unfold gcd.
    rewrite Fix_eq at 1.
    - destruct b; reflexivity.
    - (* extensionality proof *)
      admit.
  Admitted.

  Lemma gcd_k a b k : k >= 1 -> a >= k * b -> gcd a b = gcd (a - k * b) b.
    destruct b.
    - (* b = 0  is a degenerate case *)
      intros.
      rewrite gcd_unroll_once, gcd_unroll_once.
      lia.
    - intro H; induction H.
      + (* k = 1 *)
        intro.
        rewrite gcd_unroll_once.
        unfold absdiff; f_equal; lia.
      + (* k > 1 *)
        intro; rewrite IHle; try lia.
        rewrite gcd_unroll_once.
        unfold absdiff; f_equal; lia.
  Qed.

  (*
     Nat.div_mod:
       forall x y : nat, y <> 0 -> x = y * (x / y) + x mod y
   *)

  Lemma div_mul_le a b : b <> 0 -> (a / b) * b <= a.
    intro.
    rewrite Nat.mul_comm.
    erewrite (Nat.div_mod a b) at 2; try assumption.
    apply Plus.le_plus_l.
  Qed.

  Check right_lex.

  Lemma right_lex_pair A B ltA (ltB : _ -> _ -> Prop) x y y' :
    ltB y y' -> lexprod_pair A B ltA ltB (x, y) (x, y').
    intros; apply right_lex; assumption.
  Qed.

  Lemma right_lex_pair' A B ltA (ltB : _ -> _ -> Prop) x x' y y' :
    x = x' -> ltB y y' -> lexprod_pair A B ltA ltB (x, y) (x', y').
    intro; subst. apply right_lex_pair.
  Qed.

  Lemma lt123'_hole a b : lt123' a b.  (** obviously false **)
  Admitted.

  Lemma gcd_comm a b : gcd a b = gcd b a.
    induction (lt123'_wf (a,b)).
    rewrite gcd_unroll_once.
    rewrite (gcd_unroll_once b).
    case b; case a; try reflexivity.
    - intro; rewrite min_l; try apply le_0_n.
      rewrite gcd_unroll_once; compute; reflexivity.
    - intro; rewrite min_l; try apply le_0_n.
      rewrite gcd_unroll_once; compute; reflexivity.
    - intros; f_equal.
      unfold absdiff;lia. lia.
  Qed.

  Lemma gcd' a b : {y | y = gcd a b}.
    pose (lt123'_wf (a,b)) as acc.
    generalize a b acc; fix h 3.
    intros.
    destruct (Nat.eq_dec b0 0).
    - subst; rewrite gcd_unroll_once; dismiss.
    - destruct (le_lt_dec b0 a0).
      + erewrite gcd_k.
        Focus 3.
        * apply div_mul_le; assumption.
        * edestruct h as [r R]. Focus 2. rewrite <- R. dismiss.
          destruct acc0.
          apply H. (**) apply lt123'_hole. (**)
        * (* a >= b |- a / b >= 1 *)
          apply Nat.div_le_lower_bound; try assumption.
          rewrite Nat.mul_1_r; assumption.
      + rewrite gcd_unroll_once.
        generalize n; destruct b0 at 1 2; try tauto.
        intro. unfold absdiff. rewrite max_r, min_l.

  Defined.

End Euclid.

Extraction gcd.

Extraction gcd'.


Require Import Unicode.Utf8.

Open Scope nat_scope.

Theorem NAdditionAssociative : (forall x y z : nat, (x + y) + z = x + (y + z)).
Proof.
  intro x.
  intro y.
  intro z.

  induction x.

  rewrite plus_O_n.
  rewrite plus_O_n.

  reflexivity.

  rewrite (plus_Sn_m x y).
  rewrite (plus_Sn_m (x + y) z).
  rewrite (plus_Sn_m).
  rewrite IHx.

  reflexivity.
Qed.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.
Require number.Divisibility.
Require number.Gcd.
Require number.Prime.

(* Why3 assumption *)
Definition coprime (a:Z) (b:Z): Prop := ((number.Gcd.gcd a b) = 1%Z).

Lemma coprime_is_Zrel_prime :
  forall a b, coprime a b <-> Znumtheory.rel_prime a b.
intros.
unfold coprime.
unfold Znumtheory.rel_prime.
split; intro h.
rewrite <- h; apply Znumtheory.Zgcd_is_gcd.
apply Znumtheory.Zis_gcd_gcd; auto with zarith.
Qed.

(* Why3 goal *)
Lemma prime_coprime : forall (p:Z), (number.Prime.prime p) <->
  ((2%Z <= p)%Z /\ forall (n:Z), ((1%Z <= n)%Z /\ (n < p)%Z) -> (coprime n
  p)).
intros p.
(*
Znumtheory.prime_intro:
  forall p : int,
  (1 < p)%Z ->
  (forall n : int, (1 <= n < p)%Z -> Znumtheory.rel_prime n p) ->
  Znumtheory.prime p
*)
rewrite Prime.prime_is_Zprime.
split.
intro h; inversion h; clear h.
split; auto with zarith.
intros n h.
rewrite coprime_is_Zrel_prime.
apply H0; auto.
intros (h1,h2).
constructor; auto with zarith.
intros n h.
rewrite <- coprime_is_Zrel_prime.
apply h2; auto.
Qed.

(* Why3 goal *)
Lemma Gauss : forall (a:Z) (b:Z) (c:Z), ((number.Divisibility.divides a
  (b * c)%Z) /\ (coprime a b)) -> (number.Divisibility.divides a c).
intros a b c (h1,h2).
apply Znumtheory.Gauss with b; auto.
rewrite <- coprime_is_Zrel_prime; auto.
Qed.

(* Why3 goal *)
Lemma Euclid : forall (p:Z) (a:Z) (b:Z), ((number.Prime.prime p) /\
  (number.Divisibility.divides p (a * b)%Z)) -> ((number.Divisibility.divides
  p a) \/ (number.Divisibility.divides p b)).
intros p a b (h1,h2).
apply Znumtheory.prime_mult; auto.
now rewrite <- Prime.prime_is_Zprime.
Qed.

(* Why3 goal *)
Lemma gcd_coprime : forall (a:Z) (b:Z) (c:Z), (coprime a b) ->
  ((number.Gcd.gcd a (b * c)%Z) = (number.Gcd.gcd a c)).
intros a b c h1.
apply Z.gcd_unique.
- apply Z.gcd_nonneg.
- apply Gcd.gcd_def1.
- apply Divisibility.divides_multl.
  apply Gcd.gcd_def2.
- intros q h2 h3.
  apply Gcd.gcd_def3.
  trivial.
  apply Gauss with b; split; auto.
  rewrite coprime_is_Zrel_prime.
  rewrite coprime_is_Zrel_prime in h1.
  now apply Znumtheory.rel_prime_div with (2:=h2).
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf4 : natural) (lf2 : natural) : natural :=
  plus Zero (plus lf2 lf4).


(**************************************************************)
(*   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 List Omega.

Require Import tacs.

Set Implicit Arguments.

Definition app_split X (l1 : list X) : forall l2 r1 r2, l1++r1 = l2++r2
                                      -> { m | l2 = l1++m /\ r1 = m++r2 }
                                       + { m | l1 = l2++m /\ r2 = m++r1 }.
Proof.
  induction l1 as [ | x l1 Hl1 ].
  left; exists l2; auto.
  intros [ | y l2 ] r1 r2 H.
  right; exists (x::l1); auto.
  simpl in H; injection H; clear H; intros H ?; subst.
  apply Hl1 in H.
  destruct H as [ (m & H1 & H2) | (m & H1 & H2) ].
  left; exists m; subst; auto.
  right; exists m; subst; auto.
Qed.

Fact list_split_first_half U (ll : list U) x : x <= length ll -> { l : _ & { r | ll = l++r /\ length l = x } }.
Proof.
  revert ll; induction x as [ | x IHx ]; intros [ | u ll ] Hx.
  exists nil, nil; simpl; auto.
  exists nil, (u::ll); auto.
  simpl in Hx; omega.
  destruct (IHx ll) as (l & r & H1 & H2).
  simpl in Hx; omega.
  exists (u::l), r; simpl; split; f_equal; auto.
Qed.

Fact list_split_second_half U (ll : list U) x : x <= length ll -> { l : _ & { r | ll = l++r /\ length r = x } }.
Proof.
  intros Hx.
  destruct list_split_first_half with (ll := ll) (x := length ll - x)
    as (l & r & H1 & H2).
  omega.
  exists l, r; split; auto.
  apply f_equal with (f := @length _) in H1.
  rewrite app_length in H1.
  omega.
Qed.

Section list_prefix.

  Variables (X : Type).

  Fixpoint pfx (f : nat -> X) n :=
      match n with
        | 0   => nil
      | S n => f 0 :: pfx (fun n => f (S n)) n
    end.

  Fact pfx_length f n : length (pfx f n) = n.
  Proof.
    revert f; induction n; intros f; simpl; auto.
  Qed.

  Fact pfx_plus f a b : pfx f (a+b) = pfx f a ++ pfx (fun n => f (a+n)) b.
  Proof.
    revert f;
    induction a; intros f; simpl; auto.
    f_equal; apply IHa.
  Qed.

  Fact pfx_In f n x : In x (pfx f n) <-> exists i, i < n /\ x = f i.
  Proof.
    split.

    revert f; induction n as [ | n IHn ]; intros f; simpl.
    intros [].
    intros [ H | H ].
    subst; exists 0; split; auto; omega.
    destruct (IHn _ H) as (i & H1 & H2).
    exists (S i); split; auto; omega.

    intros (i & H1 & H2); subst x.
    revert f i H1.
    induction n as [ | n IH ]; intros f i Hi; try omega; simpl.
    destruct i.
    left; auto.
    right.
    apply (IH (fun x => f (S x))); omega.
  Qed.

  Fact pfx_eq f n l x r : pfx f n = l++x::r -> f (length l) = x.
  Proof.
    revert f l x r; induction n as [ | n IH ]; intros f l x r; simpl.
    destruct l; discriminate 1.
    destruct l as [ | y l ]; simpl;
    intros H; injection H; clear H; intros H1 H2; auto.
    apply IH in H1; auto.
  Qed.

  Fixpoint list_fun_concat l f n : X :=
    match l with
      | nil  => f n
      | x::l =>
      match n with
        | 0   => x
        | S n => list_fun_concat l f n
      end
    end.

  Fact lf_concat_pfx_lt ll f n : n < length ll -> exists l r, l ++ r = ll /\ l = pfx (list_fun_concat ll f) n.
  Proof.
    revert n; induction ll as [ | x ll IH ]; intros [ | n ] Hn; simpl in Hn; try (exfalso; omega); simpl.
    exists nil, (x::ll); auto.
    destruct (IH n) as (l & r & H1 & H2).
    omega.
    exists (x::l), r; simpl; split; f_equal; auto.
  Qed.

  Fact lf_concat_pfx_ge ll f n : length ll <= n -> pfx (list_fun_concat ll f) n = ll ++ pfx f (n - length ll).
  Proof.
    revert n; induction ll as [ | x ll IH ]; intros n Hn.
    simpl; f_equal; omega.
    destruct n.
    simpl in Hn; omega.
    simpl.
    f_equal.
    apply IH.
    simpl in Hn; omega.
  Qed.

End list_prefix.

Fact pfx_map X Y (h : X -> Y) f n : pfx (fun n => h (f n)) n = map h (pfx f n).
Proof.
  revert f; induction n; intros f; simpl; f_equal; auto.
Qed.

(* prefix of an infinite sequence, in reverse order *)

Section list_prefix_rev.

  Variable X : Type.

  Fixpoint pfx_rev f n : list X :=
    match n with
      | 0   => nil
      | S n => (f n)::(pfx_rev f n)
    end.

  Fact pfx_rev_plus f a b : pfx_rev f (a+b) = pfx_rev (fun n => f (b+n)) a ++ pfx_rev f b.
  Proof.
    induction a; simpl; auto.
    f_equal; auto.
    f_equal; apply plus_comm.
  Qed.

  Fact pfx_rev_S f a : pfx_rev f (S a) = pfx_rev (fun n => f (S n)) a ++ f 0 :: nil.
  Proof.
    generalize (pfx_rev_plus f a 1); intros H.
    replace_with H; f_equal; rewrite plus_comm; auto.
  Qed.

  Fact pfx_pfx_rev_eq f n : pfx_rev f n = rev (pfx f n).
  Proof.
    revert f.
    induction n as [ | n IHn ]; intros f.
    simpl; auto.
    simpl pfx.
    cutrewrite (S n = n+1); try omega.
    rewrite pfx_rev_plus; simpl.
    f_equal; auto.
  Qed.

  Fact pfx_rev_ext f g n : (forall x, x < n -> f x = g x) -> pfx_rev f n = pfx_rev g n.
  Proof.
    induction n; simpl; auto;
    intros H.
    rewrite H; try omega.
    f_equal; auto.
  Qed.

  Fact pfx_rev_minus f n : pfx_rev f n = pfx (fun x => f (n - S x)) n.
  Proof.
    revert f; induction n as [ | n IHn ]; intros f; simpl; auto.
    do 2 f_equal. omega.
    apply IHn.
  Qed.

  Fact pfx_rev_In f n x : In x (pfx_rev f n) <-> exists i, i < n /\ x = f i.
  Proof.
    split.

    induction n as [ | n IHn ]; simpl.
    intros [].
    intros [ H | H ].
    subst; exists n; auto.
    destruct (IHn H) as (i & H1 & H2).
    exists i; split; auto.

    intros (i & H1 & H2); subst x.
    revert i H1.
    induction n as [ | n IH ]; intros i Hi; try omega; simpl.
    destruct (le_lt_dec n i).
    left; f_equal; omega.
    right; apply IH; auto.
  Qed.

  Fact pfx_rev_length f n : length (pfx_rev f n) = n.
  Proof.
    induction n; simpl; auto.
  Qed.

  Fact pfx_rev_eq f n l x r : pfx_rev f n = l++x::r -> f (length r) = x.
  Proof.
    revert l x r; induction n as [ | n IH ]; intros l x r; simpl.
    destruct l; discriminate 1.
    destruct l as [ | y l ]; simpl;
    intros H; injection H; clear H; intros H1 H2.
    replace_with H2; f_equal.
    subst r; apply pfx_rev_length.
    apply IH with (1 := H1).
  Qed.

End list_prefix_rev.

Fact pfx_rev_map X Y (h : X -> Y) f n : pfx_rev (fun n => h (f n)) n = map h (pfx_rev f n).
Proof.
  induction n; simpl; f_equal; auto.
Qed.

Definition list_prefix X (ll : list X) n : n <= length ll -> { l : _ & { r | ll = l++r /\ length l = n } }.
Proof.
  revert n; induction ll as [ | x ll IH ].
  intros [ | n ] Hn; exists nil, nil; split; auto.
  exfalso; simpl in Hn; omega.
  intros [ | n ] Hn.
  exists nil, (x::ll); auto.
  simpl in Hn.
  destruct (IH n) as (l & r & H1 & H2).
  omega.
  subst.
  exists (x::l), r; auto.
Qed.

Definition list_suffix X (ll : list X) n : n <= length ll -> { l : _ & { r | ll = l++r /\ length r = n } }.
Proof.
  intros H.
  destruct (@list_prefix _ ll (length ll - n)) as (l & r & H1 & H2).
  omega.
  exists l, r; repeat split; auto.
  apply f_equal with (f := @length _) in H1.
  rewrite app_length in H1.
  omega.
Qed.

Fact list_prefix_eq X (l r l' r' : list X) : l++r = l'++r' -> length l = length l' -> l = l' /\ r = r'.
Proof.
  revert l'; induction l as [ | x l IHl ]; intros [ | y l' ] H1 H2; auto; simpl in H2; try discriminate H2.
  simpl in H1; injection H1; clear H1; intros H1 H3; subst.
  destruct IHl with (1 := H1).
  omega.
  subst; auto.
Qed.

Fact list_suffix_eq X (l r l' r' : list X) : l++r = l'++r' -> length r = length r' -> l = l' /\ r = r'.
Proof.
  intros H1 H2; apply list_prefix_eq; auto.
  apply f_equal with (f := @length _) in H1.
  do 2 rewrite app_length in H1.
  omega.
Qed.

Fact list_suffix_split X (l r l' r' : list X) : l++r = l'++r' -> length r <= length r' -> { m | l = l'++m /\ r' = m++r }.
Proof.
  revert r l' r'; induction l as [ | x l IHl ]; intros r [ | y l' ] r' H1 H2; simpl in H1.
  exists nil; auto.
  apply f_equal with (f := @length _) in H1.
  simpl in H1.
  rewrite app_length in H1.
  exfalso; omega.
  exists (x::l); auto.
  injection H1; clear H1; intros H1 ?; subst y.
  destruct IHl with (1 := H1) as (m & H3 & H4); auto.
  exists m; subst; auto.
Qed.


Require Import Contractive ContractiveFacts CS CSFacts Equiv Free FreeFacts
  NonEquiv Rel Sty StyInd Subst SubstFacts Shape Tac Msg Var Wf WfFacts.
Require Import TLC.LibRelation TLC.LibLogic.

(* ------------------------------------------------------------------------- *)
(* Reflexivity *)

Inductive R_Sequiv_reflexive : Sty -> Sty -> Prop :=
| R_Sequiv_reflexive_refl :
    forall S,
    Wf S ->
    R_Sequiv_reflexive S S
| R_Sequiv_reflexive_mu1 :
    forall X S,
    Wf (subst X (mu X S) S) ->
    R_Sequiv_reflexive (mu X S) (subst X (mu X S) S)
| R_Sequiv_reflexive_mu2 :
    forall X S,
    Wf (subst X (mu X S) S) ->
    R_Sequiv_reflexive (subst X (mu X S) S) (mu X S)
.

Theorem Sequiv_reflexive :
  forall S,
  Wf S ->
  Sequiv S S.
Proof.
  intros. apply Sequiv_coind with (R := R_Sequiv_reflexive);
    [|constructor; auto].
  clear. introv H. inverts1 H; [destruct S'|..];
    try (constructor; constructor); auto with wf.
Qed.

(* ------------------------------------------------------------------------- *)
(* Symmetry *)

Theorem Sequiv_symmetric : forall S S',
  Sequiv S S' -> Sequiv S' S.
Proof with auto.
  apply clos_sym_sym. unfold inclusion. apply Sequiv_coind.
  intros S S' H.
  inversion_clear H. inversion_clear H0.
  inversion H; constructor; subst; constructor...
Qed.

(* ------------------------------------------------------------------------- *)
(* Transitivity *)

Section Transitivity.

Inductive R_Sequiv_transitive : Sty -> Sty -> Prop :=
| R_Sequiv_transitive_intro :
    forall S T U,
    Wf S ->
    Wf T ->
    Wf U ->
    Sequiv S T ->
    Sequiv T U ->
    R_Sequiv_transitive S U
.
Hint Constructors R_Sequiv_transitive.

Theorem Sequiv_transitive :
  forall S T U,
  Wf S ->
  Wf T ->
  Wf U ->
  Sequiv S T ->
  Sequiv T U ->
  Sequiv S U.
Proof.
  intros. apply Sequiv_coind with (R := R_Sequiv_transitive);
    [|eauto].
  clear. introv H. rename S' into U. inverts H.

  assert (Sequiv S (cs T)) as HSeqT by (
    eapply cs_preserves_Sequiv_r; auto with wf
  ).

  assert (Sequiv (cs T) U) as HTeqU by (
    eapply cs_preserves_Sequiv_l; auto with wf
  ).

  Hint Extern 3 (Wf _) =>
    match goal with
    | HWfT : Wf ?T, Heq : ?S = cs ?T |- _ =>
        solve [
          apply cs_preserves_Wf in HWfT; rewrite <- Heq in HWfT; auto with wf
        ]
    end
  .

  Local Ltac finish T1 :=
    apply R_Sequiv_transitive_intro with (T := T1); auto with wf
  .

  clear H3 H4. inverts2 HSeqT; inverts2 HTeqU; subst; try solve [false].
  - auto.
  - constructor. rewrite <- HSeqT in *. eauto with wf.
  - rewrite <- H4 in H3. injection H3; intros; subst. constructor. finish S.
  - rewrite <- H3 in *. constructor. finish (send B S').
  - rewrite <- H4 in H3. injection H3; intros; subst. constructor. finish S.
  - rewrite <- H3 in *. constructor. finish (recv B S').
  - rewrite <- H4 in H3. injection H3; intros; subst. constructor.
    * finish S0.
    * finish S3.
  - rewrite <- H3 in *. constructor. finish (echoice S1' S2').
  - rewrite <- H4 in H3. injection H3; intros; subst. constructor.
    * finish S0.
    * finish S3.
  - rewrite <- H3 in *. constructor. finish (ichoice S1' S2').
  - rewrite <- HTeqU in *. constructor. eauto with wf.
  - rewrite <- H3 in *. constructor. finish (send B S).
  - rewrite <- H3 in *. constructor. finish (recv B S).
  - rewrite <- H3 in *. constructor. finish (echoice S1 S2).
  - rewrite <- H3 in *. constructor. finish (ichoice S1 S2).
  - exfalso; auto with subst wf.
  - assert (Sequiv (cs T) (mu X0 S')) as HTeqU' by auto.
    constructor. finish (cs T).
  - exfalso; auto with subst wf.
  - exfalso; auto with subst wf.
Qed.

End Transitivity.

(* ------------------------------------------------------------------------- *)
(* NSequiv -> ~ Sequiv *)

Lemma NSequiv_not_Sequiv :
  forall S S',
  Contractive S ->
  Contractive S' ->
  NSequiv S S' ->
  ~ Sequiv S S'.
Proof.
  introv Hok Hok' H. induction H; introv contra; try solve
    [ inverts2 contra; auto
    | inverts2 contra; inverts Hok; inverts Hok';
      unfold not in *; eauto with nsequiv
    ].
  - apply cs_preserves_Sequiv_r in contra; inverts2 contra;
    [apply IHNSequiv|..];
    auto using uncs_preserves_Sequiv_r with contractive subst.
  - apply cs_preserves_Sequiv_l in contra; inverts2 contra;
    [|apply IHNSequiv|..];
    auto using uncs_preserves_Sequiv_l with contractive subst.
Qed.

(* ------------------------------------------------------------------------- *)
(* ~ NSequiv -> Sequiv *)

Inductive R_not_NSequiv_Sequiv : Sty -> Sty -> Prop :=
| R_not_NSequiv_Sequiv_intro :
    forall S S',
    Closed S ->
    Closed S' ->
    ~ NSequiv S S' ->
    R_not_NSequiv_Sequiv S S'
.
Hint Constructors R_not_NSequiv_Sequiv : nsequiv.

Lemma not_NSequiv_Sequiv' :
  forall S S',
  R_not_NSequiv_Sequiv S S' ->
  Sequiv_gen R_not_NSequiv_Sequiv S S'.
Proof.
  introv H. inverts H as Hcl Hcl' H. destruct S; destruct S'; try solve
    [ exfalso; apply H; constructor; intro; discriminate ];
    try match goal with
    | B : Msg, B' : Msg |- _ =>
      destruct (eq_Msg_dec B B'); [subst | exfalso; auto with nsequiv]
    end;
    auto 8 with free nsequiv.
Qed.

Lemma not_NSequiv_Sequiv :
  forall S S',
  Closed S ->
  Closed S' ->
  ~ NSequiv S S' ->
  Sequiv S S'.
Proof.
  intros. apply Sequiv_coind with (R := R_not_NSequiv_Sequiv);
  auto using not_NSequiv_Sequiv' with nsequiv.
Qed.

(* ------------------------------------------------------------------------- *)
(* NSequiv <-> ~ Sequiv *)

Lemma NSequiv_iff_not_Sequiv :
  forall S S',
  Wf S ->
  Wf S' ->
  (NSequiv S S' <-> ~ Sequiv S S').
Proof.
  introv Hok Hok'. split; introv H; unfold Wf in *.
  + eapply NSequiv_not_Sequiv; eauto.
  + gen H. apply contrapose_elim. introv H. apply not_not_intro.
    apply not_NSequiv_Sequiv; auto.
Qed.


Require Export P08.

(** **** Exercise: 4 stars, advanced (pigeonhole principle)  *)
(** The _pigeonhole principle_ states a basic fact about counting: if
   we distribute more than [n] items into [n] pigeonholes, some
   pigeonhole must contain at least two items.  As often happens, this
   apparently trivial fact about numbers requires non-trivial
   machinery to prove, but we now have enough... *)

(** First prove an easy useful lemma. *)

Lemma lt_S: forall n m,
    S n < S m -> n < m.
Proof.
intros.
induction m.
- inversion H. inversion H1.
- inversion H. auto.
  apply IHm in H1.
  constructor.
  assumption.
Qed.

Lemma in_split : forall (X:Type) (x:X) (l:list X),
  In x l ->
  exists l1 l2, l = l1 ++ x :: l2.
Proof.
intros.
induction l.
- inversion H.
- inversion H.
  + rewrite H0 in *.
    exists [], l.
    reflexivity.
  + apply IHl in H0.
    inversion H0.
    inversion H1.
    exists (a::x0).
    exists x1.
    simpl.
    rewrite H2.
    reflexivity.
Qed.

(** Now define a property [repeats] such that [repeats X l] asserts
    that [l] contains at least one repeated element (of type [X]).  *)

Inductive repeats {X:Type} : list X -> Prop :=
| rp_base: forall x l, In x l -> repeats (x::l)
| rp_next: forall x l, repeats l -> repeats (x::l)
.

Theorem len_plus: forall (X:Type) (l1:list X) (l2:list X),
    length (l1++l2) = length l1 + length l2.
Proof.
intros.
induction l1.
- reflexivity.
- simpl. rewrite IHl1. auto.
Qed.

Theorem in_case_diff:forall (X:Type) (x:X) (x2:X) (l1 l2:list X),
  In x2 (l1++x::l2) -> x <> x2 -> In x2 (l1++l2).
Proof.
intros.
induction l1.
- simpl. simpl in H. destruct H.
  + apply H0 in H. inversion H.
  + assumption.
- simpl. simpl in H.
  destruct H.
  + auto.
  + right. auto.
Qed.

(** Now, here's a way to formalize the pigeonhole principle.  Suppose
    list [l2] represents a list of pigeonhole labels, and list [l1]
    represents the labels assigned to a list of items.  If there are
    more items than labels, at least two items must have the same
    label -- i.e., list [l1] must contain repeats.

    This proof is much easier if you use the [excluded_middle]
    hypothesis to show that [In] is decidable, i.e., [forall x l, (In x
    l) \/ ~ (In x l)].  However, it is also possible to make the proof
    go through _without_ assuming that [In] is decidable; if you
    manage to do this, you will not need the [excluded_middle]
    hypothesis. *)

Theorem pigeonhole_principle: forall (X:Type) (l1  l2:list X),
   excluded_middle ->
   (forall x, In x l1 -> In x l2) ->
   length l2 < length l1 ->
   repeats l1.
Proof.
   intros X l1. induction l1 as [|x l1' IHl1'].
   - simpl. intros. inversion H1.
   - intros l2 H_excluded H1 H2. unfold excluded_middle in *.
     assert (H' := H_excluded (In x l1')).
     destruct H'.
     + apply rp_base. assumption.
     + apply rp_next. destruct (in_split X x l2).
       * apply H1. simpl. left. reflexivity.
       * inversion H0. apply IHl1' with (l2 := x0++x1).
         ++ assumption.
         ++ intros. destruct (H_excluded (x = x2)) eqn:Heqxx2.
            +++ subst. apply H in H4. contradiction.
            +++ apply in_case_diff with (x := x). subst. apply H1.
                simpl. right. assumption. assumption.
         ++ subst. rewrite len_plus in H2. simpl in H2. rewrite <- plus_n_Sm in H2.
            rewrite len_plus. apply lt_S. assumption.
Qed.


Require Import Omega.
Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.
Import ListNotations.

From q3_2001 Require Export misc.

(* As elsewhere, no difference to work over a general type with decidable
   equality except that we'd have to litter the codebase with lots of
   'decA' terms so let's just stick with nat. *)
Definition nunique := compose (@length nat) (nodup Nat.eq_dec).

Lemma nunique_spec_0 : forall (l : list nat),
  nunique l = length (nodup Nat.eq_dec l).
Proof. auto. Qed.

Lemma nunique_spec_1 : forall (l : list nat),
  nunique l = 0 <-> l = [].
Proof. intros l. rewrite nunique_spec_0. rewrite length_zero_iff_nil. apply nodup_empty_spec. Qed.

Lemma nunique_spec_2 : forall (l : list nat),
  nunique l <> 0 <-> l <> [].
Proof. intros l. split; apply contrapositive; rewrite nunique_spec_1; trivial. Qed.

Lemma nunique_spec_3 : forall (l : list nat) (x : nat),
  In x l -> nunique (x::l) = nunique l.
Proof.
  intros l x Hx. unfold nunique. unfold compose.
  assert (H_incl : incl (nodup Nat.eq_dec (x::l)) (nodup Nat.eq_dec l)). {
    unfold incl. intros x' Hx'. rewrite -> nodup_In. rewrite -> nodup_In in Hx'.
    destruct Hx'; [subst |]; assumption.
  }
  assert (H_incl' : incl (nodup Nat.eq_dec l) (nodup Nat.eq_dec (x::l))). {
    unfold incl. intros x' Hx'. rewrite -> nodup_In. rewrite -> nodup_In in Hx'. right. assumption.
  }
  apply NoDup_incl_length in H_incl; try (apply NoDup_nodup).
  apply NoDup_incl_length in H_incl'; try (apply NoDup_nodup).
  omega.
Qed.

Lemma nunique_spec_4 : forall (l : list nat) (x : nat),
  ~In x l -> nunique (x::l) = 1 + nunique l.
Proof.
  intros l x Hx. unfold nunique. unfold compose.
  assert (H_incl : incl (nodup Nat.eq_dec (x::l)) (x::(nodup Nat.eq_dec l))). {
    unfold incl. intros x' Hx'. simpl. rewrite -> nodup_In. rewrite -> nodup_In in Hx'. simpl in Hx'. assumption.
  }
  assert (H_incl' : incl (x::(nodup Nat.eq_dec l)) (nodup Nat.eq_dec (x::l))). {
    unfold incl. intros x' Hx'. rewrite -> nodup_In. simpl in Hx'. rewrite -> nodup_In in Hx'. simpl. assumption.
  }
  apply NoDup_incl_length in H_incl; try (apply NoDup_nodup).
  apply NoDup_incl_length in H_incl'; try (rewrite NoDup_cons_iff).
  - assert (H : length (nodup Nat.eq_dec (x :: l)) = length (x :: nodup Nat.eq_dec l)). { omega. }
    rewrite -> H. reflexivity.
  - split.
    + rewrite -> nodup_In. assumption.
    + apply NoDup_nodup.
Qed.

Lemma nunique_spec_5 : forall (l : list nat),
  l = [] <-> nunique l = 0.
Proof.
  intros l.
  split; intros H.
  - subst. auto.
  - rewrite nunique_spec_0 in H. rewrite length_zero_iff_nil in H.
    rewrite nodup_empty_spec in H. assumption.
Qed.


Print le.

Lemma Z_le_n : forall n, le 0 n.
Proof.
induction n.
- constructor.
- constructor.
  assumption.
Qed.

Lemma le_S: forall n m, le n m -> le (S n) (S m).
Proof.
induction 1.
- constructor.
- constructor;assumption.
Qed.

Inductive ev : nat -> Prop :=
| ev_0 : ev 0
| ev_SS : forall n : nat, ev n -> ev (S (S n)).

Print pred.
Print Nat.pred.

Theorem ev_minus2 : forall n,
  ev n -> ev (pred (pred n)).
Proof.
(*
  intros n E.
  induction E.
  - simpl; constructor.
  - simpl.
    assumption.
*)
  intros n E.
  inversion E as [| n' E'].
  - (* E = ev_0 *) simpl. apply ev_0.
  - (* E = ev_SS n' E' *) simpl. apply E'.

Qed.

Section A_dec.

Variable A : Type.
Variable eq_dec : forall (x y:A), {x=y}+{~ x=y}.

Locate "+".
Print sumbool.

Print list.

Fixpoint count_occ (x:A)(l:list A) :=
match l with
| nil => 0
| cons y l' => let n:= count_occ x l' in
             match eq_dec x y with
             | left _ => 1 + n
             | right _ => n
             end
end.

Lemma AtLeastOne: forall (x:A)(l:list A),count_occ x l > 0 -> l<> nil.
Proof.
intros x l.
destruct l.
- simpl.
  intros.
  inversion H.
- simpl.
  destruct (eq_dec x a); intros; congruence.
Qed.

End A_dec.

Check AtLeastOne.

Lemma nat_dec: forall (x y:nat), {x=y}+{~ x=y}.
Proof.
induction x; destruct y.
 - left; reflexivity.
 - right; congruence.
 - right; congruence.
 - destruct (IHx y).
   * left; congruence.
   * right; congruence.
Qed.

Check AtLeastOne nat nat_dec.


(******************************************************************************)
(* Solutions of exercises : Small scale reflection, first examples            *)
(******************************************************************************)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
From mathcomp Require Import path choice fintype tuple finset.

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

(******************************************************************************)
(* Exercise 4.1.1                                                             *)
(******************************************************************************)

(* The proof goes by case analysis on the truth table, applying the *)
(*appropriate constructor of the reflect predicate in every meaningful *)
(*case. The other case ask a proof of False in a conctext where False *)
(*can be obtained as a hypothesis after destructing a conjunction (the *)
(*last case tactic) *)

Lemma tuto_andP : forall b1 b2 : bool, reflect (b1 /\ b2) (b1 && b2).
Proof. by case; case; constructor; auto; case. Qed.

(* Again this lemma is a macro for a cacse analysis on the truth table *)
(*of b1 b2 and (b1 || b2) *)

Lemma tuto_orP : forall b1 b2 : bool, reflect (b1 \/ b2) (b1 || b2).
Proof. by case; case; constructor; auto; case. Qed.

(******************************************************************************)
(* Exercise 4.1.2                                                             *)
(******************************************************************************)

(* The first solution follows the hint given in the tutorial. In fact *)
(* it is sufficient to perform case analysis on the constructor of the *)
(*reflect hypothesis as done in the second solution. *)
Lemma tuto_iffP : forall (P Q : Prop) (b : bool),
      reflect P b -> (P -> Q) -> (Q -> P) -> reflect Q b.
Proof. by move=> P Q; case; case; constructor; auto. Qed.

Lemma alternate_tuto_iffP : forall (P Q : Prop) (b : bool),
      reflect P b -> (P -> Q) -> (Q -> P) -> reflect Q b.
Proof. by move=> P Q b; case; constructor; auto. Qed.

(******************************************************************************)
(* Exercise 4.2.1                                                             *)
(******************************************************************************)

(*We use a section to factorize the type of elements in the *)
(*sequences*)

Section Exo_4_2_1.

Variable A : Type.

(* We use implicit type annotations to avoid casting quantified *)
(*variables : *)
Implicit Types s : seq A.
Implicit Types x : A.

(* The type of x has been declared implicit, hence the type of s1 and *)
(*s2 and inferred: *)
Fixpoint tuto_cat s1 s2 :=
match s1 with
  |[::] => s2
  | x :: s' => x :: (tuto_cat s' s2)
end.

(* Using the ssreflect pattern conditional this code can be shrinked *)
(*into the actual program present in the seq library:*)
Fixpoint alternate_tuto s1 s2 :=
  if s1 is x :: s' then x :: (tuto_cat s' s2) else s2.

(* The proof goes by induction on the first list. We do not need to be *)
(*general with respect to the second list, hence we introduce it *)
(*before the induction. The first case is solved on the fly by the //= *)
(*simple+solve switch, and x and s1 are introduced in the remaining *)
(*goal. The last hypothesis is directly rewritten without being *)
(*introduced, generating an equality between convertible terms. This *)
(*equality being trivial it is solved by the prenex 'by' tactic *)
Lemma tuto_size_cat : forall s1 s2,
   size (s1 ++ s2) = size s1 + size s2.
Proof. by move=> s1 s2; elim: s1 => //= x s1 ->. Qed.

(* We use again a pattern conditional *)
Fixpoint tuto_last (A : Type)(x : A)(s : seq A) {struct s} :=
  if s is x' :: s' then tuto_last x' s' else x.

(* Again an induction on the first list *)
Lemma tuto_last_cat : forall x s1 s2,
  last x (s1 ++ s2) = last (last x s1) s2.
Proof. by move=> x s1 s2; elim: s1 x => [|y s1 IHs] x //=; rewrite IHs. Qed.

Fixpoint tuto_take n s {struct s} :=
  match s, n with
  | x :: s', n'.+1 => x :: take n' s'
  | _, _ => [::]
  end.

(* Here we have two options: a recursion on the nat or on the seq.*)
(* Decreazing on the seq has better compositional properties: it *)
(*allows more fixpoints further defined to decrease structurally *)
Fixpoint tuto_drop n s {struct s} :=
  match s, n with
  | _ :: s', n'.+1 => drop n' s'
  | _, _ => s
  end.

Definition tuto_rot n s := drop n s ++ take n s.

Lemma tuto_rot_addn : forall m n s, m + n <= size s ->
  rot (m + n) s = rot m (rot n s).
Proof.
(* We first transform the inequality hypothesis into a case *)
(*disjunction between equality or strict inequality. *)
move=> m n s; rewrite leq_eqVlt.
(* Then a view allows to proceed to the case analysis by generating *)
(* two goals *)
case/predU1P=> [Emn|Hmn].
(*  1st case: equality. We rewrite the hypothesis, then the rot_size *)
(*lemma (try to guess the name of the lemma according to the ssr *)
(*discipline, or use the Search command, for instance:
Search _ rot size.*)
rewrite Emn rot_size.
(* Again, use the Search command:*)
Search _ (rot _ (rot _ _) = _).
  rewrite rot_add_mod -Emn ?leq_addr ?leq_addl //.
  by rewrite  Emn leqnn rot_size.
(* a more elegant proof of this last step would be:
  by rewrite  -{1}(rotrK m s) /rotr -Emn addKn.
  It is worth also browsing the source of the library to discover new
  functions that could help you, like rotr is this case *)
(* Remember rot is programmed from cat take and drop:
Search _ cat take drop.*)
rewrite -{1}(cat_take_drop n s) /rot !take_cat !drop_cat.
Search _ (size (take _ _) = _).
have Hns : n <= size s by apply: leq_trans (leq_addl _ _) (ltnW Hmn).
rewrite !(size_takel Hns).
(* We directly rewrite the condition proved forward *)
have -> : m + n < n = false by rewrite ltnNge leq_addl.
rewrite size_drop.
have -> :  m < size s - n by rewrite ltnNge leq_subLR -ltnNge addnC.
by rewrite addnK catA.
Qed.

(* Look at the source of the seq.v file for a shorter proof! *)

End Exo_4_2_1.
(******************************************************************************)
(* Exercise 4.2.2                                                             *)
(******************************************************************************)

Section Exo_4_2_2.

Variable A : Type.

(* We use implicit type annotations to avoid casting quantified *)
(*variables : *)
Implicit Types s : seq A.
Implicit Types x : A.

(* We fix an arbitrary predicate a *)
Variable a : pred A.

(* We use again a pattern conditional *)
Fixpoint tuto_count s := if s is x :: s' then a x + tuto_count s' else 0.

Lemma tuto_count_predUI : forall a1 a2 s,
 count (predU a1 a2) s + count (predI a1 a2) s = count a1 s + count a2 s.
Proof.
move=> a1 a2.
(* The proof goes by induction on the list. In the inductive case, we *)
(*introduce the head, the tail, and the induction hypothesis. After
 simplification, the case case is trivial, and since simplification is
 also usefull in the inductive case, the //= swith both simplifies and
 closes the first goal.*)
elim=> [|x s IHs] //=.
(* Now a couple of arithmetic rewriting before using the inductive hypothesis*)
rewrite addnCA -addnA  addnA addnC IHs -!addnA.
(* The nat_congr tactic (and Ltac tactic defined in ssrnat) normalizes *)
(*both sides of a nat equality to be able to use some congruence, here *)
(*with count a1 s + _ *)
nat_congr.
(* We use it a second time to eliminate (count a2 s) *)
nat_congr.
(* Now it is only a matter of truth table *)
by case (a1 x); case (a2 x).
Qed.

(* After closing the section, tuto_count_filter has the type required *)
(* by the exercise *)
Lemma tuto_count_filter : forall s, count a s = size (filter a s).
Proof. by elim=> [|x s IHs] //=; rewrite IHs; case (a x). Qed.

End Exo_4_2_2.

(******************************************************************************)
(* Exercise 4.3.1                                                             *)
(******************************************************************************)

Section Exo_4_3_1.

(* We fix an arbitrary eqType T *)
Variable T : eqType.

(* We use implicit type annotations to avoid casting quantified *)
(*variables *)
Implicit Types x y : T.
Implicit Type b : bool.

Lemma tuto_eqxx : forall x, x == x.
Proof. by move=> x; apply/eqP. Qed.

(* First solution *)
Lemma tuto_predU1l : forall x y b, x = y -> (x == y) || b.
Proof. by move=> x y b exy; rewrite exy eqxx. Qed.

(* Second solution. The syntax move/eqP-> is equivalent to *)
(*move/eqP => ->, i.e. it applies the view to the top element of the *)
(*goal stack and rewrites the term obtains immediatly without *)
(*introducing it in the context. Similarily, move-> is equaivalent to *)
(*move=> -> and rewrite the top element of the goal (which should be *)
(*an equality) in the rest of the goal, without introducing it in the context *)

Lemma tuto_predU1l_alt_proof : forall x y b, x = y -> (x == y) || b.
Proof. by move=> x y b; move/eqP->. Qed.

(* The proof script is the same in both branches thanks to the *)
(* symmetry of the view mechanism. Remeber the 'by' tactical contains *)
(* the 'split' tactic and hence solves the goal after the last *)
(* assumption interpretation move/eqP. *)
Lemma tuto_predD1P : forall x y b, reflect (x <> y /\ b) ((x != y) && b).
Proof.
by move=> x y b; apply: (iffP andP) => [] []; move/eqP.
Qed.

(* Remember that _ != _ denotes the boolean disequality *)
(* Coq's unification is able to infer from the goal the arguments to *)
(* provide to the eqP lemma*)
Lemma tuto_eqVneq : forall x y, {x = y} + {x != y}.
Proof. by move=> x y; case: eqP; [left | right]. Qed.

End Exo_4_3_1.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) : natural :=
  plus (Succ lf2) lf1.


(* Two solutions are implemented, with n = nb of rectangles
   (i.e., input size):
   - [day03_1_simple.ml], naive O(grid_size * n)
   - [day03_1.ml], O(n log(n))
 *)

Set Warnings "-extraction-opaque-accessed".

From Coq Require Import
     List Arith NArith ZArith Ascii String
     OrderedTypeEx FSetAVL FMapAVL
     extraction.ExtrOcamlIntConv
     Lia.
Import ListNotations.

From SimpleIO Require SimpleIO.

From ExtLib Require Import
     Structures.Monads.
Import MonadNotation.
Local Open Scope monad.

From advent Require Import lib.

(* Sets indexed by natural numbers. *)
Module NatSet := FSetAVL.Make Nat_as_OT.

(* Maps indexed by (binary) natural numbers. *)
Module NMap := FMapAVL.Make N_as_OT.

(* A naive solution. *)

Variant rectangle : Type :=
| Rectangle (id : N) (left top width height : N)
.

Definition matrix := list (list nat).

Definition rectangle_matrix (r : rectangle) : matrix :=
  let '(Rectangle _ l t w h) := r in
  let row := N.iter l (cons 0) (N.iter w (cons 1) []) in
  N.iter t (cons []) (N.iter h (cons row) []).

Fixpoint union {A : Type}
         (merge : A -> A -> A) (xs ys : list A) : list A :=
  match xs, ys with
  | [], _ => ys
  | _, [] => xs
  | x :: xs, y :: ys => merge x y :: union merge xs ys
  end.

Definition union1 : list nat -> list nat -> list nat := union plus.
Definition union2 : matrix -> matrix -> matrix := union union1.

Definition union_rectangles (rs : list rectangle) : matrix :=
  fold_left (fun x r => union2 x (rectangle_matrix r)) rs [].

Definition count_overlaps (x : matrix) : N :=
  fold_left (fun p row =>
    fold_left (fun p c => if 2 <=? c then (1 + p)%N else p) row p)
    x 0%N.

(* Then [fun rs : rectangle => count_overlaps (union_rectangles rs)]
   computes the expected answer: the area of the plane covered by
   at least two rectangles in [rs]. *)

(* A less naive solution. *)

(* First, there's a neat scanning algorithm bounding the complexity
   by O(matrix_sz + n_rectangles) (with an extra log factor because
   we don't have O(1) random access), but we can also avoid a boring
   array iteration by only traversing rectangle corners.
   We get O(n log(n)) where n = n_rectangles.
 *)

(* The high-level idea is thus: put 1 and -1 on/near the corners of
   a rectangle (i,j)×(a,b) as follows (the top row and leftmost
   column are coordinate axes, every other entry in the matrix is 0):

       i       j  j+1

  a    1 0 ... 0  -1
       0           0
       .           .
       .           .
  b    0           0
  b+1 -1 0 ... 0   1

   then, 1. do a scan (cumulative sum) for each column,
         2. do a scan for each row of the matrix resulting from 1,
   that fills the rectangle with 1, and sets the rest of the
   matrix to 0.

       i       j  j+1
  a    1 1 ... 1   0
       .       .   .
       .       .   .
       .       .   .
  b    1 1 ... 1   0
  b+1  0   ... 0   0

   this formula is linear, so that if you add multiple rectangles
   in the same matrix, the scan will give you a matrix where each
   entry says how many rectangles contain it.
 *)

(* A sparse infinite matrix as a map [N -> N -> Z] ([N * N -> Z]),
   where all unbound keys are mapped to 0. *)
Definition smatrix := NMap.t (NMap.t Z).

(* Modify the entry at row [i], column [j]. *)
Definition set_point (f : Z -> Z) (i j : N) (x : smatrix) : smatrix :=
  let '(row, u') :=
      match NMap.find i x with
      | None => (NMap.empty _, f 0%Z)
      | Some row => (row, match NMap.find j row with
                          | None => f 0%Z
                          | Some u => f u
                          end)
      end in
  NMap.add i (NMap.add j u' row) x.

(* Print a rectangle into the matrix. *)
Definition add_rectangle (r : rectangle) (x : smatrix) : smatrix :=
  let '(Rectangle _ l t w h) := r in
  set_point Z.succ t l (
  set_point Z.pred t (l + w) (
  set_point Z.pred (t + h) l (
  set_point Z.succ (t + h) (l + w) x))).

Definition sunion_rectangles (rs : list rectangle) : smatrix :=
  fold_left (fun x r => add_rectangle r x) rs (NMap.empty _).

Definition Row : Type := list (N * Z).

Notation conspair' i z t :=
  (if (z =? 0)%Z then
     t
   else
     (i, z%Z) :: t).

Fixpoint add_rows (r1 r2 : list (N * Z)) : list (N * Z) :=
  match r1 with
  | [] => r2
  | (i1, z1) :: tl_r1 =>
    let fix add_row2 r2 :=
        match r2 with
        | [] => r1
        | (i2, z2) :: tl_r2 =>
          match N_as_OT.compare i1 i2 with
          | OrderedType.LT _ =>
            conspair' i1 z1 (add_rows tl_r1 r2)
          | OrderedType.EQ _ =>
            let z' := (z1 + z2)%Z in
            conspair' i1 z' (add_rows tl_r1 tl_r2)
          | OrderedType.GT _ =>
            conspair' i2 z2 (add_row2 tl_r2)
          end
        end in
    add_row2 r2
  end.

(* Scan a row, looking for areas covered by overlapping rectangles
   (z0 > 2). *)
Fixpoint scan_row_aux
         (n : N) (i0 : N) (z0 : Z) (r : list (N * Z)) : N :=
  match r with
  | [] => n
  | (i, z) :: r =>
    let n' := if (2 <=? z0)%Z then (n + i - i0)%N else n in
    scan_row_aux n' i (z0 + z)%Z r
  end.

Definition scan_row : list (N * Z) -> N := scan_row_aux 0 0 0.

(* 0         5         0
   0 0 2 0 0-1 0 0 0 0 1-2 (row)
   0 0 2 2 2 1 1 1 1 1 2 0 (scanned row) (four 2's)
 *)

Example scan_row_ex :
  scan_row [(2%N, 2%Z); (5%N, (-1)%Z); (10%N, 1%Z); (11%N, (-2)%Z)]
  = 4%N.
Proof. reflexivity. Qed.

Fixpoint scan_aux
         (n : N) (r0 : list (N * Z))
         (rs : list (N * list (N * Z))) : N :=
  match rs with
  | (i1, r1) :: ((i2, _) :: _) as rs =>
    let r1' := add_rows r0 r1 in
    scan_aux (n + (i2 - i1) * scan_row r1') r1' rs
  | [_] | [] => n (* The last row should be empty *)
  end.

Definition scan : list (N * list (N * Z)) -> N := scan_aux 0 [].

Definition count_overlaps2 (rs : list rectangle) : N :=
  scan (NMap.elements
          (NMap.map (@NMap.elements _)
                    (sunion_rectangles rs))).

(* For debugging. *)
Section debug.

Context {m : Type -> Type} `{Monad m} `{MonadFix m}
        `{MonadI rectangle m}
        `{MonadO (list ascii) m}.

Definition print_matrix (x : matrix) : m unit :=
  for' x (fun row =>
    print (map (fun n =>
      match n with
      | 0 => "0"
      | 1 => "1"
      | 2 => "2"
      | 3 => "3"
      | 4 => "4"
      | 5 => "5"
      | _ => "#"
      end%char) row)).

Definition show_matrix (w h : nat) : m unit :=
  rs <- read_all;;
  let x := fold_left
             (fun m r => union2 m (rectangle_matrix r)) rs [] in
  print_matrix (map (firstn w) (firstn h x)).

End debug.

Section main.

Context {m : Type -> Type} `{Monad m} `{MonadFix m}
        `{MonadI rectangle m}
        `{MonadO N m}.

Definition main1 : m unit :=
  rs <- read_all;;
  print (count_overlaps (union_rectangles rs)).

Definition main2 : m unit :=
  rs <- read_all;;
  print (count_overlaps2 rs).

End main.

Module io.

Import SimpleIO.
Import IO.Notations.

Parameter parse_rectangle : ocaml_string -> int * int * int * int * int.
Extract Constant parse_rectangle =>
  "fun s -> Scanf.sscanf s ""#%d @ %d,%d: %dx%d""
              (fun i l t w h -> (((i, l), t), w), h)".

Instance MonadI_rectangle_IO : MonadI rectangle IO := {
  read := catch_eof (
    s <- read_line';;
    let '(i, l, t, w, h) := parse_rectangle s in
    ret (Rectangle (n_of_int i) (n_of_int l) (n_of_int t) (n_of_int w) (n_of_int h)))
}.

End io.

Import SimpleIO.

(* DEBUG *)
(*
Definition show_matrix_exec : io_unit := unsafe_run (show_matrix 0 0).
Extraction "day03_1_show_matrix.ml" show_matrix_exec.
*)

Definition exec1 : io_unit := IO.unsafe_run main1.
Extraction "day03_1_basic.ml" exec1.

Definition exec2 : io_unit := IO.unsafe_run main2.
Extraction "day03_1.ml" exec2.

(* We first verify the naive solution. *)

(* Points are given by their coordinates; shapes are sets of points. *)
Definition point : Type := nat * nat.
Definition shape : Type := point -> Prop.
Definition eq_shape (s1 s2 : shape) : Prop :=
  forall p, s1 p <-> s2 p.

(* And of course, rectangles are shapes. *)
Definition rectangle_shape (r : rectangle) : shape :=
  let '(Rectangle _ l t w h) := r in
  fun p => N.to_nat l <= fst p < N.to_nat l + N.to_nat w /\
           N.to_nat t <= snd p < N.to_nat t + N.to_nat h.

Lemma sumbool_right_de_morgan P Q R :
  { P } + { ~ Q \/ ~ R } -> { P } + { ~ (Q /\ R) }.
Proof. firstorder. Qed.

Definition rectangle_shape_dec (r : rectangle) (p : point) :
  {rectangle_shape r p} + {~ rectangle_shape r p}.
Proof.
  destruct r; simpl.
  repeat (apply sumbool_right_de_morgan; apply Sumbool.sumbool_and);
    apply le_dec.
Qed.

Definition sum (xs : list nat) : nat :=
  fold_left plus xs 0.

(* This function counts the number of rectangles in a list [rs]
   covering a given point [p]. *)
Definition count_covering_rectangles
           (rs : list rectangle) (p : point) : nat :=
  sum (map (fun r => if rectangle_shape_dec r p then 1 else 0) rs).

Definition matrix_ix (x : matrix) (p : point) : nat :=
  nth (fst p) (nth (snd p) x []) 0.

(* Matrices produced by [rectangle_points] define shapes too. *)
Definition matrix_shape (x : matrix) : shape :=
  fun p => 0 < matrix_ix x p.

Ltac simpl_length :=
  repeat rewrite repeat_length in *.

Ltac split_nth :=
  match goal with
  | [ |- context [nth ?x (app ?t1 ?t2)] ] =>
    let Hx := fresh "Hx" in
    destruct (Nat.lt_ge_cases x (List.length t1)) as [Hx | Hx];
    [ rewrite app_nth1 with (n := x)
    | rewrite app_nth2 with (n := x)
    ]
  | [ |- context [ nth ?m (repeat ?a ?n) ?b ]] =>
    let Hl := fresh "Hl" in
    destruct (Nat.lt_ge_cases m n) as [Hl | Hl];
    [ rewrite (repeat_nth1 m n a b)
    | rewrite (repeat_nth2 m n a b)
    ]
  | [ |- context [ nth ?m [] ?b ]] =>
    rewrite nth_nil
  end; auto; simpl_length.

Lemma rectangle_shape_matrix1 (r : rectangle) (p : point) :
  rectangle_shape r p -> matrix_ix (rectangle_matrix r) p = 1.
Proof.
  destruct r, p as [i j].
  unfold matrix_ix; simpl.
  repeat rewrite N2Nat.inj_iter.
  repeat rewrite iter_cons.
  intros [[Hleft Hwidth] [Htop Hheight]].
  repeat
    ((rewrite repeat_nth1 + rewrite app_nth2 + rewrite app_nth1);
     simpl_length; [|lia]).
    lia.
Qed.

Lemma rectangle_shape_matrix2 (r : rectangle) (p : point) :
  ~rectangle_shape r p -> matrix_ix (rectangle_matrix r) p = 0.
Proof.
  destruct r, p as [i j].
  unfold matrix_ix; simpl.
  repeat rewrite N2Nat.inj_iter.
  repeat rewrite iter_cons.
  intros H.
  repeat split_nth.
  exfalso; apply H; lia.
Qed.

(* [matrix_ix] is a monoid homomorphism, between [union2] and [plus].
 *)

Lemma matrix_ix_hom x1 x2 p :
  matrix_ix (union2 x1 x2) p = matrix_ix x1 p + matrix_ix x2 p.
Proof.
  destruct p as [i j].
  revert x1; revert x2.
  revert i. unfold matrix_ix.
  simpl.
  induction j.
  - destruct x1 as [ | t1 x1 ], x2 as [ | t2 x2];
      repeat rewrite nth_nil; simpl; auto.
    destruct i; auto.
    clear. revert t2; revert t1.
    induction i.
    + destruct t1, t2; simpl; auto.
    + destruct t1, t2; simpl; auto.
  - destruct x1, x2; repeat rewrite nth_nil; simpl; auto.
    destruct i; auto.
Qed.

Theorem union_rectangles_count rs p :
  matrix_ix (union_rectangles rs) p = count_covering_rectangles rs p.
Proof.
  unfold union_rectangles.
  pose proof
       (fold_left_hom
          (fun x r => union2 x (rectangle_matrix r))
          (fun n r => n + if rectangle_shape_dec r p then 1 else 0)
          (fun x => matrix_ix x p)).
  simpl in H; rewrite H; clear H.
  { rewrite fold_left_map. unfold count_covering_rectangles.
    unfold matrix_ix; repeat rewrite nth_nil; auto.
  }
  { intros; rewrite matrix_ix_hom.
    destruct rectangle_shape_dec.
    - rewrite rectangle_shape_matrix1; auto.
    - rewrite rectangle_shape_matrix2; auto.
  }
Qed.


Require Import init.

Require Export nat_base.
Require Export nat_plus.
Require Export nat_order.

Require Import order_minmax.

Fixpoint nat_minus a b := match a, b with
    | a', nat_zero => opt_val a'
    | nat_zero, _ => opt_nil nat
    | nat_suc a', nat_suc b' => nat_minus a' b'
    end.

(** This is \bar *)
Infix "¯" := nat_minus (at level 50) : nat_scope.

Open Scope nat_scope.

Theorem nat_minus_eq : ∀ a, a ¯ a = opt_val 0.
Proof.
    intros a.
    nat_induction a.
    -   unfold zero; cbn.
        reflexivity.
    -   cbn.
        exact IHa.
Qed.

Theorem nat_minus_zero : ∀ a, a ¯ 0 = opt_val a.
Proof.
    intros a.
    nat_destruct a.
    -   apply nat_minus_eq.
    -   unfold zero; cbn.
        reflexivity.
Qed.

Theorem nat_minus_lt : ∀ a b, a < b → a ¯ b = opt_nil nat.
Proof.
    intros a b ltq.
    apply nat_lt_ex in ltq as [c eq].
    subst b.
    rewrite nat_plus_rsuc.
    nat_induction a.
    -   unfold zero at 1; cbn.
        reflexivity.
    -   cbn.
        rewrite nat_plus_lsuc.
        exact IHa.
Qed.

Theorem nat_minus_plus : ∀ a b, (a + b) ¯ a = opt_val b.
Proof.
    intros a b.
    nat_induction a.
    -   rewrite plus_lid.
        apply nat_minus_zero.
    -   rewrite nat_plus_lsuc.
        cbn.
        exact IHa.
Qed.

Fixpoint nat_abs_minus a b := match a, b with
    | a', nat_zero => a'
    | nat_zero, b' => b'
    | nat_suc a', nat_suc b' => nat_abs_minus a' b'
    end.

Infix "⊖" := (nat_abs_minus) (at level 50) : nat_scope.

Theorem nat_abs_minus_eq : ∀ a, a ⊖ a = 0.
Proof.
    intros a.
    nat_induction a.
    -   unfold zero; cbn.
        reflexivity.
    -   cbn.
        exact IHa.
Qed.

Theorem nat_abs_minus_lid : ∀ a, 0 ⊖ a = a.
Proof.
    intros a.
    destruct a; reflexivity.
Qed.

Theorem nat_abs_minus_rid : ∀ a, a ⊖ 0 = a.
Proof.
    intros a.
    destruct a; reflexivity.
Qed.

Theorem nat_abs_minus_comm : ∀ a b, a ⊖ b = b ⊖ a.
Proof.
    intros a.
    nat_induction a; intros b.
    -   rewrite nat_abs_minus_lid, nat_abs_minus_rid.
        reflexivity.
    -   destruct b.
        +   cbn.
            reflexivity.
        +   cbn.
            apply IHa.
Qed.

Theorem nat_abs_minus_plus : ∀ a b, (a + b) ⊖ a = b.
Proof.
    intros a b.
    nat_induction a.
    -   rewrite plus_lid.
        apply nat_abs_minus_rid.
    -   rewrite nat_plus_lsuc.
        cbn.
        exact IHa.
Qed.

Theorem nat_abs_minus_min : ∀ a b, a ⊖ b + min a b = max a b.
Proof.
    intros a b.
    unfold min, max; case_if [leq|leq].
    -   apply nat_le_ex in leq as [c eq]; subst.
        rewrite nat_abs_minus_comm.
        rewrite nat_abs_minus_plus.
        apply plus_comm.
    -   rewrite nle_lt in leq.
        apply nat_lt_ex in leq as [c eq]; subst.
        rewrite nat_abs_minus_plus.
        apply plus_comm.
Qed.

Theorem nat_abs_minus_eq_zero : ∀ a b, 0 = a ⊖ b → a = b.
Proof.
    nat_induction a; intros b eq.
    -   rewrite nat_abs_minus_lid in eq.
        exact eq.
    -   nat_destruct b.
        +   rewrite nat_abs_minus_rid in eq.
            symmetry; exact eq.
        +   cbn in eq.
            rewrite (IHa b eq).
            reflexivity.
Qed.

Close Scope nat_scope.


Require Import Program Arith String List.
Require Import Recdef.
Open Scope string_scope.
Open Scope list_scope.

Require Import PFDS.common.Util.
Require Import PFDS.common.DecidableOrder.
Require Import PFDS.common.Result.

Declare Module Seed : DecidableOrder.Seed.
Module Elem := DecidableOrder.Make(Seed).
Import Elem.Op.

(**
   ** 二項木(Binomial Tree)
 *)

(**
   二項木は以下のように帰納的に定義される (p.30)
   - ランク [0] の二項木は 単一ノード
   - ランク [r+1] の二項木 はランク [r]の２つの二項木を [link]して作られる、
   このとき片方の木をもう片方の木の最左の子としてつなげる。
 *)
Inductive tree : Set :=
| Node : nat -> Elem.T -> list tree -> tree.

Definition rank t :=
  match t with
  | Node r _ _ => r
  end.

(**
   *** 二項木の具体例
   二項木の具体例は以下の通り
   - ランク [0] : [Tree 0 x []]
   - ランク [1] : [Tree 1 y [(Tree 0 x [])]]
   - ランク [2] : [Tree 2 z [(Tree 1 y [(Tree 0 x [])]); (Tree 0 p [])]]
   (要素の数はランク[r]に従ってちょうど [2^r] 個となる)
 *)

(**
   *** [link] 関数の実装
   リンクするのはランクの等しい木だけ。
   引数の木は、上記の二項木の制約を満たすもののみを想定すれば良いっぽい。
   できる木は必ず子要素がランクの昇順に並んでいるはず
 *)
Definition link t1 t2 :=
  match (t1, t2) with
  | (Node r x1 c1, Node _ x2 c2) =>
    if Elem.leq_bool x1 x2 then
      Node (r+1) x1 (t2 :: c1)
    else
      Node (r+1) x2 (t1 :: c2)
  end.

Inductive BinomialTree : tree -> Prop :=
| BT_O: forall x, BinomialTree (Node 0 x [])
| BT_S: forall r t1 t2, BinomialTree t1 -> BinomialTree t2 -> rank t1 = r -> rank t2 = r -> BinomialTree (link t1 t2)
.

(**
   ** 二項ヒープ(Binomial Heap)
 *)

(**
   二項木をランクに関して昇順に並べたリストとして二項ヒープを定義。
   ランクが同じ二項木は存在しないものとする。
 *)
Definition heap := list tree.

(*TODOソート済みと重複無しも
Definition BinomialHeap ts : Prop := List.Forall BinomialTree ts.
*)

(**
   *** [insert] の実装
   ヒープに[Elem.T]型の要素を１つだけ追加する[insert]関数の定義。(p.31)
   [insert]は要素数1の二項木を追加するというアルゴリズムで実現する。
 *)
Fixpoint insTree t heap :=
  match heap with
  | [] => [t]
  | t' :: ts =>
    if (rank t <? rank t')%nat then
      t :: ts
    else
      insTree(link t t') ts
  end.

Definition insert x heap := insTree (Node 0 x []) heap.

(**
   *** [merge] の実装
 *)
Function merge ts1_ts2 {measure (pair_size (@List.length tree) (@List.length tree)) ts1_ts2} :=
  match (ts1_ts2) with
  | (ts1, []) => ts1
  | ([], ts2) => ts2
  | (t1 :: ts1' as ts1, t2 :: ts2' as ts2) =>
    if (rank t1 <? rank t2)%nat then
      t1 :: merge (ts1', ts2)
    else if (rank t2 <? rank t1)%nat then
      t2 :: merge (ts1, ts2')
    else
      insTree (link t1 t2) (merge (ts1', ts2'))
  end.
Proof.
  - simpl. now auto with arith.
  - simpl. now auto with arith.
  - simpl. now auto with arith.
Defined.

(**
   *** [findMin], [deleteMin]の定義
   *)

(**
   二項木から根っこの値をとる関数。この木の中に含まれる最小の値が取れるはず。
 *)
Definition root tree : Elem.T :=
  let '(Node _ x _) := tree in x.

(**
   ヒープから最小のroot値を持つ木を抜き出して、その木と残ったヒープを組みで返す。
   ヒープがからの場合を想定して[Result]型を返す
   [map]と[fold]でもかける気がするが教科書に合わせて再帰で書いた。
 *)
Fixpoint removeMinTree (h: heap) : Result (tree * heap) :=
  match h with
  | [] => Error "empty"
  | [t] => Ok (t, [])
  | t :: ts =>
    removeMinTree ts >>= fun t'_ts' =>
    let '(t', ts') := t'_ts' in
    if root t <=? root t' then
      ret(t, ts)
    else
      ret(t', t::ts')
  end.

(**
   ヒープに含まれる最小のElem.Tの値を返す
 *)
Definition findMin ts : Result(Elem.T) :=
  removeMinTree ts >>= fun '(t, _) =>
  Ok (root t).

(**
   二項木の子要素[ts1]は二項ヒープとなっているはずなので、mergeできる。
 *)
Definition deleteMin ts :=
  removeMinTree ts >>= fun '(Node _ x ts1, ts2) =>
  Ok (merge(List.rev ts1, ts2)).

(**
 ** 演習問題3.5
   [removeMinTree]の呼び出しを経由せず、findMinを直接的に定義してみよう
 *)
Definition findMin' ts :=
  ts
  |> map root
  |> reduce Elem.min
.

Lemma findMin'_correct_aux: forall t0 ts,
    Ok (fold_right Elem.min (root t0) (map root ts)) =
    (removeMinTree ((ts ++ [t0])%list) >>= fun '(tx, _) => Ok (root tx)).
Proof.
 induction ts.
 - now simpl.
 - simpl. revert IHts. case_eq (removeMinTree (ts ++ [t0])%list); [|discriminate].
   intros s_ss. destruct s_ss as [s ss]. simpl. intros eq IH. injection IH. intros IH'.
   destruct (Elem.leq_dec (root a) (root s)).
   + rewrite IH'. rewrite (Elem.min_l _ _ l). now destruct (ts ++ [t0])%list; simpl.
   + rewrite IH'. rewrite Elem.min_r; [| now apply Elem.Ord.lt_le_incl, Elem.Ord.not_le_lt].
     now destruct (ts ++ [t0])%list; simpl.
Qed.

Theorem findMin'_correct: forall ts,
  findMin' ts = findMin ts.
Proof.
 destruct ts.
 - now auto.
 - unfold findMin, findMin', pipeline, reduce, reduce_right.
   (* t::ts = us++[u] となるような us, uが存在する *)
   cut (exists u us, t :: ts = (us ++ [u])%list).
   + intros Exu. destruct Exu as [u Exus]. destruct Exus as [us eq]. rewrite eq at 2.
     simpl. rewrite <- findMin'_correct_aux.
     f_equal. apply Util.fold_right_cons_tail.
     * apply Elem.min_assoc.
     * apply Elem.min_comm.
     * rewrite <- map_cons. rewrite eq. now rewrite map_app.
   + destruct (@List.exists_last tree (t::ts)) as [us Exu]; [discriminate|].
     destruct Exu as [u  eq]. now exists u, us.
Qed.

(**
 ** 演習問題3.6

    treeの代わりにheapでrankを持ったらどうなるかっていうこと

    (treeのノードで持つ代わりに,heapの中で [(rank, tree)] のタプルリストみたいにして持つようにする。)
<<
    link: (rank * tree) -> (rank * tree) -> (rank * tree) のような型になる
    insTree: (rank * tree) -> heap -> heap
    merge : heap -> heap -> heap だから型は変わらない。
>>
    removeMinTree とか findMin とかはもうrank関係ないからこのままで。

    link, insTree, insert, mergeの実装を修正すればよさそう
 *)

(**
 ** 演習問題3.7

    例えばinsertはScalaで次のような感じかな:
<<
    def insert (x: Elem.T, h: Heap) = {
      h match {
        case E => NE(x, H.singleton(x))
        case NE(m, ih) =>
          NE(min(m, x), H.insert(x, ih))
      }
    }
>>
    mergeなども同様にできそう。

    `NE(x, ih)` で `ih`の中に `x` を含まない流派 (a.mutake派)と 含む派 (y.oshihiro503派) がある。(上記は含む派)
 *)

(**
 ** 3.2節まとめ

<<
insert : O(log n)
merge: O(log n)
findMin: O(log n)
deleteMin: O(log n)
>>

ただし、ちょっとした拡張でfindMinはO(1)にできる (ExplicitMinファンクタ)
 *)


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

Require Import List Arith Omega Wellfounded Extraction.

Set Implicit Arguments.

Section llist.

  (** An implementation of lazy lists as co-inductive lists/streams
      with a finiteness predicate in Prop

      Inspired by  G54DTP Dependently Typed Programming.
                   Introduction to coinductive types.
                   Venanzio Capretta, March 2011.
  *)

  Variable X : Type.

  CoInductive llist : Type :=
    | lnil: llist
    | lcons: X -> llist -> llist.

  Implicit Types (n: nat) (a: X) (ll: llist) (l: list X).

  (* We must define an explicit unfold operation. *)

  Definition lunfold ll : llist :=
    match ll with
      | lnil => lnil
      | lcons a ll' => lcons a ll'
    end.

  (* The next function unfolds a lazy list several times:
     the natural number n says how many.
  *)

  Fixpoint lunfold_many ll n : llist :=
    match n with
      | O    => ll
      | S n => match ll with
          | lnil      => lnil
          | lcons a ll => lcons a (lunfold_many ll n)
          end
    end.

  (* We can prove that the unfolding is equal to the original list. *)

  Lemma lunfold_many_eq: forall n ll, ll = lunfold_many ll n.
  Proof.
    induction n as [ | n IHn ].
    + reflexivity.
    + intros [ | x ll ].
      * reflexivity.
      * simpl; f_equal; auto.
  Qed.

  (* Every finite list can be transformed into a lazy list. *)

  Fixpoint list_llist l : llist :=
    match l with
      | nil  => lnil
      | a::l => lcons a (list_llist l)
    end.

  Fact list_llist_inj l1 l2 : list_llist l1 = list_llist l2 -> l1 = l2.
  Proof.
    revert l2; induction l1 as [ | x l IHl ]; intros [ | y m ]; auto; try discriminate.
    simpl; intros H; inversion H; f_equal; auto.
  Qed.

  Inductive lfin : llist -> Prop :=
    | lfin_lnil :  lfin lnil
    | lfin_lcons : forall a ll, lfin ll -> lfin (lcons a ll).

  Fact lfin_inv a ll : lfin (lcons a ll) -> lfin ll.
  Proof. inversion 1; assumption. Defined.

  Fact lfin_list_llist l : lfin (list_llist l).
  Proof. induction l; simpl; constructor; trivial. Qed.

  Section llist_list.

    Let llist_list_rec : forall ll, lfin ll -> { l | ll = list_llist l }.
    Proof.
      refine (fix loop ll Hll { struct Hll } :=
        match ll as ll' return lfin ll' -> { l | ll' = list_llist l } with
          | lnil      => fun H => exist _ nil _
          | lcons x ll => fun H => let (l',Hl') := loop ll _ in exist _ (x::l') _
        end Hll); subst; trivial.
      inversion H; trivial.
    Qed.

    Definition llist_list ll Hll: list X := proj1_sig (@llist_list_rec ll Hll).

    Fact llist_list_spec ll Hll : ll = list_llist (@llist_list ll Hll).
    Proof. apply (proj2_sig (@llist_list_rec ll Hll)). Qed.

  End llist_list.

  Arguments llist_list : clear implicits.

  Fact llist_list_eq ll (H1 H2: lfin ll) : @llist_list ll H1 = @llist_list ll H2.
  Proof.
    apply list_llist_inj; do 2 rewrite <- llist_list_spec; reflexivity.
  Qed.

  Fact llist_list_fix_0 H : llist_list lnil H = nil.
  Proof.
    generalize (llist_list_spec H); simpl.
    generalize (llist_list _ H).
    intros [|]; try discriminate; auto.
  Qed.

  Fact llist_list_fix_1 x ll (H: lfin (lcons x ll)):
    llist_list (lcons x ll) H = x::llist_list ll (lfin_inv H).
  Proof.
    generalize (llist_list_spec H); simpl.
    generalize (llist_list _ H).
    intros [|]; try discriminate.
    simpl.
    intros G; inversion G; f_equal; auto.
    apply list_llist_inj; rewrite <- H2.
    apply llist_list_spec.
  Qed.

  Definition lfin_length ll (Hll: lfin ll): nat := length (llist_list ll Hll).

  Arguments lfin_length : clear implicits.

  Fact lfin_length_eq ll (H1 H2: lfin ll) : lfin_length ll H1 = lfin_length ll H2.
  Proof. unfold lfin_length; f_equal; apply llist_list_eq. Qed.

  Fact lfin_length_fix_0 (H: lfin lnil): lfin_length lnil H = 0.
  Proof. unfold lfin_length; rewrite llist_list_fix_0; auto. Qed.

  Fact lfin_length_fix_1 x ll (H: lfin (lcons x ll)):
    lfin_length (lcons x ll) H = S (lfin_length ll (lfin_inv H)).
  Proof. unfold lfin_length; rewrite llist_list_fix_1; auto. Qed.

End llist.

Arguments lnil {X}.
Arguments llist_list {X}.
Arguments lfin_length {X}.

Section Append.

  Variable (X : Type).

  Implicit Type (l m k : llist X).

  Section def.

    Let llist_app_rec : forall l m (Hl : lfin l) (Hm : lfin m), { k | k = list_llist (llist_list _ Hl ++ llist_list _ Hm) }.
    Proof.
      refine (fix loop l m Hl Hm { struct Hl } := _).
      revert Hl; refine (match l with
        | lnil      => fun _  => exist _ m _
        | lcons x l => fun Hl => let (r,Hr) := loop l m (lfin_inv Hl) Hm in exist _ (lcons x r) _
      end).
      + rewrite llist_list_fix_0; simpl; apply llist_list_spec.
      + rewrite llist_list_fix_1; simpl; f_equal; assumption.
    Qed.

    Definition llist_app l m (Hl : lfin l) (Hm : lfin m): llist X := proj1_sig (@llist_app_rec l m Hl Hm).

    Fact llist_app_spec l m (Hl : lfin l) (Hm : lfin m) : @llist_app l m Hl Hm = list_llist (llist_list _ Hl ++ llist_list _ Hm).
    Proof. apply (proj2_sig (@llist_app_rec l m Hl Hm)). Qed.

  End def.

  Arguments llist_app : clear implicits.

End Append.

Section Rotate.

  (* Rotate with lazy lists (with a non-informative "finiteness" predicate
     It seems the algorithm manipulates f a as lazy lists and r as a list ... no sure
     or three lazy lists ? *)

  Variable (X : Type).

  Implicit Type (l r m a: llist X).

  Section def.

    Let prec l (Hl : lfin l) r (Hr : lfin r) : Prop :=
      lfin_length r Hr = 1 + lfin_length l Hl.
    Let rspec l (Hl : lfin l) r (Hr : lfin r) a (Ha : lfin a) m: Prop :=
      m = list_llist (llist_list l Hl ++ rev (llist_list r Hr) ++ llist_list a Ha).

    (** the following definition aims at having as extracted code the function rot on p.587 in Okasaki,
              Simple and efficient purely functional queues and deques, JFP 1995 *)

    Let llist_rotate_rec : forall l r a (Hl : lfin l) (Hr : lfin r) (Ha : lfin a),
        @prec l Hl r Hr -> sig (@rspec l Hl r Hr a Ha).
    Proof.
      refine (fix loop l r a Hl Hr Ha { struct Hl } := _).
      revert Hr.
      refine (match r as r' return forall (Hr : lfin r'), @prec l Hl _ Hr  -> sig (@rspec l Hl r' Hr a Ha) with
        | lnil       => _
        | lcons y r' => _
      end); intros Hr' H.
      { exfalso; red in H; rewrite lfin_length_fix_0 in H; discriminate. }
      revert Hl H.
      refine (match l as l' return forall (Hl' : lfin l'), @prec l' Hl' _ Hr' -> sig (rspec Hl' Hr' Ha) with
        | lnil       => _
        | lcons x l' => _
      end); intros Hl' H.
      + exists (lcons y a).
        red in H |- *; revert H.
        rewrite llist_list_fix_0, llist_list_fix_1, lfin_length_fix_0, lfin_length_fix_1.
        destruct r'.
        * rewrite llist_list_fix_0; simpl.
          rewrite <- llist_list_spec; reflexivity.
        * rewrite lfin_length_fix_1; discriminate.
      + refine (let (ro,Hro) := loop l' r' (lcons y a) (lfin_inv Hl') (lfin_inv Hr') (lfin_lcons _ Ha) _ in exist _ (lcons x ro) _).
        * red in H |- *; revert H.
          do 2 rewrite lfin_length_fix_1; intros; omega.
        * red in Hro |- *; revert Hro.
          do 3 rewrite llist_list_fix_1; intros; subst.
          simpl; rewrite app_ass; simpl; reflexivity.
    Qed.

    Definition llist_rotate l r a Hl Hr Ha (H: prec Hl Hr): llist X := proj1_sig (@llist_rotate_rec l r a Hl Hr Ha H).

    Fact llist_rotate_spec l r a Hl Hr Ha H : @rspec l Hl r Hr a Ha (@llist_rotate l r a Hl Hr Ha H).
    Proof. apply (proj2_sig (@llist_rotate_rec l r a Hl Hr Ha H)). Qed.

  End def.

  Arguments llist_rotate : clear implicits.

  Fact lfin_rotate l r a Hl Hr Ha H : lfin (llist_rotate l r a Hl Hr Ha H).
  Proof.
    generalize (llist_rotate_spec Ha H); intros E.
    rewrite E; apply lfin_list_llist.
  Qed.

  Fact llist_rotate_eq l r a Hl Hr Ha H : llist_list _ (@lfin_rotate l r a Hl Hr Ha H) = llist_list l Hl ++ rev (llist_list r Hr) ++ llist_list a Ha.
  Proof.
    apply list_llist_inj.
    rewrite <- (@llist_rotate_spec l r a Hl Hr Ha H).
    generalize (llist_rotate l r a Hl Hr Ha H) (lfin_rotate Hl Hr Ha H).
    symmetry; apply llist_list_spec.
  Qed.

  Fact llist_rotate_length l r a Hl Hr Ha H : lfin_length _ (@lfin_rotate l r a Hl Hr Ha H) = lfin_length _ Hl + lfin_length _ Hr + lfin_length _ Ha.
  Proof.
    unfold lfin_length.
    rewrite llist_rotate_eq.
    do 2 rewrite app_length.
    rewrite rev_length; omega.
  Qed.

End Rotate.

(* Recursive Extraction llist_list list_llist llist_app llist_rotate.

Check llist_rotate.
Check llist_rotate_spec.

*)


Require Import Coq.Arith.Arith.

Definition Z := nat.

Definition Even (x : Z) := { y : Z & y + y = x }.
Definition Odd (x : Z) := { y : Z & S (y + y) = x }.

Definition Even_or_Odd : forall x, Even x + Odd x.
Proof.
  induction x.
  left.
  exists 0.
  reflexivity.
  induction IHx.
  right.
  exists (projT1 a).
  apply f_equal.
  apply (projT2 a).
  left.
  exists (S (projT1 b)).
  simpl.
  apply f_equal.
  induction (plus_n_Sm (projT1 b) (projT1 b)).
  apply (projT2 b).
Defined.

Definition even (n : nat) : Z := n + n.
Definition odd (n : nat) : Z := S (n + n).

Definition Zsplit' (P : Z -> Type)
 (e : forall n, P (even n)) (o : forall n, P (odd n)) (x : Z) : P x.
Proof.
  destruct (Even_or_Odd x).
  rewrite <- (projT2 e0).
  apply (e (projT1 e0)).
  rewrite <- (projT2 o0).
  apply (o (projT1 o0)).
Defined.

Definition zero := 0.
Definition pos (n : nat) : Z := S (S (n + n)).
Definition neg (n : nat) : Z := S (n + n).

Definition Zsplit (P : Z -> Type) (z : P 0)
 (p : forall n, P (pos n)) (n : forall n, P (neg n)) (x : Z) : P x.
Proof.
  destruct x.
  apply z.
  apply (Zsplit' (fun x => P (S x))).
  apply n.
  apply p.
Defined.

Definition Zsucc : Z -> Z :=
  Zsplit (fun _ => Z) (pos 0) (fun x => pos (S x)) (fun y =>
    match y with O => zero | S y => neg y end).

Definition Zpred : Z -> Z :=
  Zsplit (fun _ => Z) (neg 0) (fun x =>
    match x with O => zero | S x => pos x end) (fun y => neg (S y)).

Lemma pos_S n : pos (S n) = S (S (pos n)).
Proof.
  unfold pos.
  simpl.
  apply f_equal.
  apply f_equal.
  apply f_equal.
  symmetry.
  apply plus_n_Sm.
Qed.

Definition lem : forall x y, x + x = y + y -> x = y.
Proof.
  induction x.
  simpl.
  induction y.
  reflexivity.
  discriminate.
  induction y.
  discriminate.
  simpl.
  intros.
  apply f_equal.
  rewrite <- plus_n_Sm in H.
  rewrite <- plus_n_Sm in H.
  apply (f_equal pred) in H.
  apply (f_equal pred) in H.
  simpl in H.
  apply IHx.
  apply H.
Defined.

Require Import Coq.Arith.Peano_dec.

Lemma lem2 : forall a b, S a = b + b -> b <> 0.
Proof.
  intros.
  intro.
  rewrite H0 in H.
  discriminate.
Qed.

Lemma neq_0_r : forall n : nat, n <> 0 -> { m : nat & n = S m }.
Proof.
  intros.
  induction n.
  exfalso.
  apply H.
  reflexivity.
  exists n.
  reflexivity.
Qed.

Lemma even_is_not_odd x : Odd (even x) -> False.
Proof.
  induction x.
  intro.
  destruct H.
  discriminate.
  intro.
  destruct H.
  apply (f_equal pred) in e.
  simpl in e.
  rewrite <- plus_n_Sm in e.
  specialize (lem2 _ _ (eq_sym e)).
  intro.
  specialize (neq_0_r x0).
  intro.
  specialize (H0 H).
  destruct H0.
  rewrite e0 in e.
  rewrite <- plus_n_Sm in e.
  apply (f_equal pred) in e.
  simpl in e.
  apply IHx.
  exists x1.
  apply e.
Qed.

Lemma odd_is_not_even x : Even (odd x) -> False.
Proof.
  intro.
  induction x.
  induction H.
  unfold odd in p.
  induction x.
  discriminate.
  rewrite <- plus_n_Sm in p.
  discriminate.
  unfold Even, odd in *.
  induction H.
  rewrite <- plus_n_Sm in p.
  simpl in p.
  specialize (lem2 _ _ (eq_sym p)).
  specialize (neq_0_r x0).
  intros.
  specialize (H H0).
  destruct H.
  rewrite e in p.
  simpl in p.
  rewrite <- plus_n_Sm in p.
  do 2 apply (f_equal pred) in p.
  simpl in p.
  apply IHx.
  exists x1.
  apply p.
Qed.

Lemma Zsplit'_beta_even : forall P e o x, Zsplit' P e o (even x) = e x.
Proof.
  intros.
  unfold Zsplit'.
  destruct (Even_or_Odd (even x)).
  destruct e0.
  simpl.
  specialize (lem _ _ e0).
  intro.
  induction H.
  induction (UIP_nat _ _ eq_refl e0).
  reflexivity.
  exfalso.
  apply (even_is_not_odd x).
  apply o0.
Qed.

Lemma Zsplit'_beta_odd : forall P e o x, Zsplit' P e o (odd x) = o x.
Proof.
  intros.
  unfold Zsplit'.
  destruct (Even_or_Odd (odd x)).
  exfalso.
  apply (odd_is_not_even x).
  apply e0.
  destruct o0.
  simpl.
  unfold odd in e0.
  generalize e0.
  apply (f_equal pred) in e0.
  simpl in e0.
  apply lem in e0.
  destruct e0.
  intro.
  induction (UIP_nat _ _ eq_refl e0).
  reflexivity.
Qed.

Lemma Zsplit_beta_pos : forall P z p n x, Zsplit P z p n (pos x) = p x.
Proof.
  intros.
  simpl.
  apply (Zsplit'_beta_odd (fun x0 : Z => P (S x0)) n p x).
Qed.

Lemma Zsplit_beta_neg : forall P z p n x, Zsplit P z p n (neg x) = n x.
Proof.
  intros.
  simpl.
  apply (Zsplit'_beta_even (fun x0 : Z => P (S x0)) n p x).
Qed.

Lemma Zsucc_pos_S n : Zsucc (pos n) = pos (S n).
Proof.
  apply (Zsplit_beta_pos (fun _ : Z => Z) _ (fun x : nat => pos (S x)) _).
Qed.

Lemma Zpred_neg_S n : Zpred (neg n) = neg (S n).
Proof.
  apply (Zsplit_beta_neg (fun _ : Z => Z) _ _ (fun y : nat => neg (S y))).
Qed.

Definition Zind (P : Z -> Type) (z : P 0) (s : forall n, P n -> P (Zsucc n))
(p : forall n, P n -> P (Zpred n)) (n : Z) : P n.
Proof.
  apply Zsplit.
  apply z.
  induction n0.
  apply (s 0 z).
  rewrite <- Zsucc_pos_S.
  apply (s _ IHn0).
  induction n0.
  apply (p 0 z).
  rewrite <- Zpred_neg_S.
  apply (p _ IHn0).
Defined.

Definition Zrec (P : Type) (z : P) (s : P -> P) (p : P -> P) : Z -> P :=
  Zind (fun _ => P) z (fun _ => s) (fun _ => p).

Lemma Zrec_beta_succ (P : Type) (z : P) (s : P -> P) (p : P -> P)
              (i2 : forall (m : P), m = s (p m)) (n : Z)
: Zrec P z s p (Zsucc n) = s (Zrec P z s p n).
Proof.
  apply (Zsplit (fun n => Zrec P z s p (Zsucc n) = s (Zrec P z s p n))).
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ 0).
  reflexivity.
  intro.
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ n0).
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ n0).
  rewrite (Zsplit'_beta_odd _ _ _ (S n0)).
  simpl.
  destruct (Zsucc_pos_S n0).
  simpl.
  reflexivity.
  intro.
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ n0).
  rewrite (Zsplit'_beta_even _ _ _ n0).
  simpl.
  destruct n0.
  simpl.
  apply i2.
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ n0).
  destruct (Zpred_neg_S n0).
  simpl.
  apply i2.
Qed.

Lemma Zrec_beta_pred (P : Type) (z : P) (s : P -> P) (p : P -> P)
              (i1 : forall (m : P), m = p (s m)) (n : Z)
: Zrec P z s p (Zpred n) = p (Zrec P z s p n).
Proof.
  apply (Zsplit (fun n => Zrec P z s p (Zpred n) = p (Zrec P z s p n))).
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ 0).
  reflexivity.
  intro.
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ n0).
  rewrite (Zsplit'_beta_odd _ _ _ n0).
  destruct n0.
  simpl.
  apply i1.
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ n0).
  destruct (Zsucc_pos_S n0).
  simpl.
  apply i1.
  intro.
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ n0).
  rewrite (Zsplit'_beta_even _ _ _ n0).
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ (S n0)).
  simpl.
  destruct (Zpred_neg_S n0).
  reflexivity.
Qed.

Definition Zplus x : Z -> Z :=
  Zrec Z x Zsucc Zpred.

Lemma Zsucc_Zpred x : x = Zsucc (Zpred x).
Proof.
  apply (Zsplit (fun x => x = Zsucc (Zpred x))).
  reflexivity.
  intros.
  symmetry.
  unfold Zpred.
  rewrite Zsplit_beta_pos.
  destruct n.
  reflexivity.
  apply Zsucc_pos_S.
  unfold Zsucc.
  intros.
  symmetry.
  unfold Zpred.
  rewrite Zsplit_beta_neg.
  apply (Zsplit_beta_neg (fun _ : Z => Z) _ _
  (fun y : nat => match y with
                  | 0 => zero
                  | S y0 => neg y0
                  end)).
Qed.

Lemma Zpred_Zsucc x : x = Zpred (Zsucc x).
Proof.
  apply (Zsplit (fun x => x = Zpred (Zsucc x))).
  reflexivity.
  unfold Zsucc.
  symmetry.
  rewrite Zsplit_beta_pos.
  unfold Zpred.
  apply (Zsplit_beta_pos (fun _ : Z => Z) _
  (fun x0 : nat => match x0 with
                   | 0 => zero
                   | S x1 => pos x1
                   end) _).
  symmetry.
  unfold Zsucc.
  rewrite Zsplit_beta_neg.
  destruct n.
  reflexivity.
  apply Zpred_neg_S.
Qed.

Lemma Zplus_x_Sy (x y : Z) : Zplus x (Zsucc y) = Zsucc (Zplus x y).
Proof.
  unfold Zplus.
  apply Zrec_beta_succ.
  apply Zsucc_Zpred.
Qed.

Lemma Zplus_x_Py (x y : Z) : Zplus x (Zpred y) = Zpred (Zplus x y).
Proof.
  unfold Zplus.
  apply Zrec_beta_pred.
  apply Zpred_Zsucc.
Qed.

Lemma Zplus_0n : forall n, Zplus zero n = n.
Proof.
  apply Zind.
  reflexivity.
  simpl.
  intros.
  rewrite Zplus_x_Sy.
  apply f_equal.
  apply H.
  intros.
  rewrite Zplus_x_Py.
  apply f_equal.
  apply H.
Qed.

Lemma Zplus_Sx_y (x y : Z) : Zplus (Zsucc x) y = Zsucc (Zplus x y).
Proof.
  apply (Zind (fun y => Zplus (Zsucc x) y = Zsucc (Zplus x y))).
  reflexivity.
  intros.
  rewrite Zplus_x_Sy.
  rewrite Zplus_x_Sy.
  apply f_equal.
  apply H.
  intros.
  rewrite Zplus_x_Py.
  rewrite Zplus_x_Py.
  rewrite H.
  rewrite <- Zpred_Zsucc.
  apply Zsucc_Zpred.
Qed.

Lemma Zplus_Px_y (x y : Z) : Zplus (Zpred x) y = Zpred (Zplus x y).
Proof.
  apply (Zind (fun y => Zplus (Zpred x) y = Zpred (Zplus x y))).
  reflexivity.
  intros.
  rewrite Zplus_x_Sy.
  rewrite Zplus_x_Sy.
  rewrite H.
  rewrite <- Zsucc_Zpred.
  apply Zpred_Zsucc.
  intros.
  rewrite Zplus_x_Py.
  rewrite Zplus_x_Py.
  apply f_equal.
  apply H.
Qed.

Lemma Zplus_comm : forall x y, Zplus x y = Zplus y x.
Proof.
  intros.
  apply (Zind (fun x => Zplus x y = Zplus y x)).
  simpl.
  apply Zplus_0n.
  intros.
  rewrite Zplus_x_Sy.
  rewrite Zplus_Sx_y.
  apply f_equal.
  apply H.
  intros.
  rewrite Zplus_x_Py.
  rewrite Zplus_Px_y.
  apply f_equal.
  apply H.
Qed.

Lemma Zplus_assoc : forall x y z, Zplus (Zplus x y) z = Zplus x (Zplus y z).
Proof.
  intros.
  apply (Zind (fun z => Zplus (Zplus x y) z = Zplus x (Zplus y z))).
  reflexivity.
  intros.
  do 3 rewrite Zplus_x_Sy.
  apply f_equal.
  apply H.
  intros.
  do 3 rewrite Zplus_x_Py.
  apply f_equal.
  apply H.
Qed.

Definition Zneg : Z -> Z := Zsplit (fun _ => Z) zero neg pos.

Lemma Zneg_S n : Zneg (Zsucc n) = Zpred (Zneg n).
Proof.
  apply (Zsplit (fun n => Zneg (Zsucc n) = Zpred (Zneg n))).
  simpl.
  apply (Zsplit'_beta_odd (fun _ : Z => Z) _ _ 0).
  simpl.
  intros.
  rewrite (Zsplit'_beta_odd _ _ _ n0).
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ (S n0)).
  rewrite (Zsplit'_beta_odd _ _ _ n0).
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ n0).
  reflexivity.
  simpl.
  intros.
  rewrite (Zsplit'_beta_even _ _ _ n0).
  destruct n0.
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ 0).
  reflexivity.
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ n0).
  rewrite (Zsplit'_beta_even _ _ _ (S n0)).
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ (S n0)).
  reflexivity.
Qed.

Lemma Zneg_P n : Zneg (Zpred n) = Zsucc (Zneg n).
Proof.
  apply (Zsplit (fun n => Zneg (Zpred n) = Zsucc (Zneg n))).
  reflexivity.
  simpl.
  intros.
  do 2 rewrite (Zsplit'_beta_odd _ _ _ n0).
  destruct n0.
  reflexivity.
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ n0).
  rewrite (Zsplit'_beta_even _ _ _ (S n0)).
  reflexivity.
  simpl.
  intro.
  do 2 rewrite (Zsplit'_beta_even _ _ _ n0).
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ (S n0)).
  rewrite (Zsplit'_beta_odd _ _ _ n0).
  reflexivity.
Qed.

Lemma Zplus_neg_x : forall x, Zplus (Zneg x) x = zero.
Proof.
  intro.
  apply (Zind (fun x => Zplus (Zneg x) x = zero)).
  simpl.
  reflexivity.
  simpl.
  intros.
  rewrite Zplus_x_Sy.
  rewrite Zneg_S.
  rewrite Zplus_Px_y.
  rewrite <- Zsucc_Zpred.
  apply H.
  intros.
  rewrite Zplus_x_Py.
  rewrite Zneg_P.
  rewrite Zplus_Sx_y.
  rewrite <- Zpred_Zsucc.
  apply H.
Qed.

Lemma Zplus_x_neg : forall x, Zplus x (Zneg x) = zero.
Proof.
  intro.
  rewrite Zplus_comm.
  apply Zplus_neg_x.
Qed.

Lemma Zneg_neg x : Zneg (Zneg x) = x.
Proof.
  apply (Zsplit (fun x => Zneg (Zneg x) = x)).
  reflexivity.
  intro.
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ n).
  simpl.
  apply (Zsplit'_beta_even (fun _ => Z)).
  intro.
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ n).
  simpl.
  apply (Zsplit'_beta_odd (fun _ => Z)).
Qed.

Definition Zmult (x : Z) : Z -> Z := Zrec Z zero (Zplus x) (Zplus (Zneg x)).

Infix "+" := Zplus.
Infix "*" := Zmult.
Notation "- x" := (Zneg x).

Lemma Zmult_x_Sy x y : Zmult x (Zsucc y) = Zplus x (Zmult x y).
Proof.
  unfold Zmult.
  apply Zrec_beta_succ.
  intro.
  apply (Zind (fun x => m = Zplus x (Zplus (Zneg x) m))).
  simpl.
  symmetry.
  rewrite Zplus_0n.
  apply Zplus_0n.
  intros.
  rewrite Zplus_Sx_y.
  rewrite Zneg_S.
  rewrite Zplus_Px_y.
  rewrite Zplus_x_Py.
  rewrite <- Zsucc_Zpred.
  apply H.
  intros.
  rewrite Zplus_Px_y.
  rewrite Zneg_P.
  rewrite Zplus_Sx_y.
  rewrite Zplus_x_Sy.
  rewrite <- Zpred_Zsucc.
  apply H.
Qed.

Definition Zmult_x_Py x y : Zmult x (Zpred y) = Zplus (Zneg x) (Zmult x y).
Proof.
  unfold Zmult.
  apply Zrec_beta_pred.
  intro.
  apply (Zind (fun x => m = Zplus (Zneg x) (Zplus x m))).
  simpl.
  symmetry.
  rewrite Zplus_0n.
  apply Zplus_0n.
  intros.
  rewrite Zneg_S.
  rewrite Zplus_Px_y.
  rewrite Zplus_Sx_y.
  rewrite Zplus_x_Sy.
  rewrite <- Zpred_Zsucc.
  apply H.
  intros.
  rewrite Zneg_P.
  rewrite Zplus_Sx_y.
  rewrite Zplus_Px_y.
  rewrite Zplus_x_Py.
  rewrite <- Zsucc_Zpred.
  apply H.
Qed.

Lemma Zmult_0n n : Zmult 0 n = 0.
Proof.
  apply (Zind (fun n => Zmult 0 n = 0)).
  reflexivity.
  intros.
  rewrite Zmult_x_Sy.
  rewrite Zplus_0n.
  apply H.
  intros.
  rewrite Zmult_x_Py.
  simpl.
  rewrite Zplus_0n.
  apply H.
Qed.

Lemma Zmult_1n n : Zmult (pos 0) n = n.
Proof.
  apply (Zind (fun n => Zmult (pos 0) n = n)).
  simpl.
  reflexivity.
  intros.
  rewrite Zmult_x_Sy.
  rewrite H.
  rewrite Zplus_comm.
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ 0).
  reflexivity.
  intros.
  rewrite Zmult_x_Py.
  simpl.
  rewrite (Zsplit'_beta_odd _ _ _ 0).
  rewrite Zplus_comm.
  simpl.
  rewrite (Zsplit'_beta_even _ _ _ 0).
  simpl.
  apply f_equal.
  apply H.
Qed.

Lemma Zmult_Sx_y x y : Zmult (Zsucc x) y = Zplus y (Zmult x y).
Proof.
  intros.
  apply (Zind (fun y => Zmult (Zsucc x) y = Zplus y (Zmult x y))).
  reflexivity.
  intros.
  repeat rewrite Zmult_x_Sy.
  repeat rewrite Zplus_Sx_y.
  apply f_equal.
  rewrite H.
  rewrite <- Zplus_assoc.
  replace (Zplus x n) with (Zplus n x).
  apply Zplus_assoc.
  apply Zplus_comm.
  intros.
  repeat rewrite Zmult_x_Py.
  rewrite Zneg_S.
  repeat rewrite Zplus_Px_y.
  apply f_equal.
  rewrite H.
  rewrite <- Zplus_assoc.
  replace (Zplus (- x) n) with (Zplus n (- x)).
  apply Zplus_assoc.
  apply Zplus_comm.
Qed.

Lemma Zmult_Px_y x y : Zmult (Zpred x) y = Zplus (Zneg y) (Zmult x y).
Proof.
  apply (Zind (fun y => Zmult (Zpred x) y = Zplus (Zneg y) (Zmult x y))).
  reflexivity.
  intros.
  repeat rewrite Zmult_x_Sy.
  rewrite Zneg_S.
  repeat rewrite Zplus_Px_y.
  apply f_equal.
  rewrite H.
  rewrite <- Zplus_assoc.
  replace (Zplus x (- n)) with (Zplus (- n) x).
  apply Zplus_assoc.
  apply Zplus_comm.
  intros.
  repeat rewrite Zmult_x_Py.
  repeat rewrite Zneg_P.
  repeat rewrite Zplus_Sx_y.
  apply f_equal.
  rewrite H.
  rewrite <- Zplus_assoc.
  replace (Zplus (- x) (- n)) with (Zplus (- n) (- x)).
  apply Zplus_assoc.
  apply Zplus_comm.
Qed.

Lemma Zmult_comm x y : Zmult x y = Zmult y x.
Proof.
  apply (Zind (fun x => Zmult x y = Zmult y x)).
  simpl.
  apply Zmult_0n.
  intros.
  rewrite Zmult_Sx_y.
  rewrite Zmult_x_Sy.
  apply f_equal.
  apply H.
  intros.
  rewrite Zmult_Px_y.
  rewrite Zmult_x_Py.
  apply f_equal.
  apply H.
Qed.

Lemma Zmult_plus_distr_r x y z :
 Zmult (Zplus x y) z = Zplus (Zmult x z) (Zmult y z).
Proof.
  apply (Zind (fun x => Zmult (Zplus x y) z = Zplus (Zmult x z) (Zmult y z))).
  rewrite Zmult_0n.
  rewrite Zplus_0n.
  symmetry.
  apply Zplus_0n.
  intros.
  rewrite Zplus_Sx_y.
  repeat rewrite Zmult_Sx_y.
  rewrite H.
  symmetry.
  apply Zplus_assoc.
  intros.
  rewrite Zplus_Px_y.
  repeat rewrite Zmult_Px_y.
  rewrite H.
  symmetry.
  apply Zplus_assoc.
Qed.

Lemma Zmult_plus_distr_l x y z :
Zmult x (Zplus y z) = Zplus (Zmult x y) (Zmult x z).
Proof.
  rewrite Zmult_comm.
  replace (Zmult x y) with (Zmult y x).
  replace (Zmult x z) with (Zmult z x).
  apply Zmult_plus_distr_r.
  apply Zmult_comm.
  apply Zmult_comm.
Qed.

Lemma Zplus_neg x y : Zplus (Zneg x) (Zneg y) = Zneg (Zplus x y).
Proof.
  apply (Zind (fun y => Zplus (- x) (- y) = - Zplus x y)).
  reflexivity.
  intros.
  rewrite Zneg_S.
  rewrite Zplus_x_Py.
  rewrite Zplus_x_Sy.
  rewrite Zneg_S.
  apply f_equal.
  apply H.
  intros.
  rewrite Zneg_P.
  rewrite Zplus_x_Sy.
  rewrite Zplus_x_Py.
  rewrite Zneg_P.
  apply f_equal.
  apply H.
Qed.

Lemma Zmult_neg_l x y : Zmult (Zneg x) y = Zneg (Zmult x y).
Proof.
  apply (Zind (fun y => Zmult (- x) y = - Zmult x y)).
  reflexivity.
  intros.
  rewrite Zmult_x_Sy.
  rewrite Zmult_x_Sy.
  rewrite H.
  apply Zplus_neg.
  intros.
  repeat rewrite Zmult_x_Py.
  rewrite H.
  apply Zplus_neg.
Qed.

Lemma Zmult_neg_r x y : Zmult x (Zneg y) = Zneg (Zmult x y).
Proof.
  rewrite Zmult_comm.
  rewrite Zmult_neg_l.
  apply f_equal.
  apply Zmult_comm.
Qed.

Lemma Zmult_assoc x y z : Zmult (Zmult x y) z = Zmult x (Zmult y z).
Proof.
  apply (Zind (fun z => Zmult (Zmult x y) z = Zmult x (Zmult y z))).
  reflexivity.
  intros.
  repeat rewrite Zmult_x_Sy.
  rewrite H.
  symmetry.
  apply Zmult_plus_distr_l.
  intros.
  repeat rewrite Zmult_x_Py.
  rewrite H.
  rewrite Zmult_plus_distr_l.
  rewrite Zmult_neg_r.
  reflexivity.
Qed.


(* énoncé identique à TD03_nat_Exp.v, avec
  - suppression des entraînements sur les listes et sur nat
  - une correction de get
  - des tests devant fonctionner sur eval
  - renomme, decale, bexp à faire
  *)

(**
Deux objectifs dans ce TD :
- deux structures linéaires qui serviront constamment,
  les listes et les entiers naturels,
  et les pricipes de récurrence associés
- extensions des expressions arithmétiques
*)

(** * Entiers naturels *)

(** En mathématiques, les entiers ne sont plus une notion primitive depuis
    les travaux de Dedekind et Peano au 19e siècle : ils sont obtenus
    à partir de deux constructions élémentaires :
    - l'entier nul, que l'on notera O ;
    - le successeur d'un entier [n] déjà construit, que l'on notera [S n].
    C'est exactement ce que l'on obtient avec le type inductif suivant.
*)

Print nat.

Fact deux : 2 = S (S O).
Proof. (** regarder le but écrit par Coq *) reflexivity. Qed.

(** * Quelques commandes de recherche d'information *)

(** Quelle est la fonction qui est derrière le symbole "+" ? *)
Locate "+".
(**  Print est connu *)
Print Nat.add.
(** Intégration de l'espace de nommage Nat *)
Import Nat.
Locate "+".
(* Quelles fonctions de type [nat -> nat -> nat] sot disponibles ? *)
Search (nat -> nat -> nat).

(** * AST d'expressions arithmétiques, le retour *)

(** On considère des expressions arithmétiques comprenant
    non seulement des opération et des constantes, mais aussi des noms
    de variables.
    Pour simplifier on considère que ces variables s'écriraient "x0", "x1",
    "x2", etc., ce qui permet de les représenter par un simple entier naturel.
    Noter que les constructeurs [Ana] et [Ava] permettent de distinguer
    la constante 2 de la variable x2.
*)

Inductive aexp :=
| Aco : nat -> aexp (* constantes *)
| Ava : nat -> aexp (* variables *)
| Apl : aexp -> aexp -> aexp
| Amu : aexp -> aexp -> aexp
| Amo : aexp -> aexp -> aexp
.

(* Définir les expressions aexp correspondant à
  (1 + x2) * 3 et  (x0 * 2) + x3
 *)

Definition exp_1 := Amu (Apl (Aco 1) (Ava 2)) (Aco 3).
Definition exp_2 := Apl (Amu (Ava 0) (Aco 2)) (Ava 3).

(** Pour évaluer une expression représentée par un tel AST,
    on considère un *état*, c'est à dire une association entre
    chaque nom de variable et un valeur dans [nat].
    On choisit de représenter un tel état par une liste d'entiers,
    avec comme convention :
    - le premier élément de cette liste est la valeur associée à x0
    - le second élément de cette liste est la valeur associée à x1
    - et ainsi de suite ;
    - pour les noms restants, la valeur associée est 0.
    Par exemple, dans l'état Cons 3 (Cons 0 (Cons 8 Nil)),
    la valeur associée à x0 est 3, la valeur associée à x1 est 0,
    la valeur associée à x2 est 8, et la valeur associée à x3, x4, etc.
    est 0.
 *)

Inductive state :=
  | Nil : state
  | Cons : nat -> state -> state
.

Definition s_ex1 : state := Cons 3 (Cons 0 (Cons 8 Nil)).

(* ----------------------------------------------------------------------- *)
(** Définition d'une fonction [get] qui rend la valeur associée à xi dans l'état s *)

Fixpoint get (i: nat) (s: state) : nat :=
  match s with
  | Nil => 0
  | Cons v s' =>
    match i with
    | O => v
    | S i' => get i' s'
    end
  end.

Example get_ex1 : get 2 s_ex1 = 8.
Proof. reflexivity. Qed.

(* ----------------------------------------------------------------------- *)

(** Définir une fonction [eval] qui rend la valeur d'une aexp dans l'état s *)

(** Même si la fonction get ci-dessus a été laissée 'Admitted", elle est
    utilisable dans les questions suivantes.  *)

Fixpoint eval (a: aexp) (s: state) : nat :=
  match a with
  | Ava n => get n s
  | Aco n => n
  | Apl n x => (eval n s) + (eval x s)
  | Amu n x => (eval n s) * (eval x s)
  | Amo n x => (eval n s) - (eval x s)
  end.

Definition aexp_ex1 := Amu (Apl (Aco 1) (Ava 2)) (Aco 3).
Definition aexp_ex2 := Apl (Amu (Ava 0) (Aco 2)) (Ava 3).

Example eval_ex1_ex1 : eval aexp_ex1 s_ex1 = 27.
Proof. reflexivity. Qed.
Example eval_ex2_ex1 : eval aexp_ex2 s_ex1 = 6.
Proof. reflexivity. Qed.

(* ----------------------------------------------------------------------- *)

(** Définir une fonction [renomme] qui prend une aexp [a] et rend [a] où
    les variables correspondant à x0, x1, x2... ont été respectivement
    renommées en x1, x2, x3...  *)

Fixpoint renomme (a: aexp) : aexp :=
  match a with
  | Ava n => Ava (S n)
  | Aco n => Aco n
  | Apl n x => Apl (renomme n) (renomme x)
  | Amu n x => Amu (renomme n) (renomme x)
  | Amo n x => Amo (renomme n) (renomme x)
  end.

(** Définir une fonction [decale] qui prend un état [s] et rend
    l'état dans lequel la valeur de x0 est 0,
    la valeur de x1 est la valeur de x0 dans [s],
    la valeur de x2 est la valeur de x1 dans [s],
    la valeur de x3 est la valeur de x2 dans [s], etc.
    Indication : ce n'est PAS un Fixpoint *)

Definition decale (s : state) : state := Cons 0 s.

(** Démontrer qu'évaluer une expression renommée dans un environnement
    décalé rend la même chose qu'avant *)

Example ex_dec_ren: eval (renomme aexp_ex1) (decale s_ex1) = eval aexp_ex1 s_ex1.
Proof. reflexivity. Qed.

Theorem dec_ren: forall a s, eval (renomme a) (decale s) = eval a s.
Proof.
  intros a s.
  induction a.
  - reflexivity.
  - reflexivity.
  - cbn [renomme]. cbn [eval]. rewrite IHa1. rewrite IHa2. reflexivity.
  - cbn [renomme]. cbn [eval]. rewrite IHa1. rewrite IHa2. reflexivity.
  - cbn [renomme]. cbn [eval]. rewrite IHa1. rewrite IHa2. reflexivity.
    Qed.
(* ----------------------------------------------------------------------- *)
(** ** Expressions booléennes *)

(** Définir un type d'AST nommé bexp pour des expressions booléennes
    comprenant :
    - les constantes booléennes Btrue et Bfalse
    - un opérateur booléen unaire Bnot
    - des opérateurs booléens binaires Band et Bor
    - un opérateur de comparaison représentant le test d'égalité
      entre deux expressions arithmétiques
 *)

Inductive bexp :=
| Btrue : bexp
| Bfalse : bexp
| Bnot : bexp -> bexp
| Band : bexp -> bexp -> bexp
| Bor : bexp -> bexp -> bexp
| Beq : bexp -> bexp -> bexp
| Bcomp : aexp -> aexp -> bexp
.

(** L'environnenent initial de Coq comprend, en plus de [nat],
    un type énuméré nommé [bool à deux valeurs nommées [true] et [false]
    ainsi que des fonctions telles que la disjonction entre deux valeurs
    de type [bool].
    Vous pouvez découvrir tout cela au moyen de la commande "Print bool"
    et de la commande Search indiquée ci-dessus, mais on vous demande de
    reprogrammer les fonctions booléennes par vous-même en utilisant, comme
    pour [coulfeu], match with suivant le schéma :

      match blabla_booléen with
      | true => ...
      | false => ...
      end

    L'opération de comparaison entre deux entiers devra aussi être programmée.

    Définir une fonction d'évaluation sur bexp en s'appuyant sur ces fonctions.
 *)

Print bool.
Search bool.

Definition b_neg (a: bool) : bool :=
  match a with
  | true =>  false
  | false => true
  end.

Definition b_and (a: bool) (b:bool) : bool :=
  match (a,b) with
  | (true, true) => true
  | _ => false
  end.

Definition b_or (a:bool) (b:bool) : bool :=
  match (a,b) with
  | (false, false) => false
  | _ => true
  end.

Definition b_eq (a:bool) (b:bool) : bool :=
  match (a,b) with
  | (true, true) => true
  | (false, false) => true
  | _ => false
  end.

Fixpoint n_eq (a: nat) (b: nat) : bool :=
  match (a,b) with
  | (0,0) => true
  | (S n1, S n2) => n_eq n1 n2
  | (_, _) => false
  end.

Fixpoint beval (b: bexp) (s: state) : bool :=
  match b with
  | Btrue => true
  | Bfalse => false
  | Bnot a => b_neg (beval a s)
  | Band a1 a2 => b_and (beval a1 s) (beval a2 s)
  | Bor a1 a2 => b_or (beval a1 s) (beval a2 s)
  | Beq a1 a2 => b_eq (beval a1 s) (beval a2 s)
  | Bcomp ae1 ae2 => n_eq (eval ae1 s) (eval ae2 s)
end.

(* ----------------------------------------------------------------------- *)