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

Require Import List Arith Max Lia Wellfounded Bool.

From Undecidability.Shared.Libs.DLW
  Require Import Utils.utils.

Set Implicit Arguments.

Notation Zero := false.
Notation One  := true.

Fact list_bool_dec (l m : list bool) : { l = m } + { l <> m }.
Proof. apply list_eq_dec, bool_dec. Qed.

(* {0,1}* = 0*1{0,1}* + 0* *)

Fact list_bool_choose lb : { k : _ & { tl | lb = list_repeat Zero k ++ One :: tl } }
                         + { k            | lb = list_repeat Zero k }.
Proof.
  induction lb as [ | [] lb IHlb ].
  * right; exists 0; auto.
  * left; exists 0, lb; auto.
  * destruct IHlb as [ (k & lc & H) | (k & H) ].
    - left; exists (S k), lc; subst; auto.
    - right; exists (S k); subst; auto.
Qed.

(* {0,1}* = 1*0{0,1}* + 1* *)

Fact list_bool_choose_sym lb : { k : _ & { tl | lb = list_repeat One k ++ Zero :: tl } }
                             + { k            | lb = list_repeat One k }.
Proof.
  induction lb as [ | [] lb IHlb ].
  * right; exists 0; auto.
  * destruct IHlb as [ (k & lc & H) | (k & H) ].
    - left; exists (S k), lc; subst; auto.
    - right; exists (S k); subst; auto.
  * left; exists 0, lb; auto.
Qed.

(* [n1,...,nk] ---> 0...{n1}...01 0{n2}1 ... 0{nk}1 *)

Fixpoint list_nat_bool ln :=
  match ln with
    | nil   => nil
    | x::ll => list_repeat Zero x ++ One :: list_nat_bool ll
  end.

Lemma list_bool_decomp k lb : { ln : _ & { lc | lb = list_nat_bool ln ++ lc
                                             /\ Exists (fun x => k <= x) ln } }
                            + { ln : _ & { r  | lb = list_nat_bool ln ++ list_repeat Zero r
                                             /\ Forall (fun x => x < k) ln } }.
Proof.
  induction lb as [ lb IH ] using (measure_rect (@length _)).
  destruct (list_bool_choose lb) as [ (x & lr & Hlb) | (x & Hlb) ].
  * destruct (le_lt_dec k x) as [ Hk | Hk ].
    + left; exists (x::nil), lr; split; simpl.
      - subst; solve list eq.
      - constructor 1; auto.
    + destruct (IH lr) as [ (ln & ld & H2 & H3) | (ln & r & H2 & H3) ].
      - subst; rew length; lia.
      - left; exists (x::ln), ld; split.
        ** subst; solve list eq.
        ** constructor 2; auto.
      - right; exists (x::ln), r; split.
        ** subst; solve list eq.
        ** constructor; auto.
  * right; exists nil, x; split.
     - subst; solve list eq.
     - constructor.
Qed.

Definition list_bool_valid   k lb ln := lb = list_nat_bool ln /\ Forall (fun x => x < k) ln.
Definition list_bool_invalid k lb ln := exists lc, lb = list_nat_bool ln ++ lc
                                            /\ (   Exists (fun x => k <= x) ln
                                               \/  Forall (fun x => x < k) ln
                                                /\ exists p, lc = list_repeat Zero (S p)).

Fact list_bool_valid_dec k lb : { ln | list_bool_valid k lb ln } + { ln | list_bool_invalid k lb ln }.
Proof.
  destruct (list_bool_decomp k lb) as [ (ln & lc & H1 & H2) | (ln & [|p] & H1 & H2) ].
  * right; exists ln, lc; tauto.
  * left; exists ln; split; auto; subst; solve list eq.
  * right; exists ln, (list_repeat Zero (S p)); split; auto.
    right; split; auto; exists p; auto.
Qed.

Fixpoint list_bool_nat l :=
  match l with
    | nil     => 1
    | Zero::l => 0 + 2*list_bool_nat l
    | One::l  => 1 + 2*list_bool_nat l
  end.

Fact list_bool_nat_ge_1 l : 1 <= list_bool_nat l.
Proof. induction l as [ | [] ]; simpl in *; lia. Qed.

Unset Elimination Schemes.

Inductive list_bool_succ : list bool -> list bool -> Prop :=
  | in_lbs_0 : forall k l, list_bool_succ (list_repeat One k ++ Zero :: l) (list_repeat Zero k ++ One :: l)
  | in_lbs_1 : forall k,   list_bool_succ (list_repeat One k)              (list_repeat Zero (S k)).

Set Elimination Schemes.

Section list_bool_succ_props.

  Fact list_One_Zero_inj a b l m : list_repeat One a ++ Zero :: l = list_repeat One b ++ Zero :: m -> a = b /\ l = m.
  Proof.
    revert b l m; induction a as [ | a IHa ]; intros [ | b ] l m; simpl; try discriminate.
    inversion 1; auto.
    intros H.
    inversion H as [ H1 ].
    apply IHa in H1.
    destruct H1; subst; auto.
  Qed.

  Fact list_One_Zero_not a b l : list_repeat One a ++ Zero :: l <> list_repeat One b.
  Proof.
    revert b l; induction a as [ | a IHa ]; intros [ | b ] l; simpl; try discriminate.
    intros H.
    inversion H as [ H1 ].
    apply IHa in H1; auto.
  Qed.

  Fact list_One_inj a b : list_repeat One a = list_repeat One b -> a = b.
  Proof.
    intros H; apply f_equal with (f := @length _) in H; revert H.
    do 2 rewrite list_repeat_length; auto.
  Qed.

  Fact list_bool_succ_fun l m1 m2 : list_bool_succ l m1 -> list_bool_succ l m2 -> m1 = m2.
  Proof.
    intros H; revert l m1 H m2.
    intros ? ? [ k l | k ]; inversion 1.
    apply list_One_Zero_inj in H1; destruct H1; subst k0 l1; auto.
    symmetry in H1; apply list_One_Zero_not in H1; tauto.
    apply list_One_Zero_not in H1; tauto.
    apply list_One_inj in H1; subst; auto.
  Qed.

  Fact list_bool_succ_nil l : list_bool_succ nil l -> l = Zero::nil.
  Proof.
    intros H; symmetry; revert H; apply list_bool_succ_fun.
    constructor 2 with (k := 0).
  Qed.

  Fact list_bool_succ_neq : forall l m, list_bool_succ l m -> l <> m.
  Proof.
    intros ? ? [ [|k] l | [|k] ]; discriminate.
  Qed.

  Fact list_bool_succ_neq_nil l : ~ list_bool_succ l nil.
  Proof.
    inversion 1.
    destruct k; discriminate.
  Qed.

End list_bool_succ_props.

Section list_bool_next.

  Let list_bool_next_def l : { m | list_bool_succ l m }.
  Proof.
    destruct (list_bool_choose_sym l) as [ (k & tl & H) | (k & H) ]; subst l.
    * exists (list_repeat Zero k ++ One :: tl); constructor.
    * exists (list_repeat Zero (S k)); constructor.
  Qed.

  Definition list_bool_next l := proj1_sig (list_bool_next_def l).
  Definition list_bool_next_spec l : list_bool_succ l (list_bool_next l).
  Proof. apply (@proj2_sig _ _). Qed.

  Fact list_bool_next_neq_nil l : list_bool_next l <> nil.
  Proof.
    intros H.
    generalize (list_bool_next_spec l).
    rewrite H.
    apply list_bool_succ_neq_nil.
  Qed.

  Fact iter_list_bool_next_nil l n : iter list_bool_next l n = nil -> n = 0 /\ l = nil.
  Proof.
    destruct n as [ | n ].
    simpl; auto.
    replace (S n) with (n+1) by lia.
    rewrite iter_plus; simpl.
    intros H.
    apply list_bool_next_neq_nil in H.
    destruct H.
  Qed.

End list_bool_next.

Fact list_bool_succ_nat l m : list_bool_succ l m -> 1 + list_bool_nat l = list_bool_nat m.
Proof.
  revert l m; intros ? ? [ k l | k ]; induction k; simpl in *; lia.
Qed.

Section list_bool_succ_rect.

  Variable (P : list bool -> Type)
           (HP0 : P nil)
           (HPS : forall l m, list_bool_succ l m -> P l -> P m).

  Let list_bool_succ_rec n : forall l, list_bool_nat l = n -> P l.
  Proof.
    induction n as [ | n IHn ]; intros l Hl.
    * generalize (list_bool_nat_ge_1 l); lia.
    * destruct (list_bool_choose l) as [ (k & tl & H) | ([ | k] & H) ]; subst l;
      [ generalize (in_lbs_0 k tl) | apply HP0 | generalize (in_lbs_1 k) ];
        intros E; apply HPS with (1 := E), IHn;
        apply list_bool_succ_nat in E; lia.
  Qed.

  Theorem list_bool_succ_rect : forall l, P l.
  Proof using HP0 HPS. intro; apply list_bool_succ_rec with (1 := eq_refl). Qed.

End list_bool_succ_rect.

(* The iteration of list_bool_next from Zero::nil visits every non-empty list of booleans *)

Theorem list_bool_next_total l : l <> nil -> { n | l = iter list_bool_next (Zero::nil) n }.
Proof.
  induction l as [ | l m Hlm IH ] using list_bool_succ_rect.
  intros []; auto.
  intros Hm.
  destruct (list_bool_choose_sym l) as [ (k & tl & H) | ([|k] & H) ].
  * destruct IH as (n & Hn).
    { subst; destruct k; discriminate. }
    exists (n+1); rewrite iter_plus; simpl.
    rewrite <- Hn.
    generalize (list_bool_next_spec l).
    apply list_bool_succ_fun; auto.
  * exists 0; simpl.
    apply list_bool_succ_fun with (1 := Hlm).
    subst; simpl; constructor 2 with (k := 0).
  * destruct IH as (n & Hn).
    { subst; simpl; discriminate. }
    exists (n+1); rewrite iter_plus; simpl.
    rewrite <- Hn.
    generalize (list_bool_next_spec l).
    apply list_bool_succ_fun; auto.
Qed.


Require Import Coq.Logic.ProofIrrelevance.

Lemma sig_equivalence :
  forall (A : Type) (P : A -> Prop) (n m : A) (n_pf : P n) (m_pf : P m),
    n = m -> exist P n n_pf = exist P m m_pf.
Proof.
  intros A P n m n_pf m_pf nm_pf.
  subst.
  pose proof (proof_irrelevance _ n_pf m_pf).
  subst. reflexivity.
Qed.


(** * Synthesis.Core : Defining the memory model underlying the compiler*)
Require Import Common.
Require Import DList.
Require Word Vector.

Unset Elimination Schemes.

(** Definition of types *)

Inductive type : Type :=
| Tunit : type
| Tbool: type
| Tint: forall (n : nat), type
| Ttuple : forall l : list type,  type.

(** Notations used in the paper  *)
Notation Unit := Tunit.
Notation B  := Tbool.
Notation Int n := (Tint n).
Notation Tuple l := (Ttuple l).

Section type_ind.
  Variable P : type -> Prop.
  Variable Hunit : P Tunit.
  Variable Hbool : P Tbool.
  Variable Hint  : forall n, P (Tint n).
  Variable Hnil  : P (Ttuple []).
  Variable Hcons  : forall t q, P t -> P (Ttuple q) -> P (Ttuple (t :: q)).

  Definition type_ind (t : type) : P t.
  refine (let ind := fix ind t : P t :=
              match t with
                | Tunit => Hunit
                | Tbool => Hbool
                | Tint n => Hint n
                | Ttuple l =>
                    let fix fold l : P (Ttuple l) :=
                        match l with
                          | nil => Hnil
                          | cons t q => Hcons t q (ind t) (fold q)
                        end in
                      fold l
              end
          in ind t).
  Defined.
End type_ind.
Set Elimination Schemes.

Fixpoint eval_type st : Type :=
  match st with
    | Tunit => unit
    | Tbool => bool
    | Tint n => Word.T n
    | Ttuple l => Tuple.of_list eval_type l
  end.

Definition eval_type_list l : Type := Tuple.of_list eval_type l.

Require Import NPeano.

Definition type_eqb : forall a b : type, bool.
refine (let fix fold a b {struct a}: bool :=
            let fix pointwise   (i j : list type) : bool :=
                match i, j with
                  | [] , [] => true
                  | t::q , t' :: q' => (fold t t' && pointwise q q')%bool
                  | _, _ => false
                end%list in
              match a,b with
                | Tunit, Tunit => true
                | Tbool, Tbool => true
                | Tint n,  Tint m => Nat.eqb n m
                | Ttuple x, Ttuple y => pointwise x y
                | _ , _ => false
              end in fold
       ).
Defined.

Fixpoint type_list_eqb (la lb : list type) : bool :=
  match la,lb with
    | [], [] => true
    | t :: q , t' :: q' => (type_eqb t t' && type_list_eqb q q' )%bool
    | _ , _ => false
  end%list.

Lemma nat_eqb_eq : forall x y, Nat.eqb x y = true -> x = y.
Proof.
  induction x; destruct y; try reflexivity || simpl; try congruence.
  auto.
Defined.

Lemma type_eqb_correct a b : type_eqb a b = true -> a = b.
Proof.
  revert b.
  induction a; induction b; try simpl; try (reflexivity || congruence).
  intros. apply nat_eqb_eq in H. subst. reflexivity.
  case_eq (type_eqb a b); simpl; intros.
  apply IHa in H. subst. repeat f_equal. specialize (IHa0 (Ttuple q0) H0). congruence.
  discriminate.
Defined.

Lemma type_list_eqb_correct la lb : type_list_eqb la lb = true -> la = lb.
Proof.
    revert lb; induction la; destruct lb; simpl; try discriminate; intuition.
     rewrite Bool.andb_true_iff in H. destruct H. rewrite (IHla lb); auto.
     rewrite (type_eqb_correct a t H). reflexivity.
Qed.

Lemma type_eqb_refl : forall t, type_eqb t t = true.
Proof.
  induction t using type_ind; simpl;  firstorder.
  apply NPeano.Nat.eqb_eq. reflexivity.
Qed.

(** Operations on types *)
Section type_ops.

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

  Fixpoint type_eq (t : type) : eval_type t -> eval_type t -> bool :=
    match t with
      | Tunit => fun _ _  => true
      | Tint n => @Word.eqb n
      | Tbool  => eqb_bool
      | Ttuple l => fun _ _ => false
    end.

  Lemma type_eq_correct t x y : type_eq t x y = true -> x = y.
  Proof. destruct t; simpl in *.
    destruct x; destruct y; auto.
    destruct x; destruct y; auto.
    intros. apply Word.eqb_correct; auto.
    discriminate.
  Qed.
End type_ops.

Module Generics.
  Record signature T (E : T -> Type) := mk_signature
                                         {
                                           args : list T;
                                           res : T;
                                           value :> Tuple.of_list E args -> E res
  }.

  Arguments mk_signature {T E} args res value.
  Arguments args {T E} s.
  Arguments res {T E} s.
  Arguments value {T E} s _.

  (* could it be a primitive with an empty set of arguments ? *)
  Definition constant T (E : T -> Type) (ty : T) := E ty.
  Arguments constant {T E} ty.
End Generics.

Notation signature := (Generics.signature type eval_type).
Notation constant := (@Generics.constant type eval_type).

Definition Cbool b : constant Tbool := b.
Definition Cword {n} x : constant (Tint n) := (Word.repr _ x).

(** The definition of state elements. *)
Inductive mem : Type :=
  | Tinput: forall (t: type), mem
  | Treg : forall (t : type), mem
  | Tregfile : forall (n : nat) (t : type), mem.

Notation Input := Tinput.
Notation Reg   := Treg.
Notation Regfile   := Tregfile.

Definition state := list mem.

Definition eval_mem (s : mem) :=
  match s with
    | Tinput t => eval_type t
    | Treg t => eval_type t
    | Tregfile n t => Regfile.T n (eval_type t)
  end.

Notation eval_state := (DList.T eval_mem).


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinear4.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_collinearparallel :
   forall A B C c d,
   Par A B c d -> Col c d C -> neq C d ->
   Par A B C d.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists R a b p q, (neq A B /\ neq c d /\ Col A B a /\ Col A B b /\ neq a b /\ Col c d p /\ Col c d q /\ neq p q /\ ~ Meet A B c d /\ BetS a R q /\ BetS p R b)) by (conclude_def Par );destruct Tf as [R[a[b[p[q]]]]];spliter.
assert (neq d C) by (conclude lemma_inequalitysymmetric).
assert (Col d C p) by (conclude lemma_collinear4).
assert (Col C d p) by (forward_using lemma_collinearorder).
assert (Col d C q) by (conclude lemma_collinear4).
assert (Col C d q) by (forward_using lemma_collinearorder).
assert (~ Meet A B C d).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists E, (neq A B /\ neq C d /\ Col A B E /\ Col C d E)) by (conclude_def Meet );destruct Tf as [E];spliter.
 assert (Col C d c) by (forward_using lemma_collinearorder).
 assert (Col d E c) by (conclude lemma_collinear4).
 assert (Col c d E) by (forward_using lemma_collinearorder).
 assert (Meet A B c d) by (conclude_def Meet ).
 contradict.
 }
assert (Par A B C d) by (conclude_def Par ).
close.
Qed.

End Euclid.


Require Import Setoid.
Require Import Coq.Lists.List.
Require Import Bool.
Require Import Coq.Program.Equality.
Import ListNotations.
Import PeanoNat.Nat.

Print In.
Print reflect.

Inductive Deduplicated {A: Type} : list A -> Prop :=
| DedupNil  : Deduplicated []
| DedupCons : forall (x: A) (l: list A), ~ In x l -> Deduplicated l -> Deduplicated (x::l).

Fixpoint any {A: Type} (p : A -> bool) (l: list A) : bool :=
  match l with
  | [] => false
  | (x::l') => if p x then true else any p l'
  end.

Definition Elem_eq {A: Type} (l l' : list A) : Prop :=
  forall p : A -> bool, any p l = any p l'.

Definition Same_elements {A: Type} (l l' : list A) : Prop :=
  forall x : A, In x l <-> In x l'.

Class EqDec (A : Type) := {
  eqf : A -> A -> bool ;
  eqf_leibniz : forall x y: A, reflect (x = y) (eqf x y)
}.

Print Bool.

Lemma eqf_refl : forall {A: Type} `{EqDec A}, forall x: A, eqf x x = true.
Proof.
  intros A eq_dec x. destruct (eqf_leibniz x x).
  - reflexivity.
  - exfalso. apply n. reflexivity.
Qed.

Lemma eqf_iff : forall {A: Type} `{EqDec A}, forall x y: A, x = y <-> eqf x y = true.
Proof.
  intros A eq_dec x y. apply reflect_iff. apply eqf_leibniz.
Qed.

Lemma not_eqf_iff : forall {A: Type} `{EqDec A}, forall x y: A, x <> y <-> eqf x y = false.
Proof.
  intros A eq_dec x y. case_eq (eqf x y).
  - intro e. destruct (eqf_leibniz x y).
    + split; intro H; try inversion H; try contradiction.
    + inversion e.
  - intro e. destruct (eqf_leibniz x y).
    + inversion e.
    + split; intro H; assumption.
Qed.

Theorem any_in_eq_dec : forall (A: Type) `{EqDec A}, forall l: list A, forall x: A,
  reflect (In x l) (any (eqf x) l).
Proof.
  intros A eq_dec l x. case_eq (any (eqf x) l).
  - intro H. constructor. induction l.
    + cbn in *. inversion H.
    + destruct (eqf_leibniz x a).
      * cbn. left. symmetry. assumption.
      * cbn in *. right. apply IHl. rewrite (not_eqf_iff x a) in n.
        rewrite n in H. assumption.
  - intro H. constructor. induction l.
    + cbn. auto.
    + intro H0. cbn in *. destruct H0.
      * destruct H0. rewrite (eqf_refl a) in H. inversion H.
      * case_eq (eqf x a); intro H1.
        -- rewrite H1 in H. inversion H.
        -- rewrite H1 in H. apply IHl; assumption.
Qed.

Theorem any_in_eq_dec_iff : forall (A: Type) `{EqDec A}, forall (l: list A) (x: A),
  (In x l <-> any (eqf x) l = true).
Proof.
  intros A eq_dec l x. apply reflect_iff. apply any_in_eq_dec.
Qed.

Lemma in_any_true : forall (A: Type) (l: list A) (x: A) (p : A -> bool),
  p x = true -> In x l -> any p l = true.
Proof.
  intros A l x p H I. induction l.
  - cbn in I. auto.
  - cbn in *. destruct I.
    + subst. rewrite H. reflexivity.
    + destruct (p a) eqn:H1.
      * reflexivity.
      * apply IHl. assumption.
Qed.

Lemma exist_in_any : forall (A: Type) (l: list A) (p : A -> bool),
  any p l = true -> exists x: A, p x = true /\ In x l.
Proof.
  intros A l p H. induction l.
  - cbn in H. inversion H.
  - cbn in *. destruct (p a) eqn:H0.
    + exists a. split; try assumption. left. reflexivity.
    + assert (exists x : A, p x = true /\ In x l) by (apply IHl; apply H).
      destruct H1. exists x. destruct H1. split; try assumption. right. assumption.
Qed.

Lemma forall_in_any : forall (A: Type) (l: list A) (p : A -> bool),
  any p l = false -> forall x: A, In x l -> p x = false.
Proof.
  intros A l. induction l.
  - cbn in *. intros _ _ x [].
  - intros p H x I. cbn in *. destruct (p a) eqn:H0.
    + inversion H.
    + destruct I.
      * subst. assumption.
      * apply IHl; assumption.
Qed.

Theorem elem_eq_for_eq_dec : forall (A: Type), EqDec A -> forall x y: list A,
  (Elem_eq x y <-> Same_elements x y).
Proof.
  unfold Elem_eq, Same_elements. intros A eq_dec l l'. split.
  - intros H x. specialize (H (eqf x)). rewrite any_in_eq_dec_iff, any_in_eq_dec_iff, H.
    split; intro H0; apply H0.
  - intros H p. destruct (any p l) eqn:e1; destruct (any p l') eqn:e2; trivial.
    + assert (exists x: A, p x = true /\ In x l) by (apply exist_in_any; assumption).
      assert (forall x: A, In x l' -> p x = false) by (apply forall_in_any; assumption).
      destruct H0. rewrite H in H0. destruct H0. rewrite <- H0. apply H1. assumption.
    + assert (exists x: A, p x = true /\ In x l') by (apply exist_in_any; assumption).
      assert (forall x: A, In x l -> p x = false) by (apply forall_in_any; assumption).
      destruct H0. rewrite <- H in H0. destruct H0. rewrite <- H0. symmetry. apply H1. assumption.
Qed.

Inductive tree (A: Type) : Type :=
| leaf : tree A
| node : A -> tree A -> tree A -> tree A.

Arguments leaf {A}.
Arguments node {A} _ _ _.

Class LinearOrder {A: Type} := {
  ord      : A -> A -> bool;
  refl     : forall x: A, ord x x = true;
  anti_sym : forall x y: A, ord x y = true -> ord y x = true -> x = y;
  trans    : forall x y z: A, ord x y = true -> ord y z = true -> ord x z = true;
  full     : forall x y, ord x y = true \/ ord y x = true;
}.

Definition comp {A: Type} `{LinearOrder A} (x y: A) :=
  if ord x y then (if ord y x then Eq else Gt) else Lt.

Definition treeComp {A: Type} `{LinearOrder A} (x: A) (t: tree A) :=
match t with
| leaf => None
| node y _ _ =>  Some (comp x y)
end.

Fixpoint add_tree {A: Type} `{LinearOrder A} (x: A) (t : tree A) : tree A :=
match t with
| leaf => node x leaf leaf
| node v l r => match comp x v with
                | Lt => node v (add_tree x l) r
                | Eq => node v l r
                | Gt => node v l (add_tree x r)
                end
end.

Fixpoint to_tree {A: Type} `{LinearOrder A} (l : list A) : tree A :=
  match l with
  | []      => leaf
  | (x::l') => add_tree x (to_tree l')
  end.

Fixpoint to_list {A: Type} (l : tree A) : list A :=
  match l with
  | leaf       => []
  | node x l r => to_list l ++ [x] ++ to_list r
  end.

Fixpoint TCount {A: Type}(p: A -> bool)(t: tree A) : nat :=
  match t with
  | leaf => 0
  | node x l r => if (p x) then S (TCount p l + TCount p r) else TCount p l + TCount p r
  end.

Fixpoint TAny {A: Type}(p: A -> bool)(t: tree A) : bool :=
  match t with
  | leaf => false
  | node x l r => p x || TAny p l || TAny p r
  end.

Fixpoint count {A: Type} (p: A -> bool) (l: list A): nat :=
  match l with
  | nil => O
  | cons h t => if p h then S (count p t) else count p t
  end.

Definition permutation {A: Type} (a b : list A) :=
  forall p : A -> bool, count p a = count p b.

Definition TListPermutation{A: Type}(t: tree A)(l: list A) : Prop :=
  forall p: A->bool, TCount p t = count p l.

Definition TPermutation{A: Type}(t1 t2: tree A) : Prop :=
  forall p: A->bool, TCount p t1 = TCount p t2.

Definition TElem_eq (A: Type) (l l' : tree A) : Prop :=
  forall p : A -> bool, TAny p l = TAny p l'.

Definition TListElem_eq {A: Type} (t: tree A) (l: list A) : Prop :=
  forall p : A -> bool, TAny p t = any p l.

Definition DSort {A: Type} `{LinearOrder A} (l : list A) : list A := to_list (to_tree l).

Lemma count_list_concat {A: Type} (l l': list A):
  forall p: A-> bool, count p (l ++ l') = count p l + count p l'.
Proof.
  intros p. revert l'. induction l; intros l'.
  - cbn. reflexivity.
  - cbn. destruct (p a).
    + rewrite IHl. cbn. reflexivity.
    + apply IHl.
Qed.

Lemma to_list_perm {A: Type} (t: tree A) : TListPermutation t (to_list t).
Proof.
  intros p. induction t.
  - cbn. reflexivity.
  - cbn. rewrite count_list_concat. cbn. destruct (p a).
    + rewrite plus_n_Sm, IHt1, IHt2. reflexivity.
    + rewrite IHt1, IHt2. reflexivity.
Qed.

Lemma count_TCount {A: Type} (t: tree A) : forall p: A-> bool,
  TCount p t = count p (to_list t).
Proof.
  apply to_list_perm.
Qed.

Fixpoint TIn {A: Type} (x: A) (t: tree A) : Prop :=
match t with
| leaf => False
| node v l r => v = x \/ TIn x l \/ TIn x r
end.

Inductive normal_tree {A: Type} `{LinearOrder A} : tree A -> Prop :=
| NormLeaf : normal_tree leaf
| NormNode : forall (x: A) (l r: tree A), normal_tree l -> normal_tree r ->
  (forall y: A, TIn y l -> comp y x = Lt) -> (forall y: A, TIn y r -> comp y x = Gt) ->
  normal_tree (node x l r).

Definition TDeduplicated {A: Type} `{EqDec A} (t: tree A) : Prop :=
  forall x : A, TIn x t -> TCount (eqf x) t = 1.

Definition LDeduplicated {A: Type} `{EqDec A} (t: list A) : Prop :=
  forall x : A, In x t -> count (eqf x) t = 1.

Global Instance lo_eq_dec {A: Type} `{LinearOrder A} : EqDec A.
Proof.
  exists (fun x y => if ord x y then (if ord y x then true else false) else false).
  intros x y. destruct (ord x y) eqn:e1; destruct (ord y x) eqn:e2.
  - constructor. apply  anti_sym; assumption.
  - constructor. intro H0. subst. rewrite e2 in e1. inversion e1.
  - constructor. intro H0. subst. rewrite e1 in e2. inversion e2.
  - constructor. intro H0. subst. assert (ord y y = true) by apply refl. rewrite e1 in H0. inversion H0.
Qed.

Lemma in_to_list {A: Type} (x: A) (t: tree A) : In x (to_list t) <-> TIn x t.
Proof.
  split.
  - induction t.
    + cbn. auto.
    + cbn. intro H. rewrite in_app_iff in H. cbn in *. destruct H; try destruct H.
      * right. left. apply IHt1. assumption.
      * left. assumption.
      * right. right. apply IHt2. assumption.
  - induction t.
    + cbn. auto.
    + cbn. intro H. rewrite in_app_iff. cbn. destruct H; cycle 1. destruct H.
      * left. apply IHt1. assumption.
      * right. right. apply IHt2. assumption.
      * right. left. assumption.
Qed.

Lemma not_full {A: Type} `{LinearOrder A} (x y: A) : ~ (ord x y = false /\ ord y x = false).
Proof.
  intros (a & b). destruct (full x y).
  - rewrite H0 in a. discriminate.
  - rewrite H0 in b. discriminate.
Qed.

Lemma comp_eq {A: Type} `{LinearOrder A} (x y: A) : comp x y = Eq <-> x = y.
Proof.
  split.
  - unfold comp. intro C. destruct (ord x y) eqn:e1; destruct (ord y x) eqn:e2; try inversion C.
  apply anti_sym; assumption.
  - intros []. unfold comp. rewrite refl. auto.
Qed.

Lemma comp_lt {A: Type} `{LinearOrder A} (x y: A) :
  comp x y = Lt <-> ord x y = false /\ ord y x = true.
Proof.
  unfold comp. split.
  - intro C. destruct (ord x y) eqn:e1; destruct (ord y x) eqn:e2; try inversion C; auto.
    exfalso. apply (not_full x y); split; assumption.
  - intros (e1 & e2). rewrite e1. auto.
Qed.

Lemma comp_gt {A: Type} `{LinearOrder A} (x y: A) :
  comp x y = Gt <-> ord x y = true /\ ord y x = false.
Proof.
  unfold comp. split.
  - intro C. destruct (ord x y) eqn:e1; destruct (ord y x) eqn:e2; try inversion C; auto.
  - intros (e1 & e2). rewrite e1. rewrite e2. auto.
Qed.

Lemma ord_false_true {A: Type} `{LinearOrder A} (x y z: A) :
  ord x y = false -> ord y x = true.
Proof.
  intros. destruct (full x y).
  - rewrite H0 in H1. discriminate.
  - assumption.
Qed.

Lemma lo_false_trans {A: Type} `{LinearOrder A} (x y z: A) :
  ord y x = false -> ord z y = false -> ord z x = false.
Proof.
  intros H1 H2.
  destruct (ord x z) eqn:H3.
  - assert (x <> z).
    + intro. subst. exfalso. apply (not_full y z); split; assumption.
    + destruct (ord z x) eqn:H4.
      * destruct (anti_sym x z H3 H4). exfalso. apply H0. auto.
      * reflexivity.
  - assert (ord x z = true).
    + apply (trans x y z); apply ord_false_true; assumption.
    + rewrite H0 in H3. discriminate.
Qed.

Lemma comp_trans {A: Type} `{LinearOrder A} (x y z: A) (c: comparison) :
  comp x y = c -> comp y z = c -> comp x z = c.
Proof.
  destruct c.
  - rewrite (comp_eq x y), (comp_eq y z), (comp_eq x z). intros. subst. auto.
  - rewrite (comp_lt x y), (comp_lt y z), (comp_lt x z).
    intros (f1 & t1) (f2 & t2). split.
    + apply (lo_false_trans z y x); assumption.
    + apply (trans z y x); assumption.
  - rewrite (comp_gt x y), (comp_gt y z), (comp_gt x z).
    intros (t1 & f1) (t2 & f2). split.
    + apply (trans x y z); assumption.
    + apply (lo_false_trans x y z); assumption.
Qed.

Definition comp_inv (c: comparison) :=
match c with
| Lt => Gt
| Eq => Eq
| Gt => Lt
end.

Lemma comp_inv_def {A: Type} `{LinearOrder A} (x y: A):
  comp y x = comp_inv (comp x y).
Proof.
  unfold comp. destruct (ord x y) eqn:e1; destruct (ord y x) eqn:e2; cbn; auto.
  exfalso. apply (not_full x y); split; assumption.
Qed.

Lemma comp_inv_iff {A: Type} `{LinearOrder A} (x y: A) (c: comparison):
  comp y x = c <-> comp x y = comp_inv c.
Proof.
  rewrite comp_inv_def. split; intro O; destruct c; destruct (comp x y); cbn in *; auto; inversion O.
Qed.

Lemma add_dont_remove {A: Type} `{LinearOrder A} (t : tree A) :
  forall v: A, TIn v t -> forall n: A, TIn v (add_tree n t).
Proof.
  intros v I n. induction t.
  - cbn in *. destruct I.
  - cbn in *. destruct (comp n a) eqn:c.
    + apply I.
    + cbn. destruct I as [e|[l | r]]; subst; auto.
    + cbn. destruct I as [e|[l | r]]; subst; auto.
Qed.

Lemma TIn_add {A: Type} `{LinearOrder A} (n: A) (t : tree A) :
  forall v: A, TIn v (add_tree n t) <-> n = v \/ TIn v t.
Proof.
  intros v. split.
  - intros I. induction t.
    + left. cbn in *. destruct I; auto; try destruct H0; try destruct H0.
    + cbn in *. destruct (comp n a) eqn:c.
      * rewrite comp_eq in c. subst. cbn in *. destruct I as [e|[l|r]]; subst; auto.
      * cbn in *. destruct I as [e|[l|r]]; subst; auto. specialize (IHt1 l). destruct IHt1; auto.
      * cbn in *. destruct I as [e|[l|r]]; subst; auto. specialize (IHt2 r). destruct IHt2; auto.
  - intros [e | I].
    + induction t.
      * cbn. auto.
      * cbn. destruct (comp n a) eqn:c; cbn; auto. rewrite comp_eq in c. subst. auto.
    + apply add_dont_remove. assumption.
Qed.

Theorem add_preserves_normal {A: Type} `{LinearOrder A} (n: A) (t : tree A) :
  normal_tree t -> normal_tree (add_tree n t).
Proof.
  intro N. induction N.
  - cbn. constructor; try constructor; intros y I; cbn in *; try inversion I.
  - cbn in *. destruct (comp n x) eqn:c.
    + constructor; assumption.
    + constructor; auto. intros y I. rewrite TIn_add in I. destruct I; subst; auto.
    + constructor; auto. intros y I. rewrite TIn_add in I. destruct I; subst; auto.
Qed.

Lemma TCount_for_not_satisfied_pred {A: Type} (t : tree A) (p: A -> bool):
  (forall x:A, TIn x t -> p x = false) -> TCount p t = 0.
Proof.
  intros N. induction t.
  - auto.
  - cbn in *. rewrite (N a); auto. rewrite IHt1, IHt2; auto.
Qed.

Lemma eqf_comp_not_eq {A: Type} `{LinearOrder A} (x y: A) : comp x y <> Eq <-> eqf x y = false.
Proof.
  rewrite comp_eq. rewrite not_eqf_iff. split; auto.
Qed.

Lemma eqf_lt{A: Type} `{LinearOrder A} (x y: A) : comp x y = Lt -> eqf x y = false.
Proof.
  intro C. rewrite <-eqf_comp_not_eq. intros C'. rewrite C in C'. inversion C'.
Qed.

Lemma eqf_gt{A: Type} `{LinearOrder A} (x y: A) : comp x y = Gt -> eqf x y = false.
Proof.
  intro C. rewrite <-eqf_comp_not_eq. intros C'. rewrite C in C'. inversion C'.
Qed.

Theorem normal_is_depup {A: Type} `{LinearOrder A} (t: tree A) :
  normal_tree t -> TDeduplicated t.
Proof.
  intro N. induction N.
  - intros x I. cbn in I. destruct I.
  - intros y I. cbn in I. destruct I as [e|[I|I]].
    + subst. cbn in *. rewrite eqf_refl. rewrite TCount_for_not_satisfied_pred, TCount_for_not_satisfied_pred; auto.
      * intros x I. rewrite <-eqf_comp_not_eq. specialize (H1 x I). rewrite comp_inv_iff. cbn. rewrite H1. intros [=].
      * intros x I. rewrite <-eqf_comp_not_eq. specialize (H0 x I). rewrite comp_inv_iff. cbn. rewrite H0. intros [=].
    + destruct (comp y x) eqn:c.
      * specialize (H0 y I). rewrite H0 in c. inversion c.
      * cbn. rewrite eqf_lt; auto. rewrite IHN1; auto. rewrite TCount_for_not_satisfied_pred; auto.
        intros z I'. rewrite <-eqf_comp_not_eq. rewrite comp_eq. specialize (H1 z I'). intros c'.
        subst. rewrite c in H1. discriminate.
      * cbn. rewrite eqf_lt; auto. rewrite IHN1; auto. rewrite TCount_for_not_satisfied_pred; auto.
        intros z I'. rewrite <-eqf_comp_not_eq. rewrite comp_eq. specialize (H1 z I'). specialize (H0 y I).
        intros e. subst. rewrite H1 in H0. discriminate.
    + destruct (comp y x) eqn:c.
      * specialize (H1 y I). rewrite H1 in c. inversion c.
      * cbn. rewrite eqf_lt; auto. rewrite IHN2; auto. rewrite TCount_for_not_satisfied_pred; auto.
        intros z I'. rewrite <-eqf_comp_not_eq. rewrite comp_eq. intro e; subst. specialize (H0 z I').
        specialize (H1 z I). rewrite H0 in H1. discriminate.
      * cbn. rewrite eqf_gt; auto. rewrite IHN2; auto. rewrite TCount_for_not_satisfied_pred; auto.
        intros z I'. rewrite <-eqf_comp_not_eq. rewrite comp_eq. intro e; subst. specialize (H0 z I').
        rewrite c in H0. discriminate.
Qed.

Theorem to_tree_normal {A: Type} `{LinearOrder A} (l: list A) : normal_tree (to_tree l).
Proof.
  induction l.
  - cbn in *. constructor.
  - cbn in *. apply add_preserves_normal. assumption.
Qed.

Theorem to_tree_dedup {A: Type} `{LinearOrder A} (l: list A) : TDeduplicated (to_tree l).
Proof.
  apply normal_is_depup. apply to_tree_normal.
Qed.

Theorem dedup_DSort {A: Type} `{LinearOrder A} (l : list A) : LDeduplicated (DSort l).
Proof.
  intros x I. unfold DSort in *. rewrite <- count_TCount. rewrite in_to_list in I.
  apply to_tree_dedup. assumption.
Qed.

(* Sorted *)

Inductive Sorted {A: Type} `{LinearOrder A} : list A -> Prop :=
  | SortedNil : Sorted []
  | SortedSing : forall h: A, Sorted [h]
  | SortedCons : forall h h' : A, forall t: list A,
      Sorted (h' :: t) -> ord h' h = true -> Sorted (h :: h' :: t).

Lemma sorted_without_head {A: Type} `{LinearOrder A} (a: A) (l: list A) :
  Sorted (a::l) -> Sorted l.
Proof.
  induction l; intro h.
  - constructor.
  - dependent destruction h. assumption.
Qed.

Lemma concat_sorted {A: Type} `{LinearOrder A} (h: A) (l l': list A) : Sorted l -> Sorted (h::l') ->
  (forall x: A, In x l -> ord h x = true) -> Sorted (l ++ (h::l')).
Proof.
  intros s1 s2 N. induction l.
  - cbn. assumption.
  - destruct l.
    + cbn. constructor; auto. apply (N a). cbn. auto.
    + cbn in *. constructor.
      * apply IHl.
        -- apply (sorted_without_head a). assumption.
        -- intros x I. apply N. auto.
      * dependent destruction s1. assumption.
Qed.

Lemma head_sorted {A: Type} `{LinearOrder A} (h: A) (l: list A) : Sorted l ->
  (forall x: A, In x l -> ord x h = true) -> Sorted (h::l).
Proof.
  intros s N. induction l.
  - constructor.
  - constructor; auto. apply N. cbn. auto.
Qed.

Lemma ord_comp_lt {A: Type} `{LinearOrder A} (h: A) (l: list A) :
  (forall x: A, In x l -> comp x h = Lt) -> (forall x: A, In x l -> ord h x = true).
Proof.
  unfold comp. intros R x I. specialize (R x I). destruct (ord h x) eqn:e1; destruct (ord x h) eqn:e2; auto.
  - inversion R.
  - destruct (full h x).
    + rewrite H0 in e1. discriminate.
    + rewrite H0 in e2. discriminate.
Qed.

Lemma ord_comp_gt {A: Type} `{LinearOrder A} (h: A) (l: list A) :
  (forall x: A, In x l -> comp x h = Gt) -> (forall x: A, In x l -> ord x h = true).
Proof.
  unfold comp. intros R x I. specialize (R x I). destruct (ord h x) eqn:e1; destruct (ord x h) eqn:e2; auto.
  - inversion R.
  - destruct (full h x).
    + rewrite H0 in e1. discriminate.
    + rewrite H0 in e2. discriminate.
Qed.

Theorem normal_to_list_sorted {A: Type} `{LinearOrder A} (t: tree A) : normal_tree t -> Sorted (to_list t).
Proof.
  intros N. induction N.
  - cbn. constructor.
  - cbn. apply concat_sorted; auto.
    + apply head_sorted; auto. apply ord_comp_gt. intros z I. rewrite in_to_list in I. apply (H1 z I).
    + apply ord_comp_lt. intros z I. rewrite in_to_list in I. apply (H0 z I).
Qed.

Theorem sorted_DSort {A: Type} `{LinearOrder A} (l : list A) : Sorted (DSort l).
Proof.
  apply normal_to_list_sorted. apply to_tree_normal.
Qed.

(* Preserves elems *)

Lemma any_concat {A: Type} (l l': list A) (p: A -> bool): any p (l ++ l') = any p l || any p l'.
Proof.
  induction l; auto. cbn. destruct (p a); auto.
Qed.

Lemma to_list_any {A: Type} (t: tree A) : TListElem_eq t (to_list t).
Proof.
  intros p. induction t.
  - cbn. reflexivity.
  - cbn. rewrite any_concat. cbn. destruct (p a); cbn; auto.
    + rewrite orb_comm. auto.
    + rewrite IHt1, IHt2. reflexivity.
Qed.

Lemma add_tree_any {A: Type} `{LinearOrder A} (x: A) (t: tree A) (p: A->bool):
  TAny p (add_tree x t) = (if p x then true else TAny p t).
Proof.
  induction t.
  - cbn. destruct (p x); auto.
  - cbn. destruct (comp x a) eqn:e; cbn.
    + rewrite comp_eq in e. subst. destruct (p a) eqn:p_a; auto.
    + rewrite IHt1. destruct (p a); destruct (p x); auto.
    + rewrite IHt2. destruct (p a); destruct (p x); auto. rewrite orb_false_l, orb_comm. auto.
Qed.

Lemma to_tree_any {A: Type} `{LinearOrder A} (l: list A) : TListElem_eq (to_tree l) l.
Proof.
  intros p. induction l.
  - cbn. reflexivity.
  - cbn. rewrite add_tree_any, IHl. auto.
Qed.

Theorem same_elements_DSort {A: Type} `{LinearOrder A} (l : list A) : Elem_eq l (DSort l).
Proof.
  unfold DSort. intros p. rewrite <-to_list_any. symmetry. apply to_tree_any.
Qed.

(* Uniquness *)

Lemma count_for_not_satisfied_pred {A: Type} (l: list A) (p: A->bool) :
  (forall x : A, In x l -> p x = false) -> count p l = 0.
Proof.
  intros N. induction l; auto. cbn. rewrite IHl.
  - rewrite (N a); auto. cbn. left. auto.
  - intros x I. apply (N x). cbn. right. assumption.
Qed.

Lemma count_existing {A: Type} (l: list A) (p: A->bool) (x: A) :
  p x = true -> In x l -> count p l <> O.
Proof.
  intros pred I. induction l.
  - cbn in *. inversion I.
  - cbn in *. destruct I.
    + subst. rewrite pred. apply neq_succ_0.
    + destruct (p a); auto.
Qed.

Theorem dup_def_eq {A: Type} `{LinearOrder A} (l : list A) :
  Deduplicated l <-> LDeduplicated l.
Proof.
  unfold LDeduplicated. split.
  - intros D x I. induction D.
    + cbn in *. inversion I.
    + cbn in *. destruct I.
      * subst. rewrite eqf_refl. rewrite count_for_not_satisfied_pred; auto. intros y I.
        rewrite <- not_eqf_iff. intros e. subst. apply H0. assumption.
      * rewrite (IHD H1). assert (x <> x0) by (intro e; subst; auto). rewrite not_eqf_iff in H2.
        rewrite H2. auto.
  - intro D. induction l; constructor.
    + intro I. specialize (D a (or_intror I)). cbn in D. rewrite eqf_refl in D. assert (count (eqf a) l <> O).
      * apply count_existing with (x := a); auto. apply eqf_refl.
      * rewrite neq_0_r in H0. destruct H0 as (m & S). rewrite S in D. inversion D.
    + apply IHl. intros x I. cbn in *. specialize (D x (or_intror I)). destruct (eqf x a) eqn:e.
      * rewrite <- eqf_iff in e. subst. assert (count (eqf a) l <> O).
        -- apply count_existing with (x := a); auto. apply eqf_refl.
        -- rewrite neq_0_r in H0. destruct H0 as (m & S). rewrite S in D. inversion D.
      * assumption.
Qed.

Theorem unique_sorted {A: Type} `{LinearOrder A} (l l': list A) :
  permutation l l' -> Sorted l -> Sorted l' -> l = l'.
Proof.
Admitted.

Fixpoint remove {A: Type} `{EqDec A} (x: A) (l: list A) :=
match l with
| []     => []
| (h::t) => if eqf x h then t else h :: remove x t
end.

Lemma remove_count_true {A: Type} `{EqDec A} (h: A) (l: list A) (p: A -> bool) :
  In h l -> p h = true -> count p l = S (count p (remove h l)).
Proof.
  induction l; intros I t.
  - cbn in *. destruct I.
  - cbn in *. destruct I.
    + subst. rewrite t. rewrite eqf_refl. auto.
    + destruct (p a) eqn:e; destruct (eqf h a) eqn:e1; auto.
      * cbn in *. rewrite e. rewrite IHl; auto.
      * rewrite <- eqf_iff in e1. subst. rewrite t in e. discriminate.
      * cbn in *. rewrite e. apply IHl; auto.
Qed.

Lemma remove_count_false {A: Type} `{EqDec A} (h: A) (l: list A) (p: A -> bool) :
  p h = false -> count p l = count p (remove h l).
Proof.
  induction l; intros f; auto. cbn in *.
  destruct (p a) eqn:e; destruct (eqf h a) eqn:e1; auto.
  - rewrite <- eqf_iff in e1. subst. rewrite f in e. discriminate.
  - cbn. rewrite e. f_equal. apply IHl; auto.
  - cbn. rewrite e. apply IHl; auto.
Qed.

Lemma in_count_not_O {A: Type} `{EqDec A} (l: list A) (x: A) :
  In x l <-> count (eqf x) l <> O.
Proof.
  split.
  - intros I. induction l.
    + cbn in I. destruct I.
    + cbn in *. destruct I as [e|I].
      * subst. rewrite eqf_refl. auto.
      * destruct (eqf x a) eqn: e; auto.
  - intros C. induction l.
    + cbn in C. contradiction.
    + cbn in *. destruct (eqf x a) eqn: e; auto. rewrite <- eqf_iff in e.
      subst. left. auto.
Qed.

Lemma perm_in {A: Type} `{EqDec A} (l l': list A) (x: A) :
  permutation l l' -> In x l -> In x l'.
Proof.
  intros perm I. rewrite in_count_not_O. rewrite in_count_not_O in I.
  specialize (perm (eqf x)). rewrite <-perm. assumption.
Qed.

Lemma remove_perm {A: Type} `{EqDec A} (h: A) (l l': list A) :
  permutation (h :: l) l' -> permutation l (remove h l').
Proof.
  unfold permutation. revert l'. induction l; intros l' perm p.
  - assert (In h l').
    + apply (perm_in [h]); auto. cbn. auto.
    + cbn. apply eq_add_S. specialize (perm p). cbn in *. destruct (p h) eqn:e.
      * rewrite <-remove_count_true; auto.
      * rewrite <-remove_count_false; auto.
  - assert (In h l') by (apply (perm_in (h::a::l)); cbn; auto).
    assert (In a l') by (apply (perm_in (h::a::l)); cbn; auto).
    cbn. apply eq_add_S. apply eq_add_S. specialize (perm p). cbn in *.
    destruct (p h) eqn:e.
    + rewrite <-remove_count_true; auto.
    + rewrite <-remove_count_false; auto.
Qed.

Lemma remove_perm' {A: Type} `{EqDec A} (h: A) (l l': list A) :
  In h l' -> permutation l (remove h l') -> permutation (h :: l) l' .
Proof.
  unfold permutation. revert l'. induction l; intros l' I perm p.
  - cbn in *. specialize (perm p). destruct (p h) eqn: e.
    + rewrite (remove_count_true h); auto.
    + rewrite (remove_count_false h); auto.
  - cbn in *. specialize (perm p). destruct (p h) eqn: e.
    + rewrite (remove_count_true h l'); auto.
    + rewrite (remove_count_false h l'); auto.
Qed.

Definition perm_eqf {A: Type} `{EqDec A} (l l': list A) :=
  forall x: A, count (eqf x) l = count (eqf x) l'.

Lemma perm_eqf_iff {A: Type} `{EqDec A} (l l': list A) :
  permutation l l' <-> perm_eqf l l'.
Proof.
  split.
  - intros P x. apply (P (eqf x)).
  - revert l'. induction l; intros l' E p.
    + destruct l'; auto. specialize (E a). cbn in E. rewrite eqf_refl in E. inversion E.
    + rewrite (remove_perm' a l l'); auto.
      * rewrite in_count_not_O. specialize (E a). rewrite <- E. cbn. rewrite eqf_refl. auto.
      * intros p'. apply IHl. intros x. specialize (E x). cbn in *. destruct (eqf x a) eqn:e.
        -- apply eq_add_S. rewrite E. rewrite (remove_count_true a); auto.
           rewrite <- eqf_iff in e. subst. rewrite in_count_not_O. rewrite <-E. auto.
        -- rewrite E. rewrite (remove_count_false a); auto.
Qed.

Lemma any_count_true {A: Type} (l: list A) (p: A -> bool) :
  (count p l <> 0) <-> (any p l = true).
Proof.
  split; intro H.
  - induction l.
    + cbn in *. contradiction.
    + cbn in *. destruct (p a) eqn: e; auto.
  - intro C. induction l.
    + cbn in *. discriminate.
    + cbn in *. destruct (p a) eqn: e; try discriminate. apply IHl; auto.
Qed.

Lemma any_count_false {A: Type} (l: list A) (p: A -> bool) :
  (count p l = 0) <-> (any p l = false).
Proof.
  split; intro H.
  - induction l; auto. cbn in *. destruct (p a) eqn: e; auto; try discriminate.
  - induction l; auto. cbn in *. destruct (p a) eqn: e; auto; try discriminate.
Qed.

Theorem unique_dedup_perm {A: Type} `{LinearOrder A} (l l': list A) :
  Elem_eq l l' -> Deduplicated l -> Deduplicated l' -> permutation l l'.
Proof.
  rewrite dup_def_eq, dup_def_eq. rewrite perm_eqf_iff.
  unfold Elem_eq, LDeduplicated. intros eq d1 d2 x.
  specialize (eq (eqf x)). destruct (any (eqf x) l) eqn:I1; destruct (any (eqf x) l') eqn:I2; try discriminate.
  - rewrite <- any_count_true in I1. rewrite <- any_count_true in I2.
    rewrite <- in_count_not_O in I1. rewrite <- in_count_not_O in I2. rewrite d1, d2; auto.
  - rewrite <- any_count_false in I1. rewrite <- any_count_false in I2. rewrite I1, I2. auto.
Qed.

Theorem deduo_sort_uniquenss {A: Type} `{LinearOrder A} (l l': list A) : Elem_eq l l' ->
  Sorted l -> Sorted l' -> Deduplicated l -> Deduplicated l' -> l = l'.
Proof.
  intros e_eq s1 s2 d1 d2. apply unique_sorted; auto. apply unique_dedup_perm; auto.
Qed.

(* normal function *)

Definition normalzation {A: Type} (f: A -> A) :=
  forall x: A, f x = f (f x).

Theorem DSort_normal {A: Type} `{LinearOrder A} : normalzation DSort.
Proof.
  red. intros l. apply deduo_sort_uniquenss.
  - apply same_elements_DSort.
  - apply sorted_DSort.
  - apply sorted_DSort.
  - rewrite dup_def_eq. apply dedup_DSort.
  - rewrite dup_def_eq. apply dedup_DSort.
Qed.

Class equivalance_relation {A: Type} (R: A -> A -> Prop) := equiv_proof {
  equiv_refl  : forall x: A, R x x;
  equiv_sym   : forall x y: A, R x y -> R y x;
  equiv_trans : forall x y z: A, R x y -> R y z -> R x z;
}.

Theorem eq_elem_equiv {A: Type} : equivalance_relation (Elem_eq (A := A)).
Proof.
  apply equiv_proof.
  - intros x p. reflexivity.
  - intros x y eq p. rewrite eq. reflexivity.
  - intros x y z eq1 eq2 p. rewrite eq1, eq2. reflexivity.
Qed.


Require Export Base.Categories.

Section monoepi.
Context {C: Category}.

Definition monic {a b: C} (f: a ~> b) :=
  forall c (g1 g2: c ~> a), f ∘ g1 = f ∘ g2 -> g1 = g2.

Definition epic {a b: C} (f: a ~> b) :=
  forall c (g1 g2: b ~> c), g1 ∘ f = g2 ∘ f -> g1 = g2.

Definition splitmonic {a b: C} (f: a ~> b) :=
  exists f': b ~> a, f' ∘ f = id a.

Definition splitepic {a b: C} (f: a ~> b) :=
  exists f': b ~> a, f ∘ f' = id b.

Lemma splitmonic_is_monic {a b: C} (f: a ~> b): splitmonic f -> monic f.
Proof.
  intros [f' Hf] c g1 g2 H.
  setoid_rewrite <- comp_id_l.
  rewrite <- Hf.
  rewrite <- !comp_assoc.
  now f_equal.
Qed.

Lemma splitepic_is_epic {a b: C} (f: a ~> b): splitepic f -> epic f.
Proof.
  intros [f' Hf] c g1 g2 H.
  setoid_rewrite <- comp_id_r.
  rewrite <- Hf.
  rewrite !comp_assoc.
  now f_equal.
Qed.

Lemma monic_id (a: C): monic (id a).
Proof.
  intros x f g H.
  now setoid_rewrite <- comp_id_l.
Qed.

Lemma epic_id (a: C): epic (id a).
Proof.
  intros x f g H.
  now setoid_rewrite <- comp_id_r.
Qed.

Lemma splitmonic_id (a: C): splitmonic (id a).
Proof.
  exists (id a).
  apply comp_id_l.
Qed.

Lemma splitepic_id (a: C): splitepic (id a).
Proof.
  exists (id a).
  apply comp_id_l.
Qed.

Lemma monic_comp {a b c: C} (f: b ~> c) (g: a ~> b): monic f -> monic g -> monic (f ∘ g).
Proof.
  intros Hf Hg x h1 h2 H.
  apply Hg, Hf.
  now rewrite !comp_assoc.
Qed.

Lemma epic_comp {a b c: C} (f: b ~> c) (g: a ~> b): epic f -> epic g -> epic (f ∘ g).
Proof.
  intros Hf Hg x h1 h2 H.
  apply Hf, Hg.
  now rewrite <- !comp_assoc.
Qed.

Lemma splitmonic_comp {a b c: C} (f: b ~> c) (g: a ~> b): splitmonic f -> splitmonic g -> splitmonic (f ∘ g).
Proof.
  intros [f' Hf] [g' Hg].
  exists (g' ∘ f').
  rewrite comp_assoc, <- (comp_assoc g').
  rewrite Hf, comp_id_r.
  apply Hg.
Qed.

Lemma splitepic_comp {a b c: C} (f: b ~> c) (g: a ~> b): splitepic f -> splitepic g -> splitepic (f ∘ g).
Proof.
  intros [f' Hf] [g' Hg].
  exists (g' ∘ f').
  rewrite comp_assoc, <- (comp_assoc f).
  rewrite Hg, comp_id_r.
  apply Hf.
Qed.

Lemma monic_comp_r {a b c: C} (f: b ~> c) (g: a ~> b): monic (f ∘ g) -> monic g.
Proof.
  intros Hc x h1 h2 H.
  apply Hc.
  rewrite <- !comp_assoc.
  now f_equal.
Qed.

Lemma epic_comp_l {a b c: C} (f: b ~> c) (g: a ~> b): epic (f ∘ g) -> epic f.
Proof.
  intros Hc x h1 h2 H.
  apply Hc.
  rewrite !comp_assoc.
  now f_equal.
Qed.

Lemma splitmonic_comp_r {a b c: C} (f: b ~> c) (g: a ~> b): splitmonic (f ∘ g) -> splitmonic g.
Proof.
  intros [h H].
  exists (h ∘ f).
  now rewrite <- comp_assoc.
Qed.

Lemma splitepic_comp_l {a b c: C} (f: b ~> c) (g: a ~> b): splitepic (f ∘ g) -> splitepic f.
Proof.
  intros [h H].
  exists (g ∘ h).
  now rewrite comp_assoc.
Qed.

End monoepi.

Module Isomorphism.

Structure mixin_of {C: Category} {x y: C} (f: x ~> y) := Mixin {
  inv: y ~> x;
  inv_l: inv ∘ f = id x;
  inv_r: f ∘ inv = id y;
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.
Context {C: Category} {x y: C}.

Structure type := Pack { morphism: x ~> y; _: class_of morphism }.
Local Coercion morphism: type >-> hom.

Variable (i: type).
Definition class := match i return class_of i with Pack _ c => c end.

End ClassDef.

Module Exports.

Arguments type {_} _ _.
Coercion morphism: type >-> hom.
Notation to := morphism.
Notation iso := type.

End Exports.

End Isomorphism.

Export Isomorphism.Exports.

Section iso.
Context {C: Category} {x y: C} (i: iso x y).

Definition from: y ~> x := Isomorphism.inv i (Isomorphism.class i).

Lemma from_to: from ∘ i = id x.
Proof. apply Isomorphism.inv_l. Qed.
Lemma to_from: i ∘ from = id y.
Proof. apply Isomorphism.inv_r. Qed.

Definition inv_mixin: Isomorphism.mixin_of from :=
  Isomorphism.Mixin _ _ _ from i to_from from_to.

Global Canonical inv: iso y x :=
  Isomorphism.Pack from inv_mixin.

Lemma inv_l: inv ∘ i = id x.
Proof. apply Isomorphism.inv_l. Qed.

Lemma inv_r: i ∘ inv = id y.
Proof. apply Isomorphism.inv_r. Qed.

End iso.

Infix "<~>" := iso (at level 70, no associativity).
Notation "i '⁻¹'" := (inv i) (at level 9).

Definition id_iso_mixin {C: Category} (x: C): Isomorphism.mixin_of (id x) :=
  Isomorphism.Mixin C x x (id x) (id x) (comp_id_l (id x)) (comp_id_l (id x)).

Canonical id_iso {C: Category} (x: C): x <~> x :=
  Isomorphism.Pack (id x) (id_iso_mixin x).

Section Comp_iso.
Context {C: Category} {x y z: C} (i: y <~> z) (j: x <~> y).

Lemma comp_inv_l: j⁻¹ ∘ i⁻¹ ∘ (i ∘ j) = id x.
Proof.
  rewrite comp_assoc.
  rewrite <- (comp_assoc (j⁻¹)).
  rewrite inv_l, comp_id_r.
  apply inv_l.
Qed.

Lemma comp_inv_r: i ∘ j ∘ (j⁻¹ ∘ i⁻¹) = id z.
Proof.
  rewrite comp_assoc.
  rewrite <- (comp_assoc i).
  rewrite inv_r, comp_id_r.
  apply inv_r.
Qed.

Definition iso_comp_mixin: Isomorphism.mixin_of (i ∘ j) :=
  Isomorphism.Mixin _ _ _ (i ∘ j) (j⁻¹ ∘ i⁻¹) comp_inv_l comp_inv_r.

Global Canonical iso_comp: iso x z :=
  Isomorphism.Pack (i ∘ j) iso_comp_mixin.

End Comp_iso.

Infix "·" := iso_comp (at level 40, left associativity).

Lemma iso_eq {C: Category} {x y: C} (i j: x <~> y): i = j <-> to i = to j.
Proof.
  split; intro H.
  now subst j.
  destruct i as [f [f' Hf1 Hf2]], j as [g [g' Hg1 Hg2]].
  simpl in H.
  subst g.
  f_equal.
  enough (f' = g').
  subst g'.
  f_equal.
  1, 2: apply proof_irrelevance.
  rewrite <- (comp_id_r f').
  rewrite <- Hg2.
  rewrite comp_assoc.
  rewrite Hf1.
  apply comp_id_l.
Qed.

Lemma icomp_assoc {C: Category} {a b c d: C} (f: c <~> d) (g: b <~> c) (h: a <~> b): f · (g · h) = (f · g) · h.
Proof.
  apply iso_eq; simpl.
  apply comp_assoc.
Qed.

Lemma icomp_id_l {C: Category} {x y: C} (i: x <~> y): id_iso y · i = i.
Proof.
  apply iso_eq; simpl.
  apply comp_id_l.
Qed.

Lemma icomp_id_r {C: Category} {x y: C} (i: x <~> y): i · id_iso x = i.
Proof.
  apply iso_eq; simpl.
  apply comp_id_r.
Qed.

Lemma icomp_inv_l {C: Category} {x y: C} (i: x <~> y): i⁻¹ · i = id_iso x.
Proof.
  apply iso_eq; simpl.
  apply from_to.
Qed.

Lemma icomp_inv_r {C: Category} {x y: C} (i: x <~> y): i · i⁻¹ = id_iso y.
Proof.
  apply iso_eq; simpl.
  apply to_from.
Qed.

Definition isomorphic (C: Category) (X Y: C) := inhabited (X <~> Y).

Infix "≃" := (isomorphic _) (at level 70).

Instance isomorphic_equiv C: Equivalence (isomorphic C).
Proof.
  constructor.
  + intros x.
    constructor.
    exact (id_iso x).
  + intros x y H.
    destruct H as [i].
    constructor.
    exact (i⁻¹).
  + intros x y z H H0.
    destruct H as [i], H0 as [j].
    constructor.
    eapply iso_comp; eassumption.
Qed.

Definition eq_iso {C: Category} {X Y: C} (e: X = Y): X <~> Y :=
  match e in (_ = y) return (X <~> y) with
  | eq_refl => id_iso X
  end.

Theorem eq_iso_refl {C: Category} {X: C} (e: X = X): eq_iso e = id_iso X.
Proof.
  unfold eq_iso.
  assert (e = eq_refl).
  apply proof_irrelevance.
  subst e.
  reflexivity.
Qed.

Definition is_iso {C: Category} {X Y: C} (f: X ~> Y) :=
  exists g: Y ~> X, g ∘ f = id X /\ f ∘ g = id Y.

Lemma is_iso_ex {C: Category} {X Y: C} (f: X ~> Y): is_iso f -> exists i: X <~> Y, to i = f.
Proof.
  intros [g [Hl Hr]].
  exists (Isomorphism.Pack f (Isomorphism.Mixin _ _ _ f g Hl Hr)).
  reflexivity.
Qed.

Lemma is_isomorphic {C: Category} {X Y: C} (f: X ~> Y): is_iso f -> X ≃ Y.
Proof.
  intros H.
  apply is_iso_ex in H.
  destruct H as [i H].
  constructor.
  exact i.
Qed.

Lemma is_iso_id {C: Category} {x: C}: is_iso (id x).
Proof.
  exists (id x).
  split.
  all: apply comp_id_l.
Qed.

Lemma is_iso_comp {C: Category} {X Y Z: C} (g: Y ~> Z) (f: X ~> Y): is_iso g -> is_iso f -> is_iso (g ∘ f).
Proof.
  intros [g' [Hgl Hgr]] [f' [Hfl Hfr]].
  exists (f' ∘ g'); split.
  all: rewrite comp_assoc.
  rewrite <- (comp_assoc f').
  rewrite Hgl, comp_id_r.
  apply Hfl.
  rewrite <- (comp_assoc g).
  rewrite Hfr, comp_id_r.
  apply Hgr.
Qed.

Definition is_eq {C: Category} {X Y: C} (f: X ~> Y) :=
  exists e: X = Y, f = eq_iso e.

Lemma iso_is_iso {C: Category} {X Y: C} (f: X <~> Y): is_iso f.
Proof.
  exists (f⁻¹).
  split.
  apply inv_l.
  apply inv_r.
Qed.

Lemma is_eq_is_iso {C: Category} {X Y: C} (f: X ~> Y): is_eq f -> is_iso f.
Proof.
  intros [e H].
  subst f.
  apply iso_is_iso.
Qed.

Lemma eq_iso_is_eq {C: Category} {X Y: C} (e: X = Y): is_eq (eq_iso e).
Proof. now exists e. Qed.

Lemma is_eq_refl {C: Category} {X: C} (η: X ~> X): is_eq η -> η = id X.
Proof.
  intros [e1 H1].
  subst η.
  now rewrite eq_iso_refl.
Qed.

Lemma is_eq_unique {C: Category} {X Y: C} (η ϵ: X ~> Y): is_eq η -> is_eq ϵ -> η = ϵ.
Proof.
  intros [e1 H1] [e2 H2].
  subst η ϵ.
  do 2 f_equal.
  apply proof_irrelevance.
Qed.

Lemma is_eq_unique_iso {C: Category} {X Y: C} (η ϵ: X <~> Y): is_eq η -> is_eq ϵ -> η = ϵ.
Proof.
  intros Hη Hϵ.
  now apply iso_eq, is_eq_unique.
Qed.

Lemma is_eq_id {C: Category} {X: C}: is_eq (id X).
Proof. now exists eq_refl. Qed.

Lemma is_eq_comp {C: Category} {X Y Z: C} (ϵ: Y ~> Z) (η: X ~> Y): is_eq η -> is_eq ϵ -> is_eq (ϵ ∘ η).
Proof.
  intros [e1 H1] [e2 H2].
  subst η ϵ Y Z.
  simpl.
  rewrite comp_id_l.
  apply is_eq_id.
Qed.

Lemma is_eq_inv {C: Category} {X Y: C} (η: X <~> Y): is_eq η -> is_eq η⁻¹.
Proof.
  intros [e H].
  apply iso_eq in H.
  subst η Y.
  apply is_eq_id.
Qed.

Theorem iso_is_splitmonic {C: Category} {x y: C} (i: x <~> y): splitmonic i.
Proof.
  exists (i⁻¹).
  apply inv_l.
Qed.

Theorem iso_is_splitepic {C: Category} {x y: C} (i: x <~> y): splitepic i.
Proof.
  exists (i⁻¹).
  apply inv_r.
Qed.

Theorem iso_monic {C: Category} {x y: C} (i: x <~> y): monic i.
Proof.
  apply splitmonic_is_monic.
  apply iso_is_splitmonic.
Qed.

Theorem iso_epic {C: Category} {x y: C} (i: x <~> y): epic i.
Proof.
  apply splitepic_is_epic.
  apply iso_is_splitepic.
Qed.

Theorem is_iso_is_splitmonic {C: Category} {x y: C} (f: x ~> y): is_iso f -> splitmonic f.
Proof.
  intros [f' [H _]].
  now exists (f').
Qed.

Theorem is_iso_is_splitepic {C: Category} {x y: C} (f: x ~> y): is_iso f -> splitepic f.
Proof.
  intros [f' [_ H]].
  now exists (f').
Qed.

Theorem is_iso_monic {C: Category} {x y: C} (f: x ~> y): is_iso f -> monic f.
Proof.
  intros H.
  apply splitmonic_is_monic, is_iso_is_splitmonic, H.
Qed.

Theorem is_iso_epic {C: Category} {x y: C} (f: x ~> y): is_iso f -> epic f.
Proof.
  intros H.
  apply splitepic_is_epic, is_iso_is_splitepic, H.
Qed.

Theorem splitmonic_epic {C: Category} {x y: C} (f: x ~> y): splitmonic f -> epic f -> is_iso f.
Proof.
  intros [g inv_l] H.
  exists g; split.
  exact inv_l.
  apply H.
  rewrite <- comp_assoc, comp_id_l.
  rewrite inv_l.
  apply comp_id_r.
Qed.

Theorem splitepic_monic {C: Category} {x y: C} (f: x ~> y): splitepic f -> monic f -> is_iso f.
Proof.
  intros [g inv_r] H.
  exists g; split.
  apply H.
  rewrite comp_assoc, comp_id_r.
  rewrite inv_r.
  apply comp_id_l.
  exact inv_r.
Qed.

Theorem is_iso_comp_l {C: Category} {x y z: C} (f: y ~> z) (g: x ~> y): is_iso (f ∘ g) -> is_iso g -> is_iso f.
Proof.
  intros [c Hc] [g' Hg].
  exists (g ∘ c); split.
  rewrite <- (comp_id_r _).
  rewrite <- (proj2 Hg).
  rewrite <- !(comp_assoc g).
  f_equal.
  rewrite comp_assoc, <- (comp_assoc c).
  rewrite (proj1 Hc).
  apply comp_id_l.
  now rewrite comp_assoc.
Qed.

Theorem is_iso_comp_r {C: Category} {x y z: C} (f: y ~> z) (g: x ~> y): is_iso (f ∘ g) -> is_iso f -> is_iso g.
Proof.
  intros [c Hc] [f' Hf].
  exists (c ∘ f); split.
  now rewrite <- comp_assoc.
  rewrite <- (comp_id_l _).
  rewrite <- (proj1 Hf).
  rewrite <- comp_assoc.
  f_equal.
  rewrite !comp_assoc.
  rewrite (proj2 Hc).
  apply comp_id_l.
Qed.

Definition co_iso_mixin {C: Category} {x y: C} (i: x <~> y): Isomorphism.mixin_of (from i: @hom (co C) x y) :=
  Isomorphism.Mixin (co C) x y (from i) (to i) (from_to i) (to_from i).

Definition co_iso {C: Category} {x y: C} (i: x <~> y): (x: co C) <~> y :=
  Isomorphism.Pack _ (co_iso_mixin i).

Definition co_iso_mixin' {C: Category} {x y: C} (i: (x: co C) <~> y): Isomorphism.mixin_of (from i: x ~> y) :=
  Isomorphism.Mixin C x y (from i) (to i) (from_to i) (to_from i).

Definition co_iso' {C: Category} {x y: C} (i: (x: co C) <~> y): x <~> y :=
  Isomorphism.Pack _ (co_iso_mixin' i).

Theorem iso_co {C: Category} (x y: C): (x: co C) ≃ y <-> x ≃ y.
  split.
  + intros [i].
    constructor.
    apply co_iso', i.
  + intros [i].
    constructor.
    apply co_iso, i.
Qed.

Lemma is_iso_co {C: Category} {x y: C} (f: x ~> y): is_iso (f: (y: co C) ~> x) <-> is_iso f.
Proof.
  split.
  all: intros [g [Hl Hr]].
  all: exists g; split.
  1, 3: exact Hr.
  all: exact Hl.
Qed.

Lemma is_iso_co' {C: Category} {x y: C} (f: (x: co C) ~> y): is_iso (f: y ~> x) <-> is_iso f.
Proof.
  split.
  all: intros [g [Hl Hr]].
  all: exists g; split.
  1, 3: exact Hr.
  all: exact Hl.
Qed.

Lemma monic_co {C: Category} {x y: C} (f: x ~> y): monic f <-> epic (f: (y: co C) ~> x).
Proof. reflexivity. Qed.

Lemma epic_co {C: Category} {x y: C} (f: x ~> y): epic f <-> monic (f: (y: co C) ~> x).
Proof. reflexivity. Qed.

Lemma monic_co' {C: Category} {x y: C} (f: (x: co C) ~> y): monic (f: y ~> x) <-> epic f.
Proof. reflexivity. Qed.

Lemma epic_co' {C: Category} {x y: C} (f: (x: co C) ~> y): epic (f: y ~> x) <-> monic f.
Proof. reflexivity. Qed.

Lemma splitmonic_co {C: Category} {x y: C} (f: x ~> y): splitmonic f <-> splitepic (f: (y: co C) ~> x).
Proof. reflexivity. Qed.

Lemma splitepic_co {C: Category} {x y: C} (f: x ~> y): splitepic f <-> splitmonic (f: (y: co C) ~> x).
Proof. reflexivity. Qed.

Lemma splitmonic_co' {C: Category} {x y: C} (f: (x: co C) ~> y): splitmonic (f: y ~> x) <-> splitepic f.
Proof. reflexivity. Qed.

Lemma splitepic_co' {C: Category} {x y: C} (f: (x: co C) ~> y): splitepic (f: y ~> x) <-> splitmonic f.
Proof. reflexivity. Qed.

Lemma is_eq_co {C: Category} {x y: C} (f: x ~> y): is_eq f <-> is_eq (f: (y: co C) ~> x).
Proof.
  split.
  all: intros [e H].
  all: subst f y.
  all: exact is_eq_id.
Qed.

Lemma co_eq_iso {C: Category} {x y: C} (e: x = y): to (@eq_iso (co C) x y e) = to (eq_iso e)⁻¹.
Proof. now destruct e. Qed.

Definition eunique {C: Category} (P: C -> Prop) (x: C) :=
  Proper (isomorphic C ==> iff) P /\
  P x /\ forall x', P x' -> x ≃ x'.

Definition euniqueness {C: Category} (P: C -> Prop) :=
  forall x y, P x -> P y -> x ≃ y.

Notation "'exists' !! x .. y , p" :=
  (ex (eunique (fun x => .. (ex (eunique (fun y => p))) ..)))
  (at level 200, x binder, right associativity,
    format "'[' 'exists' !! '/ ' x .. y , '/ ' p ']'"): type_scope.

Instance euniqueness_impl (C: Category): Proper (flip (pointwise_relation C impl) ==> impl) euniqueness.
Proof.
  intros P Q PQ H x y Hx Hy.
  apply H.
  all: now apply PQ.
Qed.

Instance euniqueness_iff (C: Category): Proper (pointwise_relation C iff ==> iff) euniqueness.
Proof.
  intros P Q H.
  split.
  all: change (?P -> ?Q) with (impl P Q).
  all: f_equiv.
  all: intros x.
  exact (proj2 (H x)).
  exact (proj1 (H x)).
Qed.

Instance eunique_iff (C: Category): Proper (pointwise_relation C iff ==> isomorphic C ==> iff) eunique.
Proof.
  enough (Proper (pointwise_relation C iff ==> isomorphic C ==> impl) eunique).
  now split; apply H.
  intros P Q PQ x y xy [PP [H u]].
  split; [| split].
  intros a b H1.
  rewrite <- PQ.
  now apply PP.
  apply PQ.
  now rewrite <- xy.
  intros y' H'.
  rewrite <- xy.
  apply u, PQ, H'.
Qed.

Lemma eunique_existence {C: Category} (P: C -> Prop): (Proper (isomorphic C ==> iff) P /\ (exists x, P x) /\ euniqueness P) <-> exists!! x, P x.
Proof.
  split.
  + intros [PP [[x H] u]].
    exists x; split.
    2: split.
    1, 2: assumption.
    intros y Hy.
    now apply u.
  + intros [x [PP [H u]]].
    split.
    2: split.
    exact PP.
    now exists x.
    intros y z Hy Hz.
    transitivity x.
    symmetry.
    all: now apply u.
Qed.

Lemma forall_exists_eunique_domain_coincide {C: Category} (P:C->Prop): (exists!! x, P x) -> forall Q: C -> Prop,
  Proper (isomorphic C ==> iff) Q ->
  (forall x, P x -> Q x) <-> (exists x, P x /\ Q x).
Proof.
  intros [x [PP [Hx u]]] Q PQ.
  split.
  + intros H.
    exists x; split.
    exact Hx.
    apply H, Hx.
  + intros [y [Hy]] z Hz.
    rewrite <- (u z Hz).
    rewrite (u y Hy).
    exact H.
Qed.

Lemma forall_exists_coincide_unique_domain {C: Category} (P: C -> Prop): Proper (isomorphic C ==> iff) P ->
  (forall Q: C -> Prop, Proper (isomorphic C ==> iff) Q -> (forall x, P x -> Q x) <-> (exists x, P x /\ Q x))
  -> (exists!! x, P x).
Proof.
  intros PP H.
  destruct (proj1 (H P PP)) as [x [Hx _]].
  easy.
  exists x; split; [| split].
  1, 2: assumption.
  apply H.
  intros y z yz.
  now f_equiv.
  now exists x.
Qed.


Require Import LogicalRelations.
Require Import Coq.Lists.List.
Local Open Scope rel_scope.

(** * Tests *)

(** ** Reflexivity *)

Goal
  forall A (a: A), a = a.
Proof.
  intros.
  rauto.
Qed.

Goal
  forall A (a: A), exists b, b = a.
Proof.
  intros; eexists.
  monotonicity.
Qed.

(** ** Setoid rewriting *)

Goal
  forall A (a b: A) `(HR: Equivalence A) (H: R a b),
    sum_rel R R (inl a) (inl b).
Proof.
  intros.
  rewrite H.
  rewrite <- H.
  reflexivity.
Qed.

(** There is an issue with the following. *)

Goal
  forall A (a b: A) (R: rel A A) (f: A -> A) (p: A -> Prop),
    Monotonic f (R ++> R) ->
    Monotonic p (R --> impl) ->
    R a b ->
    p (f b) ->
    p (f a).
Proof.
  intros A a b R f p Hf Hp Hab H.
  Fail rewrite <- Hab in H.
Abort.

(** ** Monotonicity tactics *)

(** Basic sanity check. This has actually failed in the past due to
  [context_candidate] being too liberal and selecting the [RB]
  property instead of [RA], then going nowhere with that with no
  backtracking implemented yet. *)

Goal
  forall A B (RA: rel A A) (x y: A) (RB: rel B B) (z t: B),
    RA x y ->
    RB z t ->
    RA x y.
Proof.
  intros.
  rauto.
Qed.

Goal
  forall A (a b: A) (R: rel A A) (H: R a b),
    let f (x y: A * A) := (@pair (A+A) (A+A) (inr (fst x)) (inl (snd y))) in
    Monotonic f (R * ⊤ ++> ⊤ * R ++> (⊥ + R) * (R + ⊥))%rel.
Proof.
  intros; unfold f.
  rauto.
Qed.

Goal
  forall {A1 A2 B1 B2} (R1 R1': rel A1 A2) (R2 R2': rel B1 B2),
    subrel R1' R1 ->
    subrel R2 R2' ->
    subrel (R1 ++> R2) (R1' ++> R2').
Proof.
  do 10 intro.
  rauto.
Qed.

(** Check that we can use relational hypotheses from the context as
  well as [Monotonic]/[Related] instances. *)

Goal
  forall
    {A B} (R: rel A A)
    (op: A -> B) (Hop: (R ++> eq) op op)
    (x y: A) (Hxy: R x y),
    op x = op y.
Proof.
  intros.
  rauto.
Qed.

(** Bug with relational parametricity: you can't [RElim] a relation
  you don't know yet. *)

Goal
  forall {A B} (RA: rel A A) (RB: rel B B) (m n: (A -> B) * B) (x y: A),
    ((- ==> RB) * RB)%rel m n ->
    RB (fst m x) (fst n x).
Proof.
  intros A B RA RB m n x y Hmn.
  try monotonicity.
  try rauto.
Abort.

(** Pattern matching *)

Goal
  forall {A B} (RA: rel A A) (RB: rel B B) (x y: A) (f: A -> A + B),
    RA x y ->
    (RA ++> RA + RB) f f ->
    RA (match f x with inl a => a | inr b => x end)
       (match f y with inl a => a | inr b => y end).
Proof.
  intros.
  rauto.
Qed.

Goal
  forall {A B} (RA: rel A A) (RB: rel B B) (x y: A * B) (z: A),
    RA z z ->
    prod_rel RA RB x y ->
    RA (let (a, b) := x in z)
       (let (a, b) := y in z).
Proof.
  intros.
  rauto.
Qed.

Goal
  forall {A} (R: rel A A),
    Monotonic
      (fun (b: bool) x y => if b then x else y)
      (- ==> R ++> R ++> R).
Proof.
  intros.
  rauto.
Qed.

Goal
  forall {A} (R : rel A A) (b : bool) (x y : A),
    b = b ->
    R x x ->
    R y y ->
    R (if b then x else y)
      (if b then x else y).
Proof.
  intros.
  rauto.
Qed.

(** [rel_curry] *)

Goal
  forall {A B C} R R' S (f: A -> B -> B -> C) (x1 y1: A) (x2 y2: B),
    Monotonic f (rel_curry (R ++> R' ++> S)) ->
    S (f x1 x2 x2) (f y1 y2 y2).
Proof.
  intros A B C R R' S f x1 y1 x2 y2 Hf.
  monotonicity.
Abort.

(** *** Hypotheses from the context *)

(* This used to fail because [Hyy] would
  shadow [Hxy] (the hypothesis we want). *)

Goal
  forall {A} (R: rel A A) (x y: A),
    R x y -> eq y y -> R x y.
Proof.
  intros A R x y Hxy Hyy.
  monotonicity.
Qed.

(* This still fail with Coq 8.5, but Coq 8.6 is able to backtrack and
  try hypothesis from the context beyond the first one it finds. *)

Goal
  forall {A} (R: rel A A) (x y: A),
    R x y -> eq x y -> R x y.
Proof.
  intros A R x y Hxy Hyy.
  try monotonicity.
Abort.

(** This used to fail because the flipped hypothesis would not be
  identified as a candidate. This is important because the constraints
  generated by the setoid rewriting system often have this form. *)

Goal
  forall {A} (R: rel A A) (f : A -> A),
    Monotonic f (R ++> R) ->
    (flip R ++> flip R) f f.
Proof.
  intros A R f Hf.
  rauto.
Qed.

(** *** [impl] vs. [subrel] *)

(** This checks that a relational property written in terms of
  [subrel] can be used to solve a goal stated in terms of [impl].
  This is made possible by [subrel_impl_relim]. *)

Goal
  forall A B C (R: rel A A) (f: A -> rel B C) a1 a2 b c,
    Monotonic f (R ++> subrel) ->
    R a1 a2 ->
    impl (f a1 b c) (f a2 b c).
Proof.
  intros A B C R f a1 a2 b c Hf Ha.
  monotonicity; rauto.
Qed.

Goal
  forall A1 A2 B1 B2 (R1 R2: rel A1 A2) (R: rel B1 B2),
    subrel R1 R2 ->
    forall x y,
      (R2 ++> R) x y ->
      (R1 ++> R) x y.
Proof.
  intros A1 A2 B1 B2 R1 R2 R HR12 x y.
  rauto.
Qed.

(** *** Generic rules *)

(** The [coreflexivity] of [rel_prod] and [eq] makes it possible for
  [pair_rel] to behave in the same way as [f_equal] below, since they
  allow us to deduce that [eq * eq] is a [subrel] of [eq]. *)

Goal
  forall A B (x1 x2 : A) (y1 y2 : B),
    x1 = x2 -> y1 = y2 -> (x1, y1) = (x2, y2).
Proof.
  intros.
  rauto.
Qed.

(** ** Using [foo_subrel] instances *)

(** Still broken because of the interaction between [subrel] and
  [- ==> - ==> impl] (or lack thereof) *)

Goal
  forall A1 A2 B1 B2 C1 C2 (R1 R2: rel A1 A2) (R1': rel B1 B2) (R: rel C1 C2),
    subrel R1 R2 ->
    forall x y,
      (R2 ++> R) x y ->
      (R1 ++> R) x y.
Proof.
  intros A1 A2 B1 B2 C1 C2 R1 R2 R1' R HR12 x y H.
  rewrite HR12.
  assumption.
Qed.

Goal
  forall A B (xa1 xa2 ya1 ya2 : A) (xb1 xb2 yb1 yb2 : B)
         (opA: A -> A -> A) (opB: B -> B -> B)
         (RA: rel A A) (RB: rel B B)
         (HopA: Monotonic opA (RA ++> RA ++> RA))
         (HopB: Monotonic opB (RB ++> RB ++> RB))
         (Hxa: RA xa1 xa2)
         (Hxb: RB xb1 xb2)
         (Hya: RA ya1 ya2)
         (Hyb: RB yb1 yb2),
    (RA * RB)%rel
      (opA xa1 ya1, opB xb1 yb1)
      (opA xa2 ya2, opB xb2 yb2).
Proof.
  intros.
  rauto.
Qed.

Goal
  forall A1 A2 B1 B2 C1 C2 (R1 R2: rel A1 A2) (R1': rel B1 B2) (R: rel C1 C2),
    subrel R1 R2 ->
    forall x y,
      (R2 * R1' ++> R) x y ->
      (R1 * R1' ++> R) x y.
Proof.
  intros A1 A2 B1 B2 C1 C2 R1 R2 R1' R HR12 x y H.
  rewrite HR12.
  assumption.
Qed.

(** ** The [rgraph] tactic *)

Goal
  forall {A} (R S T: rel A A),
    subrel R S ->
    subrel S R ->
    subrel S T ->
    subrel R T.
Proof.
  intros.
  rstep.
Qed.

Goal
  forall `(PER) (x y z t : A),
    R x y ->
    R z y ->
    R z t ->
    R t x.
Proof.
  intros.
  rstep.
Qed.

(** ** The [transport] tactic *)

Goal
  forall W acc A B C (R1: W -> rel A A) (R2: W -> rel B B) (R3: W -> rel C C) f g a b x w,
    Monotonic f (rforall w, R1 w ++> R2 w) ->
    Monotonic g (rforall w, R2 w ++> option_rel (rel_incr acc R3 w)) ->
    R1 w a b ->
    g (f a) = Some x ->
    exists y, rel_incr acc R3 w x y.
Proof.
  intros.
  transport H2.
  eexists.
  rauto.
Qed.

(** ** Tests for specific relators *)

(** *** [list_rel] *)

(** [list_subrel] use to not work because of a missing [Params] declaration. *)

Goal
  forall A B (R R': rel A B) l1 l2 x y,
    subrel R R' ->
    list_rel R l1 l2 ->
    R' x y ->
    list_rel R' (x :: l1) (y :: l2).
Proof.
  intros.
  rauto.
Qed.

(** *** [rel_pull] *)

(** The [RIntro] instance for [rel_pull] used to be less general. *)

Goal
  forall A B (f: A -> B) (R: rel B B) x y,
    R (f x) (f y) ->
    (R @@ f) x y.
Proof.
  intros.
  rauto.
Qed.

(** We don't want the introduction rule for [rel_pull] to shadow
  relational properties. *)

Lemma rel_pull_2:
  forall A B (f: A -> B) (R: rel B B) (g: A -> A) x y,
    Monotonic g (⊤ ==> R @@ f) ->
    (R @@ f) (g x) (g y).
Proof.
  intros.
  rauto.
Qed.

(** *** [rel_all] *)

Lemma rel_all_1:
  forall {A} (x: A),
    (rforall a, req a) x x -> forall a, req a x x.
Proof.
  intros.
  rauto.
Qed.

(** *** [rel_ex] *)

Lemma rel_ex_1:
  forall {A} (x: A),
    (rexists a, req a) x x.
Proof.
  intros.
  rauto.
Qed.


Set Universe Polymorphism.

Section Graph.

Class Graph := {
  Vertex : Type;
  Edge : Vertex -> Vertex -> Type
}.

Context `{Graph}.

Inductive Path : Vertex -> Vertex -> Type :=
| refl {a} : Path a a
| step  {a b c} : Edge a b -> Path b c -> Path a c.

End Graph.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Datatypes.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Set Implicit Arguments.

Require Import Notations.
Require Import Logic.
Declare ML Module "nat_syntax_plugin".

(** [unit] is a singleton datatype with sole inhabitant [tt] *)

Inductive unit : Set :=
    tt : unit.

(** [bool] is the datatype of the boolean values [true] and [false] *)

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

Add Printing If bool.

Delimit Scope bool_scope with bool.

Bind Scope bool_scope with bool.

(** Basic boolean operators *)

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

Definition orb (b1 b2:bool) : bool := if b1 then true else b2.

Definition implb (b1 b2:bool) : bool := if b1 then b2 else true.

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

Definition negb (b:bool) := if b then false else true.

Infix "||" := orb : bool_scope.
Infix "&&" := andb : bool_scope.

(*******************************)
(** * Properties of [andb]     *)
(*******************************)

Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true.
Proof.
  destruct a; destruct b; intros; split; try (reflexivity || discriminate).
Qed.
Hint Resolve andb_prop: bool.

Lemma andb_true_intro :
  forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true.
Proof.
  destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
Qed.
Hint Resolve andb_true_intro: bool.

(** Interpretation of booleans as propositions *)

Inductive eq_true : bool -> Prop := is_eq_true : eq_true true.

Hint Constructors eq_true : eq_true.

(** Another way of interpreting booleans as propositions *)

Definition is_true b := b = true.

(** [is_true] can be activated as a coercion by
   (Local) Coercion is_true : bool >-> Prop.
*)

(** Additional rewriting lemmas about [eq_true] *)

Lemma eq_true_ind_r :
  forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true.
Proof.
  intros P b H H0; destruct H0 in H; assumption.
Defined.

Lemma eq_true_rec_r :
  forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true.
Proof.
  intros P b H H0; destruct H0 in H; assumption.
Defined.

Lemma eq_true_rect_r :
  forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true.
Proof.
  intros P b H H0; destruct H0 in H; assumption.
Defined.

(** [nat] is the datatype of natural numbers built from [O] and successor [S];
    note that the constructor name is the letter O.
    Numbers in [nat] can be denoted using a decimal notation;
    e.g. [3%nat] abbreviates [S (S (S O))] *)

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

Delimit Scope nat_scope with nat.
Bind Scope nat_scope with nat.
Arguments Scope S [nat_scope].

(** [Empty_set] has no inhabitant *)

Inductive Empty_set : Set :=.

(** [identity A a] is the family of datatypes on [A] whose sole non-empty
    member is the singleton datatype [identity A a a] whose
    sole inhabitant is denoted [refl_identity A a] *)

Inductive identity (A:Type) (a:A) : A -> Type :=
  identity_refl : identity a a.
Hint Resolve identity_refl: core.

Implicit Arguments identity_ind [A].
Implicit Arguments identity_rec [A].
Implicit Arguments identity_rect [A].

(** [option A] is the extension of [A] with an extra element [None] *)

Inductive option (A:Type) : Type :=
  | Some : A -> option A
  | None : option A.

Implicit Arguments None [A].

Definition option_map (A B:Type) (f:A->B) o :=
  match o with
    | Some a => Some (f a)
    | None => None
  end.

(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)

Inductive sum (A B:Type) : Type :=
  | inl : A -> sum A B
  | inr : B -> sum A B.

Notation "x + y" := (sum x y) : type_scope.

(** [prod A B], written [A * B], is the product of [A] and [B];
    the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)

Inductive prod (A B:Type) : Type :=
  pair : A -> B -> prod A B.

Add Printing Let prod.

Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.

Section projections.
  Variables A B : Type.
  Definition fst (p:A * B) := match p with
				| (x, y) => x
                              end.
  Definition snd (p:A * B) := match p with
				| (x, y) => y
                              end.
End projections.

Hint Resolve pair inl inr: core.

Lemma surjective_pairing :
  forall (A B:Type) (p:A * B), p = pair (fst p) (snd p).
Proof.
  destruct p; reflexivity.
Qed.

Lemma injective_projections :
  forall (A B:Type) (p1 p2:A * B),
    fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2.
Proof.
  destruct p1; destruct p2; simpl in |- *; intros Hfst Hsnd.
  rewrite Hfst; rewrite Hsnd; reflexivity.
Qed.

Definition prod_uncurry (A B C:Type) (f:prod A B -> C)
  (x:A) (y:B) : C := f (pair x y).

Definition prod_curry (A B C:Type) (f:A -> B -> C)
  (p:prod A B) : C := match p with
                       | pair x y => f x y
                       end.

(** Comparison *)

Inductive comparison : Set :=
  | Eq : comparison
  | Lt : comparison
  | Gt : comparison.

Definition CompOpp (r:comparison) :=
  match r with
    | Eq => Eq
    | Lt => Gt
    | Gt => Lt
  end.

Lemma CompOpp_involutive : forall c, CompOpp (CompOpp c) = c.
Proof.
  destruct c; reflexivity.
Qed.

Lemma CompOpp_inj : forall c c', CompOpp c = CompOpp c' -> c = c'.
Proof.
  destruct c; destruct c'; auto; discriminate.
Qed.

Lemma CompOpp_iff : forall c c', CompOpp c = c' <-> c = CompOpp c'.
Proof.
  split; intros; apply CompOpp_inj; rewrite CompOpp_involutive; auto.
Qed.

(** The [CompSpec] inductive will be used to relate a [compare] function
    (returning a comparison answer) and some equality and order predicates.
    Interest: [CompSpec] behave nicely with [case] and [destruct]. *)

Inductive CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop :=
 | CompEq : eq x y -> CompSpec eq lt x y Eq
 | CompLt : lt x y -> CompSpec eq lt x y Lt
 | CompGt : lt y x -> CompSpec eq lt x y Gt.
Hint Constructors CompSpec.

(** For having clean interfaces after extraction, [CompSpec] is declared
    in Prop. For some situations, it is nonetheless useful to have a
    version in Type. Interestingly, these two versions are equivalent.
*)

Inductive CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type :=
 | CompEqT : eq x y -> CompSpecT eq lt x y Eq
 | CompLtT : lt x y -> CompSpecT eq lt x y Lt
 | CompGtT : lt y x -> CompSpecT eq lt x y Gt.
Hint Constructors CompSpecT.

Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c,
 CompSpec eq lt x y c -> CompSpecT eq lt x y c.
Proof.
 destruct c; intros H; constructor; inversion_clear H; auto.
Defined.

(** Identity *)

Definition ID := forall A:Type, A -> A.
Definition id : ID := fun A x => x.

(** Polymorphic lists and some operations *)

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

Implicit Arguments nil [A].
Infix "::" := cons (at level 60, right associativity) : list_scope.
Delimit Scope list_scope with list.
Bind Scope list_scope with list.

Local Open Scope list_scope.

Definition length (A : Type) : list A -> nat :=
  fix length l :=
  match l with
   | nil => O
   | _ :: l' => S (length l')
  end.

(** Concatenation of two lists *)

Definition app (A : Type) : list A -> list A -> list A :=
  fix app l m :=
  match l with
   | nil => m
   | a :: l1 => a :: app l1 m
  end.

Infix "++" := app (right associativity, at level 60) : list_scope.

(* begin hide *)

(* Compatibility *)

Notation prodT := prod (only parsing).
Notation pairT := pair (only parsing).
Notation prodT_rect := prod_rect (only parsing).
Notation prodT_rec := prod_rec (only parsing).
Notation prodT_ind := prod_ind (only parsing).
Notation fstT := fst (only parsing).
Notation sndT := snd (only parsing).
Notation prodT_uncurry := prod_uncurry (only parsing).
Notation prodT_curry := prod_curry (only parsing).

(* end hide *)


(*|

=================================================
Literate programming with Alectryon (Coq input)
=================================================

Alectryon supports literate programs and documents (combinations of
code and prose) written in Coq and reStructuredText.  Here is an
example, written in Coq.

.. image:: coq.png
    :width: 200px
    :align: center
    :height: 100px
    :alt: alternate text

.. math::
   A^\alpha = \left({\phi\over c}, {\bf A}\right)

.. coq:: none
|*)

Require Import Arith.

(*|
Here's an *inductive specification* of evenness:

.. index::
   single: even

.. coq::

|*)

Inductive Even : nat -> Prop :=
| EvenO : Even O
| EvenS : forall n, Even n -> Even (S (S n)).

(*|
… and a corresponding decision procedure:
|*)

Fixpoint even (n: nat): bool :=
  match n with
  | 0 => true
  | 1 => false
  | S (S n) => even n
  end.

(* Ensure that we never unfold [even (S n)] *)
Arguments even : simpl nomatch.

(* no-hyps no-goals unfold *)

(*|
Strengthening the spec
======================
The usual approach is to strengthen the spec to work around the weakness of the inductive principle.
no-hyps no-goals unfold

.. coq::
|*)

Lemma even_Even :
  forall n, (even n = true <-> Even n) /\
       (even (S n) = true <-> Even (S n)). (* .fold *)
Proof. (* .fold *)
  induction n; cbn.
  - (* n ← 0 *)
    repeat split; cbn.
    all: try constructor.
    all: inversion 1.
  - (* n ← S _ *)
    destruct IHn as ((Hne & HnE) & (HSne & HSnE)).
    repeat split; cbn.
    all: eauto using EvenS.
    inversion 1; eauto.
Qed.

(*|
.. coq::
   :class: coq-math-2
|*)

   Notation "\mathbb{B}" := bool.
   Print bool. (* .unfold *)


Require Import Basics.
Require Import Spaces.Pos.
Require Import Spaces.Int.Core.
Require Import Spaces.Int.Spec.

(** ** Iteration of equivalences *)

(** *** Iteration by arbitrary integers *)

Definition int_iter {A} (f : A -> A) `{!IsEquiv f} (n : Int) : A -> A
  := match n with
      | neg n => fun x => pos_iter f^-1 n x
      | zero => idmap
      | pos n => fun x => pos_iter f n x
     end.

(** Iteration by arbitrary integers requires the endofunction to be an equivalence, so that we can define a negative iteration by using its inverse. *)

Definition int_iter_succ_l {A} (f : A -> A) `{IsEquiv _ _ f}
  (n : Int) (a : A)
  : int_iter f (int_succ n) a = f (int_iter f n a).
Proof.
  destruct n as [n| |n]; trivial.
  + revert n f H a.
    srapply pos_peano_ind.
    { intros f H a.
      symmetry.
      apply eisretr. }
    hnf; intros n p f H a.
    refine (ap (fun x => _ x _) _ @ _).
    1: rewrite int_neg_pos_succ.
    1: exact (eisretr int_succ (neg n)).
    apply moveL_equiv_M.
    cbn; symmetry.
    srapply pos_iter_succ_l.
  + cbn.
    rewrite pos_add_1_r.
    srapply pos_iter_succ_l.
Qed.

Definition int_iter_succ_r {A} (f : A -> A) `{IsEquiv _ _ f}
  (n : Int) (a : A) : int_iter f (int_succ n) a = int_iter f n (f a).
Proof.
   destruct n as [n| |n]; trivial.
+ revert n f H a.
  srapply pos_peano_ind.
  { intros f H a.
    symmetry.
    apply eissect. }
  hnf; intros n p f H a.
  rewrite int_neg_pos_succ.
  refine (ap (fun x => _ x _) _ @ _).
  1: exact (eisretr int_succ (neg n)).
  cbn; rewrite pos_add_1_r.
  rewrite pos_iter_succ_r.
  rewrite eissect.
  reflexivity.
+ cbn.
  rewrite pos_add_1_r.
  srapply pos_iter_succ_r.
Qed.

Definition iter_int_pred_l {A} (f : A -> A) `{IsEquiv _ _ f}
  (n : Int) (a : A)
: int_iter f (int_pred n) a = f^-1 (int_iter f n a).
Proof.
  destruct n as [n| |n]; trivial.
  + cbn; rewrite pos_add_1_r.
    by rewrite pos_iter_succ_l.
  + revert n.
    srapply pos_peano_ind.
    - cbn; symmetry; apply eissect.
    - hnf; intros p q.
      rewrite <- pos_add_1_r.
      change (int_pred (pos (p + 1)%pos))
        with (int_pred (int_succ (pos p))).
      rewrite int_pred_succ.
      change (pos (p + 1)%pos)
        with (int_succ (pos p)).
      rewrite int_iter_succ_l.
      symmetry.
      apply eissect.
Qed.

Definition iter_int_pred_r {A} (f : A -> A) `{IsEquiv _ _ f}
  (n : Int) (a : A)
: int_iter f (int_pred n) a = int_iter f n (f^-1 a).
Proof.
  revert f H n a.
  destruct n as [n| |n]; trivial;
  induction n as [|n nH] using pos_peano_ind; trivial.
  2: hnf; intros; apply symmetry, eisretr.
  all: rewrite <- pos_add_1_r.
  all: intro a.
  1: change (neg (n + 1)%pos) with (int_pred (neg n)).
  2: change (pos (n + 1)%pos) with (int_succ (pos n)).
  1: rewrite <- 2 int_neg_pos_succ.
  1: cbn; apply pos_iter_succ_r.
  rewrite int_pred_succ.
  rewrite int_iter_succ_r.
  rewrite eisretr.
  reflexivity.
Qed.


(* Lambda calculus workout *)

Require Import List.
Import ListNotations.
Require Import Arith.
Require Import Id.

From hahn Require Import HahnBase.

Require Import Coq.Relations.Relation_Operators.

Section Lambda.

(* Lambda term in regular named representation *)
Inductive term : Type :=
  Var  : id -> term
| Abs  : id -> term -> term
| App  : term -> term -> term.

(* Notations and some examples *)
Notation "\ x , .. , z --> t" := (Abs x .. (Abs z t) .. ) (at level 38, no associativity).
Notation "m @ n"              := (App m n) (at level 39, left associativity).

Definition f := 0.
Definition g := 1.
Definition h := 2.

Definition x := 3.
Definition y := 4.

Definition m := 5.
Definition n := 6.

Definition v i := Var i.

Definition i     := \ x --> v x.
Definition apply := \ f, x --> (v f @ v x).
Definition z     := \ f, x --> v x.
Definition s     := \ n, f, x --> (v f @ (v n @ v f @ v x)).
Definition add   := \ n, m, f, x --> (v m @ v f @ (v n @ v f @ v x)).
Definition mul   := \ n, m, f, x --> (v m @ (v n @ v f) @ v x).

(* Free variables*)
Inductive fv : id -> term -> Prop :=
  fv_Var : forall x,  fv x (v x)
| fv_Abs : forall x y t,  fv y t -> x <> y -> fv y (\ x --> t)
| fv_App : forall x a b,  (fv x a) \/ (fv x b) -> fv x (a @ b).

Lemma fv_var: forall x y, fv x (v y) -> x = y.
Proof. admit. Admitted.

(* Capture-avoiding substitution *)
Reserved Notation "m [[ x <~ y ]] n" (at level 40, left associativity).

Inductive cas : term -> id -> id -> term -> Prop :=
  cas_Var : forall x y, (v x) [[x <~ y]] (v y)

| cas_Var_neq : forall x y z (NEQ : x <> z), (v z) [[x <~ y]] (v z)

| cas_App : forall m n m' n' x y
                   (CASM : m [[ x <~ y ]] m')
                   (CASN : n [[ x <~ y ]] n'),
            (m @ n) [[ x<~ y ]] (m' @ n')

| cas_Lam : forall m x y, (\x --> m) [[ x <~ y ]] (\x --> m)

| cas_Lam_neq : forall m m' x y z
                       (NEQX : z <> x) (NEQY : z <> y)
                       (CASM : m [[ x<~ y ]] m'),
                (\ z --> m) [[ x <~ y ]] (\z --> m')

| cas_Lam_ren : forall m m' m'' x y z
                       (NFV : ~ fv z m)
                       (CASM  : m [[ y <~ z ]] m')
                       (CASM' : m' [[ x <~ y ]] m''),
                (\y --> m) [[ x <~ y ]] (\z --> m'')
where "m [[ x <~ y ]] n" := (cas m x y n).

#[local]
Hint Constructors cas : ll.

(* Some lemmas about CAS *)
Lemma cas_reflexive s x : s [[ x <~ x ]] s.
Proof. admit. Admitted.

Lemma cas_preserves x y z s s' (NEQX : z <> x) (NEQY : z <> y)
      (CAS : s [[x <~ y ]] s') (FV : fv z s'):
  fv z s.
Proof. admit. Admitted.

Lemma cas_renames_free s s' x y (NEQ : x <> y)
      (CAS : s [[ x <~ y ]] s') :
  ~ fv x s'.
Proof. admit. Admitted.

(* Renaming of variables *)
Reserved Notation "m [[ x <~ y ]]" (at level 37, left associativity).

Fixpoint rename t x y :=
  match t with
  | Var z     => if id_eq_dec z x then v y else t
  | \ z --> m => if id_eq_dec z x then t else \ z --> m [[x <~ y]]
  | m @ n     => m [[x <~ y]] @ n [[x <~ y]]
  end
where "m [[ x <~ y ]]" := (rename m x y).

(* Safety condition for renaming *)
Inductive safe : term -> id -> id -> Prop :=
  safe_Var   : forall x y z (NEQ : x <> z),
    safe (Var x) y z

| safe_App   : forall m n x y (SAFEM : safe m x y) (SAFEN : safe n x y),
    safe (m @ n) x y

| safe_Lam_1 : forall m z y (NFV : ~ fv y m), safe (\ z --> m) z y
| safe_Lam_2 : forall m x y z (NEQY : y <> z) (NEQX : x <> z)
                      (SAFEM : safe m x y),
    safe (\ z --> m) x y

| safe_Lam_3 : forall m x z (NEQX : x <> z) (NFV : ~ fv x m),
    safe (\ z --> m) x z.

(* Some lemmas about safety and renaming *)
Lemma safe_nfv m x y (SAFEM : safe m x y) : ~ fv y m.
Proof. admit. Admitted.

Lemma safe_fv_neq m x y z (SAFEM : safe m x y) (FV : fv z m) : y <> z.
Proof. admit. Admitted.

Lemma rename_not_fv m x z (NEQ : x <> z) : ~ fv x (m [[x <~ z]]).
Proof. admit. Admitted.

Lemma safe_reverse m x y (SAFEM : safe m x y) :
  safe (m [[x <~ y]]) y x.
Proof. admit. Admitted.

#[local]
Hint Resolve safe_reverse : ll.

Lemma rename_eq_eq m x : m [[ x <~ x]] = m.
Proof. admit. Admitted.

Lemma rename_not_free_is_id m x y (FH : ~ fv x m) : m [[ x <~ y ]] = m.
Proof. admit. Admitted.

Lemma rename_reverse m x y (SH : safe m x y) : (m [[x <~ y]]) [[y <~ x]] = m.
Proof. admit. Admitted.

Lemma rename_preserves m x z y (FH : fv x m) (NEH : z <> x) : fv x (m [[ z <~ y ]]).
Proof. admit. Admitted.

Lemma rename_free_reverse x y z m (HXZ: x <> z) (HYZ: x <> y) (HFV: fv x (m [[ z <~ y]])) : fv x m.
Proof. admit. Admitted.

Lemma rename_if_free m x y z (HFV : fv x (m [[ y <~ z ]])) (HXZ : x <> z) : y <> x.
Proof. admit. Admitted.

#[local]
Hint Resolve rename_reverse : ll.

(* Contexts *)
Inductive Context : Set :=
  CHole : Context
| CAbs  : id -> Context -> Context
| CAppL : Context -> term -> Context
| CAppR : term -> Context -> Context.

(* Substitution in a context *)
Fixpoint term_in_context (C : Context) (t : term) : term :=
  match C with
  | CHole     => t
  | CAbs x c  => Abs x (term_in_context c t)
  | CAppL c p => App (term_in_context c t) p
  | CAppR p c => App p (term_in_context c t)
  end.

(* Some lemmas about contexts *)
Lemma fv_in_term_in_context
      (C : Context) (m : term) (x : id) :
      fv x (term_in_context C m) -> fv x (term_in_context C (\ x --> v x)) \/ fv x m.
Proof. admit. Admitted.

Lemma fv_in_context
      (C : Context) (m : term) (x : id) :
      fv x (term_in_context C (\ x --> v x)) -> fv x (term_in_context C m).
Proof. admit. Admitted.

Lemma fv_in_another_term_in_context
      (C : Context) (m n : term) (x : id) (FVM : fv x m) (FVC : fv x (term_in_context C m)) :
      fv x n -> fv x (term_in_context C n).
Proof. admit. Admitted.

Lemma empty_context m n (H : term_in_context CHole m = n) : m = n.
Proof. admit. Admitted.

Lemma term_in_context_is_var m x C (H : term_in_context C m = v x) : C = CHole.
Proof. admit. Admitted.

(* Alpha conversion *)
Reserved Notation "m <~~> n" (at level 38, no associativity).

(* Alpha equivalence *)
Inductive alpha_equivalent : term -> term -> Prop :=
| ae_Refl    : forall m, m <~~> m
| ae_Rename  : forall m x y, safe m x y -> (\ x --> m) <~~> (\ y --> m [[ x <~ y ]])
| ae_Subterm : forall C a b, a <~~> b -> term_in_context C a <~~> term_in_context C b
| ae_Trans   : forall m n p, m <~~> n -> n <~~> p -> m <~~> p
where "m <~~> n" := (alpha_equivalent m n).

#[local]
Hint Constructors alpha_equivalent : ll.

Lemma alpha_equivalent_symm (m n : term) (HA : m <~~> n) : n <~~> m.
Proof. Admitted.

End Lambda.


From Coq Require Import omega.Omega.
From Coq Require Import Arith.Arith.
From LF Require Import Imp Maps.

(** Here was our first try at an evaluation function for commands,
    omitting [WHILE]. *)

Open Scope imp_scope.
Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        (l !-> aeval st a1 ; st)
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | TEST b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st  (* bogus *)
  end.
Close Scope imp_scope.
(*然而这样的定义不会被Coq接受，因为任何有可能不会停机的函数都会被Coq拒绝*)
(*一个改进技巧是将一个附加参数传入求值函数中来告诉它要运行多久*)
Open Scope imp_scope.
Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_st
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | TEST b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.
Close Scope imp_scope.

(*为了区分正常停机和异常停机,将返回参数由state替换为option state*)
Open Scope imp_scope.
Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | TEST b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.
Close Scope imp_scope.

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Open Scope imp_scope.
Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | TEST b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.
Close Scope imp_scope.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

Compute
     (test_ceval empty_st
         (X ::= 2;;
          TEST (X <= 1)
            THEN Y ::= 3
            ELSE Z ::= 4
          FI)).
(*   ====>
      Some (2, 0, 4)   *)

(** **** Exercise: 2 stars, standard, recommended (pup_to_n)

    Write an Imp program that sums the numbers from [1] to
   [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y].  Make sure
   your solution satisfies the test that follows. *)

Definition pup_to_n : com :=
   (X ::= X;;
    WHILE ~(X = 0)
    DO Y ::=Y+X;;
       X ::= X-1
    END).

Example pup_to_n_1 :
  test_ceval (X !-> 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.

(** **** Exercise: 2 stars, standard, optional (peven)  *)
Fixpoint evenb (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => evenb n'
  end.
Definition evenb_or_not : com :=
   (X ::= X;;
   WHILE ~(X <= 2)
    DO X ::= X-2
    END;;
    TEST (X=0)
        THEN Z ::= 0
        ELSE Z ::= 1
    FI).

Example pup_to_n_2 :
  test_ceval (X !-> 5) evenb_or_not
  = Some (1, 0, 1).
Proof. reflexivity. Qed.

(* ################################################################# *)
(** * Relational vs. Step-Indexed Evaluation *)

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      st =[ c ]=> st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].

  - (* i = 0 -- contradictory *)
    intros c st st' H. discriminate H.

  - (* i = S i' *)
    intros c st st' H.
    destruct c;
           simpl in H; inversion H; subst; clear H.
      + (* SKIP *) apply E_Skip.
      + (* ::= *) apply E_Ass. reflexivity.

      + (* ;; *)
        destruct (ceval_step st c1 i') eqn:Heqr1.
        * (* Evaluation of r1 terminates normally *)
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        * (* Otherwise -- contradiction *)
          discriminate H1.

      + (* TEST *)
        destruct (beval st b) eqn:Heqr.
        * (* r = true *)
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        * (* r = false *)
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.

      + (* WHILE *) destruct (beval st b) eqn :Heqr.
        * (* r = true *)
         destruct (ceval_step st c i') eqn:Heqr1.
         { (* r1 = Some s *)
           apply E_WhileTrue with s. rewrite Heqr.
           reflexivity.
           apply IHi'. rewrite Heqr1. reflexivity.
           apply IHi'. simpl in H1. assumption. }
         { (* r1 = None *) discriminate H1. }
        * (* r = false *)
          injection H1. intros H2. rewrite <- H2.
          apply E_WhileFalse. apply Heqr. Qed.

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

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  - (* i1 = 0 *)
    simpl in Hceval. discriminate Hceval.
  - (* i1 = S i1' *)
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    destruct c.
    + (* SKIP *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ::= *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ;; *)
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* st1'o = None *)
        discriminate Hceval.

    + (* TEST *)
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval;
        assumption.

    + (* WHILE *)
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* i1'o = None *)
        simpl in Hceval. discriminate Hceval.  Qed.

(** **** Exercise: 3 stars, standard, recommended (ceval__ceval_step) *)

Lemma i1_leq_i1i2 :forall i1 i2,
  i1<=i1+i2.
Proof.
  induction i2.
  -rewrite<-plus_n_O. reflexivity.
  -rewrite plus_comm. simpl. apply le_S. rewrite plus_comm. apply IHi2.
Qed.
Theorem ceval__ceval_step: forall c st st',
      st =[ c ]=> st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  -exists 1. reflexivity.
  -exists 1. simpl;rewrite H; reflexivity.
  -destruct IHHce1 as [i1 H1]. destruct IHHce2 as [i2 H2].
   exists (1+i1+i2). simpl.
   destruct (ceval_step st c1 (i1 + i2)) eqn: Heqst1.
   +assert (H1': ceval_step st c1 (i1+i2) =Some st'). {
    apply ceval_step_more with (i1:=i1) (i2:= i1+i2).
    *apply i1_leq_i1i2.
    *apply H1. }
    assert (H': s=st'). { rewrite Heqst1 in H1'.
     inversion H1'. reflexivity. }
     subst.
    apply(ceval_step_more i2 (i1+i2)).
     *rewrite plus_comm. apply i1_leq_i1i2.
     *apply H2.
   +assert (H1': ceval_step st c1 (i1+i2) =Some st'). {
    apply ceval_step_more with (i1:=i1) (i2:= i1+i2).
    *apply i1_leq_i1i2.
    *apply H1. }
    rewrite H1' in Heqst1. inversion Heqst1.
  -destruct IHHce as [i H1]. exists (1+i). simpl.
   rewrite H. apply H1.
  -destruct IHHce as [i H1]. exists (1+i). simpl.
   rewrite H. apply H1.
  -exists 1. simpl. rewrite H. reflexivity.
  -destruct IHHce1 as [i1 H1]. destruct IHHce2 as [i2 H2].
   exists (1+i1+i2). simpl.
   rewrite H.
   assert (H1': ceval_step st c (i1+i2) =Some st'). {
    apply ceval_step_more with (i1:=i1) (i2:= i1+i2).
    *apply i1_leq_i1i2.
    *apply H1. }
   rewrite H1'.
   rewrite plus_comm.
   apply (ceval_step_more i2 (i2+i1)) .
    *apply i1_leq_i1i2.
    *apply H2.
Qed.
Theorem ceval_and_ceval_step_coincide: forall c st st',
      st =[ c ]=> st'
  <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

(* ################################################################# *)
(** * Determinism of Evaluation Again *)

Theorem ceval_deterministic' : forall c st st1 st2,
     st =[ c ]=> st1 ->
     st =[ c ]=> st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega.  Qed.

(* Wed Jan 9 12:02:46 EST 2019 *)