Require Coq.setoid_ring.Ncring.
Require Coq.setoid_ring.Cring.
Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.OnSubterms.
Require Import Crypto.Util.Tactics.Revert.
Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Group Crypto.Algebra.Monoid.
Require Coq.ZArith.ZArith Coq.PArith.PArith.

Section Ring.
  Context {T eq zero one opp add sub mul} `{@ring T eq zero one opp add sub mul}.
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Notation "0" := zero. Local Notation "1" := one.
  Local Infix "+" := add. Local Infix "-" := sub. Local Infix "*" := mul.

  Lemma mul_0_l : forall x, 0 * x = 0.
  Proof using Type*.
    intros.
    assert (0*x = 0*x) as Hx by reflexivity.
    rewrite <-(right_identity 0), right_distributive in Hx at 1.
    assert (0*x + 0*x - 0*x = 0*x - 0*x) as Hxx by (rewrite Hx; reflexivity).
    rewrite !ring_sub_definition, <-associative, right_inverse, right_identity in Hxx; exact Hxx.
  Qed.

  Lemma mul_0_r : forall x, x * 0 = 0.
  Proof using Type*.
    intros.
    assert (x*0 = x*0) as Hx by reflexivity.
    rewrite <-(left_identity 0), left_distributive in Hx at 1.
    assert (opp (x*0) + (x*0 + x*0)  = opp (x*0) + x*0) as Hxx by (rewrite Hx; reflexivity).
    rewrite associative, left_inverse, left_identity in Hxx; exact Hxx.
  Qed.

  Lemma sub_0_l x : 0 - x = opp x.
  Proof using Type*. rewrite ring_sub_definition. rewrite left_identity. reflexivity. Qed.

  Lemma mul_opp_r x y : x * opp y = opp (x * y).
  Proof using Type*.
    assert (Ho:x*(opp y) + x*y = 0)
      by (rewrite <-left_distributive, left_inverse, mul_0_r; reflexivity).
    rewrite <-(left_identity (opp (x*y))), <-Ho; clear Ho.
    rewrite <-!associative, right_inverse, right_identity; reflexivity.
  Qed.

  Lemma mul_opp_l x y : opp x * y = opp (x * y).
  Proof using Type*.
    assert (Ho:opp x*y + x*y = 0)
      by (rewrite <-right_distributive, left_inverse, mul_0_l; reflexivity).
    rewrite <-(left_identity (opp (x*y))), <-Ho; clear Ho.
    rewrite <-!associative, right_inverse, right_identity; reflexivity.
  Qed.

  Definition opp_zero_iff : forall x, opp x = 0 <-> x = 0 := Group.inv_id_iff.

  Global Instance is_left_distributive_sub : is_left_distributive (eq:=eq)(add:=sub)(mul:=mul).
  Proof using Type*.
    split; intros. rewrite !ring_sub_definition, left_distributive.
    eapply Group.cancel_left, mul_opp_r.
  Qed.

  Global Instance is_right_distributive_sub : is_right_distributive (eq:=eq)(add:=sub)(mul:=mul).
  Proof using Type*.
    split; intros. rewrite !ring_sub_definition, right_distributive.
    eapply Group.cancel_left, mul_opp_l.
  Qed.

  Lemma sub_zero_iff x y : x - y = 0 <-> x = y.
  Proof using Type*.
    split; intro E.
    { rewrite <-(right_identity y), <- E, ring_sub_definition.
      rewrite commutative, <-associative, commutative.
      rewrite left_inverse, left_identity. reflexivity. }
    { rewrite E, ring_sub_definition, right_inverse; reflexivity. }
  Qed.

  Lemma neq_sub_neq_zero x y (Hxy:x<>y) : x-y <> 0.
  Proof using Type*.
    intro Hsub. apply Hxy. rewrite <-(left_identity y), <-Hsub, ring_sub_definition.
    rewrite <-associative, left_inverse, right_identity. reflexivity.
  Qed.

  Lemma zero_product_iff_zero_factor {Hzpzf:@is_zero_product_zero_factor T eq zero mul} :
    forall x y : T, eq (mul x y) zero <-> eq x zero \/ eq y zero.
  Proof using Type*.
    split; eauto using zero_product_zero_factor; [].
    intros [Hz|Hz]; rewrite Hz; eauto using mul_0_l, mul_0_r.
  Qed.

  Lemma nonzero_product_iff_nonzero_factor {Hzpzf:@is_zero_product_zero_factor T eq zero mul} :
    forall x y : T, not (eq (mul x y) zero) <-> (not (eq x zero) /\ not (eq y zero)).
  Proof using Type*. intros; rewrite zero_product_iff_zero_factor; tauto. Qed.

  Global Instance Ncring_Ring_ops : @Ncring.Ring_ops T zero one add mul sub opp eq.
  Global Instance Ncring_Ring : @Ncring.Ring T zero one add mul sub opp eq Ncring_Ring_ops.
  Proof using Type*.
    split; exact _ || cbv; intros; eauto using left_identity, right_identity, commutative, associative, right_inverse, left_distributive, right_distributive, ring_sub_definition with core typeclass_instances.
    - (* TODO: why does [eauto using @left_identity with typeclass_instances] not work? *)
      eapply @left_identity; eauto with typeclass_instances.
    - eapply @right_identity; eauto with typeclass_instances.
    - eapply associative.
    - intros; eapply right_distributive.
    - intros; eapply left_distributive.
  Qed.
End Ring.

Section Homomorphism.
  Context {R EQ ZERO ONE OPP ADD SUB MUL} `{@ring R EQ ZERO ONE OPP ADD SUB MUL}.
  Context {S eq zero one opp add sub mul} `{@ring S eq zero one opp add sub mul}.
  Context {phi:R->S}.
  Local Infix "=" := eq. Local Infix "=" := eq : type_scope.

  Class is_homomorphism :=
    {
      homomorphism_is_homomorphism : Monoid.is_homomorphism (phi:=phi) (OP:=ADD) (op:=add) (EQ:=EQ) (eq:=eq);
      homomorphism_mul : forall x y, phi (MUL x y) = mul (phi x) (phi y);
      homomorphism_one : phi ONE = one
    }.
  Global Existing Instance homomorphism_is_homomorphism.

  Context `{phi_homom:is_homomorphism}.

  Lemma homomorphism_zero : phi ZERO = zero.
  Proof using Type*. apply Group.homomorphism_id. Qed.

  Lemma homomorphism_add : forall x y,  phi (ADD x y) = add (phi x) (phi y).
  Proof using phi_homom. apply Monoid.homomorphism. Qed.

  Definition homomorphism_opp : forall x,  phi (OPP x) = opp (phi x) :=
    (Group.homomorphism_inv (INV:=OPP) (inv:=opp)).

  Lemma homomorphism_sub : forall x y, phi (SUB x y) = sub (phi x) (phi y).
  Proof using Type*.
    intros.
    rewrite !ring_sub_definition, Monoid.homomorphism, homomorphism_opp. reflexivity.
  Qed.

  Global Instance monoid_homomorphism_mul :
    Monoid.is_homomorphism (phi:=phi) (OP:=MUL) (op:=mul) (EQ:=EQ) (eq:=eq).
  Proof using phi_homom. split; destruct phi_homom; assumption || exact _. Qed.
End Homomorphism.

(* TODO: file a Coq bug for rewrite_strat -- it should accept ltac variables *)
Ltac push_homomorphism phi :=
  let H := constr:(_ : @is_homomorphism _ _ _ _ _ _ _ _ _ _ phi) in
  pose proof (@homomorphism_zero _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_0;
  pose proof (@homomorphism_one _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_1;
  pose proof (@homomorphism_add _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_p;
  pose proof (@homomorphism_opp _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_o;
  pose proof (@homomorphism_sub _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_s;
  pose proof (@homomorphism_mul _ _ _ _ _ _ _ _ _ _ _ H)
    as _push_homomrphism_m;
  (rewrite_strat bottomup (terms _push_homomrphism_0 _push_homomrphism_1 _push_homomrphism_p _push_homomrphism_o _push_homomrphism_s _push_homomrphism_m));
  clear _push_homomrphism_0 _push_homomrphism_1 _push_homomrphism_p _push_homomrphism_o _push_homomrphism_s _push_homomrphism_m.

Ltac pull_homomorphism phi :=
  let H := constr:(_ : @is_homomorphism _ _ _ _ _ _ _ _ _ _ phi) in
  pose proof (@homomorphism_zero _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_0;
  pose proof (@homomorphism_one _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_1;
  pose proof (@homomorphism_add _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_p;
  pose proof (@homomorphism_opp _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_o;
  pose proof (@homomorphism_sub _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_s;
  pose proof (@homomorphism_mul _ _ _ _ _ _ _ _ _ _ _ H)
    as _pull_homomrphism_m;
  symmetry in _pull_homomrphism_0;
  symmetry in _pull_homomrphism_1;
  symmetry in _pull_homomrphism_p;
  symmetry in _pull_homomrphism_o;
  symmetry in _pull_homomrphism_s;
  symmetry in _pull_homomrphism_m;
  (rewrite_strat bottomup (terms _pull_homomrphism_0 _pull_homomrphism_1 _pull_homomrphism_p _pull_homomrphism_o _pull_homomrphism_s _pull_homomrphism_m));
  clear _pull_homomrphism_0 _pull_homomrphism_1 _pull_homomrphism_p _pull_homomrphism_o _pull_homomrphism_s _pull_homomrphism_m.

Section Isomorphism.
  Context {F EQ ZERO ONE OPP ADD SUB MUL} {ringF:@ring F EQ ZERO ONE OPP ADD SUB MUL}.
  Context {H} {eq : H -> H -> Prop} {zero one : H} {opp : H -> H} {add sub mul : H -> H -> H} {inv : H -> H} {div : H -> H -> H}.
  Context {phi:F->H} {phi':H->F}.
  Local Infix "=" := EQ. Local Infix "=" := EQ : type_scope.
  Context (phi'_phi_id : forall A, phi' (phi A) = A)
          (phi'_eq : forall a b, EQ (phi' a) (phi' b) <-> eq a b)
          {phi'_zero : phi' zero = ZERO}
          {phi'_one : phi' one = ONE}
          {phi'_opp : forall a, phi' (opp a) = OPP (phi' a)}
          (phi'_add : forall a b, phi' (add a b) = ADD (phi' a) (phi' b))
          (phi'_sub : forall a b, phi' (sub a b) = SUB (phi' a) (phi' b))
          (phi'_mul : forall a b, phi' (mul a b) = MUL (phi' a) (phi' b)).

  Lemma ring_by_isomorphism
    : @ring H eq zero one opp add sub mul
      /\ @is_homomorphism F EQ ONE ADD MUL H eq one add mul phi
      /\ @is_homomorphism H eq one add mul F EQ ONE ADD MUL phi'.
  Proof using phi'_add phi'_eq phi'_mul phi'_one phi'_opp phi'_phi_id phi'_sub phi'_zero ringF.
    repeat match goal with
           | [ H : field |- _ ] => destruct H; try clear H
           | [ H : commutative_ring |- _ ] => destruct H; try clear H
           | [ H : ring |- _ ] => destruct H; try clear H
           | [ H : commutative_group |- _ ] => destruct H; try clear H
           | [ H : group |- _ ] => destruct H; try clear H
           | [ H : monoid |- _ ] => destruct H; try clear H
           | [ H : is_commutative |- _ ] => destruct H; try clear H
           | [ H : is_left_distributive |- _ ] => destruct H; try clear H
           | [ H : is_right_distributive |- _ ] => destruct H; try clear H
           | [ H : is_zero_neq_one |- _ ] => destruct H; try clear H
           | [ H : is_associative |- _ ] => destruct H; try clear H
           | [ H : is_left_identity |- _ ] => destruct H; try clear H
           | [ H : is_right_identity |- _ ] => destruct H; try clear H
           | [ H : Equivalence _ |- _ ] => destruct H; try clear H
           | [ H : is_left_inverse |- _ ] => destruct H; try clear H
           | [ H : is_right_inverse |- _ ] => destruct H; try clear H
           | _ => intro
           | _ => split
           | [ H : eq _ _ |- _ ] => apply phi'_eq in H
           | [ |- eq _ _ ] => apply phi'_eq
           | [ H : (~eq _ _)%type |- _ ] => pose proof (fun pf => H (proj1 (@phi'_eq _ _) pf)); clear H
           | [ H : EQ _ _ |- _ ] => rewrite H
           | _ => progress erewrite ?phi'_zero, ?phi'_one, ?phi'_opp, ?phi'_add, ?phi'_sub, ?phi'_mul, ?phi'_phi_id by reflexivity
           | [ H : _ |- _ ] => progress erewrite ?phi'_zero, ?phi'_one, ?phi'_opp, ?phi'_add, ?phi'_sub, ?phi'_mul, ?phi'_phi_id in H by reflexivity
           | _ => solve [ eauto ]
           end.
  Qed.
End Isomorphism.

Section TacticSupportCommutative.
  Context {T eq zero one opp add sub mul} `{@commutative_ring T eq zero one opp add sub mul}.

  Global Instance Cring_Cring_commutative_ring :
    @Cring.Cring T zero one add mul sub opp eq Ncring_Ring_ops Ncring_Ring.
  Proof using Type. unfold Cring.Cring; intros; cbv. eapply commutative. Qed.

  Lemma ring_theory_for_stdlib_tactic : Ring_theory.ring_theory zero one add mul sub opp eq.
  Proof using Type*.
    constructor; intros. (* TODO(automation): make [auto] do this? *)
    - apply left_identity.
    - apply commutative.
    - apply associative.
    - apply left_identity.
    - apply commutative.
    - apply associative.
    - apply right_distributive.
    - apply ring_sub_definition.
    - apply right_inverse.
  Qed.
End TacticSupportCommutative.

Section Z.
  Import ZArith.
  Global Instance ring_Z : @ring Z Logic.eq 0%Z 1%Z Z.opp Z.add Z.sub Z.mul.
  Proof. repeat split; auto using Z.eq_dec with zarith typeclass_instances. Qed.

  Global Instance commutative_ring_Z : @commutative_ring Z Logic.eq 0%Z 1%Z Z.opp Z.add Z.sub Z.mul.
  Proof. eauto using @commutative_ring, @is_commutative, ring_Z with zarith. Qed.

  Global Instance integral_domain_Z : @integral_domain Z Logic.eq 0%Z 1%Z Z.opp Z.add Z.sub Z.mul.
  Proof.
    split.
    { apply commutative_ring_Z. }
    { split. intros. eapply Z.eq_mul_0; assumption. }
    { split. discriminate. }
  Qed.
End Z.

Section of_Z.
  Import ZArith PArith. Local Open Scope Z_scope.
  Context {R Req Rzero Rone Ropp Radd Rsub Rmul}
          {Rring : @ring R Req Rzero Rone Ropp Radd Rsub Rmul}.
  Local Infix "=" := Req. Local Infix "=" := Req : type_scope.

  Fixpoint of_nat (n:nat) : R :=
    match n with
    | O => Rzero
    | S n' => Radd (of_nat n') Rone
    end.
  Definition of_Z (x:Z) : R :=
    match x with
    | Z0 => Rzero
    | Zpos p => of_nat (Pos.to_nat p)
    | Zneg p => Ropp (of_nat (Pos.to_nat p))
    end.

  Lemma of_Z_0 : of_Z 0 = Rzero.
  Proof using Type*. reflexivity. Qed.

  Lemma of_nat_add x :
    of_nat (Nat.add x 1) = Radd (of_nat x) Rone.
  Proof using Type*. destruct x; rewrite ?Nat.add_1_r; reflexivity. Qed.

  Lemma of_nat_sub x (H: (0 < x)%nat):
    of_nat (Nat.sub x 1) = Rsub (of_nat x) Rone.
  Proof using Type*.
    induction x; [omega|simpl].
    rewrite <-of_nat_add.
    rewrite Nat.sub_0_r, Nat.add_1_r.
    simpl of_nat.
    rewrite ring_sub_definition, <-associative.
    rewrite right_inverse, right_identity.
    reflexivity.
  Qed.

  Lemma of_Z_add_1_r :
    forall x, of_Z (Z.add x 1) = Radd (of_Z x) Rone.
  Proof using Type*.
    destruct x; [reflexivity| | ]; simpl of_Z.
    { rewrite Pos2Nat.inj_add, of_nat_add.
      reflexivity. }
    { rewrite Z.pos_sub_spec; break_match;
        match goal with
        | H : _ |- _ => rewrite Pos.compare_eq_iff in H
        | H : _ |- _ => rewrite Pos.compare_lt_iff in H
        | H : _ |- _ => rewrite Pos.compare_gt_iff in H;
                          apply Pos.nlt_1_r in H; tauto
        end;
        subst; simpl of_Z; simpl of_nat.
      { rewrite left_identity, left_inverse; reflexivity. }
      { rewrite Pos2Nat.inj_sub by assumption.
        rewrite of_nat_sub by apply Pos2Nat.is_pos.
        rewrite ring_sub_definition, Group.inv_op, Group.inv_inv.
        rewrite commutative; reflexivity. } }
  Qed.

  Lemma of_Z_sub_1_r :
    forall x, of_Z (Z.sub x 1) = Rsub (of_Z x) Rone.
  Proof using Type*.
    induction x.
    { simpl; rewrite ring_sub_definition, !left_identity;
        reflexivity. }
    { case_eq (1 ?= p)%positive; intros;
        match goal with
        | H : _ |- _ => rewrite Pos.compare_eq_iff in H
        | H : _ |- _ => rewrite Pos.compare_lt_iff in H
        | H : _ |- _ => rewrite Pos.compare_gt_iff in H;
                          apply Pos.nlt_1_r in H; tauto
        end.
      { subst. simpl; rewrite ring_sub_definition, !left_identity,
                      right_inverse; reflexivity. }
      { rewrite <-Pos2Z.inj_sub by assumption; simpl of_Z.
        rewrite Pos2Nat.inj_sub by assumption.
        rewrite of_nat_sub by apply Pos2Nat.is_pos.
        reflexivity. } }
    { simpl. rewrite Pos2Nat.inj_add, of_nat_add.
      rewrite ring_sub_definition, Group.inv_op, commutative.
      reflexivity. }
  Qed.

  Lemma of_Z_opp : forall a,
      of_Z (Z.opp a) = Ropp (of_Z a).
  Proof using Type*.
    destruct a; simpl; rewrite ?Group.inv_id, ?Group.inv_inv;
      reflexivity.
  Qed.

  Lemma of_Z_add : forall a b,
      of_Z (Z.add a b) = Radd (of_Z a) (of_Z b).
  Proof using Type*.
    intros.
    let x := match goal with |- ?x => x end in
    let f := match (eval pattern b in x) with ?f _ => f end in
    apply (Z.peano_ind f); intros.
    { rewrite !right_identity. reflexivity. }
    { replace (a + Z.succ x) with ((a + x) + 1) by ring.
      replace (Z.succ x) with (x+1) by ring.
      rewrite !of_Z_add_1_r, H.
      rewrite associative; reflexivity. }
    { replace (a + Z.pred x) with ((a+x)-1)
        by (rewrite <-Z.sub_1_r; ring).
      replace (Z.pred x) with (x-1) by apply Z.sub_1_r.
      rewrite !of_Z_sub_1_r, H.
      rewrite !ring_sub_definition.
      rewrite associative; reflexivity. }
  Qed.

  Lemma of_Z_mul : forall a b,
      of_Z (Z.mul a b) = Rmul (of_Z a) (of_Z b).
  Proof using Type*.
    intros.
    let x := match goal with |- ?x => x end in
    let f := match (eval pattern b in x) with ?f _ => f end in
    apply (Z.peano_ind f); intros until 0; try intro IHb.
    { rewrite !mul_0_r; reflexivity. }
    { rewrite Z.mul_succ_r, <-Z.add_1_r.
      rewrite of_Z_add, of_Z_add_1_r.
      rewrite IHb.
      rewrite left_distributive, right_identity.
      reflexivity. }
    { rewrite Z.mul_pred_r, <-Z.sub_1_r.
      rewrite of_Z_sub_1_r.
      rewrite <-Z.add_opp_r.
      rewrite of_Z_add, of_Z_opp.
      rewrite IHb.
      rewrite ring_sub_definition, left_distributive.
      rewrite mul_opp_r,right_identity.
      reflexivity. }
  Qed.

  Global Instance homomorphism_of_Z :
    @is_homomorphism
      Z Logic.eq Z.one Z.add Z.mul
      R Req  Rone  Radd  Rmul
      of_Z.
  Proof using Type*.
    repeat constructor; intros.
    { apply of_Z_add. }
    { repeat intro; subst; reflexivity. }
    { apply of_Z_mul. }
    { simpl. rewrite left_identity; reflexivity. }
  Qed.
End of_Z.

Definition char_ge
           {R eq zero one opp add} {sub:R->R->R} {mul:R->R->R}
           C :=
  @Hierarchy.char_ge R eq zero (fun p => (@of_Z R zero one opp add) (BinInt.Z.pos p)) C.
Existing Class char_ge.

(*** Tactics for ring equations *)
Require Export Coq.setoid_ring.Ring_tac.
Ltac ring_simplify_subterms := tac_on_subterms ltac:(fun t => ring_simplify t).

Ltac ring_simplify_subterms_in_all :=
  reverse_nondep; ring_simplify_subterms; intros.

Create HintDb ring_simplify discriminated.
Create HintDb ring_simplify_subterms discriminated.
Create HintDb ring_simplify_subterms_in_all discriminated.
Hint Extern 1 => progress ring_simplify : ring_simplify.
Hint Extern 1 => progress ring_simplify_subterms : ring_simplify_subterms.
Hint Extern 1 => progress ring_simplify_subterms_in_all : ring_simplify_subterms_in_all.


(******************************************************************************)
(**)
(******************************************************************************)
(* Let R : ringType and M : lmodType R                                        *)
(******************************************************************************)
(* lmodSetType M == a record consisting of a type 'sort' a function           *)
(*                'elem' : sort -> M, and proofs of (injective elem)          *)
(*                and (non_degenerate elem).                                  *)
(*                injective elem == forall x y : T, elem x = elem y -> x = y  *)
(*                non_degenerate elem == forall x : T, elem x != 0            *)
(*                S : lmodSetType M coerces to its type T and function elem   *)
(*                so b : S is shorthand for b : (sort S)                      *)
(*                and S b for (elem S) b.                                     *)
(******************************************************************************)
(* Let S : lmodSetType M                                                      *)
(******************************************************************************)
(* typeIsNonDegenerate S == the proof that S is non_degenerate                *)
(* typeIsInjective S == the proof that S  is injective                        *)
(******************************************************************************)
(* lmodOrthoType S == a record consisting of a function                       *)
(*                    'proj' : S -> {scalar M} and a proof of                 *)
(*                    (orthonormP proj)                                       *)
(*                    orthonormP proj == forall b1 b2 : S, proj b1 (S b2)     *)
(*                                         = if b1 == b2 then 1 else 0        *)
(*                    O : lmodOrthoType S coerces to S                        *)
(*                    so b : O and O b work as for lmodSetType                *)
(******************************************************************************)
(* Let O : lmodOrthoType S                                                    *)
(******************************************************************************)
(* orthonormP O     == orthonormP (lmodBasisProj O)                          *)
(* lmodBasisProj O  == the 'proj : O -> {scalar M} function                   *)
(* \basisProj_b^(O) == lmodBasisProj O b : {scalar M}                         *)
(* typeIsNonDegenerate O == the proof that O is non_degenerate                *)
(* typeIsInjective O == the proof that O is injective                         *)
(******************************************************************************)
(* lmodBasisType O == a record consisting of a proof of                       *)
(*                    basisP (lmodBasisProj O)                                *)
(*                    basisP proj == forall m1 m2 : M,                        *)
(*                      reflect (forall b : O, proj b m1 = proj b m2)         *)
(*                              (m1 == m2)                                    *)
(*                    B : lmodBasisType O coerces to O                        *)
(*                    so b : B and B b work as for lmodSetType                *)
(******************************************************************************)
(* Let B : lmodBasisType O                                                    *)
(******************************************************************************)
(* basisP B              == basisP (lmodBasisProj O)                          *)
(* lmodBasisProj B       == the 'proj : B -> {scalar M} function              *)
(* \basisProj_b^(B)      == lmodBasisProj B b : {scalar M}                    *)
(* typeIsNonDegenerate B == the proof that B is non_degenerate                *)
(* typeIsInjective B     == the proof that B is injective                     *)
(******************************************************************************)
(* lmodFinSetType M == a record consisting of a finType 'sort' and the        *)
(*                     mixin of an lmodSetType for type sort.                 *)
(*                     F : lmodBasisType M coerces to an lmodSetType          *)
(*                     so f : F and F f work as for lmodSetType               *)
(*                     However lmodFinSetType does not coerce to a finType    *)
(*                     There is an explicit function for this *)
(******************************************************************************)
(* Let F : lmodFinSetType M                                                   *)
(******************************************************************************)
(* typeIsNonDegenerate F == the proof that F is non_degenerate                *)
(* typeIsInjective F == the proof that F  is injective                        *)
(* to_FinType F == the underlying finType of F                                *)
(******************************************************************************)
(* Note that all F : lmodFinSetType M are bijective to some ordinal type,     *)
(* to establish the bijection we require:                                     *)
(*  1) n : nat                                                                *)
(*  2) and a proof K : n = size (enum (to_FinType F))                         *)
(*  to_ord F f ==     *)
(*  from_ord F f ==     *)
(******************************************************************************)
(* lmodFinBasisType O == a record consisting of a proof of                       *)
(*                    basisP (lmodBasisProj O)                                *)
(*                    basisP proj == forall m1 m2 : M,                        *)
(*                      reflect (forall b : O, proj b m1 = proj b m2)         *)
(*                              (m1 == m2)                                    *)
(*                    B : lmodBasisType O coerces to O                        *)
(*                    so b : B and B b work as for lmodSetType                *)

Require Import Coq.Program.Tactics.
From Coq.Logic Require Import FunctionalExtensionality ProofIrrelevance.
From mathcomp Require Import ssreflect ssrfun eqtype fintype seq bigop.

Require Import Modules Linears.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Open Scope ring_scope.
Set Implicit Arguments.
Unset Strict Implicit.

Reserved Notation "\basisProj_ b ^( B )"
  (at level 36, B at level 36, b at level 0,
    right associativity,
          format "'[' \basisProj_ b '^(' B ) ']'").

Reserved Notation "\finBasisProj_ b ^( B )"
(at level 36, B at level 36, b at level 0,
  right associativity,
        format "'[' \finBasisProj_ b '^(' B ) ']'").

Module lmodSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).
    Definition non_degenerate {T : Type} (elem : T -> M) := forall b : T, elem b != 0%R.

    Record mixin (T : eqType) := Mixin {
      elem : T -> M;
      _ : injective elem;
      _ : non_degenerate elem;
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build {T : eqType} (elem : T -> M) (I : injective elem) (ND : non_degenerate elem)
     := Pack (Mixin I ND).

    Lemma typeIsInjective (T : type) : injective (elem (class_of T)).
    Proof. by destruct (class_of T)=>/=. Qed.

    Lemma typeIsNonDegenerate (T : type) : non_degenerate (elem (class_of T)).
    Proof. by destruct (class_of T)=>/=. Qed.

    Definition to_Type (T : type) : Type := (sort T).
  End Def.

  Module Exports.
    Notation lmodSetType := type.
    Notation non_degenerate := non_degenerate.
    Notation typeIsInjective := typeIsInjective.
    Notation typeIsNonDegenerate := typeIsNonDegenerate.
    Coercion to_Type : type >-> Sortclass.
    Coercion elem : mixin >-> Funclass.
    Coercion class_of : type >-> mixin.
  End Exports.
End lmodSet.
Export lmodSet.Exports.

Module lmodOrthoSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    Definition orthonormP (B : lmodSetType M) (proj : B -> {scalar M})
    := forall b1 b2 : B, proj b1 (B b2) = if b1 == b2 then 1 else 0.

    Record mixin (B : lmodSetType M) := Mixin {
      proj : B -> {scalar M};
      orthonormal : orthonormP proj;
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build (T : eqType) (elem : T -> M)
      (I : injective elem) (ND : non_degenerate elem)
      (proj : (lmodSet.Build I ND) -> {scalar M})
      (O : orthonormP proj)
    : type := Pack (Mixin O).

    Local Coercion sort : type >-> lmodSetType.
    Local Coercion class_of : type >-> mixin.
    Definition coef (B : type) (b : B) : {scalar M} := @proj B B b.
  End Def.

  Module Exports.
    Notation lmodOrthoType := type.
    Notation lmodBasisProj := proj.
    Notation orthonormP := orthonormP.
    Coercion sort : type >-> lmodSetType.
    Coercion class_of : type >-> mixin.
  End Exports.
End lmodOrthoSet.
Export lmodOrthoSet.Exports.

Notation "\basisProj_ b ^( B )" := (@lmodOrthoSet.coef _ _ B b) : lmod_scope.

Module lmodBasis.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    Definition basisP (B : lmodSetType M) (proj : B -> {scalar M})
     := forall m1 m2 : M, reflect (forall b : B, proj b m1 = proj b m2) (m1 == m2).

    Record mixin (T : lmodOrthoType M) := Mixin {
      is_basisP : basisP (lmodBasisProj T);
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build (T : eqType) (elem : T -> M)
      (I : injective elem) (ND : non_degenerate elem)
      (proj : (lmodSet.Build I ND) -> {scalar M})
      (O : orthonormP proj)
      (B : @basisP (lmodOrthoSet.Build O) proj)
    : type := Pack (Mixin B).
  End Def.

  Module Exports.
    Notation lmodBasisType := type.
    Notation basisP := basisP.
    Coercion class_of : type >-> mixin.
    Coercion sort : type >-> lmodOrthoType.
  End Exports.
End lmodBasis.
Export lmodBasis.Exports.

Module lmodFinSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).
    Record class (T : finType) := Class {
      base : lmodSet.mixin M T;
    }.

    Record type := Pack { sort : _; class_of : class sort; }.

    Definition Build {T : finType} (elem : T -> M) (I : injective elem) (ND : non_degenerate elem)
    := Pack (Class (lmodSet.Build I ND)).

    Section Lemmas.
    Variable (T : type).
    Definition to_set
    := lmodSet.Pack (base (class_of T)).

    Variable (n : nat) (K : n = size (enum (sort T))).
    Definition to_ord
      : sort T -> 'I_n :=
    eq_rect_r (fun n : nat => sort T -> 'I_n)
      (eq_rect #|sort T| (fun n : nat => sort T -> 'I_n)
        enum_rank (size (enum (sort T))) (cardT (sort T))) K.

    Definition from_ord
      : 'I_n -> sort T :=
    eq_rect_r (fun n : nat => 'I_n -> sort T)
      (eq_rect #|sort T| (fun n : nat => 'I_n -> sort T)
        enum_val (size (enum (sort T))) (cardT (sort T))) K.

    Lemma tofrom_ordK : cancel to_ord from_ord.
    Proof.
      rewrite/to_ord/from_ord/eq_rect_r/eq_rect.
      destruct (cardT (sort T)), (Logic.eq_sym K)=>x.
      by rewrite enum_rankK.
    Qed.

    Lemma fromto_ordK : cancel from_ord to_ord.
    Proof.
      rewrite/to_ord/from_ord/eq_rect_r/eq_rect.
      destruct (cardT (sort T)), (Logic.eq_sym K)=>x.
      by rewrite enum_valK.
    Qed.

    End Lemmas.
  End Def.

  Module Exports.
    Notation lmodFinSetType := type.
    Notation to_FinType := sort.
    Coercion to_set : type >-> lmodSetType.
  End Exports.
End lmodFinSet.
Export lmodFinSet.Exports.

Module lmodFinBasis.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    (* Linear Independence Of A Finite Set *)
    Definition li (F : lmodFinSetType M) :=
        forall (c : F -> R), (\sum_(f : F) (c f) *: (F f)) == 0
          -> forall b, c b == 0.

    (* Linear Independence Implies All Linear Combinations
      of the Same Element are Equal *)
    Lemma li_coefs_eq (F : lmodFinSetType M)
     : li F -> forall (c1 c2 : F -> R), (\sum_(f : F) (c1 f) *: (F f)) == (\sum_(f : F) (c2 f) *: (F f)) -> c1 = c2.
    Proof. move=> L c1 c2 E.
      rewrite -GRing.subr_eq0 -GRing.sumrB in E.
      assert(\sum_i (c1 i - c2 i) *: F i == 0). {
        apply (rwP eqP) in E.
        rewrite -(rwP eqP) -{2}E.
        apply eq_bigr=>i _; apply GRing.scalerBl.
      }
      apply (functional_extensionality)=>x.
      apply (rwP eqP).
      by rewrite -GRing.subr_eq0 (L _ H x).
    Qed.

    (* The spanning property of a finite set *)
    Definition spanProp (F : lmodFinSetType M) (proj : F -> {scalar M}) (m : M)
     := (\sum_(f : F) proj f m *: F f) == m.
    Definition spanProj (F : lmodFinSetType M) (m : M)
      := {proj : F -> {scalar M} | spanProp proj m}.
    Definition spanning (F : lmodFinSetType M) :=
      forall m : M, spanProj F m.

    Record mixin (T : lmodFinSet.type M) := Mixin {
      li_ax : li T;
      span_ax : spanning T;
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build (T : finType) (elem : T -> M)
      (I : injective elem) (ND : non_degenerate elem)
      (LI : li (lmodFinSet.Build I ND))
      (Sp : spanning (lmodFinSet.Build I ND))
    : type := Pack (Mixin LI Sp).

    Definition basis_number (B : type) := #|(to_FinType (sort B))|.

    Lemma typeSpanning (T : type) : spanning (sort T).
    Proof. by destruct (class_of T). Qed.

    Lemma typeLI (T : type) : li (sort T).
    Proof. by destruct (class_of T). Qed.
  End Def.

  Module Exports.
    Notation basis_number := basis_number.
    Notation lmodFinBasisType := type.
    Notation li := li.
    Notation spanning := spanning.
    Notation typeIsSpanning := typeSpanning.
    Notation typeIsLI := typeLI.
    Coercion class_of : type >-> mixin.
    Coercion sort : type >-> lmodFinSetType.
  End Exports.
  Export Exports.

  Section Results.
    Variable (R : ringType) (M : lmodType R) (T : type M).

    Definition coef_fn (t : T) : M -> R
      := fun m => (sval ((span_ax T) m)) t m.

    Lemma coef_sca (t : T) : scalar (coef_fn t).
    Proof. rewrite/coef_fn=> r m1 m2/=.
      destruct T as [T' [li sp]]=>/=; simpl in t.
      destruct sp as [c H], sp as [c1 H1], sp as [c2 H2] =>/=.
      rewrite /spanProp in H, H1, H2.
      apply (rwP eqP) in H1; apply (rwP eqP) in H2.
      rewrite -{2}H1 -{2}H2 GRing.scaler_sumr -big_split in H.
      assert(forall i (_ : true),
        (r *: (c1 i m1 *: T' i) + c2 i m2 *: T' i)
          =
          (((r * c1 i m1) + c2 i m2) *: T' i)
      ). move =>i _;
      by rewrite GRing.scalerA GRing.scalerDl.
      rewrite (eq_bigr _ H0) in H.
      by apply (equal_f (li_coefs_eq li H) t).
    Qed.

    Definition coef (t : T) : {scalar M}
      := Linear (coef_sca t).

  Lemma coefP (m : M) : \sum_f coef f m *: T f = m.
  Proof. rewrite/coef=>/=; rewrite/coef_fn.
    destruct (span_ax T m) as [c H]=>/=.
    rewrite /spanProp in H.
    apply (rwP eqP) in H.
    by rewrite H.
  Qed.

  Definition coefAtBase (t : T) : T -> R
    := fun b : T => if b == t then 1 else 0.

  Lemma coefO : orthonormP coef.
  Proof. rewrite/orthonormP=>b1 b2; move: b1.
    apply equal_f.
    apply (li_coefs_eq (li_ax T)).
    destruct (span_ax T (lmodFinSet.base (lmodFinSet.class_of T) b2)) as [c H].
    rewrite /spanProp in H.
    assert(\sum_f (if f == b2 then 1 else 0) *: T f
    = \sum_f (if f == b2 then T f else 0)).
    apply (eq_bigr _). move=> i _.
    case (i == b2); [apply GRing.scale1r|apply GRing.scale0r].
    by rewrite H0 -big_mkcond big_pred1_eq coefP.
  Qed.

  Lemma coefB : lmodBasis.basisP coef.
  Proof. rewrite/coef=>b1 b2.
    apply (iffP idP).
    rewrite -(rwP eqP)=>H.
    by destruct H.

    rewrite /coef_fn=>/= H.
    destruct (span_ax T b1) as [c1 H1],
      (span_ax T b2) as [c2 H2]; simpl in H.
    rewrite /spanProp in H1, H2.
    apply (rwP eqP) in H1; apply (rwP eqP) in H2.
    rewrite -H1 -H2 -(rwP eqP).
    assert(H' : forall b : T, true -> c1 b b1 *: T b = c2 b b2 *: T b).
    move=>b _; by rewrite (H b).
    refine (eq_bigr _ H').
  Qed.

  Definition to_lmodBasis
  := @lmodBasis.Build _ _ _ _ (@typeIsInjective _ _ (sort T)) (@typeIsNonDegenerate _ _ (sort T)) coef coefO coefB.

  End Results.
  Module Exports2.
    Notation lmodFinBasisProj := coef.
  End Exports2.
End lmodFinBasis.
Export lmodFinBasis.Exports.
Export lmodFinBasis.Exports2.
Notation "\finBasisProj_ b ^( B )" := (@lmodFinBasisProj _ _ B b) : lmod_scope.

Section Results.

End Results.

Close Scope ring_scope.


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

(* $Id$ *)

(** * Finite sets library *)

(** This file proposes an implementation of the non-dependant
    interface [MSetWeakInterface.S] using lists without redundancy. *)

Require Import MSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.

(** * Functions over lists

   First, we provide sets as lists which are (morally) without redundancy.
   The specs are proved under the additional condition of no redundancy.
   And the functions returning sets are proved to preserve this invariant. *)

(** ** The set operations. *)

Module Ops (X: DecidableType) <: WOps X.

  Definition elt := X.t.
  Definition t := list elt.

  Definition empty : t := nil.

  Definition is_empty (l : t) : bool := if l then true else false.

  Fixpoint mem (x : elt) (s : t) : bool :=
    match s with
    | nil => false
    | y :: l =>
           if X.eq_dec x y then true else mem x l
    end.

  Fixpoint add (x : elt) (s : t) : t :=
    match s with
    | nil => x :: nil
    | y :: l =>
        if X.eq_dec x y then s else y :: add x l
    end.

  Definition singleton (x : elt) : t := x :: nil.

  Fixpoint remove (x : elt) (s : t) : t :=
    match s with
    | nil => nil
    | y :: l =>
        if X.eq_dec x y then l else y :: remove x l
    end.

  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
    fold_left (flip f) s i.

  Definition union (s : t) : t -> t := fold add s.

  Definition diff (s s' : t) : t := fold remove s' s.

  Definition inter (s s': t) : t :=
    fold (fun x s => if mem x s' then add x s else s) s nil.

  Definition subset (s s' : t) : bool := is_empty (diff s s').

  Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s).

  Fixpoint filter (f : elt -> bool) (s : t) : t :=
    match s with
    | nil => nil
    | x :: l => if f x then x :: filter f l else filter f l
    end.

  Fixpoint for_all (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => true
    | x :: l => if f x then for_all f l else false
    end.

  Fixpoint exists_ (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => false
    | x :: l => if f x then true else exists_ f l
    end.

  Fixpoint partition (f : elt -> bool) (s : t) : t * t :=
    match s with
    | nil => (nil, nil)
    | x :: l =>
        let (s1, s2) := partition f l in
        if f x then (x :: s1, s2) else (s1, x :: s2)
    end.

  Definition cardinal (s : t) : nat := length s.

  Definition elements (s : t) : list elt := s.

  Definition choose (s : t) : option elt :=
     match s with
      | nil => None
      | x::_ => Some x
     end.

End Ops.

(** ** Proofs of set operation specifications. *)

Module MakeRaw (X:DecidableType) <: WRawSets X.
  Include Ops X.

  Section ForNotations.
  Notation NoDup := (NoDupA X.eq).
  Notation In := (InA X.eq).

  (* TODO: modify proofs in order to avoid these hints *)
  Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv).
  Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv).
  Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv).

  Definition IsOk := NoDup.

  Class Ok (s:t) : Prop := ok : NoDup s.

  Hint Unfold Ok.
  Hint Resolve @ok.

  Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }.

  Ltac inv_ok := match goal with
   | H:Ok (_ :: _) |- _ => inversion_clear H; inv_ok
   | H:Ok nil |- _ => clear H; inv_ok
   | H:NoDup ?l |- _ => change (Ok l) in H; inv_ok
   | _ => idtac
  end.

  Ltac inv := invlist InA; inv_ok.
  Ltac constructors := repeat constructor.

  Fixpoint isok l := match l with
   | nil => true
   | a::l => negb (mem a l) && isok l
  end.

  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.

  Lemma In_compat : Proper (X.eq==>eq==>iff) In.
  Proof.
  repeat red; intros. subst. rewrite H; auto.
  Qed.

  Lemma mem_spec : forall s x `{Ok s},
   mem x s = true <-> In x s.
  Proof.
  induction s; intros.
  split; intros; inv. discriminate.
  simpl; destruct (X.eq_dec x a); split; intros; inv; auto.
  right; rewrite <- IHs; auto.
  rewrite IHs; auto.
  Qed.

  Lemma isok_iff : forall l, Ok l <-> isok l = true.
  Proof.
  induction l.
  intuition.
  simpl.
  rewrite andb_true_iff.
  rewrite negb_true_iff.
  rewrite <- IHl.
  split; intros H. inv.
  split; auto.
  apply not_true_is_false. rewrite mem_spec; auto.
  destruct H; constructors; auto.
  rewrite <- mem_spec; auto; congruence.
  Qed.

  Global Instance isok_Ok l : isok l = true -> Ok l | 10.
  Proof.
  intros. apply <- isok_iff; auto.
  Qed.

  Lemma add_spec :
   forall (s : t) (x y : elt) {Hs : Ok s},
     In y (add x s) <-> X.eq y x \/ In y s.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition.
  left; eauto.
  inv; auto.
  Qed.

  Global Instance add_ok s x `(Ok s) : Ok (add x s).
  Proof.
  induction s.
  simpl; intuition.
  intros; inv. simpl.
  destruct X.eq_dec; auto.
  constructors; auto.
  intro; inv; auto.
  rewrite add_spec in *; intuition.
  Qed.

  Lemma remove_spec :
   forall (s : t) (x y : elt) {Hs : Ok s},
     In y (remove x s) <-> In y s /\ ~X.eq y x.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  destruct X.eq_dec; inv; rewrite !InA_cons, ?IHs; intuition.
  elim H. setoid_replace a with y; eauto.
  elim H3. setoid_replace x with y; eauto.
  elim n. eauto.
  Qed.

  Global Instance remove_ok s x `(Ok s) : Ok (remove x s).
  Proof.
  induction s; simpl; intros.
  auto.
  destruct X.eq_dec; inv; auto.
  constructors; auto.
  rewrite remove_spec; intuition.
  Qed.

  Lemma singleton_ok : forall x : elt, Ok (singleton x).
  Proof.
  unfold singleton; simpl; constructors; auto. intro; inv.
  Qed.

  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
  Proof.
  unfold singleton; simpl; split; intros. inv; auto. left; auto.
  Qed.

  Lemma empty_ok : Ok empty.
  Proof.
  unfold empty; constructors.
  Qed.

  Lemma empty_spec : Empty empty.
  Proof.
  unfold Empty, empty; red; intros; inv.
  Qed.

  Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s.
  Proof.
  unfold Empty; destruct s; simpl; split; intros; auto.
  intro; inv.
  discriminate.
  elim (H e); auto.
  Qed.

  Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s.
  Proof.
  unfold elements; intuition.
  Qed.

  Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s).
  Proof.
  unfold elements; auto.
  Qed.

  Lemma fold_spec :
   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (flip f) (elements s) i.
  Proof.
  reflexivity.
  Qed.

  Global Instance union_ok : forall s s' `(Ok s, Ok s'), Ok (union s s').
  Proof.
  induction s; simpl; auto; intros; inv; unfold flip; auto with *.
  Qed.

  Lemma union_spec :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (union s s') <-> In x s \/ In x s'.
  Proof.
  induction s; simpl in *; unfold flip; intros; auto; inv.
  intuition; inv.
  rewrite IHs, add_spec, InA_cons; intuition.
  Qed.

  Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
  Proof.
  unfold inter, fold, flip.
  set (acc := nil (A:=elt)).
  assert (Hacc : Ok acc) by constructors.
  clearbody acc; revert acc Hacc.
  induction s; simpl; auto; intros. inv.
  apply IHs; auto.
  destruct (mem a s'); auto with *.
  Qed.

  Lemma inter_spec  :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (inter s s') <-> In x s /\ In x s'.
  Proof.
  unfold inter, fold, flip; intros.
  set (acc := nil (A:=elt)) in *.
  assert (Hacc : Ok acc) by constructors.
  assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc).
   intuition; unfold acc in *; inv.
  rewrite IFF; clear IFF. clearbody acc.
  revert acc Hacc x s' Hs Hs'.
  induction s; simpl; intros.
  intuition; inv.
  inv.
  case_eq (mem a s'); intros Hm.
  rewrite IHs, add_spec, InA_cons; intuition.
  rewrite mem_spec in Hm; auto.
  left; split; auto. rewrite H1; auto.
  rewrite IHs, InA_cons; intuition.
  rewrite H2, <- mem_spec in H3; auto. congruence.
  Qed.

  Global Instance diff_ok : forall s s' `(Ok s, Ok s'), Ok (diff s s').
  Proof.
  unfold diff; intros s s'; revert s.
  induction s'; simpl; unfold flip; auto; intros. inv; auto with *.
  Qed.

  Lemma diff_spec  :
   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
   In x (diff s s') <-> In x s /\ ~In x s'.
  Proof.
  unfold diff; intros s s'; revert s.
  induction s'; simpl; unfold flip.
  intuition; inv.
  intros. inv.
  rewrite IHs', remove_spec, InA_cons; intuition.
  Qed.

  Lemma subset_spec :
   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
   subset s s' = true <-> Subset s s'.
  Proof.
  unfold subset, Subset; intros.
  rewrite is_empty_spec.
  unfold Empty; intros.
  intuition.
  specialize (H a). rewrite diff_spec in H; intuition.
  rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition.
  rewrite diff_spec in H0; intuition.
  Qed.

  Lemma equal_spec :
   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
   equal s s' = true <-> Equal s s'.
  Proof.
  unfold Equal, equal; intros.
  rewrite andb_true_iff, !subset_spec.
  unfold Subset; intuition. rewrite <- H; auto. rewrite H; auto.
  Qed.

  Definition choose_spec1 :
    forall (s : t) (x : elt), choose s = Some x -> In x s.
  Proof.
  destruct s; simpl; intros; inversion H; auto.
  Qed.

  Definition choose_spec2 : forall s : t, choose s = None -> Empty s.
  Proof.
  destruct s; simpl; intros.
  intros x H0; inversion H0.
  inversion H.
  Qed.

  Lemma cardinal_spec :
   forall (s : t) {Hs : Ok s}, cardinal s = length (elements s).
  Proof.
  auto.
  Qed.

  Lemma filter_spec' : forall s x f,
   In x (filter f s) -> In x s.
  Proof.
  induction s; simpl.
  intuition; inv.
  intros; destruct (f a); inv; intuition; right; eauto.
  Qed.

  Lemma filter_spec :
   forall (s : t) (x : elt) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (In x (filter f s) <-> In x s /\ f x = true).
  Proof.
  induction s; simpl.
  intuition; inv.
  intros.
  destruct (f a) as [ ]_eqn:E; rewrite ?InA_cons, IHs; intuition.
  setoid_replace x with a; auto.
  setoid_replace a with x in E; auto. congruence.
  Qed.

  Global Instance filter_ok s f `(Ok s) : Ok (filter f s).
  Proof.
  induction s; simpl.
  auto.
  intros; inv.
  case (f a); auto.
  constructors; auto.
  contradict H0.
  eapply filter_spec'; eauto.
  Qed.

  Lemma for_all_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof.
  unfold For_all; induction s; simpl.
  intuition. inv.
  intros; inv.
  destruct (f a) as [ ]_eqn:F.
  rewrite IHs; intuition. inv; auto.
  setoid_replace x with a; auto.
  split; intros H'; try discriminate.
  intros.
  rewrite <- F, <- (H' a); auto.
  Qed.

  Lemma exists_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof.
  unfold Exists; induction s; simpl.
  split; [discriminate| intros (x & Hx & _); inv].
  intros.
  destruct (f a) as [ ]_eqn:F.
  split; auto.
  exists a; auto.
  rewrite IHs; firstorder.
  inv.
  setoid_replace a with x in F; auto; congruence.
  exists x; auto.
  Qed.

  Lemma partition_spec1 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (fst (partition f s)) (filter f s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  firstorder.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  case (partition f l); intros s1 s2; simpl; intros.
  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
  Qed.

  Lemma partition_spec2 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  firstorder.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  case (partition f l); intros s1 s2; simpl; intros.
  case (f x); simpl; firstorder; inversion H0; intros; firstorder.
  Qed.

  Lemma partition_ok1' :
   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
    In x (fst (partition f s)) -> In x s.
  Proof.
  induction s; simpl; auto; intros. inv.
  generalize (IHs H1 f x).
  destruct (f a); destruct (partition f s); simpl in *; auto.
  inversion_clear H; auto.
  Qed.

  Lemma partition_ok2' :
   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
    In x (snd (partition f s)) -> In x s.
  Proof.
  induction s; simpl; auto; intros. inv.
  generalize (IHs H1 f x).
  destruct (f a); destruct (partition f s); simpl in *; auto.
  inversion_clear H; auto.
  Qed.

  Global Instance partition_ok1 : forall s f `(Ok s), Ok (fst (partition f s)).
  Proof.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (@partition_ok1' _ _ f x).
  generalize (Hrec f H0).
  case (f x); case (partition f l); simpl; constructors; auto.
  Qed.

  Global Instance partition_ok2 : forall s f `(Ok s), Ok (snd (partition f s)).
  Proof.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (@partition_ok2' _ _ f x).
  generalize (Hrec f H0).
  case (f x); case (partition f l); simpl; constructors; auto.
  Qed.

  End ForNotations.

  Definition In := InA X.eq.
  Definition eq := Equal.
  Instance eq_equiv : Equivalence eq.

End MakeRaw.

(** * Encapsulation

   Now, in order to really provide a functor implementing [S], we
   need to encapsulate everything into a type of lists without redundancy. *)

Module Make (X: DecidableType) <: WSets with Module E := X.
 Module Raw := MakeRaw X.
 Include WRaw2Sets X Raw.
End Make.


(** *  Hessenberg sum of ordinals terms  (commutative and strictly monotonous)

Pierre Castéran, Labri, University of  Bordeaux *)

From Coq Require Import Arith  ArithRing Lia.
From hydras Require Import Prelude.More_Arith Prelude.Merge_Sort
     Epsilon0.T1.

Set Implicit Arguments.

(* begin snippet oplusDef *)

Fixpoint oplus (alpha beta : T1) : T1 :=
  let fix oplus_aux beta {struct beta} :=
      match alpha, beta with
        | zero, _ => beta
        | _, zero => alpha
        | cons a1 n1 b1, cons a2 n2 b2 =>
          match compare a1 a2 with
            |  Gt => cons a1 n1 (oplus b1 beta)
            |  Lt => cons a2 n2 (oplus_aux b2)
            |  Eq => cons a1 (S (n1 + n2)%nat) (oplus b1 b2)
          end
      end
  in oplus_aux beta.

Infix "o+" := oplus  (at level 50, left associativity).

(* end snippet oplusDef *)

(*
Functional Scheme oplus_ind := Induction for oplus Sort Prop.
*)

Fixpoint o_finite_mult n alpha :=
match n with
    0 => T1.zero
  | S p =>  alpha o+ (o_finite_mult p alpha)
                 end.

Open Scope t1_scope.

(* begin snippet oplusNeutral *)

(*| .. coq:: no-out |*)

Lemma oplus_0_r (alpha : T1) : alpha o+ zero = alpha.
Proof.
  destruct alpha; reflexivity.
Qed.

Lemma oplus_0_l (beta : T1): zero o+ beta = beta.
Proof.
  destruct beta; reflexivity.
Qed.
(*||*)

(* end snippet oplusNeutral *)

(* begin snippet oplusCompareLt:: no-out *)
Lemma oplus_compare_Lt:
  forall a n b a' n' b',
  compare a  a' = Lt ->
  cons a n b o+ cons a' n' b' = cons a' n' (cons a n b o+  b').
(* end snippet oplusCompareLt *)

Proof.
  intros a n b a' n' b' H; cbn ;now rewrite H.
Qed.

Lemma oplus_lt_rw :
  forall a n b a' n' b', T1.lt a  a' ->
 	                 cons a n b o+ cons a' n' b'=
	                 cons a' n' (cons a n b o+ b').
Proof.
  intros a n b a' n' b' H; cbn.
  now apply compare_lt_iff in H as ->.
Qed.

Lemma oplus_eq_rw :
  forall a n b  n' b',
    cons a n b o+ cons a n' b'=
    cons a (S (n+n')%nat)  (b o+ b').
Proof.
  intros a n b  n' b'; generalize (compare_refl a); intro H;
  cbn ; now rewrite H.
Qed.

Lemma oplus_gt_rw :
  forall a n b a' n' b',
  T1.lt a' a ->
    cons a n b o+ cons a' n' b' = cons a n  (b o+ cons a' n' b').
Proof.
  intros a n b a' n' b' H;  cbn;
  now apply compare_gt_iff in H as ->.
Qed.

Lemma oplus_compare_Gt :
  forall a n b a' n' b', compare a a' = Gt ->
 	                 cons a n b o+ cons a' n' b' =
	                 cons a n  (b o+ cons a' n' b').
Proof.
  intros a n b a' n' b' H; cbn ; now rewrite H.
Qed.

(*  useless ?
Lemma oplus_rect:
  forall P: T1 -> T1 -> T1 -> Type,
    (forall a:T1, P T1.zero a a) ->
    (forall a: T1, P a T1.zero a) ->
    (forall a1 n1 b1 a2 n2 b2 o,
       compare a1 a2 = Gt ->
       P b1 (cons a2 n2 b2) o ->
       P (cons a1 n1 b1) (cons a2 n2 b2)
         (cons a1 n1 o)) ->
    (forall a1 n1 b1 a2 n2 b2 o,
       compare a1 a2 = Lt ->
       P (cons a1 n1 b1) b2 o ->
       P (cons a1 n1 b1) (cons a2 n2 b2)
         (cons a2 n2 o)) ->
    (forall a1 n1 b1 a2 n2 b2 o,
       compare a1 a2 = Eq ->
       P b1 b2 o ->
       P (cons a1 n1 b1) (cons a2 n2 b2)
         (cons a1 (S (n1 + n2)%nat) o)) ->
    forall a b, P a b (a o+ b).
Proof with auto.
  induction a.
  -  intro; simpl; destruct b;auto.
  -  induction b.
      + apply X0.
      + case_eq (compare a1 b1).
        * intro Comp; unfold oplus; rewrite Comp.
          cbn; apply X3 ...
        * intro Comp; cbn; rewrite Comp; apply X2...
        * intro Comp; cbn; rewrite Comp ...
Defined.

Ltac oplus_induction a b:= pattern (a o+ b); apply oplus_rect.
 *)

Lemma oplus_eqn :
  forall a b,
    a o+ b =
    match a, b with
        T1.zero, _ => b
      | _, T1.zero => a
      | cons a1 n1 b1, cons a2 n2 b2 =>
        match compare  a1 a2 with
            Gt => cons a1 n1 (b1 o+ b)
          | Eq => cons a1 (S (n1 + n2)) (b1 o+ b2)
          | Lt => cons a2 n2 (a o+ b2)
        end
    end.
Proof.
  destruct a, b; now cbn.
Qed.

Lemma oplus_cons_cons :
  forall a n b a' n' b',
    (cons a n b) o+ (cons a' n' b') =
    match compare a a' with
          | Gt => cons a n (b o+ (cons a' n' b') )
          | Eq => cons a (S (n + n')%nat) (b o+ b')
          | Lt => cons a'  n' (cons a n b o+  b')
    end.
Proof.
  intros; now rewrite oplus_eqn.
Qed.

Lemma nf_helper_oplus : forall gamma alpha beta,
                        nf_helper alpha gamma ->
                        nf_helper beta gamma ->
                        nf_helper (alpha o+ beta) gamma.
Proof with auto.
  induction gamma; destruct alpha, beta.
  -     simpl; constructor.
  -  inversion 2; inversion H5;   now simpl.
  -  inversion 1; T1_inversion H4.
  -  inversion 1; T1_inversion H4.
  -  simpl; auto.
  -  simpl; auto.
  -  simpl; auto.
  -   rewrite oplus_eqn;  case_eq (compare alpha1 beta1).
      + constructor; now inversion H0.
      + right; eapply nf_helper_inv1;eauto.
      + right; eapply nf_helper_inv1;eauto.
Qed.

Lemma oplus_bounded_phi0 alpha beta gamma :
  nf alpha -> nf beta -> nf gamma ->
  lt alpha (phi0 gamma) ->
  lt beta (phi0 gamma) ->
  lt (alpha o+ beta) (phi0 gamma).
Proof.
  intros H H0 H1 H2 H3.
  apply nf_helper_phi0; auto.
  apply nf_helper_oplus; auto.
  eapply nf_helper_intro with 0; auto.
  eapply nf_intro;auto.
  1,2 :now apply nf_helper_phi0R.
Qed.

Section Proof_of_plus_nf.

  Lemma oplus_nf_0 (gamma : T1):
    nf gamma ->  forall alpha beta,  nf alpha -> nf beta ->
                               T1.lt alpha gamma ->
                               T1.lt beta gamma ->
                               nf (alpha o+ beta).
  Proof.
    transfinite_induction gamma.
    -  clear gamma ;intros gamma IHgamma  H; destruct alpha, beta; auto.
      intros Hnf_1 Hnf_2 Hlt_1 Hlt_2.
      nf_decomp Hnf_1; nf_decomp Hnf_2; rewrite oplus_cons_cons;
      compare destruct alpha1 beta1 as Hcomp.
      + specialize (IHgamma (phi0 alpha1)).
        intros; apply nf_intro; [apply nf1| | ].
        * eapply IHgamma; trivial.
          repeat split; auto with T1.
          -- apply le_lt_trans with (cons alpha1 n alpha2); auto.
             now apply le_phi0.
          -- apply nf_helper_phi0, nf_helper_intro with n, Hnf_1.
          -- apply nf_helper_phi0, nf_helper_intro with n, Hnf_2.
        * apply nf_helper_oplus; eapply nf_helper_intro; eauto.
      + apply nf_intro; auto.
        * eapply IHgamma with (phi0 beta1); auto with T1.
          -- repeat split; auto with T1.
             apply le_lt_trans with (cons beta1 n0 beta2); auto.
             apply le_phi0.
          -- now apply nf_helper_phi0, nf_helper_intro with n.
        * apply nf_helper_oplus; auto.
          -- now apply nf_helper_phi0R, head_lt.
          -- now apply nf_helper_intro with n.
      + apply nf_intro; trivial.
        * eapply IHgamma with (phi0 alpha1); trivial.
          -- repeat split; auto with T1.
             apply le_lt_trans with (cons alpha1 n alpha2); auto.
             apply le_phi0; eauto with T1.
          -- apply  nf_helper_phi0.
             eapply nf_helper_intro; eauto.
          -- now apply head_lt.
        * apply nf_helper_oplus; auto.
          eapply nf_helper_intro; eauto.
          now constructor 2.
Qed.

  Lemma oplus_nf (alpha  beta : T1) :
      nf alpha ->  nf beta -> nf (alpha o+ beta).
  Proof.
    intros  H H0;
    apply oplus_nf_0 with (phi0 (max alpha beta)) ; trivial.
    - apply nf_phi0. apply max_nf; trivial.
    - apply lt_le_trans with (phi0 alpha).
      + apply lt_a_phi0_a.
      + apply phi0_mono, le_max_a.
    - rewrite max_comm.
      apply lt_le_trans with (phi0 beta).
      + apply lt_a_phi0_a.
      + apply phi0_mono, le_max_a.
  Qed.

End Proof_of_plus_nf.

Lemma o_finite_mult_nf : forall a n, nf a -> nf (o_finite_mult n a).
Proof.
  induction n;simpl.
  - constructor.
  - intro;apply oplus_nf; auto.
Qed.

Section Proof_of_oplus_comm.
  (* begin snippet oplusComm0:: no-out *)
  Lemma oplus_comm_0 (gamma: T1):
    nf gamma ->
    forall alpha beta,  nf alpha -> nf beta ->
                        T1.lt alpha gamma ->
                        T1.lt beta gamma ->
                        alpha o+ beta = beta o+ alpha.
  Proof.
    transfinite_induction gamma.
    (* ... *)
  (* end snippet oplusComm0 *)
    intros x H0 H; destruct alpha, beta; try reflexivity.
    rewrite oplus_eqn.
    rewrite (oplus_eqn  (cons beta1 n0 beta2) (cons alpha1 n alpha2)).
    repeat rewrite (compare_rev alpha1 beta1).
    intros Hnf_1 Hnf_2 Hlt_1 Hlt_2.
    nf_decomp Hnf_1; nf_decomp Hnf_2.
    destruct (compare alpha1 beta1) eqn:Hcomp; simpl CompOpp.
    - apply compare_eq_iff in Hcomp as <-.
      repeat rewrite (Nat.add_comm n n0); f_equal.
      + apply H0 with (phi0 alpha1); trivial.
        2-3: apply nf_helper_phi0, nf_helper_intro with n; eauto.
        apply LE_LT_trans with (cons alpha1 n0 beta2).
        * now apply LE_phi0.
        * now repeat split.
    - rewrite <- oplus_compare_Lt; auto.
      rewrite oplus_compare_Lt; auto.
      f_equal.
      apply H0 with (phi0 beta1) ; trivial.
      + apply LE_LT_trans with (cons beta1 n0 beta2).
        apply LE_phi0; auto.
        repeat split; trivial.
      + now apply head_lt, compare_lt_iff.
      + now apply nf_helper_phi0, nf_helper_intro with n.
    - rewrite <- oplus_compare_Gt; auto.
      rewrite oplus_compare_Gt; auto.
      f_equal; apply H0 with (phi0 alpha1); trivial.
      apply LE_LT_trans with (cons alpha1 n alpha2); trivial.
      + now apply LE_phi0.
      + repeat split; eauto with T1; apply nf_helper_phi0.
      + apply nf_helper_phi0, nf_helper_intro with n; eauto.
      + now apply head_lt, compare_gt_iff.
  Qed.

  (* begin snippet oplusComm:: no-out *)
  Lemma oplus_comm (alpha beta: T1):
   nf alpha -> nf beta -> alpha o+ beta =  beta o+ alpha.
  Proof.
    intros ? ?; apply oplus_comm_0 with (T1.succ (max alpha beta));
      trivial.
    (* ... *)
  (* end snippet oplusComm *)

    - apply succ_nf; apply max_nf;auto.
    - apply le_lt_trans with (max alpha beta); trivial.
      + apply le_max_a.
      + apply lt_succ.
    - apply le_lt_trans with  (max alpha beta); trivial.
      + apply le_max_b.
      + apply lt_succ.
  Qed.

End Proof_of_oplus_comm.

Lemma oplus_lt_rw2 : forall a n b x, nf (cons a n b) -> nf x ->
                                     nf_helper x a ->
                                     cons a n b o+  x  =
                                     cons a n (b o+ x).
Proof.
  destruct x.
  - now (intros; repeat rewrite oplus_0_r).
  - intros; rewrite (oplus_eqn  (cons a n b) (cons x1 n0 x2)).
    apply nf_helper_phi0 in H1.
    destruct (lt_inv H1).
    + unfold T1.lt in H2.
      rewrite compare_rev, H2.
      reflexivity.
    + decompose [or and] H2.
      *  inversion H5.
      * T1_inversion H6.
Qed.

Section Proof_of_oplus_assoc.

  Ltac ass_rw Hrec alpha a b c :=
    match goal with |- context Gamma [oplus ?a (oplus ?b  ?c)] =>
                    erewrite Hrec with alpha  a b c end.

  Ltac ass_rw_rev Hrec alpha a b c :=
    match goal with |- context Gamma [oplus (oplus ?a  ?b)  ?c] =>
                          erewrite <- Hrec with alpha  a b c end.
  (* begin snippet oplusAssoc0:: no-out *)
  Lemma oplus_assoc_0 (alpha: T1):
      nf alpha ->
      forall a b c,  nf a -> nf b -> nf c ->
                      T1.lt a alpha ->
                      T1.lt b alpha -> T1.lt c alpha ->
                      a o+ (b o+ c) = (a o+ b) o+ c.
  Proof.
    transfinite_induction_lt alpha.
  (* ... *)
(* end snippet oplusAssoc0 *)
    clear alpha ; intros alpha Hrec Halpha.
    intros; destruct a, b, c; try reflexivity.
    - repeat rewrite oplus_0_l; repeat rewrite oplus_0_r; trivial.
    - now  repeat rewrite oplus_0_r.
    - {  nf_decomp H; nf_decomp H0; nf_decomp H1.
        repeat rewrite oplus_cons_cons.
        destruct (compare b1 c1) eqn:Hbc;
        destruct (compare a1 b1) eqn:Hab;
        repeat rewrite oplus_cons_cons;
        try compare trans Hab Hbc as Hac;
        try rewrite Hab;
        try rewrite Hbc;
        try rewrite Hac.
        - apply compare_eq_iff in Hbc as <-, Hac as <-.
          ass_rw Hrec (cons a1 n a2) a2 b2 c2; trivial.
          + f_equal; abstract lia.
          + apply tail_lt_cons; auto.
          + apply lt_le_trans with (phi0 a1).
            * now apply nf_helper_phi0, nf_helper_intro with n0.
            * now apply le_phi0.
          + apply lt_le_trans with (phi0 a1).
            * now apply nf_helper_phi0, nf_helper_intro with n0.
            * now apply le_phi0.
        - apply compare_eq_iff in Hbc as <-.
          ass_rw Hrec (cons b1 n0 b2) (cons a1 n a2) b2 c2; trivial.
          + now apply head_lt.
          + now apply tail_lt_cons.
          + apply lt_le_trans with (phi0 b1).
            * now apply nf_helper_phi0, nf_helper_intro with n1.
            * now apply le_phi0.
        - apply compare_eq_iff in Hbc as <-.
          f_equal.
          ass_rw_rev Hrec (cons a1 n a2) a2 (cons b1 n0 b2)
                          (cons b1 n1 c2) ; trivial.
          + f_equal.
            now rewrite oplus_cons_cons, compare_refl.
          + now apply tail_lt_cons.
          + now apply head_lt, compare_gt_iff.
          + now apply head_lt, compare_gt_iff.
        - f_equal.
          ass_rw  Hrec (cons c1 n1 c2) (cons a1 n a2)
                       (cons a1 n0 b2) c2 ; trivial.
          + f_equal; now rewrite oplus_cons_cons, Hab.
          + now apply head_lt.
          + now apply head_lt.
          + now apply tail_lt_cons.
        - f_equal.
          ass_rw  Hrec (cons c1 n1 c2) (cons a1 n a2)
                       (cons a1 n0 b2) c2 ; trivial.
          + f_equal; now rewrite oplus_cons_cons, Hab.
          + now apply head_lt.
          + now apply head_lt.
          + now apply tail_lt_cons.
        - destruct (compare a1 c1) eqn: Hac; f_equal.
          + ass_rw  Hrec (cons a1 n a2) a2 (cons b1 n0 b2) c2 ; trivial.
            * now apply tail_lt_cons.
            * now apply head_lt, compare_gt_iff.
            * apply lt_le_trans with (phi0 a1).
              -- apply compare_eq_iff in Hac as ->.
                 now apply nf_helper_phi0, nf_helper_intro with n1.
              -- now apply le_phi0.
          + ass_rw  Hrec (cons c1 n1 c2) (cons a1 n a2)
                         (cons b1 n0 b2) c2 ; trivial.
            * now rewrite oplus_cons_cons, Hab.
            * now apply head_lt, compare_lt_iff.
            * now apply head_lt, compare_lt_iff.
            * now apply tail_lt_cons.
          + ass_rw_rev Hrec (cons a1 n a2) a2 (cons b1 n0 b2)
                            (cons c1 n1 c2) ; trivial.
            * now rewrite oplus_cons_cons, Hbc.
            * now apply tail_lt_cons.
            * now apply head_lt, compare_gt_iff.
            * now apply head_lt, compare_gt_iff.
        - ass_rw_rev  Hrec (cons a1 n a2)  a2 b2  (cons c1 n1 c2); trivial.
          + now apply tail_lt_cons.
          + apply lt_le_trans with (phi0 a1).
            * apply compare_eq_iff in Hab as ->.
              now apply nf_helper_phi0, nf_helper_intro with n0.
            * now apply le_phi0.
          + now apply head_lt, compare_gt_iff.
        - ass_rw_rev  Hrec (cons b1 n0 b2) (cons a1 n a2) b2
                           (cons c1 n1 c2) ; trivial.
          + now apply head_lt, compare_lt_iff.
          + now apply tail_lt_cons.
          + now apply head_lt, compare_gt_iff.
        - f_equal.
          ass_rw_rev Hrec (cons a1 n a2) a2 (cons b1 n0 b2)
                          (cons c1 n1 c2); trivial.
            * f_equal; now rewrite oplus_cons_cons, Hbc.
            * now apply tail_lt_cons.
            * now apply head_lt, compare_gt_iff.
            * now apply head_lt, compare_gt_iff.
      }
  Qed.
  (*||*)

  (* begin snippet oplusAssoc:: no-out *)
  Lemma oplus_assoc (alpha beta gamma:T1) :
    nf alpha -> nf beta -> nf gamma ->
    alpha o+ (beta o+ gamma) =
    alpha o+ beta o+ gamma.
  Proof with eauto with T1.
    intros.
    apply oplus_assoc_0 with (T1.succ (max alpha (max beta gamma)));
      trivial.
    (* ... *)
  (* end snippet oplusAssoc *)

    1: apply succ_nf; repeat apply max_nf ...
    all: apply le_lt_trans with (max alpha (max beta gamma));
      [| apply lt_succ] ...
    - apply le_max_a.
    - rewrite (max_comm alpha (max beta gamma)). rewrite <- max_assoc.
      apply le_max_a.
    - rewrite  max_assoc.
      rewrite (max_comm (max alpha beta) gamma).
      apply le_max_a.
  Qed.

End Proof_of_oplus_assoc.

Section Proof_of_oplus_lt1.
  Variables a1 a2: T1.
  Variable n : nat.
  Hypothesis H0 : nf (cons a1 n a2).

  Lemma oplus_lt_0 : forall b, nf b -> T1.lt b (b o+ (cons a1 n a2)).
  Proof with eauto with T1.
    intros b ; transfinite_induction_lt b.
    intros x H1 H;  destruct x.
    -  simpl; auto with T1.
    - rewrite oplus_eqn;case_eq (compare x1 a1).
      +  auto with T1 arith.
      +  intros H2; apply head_lt. unfold T1.lt; now  rewrite H2.
      + intro; apply tail_lt,  H1 ;  trivial.
        eapply nf_inv2, H.
        now  apply tail_lt_cons.
        eapply nf_inv2, H.
  Qed.

End Proof_of_oplus_lt1.

Lemma oplus_lt1 : forall a b, nf a -> nf b ->  T1.lt T1.zero  a ->
                              T1.lt b  (b o+  a).
Proof.
  destruct a.
  - intros b _ _ H; T1_inversion H.
  - intros; now apply oplus_lt_0.
Qed.

Lemma oplus_lt2 : forall a b, nf a -> nf b ->  T1.lt T1.zero  b ->
                              T1.lt a  (b o+ a).
Proof.
  intros a b Ha Hb  HD. rewrite (oplus_comm Hb Ha); auto;
                        apply oplus_lt1;auto.
Qed.

Lemma oplus_le1 : forall a b, nf a -> nf b -> leq lt a (a o+ b).
Proof.
  intros; destruct b.
  - now rewrite oplus_0_r.
  - apply lt_incl_le; apply oplus_lt1; auto with T1.
Qed.

Lemma oplus_le2 : forall a b, nf a -> nf b -> leq lt  b (a o+ b).
Proof.
  intros; rewrite (@oplus_comm a b);auto.
  now apply oplus_le1.
Qed.

Lemma oplus_strict_mono_0 :
  forall alpha, nf alpha ->
                forall a (Ha:nf a) b (Hb: nf b) c (Hc : nf c),
                  lt a alpha ->  lt c alpha -> lt b c ->
                  lt (a o+ b) (a o+ c).
Proof with eauto with T1.
  intros alpha ; transfinite_induction_lt alpha.
  clear alpha ; intros alpha Hrec  Halpha; intros.
  destruct a.
  {
    now  repeat rewrite  oplus_0_l.
  }
  destruct b, c.
  - inversion H1.
  - rewrite  oplus_0_r.
    now apply oplus_lt1.
  - T1_inversion H1.
  -  nf_decomp Ha; nf_decomp Hb; nf_decomp Hc.
     rewrite ( oplus_eqn (cons a1 n a2) (cons b1 n0 b2)).
     rewrite ( oplus_eqn (cons a1 n a2) (cons c1 n1 c2)).
     case_eq (compare a1 b1).
     intro Ha1_b1; case_eq (compare a1 c1).
     {
       intro Ha1_c1.
       destruct (lt_inv H1).
       {
         apply compare_eq_iff in Ha1_b1 as <-, Ha1_c1 as <-.
         now apply lt_irrefl in H2.
       }
       destruct H2.
       destruct H2;subst c1.
       apply coeff_lt.
       auto with arith.
       decompose [and] H2; subst c1 n1.
       apply tail_lt.
       apply compare_eq_iff in Ha1_b1 as <-.
       apply Hrec with (phi0 a1); trivial.
       auto with T1.
       apply le_lt_trans with (cons a1 n a2) ; trivial.
       apply le_phi0.
       auto with T1.
       apply nf_helper_phi0.
       eapply nf_helper_intro; auto with T1.
       apply nf_helper_phi0.
       eapply nf_helper_intro ; auto with T1.
     }
     {
       intro Ha1b1; rewrite compare_lt_iff in Ha1b1.
       apply compare_eq_iff in Ha1_b1 as <-.
       now apply head_lt.
     }
     {
       apply compare_eq_iff in Ha1_b1 as <-.
       intro H2.
       absurd  (T1.lt (cons a1 n0 b2) (cons c1 n1 c2)).
       - apply lt_not_gt.
         apply head_lt.
         unfold T1.lt;rewrite compare_rev. now   rewrite H2.
       -   auto.
     }
     {
       intro.
       rewrite compare_lt_iff in H2.
       case_eq (compare a1 c1).
       {
         intro.
         apply compare_eq_iff in H3 as <-.
         absurd (T1.lt (cons b1 n0 b2) (cons a1 n1 c2));auto.
         apply lt_not_gt.
         apply head_lt; auto.
       }
       {
         intro.
         rewrite compare_lt_iff in H3.
         destruct (lt_eq_lt_dec b1 c1).
         destruct s.
         { apply head_lt; auto. }
         {
           subst c1.
           destruct (lt_inv_coeff_dec H1).
           { apply coeff_lt; auto.  }
           destruct a; subst n1.
           apply tail_lt; auto.
           rewrite (oplus_eqn (cons a1 n a2) b2).
           rewrite (oplus_eqn (cons a1 n a2) c2).
           destruct b2,c2.
           T1_inversion H5.
           case_eq (compare a1 c2_1).
           intro.
           apply coeff_lt;  auto with arith.
           intro H6; apply head_lt; unfold T1.lt; now rewrite H6.
           intros; apply tail_lt.
           apply oplus_lt1; trivial.
           T1_inversion H5.
           case_eq (compare a1 b2_1); case_eq (compare a1 c2_1); intros.
           {
             apply compare_eq_iff in H4 as <-, H6 as <-.
             destruct (lt_inv_coeff_dec H5).
             apply coeff_lt; auto with arith.
             destruct a;subst;
               apply tail_lt.
             apply Hrec with (phi0 a1); trivial.
             apply le_lt_trans with (cons a1 n a2);eauto with T1.
             apply le_phi0.
             eapply nf_inv2, nf2.
             eapply nf_inv2, nf4.
             apply nf_helper_phi0. eapply nf_helper_intro; eauto with T1.
             apply nf_helper_phi0. eapply nf_helper_intro; eauto with T1.
           }
           {
             apply compare_eq_iff in H6 as <-.
             now apply head_lt.
           }
           {
             apply compare_eq_iff in H6 as <-.
             apply compare_gt_iff in H4.
             exfalso.
             apply (@lt_trans c2_1 a1 b1) in H4 as Hgt; auto.
             now apply lt_inv_head, le_not_gt in H5.
           }
           {
             apply compare_eq_iff in H4 as <-.
             rewrite compare_lt_iff in H6.
             contradict H5; apply lt_not_gt;  now apply head_lt.
           }
           {
             destruct (lt_inv H5).
             now apply head_lt.
             destruct H7.
             destruct H7;subst c2_1.
             now apply coeff_lt.
             decompose [and] H7.
             clear H7;  subst.
             apply tail_lt.
             apply Hrec with (phi0 b1) ; trivial.
             apply le_lt_trans with (cons b1 n0 (cons c2_1 n2 c2_2));
               trivial.
             apply le_phi0.
             eapply nf_inv2, nf2.
             eapply nf_inv2, nf4.
             auto with T1.
             apply lt_trans with (cons c2_1 n2 c2_2) ; trivial.
             apply tail_lt_cons; eauto with T1.
             eauto with T1.
           }
           {
             rewrite compare_lt_iff in H6. rewrite compare_gt_iff in H4.
             generalize(lt_inv_tail H1).
             intro.
             contradict H7;  apply lt_not_gt; apply head_lt.
             eapply lt_trans;eauto.
           }
           { apply coeff_lt;auto with arith. }
           { now apply head_lt. }
           { apply tail_lt.
             apply Hrec with (phi0 a1) ; trivial.
             apply le_lt_trans with   (cons a1 n a2).
             apply le_phi0; info_eauto with T1.
             auto with T1.
             apply nf_helper_phi0.
             eapply nf_helper_intro, Ha.
             apply head_lt; now rewrite compare_gt_iff in H4.
           }
         }

         {
           contradict H1; apply lt_not_gt;   now apply head_lt.
         }
       }
       { intro H3;  rewrite compare_gt_iff in H3.
         contradict H1.
         apply lt_not_gt.
         apply head_lt;  apply lt_trans with a1;auto.
       }
     }

     { intro.
       rewrite compare_gt_iff in H2.
       case_eq  (compare a1 c1).
       intro.
       apply compare_eq_iff in H3 as <-.
       apply coeff_lt; auto with arith.
       intro H3; rewrite compare_lt_iff in H3.
       apply head_lt, H3.

       intro H3; rewrite compare_gt_iff in H3.
       apply tail_lt.
       apply Hrec with (phi0 a1) ; trivial.
       apply le_lt_trans with   (cons a1 n a2) ; trivial.
       apply le_phi0 ; info_eauto with T1.
       apply nf_helper_phi0.
       eapply nf_helper_intro;eauto with T1.
       auto with T1.
     }
     Unshelve.
     exact 0.
     exact 0.
Qed.

Lemma oplus_strict_mono_r : forall a b c, nf a -> nf b -> nf c ->
                                          lt b c -> lt (a o+ b) (a o+ c).
Proof with auto with T1.
  intros.
  apply oplus_strict_mono_0 with (phi0 (max a c)); trivial.
  apply nf_phi0;apply max_nf; trivial.
  apply le_lt_trans with (max a c).
  - apply le_max_a.
  - apply lt_a_phi0_a ...
  -  apply le_lt_trans with (max a c) ...
     apply le_max_b ...
Qed.

Lemma oplus_strict_mono_l : forall a b c, nf a -> nf b -> nf c ->
                                          T1.lt a b  ->
                                          T1.lt (a o+ c) (b o+ c).
Proof.
  intros a b c Ha Hb Hc H.
  rewrite (oplus_comm  Ha Hc).
  rewrite (oplus_comm Hb Hc).
  now apply oplus_strict_mono_r.
Qed.

(* begin snippet oplusMono *)

Lemma oplus_strict_mono_LT_l (alpha beta gamma : T1) :
  nf gamma -> alpha  t1< beta ->
  alpha o+ gamma t1< beta o+ gamma. (* .no-out *)
(*| .. coq:: none *)
Proof.
  intros  Hgamma H.
  generalize (LT_nf_l H), (LT_nf_r H); intros  Ha  Hb.
   repeat split.
  now apply oplus_nf.
  apply oplus_strict_mono_l; trivial.
  auto with T1.
  now apply oplus_nf.
Qed.
(*||*)

Lemma oplus_strict_mono_LT_r (alpha beta gamma : T1) :
  nf alpha -> beta t1< gamma ->
  alpha o+ beta t1< alpha o+ gamma. (* .no-out *)
(*| .. coq:: none *)
Proof.
  intros  Halpha H.
  generalize (LT_nf_l H), (LT_nf_r H); intros  Hb  Hc.
  repeat split.
  now apply oplus_nf.
  apply oplus_strict_mono_r; trivial.
  auto with T1.
  now apply oplus_nf.
Qed.
(*||*)
(* end snippet oplusMono *)

Lemma oplus_strict_mono_bi : forall a b c d ,
    nf a -> nf b -> nf c -> nf d ->
    T1.lt a b  -> T1.lt c d -> T1.lt (a o+ c) (b o+ d).
Proof.
  intros a b c d Ha Hb Hc Hd H0 H1;
  apply lt_trans with (oplus a d).
  -  apply oplus_strict_mono_r; auto.
  -  apply oplus_strict_mono_l; auto.
Qed.

Lemma oplus_of_phi0_0 : forall a b,
                          phi0 a o+ phi0 b =
                          match compare (phi0 a) (phi0 b)
                          with Lt => cons b 0 (cons a 0 T1.zero)
                            |  Eq => cons a 1 T1.zero
                            | Gt =>  cons a 0 (cons b 0 T1.zero)
                          end.
Proof.
  intros a b; rewrite oplus_eqn; cbn; now  destruct (compare a b).
Qed.

Lemma oplus_of_phi0 : forall a b,
                        phi0 a o+ phi0 b =
                        match compare a b
                        with Lt => cons b 0 (cons a 0 T1.zero)
                          |  Eq => cons a 1 T1.zero
                          | Gt =>  cons a 0 (cons b 0 T1.zero)
                        end.
Proof.
  intros a b; now rewrite oplus_of_phi0_0, compare_of_phi0.
Qed.

Lemma o_finite_mult_rw : forall a n, o_finite_mult (S n) (phi0 a) =
                                     cons a n T1.zero.
Proof.
  induction n.
  -  reflexivity.
  -  change (phi0 a o+  (o_finite_mult (S n) (phi0 a)) = cons a (S n) T1.zero).
     rewrite IHn;  rewrite oplus_eqn.
     simpl; now rewrite compare_refl.
Qed.

Lemma o_finite_mult_lt_phi0_1 : forall a b n,
                                  T1.lt a b ->
                                  T1.lt (o_finite_mult n (phi0 a)) (phi0 b).
Proof with auto with T1.
  intros a b n H;destruct n.
  -  apply zero_lt.
  - rewrite o_finite_mult_rw.
    now apply head_lt.
Qed.

Lemma o_finite_mult_mono : forall a b n,  nf a -> nf b -> T1.lt a b ->
                                          T1.lt (o_finite_mult (S n) a)
                                             (o_finite_mult (S n) b).
Proof with auto with T1.
  induction n.
  -  simpl;   repeat rewrite oplus_0_r;auto.
  -  simpl; intros;
     apply oplus_strict_mono_bi ...
     apply oplus_nf;auto.
     apply o_finite_mult_nf;auto.
     apply oplus_nf;auto.
     apply o_finite_mult_nf;auto.
Qed.

Lemma oplus_lt_phi0 : forall a b c,  nf a -> nf b -> nf c ->
                                     T1.lt a c -> T1.lt b c ->
                                     T1.lt (phi0 a o+ phi0 b) (phi0 c).
Proof.
  intros;  rewrite oplus_cons_cons; case_eq (compare a b).
   rewrite oplus_0_r; cbn.
   all: intros;  apply head_lt; eauto with T1.
Qed.


Require Import smart_common monads.
Require Import NArith Omega.

Inductive term : Type :=
| Var : N -> term
| App : term -> term -> term
| Abs : term -> term.

Fixpoint size t :=
  match t with
    | Var _ => 1
    | App u v => 1 + size u + size v
    | Abs t => 1 + size t
  end.

Extract Inductive term =>
  "Helpers_lambda.term"
  ["Helpers_lambda.hVar" "Helpers_lambda.hApp" "Helpers_lambda.hAbs"]
  "Helpers_lambda.term_match".

Parameter memo_term : memoizer term.
Extract Inlined Constant memo_term => "Helpers_lambda.term_memo".

Definition lifti : N -> term -> N -> term.
refine (
  memo (fun n =>
    memo_rec (well_founded_ltof _ size) (fun t rec k =>
      memo (fun k =>
        match t with
          | Var i => fun rec => if N.ltb i k then Var i else Var (N.add i n)
          | Abs t => fun rec => Abs (rec t _ (N.succ k) )
          | App t u => fun rec => App (rec t _ k) (rec u _ k)
        end) k rec)));
unfold ltof; simpl; abstract omega.
Defined.

Definition lift n t := lifti n t 0%N.

Definition substi : term -> term -> N -> term.
refine(
  memo (fun w =>
    memo_rec (well_founded_ltof _ size) (fun t rec n =>
      memo (fun n =>
        match t with
          | Var k => fun rec => if N.eqb k n then lift n w else if N.ltb k n then Var k else Var (N.pred k)
          | Abs t => fun rec => Abs (rec t _ (N.succ n))
          | App t u => fun rec => App (rec t _ n) (rec u _ n)
        end) n rec)));
unfold ltof; simpl; abstract (omega).
Defined.

Definition subst u t := substi u t 0%N.

Definition hnf : Fuel -> term  -> option (term) :=
  memo_fuel _ (fun x => term) (fun (t:term) hnf =>
    match t with
      | Var n => Some (Var n)
      | Abs t => let! t = hnf (t);
                 retn (Abs t)
      | App t u =>
        let! t = hnf t;
        match t with
          | Abs w => hnf (subst u w)
          | h => retn (App h u)
        end
    end).

Definition nf big_fuel :=
  memo_fuel _ (fun x => term) (fun (t: term) nf =>
    match t with
      | Var n => Some (Var n)
      | Abs t => let! t = nf (t);
                 retn (Abs t)
      | App t u =>
        let! t = hnf big_fuel t;
        match t with
          | Abs w => nf (subst u w)
          | h => let! h = nf h;
                 let! u = nf u;
                 retn (App h u)
        end
    end).

Inductive beta : term -> term -> Prop :=
| beta_0 : forall t u, beta (App (Abs t) u) (subst u t)
| beta_Abs : forall t1 t2, beta t1 t2 -> beta (Abs t1) (Abs t2)
| beta_App1 : forall t1 t2 u, beta t1 t2 -> beta (App t1 u) (App t2 u)
| beta_App2 : forall u t1 t2, beta t1 t2 -> beta (App u t1) (App u t2).

Inductive beta_star : term -> term -> Prop :=
| beta_star_0 : forall t, beta_star t t
| beta_star_S : forall t1 t2 t3, beta t1 t2 -> beta_star t2 t3 -> beta_star t1 t3.

Lemma beta_star_trans:
  forall t1 t2 t3,
    beta_star t1 t2 -> beta_star t2 t3 ->
    beta_star t1 t3.
Proof.
  fix 4.
  destruct 1. auto.
  intros. eapply beta_star_S. apply H. eapply beta_star_trans; eauto.
Qed.

Lemma hnf_beta :
  forall fuel t t',
    hnf fuel t = Some t' ->
    beta_star t t'.
Proof.
  induction fuel. discriminate. destruct t.
  - inversion 1. apply beta_star_0.
  - simpl. intros.
    destruct (hnf fuel t1) eqn:EQ; inversion H; subst; clear H.
    apply IHfuel in EQ.
    assert (beta_star (App t1 t2) (App t t2)).
    { clear H1. induction EQ. apply beta_star_0. eapply beta_star_S; eauto.
      apply beta_App1. auto. }
    eapply beta_star_trans. eauto.
    destruct t; inversion H1; subst; clear H1; try apply beta_star_0.
    eapply beta_star_S. apply beta_0. auto.
  - simpl. intros. destruct (hnf fuel t) eqn:?; inversion H; subst; clear H.
    apply IHfuel in Heqo.
    induction Heqo. apply beta_star_0. eapply beta_star_S. apply beta_Abs; eauto. auto.
Qed.

Lemma nf_beta :
  forall fuel1 fuel2 t t',
    nf fuel1 fuel2 t = Some t' ->
    beta_star t t'.
Proof.
  induction fuel2. discriminate. destruct t.
  - inversion 1. apply beta_star_0.
  - simpl. intros.
    destruct (hnf fuel1 t1) eqn:EQ; inversion H; subst; clear H.
    eapply hnf_beta in EQ.
    eapply beta_star_trans.
    { clear H1. induction EQ. apply beta_star_0. eapply beta_star_S; eauto.
      apply beta_App1. auto. }
    clear EQ. destruct t.
    + destruct (nf fuel1 fuel2 (Var n)) eqn:?; try discriminate.
      apply IHfuel2 in Heqo.
      eapply beta_star_trans.
      { clear H1. induction Heqo. apply beta_star_0. eapply beta_star_S; eauto.
        apply beta_App1. auto. }
      clear Heqo.
      destruct (nf fuel1 fuel2 t2) eqn:?; inversion H1. subst. clear H1.
      apply IHfuel2 in Heqo.
      induction Heqo. apply beta_star_0. eapply beta_star_S; eauto.
      apply beta_App2. auto.
    + destruct (nf fuel1 fuel2 (App t3 t4)) eqn:?; try discriminate.
      apply IHfuel2 in Heqo.
      eapply beta_star_trans.
      { clear H1. induction Heqo. apply beta_star_0. eapply beta_star_S; eauto.
        apply beta_App1. auto. }
      clear Heqo.
      destruct (nf fuel1 fuel2 t2) eqn:?; inversion H1. subst. clear H1.
      apply IHfuel2 in Heqo.
      induction Heqo. apply beta_star_0. eapply beta_star_S; eauto.
      apply beta_App2. auto.
    + apply IHfuel2 in H1.
      eapply beta_star_S. apply beta_0. auto.
  - simpl. intros.
    destruct (nf fuel1 fuel2 t) eqn:?; inversion H; subst; clear H.
    apply IHfuel2 in Heqo.
    induction Heqo. apply beta_star_0. eapply beta_star_S; eauto.
    apply beta_Abs. auto.
Qed.

Section big.

Variable big:nat.

Definition Nf t := nf big big t.

Section nat.
  Context {A : Type}.
  Variable iter : A -> A.
  Variable init : A.
  Fixpoint eval_rec t := match t with
                           | Var 0 => retn init
                           | App (Var 1) u => let! x = eval_rec u;
                                              retn (iter x)
                           | _ => None
                         end.
  Definition eval_nat t :=
    match t with
        | Abs (Abs t) => eval_rec t
        | _ => None
    end.
End nat.
Definition compute_nat := eval_nat S O.

Definition normal_nat n := let! t = Nf n; compute_nat t.

Fixpoint eval_lrec t :=
  match t with
    | Var 0 => retn (List.nil)
    | App (App (Var 1) x) l =>
      let! x = compute_nat x;
      let! q = eval_lrec l  ;
         retn (List.cons x q)
    | _ => None
  end.

Fixpoint eval_list_of_nats t :=
  match t with
    | Abs (Abs t) => eval_lrec t
    | _ => None
  end.

Definition normal_list_of_nats l := let! l = Nf l; eval_list_of_nats l.

End big.

Notation "\ x" := (Abs x) (at level 20).
Notation "x # y" := (App x y) (left associativity, at level 25).

Coercion Var : N >-> term.

Module T.

Open Scope N.
Definition K := \\1.

Definition false := \\ 0.
Definition true  := \\ 1.
Definition cond  := \\\ (2 # 1 #  0).

Definition pair  := \\\ (0 #  2 #  1).
Definition fst  := \ (0 #  true).
Definition snd  := \ (0 #  false).

Definition zero := \\ 0.
Definition succ := \\\ (1 #  (2 #  1 #  0)).
Definition one  := succ #  zero.

Fixpoint church n := match n with O => zero | S n => (succ #  (church n)) end.

Definition null := \ (0 #  ( K #  false) #  true).

Definition add := \\ \\ (3 #  1 #  (2 #  1 #  0)).
Definition pred :=
  let loop := \ (let pred := fst #  0 in
                 pair #  (succ #  pred) #  pred )
  in \ (snd #  (0 #  loop #  (pair #  zero #  zero))).

Definition geq := \\ (1 #  pred #  0 #  (K #  false) #  true).

Definition iter := \\( 0 #  1 #  (1 #  one)).
Definition ack  := \(0 #  iter #  succ #  0).

Definition Y := \(  (\ (1 #  (0 #  0) ))  #  (\ ( 1 #  ( 0 #  0)))).
Definition FIX := let F := (\\
                    let f := 0 in
                    let x := 1 in
                    (f #  ( x #  x #  f ) )) in F #  F.

Definition SUM :=
  FIX # (\\ ( (cond # (null # 0)) # zero # (add # 0 # (1 # (pred # 0))))).

Definition nil := \\0.
Definition cons := \\ (\\ (1 #  3 #  (2 #  1 #  0))).
Definition isnil := \(0 # (\\ false) # true).
Definition head  := \ (0 # (\\ (1)) # false).
Definition tail  :=
  \(fst # (0 # (\\(pair # (snd # 0)# (cons#1#(snd#0))))#(pair#nil#nil))).

Definition append := \\ \\ (3 #  1 #  (2 #  1 #  0)).

Definition partition :=
  \\
    (let fork :=
         \\
           (
             let pred := 3 in let l := 2 in let x := 1 in let acc := 0 in
             let l1 := fst #  acc in
             let l2 := snd #  acc in
             pred #  x #  (pair #  (cons #  x #  l1) #  l2) #  (pair #  l1 #  (cons #  x #  l2))
           )
     in
     0 #  fork #  (pair #  nil #  nil)
    ).

Definition quicksort' :=
  FIX #  (\
           (let sort :=
               \\
                 (let rec := 3 in let a := 1 in let l := 0 in
                 let p := partition #  (geq #  a) #  l in
                 append #  (rec # (fst #  p)) #  (cons #  a #  (rec #(snd #  p))) )
           in
           \ (0 #  sort #  nil))
        ).

(* A more usual presentation of quicksort. *)
Definition quicksort :=
  FIX #  (\\
            (cond
                # (isnil # 0)
                # (nil)
                # (let hd := head # 0 in
                    let tl := tail # 0 in
                    let p := partition #  (geq #  hd) #  tl in
                    let rec := 1 in
                    append #  (rec # (fst #  p)) #  (cons # hd #  (rec #(snd #  p))) ))).

Fixpoint list l :=
  match l with
    | List.cons t q => cons # t # (list q)
    | List.nil => nil
  end.

End T.

(* Definition big := pow 2 14. *)

(* Time Eval vm_compute in nf big big (T.SUM # T.church 1). *)
(* Time Eval vm_compute in normal_nat big (T.SUM # T.church 5). *)
(* Eval vm_compute in normal_nat big (T.snd # (T.pair # T.zero # T.one)). *)
(* Eval vm_compute in normal_nat big (T.pred # T.church 5). *)

Require Import List.
Open Scope list_scope.

Definition list l := T.list (List.map T.church l).

(* Eval vm_compute in normal_list_of_nats big (list  (1::nil))%nat. *)
(* Eval vm_compute in normal_list_of_nats big (T.append #  (list  (1::2:: nil)) # (list (nil)))%nat. *)
(* Eval vm_compute in nf big big (T.geq # T.church 2 # T.church 1). *)

(* Eval vm_compute in normal_list_of_nats big (T.snd # (T.partition # (T.geq # T.church 3) # (list (1::2 ::5::nil))))%nat. *)
(* Eval vm_compute in normal_list_of_nats big (T.append #  (list  (1::2:: nil)) # (list  (nil)))%nat. *)

Definition quicksort fuel l := normal_list_of_nats fuel (T.quicksort # (list l)).
Definition quicksort' fuel l := normal_list_of_nats fuel (T.quicksort' # (list l)).


Require Import Lia.

Require Import IFOL.Semantics.Signature.
Require Import IFOL.Semantics.Theory.

Require Import IFOL.Examples.HA.Syntax.Signature.
Require Import IFOL.Examples.HA.Syntax.Theory.
Require Import IFOL.Examples.HA.Semantics.Signature.
Require Import IFOL.Examples.HA.Semantics.Sort.

Definition eval_HA_theory :
  theory_dom eval_HA_sort HA_sig eval_HA_sig HA_theory.
Proof.
  intro ax.
  destruct ax.
  - exact PeanoNat.Nat.neq_0_succ.
  - exact eq_add_S.
  - exact plus_O_n.
  - exact PeanoNat.Nat.add_succ_l.
  - exact PeanoNat.Nat.mul_0_l.
  - exact PeanoNat.Nat.mul_succ_l.
  - simpl.
    rewrite Formula.eval_Formula_subst.
    simpl.
    intros.
    induction x.
    + exact H.
    + pose proof (H0 x IHx) as G.
      rewrite Formula.eval_Formula_var_subst in G.
      exact G.
Defined.

Print Assumptions eval_HA_theory.