(* Author: Akshay
 *)
Require Import Coq.Lists.List.
Import Coq.Lists.List.ListNotations. (* Why does Require complain about path? *)

Require Import Coq.Classes.EquivDec.

Require Import Coq.Init.Nat.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.

Require Import Coq.Bool.Bool.

(* term is Type instead of Set so we can use sigma *)
Inductive term : Set :=
  | var : nat -> term
  | fn : nat -> term -> term.

Scheme Equality for term.
(* nat_beq is defined
term_beq is defined
term_eq_dec is defined  *)

(* a = b \/ a <> b. *)
Corollary term_eq_decidable : forall (a b:term), Decidable.decidable (a = b).
Proof. intros. pose ( T := term_eq_dec a b). destruct T. left. assumption. right. assumption. Qed.

(* Let's obtain a decision procedure for term*term *)
Definition term_pair_beq (x y : term * term) : bool :=
  match x, y with
  | (x1, x2), (y1,y2) => if term_beq x1 y1 then term_beq x2 y2 else false
  end.

(* From VFA *)
Print reflect.

Lemma nat_beq_refl : forall x, nat_beq x x = true.
Proof.
  intros x. induction x.
  - reflexivity.
  - simpl. apply IHx.
Qed.
Lemma term_beq_refl: forall a, term_beq a a  = true.
Proof.
  intros a. induction a.
  - simpl; apply nat_beq_refl.
  - simpl. Locate "&&". unfold andb. rewrite IHa, nat_beq_refl. reflexivity.
Qed.

Print beq_nat. Print eqb.
(* Let's just show these two are the same, then we get lemmas for free. *)
Lemma nat_beq_is_beq_nat : forall x y, nat_beq x y = beq_nat x y.
Proof.
  intros x y. unfold nat_beq, beq_nat.
  destruct x, y; reflexivity.
Qed.
Check reflect. Print reflect.
About term_eq_dec. (* is transparent *)
About set_In_dec. (* is opaque. *)
Lemma term_beq_reflect : forall x y, reflect (x = y) (term_beq x y).
Proof.
  intros x y. apply iff_reflect. split.
  - (* x = y -> term_beq x y = true *)
    intro x_eq_y. subst. apply (term_beq_refl).
  - generalize x as a, y as b.
    induction a as [vx | n vx], b as [vy | m vy].
    + intros. unfold term_beq in H. rewrite nat_beq_is_beq_nat in H.
      apply beq_nat_true in H. subst. reflexivity.
    + intros. unfold term_beq in H. inversion H.
    + intros. unfold term_beq in H. inversion H.
    + intros. unfold term_beq in H. Search (_ && _ = true -> _).
      apply andb_prop in H. destruct H as [L R]. rewrite nat_beq_is_beq_nat in L.
      apply beq_nat_true in L. subst. apply f_equal. apply IHvx.
      destruct vx, vy; try trivial.
Qed.

Lemma term_pair_beq_reflect : forall x y, reflect (x = y) (term_pair_beq x y).
Proof.
  intros x y. Search reflect. apply iff_reflect. split.
  - intros x_eq_y. subst. destruct y as [y1 y2]. simpl.
    repeat rewrite term_beq_refl. reflexivity.
  - intros x_beq_y. destruct x as [x1 x2], y as [y1 y2]. simpl in *.
    (* Need to reflect term first. *)
    destruct x1, y1, x2, y2; simpl in *;
    repeat rewrite nat_beq_is_beq_nat in x_beq_y;
    try rewrite (nat_beq_is_beq_nat n1 n2) in x_beq_y.
    case (n =? n0) eqn: case1, (n1 =? n2) eqn: case2;
    try apply beq_nat_true in case1; try apply beq_nat_false in case2.
    + apply beq_nat_true in case2. subst. reflexivity.
    + subst. discriminate.
    + discriminate.
    + discriminate.
    + case (n =? n0) eqn:case1. discriminate. discriminate.
    + case (n =? n0) eqn:case1. discriminate. discriminate.
    + admit.
Admitted. (* Not needed. *)

Check term_pair_beq.
Locate "*". Search prod.
Locate "=". Search (prod _ _). Check injective_projections.
Search "prod_eqdec".
Check prod_eqdec. Check EqDec. Check Equivalence.
Check EqDec term eq. Locate "<>". Search (not (eq _ _)).

(* Dual of injective_projections *)
Lemma uneq_pair {A B : Type}: forall  (p1 p2 : A * B),
  fst p1 <> fst p2 \/ snd p1 <> snd p2 -> p1 <> p2.
Proof.
  intros. unfold not in *. destruct H; intros; apply H; subst; reflexivity. Qed.
Lemma uneq_pair1 {A B : Type}: forall  (p1 p2 : A * B),
  fst p1 <> fst p2 -> p1 <> p2.
Proof. intros. unfold not in *. intros. subst. apply H. reflexivity. Qed.
Lemma uneq_pair2 {A B : Type}: forall  (p1 p2 : A * B),
  snd p1 <> snd p2 -> p1 <> p2.
Proof. intros. unfold not in *. intros. subst. apply H. reflexivity. Qed.

Print sumbool.
Definition term_pair_eq_dec (x y : term * term) : {x = y} + {x <> y} :=
  match x, y with
  | (x1, x2), (y1,y2) =>
    match term_eq_dec x1 y1, term_eq_dec x2 y2 with
    | left eqx1y1, left eqx2y2 =>
          left (injective_projections (x1,x2) (y1,y2) eqx1y1 eqx2y2)
    | right a , _ => right (uneq_pair1 (x1,x2) (y1,y2) a)
    | _ , right b => right (uneq_pair2 (x1,x2) (y1,y2) b)
    (* Fix this hack of a definition? *)
    end
  end.
Compute term_pair_eq_dec ((var 1),(var 2)) ((var 3),(var 4)).
Eval compute in term_pair_eq_dec ((var 1),(var 2)) ((var 3),(var 4)).
Compute term_pair_eq_dec ((var 1),(var 2)) ((var 1),(var 2)).

Inductive proof (l : list (term*term)) : term -> term -> Prop :=
  | proofAxm : forall s t, In (s, t) l -> proof l s t
  | proofRefl : forall t, proof l t t
  | proofSymm : forall s t, proof l s t -> proof l t s
  | proofTrans : forall s t u, proof l s t -> proof l t u -> proof l s u
  | proofCong : forall (n : nat) s t, proof l s t -> proof l (fn n s) (fn n t).

Lemma proof_monotonic_cons : forall h l a b, proof l a b -> proof (h::l) a b.
Proof.
  intros h l a b Hprf. induction Hprf.
  - apply proofAxm. simpl. right. assumption.
  - apply proofRefl.
  - apply proofSymm. assumption.
  - apply (proofTrans (h::l) s t u); assumption.
  - apply proofCong. assumption.
Qed.

(* Generalization of in_cons *)
Lemma In_mono: forall A (l k: list A) (x: A), In x l -> In x (k++l).
Proof.
  intros. induction k as [| h k' IHk'].
  - simpl. assumption.
  - simpl. right; assumption.
Qed.

(* Maybe gen to proof l a b \/ proof k a b -> proof (l++k) a b *)
Lemma proof_monotonic : forall k l a b, proof l a b -> proof (k++l) a b.
Proof.
  intros k l. induction k as [|hk k' IHk'].
  - intros; simpl; assumption.
  - intros.  induction H.
    + apply (In_mono (term*term) l k' (s,t)) in H. apply proofAxm in H. simpl.
      apply proof_monotonic_cons. assumption.
    + apply proofRefl.
    + apply proofSymm. apply IHproof.
    + apply (proofTrans _ s t u); [apply IHproof1 | apply IHproof2].
    + apply proofCong. assumption.
Qed.

Inductive Subterm : term -> term -> Prop :=
  | subRefl : forall t, Subterm t t
  | subFn : forall n s, Subterm s (fn n s)
  | subTrans : forall s t u, Subterm s t -> Subterm t u -> Subterm s u.

(* Lets modify definition of occurs and define mapRep only for elements that Occur in eql. *)
Definition Occurs (eql: list (term*term)) (t: term) :=
  exists a b, In (a,b) eql /\ (Subterm t a \/ Subterm t b).

(* We assume the existence of appropriate representation by assuming a correct merge operation. *)
Definition Decidable_Eq (T:Type) := forall a b: T, Decidable.decidable (a = b).

(* Type of the map of representatives, where R is the type of the representative(which ofcourse, needs to be decidable).
We need term -> R , where R is decidable. *)
Definition mapRep (R:{T: Type | Decidable_Eq T }) :=
  term -> (proj1_sig R).

(* Decision procedure type, used in do_tc. *)
Definition DecProc (R:{T: Type | Decidable_Eq T }) :=
  forall (x y: (proj1_sig R)), {x = y} + {x <> y}.

(* Well-formed Representative Map *)
Definition WFM (eql: list (term*term)) (R:{T: Type | Decidable_Eq T}) :
  mapRep R -> Prop :=
    fun ufm =>
        (forall t1 t2, ufm t1 = ufm t2 -> proof eql t1 t2) /\
        forall x y n, ufm x = ufm y -> ufm (fn n x) = ufm (fn n y).

(* The actual merge operation.
(R in merge had to be explicit o/w type cannot be inferred in proof of do_tc) *)
(* TODO: Check correctness conditions for parents. *)
Definition merge R eql
(a b:term) (Hpf: proof eql a b)
  (ufm: { m: mapRep R | WFM eql R m }) :
      ({ m: mapRep R | WFM eql R m /\
        (forall x, (proj1_sig ufm) x = (proj1_sig ufm) a ->
            ( m x = (proj1_sig ufm) b) /\
            forall n, m (fn n x) = (proj1_sig ufm) (fn n b)) /\
        (forall x, (proj1_sig ufm) x <> (proj1_sig ufm) a ->
                   (proj1_sig ufm) x = m x) } ).
Admitted.

(* a is suffix of b *)
Definition suffix {A} (a b: list A) := exists c, b = c ++ a.

Lemma suffix_antimon : forall A (a:A) (l1 l2: list A),
  suffix (a::l1) l2 -> suffix l1 l2.
Proof.
  intros. destruct H. unfold suffix. exists (x++[a]). Locate "++". Search app.
  rewrite <- app_assoc. simpl. assumption.
Qed.

Lemma emp_no_proof: forall a b, a <> b -> ~(proof [] a b).
Proof.
  unfold not. intros a b H Hprf.
  induction Hprf; simpl in *;try assumption.
  - apply H; reflexivity.
  - apply IHHprf. intros. subst. apply H. reflexivity.
  - apply IHHprf1. intros. subst. apply IHHprf2. intros. subst. apply H. reflexivity.
  - apply IHHprf. intros. subst. apply H; reflexivity.
Qed.

Lemma emp_proof_eq: forall a b, proof [] a b -> a = b.
Proof.
  intros. induction H.
  - simpl in H; contradiction.
  - reflexivity.
  - symmetry; assumption.
  - subst. reflexivity.
  - subst; reflexivity.
Qed.

Lemma occurs_mono: forall l l' x, suffix l' l -> Occurs l' x -> Occurs l x.
Proof.
  intros. unfold suffix in H. destruct H as [el H]. rewrite H. unfold Occurs in H0.
  destruct H0 as [y H0].
(*   assert(A: forall h x, Occurs l' x -> Occurs(h::l') x). admit. *)
  unfold Occurs. exists y. destruct el as [| h el'].
  - simpl. assumption.
  - simpl. destruct H0 as [b bH]. exists b.
    + repeat destruct bH. split.
      * right. apply In_mono; assumption.
      * assumption.
Defined.

Fixpoint do_cc {R} (decProc: DecProc R) (eql: list (term*term))
  (l: {k: list (term*term) | suffix k eql}) :
    {m: mapRep R | WFM eql R m} ->
      {m: mapRep R | WFM eql R m /\
        forall a b, proof (proj1_sig l) a b -> m a = m b}.
Proof.
intros. destruct l as [l Hpf].
  (* X as [x W] is the input map to the original do_tc call. *)
simpl in *. destruct X as [x W]. induction l as [ | (hl1, hl2) l' IHl'].
- simpl.
(*   assert (F : forall (a b:term), False -> x a = x b).  *)
(*   { intros. exfalso. assumption. }  *)
  exists x. split; try assumption.
  intros r k H. destruct H.
  + simpl in H. contradiction.
  + reflexivity.
  + apply emp_proof_eq in H. subst. reflexivity.
  + apply emp_proof_eq in H. apply emp_proof_eq in H0. subst. reflexivity.
  + apply emp_proof_eq in H. subst. reflexivity.
- clear do_cc. assert(HPf := Hpf). apply suffix_antimon in Hpf.
  rename Hpf into Hpf'. assert(Hres := Hpf').
  (* Hres is the result of recursive call to do_cc, m' is the corresponding MapRep. *)
  apply IHl' in Hres. clear IHl'.
  assert(HResN := Hres).
  destruct Hres as [m' [Hm'WFM Hm'tc]].
  (* Now use merge to build goal. That's why we did destruct Hres. So we can call merge.
  Show that m' and result of merge differ only in the case where the equiv class of a is concerned. *)
  assert(H1 : Occurs ((hl1,hl2)::l') hl1).
  { unfold Occurs. exists hl1, hl2. split.
    - simpl. left; reflexivity.
    - left. apply subRefl.
  }
  assert(H2 : Occurs ((hl1,hl2)::l') hl2).
  { unfold Occurs. exists hl1, hl2. split.
    - simpl. left; reflexivity.
    - right. apply subRefl; reflexivity.
  }
  (* Use Occurs monotonic, to prove asserts. *)
  assert(h1' : Occurs eql hl1).
  { apply (occurs_mono eql ((hl1,hl2)::l')); assumption. } clear H1.
  assert(h2' : Occurs eql hl2).
  { apply (occurs_mono eql ((hl1,hl2)::l')); assumption. } clear H2.
  Check exist. pose(E1 := exist (Occurs eql)).
  assert(H1:=h1'). assert(H2:=h2').
  apply E1 in h1'. apply E1 in h2'. clear E1.
  assert(A1 : proof eql hl1 hl2).
  {
    unfold suffix in HPf. destruct HPf as [y HPf]. rewrite HPf.
    assert(A: proof ((hl1,hl2)::l') hl1 hl2).
    { apply proofAxm. simpl. left; reflexivity. }
    (* Prove by showing generalized monotonicity of proof(++ instead of ::) *)
    (* This might've not been necessary if we were only using one list: eql *)
    apply proof_monotonic. assumption.
  }
  pose(E2 := exist (WFM eql R) m').
  pose (C := merge R eql hl1 hl2 A1 (E2 Hm'WFM)).
  (* Had to make param R of merge explicit *)
  (* C, the result of merge, is our witness. *)
   destruct C as [M [HMpf [HM1 HM2]]].
  (* But, in constructing M, we have lost the information that it was created by modifying m'. Hence Hm'tc is useless, since we can't recover m' from HM1 and HM2.
  When creating the sig type, we also need m' to be the witness for the subtype.
  But this would require m' to belong to two types, which needs subtyping.
  If we could recover... *)
(*   unfold E2 in H. unfold E2 in HM1. *)
  assert(recov: m' = (proj1_sig (E2 Hm'WFM))). { simpl. reflexivity. }
  try setoid_rewrite <- recov in HM1. (* Why won't this work? *)
  (* Let's try removing the forall x, *)
  assert(HM1n := HM1 hl2). try rewrite <- recov in HM1n. (* Wtf *)
(*   unfold WFM in Hm'WFM. rewrite <- recov in HM1n. *) (* Nope! *)
  assert(recovG: forall q, m' q = proj1_sig (E2 Hm'WFM) q).
  { intros. simpl. reflexivity. }
(*   setoid_rewrite <- (recovG hl2) in HM1. (* Phew!! *) clear HM1n. *)
  setoid_rewrite <- recovG in HM1. (* This does all *) clear HM1n.
  setoid_rewrite <- recovG in HM2. clear recov recovG.
  rename HM1 into mergProp1. rename HM2 into mergProp2.
  (* ...then we can show. Maybe use the fact that classes don't split. *)
  assert(HMrecPf : forall a b : term, proof l' a b -> M a = M b).
  (* Maybe we don't need this assertion. *)
  {
    intros. induction H.
    - apply proofAxm in H. apply Hm'tc in H.
      (* Case analysis, based on antecedents of mergeprops. *)
      pose(P := decProc (m' t) (m' hl1)). destruct P as [P|P].
      + pose(Tmerg1 := mergProp1 t). pose(Tmerg2 := mergProp1 s).
         rewrite P in H. apply Tmerg1 in P. apply Tmerg2 in H.
         destruct H as [H _]. destruct P as [P _].
         rewrite H, P. reflexivity.
      + pose(Tmerg1 := mergProp2 t). pose(Tmerg2 := mergProp2 s).
        assert(Pn := P). rewrite <- H in P. apply Tmerg2 in P.
        apply Tmerg1 in Pn. rewrite <- P, <- Pn. assumption.
    - reflexivity.
    - symmetry; assumption.
    - rewrite IHproof2 in IHproof1. assumption.
    - unfold WFM in HMpf. destruct HMpf as [_ HMpf].
      apply HMpf. assumption.
  }
  (* We need to use HMrecPf, A1 to derive Goal by induction on proof(refer whiteboard) *)
  assert(Hfinal : forall a b, proof ((hl1, hl2)::l') a b -> M a = M b).
  {
    intros. induction H.
    - simpl in H. destruct H.
      + inversion H. rewrite <- H3; rewrite <- H4. clear H; clear H3; clear H4.
        (* Case analysis, based on antecedents of mergProps. *)
        pose(P := decProc (m' hl2) (m' hl1)).
        assert(Pn : m' hl1 = m' hl1). { reflexivity. } apply (mergProp1 hl1) in Pn.
        destruct P as [P|P].
        * apply (mergProp1 hl2) in P.
          destruct Pn as [Pn _]. destruct P as [P _].
          rewrite <- Pn in P. symmetry; assumption.
        * apply (mergProp2 hl2) in P. destruct Pn as [Pn _].
          rewrite <- Pn in P. assumption.
      + (* Use Hm'tc and corr *)
        apply proofAxm in H. pose (HMrecPf s t). apply e; assumption.
    - reflexivity.
    - symmetry; assumption.
    - rewrite IHproof2 in IHproof1. assumption.
    - unfold WFM in HMpf. destruct HMpf as [_ HMpf].
      apply HMpf. assumption.
  }
 exists M. split; assumption.
Defined.


(*-- TODO COMPLETE CLEANUP --*)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Sub-lists                                                               *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import Coq.Classes.Morphisms. (* for [Proper] instances *)
From TLC Require Import LibTactics LibLogic LibReflect LibOperation
 LibProd LibOption LibNat LibInt LibWf LibMonoid LibRelation LibList.
Local Open Scope nat_scope.
Local Open Scope comp_scope.
Global Close Scope list_scope.

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

(* The [prefix] ordering on lists. *)

Section Prefix.

Variables (A : Type).

(* A definition in terms of concatenation. See also [LibListZ]. *)

Definition prefix (ys xs : list A) :=
  exists zs, ys ++ zs = xs.

  (* --TODO one could give an alternate definition of [prefix] as an
     inductive predicate with two cases: [Nil/Cons] and [Cons/Cons].
     This would give rise to a potentially useful induction principle.
     Or just prove this induction principle directly. *)

(* Ordering. *)

Lemma prefix_reflexive:
  forall xs,
  prefix xs xs.
Proof using.
  intros. exists (@nil A). eapply app_nil_r.
Qed.

Lemma prefix_antisymmetric:
  forall xs ys,
  prefix xs ys ->
  prefix ys xs ->
  xs = ys.
Proof using.
  introv (ws&Ex) (zs&Ey). subst ys. rew_list in *.
  forwards Ey': app_l_eq_self_inv (rm Ey).
  forwards (E1&E2): app_eq_nil_inv (rm Ey').
  subst. rew_list~.
Qed.

Lemma prefix_transitive:
  forall xs ys zs,
  prefix xs ys ->
  prefix ys zs ->
  prefix xs zs.
Proof using.
  introv [ xs' ? ] [ ys' ? ].
  subst. rew_list. unfold prefix. eauto.
Qed.

(* [prefix] and [nil]. *)

Lemma prefix_nil:
  forall xs,
  prefix nil xs.
Proof using.
  intros. exists xs. eapply app_nil_l.
Qed.

Lemma prefix_nil_inverse:
  forall xs,
  prefix xs nil ->
  xs = nil.
Proof using.
  introv (ys&?).
  forwards: app_eq_nil_inv. eauto.
  unpack. eauto.
Qed.

(* [prefix] and [cons]. *)

Lemma prefix_cons_inverse: (* TEMPORARY rename: [prefix_cons_r_inverse] *)
  forall xs y ys,
  prefix xs (y :: ys) ->
  xs = nil \/ exists xs', xs = y :: xs' /\ prefix xs' ys.
Proof using.
  introv (zs&Heq).
  destruct xs; [ eauto | right ].
  rew_list in Heq. injects Heq.
  unfold prefix. eauto.
Qed.

Lemma use_prefix_cons: (* TEMPORARY rename: [prefix_cons_l_inverse] *)
  forall x xs ys,
  prefix (x :: xs) ys ->
  exists ys', ys = x :: ys'.
Proof using.
  introv [ slack ? ]. rew_list in *. exists (xs ++ slack). eauto.
Qed.

Lemma prefix_cons_cons:
  forall x xs1 xs2,
  prefix xs1 xs2 ->
  prefix (x :: xs1) (x :: xs2).
Proof using.
  introv (ys&?). subst. exists ys. rew_list. eauto.
Qed.

Lemma prefix_cons_cons_inverse:
  forall x1 x2 xs1 xs2,
  prefix (x1 :: xs1) (x2 :: xs2) ->
  x1 = x2 /\ prefix xs1 xs2.
Proof using.
  intros.
  forwards: prefix_cons_inverse; eauto.
  branches; unpack; try split; congruence.
Qed.

Lemma prefix_cons_cons_eq:
  forall x xs1 xs2,
  prefix (x :: xs1) (x :: xs2) = prefix xs1 xs2.
Proof using.
  intros. extens. split.
  { eapply prefix_cons_cons_inverse. }
  { eapply prefix_cons_cons. }
Qed.

(* [prefix] and [++]. *)

Lemma prefix_concat:
  forall xs ys zs,
  prefix xs ys ->
  prefix xs (ys ++ zs).
Proof using.
  unfold prefix. introv (ws&?). subst ys.
  exists (ws ++ zs). rew_list. eauto.
Qed.

Lemma prefix_concat_simplify:
  forall xs ys1 ys2,
  prefix ys1 ys2 ->
  prefix (xs ++ ys1) (xs ++ ys2).
Proof using.
  introv (ws&?). subst ys2. exists ws. rew_list. eauto.
Qed.

Lemma eliminate_common_prefix:
  forall xs ys zs,
  prefix (xs ++ ys) (xs ++ zs) ->
  prefix ys zs.
Proof using.
  introv [ slack ? ]. exists slack.
  rew_list in *.
  eauto using app_cancel_l.
Qed.

Lemma prefix_app_r_inverse:
  forall ys1 xs ys2,
  prefix xs (ys1 ++ ys2) ->
  prefix xs ys1 \/
  exists ys2a, xs = ys1 ++ ys2a /\ prefix ys2a ys2.
Proof using.
  induction ys1 as [ | y ys1 ]; simpl; intros.
  { right. exists xs. rew_list in *. eauto. }
  { destruct xs as [ | x xs ].
    { eauto using prefix_nil. }
    { rew_list in *.
      forwards: prefix_cons_cons_inverse. { eauto. } unpack. subst y.
      forwards [ ? | (ys2a&?&?) ]: IHys1. { eauto. }
      { eauto using prefix_cons_cons. }
      { right. eexists ys2a. rew_list. subst xs. eauto. }
    }
  }
Qed.

(* [prefix] and [snoc]. *)

Lemma prove_prefix_snoc:
  forall x xs ys zs,
  xs ++ x :: ys = zs ->
  prefix (xs & x) zs.
Proof using.
  intros. exists ys. rew_list. eauto.
Qed.

Lemma use_prefix_snoc:
  forall x xs ys zs,
  prefix (xs & x) ys ->
  ys = xs ++ zs ->
  exists zs', zs = x :: zs'.
Proof using.
  introv h ?. subst.
  forwards: eliminate_common_prefix h.
  eauto using use_prefix_cons.
Qed.

Lemma prefix_last: (* TEMPORARY should be: use_prefix_snoc *)
  forall x xs ys,
  prefix (xs & x) ys ->
  prefix xs ys.
Proof using.
  introv [ zs ? ]. exists (x :: zs). rew_list in *. eauto.
Qed.

(* [prefix] and [length]. See also [LibListZ]. *)

Lemma prefix_length:
  forall ys xs,
  prefix ys xs ->
  length ys <= length xs.
Proof using.
  intros ys xs [ zs ? ]. subst xs. rew_list. math.
Qed.

Lemma prefix_snoc_length:
  forall ys y xs,
  prefix (ys & y) xs ->
  length ys < length xs.
Proof using.
  intros ys y xs [ zs ? ]. subst xs. rew_list. math.
Qed.

(* [prefix] and [No_duplicates]. *)

Lemma noduplicates_prefix:
  forall xs ys,
  noduplicates ys ->
  prefix xs ys ->
  noduplicates xs.
Proof using.
  introv ? (zs&?). subst.
  forwards: noduplicates_app_inv; eauto.
  tauto.
Qed.

End Prefix.

Hint Resolve
  prefix_reflexive
  prefix_nil
  prefix_cons_cons
  prefix_concat
  prefix_concat_simplify
  prove_prefix_snoc
: prefix.

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

Section PrefixClosed.

Variables (A : Type).

Implicit Types xs ys : list A.

(* Prefix-closedness. *)

Definition prefix_closed (P : list A -> Prop) :=
  forall xs ys,
  P ys ->
  prefix xs ys ->
  P xs.

Lemma prefix_closed_nil:
  forall (P : list A -> Prop) xs,
  prefix_closed P ->
  P xs ->
  P nil.
Proof using.
  eauto with prefix.
Qed.

(* Prefix closure. *)

Definition prefix_closure (P : list A -> Prop) : list A -> Prop :=
  fun xs => exists ys, prefix xs ys /\ P ys.

Definition prefix_closure_alt (P : list A -> Prop) : list A -> Prop :=
  fun xs => exists ys, P (xs ++ ys).

Lemma prefix_closure_eq:
  forall P,
  prefix_closure P = prefix_closure_alt P.
Proof using.
  intros. extens; intros xs; split; unfold prefix_closure, prefix_closure_alt, prefix.
  { introv (ys&(zs&?)&?). subst. eauto. }
  { introv (ys&?). eauto. }
Qed.

Lemma prefix_closure_is_prefix_closed:
  forall P,
  prefix_closed (prefix_closure P).
Proof using.
  unfold prefix_closed, prefix_closure.
  introv (zs&?&?). eauto using prefix_transitive.
Qed.

(* The relation [fun xs => prefix xs ys] is the prefix closure of the
   singleton [ys]. Thus, it is prefix-closed. *)

Lemma prefix_closure_singleton:
  forall ys : list A,
  (fun xs => prefix xs ys) = prefix_closure (= ys).
Proof using.
  intros. extens; intros xs. unfold prefix_closure.
  split. eauto. intros (?&?&?). subst. eauto.
Qed.

Lemma prefix_closed_prefix:
  forall ys : list A,
  prefix_closed (fun xs => prefix xs ys).
Proof using.
  intros. rewrite prefix_closure_singleton.
  eapply prefix_closure_is_prefix_closed.
Qed.

End PrefixClosed.

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

(* DEPRECATED?

(* The [prefix] ordering on lists has been defined in [LibList]. Here, we
   provide an alternate definition, as well as more properties. *)

(* --TODO characterize [prefix] as pointwise equality *)

Section PrefixMore.

Variables (A : Type).
Implicit Types xs ys : list A.

Lemma le_implies_ge: forall x y, x <= y -> y >= x.
Proof using. math. Qed.

Local Hint Resolve le_implies_ge length_nonneg.

(* [prefix], [snoc], and read access.

Lemma prefix_read:
  forall `{Inhab A} ys xs y,
  prefix (ys & y) xs ->
  y = xs[length ys].
Proof using.
  intros.
  change (xs[length ys]) with (nth (length ys) xs).
  unfold nth. case_if as Hop; [ | clear Hop ].
  { false. forwards: length_nonneg ys. math. }
  unfold LibList.nth.
  generalize dependent xs.
  generalize dependent ys. unfold prefix.
  induction ys; intros xs [ zs ? ]; rew_list in *.
  (* Base case. *)
  { change (abs 0) with (0%nat).
    subst xs. reflexivity. }
  (* Inductive case. *)
  { rewrite abs_plus by first [ math | eauto ].
    change (abs 1) with (1%nat).
    destruct xs as [ | x xs ]; [ congruence | ].
    simpl. eapply IHys. exists zs. rew_list. congruence. }
Qed.
 *)

(* [prefix] and [length]. *)

Lemma prefix_length:
  forall ys xs,
  prefix ys xs ->
  length ys <= length xs.
Proof using.
  intros ys xs [ zs ? ]. subst xs. rew_list.
  assert (length zs >= 0). { eauto. }
  math.
Qed.

Lemma prefix_snoc_length:
  forall ys y xs,
  prefix (ys & y) xs ->
  length ys < length xs.
Proof using.
  intros ys y xs [ zs ? ]. subst xs. rew_list.
  assert (length zs >= 0). { eauto. }
  math.
Qed.

End PrefixMore.

*)


Fixpoint split {X Y: Type} (l: list (X * Y))
    : (list X) * (list Y) :=
    match l with
    | nil => (nil, nil)
    | cons (x, y) ls => match (split ls) with
                    | (p, q) => (cons x p, cons y q)
    end
    end.

Notation "x :: xs" := (cons x xs)(at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).
Notation "x ++ y" := (app x y) (at level 60, right associativity).

Example test_split:
    split [(1, false); (2, false)] = ([1;2], [false; false]).
Proof.
    reflexivity.
Qed.

Compute (fun x => x + 10).

Definition thrice {X: Type} (f: X -> X) (n: X) : X :=
    f (f (f n)).

Compute (thrice (fun x => x * 2) 4).

Fixpoint rev {X: Type} (l: list X) : list X :=
    match l with
    | nil => nil
    | x::xs => (rev xs) ++ [x]
    end.

Fixpoint map {X Y: Type} (f: X -> Y) (l: list X)
    : list Y :=
    match l with
    | nil => nil
    | x::xs => (f x) :: map f xs
    end.

Lemma mapl:forall  {X Y: Type} (f: X -> Y) (l: list X) (x: X),
    map f (l ++ [x]) = map f l ++ [f x].
Proof.
    intros X Y f l x.
    induction l as [| y ys IHy].
    reflexivity.
    simpl.
    rewrite -> IHy.
    reflexivity.
Qed.

Theorem map_rev: forall (X Y: Type) (f: X -> Y) (l: list X),
    map f (rev l) = rev (map f l).
Proof.
    intros X Y f l.
    induction l as [| x xs IHx].
    reflexivity.
    simpl.
    rewrite -> mapl.
    rewrite -> IHx.
    reflexivity.
Qed.

Fixpoint fold {X Y: Type} (f: X -> Y -> Y)
    (l: list X) (b: Y) : Y :=
    match l with
    | nil => b
    | x::xs => f x (fold f xs b)
    end.

Definition fold_map {X Y: Type} (f: X -> Y)
    (l: list X) : list Y := fold (fun x y => (f x) :: y) l nil.

(* Lemma fmhd: forall {X Y: Type} (f: X -> Y) (x: X) (xs: list X),
    fold_map f (x::xs) = (f x) :: fold_map f xs.
Proof.
    intros X Y f x xs.
    induction xs as [| y ys IHy].
    - reflexivity.
    -
Qed. *)

Theorem fm_correct: forall {X Y: Type} (f: X -> Y) (l: list X),
    map f l = fold_map f l.
Proof.
    intros X Y f l.
    induction l as [| x xs IHx].
    - reflexivity.
    - simpl.
      rewrite -> IHx.
      unfold fold_map.
      reflexivity.
Qed.

Fixpoint evenb (n: nat) : bool :=
    match n with
    | O => true
    | S O => false
    | S (S n') => evenb n'
    end.

Definition oddb (n: nat) : bool := negb (evenb n).

Theorem sill2a:
    forall (n m : nat), (n ,n) = (m, m) ->
    (forall (q r: nat), (q, q) = (r, r) ->
    [q] = [r]) -> [m] = [n].
Proof.
    intros n m eq1 eq2.
    apply eq2.
    symmetry.
    apply eq1.
Qed.

Theorem sillyex:
    (forall n, evenb n = true -> oddb (S n) = true) ->
    oddb 3 = true -> evenb 4 = true.
Proof.
    intros eq1 eq2.
    apply eq2.
Qed.

Lemma rev2: forall (l: list nat), rev (rev l) = l. Admitted.

Theorem rev_exe1: forall (l l': list nat),
    l = rev l' -> l' = rev l.
Proof.
    intros l l' eq1.
    rewrite -> eq1.
    rewrite -> rev2.
    reflexivity.
Qed.

Definition minus2 (n: nat) : nat :=
    match n with
    | 0 => 0
    | S 0 => 0
    | S (S x) => x
    end.

Theorem trans: forall (X: Type) (n m o: X),
    n = m -> m = o -> n = o.
Proof.
    intros X n m o eq1 eq2.
    rewrite -> eq1.
    apply eq2.
Qed.

Example tqe: forall (n m o p: nat),
    m = (minus2 o) ->
    (n + p) = m ->
    (n + p) = (minus2 o).
Proof.
    intros n m o p.
    intros eq1 eq2.
    apply trans with (m := (minus2 o)).
    - rewrite -> eq2.
      apply eq1.
    - reflexivity.
Qed.


Require Import init.

Require Export set_order.
Require Import function.
Require Import set.
Require Import nat.

Declare Scope ord_scope.
Delimit Scope ord_scope with ord.

Record ord_type := make_ord_type {
    ord_U : Type;
    ord_le : ord_U → ord_U → Prop;
    ord_antisym : Antisymmetric ord_le;
    ord_wo : WellOrdered ord_le;
}.

Ltac get_ord_wo A :=
    pose proof (ord_antisym A);
    pose proof (ord_wo A).

Theorem ord_zero_ex A : ord_U A → ∃ z, ∀ x, ord_le A z x.
Proof.
    get_ord_wo A.
    intros a.
    assert (∃ x : ord_U A, all x) as S_ex by (exists a; exact true).
    pose proof (well_ordered all S_ex) as [z [C0 z_min]]; clear C0.
    exists z.
    intros x.
    apply z_min.
    exact true.
Qed.
Definition ord_zero {A} (H : ord_U A) := ex_val (ord_zero_ex A H).
Theorem ord_zero_le {A} {H : ord_U A}: ∀ x, ord_le A (ord_zero H) x.
Proof.
    intros x.
    unfold ord_zero.
    unpack_ex_val z z_ex z_le; rewrite z_ex.
    apply z_le.
Qed.
Theorem ord_zero_eq {A} (H1 H2 : ord_U A) : ord_zero H1 = ord_zero H2.
Proof.
    get_ord_wo A.
    apply antisym; apply ord_zero_le.
Qed.

Theorem ord_zero_iso {A} {B} (H : ord_U A) :
    ∀ f : ord_U A → ord_U B, Bijective f →
    (∀ a b, (ord_le A) a b ↔ (ord_le B) (f a) (f b)) →
    f (ord_zero H) = ord_zero (f H).
Proof.
    intros f f_bij f_iso.
    get_ord_wo B.
    apply antisym; try apply ord_zero_le.
    pose (f' := bij_inv f).
    rewrite <- (inverse_eq2 _ _ (bij_inv_inv _) (ord_zero (f H))).
    rewrite <- f_iso.
    apply ord_zero_le.
Qed.

Definition initial_segment_set (A : ord_type) (x : ord_U A) :=
    λ a, ord_le A a x ∧ a ≠ x.
Definition initial_segment_le (A : ord_type) (x : ord_U A) :=
    λ (a b : set_type (initial_segment_set A x)), ord_le A [a|] [b|].
Lemma initial_segment_antisym : ∀ (A : ord_type) (x : ord_U A),
    Antisymmetric (initial_segment_le A x).
Proof.
    intros A x.
    get_ord_wo A.
    split.
    intros a b ab ba.
    apply set_type_eq.
    apply antisym; assumption.
Qed.
Lemma initial_segment_wo : ∀ (A : ord_type) (x : ord_U A),
    WellOrdered (initial_segment_le A x).
Proof.
    intros A x.
    get_ord_wo A.
    split.
    intros S [y Sy].
    pose (S' (a : ord_U A) := ∃ H : (initial_segment_set A x a), S [_|H]).
    assert (∃ x, S' x) as S'_nempty.
    {
        exists [y|].
        exists [|y].
        destruct y.
        exact Sy.
    }
    pose proof (well_ordered S' S'_nempty) as [m [[Am Sm] m_minimal]].
    exists [_|Am].
    split.
    +   exact Sm.
    +   intros z Sz.
        apply m_minimal.
        exists [|z].
        destruct z; exact Sz.
Qed.
Definition ord_initial_segment (A : ord_type) (x : ord_U A)
    := make_ord_type _ _ (initial_segment_antisym A x) (initial_segment_wo A x).

Theorem ord_iso_le : ∀ (A : ord_type) f, Injective f →
    (∀ a b, (ord_le A) a b ↔ (ord_le A) (f a) (f b)) →
    ∀ x, ord_le A x (f x).
Proof.
    intros A f f_inj f_iso x.
    get_ord_wo A.
    classic_contradiction x_gt.
    pose (S x := ¬ord_le A x (f x)).
    assert (∃ x, S x) as S_nempty.
    {
        exists x.
        unfold S.
        exact x_gt.
    }
    specialize (well_ordered S S_nempty) as [b [Sb b_min]].
    apply Sb.
    apply b_min.
    unfold S.
    rewrite <- f_iso.
    exact Sb.
Qed.

(* begin hide *)
Section OrdEquiv.

Let ord_eq A B := ∃ f, Bijective f ∧
                       ∀ a b, (ord_le A) a b ↔ (ord_le B) (f a) (f b).
Local Infix "~" := ord_eq.

Lemma ord_eq_reflexive : ∀ A, A ~ A.
Proof.
    intros A.
    exists identity.
    split.
    -   exact identity_bijective.
    -   intros a b.
        reflexivity.
Qed.
Instance ord_eq_reflexive_class : Reflexive _ := {
    refl := ord_eq_reflexive
}.

Lemma ord_eq_symmetric : ∀ A B, A ~ B → B ~ A.
Proof.
    intros A B [f [f_bij f_iso]].
    exists (bij_inv f).
    split.
    -   apply bij_inv_bij.
    -   intros a b.
        pose proof (bij_inv_inv f) as inv.
        apply inverse_symmetric in inv.
        split.
        +   intros ab.
            apply f_iso.
            do 2 rewrite (inverse_eq1 _ _ inv).
            exact ab.
        +   intros ab.
            apply f_iso in ab.
            do 2 rewrite (inverse_eq1 _ _ inv) in ab.
            exact ab.
Qed.
Instance ord_eq_symmetric_class : Symmetric _ := {
    sym := ord_eq_symmetric
}.

Lemma ord_eq_transitive : ∀ A B C, A ~ B → B ~ C → A ~ C.
Proof.
    intros A B C [f [f_bij f_iso]] [g [g_bij g_iso]].
    exists (λ x, g (f x)).
    split.
    -   apply bij_comp; assumption.
    -   intros a b.
        rewrite f_iso.
        rewrite g_iso.
        reflexivity.
Qed.
Instance ord_eq_transitive_class : Transitive _ := {
    trans := ord_eq_transitive
}.

End OrdEquiv.
(* end hide *)
Definition ord_equiv := make_equiv _
    ord_eq_reflexive_class ord_eq_symmetric_class ord_eq_transitive_class.
Notation "a ~ b" := (eq_equal ord_equiv a b) : ord_scope.

Notation "'ord'" := (equiv_type ord_equiv).

(* begin hide *)
Open Scope ord_scope.
(* end hide *)
Theorem ord_niso_init : ∀ A x, ¬(A ~ ord_initial_segment A x).
Proof.
    intros A x [f [f_bij f_iso]].
    pose (f' a := [f a|]).
    assert (Injective f') as f'_inj.
    {
        split.
        intros a b eq.
        apply f_bij.
        apply set_type_eq.
        exact eq.
    }
    assert (∀ a b, ord_le A a b ↔ ord_le A (f' a) (f' b)) as f'_iso
        by apply f_iso.
    pose proof (ord_iso_le A f' f'_inj f'_iso x) as leq.
    pose proof [|f x] as [fx_leq fx_neq].
    change (f' x) with [f x|] in leq.
    get_ord_wo A.
    pose proof (antisym fx_leq leq).
    contradiction.
Qed.

Theorem ord_iso_init_eq : ∀ A B C x,
    B ~ ord_initial_segment A x → C ~ ord_initial_segment A x → B ~ C.
Proof.
    intros A B C x [f [f_bij f_iso]] [g [g_bij g_iso]].
    pose (g' := bij_inv g).
    exists (λ x, g' (f x)).
    split.
    -   apply bij_comp; try assumption.
        apply bij_inv_bij.
    -   intros a b.
        rewrite f_iso.
        rewrite g_iso.
        pose proof (bij_inv_inv g) as g_inv.
        do 2 rewrite (inverse_eq2 _ _ g_inv).
        reflexivity.
Qed.

(* begin hide *)
Lemma ord_init_iso_eq1 : ∀ A x y,
    ord_initial_segment A x ~ ord_initial_segment A y → ord_le A y x.
Proof.
    intros A x y eq.
    get_ord_wo A.
    classic_contradiction xy.
    assert (initial_segment_set A y x) as x_in.
    {
        unfold initial_segment_set.
        classic_case (x = y).
        -   subst.
            destruct (connex y y); contradiction.
        -   destruct (connex x y); try contradiction.
            split; assumption.
    }
    assert (ord_initial_segment A x ~ ord_initial_segment (ord_initial_segment A y) [_|x_in]).
    {
        assert (∀ a : set_type (initial_segment_set A x),
                initial_segment_set A y [a|]) as all_in1.
        {
            intros [a a_eq].
            unfold initial_segment_set in *; cbn.
            destruct x_in as [xy_eq xy_neq], a_eq as [ax_eq ax_neq].
            split.
            -   exact (trans ax_eq xy_eq).
            -   intros ay.
                subst.
                contradiction.
        }
        assert (∀ a : set_type (initial_segment_set A x),
            initial_segment_set (ord_initial_segment A y) [x|x_in] [_|all_in1 a])
        as all_in2.
        {
            intros [a a_eq].
            unfold initial_segment_set in *; cbn.
            unfold initial_segment_le; cbn.
            destruct a_eq as [a_leq a_neq].
            split; try exact a_leq.
            intros neq.
            inversion neq.
            contradiction.
        }
        exists (λ x, [_|all_in2 x]); cbn.
        split.
        1: split; split.
        -   intros a b ab.
            apply set_type_eq; inversion ab; reflexivity.
        -   intros [[b b_y] b_x].
            unfold initial_segment_set in b_x.
            cbn in b_x.
            assert (initial_segment_set A x b) as b_x2.
            {
                split; try apply b_x.
                destruct b_x.
                intro contr.
                subst.
                apply H2.
                apply set_type_eq; reflexivity.
            }
            exists [_|b_x2].
            apply set_type_eq.
            do 2 rewrite set_value_simpl.
            apply set_type_eq.
            reflexivity.
        -   intros a b.
            unfold initial_segment_le; cbn.
            reflexivity.
    }
    apply eq_symmetric in eq.
    pose proof (eq_transitive ord_equiv).
    pose proof (trans eq H1) as contr.
    apply ord_niso_init in contr.
    exact contr.
Qed.
(* end hide *)
Theorem ord_init_iso_eq : ∀ A x y,
    ord_initial_segment A x ~ ord_initial_segment A y → x = y.
Proof.
    intros A x y eq.
    get_ord_wo A.
    apply antisym.
    -   apply eq_symmetric in eq.
        apply ord_init_iso_eq1.
        exact eq.
    -   apply ord_init_iso_eq1.
        exact eq.
Qed.

(* begin hide *)
Lemma ord_iso_unique_le : ∀ (A B : ord_type) f g, Bijective f → Bijective g →
    (∀ a b, (ord_le A) a b ↔ (ord_le B) (f a) (f b)) →
    (∀ a b, (ord_le A) a b ↔ (ord_le B) (g a) (g b)) →
    ∀ x, ord_le B (f x) (g x).
Proof.
    intros A B f g f_bij g_bij f_iso g_iso x.
    pose (f' := bij_inv f).
    pose (h x := f' (g x)).
    assert (ord_le A x (h x)) as leq.
    {
        apply ord_iso_le.
        -   split.
            intros a b eq.
            unfold h in eq.
            apply (bij_inv_bij f) in eq.
            apply g_bij in eq.
            exact eq.
        -   intros a b.
            unfold h.
            rewrite (f_iso (f' (g a))).
            do 2 rewrite (inverse_eq2 _ _ (bij_inv_inv f)).
            apply g_iso.
    }
    unfold h in leq.
    apply f_iso in leq.
    rewrite (inverse_eq2 _ _ (bij_inv_inv f)) in leq.
    exact leq.
Qed.
(* end hide *)
Theorem ord_iso_unique : ∀ (A B : ord_type) f g, Bijective f → Bijective g →
    (∀ a b, (ord_le A) a b ↔ (ord_le B) (f a) (f b)) →
    (∀ a b, (ord_le A) a b ↔ (ord_le B) (g a) (g b)) →
    f = g.
Proof.
    intros A B f g f_bij g_bij f_iso g_iso.
    apply functional_ext.
    intros x.
    get_ord_wo B.
    apply antisym; apply ord_iso_unique_le; assumption.
Qed.
Theorem ord_iso_id : ∀ A f, Bijective f →
    (∀ a b, (ord_le A) a b ↔ (ord_le A) (f a) (f b)) →
    f = identity.
Proof.
    intros A f f_bij f_iso.
    apply ord_iso_unique; try assumption.
    -   exact identity_bijective.
    -   reflexivity.
Qed.

Theorem ord_iso_strict :
   ∀ {A B f}, Bijective f →
   (∀ a b : ord_U A, ord_le A a b ↔ ord_le B (f a) (f b)) →
   (∀ a b : ord_U A, strict (ord_le A) a b ↔ strict (ord_le B) (f a) (f b)).
Proof.
    intros A B f f_bij f_iso a b.
    split.
    -   intros ab.
        split.
        +   rewrite <- f_iso.
            apply ab.
        +   intro contr.
            apply f_bij in contr.
            subst.
            destruct ab; contradiction.
    -   intros ab.
        split.
        +   rewrite f_iso.
            apply ab.
        +   intro contr.
            subst.
            destruct ab; contradiction.
Qed.

(* begin hide *)
Close Scope ord_scope.
(* end hide *)
Definition nat_to_ord_type (n : nat) :=
    make_ord_type (set_type (λ m, m < n)) le
    set_type_le_antisym_class set_type_le_wo_class.
Definition nat_to_ord (n : nat) :=
    to_equiv ord_equiv (nat_to_ord_type n).