(******************************************************************************)
(** Imports **)

(* Disable notation conflict warnings *)
Set Warnings "-notation-overridden".

(* SSReflect *)
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat seq eqtype.
Set Bullet Behavior "Strict Subproofs".

(* Permutations *)
Require Import Coq.Sorting.Permutation.

(* Basic Haskell libraries *)
Require Import GHC.Base      Proofs.GHC.Base.
Require Import GHC.List      Proofs.GHC.List.
Require Import GHC.Enum.
Require Import Data.Foldable Proofs.Data.Foldable.
Require Import Data.OldList  Proofs.Data.OldList.

(* Other utility libraries *)
Require Import OrdTactic BitUtils.

(******************************************************************************)
(** Name dismabiguation -- MUST BE COPIED LOCALLY **)

Notation list    := Coq.Init.Datatypes.list.
Notation seq     := Coq.Lists.List.seq.
Notation reflect := ssrbool.reflect.
  (* Why do I need `reflect`?  What other `reflect` is in scope? *)

(******************************************************************************)
(** Notation disambiguation **)

Infix "=="  := op_zeze__ : bool_scope.
Infix "===" := eq_op (at level 70, no associativity) : bool_scope.

Notation "x == y :> A"  := (op_zeze__ (x : A) (y : A)) : bool_scope.
Notation "x === y :> A" := (eq_op     (x : A) (y : A)) (at level 70, y at next level, no associativity) : bool_scope.

(******************************************************************************)
(** Easier simplification **)

Global Arguments "$"          {_ _}     / _ _.
Global Arguments id           {_}       / _.
Global Arguments Datatypes.id {_}       / _.
Global Arguments "∘"          {_ _}     _ _ _ /.
Global Arguments flip         {_ _ _}   _ _ _ /.

(******************************************************************************)
(** bool **)

Theorem bool_eq_iff (b1 b2 : bool) : b1 = b2 <-> (b1 <-> b2).
Proof.
  move: b1 b2 => [] [] //.
  all: split; try solve[discriminate | case=> *; exfalso; auto].
Qed.

(******************************************************************************)
(** EqTypes **)

(* EqType <-> EqExact translation *)

Theorem eqType_EqExact {A : eqType} `{EqExact A} (x y : A) : (x === y) = (x == y).
Proof. by case E: (x === y); case E': (x == y)=> //; move: E E' => /eqP ? /Eq_eq ?. Qed.

Theorem EqExact_eqType {A : eqType} `{EqExact A} (x y : A) : (x == y) = (x === y).
Proof. by rewrite eqType_EqExact. Qed.

(* EqExact decidability *)

Theorem EqExact_cases {A} `{EqExact A} (x y : A) :
  {x == y /\ x = y} + {x /= y /\ x <> y}.
Proof.
  rewrite Neq_inv; case CMP: (x == y).
  - by left; split=> //; apply/Eq_eq.
  - by right; split=> //; move=> /Eq_eq; rewrite CMP.
Qed.

Corollary EqExact_dec {A} `{EqExact A} (x y : A) :
  {x = y} + {x <> y}.
Proof. generalize (EqExact_cases x y); tauto. Qed.

(* Int is an EqType *)

Lemma Int_eqbP : Equality.axiom (_==_ : Int -> Int -> bool).
Proof. exact Eq_eq. Qed.

Canonical Int_eqMixin := EqMixin Int_eqbP.
Canonical Int_eqType := Eval hnf in EqType Int Int_eqMixin.

(******************************************************************************)
(** Ordering **)

Theorem Ord_le_ge {A} `{OrdLaws A} (x y : A) :
  (x <= y) = (y >= x).
Proof. order A. Qed.

Theorem Ord_lt_gt {A} `{OrdLaws A} (x y : A) :
  (x < y) = (y > x).
Proof. order A. Qed.

Theorem Ord_gt_lt {A} `{OrdLaws A} (x y : A) :
  (x > y) = (y < x).
Proof. order A. Qed.

Theorem Ord_lt_not_gt {A} `{OrdLaws A} (x y : A) :
  (x < y) -> ~~ (x > y).
Proof. order A. Qed.

Theorem Ord_antisym_le_le {A} `{OrdLaws A} (x y : A) :
  (x == y) = (x <= y) && (y <= x).
Proof. order A. Qed.

Theorem Ord_gt_not_lt {A} `{OrdLaws A} (x y : A) : (x > y) -> ~~ (x < y).
Proof. order A. Qed.

Theorem Ord_le_le_antisym {A} `{OrdLaws A} (x y : A) : (x == y) = (x <= y) && (y <= x).
Proof. order A. Qed.

Theorem Ord_le_ge_antisym {A} `{OrdLaws A} (x y : A) : (x == y) = (x <= y) && (x >= y).
Proof. order A. Qed.

Theorem Ord_ge_le_antisym {A} `{OrdLaws A} (x y : A) : (x == y) = (x >= y) && (x <= y).
Proof. order A. Qed.

Theorem Ord_ge_ge_antisym {A} `{OrdLaws A} (x y : A) : (x == y) = (x >= y) && (y >= x).
Proof. order A. Qed.

Theorem Ord_lt_lt_antisym {A} `{OrdLaws A} (x y : A) : (x /= y) = (x < y) || (y < x).
Proof. case: (Ord_total x y); order A. Qed.

Theorem Ord_lt_gt_antisym {A} `{OrdLaws A} (x y : A) : (x /= y) = (x < y) || (x > y).
Proof. rewrite Ord_lt_lt_antisym; order A. Qed.

Theorem Ord_gt_lt_antisym {A} `{OrdLaws A} (x y : A) : (x /= y) = (x > y) || (x < y).
Proof. rewrite Ord_lt_lt_antisym; order A. Qed.

Theorem Ord_gt_gt_antisym {A} `{OrdLaws A} (x y : A) : (x /= y) = (x > y) || (y > x).
Proof. rewrite Ord_lt_lt_antisym; order A. Qed.

Theorem Ord_le_le_antisym' {A} `{OrdLaws A} (x y : A) : (x == y) = (y <= x) && (x <= y).
Proof. order A. Qed.

Theorem Ord_le_ge_antisym' {A} `{OrdLaws A} (x y : A) : (x == y) = (y <= x) && (y >= x).
Proof. order A. Qed.

Theorem Ord_ge_le_antisym' {A} `{OrdLaws A} (x y : A) : (x == y) = (y >= x) && (y <= x).
Proof. order A. Qed.

Theorem Ord_ge_ge_antisym' {A} `{OrdLaws A} (x y : A) : (x == y) = (y >= x) && (x >= y).
Proof. order A. Qed.

Theorem Ord_lt_lt_antisym' {A} `{OrdLaws A} (x y : A) : (x /= y) = (y < x) || (x < y).
Proof. rewrite Ord_lt_lt_antisym; order A. Qed.

Theorem Ord_lt_gt_antisym' {A} `{OrdLaws A} (x y : A) : (x /= y) = (y < x) || (y > x).
Proof. rewrite Ord_lt_lt_antisym; order A. Qed.

Theorem Ord_gt_lt_antisym' {A} `{OrdLaws A} (x y : A) : (x /= y) = (y > x) || (y < x).
Proof. rewrite Ord_lt_lt_antisym; order A. Qed.

Theorem Ord_gt_gt_antisym' {A} `{OrdLaws A} (x y : A) : (x /= y) = (y > x) || (x > y).
Proof. rewrite Ord_lt_lt_antisym; order A. Qed.

(******************************************************************************)
(** List membership (`elem`, `In`, `\in`) **)

Theorem elemN {A} `{Eq_ A} (a : A) : elem a [::] = false.
Proof. done. Qed.

Theorem elemC {A} `{Eq_ A} (a x : A) (xs : list A) : elem a (x :: xs) = (a == x) || elem a xs.
Proof. done. Qed.

Theorem elem_in {A : eqType} `{EqExact A} (xs : list A) (a : A) :
  elem a xs = (a \in xs).
Proof. by elim: xs => [|x xs IH] //=; rewrite inE -IH eqType_EqExact. Qed.

Theorem in_elem {A : eqType} `{EqExact A} (xs : list A) (a : A) :
  a \in xs = elem a xs.
Proof. symmetry; apply elem_in. Qed.

Theorem elem_elem_by {A} `{EqLaws A} :
  elem =2 elem_by _==_.
Proof.
  move=> a; elim=> [|x xs IH] //=.
  by rewrite elemC IH Eq_sym.
Qed.

Theorem elemP {A} `{EqExact A} (x : A) (xs : list A) :
  reflect (In x xs) (elem x xs).
Proof.
  elim: xs => [|y ys IH] //=; first by constructor.
  rewrite elemC; case CMP: (x == y) => /=.
  - by constructor; left; apply/Eq_eq; rewrite Eq_sym.
  - apply/equivP; first exact IH.
    split; first by right.
    case=> // ?; subst.
    by move: CMP; rewrite Eq_refl.
Qed.

Theorem elem_byP {A} `{EqExact A} (xs : list A) (x : A) :
  reflect (In x xs) (elem_by _==_ x xs).
Proof.
  elim: xs => [|x' xs IH] /=; first by constructor.
  apply iff_reflect; split;
    try move=> /orP;
    move=> [? | ?];
    try apply/orP;
    solve [by left; apply/Eq_eq | by right; apply/IH].
Qed.

Theorem elem_app {A} `{Eq_ A} (a : A) (xs ys : list A) :
  elem a (xs ++ ys) = elem a xs || elem a ys.
Proof. by elim: xs => [|x xs] //=; rewrite !elemC -orbA => ->. Qed.

Theorem elem_by_resp_eq {A} `{EqLaws A} (xs : list A) (a b : A) :
  a == b ->
  elem_by _==_ a xs ->
  elem_by _==_ b xs.
Proof.
  move=> EQab; elim: xs => [|x xs IH] //=.
  case EQxa: (x == a) => //=; case EQxb: (x == b) => //=.
  have: (x == b) by eapply Eq_trans with a.
  by rewrite EQxb.
Qed.

Theorem elem_resp_eq {A} `{EqLaws A} (xs : list A) (a b : A) :
  a == b ->
  elem a xs ->
  elem b xs.
Proof. rewrite !elem_elem_by; apply elem_by_resp_eq. Qed.

Theorem elem_Permutation {A} `{Eq_ A} (xs ys : list A) :
  Permutation xs ys ->
  forall a, elem a xs = elem a ys.
Proof.
  elim=> {xs ys}
         [
         | x xs ys PERM IH
         | x y xs
         | xs ys zs PERM_xs_ys IH_xs_ys PERM_ys_zs IH_ys_zs ]
         //= a.
  - by rewrite !elemC IH.
  - by rewrite !elemC !orbA (orbC (_ == _) (_ == _)).
  - eapply etrans; [apply IH_xs_ys | apply IH_ys_zs].
Qed.

(* Non-Haskell theorems about In *)

Theorem InP {A : eqType} (x : A) (xs : list A) :
  reflect (In x xs) (x \in xs).
Proof.
  elim: xs => [|y ys IH] //=.
  - by rewrite seq.in_nil; constructor.
  - rewrite inE; case CMP: (x === y) => /=.
    + by constructor; left; apply/eqP; rewrite eq_sym.
    + apply/equivP; first exact IH.
      split; first by right.
      case=> // ?; subst.
      by move: CMP; rewrite eq_refl.
Qed.

Theorem In_split {A} (x : A) (xs : list A) :
  In x xs <->
  exists pre post, xs = pre ++ x :: post.
Proof.
  split.
  - elim: xs => [|x' xs IH] //= [? | IN]; first subst x'.
    + by exists [::], xs.
    + move: (IH IN) => [pre [post ->]].
      by exists (x' :: pre), post.
  - move=> [pre [post ->]].
    by elim: pre => [|p pre IH] //=; [left | right].
Qed.

(******************************************************************************)
(** Foldable and lists **)

Theorem Foldable_list_all {A} :
  all =2 @GHC.List.all A.
Proof.
  rewrite /all /compose /foldMap /Foldable__list /=
          /Data.Foldable.Foldable__list_foldMap /Data.Foldable.Foldable__list_foldr /=.
  move=> p; elim=> [|x xs IH] //=.
  rewrite -IH.
  rewrite {1}/mappend /Data.SemigroupInternal.Monoid__All /=.
  case: (GHC.Base.foldr _ _ _) => //=.
Qed.

Theorem Foldable_and_all {F} `{Foldable F} :
  and (t := F) =1 all id.
Proof. done. Qed.

Lemma Foldable_all_forallb {A} :
  all =2 forallb (A := A).
Proof. by move=> p xs; rewrite Foldable_list_all; elim: xs => //= x xs <-. Qed.

Theorem Foldable_all_ssreflect {A} :
  all =2 seq.all (T := A).
Proof. by move=> *; rewrite Foldable_all_forallb. Qed.

Theorem Foldable_list_any {A} :
  Data.Foldable.any =2 @GHC.List.any A.
Proof.
  rewrite /Data.Foldable.any /compose /foldMap /Foldable__list /=
          /Data.Foldable.Foldable__list_foldMap /Data.Foldable.Foldable__list_foldr /=.
  move=> p; elim=> [|x xs IH] //=.
  rewrite -IH.
  rewrite {1}/mappend /Data.SemigroupInternal.Monoid__Any /=.
  case: (GHC.Base.foldr _ _ _) => //=.
Qed.

Theorem Foldable_any_or {F} `{Foldable F} :
  or (t := F) =1 any id.
Proof. done. Qed.

Theorem Foldable_any_existsb {A} :
  any =2 existsb (A := A).
Proof. by move=> p xs; rewrite Foldable_list_any; elim: xs => //= x xs <-. Qed.

Theorem Foldable_any_ssreflect {A} :
  any =2 seq.has (T := A).
Proof. by move=> *; rewrite Foldable_any_existsb. Qed.

Theorem Foldable_list_null {A} :
  null =1 GHC.List.null (a := A).
Proof. done. Qed.

Theorem List_null_none {A} (xs : list A) :
  GHC.List.null xs <-> forall x, ~ In x xs.
Proof.
  case: xs => [|x xs] /=; split; try by intuition.
  by move=> /(_ x (or_introl erefl)).
Qed.

Theorem List_null_no_elems {A} `{EqLaws A} (xs : list A) :
  GHC.List.null xs <-> forall x, ~~ elem x xs.
Proof.
  case: xs => [|x xs] /=; split; try by intuition.
  by move=> /(_ x); rewrite elemC Eq_refl.
Qed.

Theorem null_list_none {A} (xs : list A) :
  null xs <-> forall x, ~ In x xs.
Proof. apply List_null_none. Qed.

Theorem null_list_no_elems {A} `{EqLaws A} (xs : list A) :
  null xs <-> forall x, ~~ elem x xs.
Proof. apply List_null_no_elems. Qed.

Theorem hs_coq_reverse_rev {A} :
  reverse =1 rev (A := A).
Proof.
  rewrite /reverse => xs.
  replace (rev xs) with (rev xs ++ [::]) by rewrite app_nil_r //.
  elim: xs [::] => [|x xs IH] //= acc.
  by rewrite IH -app_assoc.
Qed.

(******************************************************************************)
(** Element-based list function semantics **)

(* reverse and rev *)

Theorem rev_elem {A} `{EqLaws A} (xs : list A) (a : A) :
  elem a (rev xs) = elem a xs.
Proof.
  elim: xs => [|x xs IH] //=.
  by rewrite elem_app !elemC elemN orbF IH orbC.
Qed.

Theorem reverse_elem {A} `{EqLaws A} (xs : list A) (a : A) :
  elem a (reverse xs) = elem a xs.
Proof. rewrite hs_coq_reverse_rev; apply rev_elem. Qed.

(* nub *)

Theorem nub_elem {A} `{EqLaws A} (xs : list A) (a : A) :
  elem a (nub xs) = elem a xs.
Proof.
  rewrite /nub /nubBy !elem_elem_by;
    match goal with |- context[?F xs [::]] => set nubBy' := F end.
  replace (elem_by _==_ a xs) with (elem_by _==_ a xs && ~~ elem_by _==_ a [::])
    by rewrite /= andbT //.
  move: [::].
  elim: xs => [|x xs IH] //= acc.
  case ELEM_x: (elem_by _==_ x acc) => /=; last rename ELEM_x into NELEM_x.
  - rewrite IH.
    case NELEM_a: (elem_by _==_ a acc) => /=; rewrite ?andbT ?andbF //.
    case EQxa: (x == a) => //=.
    by rewrite (elem_by_resp_eq _ _ _ EQxa ELEM_x) in NELEM_a.
  - rewrite IH /= negb_orb orb_andr.
    case EQxa: (x == a) => //=.
    symmetry; apply/negP => ELEM_a.
    by rewrite Eq_sym in EQxa; rewrite (elem_by_resp_eq _ _ _ EQxa ELEM_a) in NELEM_x.
Qed.

(* delete and deleteBy *)

Theorem deleteBy_only_elem {A} `{Eq_ A} (xs : list A) (a b : A) :
  elem b (deleteBy _==_ a xs) -> elem b xs.
Proof.
  elim: xs => [|x xs IH] //=.
  rewrite elemC; case NEQbx: (b == x) => //=.
  case NEQax: (a == x) => //=.
  rewrite elemC NEQbx orFb; apply IH.
Qed.

Theorem delete_only_elem {A} `{Eq_ A} (xs : list A) (a b : A) :
  elem b (delete a xs) -> elem b xs.
Proof. apply deleteBy_only_elem. Qed.

Theorem deleteBy_NoDup_elem {A} `{EqExact A} (xs : list A) :
  NoDup xs -> forall a b, elem b (deleteBy _==_ a xs) = elem b xs && (a /= b).
Proof.
  elim: xs => [|x xs IH] //= ND' a b.
  inversion ND' as [|x' xs' NIN ND]; subst x' xs'.
  rewrite elemC; case EQbx: (b == x) => //=; last rename EQbx into NEQbx.
  - move/Eq_eq in EQbx; subst x.
    rewrite Neq_inv; case EQab: (a == b) => //=; last rename EQab into NEQab.
    + by apply/elemP.
    + by rewrite elemC Eq_refl orTb.
  - case EQax: (a == x) => //=; last rename EQax into NEQax.
    + have: (a /= b). {
        rewrite Neq_inv Eq_sym; apply/negP => EQba.
        by rewrite (Eq_trans _ _ _ EQba EQax) in NEQbx.
      }
      by move=> ->; rewrite andbT.
    + by rewrite elemC NEQbx orFb; apply IH.
Qed.

Theorem delete_NoDup_elem {A} `{EqExact A} (xs : list A) :
  NoDup xs -> forall a b, elem b (delete a xs) = elem b xs && (a /= b).
Proof. apply deleteBy_NoDup_elem. Qed.

Theorem deleteBy_NoDup_removes {A} `{EqExact A} (xs : list A) :
  NoDup xs -> forall a, ~~ elem a (deleteBy _==_ a xs).
Proof. by move=> ND a; rewrite deleteBy_NoDup_elem // Neq_irrefl andbF. Qed.

Theorem delete_NoDup_removes {A} `{EqExact A} (xs : list A) :
  NoDup xs -> forall a, ~~ elem a (delete a xs).
Proof. apply deleteBy_NoDup_removes. Qed.

Theorem deleteBy_preserves_NoDup {A} `{EqExact A} (xs : list A) :
  NoDup xs -> forall a, NoDup (deleteBy _==_ a xs).
Proof.
  elim: xs => [|x xs IH] //= ND' a.
  inversion ND' as [|x' xs' NIN ND]; subst x' xs'.
  case NEQax: (a == x) => //.
  constructor; last by apply IH.
  apply/elemP/negP => ELEM.
  by apply deleteBy_only_elem in ELEM; move/elemP in ELEM.
Qed.

Theorem delete_preserves_NoDup {A} `{EqExact A} (xs : list A) :
  NoDup xs -> forall a, NoDup (delete a xs).
Proof. apply deleteBy_preserves_NoDup. Qed.

(* Filter *)

Theorem filter_In {A} (p : A -> bool) (xs : list A) :
  forall a, In a (filter p xs) <-> In a xs /\ p a.
Proof.
  move=> a; elim: xs => [|x xs IH] //=; first tauto.
  case Hpx: (p x) => //=; rewrite IH; intuition congruence.
Qed.

Theorem filter_elem {A} `{EqExact A} (p : A -> bool) (xs : list A) :
  forall a, elem a (filter p xs) = elem a xs && p a.
Proof.
  move=> a; apply/bool_eq_iff.
  rewrite -(rwP andP) -!(rwP (elemP _ _)); apply filter_In.
Qed.

Theorem filter_preserves_NoDup {A} `{EqExact A} (p : A -> bool) (xs : list A) :
  NoDup xs -> NoDup (filter p xs).
Proof.
  elim: xs => [|x xs IH] //= ND'.
  inversion ND' as [|x' xs' NIN ND]; subst x' xs'.
  case: (p x); first constructor; try by apply IH.
  rewrite filter_In; contradict NIN; tauto.
Qed.

(* List intersection (intersect) *)

Theorem intersectBy_flat_map {A} (eq : A -> A -> bool) (xs ys : list A) :
  intersectBy eq xs ys = flat_map (fun x => if GHC.List.any (eq x) ys then [:: x] else [::]) xs.
Proof.
  move: xs ys => [|x xs] [|y ys] //=.
  elim: xs => [|x' xs IH] //=.
Qed.

Theorem intersectBy_filter {A} (eq : A -> A -> bool) (xs ys : list A) :
  intersectBy eq xs ys = filter (fun x => any (eq x) ys) xs.
Proof.
  rewrite intersectBy_flat_map.
  elim: xs => [|x xs IH] => //=.
  rewrite -Foldable_list_any IH.
  by case: (any _ _).
Qed.

Theorem intersectBy_elem {A} `{EqExact A} (xs ys : list A) (a : A) :
  elem a (intersectBy _==_ xs ys) = elem a xs && elem a ys.
Proof.
  rewrite intersectBy_filter filter_elem Foldable_list_any; f_equal.
  elim: ys => [|y ys IH] //=.
  by rewrite IH elemC.
Qed.

Theorem intersect_elem {A} `{EqExact A} (xs ys : list A) (a : A) :
  elem a (intersect xs ys) = elem a xs && elem a ys.
Proof. apply intersectBy_elem. Qed.

Theorem intersectBy_preserves_NoDup {A} `{EqExact A} (xs ys : list A) :
  NoDup xs -> NoDup (intersectBy _==_ xs ys).
Proof. rewrite intersectBy_filter; apply filter_preserves_NoDup. Qed.

Theorem intersect_preserves_NoDup {A} `{EqExact A} (xs ys : list A) :
  NoDup xs -> NoDup (intersect xs ys).
Proof. rewrite /intersect intersectBy_filter; apply filter_preserves_NoDup. Qed.

(* List difference (\\) *)

Theorem diff_NoDup_elem {A} `{EqExact A} (xs ys : list A) :
  NoDup xs -> forall a, elem a (xs \\ ys) = elem a xs && ~~ elem a ys.
Proof.
  unfold "\\"; elim: ys xs => [|y ys IH] //= xs ND a; first by rewrite andbT.
  rewrite elemC negb_orb IH; last by apply delete_preserves_NoDup.
  by rewrite andbA delete_NoDup_elem // Neq_inv Eq_sym.
Qed.

Theorem diff_only_elem {A} `{Eq_ A} (xs ys : list A) (a : A) :
  elem a (xs \\ ys) -> elem a xs.
Proof. by unfold "\\"; elim: ys xs => [|y ys IH] //= xs /IH; apply delete_only_elem. Qed.

Theorem diff_preserves_NoDup {A} `{EqExact A} (xs ys : list A) :
  NoDup xs -> NoDup (xs \\ ys).
Proof.
  unfold "\\"; elim: ys xs => [|y ys IH] //= xs ND.
  by apply IH, delete_preserves_NoDup.
Qed.

(******************************************************************************)
(** Bit manipulation **)

Theorem Z_eq_testbits_pos (m n : Z) :
  m = n <-> (forall ix, (0 <= ix)%Z -> Z.testbit m ix = Z.testbit n ix).
Proof.
  split => [? | bits]; first by subst.
  apply Z.bits_inj_iff => ix.
  case: (Z_le_dec 0 ix) => [POS | NEG]; first by apply bits.
  rewrite !Z.testbit_neg_r //; omega.
Qed.

Theorem Z_negb_testbit_iff (m n : Z) :
  ~~ Z.testbit m n <-> (Z.land m (Z.shiftl 1 n) = 0)%Z.
Proof.
  rewrite Z_eq_testbits_pos; split => [nbit ix POS_ix | bits].
  - rewrite Z.bits_0 Z.land_spec Z.shiftl_spec // testbit_1.
    case SUB: (ix - n =? 0)%Z.
    + by move: SUB => /Z.eqb_spec/Z.sub_move_0_r ->; rewrite (negbTE nbit) andFb.
    + by rewrite andbF.
  - case: (Z_le_dec 0 n) => [POS | NEG].
    + move: bits => /(_ n POS).
      by rewrite Z.bits_0 Z.land_spec Z.shiftl_spec // testbit_1 Z.sub_diag /= andbT => ->.
    + rewrite Z.testbit_neg_r //; omega.
Qed.

Theorem Z_negb_testbit_eq (m n : Z) :
  ~~ Z.testbit m n = (Z.land m (Z.shiftl 1 n) =? 0)%Z.
Proof.
  apply/bool_eq_iff; rewrite Z_negb_testbit_iff; apply (rwP (Z.eqb_spec _ _)).
Qed.

Theorem Z_testbit_iff (m n : Z) :
  Z.testbit m n <-> (Z.land m (Z.shiftl 1 n) <> 0)%Z.
Proof.
  by rewrite -Z_negb_testbit_iff; split => [-> | /negP]; last rewrite negbK.
Qed.

Theorem Z_testbit_eq (m n : Z) :
  Z.testbit m n = ~~ (Z.land m (Z.shiftl 1 n) =? 0)%Z.
Proof.
  by apply/bool_eq_iff; rewrite Z_testbit_iff (rwP (Z.eqb_spec _ _)) (rwP negP).
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Lists                                                                   *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibReflect LibOperation
 LibProd LibOption LibNat LibInt LibWf LibRelation.
Require Export List.
Open Local Scope nat_scope.
Open Local Scope comp_scope.

(* ********************************************************************** *)
(** Fixing implicit arguments *)

Implicit Arguments nil [[A]].
Implicit Arguments cons [[A]].

(* ********************************************************************** *)
(** * Inhabited *)

Instance list_inhab : forall A, Inhab (list A).
Proof. intros. apply (prove_Inhab nil). Qed.

(* ********************************************************************** *)
(** * Comparable *)

Fixpoint list_compare `{Comparable A} (l1 l2 : list A) :=
  match l1,l2 with
  | nil, nil => true
  | x1::t1, x2::t2 => decide (x1 = x2) && list_compare t1 t2
  | _, _ => false
  end.

Global Instance list_comparable : forall (A : Type),
  Comparable A -> Comparable (list A).
Proof.
  introv CA. applys comparable_beq list_compare. intros l1.
  induction l1; intros l2; destruct l2; simpl; rew_refl; iff H; inverts~ H;
   tryfalse; auto; try congruence.
   fequals. applys* IHl1.
   split~. applys* IHl1.
Qed.

(** Special case for comparing against the empty list *)

Global Instance list_eq_nil_decidable : forall (A : Type) (l : list A),
  Decidable (l = nil).
Proof.
  intros. applys decidable_make (match l with nil => true | _ => false end).
  extens. destruct l; iff; rew_refl in *; auto_false*.
Qed.

(* ********************************************************************** *)
(** * Operations *)

(* ---------------------------------------------------------------------- *)
(** ** Operations on lists *)

Section Folds.
Context {A B : Type}.
Implicit Types l a b : list A.
Implicit Types x : A.

Fixpoint fold_right (f : A -> B -> B) (acc : B) l :=
  match l with
  | nil => acc
  | x::L' => f x (fold_right f acc L')
  end.

Fixpoint fold_left (f : A -> B -> B) (acc : B) l :=
  match l with
  | nil => acc
  | x::L' => fold_left f (f x acc) L'
  end.

End Folds.

Section Operations.
Variables (A B C : Type) (IA : Inhab A).
Implicit Types l a b : list A.
Implicit Types x : A.

Definition map (f : A -> C) :=
  nosimpl (fold_right (fun x acc => (f x)::acc) (@nil C)).

Definition append l1 l2 :=
  nosimpl (fold_right (fun x (acc:list A) => x::acc) l2 l1).

Definition concat :=
  nosimpl (fold_right append (@nil A)).

Definition rev :=
  nosimpl (fold_left (fun x acc => x::acc) (@nil A)).

Definition length :=
  nosimpl (fold_right (fun x acc => 1+acc) 0).

Definition filter (f : predb A) :=
  nosimpl (fold_right (fun x acc => if f x then x::acc else acc) (@nil A)).

Definition for_all (f : predb A) :=
  nosimpl (fold_right (fun x acc => acc && (f x)) true).

Definition exists_st (f : predb A) :=
  nosimpl (fold_right (fun x acc => acc || (f x)) false).

Definition count (f : predb A) :=
  nosimpl (fold_right (fun x acc => (if f x then 1 else 0) + acc) 0).

Fixpoint mem x l :=
  match l with
  | nil => false
  | y::l' => (x '= y) || mem x l'
  end.

Fixpoint remove x l := (* DEPRECATED *)
  match l with
  | nil => nil
  | y::l' => let acc := remove x l' in
             If x = y then acc else y::acc
  end.

Fixpoint removes l2 l1 := (* DEPRECATED *)
  match l2 with
  | nil => l1
  | x::l2' => removes l2' (remove x l1)
  end.

Fixpoint split (l: list (A*B)) : (list A * list B) :=
  match l with
  | nil => (nil,nil)
  | (a,b)::l' => let (la,lb) := split l' in (a::la, b::lb)
  end.

Fixpoint combine (la : list A) (lb : list B) : list (A*B) :=
  match la with
  | nil => nil
  | a::la' =>
    match lb with
    | nil => arbitrary
    | b::lb' => (a,b)::(combine la' lb')
    end
  end.

(* TODO: a function that combines drop & take *)

Fixpoint drop (n:nat) (l:list A) : list A :=
  match n with
  | 0 => l
  | S n' => match l with
    | nil => nil
    | a::l' => drop n' l'
    end
  end.

Fixpoint take (n:nat) (l:list A) : list A :=
  match n with
  | 0 => nil
  | S n' => match l with
    | nil => nil
    | a::l' => a::(take n' l')
    end
  end.

Fixpoint take_drop_last (l:list A) : (list A)*A :=
  match l with
  | nil => arbitrary
  | x::l' =>
    match l' with
    | nil => (nil,x)
    | _ => let (t,y) := take_drop_last l' in
           (x::t, y)
    end
  end.

Fixpoint nth_def (d:A) (n:nat) (l:list A) : A :=
  match l with
  | nil => d
  | x::l' =>
     match n with
     | 0 => x
     | S n' => nth_def d n' l'
     end
  end.

Definition nth := nth_def arbitrary.

Fixpoint update (n:nat) (v:A) (l:list A) {struct l} : list A :=
  match l with
  | nil => nil
  | x::l' =>
     match n with
     | 0 => v::l'
     | S n' => x::update n' v l'
     end
  end.

Fixpoint make (n:nat) (v:A) : list A :=
   match n with
   | 0 => nil
   | S n' => v :: make n' v
   end.

End Operations.

Implicit Arguments fold_left [[A] [B]].
Implicit Arguments fold_right [[A] [B]].
Implicit Arguments append [[A]].
Implicit Arguments concat [[A]].
Implicit Arguments rev [[A]].
Implicit Arguments length [[A]].
Implicit Arguments mem [[A]].
Implicit Arguments remove [[A]].
Implicit Arguments removes [[A]].
Implicit Arguments take_drop_last [[A] [IA]].
Implicit Arguments nth_def [[A]].
Implicit Arguments nth [[A] [IA]].
Implicit Arguments update [[A]].
Implicit Arguments make [[A]].

(* todo: implicit arguments for the other functions *)

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

(** [l1 ++ l2] concatenates two lists *)

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

(** [l & x] extends the list [l] with the value [x] at the right end *)

Notation "l & x" := (l ++ (x::nil))
  (at level 28, left associativity) : list_scope.

(* ********************************************************************** *)
(** * Properties of operations *)

Section AppFoldProperties.
Variable A B : Type.
Implicit Types x : A.
Implicit Types l : list A.

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

Lemma app_cons : forall x l1 l2,
  (x::l1) ++ l2 = x::(l1++l2).
Proof. auto. Qed.
Lemma app_nil_l : forall l,
  nil ++ l = l.
Proof. auto. Qed.
Lemma app_nil_r : forall l,
  l ++ nil = l.
Proof. induction l. auto. rewrite app_cons. fequals~. Qed.
Lemma app_assoc : forall l1 l2 l3,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros. induction l1.
  rewrite_all~ app_nil_l.
  rewrite_all~ app_cons. fequals~.
Qed.
Lemma app_last : forall x l1 l2,
  l1 ++ (x::l2) = (l1 & x) ++ l2.
Proof. intros. rewrite~ app_assoc. Qed.
Lemma app_last_sym : forall x l1 l2,
  (l1 & x) ++ l2 = l1 ++ (x::l2).
Proof. intros. rewrite~ <- app_last. Qed.
Lemma app_cons_one : forall x l,
  (x::nil) ++ l = x::l.
Proof. auto. Qed.

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

Section FoldRight.
Variables (f : A -> B -> B) (i : B).
Lemma fold_right_nil :
  fold_right f i nil = i.
Proof. auto. Qed.
Lemma fold_right_cons : forall x l,
  fold_right f i (x::l) = f x (fold_right f i l) .
Proof. auto. Qed.
Lemma fold_right_app : forall l1 l2,
  fold_right f i (l1 ++ l2) = fold_right f (fold_right f i l2) l1.
Proof.
  intros. induction l1. auto.
  rewrite app_cons. simpl. fequals~.
Qed.
Lemma fold_right_last : forall x l,
  fold_right f i (l & x) = fold_right f (f x i) l.
Proof. intros. rewrite~ fold_right_app. Qed.
End FoldRight.

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

Section FoldLeft.
Variables (f : A -> B -> B) (i : B).
Lemma fold_left_nil :
  fold_left f i nil = i.
Proof. auto. Qed.
Lemma fold_left_cons : forall x l,
  fold_left f i (x::l) = fold_left f (f x i) l.
Proof. auto. Qed.
Lemma fold_left_app : forall l1 l2,
  fold_left f i (l1 ++ l2) = fold_left f (fold_left f i l1) l2.
Proof.
  intros. gen i. induction l1; intros. auto.
  rewrite app_cons. simpl. rewrite~ IHl1.
Qed.
Lemma fold_left_last : forall x l,
  fold_left f i (l & x) = f x (fold_left f i l).
Proof. intros. rewrite~ fold_left_app. Qed.
End FoldLeft.

End AppFoldProperties.

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

Section LengthProperties.
Variable A : Type.
Implicit Types l : list A.

Lemma length_nil :
  length (@nil A) = 0.
Proof. auto. Qed.
Lemma length_cons : forall x l,
  length (x::l) = 1 + length l.
Proof. auto. Qed.
Lemma length_app : forall l1 l2,
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros. unfold length at 1. rewrite fold_right_app.
  fold (length l2). induction l1; simple~.
Qed.
Lemma length_last : forall x l,
  length (l & x) = 1 + length l.
Proof.
  intros. rewrite length_app.
  rewrite length_cons. rewrite length_nil.
  simpl. math.
Qed.
Lemma length_zero_inv : forall l,
  length l = 0%nat -> l = nil.
Proof.
  destruct l. auto. rewrite length_cons. intros. false.
Qed.

End LengthProperties.

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

Section OperationProperties.
Variable A B : Type.
Implicit Types x : A.
Implicit Types l : list A.

Lemma rev_nil :
  rev (@nil A) = nil.
Proof. auto. Qed.
Lemma rev_app : forall l1 l2,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros. unfold rev. asserts K1: (forall l accu,
   fold_left (fun x acc => x :: acc) accu l =
   fold_left (fun x acc => x :: acc) nil l ++ accu).
   induction l; intros; simpl. auto.
   rewrite IHl. rewrite (@IHl (a::nil)). rewrite~ app_last.
  asserts K2: (forall accu,
   fold_left (fun x acc => x :: acc) accu (l1 ++ l2) =
   fold_left (fun x acc => x :: acc) nil l2 ++
   fold_left (fun x acc => x :: acc) nil l1 ++ accu).
  induction l1; intros; simpl.
    do 2 rewrite app_nil_l. apply K1.
    rewrite IHl1. rewrite (@K1 l1 (a::nil)). rewrite~ app_last.
  lets K3: (@K2 nil). rewrite app_nil_r in K3. auto.
Qed.
Lemma rev_cons : forall x l,
  rev (x::l) = rev l & x.
Proof. intros. rewrite <- app_cons_one. rewrite~ rev_app. Qed.
Lemma rev_last : forall x l,
  rev (l & x) = x::(rev l).
Proof. intros. rewrite~ rev_app. Qed.
Lemma rev_cons_app : forall x l1 l2,
  rev (x :: l1) ++ l2 = rev l1 ++ (x::l2).
Proof. intros. rewrite rev_cons. rewrite~ <- app_last. Qed.
Lemma app_rev_cons : forall x l1 l2,
  l1 ++ rev (x :: l2) = (l1 ++ rev l2) & x.
Proof. intros. rewrite rev_cons. rewrite~ app_assoc. Qed.
Lemma rev_rev : forall l,
  rev (rev l) = l.
Proof.
  induction l. auto. rewrite rev_cons. rewrite rev_last. fequals.
Qed.
Lemma length_rev : forall l,
  length (rev l) = length l.
Proof.
  induction l. auto. rewrite rev_cons.
  rewrite length_last. rewrite~ length_cons.
Qed.

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

Lemma concat_nil :
  concat (@nil (list A)) = nil.
Proof. auto. Qed.
Lemma concat_cons : forall l m,
  concat (l::m) = l ++ concat m.
Proof. auto. Qed.
Lemma concat_one : forall l,
  concat (l::nil) = l.
Proof.
  intros. rewrite concat_cons. rewrite concat_nil.
  rewrite~ app_nil_r.
Qed.
Lemma concat_app : forall m1 m2 : list (list A),
  concat (m1 ++ m2) = concat m1 ++ concat m2.
Proof.
  induction m1; intros.
  rewrite concat_nil. do 2 rewrite~ app_nil_l.
  rewrite app_cons. do 2 rewrite concat_cons.
   rewrite app_assoc. fequals.
Qed.
Lemma concat_last : forall l m,
  concat (m & l) = concat m ++ l.
Proof. intros. rewrite~ concat_app. rewrite~ concat_one. Qed.

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

Section MapProp.
Variable f : A -> B.
Lemma map_nil :
  map f nil = nil.
Proof. auto. Qed.
Lemma map_cons : forall x l,
  map f (x::l) = f x :: map f l.
Proof. auto. Qed.
Lemma map_app : forall l1 l2,
  map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros. unfold map.
  assert (forall accu,
    fold_right (fun x acc => f x :: acc) accu (l1 ++ l2) =
    fold_right (fun x acc => f x :: acc) nil l1 ++
     fold_right (fun x acc => f x :: acc) nil l2 ++ accu).
  induction l1; intros; simpl.
   do 2 rewrite app_nil_l. gen accu.
   induction l2; intros; simpl.
     auto.
     rewrite IHl2. rewrite~ app_cons.
   rewrite IHl1. rewrite~ app_cons.
  specializes H (@nil B). rewrite~ app_nil_r in H.
Qed.
Lemma map_last : forall x l,
  map f (l & x) = map f l & f x.
Proof. intros. rewrite~ map_app. Qed.
Lemma length_map : forall l,
  length (map f l) = length l.
Proof.
  induction l. auto.
  rewrite map_cons. do 2 rewrite length_cons. auto.
Qed.
End MapProp.

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

Section FilterProp.
Variable f : A -> bool.
Lemma filter_nil :
  filter f nil = nil.
Proof. auto. Qed.

Lemma filter_cons : forall x l,
  filter f (x::l) = if f x then x :: filter f l else filter f l.
Proof. auto. Qed.

Lemma filter_app : forall l1 l2,
  filter f (l1 ++ l2) = filter f l1 ++ filter f l2.
Proof.  (* todo: factorise with map_app *)
  intros. unfold filter.
  assert (forall accu,
    fold_right (fun x acc => if f x then x::acc else acc) accu (l1 ++ l2) =
    fold_right (fun x acc => if f x then x::acc else acc) nil l1 ++
     fold_right (fun x acc => if f x then x::acc else acc) nil l2 ++ accu).
  induction l1; intros; simpl.
   do 2 rewrite app_nil_l. gen accu.
   induction l2; intros; simpl.
     auto.
     case_if. fequals. rewrite IHl2. rewrite~ app_cons. fequals.
     case_if. fequals. rewrite IHl1. rewrite~ app_cons. apply IHl1.
  specializes H (@nil A). rewrite~ app_nil_r in H.
Qed.

Lemma filter_last : forall x l,
  filter f (l & x) = filter f l ++ (if f x then x::nil else nil).
Proof. intros. rewrite~ filter_app. Qed.

End FilterProp.

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

Section MemProp.
Implicit Types k : A.
Lemma mem_nil : forall k,
  mem k nil = false.
Proof. auto. Qed.
Lemma mem_cons : forall k x l,
  mem k (x::l) = (k '= x) || (mem k l).
Proof. auto. Qed.
Lemma mem_app : forall f l1 l2,
  mem f (l1 ++ l2) = (mem f l1) || mem f l2.
Proof.
  intros. induction l1.
  rew_bool. rewrite~ app_nil_l.
  rewrite app_cons. simpl. rewrite~ IHl1.
  rewrite~ assoc_or.
Qed.
Lemma mem_last : forall k x l,
  mem k (l & x) = (k '= x) || (mem k l).
Proof.
  intros. rewrite mem_app. simpl.
  rewrite LibBool.comm_or. rew_bool. auto.
Qed.
Lemma mem_cons_eq : forall x l,
  mem x (x::l) = true.
Proof. intros. simpl. rewrite~ eqb_self. Qed.
Lemma mem_last_eq : forall x l,
  mem x (l & x) = true.
Proof. intros. rewrite mem_last. rewrite~ eqb_self. Qed.
End MemProp.

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

Lemma drop_struct : forall n l,
  n <= length l -> exists l',
  length l' = n /\ l = l' ++ (drop n l).
Proof.
  induction n; introv Len.
    exists~ (@nil A).
    destruct l. rewrite length_nil in Len. math.
     destruct (IHn l) as [l' [Le Eq]].
      rewrite length_cons in Len. math.
     exists (a::l'). split. rewrite length_cons. rewrite~ Le.
     rewrite app_cons. simpl. fequals~.
Qed.
(* todo: missing properties of drop *)

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

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

Lemma take_cons : forall x l n,
  take (S n) (x::l) = x :: (take n l).
Proof. auto. Qed.

Lemma take_cons_pred : forall x l n,
  (n > 0) ->
  take n (x::l) = x :: (take (n-1) l).
Proof.
  introv H. destruct n. false; math.
  simpl. fequals_rec. math.
Qed.

Lemma take_app_l : forall n l l',
  (n <= length l) ->
  take n (l ++ l') = take n l.
Proof.
  induction n; destruct l; introv H;
   try rewrite length_nil in H;
   try rewrite length_cons in H; auto.
  math.
  rewrite app_cons. do 2 rewrite take_cons. fequals.
   applys IHn. math.
Qed.

Lemma take_app_r : forall n l l',
  (n >= length l) ->
  take n (l ++ l') = l ++ take (n - length l) l'.
Proof.
  intros. gen n. induction l; introv H.
  rewrite length_nil in *. do 2 rewrite app_nil_l.
   fequals. math.
  rewrite length_cons in *. destruct n as [|n'].
    false. math.
    do 2 rewrite app_cons. rewrite take_cons.
    fequals. applys IHl. math.
Qed.

Lemma take_app_length : forall l l',
  take (length l) (l ++ l') = l.
Proof.
  intros. rewrite take_app_r.
  asserts_rewrite (forall a, a - a = 0). math.
  rewrite take_nil. apply app_nil_r. math.
Qed.

Lemma take_at_length : forall l,
  take (length l) l = l.
Proof.
  intros. lets: (@take_app_length l nil).
  rewrite~ app_nil_r in H.
Qed.

  (* todo: or name as take_length ? *)
Lemma length_take : forall n l,
  n <= length l ->
  length (take n l) = n.
Proof.
  induction n; introv H.
  rewrite~ take_nil.
  destruct l. rewrite length_nil in H. math.
  rewrite take_cons.
   rewrite length_cons in *. rewrite IHn; math.
Qed.

Lemma take_struct : forall n l,
  n <= length l ->
  exists l', length (take n l) = n
          /\ l = (take n l) ++ l'.
Proof. (* todo: relate with drop ! *)
  induction n; introv Len.
    exists~ l.
    destruct l. rewrite length_nil in Len. math. simpl.
     destruct (IHn l) as [l' [Le Eq]].
      rewrite length_cons in Len. math.
     exists l'. split. rewrite length_cons. rewrite~ Le.
     rewrite app_cons. fequals~.
Qed.

Lemma split_cons : forall {A1 A2}
 (l1:list A1) (l2:list A2) (x1:A1) (x2:A2) (l:list (A1*A2)),
  (l1,l2) = split l ->
  split ((x1,x2)::l) = (x1::l1,x2::l2).
Proof.
  intros. destruct l; inverts H; simpl.
    auto.
    destruct p. simpl. destruct (split l). fequals.
Qed.

Lemma take_and_drop : forall n l f r,
  f = take n l -> r = drop n l -> n <= length l ->
  l = f ++ r /\ length f = n /\ length r = length l - n.
Proof.
  induction n; introv F R L; simpls.
  subst. splits~. math.
  destruct l.
    rewrite length_nil in L. math.
    rewrite length_cons in L.
     forwards~ (F'&R'&L'): (>> IHn l (take n l) r). math.
     subst f. splits.
       rewrite app_cons. fequals.
       rewrite length_cons. math.
       rewrite length_cons. math.
Qed.

End OperationProperties.

Implicit Arguments length_zero_inv [A l].
Implicit Arguments take_struct [A].

Module TakeInt.
Require Import LibInt.
Section Facts.
Variables (A:Type).
Implicit Types x : A.
Implicit Types l : list A.

Lemma take_cons_pred_int : forall x l (n:int),
  n > 0 ->
  take (abs n) (x::l) = x :: (take (abs (n-1)) l).
Proof. (* using stdlib *)
  introv Pos. rewrite take_cons_pred.
  rewrite abs_minus; try math. auto.
  forwards: Zabs_nat_lt 0 n; math.
Qed.

Lemma take_cons_int : forall x l (n:int),
  n >= 0 ->
  take (abs (n+1)) (x::l) = x :: (take (abs n) l).
Proof.
  introv Pos. rewrite~ abs_plus.
  rewrite~ plus_comm. math.
Qed.

End Facts.
End TakeInt.
Export TakeInt.

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

Section TakeDropLastProperties.
Context (A:Type) (IA:Inhab A).
Implicit Types x : A.
Implicit Types l : list A.

Lemma take_drop_last_spec : forall (x:A) (l l': list A),
  (l',x) = take_drop_last l -> l <> nil ->
  l = l' & x.
Proof.
  induction l as [|a t]; introv E N. false.
  unfold take_drop_last in E. fold take_drop_last in E.
  destruct (take_drop_last t) as [u r].
   destruct t; inverts E. rewrite* app_nil_l.
   rewrite app_cons. fequals. applys IHt; auto_false*.
Qed.

Lemma take_drop_last_length : forall l l' x,
  (l',x) = take_drop_last l -> l <> nil ->
  length l' = length l - 1.
Proof.
  (* TODO: simplify using lemma above *)
  intros l. induction l as [|x t]; introv E N.
  false.
  unfold take_drop_last in E. fold take_drop_last in E.
   sets_eq F: take_drop_last. destruct t as [|y u].
     inverts E. rewrite length_cons. math.
     destruct (F (y::u)) as [r v]. inverts E.
     forwards*: IHt. auto_false.
      rewrite length_cons in H. repeat rewrite length_cons.
      math.
Qed.

End TakeDropLastProperties.

Implicit Arguments take_drop_last_spec [[IA]].
Implicit Arguments take_drop_last_length [[IA]].

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

Section NthDefProperties.
Variables (A:Type).
Implicit Types n : nat.
Implicit Types d x : A.
Implicit Types l : list A.

Lemma nth_def_nil : forall n d,
  nth_def d n nil = d.
Proof. introv. destruct~ n. Qed.

Lemma nth_def_zero : forall x l d,
  nth_def d 0 (x::l) = x.
Proof. introv. reflexivity. Qed.

Lemma nth_def_succ : forall n x l d,
  nth_def d (S n) (x::l) = nth_def d n l.
Proof. introv. reflexivity. Qed.

End NthDefProperties.

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

Section nthProperties.
Variables (A:Type) (IA: Inhab A).
Implicit Types n : nat.
Implicit Types x : A.
Implicit Types l : list A.

Lemma nth_zero : forall x l,
  nth 0 (x::l) = x.
Proof. intros. apply nth_def_zero. Qed.

Lemma nth_succ : forall n x l,
  nth (S n) (x::l) = nth n l.
Proof. intros. apply nth_def_succ. Qed.

End nthProperties.

Implicit Arguments nth_zero [A [IA]].
Implicit Arguments nth_succ [A [IA]].

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

Lemma length_update : forall A (l:list A) (i:nat) (v:A),
  length (update i v l) = length l.
Proof.
  intros. gen i. induction l; intros.
  simple~.
  destruct i as [|i'].
    simpl. do 2 rewrite length_cons. auto.
    simpl. do 2 rewrite length_cons. rewrite~ IHl.
Qed.

Lemma nth_update_eq : forall `{Inhab A} (l:list A) (i:nat) (v:A),
  (i < length l)%nat ->
  nth i (update i v l) = v.
Proof.
  introv N. gen l. induction i; intros.
  destruct l.
    simpl in N. rewrite length_nil in N. math.
    simple~.
  destruct l.
    simpl in N. rewrite length_nil in N. math.
    simpl. rewrite nth_succ. rewrite~ IHi. rewrite length_cons in N. math.
Qed.

Lemma nth_update_neq : forall `{Inhab A} (l:list A) (i j:nat) (v:A),
  (j < length l)%nat -> (i <> j) ->
  nth j (update i v l) = nth j l.
Proof.
  introv. gen l i. induction j; introv B N.
  destruct i.
    false.
    destruct l. rewrite length_nil in B. math. simple~.
  destruct l. rewrite length_nil in B. math. destruct i.
    simpl. do 2 rewrite nth_succ. auto.
    simpl. do 2 rewrite nth_succ. apply~ IHj. rewrite length_cons in B. math.
Qed.

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

Lemma nth_make : forall `{Inhab A} (i n:nat) (v:A),
  (i < n)%nat -> nth i (make n v) = v.
Proof.
  introv. gen n; induction i; introv E.
  destruct n. math. auto.
  destruct n. math. simpl. rewrite nth_succ. rewrite~ IHi. math.
Qed.

Lemma length_make : forall A (n:nat) (v:A),
  length (make n v) = n.
Proof.
  intros. induction n.
  auto.
  simpl. rewrite length_cons. math.
Qed.

(* ********************************************************************** *)
(** * Association lists *)

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

Section Assoc.
Context {A B : Type}.
Variables (IB:Inhab B).
Implicit Types x : A.
Implicit Types l : list (A*B).

Fixpoint assoc k l : B :=
  match l with
  | nil => arbitrary
  | (x,v)::l' => If x = k then v else assoc k l'
  end.

Definition mem_assoc k :=
  exists_st (fun p:A*B => k '= fst p).

Definition keys :=
  @map (A*B) A (@fst _ _).

Fixpoint remove_assoc k l : list (A*B) :=
  match l with
  | nil => nil
  | (x,v)::l' =>
      If k = x
        then l'
        else (x,v)::(remove_assoc k l')
  end.

End Assoc.

Implicit Arguments assoc [[A] [B] [IB]].
Implicit Arguments mem_assoc [[A] [B]].
Implicit Arguments keys [[A] [B]].
Implicit Arguments remove_assoc [[A] [B]].

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

Section AssocProperties.
Variable (A B : Type) (IB:Inhab B).
Implicit Types x : A.
Implicit Types l : list (A*B).

Lemma assoc_cons : forall k x y l,
  assoc k ((x,y)::l) = If x = k then y else assoc k l.
Proof. auto. Qed.
Lemma assoc_here : forall x y l,
  assoc x ((x,y)::l) = y.
Proof. intros. simpl. case_if~. Qed.
Lemma assoc_next : forall x y k l,
  k '<> x -> assoc k ((x,y)::l) = assoc k l.
Proof. intros. simpl. fold_prop. case_if~. Qed.

Lemma keys_nil :
  keys (@nil (A*B)) = nil.
Proof. auto. Qed.
Lemma keys_cons : forall x y l,
  keys ((x,y)::l) = x :: (keys l).
Proof. auto. Qed.
Lemma keys_app : forall l1 l2,
  keys (l1 ++ l2) = keys l1 ++ keys l2.
Proof. intros. applys map_app. Qed.
Lemma keys_last : forall x y l,
  keys (l & (x,y)) = (keys l) & x.
Proof. intros. rewrite~ keys_app. Qed.

Lemma remove_assoc_nil : forall x,
  remove_assoc x nil = (@nil (A*B)).
Proof. auto. Qed.
Lemma remove_assoc_cons : forall x x' y l,
  remove_assoc x ((x',y)::l) =
    If x = x' then l else (x',y)::remove_assoc x l.
Proof. auto. Qed.

End AssocProperties.

(* ********************************************************************** *)
(* * Tactics for rewriting *)

Hint Rewrite app_cons app_nil_l app_nil_r app_assoc
 app_cons_one : rew_app. (* app_last *)
Hint Rewrite fold_right_nil fold_right_cons fold_right_app
 fold_right_last : rew_foldr.
Hint Rewrite fold_left_nil fold_left_cons fold_left_app
 fold_left_last : rew_foldl.
Hint Rewrite length_nil length_cons length_app
 length_last length_rev : rew_length.
Hint Rewrite rev_nil rev_app rev_cons rev_last rev_rev : rew_rev.
 (* +rev_cons_app *)
Hint Rewrite concat_nil concat_app concat_cons concat_last : rew_concat.
Hint Rewrite map_nil map_cons map_app map_last : rew_map.
Hint Rewrite mem_nil mem_cons mem_app mem_last
 mem_cons_eq mem_last_eq : rew_mem.
Hint Rewrite keys_nil keys_cons keys_app keys_last : rew_keys.
Hint Rewrite assoc_cons assoc_here : rew_assoc.

(* TODO: rew_tactics other than [rew_app] and [rew_length]
   will become deprecated; use [rew_list] instead. *)

Tactic Notation "rew_app" :=
  autorewrite with rew_app.
Tactic Notation "rew_foldr" :=
  autorewrite with rew_foldr rew_app.
Tactic Notation "rew_foldl" :=
  autorewrite with rew_foldl rew_app.
Tactic Notation "rew_length" :=
  autorewrite with rew_length.
Tactic Notation "rew_rev" :=
  autorewrite with rew_rev rew_app.
Tactic Notation "rew_concat" :=
  autorewrite with rew_concat rew_app.
Tactic Notation "rew_map" :=
  autorewrite with rew_map rew_app.
Tactic Notation "rew_mem" :=
  autorewrite with rew_mem rew_app.
Tactic Notation "rew_keys" :=
  autorewrite with rew_keys rew_app.
Tactic Notation "rew_assoc" :=
  autorewrite with rew_assoc rew_app.

Tactic Notation "rew_app" "in" hyp(H) :=
  autorewrite with rew_app in H.
Tactic Notation "rew_foldr" "in" hyp(H) :=
  autorewrite with rew_foldr rew_app in H.
Tactic Notation "rew_foldl" "in" hyp(H) :=
  autorewrite with rew_foldl rew_app in H.
Tactic Notation "rew_length" "in" hyp(H) :=
  autorewrite with rew_length in H.
Tactic Notation "rew_rev" "in" hyp(H) :=
  autorewrite with rew_rev rew_app in H.
Tactic Notation "rew_concat" "in" hyp(H) :=
  autorewrite with rew_concat rew_app in H.
Tactic Notation "rew_map" "in" hyp(H) :=
  autorewrite with rew_map rew_app in H.
Tactic Notation "rew_mem" "in" hyp(H) :=
  autorewrite with rew_mem rew_app in H.
Tactic Notation "rew_keys" "in" hyp(H) :=
  autorewrite with rew_keys rew_app in H.
Tactic Notation "rew_assoc" "in" hyp(H) :=
  autorewrite with rew_assoc rew_app in H.

Tactic Notation "rew_app" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_app).
  (* autorewrite with rew_app in *. *)

  (* TODO: if those are kept, need the efficiency workaround *)
Tactic Notation "rew_foldr" "in" "*" :=
  autorewrite with rew_foldr rew_app in *.
Tactic Notation "rew_foldl" "in" "*" :=
  autorewrite with rew_foldl rew_app in *.
Tactic Notation "rew_length" "in" "*" :=
  autorewrite with rew_length in *.
Tactic Notation "rew_rev" "in" "*" :=
  autorewrite with rew_rev rew_app in *.
Tactic Notation "rew_concat" "in" "*" :=
  autorewrite with rew_concat rew_app in *.
Tactic Notation "rew_map" "in" "*" :=
  autorewrite with rew_map rew_app in *.
Tactic Notation "rew_mem" "in" "*" :=
  autorewrite with rew_mem rew_app in *.
Tactic Notation "rew_keys" "in" "*" :=
  autorewrite with rew_keys rew_app in *.
Tactic Notation "rew_assoc" "in" "*" :=
  autorewrite with rew_assoc rew_app in *.

Tactic Notation "rew_app" "~" :=
  rew_app; auto_tilde.
Tactic Notation "rew_rev" "~" :=
  rew_rev; auto_tilde.
Tactic Notation "rew_mem" "~" :=
  rew_mem; auto_tilde.
Tactic Notation "rew_length" "~" :=
  rew_length; auto_tilde.

Hint Rewrite app_cons app_nil_l app_nil_r app_assoc
 app_cons_one
 fold_right_nil fold_right_cons fold_right_app
 fold_right_last
 fold_left_nil fold_left_cons fold_left_app
 fold_left_last
 length_nil length_cons length_app length_rev
 length_last
 rev_nil rev_app rev_cons rev_last rev_rev
 concat_nil concat_app concat_cons concat_last
  map_nil map_cons map_app map_last : rew_list.

Hint Rewrite app_cons app_nil_l app_nil_r app_assoc
 app_cons_one
 mem_nil mem_cons mem_app mem_last
 mem_cons_eq mem_last_eq
 keys_nil keys_cons keys_app keys_last
 assoc_cons assoc_here : rew_lists.

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

Tactic Notation "rew_lists" :=
  autorewrite with rew_lists.
Tactic Notation "rew_lists" "~" :=
  rew_lists; auto_tilde.
Tactic Notation "rew_lists" "*" :=
  rew_lists; auto_star.
Tactic Notation "rew_lists" "in" "*" :=
  autorewrite with rew_lists in *.
Tactic Notation "rew_lists" "~" "in" "*" :=
  rew_lists in *; auto_tilde.
Tactic Notation "rew_lists" "*" "in" "*" :=
  rew_lists in *; auto_star.
Tactic Notation "rew_lists" "in" hyp(H) :=
  autorewrite with rew_lists in H.
Tactic Notation "rew_lists" "~" "in" hyp(H) :=
  rew_lists in H; auto_tilde.
Tactic Notation "rew_lists" "*" "in" hyp(H) :=
  rew_lists in H; auto_star.

(* ********************************************************************** *)
(** * Other definitions and results *)

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

(* todo *)

Definition is_head A (l:list A) (x:A) :=
  exists t, l = x::t.

Definition is_tail A (l:list A) (t:list A) :=
  exists x, l = x::t.

Definition is_last A (l:list A) (x:A) :=
  exists t, l = t&x.

Definition is_init A (l:list A) (t:list A) :=
  exists x, l = t&x.

Hint Unfold is_head is_tail is_last is_init.

Section IsProp.
Variables A : Type.
Implicit Types x : A.

Lemma is_last_one : forall x,
  is_last (x::nil) x.
Proof. intros. unfolds. exists~ (@nil A). Qed.

Lemma is_init_one : forall x,
  is_init (x::nil) nil.
Proof. intros. unfolds. exists~ x. Qed.

End IsProp.

Hint Immediate is_last_one.
Hint Immediate is_init_one.

(* ---------------------------------------------------------------------- *)
(** * Inversions on the structure of lists *)

Section Inversions.
Variables A : Type.
Implicit Types l : list A.

Lemma cons_neq_nil : forall x l,
  x::l <> nil.
Proof. auto_false. Qed.

Lemma last_eq_nil_inv : forall a l,
  l & a = nil -> False.
Proof. induction l; rew_app; intros; false. Qed.

Lemma nil_eq_last_inv : forall a l,
  nil = l & a -> False.
Proof. intros. apply* last_eq_nil_inv. Qed.

Lemma rev_eq_nil_inv : forall l,
  rev l = nil -> l = nil.
Proof.
  destruct l; rew_rev; intros. auto.
  false* last_eq_nil_inv.
Qed.

Lemma nil_eq_rev_inv : forall l,
  nil = rev l -> l = nil.
Proof. introv H. apply~ rev_eq_nil_inv. Qed.

Lemma app_eq_nil_inv : forall l1 l2,
  l1 ++ l2 = nil -> l1 = nil /\ l2 = nil.
Proof. destruct l1; destruct l2; intros; tryfalse~; auto. Qed.

Lemma nil_eq_app_inv : forall l1 l2,
  nil = l1 ++ l2 -> l1 = nil /\ l2 = nil.
Proof. intros. symmetry in H. apply* app_eq_nil_inv. Qed.

Lemma app_eq_self_inv_r : forall l1 l2,
  l2 = l1 ++ l2 -> l1 = nil.
Proof.
  introv E. apply length_zero_inv.
  lets: (func_eq_1 length E). rew_length in H. math.
Qed.

Lemma app_eq_self_inv_l : forall l1 l2,
  l1 = l1 ++ l2 -> l2 = nil.
Proof.
  introv E. apply length_zero_inv.
  lets: (func_eq_1 length E). rew_length in H. math.
Qed.

Lemma app_rev_eq_nil_inv : forall l1 l2,
  l1 ++ rev l2 = nil -> l1 = nil /\ l2 = nil.
Proof.
  intros. lets H1 H2: (app_eq_nil_inv _ _ H).
  applys_to H2 rev_eq_nil_inv. autos*.
Qed.

Lemma nil_eq_app_rev_inv : forall l1 l2,
  nil = l1 ++ rev l2 -> l1 = nil /\ l2 = nil.
Proof. intros. apply* app_rev_eq_nil_inv. Qed.

(* todo: too specific? *)

Lemma nil_eq_last_val_app_inv : forall x l1 l2,
  nil = l1 & x ++ l2 -> False.
Proof. intros. destruct l1; inverts H. Qed.

Lemma last_eq_last_inv : forall x1 x2 l1 l2,
  l1 & x1 = l2 & x2 -> l1 = l2 /\ x1 = x2.
Proof.
  introv H. gen l2. induction l1; introv E; rew_app in E.
  destruct l2; rew_app in E; inverts E as E.
   auto. false nil_eq_last_inv E.
  destruct l2; rew_app in E.
    inverts E as E. false last_eq_nil_inv E.
    inverts E. forwards* [? ?]: IHl1.
     split; congruence. (* TODO: congruence that does split *)
Qed.

Lemma cons_eq_last_val_app_inv : forall x y l1 l2 l,
  x :: l = l1 & y ++ l2 ->
  (l1 = nil /\ x = y /\ l = l2) \/ (exists l1', l1 = x::l1').
Proof.
  intros. destruct l1; rew_list in H; inverts H.
   left~. right*.
Qed.

Lemma last_inv : forall l, (* TODO: rename to last_inv_pos_length *)
  (length l > 0%nat) ->
  exists x l', l = l' & x.
Proof.
  induction l; rew_length; introv H.
  false. math.
  destruct l.
    exists~ a (@nil A).
    destruct IHl as (x&l'&E). rew_length in *. math.
    exists x (a::l'). rewrite~ E.
Qed.

Lemma last_case : forall l,
  l = nil \/ exists x l', l = l' & x.
Proof.
  intros. destruct l. left*. right.
  forwards* (x&l'&H): (last_inv (a::l)).
    rew_length. math.
Qed.

Lemma last_neq_nil : forall l,
  l <> nil -> exists x q, l = q&x.
Proof. introv N. destruct* (@last_case l). Qed.

Lemma app_not_empty_l : forall l1 l2,
  l1 <> nil -> l1 ++ l2 <> nil.
Proof. introv NE K. apply NE. destruct~ (app_eq_nil_inv _ _ K). Qed.

Lemma app_not_empty_r : forall l1 l2,
  l2 <> nil -> l1 ++ l2 <> nil.
Proof. introv NE K. apply NE. destruct~ (app_eq_nil_inv _ _ K). Qed.

Lemma length_zero_iff_nil : forall l,
  length l = 0 <-> l = nil.
Proof.
  intros. iff M. destruct l; simpls; auto_false*. subst*. Qed.

Lemma length_neq_elim : forall l1 l2,
  length l1 <> length l2 -> (l1 <> l2).
Proof. introv N E. subst. auto. Qed.

End Inversions.

Implicit Arguments last_eq_nil_inv [A a l].
Implicit Arguments nil_eq_last_inv [A a l].
Implicit Arguments rev_eq_nil_inv [A l].
Implicit Arguments nil_eq_rev_inv [A l].
Implicit Arguments app_eq_nil_inv [A l1 l2].
Implicit Arguments nil_eq_app_inv [A l1 l2].
Implicit Arguments app_rev_eq_nil_inv [A l1 l2].
Implicit Arguments nil_eq_app_rev_inv [A l1 l2].
Implicit Arguments nil_eq_last_val_app_inv [A x l1 l2].
Implicit Arguments cons_eq_last_val_app_inv [A x y l1 l2 l].

(* ---------------------------------------------------------------------- *)
(* ** Function for mapping partial function on lists *)

Definition map_partial (A B : Type) (f : A -> option B) :=
  fix aux (l : list A) : option (list B) := match l with
    | nil => Some nil
    | x::l' => LibOption.apply_on (f x) (fun v =>
                 LibOption.map (cons v) (aux l'))
   end.

Lemma map_partial_inv : forall (A B:Type) (f: A->option B) lx ly,
  map_partial f lx = Some ly ->
  Forall2 (fun x y => f x = Some y) lx ly.
Proof.
  induction lx; simpl map_partial; introv Eq.
  inverts Eq. apply Forall2_nil.
  lets fa Fa Eq2: (apply_on_inv Eq).
   lets ly1 Eqly ?: (map_on_inv Eq2). subst ly.
   apply* Forall2_cons.
Qed.

Implicit Arguments map_partial_inv [A B f lx ly].

(* ---------------------------------------------------------------------- *)
(* ** Induction principle on lists *)

Section ListSub.
Variable (A:Type).

(** Immediate sub-list well-founded order *)

Inductive list_sub : list A -> list A -> Prop :=
  | list_sub_cons : forall x l,
      list_sub l (x::l).

Hint Constructors list_sub.
Lemma list_sub_wf : wf list_sub.
Proof.
  intros l. induction l;
  apply Acc_intro; introv H; inverts~ H.
Qed.

End ListSub.

Implicit Arguments list_sub [[A]].
Hint Constructors list_sub.
Hint Resolve list_sub_wf : wf.

(** Induction on all but last item *)

Lemma list_ind_last : forall (A : Type) (P : list A -> Prop),
  P nil ->
  (forall (a : A) (l : list A), P l -> P (l & a)) ->
  forall l : list A, P l.
Proof.
  introv H1 H2. intros. induction_wf IH: (measure_wf (@length A)) l.
  lets [E|(x&l'&E)]: (last_case l); subst. auto.
  unfolds measure. rewrite length_last in IH. auto with maths.
Qed.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Logical predicates *)

Section LogicList.

(** [Forall P L] asserts that all the elements in the list [L]
    satisfy the predicate [P]. *)

Inductive Forall A (P : A -> Prop)
  : list A -> Prop :=
  | Forall_nil :
      Forall P nil
  | Forall_cons : forall l x,
      P x -> Forall P l ->
      Forall P (x::l).

(** [Forall2 P L1 L2] asserts that the lists [L1] and [L2]
    have the same length and that elements at corresponding
    indices are related by the binary relation [P]. *)

Inductive Forall2 A B (P : A -> B -> Prop)
  : list A -> list B -> Prop :=
  | Forall2_nil :
      Forall2 P nil nil
  | Forall2_cons : forall l1 l2 x1 x2,
      P x1 x2 -> Forall2 P l1 l2 ->
      Forall2 P (x1::l1) (x2::l2).

(** Similar to [Forall2] except that it relates three lists *)

Inductive Forall3 A B C (P : A -> B -> C -> Prop)
  : list A -> list B -> list C -> Prop :=
  | Forall3_nil :
      Forall3 P nil nil nil
  | Forall3_cons : forall l1 l2 l3 x1 x2 x3,
      P x1 x2 x3 -> Forall3 P l1 l2 l3 ->
      Forall3 P (x1::l1) (x2::l2) (x3::l3).

(** [exists P L] asserts that there exists a value in the
    list [L] that satisfied the predicate [P]. *)

Inductive Exists A (P : A -> Prop)
  : list A -> Prop :=
  | Exists_here : forall l x,
      P x -> Exists P (x::l)
  | Exists_next : forall l x,
      Exists P l ->
      Exists P (x::l).

(** [exists2 P L1 L2] asserts that there exists an index [n]
    such that the n-th element of [L1] and the n-th element
    of [L2] are related by the binary relation [P]. *)

Inductive Exists2 A1 A2 (P : A1 -> A2 -> Prop)
  : list A1 -> list A2 -> Prop :=
  | Exists2_here : forall l1 l2 x1 x2,
      P x1 x2 -> Exists2 P (x1::l1) (x2::l2)
  | Exists2_next : forall l1 l2 x1 x2,
      Exists2 P l1 l2 ->
      Exists2 P (x1::l1) (x2::l2).

(** [filter P L] produces a list [L'] that is the sublist of [L]
    made exactly of the elements of [L] that satisfy [P]. *)

Definition Filter A (P : A->Prop) :=
  fold_right (fun x acc => If P x then x::acc else acc) (@nil A).

(** [filters P L L'] asserts that [L'] is the sublist of [L]
    made exactly of the elements of [L] that satisfy [P]. *)
   (* DEPRECATED: use Filter instead *)

Inductive Filters A (P : A -> Prop)
  : list A -> list A -> Prop :=
  | Filters_nil : Filters P nil nil
  | Filters_cons_yes : forall l l' x,
      P x -> Filters P l l' ->
      Filters P (x::l) (x::l')
  | Filters_cons_no : forall l l' x,
      ~ (P x) -> Filters P l l' ->
      Filters P (x::l) l'.

(** [Mem x l] asserts that [x] belongs to [M] *)

Inductive Mem A (x:A) : list A -> Prop :=
  | Mem_here : forall l,
      Mem x (x::l)
  | Mem_next : forall y l,
      Mem x l ->
      Mem x (y::l).

(** [Remove_duplicates L] produces a list [L'] that is the sublist of [L]
    obtained by keeping only the first occurence of every item. *)

Fixpoint Remove_duplicates A (L:list A) :=
  match L with
  | nil => nil
  | x::L' => x :: (Filter (<> x) (Remove_duplicates L'))
  end.

(** [No_duplicates L] asserts that [L] does not contain any
    duplicated item. *)

Inductive No_duplicates A : list A -> Prop :=
  | No_duplicates_nil : No_duplicates nil
  | No_duplicates_cons : forall x l,
      ~ (Mem x l) -> No_duplicates l -> No_duplicates (x::l).

(** [Nth n L x] asserts that the n-th element of the list [L]
    exists and is exactly [x] *)

Inductive Nth A : nat -> list A -> A -> Prop :=
  | Nth_here : forall l x,
      Nth 0 (x::l) x
  | Nth_next : forall y n l x,
      Nth n l x ->
      Nth (S n) (y::l) x.

(** [Update n x L L'] asserts [L'] is the list obtained by substituting
    in [L] the item at index [n] with [x]. *)

Definition Update A (n:nat) (x:A) l l' :=
    length l' = length l
  /\ (forall y m, Nth m l y -> m <> n -> Nth m l' y)
  /\ Nth n l' x.

(** [Assoc x v l] asserts that [(x,v)] the first pair of the
    form [(x,_)] in [l] *)

Inductive Assoc A B (x:A) (v:B) : list (A*B) -> Prop :=
  | Assoc_here : forall l ,
      Assoc x v ((x,v)::l)
  | Assoc_next : forall y l (w:B),
      Assoc x v l -> x <> y ->
      Assoc x v ((y,w)::l).

(** [has pair x1 x2 l1 l2] asserts that there exists an
    index [n] such that the n-th element of [l1] is [x1]
    and the n-th element of [l2] is [x2] *)

Definition has_pair A1 A2 (x1:A1) (x2:A2) l1 l2 :=
  Exists2 (fun v1 v2 => v1 = x1 /\ v2 = x2) l1 l2.

Lemma has_pair_here : forall A1 A2 (x1:A1) (x2:A2) l1 l2,
  has_pair x1 x2 (x1::l1) (x2::l2).
Proof. intros. constructor~. Qed.

Lemma has_pair_next : forall A1 A2 (x1:A1) (x2:A2) y1 y2 l1 l2,
  has_pair x1 x2 l1 l2 ->
  has_pair x1 x2 (y1::l1) (y2::l2).
Proof. introv H. apply* Exists2_next. Qed.

End LogicList.

(* ********************************************************************** *)
(** * Properties of predicate on lists *)

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

Section ForallProp.
Variables A : Type.
Implicit Types l : list A.

Hint Constructors Forall.

Lemma Forall_app : forall P l1 l2,
  Forall P l1 -> Forall P l2 ->
  Forall P (l1 ++ l2).
Proof. introv H Px. induction H; rew_app; auto. Qed.

Lemma Forall_app_inv : forall P l1 l2,
  Forall P (l1 ++ l2) ->
  Forall P l1 /\ Forall P l2.
Proof.
  intros. induction l1. auto.
  rew_app in H. inverts* H.
Qed.

Lemma Forall_last : forall P l x,
  Forall P l -> P x ->
  Forall P (l & x).
Proof. intros. apply~ Forall_app. Qed.

Lemma Forall_last_inv : forall P l x,
  Forall P (l & x) ->
  Forall P l /\ P x.
Proof.
  introv H. induction l.
  inverts* H.
  rew_list in *. inverts H. forwards*: IHl.
Qed.

Lemma Forall_weaken : forall P Q l,
  Forall P l -> pred_le P Q ->
  Forall Q l.
Proof. induction l; introv H L; inverts* H. Qed.

End ForallProp.

Section ForallToConj.
Variables (A : Type) (P : A->Prop).
Hint Constructors Forall.
Ltac forall_to_conj_prove :=
  extens; iff H;
  repeat (match goal with H: Forall _ _ |- _ => inversion H end);
  repeat (first [constructor | auto_star ]).

Lemma Forall_to_conj_1 : forall x1,
  Forall P (x1::nil) = (P x1).
Proof. forall_to_conj_prove. Qed.

Lemma Forall_to_conj_2 : forall x1 x2,
  Forall P (x1::x2::nil) = (P x1 /\ P x2).
Proof. forall_to_conj_prove. Qed.

Lemma Forall_to_conj_3 : forall x1 x2 x3,
  Forall P (x1::x2::x3::nil) = (P x1 /\ P x2 /\ P x3).
Proof. forall_to_conj_prove. Qed.

Lemma Forall_to_conj_4 : forall x1 x2 x3 x4,
  Forall P (x1::x2::x3::x4::nil) = (P x1 /\ P x2 /\ P x3 /\ P x4).
Proof. forall_to_conj_prove. Qed.

End ForallToConj.

Hint Resolve has_pair_here has_pair_next.

Global Instance Forall_decidable : forall (A : Type) (P : A->Prop) (l : list A),
  (forall x, Decidable (P x)) -> Decidable (Forall P l).
Proof.  (*todo: optimize proof *)
  introv H. applys decidable_make
    (fold_left (fun a b => and b (decide (P a))) true l).
  tests: (Forall P l).
   rewrite~ isTrue_true. fold_bool.
    induction~ C. simpl. case_if~.
   rewrite~ isTrue_false. fold_bool.
    induction~ l.
     false C. constructor~.
     simpl. case_if~.
      apply~ IHl. intro F; apply C. constructor~.
      clear C IHl. induction* l.
Qed.

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

Section PropProperties2.
Variables A1 A2 : Type.
Implicit Types l : list A1.
Implicit Types r : list A2.
Hint Constructors Forall2.

Lemma Forall2_app : forall P l1 l2 r1 r2,
      Forall2 P l1 r1 -> Forall2 P l2 r2 ->
      Forall2 P (l1 ++ l2) (r1 ++ r2).
Proof. introv H H'. induction H; rew_app; auto. Qed.

Lemma Forall2_last : forall P l r x1 x2,
      Forall2 P l r -> P x1 x2 ->
      Forall2 P (l & x1) (r & x2).
Proof. intros. apply~ Forall2_app. Qed.

Lemma Forall2_last_inv : forall P l1 r' x1,
  Forall2 P (l1 & x1) r' ->
  exists (r2:list A2) x2,
  r' = r2 & x2 /\ P x1 x2 /\ Forall2 P l1 r2.
Proof.
  introv H. sets_eq l': (l1&x1). gen l1 x1.
  induction H; intros; subst.
  false* nil_eq_last_inv.
  destruct l0; rew_app in EQl'; inverts EQl'.
    inverts H0. exists~ (@nil A2) x2.
    forwards~ (r2'&x2'&?&?&?): IHForall2. subst. exists~ (x2::r2') x2'.
Qed.

Lemma Forall2_length : forall P l r,
  Forall2 P l r -> length l = length r.
Proof.
  introv H. induction H. simple~.
  do 2 rewrite~ length_cons.
Qed.

Lemma Forall2_take : forall P n l r,
  Forall2 P l r ->
  Forall2 P (take n l) (take n r).
Proof. induction n; introv H; inverts H; simple~. Qed.

Hint Constructors Forall2.
Hint Resolve Forall2_last.

Lemma Forall2_rev : forall P l r,
  Forall2 P l r -> Forall2 P (rev l) (rev r).
Proof. induction l; introv M; inverts M; rew_rev; auto. Qed.

(* TODO: Forall2_weaken *)

End PropProperties2.

Implicit Arguments Forall2_last_inv [A1 A2 P l1 r' x1].

(* todo : inversion lemmas for other predicates *)

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

Section ExistsProp.
Variables A : Type.
Implicit Types l : list A.

Lemma Exists_nil_inv : forall (P : A -> Prop),
  Exists P nil -> False.
Proof. introv H. invert* H. Qed.

Lemma Exists_cons_inv : forall (P : A -> Prop) l x,
  Exists P (x::l) -> P x \/ Exists P l.
Proof. induction l; introv H; inverts~ H. Qed.

(* TODO: Exists_weaken *)

End ExistsProp.

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

Section NthProperties.
Variables (A : Type) (IA : Inhab A).
Implicit Types l : list A.
Implicit Types x : A.
Implicit Types n : nat.
Hint Constructors Nth.

Lemma Nth_lt_length : forall n l x,
  Nth n l x -> n < length l.
Proof.
  induction n; introv H; inverts H.
  rewrite length_cons. math.
  rewrite length_cons. simpl. rew_nat*.
Qed.

Lemma Nth_func: forall n l x1 x2,
  Nth n l x1 -> Nth n l x2 -> x1 = x2.
Proof. introv H1. induction H1; intro H2; inverts~ H2. Qed.

Lemma Nth_to_nth_def : forall n l x dummy,
  Nth n l x -> nth_def dummy n l = x.
Proof. introv H. induction~ H. Qed.

Lemma Nth_to_nth : forall n l x,
  Nth n l x -> nth n l = x.
Proof. introv H. apply~ Nth_to_nth_def. Qed.

Lemma mem_Nth : forall l x,
  mem x l -> exists n, Nth n l x.
Proof.
  intros. induction l.
  rewrite mem_nil in H. false.
  rewrite mem_cons in H. rew_reflect in H. destruct H.
   fold_prop. subst*.
   forwards* [n ?]: IHl.
Qed.

Implicit Arguments mem_Nth [l x].

Lemma mem_nth : forall l x,
  mem x l -> exists n, nth n l = x.
Proof.
  intros. forwards [n P]: (mem_Nth H).
  exists n. apply~ Nth_to_nth.
Qed.

Lemma Nth_app_l : forall n x l1 l2,
  Nth n l1 x -> Nth n (l1 ++ l2) x.
Proof. induction n; introv H; inverts H; rew_list*. Qed.

Lemma Nth_app_r : forall n m x l1 l2,
  Nth m l2 x -> n = (m + length l1)%nat -> Nth n (l1 ++ l2) x.
Proof.
  intros. subst. gen m. induction l1; introv H.
  rew_list. applys_eq~ H 3.
  rew_list. applys_eq* Nth_next 3.
Qed.

Lemma Nth_app_inv : forall n x l1 l2,
  Nth n (l1++l2) x ->
     (Nth n l1 x)
  \/ (exists m, n = (length l1 + m)%nat /\ Nth m l2 x).
Proof.
  introv. gen n. induction l1; introv H; rew_list in H.
  right. rew_length. exists~ n.
  inverts H. left~.
   forwards* M: IHl1. destruct M.
    left~. unpack. rew_length.
    right*. exists x0. split~. math.
Qed.

Lemma Nth_nil_inv : forall n x,
  Nth n nil x -> False.
Proof. introv H. inverts H. Qed.

Lemma Nth_cons_inv : forall n x l,
  Nth n l x ->
     (exists q, l = x::q /\ n = 0%nat)
  \/ (exists y q m, l = y::q /\ Nth m q x /\ n = (m+1)%nat).
Proof.
  introv H. inverts H. left*.
  right. eauto 8 with maths.
Qed.

End NthProperties.

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

Section MemFacts.
Hint Constructors Mem.

Lemma Mem_induct : forall (A : Type) (x : A) (P : list A -> Prop),
  (forall l : list A, P (x :: l)) ->
  (forall (y : A) (l : list A), Mem x l -> x <> y -> P l -> P (y :: l)) ->
  (forall l : list A, Mem x l -> P l).
Proof.
  introv HH HN M. induction l.
  inverts M.
  tests: (x = a). auto. inverts M; auto_false*.
Qed.

Lemma Mem_nil_eq : forall A (x:A),
  Mem x nil = False.
Proof. intros. extens. iff H; inverts H. Qed.

Lemma Mem_cons_eq : forall A (x y:A) l,
  Mem x (y::l) = ((x = y) \/ (Mem x l)).
Proof. intros. extens. iff H; inverts~ H. Qed.

Lemma Mem_app_or_eq : forall (A:Type) (l1 l2 : list A) x,
  Mem x (l1 ++ l2) = (Mem x l1 \/ Mem x l2).
Proof.
  intros. extens. induction l1; rew_app.
  split. auto. introv [H|?]. inverts H. auto.
  iff M. inverts~ M. rewrite IHl1 in H0. destruct* H0.
   destruct M. inverts~ H. constructors. rewrite~ IHl1.
   constructors. rewrite~ IHl1.
Qed.

Lemma Mem_app_or : forall (A:Type) (l1 l2 : list A) x,
  Mem x l1 \/ Mem x l2 -> Mem x (l1 ++ l2).
Proof. intros. rewrite~ Mem_app_or_eq. Qed.

Lemma Mem_last : forall A (L:list A) x,
  Mem x (L & x).
Proof. intros. apply* Mem_app_or. Qed.

Lemma Mem_rev : forall A (L:list A) x,
  Mem x L -> Mem x (rev L).
Proof. introv H. induction H; rew_rev; apply~ Mem_app_or. Qed.

Lemma Mem_rev_iff : forall A (L:list A) x,
  Mem x L <-> Mem x (rev L).
Proof.
 iff M.
 apply~ Mem_rev.
 lets H: Mem_rev M. rewrite~ rev_rev in H.
Qed.

Lemma Mem_inv : forall A (L:list A) x y,
  Mem x (y::L) -> x = y \/ x <> y /\ Mem x L.
Proof. introv H. tests: (x = y). eauto. inverts H. false. eauto. Qed.

Lemma Mem_map : forall (A B:Type) (f:A->B) (l: list A) x,
  Mem x l -> Mem (f x) (map f l).
Proof. introv M. induction M; rew_map; auto. Qed.

Fixpoint mem_decide `{Comparable A} (x : A) (l : list A) :=
  match l with
  | nil => false
  | y::l' => ifb x = y then true else mem_decide x l'
  end.

Global Instance Mem_decidable : forall `{Comparable A} (x : A) (l : list A),
   Decidable (Mem x l).
Proof.
  intros. applys decidable_make (mem_decide x l). extens. rew_refl.
  induction l; simpl.
  iff E. false. inverts E.
  case_if.
    iff E; subst*.
    iff E. constructors*. inverts* E.
Qed.

End MemFacts.

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

Section FilterFacts.
Variables (A:Type).
Implicit Types P : A -> Prop.

Lemma Filter_nil : forall P,
  Filter P nil = nil.
Proof. auto. Qed.

Lemma Filter_cons : forall x l P,
  Filter P (x::l) = If P x then x :: Filter P l else Filter P l.
Proof. auto. Qed.

Lemma Filter_app : forall l1 l2 P,
  Filter P (l1 ++ l2) = Filter P l1 ++ Filter P l2.
Proof.  (* todo: factorise with map_app and above *)
  intros. unfold Filter.
  assert (forall accu,
    fold_right (fun x acc => If P x then x::acc else acc) accu (l1 ++ l2) =
    fold_right (fun x acc => If P x then x::acc else acc) nil l1 ++
     fold_right (fun x acc => If P x then x::acc else acc) nil l2 ++ accu).
  induction l1; intros; simpl.
   do 2 rewrite app_nil_l. gen accu.
   induction l2; intros; simpl.
     auto.
     case_if. fequals. rewrite IHl2. rewrite~ app_cons. fequals.
     case_if. fequals. rewrite IHl1. rewrite~ app_cons. apply IHl1.
  specializes H (@nil A). rewrite~ app_nil_r in H.
Qed.

Lemma Filter_last : forall x l P,
  Filter P (l & x) = Filter P l ++ (If P x then x::nil else nil).
Proof. intros. rewrite~ Filter_app. Qed.

Lemma Filter_neq : forall x (L:list A),
  ~ Mem x (Filter (<> x) L).
Proof.
  intros. induction L.
  rewrite Filter_nil. introv M. inverts M.
  rewrite Filter_cons. case_if.
    introv M. inverts M; false.
    auto.
Qed.

Lemma Filter_Mem : forall x (L:list A) (P:A->Prop),
  Mem x L -> P x -> Mem x (Filter P L).
Proof.
  Hint Constructors Mem.
  introv H Px. induction H using Mem_induct.
  rewrite Filter_cons. case_if*.
  rewrite Filter_cons. case_if*.
Qed.

Lemma Filter_Mem_inv : forall x (L:list A) P,
  Mem x (Filter P L) -> Mem x L /\ P x.
Proof.
  Hint Constructors Mem.
  introv M. induction L.
  rewrite Filter_nil in M. inverts M.
  rewrite Filter_cons in M. case_if. inverts* M. autos*.
Qed.

Lemma Filter_length_le : forall (L:list A) P,
  (length (Filter P L) <= length L)%nat.
Proof.
  intros. induction L.
  rewrite Filter_nil. math.
  rewrite Filter_cons. case_if; rew_length; math.
Qed.

Lemma Filter_neq_Mem_length : forall x (L:list A),
  Mem x L -> (length (Filter (<> x) L) < length L)%nat.
Proof.
  introv M. induction L.
  inverts M.
  rewrite Filter_cons. case_if.
    inverts M. false. rew_length. forwards~: IHL. math.
    lets: (Filter_length_le L (<> x)). rew_length. math.
Qed.

Lemma Filter_No_duplicates : forall (L:list A) P,
  No_duplicates L -> No_duplicates (Filter P L).
Proof.
  Hint Constructors No_duplicates.
  introv H. induction H.
  rewrite* Filter_nil.
  rewrite Filter_cons. case_if.
    constructors*. introv N. false* Filter_Mem_inv N.
    auto.
Qed.

End FilterFacts.

(* ---------------------------------------------------------------------- *)
(* ** Remove_duplicates and No_duplicates *)

Lemma Remove_duplicates_spec : forall A (L L':list A),
  L' = Remove_duplicates L ->
  No_duplicates L' /\ (forall x, Mem x L' <-> Mem x L).
Proof.
  Hint Constructors Mem No_duplicates.
  introv. gen L'. induction L; introv E; simpls.
  subst. splits*.
  sets_eq L'': (Remove_duplicates L). forwards~ [E' M]: IHL. splits~.
    subst L'. constructors. applys Filter_neq. applys* Filter_No_duplicates.
    subst L'. intros x. lets (M1&M2): M x. iff N.
      inverts N as R. auto. lets: Filter_Mem_inv R. constructors*.
      lets [E|(H1&H2)]: Mem_inv N. subst*. constructors. applys* Filter_Mem.
Qed.

Lemma No_duplicates_length_le : forall A (L L':list A),
  No_duplicates L ->
  (forall x, Mem x L -> Mem x L') ->
  (length L <= length L')%nat.
Proof.
  Hint Constructors Mem.
  introv NL ML. gen L'. induction L as [|a L]; intros.
  rew_length. math.
  rew_length. inverts NL as HM NL'.
   sets_eq L'': (Filter (<> a) L').
   forwards H: Filter_neq_Mem_length a L'. applys* ML.
   rewrite <- EQL'' in H.
   forwards~: IHL L''. introv N. tests: (x = a). subst L''. applys* Filter_Mem.
   math.
Qed.

(* ---------------------------------------------------------------------- *)
(* ** Update of a functional list *)

Section UpdateProp.
Variables A : Type.
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types n : nat.
Hint Constructors Nth.

Lemma Update_here : forall x y l,
  Update 0 x (y::l) (x::l).
Proof.
  intros. splits.
  rew_length~.
  introv M H. inverts* M.
  autos*.
Qed.

Lemma Update_cons : forall i x y l l',
  Update i x l l' -> Update (S i) x (y::l) (y::l').
Proof.
  introv (L&O&E). splits.
  rew_length~.
  introv M H. inverts* M.
  autos*.
Qed.

Lemma Update_app_l : forall i x l1 l1' l2,
  Update i x l1 l1' -> Update i x (l1++l2) (l1'++l2).
Proof.
  introv (L&O&E). splits.
  rew_length~.
  introv M H. destruct (Nth_app_inv _ _ M).
    apply~ Nth_app_l.
    unpack. apply* Nth_app_r. math.
  apply~ Nth_app_l.
Qed.

Lemma Update_app_r : forall i j x l1 l2 l2',
  Update j x l2 l2' -> i = (j + length l1)%nat -> Update i x (l1++l2) (l1++l2').
Proof.
  introv (L&O&E) Eq. splits.
  rew_length~.
  introv M H. destruct (Nth_app_inv _ _ M).
    apply~ Nth_app_l.
    unpack. apply* Nth_app_r. apply* O. math. math.
  apply* Nth_app_r.
Qed.

Lemma Update_length : forall i x l l',
  Update i x l l' -> length l = length l'.
Proof. introv (L&O&E). auto. Qed.

Lemma Update_not_nil : forall i x l1 l2,
  Update i x l1 l2 -> l2 <> nil.
Proof. introv (L&O&E) K. subst. inverts E. Qed.

End UpdateProp.

(* ---------------------------------------------------------------------- *)
(* ** Equality modulo equivalence relation *)

(** [list_equiv E l1 l2] asserts that the lists [l1] and [l2]
    are equal when their elements are compared modulo E *)

Definition list_equiv (A:Type) (E:binary A) : binary (list A) :=
   Forall2 E.

Section ListEquiv.
Hint Constructors Forall2.

Lemma list_equiv_equiv : forall A (E:binary A),
  equiv E -> equiv (list_equiv E).
Proof.
  introv Equiv. unfold list_equiv. constructor.
  unfolds. induction x. auto. constructor; dauto.
  unfolds. induction x; destruct y; introv H; inversions H; dauto.
  unfolds. induction y; destruct x; destruct z; introv H1 H2;
   inversions H1; inversions H2; dauto.
Qed.

End ListEquiv.


Require Import Coq.Program.Program.
Require Import Coq.Program.Tactics.
Require Import Coquelicot.Coquelicot.
Set Bullet Behavior "Strict Subproofs".
Require Import Coq.omega.Omega.
Require Import Coq.fourier.Fourier.

Ltac solve_inversion :=
  match goal with
  | [ H : _ |- _ ] => solve [inversion H]
  end.

Local Hint Extern 9 => solve_inversion.

Local Hint Extern 9 => contradiction.

Scheme le_dep_ind := Induction for le Sort Prop.

Lemma le_pf_unique : forall (n m : nat) (H1 H2 : (n <= m)%nat),
    H1 = H2.
Proof.
  intros.
  induction H1 using le_dep_ind.
  - dependent destruction H2; auto.
    destruct (Nat.nle_succ_diag_l _ H2).
  - dependent destruction H2; auto.
    + destruct (Nat.nle_succ_diag_l _ H1).
    + erewrite IHle.
      f_equal.
Qed.

Lemma lt_pf_unique : forall (n m : nat) (H1 H2 : (n < m)%nat),
    H1 = H2.
Proof.
  intros.
  induction H1 using le_dep_ind.
  - dependent destruction H2; auto.
    destruct (Nat.nle_succ_diag_l _ H2).
  - dependent destruction H2; auto.
    + destruct (Nat.nle_succ_diag_l _ H1).
    + erewrite IHle.
      f_equal.
Qed.

Lemma Rbar_mult_le_compat_l : forall r r1 r2 : Rbar,
    Rbar_le (Finite 0) r ->
    Rbar_le r1 r2 ->
    Rbar_le (Rbar_mult r r1) (Rbar_mult r r2).
Proof.
  intros r r1 r2 H H0.
  destruct r; cbn in H;
    auto.
  - destruct r1, r2;
      cbn in *;
      auto;
      unfold Rbar_mult, Rbar_mult';
      try apply Rmult_le_compat_l;
      try fourier;
      refine (match H with
              | or_introl H1 => _
              | or_intror H1 => _
              end);
      destruct (Rle_dec 0 r);
      try match goal with
      | [ |- context[Rle_lt_or_eq_dec 0 ?r ?r1]] =>
        destruct (Rle_lt_or_eq_dec 0 r r1)
      end;
      subst;
      cbn;
      try fourier;
      auto.
  - destruct r1, r2;
      cbn;
      unfold Rbar_mult, Rbar_mult';
      repeat destruct Rle_dec;
      repeat destruct Rle_lt_or_eq_dec;
      subst;
      auto.
    + cbn in H0.
      fourier.
    + cbn in H0.
      exfalso.
      assert (0 <= r0) by fourier.
      apply n in H1.
      auto.
Qed.

Hint Extern 1 (_ = _)%nat => abstract omega.
Hint Extern 1 (_ <= _)%nat => abstract omega.
Hint Extern 1 (_ >= _)%nat => abstract omega.
Hint Extern 1 (_ < _)%nat => abstract omega.
Hint Extern 1 (_ > _)%nat => abstract omega.
Hint Extern 1 (_ <= _)%R => abstract fourier.
Hint Extern 1 (_ >= _)%R => abstract fourier.
Hint Extern 1 (_ < _)%R => abstract fourier.
Hint Extern 1 (_ > _)%R => abstract fourier.
Hint Extern 1 False => abstract omega.
Hint Extern 1 False => abstract fourier.
Hint Resolve Sup_seq_ext.


From mathcomp Require Import all_ssreflect all_fingroup all_algebra.
From mathcomp Require Import all_solvable all_field.
From Abel Require Import various cyclotomic_ext.

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

Import GRing.Theory.

Local Open Scope ring_scope.

Local Notation "p ^^ f" := (map_poly f p)
  (at level 30, f at level 30, format "p  ^^  f").

Lemma classic_fieldExtFor
  (F0 : fieldType) (L : fieldExtType F0) (p : {poly L}) : p != 0 ->
  classically
  { L' : fieldExtType F0 & { rs : seq L' & { iota : 'AHom(L, L') |
  <<iota @: fullv & rs>>%VS = fullv &
  p ^^ iota %= \prod_(r <- rs) ('X - r%:P) }}}.
Proof.
have [n] := ubnP (size p); elim: n => [|n IHn]// in F0 L p *.
rewrite ltnS => sp_lt p_neq0.
apply: classic_bind (@classic_EM (irreducible_poly p)) => -[]; last first.
  have [|p_gt1] := leqP (size p) 1.
    rewrite leq_eqVlt ltnS leqn0 size_poly_eq0 (negPf p_neq0) orbF.
    move=> /size_poly1P[c cN0 ->] _.
    apply/classicW; exists L, [::], (id_ahom _).
      by rewrite Fadjoin_nil/= lim1g.
    by rewrite big_nil map_polyC/= lfunE/= polyC_eqp1.
  move=> NNred_p; have: classically (exists q : {poly L},
      [/\ size q != 1%N, (size q < size p)%N & q %| p]).
    apply/classicP => Nexq; apply: NNred_p.
    split => // q sq_neq1 dvdqp; apply: contraTT isT => eq_qp.
    case: Nexq; exists q; split => //.
    by rewrite ltn_neqAle dvdp_size_eqp// eq_qp/= dvdp_leq.
  apply: classic_bind => -[q [qN1 sq qp]].
  have qN0 : q != 0 by apply: contraTneq qp => ->; rewrite dvd0p.
  have sqn : (size q < n)%N by rewrite (leq_trans sq).
  apply: classic_bind (IHn _ _ _ sqn qN0) => -[L1 [rs1 [iota1 rs1_full qE]]].
  have /dvdpP [r pE]:= qp.
  have rN0 : r != 0 by apply: contra_eq_neq pE => ->; rewrite mul0r.
  have r1N0 : r ^^ iota1 != 0 by rewrite map_poly_eq0.
  have srn : (size (r ^^ iota1) < n)%N.
    rewrite size_map_poly.
    have /(congr1 (fun p : {poly _} => size p)) := pE.
    rewrite size_mul// [size q]polySpred// addnS/=.
    move=> /(canLR (@addnK _))<-; rewrite (leq_trans _ sp_lt)//.
    rewrite ltn_subrL size_poly_gt0 p_neq0 andbT.
    by rewrite ltn_predRL// ltn_neqAle eq_sym qN1 ?size_poly_gt0/=.
  apply: classic_bind (IHn _ _ _ srn r1N0) => -[L2 [rs2 [iota2 rs2_full rE]]].
  apply/classicW; exists L2, (map iota2 rs1 ++ rs2), (iota2 \o iota1)%AF.
    by rewrite adjoin_cat limg_comp -aimg_adjoin_seq rs1_full rs2_full.
  rewrite big_cat/= big_map (eq_map_poly (comp_lfunE _ _)) map_poly_comp pE.
  rewrite !rmorphM/= mulrC (eqp_trans (eqp_mull _ rE))// eqp_mulr//.
  have := qE; rewrite -(eqp_map [rmorphism of iota2]) => /eqp_trans->//=.
  rewrite (big_morph _ (rmorphM _) (rmorph1 _))/=.
  under eq_bigr do rewrite rmorphB/= -/iota map_polyX map_polyC/=.
  by rewrite eqpxx.
move=> /irredp_FAdjoin[L1 df [r1 r1_root r1_full]].
pose L01 := [fieldExtType F0 of baseFieldType L1].
pose r01 : L01 := r1.
pose inL01 : L -> L01 := in_alg L1.
have iota_morph : lrmorphism inL01.
split; [split; [exact: rmorphB|split; [exact: rmorphM|]]|].
  by rewrite /inL01 rmorph1.
  by move=> k a; rewrite /inL01 -mulr_algl rmorphM/= mulr_algl.
pose iota1 : 'AHom(L, L01) := AHom (linfun_is_ahom (LRMorphism iota_morph)).
have inL01E : inL01 =1 iota1 by move=> x; rewrite lfunE.
have r01_root : root (p ^^ iota1) r01 by rewrite -(eq_map_poly inL01E).
have r01_full : <<limg iota1; r01>>%VS = fullv.
  apply/eqP; rewrite eqEsubv subvf/=; apply/subvP => v _.
  have : (v : L1) \in <<1; r1>>%VS by rewrite r1_full memvf.
  move/Fadjoin_polyP => [pr pr1 ->].
  suff [qr ->] : exists2 qr, pr = qr & qr \is a polyOver (limg iota1).
    exact: mempx_Fadjoin.
  have /polyOver1P[qr ->] := pr1; exists (map_poly iota1 qr).
    by apply/eq_map_poly => w; rewrite lfunE.
  by apply/polyOverP => i; rewrite coef_map/= memv_img ?memvf.
have /dvdpP[q pE] : ('X - r01%:P) %| (p ^^ iota1) by rewrite dvdp_XsubCl.
have qN0 : q != 0.
  by apply: contra_eq_neq pE => ->; rewrite mul0r map_poly_eq0//.
have sq : (size q < n)%N.
  have /(congr1 (fun p : {poly _} => size p)) := pE.
  rewrite size_map_poly size_mul ?polyXsubC_eq0//.
  by rewrite size_XsubC addn2//= => <-.
apply: classic_bind (IHn _ _ _ sq qN0) => -[L2 [rs2 [iota12 rs2_full qE]]].
apply/classicW.
exists L2, (iota12 r01 :: rs2), (iota12 \o iota1)%AF.
  by rewrite adjoin_cons limg_comp -aimg_adjoin r01_full rs2_full.
rewrite big_cons/= (eq_map_poly (comp_lfunE _ _)) map_poly_comp pE.
by rewrite rmorphM/= mulrC rmorphB/= map_polyX map_polyC/= eqp_mull.
Qed.

Lemma classic_cycloExt (F0 : fieldType) (L : fieldExtType F0) n :
  (n%:R != 0 :> F0) -> classically
  { L' : fieldExtType F0 & { w : L' & { iota : 'AHom(L, L') |
    <<iota @: fullv; w>>%VS = fullv & n.-primitive_root w }}}.
Proof.
case: n => [|[_|[two_neq0|n']]]//; first by rewrite eqxx.
- apply/classicW; exists L, 1, (id_ahom _); rewrite ?prim_root1//.
  by rewrite lim1g (Fadjoin_idP _)// rpred1.
- apply/classicW; exists L, (- 1), (id_ahom _) => /=.
    by rewrite lim1g (Fadjoin_idP _)// rpredN1.
  by rewrite prim2_rootN1// -(rmorph_nat [rmorphism of in_alg L]) fmorph_eq0.
set n := n'.+3 => nF0neq0.
have poly_XnsubC_neq0 : 'X^n - 1 != 0 :> {poly L}.
  by rewrite -size_poly_eq0 size_XnsubC.
apply: classic_bind (classic_fieldExtFor (poly_XnsubC_neq0)).
case=> [L' [rs [iota rs_full]]].
rewrite rmorphB rmorph1/= map_polyXn.
rewrite eqp_monic ?monic_XnsubC ?monic_prod_XsubC// => /eqP Xnsub1E.
have rs_uniq : uniq rs.
  rewrite -separable_prod_XsubC -Xnsub1E separable_Xn_sub_1//.
  have: in_alg L' n%:R != 0 by rewrite fmorph_eq0.
  by rewrite raddfMn/= -(@in_algE _ L') rmorph1.
have rs_ge : (n <= size rs)%N.
  have /(congr1 (fun p : {poly _} => size p)) := Xnsub1E.
  rewrite size_XnsubC// size_prod_seq; last first.
    by move=> i _; rewrite polyXsubC_eq0.
  under eq_bigr do rewrite size_XsubC.
  rewrite big_tnth sum_nat_const card_ord subSn ?leq_pmulr//.
  by rewrite muln2 -addnn addnK => -[->].
have rsUroots : all n.-unity_root rs.
  apply/allP => r rrs; apply/eqP; rewrite Xnsub1E.
  by rewrite (big_rem _ rrs)/= hornerM hornerXsubC subrr mul0r.
have /has_prim_root/(_ _ _)/hasP[]// := rsUroots.
move=> w wrs wprim; apply/classicW; exists L', w, iota => //.
symmetry; rewrite -rs_full; have /eq_adjoin-> : rs =i w :: rs.
  by move=> r'; rewrite in_cons; case: eqVneq => // -> /=.
set K := limg iota => {wrs rs_uniq Xnsub1E rs_full rs_ge}.
elim: rs rsUroots => [|r' rs IHrs /andP[r'Uroots rsUroots]].
  by rewrite adjoin_seq1.
have r'K : r' \in <<K; w>>%VS.
  have /unity_rootP/(prim_rootP wprim)[i ->] := r'Uroots.
  by rewrite rpredX// memv_adjoin.
by rewrite !adjoin_cons (Fadjoin_idP r'K) -adjoin_cons IHrs.
Qed.

Lemma SplittingFieldExt
  (F0 : fieldType) (L : splittingFieldType F0) (p : {poly F0})
  (M : fieldExtType F0) (iota : 'AHom(L, M)) :
  splittingFieldFor (iota @: fullv) (p ^^ in_alg M) fullv ->
  SplittingField.axiom M.
Proof.
case=> rs pE rsf; have [_/polyOver1P[q ->] [rsq qE rsqf]] := splittingPoly L.
exists ((p * q) ^^ in_alg M); first by apply/polyOver1P; exists (p * q).
exists (map iota rsq ++ rs); last first.
  by rewrite adjoin_cat -(aimg1 iota) -aimg_adjoin_seq rsqf rsf.
rewrite big_cat/= rmorphM/= big_map mulrC.
rewrite (eqp_trans (eqp_mull _ pE))// eqp_mulr//.
have := qE; rewrite -(eqp_map [rmorphism of iota])/=.
rewrite (big_morph _ (rmorphM _) (rmorph1 _))/=.
under eq_bigr do rewrite rmorphB/= map_polyX map_polyC/=.
by rewrite -map_poly_comp (eq_map_poly (rmorph_alg _)).
Qed.

Lemma classic_cycloSplitting (F0 : fieldType) (L : splittingFieldType F0) n :
  (n%:R != 0 :> F0) -> classically
  { L' : splittingFieldType F0 & { w : L' & { iota : 'AHom(L, L') |
    <<iota @: fullv; w>>%VS = fullv & n.-primitive_root w }}}.
Proof.
move=> /(@classic_cycloExt _ L).
apply/classic_bind => -[M [w [iota wfull wprim]]]; apply/classicW.
suff splitM : SplittingField.axiom M.
  by exists (SplittingFieldType F0 M splitM), w, iota.
apply: (@SplittingFieldExt _ L ('Phi_n ^^ intr) _ iota).
rewrite -map_poly_comp (eq_map_poly (rmorph_int _)) -wfull.
by rewrite (Phi_cyclotomic wprim); apply: splitting_Fadjoin_cyclotomic.
Qed.

Lemma classic_baseCycloExt (F : fieldType) (n : nat) :
  (n%:R != 0 :> F) -> classically
   { L' : splittingFieldType F & { w : L' &
    <<1; w>>%VS = fullv & n.-primitive_root w }}.
Proof.
move=> nN0; suff: classically { L' : fieldExtType F & { w : L' &
    <<1; w>>%VS = fullv & n.-primitive_root w }}.
  apply/classic_bind => -[L [w wfull wprim]]; apply/classicW.
  have splitL : SplittingField.axiom L.
    exists (cyclotomic w n); rewrite ?cyclotomic_over// -wfull.
    exact: splitting_Fadjoin_cyclotomic.
  by exists (SplittingFieldType F L splitL), w.
pose Fo := [splittingFieldType F of F^o].
apply: classic_bind (@classic_cycloExt _ Fo n nN0).
case=> [L [w [iota wfull wprim]]]; apply/classicW.
exists L, w => //; apply/eqP; rewrite eqEsubv subvf/= -wfull.
apply/subvP => x /Fadjoin_polyP[/= p pover ->].
apply/mempx_Fadjoin/polyOverP => i /=.
have /memv_imgP[u _ ->] := polyOverP pover i.
by rewrite -(aimg1 iota) memv_img// -regular_fullv memvf.
Qed.


Require Export XR_Rle.
Require Export XR_Rsqr.
Require Export XR_Rtotal_order.
Require Export XR_Ropp_involutive.
Require Export XR_Ropp_mult_distr_r.
Require Export XR_Rmult_lt_0_compat.
Require Export XR_Ropp_0.
Require Export XR_Ropp_lt_contravar.

Local Open Scope R_scope.

Lemma Rle_0_sqr : forall r, R0 <= Rsqr r.
Proof.
  intros x.
  unfold Rsqr.
  destruct (Rtotal_order x R0) as [ hx | [ heq | hx ] ].
  {
    rewrite <- Ropp_involutive with (x*x).
    rewrite Ropp_mult_distr_l.
    rewrite Ropp_mult_distr_r.
    unfold "<=".
    left.
    apply Rmult_lt_0_compat.
    {
      rewrite <- Ropp_0.
      apply Ropp_lt_contravar.
      exact hx.
    }
    {
      rewrite <- Ropp_0.
      apply Ropp_lt_contravar.
      exact hx.
    }
  }
  {
    subst x.
    rewrite Rmult_0_l.
    unfold "<=".
    right.
    reflexivity.
  }
  {
    unfold "<=".
    left.
    apply Rmult_lt_0_compat.
    { exact hx. }
    { exact hx. }
  }
Qed.


Set Implicit Arguments.

Require Import kat normalisation rewriting kat_tac.
Require Import rel comparisons netcore.
Require Import Packet.

  Section Eg.
    Import KatNotation.
    Local Open Scope kat_scope.

  Definition topo := sw=?S 0; pt=?2; sw^:=2; pt~:=S 0 +
                     sw=?2; pt~:=S 0; sw^:=S 0; pt~:=2.
  Definition fwd := pt=?S 0; pt~:=2 + pt=?2; pt~:=S 0.
  Definition pol1 :=
    sw=?S 0;(pt=?S 0; pt~:=2 + pt=?2; pt~:=S 0) +
    sw=?2;((~src=?10); pt=?S 0; pt~:=2 + pt=?2; pt~:=S 0).

  Lemma trivial_kat : forall  b, po_id + b;b^* ~ b^*.
  Proof.
    intros.
    kat_simpl.
    kat.
  Qed.

  Definition foo :=     sw=?S 0; pt=?S 0; src=?10; (pol1; topo)^* ; sw=?2;pt=?2 ~ po_drop.

  End Eg.

  Import Notation.
  Local Open Scope netcore_scope.

  Lemma comm_tests :
    forall (e : rel trace trace) h1 h2 v1 v2,
      [h1 =? v1]; [h2 =? v2] == [h2 =? v2]; [h1 =? v1].
  Proof. intros. kat. Qed.

  Lemma test_order_sw_src :
    forall (e : rel trace trace) m n,
      e; [src =? m]; [sw =? n] == e; [sw =? n]; [src =? m].
  Proof. intros. kat. Qed.

  Lemma test_order_sw_pt :
    forall (e : rel trace trace) m n,
      e; [pt =? m]; [sw =? n] == e; [sw =? n]; [pt =? m].
  Proof. intros. kat. Qed.

  Lemma test_order_pt_src :
    forall (e : rel trace trace) m n,
      e; [src =? m]; [pt =? n] == e; [pt =? n]; [src =? m].
  Proof. intros. kat. Qed.

  Lemma trace_assoc :
    forall (e1 e2 e3 : rel trace trace),
      e1; e2; e3 == e1; (e2; e3).
  Proof. kat. Qed.

  Lemma line_test_test_zero :
    forall (e : rel trace trace) h m n,
      m <> n ->
      e; [h =? m]; [h =? n] == 0.
  Proof.
    intros.
    rewrite -> trace_assoc.
    rewrite -> test_test_zero; auto.
    kat.
  Qed.

  Lemma line_upd_test_zero :
    forall (e : rel trace trace) h m n,
      m <> n ->
      e; h ~:= m; [h =? n] == 0.
  Proof with auto.
    intros.
    rewrite -> trace_assoc. rewrite -> upd_test_zero...
    kat.
  Qed.

  Lemma line_test_compress :
    forall (e : rel trace trace) h n,
      e; [h =? n]; [h =? n] == e; [h =? n].
  Proof.
    kat.
  Qed.

  Hint Rewrite
       test_order_sw_pt
       test_order_sw_src
       test_order_pt_src
       line_test_compress
  : netcore.

  Lemma firewall_ok1 : foo.
  Proof with auto.
    intros.
    unfold foo.
    unfold pol1.
    unfold topo.
    kat_simpl.
    ra_normalise.
    rewrite -> str_unfold_l.
    ra_normalise.
    autorewrite with netcore using idtac.
    rewrite -> test_test_zero.
    ra_normalise.
    rewrite -> (@line_test_test_zero _ pt (S O) 2).
    ra_normalise.
    rewrite -> (@line_upd_test_zero _ pt (S O) 2).
    ra_normalise.
  Admitted.


Require Import HoTT.Basics HoTT.Types.Bool HoTT.Types.Paths.
Require Import Colimits.Diagram Colimits.Colimit.

(* Section PO. *)
  (* Context {A B C} (f : A -> B) (g : A -> C). *)

  (* Definition span X := exists (l : B -> X) (r : C -> X), l o f == r o g. *)

  (* Definition is_PO X (s : span X) : Type. *)
  (* Admitted. *)

Section PO.
  Definition PO_graph : graph.
    simple refine (Build_graph _ _).
    - exact (Unit + Bool).
    - intros [i|i] [j|j]. exact Empty. exact Unit. exact Empty. exact Empty.
  Defined.

  Context {A B C} (f : A -> B) (g : A -> C).

  Definition span : diagram PO_graph.
    simple refine (Build_diagram _ _ _).
    - intros [i|i]. exact A. exact (if i then B else C).
    - intros [i|i] [j|j] u; cbn; try contradiction.
      destruct j. exact f. exact g.
  Defined.

  Definition PO := colimit span.

  Definition pol : B -> PO.
    intro. simple refine (colim _ _); cbn. exact (inr true). exact X.
  Defined.
  Definition por : C -> PO.
    intro. simple refine (colim _ _); cbn. exact (inr false). exact X.
  Defined.

  Definition is_PO := is_colimit span.
End PO.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.monads MathClasses.theory.jections MathClasses.theory.monads.

Inductive option_equiv A `{Equiv A} : Equiv (option A) :=
  | option_equiv_Some : Proper ((=) ==> (=)) Some
  | option_equiv_None : None = None.

#[global]
Existing Instance option_equiv.
#[global]
Hint Constructors option_equiv.

Section contents.
  Context `{Setoid A}.

  Lemma Some_ne_None x : Some x ≠ None.
  Proof. intros E. inversion E. Qed.

  Lemma None_ne_Some x : None ≠ Some x.
  Proof. intros E. inversion E. Qed.

  Global Instance: Setoid (option A).
  Proof.
    split.
      intros [x|]. now apply option_equiv_Some. now apply option_equiv_None.
     red. induction 1. now apply option_equiv_Some. now apply option_equiv_None.
    intros x y z E. revert z. induction E.
     intros z E2. inversion_clear E2.
     apply option_equiv_Some. etransitivity; eassumption.
    easy.
  Qed.

  Global Instance: Setoid_Morphism Some.
  Proof. split; try apply _. now apply option_equiv_Some. Qed.

  Global Instance: Injective Some.
  Proof. split; try apply _. intros ? ? E. now inversion E. Qed.

  Global Instance option_zero: MonUnit (option A) := None.

  Global Instance option_op: SgOp (option A) := λ mx my,
    match mx with
    | Some x => Some x
    | None => my
    end.

  Instance: Proper ((=) ==> (=) ==> (=)) option_op.
  Proof. intros [?|] [?|] ? ???; simpl; try setoid_discriminate; auto. Qed.

  Global Instance: Monoid (option A).
  Proof. repeat (split; try apply _); now repeat intros [?|]. Qed.

  Lemma option_equiv_alt x y :
    x = y ↔ (∀ n, x = Some n ↔ y = Some n).
  Proof.
    split; intros E1.
     intro. now rewrite E1.
    destruct x, y.
       now apply E1.
      symmetry. now apply E1.
     now apply E1.
    easy.
  Qed.

  Global Program Instance option_dec `(A_dec : ∀ x y : A, Decision (x = y))
     : ∀ x y : option A, Decision (x = y) := λ x y,
    match x with
    | Some r =>
      match y with
      | Some s => match A_dec r s with left _ => left _ | right _ => right _ end
      | None => right _
      end
    | None =>
      match y with
      | Some s => right _
      | None => left _
      end
    end.
  Next Obligation. now apply (injective_ne Some). Qed.
  Next Obligation. setoid_discriminate. Qed.
  Next Obligation. setoid_discriminate. Qed.
End contents.

#[global]
Hint Extern 10 (Equiv (option _)) => apply @option_equiv : typeclass_instances.

Lemma option_equiv_eq {A} (x y : option A) :
  @option_equiv A (≡) x y ↔ x ≡ y.
Proof.
  split.
   induction 1. now f_equal. reflexivity.
  intros. subst.
  now assert (@Setoid A (@eq A)) by (split; apply _).
Qed.

#[global]
Instance option_ret: MonadReturn option := λ A x, Some x.
#[global]
Instance option_bind: MonadBind option := λ A B f x,
  match x with
  | Some a => f a
  | None => None
  end.

#[global]
Instance option_ret_proper `{Equiv A} : Proper ((=) ==> (=)) (option_ret A).
Proof. intros x y E. now apply option_equiv_Some. Qed.

#[global]
Instance option_bind_proper `{Setoid A} `{Setoid (option B)}: Proper (=) (option_bind A B).
Proof.
  intros f₁ f₂ E1 x₁ x₂ [?|].
   unfold option_bind. simpl. now apply E1.
  easy.
Qed.

#[global]
Instance: Monad option.
Proof.
  repeat (split; try apply _); unfold bind, ret, option_bind, option_ret, compose.
    intros. now apply setoids.ext_equiv_refl.
   now intros ? ? ? [?|].
  intros A ? B ? C ? ? f [???] g [???] [x|] [y|] E; try solve [inversion_clear E].
   setoid_inject. cut (g x = g y); [|now rewrite E].
   case (g x), (g y); intros E2; inversion_clear E2. now f_equiv. easy.
  easy.
Qed.

#[global]
Instance option_map: SFmap option := option_map.

#[global]
Instance: FullMonad option.
Proof. apply @monad_default_full_monad. apply _. Qed.

Section map.
  Context `{Setoid A} `{Setoid B} `{!Injective (f : A → B)}.

  Global Instance: Injective (sfmap f).
  Proof.
    pose proof (injective_mor f).
    repeat (split; try apply _).
    intros [x|] [y|] E; try solve [inversion E | easy].
    apply sm_proper. apply (injective f). now apply (injective Some).
  Qed.
End map.


Section compose.
  Variable T : Type.
  Variable R1 R2 : T -> T -> Prop.

  Definition compose (x z : T) : Prop :=
    exists y, R1 x y /\ R2 y z.
End compose.