Require Import Coq.Program.Basics.
Require Import Coq.Program.Equality. (* for dependent induction *)
Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Lt.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Logic.FunctionalExtensionality.

Require Export Coq.Vectors.Vector.
Require Export CoLoR.Util.Vector.VecUtil.
Import VectorNotations.

Require Import Helix.Tactics.HelixTactics.
Require Import Helix.Util.Misc.
Require Import Helix.Util.FinNat.

Local Open Scope program_scope. (* for \circ notation *)
Open Scope vector_scope.

(* Re-define :: List notation for vectors. Probably not such a good idea *)
Notation "h :: t" := (cons h t) (at level 60, right associativity)
                     : vector_scope.

(* Split vector into a pair: first  'p' elements and the rest. *)
Definition vector2pair {A:Type} (p:nat) {t:nat} (v:vector A (p+t)) : (vector A p)*(vector A t) :=
  @Vbreak A p t v.

(* Split vector into a pair: first  'p' elements and the rest. *)
Definition pair2vector {A:Type} {i j:nat} (p:(vector A i)*(vector A j)) : (vector A (i+j))  :=
  match p with
    (a,b) => Vapp a b
  end.

Lemma vp2pv: forall {T:Type} i1 i2 (p:((vector T i1)*(vector T i2))),
    vector2pair i1 (pair2vector p) = p.
Proof.
  intros.
  unfold vector2pair.
  destruct p.
  unfold pair2vector.
  apply Vbreak_app.
Qed.

Lemma Vmap_cons: forall A B (f:A->B) n (x:A) (xs: vector A n),
    Vmap f (Vcons x xs) = Vcons (f x) (Vmap f xs).
Proof.
  intros.
  constructor.
Qed.

Lemma Vhead_Vmap {A B: Type} {f: A->B} {n:nat} {x: vector A (S n)}:
  Vhead (Vmap f x) = f (Vhead x).
Proof.
  dep_destruct x.
  reflexivity.
Qed.

Lemma Vmap_Vconst
      {n : nat}
      {A B: Type}
      {f: A -> B}
      (x : A):
  Vmap f (Vconst x n) = Vconst (f x) n.
Proof.
  induction n.
  -
    auto.
  -
    simpl.
    rewrite IHn.
    reflexivity.
Qed.

Lemma VMapp2_app:
  forall {A B} {f: A->A->B} (n m : nat)
    {a b: vector A m} {a' b':vector A n},
    Vmap2 f (Vapp a a') (Vapp b b')
    = Vapp (Vmap2 f a b) (Vmap2 f a' b').
Proof.
  intros A B f n m a b a' b'.
  induction m.
  - VOtac.
    reflexivity.
  - VSntac a. VSntac b.
    simpl.
    rewrite IHm.
    reflexivity.
Qed.

Lemma Vmap2_Vmap
      {A1 A2 B1 B2 C: Type}
      {n: nat}
      {x1: vector A1 n}
      {x2: vector A2 n}
      {g1: A1->B1}
      {g2: A2->B2}
      {f: B1 -> B2 -> C}
  :
    Vmap2 f
          (Vmap g1 x1)
          (Vmap g2 x2)
    =
    Vmap2 (fun a b => f (g1 a) (g2 b)) x1 x2.
Proof.
  induction n.
  -
    reflexivity.
  -
    simpl.
    rewrite <- IHn.
    dep_destruct  x1.
    dep_destruct  x2.
    reflexivity.
Qed.

Lemma Vmap_Vmap2
      {A1 A2 B C: Type}
      {n: nat}
      {x1: vector A1 n}
      {x2: vector A2 n}
      {g: B -> C}
      {f: A1 -> A2 -> B}
  :
    Vmap g (Vmap2 f x1 x2) = Vmap2 (fun a b => g (f a b)) x1 x2.
Proof.
  induction n.
  -
    reflexivity.
  -
    simpl.
    rewrite <- IHn.
    reflexivity.
Qed.

Lemma Vmap2_as_Vbuild (A B C : Type) (f: A->B->C) {n}
      {a: vector A n}
      {b: vector B n}:
  Vmap2 f a b = Vbuild (fun i ic => f (Vnth a ic) (Vnth b ic)).
Proof.
  apply Veq_nth.
  intros j jc.
  rewrite Vnth_map2.
  rewrite Vbuild_nth.
  reflexivity.
Qed.

Section VFold.

  Lemma Vfold_right_cons: forall A B n (f:A->B->B) (id:B) (h:A) (v:vector A n),
      Vfold_right f (Vcons h v) id = f h (Vfold_right f v id).
  Proof.
    intros.
    reflexivity.
  Qed.

  Lemma Vfold_right_reduce: forall A B n (f:A->B->B) (id:B) (v:vector A (S n)),
      Vfold_right f v id = f (hd v) (Vfold_right f (tl v) id).
  Proof.
    intros.
    dep_destruct v.
    reflexivity.
  Qed.

  (* It directly follows from definition, but haiving it as sepearate lemma helps to do rewiring *)
  Lemma Vfold_left_rev_cons:
    forall A B {n} (f : B->A->B) (b:B) (x: A) (xs : vector A n),
      Vfold_left_rev f b (Vcons x xs) = f (Vfold_left_rev f b xs) x.
  Proof.
    intros A B n f b x xs.
    reflexivity.
  Qed.

  Lemma Vfold_right_Vmap
        {A B C: Type}
        {n: nat}
        (f : A->B->B)
        (g : C->A)
        (x : vector C n)
        (z:B)
    : Vfold_right f (Vmap g x) z = Vfold_right (f∘g) x z.
  Proof.
    induction x.
    - crush.
    - simpl.
      rewrite IHx.
      unfold compose.
      reflexivity.
  Qed.

End VFold.

Section Vfold_right_indexed.

  Program Fixpoint Vfold_right_indexed
           {n:nat}
           {A B:Type}
           (f : forall i (ip:i < n), A -> B -> B)
           (v:vector A n)
           (b: B) (* initial value *)

  : B
    := match v, n as m return n=m -> B with
               | Vnil, _ => fun _ => b
               | Vcons x xs, n' =>
                 fun E =>
                   let f' := (fun i ip => f (S i) (lt_n_S ip) ) in
                   f 0 _ x (Vfold_right_indexed f' xs b)
       end eq_refl.
  Next Obligation. apply zero_lt_Sn. Qed.

  Fixpoint Vfold_right_indexed'
           {n: nat}
           {A B: Type}
           (i: nat) (* first index *)
           (f: nat -> A -> B -> B)
           (v: vector A n)
           (b: B) (* initial value *)

    : B :=
    match v with
    | Vnil => b
    | Vcons x xs =>
      f i x (Vfold_right_indexed' (S i) f xs b)
    end.

End Vfold_right_indexed.

Section VBreak.
  Lemma Vbreak_arg_app:
    forall {B} (m n : nat) (x : vector B (m + n)) (a: vector B m) (b: vector B n),
      Vbreak x = (a, b) -> x = Vapp a b.
  Proof.
    intros B m n x a b V.
    rewrite Vbreak_eq_app with (v:=x).
    rewrite V.
    reflexivity.
  Qed.

  Lemma Vbreak_preserves_values {A} {n1 n2} {x: vector A (n1+n2)} {x0 x1}:
    Vbreak x = (x0, x1) ->
    forall a, Vin a x <-> ((Vin a x0) \/ (Vin a x1)).
  Proof.
    intros B a.
    apply Vbreak_arg_app in B.
    subst.
    split.
    apply Vin_app.
    intros.
    destruct H.
    apply Vin_appl; assumption.
    apply Vin_appr; assumption.
  Qed.

  Lemma Vbreak_preserves_P {A} {n1 n2} {x: vector A (n1+n2)} {x0 x1} {P}:
    Vbreak x = (x0, x1) ->
    (Vforall P x -> ((Vforall P x0) /\ (Vforall P x1))).
  Proof.
    intros B D.
    assert(N: forall a, Vin a x -> P a).
    {
      intros a.
      apply Vforall_in with (v:=x); assumption.
    }
    (split;
     apply Vforall_intro; intros x2 H;
     apply N;
     apply Vbreak_preserves_values with (a:=x2) in B;
     destruct B as [B0 B1];
     apply B1) ;
      [left | right]; assumption.
  Qed.

  Lemma Vnth_fst_Vbreak
        {A:Type}
        (m n : nat)
        (v : vector A (m + n))
        (j : nat) (jc : j < m)
        (jc1 : j < m + n):
    Vnth (fst (Vbreak v)) jc = Vnth v jc1.
  Proof.
    replace (Vnth v) with (Vnth (Vapp (fst (Vbreak v)) (snd (Vbreak v)))).
    -
      rewrite Vnth_app.
      break_match.
      + lia.
      + apply f_equal, le_unique.
    -
      f_equal. symmetry.
      apply Vbreak_eq_app.
  Qed.

  Lemma Vnth_snd_Vbreak
        {A: Type}
        (m n : nat)
        (v : vector A (m + n)) (j : nat)
        (jc : j < n)
        (jc2 : j + m < m + n):
    Vnth (snd (Vbreak v)) jc = Vnth v jc2.
  Proof.
    replace (Vnth v) with (Vnth (Vapp (fst (Vbreak v)) (snd (Vbreak v)))).
    -
      rewrite Vnth_app.
      break_match.
      +
        generalize (Vnth_app_aux n jc2 l) as g.

        assert(E: j + m - m = j).
        {
          rewrite NatUtil.plus_minus_eq.
          reflexivity.
        }
        rewrite E.
        intros g.
        apply f_equal, le_unique.
      + lia.
    -
      f_equal. symmetry.
      apply Vbreak_eq_app.
  Qed.

End VBreak.

Lemma vec_eq_elementwise n B (v1 v2: vector B n):
  Vforall2 eq v1 v2 -> (v1 = v2).
Proof.
  induction n.
  + dep_destruct v1. dep_destruct v2.
    auto.
  + dep_destruct v1. dep_destruct v2.
    intros H.
    rewrite Vforall2_cons_eq in H.
    destruct H as [Hh Ht].
    apply IHn in Ht.
    rewrite Ht, Hh.
    reflexivity.
Qed.

Lemma Vmap_Vbuild n B C (fm: B->C) (fb : forall i : nat, i < n -> B):
  Vmap fm (Vbuild fb) = Vbuild (fun z zi => fm (fb z zi)).
Proof.
  apply vec_eq_elementwise.
  apply Vforall2_intro_nth.
  intros i ip.
  rewrite Vnth_map.
  rewrite 2!Vbuild_nth.
  reflexivity.
Qed.

Lemma Vexists_Vbuild:
  forall (T:Type) (P: T -> Prop) (n:nat) {f},
    Vexists P (Vbuild (n:=n) f) <-> exists i (ic:i<n), P (f i ic).
Proof.
  intros T P n f.
  split.
  - intros E.
    apply Vexists_eq in E.
    destruct E as[x [V Px]].
    apply Vin_nth in V.
    destruct V as [i [ip V]].
    rewrite Vbuild_nth in V.
    subst x.
    exists i, ip.
    apply Px.
  - intros H.
    apply Vexists_eq.
    destruct H as [i [ic H]].
    exists (f i ic).
    split.
    +
      apply Vin_build.
      exists i, ic.
      reflexivity.
    + assumption.
Qed.

Lemma Vbuild_0: forall B gen, @Vbuild B 0 gen = @Vnil B. Proof. reflexivity. Qed.

Lemma Vbuild_Sn (B : Type) (n : nat) (gen : forall i : nat, i < S n -> B):
  @Vbuild B (S n) gen = (gen 0 (Nat.lt_0_succ n))
                          ::
                          Vbuild (fun (i : nat) (ip : i < n) => gen (S i) (lt_n_S ip)).
Proof.
  rewrite <- Vbuild_head.
  rewrite <- Vbuild_tail.
  apply VSn_eq.
Qed.

Lemma Vbuild_1 B gen:
  @Vbuild B 1 gen = [gen 0 (lt_0_Sn 0)].
Proof.
  rewrite Vbuild_Sn.
  apply Vcons_eq.
  split.
  - apply f_equal, le_unique.
  - reflexivity.
Qed.

Fact lt_0_SSn:  forall n:nat, 0<S (S n). Proof. intros; lia. Qed.

Fact lt_1_SSn:  forall n:nat, 1<S (S n). Proof. intros; lia. Qed.

Lemma Vbuild_2 B gen:
  @Vbuild B 2 gen = [gen 0 (lt_0_SSn 0) ; gen 1 (lt_1_SSn 0)].
Proof.
  repeat rewrite Vbuild_Sn.
  apply Vcons_eq.
  split.
  - apply f_equal, le_unique.
  - apply Vcons_eq.
    split.
    + apply f_equal, le_unique.
    + reflexivity.
Qed.

Definition Vin_aux {A} {n} (v : vector A n) (x : A) : Prop := Vin x v.

Section Vnth.

  Lemma Vnth_arg_eq:
    forall (A : Type) (n : nat) (v1 v2 : vector A n)
      (i : nat) (ip : i < n), v1 = v2 -> Vnth v1 ip = Vnth v2 ip.
  Proof.
    crush.
  Qed.

  (* Convenience method, swapping arguments on Vnth *)
  Definition Vnth_aux {A:Type} {n i:nat} (ic:i<n) (a: vector A n) :=
    Vnth a ic.

  Lemma Vnth_to_Vnth_aux
        {A:Type} {n i:nat} (ic:i<n) (a: vector A n):
    Vnth a ic = Vnth_aux ic a.
  Proof.
    unfold Vnth_aux.
    reflexivity.
  Qed.

  Lemma Vnth_0
        {B} {n} (v:vector B (S n)) (ip: 0<(S n)):
    Vnth (i:=0) v ip = Vhead v.
  Proof.
    dep_destruct v.
    simpl.
    reflexivity.
  Qed.

  Lemma Vnth_1_Vhead
        {T:Type}
        (x:vector T 1)
        (i:nat) (ic: Peano.lt i 1)
    :
      Vnth x ic = Vhead x.
  Proof.
    destruct i.
    -
      rewrite Vnth_0.
      reflexivity.
    - lia.
  Qed.

  Lemma Vnth_1
        {T:Type}
        (x:T)
        (i:nat) (ic: Peano.lt i 1)
    :
      Vnth [x] ic = x.
  Proof.
    destruct i.
    - auto.
    - lia.
  Qed.

  Lemma Vnth_Sn {B} (n i:nat) (v:B) (vs:vector B n) (ip: S i< S n) (ip': i< n):
    Vnth (Vcons v vs) ip = Vnth vs ip'.
  Proof.
    simpl.
    apply f_equal, le_unique.
  Qed.

  Lemma Vnth_cast_index:
    forall {B} {n : nat} i j (ic: i<n) (jc: j<n) (x : vector B n),
      i = j -> Vnth x ic = Vnth x jc.
  Proof.
    intros B n i j ic jc x E.
    crush.
    apply f_equal, le_unique.
  Qed.

  Lemma P_Vnth_Vcons {T:Type} {P:T -> Prop} {n:nat} (h:T) (t:vector T n):
    forall i (ic:i<S n) (ic': (pred i) < n),
      P (Vnth (Vcons h t) ic) -> P h \/ P (Vnth t ic').
  Proof.
    intros i ic ic' H.
    destruct i.
    + left.
      auto.
    + right.
      simpl in H.
      rewrite (le_unique _ _ ic' (lt_S_n ic)).
      apply H.
  Qed.

  Lemma P_Vnth_Vcons_not_head {T:Type} {P:T -> Prop} {n:nat} (h:T) (t:vector T n):
    forall i (ic:i<S n) (ic': (pred i) < n),
      not (P h) -> P (Vnth (Vcons h t) ic) -> P (Vnth t ic').
  Proof.
    intros i ic ic' Ph Pt.
    destruct i.
    - simpl in Pt; congruence.
    - simpl in Pt.
      rewrite (le_unique _ _ ic' (lt_S_n ic)).
      apply Pt.
  Qed.

End Vnth.

Lemma Vforall_Vbuild (T : Type) (P:T -> Prop) (n : nat) (gen : forall i : nat, i < n -> T):
  Vforall P (Vbuild gen) <-> forall (i : nat) (ip : i < n), P (gen i ip).
Proof.
  split.
  - intros H i ip.
    apply Vforall_nth with (ip:=ip) in H.
    rewrite Vbuild_nth in H.
    apply H.
  - intros H.
    apply Vforall_nth_intro.
    intros i ip.
    rewrite Vbuild_nth.
    apply H.
Qed.

Lemma Vbuild_Vapp
      {A: Type}
      {n m: nat}
      {f: forall (t:nat), (t<n+m) -> A}
  : Vbuild f =
    @Vapp A n m
          (Vbuild (fun t (tc:t<n) => f t (Nat.lt_lt_add_r t n m tc)))
          (Vbuild (fun t (tc:t<m) => f (t+n) (add_lt_lt tc))).
Proof.
  apply Veq_nth.
  intros i ip.
  rewrite Vbuild_nth.
  rewrite Vnth_app.
  break_match.
  -
    rewrite Vbuild_nth.
    generalize (@add_lt_lt n m (i - n) (@Vnth_app_aux n m i ip l)).
    intros ic.
    remember (i - n + n) as Q.
    replace (i - n + n) with i in HeqQ.
    subst Q.
    apply f_equal, le_unique.
    lia.
  -
    rewrite Vbuild_nth.
    apply f_equal, le_unique.
Qed.

Lemma Vbuild_range_cast
      {A: Type}
      {n m: nat}
      {f: forall (t:nat), (t<n) -> A}
      (E: m=n)
:
  @Vbuild A n f =
  Vcast (
      @Vbuild A m (fun t tc => f t (eq_lt_lt E tc))
    ) E.
Proof.
  apply Veq_nth.
  intros i ip.
  rewrite Vnth_cast.
  rewrite 2!Vbuild_nth.
  f_equal.
  apply le_unique.
Qed.

Program Definition Vbuild_split_at_def
        {A: Type}
        {n m: nat}
        {f: forall (t:nat), (t<n+(S m)) -> A}
  := Vbuild f =
            @Vapp A n (S m)
            (Vbuild (fun t (tc:t<n) => f t _))
            (Vcons
               (f n _)
               (Vbuild (fun t (tc:t<m) => f (t+1+n) _))
            ).
Next Obligation. lia. Qed.
Next Obligation. lia. Qed.
Next Obligation. lia. Qed.

Lemma Vbuild_split_at
      {A: Type}
      (n m: nat)
      {f: forall (t:nat), (t<n+(S m)) -> A}: @Vbuild_split_at_def A n m f.

Proof.
  unfold Vbuild_split_at_def.
  rewrite Vbuild_Vapp.
  f_equal.
  -
    apply Veq_nth.
    intros i ip.
    rewrite 2!Vbuild_nth.
    f_equal.
    apply le_unique.
  -
    repeat rewrite Vbuild_Sn.
    simpl.
    f_equal.
    +
      f_equal.
      apply le_unique.
    +
      apply Veq_nth.
      intros i ip.
      rewrite 2!Vbuild_nth.
      assert(E: i+1+n = S (i+n) ) by lia.
      symmetry.
      forall_n_lt_eq.
Qed.

Section Vunique.
  Local Open Scope nat_scope.

  (* There is at most one element in vector satisfying given predicate *)
  Definition Vunique
             {n} {T:Type}
             (P: T -> Prop)
             (v: vector T n) :=

    (forall (i: nat) (ic: i < n) (j: nat) (jc: j < n),
        (P (Vnth v ic) /\ P (Vnth v jc)) -> i = j).

  Lemma Vunique_Vnil (T : Type) (P : T -> Prop):
    Vunique P (@Vnil T).
  Proof.
    unfold Vunique.
    intros i ic j jc H.
    nat_lt_0_contradiction.
  Qed.

  Lemma Vforall_notP_Vunique:
    forall (n : nat) (T : Type) (P : T -> Prop) (v : vector T n),
      Vforall (not ∘ P) v -> Vunique P v.
  Proof.
    intros n T P v.
    induction v.
    - intros H.
      apply Vunique_Vnil.
    -
      intros H.
      unfold Vunique in *.
      intros i ic j jc V.
      destruct V.
      apply Vforall_nth with (i:=i) (ip:=ic) in H.
      congruence.
  Qed.

  Lemma Vunique_P_Vforall_notP:
    forall (n : nat) (T : Type) (P : T -> Prop) (h:T) (x : vector T n),
      P(h) /\ Vunique P (h::x) -> Vforall (not ∘ P) x.
  Proof.
    intros n T P h x [H V].
    unfold Vunique in V.
    specialize (V 0 (zero_lt_Sn n)).
    simpl (Vnth (h :: x) (zero_lt_Sn n)) in V.
    apply Vforall_nth_intro; intros i ip.
    unfold compose.
    specialize (V (S i) (lt_n_S ip)).
    replace (Vnth (h :: x) (lt_n_S ip)) with (Vnth x ip) in V.
    contradict V.
    crush.
    simpl.
    apply f_equal, le_unique.
  Qed.

  Lemma Vunique_cons_not_head
        {n} {T:Type}
        (P: T -> Prop)
        (h: T) (t: vector T n):
    not (P h) /\ Vunique P t -> Vunique P (Vcons h t).
  Proof.
    intros H.
    destruct H as [Ph Pt].
    unfold Vunique.
    intros i ic j jc H.
    destruct H as [Hi Hj].

    destruct i,j.
    - reflexivity.
    - simpl in Hi. congruence.
    - simpl in Hj. congruence.
    -
      assert(ic': pred (S i) < n) by (apply lt_S_n; apply ic).
      apply P_Vnth_Vcons_not_head with (ic'0:=ic') in Hi; try apply Ph.

      assert(jc': pred (S j) < n) by (apply lt_S_n; apply jc).
      apply P_Vnth_Vcons_not_head with (ic'0:=jc') in Hj; try apply Ph.

      f_equal.
      unfold Vunique in Pt.
      apply Pt with (ic:=ic') (jc:=jc').
      split; [apply Hi| apply Hj].
  Qed.

  Lemma Vunique_cons_head
        {n} {T:Type}
        (P: T -> Prop)
        (h: T) (t: vector T n):
    P h /\ (Vforall (not ∘ P) t) -> Vunique P (Vcons h t).
  Proof.
    intros H.
    destruct H as [Ph Pt].
    unfold Vunique.
    intros i ic j jc H.
    destruct H as [Hi Hj].

    destruct i, j.
    - reflexivity.
    -
      assert(jc':j < n) by lia.
      apply Vforall_nth with (i:=j) (ip:=jc') in Pt.
      unfold compose in Pt.
      rewrite Vnth_Sn with (ip:=jc) (ip':=jc') in Hj.
      congruence.
    -
      assert(ic':i < n) by lia.
      apply Vforall_nth with (i:=i) (ip:=ic') in Pt.
      unfold compose in Pt.
      rewrite Vnth_Sn with (ip:=ic) (ip':=ic') in Hi.
      congruence.
    -
      assert(jc':j < n) by lia.
      apply Vforall_nth with (i:=j) (ip:=jc') in Pt.
      unfold compose in Pt.
      rewrite Vnth_Sn with (ip:=jc) (ip':=jc') in Hj.
      congruence.
  Qed.

  Lemma Vunique_cons {n} {T:Type}
        (P: T -> Prop)
        (h: T) (t: vector T n):
    ((P h /\ (Vforall (not ∘ P) t)) \/
     (not (P h) /\ Vunique P t))
    ->
    Vunique P (Vcons h t).
  Proof.
    intros H.
    destruct H.
    apply Vunique_cons_head; auto.
    apply Vunique_cons_not_head; auto.
  Qed.
  Lemma Vunique_cons_tail {n}
        {T:Type} (P: T -> Prop)
        (h : T) (t : vector T n):
    Vunique P (Vcons h t) -> Vunique P t.
  Proof.
    intros H.
    unfold Vunique in *.
    intros i ic j jc [Vi Vj].
    assert(S i = S j).
    {
      assert(ic': S i < S n) by lia.
      assert(jc': S j < S n) by lia.
      apply H with (ic:=ic') (jc:=jc').
      simpl.
      rewrite (le_unique _ _ (lt_S_n ic') ic).
      rewrite (le_unique _ _ (lt_S_n jc') jc).
      auto.
    }
    auto.
  Qed.

  (* All vector's element except one with given index satisfy given perdicate. It is not known wether the remaining element satisfy it is or not *)
  Definition VAllButOne
             {n} {T:Type}
             i (ic:i<n)
             (P: T -> Prop)
             (x: vector T n)
    :=
      (forall j (jc:j<n), ~(i = j) -> P (Vnth x jc)).

  Lemma VallButOne_Sn_cons_not_head
        {T: Type}
        (h : T)
        (n : nat)
        (v : vector T n)
        (P: T -> Prop)
        (i : nat)
        (ic : S i < S n):
    VAllButOne (S i) ic (not ∘ P) (Vcons h v) -> not (P h).
  Proof.
    intros H.
    unfold VAllButOne in H.
    specialize (H 0).
    unfold compose in H.
    simpl in H.
    apply H ; lia.
  Qed.

  Lemma VAllButOne_0_Vforall
        {T}
        n
        (v: T)
        (vs : vector T n)
        (kc : 0 < S n)
        (P: T -> Prop)
    :
      VAllButOne 0 kc P (Vcons v vs) -> Vforall P vs.
  Proof.
    intros H.
    unfold VAllButOne in H.
    apply Vforall_nth_intro.
    intros i ip.
    assert (ip1: S i < S n) by lia.
    assert (ip2: 0 <> S i) by lia.
    specialize (H (S i) ip1 ip2).
    simpl in *.
    rewrite (le_unique _ _  ip (lt_S_n ip1)).
    apply H.
  Qed.

  (* Always works in this direction *)
  Lemma VAllButOne_Sn
        {n} {T:Type}
        (P: T -> Prop)
        (h: T)
        (t: vector T n)
        i (ic: S i < S n) (ic': i < n):
    VAllButOne (S i) ic P (Vcons h t) -> VAllButOne i ic' P t .
  Proof.
    intros H.
    unfold VAllButOne in *.
    intros j jc N.
    assert(jc': S j < S n) by lia.
    assert(N':S i <> S j) by lia.
    specialize (H (S j) jc' N').
    rewrite <- Vnth_Sn with (v:=h) (ip:=jc').
    assumption.
  Qed.

  Lemma VallButOneSimpl
        {T}
        n
        (vl : vector T n)
        (k : nat)
        (kc : k < n)
        (P0: T -> Prop)
        (P1: T -> Prop)
        (Pimpl: forall x, P0 x -> P1 x)
    :
      VAllButOne k kc P0 vl -> VAllButOne k kc P1 vl.
  Proof.
    unfold VAllButOne.
    intros H j jc H0.
    specialize (H j jc H0).
    apply Pimpl.
    apply H.
  Qed.

  (* In this direction requires additional assumtion  ¬ P h *)
  Lemma VAllButOne_Sn'
        (T : Type)
        (P : T -> Prop)
        (h : T)
        (n : nat)
        (x : vector T n)
        (N: ~P h)
        (i : nat) (ic : i < n) (ic': S i < S n):
    VAllButOne i ic  (not ∘ P) x -> VAllButOne (S i) ic' (not ∘ P) (h :: x).
  Proof.
    intros H.
    unfold VAllButOne in *.
    intros j jc H0.
    destruct j.
    crush.
    assert(jc': j < n) by lia.
    rewrite Vnth_Sn with (ip':=jc').
    apply H.
    lia.
  Qed.

  (* In this direction requires additional assumtion  P h *)
  Lemma Vforall_VAllButOne_P0
        (T : Type)
        (P : T -> Prop)
        (h : T)
        (n : nat)
        (x : vector T n)
        (N: P h):
    Vforall (not ∘ P) x -> VAllButOne 0 (zero_lt_Sn n) (not ∘ P) (h :: x).
  Proof.
    intros H.
    unfold VAllButOne.
    intros j jc H0.
    simpl.
    break_match.
    congruence.
    apply Vforall_nth with (ip:=(lt_S_n jc)) in H.
    assumption.
  Qed.

  Lemma VallButOne_Vunique
        {n} {T:Type}
        (P: T -> Prop)
        {Pdec: forall a, {P a}+{~(P a)}}
        (x: vector T n)
    :
      (exists i ic, VAllButOne i ic (not∘P) x) ->
      Vunique P x.
  Proof.
    intros V.
    elim V. clear V. intros k V.
    elim V. clear V. intros kc V.
    destruct n.
    -
      dep_destruct x.
      apply Vunique_Vnil.
    -
      unfold VAllButOne in V.
      unfold Vunique.
      intros i ic j jc H.
      destruct H as [H0 H1].

      assert(V1:=V).
      rename V into V0.
      specialize (V0 i ic).
      specialize (V1 j jc).

      generalize dependent (Vnth x ic).
      intros x0 V0 H0. unfold compose in V0.
      generalize dependent (Vnth x jc).
      intros x1 H1 V1. unfold compose in V1.
      clear x ic jc kc.
      destruct (Pdec x0), (Pdec x1); try congruence.
      clear Pdec.

      destruct(eq_nat_dec k j).
      + subst j.
        destruct(eq_nat_dec k i).
        subst i.
        reflexivity.
        crush.
      + crush.
  Qed.

  Lemma VallButOne_Sn_cases
        {T: Type}
        (h : T)
        (n : nat)
        (v : vector T n)
        (P: T -> Prop)
        (i : nat)
        (ic : S i < S n)
        (ic' : i < n):
    VAllButOne (S i) ic (not ∘ P) (Vcons h v) <->
    (not (P h) /\ VAllButOne i ic' (not ∘ P) v).
  Proof.
    split.
    -
      intros H.
      split.
      + apply VallButOne_Sn_cons_not_head in H.
        apply H.
      +
        apply VAllButOne_Sn with (h0:=h) (ic0:=ic).
        apply H.
    -
      intros [H0 H1].
      apply VAllButOne_Sn' with (ic:=ic').
      apply H0.
      apply H1.
  Qed.

  Lemma Vunique_cases
        {n} {T:Type}
        (P: T -> Prop)
        `{D: forall (a:T), {P a}+{~P a}}
        (x: vector T n):
    Vunique P x ->
    ({Vforall (not ∘ P) x}+{exists i ic, VAllButOne i ic (not∘P) x}).
  Proof.
    intros U.
    induction x.
    - left.
      crush.
    -
      destruct (D h).
      + right.
        assert(Ux := U); apply Vunique_cons_tail in Ux.
        specialize (IHx Ux); clear Ux.
        exists 0, (zero_lt_Sn n). (* only 0 element could be ^P *)

        apply Vforall_VAllButOne_P0; try assumption.
        apply Vunique_P_Vforall_notP with (h:=h).
        split; assumption.
      +
        apply Vunique_cons_tail in U.
        specialize (IHx U).
        clear U.
        destruct IHx.
        * left.
          crush.
        * right.
          inversion e.
          inversion H.
          clear e H.
          assert(sx0: S x0 < S n) by lia.
          exists (S x0), sx0.
          apply VAllButOne_Sn' with (ic':=sx0) (ic:=x1); assumption.
  Qed.

End Vunique.

Section Vforall.

  Variable A : Type.
  Variable P: A -> Prop.
  Variable n: nat.

  Lemma Vforall_Vhead
        {v:vector A (S n)}:
    Vforall P v -> P (Vhead v).
  Proof.
    intros H.
    eapply Vforall_nth with (i:=0) in H.
    rewrite Vhead_nth.
    apply H.
  Qed.

  Lemma Vforall_Vtail
        {v:vector A (S n)}:
    Vforall P v -> Vforall P (Vtail v).
  Proof.
    intros H.
    dep_destruct v.
    apply H.
  Qed.

End Vforall.

(* Utlity functions for vector products *)

Section VectorPairs.

  Definition Phead {A} {B} {n} (ab:(vector A (S n))*(vector B (S n))): A*B
    := match ab with
       | (va,vb) => ((Vhead va), (Vhead vb))
       end.

  Definition Ptail {A} {B} {n} (ab:(vector A (S n))*(vector B (S n))): (vector A n)*(vector B n)
    := match ab with
       | (va,vb) => ((Vtail va), (Vtail vb))
       end.

End VectorPairs.

Section VMap2_Indexed.

  Definition Vmap2Indexed {A B C : Type} {n}
             (f: nat->A->B->C) (a: vector A n) (b: vector B n)
    := Vbuild (fun i ip => f i (Vnth a ip) (Vnth b ip)).

  Definition Vmap2SigIndexed {A B C : Type} {n}
             (f: FinNat n->A->B->C) (a: vector A n) (b: vector B n)
    := Vbuild (fun i ip => f (mkFinNat ip) (Vnth a ip) (Vnth b ip)).

  Lemma Vnth_Vmap2Indexed:
    forall {A B C : Type} {n:nat} (i : nat) (ip : i < n) (f: nat->A->B->C)
      (a:vector A n) (b:vector B n),
      Vnth (Vmap2Indexed f a b) ip = f i (Vnth a ip) (Vnth b ip).
  Proof.
    intros A B C n i ip f a b.
    unfold Vmap2Indexed.
    rewrite Vbuild_nth.
    reflexivity.
  Qed.

  Lemma Vnth_Vmap2SigIndexed:
    forall {A B C : Type} {n:nat} (i : nat) (ip : i < n) (f: FinNat n->A->B->C)
      (a:vector A n) (b:vector B n),
      Vnth (Vmap2SigIndexed f a b) ip = f (mkFinNat ip) (Vnth a ip) (Vnth b ip).
  Proof.
    intros A B C n i ip f a b.
    unfold Vmap2SigIndexed.
    rewrite Vbuild_nth.
    reflexivity.
  Qed.

End VMap2_Indexed.

Definition Lst {B:Type} (x:B) := [x].

Lemma Vin_cons:
  forall (T:Type) (h : T) (n : nat) (v : vector T n) (x : T),
    Vin x (Vcons h v) -> x = h \/ Vin x v.
Proof.
  crush.
Qed.

Lemma Vin_1
      (A: Type)
      (a:A)
      (v:vector A 1)
  :
    Vin a v -> a = Vhead v.
Proof.
      intros H.
      dep_destruct v.
      dep_destruct x.
      destruct H.
      - auto.
      - contradiction.
Qed.

Lemma Vforall_not_Vexists
      {n} {T}
      (v: vector T n)
      (P: T -> Prop) :
  Vforall (not ∘ P) v -> not (Vexists P v).
Proof.
  intros A.
  unfold not.
  intros E.
  apply Vexists_eq in E.
  destruct E as [x [E E1]].
  apply Vforall_in with (x:=x) in A.
  congruence.
  apply E.
Qed.

Lemma Vforall_Vconst
      {A: Type}
      {n: nat}
      {z: A}
      {P: A->Prop}:
  P z -> Vforall P (Vconst z n).
Proof.
  intros Pz.
  apply Vforall_nth_intro.
  intros i ip.
  rewrite Vnth_const.
  apply Pz.
Qed.

Lemma Vforall_Vmap2
      {A: Type}
      {n: nat}
      {P: A->Prop}
      {f: A->A->A}
      (C: forall x y : A, P x -> P y -> P (f x y))
      {a b: vector A n}
      (PA: Vforall P a)
      (PB: Vforall P b)
  :
    Vforall P (Vmap2 f a b).
Proof.
  apply Vforall_nth_intro.
  intros i ip.
  rewrite Vnth_map2.
  apply C.
  apply Vforall_nth, PA.
  apply Vforall_nth, PB.
Qed.

Lemma Vtail_1:
  forall {A:Type} (x:vector A 1), (Vtail x = @Vnil A).
Proof.
  intros A x.
  dep_destruct x.
  dep_destruct x0.
  simpl.
  reflexivity.
Qed.

Lemma V0_V0_eq:
  forall {A:Type} (x y:vector A 0), x=y.
Proof.
  intros A x y.
  dep_destruct x.
  dep_destruct y.
  reflexivity.
Qed.

Lemma vector1_eq_Vhead_eq
      {A: Type}
      {a b: vector A 1}:
  Vhead a = Vhead b -> a = b.
Proof.
  intros H.
  dep_destruct a.
  dep_destruct b.
  dep_destruct x.
  dep_destruct x0.
  simpl in H.
  apply Vcons_eq_intro.
  assumption.
  reflexivity.
Qed.

Require Import CoLoR.Util.List.ListUtil.

Section List_of_Vec.

  Lemma list_of_vec_eq {A:Type} {n:nat} (v1 v2 : vector A n) :
    list_of_vec v1 = list_of_vec v2 -> v1 = v2.
  Proof.
    induction n.
    -
      dep_destruct v1.
      dep_destruct v2.
      reflexivity.
    -
      intros H.
      dep_destruct v1.
      dep_destruct v2.
      inversion H.
      apply Vcons_eq_intro; auto.
  Qed.

  Lemma list_of_vec_length {A:Type} {n:nat} {v : vector A n} :
    length (list_of_vec v) = n.
  Proof.
    induction n.
    -
      dep_destruct v.
      reflexivity.
    -
      dep_destruct v.
      simpl.
      apply eq_S.
      auto.
  Qed.

  Lemma list_of_vec_vec_of_list {A:Type} {l : list A} :
    list_of_vec (vec_of_list l) = l.
  Proof.
    induction l.
    -
      reflexivity.
    -
      simpl.
      rewrite IHl.
      reflexivity.
  Qed.

  Lemma list_of_vec_Vcast {A:Type} {m n:nat} (v : vector A m) {E:m=n}:
    list_of_vec (Vcast v E) = list_of_vec v.
  Proof.
    dependent induction m.
    -
      crush.
    -
      destruct n; try congruence.
      dep_destruct v.
      simpl.
      rewrite Vcast_cons.
      simpl.
      apply tail_eq.
      eapply IHm.
  Qed.

  (* Note: no [default] param for [nth] is not specified *)
  Lemma nth_cons {A:Type} (l: list A) (a:A) (i:nat):
    nth (S i) (a::l) = nth i l.
  Proof.
    crush.
  Qed.

  (* Note: no [default] param for [nth] is not specified *)
  Lemma list_eq_nth {A:Type} (l1 l2: list A):
    (length l1 = length l2) ->
    (forall i (ic1:i<length l1), nth i l1 = nth i l2) ->
    l1 = l2.
  Proof.
    revert l1 l2.
    induction l1.
    -
      intros L N.
      simpl in L.
      symmetry.
      apply length_zero_iff_nil.
      auto.
    -
      intros l2 L F.
      destruct l2.
      crush.
      apply cons_eq.
      +
        assert(H1: 0 < length (a :: l1)) by crush.
        specialize (F 0 H1).
        simpl in F.
        apply equal_f in F.
        auto.
        exact a0.
      +
        apply IHl1.
        *
          auto.
        *
          intros i ic1.
          rewrite <- nth_cons with (a1:=a).
          rewrite <- nth_cons with (a1:=a0) (l:=l2).
          apply F; crush.
  Qed.

  (* Note: no [default] param for [nth] is not specified *)
  Lemma nth_Vnth {A:Type} {n:nat} {v:vector A n} (i:nat) (ic:i<n):
    nth i (list_of_vec (v)) = fun _ => Vnth v ic.
  Proof.
    revert i ic.
    dependent induction v.
    -
      intros i ic.
      nat_lt_0_contradiction.
    -
      intros i ic.
      destruct i.
      +
        reflexivity.
      +
        simpl.
        apply IHv.
  Qed.

  Lemma list_of_vec_Vapp {A:Type} {m n:nat} {v1: vector A m} {v2: vector A n}:
    list_of_vec (Vapp v1 v2) = List.app (list_of_vec v1) (list_of_vec v2).
  Proof.
    apply list_eq_nth.
    -
      rewrite app_length.
      repeat rewrite list_of_vec_length.
      auto.
    -
      intros i ic1.
      rewrite list_of_vec_length in ic1.
      rewrite nth_Vnth with (ic:=ic1).
      rewrite Vnth_app.
      break_match.
      +
        rewrite <- nth_Vnth.
        extensionality x.
        rewrite app_nth2.
        rewrite list_of_vec_length.
        reflexivity.
        rewrite list_of_vec_length.
        auto.
      +
        rewrite <- nth_Vnth.
        extensionality x.
        rewrite app_nth1.
        reflexivity.
        rewrite list_of_vec_length.
        auto.
  Qed.

End List_of_Vec.

(* --- Some tactics --- *)

(* Given a `Vnth x i0 ic0 = Vnth y i1 ic0` and a hypotheis `i0=i1` reduces goal to `x=y`. *)
Ltac Vnth_eq_index_to_val_eq :=
  let lc := fresh in
  let rc := fresh in
  let Q := fresh in
  let HeqQ := fresh in
  match goal with
  | [ H: ?i0 = ?i1 |- @Vnth ?t ?s ?v0 ?i0 ?ic0 = @Vnth ?t ?s ?v1 ?i1 ?ic1] =>
    generalize ic0 as lc;
    generalize ic1 as rc;
    intros rc lc ;
    remember i0 as Q eqn:HeqQ;
    rewrite H in HeqQ;
    subst Q;
    rewrite (le_unique _ _ lc rc);
    apply Vnth_arg_eq;
    clear rc lc HeqQ
  end.

Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Data.Monads.OptionMonad.

Import MonadNotation.
Local Open Scope monad_scope.

(* Shrink function agrument of Vbuild by omitting the last element *)
Definition shrink_vbuild_function_r {A:Type} {n:nat}:
  (forall (i:nat), (i < S n)%nat -> A) -> (forall (i:nat), (i < n)%nat -> A)
  := fun f i ic => f i (lt_S ic).

(* Shrink function agrument of Vbuild by skipping the fist element *)
Definition shrink_vbuild_function_l {A:Type} {n:nat}:
  (forall (i:nat), (i < S n)%nat -> A) -> (forall (i:nat), (i < n)%nat -> A)
  := fun f i ic => f (S i) (lt_n_S ic).

Fixpoint vsequence {n:nat} {A:Type}
         {m} {M:Monad m}
         (mv: vector (m A) n): m (vector A n)
  := match mv with
     | Vnil => ret []
     | Vcons x xs =>
       x' <- x ;;
          xs' <- (vsequence xs) ;;
          ret (Vcons x' xs')
     end.

Lemma vsequence_Vmap_Some {A:Type} {n:nat} {v: vector A n} {f: A->A}:
  vsequence (Vmap (fun a => Some (f a)) v) = Some (Vmap f v).
Proof.
  induction v.
  -
    reflexivity.
  -
    simpl.
    break_match.
    +
      inversion IHv.
      rewrite <- H0.
      reflexivity.
    +
      inversion IHv.
Qed.

Require Import Coq.Logic.ProofIrrelevance.

Lemma vsequence_Vbuild_eq_Some
      {A: Type}
      {n: nat}
      {f: forall (i:nat), (i < n)%nat -> option A}
      {x: vector A n}
  : Vbuild f = Vmap Some x <->
    (@vsequence n A _ _ (Vbuild f)) = Some x.
Proof.
  split.
  -
    intros H.
    rewrite H.
    rewrite vsequence_Vmap_Some.
    f_equal.
    rewrite Vmap_id.
    reflexivity.
  -
    intros H.
    induction n.
    +
      rewrite Vbuild_0.
      dep_destruct x.
      reflexivity.
    +
      rewrite Vbuild_Sn.
      dep_destruct x. rename x0 into xs, h into x0.
      cbn.
      apply Vcons_eq_intro.
      *
        rewrite Vbuild_Sn in H.
        cbn in H.
        repeat break_match_hyp; try inversion H.
        reflexivity.
      *
        specialize (IHn (shrink_vbuild_function_l f) xs).
        rewrite <- IHn; clear IHn.
        --
          f_equal.
        --
          rewrite Vbuild_Sn in H.
          cbn in H.
          repeat break_match_hyp; try inversion H.
          apply inj_pair2 in H2.
          rewrite <- H2.
          rewrite <- Heqo0.
          f_equal.
Qed.

Lemma vsequence_cons_eq_None (A : Type) (n : nat) (v: vector (option A) n) (h:option A):
  vsequence (Vcons h v) = None <->
  ((h = None) \/ (vsequence v = None)).
Proof.
  split; intros H.
  -
    simpl in H.
    break_match_hyp.
    +
      right.
      break_match.
      inversion H.
      reflexivity.
    +
      left.
      reflexivity.
  -
    destruct H.
    *
      simpl.
      dep_destruct h.
      inversion H.
      reflexivity.
    *
      simpl.
      dep_destruct h.
      rewrite H.
      reflexivity.
      reflexivity.
Qed.

Lemma vsequence_eq_None:
  forall (A : Type) (n : nat) (v: vector (option A) n),
    vsequence v = None <-> (exists j (jc:j<n), Vnth v jc = None).
Proof.
  split.
  -
    intros H.
    induction n.
    +
      dep_destruct v.
      crush.
    +
      dep_destruct v.
      apply vsequence_cons_eq_None in H.
      destruct H.
      *
        exists 0.
        exists (zero_lt_Sn _).
        apply H.
      *
        specialize (IHn x H).
        destruct IHn as [j [jc IHn]].
        exists (S j).
        exists (lt_n_S jc).
        rewrite <- IHn.
        apply Vnth_Sn.
  -
    intros H.
    induction n.
    +
      dep_destruct v.
      crush.
    +
      dep_destruct v.
      specialize (IHn x).
      destruct H as [j [jc H]].
      apply vsequence_cons_eq_None.
      destruct j.
      left.
      *
        rewrite Vnth_0 in H.
        apply H.
      *
        right.
        apply IHn.
        exists j.
        exists (lt_S_n jc).
        rewrite <- H.
        symmetry; apply Vnth_Sn.
Qed.

Lemma vsequence_Vbuild_eq_None:
  forall (A : Type) (n : nat) (f : forall i : nat, (i < n)%nat -> option A),
  vsequence (Vbuild f) = None <-> (exists j (jc:j<n), f j jc = None).
Proof.
  intros A n f.
  split.
  -
    intros H.
    apply vsequence_eq_None in H.
    destruct H as [j [jc H]].
    rewrite Vbuild_nth in H.
    exists j.
    exists jc.
    apply H.
  -
    intros [j [jc H]].
    apply vsequence_eq_None.
    exists j.
    exists jc.
    rewrite Vbuild_nth.
    apply H.
Qed.

Lemma vsequence_Vbuild_is_Some:
  forall (A : Type) (n : nat) (f : forall i : nat, (i < n)%nat -> option A),
  util.is_Some (vsequence (Vbuild f)) <-> (forall j (jc:j<n), util.is_Some (f j jc)).
Proof.
  unfold util.is_Some.
  split.
  -
    intros H j jc.
    repeat break_match; auto.
    rename Heqo0 into H1.
    apply vsequence_Vbuild_eq_Some in H1.
    eapply Vnth_arg_eq with (ip:=jc) in H1.
    rewrite Vbuild_nth in H1.
    rewrite Vnth_map in H1.
    congruence.
  -
    intros H.
    repeat break_match; auto.
    rename Heqo into H1.
    apply vsequence_Vbuild_eq_None in H1.
    destruct H1 as [j [jc H1]].
    specialize (H j jc).
    break_match; auto.
    inversion H1.
Qed.


(* This file is extracted from the TLC library.
   http://github.com/charguer/tlc
   DO NOT EDIT. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Lists accessed with integers (not nat), using LibContainer typeclasses  *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
From SLF Require Import LibTactics LibLogic LibOperation LibReflect
  LibProd LibNat LibInt LibOption LibWf.
From SLF Require Export LibList LibNat.
From SLF Require Import LibInt.
From SLF Require Export LibContainer.

Open Scope Int_scope.
Local Open Scope comp_scope.

Ltac auto_tilde ::= eauto with maths.

(* ********************************************************************** *)
(* ################################################################# *)
(** * List operations using indices in Z *)

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Length, with result as [int] *)

(** Defined using a coercion from [nat] to [int] *)

Definition length A (l:list A) : int :=
  LibList.length l.

Section Length.
Variables A : Type.
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types i : int.

Lemma length_eq : forall l,
  length l = LibList.length l.
Proof using. auto. Qed.

Lemma abs_length : forall i l,
  i = length l ->
  abs i = LibList.length l.
Proof using.
  introv E. unfold length in E.
  applys eq_nat_of_eq_int.
  rewrite abs_nonneg; math.
Qed.

Lemma length_nonneg : forall (l: list A),
  0 <= length l.
Proof using. intros. rewrite length_eq. math. Qed.

Lemma length_nil :
  length (@nil A) = 0.
Proof using. auto. Qed.

Lemma length_cons : forall x l,
  length (x::l) = 1 + length l.
Proof using. intros. unfold length. rew_list~. Qed.

Lemma length_one: forall x,
  length (x::nil) = 1.
Proof using. reflexivity. Qed.

Lemma length_app : forall l1 l2,
  length (l1 ++ l2) = length l1 + length l2.
Proof using. intros. unfold length. rew_list~. Qed.

Lemma length_last : forall x l,
  length (l & x) = 1 + length l.
Proof using. intros. unfold length. rew_list~. Qed.

End Length.

Hint Rewrite length_nil length_cons length_app
 length_last : rew_list.
Hint Rewrite length_nil length_cons length_app
 length_last : rew_listx.
 (* --TODO: should we use a separate [rew_listZ] data base? probably so *)

(** Automation for [math], to unfold [length] *)

Hint Rewrite length_eq : rew_maths.

(** Demo of automation with maths *)

Goal forall A (l : list A), 0 <= length l.
Proof using. intros. math. Qed.

Goal forall (l : list Z) (s n : int),
  s <= n ->
  s = length l ->
  n >= 0.
Proof using. intros. math. Qed.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Inversion lemmas for structural composition *)

Section AppInversion.
Variables A : Type.
Implicit Types x : A.
Implicit Types l : list A.

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

Lemma length_zero_inv : forall l,
  length l = 0 ->
  l = nil.
Proof using. intros. unfolds length. applys~ LibList.length_zero_inv. Qed.

Lemma length_zero_eq_eq_nil : forall l,
  (length l = 0) = (l = nil).
Proof using.
  intros. unfolds length. rewrite <-LibList.length_zero_eq_eq_nil. math.
Qed.

Lemma length_neq_inv : forall l1 l2,
  length l1 <> length l2 ->
  (l1 <> l2).
Proof using. introv N E. subst*. Qed.

Lemma length_pos_inv_cons : forall l,
  (length l > 0) ->
  exists x l', l = x :: l'.
Proof using.
  intros. unfolds length. applys~ LibList.length_pos_inv_cons.
Qed.

Lemma length_pos_inv_last : forall l,
  (length l > 0) ->
  exists x l', l = l' & x.
Proof using.
  intros. unfolds length. applys~ LibList.length_pos_inv_last.
Qed.

End AppInversion.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [index], with length as [int], as typeclass *)

Definition index_impl A (l:list A) (i:int) : Prop :=
  index (LibList.length l : int) i.

Instance index_inst : forall A, BagIndex int (list A).
Proof using. constructor. rapply (@index_impl A). Defined.

Section Index.
Variables (A : Type).
Implicit Types l : list A.
Implicit Types n i : int.

Lemma index_eq_inbound : forall l i,
  index l i = (0 <= i < length l).
Proof using. auto. Qed.

Lemma index_of_inbound : forall l i,
  0 <= i < length l ->
  index l i.
Proof using. intros. rewrite~ index_eq_inbound. Qed.

Lemma index_eq_index_length : forall l i,
  index l i = index (length l) i.
Proof using. auto. Qed.

Lemma index_of_index_length : forall l i,
  index (length l) i ->
  index l i.
Proof using. introv H. rewrite* index_eq_index_length. Qed.

(** Reformulation of above, helpful for automation *)

Lemma index_of_index_length' : forall l n i,
  index n i ->
  n = length l ->
  index l i.
Proof using. intros. subst. rewrite~ index_eq_index_length. Qed.

End Index.

Global Opaque index_inst.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [read], with length as [int], as typeclass *)

Definition read_impl `{Inhab A} (l:list A) (i:int) : A :=
  If i < 0 then arbitrary else nth (abs i) l.

Instance read_inst : forall `{Inhab A}, BagRead int A (list A).
Proof using. constructor. rapply (@read_impl A H). Defined.

Section Read.
Context (A : Type) `{Inhab A}.
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types n i : int.

Lemma read_cons_case : forall l i v,
  (v::l)[i] = (If i = 0 then v else l[i-1]).
Proof using.
  introv. simpl. unfold read_impl. case_if.
  { case_if. math. case_if~. math. }
  { case_if~.
    { subst. rewrite abs_0. rew_listx~. }
    { rewrite~ abs_eq_succ_abs_minus_one. rew_listx.
      case_if. math. auto. } }
Qed.

Lemma read_zero : forall x l,
  (x::l)[0] = x.
Proof using.
  intros. rewrite read_cons_case. case_if. auto.
Qed.

Lemma read_succ : forall x l i,
  0 <= i < length l ->
  (x::l)[i+1] = l[i].
Proof using.
  introv M. rewrite read_cons_case. case_if. { math. }
  fequals. math.
Qed.

Lemma read_last_case : forall l i v,
  (l & v)[i] = (If i = length l then v else l[i]).
Proof using.
  introv. simpl. unfold read_impl. case_if.
  { case_if~; math. }
  { rewrite nth_last_case. rewrite~ abs_eq_nat_eq. }
Qed.

Lemma read_middle : forall i l1 l2 x,
  i = length l1 ->
  (l1 ++ x :: l2)[i] = x.
Proof.
  introv M. rewrite length_eq in M. unfold read, read_inst, read_impl.
  case_if. { false; math. }
  rewrite~ nth_middle.
Qed.

Lemma read_app : forall i l1 l2,
  (l1 ++ l2)[i] = (If i < length l1 then l1[i] else l2[i - length l1]).
Proof using.
  intros. rewrite length_eq. unfold read, read_inst, read_impl. case_if.
  { case_if. { auto. } { false; math. } }
  case_if as C'.
  { applys nth_app_l. applys lt_nat_of_lt_int. rewrite abs_nonneg; math. }
  case_if. { false; math. }
  rewrite abs_gt_minus_nat; [|math]. applys nth_app_r.
  { applys ge_nat_of_ge_int. rewrite abs_nonneg; math. }
Qed.

(** * Equality between two lists from equality of length and
      extensional equality of reads. *)

Lemma eq_of_extens_range : forall l1 l2,
  length l1 = length l2 ->
  (forall i, 0 <= i < length l1 -> l1[i] = l2[i]) ->
  l1 = l2.
Proof using.
  introv HL HR. do 2 rewrite length_eq in HL.
  unfold read, read_inst, read_impl in HR.
  applys~ LibList.eq_of_extens l1 l2.
  { intros n L. forwards M: (rm HR) (nat_to_Z n). math.
    case_if. false; math. rewrite~ abs_nat in M. }
Qed.

Lemma eq_of_extens : forall l1 l2,
  length l1 = length l2 ->
  (forall i, index l1 i -> l1[i] = l2[i]) ->
  l1 = l2.
Proof using. intros. applys~ eq_of_extens_range. Qed.

End Read.

Global Opaque read_inst.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [update], with index as [int], as typeclass *)

Definition update_impl A (l:list A) (i:int) (v:A) : list A :=
  If i < 0 then l else LibList.update (abs i) v l.

Instance update_inst : forall A, BagUpdate int A (list A).
Proof using. constructor. rapply (@update_impl A). Defined.

Section Update.
Transparent index_inst read_inst update_inst.
Context (A : Type) `{IA:Inhab A}.
Implicit Types x v w : A.
Implicit Types l : list A.
Implicit Types i j : int.

Lemma length_update : forall l i v,
  length (l[i:=v]) = length l.
Proof using.
  intros. unfold update_inst, update_impl, length, update. simpl.
  case_if. math. rewrite~ length_update.
Qed.

Lemma index_update_eq : forall l i j v,
  index (l[j:=v]) i = index l i.
Proof using. intros. rewrite index_eq_index_length in *. rewrite~ length_update. Qed.

Lemma index_update : forall l i j v,
  index l i ->
  index (l[j:=v]) i.
Proof using. intros. rewrite~ index_update_eq. Qed.

Lemma read_update_case : forall l i j v,
  index l j ->
  l[i:=v][j] = (If i = j then v else l[j]).
Proof using.
  introv. unfold index_inst, index_impl, update_inst, update_impl, update,
    read_inst, read_impl. simpl. introv N. rewrite int_index_eq in N.
  case_if. math.
  case_if. case_if. auto. case_if.
    subst. rewrite~ nth_update_same.
    rewrite~ nth_update_neq.
Qed.

Lemma read_update_same : forall l i v,
  index l i ->
  (l[i:=v])[i] = v.
Proof using. introv N. rewrite~ read_update_case. case_if~. Qed.

Lemma read_update_neq : forall l i j v,
  index l j ->
  (i <> j) ->
  (l[i:=v])[j] = l[j].
Proof using. introv N. rewrite~ read_update_case. case_if; auto_false~. Qed.

End Update.

Section UpdateNoInhab.
Transparent index_inst read_inst update_inst.
Context (A : Type).
Implicit Types x v w : A.
Implicit Types l : list A.
Implicit Types i j : int.

Lemma update_zero : forall v x l,
  (x::l)[0:=v] = v::l.
Proof using.
  intros. unfold update, update_inst, update_impl.
  case_if. false; math. rewrite~ update_zero.
Qed.

Lemma update_cons_pos : forall n v x l,
  n > 0 ->
  (x::l)[n:=v] = x::(l[(n-1):=v]).
Proof using.
  introv N. unfold update, update_inst, update_impl.
  do 2 (case_if; try solve [ false; math ]).
  rewrite~ update_cons_pos.
  { fequals_rec. rewrite <- abs_gt_minus_nat. fequals. math. }
Qed.

Lemma update_update_same : forall l i v w,
  index l i ->
  l[i:=v][i:=w] = l[i:=w].
Proof using.
  intros. asserts IA: (Inhab A). typeclass.
  eapply eq_of_extens; repeat rewrite length_update. { auto. }
  intros k Hk. repeat rewrite index_update_eq in Hk.
  repeat rewrite read_update_case by eauto using index_update.
  case_if~.
Qed.

Lemma update_update_neq : forall l i j v w,
  index l i ->
  index l j ->
  i <> j ->
  l[i:=v][j:=w] = l[j:=w][i:=v].
Proof using.
  intros. asserts IA: (Inhab A). typeclass.
  applys eq_of_extens; repeat rewrite length_update. { auto. }
  intros k Hk. repeat rewrite index_update_eq in Hk.
  repeat rewrite read_update_case by eauto using index_update.
  repeat case_if~.
Qed.

Lemma update_app_l : forall l1 i l2 v,
  0 <= i < length l1 ->
  (l1 ++ l2)[i:=v] = (l1[i:=v]) ++ l2.
Proof using.
  introv N. asserts IA: (Inhab A). typeclass.
  unfold LibContainer.update, update_inst, update_impl.
  rewrite length_eq in N. case_if~. rewrite~ update_app_l.
Qed.

Lemma update_app_r : forall l2 j l1 i ij v,
  i = length l1 ->
  0 <= j ->
  ij = i + j ->
  (l1 ++ l2)[ij:=v] = l1 ++ (l2[j:=v]).
Proof using.
  intros. asserts IA: (Inhab A). typeclass. subst ij.
  unfold LibContainer.update, update_inst, update_impl.
  do 2 (case_if; [ math | ]).
  rewrite Zabs2Nat.inj_add; try math. subst i.
  rewrite length_eq. rewrite abs_nat.
  rewrite~ update_app_r. fequals_rec. math.
Qed.

Lemma update_middle : forall i l1 l2 v w,
  i = length l1 ->
  (l1 ++ w :: l2)[i := v] = l1 & v ++ l2.
Proof using.
  introv E. rewrites~ (>> update_app_r 0 i).
  rewrite update_zero. rew_list~.
Qed.

End UpdateNoInhab.

Global Opaque update_inst.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [make], with length as [int] *)

Definition make A (n:int) (v:A) : list A :=
  If n < 0 then arbitrary else make (abs n) v.

Section Make.
Transparent index_inst read_inst.
Context (A : Type) {IA:Inhab A}.
Implicit Types x v : A.
Implicit Types l : list A.
Implicit Types n i : int.

Lemma length_make : forall n v,
  n >= 0 ->
  length (make n v) = n.
Proof using.
  introv N. unfold make. case_if. math.
  unfold length. rewrite LibList.length_make.
  rewrite~ abs_nonneg.
Qed.

Lemma index_make : forall n i v,
  index n i ->
  index (make n v) i.
Proof using.
  introv H. rewrite index_eq_index_length.
  rewrite int_index_eq in H.
  rewrite~ length_make.
Qed.

Lemma read_make : forall i n v,
  index n i ->
  (make n v)[i] = v.
Proof using.
  introv N. rewrite int_index_eq in N.
  unfold make, read_inst, read_impl.
  case_if. math. simpl. case_if. math.
  applys nth_make. forwards: lt_abs_abs i n; try math.
Qed.

Lemma make_zero : forall v,
  make 0 v = nil.
Proof using.
  intros. unfold make. case_if. { false; math. }
  asserts_rewrite (abs 0 = 0%nat).
  { applys eq_nat_of_eq_int. rewrite abs_nonneg; math. }
  auto.
Qed.

End Make.

Section MakeNoInhab.
Transparent index_inst read_inst.
Context (A : Type).
Implicit Types x v : A.
Implicit Types l : list A.
Implicit Types n i : int.

Lemma make_succ_l : forall n v,
  n >= 0 ->
  make (n+1) v = v :: make n v.
Proof using.
  introv N. unfold make. case_if; case_if; try solve [false;math].
  rewrite <- LibList.make_succ. fequal.
  { rewrite succ_abs_eq_abs_one_plus. fequal. math. math. }
Qed.

Lemma make_succ_r : forall n v,
  n >= 0 ->
  make (n+1) v = make n v & v.
Proof using.
  intros. asserts IA: (Inhab A). applys Inhab_of_val v.
  applys eq_of_extens_range.
  { rewrite length_make. rew_list. rewrite length_make.
    math. math. math. }
  { intros i Ei. rewrite length_make in Ei; [| math ].
    rewrite read_make; [| rewrite int_index_eq; math ].
    rewrite read_app. rewrite length_make; [|math].
    case_if as C.
    { rewrite read_make. auto. rewrite int_index_eq; math. }
    { math_rewrite (i-n = 0). rewrite~ read_zero. } }
Qed.

Lemma make_eq_cons_make_pred : forall n v,
  0 < n ->
  make n v = v :: (make (n-1) v).
Proof using.
  intros. math_rewrite (n = (n-1)+1). rewrite make_succ_l.
  fequals_rec. math. math.
Qed.

End MakeNoInhab.

Global Opaque make.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [LibList.rev] interactions with [LibListZ] operations *)

Section Rev.
Variables (A : Type).
Implicit Types x : A.
Implicit Types l : list A.

Lemma length_rev : forall l,
  length (rev l) = length l.
Proof using. intros. unfold length. rew_list~. Qed.

End Rev.

Hint Rewrite length_rev : rew_list.
Hint Rewrite length_rev : rew_listx.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [LibList.map] interactions with [LibListZ] operations *)

Section Map.
Transparent index_inst read_inst update_inst.
(*Context (A : Type).
Implicit Types x v : A.
Implicit Types l : list A.
*)
Implicit Types n i : int.

Lemma length_map : forall A B (l:list A) (f:A->B),
  length (map f l) = length l.
Proof using. intros. unfold length. rewrite~ length_map. Qed.

Lemma index_map_eq : forall A B (l:list A) i (f:A->B),
  index (map f l) i = index l i.
Proof using. intros. rewrite index_eq_inbound in *. rewrite~ length_map. Qed.

Lemma index_map : forall A B (l:list A) i (f:A->B),
  index l i -> index (map f l) i.
Proof using. intros. rewrite~ index_map_eq. Qed.

Lemma map_make : forall A B (f:A->B) (n:int) (v:A),
  n >= 0 ->
  map f (make n v) = make n (f v).
Proof using.
  Transparent make.
  intros. unfold make. case_if. { false; math. }
  applys map_make.
Qed.

Lemma map_update : forall A B (l:list A) (i:int) (x:A) (f:A->B),
  index l i ->
  map f (l[i := x]) = (map f l)[i := f x].
Proof using.
  introv H. rewrite index_eq_inbound in H.
  unfold update_inst, update_impl, update. simpl.
  case_if. { false; math. }
  { applys LibList.map_update.
    { applys lt_nat_of_lt_int. rewrite abs_nonneg; math. } }
Qed.

Lemma read_map : forall `{IA:Inhab A} `{IB:Inhab B} (l:list A) (i:int) (f:A->B),
  index l i ->
  (map f l)[i] = f (l[i]).
Proof using.
  introv H. rewrite index_eq_inbound in H.
  unfold read_inst, read_impl. simpl. case_if.
  { false; math. }
  { rewrite nth_map. auto.
    applys lt_nat_of_lt_int. rewrite abs_nonneg; math. }
Qed.

End Map.

Hint Rewrite length_map index_map_eq : rew_listx.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [LibList.filter] interactions with [LibListZ] operations *)

Section Filter.
Variables (A : Type).
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types P : A -> Prop.

Lemma length_filter : forall l P,
  length (filter P l) <= length l.
Proof using.
  intros. unfolds length. forwards~: LibList.length_filter l P.
Qed.

Lemma filter_length_two_disjoint : forall (P Q : A-> Prop) l,
  (forall x, mem x l -> P x -> Q x -> False) ->
  length (filter P l) + length (filter Q l) <= length l.
Proof using.
  intros. unfolds length.
  forwards~: LibList.filter_length_two_disjoint.
Qed.

Lemma filter_length_partition : forall P l,
    length (filter (fun x => P x) l)
  + length (filter (fun x => ~ P x) l)
  <= length l.
Proof using.
  intros. unfolds length. forwards~: LibList.filter_length_partition P l.
Qed.

Lemma length_filter_eq_mem_ge_one : forall x l,
  mem x l ->
  length (filter (= x) l) >= 1.
Proof using.
  intros. unfolds length. forwards~: LibList.length_filter_eq_mem_ge_one.
Qed.

End Filter.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [LibList.remove] interactions with [LibListZ] operations *)

Section Remove.
Variables (A : Type).
Implicit Types a x : A.
Implicit Types l : list A.

Lemma length_remove : forall l a,
  length (LibList.remove a l) <= length l.
Proof using. intros. rewrite remove_as_filter. applys length_filter. Qed.

Lemma length_remove_mem : forall x l,
  mem x l ->
  length (LibList.remove x l) < length l.
Proof using.
  intros. unfolds length. forwards~: LibList.length_remove_mem.
Qed.

End Remove.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Take, with an [int] as the number of elements *)

Definition take A (n:int) (l:list A) : list A :=
  LibList.take (to_nat n) l.

Section Take.
Variables (A : Type).
Implicit Types n : int.
Implicit Types x : A.
Implicit Types l : list A.

Lemma take_nil : forall n,
  take n (@nil A) = nil.
Proof using. intros. unfold take. apply LibList.take_nil. Qed.

Lemma take_zero : forall l,
  take 0 l = nil.
Proof using. auto. Qed.

Lemma take_succ : forall x l n,
  0 <= n ->
  take (n+1) (x::l) = x :: (take n l).
Proof using.
  intros. unfold take. rew_to_nat_nonneg~.
  rewrite Nat.add_1_r. apply LibList.take_succ.
Qed.

Definition take_cons := take_succ.

Lemma take_cons_pos : forall x l n,
  (n > 0) ->
  take n (x::l) = x :: (take (n-1) l).
Proof using.
  intros. unfold take. rew_to_nat_nonneg~.
  rewrite~ LibList.take_cons_pos.
Qed.

Lemma take_neg : forall n l,
  n <= 0 ->
  take n l = nil.
Proof using. intros. unfold take. rewrite~ to_nat_neg. Qed.

Lemma take_ge : forall n l,
  (n >= length l) ->
  take n l = l.
Proof using.
  intros. unfold take, length in *. applys~ LibList.take_ge.
Qed.

Lemma take_is_prefix : forall n l,
  exists q, l = take n l ++ q.
Proof using.
  intros. unfold take. applys~ LibList.take_is_prefix.
Qed.

Lemma take_app_l : forall n l l',
  (n <= length l) ->
  take n (l ++ l') = take n l.
Proof using.
  intros. tests: (0 <= n).
  { unfold take, length in *.
    applys~ LibList.take_app_l. }
  { rewrite !take_neg; auto; math. }
Qed.

Lemma take_app_r : forall n l l',
  (n >= length l) ->
  take n (l ++ l') = l ++ take (n - length l) l'.
Proof using.
  intros. unfold take, length in *. rew_to_nat_nonneg~.
  applys~ LibList.take_app_r.
Qed.

Lemma take_prefix_length : forall l l',
  take (length l) (l ++ l') = l.
Proof using.
  intros. unfold take, length. rew_to_nat_nonneg~.
  applys~ LibList.take_prefix_length.
Qed.

Lemma take_full_length : forall l,
  take (length l) l = l.
Proof using.
  intros. unfold take, length. rew_to_nat_nonneg~.
  apply LibList.take_full_length.
Qed.

(* See below for [length_take] and other properties *)

End Take.

(* Arguments take [A] : simpl never. *)

Hint Rewrite take_nil take_zero take_succ : rew_listx.
(* Note: [take_prefix_length] and [take_full_length]
   may be safely added to [rew_listx]. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Drop, with an [int] as the number of elements. *)

Definition drop A (n:int) (l:list A) : list A :=
  LibList.drop (to_nat n) l.

Section Drop.
Variables (A : Type).
Implicit Types n : int.
Implicit Types x : A.
Implicit Types l : list A.

Lemma drop_nil : forall n,
  drop n (@nil A) = nil.
Proof using. intros. unfold drop. apply LibList.drop_nil. Qed.

Lemma drop_zero : forall l,
  drop 0 l = l.
Proof using. auto. Qed.

Lemma drop_succ : forall x l n,
  0 <= n ->
  drop (n+1) (x::l) = (drop n l).
Proof using.
  intros. unfold drop. rew_to_nat_nonneg~.
  rewrite Nat.add_1_r. apply LibList.drop_succ.
Qed.

Definition drop_cons := drop_succ.

Lemma drop_neg : forall n l,
  n <= 0 ->
  drop n l = l.
Proof using. intros. unfold drop. rewrite~ to_nat_neg. Qed.

Lemma drop_cons_pos : forall x l n,
  (n > 0) ->
  drop n (x::l) = drop (n-1) l.
Proof using.
  intros. unfold drop. rew_to_nat_nonneg~.
  apply~ LibList.drop_cons_pos.
Qed.

Lemma drop_is_suffix : forall n l,
  exists q, l = q ++ drop n l.
Proof using.
  intros. unfold drop. apply LibList.drop_is_suffix.
Qed.

Lemma drop_app_l : forall n l l',
  (n <= length l) ->
  drop n (l ++ l') = drop n l ++ l'.
Proof using.
  intros. tests: (0 <= n).
  { unfold drop, length in *.
    apply LibList.drop_app_l. rewrites~ to_nat_le_nat_le. }
  { rewrite !drop_neg; auto; math. }
Qed.

Lemma drop_app_r : forall n l l',
  (n >= length l) ->
  drop n (l ++ l') = drop (n - length l) l'.
Proof using.
  intros. unfold drop, length in *. rew_to_nat_nonneg~.
  apply LibList.drop_app_r. rewrites~ to_nat_ge_nat_ge.
Qed.

Lemma drop_app_length : forall l l',
  drop (length l) (l ++ l') = l'.
Proof using.
  intros. unfold drop, length. rew_to_nat_nonneg~.
  apply LibList.drop_app_length.
Qed.

Lemma drop_at_length : forall l,
  drop (length l) l = nil.
Proof using.
  intros. unfold drop, length. rew_to_nat_nonneg~.
  apply LibList.drop_at_length.
Qed.

(* See below for [length_drop] and other properties *)

End Drop.

(* Arguments drop [A] : simpl never. *)

Hint Rewrite drop_nil drop_zero drop_succ : rew_listx.
(* Note: [drop_prefix_length] and [drop_full_length]
   may be safely added to [rew_list]. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Take and drop decomposition of a list *)

Section TakeAndDrop.
Variables (A : Type).
Implicit Types x : A.
Implicit Types l : list A.

Lemma take_app_drop_spec : forall n l f r,
  f = take n l ->
  r = drop n l ->
  (0 <= n <= length l ->
      l = f ++ r
   /\ length f = n
   /\ length r = length l - n) /\
  (n <= 0 ->
    f = nil /\ r = l).
Proof using.
  introv ? ?. split.
  { intros (? & Hn). unfold take, drop, length in *.
    forwards~ (? & ? & Hlenrest): @LibList.take_app_drop_spec (to_nat n) l f r. }
  { intros. rewrites~ take_neg in *. rewrites~ drop_neg in *. }
Qed.

Lemma take_spec : forall n l,
  0 <= n <= length l ->
  exists l', length (take n l) = n
          /\ l = (take n l) ++ l'.
Proof using. introv E. forwards* (E1&_): take_app_drop_spec. forwards*: E1. Qed.

Lemma length_take_nonneg : forall n l,
  0 <= n <= length l ->
  length (take n l) = n.
Proof using. introv E. forwards~ (l'&N&M): take_spec n l. Qed.

Lemma length_take : forall n l,
  n <= length l ->
  length (take n l) = Z.max 0 n.
Proof using.
  intros. tests: (0 <= n).
  { rewrite~ length_take_nonneg. }
  { rewrite~ take_neg. rewrite~ Z.max_l. }
Qed.

Lemma drop_spec : forall n l,
  0 <= n <= length l ->
  exists l', length l' = n
          /\ l = l' ++ (drop n l).
Proof using. introv E. forwards* (E1&_): take_app_drop_spec. forwards*: E1. Qed.

Lemma length_drop_nonneg : forall n l,
  0 <= n <= length l ->
  length (drop n l) = length l - n.
Proof using.
  introv E. forwards~ (l'&N&M): drop_spec n l.
  pattern l at 2. rewrite M. rew_list. math.
Qed.

Lemma length_drop : forall n l,
  n <= length l ->
  length (drop n l) = Z.min (length l) (length l - n).
Proof using.
  intros. tests: (0 <= n).
  { rewrite~ length_drop_nonneg. }
  { rewrite~ drop_neg. }
Qed.

Lemma list_eq_take_app_drop : forall n l,
  n <= length l ->
  take n l ++ drop n l = l.
Proof using.
  introv H. tests: (0 <= n).
  { forwards*: take_app_drop_spec n l. }
  { rewrite~ take_neg. rewrite~ drop_neg. }
Qed.

End TakeAndDrop.

Arguments take_app_drop_spec [A].
Arguments take_spec [A].
Arguments drop_spec [A].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [count], returning an int *)

Definition count A (P: A -> Prop) (l: list A): int :=
  abs (LibList.count P l).

Section Count.
Variables A : Type.
Implicit Types l : list A.
Implicit Types P : A -> Prop.

Ltac gowith L :=
  let H := fresh in
  lets H: L;
  repeat (let x := fresh in intro x; specializes H x);
  unfold count in *; repeat rewrites~ abs_nonneg in *;
  try solve [
    first [ rewrites~ H in * | forwards~: H ];
    repeat case_if~
  ].

(* Rewriting *)

Lemma count_nil : forall P,
  count P nil = 0.
Proof using. auto. Qed.

Lemma count_one : forall P x,
  count P (x::nil) = If P x then 1 else 0.
Proof using. gowith LibList.count_one. Qed.

Lemma count_cons : forall P l x,
  count P (x::l) = count P l + If P x then 1 else 0.
Proof using. gowith LibList.count_cons. Qed.

Lemma count_app : forall P l1 l2,
  count P (l1++l2) = count P l1 + count P l2.
Proof using. gowith LibList.count_app. Qed.

Lemma count_last : forall P l x,
  count P (l&x) = count P l + If P x then 1 else 0.
Proof using. gowith LibList.count_last. Qed.

Lemma count_rev : forall P l,
  count P (rev l) = count P l.
Proof using. gowith LibList.count_rev. Qed.

Lemma count_eq_length_filter : forall P l,
  count P l = length (filter P l).
Proof using. gowith LibList.count_eq_length_filter. Qed.

(* Properties *)

Lemma count_nonneg : forall P l,
  0 <= count P l.
Proof using. intros. unfold count. math. Qed.

Lemma count_le_length : forall P l,
  count P l <= length l.
Proof using. gowith LibList.count_le_length. Qed.

(* Interactions with [Forall] *)

Lemma Forall_eq_count_eq_length : forall P l,
  Forall P l = (count P l = length l).
Proof using.
  intros. rewrite LibList.Forall_eq_count_eq_length, length_eq.
  unfold count. rewrite abs_nonneg; math.
Qed.

Lemma count_Forall : forall P l,
  Forall P l ->
  count P l = length l.
Proof using. introv. rewrite~ Forall_eq_count_eq_length. Qed.

Lemma Forall_of_count_eq_length : forall P l,
  count P l = length l ->
  Forall P l.
Proof using. introv. rewrite~ Forall_eq_count_eq_length. Qed.

(* Interactions with [Forall (pred_not P)] *)

Lemma Forall_not_eq_count_eq_zero : forall P l,
  Forall (fun x => ~ P x) l = (count P l = 0).
Proof using.
  intros. rewrite LibList.Forall_not_eq_count_eq_zero.
  unfold count. rewrite abs_nonneg; math.
Qed.

Lemma Forall_not_of_count_eq_zero : forall P l,
  count P l = 0 ->
  Forall (fun x => ~ P x) l.
Proof using. introv. rewrite~ Forall_not_eq_count_eq_zero. Qed.

Lemma count_eq_zero_of_Forall_not : forall P l,
  Forall (fun x => ~ P x) l ->
  count P l = 0.
Proof using. introv. rewrite~ Forall_not_eq_count_eq_zero. Qed.

(* Interactions with [Exists] *)

Lemma Exists_eq_count_pos : forall P l,
  Exists P l = (count P l > 0).
Proof using.
  intros. rewrite LibList.Exists_eq_count_pos.
  unfold count. rewrite abs_nonneg; math.
Qed.

Lemma Exists_of_count_pos : forall P l,
  count P l > 0 ->
  Exists P l.
Proof using. introv. rewrite~ Exists_eq_count_pos. Qed.

Lemma count_pos_of_Exists : forall P l,
  Exists P l ->
  count P l > 0.
Proof using. introv. rewrite~ Exists_eq_count_pos. Qed.

(* Interactions with [mem] *)

Lemma count_pos_eq_exists_mem : forall P l,
  (count P l > 0) = (exists x, mem x l /\ P x).
Proof using.
  intros. rewrite <- LibList.count_pos_eq_exists_mem.
  unfold count. rewrite abs_nonneg; math.
Qed.

Lemma count_pos_of_mem : forall x P l,
  mem x l ->
  P x ->
  count P l > 0.
Proof using. introv. rewrite* count_pos_eq_exists_mem. Qed.

Lemma exists_mem_of_count_pos : forall P l,
  count P l > 0 ->
  exists x, mem x l /\ P x.
Proof using. introv. rewrite* count_pos_eq_exists_mem. Qed.

End Count.

Opaque count.

Hint Rewrite count_nil count_cons count_app count_last count_rev : rew_listx.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [card], with result as [nat], as typeclass *)

(** Note that [card] produces a [nat], whereas [length] produces an [int].
    Currently, in practice, we use [LibList.length] rather than [card]. *)

Definition card_impl A (l:list A) : nat :=
  LibList.length l.

Instance card_inst : forall A, BagCard (list A).
Proof using. constructor. rapply (@card_impl A). Defined.

Global Opaque card_inst.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Normalization tactics *)

(** [rew_array_nocase] is a light normalization tactic for array *)

Hint Rewrite @read_make @length_make @length_update @read_update_same
  : rew_array_nocase.

Tactic Notation "rew_array_nocase" :=
  autorewrite with rew_array_nocase.
Tactic Notation "rew_array_nocase" "in" hyp(H) :=
  autorewrite with rew_array_nocase in H.
Tactic Notation "rew_array_nocase" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_array_nocase).
  (* autorewrite with rew_array_nocase in *. *)
Tactic Notation "rew_array_nocase" "~" :=
  rew_array_nocase; auto_tilde.
Tactic Notation "rew_array_nocase" "*" :=
  rew_array_nocase; auto_star.
Tactic Notation "rew_array_nocase" "~" "in" hyp(H) :=
  rew_array_nocase in H; auto_tilde.
Tactic Notation "rew_array_nocase" "*" "in" hyp(H) :=
  rew_array_nocase in H; auto_star.
Tactic Notation "rew_array_nocase" "~" "in" "*" :=
  rew_array_nocase in *; auto_tilde.
Tactic Notation "rew_array_nocase" "*" "in" "*" :=
  rew_array_nocase in *; auto_star.

(** [rew_array] is a normalization tactic for array, which introduces
    case analyses for all read-on-update operations. *)

Hint Rewrite @read_make @length_make @length_update @read_update_same
  @read_update_case @read_cons_case @read_last_case : rew_array.

Tactic Notation "rew_array" :=
  autorewrite with rew_array.
Tactic Notation "rew_array" "in" hyp(H) :=
  autorewrite with rew_array in H.
Tactic Notation "rew_array" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_array).
  (* autorewrite with rew_array in *. *)
Tactic Notation "rew_array" "~" :=
  rew_array; auto_tilde.
Tactic Notation "rew_array" "*" :=
  rew_array; auto_star.
Tactic Notation "rew_array" "~" "in" hyp(H) :=
  rew_array in H; auto_tilde.
Tactic Notation "rew_array" "*" "in" hyp(H) :=
  rew_array in H; auto_star.
Tactic Notation "rew_array" "~" "in" "*" :=
  rew_array in *; auto_tilde.
Tactic Notation "rew_array" "*" "in" "*" :=
  rew_array in *; auto_star.

(* **********************************************************************

    Restore automation *)

Ltac auto_tilde ::= auto_tilde_default.

(* **********************************************************************

    FUTURE WORK *)

(*-- Lemmas on tail; is this useful? *)

(*
Lemma length_tail : forall l,
  l <> nil ->
  length (tail l) = length l - 1.
Proof using. induction l; intros; simpl; unfold length; rew_list. congruence. math. Qed.

Lemma length_tail_le : forall l,
  length (tail l) <= length l.
Proof using. destruct l; simpl; unfold length; rew_list; math. Qed.

Lemma length_le_1_inv_tail_eq_nil : forall l,
  length l <= 1 ->
  tail l = nil.
Proof using.
  intros. destruct l; eauto.
  simpl. unfold length in *. rew_list in *.
  eapply length_zero_inv. math.
Qed.
*)

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [binds], with length as [int], as typeclass *)

(* --LATER: is this any useful?

  Definition binds_impl A (l:list A) (i:int) (v:A) : Prop :=
    index_impl l i /\ nth i l = v.

  Instance binds_inst : forall A, BagBinds int A (list A).
  Proof using. constructor. rapply (@binds_impl A). Defined.

  Global Opaque binds_inst

*)

(* 2021-08-11 15:24 *)


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

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.


(** * NaiveSet.v : The general naive set theory. *)

From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality.

From Coq Require Import Classical Relations.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

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

(** *** Reserved Notations for naive_set *)
Declare Scope NSet_scope.
Open Scope NSet_scope.

Reserved Notation " '𝒫(' T ) " (format "'𝒫(' T )").
Reserved Notation " s '∈' S " (at level 50).
Reserved Notation " s '∉' S " (at level 50).
Reserved Notation " {  expr , x .. y | cond  } " (x binder, at level 0, expr at level 99).
Reserved Notation "∅".
Reserved Notation " '𝒫(' T ')₊' ".
Reserved Notation "'𝕌'".
Reserved Notation " A '⊆' B " (at level 49).
Reserved Notation " A '⊇' B " (at level 49).
Reserved Notation " A '∪' B " (at level 43).
Reserved Notation " A '∩' B " (at level 42).
Reserved Notation " '∁' A" (at level 39).

Reserved Notation "⋃".
Reserved Notation "⋂".
Reserved Notation " f [<] " (at level 11, right associativity).
Reserved Notation " F [>] " (at level 11, right associativity).
Reserved Notation " F [<<] " (at level 11, right associativity).
Reserved Notation " F [><] " (at level 11, right associativity).

(** TODO #11 *)
Reserved Notation "'forall'' x '∈' A , expr" (at level 80, x at level 20, A at level 80, expr at level 80).
Reserved Notation "'exists'' x '∈' A , expr" (at level 80, x at level 20, A at level 80, expr at level 80).
Reserved Notation "'forall'' A '⊆' B , expr" (at level 80, A at level 20, B at level 80, expr at level 80).
Reserved Notation "'exists'' A '⊆' B , expr" (at level 80, A at level 20, B at level 80, expr at level 80).
Reserved Notation "'∀'' x '∈' A , expr" (at level 80, x at level 20, A at level 80, expr at level 80).
Reserved Notation "'∃'' x '∈' A , expr" (at level 80, x at level 20, A at level 80, expr at level 80).
Reserved Notation "'∀'' A '⊆' B , expr" (at level 80, A at level 20, B at level 80, expr at level 80).
Reserved Notation "'∃'' A '⊆' B , expr" (at level 80, A at level 20, B at level 80, expr at level 80).

Reserved Notation " {{ x , .. , y }} " (at level 20).

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

(** ** Set Definition *)

(** The equivalence between predicates. *)
Lemma predeqP {T : Type} (p q : T -> Prop) : p = q <-> (forall x, p x <-> q x).
Proof. split.
    by move => ->.
    move => H. apply functional_extensionality => x.
    apply propositional_extensionality. by apply H.
Qed.

(** powerset
    The type [powerset T] is indeed the power powerset of T, because every element of it
    has the [chac] function, which corresponds to a [sig] type. And the [sig]
    type further corresponds to subsets in maths. *)
Record powerset (T : Type) := mk_set {
    chac : T -> Prop;
}.
(** This notation means 'power set'. *)
Notation " '𝒫(' T ) " := (powerset T) (format "'𝒫(' T )") : NSet_scope.
Notation " s '∈' S " := ((chac S) s) : NSet_scope.
Notation " s '∉' S " := (~ s ∈ S) : NSet_scope.
Notation "{  x : A | P  }" := (mk_set (T:=A) (fun x => P)) : NSet_scope.
Notation "{  x | P  }" := (mk_set (fun x => P)) : NSet_scope.
Notation "{ expr , x .. y | cond }" :=
    { a | (exists x, .. (exists y, cond /\ a = expr ) ..) } : NSet_scope.

Notation "'forall'' x '∈' A , expr" := (forall x , x ∈ A -> expr)
        (only parsing): NSet_scope.
Notation "'exists'' x '∈' A , expr" := (exists x , x ∈ A /\ expr)
        (only parsing): NSet_scope.
Notation "'∀'' x '∈' A , expr" := (forall x , x ∈ A -> expr) : NSet_scope.
Notation "'∃'' x '∈' A , expr" := (exists x , x ∈ A /\ expr) : NSet_scope.

(** TODO We should add a lemma to move the binder right and left in the set description
    { f a b , a b | a ∈ A /\ b ∈ B } = { f a [<] B , a | a ∈ A }
*)

(** The equivalence between sets. *)
Lemma seteq_predP {T : Type} (A B : 𝒫(T)) : A = B <-> chac A = chac B.
Proof. split. by move => ->. destruct A, B => /= -> //. Qed.

(** The equivalence between sets (2). *)
Lemma seteqP {T : Type} (A B : 𝒫(T)) :
    A = B <-> (forall x, x ∈ A <-> x ∈ B).
Proof.
    split. by move => ->.
    move => H. by apply /seteq_predP /predeqP.
Qed.

(** This one needs classical logic. *)
Lemma setneqP {T : Type} (A B : 𝒫(T)) :
    A <> B <-> ((exists x, x ∈ A /\ x ∉ B) \/ (exists x, x ∈ B /\ x ∉ A)).
Proof. split.
    move => HAneqB. apply NNPP => H. apply HAneqB.
    apply not_or_and in H. destruct H as [H1 H2].
Admitted.

(** The set we defined can be converted into a sigma type, which corresponds to
    the subset in type system. *)
Coercion set2sigma (T : Type) (A : 𝒫(T)) : Type := sig (chac A).

Lemma belongs_to [T : Type] : forall (A : 𝒫(T)) (a : A), proj1_sig a ∈ A.
Proof. move => A a. by apply (proj2_sig a). Qed.

(** The empty set. *)
Definition set_em (T : Type) : 𝒫(T) := { x | False }.
Notation "∅" := (set_em _).

(** The universal set (of type T). *)
Definition set_uni (T : Type) : 𝒫(T) := { x | True }.
Notation "'𝕌'" := (set_uni _).

Lemma in_set_em_F [T : Type] :
    forall (A : 𝒫(T)) (x : T), x ∈ A -> A = ∅ -> False.
Proof. move => A x Hx HA. rewrite HA in Hx. by destruct Hx. Qed.

(** The set is nonempty *)
Lemma nonemptyP {T : Type} (A : 𝒫(T)) :  A <> ∅ <-> exists x, x ∈ A.
Proof. split; last first.

    move => [x Hx] H. move: Hx H. by apply in_set_em_F.

    move => HA. apply NNPP => /(not_ex_all_not _ _) H.
    apply HA. apply /seteqP => x. split.
    by move => Hx; apply (H x).
    by move => [].

Qed.

(*##########################################################*)
(** type of nonempty set *)
Module NemSet.
Section ClassDef.

Definition mixin_of (T : Type) (A : 𝒫(T)) := A <> ∅.
Definition class_of := mixin_of.

Structure type (T : Type) := Pack {
    set : 𝒫(T);
    _ : class_of set;
}.

Variable (T : Type) (cT : type T).

Definition class := let: Pack _ c := cT return class_of (set cT) in c.

Definition pack := Pack.

End ClassDef.

Module Exports.
#[reversible] Coercion set : type >-> powerset.
Arguments class [T] cT.

Notation nemset := type.
Notation " '𝒫(' T ')₊' " := (type T) (format "'𝒫(' T )₊") : NSet_scope.

Notation NemSet T m := (@pack _ T m).
Notation "[ 'nemset' 'of' T ]" := (T : type _)
  (at level 0, format "[ 'nemset'  'of'  T ]") : NSet_scope.

(** This item returns [ ∃ x : _, x ∈ T ] directly. *)
Notation "[ 'nemset_witness' 'of' T ]" :=
    (iffLR (@nonemptyP _ _ ) (class T))
    (at level 0, format "[ 'nemset_witness'  'of'  T ]") : NSet_scope.

End Exports.

End NemSet.
Export NemSet.Exports.

(** subset relation *)
Definition subset {T : Type} (A B : 𝒫(T)) : Prop :=
    forall x, x ∈ A -> x ∈ B.
Notation " A '⊆' B " := (subset A B) : NSet_scope.

(** supset relation, which is dual to subset *)
Definition supset {T : Type} (A B : 𝒫(T)) : Prop := B ⊆ A.
Notation " A '⊇' B " := (supset A B) : NSet_scope.

Notation "'forall'' A '⊆' B , expr" := (forall A , A ⊆ B -> expr)
        (only parsing): NSet_scope.
Notation "'exists'' A '⊆' B , expr" := (exists A , A ⊆ B /\ expr)
        (only parsing): NSet_scope.
Notation "'∀'' A '⊆' B , expr" := (forall A , A ⊆ B -> expr) : NSet_scope.
Notation "'∃'' A '⊆' B , expr" := (exists A , A ⊆ B /\ expr) : NSet_scope.

Lemma subsupP {T : Type} (A B : 𝒫(T)) : A ⊆ B <-> B ⊇ A.
Proof. split; auto. Qed.

Lemma set_belong_cut {T : Type} (A B : 𝒫(T)) (x : T):
    x ∈ B -> B ⊆ A -> x ∈ A.
Proof. move => Hxin HBinA. apply HBinA. by apply Hxin. Qed.
Arguments set_belong_cut {_} [_] _.

(*
Lemma set_trichotomy {T : Type} (A B : 𝒫(T)) :
    A = B \/ A ⊆ B \/ A ⊇ B.
Proof.
*)

(** subset relation *)

(** subset_refl : A ⊆ A *)
Lemma subset_refl {T : Type}: reflexive _ (@subset T).
Proof. unfold reflexive, subset. auto. Qed.

(** subset_trans : A ⊆ B -> B ⊆ C -> A ⊆ C *)
Lemma subset_trans {T : Type}: transitive _ (@subset T).
Proof.
    unfold transitive, subset.
    intros A B C HAinB HBinC. intros x HxinA.
    apply HBinC. apply HAinB. apply HxinA.
Qed.

(** subset_asymm : A ⊆ B -> B ⊆ A -> A = B *)
Lemma subset_asymm {T : Type}: antisymmetric _ (@subset T).
Proof.
    rewrite /antisymmetric => A B HAinB HBinA.
    apply /seteqP => x. split.
    by apply HAinB. by apply HBinA.
Qed.

Add Parametric Relation {T : Type} : _ (@subset T)
    reflexivity proved by (@subset_refl T)
    transitivity proved by (@subset_trans T)
    as subset_rel.

(** supset relation *)

Lemma supset_refl {T : Type}: reflexive _ (@supset T).
Proof. unfold reflexive, supset, subset. auto. Qed.

Lemma supset_trans {T : Type}: transitive _ (@supset T).
Proof.
    unfold transitive, supset, subset.
    intros A B C HBinA HCinB. intros x HxinC.
    apply HBinA. apply HCinB. apply HxinC.
Qed.

Lemma supset_asymm {T : Type}: antisymmetric _ (@supset T).
Proof.
    rewrite /antisymmetric => A B HAinB HBinA.
    apply /seteqP => x. split.
    by apply HBinA. by apply HAinB.
Qed.

Add Parametric Relation {T : Type} : _ (@supset T)
    reflexivity proved by (@supset_refl T)
    transitivity proved by (@supset_trans T)
    as supset_rel.

(** tranform an element into the super set *)
Definition into_supset {T : Type} {A B : 𝒫(T)} (a : A) (HAB : A ⊆ B) : B.
Proof.
    destruct a.
    rewrite /set2sigma. refine (exist _ x _). by apply HAB.
Defined.

Notation "[ a 'in' HAB ]" := (into_supset a HAB) : NSet_scope.

Lemma eq_in_subset {T : Type} {A B : 𝒫(T)}
    (x y : A) (HAB : A ⊆ B) : [x in HAB] = [y in HAB] -> x = y.
Proof.
    rewrite /into_supset => H.
    destruct x as [x0 Hx0in], y as [y0 Hy0in].
    inversion H. move : Hx0in Hy0in H. rewrite H1.
    move => Hx0in Hy0in _. replace Hx0in with Hy0in => //.
    by apply proof_irrelevance.
Qed.
Arguments eq_in_subset {T A B} [x y] (HAB).

(** subset_em : ∅ ⊆ A *)
Lemma em_subset {T : Type}: forall (A : 𝒫(T)), ∅ ⊆ A.
Proof. by move => ?. Qed.

Lemma subset_emP {T : Type}: forall (A : 𝒫(T)), A ⊆ ∅ <-> A = ∅.
Proof.
    move => A. split.
    move => HAin. apply /seteqP => x. split.
    by apply HAin. by move => [].
    by move => ->.
Qed.

Lemma subset_uni {T : Type}: forall (A : 𝒫(T)), A ⊆ 𝕌.
Proof. by move => ?. Qed.

Lemma uni_subsetP {T : Type}: forall (A : 𝒫(T)), 𝕌 ⊆ A <-> A = 𝕌.
Proof.
    move => A. split.
    move => HAin. apply seteqP => x. split.
    by []. by apply HAin. by move => ->.
Qed.

(* some calculations between sets *)
Definition union {T : Type} (A B : 𝒫(T)) : 𝒫(T) := { x | x ∈ A \/ x ∈ B }.
Notation " A '∪' B " := (union A B) : NSet_scope.

Definition itsct {T : Type} (A B : 𝒫(T)) : 𝒫(T) := { x | x ∈ A /\ x ∈ B }.
Notation " A '∩' B " := (itsct A B) : NSet_scope.

Definition complement {T : Type} (A : 𝒫(T)) : 𝒫(T) := { x | x ∉ A }.
Notation " '∁' A" := (complement A) : NSet_scope.

Definition diff {T : Type} (A B: 𝒫(T)) : 𝒫(T) := { x | x ∈ A /\ x ∉ B }.
Notation " A / B " := (diff A B) : NSet_scope.

Add Parametric Morphism {T : Type} : (@union T)
    with signature (@subset T)==> (@subset T) ==> (@subset T) as union_mor_sub.
Proof.
    intros X Y HXinY A B HAinB.
    unfold union. simpl. unfold subset.
    intros x H.
    destruct H. left. by apply HXinY. right. by apply HAinB.
Qed.

Add Parametric Morphism {T : Type} : (@itsct T)
    with signature (@subset T) ==> (@subset T) ==> (@subset T) as itsct_mor_sub.
Proof.
    intros X Y HXinY A B HAinB.
    unfold union. simpl. unfold subset.
    intros x H.
    destruct H as [HxinX HxinA]. split.
    by apply HXinY. by apply HAinB.
Qed.

Add Parametric Morphism {T : Type} : (@complement T)
    with signature (@subset T) ==> (@supset T) as complement_mor_subsup.
Proof.
    rewrite /complement /supset /subset => A B HAB x //= HxninB HxinA.
    by apply /HxninB /HAB.
Qed.

Add Parametric Morphism {T : Type} : (@diff T)
    with signature (@subset T) ==> (@supset T) ==> (@subset T) as diff_mor_sub.
Proof.
    intros X Y HXinY A B HBinA.
    unfold subset, diff, not; simpl. intros x Hx.
    split. apply HXinY. by apply Hx. intros HxinB. apply HBinA in HxinB.
    by apply Hx.
Qed.

(* set by enumerating *)

Definition singleton {T : Type} (x : T) := { a | a = x }.

Notation "{{ x , .. , y }} " :=
    (singleton x ∪ .. (singleton y ∪ ∅) .. ) : NSet_scope.

(** This part, especially [mapL] [mapR] needs the notion of function, base on set. *)

Definition big_union {T : Type} (A : 𝒫(𝒫(T))) : 𝒫(T) :=
    { x | exists X, X ∈ A /\ x ∈ X }.
Notation "⋃" := big_union : NSet_scope.

Add Parametric Morphism {X : Type} : (@big_union X)
    with signature (@subset (𝒫(X))) ==> (@subset X) as bigU_mor_sub.
Proof.
    intros M N HMinN. unfold big_union, subset. simpl.
    intros x [S HS]. exists S. split. apply HMinN. apply HS. apply HS.
Qed.

Definition big_itsct {T : Type} (A : 𝒫(𝒫(T))) : 𝒫(T) :=
    { x | forall X, X ∈ A -> x ∈ X }.
Notation "⋂" := big_itsct : NSet_scope.

(** As is also confirmned in mathematica, this operation can be considered as a
    map. This [mapR] can be considered as the operator to lift a function.
*)
Definition mapR {X Y: Type} (f : X -> Y) : 𝒫(X) -> 𝒫(Y) :=
    fun A => { f x , x | x ∈ A }.
Notation " f [<] " := (@mapR _ _ f) : NSet_scope.

Lemma mapR_fold (X Y: Type) (f : X -> Y) A :
    { f a , a | a ∈ A } = f [<] A.
Proof. by []. Qed.

Add Parametric Morphism {X Y : Type} : (@mapR X Y)
    with signature eq ==> (@subset X) ==> (@subset Y) as mapR_mor_sub.
Proof.
    intros f M N HMinN. unfold mapR, subset. simpl.
    intros y [x Hxin]. exists x. split. apply HMinN.
    by apply Hxin. by apply Hxin.
Qed.

Definition mapL {X Y: Type} (F : 𝒫(X -> Y)) : X -> 𝒫(Y) :=
    fun x => { f x , f | f ∈ F }.

Notation " F [>] " := (@mapL _ _ F) : NSet_scope.

Add Parametric Morphism {X Y : Type} : (@mapL X Y)
    with signature (@subset (X -> Y)) ==> eq ==> (@subset Y) as mapL_mor_sub.
Proof.
    rewrite /mapL /subset => F G HFinG x //=.
    move => y [f [Hfin Hyeq]]. exists f. split => //. by apply HFinG.
Qed.

(** Note that this operator automatically contains a big union. *)
Definition UmapR {X Y: Type} (F : X -> 𝒫(Y)) : 𝒫(X) -> 𝒫(Y)
    := fun x => ⋃ (F [<] x).

Notation " F [<<] " := (@UmapR _ _ F) : NSet_scope.

Lemma UmapR_fold {X Y: Type} (F : X -> 𝒫(Y)) (A :  𝒫(X)) :

    ⋃ (F [<] A) = F [<<] A.

Proof. by rewrite /UmapR. Qed.

(** Note that this operator automatically contains a big union. *)
Definition UmapLR {X Y: Type} (F : 𝒫(X -> Y)) : 𝒫(X) -> 𝒫(Y)
    := fun x => ⋃ (F [>][<] x).

Notation " F [><] " := (@UmapLR _ _ F) : NSet_scope.

Lemma UmapLR_fold {X Y: Type} (F : 𝒫(X -> Y)) (A :  𝒫(X)) :

    ⋃ (F [>][<] A) = F [><] A.

Proof. by rewrite /UmapLR. Qed.

(*
(*  Example: Function Lifting
    言の葉ではなく…秘められし真意を伝えん!
*)
Axiom (A B C D: Type) (f : A -> B -> C -> D).
Check (fun x => f [<] x).
Check (fun x => f [<] x [>]).
Check (fun x => f [<] x [>][<<]).
Check (fun x y => ((f [<] x) [>])[<] y).
Check (fun x y z => f [<] x [>][<<] y [>][<<] z).
*)

(** lift operator of a function with two parameters *)
Definition funlift2 {X Y Z: Type} (f : X -> Y -> Z) : 𝒫(X) -> 𝒫(Y) -> 𝒫(Z) :=
    fun A B => f[<]A[>][<<]B.

(*

(* bi_ele_eq : { x , y } {=} { y , x } *)
Lemma bi_ele_eq : forall x y : T, {{ x , y }} {=} {{ y , x }}.
Proof
    intros. split; simpl.
    - intros. destruct H. right. left. apply H.
        destruct H. left. apply H. destruct H.
    - intros. destruct H. right. left. apply H.
        destruct H. left. apply H. destruct H.
Qed.

(* bi_ele_in : x ∈ X -> y ∈ X -> { x , y } ⊆ X *)
Lemma bi_ele_in (X : set T): forall' x ∈ X, forall' y ∈ X, {{x, y}} ⊆ X.
Proof. unfold subset. simpl. intros x HxinX y HyinX z H.
    destruct H. rewrite H. apply HxinX.
    destruct H. rewrite H. apply HyinX.
    destruct H.
Qed.

*)

(*#######################################################################*)
(** I am not sure whether this axiom is consistent.
    TODO #10 *)
Module TypeSetEquivalence.

Axiom type_eq_set : forall (T: Type), T = (set_uni T : Type).

(** shoule we add a axiom saying that the sigma type of a sigma type can be
    simplified? *)

End TypeSetEquivalence.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 8 *)

Require Import Frap.

(* Authors: Peng Wang (wangpeng@csail.mit.edu), Adam Chlipala (adamc@csail.mit.edu) *)

(* In class, we learned about a version of Hoare logic where every loop has an
 * invariant written right on it.  Hoare logic can also be defined over
 * completely conventional program syntax, where the person writing the proof
 * chooses a suitable invariant on every invocation of the loop rule.  This
 * style may be more appealing for its clear separation of the program
 * correctness property (the precondition and postcondition) from the
 * correctness argument (including loop invariants).  And we can still prove the
 * key *soundness* theorem for this logic, which will be your first task in this
 * problem set.  It also becomes easier to state a *completeness* property:
 * every true specification is provable, using just the Hoare-logic rules.
 * Proof of that fact will be your second task, and it will require some
 * different ingredients than in the soundness proof. *)

(* Let's start with a big-step semantics for the no-loop-invariants imperative
 * language.  The language we will use is a simplified version of the one in
 * class, stripping away heap operations. *)
Inductive exp :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp).

(* Boolean expression syntax *)
Inductive test :=
| Eq (e1 e2 : exp)
| NotEq (e1 e2 : exp).

Inductive cmd :=
| Assign (x : var) (e : exp)
| Seq (c1 c2 : cmd)
| If (b : test) (c1 c2 : cmd)
| While (b : test) (c1 : cmd)
(* ^-- As promised, no invariant on a loop! *)
| Skip.

Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

Fixpoint eval (e : exp) (s : fmap var nat) : nat :=
  match e with
    | Const n => n
    | Var x => s $! x
    | Plus e1 e2 => eval e1 s + eval e2 s
    | Minus e1 e2 => eval e1 s - eval e2 s
  end.

Definition beval (b : test) (s : fmap var nat) : bool :=
  match b with
    | Eq e1 e2 => beq_nat (eval e1 s) (eval e2 s)
    | NotEq e1 e2 => negb (beq_nat (eval e1 s) (eval e2 s))
  end.

(* Big-step semantics for commands *)
Inductive exec : fmap var nat -> cmd -> fmap var nat -> Prop :=
| ExecAssign : forall s x e,
  exec s (Assign x e) (s $+ (x, eval e s))
| ExecSeq : forall s1 c1 c2 s2 s3,
  exec s1 c1 s2
  -> exec s2 c2 s3
  -> exec s1 (Seq c1 c2) s3
| ExecIfTrue : forall s1 b c1 c2 s2,
  beval b s1 = true
  -> exec s1 c1 s2
  -> exec s1 (If b c1 c2) s2
| ExecIfFalse : forall s1 b c1 c2 s2,
  beval b s1 = false
  -> exec s1 c2 s2
  -> exec s1 (If b c1 c2) s2
| ExecWhileTrue : forall s1 b c1 s2 s3,
  beval b s1 = true
  -> exec s1 c1 s2
  -> exec s2 (While b c1) s3
  -> exec s1 (While b c1) s3
| ExecWhileFalse : forall s b c1,
  beval b s = false
  -> exec s (While b c1) s
| ExecSkip : forall s,
    exec s Skip s.

Hint Constructors exec.

Notation valuation := (fmap var nat).
Notation assertion := (valuation -> Prop).

(* Now for the Hoare-triple rules.  Remember that in class we followed a
 * 'postcondition calculator' style of defining Hoare triple rules, where in
 * each case we allow the precondition to be an arbitrary assertion and
 * constrain the form of the postcondition. Here we reverse the direction,
 * following a 'precondition calculator' style of allowing arbitrary
 * postcondition, except for the [While] case. *)
Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
| HtAssign : forall P x e,
    hoare_triple (fun s => P (s $+ (x, eval e s))) (Assign x e) P
    (* Note how the precondition is built from the postcondition by,
     * essentially, "simulating the effect of the assignment ahead of time." *)

| HtIf : forall P Q b c1 c2,
    hoare_triple (fun s => P s /\ beval b s = true) c1 Q
    -> hoare_triple (fun s => P s /\ beval b s = false) c2 Q
    -> hoare_triple P (If b c1 c2) Q
    (* This rule avoids the disjunction we used last time around. *)

| HtWhile : forall P b c,
    hoare_triple (fun s => P s /\ beval b s = true) c P
    -> hoare_triple P (While b c) (fun s => P s /\ beval b s = false)
    (* Here we use the precondition as the loop invariant.  In practice, of
     * course, the "immediate" precondition isn't suitable as an invariant, in
     * which case the consequence rule below becomes even more important,
     * to wrap a proof with an invariant installed as precondition. *)

(* The last three rules are unchanged. *)
| HtSeq : forall R P Q c1 c2,
    hoare_triple P c1 R
    -> hoare_triple R c2 Q
    -> hoare_triple P (Seq c1 c2) Q
| HtSkip : forall P : assertion,
    hoare_triple P Skip P
| HtConsequence : forall (P Q P' Q' : assertion) c,
    hoare_triple P c Q
    -> (forall s, P' s -> P s)
    -> (forall s, Q s -> Q' s)
    -> hoare_triple P' c Q'.

(* Some automation help: you may appreciate these lemmas and tactics. *)

Lemma HtStrengthenPre : forall (P Q P' : assertion) c,
  hoare_triple P c Q
  -> (forall v, P' v -> P v)
  -> hoare_triple P' c Q.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

Lemma HtStrengthenPost : forall (P Q Q' : assertion) c,
  hoare_triple P c Q
  -> (forall v, Q v -> Q' v)
  -> hoare_triple P c Q'.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

Ltac ht1 := apply HtSkip || apply HtAssign || eapply HtSeq
            || eapply HtIf || eapply HtWhile
            || eapply HtStrengthenPre
            || eapply HtStrengthenPost.

Ltac t := cbv beta; propositional; subst;
          repeat match goal with
                 | [ H : ex _ |- _ ] => invert H; propositional; subst
                 end;
          simplify;
          repeat match goal with
                 | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
                 | [ H : ?E = ?E |- _ ] => clear H
                 end; simplify; propositional; auto; try equality; try linear_arithmetic.

Ltac ht := simplify; repeat ht1; t.

Module Type S.

  (* Prove the soundness of this Hoare Logic with regard to the big-step
   * semantics: when we prove a program with respect to a
   * precondition-postcondition pair, it really does follow that spec. *)
  Axiom hoare_triple_sound : forall P c Q,
    hoare_triple P c Q ->
    (forall s s',
        P s ->
        exec s c s' ->
        Q s').

  (* Prove the completeness of this Hoare Logic with regard to the big-step
   * semantics: given any legitimate pre/postcondition, we can establish a Hoare
   * triple using them. *)
  Axiom hoare_triple_complete : forall c (P Q : assertion),
      (forall s s',
          P s ->
          exec s c s' ->
          Q s') ->
      hoare_triple P c Q.

End S.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import Utf8.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Streams.
Variable A : Type.

CoInductive Stream :=
  | Nil : Stream
  | Cons : A -> Stream -> Stream.

Definition Stream_decompose (s : Stream) : Stream :=
  match s with
    | Nil => Nil
    | Cons h t => Cons h t
  end.

Lemma Stream_decompose_lemma s : s = Stream_decompose s.
Proof.
by case: s.
Qed.

(*Lemma Stream_unfold x :
  x = match x with
        | Nil => Nil
        | Cons a s => Cons a s
      end.
Proof. by case: x. Qed.*)

Lemma not_Nil_Cons s :
  ~ s = Nil -> exists h t, s = Cons h t.
Proof.
case: s => [// |]; by eauto.
Qed.

Fixpoint seqToStream (s : seq A) : Stream :=
  match s with
    | [::] => Nil
    | h :: t => Cons h (seqToStream t)
  end.

Fixpoint firstN n (s : Stream) : seq A :=
  match n with
    | 0 => [::]
    | n.+1 =>
        match s with
          | Nil => [::]
          | Cons h t => h :: firstN n t
        end
  end.

Fixpoint catSeqStream (s1 : seq A) (s2 : Stream) : Stream :=
  match s1 with
    | [::] => s2
    | h :: t => Cons h (catSeqStream t s2)
  end.

Lemma catSeqStream_cat s1 s2 s3 :
  catSeqStream s1 (catSeqStream s2 s3) =
  catSeqStream (s1 ++ s2) s3.
Proof.
elim: s1 => [| h t IH] //=.
by rewrite IH.
Qed.

Lemma catSeqStream_Nil s :
  catSeqStream s Nil = seqToStream s.
Proof.
elim: s => [| h t IH] //=.
by rewrite IH.
Qed.

Lemma catSeqStream_firstN s p r :
  s = catSeqStream p r -> exists n, p = firstN n s.
Proof.
move: s.
elim: p => [| h t IH].
- rewrite /=. by move => s _; exists 0.
- move => s e.
  rewrite /= in e.
  elim: (IH _ Logic.eq_refl) => n Hn.
  exists n.+1.
  by rewrite e [in X in X = _]Hn.
Qed.

(*CoFixpoint catStream (s1 s2 : Stream) : Stream :=
  match s1 with
    | Nil => s2
    | Cons h t => Cons h (catStream t s2)
  end.

Lemma catStream_nil (s : Stream) :
  catSeqStream [::] s = s.
by [].
Qed.

Definition catSeqStream_bis (s1 : seq A) (s2 : Stream)
  := catStream (seqToStream s1) s2.*)

CoFixpoint funToStream_from n (f : nat -> A) : Stream
  := Cons (f n) (funToStream_from n.+1 f).

Definition funToStream f := funToStream_from 0 f.

Inductive Finite : Stream -> Prop :=
  | Nil_fin : Finite Nil
  | Cons_fin : forall a s, Finite s -> Finite (Cons a s).

CoInductive Infinite : Stream -> Prop :=
  | Cons_inf : forall a s, Infinite s -> Infinite (Cons a s).

Lemma seq_Finite s : Finite (seqToStream s).
Proof.
elim: s => [| h t IH] //=; by constructor.
Qed.

Lemma catSeqStream_Finite s1 s2 :
  Finite s2 -> Finite (catSeqStream s1 s2).
Proof.
elim: s1 => [| h t IH] //=.
move => H. by constructor; auto.
Qed.

Lemma Infinite_elim s :
  Infinite s -> exists a t, s = Cons a t /\ Infinite t.
Proof.
case; by eauto.
Qed.

Lemma Infinite_not_Nil s : Infinite s -> ~ s = Nil.
Proof.
move => Hinf.
elim: (Infinite_elim Hinf) => h [t [? _]].
by subst s.
Qed.

Lemma catSeqStream_Infinite_1 l s :
  Infinite s -> Infinite (catSeqStream l s).
Proof.
elim: l => [| a h IH]; by intuition.
Qed.

Lemma catSeqStream_Infinite_2 l s :
  Infinite (catSeqStream l s) -> Infinite s.
Proof.
elim: l => [| a h IH] //=.
move => H. by inversion H; intuition.
Qed.

Lemma funToStream_from_unfold n f :
  funToStream_from n f = Cons (f n) (funToStream_from n.+1 f).
Proof.
by rewrite [X in X = _] Stream_decompose_lemma.
Qed.

Lemma funToStream_from_Infinite f :
  forall n, Infinite (funToStream_from n f).
Proof.
cofix H.
move => n.
rewrite funToStream_from_unfold.
constructor.
by apply: H.
Qed.

Lemma funToStream_Infinite f : Infinite (funToStream f).
Proof.
by apply: funToStream_from_Infinite.
Qed.

Lemma Nil_not_Infinite : ~ Infinite Nil.
Proof.
move => H. by inversion H.
Qed.
Hint Resolve Nil_not_Infinite.

Lemma Finite_not_Infinite s :
  Finite s -> ~ Infinite s.
Proof.
move => H. elim: H => //.
move => h t Hf Hi Hicons.
case: Hi. by inversion Hicons.
Qed.

Lemma not_Finite_Infinite s :
  ~ Finite s -> Infinite s.
Proof.
move: s. cofix H. case.
- by have Habs : Finite Nil by constructor.
- move => h t Hcons.
  constructor.
  apply: H => H. elim: Hcons. by constructor.
Qed.

End Streams.

Arguments Nil [A] : default implicits.