Require Import Arith.
Require Import Ensembles.
Require Import Coq.Lists.List.

Require Export Languages.
Require Import folProof.
Require Import folProp.
Require Import folLogic3.

Definition Formula := Formula LNN.
Definition Formulas := Formulas LNN.
Definition System := System LNN.
Definition Sentence := Sentence LNN.
Definition Term := Term LNN.
Definition Terms := Terms LNN.
Definition var := var LNN.
Definition equal := equal LNN.
Definition impH := impH LNN.
Definition notH := notH LNN.
Definition iffH := iffH LNN.
Definition forallH := forallH LNN.
Definition orH := orH LNN.
Definition andH := andH LNN.
Definition existH := existH LNN.
Definition ifThenElseH := ifThenElseH LNN.
Definition SysPrf := SysPrf LNN.

Definition Plus (x y : Term) : Term :=
  apply LNN Plus (Tcons LNN 1 x (Tcons LNN 0 y (Tnil LNN))).

Definition Times (x y : Term) : Term :=
  apply LNN Times (Tcons LNN 1 x (Tcons LNN 0 y (Tnil LNN))).

Definition Succ (x : Term) : Term :=
  apply LNN Succ (Tcons LNN 0 x (Tnil LNN)).

Definition Zero : Term := apply LNN Zero (Tnil LNN).

Definition LT (x y : Term) : Formula :=
  atomic LNN LT (Tcons LNN 1 x (Tcons LNN 0 y (Tnil LNN))).

Lemma LNN_dec : language_decideable LNN.
Proof.
unfold language_decideable in |- *.
split; decide equality.
Qed.

Section Free_Variables.

Lemma freeVarPlus :
 forall x y : Term,
 freeVarTerm LNN (Plus x y) = freeVarTerm LNN x ++ freeVarTerm LNN y.
Proof.
intros.
rewrite (app_nil_end (freeVarTerm LNN y)).
reflexivity.
Qed.

Lemma freeVarTimes :
 forall x y : Term,
 freeVarTerm LNN (Times x y) = freeVarTerm LNN x ++ freeVarTerm LNN y.
Proof.
intros.
rewrite (app_nil_end (freeVarTerm LNN y)).
reflexivity.
Qed.

Lemma freeVarSucc :
 forall x : Term, freeVarTerm LNN (Succ x) = freeVarTerm LNN x.
Proof.
intros.
rewrite (app_nil_end (freeVarTerm LNN x)).
reflexivity.
Qed.

Lemma freeVarZero : freeVarTerm LNN Zero = nil.
Proof.
reflexivity.
Qed.

Lemma freeVarLT :
 forall x y : Term,
 freeVarFormula LNN (LT x y) = freeVarTerm LNN x ++ freeVarTerm LNN y.
Proof.
intros.
rewrite (app_nil_end (freeVarTerm LNN y)).
reflexivity.
Qed.

End Free_Variables.

Section Logic.

Lemma Axm :
 forall (T : System) (f : Formula), mem _ T f -> SysPrf T f.
Proof.
apply (Axm LNN).
Qed.

Lemma sysExtend :
 forall (T U : System) (f : Formula),
 Included _ T U -> SysPrf T f -> SysPrf U f.
Proof.
apply (sysExtend LNN).
Qed.

Lemma sysWeaken :
 forall (T : System) (f g : Formula), SysPrf T f -> SysPrf (Ensembles.Add _ T g) f.
Proof.
apply (sysWeaken LNN).
Qed.

Lemma impI :
 forall (T : System) (f g : Formula),
 SysPrf (Ensembles.Add _ T g) f -> SysPrf T (impH g f).
Proof.
apply (impI LNN).
Qed.

Lemma impE :
 forall (T : System) (f g : Formula),
 SysPrf T (impH g f) -> SysPrf T g -> SysPrf T f.
Proof.
apply (impE LNN).
Qed.

Lemma contradiction :
 forall (T : System) (f g : Formula),
 SysPrf T f -> SysPrf T (notH f) -> SysPrf T g.
Proof.
apply (contradiction LNN).
Qed.

Lemma nnE :
 forall (T : System) (f : Formula), SysPrf T (notH (notH f)) -> SysPrf T f.
Proof.
apply (nnE LNN).
Qed.

Lemma noMiddle : forall (T : System) (f : Formula), SysPrf T (orH (notH f) f).
Proof.
apply (noMiddle LNN).
Qed.

Lemma nnI :
 forall (T : System) (f : Formula), SysPrf T f -> SysPrf T (notH (notH f)).
Proof.
apply (nnI LNN).
Qed.

Lemma cp1 :
 forall (T : System) (f g : Formula),
 SysPrf T (impH (notH f) (notH g)) -> SysPrf T (impH g f).
Proof.
apply (cp1 LNN).
Qed.

Lemma cp2 :
 forall (T : System) (f g : Formula),
 SysPrf T (impH g f) -> SysPrf T (impH (notH f) (notH g)).
Proof.
apply (cp2 LNN).
Qed.

Lemma orI1 :
 forall (T : System) (f g : Formula), SysPrf T f -> SysPrf T (orH f g).
Proof.
apply (orI1 LNN).
Qed.

Lemma orI2 :
 forall (T : System) (f g : Formula), SysPrf T g -> SysPrf T (orH f g).
Proof.
apply (orI2 LNN).
Qed.

Lemma orE :
 forall (T : System) (f g h : Formula),
 SysPrf T (orH f g) ->
 SysPrf T (impH f h) -> SysPrf T (impH g h) -> SysPrf T h.
Proof.
apply (orE LNN).
Qed.

Lemma orSys :
 forall (T : System) (f g h : Formula),
 SysPrf (Ensembles.Add _ T f) h -> SysPrf (Ensembles.Add _ T g) h -> SysPrf (Ensembles.Add _ T (orH f g)) h.
Proof.
apply (orSys LNN).
Qed.

Lemma andI :
 forall (T : System) (f g : Formula),
 SysPrf T f -> SysPrf T g -> SysPrf T (andH f g).
Proof.
apply (andI LNN).
Qed.

Lemma andE1 :
 forall (T : System) (f g : Formula), SysPrf T (andH f g) -> SysPrf T f.
Proof.
apply (andE1 LNN).
Qed.

Lemma andE2 :
 forall (T : System) (f g : Formula), SysPrf T (andH f g) -> SysPrf T g.
Proof.
apply (andE2 LNN).
Qed.

Lemma iffI :
 forall (T : System) (f g : Formula),
 SysPrf T (impH f g) -> SysPrf T (impH g f) -> SysPrf T (iffH f g).
Proof.
apply (iffI LNN).
Qed.

Lemma iffE1 :
 forall (T : System) (f g : Formula),
 SysPrf T (iffH f g) -> SysPrf T (impH f g).
Proof.
apply (iffE1 LNN).
Qed.

Lemma iffE2 :
 forall (T : System) (f g : Formula),
 SysPrf T (iffH f g) -> SysPrf T (impH g f).
Proof.
apply (iffE2 LNN).
Qed.

Lemma forallI :
 forall (T : System) (f : Formula) (v : nat),
 ~ In_freeVarSys LNN v T -> SysPrf T f -> SysPrf T (forallH v f).
Proof.
apply (forallI LNN).
Qed.

Lemma forallE :
 forall (T : System) (f : Formula) (v : nat) (t : Term),
 SysPrf T (forallH v f) -> SysPrf T (substituteFormula LNN f v t).
Proof.
apply (forallE LNN).
Qed.

Lemma forallSimp :
 forall (T : System) (f : Formula) (v : nat),
 SysPrf T (forallH v f) -> SysPrf T f.
Proof.
apply (forallSimp LNN).
Qed.

Lemma existI :
 forall (T : System) (f : Formula) (v : nat) (t : Term),
 SysPrf T (substituteFormula LNN f v t) -> SysPrf T (existH v f).
Proof.
apply (existI LNN).
Qed.

Lemma existE :
 forall (T : System) (f g : Formula) (v : nat),
 ~ In_freeVarSys LNN v T ->
 ~ In v (freeVarFormula LNN g) ->
 SysPrf T (existH v f) -> SysPrf T (impH f g) -> SysPrf T g.
Proof.
apply (existE LNN).
Qed.

Lemma existSimp :
 forall (T : System) (f : Formula) (v : nat),
 SysPrf T f -> SysPrf T (existH v f).
Proof.
apply (existSimp LNN).
Qed.

Lemma existSys :
 forall (T : System) (f g : Formula) (v : nat),
 ~ In_freeVarSys LNN v T ->
 ~ In v (freeVarFormula LNN g) ->
 SysPrf (Ensembles.Add _ T f) g -> SysPrf (Ensembles.Add _ T (existH v f)) g.
Proof.
apply (existSys LNN).
Qed.

Lemma absurd1 :
 forall (T : System) (f : Formula),
 SysPrf T (impH f (notH f)) -> SysPrf T (notH f).
Proof.
apply (absurd1 LNN).
Qed.

Lemma nImp :
 forall (T : System) (f g : Formula),
 SysPrf T (andH f (notH g)) -> SysPrf T (notH (impH f g)).
Proof.
apply (nImp LNN).
Qed.

Lemma nOr :
 forall (T : System) (f g : Formula),
 SysPrf T (andH (notH f) (notH g)) -> SysPrf T (notH (orH f g)).
Proof.
apply (nOr LNN).
Qed.

Lemma nAnd :
 forall (T : System) (f g : Formula),
 SysPrf T (orH (notH f) (notH g)) -> SysPrf T (notH (andH f g)).
Proof.
apply (nAnd LNN).
Qed.

Lemma nForall :
 forall (T : System) (f : Formula) (v : nat),
 SysPrf T (existH v (notH f)) -> SysPrf T (notH (forallH v f)).
Proof.
apply (nForall LNN).
Qed.

Lemma nExist :
 forall (T : System) (f : Formula) (v : nat),
 SysPrf T (forallH v (notH f)) -> SysPrf T (notH (existH v f)).
Proof.
apply (nExist LNN).
Qed.

Lemma impRefl : forall (T : System) (f : Formula), SysPrf T (impH f f).
Proof.
apply (impRefl LNN).
Qed.

Lemma impTrans :
 forall (T : System) (f g h : Formula),
 SysPrf T (impH f g) -> SysPrf T (impH g h) -> SysPrf T (impH f h).
Proof.
apply (impTrans LNN).
Qed.

Lemma orSym :
 forall (T : System) (f g : Formula),
 SysPrf T (orH f g) -> SysPrf T (orH g f).
Proof.
apply (orSym LNN).
Qed.

Lemma andSym :
 forall (T : System) (f g : Formula),
 SysPrf T (andH f g) -> SysPrf T (andH g f).
Proof.
apply (andSym LNN).
Qed.

Lemma iffRefl : forall (T : System) (f : Formula), SysPrf T (iffH f f).
Proof.
apply (iffRefl LNN).
Qed.

Lemma iffSym :
 forall (T : System) (f g : Formula),
 SysPrf T (iffH f g) -> SysPrf T (iffH g f).
Proof.
apply (iffSym LNN).
Qed.

Lemma iffTrans :
 forall (T : System) (f g h : Formula),
 SysPrf T (iffH f g) -> SysPrf T (iffH g h) -> SysPrf T (iffH f h).
Proof.
apply (iffTrans LNN).
Qed.

Lemma eqRefl : forall (T : System) (a : Term), SysPrf T (equal a a).
Proof.
apply (eqRefl LNN).
Qed.

Lemma eqSym :
 forall (T : System) (a b : Term),
 SysPrf T (equal a b) -> SysPrf T (equal b a).
Proof.
apply (eqSym LNN).
Qed.

Lemma eqTrans :
 forall (T : System) (a b c : Term),
 SysPrf T (equal a b) -> SysPrf T (equal b c) -> SysPrf T (equal a c).
Proof.
apply (eqTrans LNN).
Qed.

Lemma eqPlus :
 forall (T : System) (a b c d : Term),
 SysPrf T (equal a b) ->
 SysPrf T (equal c d) -> SysPrf T (equal (Plus a c) (Plus b d)).
Proof.
intros.
unfold Plus in |- *.
apply (equalFunction LNN).
simpl in |- *.
induction (consTerms LNN 1 (Tcons LNN 1 a (Tcons LNN 0 c (Tnil LNN)))).
induction x as (a0, b0).
simpl in |- *.
induction (consTerms LNN 1 (Tcons LNN 1 b (Tcons LNN 0 d (Tnil LNN)))).
induction x as (a1, b1).
simpl in |- *.
induction (consTerms LNN 0 b0).
induction x as (a2, b2).
simpl in |- *.
induction (consTerms LNN 0 b1).
induction x as (a3, b3).
simpl in |- *.
repeat split.
simpl in p.
inversion p.
simpl in p0.
inversion p0.
apply H.
simpl in p.
inversion p.
rewrite <- p1 in H3.
simpl in H3.
inversion H3.
simpl in p0.
inversion p0.
rewrite <- p2 in H7.
inversion H7.
apply H0.
Qed.

Lemma eqTimes :
 forall (T : System) (a b c d : Term),
 SysPrf T (equal a b) ->
 SysPrf T (equal c d) -> SysPrf T (equal (Times a c) (Times b d)).
Proof.
intros.
unfold Times in |- *.
apply (equalFunction LNN).
simpl in |- *.
induction (consTerms LNN 1 (Tcons LNN 1 a (Tcons LNN 0 c (Tnil LNN)))).
induction x as (a0, b0).
simpl in |- *.
induction (consTerms LNN 1 (Tcons LNN 1 b (Tcons LNN 0 d (Tnil LNN)))).
induction x as (a1, b1).
simpl in |- *.
induction (consTerms LNN 0 b0).
induction x as (a2, b2).
simpl in |- *.
induction (consTerms LNN 0 b1).
induction x as (a3, b3).
simpl in |- *.
repeat split.
simpl in p.
inversion p.
simpl in p0.
inversion p0.
apply H.
simpl in p.
inversion p.
rewrite <- p1 in H3.
simpl in H3.
inversion H3.
simpl in p0.
inversion p0.
rewrite <- p2 in H7.
inversion H7.
apply H0.
Qed.

Lemma eqSucc :
 forall (T : System) (a b : Term),
 SysPrf T (equal a b) -> SysPrf T (equal (Succ a) (Succ b)).
Proof.
intros.
unfold Succ in |- *.
apply (equalFunction LNN).
simpl in |- *.
induction (consTerms LNN 0 (Tcons LNN 0 a (Tnil LNN))).
induction x as (a0, b0).
simpl in |- *.
induction (consTerms LNN 0 (Tcons LNN 0 b (Tnil LNN))).
induction x as (a1, b1).
simpl in |- *.
repeat split.
simpl in p.
inversion p.
simpl in p0.
inversion p0.
apply H.
Qed.

Lemma eqLT :
 forall (T : System) (a b c d : Term),
 SysPrf T (equal a b) ->
 SysPrf T (equal c d) -> SysPrf T (iffH (LT a c) (LT b d)).
Proof.
intros.
unfold LT in |- *.
apply (equalRelation LNN).
simpl in |- *.
induction (consTerms LNN 1 (Tcons LNN 1 a (Tcons LNN 0 c (Tnil LNN)))).
induction x as (a0, b0).
simpl in |- *.
induction (consTerms LNN 1 (Tcons LNN 1 b (Tcons LNN 0 d (Tnil LNN)))).
induction x as (a1, b1).
simpl in |- *.
induction (consTerms LNN 0 b0).
induction x as (a2, b2).
simpl in |- *.
induction (consTerms LNN 0 b1).
induction x as (a3, b3).
simpl in |- *.
repeat split.
simpl in p.
inversion p.
simpl in p0.
inversion p0.
apply H.
simpl in p.
inversion p.
rewrite <- p1 in H3.
simpl in H3.
inversion H3.
simpl in p0.
inversion p0.
rewrite <- p2 in H7.
inversion H7.
apply H0.
Qed.

End Logic.

Fixpoint natToTerm (n : nat) : Term :=
  match n with
  | O => Zero
  | S m => Succ (natToTerm m)
  end.

Lemma closedNatToTerm :
 forall a v : nat, ~ In v (freeVarTerm LNN (natToTerm a)).
Proof.
intros.
induction a as [| a Hreca].
auto.
simpl in |- *.
rewrite freeVarSucc.
auto.
Qed.


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

(** * Decidable equivalences.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

(** Export notations. *)

Require Export Coq.Classes.Equivalence.

(** The [DecidableSetoid] class asserts decidability of a [Setoid].
   It can be useful in proofs to reason more classically. *)

Require Import Coq.Logic.Decidable.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Program.Program.

Generalizable Variables A B R.

Open Scope equiv_scope.

Class DecidableEquivalence `(equiv : Equivalence A) :=
  setoid_decidable : forall x y : A, decidable (x === y).

(** The [EqDec] class gives a decision procedure for a particular
   setoid equality. *)

Class EqDec A R {equiv : Equivalence R} :=
  equiv_dec : forall x y : A, { x === y } + { x =/= y }.

(** We define the [==] overloaded notation for deciding equality. It does not
   take precedence of [==] defined in the type scope, hence we can have both
   at the same time. *)

Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70) : equiv_scope.

Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
  match x with
    | left H => @right _ _ H
    | right H => @left _ _ H
  end.

Open Local Scope program_scope.

(** Invert the branches. *)

Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y).

(** Overloaded notation for inequality. *)

Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope.

(** Define boolean versions, losing the logical information. *)

Definition equiv_decb `{EqDec A} (x y : A) : bool :=
  if x == y then true else false.

Definition nequiv_decb `{EqDec A} (x y : A) : bool :=
  negb (equiv_decb x y).

Infix "==b" := equiv_decb (no associativity, at level 70).
Infix "<>b" := nequiv_decb (no associativity, at level 70).

(** Decidable leibniz equality instances. *)

(** The equiv is burried inside the setoid, but we can recover it by specifying
   which setoid we're talking about. *)

Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec.

Program Instance bool_eqdec : EqDec bool eq := bool_dec.

Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left.

  Next Obligation.
  Proof.
    destruct x ; destruct y.
    reflexivity.
  Qed.

Obligation Tactic := unfold complement, equiv ; program_simpl.

Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) :
  ! EqDec (prod A B) eq :=
  { equiv_dec x y :=
    let '(x1, x2) := x in
    let '(y1, y2) := y in
    if x1 == y1 then
      if x2 == y2 then in_left
      else in_right
    else in_right }.

Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) :
  EqDec (sum A B) eq := {
  equiv_dec x y :=
    match x, y with
      | inl a, inl b => if a == b then in_left else in_right
      | inr a, inr b => if a == b then in_left else in_right
      | inl _, inr _ | inr _, inl _ => in_right
    end }.

(** Objects of function spaces with countable domains like bool have decidable
  equality. Proving the reflection requires functional extensionality though. *)

Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq :=
  { equiv_dec f g :=
    if f true == g true then
      if f false == g false then in_left
      else in_right
    else in_right }.

  Next Obligation.
  Proof.
    extensionality x.
    destruct x ; auto.
  Qed.

Require Import List.

Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq :=
  { equiv_dec :=
    fix aux (x y : list A) :=
    match x, y with
      | nil, nil => in_left
      | cons hd tl, cons hd' tl' =>
        if hd == hd' then
          if aux tl tl' then in_left else in_right
          else in_right
      | _, _ => in_right
    end }.

  Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto).

  Next Obligation. destruct y ; intuition eauto. Defined.

  Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto).


Require Import HoTT.
(*Require Import Nat.*)

(*Local Unset Elimination Schemes.*)
Generalizable Variables A B P x y z w.
Set Impicit Arguments.

(** This section should really be in some other place. TODO: move it. *)
Section Rel_eq.
  (** Heterogeneous equality for 2-parametric type family. *)
  Local Definition rel_eq {A: Type} {x y x' y': A} (P: relation A)
      (sx: x = x') (sy: y = y') (u: P x y) (u': P x' y'): Type.
    path_induction.
    exact (u = u').
    Defined.

  Local Definition rel_eq_ex {A: Type} {x y x' y': A}
      (P: relation A) (u: P x y) (u': P x' y'): Type
    := exists (sx: x = x') (sy: y = y'), rel_eq P sx sy u u'.

  (** Proof that rel_ex can be defined inductively. *)
  Inductive jmeq2 {A: Type} {x y: A} (P: relation A)
      (u: P x y): forall {x' y': A}, (P x' y') -> Type
    := ideq: jmeq2 P u u.

(*  Scheme jmeq2_ind := Induction for jmeq2 Sort Type.
  Scheme jmeq2_rec := Minimality for jmeq2 Sort Type.
  Definition jmeq2_rect := jmeq2_ind.*)

  Definition jmeq2_to_rel_eq_ex {A: Type} {x y x' y': A} (P: relation A)
      (u: P x y) (u': P x' y'): (jmeq2 P u u') -> (rel_eq_ex P u u').
    intro jm_s; induction jm_s.
    exact (idpath; (idpath; idpath)).
    Defined.

  Definition rel_eq_ex_to_jmeq2 {A: Type} {x y x' y': A} (P: relation A)
      (u: P x y) (u': P x' y'): (rel_eq_ex P u u') -> (jmeq2 P u u').
    intros (sx & sy & p).
    path_induction.
    revert p; simpl.
    intro su; induction su; done.
    Defined.

  Lemma jmeq2_eq_rel_eq_eq {A: Type} {x y x' y': A}
      (P: relation A) (u: P x y) (u': P x' y')
      : IsEquiv (jmeq2_to_rel_eq_ex P u u').
    Proof.
    refine (BuildIsEquiv _ _ (jmeq2_to_rel_eq_ex P u u') _ _ _ _ ).
    - exact (rel_eq_ex_to_jmeq2 P u u').
    - unfold Sect.
      intros (? & ? & ? ).
      path_induction.
      revert proj2_sig.
      unfold rel_eq; simpl.
      path_induction.
      compute; done.
    - unfold Sect.
      induction x0.
      compute; done.
    - induction x0; done.
    Qed.

End Rel_eq.

Local Notation "u ~= v" := (jmeq2 _ u v) (at level 75).
(*Local Notation "u ~= v" := ((_; (_; u)) = (_; (_; v))) (at level 75).*)

(** Type of chains - parametric analogue of List. Main example: chains of morphisms in a category. Most of functions and lemmas defined for lists are more or less directly applicable for chains. *)
Inductive Chain {A: Type} (P: relation A) : relation A :=
  | idchain {x: A} : Chain P x x
  | concat {x y z: A} : (P y z) -> (Chain P x y) -> (Chain P x z).

Arguments idchain [A P x].
Arguments concat [A P x y z] _ _.

(*Scheme Chain_ind := Induction for Chain Sort Type.
Scheme Chain_rec := Minimality for Chain Sort Type.
Definition Chain_rect := Chain_ind.*)

Delimit Scope Chain_scope with Chain.
Bind Scope Chain_scope with Chain.

Local Open Scope Chain_scope.

(** Concatenation of two chains *)
Definition app {A: Type} {P: relation A} {x y z: A}
    (fs: Chain P y z) (gs: Chain P x y) : Chain P x z.
  intros.
  induction fs; [ exact gs | exact (concat p (IHfs gs)) ].
  Defined.

Module ChainNotations.

  Infix "++" := app (right associativity, at level 60) : Chain_scope.
  Infix "::" := concat (at level 60, right associativity) : Chain_scope.
  Notation "[ ]" := idchain : Chain_scope.
  Notation "[ x ]" := (x :: []) : Chain_scope.
  Notation "[ x ; .. ; y ]" := (x :: .. (y :: []) .. ) : Chain_scope.
  Notation "x ~> y :> P" := (Chain P x y) (at level 99, y at next level).
  Notation "x ~> y" := (x ~> y :> _ ) (at level 99, y at next level).

End ChainNotations.

Import ChainNotations.

Section Chains.

  Context {A : Type} {P: relation A}.
  Implicit Types x y z w: A.

  (** Length of chain *)
  Fixpoint length {x y: A} (fs: Chain P x y) : nat :=
    match fs with
    | [] => O
    | f :: fs' => S (length fs')
    end.

  (** Head and tail *)

  Definition hd `(default: P x x) `(cs: Chain P x z) : { y: A & P y z }.
    induction cs; [exact (x; default) | exact (y; p)].
    Defined.

  Definition hd_error `(cs: Chain P x z): option { y: A & P y z}.
    induction cs; [exact error | exact (value (y; p)) ].
    Defined.

  Definition tl `(cs: Chain P x z): { y: A & Chain P x y }.
    induction cs; [ exact (x; []) | exact (y; cs) ].
    Defined.

  (** The [In] predicate *)
  Fixpoint In `(f: P z w) `(cs: Chain P x y) : Type :=
    match cs with
    | [] => Empty
    | c :: cs' => (f ~= c) + In f cs'
    end.

End Chains.

Notation "head" = hd (only parsing).
Notation "tail" = tl (only parsing).

(** Opposite relation $P^{op} x y = P y x$. *)
Definition opp `(P: relation A): relation A :=
  fun (x y: A) => P y x.

(** Reverse chain. Its elements lie in dual relation P^op x y = P y x. *)
Fixpoint rev {A: Type} {P: relation A} `(fs: Chain P x y) : Chain (opp P) y x
  := match fs with
    | [] => []
    | f :: fss => (rev fss) ++ [f]
    end.

(** opp opp = id *)
Lemma opp_involutive {A: Type} {P: relation A} : opp (opp P) = P.
  unfold opp; auto.
  Qed.

Section app_Facts.
  Context {A: Type} {P: relation A}.

  (** Left and right unit laws for ++. *)
  Lemma app_nil_l `(fs: x ~> y :> P): [] ++ fs = fs.
  induction fs; auto.
  Qed.

  Lemma app_nil_r `(fs: x ~> y :> P): fs ++ [] = fs.
  induction fs; simpl; [auto | f_ap ].
  Qed.

  (** ++ is associative. *)
  Lemma app_assoc `(fs: z ~> w :> P) `(gs: y ~> z :> P) `(hs: x ~> y :> P):
    (fs ++ gs) ++ hs = fs ++ (gs ++ hs).
  induction fs; simpl; [ auto | f_ap ].
  Qed.

End app_Facts.

Section rev_Facts.
  Context {A: Type}.

  (** Distributivity of rev over ++. *)
  Lemma rev_distr {P: relation A} `(fs: y ~> z :> P) `(gs: x ~> y :> P):
    rev (fs ++ gs) = (rev gs) ++ (rev fs).
  induction fs; simpl.
  exact ((app_nil_r (rev gs))^).
  transitivity ((rev gs ++ rev fs) ++ [p]).
  f_ap.
  exact (app_assoc (rev gs) (rev fs) [p]).
  Qed.

  (** rev rev = id *)
  Lemma rev_involutive {P: relation A} `(fs: x ~> y :> P): rev (rev fs) = fs.
  induction fs; [auto | simpl ].
  transitivity ([p] ++ (rev (rev fs))).
  apply (rev_distr (rev fs) [p]).
  simpl; f_ap.
  Qed.

End rev_Facts.

(** n-th elemen of chain, error if n>length *)
Fixpoint nth {A: Type} `(cs: x ~> y :> P) (n: nat)
    : option (exists (w z: A), P w z) :=
  match cs return option (exists (w z: A), P w z) with
  | [] => error
  | @concat _ _ x' y' z' c cs' => match n with
                                  | O => value (y'; (z'; c))
                                  | S n' => nth cs' n'
                                  end
  end.

Section Actions.
  Context {A: Type} {P: relation A} {F: A -> Type}.

  (** Left action of P on type family F (covariant functors). *)
  Definition LAction (P: relation A) (F: A -> Type) : Type
    := `(P x y -> F x -> F y).
  (** Right action of P on type family F (contravariant functors). *)
  Definition RAction (P: relation A) (F: A -> Type) : Type
    := `(P x y -> F y -> F x).
  (** By default any action is right action *)
  Notation Action P F := (RAction P F).

(*
  (** Left action of P is right action of P^op *)
  Lemma left_right : (LAction P F = RAction (opp P) F).
  unfold LAction, RAction, opp.
*)

  (** (f: Fx; [p_n, .. , p_1]: Chain x y) |-> (..(f * p_n)* ..)* p_1 *)
  Fixpoint foldl {x y: A} (m: RAction P F) (f: F y)
      (cs: Chain P x y) : F x.
    induction cs; [exact f | apply IHcs].
    exact (m y z p f).
    Defined.

  (** (f: Fx; [p_n, .. , p_1]: Chain x y) |-> p_n(.. p_1(f) ..) *)
  Fixpoint foldr {x y: A} (m: LAction P F) (f: F x)
      (cs: Chain P x y) : F y.
    induction cs; [exact f | exact (m y z p (IHcs f)) ].
    Defined.

End Actions.

(***************************************************)
(** * Applying functions to the elements of a chain *)
(***************************************************)

Section Chain_map.

  Record Chain_map {A B: Type} (PA: relation A) (PB: relation B) := {
    base: A -> B;
    fam: forall {x y: A}, PA x y -> PB (base x) (base y)
    }.

  Global Coercion base: Chain_map  >-> Funclass.
  Global Arguments base [A B PA PB] c _.
  Global Arguments fam [A B PA PB] c {x y} _. (* somewhy can't declare another sequence of elements. Reason: 'Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.' *)

  Definition ap_chain {A B: Type} {PA: relation A} {PB: relation B}
      (F: Chain_map PA PB) {x y x' y': A} {u: PA x y} {u': PA x' y'}
      (su: u ~= u'): ((fam F u) ~= (fam F u')).
    induction su; done.
    Defined.

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

  (** Map between pairs (A,PA) and (B, PB) *)
  Definition map {A B: Type} {PA: relation A} {PB: relation B}
      {x y: A} (F: Chain_map PA PB) (cs: x ~> y :> PA)
      : (F x) ~> (F y) :> PB.
    induction cs.
    exact [].
    exact ((fam F p) :: IHcs).
    Defined.

  (** Map between type families over a shared base *)
  Definition map_base {A: Type} {P Q: relation A} {x y: A}
      (f: forall x y: A, P x y -> Q x y)
      (cs: x ~> y :> P) : x ~> y :> Q
    := map (@Build_Chain_map A A P Q idmap f) cs.

End Chain_map.

(******************)
(** ** Map facts  *)
(******************)

Section Chain_map_facts.

  Context {A B: Type} {PA: relation A} {PB: relation B}.
  Context (F: Chain_map PA PB).
  Implicit Types (x y z w: A).

  (** f $ x :: xs = (f x) :: (f $ xs) *)
  Lemma map_cons {x y z: A} (p: PA y z) (ps: x ~> y :> PA)
      : map F (p :: ps) = (fam F p) :: (map F ps).
  Proof.
    reflexivity.
  Qed.

  (** Maps preserve inclusion of elements. *)
  Lemma in_map :
    forall {x y z w: A} (ps: x ~> y :> PA) (p: PA z w), In p ps
    -> In (fam F p) (map F ps).
  Proof.
    intros; induction ps.
    revert X; auto.
    rewrite (map_cons p0 ps).
    simpl.
    assert ((p ~= p0) + In p ps).
    revert X; done.
    destruct X0.
    - exact (inl (ap_chain F j)).
    - exact (inr (IHps i)).
  Qed.

  (** Chain maps preserve length. *)
  Lemma map_length {x y: A} (cs: x ~> y :> PA) :
     length (map F cs) = length cs.
  Proof.
    induction cs; [ exact idpath | simpl; f_ap].
  Qed.
(*
  Section In_map_iff.

    Context {x y z w: A} (cs: x ~> y :> PA) (zt wt: B) (t: PB zt wt).

    Local Definition in_to_ex: In t (map F cs) -> {z' : A & {w' : A &
        {p : PA z' w' & (t ~= fam F p) * In p cs}}}.
      induction cs; simpl.
      done.
      intros [ eq_path | ind_cs ].
      - refine (y; (z0; (p; _))).
        exact (eq_path, inl (ideq PA p)).
      - apply (IHc c) in ind_cs.
        revert ind_cs.
        intros (z' & w' & p' & fib_eq & p_in_cs).
        exact (z'; (w'; (p'; (fib_eq, inr p_in_cs)))).
      Defined.

    Local Definition ex_to_in: {z' : A & {w' : A & {p : PA z' w' &
        (t ~= fam F p) * In p cs}}} -> In t (map F cs).
      intros (z' & w' & p' & t_eq & p_in ).
      apply (in_map cs p') in p_in.
      induction t_eq; auto.
      Defined.

    (** An element lies in f(chain) only if its preimage lies in chain.*)
    Lemma in_map_iff  : Equiv (In t (map F cs))
        (exists (z' w': A) (p: PA z' w'), (t ~= fam F p) * (In p cs)).
    Proof.
      refine (BuildEquiv (In t (map F cs))
        (exists (z' w': A) (p: PA z' w'), (t ~= fam F p) * (In p cs))
           in_to_ex _).
      refine (BuildIsEquiv (In t (map F cs))
        (exists (z' w': A) (p: PA z' w'), (t ~= fam F p) * (In p cs))
        in_to_ex ex_to_in _ _ _).
      - admit. (*unfold Sect.
        intros (z' & w' & p' & t_eq & p_in ).
        induction t_eq.
        unfold ex_to_in.
        unfold in_map.
        simpl.
        induction *)
      - admit. (*unfold Sect.
        intro t_in.
        unfold in_to_ex. simpl. *)
      - admit.
    Qed.

  End In_map_iff.
*)

  Lemma map_nth `(cs: x ~> y):
    nth (map F cs) n  = fmap F (nth cs n).
  Proof.
    induction l; simpl map; destruct n; firstorder.
  Qed.

  Lemma map_nth_error : forall n l d,
    nth_error l n = Some d -> nth_error (map l) n = Some (f d).
  Proof.
    induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto.
  Qed.

  Lemma map_app : forall l l',
    map (l++l') = (map l)++(map l').
  Proof.
    induction l; simpl; auto.
    intros; rewrite IHl; auto.
  Qed.

  Lemma map_rev : forall l, map (rev l) = rev (map l).
  Proof.
    induction l; simpl; auto.
    rewrite map_app.
    rewrite IHl; auto.
  Qed.

  Lemma map_eq_nil : forall l, map l = [] -> l = [].
  Proof.
    destruct l; simpl; reflexivity || discriminate.
  Qed.

  (** [flat_map] *)

  Definition flat_map (f:A -> list B) :=
    fix flat_map (l:list A) : list B :=
    match l with
      | nil => nil
      | cons x t => (f x)++(flat_map t)
    end.

  Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B),
    In y (flat_map f l) <-> exists x, In x l /\ In y (f x).
  Proof using A B.
    induction l; simpl; split; intros.
    contradiction.
    destruct H as (x,(H,_)); contradiction.
    destruct (in_app_or _ _ _ H).
    exists a; auto.
    destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)).
    exists x; auto.
    apply in_or_app.
    destruct H as (x,(H0,H1)); destruct H0.
    subst; auto.
    right; destruct (IHl y) as (_,H2); apply H2.
    exists x; auto.
  Qed.

End Map.

Lemma flat_map_concat_map : forall A B (f : A -> list B) l,
  flat_map f l = concat (map f l).
Proof.
intros A B f l; induction l as [|x l IH]; simpl.
+ reflexivity.
+ rewrite IH; reflexivity.
Qed.

Lemma concat_map : forall A B (f : A -> B) l, map f (concat l) = concat (map (map f) l).
Proof.
intros A B f l; induction l as [|x l IH]; simpl.
+ reflexivity.
+ rewrite map_app, IH; reflexivity.
Qed.

Lemma map_id : forall (A :Type) (l : list A),
  map (fun x => x) l = l.
Proof.
  induction l; simpl; auto; rewrite IHl; auto.
Qed.

Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l,
  map g (map f l) = map (fun x => g (f x)) l.
Proof.
  induction l; simpl; auto.
  rewrite IHl; auto.
Qed.

Lemma map_ext :
  forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l.
Proof.
  induction l; simpl; auto.
  rewrite H; rewrite IHl; auto.
Qed.

End Chain_map.

Section Monadic.
  Context {A: Type} {P: relation A}.

  (**
    Chain is a monad, chain_join is its monadic composition.
    [ [x1, .. , xn], .. , [z1, .. zk] ] |-> [ x1, .. , zk ]
    LAction = (R y z -> F y -> F z)
    ++ : (y ~> z) -> (x ~> y) -> (x ~> z)
    F y := x ~> y
    R y z := y ~> z
    *)
  Definition chain_join {x y: A} (cs: Chain (Chain P) x y)
      : Chain P x y.
    assert (act: LAction (Chain P) (Chain P x)).
    exact (fun (y' z': A) (p: y' ~> z' :> P) (f: x ~> y' :> P)
      => p ++ f).
    exact (@foldr A (Chain P) (Chain P x) x y act [] cs).
    Defined.

End Monadic.

(*******************************)
(** ** Last element of a chain *)
(*******************************)

  (** [last l d] returns the last element of the list [l],
    or the default value [d] if [l] is empty. *)

  Fixpoint last (l:list A) (d:A) : A :=
  match l with
    | [] => d
    | [a] => a
    | a :: l => last l d
  end.

  (** [removelast l] remove the last element of [l] *)

  Fixpoint removelast (l:list A) : list A :=
    match l with
      | [] =>  []
      | [a] => []
      | a :: l => a :: removelast l
    end.

  Lemma app_removelast_last :
    forall l d, l <> [] -> l = removelast l ++ [last l d].
  Proof.
    induction l.
    destruct 1; auto.
    intros d _.
    destruct l; auto.
    pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate.
  Qed.

  Lemma exists_last :
    forall l, l <> [] -> { l' : (list A) & { a : A | l = l' ++ [a]}}.
  Proof.
    induction l.
    destruct 1; auto.
    intros _.
    destruct l.
    exists [], a; auto.
    destruct IHl as [l' (a',H)]; try discriminate.
    rewrite H.
    exists (a::l'), a'; auto.
  Qed.

  Lemma removelast_app :
    forall l l', l' <> [] -> removelast (l++l') = l ++ removelast l'.
  Proof.
    induction l.
    simpl; auto.
    simpl; intros.
    assert (l++l' <> []).
    destruct l.
    simpl; auto.
    simpl; discriminate.
    specialize (IHl l' H).
    destruct (l++l'); [elim H0; auto|f_equal; auto].
  Qed.

(*                       *)
(*                       *)
(* List ripoff following *)
(*                       *)
(*                       *)

Section Facts.

  Context {A : Type}.

  (** *** Genereric facts *)

  (** Discrimination *)
  Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l.
  Proof.
    intros; discriminate.
  Qed.

  (** Destruction *)

  Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = []}.
  Proof.
    induction l as [|a tail].
    right; reflexivity.
    left; exists a, tail; reflexivity.
  Qed.

  Lemma hd_error_tl_repr : forall l (a:A) r,
    hd_error l = Some a /\ tl l = r <-> l = a :: r.
  Proof. destruct l as [|x xs].
    - unfold hd_error, tl; intros a r. split; firstorder discriminate.
    - intros. simpl. split.
      * intros (H1, H2). inversion H1. rewrite H2. reflexivity.
      * inversion 1. subst. auto.
  Qed.

  Lemma hd_error_some_nil : forall l (a:A), hd_error l = Some a -> l <> nil.
  Proof. unfold hd_error. destruct l; now discriminate. Qed.

  Theorem length_zero_iff_nil (l : list A):
    length l = 0 <-> l=[].
  Proof.
    split; [now destruct l | now intros ->].
  Qed.

  (** *** Head and tail *)

  Theorem hd_error_nil : hd_error (@nil A) = None.
  Proof.
    simpl; reflexivity.
  Qed.

  Theorem hd_error_cons : forall (l : list A) (x : A), hd_error (x::l) = Some x.
  Proof.
    intros; simpl; reflexivity.
  Qed.

  (************************)
  (** *** Facts about [In] *)
  (************************)

  (** Characterization of [In] *)

  Theorem in_eq : forall (a:A) (l:list A), In a (a :: l).
  Proof.
    simpl; auto.
  Qed.

  Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l).
  Proof.
    simpl; auto.
  Qed.

  Theorem not_in_cons (x a : A) (l : list A):
    ~ In x (a::l) <-> x<>a /\ ~ In x l.
  Proof.
    simpl. intuition.
  Qed.

  Theorem in_nil : forall a:A, ~ In a [].
  Proof.
    unfold not; intros a H; inversion_clear H.
  Qed.

  Theorem in_split : forall x (l:list A), In x l -> exists l1 l2, l = l1++x::l2.
  Proof.
  induction l; simpl; destruct 1.
  subst a; auto.
  exists [], l; auto.
  destruct (IHl H) as (l1,(l2,H0)).
  exists (a::l1), l2; simpl. apply f_equal. auto.
  Qed.

  (** Inversion *)
  Lemma in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l.
  Proof.
    intros a b l H; inversion_clear H; auto.
  Qed.

  (** Decidability of [In] *)
  Theorem in_dec :
    (forall x y:A, {x = y} + {x <> y}) ->
    forall (a:A) (l:list A), {In a l} + {~ In a l}.
  Proof.
    intro H; induction l as [| a0 l IHl].
    right; apply in_nil.
    destruct (H a0 a); simpl; auto.
    destruct IHl; simpl; auto.
    right; unfold not; intros [Hc1| Hc2]; auto.
  Defined.

  (**************************)
  (** *** Facts about [app] *)
  (**************************)

  (** Discrimination *)
  Theorem app_cons_not_nil : forall (x y:list A) (a:A), [] <> x ++ a :: y.
  Proof.
    unfold not.
    destruct x as [| a l]; simpl; intros.
    discriminate H.
    discriminate H.
  Qed.

  (** [app] commutes with [cons] *)
  Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
  Proof.
    auto.
  Qed.

  (** Facts deduced from the result of a concatenation *)

  Theorem app_eq_nil : forall l l':list A, l ++ l' = [] -> l = [] /\ l' = [].
  Proof.
    destruct l as [| x l]; destruct l' as [| y l']; simpl; auto.
    intro; discriminate.
    intros H; discriminate H.
  Qed.

  Theorem app_eq_unit :
    forall (x y:list A) (a:A),
      x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = [].
  Proof.
    destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ];
      simpl.
    intros a H; discriminate H.
    left; split; auto.
    right; split; auto.
    generalize H.
    generalize (app_nil_r l); intros E.
    rewrite -> E; auto.
    intros.
    injection H.
    intro.
    assert ([] = l ++ a0 :: l0) by auto.
    apply app_cons_not_nil in H1 as [].
  Qed.

  Lemma app_inj_tail :
    forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b.
  Proof.
    induction x as [| x l IHl];
      [ destruct y as [| a l] | destruct y as [| a l0] ];
      simpl; auto.
    - intros a b H.
      injection H.
      auto.
    - intros a0 b H.
      injection H as H1 H0.
      apply app_cons_not_nil in H0 as [].
    - intros a b H.
      injection H as H1 H0.
      assert ([] = l ++ [a]) by auto.
      apply app_cons_not_nil in H as [].
    - intros a0 b H.
      injection H as <- H0.
      destruct (IHl l0 a0 b H0) as (<-,<-).
      split; auto.
  Qed.

  (** Compatibility with other operations *)

  Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'.
  Proof.
    induction l; simpl; auto.
  Qed.

  Lemma in_app_or : forall (l m:list A) (a:A), In a (l ++ m) -> In a l \/ In a m.
  Proof.
    intros l m a.
    elim l; simpl; auto.
    intros a0 y H H0.
    now_show ((a0 = a \/ In a y) \/ In a m).
    elim H0; auto.
    intro H1.
    now_show ((a0 = a \/ In a y) \/ In a m).
    elim (H H1); auto.
  Qed.

  Lemma in_or_app : forall (l m:list A) (a:A), In a l \/ In a m -> In a (l ++ m).
  Proof.
    intros l m a.
    elim l; simpl; intro H.
    now_show (In a m).
    elim H; auto; intro H0.
    now_show (In a m).
    elim H0. (* subProof completed *)
    intros y H0 H1.
    now_show (H = a \/ In a (y ++ m)).
    elim H1; auto 4.
    intro H2.
    now_show (H = a \/ In a (y ++ m)).
    elim H2; auto.
  Qed.

  Lemma in_app_iff : forall l l' (a:A), In a (l++l') <-> In a l \/ In a l'.
  Proof.
    split; auto using in_app_or, in_or_app.
  Qed.

  Lemma app_inv_head:
   forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2.
  Proof.
    induction l; simpl; auto; injection 1; auto.
  Qed.

  Lemma app_inv_tail:
    forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2.
  Proof.
    intros l l1 l2; revert l1 l2 l.
    induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2];
     simpl; auto; intros l H.
    absurd (length (x2 :: l2 ++ l) <= length l).
    simpl; rewrite app_length; auto with arith.
    rewrite <- H; auto with arith.
    absurd (length (x1 :: l1 ++ l) <= length l).
    simpl; rewrite app_length; auto with arith.
    rewrite H; auto with arith.
    injection H; clear H; intros; f_equal; eauto.
  Qed.

End Facts.

Hint Resolve app_assoc app_assoc_reverse: datatypes v62.
Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62.
Hint Immediate app_eq_nil: datatypes v62.
Hint Resolve app_eq_unit app_inj_tail: datatypes v62.
Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62.

(*******************************************)
(** * Operations on the elements of a list *)
(*******************************************)

Section Elts.

  Variable A : Type.

  (*****************************)
  (** ** Nth element of a list *)
  (*****************************)

  Fixpoint nth (n:nat) (l:list A) (default:A) {struct l} : A :=
    match n, l with
      | O, x :: l' => x
      | O, other => default
      | S m, [] => default
      | S m, x :: t => nth m t default
    end.

  Fixpoint nth_ok (n:nat) (l:list A) (default:A) {struct l} : bool :=
    match n, l with
      | O, x :: l' => true
      | O, other => false
      | S m, [] => false
      | S m, x :: t => nth_ok m t default
    end.

  Lemma nth_in_or_default :
    forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}.
  Proof.
    intros n l d; revert n; induction l.
    - right; destruct n; trivial.
    - intros [|n]; simpl.
      * left; auto.
      * destruct (IHl n); auto.
  Qed.

  Lemma nth_S_cons :
    forall (n:nat) (l:list A) (d a:A),
      In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l).
  Proof.
    simpl; auto.
  Qed.

  Fixpoint nth_error (l:list A) (n:nat) {struct n} : Exc A :=
    match n, l with
      | O, x :: _ => value x
      | S n, _ :: l => nth_error l n
      | _, _ => error
    end.

  Definition nth_default (default:A) (l:list A) (n:nat) : A :=
    match nth_error l n with
      | Some x => x
      | None => default
    end.

  Lemma nth_default_eq :
    forall n l (d:A), nth_default d l n = nth n l d.
  Proof.
    unfold nth_default; induction n; intros [ | ] ?; simpl; auto.
  Qed.

  (** Results about [nth] *)

  Lemma nth_In :
    forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l.
  Proof.
    unfold lt; induction n as [| n hn]; simpl.
    - destruct l; simpl; [ inversion 2 | auto ].
    - destruct l as [| a l hl]; simpl.
      * inversion 2.
      * intros d ie; right; apply hn; auto with arith.
  Qed.

  Lemma In_nth l x d : In x l ->
    exists n, n < length l /\ nth n l d = x.
  Proof.
    induction l as [|a l IH].
    - easy.
    - intros [H|H].
      * subst; exists 0; simpl; auto with arith.
      * destruct (IH H) as (n & Hn & Hn').
        exists (S n); simpl; auto with arith.
  Qed.

  Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d.
  Proof.
    induction l; destruct n; simpl; intros; auto.
    - inversion H.
    - apply IHl; auto with arith.
  Qed.

  Lemma nth_indep :
    forall l n d d', n < length l -> nth n l d = nth n l d'.
  Proof.
    induction l.
    - inversion 1.
    - intros [|n] d d'; simpl; auto with arith.
  Qed.

  Lemma app_nth1 :
    forall l l' d n, n < length l -> nth n (l++l') d = nth n l d.
  Proof.
    induction l.
    - inversion 1.
    - intros l' d [|n]; simpl; auto with arith.
  Qed.

  Lemma app_nth2 :
    forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d.
  Proof.
    induction l; intros l' d [|n]; auto.
    - inversion 1.
    - intros; simpl; rewrite IHl; auto with arith.
  Qed.

  Lemma nth_split n l d : n < length l ->
    exists l1, exists l2, l = l1 ++ nth n l d :: l2 /\ length l1 = n.
  Proof.
    revert l.
    induction n as [|n IH]; intros [|a l] H; try easy.
    - exists nil; exists l; now simpl.
    - destruct (IH l) as (l1 & l2 & Hl & Hl1); auto with arith.
      exists (a::l1); exists l2; simpl; split; now f_equal.
  Qed.

  (** Results about [nth_error] *)

  Lemma nth_error_In l n x : nth_error l n = Some x -> In x l.
  Proof.
    revert n. induction l as [|a l IH]; intros [|n]; simpl; try easy.
    - injection 1; auto.
    - eauto.
  Qed.

  Lemma In_nth_error l x : In x l -> exists n, nth_error l n = Some x.
  Proof.
    induction l as [|a l IH].
    - easy.
    - intros [H|H].
      * subst; exists 0; simpl; auto with arith.
      * destruct (IH H) as (n,Hn).
        exists (S n); simpl; auto with arith.
  Qed.

  Lemma nth_error_None l n : nth_error l n = None <-> length l <= n.
  Proof.
    revert n. induction l; destruct n; simpl.
    - split; auto.
    - split; auto with arith.
    - split; now auto with arith.
    - rewrite IHl; split; auto with arith.
  Qed.

  Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l.
  Proof.
   revert n. induction l; destruct n; simpl.
    - split; [now destruct 1 | inversion 1].
    - split; [now destruct 1 | inversion 1].
    - split; now auto with arith.
    - rewrite IHl; split; auto with arith.
  Qed.

  Lemma nth_error_split l n a : nth_error l n = Some a ->
    exists l1, exists l2, l = l1 ++ a :: l2 /\ length l1 = n.
  Proof.
    revert l.
    induction n as [|n IH]; intros [|x l] H; simpl in *; try easy.
    - exists nil; exists l. injection H; clear H; intros; now subst.
    - destruct (IH _ H) as (l1 & l2 & H1 & H2).
      exists (x::l1); exists l2; simpl; split; now f_equal.
  Qed.

  Lemma nth_error_app1 l l' n : n < length l ->
    nth_error (l++l') n = nth_error l n.
  Proof.
    revert l.
    induction n; intros [|a l] H; auto; try solve [inversion H].
    simpl in *. apply IHn. auto with arith.
  Qed.

  Lemma nth_error_app2 l l' n : length l <= n ->
    nth_error (l++l') n = nth_error l' (n-length l).
  Proof.
    revert l.
    induction n; intros [|a l] H; auto; try solve [inversion H].
    simpl in *. apply IHn. auto with arith.
  Qed.

  (****************************************)
  (** ** Counting occurences of a element *)
  (****************************************)

  Fixpoint count_occ (l : list A) (x : A) : nat :=
    match l with
      | [] => 0
      | y :: tl =>
        let n := count_occ tl x in
        if eq_dec y x then S n else n
    end.

  (** Compatibility of count_occ with operations on list *)
  Theorem count_occ_In l x : In x l <-> count_occ l x > 0.
  Proof.
    induction l as [|y l]; simpl.
    - split; [destruct 1 | apply gt_irrefl].
    - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition.
  Qed.

  Theorem count_occ_not_In l x : ~ In x l <-> count_occ l x = 0.
  Proof.
    rewrite count_occ_In. unfold gt. now rewrite Nat.nlt_ge, Nat.le_0_r.
  Qed.

  Lemma count_occ_nil x : count_occ [] x = 0.
  Proof.
    reflexivity.
  Qed.

  Theorem count_occ_inv_nil l :
    (forall x:A, count_occ l x = 0) <-> l = [].
  Proof.
    split.
    - induction l as [|x l]; trivial.
      intros H. specialize (H x). simpl in H.
      destruct eq_dec as [_|NEQ]; [discriminate|now elim NEQ].
    - now intros ->.
  Qed.

  Lemma count_occ_cons_eq l x y :
    x = y -> count_occ (x::l) y = S (count_occ l y).
  Proof.
    intros H. simpl. now destruct (eq_dec x y).
  Qed.

  Lemma count_occ_cons_neq l x y :
    x <> y -> count_occ (x::l) y = count_occ l y.
  Proof.
    intros H. simpl. now destruct (eq_dec x y).
  Qed.

End Elts.

(*******************************)
(** * Manipulating whole lists *)
(*******************************)

Section ListOps.

  Variable A : Type.

  (*************************)
  (** ** Reverse           *)
  (*************************)

  Fixpoint rev (l:list A) : list A :=
    match l with
      | [] => []
      | x :: l' => rev l' ++ [x]
    end.

  Lemma rev_app_distr : forall x y:list A, rev (x ++ y) = rev y ++ rev x.
  Proof.
    induction x as [| a l IHl].
    destruct y as [| a l].
    simpl.
    auto.

    simpl.
    rewrite app_nil_r; auto.

    intro y.
    simpl.
    rewrite (IHl y).
    rewrite app_assoc; trivial.
  Qed.

  Remark rev_unit : forall (l:list A) (a:A), rev (l ++ [a]) = a :: rev l.
  Proof.
    intros.
    apply (rev_app_distr l [a]); simpl; auto.
  Qed.

  Lemma rev_involutive : forall l:list A, rev (rev l) = l.
  Proof.
    induction l as [| a l IHl].
    simpl; auto.

    simpl.
    rewrite (rev_unit (rev l) a).
    rewrite IHl; auto.
  Qed.

  (** Compatibility with other operations *)

  Lemma in_rev : forall l x, In x l <-> In x (rev l).
  Proof.
    induction l.
    simpl; intuition.
    intros.
    simpl.
    intuition.
    subst.
    apply in_or_app; right; simpl; auto.
    apply in_or_app; left; firstorder.
    destruct (in_app_or _ _ _ H); firstorder.
  Qed.

  Lemma rev_length : forall l, length (rev l) = length l.
  Proof.
    induction l;simpl; auto.
    rewrite app_length.
    rewrite IHl.
    simpl.
    elim (length l); simpl; auto.
  Qed.

  Lemma rev_nth : forall l d n,  n < length l ->
    nth n (rev l) d = nth (length l - S n) l d.
  Proof.
    induction l.
    intros; inversion H.
    intros.
    simpl in H.
    simpl (rev (a :: l)).
    simpl (length (a :: l) - S n).
    inversion H.
    rewrite <- minus_n_n; simpl.
    rewrite <- rev_length.
    rewrite app_nth2; auto.
    rewrite <- minus_n_n; auto.
    rewrite app_nth1; auto.
    rewrite (minus_plus_simpl_l_reverse (length l) n 1).
    replace (1 + length l) with (S (length l)); auto with arith.
    rewrite <- minus_Sn_m; auto with arith.
    apply IHl ; auto with arith.
    rewrite rev_length; auto.
  Qed.

  (**  An alternative tail-recursive definition for reverse *)

  Fixpoint rev_append (l l': list A) : list A :=
    match l with
      | [] => l'
      | a::l => rev_append l (a::l')
    end.

  Definition rev' l : list A := rev_append l [].

  Lemma rev_append_rev : forall l l', rev_append l l' = rev l ++ l'.
  Proof.
    induction l; simpl; auto; intros.
    rewrite <- app_assoc; firstorder.
  Qed.

  Lemma rev_alt : forall l, rev l = rev_append l [].
  Proof.
    intros; rewrite rev_append_rev.
    rewrite app_nil_r; trivial.
  Qed.

(*********************************************)
(** Reverse Induction Principle on Lists  *)
(*********************************************)

  Section Reverse_Induction.

    Lemma rev_list_ind :
      forall P:list A-> Prop,
	P [] ->
	(forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
	forall l:list A, P (rev l).
    Proof.
      induction l; auto.
    Qed.

    Theorem rev_ind :
      forall P:list A -> Prop,
	P [] ->
	(forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l.
    Proof.
      intros.
      generalize (rev_involutive l).
      intros E; rewrite <- E.
      apply (rev_list_ind P).
      auto.

      simpl.
      intros.
      apply (H0 a (rev l0)).
      auto.
    Qed.

  End Reverse_Induction.

  (*************************)
  (** ** Concatenation     *)
  (*************************)

  Fixpoint concat (l : list (list A)) : list A :=
  match l with
  | nil => nil
  | cons x l => x ++ concat l
  end.

  Lemma concat_nil : concat nil = nil.
  Proof.
  reflexivity.
  Qed.

  Lemma concat_cons : forall x l, concat (cons x l) = x ++ concat l.
  Proof.
  reflexivity.
  Qed.

  Lemma concat_app : forall l1 l2, concat (l1 ++ l2) = concat l1 ++ concat l2.
  Proof.
  intros l1; induction l1 as [|x l1 IH]; intros l2; simpl.
  + reflexivity.
  + rewrite IH; apply app_assoc.
  Qed.

  (***********************************)
  (** ** Decidable equality on lists *)
  (***********************************)

  Hypothesis eq_dec : forall (x y : A), {x = y}+{x <> y}.

  Lemma list_eq_dec : forall l l':list A, {l = l'} + {l <> l'}.
  Proof. decide equality. Defined.

End ListOps.

(************************************)
(** Left-to-right iterator on lists *)
(************************************)

Section Fold_Left_Recursor.
  Variables (A : Type) (B : Type).
  Variable f : A -> B -> A.

  Fixpoint fold_left (l:list B) (a0:A) : A :=
    match l with
      | nil => a0
      | cons b t => fold_left t (f a0 b)
    end.

  Lemma fold_left_app : forall (l l':list B)(i:A),
    fold_left (l++l') i = fold_left l' (fold_left l i).
  Proof.
    induction l.
    simpl; auto.
    intros.
    simpl.
    auto.
  Qed.

End Fold_Left_Recursor.

Lemma fold_left_length :
  forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l.
Proof.
  intros A l.
  enough (H : forall n, fold_left (fun x _ => S x) l n = n + length l) by exact (H 0).
  induction l; simpl; auto.
  intros; rewrite IHl.
  simpl; auto with arith.
Qed.

(************************************)
(** Right-to-left iterator on lists *)
(************************************)

Section Fold_Right_Recursor.
  Variables (A : Type) (B : Type).
  Variable f : B -> A -> A.
  Variable a0 : A.

  Fixpoint fold_right (l:list B) : A :=
    match l with
      | nil => a0
      | cons b t => f b (fold_right t)
    end.

End Fold_Right_Recursor.

  Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i,
    fold_right f i (l++l') = fold_right f (fold_right f i l') l.
  Proof.
    induction l.
    simpl; auto.
    simpl; intros.
    f_equal; auto.
  Qed.

  Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i,
    fold_right f i (rev l) = fold_left (fun x y => f y x) l i.
  Proof.
    induction l.
    simpl; auto.
    intros.
    simpl.
    rewrite fold_right_app; simpl; auto.
  Qed.

  Theorem fold_symmetric :
    forall (A : Type) (f : A -> A -> A),
    (forall x y z : A, f x (f y z) = f (f x y) z) ->
    forall (a0 : A), (forall y : A, f a0 y = f y a0) ->
    forall (l : list A), fold_left f l a0 = fold_right f a0 l.
  Proof.
    intros A f assoc a0 comma0 l.
    induction l as [ | a1 l ]; [ simpl; reflexivity | ].
    simpl. rewrite <- IHl. clear IHl. revert a1. induction l; [ auto | ].
    simpl. intro. rewrite <- assoc. rewrite IHl. rewrite IHl. auto.
  Qed.

  (** [(list_power x y)] is [y^x], or the set of sequences of elts of [y]
      indexed by elts of [x], sorted in lexicographic order. *)

  Fixpoint list_power (A B:Type)(l:list A) (l':list B) :
    list (list (A * B)) :=
    match l with
      | nil => cons nil nil
      | cons x t =>
	flat_map (fun f:list (A * B) => map (fun y:B => cons (x, y) f) l')
        (list_power t l')
    end.

  (*************************************)
  (** ** Boolean operations over lists *)
  (*************************************)

  Section Bool.
    Variable A : Type.
    Variable f : A -> bool.

  (** find whether a boolean function can be satisfied by an
       elements of the list. *)

    Fixpoint existsb (l:list A) : bool :=
      match l with
	| nil => false
	| a::l => f a || existsb l
      end.

    Lemma existsb_exists :
      forall l, existsb l = true <-> exists x, In x l /\ f x = true.
    Proof.
      induction l; simpl; intuition.
      inversion H.
      firstorder.
      destruct (orb_prop _ _ H1); firstorder.
      firstorder.
      subst.
      rewrite H2; auto.
    Qed.

    Lemma existsb_nth : forall l n d, n < length l ->
      existsb l = false -> f (nth n l d) = false.
    Proof.
      induction l.
      inversion 1.
      simpl; intros.
      destruct (orb_false_elim _ _ H0); clear H0; auto.
      destruct n ; auto.
      rewrite IHl; auto with arith.
    Qed.

    Lemma existsb_app : forall l1 l2,
      existsb (l1++l2) = existsb l1 || existsb l2.
    Proof.
      induction l1; intros l2; simpl.
        solve[auto].
      case (f a); simpl; solve[auto].
    Qed.

  (** find whether a boolean function is satisfied by
    all the elements of a list. *)

    Fixpoint forallb (l:list A) : bool :=
      match l with
	| nil => true
	| a::l => f a && forallb l
      end.

    Lemma forallb_forall :
      forall l, forallb l = true <-> (forall x, In x l -> f x = true).
    Proof.
      induction l; simpl; intuition.
      destruct (andb_prop _ _ H1).
      congruence.
      destruct (andb_prop _ _ H1); auto.
      assert (forallb l = true).
      apply H0; intuition.
      rewrite H1; auto.
    Qed.

    Lemma forallb_app :
      forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2.
    Proof.
      induction l1; simpl.
        solve[auto].
      case (f a); simpl; solve[auto].
    Qed.
(*  (** [filter] *)

    Fixpoint filter (l:list A) : list A :=
      match l with
	| nil => nil
	| x :: l => if f x then x::(filter l) else filter l
      end.

    Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true.
    Proof.
      induction l; simpl.
      intuition.
      intros.
      case_eq (f a); intros; simpl; intuition congruence.
    Qed.*)

  (** [find] *)

    Fixpoint find (l:list A) : option A :=
      match l with
	| nil => None
	| x :: tl => if f x then Some x else find tl
      end.

    Lemma find_some l x : find l = Some x -> In x l /\ f x = true.
    Proof.
     induction l as [|a l IH]; simpl; [easy| ].
     case_eq (f a); intros Ha Eq.
     * injection Eq as ->; auto.
     * destruct (IH Eq); auto.
    Qed.

    Lemma find_none l : find l = None -> forall x, In x l -> f x = false.
    Proof.
     induction l as [|a l IH]; simpl; [easy|].
     case_eq (f a); intros Ha Eq x IN; [easy|].
     destruct IN as [<-|IN]; auto.
    Qed.

  (** [partition] *)

    Fixpoint partition (l:list A) : list A * list A :=
      match l with
	| nil => (nil, nil)
	| x :: tl => let (g,d) := partition tl in
	  if f x then (x::g,d) else (g,x::d)
      end.

  Theorem partition_cons1 a l l1 l2:
    partition l = (l1, l2) ->
    f a = true ->
    partition (a::l) = (a::l1, l2).
  Proof.
    simpl. now intros -> ->.
  Qed.

  Theorem partition_cons2 a l l1 l2:
    partition l = (l1, l2) ->
    f a=false ->
    partition (a::l) = (l1, a::l2).
  Proof.
    simpl. now intros -> ->.
  Qed.

  Theorem partition_length l l1 l2:
    partition l = (l1, l2) ->
    length l = length l1 + length l2.
  Proof.
    revert l1 l2. induction l as [ | a l' Hrec]; intros l1 l2.
    - now intros [= <- <- ].
    - simpl. destruct (f a), (partition l') as (left, right);
      intros [= <- <- ]; simpl; rewrite (Hrec left right); auto.
  Qed.

  Theorem partition_inv_nil (l : list A):
    partition l = ([], []) <-> l = [].
  Proof.
    split.
    - destruct l as [|a l' _].
      * intuition.
      * simpl. destruct (f a), (partition l'); now intros [= -> ->].
    - now intros ->.
  Qed.

  Theorem elements_in_partition l l1 l2:
    partition l = (l1, l2) ->
    forall x:A, In x l <-> In x l1 \/ In x l2.
  Proof.
    revert l1 l2. induction l as [| a l' Hrec]; simpl; intros l1 l2 Eq x.
    - injection Eq as <- <-. tauto.
    - destruct (partition l') as (left, right).
      specialize (Hrec left right eq_refl x).
      destruct (f a); injection Eq as <- <-; simpl; tauto.
  Qed.

  End Bool.

  (******************************************************)
  (** ** Operations on lists of pairs or lists of lists *)
  (******************************************************)

  Section ListPairs.
    Variables (A : Type) (B : Type).

  (** [split] derives two lists from a list of pairs *)

    Fixpoint split (l:list (A*B)) : list A * list B :=
      match l with
	| [] => ([], [])
	| (x,y) :: tl => let (left,right) := split tl in (x::left, y::right)
      end.

    Lemma in_split_l : forall (l:list (A*B))(p:A*B),
      In p l -> In (fst p) (fst (split l)).
    Proof.
      induction l; simpl; intros; auto.
      destruct p; destruct a; destruct (split l); simpl in *.
      destruct H.
      injection H; auto.
      right; apply (IHl (a0,b) H).
    Qed.

    Lemma in_split_r : forall (l:list (A*B))(p:A*B),
      In p l -> In (snd p) (snd (split l)).
    Proof.
      induction l; simpl; intros; auto.
      destruct p; destruct a; destruct (split l); simpl in *.
      destruct H.
      injection H; auto.
      right; apply (IHl (a0,b) H).
    Qed.

    Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B),
      nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)).
    Proof.
      induction l.
      destruct n; destruct d; simpl; auto.
      destruct n; destruct d; simpl; auto.
      destruct a; destruct (split l); simpl; auto.
      destruct a; destruct (split l); simpl in *; auto.
      apply IHl.
    Qed.

    Lemma split_length_l : forall (l:list (A*B)),
      length (fst (split l)) = length l.
    Proof.
      induction l; simpl; auto.
      destruct a; destruct (split l); simpl; auto.
    Qed.

    Lemma split_length_r : forall (l:list (A*B)),
      length (snd (split l)) = length l.
    Proof.
      induction l; simpl; auto.
      destruct a; destruct (split l); simpl; auto.
    Qed.

  (** [combine] is the opposite of [split].
      Lists given to [combine] are meant to be of same length.
      If not, [combine] stops on the shorter list *)

    Fixpoint combine (l : list A) (l' : list B) : list (A*B) :=
      match l,l' with
	| x::tl, y::tl' => (x,y)::(combine tl tl')
	| _, _ => nil
      end.

    Lemma split_combine : forall (l: list (A*B)),
      let (l1,l2) := split l in combine l1 l2 = l.
    Proof.
      induction l.
      simpl; auto.
      destruct a; simpl.
      destruct (split l); simpl in *.
      f_equal; auto.
    Qed.

    Lemma combine_split : forall (l:list A)(l':list B), length l = length l' ->
      split (combine l l') = (l,l').
    Proof.
      induction l; destruct l'; simpl; intros; auto; try discriminate.
      injection H; clear H; intros.
      rewrite IHl; auto.
    Qed.

    Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B),
      In (x,y) (combine l l') -> In x l.
    Proof.
      induction l.
      simpl; auto.
      destruct l'; simpl; auto; intros.
      contradiction.
      destruct H.
      injection H; auto.
      right; apply IHl with l' y; auto.
    Qed.

    Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B),
      In (x,y) (combine l l') -> In y l'.
    Proof.
      induction l.
      simpl; intros; contradiction.
      destruct l'; simpl; auto; intros.
      destruct H.
      injection H; auto.
      right; apply IHl with x; auto.
    Qed.

    Lemma combine_length : forall (l:list A)(l':list B),
      length (combine l l') = min (length l) (length l').
    Proof.
      induction l.
      simpl; auto.
      destruct l'; simpl; auto.
    Qed.

    Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B),
      length l = length l' ->
      nth n (combine l l') (x,y) = (nth n l x, nth n l' y).
    Proof.
      induction l; destruct l'; intros; try discriminate.
      destruct n; simpl; auto.
      destruct n; simpl in *; auto.
    Qed.

  (** [list_prod] has the same signature as [combine], but unlike
     [combine], it adds every possible pairs, not only those at the
     same position. *)

    Fixpoint list_prod (l:list A) (l':list B) :
      list (A * B) :=
      match l with
	| nil => nil
	| cons x t => (map (fun y:B => (x, y)) l')++(list_prod t l')
      end.

    Lemma in_prod_aux :
      forall (x:A) (y:B) (l:list B),
	In y l -> In (x, y) (map (fun y0:B => (x, y0)) l).
    Proof.
      induction l;
	[ simpl; auto
	  | simpl; destruct 1 as [H1| ];
	    [ left; rewrite H1; trivial | right; auto ] ].
    Qed.

    Lemma in_prod :
      forall (l:list A) (l':list B) (x:A) (y:B),
	In x l -> In y l' -> In (x, y) (list_prod l l').
    Proof.
      induction l;
	[ simpl; tauto
	  | simpl; intros; apply in_or_app; destruct H;
	    [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ].
    Qed.

    Lemma in_prod_iff :
      forall (l:list A)(l':list B)(x:A)(y:B),
	In (x,y) (list_prod l l') <-> In x l /\ In y l'.
    Proof.
      split; [ | intros; apply in_prod; intuition ].
      induction l; simpl; intros.
      intuition.
      destruct (in_app_or _ _ _ H); clear H.
      destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_).
      destruct (H1 H0) as (z,(H2,H3)); clear H0 H1.
      injection H2; clear H2; intros; subst; intuition.
      intuition.
    Qed.

    Lemma prod_length : forall (l:list A)(l':list B),
      length (list_prod l l') = (length l) * (length l').
    Proof.
      induction l; simpl; auto.
      intros.
      rewrite app_length.
      rewrite map_length.
      auto.
    Qed.

  End ListPairs.

(*****************************************)
(** * Miscellaneous operations on lists  *)
(*****************************************)

(******************************)
(** ** Length order of lists  *)
(******************************)

Section length_order.
  Variable A : Type.

  Definition lel (l m:list A) := length l <= length m.

  Variables a b : A.
  Variables l m n : list A.

  Lemma lel_refl : lel l l.
  Proof.
    unfold lel; auto with arith.
  Qed.

  Lemma lel_trans : lel l m -> lel m n -> lel l n.
  Proof.
    unfold lel; intros.
    now_show (length l <= length n).
    apply le_trans with (length m); auto with arith.
  Qed.

  Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m).
  Proof.
    unfold lel; simpl; auto with arith.
  Qed.

  Lemma lel_cons : lel l m -> lel l (b :: m).
  Proof.
    unfold lel; simpl; auto with arith.
  Qed.

  Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m.
  Proof.
    unfold lel; simpl; auto with arith.
  Qed.

  Lemma lel_nil : forall l':list A, lel l' nil -> nil = l'.
  Proof.
    intro l'; elim l'; auto with arith.
    intros a' y H H0.
    now_show (nil = a' :: y).
    absurd (S (length y) <= 0); auto with arith.
  Qed.
End length_order.

Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons:
  datatypes v62.

(******************************)
(** ** Set inclusion on list  *)
(******************************)

Section SetIncl.

  Variable A : Type.

  Definition incl (l m:list A) := forall a:A, In a l -> In a m.
  Hint Unfold incl.

  Lemma incl_refl : forall l:list A, incl l l.
  Proof.
    auto.
  Qed.
  Hint Resolve incl_refl.

  Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_tl.

  Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n.
  Proof.
    auto.
  Qed.

  Lemma incl_appl : forall l m n:list A, incl l n -> incl l (n ++ m).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_appl.

  Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_appr.

  Lemma incl_cons :
    forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m.
  Proof.
    unfold incl; simpl; intros a l m H H0 a0 H1.
    now_show (In a0 m).
    elim H1.
    now_show (a = a0 -> In a0 m).
    elim H1; auto; intro H2.
    now_show (a = a0 -> In a0 m).
    elim H2; auto. (* solves subgoal *)
    now_show (In a0 l -> In a0 m).
    auto.
  Qed.
  Hint Resolve incl_cons.

  Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n.
  Proof.
    unfold incl; simpl; intros l m n H H0 a H1.
    now_show (In a n).
    elim (in_app_or _ _ _ H1); auto.
  Qed.
  Hint Resolve incl_app.

End SetIncl.

Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons
  incl_app: datatypes v62.

(**************************************)
(** * Cutting a list at some position *)
(**************************************)

Section Cutting.

  Variable A : Type.

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

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

  Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l.
  Proof.
    induction n.
    simpl; auto.
    destruct l; simpl; auto.
    f_equal; auto.
  Qed.

  Lemma firstn_length : forall n l, length (firstn n l) = min n (length l).
  Proof.
    induction n; destruct l; simpl; auto.
  Qed.

   Lemma removelast_firstn : forall n l, n < length l ->
     removelast (firstn (S n) l) = firstn n l.
   Proof.
     induction n; destruct l.
     simpl; auto.
     simpl; auto.
     simpl; auto.
     intros.
     simpl in H.
     change (firstn (S (S n)) (a::l)) with ((a::nil)++firstn (S n) l).
     change (firstn (S n) (a::l)) with (a::firstn n l).
     rewrite removelast_app.
     rewrite IHn; auto with arith.

     clear IHn; destruct l; simpl in *; try discriminate.
     inversion_clear H.
     inversion_clear H0.
   Qed.

   Lemma firstn_removelast : forall n l, n < length l ->
     firstn n (removelast l) = firstn n l.
   Proof.
     induction n; destruct l.
     simpl; auto.
     simpl; auto.
     simpl; auto.
     intros.
     simpl in H.
     change (removelast (a :: l)) with (removelast ((a::nil)++l)).
     rewrite removelast_app.
     simpl; f_equal; auto with arith.
     intro H0; rewrite H0 in H; inversion_clear H; inversion_clear H1.
   Qed.

End Cutting.

(**********************************************************************)
(** ** Predicate for List addition/removal (no need for decidability) *)
(**********************************************************************)

Section Add.

  Variable A : Type.

  (* [Add a l l'] means that [l'] is exactly [l], with [a] added
     once somewhere *)
  Inductive Add (a:A) : list A -> list A -> Prop :=
    | Add_head l : Add a l (a::l)
    | Add_cons x l l' : Add a l l' -> Add a (x::l) (x::l').

  Lemma Add_app a l1 l2 : Add a (l1++l2) (l1++a::l2).
  Proof.
   induction l1; simpl; now constructor.
  Qed.

  Lemma Add_split a l l' :
    Add a l l' -> exists l1 l2, l = l1++l2 /\ l' = l1++a::l2.
  Proof.
   induction 1.
   - exists nil; exists l; split; trivial.
   - destruct IHAdd as (l1 & l2 & Hl & Hl').
     exists (x::l1); exists l2; split; simpl; f_equal; trivial.
  Qed.

  Lemma Add_in a l l' : Add a l l' ->
   forall x, In x l' <-> In x (a::l).
  Proof.
   induction 1; intros; simpl in *; rewrite ?IHAdd; tauto.
  Qed.

  Lemma Add_length a l l' : Add a l l' -> length l' = S (length l).
  Proof.
   induction 1; simpl; auto with arith.
  Qed.

  Lemma Add_inv a l : In a l -> exists l', Add a l' l.
  Proof.
   intro Ha. destruct (in_split _ _ Ha) as (l1 & l2 & ->).
   exists (l1 ++ l2). apply Add_app.
  Qed.

  Lemma incl_Add_inv a l u v :
    ~In a l -> incl (a::l) v -> Add a u v -> incl l u.
  Proof.
   intros Ha H AD y Hy.
   assert (Hy' : In y (a::u)).
   { rewrite <- (Add_in AD). apply H; simpl; auto. }
   destruct Hy'; [ subst; now elim Ha | trivial ].
  Qed.

End Add.

Section Exists_Forall.

  (** * Existential and universal predicates over lists *)

  Variable A:Type.

  Section One_predicate.

    Variable P:A->Prop.

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

    Hint Constructors Exists.

    Lemma Exists_exists (l:list A) :
      Exists l <-> (exists x, In x l /\ P x).
    Proof.
      split.
      - induction 1; firstorder.
      - induction l; firstorder; subst; auto.
    Qed.

    Lemma Exists_nil : Exists nil <-> False.
    Proof. split; inversion 1. Qed.

    Lemma Exists_cons x l:
      Exists (x::l) <-> P x \/ Exists l.
    Proof. split; inversion 1; auto. Qed.

    Lemma Exists_dec l:
      (forall x:A, {P x} + { ~ P x }) ->
      {Exists l} + {~ Exists l}.
    Proof.
      intro Pdec. induction l as [|a l' Hrec].
      - right. now rewrite Exists_nil.
      - destruct Hrec as [Hl'|Hl'].
        * left. now apply Exists_cons_tl.
        * destruct (Pdec a) as [Ha|Ha].
          + left. now apply Exists_cons_hd.
          + right. now inversion_clear 1.
    Qed.

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

    Hint Constructors Forall.

    Lemma Forall_forall (l:list A):
      Forall l <-> (forall x, In x l -> P x).
    Proof.
      split.
      - induction 1; firstorder; subst; auto.
      - induction l; firstorder.
    Qed.

    Lemma Forall_inv : forall (a:A) l, Forall (a :: l) -> P a.
    Proof.
      intros; inversion H; trivial.
    Qed.

    Lemma Forall_rect : forall (Q : list A -> Type),
      Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall l -> Q l.
    Proof.
      intros Q H H'; induction l; intro; [|eapply H', Forall_inv]; eassumption.
    Qed.

    Lemma Forall_dec :
      (forall x:A, {P x} + { ~ P x }) ->
      forall l:list A, {Forall l} + {~ Forall l}.
    Proof.
      intro Pdec. induction l as [|a l' Hrec].
      - left. apply Forall_nil.
      - destruct Hrec as [Hl'|Hl'].
        + destruct (Pdec a) as [Ha|Ha].
          * left. now apply Forall_cons.
          * right. now inversion_clear 1.
        + right. now inversion_clear 1.
    Qed.

  End One_predicate.

  Lemma Forall_Exists_neg (P:A->Prop)(l:list A) :
   Forall (fun x => ~ P x) l <-> ~(Exists P l).
  Proof.
   rewrite Forall_forall, Exists_exists. firstorder.
  Qed.

  Lemma Exists_Forall_neg (P:A->Prop)(l:list A) :
    (forall x, P x \/ ~P x) ->
    Exists (fun x => ~ P x) l <-> ~(Forall P l).
  Proof.
   intro Dec.
   split.
   - rewrite Forall_forall, Exists_exists; firstorder.
   - intros NF.
     induction l as [|a l IH].
     + destruct NF. constructor.
     + destruct (Dec a) as [Ha|Ha].
       * apply Exists_cons_tl, IH. contradict NF. now constructor.
       * now apply Exists_cons_hd.
  Qed.

  Lemma Forall_Exists_dec (P:A->Prop) :
    (forall x:A, {P x} + { ~ P x }) ->
    forall l:list A,
    {Forall P l} + {Exists (fun x => ~ P x) l}.
  Proof.
    intros Pdec l.
    destruct (Forall_dec P Pdec l); [left|right]; trivial.
    apply Exists_Forall_neg; trivial.
    intro x. destruct (Pdec x); [now left|now right].
  Qed.

  Lemma Forall_impl : forall (P Q : A -> Prop), (forall a, P a -> Q a) ->
    forall l, Forall P l -> Forall Q l.
  Proof.
    intros P Q H l. rewrite !Forall_forall. firstorder.
  Qed.

End Exists_Forall.

Hint Constructors Exists.
Hint Constructors Forall.

Section Forall2.

  (** [Forall2]: stating that elements of two lists are pairwise related. *)

  Variables A B : Type.
  Variable R : A -> B -> Prop.

  Inductive Forall2 : list A -> list B -> Prop :=
    | Forall2_nil : Forall2 [] []
    | Forall2_cons : forall x y l l',
      R x y -> Forall2 l l' -> Forall2 (x::l) (y::l').

  Hint Constructors Forall2.

  Theorem Forall2_refl : Forall2 [] [].
  Proof. intros; apply Forall2_nil. Qed.

  Theorem Forall2_app_inv_l : forall l1 l2 l',
    Forall2 (l1 ++ l2) l' ->
    exists l1' l2', Forall2 l1 l1' /\ Forall2 l2 l2' /\ l' = l1' ++ l2'.
  Proof.
    induction l1; intros.
      exists [], l'; auto.
      simpl in H; inversion H; subst; clear H.
      apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->).
      exists (y::l1'), l2'; simpl; auto.
  Qed.

  Theorem Forall2_app_inv_r : forall l1' l2' l,
    Forall2 l (l1' ++ l2') ->
    exists l1 l2, Forall2 l1 l1' /\ Forall2 l2 l2' /\ l = l1 ++ l2.
  Proof.
    induction l1'; intros.
      exists [], l; auto.
      simpl in H; inversion H; subst; clear H.
      apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->).
      exists (x::l1), l2; simpl; auto.
  Qed.

  Theorem Forall2_app : forall l1 l2 l1' l2',
    Forall2 l1 l1' -> Forall2 l2 l2' -> Forall2 (l1 ++ l2) (l1' ++ l2').
  Proof.
    intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto.
  Qed.
End Forall2.

Hint Constructors Forall2.

Section ForallPairs.

  (** [ForallPairs] : specifies that a certain relation should
    always hold when inspecting all possible pairs of elements of a list. *)

  Variable A : Type.
  Variable R : A -> A -> Prop.

  Definition ForallPairs l :=
    forall a b, In a l -> In b l -> R a b.

  (** [ForallOrdPairs] : we still check a relation over all pairs
     of elements of a list, but now the order of elements matters. *)

  Inductive ForallOrdPairs : list A -> Prop :=
    | FOP_nil : ForallOrdPairs nil
    | FOP_cons : forall a l,
      Forall (R a) l -> ForallOrdPairs l -> ForallOrdPairs (a::l).

  Hint Constructors ForallOrdPairs.

  Lemma ForallOrdPairs_In : forall l,
    ForallOrdPairs l ->
    forall x y, In x l -> In y l -> x=y \/ R x y \/ R y x.
  Proof.
    induction 1.
    inversion 1.
    simpl; destruct 1; destruct 1; repeat subst; auto.
    right; left. apply -> Forall_forall; eauto.
    right; right. apply -> Forall_forall; eauto.
  Qed.

  (** [ForallPairs] implies [ForallOrdPairs]. The reverse implication is true
    only when [R] is symmetric and reflexive. *)

  Lemma ForallPairs_ForallOrdPairs l: ForallPairs l -> ForallOrdPairs l.
  Proof.
    induction l; auto. intros H.
    constructor.
    apply <- Forall_forall. intros; apply H; simpl; auto.
    apply IHl. red; intros; apply H; simpl; auto.
  Qed.

  Lemma ForallOrdPairs_ForallPairs :
    (forall x, R x x) ->
    (forall x y, R x y -> R y x) ->
    forall l, ForallOrdPairs l -> ForallPairs l.
  Proof.
    intros Refl Sym l Hl x y Hx Hy.
    destruct (ForallOrdPairs_In Hl _ _ Hx Hy); subst; intuition.
  Qed.
End ForallPairs.

(** * Inversion of predicates over lists based on head symbol *)

Ltac is_list_constr c :=
 match c with
  | nil => idtac
  | (_::_) => idtac
  | _ => fail
 end.

Ltac invlist f :=
 match goal with
  | H:f ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | _ => idtac
 end.

(** * Exporting hints and tactics *)

Hint Rewrite
  rev_involutive (* rev (rev l) = l *)
  rev_unit (* rev (l ++ a :: nil) = a :: rev l *)
  map_nth (* nth n (map f l) (f d) = f (nth n l d) *)
  map_length (* length (map f l) = length l *)
  seq_length (* length (seq start len) = len *)
  app_length (* length (l ++ l') = length l + length l' *)
  rev_length (* length (rev l) = length l *)
  app_nil_r (* l ++ nil = l *)
  : list.

Ltac simpl_list := autorewrite with list.
Ltac ssimpl_list := autorewrite with list using simpl.

(* begin hide *)
(* Compatibility notations after the migration of [list] to [Datatypes] *)
Notation list := list (only parsing).
Notation list_rect := list_rect (only parsing).
Notation list_rec := list_rec (only parsing).
Notation list_ind := list_ind (only parsing).
Notation nil := nil (only parsing).
Notation cons := cons (only parsing).
Notation length := length (only parsing).
Notation app := app (only parsing).
(* Compatibility Names *)
Notation tail := tl (only parsing).
Notation head := hd_error (only parsing).
Notation head_nil := hd_error_nil (only parsing).
Notation head_cons := hd_error_cons (only parsing).
Notation ass_app := app_assoc (only parsing).
Notation app_ass := app_assoc_reverse (only parsing).
Notation In_split := in_split (only parsing).
Notation In_rev := in_rev (only parsing).
Notation In_dec := in_dec (only parsing).
Notation distr_rev := rev_app_distr (only parsing).
Notation rev_acc := rev_append (only parsing).
Notation rev_acc_rev := rev_append_rev (only parsing).
Notation AllS := Forall (only parsing). (* was formerly in TheoryList *)

Hint Resolve app_nil_end : datatypes v62.
(* end hide *)

Section Repeat.

  Variable A : Type.
  Fixpoint repeat (x : A) (n: nat ) :=
    match n with
      | O => []
      | S k => x::(repeat x k)
    end.

  Theorem repeat_length x n:
    length (repeat x n) = n.
  Proof.
    induction n as [| k Hrec]; simpl; rewrite ?Hrec; reflexivity.
  Qed.

  Theorem repeat_spec n x y:
    In y (repeat x n) -> y=x.
  Proof.
    induction n as [|k Hrec]; simpl; destruct 1; auto.
  Qed.

End Repeat.


Require Export Base.
Require Import Classes.Galois List.
Require Import Classes.PreorderedSet.

Implicit Type M : Type → Type.
Implicit Type T : (Type → Type) → Type → Type.
Implicit Type A B C D : Type.

Create HintDb monads.

Class return_op (M : Type → Type) : Type := returnM : ∀ {A}, A → M A.
Class bind_op (M : Type → Type) : Type := bindM : ∀ {A B},
  M A → (A → M B) → M B.

Notation "x >>= y" := (bindM x y) (at level 40, left associativity).
Notation "x '<-' y ; z" := (bindM y (λ x, z))
  (at level 20, y at level 100, z at level 200, only parsing).
Notation "x ;; z" := (bindM x (λ _, z))
    (at level 100, z at level 200, only parsing, right associativity).

Class Monad M {RO : return_op M} {BO : bind_op M} : Type :=
{
  bind_id_left : ∀ {A B} (f : A → M B) (a : A),
    (returnM a) >>= f = f a;
  bind_id_right : ∀ {A} (m : M A),
    m >>= returnM = m;
  bind_assoc : ∀ {A B C} (m : M A) (f : A → M B) (g : B → M C),
    (m >>= f) >>= g = m >>= (λ a, (f a) >>= g);
}.

Class bind2_op (M : Type → Type) {BO : bind_op M} {RO : return_op M} : Type :=
{
  bindM2 : ∀ {A B}, M A → (A → M B) → M B;
  bindM2_return : ∀ {A B} (f : A → M B) (a : A),
    bindM2 (returnM a) f = f a;
}.

Class bind2_op_sound (M M' : Type → Type) `{BO2 : bind2_op M}
  {BO' : bind_op M'}
  {GM : ∀ A A', Galois A A' → Galois (M A) (M' A')} : Type :=
{
  bindM2_sound_l : ∀ {A A' : Type} {GA : Galois A A'}
    (m : M A) (f : A → M A) (f' : A' → M' A') (m' : M' A'),
    γ m m' → γ f f' → γ (bindM2 m f) (bindM m' f');
}.

Class OrderedMonad M {RO : return_op M} {BO : bind_op M}
  {MO : ∀ {A}, PreorderedSet A -> PreorderedSet (M A)} : Type :=
{
  return_monotone : ∀ {A} {PA : PreorderedSet A} (a a' : A),
    a ⊑ a' → returnM a ⊑ returnM a';
  bind_monotone : ∀ {A B} {PA : PreorderedSet A} {PB : PreorderedSet B}
   (m m' : M A) (f f' : A → M B),
   m ⊑ m' →
   monotone f →
   monotone f' →
   (∀ a : A, (f a) ⊑ (f' a)) →
   (m >>= f) ⊑ (m' >>= f');
}.

Class LaxMonad M `{OM : OrderedMonad M} : Type :=
{
  bind_id_left_lax : ∀ {A B} {PA : PreorderedSet A} {PB : PreorderedSet B}
    (f : A → M B) (a : A),
    ((returnM a) >>= f) = (f a);
  bind_id_right_lax : ∀ {A} {PA : PreorderedSet A} (m : M A),
    (m >>= returnM) = m;
  bind_assoc_lax : ∀ {A B C} {PB : PreorderedSet B} {PC : PreorderedSet C}
    (m : M A) (f : A → M B) (g : B → M C),
      ((m >>= f) >>= g) ⊑ (m >>= (λ a, (f a) >>= g));
}.

Arguments bindM : simpl never.
Arguments returnM: simpl never.
Hint Unfold bindM : monads.
Hint Rewrite @bind_id_left @bind_assoc : monads.

Class bind_sound (M M' : Type → Type) {MB : bind_op M} {MB' : bind_op M'}
  {GM : ∀ A A', Galois A A' → Galois (M A) (M' A')} : Prop :=
  bindM_sound : ∀ {A A' B B' : Type} {GA : Galois A A'} {GB : Galois B B'}
    (m : M A) (m' : M' A') (f : A → M B) (f' : A' → M' B'),
    γ m m' → γ f f' → γ (m >>= f) (m' >>= f').
Hint Resolve bindM_sound : soundness.

Class return_sound (M M' : Type → Type) {MR : return_op M} {MR' : return_op M'}
  {GM : ∀ A A', Galois A A' → Galois (M A) (M' A')} : Prop :=
  returnM_sound : ∀ {A A' : Type} {GA : Galois A A'} (a : A) (a' : A'),
    γ a a' →
    γ (returnM a) (returnM a').
Hint Resolve returnM_sound : soundness.

Definition join {M} `{Monad M} {A}
  (mma : M (M A)) : M A :=
  bindM mma id.

Ltac simple_solve := autounfold with monads; intros;
  repeat (simplify;
    autorewrite with monads in * + autounfold with monads in *;
    intros; subst
  );
  try (unfold compose, id, const; contradiction + discriminate + eauto with monads).
Ltac solve_monad := repeat (simplify; simple_solve;
  match goal with
  | |- bindM ?f _ = ?f => rewrite <- bind_id_right; f_equal
  | |- bindM ?f _ = bindM ?f _ => f_equal
  | _ => simple_solve
  end).

Section Identity_Monad.
  Global Instance return_op_id : return_op Identity :=
    λ (A : Type) (a : A), identity a.

  Global Instance bind_op_id : bind_op Identity := λ A B
    (m : Identity A) (f : A → Identity B),
      match m with
      | identity a => f a
      end.
  Arguments return_op_id [A] a.
  Arguments bind_op_id [A B] m f.

  Lemma bind_id_id_left : ∀ (A B : Type) (f : A → Identity B) (a : A),
    bind_op_id (identity a) f = f a.
  Proof. easy. Qed.

  Lemma bind_id_id_right : ∀ (A : Type) (m : Identity A),
    bind_op_id m identity = m.
  Proof.
    intros.
    destruct m; easy.
  Qed.

  Lemma bind_id_assoc : ∀ (A B C : Type) (m : Identity A)
    (f : A → Identity B) (g : B → Identity C),
    bind_op_id (bind_op_id m f) g = bind_op_id m (λ a : A, bind_op_id (f a) g).
  Proof.
    intros.
    destruct m; easy.
  Qed.

  Global Instance monad_identity : Monad Identity :=
  {
    bind_id_left := bind_id_id_left;
    bind_id_right := bind_id_id_right;
    bind_assoc := bind_id_assoc;
  }.

  Global Instance ordered_identity : OrderedMonad Identity.
  Proof.
    split.
    - intros A PA a a' Ha; apply Ha.
    - intros A B PA PB m m' f f' Hm Hf Hf' Hff'.
      unfold bindM, bind_op_id.
      destruct m as [a], m' as [a']; simpl in Hm.
      eapply preorder_trans with (f a'); auto.
  Qed.

  Global Instance return_id_sound :
    return_sound Identity Identity.
  Proof.
    intros A A' GA a a' Ha.
    apply Ha.
  Qed.

  Global Instance bind_id_sound :
    bind_sound Identity Identity.
  Proof.
    intros A A' B B' GA GB m m' f f' Hm Hf.
    destruct m as [a], m' as [a']; cbv.
    unfold γ, galois_identity, gamma_identity in Hm.
    apply Hf in Hm.
    destruct (f a) as [b], (f' a') as [b'].
    apply Hm.
  Qed.
End Identity_Monad.

Section list_monad.
  Definition return_list {A} (a : A) : list A := cons a nil.
  Instance return_op_list : return_op list := @return_list.

  Definition bind_list {A B} (m : list A) (f : A → list B) := flat_map f m.
  Instance bind_op_list : bind_op list := @bind_list.

  Lemma bind_list_id_left : ∀ {A B} (f : A → list B) (a : A),
    bind_list (return_list a) f = f a.
  Proof.
    intros A B f a; unfold bind_list, return_list; simpl.
    rewrite app_nil_r; reflexivity.
  Qed.

  Lemma bind_list_id_right : ∀ {A} (m : list A),
    bind_list m return_list = m.
  Proof.
    intros. unfold bind_list, return_list.
    induction m.
    - easy.
    - simpl; rewrite IHm; reflexivity.
  Qed.

  Lemma flat_map_distr {A B} : ∀ (l l': list A) (f : A → list B),
    flat_map f (l ++ l') = flat_map f l ++ flat_map f l'.
  Proof.
    intros l l' f; generalize dependent l'.
    induction l; intros l'.
    - easy.
    - simpl. rewrite <- app_assoc. rewrite IHl. reflexivity.
  Qed.

  Lemma bind_list_assoc : ∀ {A B C} (m : list A)
    (f : A → list B) (g : B → list C),
    bind_list (bind_list m f) g =
    bind_list m (λ a : A, bind_list (f a) g).
  Proof.
    intros A B C m f g; unfold bind_list.
    induction m; simpl.
    - reflexivity.
    - rewrite <- IHm.
      apply flat_map_distr.
  Qed.

  Global Instance list_monad : Monad list := {
    bind_id_left := @bind_list_id_left;
    bind_id_right := @bind_list_id_right;
    bind_assoc := @bind_list_assoc;
  }.
End list_monad.


From Coq Require Import ZArith Lia.
From stdpp Require Import list.
From machine_utils Require Import finz_base.

(* Automation: a [solve_finz] tactic that solves arithmetic involving [finz] *)

(* This is implemented as a zify-like tactic, that sends arithmetic on adresses
   into Z, and then calls lia *)

(* Faster alternative to [set (H := v) in *] *)
(* https://github.com/coq/coq/issues/13788#issuecomment-767217670 *)
Ltac fast_set H v :=
  pose v as H; change v with H;
  repeat match goal with H' : context[v] |- _ => change v with H in H' end.

Lemma finz_incr_spec (fb : Z) (f : finz fb) (z : Z) :
  (∃ (f': finz fb),
   (f + z)%f = Some f' ∧ f + z < fb ∧ 0 ≤ f + z ∧ (f':Z) = f + z)%Z
  ∨
  ((f + z)%f = None ∧ (f + z >= fb ∨ f + z < 0))%Z.
Proof.
  unfold finz.incr.
  destruct (Z_lt_dec (f + z)%Z fb),(Z_le_dec 0%Z (f + z)%Z); [ left | right; split; auto; try lia..].
  eexists. repeat split; lia.
Qed.

Ltac finz_incr_as_spec f x :=
  generalize (finz_incr_spec _ f x); intros [(?&?&?&?&?)|(?&[?|?])];
  let fx := fresh "fx" in
  fast_set fx (finz.incr f x);
  clearbody fx; subst fx.

(* Non-branching lemma for the special case of an assumption [(a + z) = Some a'],
   which is common in practice. *)
Lemma finz_incr_Some_spec fb (f f' : finz fb) (z : Z) :
  (f + z)%f = Some f' →
  (f + z < fb ∧ 0 ≤ f + z ∧ (f':Z) = f + z)%Z.
Proof.
  unfold finz.incr.
  destruct (Z_lt_dec (f + z)%Z fb),(Z_le_dec 0%Z (f + z)%Z); inversion 1.
  repeat split; lia.
Qed.

Lemma finz_incr_is_Some_spec fb (f : finz fb) (z : Z) :
  (f + z < fb ∧ 0 ≤ f + z)%Z →
  is_Some (f + z)%f.
Proof.
  unfold finz.incr.
  destruct (Z_lt_dec (f + z)%Z fb),(Z_le_dec 0%Z (f + z)%Z); eauto; lia.
Qed.

Lemma finz_incr_Some_prove_spec (fb : Z) (f f' : finz fb) (z: Z) :
  (f + z < fb ∧ 0 ≤ f + z ∧ (f':Z) = f + z)%Z →
  (f + z)%f = Some f'.
Proof.
  unfold finz.incr.
  destruct (Z_lt_dec (f + z)%Z fb),(Z_le_dec 0%Z (f + z)%Z); eauto; try lia.
  intros. apply f_equal. apply finz_to_z_eq. cbn. lia.
Qed.

Lemma finz_incr_default_spec (fb : Z) (f : finz fb) z :
  (0%Z ≤ f + z ∧ f + z < fb ∧ ((f ^+ z)%f:Z) = f + z)%Z ∨
  ((f + z < 0%Z ∨ fb <= f + z) ∧ ((f ^+ z)%f:Z) = finz.largest f)%Z.
Proof.
  unfold finz.incr_default, finz.incr, finz.largest.
  destruct (Z_lt_dec (f + z)%Z fb),(Z_le_dec 0%Z (f + z)%Z); cbn; lia.
Qed.

Ltac finz_incr_default_as_spec f x :=
  generalize (finz_incr_default_spec _ f x); intros ?;
  let fx := fresh "fx" in
  fast_set fx (finz.incr_default f x);
  clearbody fx.

Lemma finz_min_spec fb (f1 f2 : finz fb) :
  ∃ f, finz.min f1 f2 = f ∧ (f : Z) = Z.min (f1 : Z) (f2 : Z).
Proof.
  exists (finz.min f1 f2); split; auto.
  unfold finz.min. case_match. all: unfold finz.leb in *; lia.
Qed.

Ltac finz_min_as_spec f1 f2 :=
  generalize (finz_min_spec _ f1 f2); intros [? [? ?]];
  let fx := fresh "fx" in
  fast_set fx (finz.min f1 f2);
  clearbody fx; subst fx.

Lemma finz_max_spec fb (f1 f2 : finz fb) :
  ∃ f, finz.max f1 f2 = f ∧ (f : Z) = Z.max (f1 : Z) (f2 : Z).
Proof.
  exists (finz.max f1 f2); split; auto.
  unfold finz.max. case_match. all: unfold finz.leb in *; lia.
Qed.

Ltac finz_max_as_spec f1 f2 :=
  generalize (finz_max_spec _ f1 f2); intros [? [? ?]];
  let fx := fresh "fx" in
  fast_set fx (finz.max f1 f2);
  clearbody fx; subst fx.

Lemma finz_mult_Some_spec fb (f f' : finz fb) (z : Z) :
  (f * z)%f = Some f' →
  (f * z < fb ∧ (0 < f ∧ 0 <= z ∨ 0 = f) ∧ (f':Z) = f * z)%Z.
Proof.
  unfold finz.mult.
  destruct (Z_lt_dec (f * z)%Z fb),(Z_le_dec 0%Z (f * z)%Z); inversion 1.
  repeat split;try lia.
  destruct (decide (0 < f)%Z).
  - left;lia.
  - right. destruct f. cbn in *. lia.
Qed.

Lemma finz_mult_is_Some_spec fb (f : finz fb) (z : Z) :
  (f * z < fb ∧ (0 < f ∧ 0 <= z ∨ 0 = f))%Z →
  is_Some (f * z)%f.
Proof.
  unfold finz.mult.
  destruct (Z_lt_dec (f * z)%Z fb),(Z_le_dec 0%Z (f * z)%Z); eauto; try lia.
Qed.

Lemma finz_mult_Some_prove_spec fb (f f': finz fb) (z : Z) :
  (f * z < fb ∧ (0 < f ∧ 0 <= z ∨ 0 = f) ∧ (f':Z) = f * z)%Z →
  (f * z)%f= Some f'.
Proof.
  unfold finz.mult.
  destruct (Z_lt_dec (f * z)%Z fb),(Z_le_dec 0%Z (f * z)%Z); eauto; try lia.
  intros. apply f_equal. apply finz_to_z_eq. cbn. lia.
Qed.

Lemma finz_largest_spec fb (f : finz fb) :
  finz.to_z (finz.largest f) = (fb - 1)%Z.
Proof. reflexivity. Qed.

Ltac finz_largest_as_spec f :=
  generalize (finz_largest_spec _ f); intros ?;
  let fx := fresh "fx" in
  fast_set fx (finz.largest f);
  clearbody fx.

Lemma finz_zero_spec fb (f : finz fb) :
  finz.to_z (finz.zero f) = 0%Z.
Proof. reflexivity. Qed.

Ltac finz_zero_as_spec f :=
  generalize (finz_zero_spec _ f); intros ?;
  let fx := fresh "fx" in
  fast_set fx (finz.zero f);
  clearbody fx.

Lemma finz_of_z_spec fb (z : Z) :
  (∃ (f : finz fb),
    finz.of_z z = Some f ∧ finz.to_z f = z) ∨
  (@finz.of_z fb z = None ∧ (z >= fb ∨ z < 0))%Z.
Proof.
  unfold finz.of_z.
  destruct (Z_lt_dec z fb).
  { destruct (Z_le_dec 0%Z z).
    { left. eexists. split; auto. }
    { right; split; auto; lia. } }
  { right. destruct (Z_le_dec 0%Z z); split; auto; lia. }
Qed.

Ltac finz_of_z_as_spec z :=
  generalize (finz_of_z_spec _ z); intros [[? [? ?]] | [? [?|?]]];
  let o := fresh "o" in
  fast_set o (finz.of_z z);
  clearbody o; subst o.

Lemma finz_of_z_is_Some_spec fb z (f : finz fb) :
  finz.of_z z = Some f →
  finz.to_z f = z.
Proof.
  destruct (finz_of_z_spec fb z) as [[? [? ?]]|[? ?]]; congruence.
Qed.

Lemma finz_of_z_Some_spec z fb (f : finz fb) :
  finz.to_z f = z →
  finz.of_z z = Some f.
Proof.
  intros. destruct (finz_of_z_spec fb z) as [[? [? ?]]|[? ?]].
  all: subst; rewrite finz_of_z_to_z in *; auto.
Qed.

Lemma Some_eq_inj A (x y: A) :
  Some x = Some y ->
  x = y.
Proof. congruence. Qed.

(* Hook for extending the tactic *)
Ltac zify_finz_op_nonbranching_step_hook :=
  fail.

Ltac without_evars c :=
  (has_evar c; fail 1) || idtac.

Ltac zify_finz_op_nonbranching_step :=
  lazymatch goal with
  | |- @eq (finz _) ?f ?f' =>
    apply finz_to_z_eq
  | H : @eq (finz _) ?f ?f' |- _ =>
    apply finz_eq_to_z in H
  | |- not (@eq (finz _) ?f ?f') =>
    apply finz_to_z_neq
  | H : not (@eq (finz _) ?f ?f') |- _ =>
    apply finz_neq_to_z in H
  | |- @eq (option (finz _)) (Some _) (Some _) =>
    f_equal
  | H : @eq (option (finz _)) (Some _) (Some _) |- _ =>
    apply Some_eq_inj in H
  | |- @eq (option (finz _)) (Some _) None =>
    exfalso
  | |- @eq (option (finz _)) None (Some _) =>
    exfalso

  (* wrapper definitions to unfold (<=, <, etc) *)
  | |- context [ finz.le_lt _ _ _ ] =>
    unfold finz.le_lt
  | H : context [ finz.le_lt _ _ _ ] |- _ =>
    unfold finz.le_lt in H
  | |- context [ finz.le _ _ ] =>
    unfold finz.le
  | H : context [ finz.le _ _ ] |- _ =>
    unfold finz.le in H
  | |- context [ finz.leb _ _ ] =>
    unfold finz.leb
  | H : context [ finz.leb _ _ ] |- _ =>
    unfold finz.leb in H
  | |- context [ finz.lt _ _ ] =>
    unfold finz.lt
  | H : context [ finz.lt _ _ ] |- _ =>
    unfold finz.lt in H
  | |- context [ finz.ltb _ _ ] =>
    unfold finz.ltb
  | H : context [ finz.ltb _ _ ] |- _ =>
    unfold finz.ltb in H
  | |- context [ finz.eqb _ _ ] =>
    unfold finz.eqb
  | H : context [ finz.eqb _ _ ] |- _ =>
    unfold finz.eqb in H
  | H : ContiguousRegion _ _ |- _ => unfold ContiguousRegion in H
  | |- ContiguousRegion _ _ => unfold ContiguousRegion
  | H : SubBounds _ _ _ _ |- _ => unfold SubBounds in H
  | |- SubBounds ?b ?e ?b' ?e' =>
    without_evars b; without_evars e; without_evars b'; without_evars e';
    unfold SubBounds
  | H : InBounds _ _ _ |- _ => unfold InBounds in H
  | |- InBounds ?b ?e ?a =>
    without_evars b; without_evars e; without_evars a;
    unfold InBounds

  | H : context [ finz.min ?f1 ?f2 ] |- _ =>
    finz_min_as_spec f1 f2
  | |- context [ finz.min ?f1 ?f2 ] =>
    finz_min_as_spec f1 f2
  | H : context [ finz.max ?f1 ?f2 ] |- _ =>
    finz_max_as_spec f1 f2
  | |- context [ finz.max ?f1 ?f2 ] =>
    finz_max_as_spec f1 f2

  | H : context [ finz.largest ?f ] |- _ =>
    finz_largest_as_spec f
  | |- context [ finz.largest ?f ] =>
    finz_largest_as_spec f

  | H : context [ finz.zero ?f ] |- _ =>
    finz_zero_as_spec f
  | |- context [ finz.zero ?f ] =>
    finz_zero_as_spec f

  | H : context [ finz.incr_default ?f ?x ] |- _ =>
    finz_incr_default_as_spec f x
  | |- context [ finz.incr_default ?f ?x ] =>
    finz_incr_default_as_spec f x

  | H : is_Some (finz.incr _ _) |- _ =>
    destruct H
  | H : finz.incr _ _ = Some _ |- _ =>
    apply finz_incr_Some_spec in H;
    destruct H as (? & ? & ?)
  | |- is_Some (finz.incr _ _) =>
    apply finz_incr_is_Some_spec
  | |- finz.incr _ _ = Some _ =>
    apply finz_incr_Some_prove_spec

  | H : is_Some (finz.mult _ _) |- _ =>
    destruct H
  | H : finz.mult _ _ = Some _ |- _ =>
    apply finz_mult_Some_spec in H;
    destruct H as (? & ? & ?)
  | |- is_Some (finz.mult _ _) =>
    apply finz_mult_is_Some_spec
  | |- finz.mult _ _ = Some _ =>
    apply finz_mult_Some_prove_spec

  | H : finz.of_z _ = Some _ |- _ =>
    apply finz_of_z_is_Some_spec in H
  | |- finz.of_z _ = Some _ =>
    apply finz_of_z_Some_spec

  end || zify_finz_op_nonbranching_step_hook.

(* We need some reduction, but naively calling "cbn in *" causes performance
   problems down the road. So here we try to:
   - give a "good enough" allow-list
   - reduce all occurences of [length foo], because in practice [foo] often
     unfolds to a concrete list of instructions and we want its length to compute.
*)
Ltac solve_finz_cbn :=
  cbn [finz.to_z finz.incr_default finz.mult_default fst snd length];
  simpl length.

Ltac solve_finz_cbn_in_all :=
  cbn [finz.to_z finz.incr_default finz.mult_default fst snd length] in *;
  simpl length in *.

Ltac zify_finz_nonbranching_step :=
  first [ progress solve_finz_cbn_in_all
        | zify_finz_op_nonbranching_step ].

Ltac zify_finz_op_branching_goal_step :=
  lazymatch goal with
  | |- context [ finz.incr ?f ?x ] =>
    finz_incr_as_spec f x
  | |- context [ finz.of_z ?x ] =>
    finz_of_z_as_spec x
  end.

Ltac zify_finz_op_branching_hyps_step :=
  lazymatch goal with
  | _ : context [ finz.incr ?f ?x ] |- _ =>
    finz_incr_as_spec f x
  | _ : context [ finz.of_z ?x ] |- _ =>
    finz_of_z_as_spec x
  end.

Ltac zify_finz_ty_step_on f :=
  generalize (finz_spec f); intros [? ?];
  let z := fresh "z" in
  fast_set z (finz.to_z f);
  clearbody z;
  first [ clear f | revert dependent f ].

Ltac zify_finz_ty_step_var :=
  lazymatch goal with
  | f : finz _ |- _ => zify_finz_ty_step_on f
  end.

Ltac zify_finz_ty_step_subterm :=
  match goal with
  | H : context [ ?x ] |- _ =>
    lazymatch type of x with finz _ =>
      let X := fresh in
      set (X := x) in *;
      zify_finz_ty_step_on X
    end
  end.

Ltac zify_finz_ty_step :=
  first [ zify_finz_ty_step_var | zify_finz_ty_step_subterm ].

(** zify_finz **)
(* This greedily translates all the address-related terms in the goal and in the
   context. Because each (_ + _) introduces a disjunction, the number of goals
   quickly explodes if there are many (_ + _) in the context.

   The solve_finz tactic below is more clever and tries to limit the
   combinatorial explosion, but zify_finz does not. *)

Ltac zify_finz :=
  intros; solve_finz_cbn;
  repeat (first [ zify_finz_nonbranching_step
                | zify_finz_op_branching_goal_step
                | zify_finz_op_branching_hyps_step ]);
  repeat zify_finz_ty_step; intros.

(** solve_finz *)
(* From a high-level perspective, [solve_finz] is equivalent to [zify_finz]
   followed by [lia].

   However, this gets very slow when there are many (_ + _) in the context (and
   some of those may not be relevant to prove the goal at hand), so the
   implementation is a bit more clever. Instead, we try to call [lia] as soon as
   possible to quickly terminate sub-goals than can be proved before the whole
   context gets translated. *)

Ltac zify_finz_op_goal_step :=
  first [ zify_finz_nonbranching_step
        | zify_finz_op_branching_goal_step ].

Ltac zify_finz_op_deepen :=
  zify_finz_op_branching_hyps_step;
  repeat zify_finz_nonbranching_step;
  try (
    zify_finz_op_branching_hyps_step;
    repeat zify_finz_nonbranching_step
  ).

Ltac solve_finz_close_proof :=
  repeat zify_finz_ty_step; intros;
  solve [ auto | lia | congruence ].

Ltac solve_finz :=
  intros; solve_finz_cbn;
  repeat zify_finz_op_goal_step;
  try solve_finz_close_proof;
  repeat (
    zify_finz_op_deepen;
    try solve_finz_close_proof
  );
  solve_finz_close_proof.

Tactic Notation "solve_finz" := solve_finz.
Tactic Notation "solve_finz" "-" hyp_list(Hs) := clear Hs; solve_finz.
Tactic Notation "solve_finz" "+" hyp_list(Hs) := clear -Hs; solve_finz.

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

Goal forall fb (f : finz fb),
    (f + -(f + 3))%f = None.
Proof.
  intros. solve_finz.
Qed.

Goal forall fb (a a' b b' : finz fb),
  (a + 1)%f = Some a' ->
  (b + 1)%f = Some b' ->
  (a + 0)%f = Some a.
Proof.
  intros.
  repeat zify_finz_op_goal_step; [].
  solve_finz_close_proof.
Qed.

Goal forall (word_size : Z) (T : Type) (pid : T) (finz_of : T -> finz word_size),
    (((finz_of pid) ^+ 1) ^+ 1)%f = ((finz_of pid) ^+ 2)%f.
Proof. solve_finz. Qed.

Goal forall fb (f f' : finz fb),
  (f + 15)%f = Some f' →
  finz.of_z (f + 4) = Some (f ^+ 4)%f.
Proof. solve_finz. Qed.

Goal forall (fb : Z) (f : finz fb) (n m : Z),
  (0 <= n)%Z →
  (0 <= m)%Z →
  ((f ^+ n) ^+ m)%f = (f ^+ (n + m)%Z)%f.
Proof. zify_finz;[]. (* only one goal! *) lia. Qed.

Goal forall fb (f1 f2 : finz fb),
  (f1 < f2)%Z ->
  (f2 * 10 = fb)%Z ->
  is_Some (f1 * 10)%f.
Proof.
  intros.
  solve_finz.
Qed.