(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*  Pierre Casteran
    LaBRI, Université Bordeaux 1, and Inria Futurs (Logical)
*)

(*** Cantor "pre" Normal form
 After Manolios and Vroon work on ACL2 *)

Require Import Arith.
Require Import Omega. (* ( :-) *)
Require Import Compare_dec.
Require Import Relations.
Require Import Wellfounded.

Require Import Tools.
Require Import More_nat.
Require Import Wf_nat.
Require Import AccP.
Require Import not_decreasing.
Require Import ArithRing.

Require Import term.
Require Import rpo.
Require Import List.

Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

(************************)
(*   Definitions        *)
(************************)

(** cons a n b represents  omega^a *(S n)  + b *)

Inductive T1 : Set :=
  zero : T1
| cons : T1 -> nat -> T1 -> T1.

(** some abreviations *)
(*********************)

(** omega^x * (S k) *)

Definition omega_term (a:T1)(k:nat) :=
   cons a k zero.

Definition phi0 a := cons a 0 zero.

Definition finite (n:nat) : T1 :=
 match n with  0 => zero
             | S p => cons zero p zero
         end.

Notation "'F' n" := (finite n)(at level 29) : cantor_scope.

Definition omega := cons (cons zero 0 zero) 0 zero.

Definition log a := match a with
                               | zero => zero
                               | cons a _ _ => a
                              end.

Fixpoint omega_tower (n:nat) : T1 :=
            match n with 0 => finite 1
                       | S p => cons (omega_tower p) 0 zero
            end.

(* A total strict order on T1 *)

Inductive lt : T1 -> T1 -> Prop :=
|  zero_lt : forall a n b, lt zero  (cons a n b)
|  head_lt :
    forall a a' n n' b b', lt a  a' ->
                           lt (cons a n b) (cons a' n' b')
|  coeff_lt : forall a n n' b b', (n < n')%nat ->
                                 lt (cons a n b) (cons a n' b')
|  tail_lt : forall a n b b', lt b b' ->
                             lt (cons a n b) (cons a n b')
where  "o < o'" := (lt o o') : cantor_scope.

Hint Resolve zero_lt head_lt coeff_lt tail_lt : T1.

Open Scope cantor_scope.
Delimit Scope cantor_scope with ca.

(* the total non-strict order associated with lt   *)

Definition le (alpha beta :T1) := alpha = beta \/ alpha < beta.
Notation "alpha <= beta" := (le alpha beta) : cantor_scope.

Hint Unfold le : T1.

(* Additive principal ordinals *)

Inductive ap : T1 -> Prop:=
 ap_intro : forall a,  ap (cons a 0 zero).

Lemma ap_phi0 : forall a, ap (phi0 a).
Proof.
 unfold phi0;constructor.
Qed.

Lemma ap_phi0R : forall a, ap a ->{b : T1 | a = phi0 b}.
Proof.
  destruct a.
  intro;  elimtype False.
  inversion H.
  exists a1.
  inversion H.
  unfold phi0;auto.
Qed.

Fixpoint compare (c c':T1){struct c'}:comparison :=
  match c,c' with
    zero, zero => Eq
  | zero, cons a' n' b' => Lt
  | _   , zero => Gt
  | (cons a n b),(cons a' n' b') =>
      (match compare a a' with
          | Lt => Lt
          | Gt => Gt
          | Eq => (match lt_eq_lt_dec n n' with
                                           inleft  (left _) => Lt
                                         | inright _ => Gt
                                         |   _ => compare b b'
                                         end)
      end)
 end.

Definition max a b := match compare a b with Lt => b | _ => a end.

(* Properties of lt *)
(**********************)

Theorem not_lt_zero : forall a, ~ a < zero.
Proof.
  red; inversion_clear 1.
Qed.

Hint Resolve not_lt_zero : T1.

Theorem lt_inv : forall a n b a' n' b',
                      cons a n b <  cons a' n' b' ->
                      a < a' \/
                      a = a' /\ (n < n')%nat \/
                      a = a' /\ n = n' /\ b < b'.
Proof.
 inversion_clear 1; auto.
Qed.

Theorem lt_irr : forall a, ~ a < a.
Proof.
 induction a.
 red;inversion_clear 1.
 intro H; case (lt_inv  H); intuition.
Qed.
Hint Resolve lt_irr : T1.

Lemma lt_inv_nb : forall a n n' b b',
                       cons a n b <  cons a n' b' ->
                       (n<n')%nat \/  n=n' /\ b < b'.
Proof.
 inversion_clear 1; auto with T1.
 elim (lt_irr (a:=a)); auto.
Qed.

Lemma lt_inv_b : forall a n b b',
       cons a n b <  cons a n b' -> b < b'.
Proof.
 inversion_clear 1; auto with arith T1.
 elim (lt_irr  (a:=a));auto.
 elim (lt_irrefl n);auto.
Qed.

(* lt is a (strict) order *)

Theorem lt_trans : forall a b, a < b ->
                        forall c, b < c -> a < c.
Proof.
 induction 1.
 inversion 1; auto with T1.
 inversion_clear 1; auto with T1.
 inversion_clear 1; eauto with T1 arith.
 inversion_clear 1; auto with T1.
Qed.

Theorem lt_not_gt : forall a b, a < b  -> ~ b < a.
Proof.
 intros o1 o2 H H0.
 generalize (lt_trans  H H0).
 intro H2; case (lt_irr H2).
Qed.

Lemma finite_lt : forall n p : nat, (n < p)%nat ->
                      F n < F p.
Proof.
 destruct n;simpl.
 destruct p.
 inversion 1.
 simpl;auto with T1.
 destruct p.
 inversion 1.
 simpl;auto with T1.
 intro; assert (n<p)%nat ; auto with arith T1.
Qed.

Lemma finite_ltR : forall n p : nat,
                      F n < F p  ->
                      (n < p)%nat.
Proof.
 destruct n;simpl.
 destruct p.
 inversion 1.
 auto with arith.
 destruct p.
 inversion 1.
 simpl.
 intro H; case (lt_inv_nb H).
 auto with arith.
 intros (_,H0); case (lt_irr H0).
Qed.

(* The predicate "to be in normal form" *)

(* The real Cantor normal form needs the exponents of omega to be
   in strict decreasing order *)

Inductive nf : T1 -> Prop :=
| zero_nf : nf zero
| single_nf : forall a n, nf a ->  nf (cons a n zero)
| cons_nf : forall a n a' n' b, a' < a ->
                             nf a ->
                             nf(cons a' n' b)->
                             nf(cons a n (cons a' n' b)).
Hint Resolve zero_nf single_nf cons_nf : T1.

(*  "nf2 b a "means "b less than omega^a" *)

Inductive nf2 : T1 -> T1 -> Prop :=
| nf2_z : forall a, nf2 zero a
| nf2_c : forall a a' n' b', a' < a ->
                             nf2 (cons a' n' b') a.

Hint Resolve nf2_z nf2_c : T1.

(* General properties of the predicate "to be in normal form" *)

(* inversion lemmas *)

Lemma nf_inv1 : forall a n b, nf (cons a n b) -> nf a.
Proof.
  inversion_clear 1; auto.
Qed.

Lemma nf_inv2 : forall a n b, nf (cons a n b) -> nf b.
Proof.
 inversion_clear 1; auto  with T1.
Qed.

Hint Resolve nf_inv1 nf_inv2 : T1.

Ltac nf_inv := (eapply nf_inv1; progress eauto)||
               (eapply nf_inv2; progress eauto).

Lemma nf_tail_lt_nf : forall  b b', b' < b -> nf b' ->
                          forall a n,   nf (cons a n b) ->
                                        nf (cons a n b').
Proof.
 induction 1.
 constructor; eauto with T1.
 constructor.
 apply lt_trans with a'; auto.
 inversion H1; eauto with T1.
 eauto with T1.
 assumption.
 constructor.
 inversion H1;eauto with T1.
 eauto with T1.
 assumption.
 constructor.
 inversion H1;eauto with T1.
 eauto with T1.
 assumption.
Qed.

Lemma tail_lt_cons : forall b n a,
     nf (cons a n b)->
     b < cons a n b.
Proof.
 induction b.
 constructor.
 constructor 2.
 inversion H;auto.
Qed.

(* the number n isn't so important in nf_ness *)

Lemma nf_intro : forall a n b, nf a ->
                               nf b ->
                               nf2 b a ->
                               nf (cons a n b).
Proof.
 destruct 3; constructor; auto.
Qed.

Lemma nf2_intro : forall a n b, nf (cons a n b) ->
                                nf2 b a.
Proof.
 inversion 1 ; constructor; auto.
Qed.

Lemma nf2_phi0 : forall a b, nf2 b a ->
                             b < phi0 a.
Proof.
  induction 1; compute;  auto with T1.
Qed.

Lemma nf2_phi0R : forall a b, b < phi0 a -> nf2 b a.
Proof.
  induction b.
  constructor.
 inversion_clear 1.
 constructor;auto.
 inversion H0.
 inversion H0.
Qed.

Lemma nf_coeff_irrelevance : forall a b n p, nf (cons a n b) ->
                                             nf (cons a p b).
Proof.
 intros; apply nf_intro; try nf_inv.
 eapply nf2_intro;eauto.
Qed.

Lemma log_nf : forall a, nf a -> nf (log a).
Proof.
 destruct a;unfold log;simpl.
 constructor; eauto with T1.
 eauto with T1.
Qed.

Lemma nf_of_finite : forall  n b, nf (cons zero n b) ->
                       b = zero.
Proof.
 intros n b H; inversion_clear H.
 trivial.
 case (not_lt_zero (a:=a'));auto.
Qed.

Lemma ordinal_finite : forall n, nf (F n).
Proof.
 unfold finite; intro n;case n; auto with T1 arith.
Qed.

Lemma nf_omega : nf omega.
Proof.
 unfold omega; auto with T1.
Qed.

Theorem nf_phi0 : forall a, nf a -> nf (phi0 a).
 compute;auto with T1.
Qed.

Lemma nf_tower : forall n, nf (omega_tower n).
 induction n; simpl; auto with T1.
Qed.

Definition nf_rect : forall P : T1 -> Type,
   P zero ->
   (forall n: nat,  P (cons zero n zero)) ->
   (forall a n b n' b', nf (cons a n b) ->
                        P (cons a n b)->
                        nf2 b' (cons a n b) ->
                        nf b' ->
                        P b' ->
                         P (cons (cons a n b) n' b')) ->
   forall a, nf a -> P a.
Proof.
 intros P H0 Hfinite Hcons.
 induction a.
 trivial.
 generalize IHa1;case a1.
 intros IHc0 H.
 rewrite (nf_of_finite H).
 apply Hfinite.
 intros c n0 c0 IHc0 H2; apply Hcons.
 eauto with T1.
 apply IHc0; eauto with T1.
 eapply nf2_intro. eauto.
 nf_inv; eauto.
 apply IHa2.
 nf_inv.
Defined.

Section lt_not_well_founded.

  (* let us build the sequence of terms :
        omega + omega + .... + omega ^ 2   *)
  Let f := (fix f (i:nat): T1 :=
            match i with 0 => (phi0 (F 2))
                       | S i => cons (F 1)  0 (f  i)
            end).

 Lemma f_not_in_normal_form :
  forall i, ~ (nf (f (S i))).
 Proof.
  induction i;  red; simpl.
  inversion 1.
  inversion H3.
  inversion H9.
  inversion H9.
  simpl in IHi.
  inversion 1.
  case (lt_irr H3).
 Qed.

 Lemma  f_decreases : forall i, f (S i) <  f i.
 Proof.
  induction i; compute; auto with T1.
 Qed.

 Theorem lt_not_wf : ~ (well_founded lt).
 Proof.
  red; intro wf.
  case (not_decreasing _ lt).
  auto.

  exists f.
  exact f_decreases.
 Qed.

End lt_not_well_founded.

Theorem zero_le : forall a, zero <= a.
Proof.
 unfold le.
 destruct  a; [left|right];repeat constructor.
Qed.

Theorem le_trans : forall a b c, a <= b -> b <= c -> a <= c.
Proof.
 destruct 1.
 subst b;auto.
 destruct 1.
 subst b;right;auto.
 right;eapply lt_trans;eauto.
Qed.

Theorem le_lt_trans : forall a b c, a <= b -> b < c -> a < c.
Proof.
 destruct 1.
 subst b;auto.
 intros;eapply lt_trans;eauto.
Qed.

Theorem lt_le_trans : forall a b c, a < b -> b <= c -> a < c.
Proof.
 destruct 2.
 subst b;auto.
 eapply lt_trans;eauto.
Qed.

Theorem le_inv : forall a n b a' n' b',
                      cons a n b <= cons a' n' b' ->
                      a < a' \/
                      a = a' /\ (n < n')%nat \/
                      a = a' /\ n = n' /\ b <= b'.
Proof.
 intros a n b a' n' b' H; case H.
 injection 1; right.
 right; subst a; subst n ; subst b; auto with T1.
 intro H0; generalize (lt_inv H0).
 intro H1; case H1; auto.
 intros [(H2,H3) | (H2,(H3,H4))].
 auto.
 right;right;auto with T1.
Qed.

Lemma lt_not_le: forall a b,  a < b -> ~  b <= a.
Proof.
 red; unfold le.
 intros a b H H0; case H0;intro.
 subst b; absurd (lt a a);auto with T1.
 absurd (lt a a); eauto with T1.
 eapply lt_trans;eauto.
Qed.

Lemma lt_inv_le : forall a n b a' n' b',
                     cons a n b < cons a' n' b' ->
                     a <= a'.
Proof.
 intros a n b a' n' b' H.
 case (lt_inv H).
 auto with T1.
 intros [(e,i)|(e,(e',i))].
 subst a; auto with T1.
 subst a; auto with T1.
Qed.

Theorem le_zero_inv : forall a, a <= zero -> a = zero.
Proof.
 destruct 1.
 auto.
 absurd (a < zero);auto with T1.
Qed.

Theorem le_tail : forall a n b b', b <= b' ->
                                   cons a n b <= cons a n b'.
Proof.
 destruct 1.
 subst b; left; auto.
 right; auto with T1.
Qed.

Hint Resolve zero_le le_tail : T1.

(* warning : this is NOT a general property of ALL ordinals *)
(* False when a >= epsilon_0
*)

Lemma head_lt_cons : forall a n b, a < cons a n b.
Proof.
 induction a.
 constructor.
 constructor 2; auto.
Qed.

Definition T1_eq_dec : forall (a b : T1), {a = b}+{a <> b}.
Proof.
 decide equality.
 apply eq_nat_dec.
Defined.

Definition trichotomy_inf : forall a b, {a < b}+{a = b}+{b < a}.
Proof.
 induction a; destruct b; auto with T1.
 case (IHa1 b1);intros s.
 case s;intros.
 auto with T1.
 subst b1; case (lt_eq_lt_dec n n0).
 destruct 1.
 auto with T1.
 subst n;
  case (IHa2 b2); auto with T1.
 destruct 1;[idtac| subst b2];auto with T1.
 right;auto with T1.
 auto with T1.
Defined.

Definition max' a b :=
    if trichotomy_inf a b
    then b else a.
(*

Definition max' a b :=
    match trichotomy_inf a b with
      inleft _ => b
    | _        => a
    end.
*)

Goal forall a b, a < b -> max' a b = b.
 intros a b H; unfold max';
   case (trichotomy_inf a b);auto.
   intro;case (lt_not_gt H);auto.
Qed.

Definition lt_le_dec : forall a b, {a < b}+{b <= a}.
Proof.
 intros a b; case (trichotomy_inf a b).
 destruct 1.
 left;auto.
 right;left; auto.
 right;right; auto.
Defined.

Module  Eps0_sig <: Signature.

Inductive symb0 : Set := nat_0 | nat_S | ord_zero | ord_cons.

Definition symb := symb0.

Lemma eq_symbol_dec : forall f1 f2 : symb, {f1 = f2} + {f1 <> f2}.
Proof.
intros; decide equality.
Qed.

(** The arity of a symbol contains also the information about built-in theories as in CiME *)
Inductive arity_type : Set :=
  | AC : arity_type
  | C : arity_type
  | Free : nat -> arity_type.

Definition arity : symb -> arity_type :=
  fun f => match f with
                  | nat_0 => Free 0
                  | ord_zero => Free 0
                  | nat_S => Free 1
                  | ord_cons => Free 3
                  end.

End Eps0_sig.

(** * Module Type Variables.
 There are almost no assumptions, except a decidable equality. *)
Module Vars <: Variables.

Inductive empty_set : Set := .
Definition var := empty_set.

Lemma eq_variable_dec : forall v1 v2 : var, {v1 = v2} + {v1 <> v2}.
Proof.
intros; decide equality.
Qed.

End Vars.

Module  Eps0_prec <: Precedence.

Definition A : Set := Eps0_sig.symb.
Import Eps0_sig.

Definition prec : relation A :=
   fun f g => match f, g with
                      | nat_0, nat_S => True
                      | nat_0, ord_zero => True
                      | nat_0, ord_cons => True
                      | ord_zero, nat_S => True
                      | ord_zero, ord_cons => True
                      | nat_S, ord_cons => True
                      | _, _ => False
                      end.

Inductive status_type : Set :=
  | Lex : status_type
  | Mul : status_type.

Definition status : A -> status_type := fun f => Lex.

Lemma prec_dec : forall a1 a2 : A, {prec a1 a2} + {~ prec a1 a2}.
Proof.
intros a1 a2; destruct a1; destruct a2;
  ((right; intro; contradiction)||(left;simpl;trivial)).
Qed.

Lemma prec_antisym : forall s, prec s s -> False.
Proof.
intros s; destruct s; simpl; trivial.
Qed.

Lemma prec_transitive : transitive A prec.
Proof.
intros s1 s2 s3; destruct s1; destruct s2; destruct s3; simpl; intros; trivial; contradiction.
Qed.

End Eps0_prec.

Module Eps0_alg <: Term := term.Make (Eps0_sig) (Vars).
Module Eps0_rpo <: RPO := rpo.Make (Eps0_alg) (Eps0_prec).

Import Eps0_alg.
Import Eps0_rpo.
Import Eps0_sig.

Fixpoint nat_2_term (n:nat) : term :=
  match n with 0 => (Term nat_0 nil)
             | S p => Term nat_S ((nat_2_term p)::nil)
  end.

(** * Every (representation of a) natural number is less than
 a non zero ordinal *)

Lemma nat_lt_cons : forall (n:nat) a p  b , rpo (nat_2_term n)
                                     (Term ord_cons (a::p::b::nil)).
 induction n;simpl.
 constructor 2.
 simpl; trivial.
 destruct 1.
 constructor 2.
 simpl; trivial.
 inversion_clear 1.
 subst s';apply IHn.
 case H0.
Qed.

Theorem rpo_trans : forall t t1 t2, rpo t t1 -> rpo t1 t2 -> rpo t t2.
 intros.
 case (rpo_closure t2 t1 t);eauto.
Qed.

Fixpoint T1_2_term (a:T1) : term :=
match a with
 zero => Term ord_zero nil
|cons a n b => Term ord_cons (T1_2_term a :: nat_2_term n ::T1_2_term b::nil)
end.

Fixpoint T1_size (o:T1):nat :=
 match o with zero => 0
            | cons a n b => S (T1_size a + n + T1_size b)%nat
         end.

Lemma T1_size1 : forall a n b, (T1_size zero < T1_size (cons a n b))%nat.
Proof.
 simpl.
 intros.
 auto with arith.
Qed.

Lemma T1_size2 : forall a n b , (T1_size a < T1_size (cons a n b))%nat.
Proof.
 simpl; auto with arith.
Qed.

Lemma T1_size3 : forall a n b , (T1_size b < T1_size (cons a n b))%nat.
Proof.
 simpl; auto with arith.
Qed.

Hint Resolve T1_size2 T1_size3.

(** let us recall subterm properties on T1 *)
Lemma lt_subterm1 : forall a a'  n'  b', a < a' ->
                                         a < cons a' n' b'.
Proof.
 intros.
 apply lt_trans with (cons a n' b');auto with T1.
 apply head_lt_cons.
Qed.

Lemma lt_subterm2 : forall a a' n n' b b', a < a' ->
                                           nf (cons a n  b) ->
                                           nf (cons a' n' b') ->
                                           b < cons a' n' b'.
Proof.
 intros.
 apply le_lt_trans with (cons a n b).
 right.
 apply tail_lt_cons;auto.
 constructor.
 auto.
Qed.

Hint Resolve nat_lt_cons.
Hint Resolve lt_subterm2 lt_subterm1.
Hint Resolve T1_size3 T1_size2 T1_size1.

Lemma nat_2_term_mono : forall n n', (n < n')%nat ->
                                      rpo (nat_2_term n) (nat_2_term n').
Proof.
 induction 1.
 simpl.
 eapply Subterm.
 eleft.
 esplit.
 constructor.
 simpl.
 eapply Subterm.
 eleft.
 esplit.
 constructor.
 auto.
Qed.

Theorem lt_inc_rpo_0 : forall n,
                           forall o' o, (T1_size o + T1_size o' <= n)%nat->
                              o < o' -> nf o -> nf o' ->
                                  rpo (T1_2_term o) (T1_2_term o').
Proof.
 induction n.
 destruct o'.
 inversion 2.
 destruct o.
 simpl.
 inversion 1.
 simpl;inversion 1.
 inversion 2.
 simpl.
 intros; apply Top_gt.
 simpl;trivial.
 inversion 1.
 simpl; intros; apply Top_eq_lex.
 simpl;trivial.
 left.
 apply IHn.
 subst o;subst o'.
 apply  lt_n_Sm_le .
 apply Lt.lt_le_trans with (T1_size (cons a n0 b) + T1_size (cons a' n' b'))%nat.
 simpl;
 auto with arith.
 omega.
 auto.
 auto.
 nf_inv.
 nf_inv.
 simpl;auto.
 inversion_clear 1.
 subst s'.
 change (rpo (T1_2_term a) (T1_2_term (cons a' n' b'))).
 apply IHn;auto.
 subst o;subst o'.
 apply  lt_n_Sm_le .
 apply Lt.lt_le_trans with (T1_size (cons a n0 b) + T1_size (cons a' n' b'))%nat.
 auto with arith.
 auto.
 nf_inv.
 destruct H7 as [|[|H8]].
 subst s'.
 apply nat_lt_cons.
 subst s'.
 change (rpo (T1_2_term b) (T1_2_term (cons a' n' b'))).
 apply IHn;auto.
 subst o;subst o'.
 apply  lt_n_Sm_le .
 apply Lt.lt_le_trans with (T1_size (cons a n0 b) + T1_size (cons a' n' b'))%nat.
 auto with arith.
 auto.
 eauto.
 nf_inv.
 case H8.
 intros.
 simpl;apply Top_eq_lex.
 auto.
 constructor 2.
 constructor 1.
 apply nat_2_term_mono.
 auto.
 auto.
 inversion_clear 1.
 subst s'.
 change (rpo (T1_2_term a) (T1_2_term (cons a n' b'))).
 apply IHn;auto.
 subst o;subst o'.
 apply  lt_n_Sm_le .
 apply Lt.lt_le_trans with (T1_size (cons a n0 b) + T1_size (cons a n' b'))%nat.
 auto with arith.
 auto.
 apply head_lt_cons.
 nf_inv.
 destruct H7 as [|[|H8]].
 subst s'.
 apply nat_lt_cons.
 subst s'.
 change (rpo (T1_2_term b) (T1_2_term (cons a n' b'))).
 apply IHn;auto.
 subst o;subst o'.
 apply  lt_n_Sm_le .
 apply Lt.lt_le_trans with (T1_size (cons a n0 b) + T1_size (cons a n' b'))%nat.
 auto with arith.
 auto.
 apply lt_le_trans with (cons a 0 zero).
 inversion H4.
 auto with T1.
 auto with T1.
 case n'.
 apply le_tail;auto with T1.
 auto with T1 arith.
 nf_inv.
 case H8.
 simpl.
 intros;apply Top_eq_lex.
 auto.
 right.
 right.
 left.
 apply IHn.
 apply  lt_n_Sm_le .
 apply Lt.lt_le_trans with (T1_size (cons a n0 b) + T1_size (cons a n0 b'))%nat.
 apply plus_lt_compat.
 auto.
 auto.
 subst o;subst o';auto.
 auto.
 nf_inv.
 nf_inv.
 auto.
 inversion_clear 1.
 subst s'.
 eapply Subterm.
 2:eleft.
 left;auto.
 destruct H7 as [|[|H8]].
 subst s'.
 apply nat_lt_cons.
 subst s'.
 change (rpo (T1_2_term b) (T1_2_term (cons a n0 b'))).
 apply IHn.
 apply  lt_n_Sm_le .
 apply Lt.lt_le_trans with (T1_size (cons a n0 b) + T1_size (cons a n0 b'))%nat.
 auto with arith.
 subst o;subst o'.
 auto.
 apply lt_le_trans with (cons a 0 zero).
 inversion H4.
 auto with T1.
 auto with T1.
 case n0.
 apply le_tail;auto with T1.
 auto with T1 arith.
 nf_inv.
 auto.
 case H8.
Qed.

Remark R1 : Acc P.prec nat_0.
 split.
 destruct y; try contradiction.
Qed.

Hint Resolve R1.

Remark R2 : Acc P.prec ord_zero.
 split.
 destruct y; try contradiction; auto.
Qed.

Hint Resolve R2.

Remark R3 : Acc P.prec nat_S.
 split.
 destruct y; try contradiction;auto.
Qed.

Hint Resolve R3.

Remark R4 : Acc P.prec ord_cons.
 split.
 destruct y; try contradiction;auto.
Qed.

Hint Resolve R4.

Theorem well_founded_rpo : well_founded rpo.
Proof.
 apply wf_rpo.
 red.
 destruct a;auto.
Qed.

Section  well_founded.

  Let R := restrict T1 nf lt.

  Hint Unfold restrict R.

 Lemma R_inc_rpo : forall o o', R o o' -> rpo (T1_2_term o) (T1_2_term o').
 Proof.
  intros o o' (H,(H1,H2)).
  eapply lt_inc_rpo_0;auto.
 Qed.

 Lemma nf_Wf : well_founded_P _ nf lt.
Proof.
 unfold well_founded_P.
 intros.
 unfold restrict.
 generalize (Acc_inverse_image _ _ rpo T1_2_term a (well_founded_rpo (T1_2_term a))).
  intro.
 eapply  Acc_incl  with  (fun x y : T1 => rpo (T1_2_term x) (T1_2_term y)).
 red.
 apply R_inc_rpo.
 auto.
Qed.

End well_founded.

Definition transfinite_induction :
 forall (P:T1 -> Type),
   (forall x:T1, nf x ->
                   (forall y:T1, nf y ->  y < x -> P y) -> P x) ->
    forall a, nf a -> P a.
Proof.
 intros; eapply P_well_founded_induction_type; eauto.
 eexact nf_Wf;auto.
Defined.

Definition transfinite_induction_Q :
  forall (P : T1 -> Type) (Q : T1 -> Prop),
      (forall x:T1, Q x -> nf x ->
           (forall y:T1, Q y -> nf y ->  y < x -> P y) -> P x) ->
   forall a, nf a -> Q a -> P a.
Proof.
 intros.
 eapply P_well_founded_induction_type with (R:=lt)(P:=fun a => nf a /\ Q a).
 3:split;auto.
 2:destruct 1; intros; eapply X; eauto.
 unfold well_founded_P.
 intros.
 apply Acc_incl with (restrict _ nf lt).
 unfold inclusion; intros.
 unfold restrict.
 unfold restrict in H2.
 tauto.
 apply nf_Wf.
 case H1;auto.
Defined.

(* Ordinal arithmetics *)

Fixpoint succ (c:T1) : T1 :=
  match c with zero => finite 1
             | cons zero n _ => cons zero (S n) zero
             | cons a n b => cons a n (succ b)
  end.

Fixpoint pred (c:T1) : option T1 :=
  match c with zero => None
             | cons zero 0 _ => Some zero
             | cons zero (S n) _ => Some (cons zero n zero)
             | cons a n b =>
                  match (pred b) with None => None
                                    | Some c => Some (cons a n c)
                  end
  end.

Fixpoint plus (c1 c2 : T1) {struct c1}:T1 :=
  match c1,c2 with
 |  zero, y  => y
 |  cons zero n _, zero => cons zero n zero
 |  x, zero  => x
 |  cons zero n _, cons zero n' _ => cons zero (S (n+n')) zero
 |  cons a n b, cons a' n' b' =>
      (match compare a a' with
        | Datatypes.Lt => cons a' n' b'
        | Gt => (cons a n (plus b (cons a' n' b')))
        | Datatypes.Eq  => (cons a (S(n+n')) b')
       end)
 end
 where "a + b" := (plus a b) : cantor_scope.

Fixpoint minus (c1 c2 : T1) {struct c1}:T1 :=
  match c1,c2 with
 |  zero, y  => zero
 |  cons zero n _, cons zero n' _ =>
                  if (le_lt_dec n n')
                  then zero
                  else  cons zero (Peano.pred (n-n')) zero
 |  cons zero n _, zero =>  cons zero n zero
 |  cons zero n _, y =>  zero
 |  cons a n b, zero =>  cons a n b
 |  cons a n b, cons a' n' b' =>
      (match compare a a' with
            | Datatypes.Lt => zero
            | Gt => cons a n b
            |  Datatypes.Eq  => (match (lt_eq_lt_dec n n') with
                            | inleft (left _) => zero
                            | inright _ => (cons a (Peano.pred (n-n')) b')
                            | _ =>  b - b'
                      end)

       end)
 end
 where  "c1 - c2" := (minus c1 c2):cantor_scope.

Lemma omega_minus_one : omega - F 1 = omega.
Proof.
 reflexivity.
Qed.

Fixpoint mult (c1 c2 : T1) {struct c2}:T1 :=
  match c1,c2 with
 |  zero, y  => zero
 |  x, zero => zero
 |  cons zero n _, cons zero n' _ =>
                 cons zero (Peano.pred((S n) * (S n'))) zero
 |  cons a n b, cons zero n' b' =>
                 cons a (Peano.pred((S n) * (S n'))) b
 |  cons a n b, cons a' n' b' =>
     cons (a + a') n' ((cons a n b) * b')
 end
where  "c1 * c2" := (mult c1 c2) : cantor_scope.

Fixpoint exp_F (a:T1)(n:nat){struct n}:T1 :=
 match n with
 | 0 => F 1
 | S p => a * (exp_F a p)
 end.

Fixpoint exp  (a b : T1) {struct b}:T1 :=
  match a,b with
 |  x, zero => cons zero 0 zero
 | cons zero 0 _ , _ => cons zero 0 zero
 | zero, y            => zero
 | x , cons zero n' _ =>  exp_F x (S n')
 | cons zero n _, cons  (cons zero 0 zero) n'  b' =>
        ((cons (cons zero n' zero) 0 zero) *
                ((cons zero n zero) ^  b'))
 | cons zero n _, cons  a' n' b' =>
            (omega_term
                    (omega_term (a' - (F 1)) n')
                    0) *
                 ((cons zero n zero) ^ b')
 | cons a  n b, cons  a' n' b' =>
    ((omega_term   (a * (cons a' n' zero))
                            0) *
            ((cons a n b) ^ b'))
end
where "a ^ b" := (exp a b) : cantor_scope.

(* properties of the data structure *)
(************************************)

(* A tactic for decomposing a non zero ordinal *)
(* use : H : lt zero ?c ; a n b : names to give to the constituents of
   c *)

Definition get_decomposition : forall c, lt zero c ->
                           {a:T1 & {n:nat & {b:T1 | c = cons a n b}}}.
 intro c; case c.
 intro H; elimtype False; inversion H.
 intros c0 n c1; exists c0;exists n;exists c1;auto.
Defined.

Ltac decomp_exhib H a n b e:=
 let Ha := fresh in
 let Hn := fresh in
 let Hb := fresh in
  match type of H
  with lt zero ?c =>
    case (get_decomposition  H);
     intros a Ha;
     case Ha;intros n Hn; case Hn; intros b e;
     clear Ha Hn
  end.

(* characteristic of epsilon0 *)

Lemma lt_a_phi0_a : forall a, a < phi0 a.
Proof.
 induction a;simpl.
 compute; constructor.
 unfold phi0.
 constructor 2.
 assert (le (cons a1 0 zero) (cons a1 n a2)).
 case n.
 case a2.
 left.
 trivial.
 right;constructor 4;constructor.
 right;constructor 3.
 auto with arith.
 case H.
 injection 1.
 intros; subst a2;subst n;auto.
 intro; eapply lt_trans; eauto.
Qed.

Lemma phi0_lt : forall a b, a < b -> phi0 a < phi0 b.
Proof.
 unfold phi0;intros c c' H.
 constructor 2;trivial.
Qed.

Lemma phi0_ltR : forall a b, phi0 a < phi0 b ->  a < b.
Proof.
 unfold phi0;intros c c' H.
 case (lt_inv H).
 trivial.
 intros [(_,i)|(_,(_,i))]; inversion i.
Qed.

(* Unfortunately, lt is NOT well founded *)

(* compare reflects trichotomy_inf *)

Lemma compare_ok_1:
   forall a a', (compare a a' =  Datatypes.Lt <-> a < a') /\
                (compare a a' =  Datatypes.Eq <-> a = a') .
Proof.
 induction a;simpl.
 destruct a';simpl.
 split;split.
 discriminate 1.
 inversion 1.
 auto.
 auto.
 split;split.
 auto with T1.
 auto.
 discriminate 1.
 discriminate 1.
 destruct a'; simpl.
 split; split.
 discriminate 1.
 inversion 1.
 inversion 1.
 discriminate 1.
 (* use Yves's caseEq *)
 caseEq (compare a1 a'1).
 intros.
 case (lt_eq_lt_dec n n0).
 destruct s.
 repeat split.
 replace a1 with a'1.
 constructor 3;auto.
 case (IHa1 a'1).
 intros.
 case H1;auto.
 intros;symmetry.
 auto.
 discriminate 1.
 injection 1.
 intros;  subst n0.
 absurd (n<n)%nat;auto with arith.
 split.
 repeat split.
 intro.
 subst n0.
 replace a1 with a'1.
 constructor 4.
 case (IHa2 a'2);intros.
 auto.
 case H1;auto.
 elim (IHa1 a'1);intros.
 case H2;auto.
 symmetry;auto.
 subst n0.
 replace a1 with a'1.
 intro.
 assert (lt a2 a'2).
 eapply lt_inv_b;eauto.
 case (IHa2 a'2);intros.
 case H2;auto.
 case (IHa1 a'1);intros.
 case H1;auto.
 intros;symmetry;auto.
 replace a1 with a'1.
 subst n0.
 repeat split.
 intros.
 case (IHa2 a'2); intros.
 replace a2 with a'2.
 auto.
 case H2;intros.
 symmetry;auto.
 injection 1.
 intro;subst a'2.
 case (IHa2 a2).
 intros.
 case H2;auto.
 case (IHa1 a'1);intros.
 case H1;intros;symmetry;auto.
 intro;repeat split.
 discriminate 1.
 intro H0.
 absurd (cons a1 n a2 < cons a'1 n0 a'2);auto.
 apply lt_not_gt.
 replace a1 with a'1.
 constructor 3;auto.
 elim (IHa1 a'1);intros.
 case H2;auto.
 symmetry;auto.
 discriminate 1.
 injection 1.
 intros; subst n0; absurd (n<n)%nat;auto with arith.
 intros; repeat split.
 constructor 2.
 case (IHa1 a'1);intros.
 case H1;auto.
 discriminate 1.
 injection 1;intros.
 subst a'1;absurd (lt a1 a1).
 apply lt_irr.
 case (IHa1 a1);intros.
 case H3;auto.
 intro;repeat split.
 discriminate 1.
 inversion 1.
 case (IHa1 a'1);intros.
 case H8;intros.
 rewrite <- (H11 H2).
 symmetry;auto.
 absurd (cons a'1 n0 a'2 < cons a1 n a2).
 apply lt_not_gt;auto.
 case (IHa1 a'1);intros.
 case H9;intros.
 rewrite H in H11.
 generalize (H11 H5).
 discriminate 1.
 case (IHa1 a'1);intros.
 case H9;intros.
 rewrite H in H11.
 generalize (H11 H5).
 discriminate 1.
 discriminate 1.
 injection 1;intros.
 subst a'1; case (IHa1 a1);intros.
 case H4;intros.
 rewrite H in H6.
 auto.
Qed.

Lemma compare_reflect : forall a a', match compare a a' with
                                    |    Datatypes.Lt => a < a'
                                    |    Datatypes.Eq => a = a'
                                    |    Datatypes.Gt => a' < a
                                    end.
Proof.
 intros c c';  case (compare_ok_1 c c');intros H0 H1; case H0; case H1;
 intros;
   caseEq (compare c c'); auto.
 intro comp; case (trichotomy_inf c c').
 intro x; case x; intro H'.
 rewrite (H4 H') in comp;discriminate comp.
 rewrite (H2 H') in comp;discriminate comp.
 trivial.
Qed.

(* the following theorems were proved in another time and
 place ; It seems that some cleaning is necessary *)

Lemma compare_rw1 : forall a b, a < b -> compare a b =  Datatypes.Lt.
Proof.
 intros c1 c2; generalize (compare_reflect c1 c2).
 case (compare c1 c2);auto.
 intros e H;subst c2;case (lt_irr H).
 intros H1 H2;case (lt_not_gt H2);auto.
Qed.

Lemma compare_rw2 : forall a, compare a a =  Datatypes.Eq.
Proof.
 intro c; generalize (compare_reflect c c).
 case (compare c c);auto;
 intro H;case (lt_irr H);auto.
Qed.

Lemma compare_rw3 : forall a b, b < a  -> compare a b = Gt.
Proof.
 intros c1 c2; generalize (compare_reflect c1 c2).
 case (compare c1 c2);auto.
 intros e H;subst c2;case (lt_irr H).
 intros H1 H2;case (lt_not_gt H2);auto.
Qed.

Theorem compare_reflectR : forall a b : T1,
  (match trichotomy_inf a b with
    inleft  (left _) =>  Datatypes.Lt
  | inleft  (right _) =>  Datatypes.Eq
  | inright _ => Gt
  end)
  = compare a b.
Proof.
 intros c1 c2;case (trichotomy_inf c1 c2).
 destruct s; auto; try discriminate.
 rewrite compare_rw1;auto.
 subst c1;rewrite compare_rw2;auto.
 intro;  rewrite compare_rw3;auto.
Qed.

(* on max *)

Lemma max_le_1 : forall a b, a <= max a b.
Proof.
 unfold max.
 intros.
 rewrite <- compare_reflectR.
 case (trichotomy_inf a b);auto with T1.
 destruct s;auto with T1.
Qed.

Lemma max_comm : forall a b, max a b = max b a.
Proof.
 unfold max.
 intros a b; repeat rewrite <- compare_reflectR.
 case ( trichotomy_inf a b); case (trichotomy_inf b a);auto with T1.
 destruct s; destruct s; auto with T1.
 case (lt_not_gt l);auto.
 destruct s;auto with T1.
 destruct s;auto with T1.
 intros H H0; case (lt_not_gt H);auto.
Qed.

Lemma lt_intro : forall a b, compare a b =  Datatypes.Lt -> a < b.
Proof.
   intros a b; rewrite <- compare_reflectR.
   case (trichotomy_inf a b);auto with T1.
    destruct s; auto.
    discriminate 1.
  discriminate 2.
Qed.

Lemma max_dec : forall a b, {max a b = a}+{max a b = b}.
Proof.
 unfold max;  intros a b; case (trichotomy_inf a b);auto.
 destruct 1.
 repeat rewrite compare_rw1;auto.
 subst b;repeat rewrite compare_rw2;auto.
 intro; repeat rewrite compare_rw3;auto.
Qed.

Lemma max_nf : forall a b, nf a -> nf b -> nf (max a b).
Proof.
 intros c c'; case (max_dec c c');
 intro H;rewrite H;auto.
Qed.

Lemma max_assoc : forall a b c, max (max a b) c =
                                max a (max b c).
Proof.
 intros c1 c2 c3.
 unfold max.
 case (trichotomy_inf c1 c2).
 destruct 1.
 repeat (rewrite (compare_rw1 l)).

 case (trichotomy_inf c2 c3).
 destruct 1.
 repeat (rewrite (compare_rw1 l0)).
 assert (lt c1 c3).
 eapply lt_trans;eauto.
 rewrite (compare_rw1 H);auto.
 subst c3.
 repeat rewrite compare_rw2.
 rewrite compare_rw1;auto.
 intro c'.
 repeat (rewrite (compare_rw3 c')).
 rewrite compare_rw1;auto.
 subst c2;
 repeat (rewrite (compare_rw2));auto.
 case (trichotomy_inf c1 c3).
 destruct 1.
 repeat (rewrite (compare_rw1 l));auto.
 subst c3;repeat rewrite compare_rw2;auto.
 intro c;repeat (rewrite (compare_rw3 c));auto.
 repeat rewrite compare_rw2;auto.
 intro c; repeat rewrite (compare_rw3 c);auto.
 case (trichotomy_inf c1 c3).
 destruct 1.
 rewrite (compare_rw1 l);auto.
 assert (lt c2 c3).
 eapply lt_trans;eauto.
 repeat rewrite (compare_rw1 H);auto.
 rewrite (compare_rw1 l);auto.
 subst c3;rewrite (compare_rw2);auto.
 repeat rewrite (compare_rw1 c);auto.
 rewrite compare_rw2;auto.
 intro.
 rewrite (compare_rw3 l).
 case (trichotomy_inf c2 c3).
 destruct 1.
 repeat rewrite (compare_rw1 l0);auto.
 repeat rewrite (compare_rw3 l);auto.
 subst c3;repeat rewrite (compare_rw2);auto.
 repeat rewrite (compare_rw3 l);auto.
 intro c';repeat rewrite (compare_rw3 c');auto.
 repeat rewrite (compare_rw3 c);auto.
Qed.

(* Properties of successor *)

Lemma succ_nf2 : forall c a n b, nf2 c (cons a n b) ->
                               nf2 (succ c) (cons a n b).
Proof.
 induction c.
 simpl.
 repeat constructor.
 simpl.
 case c1.
 repeat constructor.
 intros t n0 t0 a n1 b H.
 inversion_clear H.
 constructor; auto.
Qed.

Lemma succ_nf : forall a, nf a -> nf (succ a).
Proof.
 induction a.
 simpl.
 repeat constructor; auto  with arith.
 simpl.
 generalize IHa1 ; case a1.
 simpl;repeat constructor; auto.
 intros c n0 c0 H H0.
 apply nf_intro.
 nf_inv.
 apply IHa2; nf_inv.
 apply succ_nf2.
 eapply nf2_intro; eauto.
Qed.

(* properties of lt and le *)

Lemma lt_succ :  forall a, a < succ a.
Proof.
  intro c; elim c; simpl; auto with T1.
  intro c0; case  c0; simpl; auto with T1.
Qed.

Lemma phi0_log : forall a, a < phi0 (succ (log a)).
Proof.
 destruct a.
 simpl.
 compute.
 constructor.
 simpl.
 unfold phi0.
 constructor 2.
 apply lt_succ.
Qed.

(* properties of addition *)

Lemma plus_zero : forall a, zero + a  = a.
Proof.
 simpl; intro a; case a; auto.
Qed.

Lemma plus_a_zero : forall a, nf a -> a + zero = a.
Proof.
 intro c; case c;simpl.
 trivial.
 intro c0;case c0;simpl;auto.
 intros n c1 H1; rewrite (nf_of_finite H1); auto with T1.
Qed.

Lemma plus_fin_omega : forall n ,F n + omega = omega.
Proof.
 destruct n;simpl;auto.
Qed.

Lemma plus_not_comm : {a:T1 & {b :T1 |
                          nf a /\ nf a /\ a + b  <> b + a}}.
Proof.
 exists (finite 1); exists omega.
 split.
 simpl;repeat constructor.
 split.
 compute;repeat constructor.
 compute.
 discriminate 1.
Defined.

Lemma succ_is_plus_one: forall a, nf a -> succ a = a + F 1.
Proof.
 unfold finite.
 intro c; elim c.
 compute; trivial.
 intro c0;case c0.
 simpl.
 intros H n c1 H0 H1.
 rewrite <- plus_n_O; trivial.
 intros c1 n c2 H n0 c3 H0 H1.
 simpl.
 rewrite H0; [trivial | nf_inv].
Qed.

(* plus and lt *)

Lemma plus_cons_cons_rw1 : forall a n b a' n' b',
     a < a' ->
     cons a n b + cons a' n' b' = cons a' n' b'.
Proof.
 simpl.
 destruct a.
 destruct a'.
 inversion 1.
 intros; rewrite compare_rw1; auto with T1.
 destruct a'.
 inversion 1.
 intros n' b' H; rewrite (compare_rw1);auto.
Qed.

Lemma plus_cons_cons_rw2 : forall a n b n' b',
      nf (cons a n b) ->
      nf (cons a n' b') ->
      plus (cons a n b) (cons a n' b')=
      cons a (S (n + n') ) b'.
Proof.
 simpl.
 destruct a.
 intros.
 rewrite (nf_of_finite H0).
 auto.
 rewrite (compare_rw2).
 auto.
Qed.

Lemma plus_cons_cons_rw3 : forall a n b a' n' b',
      a' < a ->
      nf (cons a n b) ->
      nf (cons a' n' b') ->
      cons a n b + cons a' n' b'=
      cons a n (b + (cons a' n' b')).
Proof.
simpl.
destruct a.
inversion 1.

destruct a'.
rewrite compare_rw3.
auto.
constructor.
intros;
rewrite compare_rw3.
auto.
auto.
Qed.

Lemma ap_plus : forall a, ap a ->
    forall b c, nf b -> nf c -> b < a -> c < a -> b + c <  a.
Proof.
 destruct 1.
 intro b; elim b.
 intro c; elim c;intros.
 simpl; auto with T1.
 simpl.
 auto.
 intros c H0.
 intros.
 generalize c0 H2 H4.
 destruct c1.
 rewrite (plus_a_zero).
 auto.
 auto.
 intros.
 case (trichotomy_inf c c1_1).
 destruct 1.
 rewrite (plus_cons_cons_rw1 n t n0 c1_2 l).
 auto.
 subst c1_1.
 (* *)
 rewrite (plus_cons_cons_rw2 H1 H5).
 constructor 2.

 inversion H3;auto.
 inversion H8. (* make automatic tactics for that ! *)
 inversion H8.
 intro H7.
 rewrite (plus_cons_cons_rw3).
 constructor 2.
 inversion_clear H3;auto.
 inversion H8.
 inversion H8. (* argh *)
 auto.
 auto.
 auto.
Qed.

Lemma ap_plusR : forall c, nf c -> c <> zero ->
                  (forall a b, nf a -> nf b ->  a < c ->
                          b < c -> a + b < c)  ->
                  ap c.
 destruct c.
 intros; absurd (zero = zero); auto.
 case c2.
 case n.
 constructor.
 intros.
 generalize (H1 (cons c1 0 zero) (cons c1 n0 zero)).
 clear H1;intros.
 assert (nf (cons c1 0 zero)).
 eapply nf_coeff_irrelevance;eauto.
 assert (nf (cons c1 n0 zero)).
 eapply nf_coeff_irrelevance;eauto.
 assert  (lt (cons c1 0 zero) (cons c1 (S n0) zero)).
 constructor 3;auto with arith.
  assert (lt (cons c1 n0 zero) (cons c1 (S n0) zero) ).
 constructor 3;auto with arith.
 generalize (H1 H2 H3 H4 H5).
 intro.
 rewrite plus_cons_cons_rw2 in H6.
 simpl in H6.
 case (lt_irr H6).
 auto.
 auto.
 intros.
 assert (nf (cons c1 n zero)).
 constructor.
 nf_inv.
 assert (nf (cons t n0 t0)).
 nf_inv.
 assert (cons c1 n zero < cons c1 n (cons t n0 t0)).
 constructor 4;auto with T1.
 assert (lt (cons t n0 t0)   (cons c1 n (cons t n0 t0))).
 constructor 2.
 inversion H;auto.
 generalize (H1 _ _ H2 H3 H4 H5).
 clear H1 H4 H5;intro.
 rewrite plus_cons_cons_rw3 in H1.
 simpl in H1.
 case (lt_irr H1).
 inversion H;auto.
 auto.
 auto.
Qed.

Lemma plus_nf0 : forall a, nf a -> forall b c, b < phi0 a ->
                                               c < phi0 a ->
                                               nf b -> nf c ->
                                               nf (b + c).
Proof.
 intros a Ha ; pattern a.
 apply transfinite_induction.
 2:assumption.
 intros x Cx Hx.
 destruct b; destruct c.
 simpl;constructor.
 simpl;auto.
 intros;rewrite plus_a_zero; auto.
 intros.
 case (trichotomy_inf b1 c1).
 destruct 1.
 rewrite plus_cons_cons_rw1.
 auto.
 auto.
 subst c1.

 rewrite plus_cons_cons_rw2.
 eapply nf_coeff_irrelevance;eauto.
 auto.
 auto.
 intro; rewrite plus_cons_cons_rw3;auto.

 apply nf_intro.
 nf_inv.
 eapply Hx with b1.
 nf_inv.
 inversion_clear H; auto.
 inversion H3.
 inversion H3.
 inversion H1.
 compute;auto with T1.
(* debile *)
 unfold phi0.
 constructor 2;auto.

  unfold phi0.
 constructor 2;auto.
 nf_inv.
 auto.
 apply nf2_phi0R.
 apply ap_plus.
 unfold phi0;constructor.
 nf_inv.
 auto.
 apply nf2_phi0.
 eapply nf2_intro.
 eauto.
 unfold phi0; constructor 2; auto.
Qed.

Lemma plus_nf : forall a,  nf a -> forall b, nf b -> nf (a + b).
Proof.
 intros.
 case (trichotomy_inf a b).
 destruct 1.
 apply plus_nf0 with b; auto.
 apply lt_trans with b; auto.
 apply lt_a_phi0_a.
 apply lt_a_phi0_a.
 subst b.
  apply plus_nf0 with a; auto.
 apply lt_a_phi0_a.
 apply lt_a_phi0_a.
 intro;  apply plus_nf0 with a; auto.
  apply lt_a_phi0_a.
 apply lt_trans with a.
 auto.
  apply lt_a_phi0_a.
Qed.

Lemma plus_to_cons:  forall a n b,
   nf (cons a n b) -> omega_term a n + b =
                      cons  a n b.
Proof.
simpl.
 destruct a.
 intros n b H.
 rewrite (nf_of_finite H); auto.
 destruct b.
 auto.
 inversion_clear 1.
 case (trichotomy_inf (cons a1 n a2) b1).
 destruct 1.
 absurd (lt b1 b1);eauto with T1.
 eapply lt_trans;eauto.
 subst b1.
 case (lt_irr H0).
 intro; rewrite compare_rw3; auto.
Qed.

Lemma plus_is_zero : forall a b, nf a -> nf b ->
                               a + b  = zero -> a = zero /\
                                                b = zero.
Proof.
 destruct a;destruct b.
 compute.
 auto.
 simpl.
 discriminate 3.
 intro;rewrite plus_a_zero.
 discriminate 2.
 auto.
 simpl.
 case a1;case b1.
 discriminate 3.
 intros c n1 c0 H H0; rewrite compare_rw1.
 discriminate 1.
 constructor.
 intros c n1 c0 H H0; rewrite compare_rw3.
 discriminate 1.
 constructor.
 intros c n1 c0 c3 n2 c4 H H0;
    case (compare  (cons c3 n2 c4) (cons c n1 c0));discriminate 1.
Qed.

Lemma lt_succ_succ : forall a b,
                    a < b -> nf a -> nf b ->
                    succ a < succ b.
Proof.
    induction 1.
    simpl.
    case a.
    constructor 3;auto with arith.
    constructor 2.
    constructor.
    generalize H; simpl.
     case a.
     case a'.
     inversion 1.
     constructor 2.
     constructor 1.
     case a'.
    inversion 1.
    constructor 2;auto.
   simpl.
  case a.
 constructor 3;auto with arith.
 constructor 3;auto.
 simpl.
 case a.
 intros.
 assert (b'=zero).
 inversion H1.
 auto.
 inversion H5.
 subst b';inversion H.
 constructor 4.
 apply IHlt; nf_inv.
Qed.

Lemma lt_phi0_phi0 : forall a b, a < b -> phi0 a < phi0 b.
Proof.
 unfold phi0.
 constructor 2.
 auto.
Qed.

Lemma le_phi0_phi0 : forall a b, a <= b  -> phi0 a <= phi0 b.
Proof.
 destruct 1.
 subst b;left;auto.
 right;unfold phi0;constructor 2.
 auto.
Qed.

Lemma le_succ_succ : forall a b, nf a -> nf b ->
   a <= b -> succ a <= succ b.
Proof.
 destruct 3.
 subst a;left;auto.
 right.
 apply lt_succ_succ;auto.
Qed.

Lemma lt_succ_le_R : forall a,  nf a -> forall b, nf b ->
                      succ a <= b ->  a < b .
 intros c Hc; elim Hc using nf_rect.
 compute.
 intros.
 case H0;intros.
 subst b;auto with T1.
 eapply lt_trans.
 2:eexact H1.
 auto with T1.
 intros.
 inversion_clear H0.

 subst b; simpl; auto with T1.
 simpl in H1.
 eapply lt_trans.
 2:eauto.
 auto with T1.
 intros.
 simpl in H5.
 case H5.
 intro; subst b0.
 constructor 4.
 apply lt_succ;auto.
 intro.
 eapply lt_trans.
 2:eauto.
 constructor 4.
 apply lt_succ;auto.
Qed.

Lemma lt_succ_le_2 : forall a,  nf a -> forall b, nf b ->
                      a < succ b ->  a <= b.
 intros c Hc; elim Hc using nf_rect.
 intros;apply zero_le.
 intros.
 generalize H0; case b;simpl.
 intros.
 generalize (lt_inv_nb  H1).
 destruct 1.
 inversion H2.
 case H2;intros.
 inversion H4.
 destruct t.

 inversion 1.
 inversion H3.
 assert (n = n0 \/ (n < n0)%nat).
 omega.
 destruct H8.
 rewrite H8.
 case t.
 left.
 auto.
 right;constructor 4.
 auto with T1.
 right;constructor 3;auto.
 inversion H3.
 right;constructor 2;auto with T1.
 (* ici *)
 destruct b0.
 simpl.
 inversion 2.
 inversion H7.
 simpl.
 case b0_1;simpl.
 inversion 2.
 inversion H7.
 intros.
 inversion_clear H5.
 right;constructor 2;auto.
 right;constructor 3;auto.
 case (H3 b0_2 (nf_inv2 H4) H6).
 intro; subst b';left;auto.
 right;constructor 4;auto.
Qed.

Lemma lt_succ_le : forall a,  nf a -> forall b, nf b ->
                     a < b -> succ a <=  b.
 induction a.
 intros H0 c'; case c'.
 inversion 2.
 destruct t.
 destruct n.

 intros.
 inversion_clear H.
 simpl.
 left;auto.
 inversion H2.
 simpl;case n.
 right;constructor 3;auto with arith.
 right; constructor 3;auto with arith.
 simpl;right;constructor 2; auto with T1.
 inversion 3.
 simpl;constructor 2;auto with T1.
 generalize H6;case a1.
 constructor 2;auto with T1.
 constructor 2.
 auto.
 simpl.
 case a1.
 assert (S n = n' \/ (S n < n')%nat).
 omega.
 case H7.
 intro; subst n'.
 case b'.
 left;auto.
 right;constructor 4;auto with T1.
 right;constructor 3;auto.
 intros.
 right;constructor 3;auto.
 subst b;generalize H0;case a1.
 intro.
 assert (b'=zero).
 inversion_clear H3.
 auto.
 inversion H7.
 subst b'; inversion H6.
 simpl.
 intros.
 case (IHa2 (nf_inv2 H) b').
 eapply nf_inv2;eauto.
 auto.
 destruct 1;left;auto.
 intro;apply le_tail.
 right;auto.
Qed.

(* About minus *)

Lemma minus_lt : forall a b, a < b -> a - b = zero.
 induction 1;simpl.
 auto.
 generalize H;case a.
 case a';simpl;auto.
 intro H0;case (lt_irr H0).
 intros.
 rewrite (compare_rw1  H0).
 auto.
 case a.
 case (le_lt_dec n n').
 auto.
 intro H0; absurd (n < n)%nat;auto with arith.
 eauto with arith.
 intros;rewrite (compare_rw2).
 case (lt_eq_lt_dec n n').
 destruct s.
 auto.
 subst n';absurd (n < n)%nat;auto with arith.
 intro; absurd (n<n)%nat;eauto with arith.
 case a.
 case (le_lt_dec n n).
 auto.
 intro; absurd (n>n);auto with arith.
 intros; rewrite (compare_rw2).
 case (lt_eq_lt_dec n n).
 destruct s.
 auto.
 auto.
 intro; absurd (n < n)%nat;auto with arith.
Qed.

Lemma minus_a_a : forall a, a - a = zero.
Proof.
 induction a;simpl;auto.
 case a1.
 case (le_lt_dec n n).
 auto.
 intros; absurd (n < n)%nat; auto with arith.
 case (lt_eq_lt_dec n n ).
 destruct s.
 absurd (n < n)%nat;auto with arith.
 intros;rewrite compare_rw2.
 rewrite IHa2;auto.
 intro; absurd (n<n)%nat;auto with arith.
Qed.

Lemma minus_le : forall a b, a <= b -> a - b = zero.
Proof.
 destruct 1.
 subst b; apply minus_a_a.
 apply minus_lt;auto.
Qed.

Lemma mult_fin_omega : forall n,
                          (F (S n)) * omega = omega.
Proof.
 simpl.
 unfold omega;auto.
Qed.

Lemma phi0_plus_mult : forall a b, nf a -> nf b ->
                       phi0 (a + b) = phi0 a * phi0 b.
Proof.
 simpl.
 intro a; case a.
 intro b; case b;simpl.
 compute;trivial.
 compute; trivial.
 intros until b;case b;simpl.
 case t;simpl;auto.
 intro H; rewrite (nf_of_finite H).
 compute;trivial.
 case t;simpl.
 compute;auto.
 unfold phi0;auto.
Qed.

(** operations on T1 extend operations on nat *)

Lemma succ_compat : forall n:nat, succ (F n) = F (S n).
Proof.
 destruct n;  compute ; trivial.
Qed.

Lemma plus_compat: forall n p, F n + F p = F (n + p)%nat.
Proof.
 induction  n; destruct p; simpl ; auto.
 rewrite <- (plus_n_O n);auto.
 rewrite plus_n_Sm;auto.
Qed.

Lemma mult_compat : forall n p,  (F n) * (F p) =
                                  F (n * p)%nat.
Proof.
 induction n; destruct p; simpl; auto.
 rewrite (mult_0_r n).
 (*  pb of theorem name : mult_0_r versus mult_n_O. *)
 compute; trivial.
Qed.

Lemma exp_F_compat :
 forall p n, exp_F (F n) p =
             F (n ^ p)%nat.
Proof.
 induction p;simpl.
 trivial.
 intro n.
 rewrite (IHp n).
 rewrite mult_compat; trivial.
Qed.

(* the following proof is too? long *)

Lemma exp_compat : forall p n, (F n) ^ (F p) =
                                    F (n ^  p)%nat.
Proof.
 induction p.
 destruct n;simpl.
 auto.
 destruct n;auto.
 destruct n;simpl.
 auto.
 case n.
 simpl.
 rewrite power_of_1.
 rewrite <- plus_n_O;auto.

 simpl.
 intros.
 replace (cons zero (S n0) zero) with (finite (S (S n0))).
 2:simpl;auto.
 rewrite exp_F_compat.
 rewrite mult_compat.
 assert ( (S (S n0) * S (S n0) ^ p) =
    (S (S n0) ^ p + (S (S n0) ^ p + n0 * S (S n0) ^ p)))%nat.
 ring.
 rewrite H;trivial.
Qed.

Lemma mult_0_a : forall a, zero * a  = zero.
Proof.
 induction a;simpl;auto.
Qed.

Lemma mult_a_0 : forall a, a * zero = zero.
Proof.
 simple induction a; simpl.
 auto.
 destruct t;auto.
Qed.

Lemma mult_1_a : forall a, nf a -> (F 1) * a = a.
 induction a.
 simpl.
 trivial.
 simpl.

 simpl in IHa2.
 intro.
 caseEq a1.
 intro.
 subst a1.
 rewrite (nf_of_finite H).
 rewrite <- (plus_n_O n).
 auto.
 intros.
 subst a1.
 unfold finite in IHa2.
 rewrite IHa2.
 auto.
 nf_inv.
Qed.

 Lemma mult_a_1 : forall a, nf a -> a *  (F 1)  = a.
 induction a.
 simpl.
 trivial.
 simpl.

 simpl in IHa2.
 intro.
 caseEq a1.
 intro.
 subst a1.
 rewrite mult_1_r.
 rewrite (nf_of_finite H).
 auto.
 intros.
 subst a1.
  rewrite mult_1_r;auto.
Qed.

Lemma exp_fin_omega : forall n, (F (S (S n)))^ omega = omega.
Proof.
 reflexivity.
Qed.

Lemma omega_exp_rw : forall a, nf a -> omega ^ a =  phi0 a.
Proof.
 unfold omega, phi0;simpl.
 intro a; elim a; simpl.
 trivial.
 destruct t.
 simpl.
 intros.
 generalize (nf_of_finite H1).
 intro; subst t.
 case n;simpl.
 auto.
 simpl.
 induction n0;simpl.
 auto.
 rewrite IHn0.
 simpl.
 auto.
 intros.
 unfold omega_term.
 rewrite H0.
 fold (phi0 t).
 fold (phi0 (cons (cons t1 n t2) n0 t)).
 fold (phi0 (cons (cons t1 n t2) n0 zero)).
 rewrite <- (plus_to_cons H1).
 rewrite  phi0_plus_mult.
 unfold omega_term;auto.
 unfold omega_term;constructor.
 nf_inv.
 nf_inv.
 nf_inv.
Qed.

Lemma omega_term_ambiguity : forall a n, nf a -> omega_term a n =
                                                 (omega ^ a) * (F (S n)).
 Proof.
  intros a n H; rewrite omega_exp_rw.
  simpl.
 case a; simpl; unfold omega_term; auto.
 rewrite <- (plus_n_O n).
 auto.
  rewrite <- (plus_n_O n).
 auto.
 auto.
Qed.

Lemma cons_ambiguity : forall a n b, nf(cons a n b) ->
                       cons a n b = (omega^a)*(F (S n))+b.
Proof.
 intros.
 rewrite <- plus_to_cons.
 rewrite omega_term_ambiguity; auto.
 nf_inv.
 auto.
Qed.

Lemma cons_unicity : forall a n b a' n' b',
                    nf (cons a n b) -> nf (cons a' n' b') ->
                    (omega^a)*(F (S n))+b = (omega^a')*(F (S n'))+b' ->
                    a=a' /\ n = n' /\ b = b'.
Proof.
 intros a n b a' n' b' N N'.
 rewrite <- (cons_ambiguity N).
 rewrite <- (cons_ambiguity N').
 injection 1;auto.
Qed.

Theorem Cantor_normal_form :
  forall o, zero < o -> nf o ->
    {a:T1 & {n: nat &{b : T1 | o = omega ^ a * (F (S n)) + b  /\
                               nf (cons a n b) /\
                    (forall a' n' b', nf (cons a' n' b') ->
                      o = omega ^ a' * (F (S n')) + b' ->
                     a = a' /\ n=n' /\ b = b' )}}}.
Proof.
 intro ; case o.
 intro i; case (lt_irr i).
 intros a n b H H0.
 exists a;exists n;exists b; split.
 apply cons_ambiguity;auto.
 split;[auto|intros a' n' b' H' e'].
 apply cons_unicity;auto.
 rewrite <- e'.
 symmetry;apply cons_ambiguity;auto.
Defined.

Lemma trichotomy : forall a b, a < b \/ a = b \/ b < a.
Proof.
 intros a b; case (trichotomy_inf a b); auto.
 destruct 1;auto.
Qed.

Ltac tricho t t' Hname := case (trichotomy t t');
                           [auto with T1 |
                            auto with T1 |
                            intro Hname |
                            intros [Hname|Hname]].


(** * Effectful functional programming *)

Require Import Coq.Classes.SetoidClass.
Require FunctionalExtensionality.

(** **Stateful operations *)
Module StateMonad.
  Definition S := nat.

  Inductive ΣState (X : Type) : Type :=
  | get' : unit -> (S -> X) -> ΣState X
  | set' : S -> (unit -> X) -> ΣState X.
  Arguments get' {_}. Arguments set' {_}.

  Definition ΣState_map {V W : Type} (f : (V -> W)) (v : ΣState V) : (ΣState W) :=
    match v with
    | get' _ g => get' tt (fun x => f (g x))
    | set' s g => set' s (fun u => f (g u))
    end.

  Lemma ΣState_map_id : forall {V : Type} (x : ΣState V),
      (ΣState_map (fun xs => xs) x) = x.
  Proof.
    intros V x. destruct x; simpl.
    - destruct u. f_equal.
    - f_equal.
  Qed.

  Lemma ΣState_map_comp : forall {U V W : Type} (f : U -> V)(g : V -> W)(x : ΣState U),
      ΣState_map (fun x => g (f x)) x = ΣState_map g (ΣState_map f x).
  Proof.
    intros U V W f g x. destruct x; auto.
  Qed.

  (** Remark : an equivalent (but more modular) way to obtain the same signature
      is through the following constructs: *)
  Inductive ΣGet (X : Type) : Type :=
  | get'2 : unit -> (S -> X) -> ΣGet X.
  Inductive ΣType (X : Type) : Type :=
  | set'2 : S -> (unit -> X) -> ΣType X.
  Arguments get'2 {_}. Arguments set'2 {_}.

  Inductive ΣGetType (F G : Type -> Type) (X : Type) : Type :=
  | inl : F X -> ΣGetType F G X
  | inr : G X -> ΣGetType F G X.
  Notation " F ⊕ G " := (ΣGetType F G) (at level 20).

  (** *** Free term algebra for state *)

  Inductive StateF (V : Type) : Type :=
  | ret : V -> StateF V
  | op : ΣState (StateF V) -> StateF V.
  Arguments ret {_}. Arguments op {_}.

  Definition get : unit -> StateF S :=
    fun _ => op (get' tt ret).

  Definition set : S -> StateF unit :=
    fun s => op (set' s ret).

  Fixpoint bind {V W : Type} (x : StateF V) (mf : V -> StateF W) : StateF W :=
    match x with
    | ret x => mf x
    | op (get' u f) => op (get' u (fun s => bind (f s) mf))
    | op (set' s f) => op (set' s (fun u => bind (f u) mf))
    end.
  Notation "x >>= y" := (bind x y) (at level 50, left associativity).

  (** At this stage, we can write (but not execute) stateful programs, such as: *)

  Definition test0 : StateF S :=
    get tt >>= fun s => set s >>= fun _ => get tt >>= fun s' => ret s'.
  Definition test1 : StateF S :=
    get tt >>= fun s' => ret s'.
  Definition test2 : StateF S :=
    get tt >>= fun s => set s >>= fun _ => ret s.
  Definition random : StateF nat :=
    get tt >>= fun seed => let n := Nat.modulo (seed * 25 + 17) 65 in
                        set n >>= fun _ => ret n.

  (** *** Monad laws *)

  Lemma bind_left_unit : forall {X Y : Type} (x : X) (k : X -> StateF Y),
      (ret x >>= k) = k x.
  Proof. reflexivity. Qed.

  Import FunctionalExtensionality.

  Lemma bind_right_unit : forall {X : Type} (mx : StateF X),
      mx >>= ret = mx.
  Proof.
    fix bind_right_unit 2.
    intros X mx. destruct mx as [?|x].
    - reflexivity.
    - destruct x; simpl; repeat f_equal;
        apply functional_extensionality; intro x; apply bind_right_unit.
  Qed.

  Lemma bind_compose : forall {X Y Z : Type} (mx : StateF X)(f : X -> StateF Y)(g : Y -> StateF Z),
    ((mx >>= f) >>= g) = (mx >>= fun x => (f x >>= g)).
  Proof.
    fix bind_compose 4.
    intros X Y Z mx f g.
    destruct mx as [?|x]; simpl.
    - reflexivity.
    - destruct x; simpl; repeat f_equal;
        apply functional_extensionality; intro x;
          rewrite <- bind_compose; reflexivity.
  Qed.

  (** *** Equational theory of State *)

  Inductive StateF_red {V : Type} : StateF V -> StateF V -> Prop :=
    | red_get_get (k : S -> S -> StateF V) :
        StateF_red (get tt >>= (fun s => get tt >>= fun s' => k s s'))
                   (get tt >>= fun s => k s s)
    | red_set_set k s1 s2 :
        StateF_red (set s1 >>= (fun _ => set s2 >>= fun _ => k))
                   (set s2 >>= fun _ => k)
    | red_get_set k :
        StateF_red (get tt >>= fun s => set s >>= fun _ => k) k
    | red_set_get k s :
        StateF_red (set s >>= (fun _ => get tt >>= k))
                   (set s >>= fun _ => k s).
  Notation "x ⤳ y" := (StateF_red x y) (at level 70).

  Reserved Notation "x ∼ y" (at level 70).
  Inductive StateF_eq {V : Type} : StateF V -> StateF V -> Prop :=
    | eq_red p q : (p ⤳ q) -> p ∼ q
    | eq_trans p q r : (p ∼ q) -> (q ∼ r) -> (p ∼ r)
    | eq_refl p : p ∼ p
    | eq_sym p q : p ∼ q -> q ∼ p
    | eq_cong {W : Type} (tm : StateF W)(ps qs : W -> StateF V) :
        (forall w, ps w ∼ qs w) -> (tm >>= ps) ∼ (tm >>= qs)
    where "x ∼ y" := (StateF_eq x y).

  Add Parametric Relation {V : Type} : (StateF V) (@StateF_eq V)
      reflexivity proved by eq_refl
      symmetry proved by eq_sym
      transitivity proved by eq_trans
        as StateF_rel.

  Definition prog1 : StateF nat :=
    get tt >>=
        fun x => set (1 + x) >>=
                  fun _ => get tt >>=
                            fun y => set (2 + x) >>=
                                      fun _ => get tt >>=
                                                fun z => set (3 + y) >>=
                                                          fun _ => ret y.

  Definition prog2 : StateF nat :=
    get tt >>= fun x => set (4 + x) >>= fun _ => ret (1 + x).

  Lemma prog_equiv : prog1 ∼ prog2.
  Proof.
    unfold prog1; unfold prog2.
    repeat (etransitivity;
            try (apply eq_cong; intro w; apply eq_red; constructor)).
  Qed.

  (** ** Semantics: `State ≡ StateF/∼` *)

  Definition State (V : Type) := ΣGet (ΣType V).

  (** We have recovered Haskell's `State` monad: *)
  Definition STATE (V : Type) := S -> (S * V).

  (** It remains to substantiate this claim that every stateful program is
      equivalent to a `get` followed by a `set`. We should do so computationally,
      thus inheriting a program computing these normal forms, as well as a proof
      that this program is correct. *)

  (** The first step is to interpret stateful statements into a suitable
      semantic domain which is extensionally quotiented by the theory of State *)
  Fixpoint eval {A : Type} (s : StateF A) : STATE A :=
    match s with
    | ret x => fun s => (s, x)
    | op x => match x with
             | get' _ k => fun s => eval (k s) s
             | set' s' k => fun s => eval (k tt) s'
             end
    end.

  (** The function should satisfy the following unit-proofs: *)
  Lemma test_eval_get : forall {A} (k : S -> StateF A) s,
      eval (get tt >>= k) s = eval (k s) s.
  Proof. reflexivity. Qed.
  Lemma test_eval_set : forall {A} (k : unit -> StateF A) s s',
      eval (set s' >>= k) s = eval (k tt) s'.
  Proof. reflexivity. Qed.

  (** The second step consists in reifying the semantic objects into a desired
      normal form *)
  Definition reify {A : Type} (f : STATE A) : State A :=
    get'2 tt (fun s => set'2 (fst (f s)) (fun _ => (snd (f s)))).

  (** The normalization procedure thus genuinely computes the normal form: *)
  Definition norm {A : Type} (p : StateF A) : State A :=
    reify (eval p).

  Definition denorm {A : Type} (p : State A) : StateF A :=
    let help := (fun p => match p with
                  | set'2 s k => set s >>= fun _ => ret (k tt)
                  end) in
    match p with
    | get'2 _ k => get tt >>= fun s => help (k s)
    end.
  Notation "⎡ p ⎤" := (denorm p) (at level 60).

  (** ***Monads strike back*** *)

  (** Looking closely at the `eval` function, we notice that we map syntactic
      objects to semantics objects. The natural question to ask is whether all
      the structure defined over `StateF A` carries over to `STATE A`, ie. is
      there a semantical counterpart to `ret`, `get`, `set` and `>>=` ? *)

  Definition sem_return {A : Type} (a : A) : STATE A := fun s => (s, a).

  Definition sem_get (_ : unit) : STATE S := fun s => (s, s).

  Definition sem_set (s : S) : STATE unit := fun _ => (s, tt).

  Lemma test_sem_return : forall {X : Type} (x : X), eval (ret x) = sem_return x.
  Proof. reflexivity. Qed.

  Lemma test_sem_get : forall (s : S), eval (get tt) s = sem_get tt s.
  Proof. reflexivity. Qed.

  Lemma test_sem_set : forall s s', eval (set s') s = sem_set s' s.
  Proof. reflexivity. Qed.

  Definition sem_bind {X Y : Type} (mx : STATE X) (k : X -> STATE Y) : STATE Y :=
    fun s => let (x, y) := (mx s) in k y x.
  Notation "x sem->>= k" := (sem_bind x k) (at level 50, left associativity).

  Lemma test_eval_compose : forall {X Y : Type}(mx : StateF X)(k : X -> StateF Y)(s : S),
      eval (mx >>= k) s = (eval mx sem->>= (fun x => eval (k x))) s.
  Proof.
    fix test_eval_compose 3.
    intros X Y mx k s.
    destruct mx as [x|x]; simpl; unfold sem_bind.
    - reflexivity.
    - destruct x; simpl.
      + rewrite test_eval_compose. unfold sem_bind. reflexivity.
      + rewrite test_eval_compose. unfold sem_bind. reflexivity.
  Qed.

  (** ***Soundness and completeness*** *)

  Fact eval_bind_eq : forall {V W : Type} (tm : StateF V) (p q : V -> StateF W),
      (forall w x, eval (p w) x = eval (q w) x) ->
      forall x, eval (tm >>= p) x = eval (tm >>= q) x.
  Proof.
    fix eval_bind_eq 3.
    intros V W tm p q Hev.
    destruct tm as [?|x]; simpl.
    - apply Hev.
    - destruct x; intro x; simpl;
      apply eval_bind_eq; auto.
  Qed.

  Lemma pf_sound : forall {A : Type} (p : StateF A), p ∼ ⎡ norm p ⎤.
  Proof.
    fix pf_sound 2.
    intros A p.
    destruct p as [x|x]; simpl.
    - symmetry. apply eq_red. apply red_get_set.
    - destruct x as [u k | s k]; simpl.
      + destruct u.
        assert (get tt >>= k ∼ get tt >>= (fun s' => ⎡ norm (k s') ⎤)) as Heq.
        { apply eq_cong. intros. apply pf_sound. }
        etransitivity. apply Heq.
        apply eq_red. apply red_get_get.
      + assert (set s >>= k ∼ set s >>= (fun _ => ⎡ norm (k tt) ⎤)) as Heq.
        { apply eq_cong. intros u; destruct u. apply pf_sound. }
        etransitivity. apply Heq.
        etransitivity. apply eq_red. apply red_set_get.
        etransitivity. apply eq_red. apply red_set_set.
        etransitivity. symmetry. apply eq_red. apply red_get_set.
        etransitivity. apply eq_cong.
        { intros w. apply eq_red. apply red_set_set. }
        reflexivity.
  Qed.

  Lemma pf_complete : forall {A : Type} (p q : StateF A),
      p ∼ q -> forall s, eval p s = eval q s.
  Proof.
    intros A p q Hsim.
    induction Hsim.
    - induction H; reflexivity.
    - intro s. rewrite IHHsim1. rewrite IHHsim2. reflexivity.
    - reflexivity.
    - intro s. auto.
    - intro s. apply eval_bind_eq. assumption.
  Qed.

  Theorem sound : forall {V : Type} (p q : StateF V),
      ⎡ norm p ⎤ = ⎡ norm q ⎤ -> p ∼ q.
  Proof.
    intros V p q H.
    etransitivity. apply pf_sound.
    rewrite H. symmetry.
    apply pf_sound.
  Qed.

  Theorem complete : forall {A : Type} (p q : StateF A),
      p ∼ q -> ⎡ norm p ⎤ = ⎡ norm q ⎤.
  Proof.
    intros V p q H.
    unfold norm at 1.
    assert (eval p = eval q) as He.
    - apply functional_extensionality.
      apply pf_complete; auto.
    - rewrite He. reflexivity.
  Qed.

  (** ***Examples*** *)

  Example test01 : test0 ∼ test1.
  Proof. apply sound. reflexivity. Qed.

  Example test12 : test1 ∼ test2.
  Proof. apply sound. reflexivity. Qed.

  Fact eval_compose : forall {V W : Type} (tm : StateF V) (k : V -> StateF W) s,
      eval (tm >>= k) s = eval (k (snd (eval tm s))) (fst (eval tm s)).
  Proof.
    fix eval_compose 3.
    intros V W tm k s.
    destruct tm as [?|x]; simpl.
    - reflexivity.
    - destruct x; apply eval_compose.
  Qed.

  Lemma norm_compose : forall {V W : Type} (tm : StateF W) (ps : W -> StateF V),
      ⎡ norm (tm >>= ps) ⎤ = ⎡ norm (⎡ norm tm ⎤ >>= fun w => ⎡ norm (ps w) ⎤) ⎤.
  Proof.
    intros V W tm ps.
    simpl. repeat f_equal.
    apply functional_extensionality. intros x. f_equal.
    rewrite eval_compose. reflexivity.
  Qed.

  Lemma cong2 : forall {V W : Type} (tm tm' : StateF W) (ps qs : W -> StateF V),
      (tm ∼ tm') ->
      (forall w, ps w ∼ qs w) ->
      (tm >>= ps) ∼ (tm' >>= qs).
  Proof.
    intros V W tm tm' ps qs Htm Hps.
    apply sound.
    rewrite norm_compose.
    apply complete in Htm. rewrite Htm.
    symmetry. rewrite norm_compose.
    repeat f_equal.
    apply functional_extensionality.
    intros x. apply complete. symmetry. apply Hps.
  Qed.

End StateMonad.

(** We will now represent a generic monad with a class *)
Class Monad (m : Type -> Type) : Type :=
  {
    ret {A} : A -> m A;
    bind {A B}: m A -> (A -> m B) -> m B;

    bind_left_unit {X Y} : forall (x : X) (k : X -> m Y), bind (ret x) k = k x;
    bind_right_unit {X} : forall (x : m X), bind x ret = x;
    bind_compose {X Y Z} : forall (x : m X)(f : X -> m Y)(g : Y -> m Z),
        (bind (bind x f) g) = bind x (fun x => bind (f x) g);
  }.
Notation "x >>= f" := (bind x f) (at level 50, left associativity).

(** **Application: the Tick monad TODO *)

(** **More monads *)

(** ***Exception/Error monad *)
Module Exception.
  Parameter E : Type.

  Inductive Exn (X : Type) :=
  | Ok (v : X) : Exn X
  | Ko (e : E) : Exn X.
  Arguments Ok {_}. Arguments Ko {_}.

  Definition raise (e : E) : Exn unit := Ko e.
  Definition catch {A B : Type} (x : Exn A) (k : A -> Exn B) (ke : E -> Exn B) :=
    match x with
    | Ok v => k v
    | Ko e => ke e
    end.
  Notation "x >>= [ k | ke ]" := (catch x k ke) (at level 50, left associativity).

  Program Instance ExceptionMonad : Monad Exn :=
    {
      ret _ v := Ok v;
      bind _ _ x k := match x with
                      | Ok v => k v
                      | Ko e => Ko e
                      end;
    }.
  Next Obligation. destruct x; reflexivity. Qed.
  Next Obligation. destruct x; reflexivity. Qed.

  (* TODO algebraic presentation *)
End Exception.

(** ***Reader/environment monad *)
Module Reader.
  Parameter Env : Type.

  Definition Reader (X : Type) : Type := Env -> X.

  Definition get_env (_ : unit) : Reader Env := fun e => e.

  Definition local {A : Type} (e : Env) (r : Reader A) : Reader A :=
    fun e => r e.

  Program Instance ReaderMonad : Monad Reader :=
    {
      ret _ v := fun _ => v;
      bind _ _ x k := fun e => k (x e) e
    }.

  (* TODO algebraic presentation *)
End Reader.

(** ***Non-determinism monad *)
Module ND.
  Parameter Info : Type.
  Open Scope list_scope.

  Definition Nondet (A : Type) : Type := list A.

  Definition ndfail {X : Type} : Nondet X := nil.

  Definition ndor {X : Type} (mx1 : Nondet X) (mx2 : Nondet X) : Nondet X :=
    List.app mx1 mx2.

  Program Instance NDMonad : Monad Nondet :=
    {
      ret _ x := x::nil;
      bind _ _ x k := List.concat (List.map k x);
    }.
  Next Obligation. apply List.app_nil_r. Qed.
  Next Obligation.
    induction x; simpl.
    - reflexivity.
    - rewrite IHx. reflexivity.
  Qed.
  Next Obligation.
    induction x; simpl.
    - reflexivity.
    - rewrite List.map_app. repeat rewrite List.concat_app.
      rewrite IHx. reflexivity.
  Qed.

  (* TODO algebraic presentation *)

  (** Insert an element `x` at a non-deterministic position of a list `l` *)
  Fixpoint insert {X : Type} (x : X) (l : list X) : Nondet (list X) :=
    match l with
    | nil => ret (x::nil)
    | hd::tl => ndor (ret (x::hd::tl)) (insert x tl >>= (fun l => ret (hd::l)))
    end.

  (** Compute (non-deterministically) a permutation of list `l` *)
  Fixpoint permut {X : Type} (l : list X) : Nondet (list X) :=
    match l with
    | nil => ret nil
    | hd::tl => (permut tl >>= (fun tl => insert hd tl))
    end.
End ND.

(* TODO Random monad *)

(** ***Counting/complexity monad *)
Module Count.
  Definition Count (X : Type) : Type := (nat * X).

  Definition count {X : Type} (x : X) : Count X := (1, x).

  Program Instance CountMonad : Monad Count :=
    {
      ret _ x := (0, x);
      bind _ _ '(n , x) k :=
        let (n', y) := k x in (n + n', y);
    }.
  Next Obligation. destruct (k x); reflexivity. Qed.
  Next Obligation.
    destruct x; simpl.
    f_equal. symmetry. apply plus_n_O.
  Qed.
  Next Obligation.
    destruct x; simpl.
    destruct (f x); simpl; destruct (g y); simpl.
    f_equal. rewrite <- PeanoNat.Nat.add_assoc. reflexivity.
  Qed.

  Open Scope list_scope.
  Fixpoint insert (n : nat) (l : list nat) : Count (list nat) :=
    match l with
    | nil => ret (n::nil)
    | hd::tl => count (Nat.leb n hd)
                     >>= (fun is_le =>
                            match is_le with
                            | true => ret (n::hd::tl)
                            | false => (insert n tl)
                                        >>= (fun tl => ret (hd::tl))
                            end)
    end.

  Example insert_ex:
    (insert 4 (2::3::5::6::nil)) = (3, (2::3::4::5::6::nil)).
  Proof. reflexivity. Qed.
End Count.

(** ***Writer/logging monad *)
Module Log.
  Parameter Info : Type.
  Open Scope list_scope.

  Definition Log (X : Type) : Type := list Info * X.

  Definition log (i : Info) : Log unit := ((i::nil), tt).

  Program Instance LogMonad : Monad Log :=
    {
      ret _ x := (nil, x);
      bind _ _ '(log, x) k :=
        let (log', y) := k x in (List.app log log', y);
    }.
  Next Obligation. destruct (k x). reflexivity. Qed.
  Next Obligation.
    destruct x. f_equal. rewrite List.app_nil_r. reflexivity.
  Qed.
  Next Obligation.
    destruct x; simpl. destruct (f x); simpl. destruct (g y); simpl.
    rewrite List.app_assoc. reflexivity.
  Qed.
End Log.

(** ***CPS monad *)
Module CPS.
  Parameter U : Type.

  Definition CPS (X : Type) : Type := (X -> U) -> U.

  Definition call_cc {X : Type} (f : (X -> U) -> CPS X) : CPS X :=
    fun k => f k k.

  Definition throw {X : Type} (k' : X -> U) (mx : CPS X) : CPS X :=
    fun k => mx k'.

  Program Instance CPSMonad : Monad CPS :=
    {
      ret _ x := fun k => k x;
      bind _ _ x k := fun k' => x (fun x => k x k');
    }.
End CPS.

(** ***Maybe monad (for my personal use) *)
Module Maybe.
  Inductive Maybe (X : Type) : Type :=
  | None : Maybe X
  | Some : X -> Maybe X.
  Arguments None {_}. Arguments Some {_}.

  Program Instance MaybeMonad : Monad Maybe :=
    {
      ret _ x := Some x;
      bind _ _ x k := match x with | Some x => k x | None => None end
    }.
  Next Obligation. destruct x; reflexivity. Qed.
  Next Obligation. destruct x; reflexivity. Qed.
End Maybe.


From iris.algebra Require Export cmra.
From iris.base_logic Require Import base_logic.
From iris.algebra Require Import local_updates.
Set Default Proof Using "Type".
Local Arguments pcore _ _ !_ /.
Local Arguments cmra_pcore _ !_ /.
Local Arguments validN _ _ _ !_ /.
Local Arguments valid _ _  !_ /.
Local Arguments cmra_validN _ _ !_ /.
Local Arguments cmra_valid _  !_ /.

Inductive csum (A B : Type) :=
  | Cinl : A → csum A B
  | Cinr : B → csum A B
  | CsumBot : csum A B.
Arguments Cinl {_ _} _.
Arguments Cinr {_ _} _.
Arguments CsumBot {_ _}.

Instance: Params (@Cinl) 2.
Instance: Params (@Cinr) 2.
Instance: Params (@CsumBot) 2.

Instance maybe_Cinl {A B} : Maybe (@Cinl A B) := λ x,
  match x with Cinl a => Some a | _ => None end.
Instance maybe_Cinr {A B} : Maybe (@Cinr A B) := λ x,
  match x with Cinr b => Some b | _ => None end.

Section cofe.
Context {A B : ofeT}.
Implicit Types a : A.
Implicit Types b : B.

(* Cofe *)
Inductive csum_equiv : Equiv (csum A B) :=
  | Cinl_equiv a a' : a ≡ a' → Cinl a ≡ Cinl a'
  | Cinr_equiv b b' : b ≡ b' → Cinr b ≡ Cinr b'
  | CsumBot_equiv : CsumBot ≡ CsumBot.
Existing Instance csum_equiv.
Inductive csum_dist : Dist (csum A B) :=
  | Cinl_dist n a a' : a ≡{n}≡ a' → Cinl a ≡{n}≡ Cinl a'
  | Cinr_dist n b b' : b ≡{n}≡ b' → Cinr b ≡{n}≡ Cinr b'
  | CsumBot_dist n : CsumBot ≡{n}≡ CsumBot.
Existing Instance csum_dist.

Global Instance Cinl_ne : NonExpansive (@Cinl A B).
Proof. by constructor. Qed.
Global Instance Cinl_proper : Proper ((≡) ==> (≡)) (@Cinl A B).
Proof. by constructor. Qed.
Global Instance Cinl_inj : Inj (≡) (≡) (@Cinl A B).
Proof. by inversion_clear 1. Qed.
Global Instance Cinl_inj_dist n : Inj (dist n) (dist n) (@Cinl A B).
Proof. by inversion_clear 1. Qed.
Global Instance Cinr_ne : NonExpansive (@Cinr A B).
Proof. by constructor. Qed.
Global Instance Cinr_proper : Proper ((≡) ==> (≡)) (@Cinr A B).
Proof. by constructor. Qed.
Global Instance Cinr_inj : Inj (≡) (≡) (@Cinr A B).
Proof. by inversion_clear 1. Qed.
Global Instance Cinr_inj_dist n : Inj (dist n) (dist n) (@Cinr A B).
Proof. by inversion_clear 1. Qed.

Definition csum_ofe_mixin : OfeMixin (csum A B).
Proof.
  split.
  - intros mx my; split.
    + by destruct 1; constructor; try apply equiv_dist.
    + intros Hxy; feed inversion (Hxy 0); subst; constructor; try done;
      apply equiv_dist=> n; by feed inversion (Hxy n).
  - intros n; split.
    + by intros [|a|]; constructor.
    + by destruct 1; constructor.
    + destruct 1; inversion_clear 1; constructor; etrans; eauto.
  - by inversion_clear 1; constructor; apply dist_S.
Qed.
Canonical Structure csumC : ofeT := OfeT (csum A B) csum_ofe_mixin.

Program Definition csum_chain_l (c : chain csumC) (a : A) : chain A :=
  {| chain_car n := match c n return _ with Cinl a' => a' | _ => a end |}.
Next Obligation. intros c a n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
Program Definition csum_chain_r (c : chain csumC) (b : B) : chain B :=
  {| chain_car n := match c n return _ with Cinr b' => b' | _ => b end |}.
Next Obligation. intros c b n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
Definition csum_compl `{Cofe A, Cofe B} : Compl csumC := λ c,
  match c 0 with
  | Cinl a => Cinl (compl (csum_chain_l c a))
  | Cinr b => Cinr (compl (csum_chain_r c b))
  | CsumBot => CsumBot
  end.
Global Program Instance csum_cofe `{Cofe A, Cofe B} : Cofe csumC :=
  {| compl := csum_compl |}.
Next Obligation.
  intros ?? n c; rewrite /compl /csum_compl.
  feed inversion (chain_cauchy c 0 n); first auto with lia; constructor.
  + rewrite (conv_compl n (csum_chain_l c a')) /=. destruct (c n); naive_solver.
  + rewrite (conv_compl n (csum_chain_r c b')) /=. destruct (c n); naive_solver.
Qed.

Global Instance csum_ofe_discrete :
  OfeDiscrete A → OfeDiscrete B → OfeDiscrete csumC.
Proof. by inversion_clear 3; constructor; apply (discrete _). Qed.
Global Instance csum_leibniz :
  LeibnizEquiv A → LeibnizEquiv B → LeibnizEquiv (csumC A B).
Proof. by destruct 3; f_equal; apply leibniz_equiv. Qed.

Global Instance Cinl_discrete a : Discrete a → Discrete (Cinl a).
Proof. by inversion_clear 2; constructor; apply (discrete _). Qed.
Global Instance Cinr_discrete b : Discrete b → Discrete (Cinr b).
Proof. by inversion_clear 2; constructor; apply (discrete _). Qed.
End cofe.

Arguments csumC : clear implicits.

(* Functor on COFEs *)
Definition csum_map {A A' B B'} (fA : A → A') (fB : B → B')
                    (x : csum A B) : csum A' B' :=
  match x with
  | Cinl a => Cinl (fA a)
  | Cinr b => Cinr (fB b)
  | CsumBot => CsumBot
  end.
Instance: Params (@csum_map) 4.

Lemma csum_map_id {A B} (x : csum A B) : csum_map id id x = x.
Proof. by destruct x. Qed.
Lemma csum_map_compose {A A' A'' B B' B''} (f : A → A') (f' : A' → A'')
                       (g : B → B') (g' : B' → B'') (x : csum A B) :
  csum_map (f' ∘ f) (g' ∘ g) x = csum_map f' g' (csum_map f g x).
Proof. by destruct x. Qed.
Lemma csum_map_ext {A A' B B' : ofeT} (f f' : A → A') (g g' : B → B') x :
  (∀ x, f x ≡ f' x) → (∀ x, g x ≡ g' x) → csum_map f g x ≡ csum_map f' g' x.
Proof. by destruct x; constructor. Qed.
Instance csum_map_cmra_ne {A A' B B' : ofeT} n :
  Proper ((dist n ==> dist n) ==> (dist n ==> dist n) ==> dist n ==> dist n)
         (@csum_map A A' B B').
Proof. intros f f' Hf g g' Hg []; destruct 1; constructor; by apply Hf || apply Hg. Qed.
Definition csumC_map {A A' B B'} (f : A -n> A') (g : B -n> B') :
  csumC A B -n> csumC A' B' :=
  CofeMor (csum_map f g).
Instance csumC_map_ne A A' B B' :
  NonExpansive2 (@csumC_map A A' B B').
Proof. by intros n f f' Hf g g' Hg []; constructor. Qed.

Section cmra.
Context {A B : cmraT}.
Implicit Types a : A.
Implicit Types b : B.

(* CMRA *)
Instance csum_valid : Valid (csum A B) := λ x,
  match x with
  | Cinl a => ✓ a
  | Cinr b => ✓ b
  | CsumBot => False
  end.
Instance csum_validN : ValidN (csum A B) := λ n x,
  match x with
  | Cinl a => ✓{n} a
  | Cinr b => ✓{n} b
  | CsumBot => False
  end.
Instance csum_pcore : PCore (csum A B) := λ x,
  match x with
  | Cinl a => Cinl <$> pcore a
  | Cinr b => Cinr <$> pcore b
  | CsumBot => Some CsumBot
  end.
Instance csum_op : Op (csum A B) := λ x y,
  match x, y with
  | Cinl a, Cinl a' => Cinl (a ⋅ a')
  | Cinr b, Cinr b' => Cinr (b ⋅ b')
  | _, _ => CsumBot
  end.

Lemma Cinl_op a a' : Cinl a ⋅ Cinl a' = Cinl (a ⋅ a').
Proof. done. Qed.
Lemma Cinr_op b b' : Cinr b ⋅ Cinr b' = Cinr (b ⋅ b').
Proof. done. Qed.

Lemma csum_included x y :
  x ≼ y ↔ y = CsumBot ∨ (∃ a a', x = Cinl a ∧ y = Cinl a' ∧ a ≼ a')
                      ∨ (∃ b b', x = Cinr b ∧ y = Cinr b' ∧ b ≼ b').
Proof.
  split.
  - unfold included. intros [[a'|b'|] Hy]; destruct x as [a|b|];
      inversion_clear Hy; eauto 10.
  - intros [->|[(a&a'&->&->&c&?)|(b&b'&->&->&c&?)]].
    + destruct x; exists CsumBot; constructor.
    + exists (Cinl c); by constructor.
    + exists (Cinr c); by constructor.
Qed.

Lemma csum_includedN n x y :
  x ≼{n} y ↔ y = CsumBot ∨ (∃ a a', x = Cinl a ∧ y = Cinl a' ∧ a ≼{n} a')
                         ∨ (∃ b b', x = Cinr b ∧ y = Cinr b' ∧ b ≼{n} b').
Proof.
  split.
  - unfold includedN. intros [[a'|b'|] Hy]; destruct x as [a|b|];
      inversion_clear Hy; eauto 10.
  - intros [->|[(a&a'&->&->&c&?)|(b&b'&->&->&c&?)]].
    + destruct x; exists CsumBot; constructor.
    + exists (Cinl c); by constructor.
    + exists (Cinr c); by constructor.
Qed.

Lemma csum_cmra_mixin : CmraMixin (csum A B).
Proof.
  split.
  - intros [] n; destruct 1; constructor; by ofe_subst.
  - intros ???? [n a a' Ha|n b b' Hb|n] [=]; subst; eauto.
    + destruct (pcore a) as [ca|] eqn:?; simplify_option_eq.
      destruct (cmra_pcore_ne n a a' ca) as (ca'&->&?); auto.
      exists (Cinl ca'); by repeat constructor.
    + destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
      destruct (cmra_pcore_ne n b b' cb) as (cb'&->&?); auto.
      exists (Cinr cb'); by repeat constructor.
  - intros ? [a|b|] [a'|b'|] H; inversion_clear H; ofe_subst; done.
  - intros [a|b|]; rewrite /= ?cmra_valid_validN; naive_solver eauto using O.
  - intros n [a|b|]; simpl; auto using cmra_validN_S.
  - intros [a1|b1|] [a2|b2|] [a3|b3|]; constructor; by rewrite ?assoc.
  - intros [a1|b1|] [a2|b2|]; constructor; by rewrite 1?comm.
  - intros [a|b|] ? [=]; subst; auto.
    + destruct (pcore a) as [ca|] eqn:?; simplify_option_eq.
      constructor; eauto using cmra_pcore_l.
    + destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
      constructor; eauto using cmra_pcore_l.
  - intros [a|b|] ? [=]; subst; auto.
    + destruct (pcore a) as [ca|] eqn:?; simplify_option_eq.
      feed inversion (cmra_pcore_idemp a ca); repeat constructor; auto.
    + destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
      feed inversion (cmra_pcore_idemp b cb); repeat constructor; auto.
  - intros x y ? [->|[(a&a'&->&->&?)|(b&b'&->&->&?)]]%csum_included [=].
    + exists CsumBot. rewrite csum_included; eauto.
    + destruct (pcore a) as [ca|] eqn:?; simplify_option_eq.
      destruct (cmra_pcore_mono a a' ca) as (ca'&->&?); auto.
      exists (Cinl ca'). rewrite csum_included; eauto 10.
    + destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
      destruct (cmra_pcore_mono b b' cb) as (cb'&->&?); auto.
      exists (Cinr cb'). rewrite csum_included; eauto 10.
  - intros n [a1|b1|] [a2|b2|]; simpl; eauto using cmra_validN_op_l; done.
  - intros n [a|b|] y1 y2 Hx Hx'.
    + destruct y1 as [a1|b1|], y2 as [a2|b2|]; try by exfalso; inversion Hx'.
      destruct (cmra_extend n a a1 a2) as (z1&z2&?&?&?); [done|apply (inj Cinl), Hx'|].
      exists (Cinl z1), (Cinl z2). by repeat constructor.
    + destruct y1 as [a1|b1|], y2 as [a2|b2|]; try by exfalso; inversion Hx'.
      destruct (cmra_extend n b b1 b2) as (z1&z2&?&?&?); [done|apply (inj Cinr), Hx'|].
      exists (Cinr z1), (Cinr z2). by repeat constructor.
    + by exists CsumBot, CsumBot; destruct y1, y2; inversion_clear Hx'.
Qed.
Canonical Structure csumR := CmraT (csum A B) csum_cmra_mixin.

Global Instance csum_cmra_discrete :
  CmraDiscrete A → CmraDiscrete B → CmraDiscrete csumR.
Proof.
  split; first apply _.
  by move=>[a|b|] HH /=; try apply cmra_discrete_valid.
Qed.

Global Instance Cinl_core_id a : CoreId a → CoreId (Cinl a).
Proof. rewrite /CoreId /=. inversion_clear 1; by repeat constructor. Qed.
Global Instance Cinr_core_id b : CoreId b → CoreId (Cinr b).
Proof. rewrite /CoreId /=. inversion_clear 1; by repeat constructor. Qed.

Global Instance Cinl_exclusive a : Exclusive a → Exclusive (Cinl a).
Proof. by move=> H[]? =>[/H||]. Qed.
Global Instance Cinr_exclusive b : Exclusive b → Exclusive (Cinr b).
Proof. by move=> H[]? =>[|/H|]. Qed.

Global Instance Cinl_cancelable a : Cancelable a → Cancelable (Cinl a).
Proof.
  move=> ?? [y|y|] [z|z|] ? EQ //; inversion_clear EQ.
  constructor. by eapply (cancelableN a).
Qed.
Global Instance Cinr_cancelable b : Cancelable b → Cancelable (Cinr b).
Proof.
  move=> ?? [y|y|] [z|z|] ? EQ //; inversion_clear EQ.
  constructor. by eapply (cancelableN b).
Qed.

Global Instance Cinl_id_free a : IdFree a → IdFree (Cinl a).
Proof. intros ? [] ? EQ; inversion_clear EQ. by eapply id_free0_r. Qed.
Global Instance Cinr_id_free b : IdFree b → IdFree (Cinr b).
Proof. intros ? [] ? EQ; inversion_clear EQ. by eapply id_free0_r. Qed.

(** Internalized properties *)
Lemma csum_equivI {M} (x y : csum A B) :
  x ≡ y ⊣⊢ (match x, y with
            | Cinl a, Cinl a' => a ≡ a'
            | Cinr b, Cinr b' => b ≡ b'
            | CsumBot, CsumBot => True
            | _, _ => False
            end : uPred M).
Proof.
  uPred.unseal; do 2 split; first by destruct 1.
  by destruct x, y; try destruct 1; try constructor.
Qed.
Lemma csum_validI {M} (x : csum A B) :
  ✓ x ⊣⊢ (match x with
          | Cinl a => ✓ a
          | Cinr b => ✓ b
          | CsumBot => False
          end : uPred M).
Proof. uPred.unseal. by destruct x. Qed.

(** Updates *)
Lemma csum_update_l (a1 a2 : A) : a1 ~~> a2 → Cinl a1 ~~> Cinl a2.
Proof.
  intros Ha n [[a|b|]|] ?; simpl in *; auto.
  - by apply (Ha n (Some a)).
  - by apply (Ha n None).
Qed.
Lemma csum_update_r (b1 b2 : B) : b1 ~~> b2 → Cinr b1 ~~> Cinr b2.
Proof.
  intros Hb n [[a|b|]|] ?; simpl in *; auto.
  - by apply (Hb n (Some b)).
  - by apply (Hb n None).
Qed.
Lemma csum_updateP_l (P : A → Prop) (Q : csum A B → Prop) a :
  a ~~>: P → (∀ a', P a' → Q (Cinl a')) → Cinl a ~~>: Q.
Proof.
  intros Hx HP n mf Hm. destruct mf as [[a'|b'|]|]; try by destruct Hm.
  - destruct (Hx n (Some a')) as (c&?&?); naive_solver.
  - destruct (Hx n None) as (c&?&?); naive_solver eauto using cmra_validN_op_l.
Qed.
Lemma csum_updateP_r (P : B → Prop) (Q : csum A B → Prop) b :
  b ~~>: P → (∀ b', P b' → Q (Cinr b')) → Cinr b  ~~>: Q.
Proof.
  intros Hx HP n mf Hm. destruct mf as [[a'|b'|]|]; try by destruct Hm.
  - destruct (Hx n (Some b')) as (c&?&?); naive_solver.
  - destruct (Hx n None) as (c&?&?); naive_solver eauto using cmra_validN_op_l.
Qed.
Lemma csum_updateP'_l (P : A → Prop) a :
  a ~~>: P → Cinl a ~~>: λ m', ∃ a', m' = Cinl a' ∧ P a'.
Proof. eauto using csum_updateP_l. Qed.
Lemma csum_updateP'_r (P : B → Prop) b :
  b ~~>: P → Cinr b ~~>: λ m', ∃ b', m' = Cinr b' ∧ P b'.
Proof. eauto using csum_updateP_r. Qed.

Lemma csum_local_update_l (a1 a2 a1' a2' : A) :
  (a1,a2) ~l~> (a1',a2') → (Cinl a1,Cinl a2) ~l~> (Cinl a1',Cinl a2').
Proof.
  intros Hup n mf ? Ha1; simpl in *.
  destruct (Hup n (mf ≫= maybe Cinl)); auto.
  { by destruct mf as [[]|]; inversion_clear Ha1. }
  split. done. by destruct mf as [[]|]; inversion_clear Ha1; constructor.
Qed.
Lemma csum_local_update_r (b1 b2 b1' b2' : B) :
  (b1,b2) ~l~> (b1',b2') → (Cinr b1,Cinr b2) ~l~> (Cinr b1',Cinr b2').
Proof.
  intros Hup n mf ? Ha1; simpl in *.
  destruct (Hup n (mf ≫= maybe Cinr)); auto.
  { by destruct mf as [[]|]; inversion_clear Ha1. }
  split. done. by destruct mf as [[]|]; inversion_clear Ha1; constructor.
Qed.
End cmra.

Arguments csumR : clear implicits.

(* Functor *)
Instance csum_map_cmra_morphism {A A' B B' : cmraT} (f : A → A') (g : B → B') :
  CmraMorphism f → CmraMorphism g → CmraMorphism (csum_map f g).
Proof.
  split; try apply _.
  - intros n [a|b|]; simpl; auto using cmra_morphism_validN.
  - move=> [a|b|]=>//=; rewrite cmra_morphism_pcore; by destruct pcore.
  - intros [xa|ya|] [xb|yb|]=>//=; by rewrite -cmra_morphism_op.
Qed.

Program Definition csumRF (Fa Fb : rFunctor) : rFunctor := {|
  rFunctor_car A B := csumR (rFunctor_car Fa A B) (rFunctor_car Fb A B);
  rFunctor_map A1 A2 B1 B2 fg := csumC_map (rFunctor_map Fa fg) (rFunctor_map Fb fg)
|}.
Next Obligation.
  by intros Fa Fb A1 A2 B1 B2 n f g Hfg; apply csumC_map_ne; try apply rFunctor_ne.
Qed.
Next Obligation.
  intros Fa Fb A B x. rewrite /= -{2}(csum_map_id x).
  apply csum_map_ext=>y; apply rFunctor_id.
Qed.
Next Obligation.
  intros Fa Fb A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -csum_map_compose.
  apply csum_map_ext=>y; apply rFunctor_compose.
Qed.

Instance csumRF_contractive Fa Fb :
  rFunctorContractive Fa → rFunctorContractive Fb →
  rFunctorContractive (csumRF Fa Fb).
Proof.
  by intros ?? A1 A2 B1 B2 n f g Hfg; apply csumC_map_ne; try apply rFunctor_contractive.
Qed.


From Undecidability.L.Tactics Require Import LTactics GenEncode Computable.
From Undecidability.L Require Import  FinTypeLookup LFinType LSum.
From Undecidability.Shared.Libs.PSL Require Import FinTypes.

From Complexity.NP Require Import FSAT_to_SAT kSAT_to_SAT kSAT_to_FlatClique.
From Complexity.NP.SAT.CookLevin.Subproblems Require Import FlatCC SingleTMGenNP BinaryCC.
From Complexity.NP.SAT.CookLevin.Subproblems Require FlatTCC.
From Complexity.NP Require Import SAT FSAT kSAT FlatClique.
From Complexity.NP.SAT.CookLevin Require Import FlatSingleTMGenNP_to_FlatTCC FlatTCC_to_FlatCC FlatCC_to_BinaryCC BinaryCC_to_FSAT.

Require Import Complexity.NP.SAT.CookLevin.Reductions.TMGenNP_fixed_singleTapeTM_to_FlatFunSingleTMGenNP.
From Complexity.NP.TM Require Import IntermediateProblems.

From Undecidability.TM Require Import TM_facts CodeTM.

From Complexity Require Import L_to_LM LM_to_mTM mTM_to_singleTapeTM TMGenNP_fixed_mTM.
From Undecidability.L Require Import Prelim.MoreList Prelim.MoreBase.
From Complexity.Complexity Require Import NP Definitions Subtypes.
From Complexity.NP Require Import GenNP.

From Complexity Require GenNP_is_hard CanEnumTerm.

(** * Overview of the results proved in the paper. *)

Import LNat.
Lemma GenNP_to_LMGenNP :
  GenNP (list bool) ⪯p LMGenNP.LMGenNP (list bool).
Proof.
  apply GenNP_to_LMGenNP.
Qed.

Lemma LMGenNP_to_TMGenNP :
  LMGenNP.LMGenNP (list bool) ⪯p mTMGenNP_fixed (projT1 M.M).
Proof.
  apply LMGenNP_to_TMGenNP_mTM.
Qed.

Lemma TMGenNP_to_TMGenNP_fixed_singleTapeTM :
  mTMGenNP_fixed (projT1 M.M) ⪯p TMGenNP_fixed (projT1 (M_multi2mono.M__mono (projT1 M.M))).
Proof.
  apply TMGenNP_mTM_to_TMGenNP_singleTM.
Qed.

(* reduce to the formulation of SingleTMGenNP where the TM is not fixed *)
Import Specif.
Lemma fixedTM_to_FlatSingleTMGenNP (sig : finType) (M : TM sig 1)
      (reg__sig : encodable sig) (index__comp : {c & computableTime' (index (F:=sig)) (fun _ _ => (c,tt))}):
  TMGenNP_fixed M ⪯p FlatSingleTMGenNP.
Proof.
  eapply reducesPolyMO_transitive with (Q := FlatFunSingleTMGenNP).
  apply (TMGenNP_fixed_singleTapeTM_to_FlatFunSingleTMGenNP M).  eassumption.
  eapply reducesPolyMO_intro with (f := id).
  - exists (fun _ => 1).
    + extract. solverec.
    + smpl_inO.
    + smpl_inO.
    + exists (fun n => n). 2, 3: smpl_inO.
      intros x. now cbn.
  - intros (((? & ?) & ?) & ?). apply FlatFunSingleTMGenNP_FlatSingleTMGenNP_equiv.
Qed.

Corollary GenNP_to_SingleTMGenNP :
  GenNP (list bool) ⪯p FlatSingleTMGenNP.
Proof.
  eapply reducesPolyMO_transitive.
  apply GenNP_to_LMGenNP.
  eapply reducesPolyMO_transitive.
  apply LMGenNP_to_TMGenNP.
  eapply reducesPolyMO_transitive.
  apply TMGenNP_to_TMGenNP_fixed_singleTapeTM.
  apply fixedTM_to_FlatSingleTMGenNP.
  eapply finFun_computableTime_const. 2:exact 0.
  exact _.
Qed.

(** reduction from TM to SAT *)
Lemma FlatSingleTMGenNP_to_FlatTCC : FlatSingleTMGenNP ⪯p FlatTCC.FlatTCCLang.
Proof.
exact FlatSingleTMGenNP_to_FlatTCCLang_poly.
Qed.

Lemma FlatTCC_to_FlatCC : FlatTCC.FlatTCCLang ⪯p FlatCCLang.
Proof.
exact FlatTCC_to_FlatCC_poly.
Qed.

Lemma FlatCC_to_BinaryCC : FlatCCLang ⪯p BinaryCCLang.
Proof.
exact FlatCC_to_BinaryCC_poly.
Qed.

Lemma BinaryCC_to_FSAT : BinaryCCLang ⪯p FSAT.
Proof.
exact BinaryCC_to_FSAT_poly.
Qed.

Lemma FSAT_to_SAT : FSAT ⪯p SAT.
Proof.
exact FSAT_to_SAT_poly.
Qed.

Lemma FSAT_to_3SAT : FSAT ⪯p kSAT 3.
Proof.
exact FSAT_to_3SAT_poly.
Qed.

Lemma kSAT_to_FlatClique k: kSAT k ⪯p FlatClique.
Proof.
apply kSAT_to_FlatClique_poly.
Qed.

Corollary FlatSingleTMGenNP_to_3SAT : FlatSingleTMGenNP ⪯p kSAT 3.
Proof.
  eapply reducesPolyMO_transitive.
  2: apply FSAT_to_3SAT.
  eapply reducesPolyMO_transitive.
  2: apply BinaryCC_to_FSAT.
  eapply reducesPolyMO_transitive.
  2: apply FlatCC_to_BinaryCC.
  eapply reducesPolyMO_transitive.
  2: apply FlatTCC_to_FlatCC.
  apply FlatSingleTMGenNP_to_FlatTCC.
Qed.

Corollary GenNP_to_3SAT : GenNP (list bool) ⪯p kSAT 3.
Proof.
  eapply reducesPolyMO_transitive.
  apply GenNP_to_SingleTMGenNP.
  apply FlatSingleTMGenNP_to_3SAT.
Qed.

Import GenNP_is_hard CanEnumTerm.
(** even 3-SAT is already NP-complete. *)
Lemma CookLevin0 : NPcomplete (kSAT 3).
Proof.
  split. 2:apply inNP_kSAT.
  eapply red_NPhard. apply GenNP_to_3SAT.
  apply NPhard_GenNP.
  eapply boollist_enum.boollists_enum_term.
Qed.

(** The Cook-Levin-Theorem: SAT is NP-complete. *)
Lemma CookLevin : NPcomplete SAT.
Proof.
  split. 2:apply SAT_inNP.sat_NP.
  eapply red_NPhard. eapply kSAT_to_SAT. apply CookLevin0.
Qed.

(** The Clique problem is also NP-complete *)
Lemma Clique_complete : NPcomplete FlatClique.
Proof.
  split.
  - eapply red_NPhard; [apply kSAT_to_FlatClique | apply CookLevin0].
  - apply FlatClique_in_NP.
Qed.

(*Print Assumptions CookLevin. *)
(* Closed under the global context *)