(** * Records: Adding Records to STLC *)

(* $Date: 2012-04-23 14:08:14 -0400 (Mon, 23 Apr 2012) $ *)

Require Export Stlc.

(* ###################################################################### *)
(** * Adding Records *)

(** We saw in chapter [MoreStlc] how records can be treated as syntactic
    sugar for nested uses of products.  This is fine for simple
    examples, but the encoding is informal (in reality, if we really
    treated records this way, it would be carried out in the parser,
    which we are eliding here), and anyway it is not very efficient.
    So it is also interesting to see how records can be treated as
    first-class citizens of the language.

    Recall the informal definitions we gave before: *)

(**
    Syntax:
<<
       t ::=                          Terms:
           | ...
           | {i1=t1, ..., in=tn}         record
           | t.i                         projection

       v ::=                          Values:
           | ...
           | {i1=v1, ..., in=vn}         record value

       T ::=                          Types:
           | ...
           | {i1:T1, ..., in:Tn}         record type
>>
   Reduction:
                                 ti ==> ti'                            (ST_Rcd)
    --------------------------------------------------------------------
    {i1=v1, ..., im=vm, in=tn, ...} ==> {i1=v1, ..., im=vm, in=tn', ...}

                                 t1 ==> t1'
                               --------------                        (ST_Proj1)
                               t1.i ==> t1'.i

                          -------------------------                (ST_ProjRcd)
                          {..., i=vi, ...}.i ==> vi
   Typing:
               Gamma |- t1 : T1     ...     Gamma |- tn : Tn
             --------------------------------------------------         (T_Rcd)
             Gamma |- {i1=t1, ..., in=tn} : {i1:T1, ..., in:Tn}

                       Gamma |- t : {..., i:Ti, ...}
                       -----------------------------                   (T_Proj)
                             Gamma |- t.i : Ti
*)

(* ###################################################################### *)
(** * Formalizing Records *)

Module STLCExtendedRecords.

(* ###################################################################### *)
(** *** Syntax and Operational Semantics *)

(** The most obvious way to formalize the syntax of record types would
    be this: *)

Module FirstTry.

Definition alist (X : Type) := list (id * X).

Inductive ty : Type :=
  | TBase     : id -> ty
  | TArrow    : ty -> ty -> ty
  | TRcd      : (alist ty) -> ty.

(** Unfortunately, we encounter here a limitation in Coq: this type
    does not automatically give us the induction principle we expect
    -- the induction hypothesis in the [TRcd] case doesn't give us
    any information about the [ty] elements of the list, making it
    useless for the proofs we want to do.  *)

(* Check ty_ind.
   ====>
    ty_ind :
      forall P : ty -> Prop,
        (forall i : id, P (TBase i)) ->
        (forall t : ty, P t -> forall t0 : ty, P t0 -> P (TArrow t t0)) ->
        (forall a : alist ty, P (TRcd a)) ->    (* ??? *)
        forall t : ty, P t
*)

End FirstTry.

(** It is possible to get a better induction principle out of Coq, but
    the details of how this is done are not very pretty, and it is not
    as intuitive to use as the ones Coq generates automatically for
    simple [Inductive] definitions.

    Fortunately, there is a different way of formalizing records that
    is, in some ways, even simpler and more natural: instead of using
    the existing [list] type, we can essentially include its
    constructors ("nil" and "cons") in the syntax of types. *)

Inductive ty : Type :=
  | TBase : id -> ty
  | TArrow : ty -> ty -> ty
  | TRNil : ty
  | TRCons : id -> ty -> ty -> ty.

Tactic Notation "T_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TBase" | Case_aux c "TArrow"
  | Case_aux c "TRNil" | Case_aux c "TRCons" ].

(** Similarly, at the level of terms, we have constructors [trnil]
    -- the empty record -- and [trcons], which adds a single field to
    the front of a list of fields. *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  (* records *)
  | tproj : tm -> id -> tm
  | trnil :  tm
  | trcons : id -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp" | Case_aux c "tabs"
  | Case_aux c "tproj" | Case_aux c "trnil" | Case_aux c "trcons" ].

(** Some variables, for examples... *)

Notation a := (Id 0).
Notation f := (Id 1).
Notation g := (Id 2).
Notation l := (Id 3).
Notation A := (TBase (Id 4)).
Notation B := (TBase (Id 5)).
Notation k := (Id 6).
Notation i1 := (Id 7).
Notation i2 := (Id 8).

(** [{ i1:A }] *)

(* Check (TRCons i1 A TRNil). *)

(** [{ i1:A->B, i2:A }] *)

(* Check (TRCons i1 (TArrow A B)
           (TRCons i2 A TRNil)). *)

(* ###################################################################### *)
(** *** Well-Formedness *)

(** Generalizing our abstract syntax for records (from lists to the
    nil/cons presentation) introduces the possibility of writing
    strange types like this *)

Definition weird_type := TRCons X A B.

(** where the "tail" of a record type is not actually a record type! *)

(** We'll structure our typing judgement so that no ill-formed types
    like [weird_type] are assigned to terms.  To support this, we
    define [record_ty] and [record_tm], which identify record types
    and terms, and [well_formed_ty] which rules out the ill-formed
    types. *)

(** First, a type is a record type if it is built with just [TRNil]
    and [TRCons] at the outermost level. *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty TRNil
  | RTcons : forall i T1 T2,
        record_ty (TRCons i T1 T2).

(** Similarly, a term is a record term if it is built with [trnil]
    and [trcons] *)

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (trcons i t1 t2).

(** Note that [record_ty] and [record_tm] are not recursive -- they
    just check the outermost constructor.  The [well_formed_ty]
    property, on the other hand, verifies that the whole type is well
    formed in the sense that the tail of every record (the second
    argument to [TRCons]) is a record.

    Of course, we should also be concerned about ill-formed terms, not
    just types; but typechecking can rules those out without the help
    of an extra [well_formed_tm] definition because it already
    examines the structure of terms.  *)
(** LATER : should they fill in part of this as an exercise?  We
    didn't give rules for it above *)

Inductive well_formed_ty : ty -> Prop :=
  | wfTBase : forall i,
        well_formed_ty (TBase i)
  | wfTArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (TArrow T1 T2)
  | wfTRNil :
        well_formed_ty TRNil
  | wfTRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (TRCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

(* ###################################################################### *)
(** *** Substitution *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y => if beq_id x y then s else t
  | tabs y T t1 =>  tabs y T (if beq_id x y then t1 else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tproj t1 i => tproj (subst x s t1) i
  | trnil => trnil
  | trcons i t1 tr1 => trcons i (subst x s t1) (subst x s tr1)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* ###################################################################### *)
(** *** Reduction *)

(** Next we define the values of our language.  A record is a value if
    all of its fields are. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tabs x T11 t12)
  | v_rnil : value trnil
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value (trcons i v1 vr).

Hint Constructors value.

(** Utility functions for extracting one field from record type or
    term: *)

Fixpoint Tlookup (i:id) (Tr:ty) : option ty :=
  match Tr with
  | TRCons i' T Tr' => if beq_id i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:id) (tr:tm) : option tm :=
  match tr with
  | trcons i' t tr' => if beq_id i i' then Some t else tlookup i tr'
  | _ => None
  end.

(** The [step] function uses the term-level lookup function (for the
    projection rule), while the type-level lookup is needed for
    [has_type]. *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (tapp (tabs x T11 t12) v2) ==> ([x:=v2]t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1 t2')
  | ST_Proj1 : forall t1 t1' i,
        t1 ==> t1' ->
        (tproj t1 i) ==> (tproj t1' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
        (tproj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (trcons i t1 tr2) ==> (trcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (trcons i v1 tr2) ==> (trcons i v1 tr2')

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1" | Case_aux c "ST_App2"
  | Case_aux c "ST_Proj1" | Case_aux c "ST_ProjRcd"
  | Case_aux c "ST_Rcd_Head" | Case_aux c "ST_Rcd_Tail" ].

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

(* ###################################################################### *)
(** *** Typing *)

Definition context := partial_map ty.

(** Next we define the typing rules.  These are nearly direct
    transcriptions of the inference rules shown above.  The only major
    difference is the use of [well_formed_ty].  In the informal
    presentation we used a grammar that only allowed well formed
    record types, so we didn't have to add a separate check.

    We'd like to set things up so that that whenever [has_type Gamma t
    T] holds, we also have [well_formed_ty T].  That is, [has_type]
    never assigns ill-formed types to terms.  In fact, we prove this
    theorem below.

    However, we don't want to clutter the definition of [has_type]
    with unnecessary uses of [well_formed_ty].  Instead, we place
    [well_formed_ty] checks only where needed - where an inductive
    call to [has_type] won't already be checking the well-formedness
    of a type.

    For example, we check [well_formed_ty T] in the [T_Var] case,
    because there is no inductive [has_type] call that would
    enforce this.  Similarly, in the [T_Abs] case, we require a
    proof of [well_formed_ty T11] because the inductive call to
    [has_type] only guarantees that [T12] is well-formed.

    In the rules you must write, the only necessary [well_formed_ty]
    check comes in the [tnil] case.  *)

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      has_type Gamma (tvar x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tabs x T11 t12) (TArrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (TArrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (tapp t1 t2) T2
  (* records: *)
  | T_Proj : forall Gamma i t Ti Tr,
      has_type Gamma t Tr ->
      Tlookup i Tr = Some Ti ->
      has_type Gamma (tproj t i) Ti
  | T_RNil : forall Gamma,
      has_type Gamma trnil TRNil
  | T_RCons : forall Gamma i t T tr Tr,
      has_type Gamma t T ->
      has_type Gamma tr Tr ->
      record_ty Tr ->
      record_tm tr ->
      has_type Gamma (trcons i t tr) (TRCons i T Tr).

Hint Constructors has_type.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
  | Case_aux c "T_Proj" | Case_aux c "T_RNil" | Case_aux c "T_RCons" ].

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

(** **** Exercise: 2 stars (examples) *)
(** Finish the proofs. *)

(** Feel free to use Coq's automation features in this proof.
    However, if you are not confident about how the type system works,
    you may want to carry out the proof first using the basic
    features ([apply] instead of [eapply], in particular) and then
    perhaps compress it using automation. *)

Lemma typing_example_2 :
  has_type empty
    (tapp (tabs a (TRCons i1 (TArrow A A)
                      (TRCons i2 (TArrow B B)
                       TRNil))
              (tproj (tvar a) i2))
            (trcons i1 (tabs a A (tvar a))
            (trcons i2 (tabs a B (tvar a))
             trnil)))
    (TArrow B B).
Proof.
  (* FILL IN HERE *) Admitted.

(** Before starting to prove this fact (or the one above!), make sure
    you understand what it is saying. *)

Example typing_nonexample :
  ~ exists T,
      has_type (extend empty a (TRCons i2 (TArrow A A)
                                TRNil))
               (trcons i1 (tabs a B (tvar a)) (tvar a))
               T.
Proof.
  (* FILL IN HERE *) Admitted.

Example typing_nonexample_2 : forall y,
  ~ exists T,
    has_type (extend empty y A)
           (tapp (tabs a (TRCons i1 A TRNil)
                     (tproj (tvar a) i1))
                   (trcons i1 (tvar y) (trcons i2 (tvar y) trnil)))
           T.
Proof.
  (* FILL IN HERE *) Admitted.

(* ###################################################################### *)
(** ** Properties of Typing *)

(** The proofs of progress and preservation for this system are
    essentially the same as for the pure simply typed lambda-calculus,
    but we need to add some technical lemmas involving records. *)

(* ###################################################################### *)
(** *** Well-Formedness *)

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  T_cases (induction T) Case; intros; try solve by inversion.
  Case "TRCons".
    inversion H. subst. unfold Tlookup in H0.
    remember (beq_id i i0) as b. destruct b; subst...
    inversion H0. subst...  Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr ==> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; auto.
Qed.

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  has_type_cases (induction Htyp) Case...
  Case "T_App".
    inversion IHHtyp1...
  Case "T_Proj".
    eapply wf_rcd_lookup...
Qed.

(* ###################################################################### *)
(** *** Field Lookup *)

(** Lemma: If [empty |- v : T] and [Tlookup i T] returns [Some Ti],
     then [tlookup i v] returns [Some ti] for some term [ti] such
     that [has_type empty ti Ti].

    Proof: By induction on the typing derivation [Htyp].  Since
      [Tlookup i T = Some Ti], [T] must be a record type, this and
      the fact that [v] is a value eliminate most cases by inspection,
      leaving only the [T_RCons] case.

      If the last step in the typing derivation is by [T_RCons], then
      [t = trcons i0 t tr] and [T = TRCons i0 T Tr] for some [i0],
      [t], [tr], [T] and [Tr].

      This leaves two possiblities to consider - either [i0 = i] or
      not.

      - If [i = i0], then since [Tlookup i (TRCons i0 T Tr) = Some
        Ti] we have [T = Ti].  It follows that [t] itself satisfies
        the theorem.

      - On the other hand, suppose [i <> i0].  Then
        Tlookup i T = Tlookup i Tr
        and
        tlookup i t = tlookup i tr,
        so the result follows from the induction hypothesis. [] *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  Tlookup i T = Some Ti ->
  exists ti, tlookup i v = Some ti /\ has_type empty ti Ti.
Proof with eauto.
  intros v T i Ti Hval Htyp Hget.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Htyp) Case; subst; try solve by inversion...
  Case "T_RCons".
    simpl in Hget. simpl. destruct (beq_id i i0).
    SCase "i is first".
      simpl. inversion Hget. subst.
      exists t...
    SCase "get tail".
      destruct IHHtyp2 as [vi [Hgeti Htypi]]...
      inversion Hval... Qed.

(* ###################################################################### *)
(** *** Progress *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  (* Theorem: Suppose empty |- t : T.  Then either
       1. t is a value, or
       2. t ==> t' for some t'.
     Proof: By induction on the given typing derivation. *)
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  has_type_cases (induction Ht) Case; intros HeqGamma; subst.
  Case "T_Var".
    (* The final rule in the given typing derivation cannot be [T_Var],
       since it can never be the case that [empty |- x : T] (since the
       context is empty). *)
    inversion H.
  Case "T_Abs".
    (* If the [T_Abs] rule was the last used, then [t = tabs x T11 t12],
       which is a value. *)
    left...
  Case "T_App".
    (* If the last rule applied was T_App, then [t = t1 t2], and we know
       from the form of the rule that
         [empty |- t1 : T1 -> T2]
         [empty |- t2 : T1]
       By the induction hypothesis, each of t1 and t2 either is a value
       or can take a step. *)
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
      (* If both [t1] and [t2] are values, then we know that
         [t1 = tabs x T11 t12], since abstractions are the only values
         that can have an arrow type.  But
         [(tabs x T11 t12) t2 ==> [x:=t2]t12] by [ST_AppAbs]. *)
        inversion H; subst; try (solve by inversion).
        exists ([x:=t2]t12)...
      SSCase "t2 steps".
        (* If [t1] is a value and [t2 ==> t2'], then [t1 t2 ==> t1 t2']
           by [ST_App2]. *)
        destruct H0 as [t2' Hstp]. exists (tapp t1 t2')...
    SCase "t1 steps".
      (* Finally, If [t1 ==> t1'], then [t1 t2 ==> t1' t2] by [ST_App1]. *)
      destruct H as [t1' Hstp]. exists (tapp t1' t2)...
  Case "T_Proj".
    (* If the last rule in the given derivation is [T_Proj], then
       [t = tproj t i] and
           [empty |- t : (TRcd Tr)]
       By the IH, [t] either is a value or takes a step. *)
    right. destruct IHHt...
    SCase "rcd is value".
      (* If [t] is a value, then we may use lemma
         [lookup_field_in_value] to show [tlookup i t = Some ti] for
         some [ti] which gives us [tproj i t ==> ti] by [ST_ProjRcd]
         *)
      destruct (lookup_field_in_value _ _ _ _ H0 Ht H) as [ti [Hlkup _]].
      exists ti...
    SCase "rcd_steps".
      (* On the other hand, if [t ==> t'], then [tproj t i ==> tproj t' i]
         by [ST_Proj1]. *)
      destruct H0 as [t' Hstp]. exists (tproj t' i)...
  Case "T_RNil".
    (* If the last rule in the given derivation is [T_RNil], then
       [t = trnil], which is a value. *)
    left...
  Case "T_RCons".
    (* If the last rule is [T_RCons], then [t = trcons i t tr] and
         [empty |- t : T]
         [empty |- tr : Tr]
       By the IH, each of [t] and [tr] either is a value or can take
       a step. *)
    destruct IHHt1...
    SCase "head is a value".
      destruct IHHt2; try reflexivity.
      SSCase "tail is a value".
      (* If [t] and [tr] are both values, then [trcons i t tr]
         is a value as well. *)
        left...
      SSCase "tail steps".
        (* If [t] is a value and [tr ==> tr'], then
           [trcons i t tr ==> trcons i t tr'] by
           [ST_Rcd_Tail]. *)
        right. destruct H2 as [tr' Hstp].
        exists (trcons i t tr')...
    SCase "head steps".
      (* If [t ==> t'], then
         [trcons i t tr ==> trcons i t' tr]
         by [ST_Rcd_Head]. *)
      right. destruct H1 as [t' Hstp].
      exists (trcons i t' tr)...  Qed.

(* ###################################################################### *)
(** *** Context Invariance *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  | afi_proj : forall x t i,
     appears_free_in x t ->
     appears_free_in x (tproj t i)
  | afi_rhead : forall x i ti tr,
      appears_free_in x ti ->
      appears_free_in x (trcons i ti tr)
  | afi_rtail : forall x i ti tr,
      appears_free_in x tr ->
      appears_free_in x (trcons i ti tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  has_type_cases (induction H) Case;
    intros Gamma' Heqv...
  Case "T_Var".
    apply T_Var... rewrite <- Heqv...
  Case "T_Abs".
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold extend. remember (beq_id x y) as e.
    destruct e...
  Case "T_App".
    apply T_App with T1...
  Case "T_RCons".
    apply T_RCons...  Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  has_type_cases (induction Htyp) Case; inversion Hafi; subst...
  Case "T_Abs".
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold extend in Hctx.
    apply not_eq_beq_id_false in H3. rewrite H3 in Hctx...
Qed.

(* ###################################################################### *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (extend Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  (* Theorem: If Gamma,x:U |- t : S and empty |- v : U, then
     Gamma |- ([x:=v]t) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow directly
     from the IH, with the exception of tvar, tabs, trcons.
     The former aren't automatic because we must reason about how the
     variables interact. In the case of trcons, we must do a little
     extra work to show that substituting into a term doesn't change
     whether it is a record term. *)
  t_cases (induction t) Case;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  Case "tvar".
    simpl. rename i into y.
    (* If t = y, we know that
         [empty |- v : U] and
         [Gamma,x:U |- y : S]
       and, by inversion, [extend Gamma x U y = Some S].  We want to
       show that [Gamma |- [x:=v]y : S].

       There are two cases to consider: either [x=y] or [x<>y]. *)
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then we know that [U = S], and that [[x:=v]y = v].
       So what we really must show is that if [empty |- v : U] then
       [Gamma |- v : U].  We have already proven a more general version
       of this theorem, called context invariance. *)
      apply beq_id_eq in Heqe. subst.
      unfold extend in H0. rewrite <- beq_id_refl in H0.
      inversion H0; subst. clear H0.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
    (* If [x <> y], then [Gamma y = Some S] and the substitution has no
       effect.  We can show that [Gamma |- y : S] by [T_Var]. *)
      apply T_Var... unfold extend in H0. rewrite <- Heqe in H0...
  Case "tabs".
    rename i into y. rename t into T11.
    (* If [t = tabs y T11 t0], then we know that
         [Gamma,x:U |- tabs y T11 t0 : T11->T12]
         [Gamma,x:U,y:T11 |- t0 : T12]
         [empty |- v : U]
       As our IH, we know that forall S Gamma,
         [Gamma,x:U |- t0 : S -> Gamma |- [x:=v]t0 S].

       We can calculate that
         [x:=v]t = tabs y T11 (if beq_id x y then t0 else [x:=v]t0)
       And we must show that [Gamma |- [x:=v]t : T11->T12].  We know
       we will do so using [T_Abs], so it remains to be shown that:
         [Gamma,y:T11 |- if beq_id x y then t0 else [x:=v]t0 : T12]
       We consider two cases: [x = y] and [x <> y].
    *)
    apply T_Abs...
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then the substitution has no effect.  Context
       invariance shows that [Gamma,y:U,y:T11] and [Gamma,y:T11] are
       equivalent.  Since the former context shows that [t0 : T12], so
       does the latter. *)
      eapply context_invariance...
      apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend.
      destruct (beq_id y x)...
    SCase "x<>y".
    (* If [x <> y], then the IH and context invariance allow us to show that
         [Gamma,x:U,y:T11 |- t0 : T12]       =>
         [Gamma,y:T11,x:U |- t0 : T12]       =>
         [Gamma,y:T11 |- [x:=v]t0 : T12] *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      remember (beq_id y z) as e0. destruct e0...
      apply beq_id_eq in Heqe0. subst.
      rewrite <- Heqe...
  Case "trcons".
    apply T_RCons... inversion H7; subst; simpl...
Qed.

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  (* Theorem: If [empty |- t : T] and [t ==> t'], then [empty |- t' : T]. *)
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.  Many cases are
     contradictory ([T_Var], [T_Abs]) or follow directly from the IH
     ([T_RCons]).  We show just the interesting ones. *)
  has_type_cases (induction HT) Case;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    (* If the last rule used was [T_App], then [t = t1 t2], and three rules
       could have been used to show [t ==> t']: [ST_App1], [ST_App2], and
       [ST_AppAbs]. In the first two cases, the result follows directly from
       the IH. *)
    inversion HE; subst...
    SCase "ST_AppAbs".
      (* For the third case, suppose
           [t1 = tabs x T11 t12]
         and
           [t2 = v2].  We must show that [empty |- [x:=v2]t12 : T2].
         We know by assumption that
             [empty |- tabs x T11 t12 : T1->T2]
         and by inversion
             [x:T1 |- t12 : T2]
         We have already proven that substitution_preserves_typing and
             [empty |- v2 : T1]
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  Case "T_Proj".
  (* If the last rule was [T_Proj], then [t = tproj t1 i].  Two rules
     could have caused [t ==> t']: [T_Proj1] and [T_ProjRcd].  The typing
     of [t'] follows from the IH in the former case, so we only
     consider [T_ProjRcd].

     Here we have that [t] is a record value.  Since rule T_Proj was
     used, we know [has_type empty t Tr] and [Tlookup i Tr = Some
     Ti] for some [i] and [Tr].  We may therefore apply lemma
     [lookup_field_in_value] to find the record element this
     projection steps to. *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Htyp]].
    rewrite H4 in Hget. inversion Hget. subst...
  Case "T_RCons".
  (* If the last rule was [T_RCons], then [t = trcons i t tr] for
     some [i], [t] and [tr] such that [record_tm tr].  If the step is
     by [ST_Rcd_Head], the result is immediate by the IH.  If the step
     is by [ST_Rcd_Tail], [tr ==> tr2'] for some [tr2'] and we must also
     use lemma [step_preserves_record_tm] to show [record_tm tr2']. *)
    apply T_RCons... eapply step_preserves_record_tm...
Qed.
(** [] *)

End STLCExtendedRecords.


Set Implicit Arguments.
Unset Strict Implicit.

Require Export ordinal_arith.

Module nNum_ring. (*actually quasiring but too long to bother*)
Export Ordinal. Export Cardinal.
Import Ordinal_arith.
Import Cardinal_arith.
Export Ordered_lci.

Definition nPlus := caPlus.
Definition nMult := caMult.
Definition nLeq := sub.
Definition n0 := emptyset.
Definition n1 := oS emptyset.

Lemma nPlus_oPlus : forall x, inc x nNum -> forall y, inc y nNum ->
nPlus x y = oPlus x y.
Proof.
intros x Hx. ap nNum_rect;uf nPlus;ir.
rw caPlus_N_0_r. rw oPlus_0_r. tv. am.
rw caPlus_N_S. rw oPlus_S. ap uneq. am.
apply nNum_ordinal;am. am. am.
Qed.

Lemma nMult_oMult : forall x, inc x nNum -> forall y, inc y nNum ->
nMult x y = oMult x y.
Proof.
uf nMult;intros x Hx;ap nNum_rect;ir.
rw caMult_0_r. rw oMult_0_r. tv.
rw caMult_N_S. rw oMult_S. wr H0.
wr nPlus_oPlus. tv. ap caMult_N_lci.
am. am. am. apply nNum_ordinal;am.
am. am.
Qed.

Lemma nPlus_0 : forall x, inc x nNum -> nPlus x n0 = x.
Proof.
ir. uf n0. uf nPlus. ap caPlus_N_0_r. am.
Qed.

Lemma nPlus_comm : forall x y, nPlus x y = nPlus y x.
Proof.
uf nPlus. ap caPlus_comm.
Qed.

Lemma nMult_comm : forall x y, nMult x y = nMult y x.
Proof.
uf nMult;ap caMult_comm.
Qed.

Lemma nPlus_assoc : forall x y z, nPlus x (nPlus y z) = nPlus (nPlus x y) z.
Proof.
uf nPlus;ap caPlus_assoc.
Qed.

Lemma nMult_assoc : forall x y z, nMult x (nMult y z) = nMult (nMult x y) z.
Proof.
ap caMult_assoc.
Qed.

Lemma nMult_distrib_r : forall x y z, nMult (nPlus x y) z = nPlus (nMult x z) (nMult y z).
Proof.
ir;ap caMult_distrib_r.
Qed.

Lemma nMult_distrib_l : forall x y z, nMult x (nPlus y z) = nPlus (nMult x y) (nMult x z).
Proof.
ir. ap caMult_distrib_l.
Qed.

Lemma nPlus_0_l : forall x, inc x nNum -> nPlus n0 x = x.
Proof.
ir. rw nPlus_comm. ap nPlus_0. am.
Qed.

Lemma nMult_0 : forall x, nMult x n0 = n0.
Proof.
ir. uf nMult. rw caMult_0_r. tv.
Qed.

Lemma nMult_0_l : forall x, nMult n0 x = n0.
Proof.
ir;rw nMult_comm;ap nMult_0.
Qed.

Lemma nPlus_S : forall x, inc x nNum -> forall y, inc y nNum ->
nPlus x (oS y) = oS (nPlus x y).
Proof.
uf nPlus. ap caPlus_N_S.
Qed.

Lemma nMult_S : forall x, inc x nNum -> forall y, inc y nNum ->
nMult x (oS y) = nPlus (nMult x y) x.
Proof.
uf nPlus;uf nMult;ap caMult_N_S.
Qed.

Lemma nPlus_S_l : forall x, inc x nNum -> forall y, inc y nNum ->
nPlus (oS x) y = oS (nPlus x y).
Proof.
ir.
rw nPlus_comm. rw nPlus_S. ap uneq. ap nPlus_comm.
am. am.
Qed.

Lemma nMult_S_l : forall x, inc x nNum -> forall y, inc y nNum ->
nMult (oS x) y = nPlus y (nMult x y).
Proof.
ir. rw nMult_comm. rw nMult_S;au.
rw nMult_comm;ap nPlus_comm.
Qed.

Lemma n0_inc : inc n0 nNum.
Proof.
ap emptyset_N.
Qed.

Lemma n1_inc : inc n1 nNum.
Proof.
ap oS_nNum. ap emptyset_N.
Qed.

Lemma nPlus_lci : is_lci nPlus nNum.
Proof.
uf nPlus;ap caPlus_N_lci.
Qed.

Lemma nMult_lci : is_lci nMult nNum.
Proof.
ap caMult_N_lci.
Qed.

Ltac nSolveS := match goal with
  | |- inc n0 nNum => exact (n0_inc)
  | |- inc emptyset nNum => exact (n0_inc)
  | |- inc n1 nNum => exact (n1_inc)
  | |- inc (oS emptyset) nNum => exact (n1_inc)
  | |- inc (oS _) nNum => ap oS_nNum;nSolveS
  | |- inc (nPlus _ _) nNum => ap nPlus_lci;nSolveS
  | |- inc (nMult _ _) nNum => ap nMult_lci;nSolveS
  | |- inc _ nNum => try am
  | |- nLeq emptyset _ => ap emptyset_sub_all
  | |- nLeq n0 _ => ap emptyset_sub_all
  | |- nLeq ?x ?x => ap sub_refl
  | |- nLeq ?x (oS ?x) => ap oS_sub
  | |- sub n0 _ => ap emptyset_sub_all
  | |- sub emptyset _ => ap emptyset_sub_all
  | |- sub ?x ?x => ap sub_refl
  | |- sub ?x (oS ?x) => ap oS_sub
  | _ => try tv
  end.

Lemma nMult_1 : forall x, inc x nNum -> nMult x n1 = x.
Proof.
ir. uf n1;rw nMult_S;nSolveS.
rw nMult_0. rw nPlus_0_l;nSolveS.
Qed.

Lemma nMult_1_l : forall x, inc x nNum -> nMult n1 x = x.
Proof.
ir;rw nMult_comm;ap nMult_1;am.
Qed.

Lemma oS_emptyset_neq : forall x, oS x <> emptyset.
Proof.
uhg;ir. apply emptyset_empty with x;wr H;rw oS_inc;au.
Qed.

Lemma nMult_pow : forall x, inc x nNum -> forall y, inc y nNum ->
nMult x y = Pow.pow nPlus n0 x y.
Proof.
intros x Hx;ap nNum_rect;ir.
rw nMult_0. symmetry. ap nNum_repeat_0.
rw nMult_S;nSolveS.
rw Pow.pow_S. wr H0.
ap nPlus_comm. am.
Qed.

Lemma nPlus_n0_neutre : is_neutre nPlus nNum n0.
Proof.
uhg;ee;nSolveS. ap nPlus_0. ap nPlus_0_l.
Qed.

Lemma nMult_n1_neutre : is_neutre nMult nNum n1.
Proof.
uhg;ee. nSolveS.
ap nMult_1. ap nMult_1_l.
Qed.

Lemma nPlus_N_assoc : associative nPlus nNum.
Proof.
uhg;ir;ap nPlus_assoc.
Qed.

Lemma nMult_N_assoc : associative nMult nNum.
Proof.
uhg;ir;ap nMult_assoc.
Qed.

Lemma nPlus_monoid : is_monoid nPlus nNum n0.
Proof.
ap caPlus_N_monoid.
Qed.

Lemma nMult_monoid : is_monoid nMult nNum n1.
Proof.
ap caMult_N_monoid.
Qed.

Lemma nPlus_reg_r : is_reg_r nPlus nNum.
Proof.
uhg.
assert (forall y y', inc y nNum -> inc y' nNum -> forall x, inc x nNum ->
nPlus y x = nPlus y' x -> y=y').
intros y y' Hy Hy'. pose (p := fun x => nPlus y x = nPlus y' x -> y=y').
assert (forall x, inc x nNum -> p x);try am.
ap nNum_rect;uf p;ir.
rwi nPlus_0 H;nSolveS. rwi nPlus_0 H;nSolveS.
rwi nPlus_S H1;nSolveS. rwi nPlus_S H1;nSolveS.
apply oS_N_inj in H1;nSolveS. au.
ir;eau.
Qed.

Lemma nPlus_reg_l : is_reg_l nPlus nNum.
Proof.
uhg;ir;eapply nPlus_reg_r.
ap H. am. am.
rw nPlus_comm. rw H2. ap nPlus_comm.
Qed.

Lemma nPlus_reg : is_regular nPlus nNum.
Proof.
uhg;ee. ap nPlus_reg_l. ap nPlus_reg_r.
Qed.

Lemma nPlus_le_l : forall a, inc a nNum -> forall b, sub a (nPlus a b).
Proof.
ir. apply sub_trans with (card a).
rw nNum_card. ap sub_refl. am.
ap iso_sub_card_sub.
rw iso_sub_rw. exists (L a (fun x => J emptyset x)).
ap map_of_injective.
uhg;ee;uhg;ir. ap union2_l.
ap product_pair_inc. ap singleton_inc.
am.
apply pair_eq in H2;ee;am.
Qed.

Lemma nPlus_le_r : forall a, inc a nNum -> forall b, sub a (nPlus b a).
Proof.
ir. rw nPlus_comm. ap nPlus_le_l;am.
Qed.

Lemma nPlus_0eq : forall a b, nPlus a b = n0 -> (a=n0 & b=n0).
Proof.
ap caPlus_0eq.
Qed.

Lemma nMult_integral_all : forall x y, nMult x y = n0 -> (x=n0 \/ y=n0).
Proof.
ap caMult_integral.
Qed.

Lemma nMult_integral : is_integral nMult nNum n0.
Proof.
uhg;ir;ap nMult_integral_all;am.
Qed.

Lemma nMult_distributes : distributes nPlus nMult nNum.
Proof.
ap caMult_N_distrib.
Qed.

Lemma nPlus_N_comm : commutative nPlus nNum.
Proof.
uhg;ir;ap nPlus_comm.
Qed.

Lemma nMult_N_comm : commutative nMult nNum.
Proof.
uhg;ir;ap nMult_comm.
Qed.

Lemma nNum_quasiring : is_quasiring nPlus nMult nNum n0 n1.
Proof.
ap ca_N_quasiring.
Qed.

Lemma nMult_1eq : forall x, inc x nNum -> forall y, inc y nNum ->
nMult x y = n1 -> (x=n1 & y=n1).
Proof.
uf n1;ir.
apply nNum_destruct in H0. nin H0;subst.
rwi nMult_0 H1. edestruct oS_emptyset_neq.
symmetry;am.
ap PropGuard_use.
nin H0;ee;subst.

apply nNum_destruct in H;nin H;subst.
rwi nMult_0_l H1;nSolveS.  edestruct oS_emptyset_neq.
symmetry;am.
nin H;ee;subst.
rwi nMult_S H1;nSolveS. rwi nPlus_S H1;nSolveS.
apply oS_N_inj in H1;nSolveS.
apply nPlus_0eq in H1.
ee;subst.
rwi nMult_comm  H1. rwi nMult_S H1;nSolveS.
rwi nMult_0 H1. rwi nPlus_0_l H1;nSolveS.
subst. constructor. ee;tv.
Qed.

Lemma nLeq_rw : forall x, inc x nNum -> forall y, inc y nNum ->
nLeq x y = (exists z, inc z nNum & y = nPlus x z).
Proof.
ir. etransitivity.
uf nLeq. ap iff_eq. ap ordinal_sub_ex;ap nNum_ordinal;am.
ir. nin H1;ee. subst.
ap oPlus_sub_l. ap nNum_ordinal;am.
am.

ap iff_eq;ir;nin H1;ee;subst.
exists x0;dj.
cp (nNum_ordinal H).
rw ordinal_inc_not_sub;au.
uhg;ir. assert (sub x0 (oPlus x x0)).
ap oPlus_sub_r. am. am.
cp (sub_trans H3 H4).
assert (sub (oPlus x x0) nNum). ap omega_ordinal.
am. cp (extensionality H5 H6).
wri H7 H0. eapply omega_ordinal. ap H0.
am. ap omega_ordinal.
symmetry. ap nPlus_oPlus. am. am.
exists x0;ee;au. ap nNum_ordinal;am.
ap nPlus_oPlus;am.
Qed.

Definition nLt := lt_of nLeq.

Lemma nLt_inc_rw : forall x, inc x nNum -> forall y, inc y nNum ->
nLt x y = inc x y.
Proof.
ir. uf nLt. uf nLeq. ap ordinal_inc_lt_of;ap nNum_ordinal;am.
Qed.

Lemma inc_nLt : forall x, inc x nNum -> forall y, inc y x -> nLt y x.
Proof.
ir. assert (inc y nNum).
cp (and_P omega_ordinal). eapply H1. am. am.
rw nLt_inc_rw;au.
Qed.

Lemma nLt_S : forall x y, inc y nNum -> nLeq (oS x) y -> nLt x y.
Proof.
ir. ap inc_nLt. am. ap H0. rw oS_inc;au.
Qed.

Lemma nLt_S_rw : forall x, inc x nNum -> forall y, inc y nNum ->
nLt x y = nLeq (oS x) y.
Proof.
ir. rw nLt_inc_rw;au. ap iff_eq;ir.
cp (inc_nLt H0 H1).
nin H2. uhg;uhg;ir. rwi oS_inc H4;nin H4;au. subst.
am. ap H1. rw oS_inc;au.
Qed.

Lemma nLeq_wo : is_well_order nLeq nNum.
Proof.
ap ordinal_sub_wo. ap omega_ordinal.
Qed.

Lemma nLeq_to : is_total_order nLeq nNum.
Proof.
ap well_order_total_order. ap nLeq_wo.
Qed.

Lemma nLeq_total : is_total nLeq nNum.
Proof.
ap well_order_total. ap nLeq_wo.
Qed.

Lemma nLeq_S_S : forall x, inc x nNum -> forall y, inc y nNum ->
nLeq x y = nLeq (oS x) (oS y).
Proof.
ir;ap iff_eq;ir.
uhg;uhg;ir.
rwi oS_inc H2;nin H2;rw oS_inc;au. subst.
uh H1. rwi ordinal_sub_leq_of H1. am.
ap nNum_ordinal;am. ap nNum_ordinal;am.
ufi nLeq H1. uf nLeq.
destruct (nLeq_total H H0).
am.
uh H2. apply by_cases with (inc y (oS x));ir.
assert (x=y);subst;nSolveS.
ap oS_N_inj;au. ap extensionality. am.
fold nLeq. wr nLt_S_rw;nSolveS. uhg;uhg;ee.
uhg;uhg;ir;rw oS_inc;au.
ap ordinal_inc_neq;au. ap nNum_ordinal;nSolveS.
apply sub_trans with (oS x).
nSolveS.
uhg;ir. cp (H1 a H4).
rwi oS_inc H5;nin H5. am.
subst. nin H3;am.
Qed.

Lemma nLt_S_S : forall x, inc x nNum -> forall y, inc y nNum ->
nLt x y = nLt (oS x) (oS y).
Proof.
ir. rw nLt_S_rw;nSolveS. rw nLt_S_rw;nSolveS.
ap nLeq_S_S;nSolveS.
Qed.

Lemma nLeq_nPlus_compat : is_compatible nLeq nPlus nNum.
Proof.
ap invariant_compat. ap sub_is_order.
ap nPlus_lci.
uhg. dj.
uhg;ir.
rwi nLeq_rw H2;au. nin H2;ee;subst.
rw nLeq_rw;nSolveS.
exists x0;ee. am.
wr nPlus_assoc. rw (nPlus_comm x0). rw nPlus_assoc.
tv.

uhg;ir. rw nPlus_comm. rw (nPlus_comm x).
ap H;am.
Qed.

Lemma nPlus_ordered_monoid : is_ordered_monoid nLeq nPlus nNum n0.
Proof.
uhg;ee. ap sub_is_order. ap nPlus_monoid.
ap nLeq_nPlus_compat.
Qed.

Lemma nLeq_nMult_compat : is_compatible nLeq nMult nNum.
Proof.
ap invariant_compat. ap sub_is_order.
ap nMult_lci.
uhg. dj;uhg;ir.
rwi nLeq_rw H2;nSolveS;rw nLeq_rw;nSolveS.
nin H2;ee;subst.
rw nMult_distrib_r.
exists (nMult x0 x).
ee;nSolveS.
rw nMult_comm. rw (nMult_comm x). ap H;am.
Qed.

Lemma nMult_reg_l : forall x, inc x nNum -> x<>emptyset ->
forall a, inc a nNum -> forall b, inc b nNum ->
nMult x a = nMult x b ->
a=b.
Proof.
pose (p := fun a => forall x, inc x nNum -> forall b, inc b nNum ->
nMult (oS x) a = nMult (oS x) b -> a=b).
assert (forall a, inc a nNum -> p a).
ap nNum_rect;uf p;clear p;ir.
rwi nMult_0 H1. symmetry in H1. apply nMult_integral in H1;nSolveS.
nin H1;subst;au. edestruct oS_emptyset_neq. am.

apply nNum_destruct in H2;nin H2;subst.
rwi nMult_0 H3. apply nMult_integral in H3;nSolveS.
nin H3;edestruct oS_emptyset_neq;am.
nin H2;ee;subst.
rwi nMult_S H3;nSolveS.
rwi nMult_S H3;nSolveS.
apply nPlus_reg_r in H3;nSolveS.
ap uneq. eau.

ufi p H;clear p.
ir. apply nNum_destruct in H0;nin H0;subst. nin H1;tv.
nin H0;ee;subst.
eau.
Qed.

Lemma nMult_reg_r : forall x, inc x nNum -> x<>emptyset ->
forall a, inc a nNum -> forall b, inc b nNum ->
nMult a x = nMult b x ->
a=b.
Proof.
ir. eapply nMult_reg_l.
ap H. am. am. am.
rw nMult_comm;rw H3. ap nMult_comm.
Qed.

Lemma nLt_nLeq_trans : forall x y, nLt x y -> forall z, nLeq y z -> nLt x z.
Proof.
ap subLt_sub_trans.
Qed.

Lemma nLeq_nLt_trans : forall x y, nLeq x y -> forall z, nLt y z -> nLt x z.
Proof.
ap sub_subLt_trans.
Qed.

Lemma nLt_trans : forall x y, nLt x y -> forall z, nLt y z -> nLt x z.
Proof.
intros x y H. ap nLeq_nLt_trans. am.
Qed.

Lemma nLeq_nPlus_reg_r : forall x, inc x nNum ->
forall a, inc a nNum -> forall b, inc b nNum ->
nLeq (nPlus a x) (nPlus b x) -> nLeq a b.
Proof.
ir. rw nLeq_rw;nSolveS. rwi nLeq_rw H2;nSolveS.
nin H2;ee;subst.
exists x0. ee. am.
apply nPlus_reg_r with x. am. am. nSolveS.
rw H3. repeat wr nPlus_assoc.
ap uneq. ap nPlus_comm.
Qed.

Lemma nLeq_nPlus_reg_l : forall x, inc x nNum ->
forall a, inc a nNum -> forall b, inc b nNum ->
nLeq (nPlus x a) (nPlus x b) -> nLeq a b.
Proof.
intros x Hx a Ha b Hb.
rw nPlus_comm. rw (nPlus_comm x). ap nLeq_nPlus_reg_r;am.
Qed.

Lemma nLeq_nMult_reg_l : forall a, inc a nNum -> a<>n0 ->
forall x, inc x nNum -> forall y, inc y nNum -> nLeq (nMult a x) (nMult a y) ->
nLeq x y.
Proof.
ir.
rw (leq_not_lt nLeq_to);try am.
uhg;ir. nin H4.
assert (nMult a x = nMult a y).
ap extensionality;fold nLeq;try am.
ap nLeq_nMult_compat;try am.
ap sub_refl.
ap H5. apply nMult_reg_l with a.
am. am. am. am. au.
Qed.

Lemma nLeq_nMult_reg_r : forall a, inc a nNum -> a<>n0 ->
forall x, inc x nNum -> forall y, inc y nNum -> nLeq (nMult x a) (nMult y a) ->
nLeq x y.
Proof.
ir. apply nLeq_nMult_reg_l with a;try am.
rw nMult_comm. rw (nMult_comm a). am.
Qed.

End nNum_ring.

Module Pow_nNum.
Export Pow. Export nNum_ring.
Import Ordinal. (*for omega*)

Section VarSec.

Variables (law : E2) (g e : E).

Hypothesis (Hmon : is_monoid law g e).

Notation Pow := (pow law e).

Lemma pow_are_inverse : forall x y, Lci.are_inverse law g e x y -> forall n, inc n nNum ->
Lci.are_inverse law g e (Pow x n) (Pow y n).
Proof.
intros x y H. ap nNum_rect.
rw pow_0. rw pow_0.
uhg;ee. am. am.
ap Hmon;am. ap Hmon;am.

ir.
uhg;ee.
ap pow_inc. am. am. ap oS_nNum;am.
ap pow_inc. am. am. ap oS_nNum;am.
erewrite pow_atend;try am.
rw pow_S;try am.
transitivity (law (Pow x n) (law (law x y) (Pow y n))).
assert (is_lci law g);try am.
assert (associative law g);try am.
uh H;ee;uh H1;ee.
repeat rw H3;au.
uh H;ee. rw H3.
assert (is_neutre law g e);try am.
uh H5;ee. rw H7;am.

erewrite pow_atend;try am.
rw pow_S;try am.
transitivity (law (Pow y n) (law (law y x) (Pow x n))).
assert (is_lci law g);try am.
assert (associative law g);try am.
uh H;ee;uh H1;ee.
repeat rw H3;au.
uh H;ee. rw H4.
assert (is_neutre law g e);try am.
uh H5;ee. rw H7;am.
Qed.

Lemma pow_inversible_inverse : forall x, inversible law g e x ->
forall n, inc n nNum -> inverse_of law g e (Pow x n) = Pow (inverse_of law g e x) n.
Proof.
ir.
nin H. assert (x0 = inverse_of law g e x).
eapply Lci.inverse_unicity. am. am. ap inversible_inverse_of.
am. exists x0;am.
wr H1.
cp (pow_are_inverse H H0).
eapply Lci.inverse_unicity. am. Focus 2. am.
ap inversible_inverse_of. am. econstructor;am.
Qed.

Lemma pow_nPlus : forall x, inc x g ->
forall n, inc n nNum -> forall m, inc m nNum ->
Pow x (nPlus n m) = law (Pow x n) (Pow x m).
Proof.
intros x Hx n Hn.
cp (pow_inc Hmon).
ap nNum_rect;ir.
rw nPlus_0;try am. rw pow_0. symmetry. ap Hmon.
ap pow_inc. am. am. am.
rw nPlus_S;try am.
symmetry.
rw pow_S;nSolveS.
assert (associative law g). am.
rw H2;au. wr (pow_atend Hmon);try am.
rw pow_S;au. wr H2;au.
wr H1. symmetry. ap pow_S.
nSolveS.
Qed.

Lemma pow_nPlus_inverse : forall x y, Lci.are_inverse law g e x y ->
forall n, inc n nNum -> forall m, inc m nNum -> law (Pow x (nPlus n m)) (Pow y m) = Pow x n.
Proof.
ir.
cp H. uh H2;ee.
rw pow_nPlus;nSolveS.
cp (pow_inc Hmon).
cp (and_Q (and_Q Hmon)).
wr H7;au.
cp (pow_are_inverse H H1).
uh H8;ee. rw H10.
ap Hmon;au.
Qed.

End VarSec.

(*needs to be out to not require is_monoid*)
Lemma pow_group_inverse : forall law g e, is_group law g e ->
forall x, inc x g -> forall n, inc n nNum -> inverse_of law g e (pow law e x n) = pow law e (inverse_of law g e x) n.
Proof.
intros law g e Hgr x Hx. ap pow_inversible_inverse. ap group_is_monoid;am.
ap Hgr;am.
Qed.

End Pow_nNum.
Export Pow_nNum.