Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Bool.Bool.
From mathcomp Require Import all_ssreflect.
Require Import PreOrders.
Require Import Types.
Require Import Cover.
Require Import FCL.
Require Import DependentFixpoint.

Set Bullet Behavior "Strict Subproofs".

Delimit Scope it_scope with IT.
Open Scope it_scope.

Delimit Scope alg_scope with ALG.
Open Scope alg_scope.

Import EqNotations.

Notation "[ 'sort' c <= d ]" := (lessOrEqual c d) (at level 0, c at next level): alg_scope.

Module SignatureFamily.
  Record mixin_of (I: Type) (S: preOrdered) (O: finType): Type :=
    Mixin {
        arity: I -> O -> nat;
        dom: forall i o, (arity i o).-tuple S;
        range: I -> O -> S;
      }.
  Section ClassDef.
    Structure class_of (I: Type) (S: Type) (O: Type) :=
      Class {
          sort_base: PreOrdered.class_of S;
          operation_base: Finite.class_of O;
          mixin: mixin_of I
                   (PreOrdered.Pack S sort_base)
                   (@Finite.Pack O operation_base)
        }.
    Local Coercion operation_base : class_of >-> Finite.class_of.
    Local Coercion sort_base : class_of >-> PreOrdered.class_of.
    Structure type I := Pack { sort_sort : Type; operation_sort: Type; _ : class_of I sort_sort operation_sort }.
    Variables (I: Type) (S: Type) (O: Type) (sigFam: type I).
    Definition class := let: Pack _ _ c as sigFam' := sigFam return class_of I
                                                                             (sort_sort I sigFam')
                                                                             (operation_sort I sigFam')
                        in c.
    Definition clone c of phant_id class c := @Pack S O c.
    Let xSort := (let: Pack S _ _ := sigFam in S).
    Let xOperation := (let: Pack _ O _ := sigFam in O).
    Notation xclass := (class : class_of I xSort xOperation).
    Definition pack b0 b1 (m0: mixin_of I (PreOrdered.Pack S b1) (@Finite.Pack O b0)) :=
      fun bSort bsort & phant_id (PreOrdered.class bSort) bsort =>
        fun bOperation boperation & phant_id (Finite.class bOperation) boperation =>
          fun m & phant_id m0 m => Pack I S O (@Class I S O bsort boperation m).

    Definition operationEqType := Eval hnf in @Equality.Pack xOperation xclass.
    Definition operationChoiceType := Eval hnf in  @Choice.Pack xOperation xclass.
    Definition operationCountType := Eval hnf in  @Countable.Pack xOperation xclass.
    Definition finType := Eval hnf in  @Finite.Pack xOperation xclass.

    Definition sortEqType := Eval hnf in @Equality.Pack xSort (PreOrdered.base _ xclass).
    Definition ctorCountType := Eval hnf in @Countable.Pack xSort (PreOrdered.base _ xclass).
    Definition preOrdered := Eval hnf in  @PreOrdered.Pack xSort xclass.
  End ClassDef.

  Module Import Exports.
    Coercion mixin: class_of >-> mixin_of.
    Coercion preOrdered : type >-> PreOrdered.type.
    Canonical preOrdered.
    Coercion finType: type >-> Finite.type.
    Canonical finType.

    Notation sigFam := type.
    Notation SignatureFamilyMixin := Mixin.
    Notation SignatureFamilyType I S O m := (@pack I S O _ _ m _ _ id _ _ id m id).
    Notation "[ 'sigFam' I 'of' S ',' O 'for' sigFam ]" :=
      (@clone I S O sigFam _ idfun)
        (at level 0, format "[ 'sigFam' I 'of' S ',' O 'for' sigFam ]") : form_scope.
    Notation "[ 'sigFam' I 'of' S ',' O ]" :=
      (@clone I S O _ _ id) (at level 0, format "[ 'sigFam' I 'of' S ',' O ]") : form_scope.
  End Exports.
End SignatureFamily.

Export SignatureFamily.Exports.

Definition sort {I: Type} (Sigma: sigFam I): preOrdered :=
  SignatureFamily.preOrdered I Sigma.
Definition operation {I: Type} (Sigma: sigFam I): finType :=
  SignatureFamily.finType I (Sigma).
Definition arity {I: Type} (Sigma: sigFam I): I -> operation Sigma -> nat :=
  SignatureFamily.arity _ _ _ (SignatureFamily.class I Sigma).
Definition dom {I: Type} (Sigma: sigFam I): forall (i: I) (o: operation Sigma), (arity Sigma i o).-tuple (sort Sigma) :=
  SignatureFamily.dom _ _ _ (SignatureFamily.class I Sigma).
Definition range {I: Type} (Sigma: sigFam I): I -> operation Sigma -> (sort Sigma) :=
  SignatureFamily.range _ _ _ (SignatureFamily.class I Sigma).

Definition sigFamSpec_Mixin {I: Type} {S: preOrdered} {O: finType} (spec: I -> O -> (seq S * S)):
  SignatureFamily.mixin_of
    I (PreOrdered.Pack S (PreOrdered.class S))
    (Finite.Pack (Finite.class O)).
Proof.
  move: spec.
  case: O => T1 o.
  case: S => S c.
  move => spec.
  by exact: (@SignatureFamily.Mixin
               I (PreOrdered.Pack S c) (Finite.Pack o)
               (fun i o => seq.size (spec i o).1)
               (fun i o =>
                  let res := (spec i o).1 in
                  @Tuple (seq.size res) S res (eq_refl _))
               (fun i o => (spec i o).2)).
Defined.

Definition SigSpec I S O : Type := I -> O -> (seq S * S).
Definition sigFamSpec_Type {I: Type} {S: preOrdered} {O: finType} (spec: SigSpec I S O) :=
  Eval hnf in SignatureFamilyType I S O (sigFamSpec_Mixin spec).

Record F {I: Type} (Sigma: sigFam I) (C: (sort Sigma) -> Type) (s: sort Sigma): Type :=
    mkF {
        index: I;
        op: operation Sigma;
        args: {ffun forall n, C (tnth (dom Sigma index op) n) };
        range_cond: [sort (range Sigma index op) <= s]
      }.

Arguments mkF [I] [Sigma] [C] [s].
Arguments index [I] [Sigma] [C] [s].
Arguments op [I] [Sigma] [C] [s].
Arguments args [I] [Sigma] [C] [s].
Arguments range_cond [I] [Sigma] [C] [s].

Section SignatureFunctor.
  Variable I : Type.
  Variable Sigma: sigFam I.
  Variable C D: (sort Sigma) -> Type.
  Definition fmap (f: forall s, C s -> D s): forall s, F Sigma C s -> F Sigma D s :=
    fun s x => mkF (index x) (op x) [ffun n => f (tnth (dom Sigma (index x) (op x)) n) (args x n)] (range_cond x).
End SignatureFunctor.

Arguments fmap [I] [Sigma] [C D].

Section SignatureFunctorProps.
  Variable I : Type.
  Variable Sigma: sigFam I.
  Variable C D E: (sort Sigma) -> Type.

  Lemma fmap_id: forall s, fmap (fun s => (@id (C s))) s =1 id.
  Proof.
    move => s.
    rewrite /fmap.
    case => /= *.
    apply f_equal2 => //.
    apply ffunP.
    move => x.
      by rewrite ffunE.
  Qed.

  Lemma fmap_comp: forall (f: forall s, D s -> E s) (g: forall s, C s -> D s) s, fmap (fun s => f s \o g s) s =1 fmap f s \o fmap g s.
  Proof.
    move => f g s.
    rewrite /fmap /=.
    case => /= *.
    apply f_equal2 => //.
    apply ffunP.
    move => x.
      by do 3 rewrite ffunE.
  Qed.
End SignatureFunctorProps.

Module SigmaAlgebra.
  Record mixin_of (I: Type) (Sigma: sigFam I) (C: (sort Sigma) -> Type): Type :=
    Mixin { action: forall s, F Sigma C s -> C s }.
  Section ClassDef.
    Notation class_of := mixin_of.
    Structure type I Sigma := Pack { carrier_sort : (sort Sigma) -> Type; _ : class_of I Sigma carrier_sort }.
    Variables (I: Type) (Sigma: sigFam I) (C: (sort Sigma) -> Type) (alg: type I Sigma).
    Definition class := let: Pack _ c as alg' := alg return class_of I Sigma (carrier_sort I Sigma alg') in c.
    Definition clone c of phant_id class c := @Pack I Sigma C c.
    Let xCarrier := (let: Pack C _ := alg in C).
    Notation xclass := (class : class_of I xCarrier).
    Definition pack (m0: mixin_of I Sigma C) :=
          fun m & phant_id m0 m => Pack I Sigma C m.

    Definition carrier := Eval hnf in xCarrier.
  End ClassDef.

  Module Import Exports.
    Coercion carrier : type >-> Funclass.
    Coercion action : mixin_of >-> Funclass.

    Notation sigAlg := (type _).
    Notation Mixin := Mixin.
    Notation AlgebraType I Sigma C m := (@pack I Sigma C m m id).
    Notation "[ 'sigAlg' Sigma 'on' C 'for' sigAlg ]" :=
      (@clone _ Sigma C sigAlg _ idfun)
        (at level 0, format "[ 'sigAlg' Sigma 'on' C 'for' sigAlg ]") : form_scope.
    Notation "[ 'sigAlg' Sigma 'on' C ]" :=
      (@clone _ Sigma C _ _ id) (at level 0, format "[ 'sigAlg' Sigma 'on' C ]") : form_scope.
  End Exports.
End SigmaAlgebra.

Export SigmaAlgebra.Exports.

Definition carrier {I: Type} {Sigma: sigFam I} (alg: sigAlg Sigma): sort Sigma -> Type  :=
  SigmaAlgebra.carrier I Sigma alg.
Definition action {I: Type} {Sigma: sigFam I} (alg: sigAlg Sigma): forall s, F Sigma (carrier alg) s -> (carrier alg) s :=
  SigmaAlgebra.action I (Sigma) (carrier alg) (SigmaAlgebra.class I Sigma alg).

Coercion action: sigAlg >-> Funclass.

Definition sigAlg_Type {I: Type} {Sigma: sigFam I} {C: (sort Sigma) -> Type} (m: forall s, F Sigma C s -> C s): sigAlg Sigma :=
  AlgebraType I Sigma C (SigmaAlgebra.Mixin I Sigma C m).

Module SigmaCoAlgebra.
  Record mixin_of (I: Type) (Sigma: sigFam I) (C: (sort Sigma) -> Type): Type :=
    Mixin { coaction: forall s, C s -> F Sigma C s }.
  Section ClassDef.
    Notation class_of := mixin_of.
    Structure type I Sigma := Pack { carrier_sort : (sort Sigma) -> Type; _ : class_of I Sigma carrier_sort }.
    Variables (I: Type) (Sigma: sigFam I) (C: (sort Sigma) -> Type) (coAlg: type I Sigma).
    Definition class := let: Pack _ c as coAlg' := coAlg return class_of I Sigma (carrier_sort I Sigma coAlg') in c.
    Definition clone c of phant_id class c := @Pack I Sigma C c.
    Let xCarrier := (let: Pack C _ := coAlg in C).
    Notation xclass := (class : class_of I xCarrier).
    Definition pack (m0: mixin_of I Sigma C) :=
          fun m & phant_id m0 m => Pack I Sigma C m.

    Definition carrier := Eval hnf in xCarrier.
  End ClassDef.

  Module Import Exports.
    Coercion carrier : type >-> Funclass.
    Coercion coaction : mixin_of >-> Funclass.

    Notation sigCoAlg := (type _).
    Notation Mixin := Mixin.
    Notation CoAlgebraType I Sigma C m := (@pack I Sigma C m m id).
    Notation "[ 'sigCoAlg' Sigma 'on' C 'for' sigCoAlg ]" :=
      (@clone I Sigma C sigCoAlg _ idfun)
        (at level 0, format "[ 'sigCoAlg' Sigma 'on' C 'for' sigCoAlg ]") : form_scope.
    Notation "[ 'sigCoAlg' Sigma 'on' C ]" :=
      (@clone I Sigma C _ _ id) (at level 0, format "[ 'sigCoAlg' Sigma 'on' C ]") : form_scope.
  End Exports.
End SigmaCoAlgebra.

Export SigmaCoAlgebra.Exports.

Definition cocarrier {I: Type} {Sigma: sigFam I} (coAlg: sigCoAlg Sigma): sort Sigma -> Type  :=
  SigmaCoAlgebra.carrier I Sigma coAlg.
Definition coaction {I: Type} {Sigma: sigFam I} (coAlg: sigCoAlg Sigma):
  forall s, cocarrier coAlg s -> F Sigma (cocarrier coAlg) s :=
  SigmaCoAlgebra.coaction I (Sigma) (cocarrier coAlg) (SigmaCoAlgebra.class I Sigma coAlg).

Coercion coaction: sigCoAlg >-> Funclass.

Definition sigCoAlg_Type {I: Type} {Sigma: sigFam I} {C: (sort Sigma) -> Type} (m: forall s, C s -> F Sigma C s): sigCoAlg Sigma :=
  CoAlgebraType I Sigma C (SigmaCoAlgebra.Mixin I Sigma C m).

Inductive AlgGen {I: Type} (Sigma: sigFam I) (h: sigAlg Sigma) (s: sort Sigma): carrier h s -> Prop :=
| Gen : forall (x: F Sigma (carrier h) s),
    (forall n, AlgGen Sigma h (tnth (dom Sigma (index x) (op x)) n) (args x n)) ->
    AlgGen Sigma h s (action h s x).

Section CanonicalAlgebraMorphism.
  Variable I: Type.
  Variable Sigma: sigFam I.
  Variables h g: sigAlg Sigma.
  Variable h_inv: forall s, carrier h s -> F Sigma (carrier h) s.

  Variable A: Type.
  Variable measure: forall (s: sort Sigma), carrier h s -> A.
  Variable R: A -> A -> Prop.
  Hypothesis R_wf: well_founded R.

  Hypothesis h_inv_dec: forall s x n, R (measure _ (args (h_inv s x) n)) (measure s x).

  Definition fmap_dec (m1: A) (f: forall s2 (y: carrier h s2), R (measure s2 y) m1 -> carrier g s2):
    forall s (x: F Sigma (carrier h) s), (forall n, R (measure _ (args x n)) m1) -> F Sigma (carrier g) s :=
    fun s x prfs => mkF (index x) (op x) [ffun n => f (tnth (dom Sigma (index x) (op x)) n)
                                                  (args x n) (prfs n)] (range_cond x).

  Definition canonical_morphism: forall s, carrier h s -> carrier g s :=
    DepFix A R R_wf (sort Sigma) (carrier h) (fun s _ => carrier g s) measure
           (fun s x canonical_morphism_rec =>
              action g s (fmap_dec (measure s x) canonical_morphism_rec s (h_inv s x) (h_inv_dec s x))).

  Lemma canonical_morphism_commutes:
    forall s (x: carrier h s), canonical_morphism s x = action g s (fmap (canonical_morphism) s (h_inv s x)).
  Proof.
    move => s x.
    rewrite /canonical_morphism /DepFix /=.
    case: (R_wf (measure s x)) => prf /=.
    apply: f_equal.
    rewrite /fmap /fmap_dec -/canonical_morphism.
    apply: (f_equal2 (mkF (index (h_inv s x)) (op (h_inv s x)))) => //.
    apply: eq_dffun.
    move => y /=.
    apply: (fun f eqprf => Fix_F_inv A R (sort Sigma) (carrier h) (fun s _ => carrier g s) measure f eqprf
                      (tnth (dom Sigma (index (h_inv s x)) (op (h_inv s x))) y)
                      ((args (h_inv s x)) y)
                      (prf (measure (tnth (dom Sigma (index (h_inv s x)) (op (h_inv s x))) y)
                                      ((args (h_inv s x)) y)) (h_inv_dec s x y))
                      (R_wf (measure (tnth (dom Sigma (index (h_inv s x)) (op (h_inv s x))) y)
                                     ((args (h_inv s x)) y)))).
    move => *.
    apply: f_equal => //.
    apply: f_equal2 => //.
    apply ffunP.
    move => z.
      by do 2 rewrite ffunE.
  Qed.

  Variable hC: forall s, cancel (action h s) (h_inv s).
  Variable h_invC: forall s, cancel (h_inv s) (action h s).

  Lemma canonical_morphism_alg_morphism:
    forall s, canonical_morphism s \o (action h s) =1 (action g s) \o fmap (canonical_morphism) s.
  Proof.
    move => s x.
    rewrite /=.
    rewrite canonical_morphism_commutes.
      by rewrite hC.
  Qed.

  Lemma canonical_morphism_unique:
    forall (m: forall s, carrier h s -> carrier g s)
      (is_alg_mor_m: forall s, m s \o (action h s) =1 (action g s) \o fmap m s),
    forall s, canonical_morphism s =1 m s.
  Proof.
    move => m is_alg_mor_m s x.
    rewrite canonical_morphism_commutes.
    apply: (fun f_rec => Fix_F A R (sort Sigma) (carrier h)
                            (fun s x => action g s (fmap canonical_morphism s (h_inv s x))  = m s x)
                            measure f_rec s x (R_wf (measure s x))).
    move: s x => _ _.
    move => s x IH.
    suff: (fmap canonical_morphism s (h_inv s x) = fmap m s (h_inv s x)).
    { move => ->.
      move: (is_alg_mor_m s (h_inv s x)).
      rewrite /= => <-.
        by rewrite h_invC. }
    rewrite /fmap.
    apply: f_equal2 => //.
    apply ffunP.
    move => n.
    do 2 rewrite ffunE.
    rewrite canonical_morphism_commutes.
    apply: IH.
      by apply: h_inv_dec.
  Qed.

  Lemma canonical_morphism_sound:
    forall s x, AlgGen Sigma g s (canonical_morphism s x).
  Proof.
    move => s x.
    rewrite canonical_morphism_commutes.
    apply: (fun f_rec => Fix_F A R (sort Sigma) (carrier h)
                            (fun s x => AlgGen Sigma g s (action g s (fmap canonical_morphism s (h_inv s x))))
                            measure f_rec s x (R_wf (measure s x))).
    move: s x => _ _.
    move => s x.
    move: (h_inv_dec s x).
    case: (h_inv s x) => /= i o args range_prf dec_prf IH.
    rewrite /fmap /=.
    constructor.
    move => /= n.
    rewrite ffunE.
    rewrite canonical_morphism_commutes.
    apply: IH.
      by apply: dec_prf.
  Qed.

   Lemma canonical_morphism_complete:
    forall s x, AlgGen Sigma g s x -> exists y, canonical_morphism s y = x.
  Proof.
    move => s x prf.
    elim: s x / prf.
    move => s x prfs IH.
    have: (exists f: {ffun forall n, carrier h (tnth (dom Sigma (index x) (op x)) n) },
              forall n, canonical_morphism (tnth (dom Sigma (index x) (op x)) n) (f n) = (args x) n).
    { move: IH.
      clear ...
      move: x => [] /= idx op args _ prf.
      move: (fin_all_exists prf) => [] f f_prf.
      exists (finfun f).
      move => n.
      rewrite ffunE.
      apply: f_prf. }
    move => [] args' args'_prf.
    exists (action h s (mkF (index x) (op x) args' (range_cond x))).
    move: (canonical_morphism_alg_morphism s (mkF (index x) (op x) args' (range_cond x))).
    rewrite /= => ->.
    apply f_equal.
    rewrite /fmap /=.
    move: args' args'_prf.
    clear...
    case: x => /= i o args range_cond args' args'_prf.
    apply: f_equal2 => //.
    apply ffunP.
    move => n.
    rewrite ffunE.
      by apply: args'_prf.
  Qed.
End CanonicalAlgebraMorphism.

Section FCLAlgebra.
  Variable I: finType.
  Variable Sigma: sigFam I.

  Definition Combinator: finType := sum_finType I (operation Sigma).
  Definition Constructor: ctor := sum_preOrderedType (diag_preOrderedType I) (sort Sigma).

  Definition Gamma__I : {ffun I -> @IT Constructor} :=
    [ffun i => Ctor (inl i) (Omega)].

  Definition embed (s: sort Sigma): @IT Constructor := @Ctor Constructor (inr s) Omega.
  Definition unembed (A: @IT Constructor): option (sort Sigma) :=
    if A is Ctor (inr s) Omega then Some s else None.

  Lemma embed_unembed: pcancel embed unembed.
  Proof. done. Qed.

  Lemma embed_le: forall s1 s2, [sort s1 <= s2] -> [bcd (embed s1) <= embed s2].
  Proof.
    move => s1 s2 prf.
      by apply: BCD__CAx.
  Qed.

  Definition typeAtIndex (o: operation Sigma) (i: I) : @IT Constructor :=
    (Gamma__I i) -> (mkArrow (rev (map embed (dom Sigma i o)), embed (range Sigma i o))).

  Definition Gamma__Sigma : {ffun (operation Sigma) -> @IT Constructor} :=
    [ffun o => \bigcap_(A_i <- map (typeAtIndex o) (enum I)) A_i].

  Definition Gamma: {ffun Combinator -> @IT Constructor} :=
    [ffun c => match c with
              | inl idx => Gamma__I idx
              | inr o => Gamma__Sigma o
              end].

  Definition C__FCL (s: sort Sigma) := { M : @Term Combinator | (typeCheck Gamma M (embed s)) }.

  Definition termAction__FCL (s: sort Sigma) (x: F Sigma C__FCL s): @Term Combinator :=
    let: mkF i o args rangeprf := x in
    revApply (Var (inr o) @ (Var (inl i)))
             (rev (map (fun n => sval (args n)) (enum ('I_(arity Sigma i o))))).

  Lemma proofAction__FCL: forall s x, typeCheck Gamma (termAction__FCL s x) (embed s).
  Proof.
    move => s [] i o args range_prf.
    have size_eq: (seq.size (rev (map (fun n => sval (args n)) (enum 'I_(arity Sigma i o)))) =
                   seq.size (rev (map embed (dom Sigma i o)))).
    { do 2 rewrite size_rev size_map.
        by rewrite -cardE card_ord size_tuple. }
    apply /fclP.
    apply: (FCL__Sub (embed (range Sigma i o))); last by apply: embed_le.
    apply: (FCL__App Gamma (@Var Combinator (inr o) @ Var (inl i))
                   (rev (map (fun n => sval (args n)) (enum ('I_(arity Sigma i o)))))
                   (rev (map embed (dom Sigma i o)), embed (range Sigma i o))) => //.
    rewrite /=.
    move => n.
    case arity0: (n < (arity Sigma i o)).
    - rewrite nth_rev; last first.
      { by rewrite size_map -cardE card_ord. }
      rewrite nth_rev; last first.
      { by rewrite size_map size_tuple. }
      rewrite (nth_map s); last first.
      { by rewrite size_map size_tuple -subn_gt0 subnBA // addnC -addnBA // subnn. }
      rewrite (nth_map (Ordinal arity0)); last first.
      { rewrite size_map size_tuple card_ord -subn_gt0 subnBA // addnC -addnBA // subnn. }
      rewrite size_map.
      move: (args
               (nth (Ordinal arity0)
                    (enum 'I_(arity Sigma i o))
                    (seq.size (enum 'I_(arity Sigma i o)) - n.+1))).
      move => [] M /=.
      rewrite (tnth_nth s).
      rewrite (@nth_enum_ord _ (Ordinal arity0) ((seq.size (enum 'I_(arity Sigma i o)) - n.+1))); last first.
      { by rewrite -cardE card_ord -subn_gt0 subnBA // addnC -addnBA // subnn. }
      move: size_eq.
        by rewrite size_rev size_rev size_map => -> /fclP.
    - rewrite nth_default; last first.
      { by rewrite size_rev size_map -cardE card_ord leqNgt arity0. }
      rewrite nth_default; last first.
      { by rewrite size_rev size_map size_tuple leqNgt arity0. }
      apply: FCL__MP; last by apply: FCL__Var.
      apply: FCL__Sub; first by apply: FCL__Var.
      rewrite /Gamma ffunE /Gamma__Sigma ffunE ffunE.
      apply: BCD__Trans.
      + apply: (bcd_subset_f _ id _ [:: typeAtIndex o i]).
        move => x.
        rewrite mem_seq1.
        move => /eqP ->.
        apply /mapP.
        exists i => //.
          by rewrite mem_enum.
      + rewrite /= /typeAtIndex.
          by apply: BCD__Sub.
  Qed.

  Definition action__FCL (s: sort Sigma) (x: F Sigma C__FCL s): C__FCL s :=
    exist _ (termAction__FCL s x) (proofAction__FCL s x).

  Definition termCoAction__FCL (s: sort Sigma) (x: C__FCL s): seq (@Term Combinator) :=
    behead (rev ((unapply (sval x)).2)).

  Lemma unapplyNotIndex: forall s (x: C__FCL s), if (unapply (sval x)).1 is (inl _) then False else True.
  Proof.
    move => s [] M.
    rewrite -(unapply_revapply M) /= revapply_unapply.
    move => /fclP /FCL__invApp [] srcs [] size__eq /(fun prf => prf (seq.size srcs)).
    rewrite nth_default; last by rewrite size__eq.
    rewrite nth_default //.
    case: (unapply M).1 => //.
    move => i /minimalType_minimal.
    move: size__eq => _.
    elim /last_ind: srcs.
    - move => /subty_complete.
      rewrite /mkArrow /= /embed /= ffunE /Gamma__I ffunE.
      move => /SubtypeMachine_inv /= /(fun prf => prf (fun i r => if r is Return true then false else true)) res.
        by move: (res (fun _ _ => isT)).
    - move => srcs src _.
      rewrite mkArrow_rcons.
      move => /subty_complete.
      rewrite /= /Gamma ffunE /Gamma__I ffunE.
      move => /SubtypeMachine_inv /(fun prf => prf (fun i r => if r is Return true then false else true)) res.
      suff: false by done.
      apply: res.
      move => Delta r'.
      rewrite /cast /= omega_mkArrow_tgt /=.
      move => /emptyDoneTgt -> /=.
      case: r' => //.
      move => /Omega__subty.
      rewrite omega_mkArrow_tgt /=.
      move => res.
        by apply: res.
  Qed.

  Definition opCoAction__FCL (s: sort Sigma) (x: C__FCL s): operation Sigma :=
    match (unapply (sval x)).1 as o return (if o is (inl _) then False else True) -> operation Sigma with
    | inl _ => False_rect _
    | inr o => fun _ => o
    end (unapplyNotIndex s x).

  Lemma arrow_le {C: ctor}: forall srcs1 srcs2 c1 c2 A1 A2,
      [bcd (mkArrow (srcs2, @Ctor C c2 A2)) <= (mkArrow (srcs1, Ctor c1 A1))] ->
      (seq.size srcs2 = seq.size srcs1) /\
      all (fun AB => checkSubtypes AB.1 AB.2) (zip srcs1 srcs2) /\
      [bcd (Ctor c2 A2) <= (Ctor c1 A1)].
  Proof.
    elim /last_ind.
    - elim /last_ind => // srcs2 src _ c1 c2 A1 A2.
      move => /subty_complete /SubtypeMachine_inv /=.
      rewrite mkArrow_rcons.
      move => /(fun prf => prf (fun i r => if (i, r) is ([subty A -> B of Ctor c C], Return true) then false else true)) res.
      suff: false by done.
        by apply: res.
    - move => // srcs1 src1 IH.
      elim /last_ind.
      + move => c1 c2 A1 A2 /subty_complete /SubtypeMachine_inv.
        rewrite mkArrow_rcons /(mkArrow ([::], _)) /=.
        move => /(fun prf => prf (fun i r => if (i, r) is ([subty Ctor c A of B -> C], Return true) then false else true)) res.
        suff: false by done.
        apply: res.
        move => Delta.
        rewrite /cast /= omega_mkArrow_tgt /=.
        case => //.
        move => /emptyDoneTgt ->.
        move => /Omega__subty /= /(fun prf => prf isT).
          by rewrite omega_mkArrow_tgt.
      + move => srcs2 src2 _ c1 c2 A1 A2.
        do 2 rewrite mkArrow_rcons.
        do 2 rewrite size_rcons.
        move => /subty_complete /SubtypeMachine_inv prf.
        have: (checkSubtypes src1 src2 /\ [bcd (mkArrow (srcs2, Ctor c2 A2)) <= mkArrow (srcs1, Ctor c1 A1)]).
        { apply: (prf (fun i r => if (i, r) is ([subty A -> B of C -> D], Return true)
                               then (checkSubtypes C A /\ [bcd B <= D])
                               else true)).
          rewrite /cast /= omega_mkArrow_tgt /=.
          move => Delta.
          case => //.
          move => args_prf.
          move: (check_tgt_subseq _ _ _ _ args_prf).
          move: args_prf.
          case: Delta.
          - move => _ _ /= /Omega__subty /(fun prf => prf isT).
              by rewrite omega_mkArrow_tgt.
          - move => A Delta /=.
            case A__eq: (A == mkArrow (srcs2, Ctor c2 A2)) => //.
            move => args_prf /eqP Delta__eq.
            move: args_prf.
            rewrite Delta__eq (eqP A__eq) /=.
            move => /SubtypeMachine_inv /(fun prf => prf (fun i r =>
                                                        if (i, r) is ([tgt_for_srcs_gte A in [:: (B1, B2)]], [check_tgt [:: C]])
                                                        then checkSubtypes A B1
                                                        else true)) res.
            move => /subty__sound restprf.
            split => //.
            apply: res.
            move => Delta2.
            case.
            * move => /subty__sound /subtypeMachineP ->.
                by case: Delta2.
            * by move => _ /emptyDoneTgt ->. }
        move => [] prf1 /IH [] size_prf.
        rewrite zip_rcons; last by rewrite size_prf.
          by rewrite all_rcons /= prf1 andTb size_prf.
  Qed.

  Lemma indexType_sound: forall M i, [FCL Gamma |- M : @Ctor Constructor (inl i) Omega] -> M = (@Var Combinator (inl i)).
  Proof.
    move => M i.
    move A__eq: (@Ctor Constructor (inl i) Omega) => A prf.
    move: i A__eq.
    elim /FCL_normalized_ind: M A /prf.
    - case.
      + move => i1 i2.
        rewrite /Gamma ffunE /Gamma__I ffunE.
          by move => [] ->.
      + move => o i.
        rewrite /Gamma ffunE /Gamma__Sigma ffunE.
          by case: (enum I) => // ? [] //.
    - move => c A IH prf i A__eq.
      apply: IH.
      move: prf.
      rewrite -A__eq /Gamma ffunE.
      case: c.
      + move => i2.
        rewrite /Gamma__I ffunE.
        move => /subty_complete /SubtypeMachine_inv /=.
        move => /(fun prf => prf (fun i r => if (i, r) is ([subty (Ctor (inl i1) Omega) of (Ctor (inl i2) Omega)], Return true)
                                      then i2 = i1 else True)) => res.
        apply: f_equal2 => //.
        apply: f_equal.
        apply: res.
        rewrite /cast /=.
        case res: (i2 == i).
        * rewrite (eqP res) preorder_reflexive.
            by case.
        * by rewrite /[sort _ <= _] /= /[sort _ <= _] /= res.
      + move => o /subty_complete /SubtypeMachine_inv /(fun prf => prf (fun i r => if r is Return true then false else true)) res.
        suff: false by done.
        apply: res.
        rewrite /Gamma__Sigma ffunE.
        suff: nilp (cast (@Ctor Constructor (inl i) Omega) (\bigcap_(A_i <- map (typeAtIndex o) (enum I)) A_i)) by move => ->.
        rewrite slow_cast_cast.
        elim: (enum I) => // idx idxs.
          by case: idxs => [].
    - move => M N A B devil _ _ _ i B__eq.
      move: devil.
      rewrite -B__eq.
      rewrite -(unapply_revapply M).
      move => /FCL__invApp prf.
      suff: false by done.
      move: prf.
      case: (unapply M).
      move: M => _ c Ns.
      rewrite [(_, _).2]/=.
      move => [] srcs [] size_eq.
      move => /(fun prf => prf (seq.size srcs)).
      rewrite nth_default; last by rewrite size_eq.
      rewrite nth_default => //.
      move /minimalType_minimal.
      rewrite /= /Gamma ffunE.
      have: (mkArrow (srcs, (A -> @Ctor Constructor (inl i) Omega)) =
             mkArrow ([:: A & srcs], @Ctor Constructor (inl i) Omega)) by reflexivity.
      move => ->.
      clear size_eq.
      case: c.
      + move => index.
        rewrite /Gamma__I ffunE.
          by move => /(arrow_le _ [::]) [].
      + move => o.
        rewrite /Gamma__Sigma ffunE.
        move => /primeComponentPrime_seq /=.
        rewrite omega_mkArrow_tgt /=.
        move => /(fun prf x => prf isT (isPrimeComponentP x)) /=.
        rewrite mkArrow_prime //=.
        move => /(fun prf => prf isT).
        move => /hasP [] x /mapP [] idx inprf__idx ->.
        move => /subtypeMachineP.
        rewrite /typeAtIndex -mkArrow_rcons.
        move => /arrow_le [] _ [] _ /subty_complete /SubtypeMachine_inv.
        move => /(fun prf => prf (fun i r => if r is Return true then false else true)) res.
          by apply: res.
  Qed.

  Lemma unapplyIsIndex: forall s (x: C__FCL s), if rev (unapply (sval x)).2 is [:: (Var (inl _)) & _] then True else False.
  Proof.
    move => s x.
    move: (unapplyNotIndex s x).
    case x => M.
    rewrite -(unapply_revapply M) /= revapply_unapply.
    move => /fclP /FCL__invApp [] srcs [] size__eq.
    case: (unapply M).1 => // o.
    move: size__eq.
    elim /last_ind: (unapply M).2.
    - case: srcs => // _.
      move => /(fun prf => prf 0) /=.
      move => /minimalType_minimal /=.
      rewrite /mkArrow /= /Gamma ffunE /Gamma__Sigma ffunE /embed.
      move => /subty_complete /SubtypeMachine_inv /= /(fun prf => prf (fun i r => if r is Return true then false else true)) res.
      suff: false by done.
      apply: res.
      suff: (nilp (cast (@Ctor Constructor (inr s) Omega) (\bigcap_(A_i <- map (typeAtIndex o) (enum I)) A_i))) by move ->.
      rewrite slow_cast_cast.
      elim (enum I) => // idx idxs.
        by case: idxs.
    - elim /last_ind: srcs => // srcs src _; first by rewrite size_rcons.
      move => Ns N _ /= size__eq prf.
      have: [FCL Gamma |- N : src].
      { move: (prf (seq.size srcs)).
        move: size__eq => /eqP.
        rewrite size_rcons size_rcons eqSS => /eqP size__eq.
        rewrite nth_rcons.
        case lt_prf: (seq.size srcs < seq.size Ns); first by move: lt_prf; rewrite size__eq ltnn.
        rewrite size__eq eq_refl.
          by rewrite nth_rcons ltnn eq_refl. }
      suff: exists i, [bcd src <= @Ctor Constructor (inl i) Omega].
      { move => [] i le_prf.
        move => /(fun prf => FCL__Sub _ prf le_prf) /indexType_sound ->.
          by rewrite rev_rcons. }
      move: (prf (seq.size (rcons srcs src))).
      rewrite nth_default; last by rewrite /= size__eq.
      rewrite nth_default //.
      move => /minimalType_minimal.
      rewrite /minimalType /Gamma ffunE /Gamma__Sigma ffunE.
      move => /primeComponentPrime_seq.
      rewrite omega_mkArrow_tgt /=.
      move => /(fun prf x => prf isT (isPrimeComponentP x)).
      rewrite mkArrow_prime //.
      move => /(fun prf => prf isT) /hasP [] A /mapP [] i inprf__i -> /subtypeMachineP le_prf.
      exists i.
      move: le_prf => /subty_complete.
      rewrite mkArrow_rcons /typeAtIndex.
      move => /SubtypeMachine_inv /(fun prf => prf (fun i r => if (i, r) is ([subty A -> B of C -> D], Return true)
                                                        then  [bcd C <= A]
                                                        else True)).
      rewrite /Gamma__I ffunE.
      move => res.
      apply: res.
      rewrite /cast /= omega_mkArrow_tgt /=.
      move => Delta [] // check_prf.
      move: (check_prf) => /check_tgt_subseq.
      move: check_prf.
      case: Delta.
      + move => _ _ /= /Omega__subty /(fun prf => prf isT).
          by rewrite omega_mkArrow_tgt.
      + move => B ? /=.
        case B__eq: (B == mkArrow (rev (map embed (dom Sigma i o)), embed (range Sigma i o))) => // check_prf /eqP eq_prf.
        move: check_prf.
        rewrite eq_prf /= (eqP B__eq).
        move => /SubtypeMachine_inv /(fun prf => prf (fun i r => if (i, r) is ([tgt_for_srcs_gte A in [:: (B, _)]], [check_tgt [:: _ ]])
                                                          then  [bcd A <= B]
                                                          else True)) res.
        move => _.
        apply: res.
        move => Delta2 r res_prf /emptyDoneTgt ->.
        move: res_prf.
        case: r => //.
          by move => /subty__sound.
  Qed.

  Definition indexCoAction__FCL (s: sort Sigma) (x: C__FCL s): I :=
    match rev (unapply (sval x)).2 as args return (if args is [:: (Var (inl _)) & _] then True else False) -> I with
    | [:: Var (inl i) & _] => fun _ => i
    | _ => False_rect _
    end (unapplyIsIndex s x).

  Lemma termCoAction_size:
    forall s x, seq.size (termCoAction__FCL s x) == arity Sigma (indexCoAction__FCL s x) (opCoAction__FCL s x).
  Proof.
    move => s [] M.
    rewrite /opCoAction__FCL /= /termCoAction__FCL /indexCoAction__FCL.
    move: (unapply_revapply M) => <-.
    move: (unapply M).1 => c.
    move: (unapply M).2 => Ns.
    move: M => _ prf.
    move: (unapplyNotIndex s
                           (exist (fun M : Term => typeCheck Gamma M (embed s))
                                  (revApply (Var c) Ns) prf)).
    move: (unapplyIsIndex s
                          (exist (fun M : Term => typeCheck Gamma M (embed s))
                                  (revApply (Var c) Ns) prf)).
    rewrite (revapply_unapply (c, Ns)) /=.
    move: prf => /fclP /FCL__invApp.
    case: c => //= o [] srcs [].
    elim /last_ind: Ns => // Ns N _.
    rewrite rev_rcons.
    case: N => // [].
    case => // i.
    rewrite size_rcons.
    elim /last_ind: srcs => // srcs src _.
    rewrite size_rcons.
    move => /eqP.
    rewrite eqSS.
    move => /eqP size__eq prf _ _.
    rewrite /= size_rev size__eq /=.
    move: (prf (seq.size srcs).+1).
    rewrite nth_default; last by rewrite size_rcons size__eq.
    rewrite nth_default; last by rewrite size_rcons.
    move => /minimalType_minimal /=.
    rewrite /Gamma ffunE /Gamma__Sigma ffunE.
    move => /primeComponentPrime_seq.
    rewrite omega_mkArrow_tgt /=.
    move => /(fun prf x => prf isT (isPrimeComponentP x)).
    rewrite mkArrow_prime //.
    move => /(fun prf => prf isT) /hasP [] ? /mapP [] idx _ -> /subtypeMachineP.
    rewrite /typeAtIndex -mkArrow_rcons.
    move => /arrow_le.
    do 2 rewrite size_rcons.
    move => [] /eqP.
    rewrite eqSS => /eqP size_eq.
    rewrite -size_eq size_rev size_map size_tuple.
    move => [].
    rewrite zip_rcons // all_rcons /=.
    move => /andP [] /subtypeMachineP src_le.
    suff: (idx = i) by move => ->.
    move: (prf (seq.size Ns)).
    rewrite nth_rcons nth_rcons size__eq ltnn eq_refl.
    move => /minimalType_minimal.
    move => /(fun prf => BCD__Trans _ prf src_le).
    rewrite /= /Gamma ffunE /Gamma__I ffunE ffunE.
    move => /subty_complete /SubtypeMachine_inv.
    move => /(fun prf => prf (fun i r => if (i, r) is ([subty Ctor (inl i1) _ of Ctor (inl i2) _], Return true) return Prop
                                  then  i2 = i1
                                  else true)) res.
    apply: res.
    case; last by rewrite andbF.
    rewrite /cast /= /[sort _ <= _] /= /[sort _ <= _] /=.
    case idx__eq: (i == idx) => //=.
      by rewrite (eqP idx__eq).
  Qed.

  Lemma proofCoAction__FCL:
    forall (s: sort Sigma) (x: C__FCL s) n,
      typeCheck Gamma
                (tnth (Tuple (termCoAction_size s x)) n)
                (embed (tnth (dom Sigma (indexCoAction__FCL s x) (opCoAction__FCL s x)) n)).
  Proof.
    move => s x [] n n_lt.
    rewrite (@tnth_nth _ _ (projT1 x)) (@tnth_nth _ _ s).
    apply /fclP.
    move: n_lt.
    move: x => [] M.
    rewrite /opCoAction__FCL /= /termCoAction__FCL /indexCoAction__FCL.
    move: (unapply_revapply M) => <-.
    move: (unapply M).1 => c.
    move: (unapply M).2 => Ns.
    move: M => _ prf.
    move: (unapplyNotIndex s
                           (exist (fun M : Term => typeCheck Gamma M (embed s))
                                  (revApply (Var c) Ns) prf)).
    move: (unapplyIsIndex s
                          (exist (fun M : Term => typeCheck Gamma M (embed s))
                                  (revApply (Var c) Ns) prf)).
    rewrite (revapply_unapply (c, Ns)).
    move: prf => /fclP /FCL__invApp.
    case: c => //= o [] srcs [].
    elim /last_ind: Ns => // Ns N _.
    rewrite rev_rcons.
    case: N => // [].
    case => // i.
    rewrite size_rcons.
    elim /last_ind: srcs => // srcs src _.
    rewrite size_rcons.
    move => /eqP.
    rewrite eqSS.
    move => /eqP size__eq prf _ _.
    move: (prf (seq.size srcs).+1).
    rewrite nth_default; last by rewrite size_rcons size__eq.
    rewrite nth_default; last by rewrite size_rcons.
    move => /minimalType_minimal /=.
    rewrite /Gamma ffunE /Gamma__Sigma ffunE.
    move => /primeComponentPrime_seq.
    rewrite omega_mkArrow_tgt /=.
    move => /(fun prf x => prf isT (isPrimeComponentP x)).
    rewrite mkArrow_prime //.
    move => /(fun prf => prf isT) /hasP [] ? /mapP [] idx _ -> /subtypeMachineP.
    rewrite /typeAtIndex -mkArrow_rcons.
    move => /arrow_le.
    do 2 rewrite size_rcons.
    move => [] /eqP.
    rewrite eqSS => /eqP size_eq.
    rewrite zip_rcons // all_rcons.
    move => [] /andP [] /subtypeMachineP src_le.
    move: size_eq.
    have: (idx = i).
    { move: (prf (seq.size Ns)).
      rewrite nth_rcons nth_rcons size__eq ltnn eq_refl.
      move => /minimalType_minimal.
      move => /(fun prf => BCD__Trans _ prf src_le).
      rewrite /= /Gamma ffunE /Gamma__I ffunE ffunE.
      move => /subty_complete /SubtypeMachine_inv.
      move => /(fun prf => prf (fun i r => if (i, r) is ([subty Ctor (inl i1) _ of Ctor (inl i2) _], Return true) return Prop
                                    then  i2 = i1
                                    else true)) res.
      apply: res.
      case; last by rewrite andbF.
      rewrite /cast /= /[sort _ <= _] /= /[sort _ <= _] /=.
      case idx__eq: (i == idx) => //=.
        by rewrite (eqP idx__eq). }
    move => -> size_eq prfs _ n_lt.
    apply: (FCL__Sub (nth (mkArrow (rcons srcs src, embed s)) (rev srcs) n)); last first.
    { apply /subtypeMachineP.
      move: prfs.
      rewrite -all_rev rev_zip; last by rewrite size_eq.
      move => /allP prfs.
      apply: (prfs (nth (mkArrow (rcons srcs src, embed s)) (rev srcs) n, embed (nth s (dom Sigma i o) n))).
      rewrite -(nth_map s (embed s)); last by rewrite size_tuple.
      rewrite -[X in X \in _]nth_zip; last by rewrite size_rev -size_eq size_rev.
      rewrite revK.
      apply: mem_nth.
        by rewrite size_zip size_rev -size_eq size_rev minnn size_tuple. }
    rewrite nth_rev; last by rewrite size__eq -size_eq size_tuple.
    rewrite nth_rev; last by rewrite -size_eq size_tuple.
    move: (prf (seq.size srcs - n.+1)).
    do 2 rewrite nth_rcons.
    rewrite size__eq.
    rewrite subnSK; last by rewrite -size_eq size_tuple.
    rewrite leq_subr.
    move => res.
    erewrite set_nth_default; first by exact res.
    rewrite size__eq subnSK; last by rewrite -size_eq size_tuple.
      by rewrite leq_subr.
  Qed.

  Lemma range_coAction:
    forall (s: sort Sigma) (x: C__FCL s),
      [sort (range Sigma (indexCoAction__FCL s x) (opCoAction__FCL s x)) <= s].
  Proof.
    move => s [] M.
    rewrite /opCoAction__FCL /= /indexCoAction__FCL.
    move: (unapply_revapply M) => <-.
    move: (unapply M).1 => c.
    move: (unapply M).2 => Ns.
    move: M => _ prf.
    move: (unapplyNotIndex s
                           (exist (fun M : Term => typeCheck Gamma M (embed s))
                                  (revApply (Var c) Ns) prf)).
    move: (unapplyIsIndex s
                          (exist (fun M : Term => typeCheck Gamma M (embed s))
                                  (revApply (Var c) Ns) prf)).
    rewrite (revapply_unapply (c, Ns)).
    move: prf => /fclP /FCL__invApp.
    case: c => //= o [] srcs [].
    elim /last_ind: Ns => // Ns N _.
    rewrite rev_rcons.
    case: N => // [].
    case => // i.
    rewrite size_rcons.
    elim /last_ind: srcs => // srcs src _.
    rewrite size_rcons.
    move => /eqP.
    rewrite eqSS.
    move => /eqP size__eq prf _ _.
    move: (prf (seq.size srcs).+1).
    rewrite nth_default; last by rewrite size_rcons size__eq.
    rewrite nth_default; last by rewrite size_rcons.
    move => /minimalType_minimal /=.
    rewrite /Gamma ffunE /Gamma__Sigma ffunE.
    move => /primeComponentPrime_seq.
    rewrite omega_mkArrow_tgt /=.
    move => /(fun prf x => prf isT (isPrimeComponentP x)).
    rewrite mkArrow_prime //.
    move => /(fun prf => prf isT) /hasP [] ? /mapP [] idx _ -> /subtypeMachineP.
    rewrite /typeAtIndex -mkArrow_rcons.
    move => /arrow_le.
    do 2 rewrite size_rcons.
    move => [] /eqP.
    rewrite eqSS => /eqP size_eq.
    rewrite zip_rcons // all_rcons.
    move => [] /andP [] /subtypeMachineP src_le.
    move: size_eq.
    have: (idx = i).
    { move: (prf (seq.size Ns)).
      rewrite nth_rcons nth_rcons size__eq ltnn eq_refl.
      move => /minimalType_minimal.
      move => /(fun prf => BCD__Trans _ prf src_le).
      rewrite /= /Gamma ffunE /Gamma__I ffunE ffunE.
      move => /subty_complete /SubtypeMachine_inv.
      move => /(fun prf => prf (fun i r => if (i, r) is ([subty Ctor (inl i1) _ of Ctor (inl i2) _], Return true) return Prop
                                    then  i2 = i1
                                    else true)) res.
      apply: res.
      case; last by rewrite andbF.
      rewrite /cast /= /[sort _ <= _] /= /[sort _ <= _] /=.
      case idx__eq: (i == idx) => //=.
        by rewrite (eqP idx__eq). }
    move => -> _ _ /subty_complete /SubtypeMachine_inv.
    move => /(fun prf => prf (fun i r => if (i, r) is ([subty (Ctor c A) of (Ctor d B)], Return true)
                                  then [sort c <= d]
                                  else true)) res.
    apply: res.
    case; last by rewrite andbF.
    rewrite /cast /=.
      by case: [ sort (inr (range Sigma i o) : Constructor) <= (inr s : Constructor)].
  Qed.

  Definition coAction__FCL: forall s, C__FCL s -> F Sigma C__FCL s :=
    fun s c =>
      @mkF I Sigma C__FCL s
        (indexCoAction__FCL s c) (opCoAction__FCL s c)
        [ffun n => exist _ (tnth (Tuple (termCoAction_size s c)) n) (proofCoAction__FCL s c n)]
        (range_coAction s c).

  Section Measure.
    Definition measure__FCL: forall s, C__FCL s -> Term := fun s => sval.
    Definition IsChild: @Term Combinator -> @Term Combinator -> Prop := fun M N => M \in (unapply N).2.
    Lemma revApply_rcons: forall (M N: @Term Combinator) Ns, revApply M (rcons Ns N) = revApply (M @ N) Ns.
    Proof.
      move => M N Ns.
        by rewrite /revApply -cats1 (foldr_cat _ _ Ns [:: N]).
    Qed.

    Lemma revApply_nil: forall (M: @Term Combinator), revApply M [::] = M.
    Proof. by move => M. Qed.

    Lemma Term_unapply_ind: forall (P : @Term Combinator -> Prop) (f: forall c Ns, (forall N, N \in Ns -> P N) -> P (revApply (Var c) Ns)) M, P M.
    Proof.
      move => P f M.
      have: (forall N, N \in [::] -> P N) by done.
      rewrite -(revApply_nil M).
      move: [::].
      elim: M.
      - move => c Ns IH.
          by apply: f.
      - move => M IH__M N IH__N Ns prf.
        rewrite -revApply_rcons.
        apply: IH__M.
        move => N'.
        rewrite mem_rcons in_cons.
        case /orP.
        + move => /eqP ->.
            by apply: (IH__N [::]).
        + by apply: prf.
    Qed.

    Lemma IsChild_wf: well_founded IsChild.
    Proof.
      elim /Term_unapply_ind.
      move => c Ns IH.
      apply: Acc_intro.
      move => N.
      rewrite /IsChild.
      rewrite (revapply_unapply (c, Ns)).
        by move => /IH.
    Qed.

    Lemma dec_coAction__FCL:
      forall (s : sort Sigma) (x : C__FCL s)
        (n : 'I_(arity Sigma (index (coAction__FCL s x)) (op (coAction__FCL s x)))),
        IsChild (measure__FCL (tnth (dom Sigma (index (coAction__FCL s x)) (op (coAction__FCL s x))) n)
                            ((args (coAction__FCL s x)) n)) (measure__FCL s x).
    Proof.
      move => s x n.
      rewrite /= ffunE /= /measure__FCL (tnth_nth (sval x)) /IsChild /= /termCoAction__FCL.
      have n_lt: (n.+1 < seq.size (unapply (sval x)).2).
      { move: n => [] /= n.
        move: (termCoAction_size s x) => /eqP <-.
          by rewrite /termCoAction__FCL size_behead size_rev -subn1 ltn_subRL add1n. }
      rewrite nth_behead nth_rev //.
      apply mem_nth.
        by rewrite subnSK // leq_subr.
    Qed.
  End Measure.

  Lemma cancel_action_coAction__FCL: forall s, cancel (action__FCL s) (coAction__FCL s).
  Proof.
    move => s [] /= i op args range_cond.
    rewrite /action__FCL /coAction__FCL.
    move: (proofCoAction__FCL s _) => prf_action.
    have i__eq: (indexCoAction__FCL s
                                (exist (fun M : Term => typeCheck Gamma M (embed s))
                                       (termAction__FCL s
                                                      {|
                                                        index := i;
                                                        op := op;
                                                        args := args;
                                                        range_cond := range_cond |})
                                       (proofAction__FCL s
                                                       {|
                                                         index := i;
                                                         op := op;
                                                         args := args;
                                                         range_cond := range_cond |})) = i).
    { rewrite /indexCoAction__FCL /=.
      move: (unapplyIsIndex s _).
        by rewrite /= -revApply_rcons (revapply_unapply (inr op: Combinator, _)) /= rev_rcons. }
    have op__eq: (opCoAction__FCL s
          (exist (fun M : Term => typeCheck Gamma M (embed s))
             (termAction__FCL s
                {|
                index := i;
                op := op;
                args := args;
                range_cond := range_cond |})
             (proofAction__FCL s
                {|
                index := i;
                op := op;
                args := args;
                range_cond := range_cond |})) = op).
    { rewrite /opCoAction__FCL /=.
      move: (unapplyNotIndex s _).
        by rewrite /= -revApply_rcons (revapply_unapply (inr op: Combinator, _)) /=. }
    move: (range_coAction s _).
    move: prf_action.
    move: (termCoAction_size s _).
    rewrite i__eq op__eq.
    move => termCoAction_size prf_action  range_coAction.
    apply: f_equal2.
    - apply ffunP.
      move => x.
      rewrite ffunE.
      move: termCoAction_size prf_action.
      rewrite  /termCoAction__FCL /= -revApply_rcons.
      rewrite (revapply_unapply (inr op : Combinator, _)) /= rev_rcons revK /=.
      clear...
      move rhs__eq: (args x) => rhs.
      move: rhs__eq.
      case: rhs => [] m args_prf termCoAction_size.
      move: args args_prf termCoAction_size.
      move: (arity Sigma i op) x (dom Sigma i op).
      move => arity x dom args args_prf rhs__eq prf.
      move: (prf) (args_prf) (rhs__eq).
      move: (x) (dom) (args).
      rewrite -(eqP prf) size_map size_enum_ord.
      clear x dom args rhs__eq args_prf prf.
      move => x dom args prf args_prf rhs__eq.
      have lhs__eq: (tnth (Tuple (n:=arity) (tval:=[seq sval (args n) | n <- enum 'I_arity]) prf) x = m).
      { rewrite (tnth_nth m) /=.
        rewrite (nth_map x); last by rewrite size_enum_ord ltn_ord.
          by rewrite -(tnth_nth x (ord_tuple arity) x) tnth_ord_tuple rhs__eq. }
      clear rhs__eq.
      move: args_prf.
      rewrite -lhs__eq.
      move => args_prf prf_action.
      apply: f_equal.
      move: (prf_action x).
      clear prf_action.
      move: args_prf.
      move: (@UIP_dec bool bool_dec) => res prf1 prf2.
        by apply: res.
    - apply: (@UIP_dec bool bool_dec).
  Qed.

  Lemma cancel_coAction__FCL_action: forall s, cancel (coAction__FCL s) (action__FCL s).
  Proof.
    move => s x.
    rewrite /coAction__FCL /action__FCL /= /indexCoAction__FCL.
    case: x => M prf.
    rewrite /=.
    move: (proofAction__FCL s _).
    rewrite /= -revApply_rcons /=.
    move: (proofCoAction__FCL s _).
    move: (termCoAction_size s _).
    rewrite  /opCoAction__FCL /=.
    move: (unapplyNotIndex s
                           (exist
                              (fun M0 : Term =>
                                 typeCheck Gamma M0 (embed s)) M
                              prf)).
    rewrite /=.
    rewrite /indexCoAction__FCL /=.
    move: (unapplyIsIndex s (exist (fun M0 : Term => typeCheck Gamma M0 (embed s)) M prf)).
    rewrite /termCoAction__FCL /=.
    move M__eq: (unapply M) => cNs.
    move: M__eq.
    case: cNs => c Ns.
    elim /last_ind: Ns => //= Ns idx _.
    rewrite rev_rcons.
    case: idx; case => //.
    case: c => // o i.
    move: (unapply_revapply M) => M__eq unapply__eq.
    move: M__eq.
    rewrite unapply__eq /=.
    move => M__eq _ _ termCoAction_size proofCoAction__FCL.
    have: (rev
             [seq sval
                    ([ ffun n0 : 'I_(arity Sigma i o) =>
                     exist (fun M0 : Term => typeCheck Gamma M0 (embed (tnth (dom Sigma i o) n0)))
                       (tnth (Tuple (n:=arity Sigma i o) (tval:=rev Ns) termCoAction_size) n0)
                       (proofCoAction__FCL n0)] n)
             | n <- enum 'I_(arity Sigma i o)] = Ns).
    { rewrite -map_rev.
      apply: (@eq_from_nth _ M).
      - by rewrite size_map size_rev size_enum_ord -(eqP termCoAction_size) size_rev.
      - move => n.
        rewrite size_map size_rev size_enum_ord.
        move => lt_n.
        rewrite (nth_map (Ordinal lt_n)); last by rewrite size_rev size_enum_ord.
        rewrite ffunE /=.
        rewrite (tnth_nth M) /=.
        rewrite nth_rev; last first.
        { rewrite nth_rev; last by rewrite size_enum_ord.
          have size_prf: (seq.size (enum 'I_(arity Sigma i o)) - n.+1 < arity Sigma i o).
          { by rewrite size_enum_ord subnSK // leq_subr. }
          rewrite nth_enum_ord //.
          clear proofCoAction__FCL.
          move: termCoAction_size.
            by rewrite size_rev => /eqP ->. }
        apply: f_equal.
        rewrite nth_rev; last by rewrite size_enum_ord.
        rewrite nth_enum_ord; last first.
        { by rewrite size_enum_ord subnSK // leq_subr. }
        rewrite -subSn; last by rewrite size_enum_ord.
        rewrite subSS.
        rewrite size_enum_ord -(eqP termCoAction_size) size_rev subKn //.
        clear proofCoAction__FCL.
        move: termCoAction_size.
        rewrite size_rev => /eqP ->.
          by apply: ltnW. }
    move => ->.
    rewrite M__eq.
    move => proofAction__FCL.
    apply: f_equal.
      by apply: (@UIP_dec bool bool_dec).
  Qed.

  Definition algebra_morphism__FCL (g: sigAlg Sigma): forall s, C__FCL s -> carrier g s :=
    canonical_morphism I Sigma (sigAlg_Type action__FCL) g coAction__FCL
                       Term measure__FCL IsChild IsChild_wf
                       dec_coAction__FCL.

  Lemma commutes_algebra_morphism__FCL:
    forall (g: sigAlg Sigma) (s: sort Sigma) (x: C__FCL s),
       algebra_morphism__FCL g s x =
       action g s (fmap (algebra_morphism__FCL g) s (coAction__FCL s x)).
  Proof.
    move => g s x.
      by apply: canonical_morphism_commutes.
  Qed.

  Theorem unique_algebra_morphism__FCL:
    forall (g: sigAlg Sigma) (m : forall s : sort Sigma, C__FCL s -> carrier g s),
      (forall s : sort Sigma, m s \o action__FCL s =1 action g s \o fmap m s) ->
      forall s : sort Sigma, algebra_morphism__FCL g s =1 m s.
  Proof.
    move => g m mC s x.
    rewrite /algebra_morphism__FCL.
    apply: canonical_morphism_unique => //.
      by exact cancel_coAction__FCL_action.
  Qed.

  Theorem sound_algebra_morphism__FCL:
    forall (g: sigAlg Sigma) s x, AlgGen Sigma g s (algebra_morphism__FCL g s x).
  Proof.
    move => g s x.
      by apply: canonical_morphism_sound.
  Qed.

  Theorem complete_algebra_morphism__FCL:
    forall (g: sigAlg Sigma) s x, AlgGen Sigma g s x -> exists y, (algebra_morphism__FCL g s y) = x.
  Proof.
    move => g s x /canonical_morphism_complete prf.
    apply: (prf (sigAlg_Type action__FCL)).
      by apply: cancel_action_coAction__FCL.
  Qed.

End FCLAlgebra.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing Not %\ensuremath\neg% #~# *)
(** printing CNot %\ensuremath\neg% #~# *)
(** printing Iff %\ensuremath\Leftrightarrow% #⇔# *)
(** printing CFalse %\ensuremath\bot% #⊥# *)
(** printing False %\ensuremath\bot% #⊥# *)
(** printing CTrue %\ensuremath\top% *)
(** printing True %\ensuremath\top% *)
(** printing or %\ensuremath{\mathrel\vee}% *)
(** printing and %\ensuremath{\mathrel\wedge}% *)

Require Export Coq.Arith.Compare_dec.
Require Export CoRN.logic.CornBasics.
Require Export Coq.ZArith.ZArith.
Require Export Coq.setoid_ring.ZArithRing.
Require Export Coq.Arith.Div2.
Require Export Coq.Arith.Wf_nat.
From Coq Require Import Lia.

Set Automatic Introduction.

(**
* Extending the Coq Logic
Because notions of apartness and order have computational meaning, we
will have to define logical connectives in [Type].  In order to
keep a syntactic distinction between types of terms, we define [CProp]
as an alias for [Type], to be used as type of (computationally meaningful)
propositions.

Falsehood and negation will typically not be needed in [CProp], as
they are used to refer to negative statements, which carry no
computational meaning.  Therefore, we will simply define a negation
operator from [Type] to [Prop] .

Conjunction, disjunction and existential quantification will have to come in
multiple varieties.  For conjunction, we will need four operators of type
[s1->s2->s3], where [s3] is [Prop] if both [s1] and [s2]
are [Prop] and [CProp] otherwise.
We here take advantage of the inclusion of [Prop] in [Type].

Disjunction is slightly different, as it will always return a value in [CProp] even
if both arguments are propositions.  This is because in general
it may be computationally important to know which of the two branches of the
disjunction actually holds.

Existential quantification will similarly always return a value in [CProp].

- [CProp]-valued conjuction will be denoted as [and];
- [Crop]-valued conjuction will be denoted as [or];
- Existential quantification will be written as [{x:A & B}] or [{x:A | B}],
according to whether [B] is respectively of type [CProp] or [Prop].

In a few specific situations we do need truth, false and negation in [CProp],
so we will also introduce them; this should be a temporary option.

Finally, for other formulae that might occur in our [CProp]-valued
propositions, such as [(le m n)], we have to introduce a [CProp]-valued
version.
*)

Notation "'CProp'":= Type.

Section Basics.
(**
** Basics
Here we treat conversion from [Prop] to [CProp] and vice versa,
and some basic connectives in [CProp].
*)

Definition True_constr := I.
  (* The name I is occasionally used for other things, hiding True's constructor. *)

Definition Not (P : CProp) := P -> False.

Definition Iff (A B : CProp) : CProp := prod (A -> B) (B -> A).

Definition proj1_sigT (A : Type) (P : A -> CProp) (e : sigT P) :=
  match e with
  | existT _ a b => a
  end.

Definition proj2_sigT (A : Type) (P : A -> CProp) (e : sigT P) :=
  match e return (P (proj1_sigT A P e)) with
  | existT _ a b => b
  end.

Inductive sig2T (A : Type) (P Q : A -> CProp) : CProp :=
    exist2T : forall x : A, P x -> Q x -> sig2T A P Q.

Definition proj1_sig2T (A : Type) (P Q : A -> CProp) (e : sig2T A P Q) :=
  match e with
  | exist2T _ _ _ a b c => a
  end.

Definition proj2a_sig2T (A : Type) (P Q : A -> CProp) (e : sig2T A P Q) :=
  match e return (P (proj1_sig2T A P Q e)) with
  | exist2T _ _ _ a b c => b
  end.

Definition proj2b_sig2T (A : Type) (P Q : A -> CProp) (e : sig2T A P Q) :=
  match e return (Q (proj1_sig2T A P Q e)) with
  | exist2T _ _ _ a b c => c
  end.

End Basics.

(* begin hide *)
Infix "or" := sum (at level 85, right associativity).

Infix "and" := prod (at level 80, right associativity).

Notation "A 'IFF' B" := (Iff A B) (at level 95, no associativity).

Notation ProjT1 := (proj1_sigT _ _).

Notation ProjT2 := (proj2_sigT _ _).
(* end hide *)

(**
Some lemmas to make it possible to use [Step]
when reasoning with bi-implications. *)

Lemma Iff_left :
  forall (A B C : CProp),
  (A IFF B) -> (A IFF C) -> (C IFF B).
Proof.
 unfold Iff.
 intuition.
Qed.

Lemma Iff_right:
  forall (A B C : CProp),
  (A IFF B) -> (A IFF C) -> (B IFF C).
Proof.
 unfold Iff.
 intuition.
Qed.

Lemma Iff_refl : forall (A : CProp), (A IFF A).
Proof.
 unfold Iff.
 intuition.
Qed.

Lemma Iff_sym :
  forall (A B : CProp),(A IFF B) -> (B IFF A).
Proof.
 unfold Iff.
 intuition.
Qed.

Lemma Iff_trans :
  forall (A B C : CProp),
  (prod (A IFF B) (B IFF C)) -> (A IFF C).
Proof.
 unfold Iff.
 intuition.
Qed.

Lemma Iff_imp_imp :
  forall (A B : CProp),
  (A IFF B) -> (prod (A->B) (B->A)).
Proof.
 unfold Iff.
 intuition.
Qed.

Declare Right Step Iff_right.
Declare Left Step Iff_left.
#[global]
Hint Resolve Iff_trans Iff_sym Iff_refl Iff_right Iff_left Iff_imp_imp : algebra.

Lemma not_r_cor_rect :
  forall (A B : CProp) (S : Type) (l r : S),
  Not B ->
  forall H : A or B,
  @sum_rect A B (fun _ : A or B => S) (fun x : A => l) (fun x : B => r) H = l.
Proof.
 intros. elim H0.
 intros. reflexivity.
  intro. elim H. assumption.
Qed.

Lemma not_l_cor_rect :
  forall (A B : CProp) (S : Type) (l r : S),
  Not A ->
  forall H : A or B,
  @sum_rect A B (fun _ : A or B => S) (fun x : A => l) (fun x : B => r) H = r.
Proof.
 intros. elim H0.
 intro. elim H. assumption.
  intros. reflexivity.
Qed.

(* begin hide *)
(** This notation is incompatible with [Program]. It should be avoided *)
Notation "{ x : A  |  P }" := (sigT (fun x : A => P):CProp)
  (at level 0, x at level 99) : type_scope.
Notation "{ x : A  |  P  |  Q }" :=
  (sig2T A (fun x : A => P) (fun x : A => Q)) (at level 0, x at level 99) :
  type_scope.

(* end hide *)

#[global]
Hint Resolve pair inl inr existT exist2T : core.

Section Choice.
(* **Choice
Let [P] be a predicate on $\NN^2$#N times N#.
*)

Variable P : nat -> nat -> Prop.

Lemma choice :
  (forall n : nat, {m : nat | P n m}) ->
  {d : nat -> nat | forall n : nat, P n (d n)}.
Proof.
 intro H.
 exists (fun i : nat => proj1_sigT _ _ (H i)).
 apply (fun i : nat => proj2_sigT _ _ (H i)).
Qed.

End Choice.

Section Logical_Remarks.

(** We prove a few logical results which are helpful to have as lemmas
when [A], [B] and [C] are non trivial.
*)

Lemma CNot_Not_or : forall A B C : CProp,
 (A -> Not C) -> (B -> Not C) -> ~ Not (A or B) -> Not C.
Proof.
 intros A B C H H0 H1.
 intro H2.
 apply H1.
 intro H3.
 elim H3.
  intro; apply H; auto.
 intro; apply H0; auto.
Qed.

Lemma CdeMorgan_ex_all : forall (A : Type) (P : A -> CProp) (X : Type),
 (sigT P -> X) -> forall a : A, P a -> X.
Proof.
 intros A P X H a H0.
 eauto.
Qed.

End Logical_Remarks.

Section CRelation_Definition.

(**
** [CProp]-valued Relations
Similar to Relations.v in Coq's standard library.

%\begin{convention}% Let [A:Type] and [R:Crelation].
%\end{convention}%
*)

Variable A : Type.

Definition Crelation := A -> A -> CProp.

Variable R : Crelation.

Definition Creflexive : CProp :=
  forall x : A, R x x.

Definition Ctransitive : CProp :=
  forall x y z : A, R x y -> R y z -> R x z.

Definition Csymmetric : CProp :=
  forall x y : A, R x y -> R y x.

Record Cequivalence : CProp :=
  {Cequiv_refl  : Creflexive;
   Cequiv_symm  : Csymmetric;
   Cequiv_trans : Ctransitive}.

Definition Cdecidable (P:CProp):= P or Not P.

End CRelation_Definition.

Fixpoint member (A : Type) (n : A) (l : list A) {struct l} : CProp :=
  match l with
  | nil => False
  | cons y m => member A n m or y = n
  end.

Arguments member [A].

Section TRelation_Definition.
(**
** [Prop]-valued Relations
Analogous.

%\begin{convention}% Let [A:Type] and [R:Trelation].
%\end{convention}%
*)

Variable A : Type.

Definition Trelation := A -> A -> Prop.

Variable R : Trelation.

Definition Treflexive : CProp := forall x : A, R x x.

Definition Ttransitive : CProp := forall x y z : A, R x y -> R y z -> R x z.

Definition Tsymmetric : CProp := forall x y : A, R x y -> R y x.

Definition Tequiv : CProp := Treflexive and Ttransitive and Tsymmetric.

End TRelation_Definition.

Section le_odd.

(**
** The relation [le], [lt], [odd] and [even] in [CProp]
*)

Inductive Cle (n : nat) : nat -> CProp :=
  | Cle_n : Cle n n
  | Cle_S : forall m : nat, Cle n m -> Cle n (S m).

Theorem Cnat_double_ind : forall R : nat -> nat -> CProp,
 (forall n : nat, R 0 n) -> (forall n : nat, R (S n) 0) ->
 (forall n m : nat, R n m -> R (S n) (S m)) -> forall n m : nat, R n m.
Proof.
 simple induction n; auto.
 simple induction m; auto.
Qed.

Theorem my_Cle_ind : forall (n : nat) (P : nat -> CProp),
 P n -> (forall m : nat, Cle n m -> P m -> P (S m)) ->
 forall n0 : nat, Cle n n0 -> P n0.
Proof.
 intros n P.
 generalize (Cle_rect n (fun (n0 : nat) (H : Cle n n0) => P n0)); intro.
 assumption.
Qed.

Theorem Cle_n_S : forall n m : nat, Cle n m -> Cle (S n) (S m).
Proof.
 intros n m H.
 pattern m in |- *.
 apply (my_Cle_ind n).
   apply Cle_n.
  intros.
  apply Cle_S.
  assumption.
 assumption.
Qed.

Lemma toCle : forall m n : nat, m <= n -> Cle m n.
Proof.
 intros m.
 induction  m as [| m Hrecm].
  simple induction n.
   intro H.
   apply Cle_n.
  intros n0 H H0.
  apply Cle_S.
  apply H.
  apply le_O_n.
 simple induction n.
  intro.
  exfalso.
  inversion H.
 intros n0 H H0.
 generalize (le_S_n _ _ H0); intro H1.
 generalize (Hrecm _ H1); intro H2.
 apply Cle_n_S.
 assumption.
Qed.

Hint Resolve toCle.

Lemma Cle_to : forall m n : nat, Cle m n -> m <= n.
Proof.
 intros m n H.
 elim H.
  apply le_n.
 intros m0 s H0.
 apply le_S.
 assumption.
Qed.

Definition Clt (m n : nat) : CProp := Cle (S m) n.

Lemma toCProp_lt : forall m n : nat, m < n -> Clt m n.
Proof.
 unfold lt in |- *.
 unfold Clt in |- *.
 intros m n H.
 apply toCle.
 assumption.
Qed.

Lemma Clt_to : forall m n : nat, Clt m n -> m < n.
Proof.
 unfold lt in |- *.
 unfold Clt in |- *.
 intros m n H.
 apply Cle_to.
 assumption.
Qed.

Lemma Cle_le_S_eq : forall p q : nat, p <= q -> {S p <= q} + {p = q}.
Proof.
 intros p q H.
 elim (gt_eq_gt_dec p q); intro H0.
  elim H0; auto.
 exfalso.
 apply lt_not_le with q p; auto.
Qed.

Lemma Cnat_total_order : forall m n : nat, m <> n -> {m < n} + {n < m}.
Proof.
 intros m n H.
 elim (gt_eq_gt_dec m n).
  intro H0.
  elim H0; intros.
   left; auto.
  exfalso.
  auto.
 auto.
Qed.

Inductive Codd : nat -> CProp :=
    Codd_S : forall n : nat, Ceven n -> Codd (S n)
with Ceven : nat -> CProp :=
  | Ceven_O : Ceven 0
  | Ceven_S : forall n : nat, Codd n -> Ceven (S n).

Lemma Codd_even_to : forall n : nat, (Codd n -> odd n) /\ (Ceven n -> even n).
Proof.
 simple induction n.
  split.
   intro H.
   inversion H.
  intro.
  apply even_O.
 intros n0 H.
 elim H; intros H0 H1.
 split.
  intro H2.
  inversion H2.
  apply odd_S.
  apply H1.
  assumption.
 intro H2.
 inversion H2.
 apply even_S.
 apply H0.
 assumption.
Qed.

Lemma Codd_to : forall n : nat, Codd n -> odd n.
Proof.
 intros n H.
 elim (Codd_even_to n); auto.
Qed.

Lemma Ceven_to : forall n : nat, Ceven n -> even n.
Proof.
 intros n H.
 elim (Codd_even_to n); auto.
Qed.

Lemma to_Codd_even : forall n : nat, (odd n -> Codd n) and (even n -> Ceven n).
Proof.
 simple induction n.
  split.
   intro H.
   exfalso.
   inversion H.
  intro H.
  apply Ceven_O.
 intros n0 H.
 elim H; intros H0 H1.
 split.
  intro H2.
  apply Codd_S.
  apply H1.
  inversion H2.
  assumption.
 intro H2.
 apply Ceven_S.
 apply H0.
 inversion H2.
 assumption.
Qed.

Lemma to_Codd : forall n : nat, odd n -> Codd n.
Proof.
 intros.
 elim (to_Codd_even n); auto.
Qed.

Lemma to_Ceven : forall n : nat, even n -> Ceven n.
Proof.
 intros.
 elim (to_Codd_even n); auto.
Qed.

End le_odd.

Section Misc.

(**
** Miscellaneous
*)

Lemma CZ_exh : forall z : Z, {n : nat | z = n} or {n : nat | z = (- n)%Z}.
Proof.
 intro z.
 elim z.
   left.
   exists 0.
   auto.
  intro p.
  left.
  exists (nat_of_P p).
  rewrite convert_is_POS.
  reflexivity.
 intro p.
 right.
 exists (nat_of_P p).
 rewrite min_convert_is_NEG.
 reflexivity.
Qed.

Lemma Cnats_Z_ind : forall P : Z -> CProp,
 (forall n : nat, P n) -> (forall n : nat, P (- n)%Z) -> forall z : Z, P z.
Proof.
 intros P H H0 z.
 elim (CZ_exh z); intros H1.
  elim H1; intros n H2.
  rewrite H2.
  apply H.
 elim H1; intros n H2.
 rewrite H2.
 apply H0.
Qed.

Lemma Cdiff_Z_ind : forall P : Z -> CProp,
 (forall m n : nat, P (m - n)%Z) -> forall z : Z, P z.
Proof.
 intros P H z.
 apply Cnats_Z_ind.
  intro n.
  replace (Z_of_nat n) with (n - 0%nat)%Z.
   apply H.
  simpl in |- *.
  auto with zarith.
 intro n.
 replace (- n)%Z with (0%nat - n)%Z.
  apply H.
 simpl in |- *.
 reflexivity.
Qed.

Lemma Cpred_succ_Z_ind : forall P : Z -> CProp,
 P 0%Z -> (forall n : Z, P n -> P (n + 1)%Z) ->
 (forall n : Z, P n -> P (n - 1)%Z) -> forall z : Z, P z.
Proof.
 intros P H H0 H1 z.
 apply Cnats_Z_ind.
  intro n.
  elim n.
   exact H.
  intros n0 H2.
  replace (S n0:Z) with (n0 + 1)%Z.
   apply H0.
   assumption.
  rewrite Znat.inj_S.
  reflexivity.
 intro n.
 elim n.
  exact H.
 intros n0 H2.
 replace (- S n0)%Z with (- n0 - 1)%Z.
  apply H1.
  assumption.
 rewrite Znat.inj_S.
 unfold Z.succ in |- *.
 rewrite Zopp_plus_distr.
 reflexivity.
Qed.

Lemma not_r_sum_rec : forall (A B S : Set) (l r : S), Not B -> forall H : A + B,
 sum_rec (fun _ : A + B => S) (fun x : A => l) (fun x : B => r) H = l.
Proof.
 intros A B S l r H H0. elim H0.
 intro a. reflexivity.
  intro b. elim H. assumption.
Qed.

Lemma not_l_sum_rec : forall (A B S : Set) (l r : S), Not A -> forall H : A + B,
 sum_rec (fun _ : A + B => S) (fun x : A => l) (fun x : B => r) H = r.
Proof.
 intros A B S l r H H0. elim H0.
 intro a. elim H. assumption.
  intros. reflexivity.
Qed.

(**
%\begin{convention}%
Let [M:Type].
%\end{convention}%
*)

Variable M : Type.

Lemma member_app :
  forall (x : M) (l k : (list M)),
  (Iff (member x (app k l))
       ((member x k) or (member x l))).
Proof.
 induction k; firstorder.
Qed.

End Misc.

(**
** Results about the natural numbers

We now define a class of predicates on a finite subset of natural
numbers that will be important throughout all our work.  Essentially,
these are simply setoid predicates, but for clarity we will never
write them in that form but we will single out the preservation of the
setoid equality.
*)

Definition nat_less_n_pred (n : nat) (P : forall i : nat, i < n -> CProp) :=
  forall i j : nat, i = j -> forall (H : i < n) (H' : j < n), P i H -> P j H'.

Definition nat_less_n_pred' (n : nat) (P : forall i : nat, i <= n -> CProp) :=
  forall i j : nat, i = j -> forall (H : i <= n) (H' : j <= n), P i H -> P j H'.

Arguments nat_less_n_pred [n].
Arguments nat_less_n_pred' [n].

Section Odd_and_Even.

(**
For our work we will many times need to distinguish cases between even or odd numbers.
We begin by proving that this case distinction is decidable.
Next, we prove the usual results about sums of even and odd numbers:
*)

Lemma even_plus_n_n : forall n : nat, even (n + n).
Proof.
 intro n; induction  n as [| n Hrecn].
  auto with arith.
 replace (S n + S n) with (S (S (n + n))).
  apply even_S; apply odd_S; apply Hrecn.
 rewrite plus_n_Sm; simpl in |- *; auto.
Qed.

Lemma even_or_odd_plus : forall k : nat, {j : nat &  {k = j + j} + {k = S (j + j)}}.
Proof.
 intro k.
 elim (even_odd_dec k); intro H.
  elim (even_2n k H); intros j Hj; exists j; auto.
 elim (odd_S2n k H); intros j Hj; exists j; auto.
Qed.

(** Finally, we prove that an arbitrary natural number can be written in some canonical way.
*)

Lemma even_or_odd_plus_gt : forall i j : nat,
 i <= j -> {k : nat &  {j = i + (k + k)} + {j = i + S (k + k)}}.
Proof.
 intros i j H.
 elim (even_or_odd_plus (j - i)).
 intros k Hk.
 elim Hk; intro H0.
  exists k; left; rewrite <- H0; auto with arith.
 exists k; right; rewrite <- H0; auto with arith.
Qed.

End Odd_and_Even.

#[global]
Hint Resolve even_plus_n_n: arith.
#[global]
Hint Resolve toCle: core.

Section Natural_Numbers.

(**
** Algebraic Properties

We now present a series of trivial things proved with [Lia] that are
stated as lemmas to make proofs shorter and to aid in auxiliary
definitions.  Giving a name to these results allows us to use them in
definitions keeping conciseness.
*)

Lemma Clt_le_weak : forall i j : nat, Clt i j -> Cle i j.
Proof.
 intros.
 apply toCle; apply lt_le_weak; apply Clt_to; assumption.
Qed.

Lemma lt_5 : forall i n : nat, i < n -> pred i < n.
Proof.
 intros; apply le_lt_trans with (pred n).
  apply le_pred; auto with arith.
 apply lt_pred_n_n; apply le_lt_trans with i; auto with arith.
Qed.

Lemma lt_8 : forall m n : nat, m < pred n -> m < n.
Proof.
 intros; apply lt_le_trans with (pred n); auto with arith.
Qed.

Lemma pred_lt : forall m n : nat, m < pred n -> S m < n.
Proof.
 intros; apply le_lt_trans with (pred n); auto with arith.
 apply lt_pred_n_n; apply le_lt_trans with m.
  auto with arith.
 apply lt_le_trans with (pred n); auto with arith.
Qed.

Lemma lt_10 : forall i m n : nat,
 0 < i -> i < pred (m + n) -> pred i < pred m + pred n.
Proof.
 intros; lia.
Qed.

Lemma lt_pred' : forall m n : nat, 0 < m -> m < n -> pred m < pred n.
Proof.
 intros m n H H0; red in |- *.
 destruct n.
  inversion H0.
 rewrite <- (S_pred m 0); auto.
 simpl in |- *.
 auto with arith.
Qed.

Lemma le_1 : forall m n : nat, Cle m n -> pred m <= n.
Proof.
 intros.
 cut (m <= n); [ intro | apply Cle_to; assumption ].
 apply le_trans with (pred n); auto with arith.
 apply le_pred; auto.
Qed.

Lemma le_2 : forall i j : nat, i < j -> i <= pred j.
Proof.
 intros; lia.
Qed.

Lemma plus_eq_one_imp_eq_zero : forall m n : nat,
 m + n <= 1 -> {m = 0} + {n = 0}.
Proof.
 intros m n H.
 elim (le_lt_dec m 0); intro.
  left; auto with arith.
 right; lia.
Qed.

Lemma not_not_lt : forall i j : nat, ~ ~ i < j -> i < j.
Proof.
 intros; lia.
Qed.

Lemma plus_pred_pred_plus :
  forall i j k,
  k <= pred i + pred j ->
  k <= pred (i + j).
Proof.
 intros; lia.
Qed.

(** We now prove some properties of functions on the natural numbers.

%\begin{convention}% Let [H:nat->nat].
%\end{convention}%
*)

Variable h : nat -> nat.

(**
First we characterize monotonicity by a local condition: if [h(n) < h(n+1)]
for every natural number [n] then [h] is monotonous.  An analogous result
holds for weak monotonicity.
*)

Lemma nat_local_mon_imp_mon :
  (forall i : nat, h i < h (S i)) ->
  forall i j : nat, i < j -> h i < h j.
Proof.
 intros H i j H0.
 induction  j as [| j Hrecj].
  exfalso; lia.
 cut (i <= j); [ intro H1 | auto with arith ].
 elim (le_lt_eq_dec _ _ H1); intro H2.
  cut (h i < h j); [ intro | apply Hrecj; assumption ].
  cut (h j < h (S j)); [ intro | apply H ].
  apply lt_trans with (h j); auto.
 rewrite H2; apply H.
Qed.

Lemma nat_local_mon_imp_mon_le :
  (forall i : nat, h i <= h (S i)) ->
  forall i j : nat, i <= j -> h i <= h j.
Proof.
 intros H i j H0.
 induction  j as [| j Hrecj].
  cut (i = 0); [ intro H1 | auto with arith ].
  rewrite H1; apply le_n.
 elim (le_lt_eq_dec _ _ H0); intro H1.
  cut (h i <= h j); [ intro | apply Hrecj; auto with arith ].
  cut (h j <= h (S j)); [ intro | apply H ].
  apply le_trans with (h j); auto.
 rewrite H1; apply le_n.
Qed.

(** A strictly increasing function is injective: *)

Lemma nat_mon_imp_inj : (forall i j : nat, i < j -> h i < h j) ->
 forall i j : nat, h i = h j -> i = j.
Proof.
 intros H i j H0.
 cut (~ i <> j); [ lia | intro H1 ].
 cut (i < j \/ j < i); [ intro H2 | lia ].
 inversion_clear H2.
  cut (h i < h j); [ rewrite H0; apply lt_irrefl | apply H; assumption ].
 cut (h j < h i); [ rewrite H0; apply lt_irrefl | apply H; assumption ].
Qed.

(** And (not completely trivial) a function that preserves [lt] also preserves [le]. *)

Lemma nat_mon_imp_mon' : (forall i j : nat, i < j -> h i < h j) ->
 forall i j : nat, i <= j -> h i <= h j.
Proof.
 intros H i j H0.
 elim (le_lt_eq_dec _ _ H0); intro H1.
  apply lt_le_weak; apply H; assumption.
 rewrite H1; apply le_n.
Qed.

(**
The last lemmas in this section state that a monotonous function in the
 natural numbers completely covers the natural numbers, that is, for every
natural number [n] there is an [i] such that [h(i) <= n<(n+1) <= h(i+1)].
These are useful for integration.
*)

Lemma mon_fun_covers : (forall i j, i < j -> h i < h j) -> h 0 = 0 ->
 forall n, {k : nat | S n <= h k} -> {i : nat | h i <= n | S n <= h (S i)}.
Proof.
 intros H H0 n H1.
 elim H1; intros k Hk.
 induction  k as [| k Hreck].
  exists 0.
   rewrite H0; auto with arith.
  cut (h 0 < h 1); [ intro; apply le_trans with (h 0); auto with arith | apply H; apply lt_n_Sn ].
 cut (h k < h (S k)); [ intro H2 | apply H; apply lt_n_Sn ].
 elim (le_lt_dec (S n) (h k)); intro H3.
  elim (Hreck H3); intros i Hi.
  exists i; assumption.
 exists k; auto with arith.
Qed.

Lemma weird_mon_covers : forall n (f : nat -> nat), (forall i, f i < n -> f i < f (S i)) ->
 {m : nat | n <= f m | forall i, i < m -> f i < n}.
Proof.
 intros; induction  n as [| n Hrecn].
  exists 0.
   auto with arith.
  intros; inversion H0.
 elim Hrecn.
  2: auto.
 intros m Hm Hm'.
 elim (le_lt_eq_dec _ _ Hm); intro.
  exists m.
   assumption.
  auto with arith.
 exists (S m).
  apply le_lt_trans with (f m).
   rewrite b; auto with arith.
  apply H.
  rewrite b; apply lt_n_Sn.
 intros.
 elim (le_lt_eq_dec _ _ H0); intro.
  auto with arith.
 cut (i = m); [ intro | auto ].
 rewrite b; rewrite <- H1.
 apply lt_n_Sn.
Qed.

End Natural_Numbers.

(**
Useful for the Fundamental Theorem of Algebra.
*)

Lemma kseq_prop :
  forall (k : nat -> nat) (n : nat),
  (forall i : nat, 1 <= k i /\ k i <= n) ->
  (forall i : nat, k (S i) <= k i) ->
  {j : nat | S j < 2 * n /\ k j = k (S j) /\ k (S j) = k (S (S j))}.
Proof.
 intros k n.
 generalize k; clear k.
 induction  n as [| n Hrecn]; intros k H H0.
  elim (H 0); intros H1 H2.
  generalize (le_trans _ _ _ H1 H2); intro H3.
  exfalso.
  inversion H3.
 elim (eq_nat_dec (k 0) (k 2)).
  intro H1.
  exists 0.
  cut (k 0 = k 1).
   intro H2.
   repeat split.
     lia.
    assumption.
   rewrite <- H1.
   auto.
  apply le_antisym.
   rewrite H1.
   apply H0.
  apply H0.
 intro H1.
 elim (Hrecn (fun m : nat => k (S (S m)))).
   3: intro; apply H0.
  intros m Hm.
  exists (S (S m)); lia.
 intro i.
 split.
  elim (H (S (S i))); auto.
 elim (lt_eq_lt_dec (k 0) (k 2)); intro H2.
  elim H2; intro H3.
   generalize (H0 0); intro H4.
   generalize (H0 1); intro H5.
   lia.
  tauto.
 generalize (H 0); intro H3.
 elim H3; intros H4 H5.
 generalize (lt_le_trans _ _ _ H2 H5); intro H6.
 cut (k 2 <= n).
  2: lia.
 intro H7.
 induction  i as [| i Hreci].
  assumption.
 apply le_trans with (k (S (S i))); auto.
Qed.

Section Predicates_to_CProp.

(**
** Logical Properties

This section contains lemmas that aid in logical reasoning with
natural numbers.  First, we present some principles of induction, both
for [CProp]- and [Prop]-valued predicates.  We begin by presenting the
results for [CProp]-valued predicates:
*)

Lemma even_induction :
  forall P : nat -> CProp,
  P 0 ->
  (forall n, even n -> P n -> P (S (S n))) ->
  forall n, even n -> P n.
Proof.
 intros P H H0 n.
 pattern n in |- *; apply lt_wf_rect.
 clear n.
 intros n H1 H2.
 induction  n as [| n Hrecn].
  auto.
 induction  n as [| n Hrecn0].
  exfalso; inversion H2; inversion H4.
 apply H0.
  inversion H2; inversion H4; auto.
 apply H1.
  auto with arith.
 inversion H2; inversion H4; auto.
Qed.

Lemma odd_induction :
  forall P : nat -> CProp,
  P 1 ->
  (forall n, odd n -> P n -> P (S (S n))) ->
  forall n, odd n -> P n.
Proof.
 intros P H H0 n; case n.
  intro H1; exfalso; inversion H1.
 clear n; intros n H1.
 pattern n in |- *; apply even_induction; auto.
  intros n0 H2 H3; auto with arith.
 inversion H1; auto.
Qed.

Lemma four_induction :
  forall P : nat -> CProp,
  P 0 -> P 1 -> P 2 -> P 3 ->
  (forall n, P n -> P (S (S (S (S n))))) ->
  forall n, P n.
Proof.
 intros.
 apply lt_wf_rect.
 intro m.
 case m; auto.
 clear m; intro m.
 case m; auto.
 clear m; intro m.
 case m; auto.
 clear m; intro m.
 case m; auto with arith.
Qed.

Lemma nat_complete_double_induction : forall P : nat -> nat -> CProp,
 (forall m n, (forall m' n', m' < m -> n' < n -> P m' n') -> P m n) -> forall m n, P m n.
Proof.
 intros P H m.
 pattern m in |- *; apply lt_wf_rect; auto with arith.
Qed.

Lemma odd_double_ind : forall P : nat -> CProp, (forall n, odd n -> P n) ->
 (forall n, 0 < n -> P n -> P (double n)) -> forall n, 0 < n -> P n.
Proof.
 cut (forall n : nat, 0 < double n -> 0 < n). intro.
  intro. intro H0. intro H1. intro n.
  pattern n in |- *.
  apply lt_wf_rect. intros n0 H2 H3.
  generalize (even_odd_dec n0). intro H4. elim H4.
  intro.
   rewrite (even_double n0).
    apply H1.
     apply H.
     rewrite <- (even_double n0). assumption.
      assumption.
    apply H2.
     apply lt_div2. assumption.
     rewrite (even_double n0) in H3.
     apply H. assumption.
     assumption.
   assumption.
  exact (H0 n0).
 unfold double in |- *. intros.
 case (zerop n). intro.
  absurd (0 < n + n).
   rewrite e. auto with arith.
   assumption.
 intro. assumption.
Qed.

(** For subsetoid predicates in the natural numbers we can eliminate
disjunction (and existential quantification) as follows.
*)

Lemma finite_or_elim :
  forall (n : nat) (P Q : forall i, i <= n -> CProp),
  nat_less_n_pred' P ->
  nat_less_n_pred' Q ->
  (forall i H, P i H or Q i H) ->
  {m : nat | {Hm : m <= n | P m Hm}} or (forall i H, Q i H).
Proof.
 intro n; induction  n as [| n Hrecn].
  intros P Q HP HQ H.
  elim (H _ (le_n 0)); intro H0.
   left; exists 0; exists (le_n 0); assumption.
  right; intros i H1.
  apply HQ with (H := le_n 0); auto with arith.
 intros P Q H H0 H1.
 elim (H1 _ (le_n (S n))); intro H2.
  left; exists (S n); exists (le_n (S n)); assumption.
 set (P' := fun (i : nat) (H : i <= n) => P i (le_S _ _ H)) in *.
 set (Q' := fun (i : nat) (H : i <= n) => Q i (le_S _ _ H)) in *.
 cut ({m : nat | {Hm : m <= n | P' m Hm}} or (forall (i : nat) (H : i <= n), Q' i H)).
  intro H3; elim H3; intro H4.
   left.
   elim H4; intros m Hm; elim Hm; clear H4 Hm; intros Hm Hm'.
   exists m.
   unfold P' in Hm'.
   exists (le_S _ _ Hm).
   eapply H with (i := m); [ lia | apply Hm' ].
  right.
  intros i H5.
  unfold Q' in H4.
  elim (le_lt_eq_dec _ _ H5); intro H6.
   cut (i <= n); [ intro | auto with arith ].
   eapply H0 with (i := i); [ auto with arith | apply (H4 i H7) ].
  eapply H0 with (i := S n); [ auto with arith | apply H2 ].
 apply Hrecn.
   intro i; intros j H3 H4 H5 H6.
   unfold P' in |- *.
   exact (H _ _ H3 _ _ H6).
  intro i; intros j H3 H4 H5 H6.
  unfold Q' in |- *.
  exact (H0 _ _ H3 _ _ H6).
 intros i H3.
 unfold P', Q' in |- *; apply H1.
Qed.

Lemma str_finite_or_elim :
  forall (n : nat) (P Q : forall i, i <= n -> CProp),
  nat_less_n_pred' P ->
  nat_less_n_pred' Q ->
  (forall i H, P i H or Q i H) ->
  {j : nat | {Hj : j <= n | P j Hj and (forall j' Hj', j' < j -> Q j' Hj')}}
  or (forall i H, Q i H).
Proof.
 intro n; induction  n as [| n Hrecn].
  intros P Q H H0 H1.
  elim (H1 0 (le_n 0)); intro HPQ.
   left.
   exists 0; exists (le_n 0).
   split.
    apply H with (H := le_n 0); auto.
   intros; exfalso; inversion H2.
  right; intros.
  apply H0 with (H := le_n 0); auto with arith.
 intros P Q H H0 H1.
 set (P' := fun (i : nat) (H : i <= n) => P i (le_S _ _ H)) in *.
 set (Q' := fun (i : nat) (H : i <= n) => Q i (le_S _ _ H)) in *.
 elim (Hrecn P' Q').
     intro H2.
     left.
     elim H2; intros m Hm; elim Hm; clear H2 Hm; intros Hm Hm'.
     exists m.
     unfold P' in Hm'.
     exists (le_S _ _ Hm).
     elim Hm'; clear Hm'; intros Hm' Hj.
     split.
      eapply H with (i := m); [ auto with arith | apply Hm' ].
     unfold Q' in Hj; intros j' Hj' H2.
     cut (j' <= n); [ intro H4 | apply le_trans with m; auto with arith ].
     apply H0 with (H := le_S _ _ H4); [ auto | apply Hj; assumption ].
    elim (H1 (S n) (le_n (S n))); intro H1'.
     intro H2.
     left; exists (S n); exists (le_n (S n)); split.
      assumption.
     intros j' Hj' H3; unfold Q' in H1'.
     cut (j' <= n); [ intro H4 | auto with arith ].
     unfold Q' in H2.
     apply H0 with (H := le_S _ _ H4); auto.
    intro H2.
    right; intros i H3.
    unfold Q' in H1'.
    elim (le_lt_eq_dec _ _ H3); intro H4.
     cut (i <= n); [ intro H5 | auto with arith ].
     unfold Q' in H2.
     apply H0 with (H := le_S _ _ H5); auto.
    apply H0 with (H := le_n (S n)); auto.
   intro i; intros j H2 H3 H4 H5.
   unfold P' in |- *.
   exact (H _ _ H2 _ _ H5).
  intro i; intros j H2 H3 H4 H5.
  unfold Q' in |- *.
  exact (H0 _ _ H2 _ _ H5).
 intros i H2.
 unfold P', Q' in |- *.
 apply H1.
Qed.

End Predicates_to_CProp.

Section Predicates_to_Prop.

(** Finally, analogous results for [Prop]-valued predicates are presented for
completeness's sake.
*)

Lemma even_ind : forall P : nat -> Prop,
 P 0 -> (forall n, even n -> P n -> P (S (S n))) -> forall n, even n -> P n.
Proof.
 intros P H H0 n.
 pattern n in |- *; apply lt_wf_ind.
 clear n.
 intros n H1 H2.
 induction  n as [| n Hrecn].
  auto.
 induction  n as [| n Hrecn0].
  exfalso; inversion H2; inversion H4.
 apply H0.
  inversion H2; inversion H4; auto.
 apply H1.
  auto with arith.
 inversion H2; inversion H4; auto.
Qed.

Lemma odd_ind : forall P : nat -> Prop,
 P 1 -> (forall n, P n -> P (S (S n))) -> forall n, odd n -> P n.
Proof.
 intros P H H0 n; case n.
  intro H1; exfalso; inversion H1.
 clear n; intros n H1.
 pattern n in |- *; apply even_ind; auto.
 inversion H1; auto.
Qed.

Lemma nat_complete_double_ind :
  forall P : nat -> nat -> Prop,
  (forall m n, (forall m' n', m' < m -> n' < n -> P m' n') -> P m n) ->
  forall m n, P m n.
Proof.
 intros P H m.
 pattern m in |- *; apply lt_wf_ind; auto.
Qed.

Lemma four_ind :
  forall P : nat -> Prop,
  P 0 -> P 1 -> P 2 -> P 3 ->
  (forall n, P n -> P (S (S (S (S n))))) -> forall n, P n.
Proof.
 intros.
 apply lt_wf_ind.
 intro m.
 case m; auto.
 clear m; intro m.
 case m; auto.
 clear m; intro m.
 case m; auto.
 clear m; intro m.
 case m; auto with arith.
Qed.

End Predicates_to_Prop.

(**
** Integers

Similar results for integers.
*)

(* begin hide *)
Tactic Notation "ElimCompare" constr(c) constr(d) :=  elim_compare c d.
(* end hide *)

Definition Zlts (x y : Z) := eq (A:=Datatypes.comparison) (x ?= y)%Z Datatypes.Lt.

Lemma toCProp_Zlt : forall x y : Z, (x < y)%Z -> Zlts x y.
Proof.
 intros x y H.
 unfold Zlts in |- *.
 unfold Z.lt in H.
 auto.
Qed.

Lemma CZlt_to : forall x y : Z, Zlts x y -> (x < y)%Z.
Proof.
 intros x y H.
 unfold Z.lt in |- *.
 inversion H.
 auto.
Qed.

Lemma Zsgn_1 : forall x : Z, {Z.sgn x = 0%Z} + {Z.sgn x = 1%Z} + {Z.sgn x = (-1)%Z}.
Proof.
 intro x.
 case x.
   left.
   left.
   unfold Z.sgn in |- *.
   reflexivity.
  intro p.
  simpl in |- *.
  left.
  right.
  reflexivity.
 intro p.
 right.
 simpl in |- *.
 reflexivity.
Qed.

Lemma Zsgn_2 : forall x : Z, Z.sgn x = 0%Z -> x = 0%Z.
Proof.
 intro x.
 case x.
   intro H.
   reflexivity.
  intros p H.
  inversion H.
 intros p H.
 inversion H.
Qed.

Lemma Zsgn_3 : forall x : Z, x <> 0%Z -> Z.sgn x <> 0%Z.
Proof.
 intro x.
 case x.
   intro H.
   elim H.
   reflexivity.
  intros p H.
  simpl in |- *.
  discriminate.
 intros p H.
 simpl in |- *.
 discriminate.
Qed.

(** The following have unusual names, in line with the series of lemmata in
fast_integers.v.
*)

Lemma ZL4' : forall y : positive, {h : nat | nat_of_P y = S h}.
Proof.
 simple induction y; [ intros p H; elim H; intros x H1; exists (S x + S x);
   unfold nat_of_P in |- *; simpl in |- *; rewrite ZL0;
     rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1; rewrite H1; auto with arith
       | intros p H1; elim H1; intros x H2; exists (x + S x);
         unfold nat_of_P in |- *; simpl in |- *; rewrite ZL0;
           rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2; rewrite H2; auto with arith
             | exists 0; auto with arith ].
Qed.

Lemma ZL9 : forall p : positive, Z_of_nat (nat_of_P p) = Zpos p.
Proof.
 intro p.
 elim (ZL4 p).
 intros x H0.
 rewrite H0.
 unfold Z_of_nat in |- *.
 apply f_equal with (A := positive) (B := Z) (f := Zpos).
 cut (P_of_succ_nat (nat_of_P p) = P_of_succ_nat (S x)).
  intro H1.
  rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H1.
  cut (Pos.pred (Pos.succ p) = Pos.pred (P_of_succ_nat (S x))).
   intro H2.
   rewrite Pos.pred_succ in H2.
   simpl in H2.
   rewrite Pos.pred_succ in H2.
   auto.
  apply f_equal with (A := positive) (B := positive) (f := Pos.pred).
  assumption.
 apply f_equal with (f := P_of_succ_nat).
 assumption.
Qed.

Theorem Zsgn_4 : forall a : Z, a = (Z.sgn a * Z.abs_nat a)%Z.
Proof.
 intro a.
 case a.
   simpl in |- *.
   reflexivity.
  intro p.
  unfold Z.sgn in |- *.
  unfold Z.abs_nat in |- *.
  rewrite Zmult_1_l.
  symmetry  in |- *.
  apply ZL9.
 intro p.
 unfold Z.sgn in |- *.
 unfold Z.abs_nat in |- *.
 rewrite ZL9.
 constructor.
Qed.

Theorem Zsgn_5 : forall a b x y : Z, x <> 0%Z -> y <> 0%Z ->
 (Z.sgn a * x)%Z = (Z.sgn b * y)%Z -> (Z.sgn a * y)%Z = (Z.sgn b * x)%Z.
Proof.
 intros a b x y H H0.
 case a.
   case b.
     simpl in |- *.
     trivial.
    intro p.
    unfold Z.sgn in |- *.
    intro H1.
    rewrite Zmult_1_l in H1.
    simpl in H1.
    elim H0.
    auto.
   intro p.
   unfold Z.sgn in |- *.
   intro H1.
   elim H0.
   apply Z.opp_inj.
   simpl in |- *.
   transitivity (-1 * y)%Z; auto.
  intro p.
  unfold Z.sgn at 1 in |- *.
  unfold Z.sgn at 2 in |- *.
  intro H1.
  transitivity y.
   rewrite Zmult_1_l.
   reflexivity.
  transitivity (Z.sgn b * (Z.sgn b * y))%Z.
   case (Zsgn_1 b).
    intro H2.
    case H2.
     intro H3.
     elim H.
     rewrite H3 in H1.
     change ((1 * x)%Z = 0%Z) in H1.
     rewrite Zmult_1_l in H1.
     assumption.
    intro H3.
    rewrite H3.
    rewrite Zmult_1_l.
    rewrite Zmult_1_l.
    reflexivity.
   intro H2.
   rewrite H2.
   ring.
  rewrite Zmult_1_l in H1.
  rewrite H1.
  reflexivity.
 intro p.
 unfold Z.sgn at 1 in |- *.
 unfold Z.sgn at 2 in |- *.
 intro H1.
 transitivity (Z.sgn b * (-1 * (Z.sgn b * y)))%Z.
  case (Zsgn_1 b).
   intro H2.
   case H2.
    intro H3.
    elim H.
    apply Z.opp_inj.
    transitivity (-1 * x)%Z.
     ring.
    unfold Z.opp in |- *.
    rewrite H3 in H1.
    transitivity (0 * y)%Z; auto.
   intro H3.
   rewrite H3.
   ring.
  intro H2.
  rewrite H2.
  ring.
 rewrite <- H1.
 ring.
Qed.

Lemma nat_nat_pos : forall m n : nat, ((m + 1) * (n + 1) > 0)%Z.
Proof.
 intros m n.
 apply Z.lt_gt.
 cut (Z_of_nat m + 1 > 0)%Z.
  intro H.
  cut (0 < Z_of_nat n + 1)%Z.
   intro H0.
   cut ((Z_of_nat m + 1) * 0 < (Z_of_nat m + 1) * (Z_of_nat n + 1))%Z.
    rewrite Zmult_0_r.
    auto.
   apply Zlt_reg_mult_l; auto.
  change (0 < Z.succ (Z_of_nat n))%Z in |- *.
  apply Zle_lt_succ.
  change (Z_of_nat 0 <= Z_of_nat n)%Z in |- *.
  apply Znat.inj_le.
  apply le_O_n.
 apply Z.lt_gt.
 change (0 < Z.succ (Z_of_nat m))%Z in |- *.
 apply Zle_lt_succ.
 change (Z_of_nat 0 <= Z_of_nat m)%Z in |- *.
 apply Znat.inj_le.
 apply le_O_n.
Qed.

Theorem S_predn : forall m : nat, m <> 0 -> S (pred m) = m.
Proof.
 intros m H.
 symmetry  in |- *.
 apply S_pred with 0.
 lia.
Qed.

Lemma absolu_1 : forall x : Z, Z.abs_nat x = 0 -> x = 0%Z.
Proof.
 intros x H.
 case (dec_eq x 0).
  auto.
 intro H0.
 apply False_ind.
 ElimCompare x 0%Z.
   intro H2.
   apply H0.
   elim (Zcompare_Eq_iff_eq x 0%nat).
   intros H3 H4.
   auto.
  intro H2.
  cut (exists h : nat, Z.abs_nat x = S h).
   intro H3.
   case H3.
   rewrite H.
   exact O_S.
  change (x < 0)%Z in H2.
  set (H3 := Z.lt_gt _ _ H2) in *.
  elim (Zcompare_Gt_spec _ _ H3).
  intros x0 H5.
  cut (exists q : positive, x = Zneg q).
   intro H6.
   case H6.
   intros x1 H7.
   rewrite H7.
   unfold Z.abs_nat in |- *.
   generalize x1.
   exact ZL4.
  cut (x = (- Zpos x0)%Z).
   simpl in |- *.
   intro H6.
   exists x0.
   assumption.
  rewrite <- (Z.opp_involutive x).
  exact (f_equal Z.opp H5).
 intro H2.
 cut (exists h : nat, Z.abs_nat x = S h).
  intro H3.
  case H3.
  rewrite H.
  exact O_S.
 elim (Zcompare_Gt_spec _ _ H2).
 simpl in |- *.
 rewrite Zplus_0_r.
 intros x0 H4.
 rewrite H4.
 unfold Z.abs_nat in |- *.
 generalize x0.
 exact ZL4.
Qed.

Lemma absolu_2 : forall x : Z, x <> 0%Z -> Z.abs_nat x <> 0.
Proof.
 intros x H.
 intro H0.
 apply H.
 apply absolu_1.
 assumption.
Qed.

Lemma Zgt_mult_conv_absorb_l : forall a x y : Z,
 (a < 0)%Z -> (a * x > a * y)%Z -> (x < y)%Z.
Proof.
 intros a x y H H0.
 case (dec_eq x y).
  intro H1.
  apply False_ind.
  rewrite H1 in H0.
  cut ((a * y)%Z = (a * y)%Z).
   change ((a * y)%Z <> (a * y)%Z) in |- *.
   apply Zgt_not_eq.
   assumption.
  trivial.
 intro H1.
 case (not_Zeq x y H1).
  trivial.
 intro H2.
 apply False_ind.
 cut (a * y > a * x)%Z.
  apply Zgt_asym with (m := (a * y)%Z) (n := (a * x)%Z).
  assumption.
 apply Zlt_conv_mult_l.
  assumption.
 assumption.
Qed.

Lemma Zgt_mult_reg_absorb_l : forall a x y : Z,
 (a > 0)%Z -> (a * x > a * y)%Z -> (x > y)%Z.
Proof.
 intros a x y H H0.
 cut (- a < - (0))%Z.
  rewrite <- (Z.opp_involutive a) in H.
  rewrite <- (Z.opp_involutive 0) in H.
  simpl in |- *.
  intro H1.
  rewrite <- (Z.opp_involutive x).
  rewrite <- (Z.opp_involutive y).
  apply Zlt_opp.
  apply Zgt_mult_conv_absorb_l with (a := (- a)%Z) (x := (- x)%Z).
   assumption.
  rewrite Zopp_mult_distr_l_reverse.
  rewrite Zopp_mult_distr_l_reverse.
  apply Zlt_opp.
  rewrite <- Zopp_mult_distr_r.
  rewrite <- Zopp_mult_distr_r.
  apply Z.gt_lt.
  apply Zlt_opp.
  apply Z.gt_lt.
  assumption.
 lia.
Qed.

Lemma Zmult_Sm_Sn : forall m n : Z,
 ((m + 1) * (n + 1))%Z = (m * n + (m + n) + 1)%Z.
Proof.
 intros.
 ring.
Qed.

Definition CForall {A: Type} (P: A -> Type): list A -> Type :=
  fold_right (fun x => prod (P x)) True.

Definition CForall_prop {A: Type} (P: A -> Prop) (l: list A):
 (forall x, In x l -> P x)  IFF  CForall P l.
Proof with firstorder. induction l... subst... Qed.

Lemma CForall_indexed {A} (P: A -> Type) (l: list A): CForall P l ->
  forall i (d: A), (i < length l)%nat -> P (nth i l d).
Proof.
 intros X i.
 revert l X.
 induction i; destruct l; simpl in *; intuition; exfalso; inversion H.
Qed.

Lemma CForall_map {A B} (P: B -> Type) (f: A -> B) (l: list A):
  CForall P (map f l)  IFF  CForall (fun x => P (f x)) l.
Proof. induction l; firstorder. Qed.

Lemma CForall_weak {A} (P Q: A -> Type):
  (forall x, P x -> Q x) ->
  (forall l, CForall P l -> CForall Q l).
Proof. induction l; firstorder. Qed.

Fixpoint CNoDup {T: Type} (R: T -> T -> Type) (l: list T): Type :=
  match l with
  | nil => True
  | h :: t => prod (CNoDup R t) (CForall (R h) t)
  end.

Lemma CNoDup_weak {A: Type} (Ra Rb: A -> A -> Type) (l: list A):
  (forall x y, Ra x y -> Rb x y) ->
  CNoDup Ra l -> CNoDup Rb l.
Proof with auto.
 induction l... firstorder.
 apply CForall_weak with (Ra a)...
Qed.

Lemma CNoDup_indexed {T} (R: T -> T -> Type) (Rsym: Csymmetric _ R) (l: list T) (d: T): CNoDup R l ->
  forall i j, (i < length l)%nat -> (j < length l)%nat -> i <> j -> R (nth i l d) (nth j l d).
Proof with intuition.
 induction l; simpl...
  exfalso...
 destruct i.
  destruct j...
  apply (CForall_indexed (R a) l)...
 destruct j...
 apply Rsym.
 apply (CForall_indexed (R a) l)...
Qed.

Lemma CNoDup_map {A B: Type} (R: B -> B -> Type) (f: A -> B):
  forall l, CNoDup (fun x y => R (f x) (f y)) l  IFF  CNoDup R (map f l).
Proof with auto; intuition.
 induction l; simpl...
 split; intro; split.
    apply IHl, X.
   apply CForall_map...
  apply IHl, X.
 apply CForall_map...
Qed.