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

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.

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

(** We saw in chapter [MoreStlc] how records can be treated as just
    syntactic sugar for nested uses of products.  This is OK for
    simple examples, but the encoding is informal (in reality, if we
    actually 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.  This chapter
    shows how.

    Recall the informal definitions we gave before: *)

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

       v ::=                          Values:
           | {i=v, ..., i=v}             record value
           | ...

       T ::=                          Types:
           | {i:T, ..., i:T}             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 |- t0 : {..., i:Ti, ...}
                       ------------------------------                   (T_Proj)
                             Gamma |- t0.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 (string * X).

Inductive ty : Type :=
  | Base     : string -> ty
  | Arrow    : 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 (Base i)) ->
        (forall t : ty, P t -> forall t0 : ty, P t0
                            -> P (Arrow 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 the
    principle we obtain 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 standard Coq [list] type, we can essentially incorporate its
    constructors ("nil" and "cons") in the syntax of our types. *)

Inductive ty : Type :=
  | Ty_Base : string -> ty
  | Ty_Arrow : ty -> ty -> ty
  | Ty_RNil : ty
  | Ty_RCons : string -> ty -> ty -> ty.

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

Inductive tm : Type :=
  | tm_var : string -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : string -> ty -> tm -> tm
  (* records *)
  | tm_rproj : tm -> string -> tm
  | tm_rnil :  tm
  | tm_rcons : string -> tm -> tm -> tm.

Declare Custom Entry stlc_ty.

Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "<{{ e }}>" := e (e custom stlc_ty at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "( x )" := x (in custom stlc_ty, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "x" := x (in custom stlc_ty at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc_ty at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99,
                     t custom stlc_ty at level 99,
                     y custom stlc at level 99,
                     left associativity).
Coercion tm_var : string >-> tm.

Notation "{ x }" := x (in custom stlc at level 1, x constr).

Notation "'Base' x" := (Ty_Base x) (in custom stlc_ty at level 0).

Notation "  l ':' t1  '::' t2" := (Ty_RCons l t1 t2) (in custom stlc_ty at level 3, right associativity).
Notation " l := e1 '::' e2" := (tm_rcons l e1 e2) (in custom stlc at level 3, right associativity).
Notation "'nil'" := (Ty_RNil) (in custom stlc_ty).
Notation "'nil'" := (tm_rnil) (in custom stlc).
Notation "o --> l" := (tm_rproj o l) (in custom stlc at level 0).

(** Some examples... *)
Open Scope string_scope.

Notation a := "a".
Notation f := "f".
Notation g := "g".
Notation l := "l".
Notation A := <{{ Base "A" }}>.
Notation B := <{{ Base "B" }}>.
Notation k := "k".
Notation i1 := "i1".
Notation i2 := "i2".

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

(* Check (RCons i1 A RNil). *)

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

(* Check (RCons i1 (Arrow A B)
           (RCons i2 A RNil)). *)

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

(** One issue with generalizing the abstract syntax for records from
    lists to the nil/cons presentation is that it introduces the
    possibility of writing strange types like this... *)

Definition weird_type := <{{  a : 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 ever assigned to terms.  To support this, we
    define predicates [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 [RNil]
    and [RCons] at the outermost level. *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty <{{ nil }}>
  | RTcons : forall i T1 T2,
        record_ty <{{ i : T1 :: T2 }}>.

(** With this, we can define well-formed types. *)

Inductive well_formed_ty : ty -> Prop :=
  | wfBase : forall (i : string),
        well_formed_ty <{{ Base i }}>
  | wfArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty <{{ T1 -> T2 }}>
  | wfRNil :
        well_formed_ty <{{ nil }}>
  | wfRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty <{{ i : T1 :: T2 }}>.

Hint Constructors record_ty well_formed_ty : core.

(** Note that [record_ty] is not recursive -- it just checks 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
    [RCons]) is a record.

    Of course, we should also be concerned about ill-formed terms, not
    just types; but typechecking can rule those out without the help
    of an extra [well_formed_tm] definition because it already
    examines the structure of terms.  All we need is an analog of
    [record_ty] saying that a term is a record term if it is built
    with [trnil] and [rcons]. *)

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm <{ nil }>
  | rtcons : forall i t1 t2,
        record_tm <{ i := t1 :: t2 }>.

Hint Constructors record_tm : core.

(* ----------------------------------------------------------------- *)
(** *** Substitution *)

(** Substitution extends easily. *)

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | tm_var y =>
      if eqb_string x y then s else t
  | <{\y:T, t1}> =>
      if eqb_string x y then t else <{\y:T, [x:=s] t1}>
  | <{t1 t2}> =>
      <{([x:=s] t1) ([x:=s] t2)}>
  | <{ t1 --> i }> =>
      <{ ( [x := s] t1) --> i }>
  | <{ nil }> =>
      <{ nil }>
  | <{ i := t1 :: tr }> =>
     <{ i :=  [x := s] t1 :: ( [x := s] tr) }>
  end

where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc).

(* ----------------------------------------------------------------- *)
(** *** Reduction *)

(** A record is a value if all of its fields are. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T2 t1,
      value  <{ \ x : T2, t1 }>
  | v_rnil : value <{ nil }>
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value <{ i := v1 :: vr }>.

Hint Constructors value : core.

(** To define reduction, we'll need a utility function for extracting
    one field from record term: *)

Fixpoint tlookup (i:string) (tr:tm) : option tm :=
  match tr with
  | <{ i' := t :: tr'}> => if eqb_string i i' then Some t else tlookup i tr'
  | _ => None
  end.

(** The [step] function uses this term-level lookup function in the
    projection rule. *)

Reserved Notation "t '-->' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T2 t1 v2,
         value v2 ->
         <{(\x:T2, t1) v2}> --> <{ [x:=v2]t1 }>
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         <{t1 t2}> --> <{t1' t2}>
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         <{v1 t2}> --> <{v1  t2'}>
  | ST_Proj1 : forall t1 t1' i,
        t1 --> t1' ->
        <{ t1 --> i }> --> <{ t1' --> i }>
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
        <{ tr --> i }> --> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 --> t1' ->
        <{ i := t1 :: tr2 }> --> <{ i := t1' :: tr2 }>
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 --> tr2' ->
        <{ i := v1 :: tr2 }> --> <{ i := v1 :: tr2' }>

where "t '-->' t'" := (step t t').

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

Hint Constructors step : core.

(* ----------------------------------------------------------------- *)
(** *** Typing *)

(** Next we define the typing rules.  These are nearly direct
    transcriptions of the inference rules shown above: the only
    significant 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.

    One sanity condition that we'd like to maintain is that, whenever
    [has_type Gamma t T] holds, will also be the case that
    [well_formed_ty T], so that [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. *)

Fixpoint Tlookup (i:string) (Tr:ty) : option ty :=
  match Tr with
  | <{{ i' : T :: Tr' }}> =>
      if eqb_string i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40,
                                          t custom stlc, T custom stlc_ty at level 0).

Inductive has_type (Gamma : context) :tm -> ty -> Prop :=
  | T_Var : forall x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- x \in T
  | T_Abs : forall x T11 T12 t12,
      well_formed_ty T11 ->
      (x |-> T11; Gamma) |- t12 \in T12 ->
      Gamma |- \x : T11, t12 \in (T11 -> T12)
  | T_App : forall T1 T2 t1 t2,
      Gamma |- t1 \in (T1 -> T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- ( t1 t2) \in T2
  (* records: *)
  | T_Proj : forall i t Ti Tr,
      Gamma |- t \in Tr ->
      Tlookup i Tr = Some Ti ->
      Gamma |- (t --> i) \in Ti
 | T_RNil :
      Gamma |- nil \in nil
  | T_RCons : forall i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- ( i := t :: tr) \in ( i : T :: Tr)

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type : core.

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

(** **** Exercise: 2 stars, standard (examples)

    Finish the proofs below.  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 proofs
    first using the basic features ([apply] instead of [eapply], in
    particular) and then perhaps compress it using automation.  Before
    starting to prove anything, make sure you understand what it is
    saying. *)

Lemma typing_example_2 :
  empty |- (\a : ( i1 : (A -> A) :: i2 : (B -> B) :: nil), a --> i2)
            ( i1 := (\a : A, a) :: i2 := (\a : B,a ) :: nil )  \in (B -> B).
Proof.
  eapply T_App.
  - constructor. constructor; auto. eapply T_Proj.
    + constructor. unfold update. reflexivity. auto.
    + simpl. reflexivity.

  - constructor; auto.
Qed.

Example typing_nonexample :
  ~ exists T,
     (a |-> <{{  i2 : (A -> A) :: nil   }}>) |-
       ( i1 := (\a : B, a) :: a ) \in
               T.
Proof.
  intro.
  destruct H.
  inversion H; subst; clear H.
  inversion H7.
Qed.

Example typing_nonexample_2 : forall y,
  ~ exists T,
    (y |-> A) |-
     (\a : ( i1 : A  :: nil ), a --> i1 )
      ( i1 := y :: i2 := y :: nil )  \in T.
Proof.
  intros y Hcontra.
  inversion Hcontra; clear Hcontra.

  inversion H; subst; clear H.

  (* find out the T1 in T1 -> x *)
  inversion H2; subst; clear H2.
  inversion H7; subst; clear H7.
  simpl in H5.
  inversion H2; subst; clear H2.
  unfold update in *; rewrite t_update_eq in H0.
  inversion H0; subst; clear H0.
  simpl in H5. inversion H5; subst; clear H5.
  clear H1 H3.

  (* find out T1 *)
  inversion H4; subst; clear H4.
  inversion H6.
Qed.
(* ================================================================= *)
(** ** 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.
  induction T; intros; try solve_by_invert.
  - (* RCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (eqb_string i s)...
    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,
  Gamma |- t \in T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* 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 [empty |- ti \in 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 = rcons i0 t tr] and [T = RCons 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 (RCons 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. []

    Here is the formal statement:
*)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  empty |- v \in T ->
  Tlookup i T = Some Ti ->
  exists ti, tlookup i v = Some ti /\ empty |- ti \in Ti.
Proof with eauto.
  intros v T i Ti Hval Htyp Hget.
  remember empty as Gamma.
  induction Htyp; subst; try solve_by_invert...
  - (* T_RCons *)
    simpl in Hget. simpl. destruct (eqb_string i i0).
    + (* i is first *)
      simpl. injection Hget as Hget. subst.
      exists t...
    + (* get tail *)
      destruct IHHtyp2 as [vi [Hgeti Htypi] ]...
      inversion Hval... Qed.

(* ----------------------------------------------------------------- *)
(** *** Progress *)

Theorem progress : forall t T,
     empty |- t \in 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 as Gamma.
  generalize dependent HeqGamma.
  induction Ht; intros HeqGamma; subst.
  - (* 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.
  - (* T_Abs *)
    (* If the [T_Abs] rule was the last used, then
       [t = abs x T11 t12], which is a value. *)
    left...
  - (* 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...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
      (* If both [t1] and [t2] are values, then we know that
         [t1 = abs x T11 t12], since abstractions are the only
         values that can have an arrow type.  But
         [(abs x T11 t12) t2 --> [x:=t2]t12] by [ST_AppAbs]. *)
        inversion H; subst; try solve_by_invert.
        exists <{ [x:=t2]t0 }>...
      * (* t2 steps *)
        (* If [t1] is a value and [t2 --> t2'], then
           [t1 t2 --> t1 t2'] by [ST_App2]. *)
        destruct H0 as [t2' Hstp]. exists <{ t1 t2' }>...
    + (* t1 steps *)
      (* Finally, If [t1 --> t1'], then [t1 t2 --> t1' t2]
         by [ST_App1]. *)
      destruct H as [t1' Hstp]. exists <{ t1' t2 }>...
  - (* T_Proj *)
    (* If the last rule in the given derivation is [T_Proj], then
       [t = rproj t i] and
           [empty |- t : (TRcd Tr)]
       By the IH, [t] either is a value or takes a step. *)
    right. destruct IHHt...
    + (* 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 [rproj i t --> ti] by
         [ST_ProjRcd]. *)
      destruct (lookup_field_in_value _ _ _ _ H0 Ht H)
        as [ti [Hlkup _] ].
      exists ti...
    + (* rcd_steps *)
      (* On the other hand, if [t --> t'], then
         [rproj t i --> rproj t' i] by [ST_Proj1]. *)
      destruct H0 as [t' Hstp]. exists <{ t' --> i }>...
  - (* T_RNil *)
    (* If the last rule in the given derivation is [T_RNil],
       then [t = trnil], which is a value. *)
    left...
  - (* T_RCons *)
    (* If the last rule is [T_RCons], then [t = rcons 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...
    + (* head is a value *)
      destruct IHHt2; try reflexivity.
      * (* tail is a value *)
      (* If [t] and [tr] are both values, then [rcons i t tr]
         is a value as well. *)
        left...
      * (* tail steps *)
        (* If [t] is a value and [tr --> tr'], then
           [rcons i t tr --> rcons i t tr'] by
           [ST_Rcd_Tail]. *)
        right. destruct H2 as [tr' Hstp].
        exists <{ i := t :: tr'}>...
    + (* head steps *)
      (* If [t --> t'], then
         [rcons i t tr --> rcons i t' tr]
         by [ST_Rcd_Head]. *)
      right. destruct H1 as [t' Hstp].
      exists <{ i := t' :: tr }>...  Qed.

(* ================================================================= *)
(** ** Weakening *)

(** The weakening lemma is proved as in pure STLC. *)

Lemma weakening : forall Gamma Gamma' t T,
     inclusion Gamma Gamma' ->
     Gamma  |- t \in T  ->
     Gamma' |- t \in T.
Proof.
  intros Gamma Gamma' t T H Ht.
  generalize dependent Gamma'.
  induction Ht; eauto using inclusion_update.
Qed.

Lemma weakening_empty : forall Gamma t T,
     empty |- t \in T  ->
     Gamma |- t \in T.
Proof.
  intros Gamma t T.
  eapply weakening.
  discriminate.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Preservation *)

  (* As before, we prove the substitution lemma by induction
     on the term t. The only new case (compared to the proof in
     StlcProp.v) is the case of rcons. For this case, we must do a little
     extra work to show that substituting into a term doesn't change
     whetherit is a record term. *)

Lemma substitution_preserves_typing : forall Gamma x U t v T,
  (x |-> U ; Gamma) |- t \in T ->
  empty |- v \in U   ->
  Gamma |- [x:=v]t \in T.
Proof.
  intros Gamma x U t v T Ht Hv.
  generalize dependent Gamma. generalize dependent T.
  induction t; intros T Gamma H;
  (* in each case, we'll want to get at the derivation of H *)
    inversion H; clear H; subst; simpl; eauto.
  - (* var *)
    rename s into y. destruct (eqb_stringP x y); subst.
    + (* x=y *)
      rewrite update_eq in H1.
      injection H1 as H1; subst.
      apply weakening_empty. assumption.
    + (* x<>y *)
      apply T_Var. rewrite update_neq in H1; auto. assumption.
  - (* abs *)
    rename s into y, t into T.
    destruct (eqb_stringP x y); subst; apply T_Abs; try assumption.
    + (* x=y *)
      rewrite update_shadow in H5. assumption.
    + (* x<>y *)
      apply IHt.
      rewrite update_permute; auto.
  - (* rcons *)   (* <=== only new case compared to pure STLC *)
     apply T_RCons; eauto.
     inversion H7; subst; simpl; auto.
Qed.

Theorem preservation : forall t t' T,
  empty |- t \in T  ->
  t --> t'  ->
  empty |- t' \in T.
Proof with eauto.
  intros t t' T HT. generalize dependent t'.
  remember empty as Gamma.
  induction HT;
       intros t' HE; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  - (* T_Proj *) (* <=== new case compared to pure STLC *)
    (* If the last rule was [T_Proj], then [t = rproj 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 [empty |- t \in 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. *)
    inversion HE; subst...
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Htyp] ].
    rewrite H4 in Hget. injection Hget as Hget. subst...
  - (* T_RCons *) (* <=== new case compared to pure STLC *)
    (* If the last rule was [T_RCons], then [t = rcons 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']. *)
    inversion HE; subst...
    apply T_RCons... eapply step_preserves_record_tm...
Qed.
(** [] *)

End STLCExtendedRecords.

(* 2020-09-09 21:08 *)


(* This file formalises some basic properties of the relations from
   Section 4, including lemmas 4.3, 4.4 and generalised versions of
   lemmas 4.5, 4.7. *)

Require Export defs.
Require Export tactics.
Require Export star.
Require Export equality.

Lemma lem_root_active_bot : root_active bot.
Proof.
  unfold root_active.
  unfold has_rnf.
  intro H.
  destruct H as [t [H1 H2]].
  revert H1.
  inversion_clear H2.
  - ycrush.
  - inversion_clear H; sauto; inversion_clear H0.
  - inversion_clear H; sauto; inversion_clear H0.
  - inversion_clear H; sauto; inversion_clear H0.
Qed.

Section Basic_clos_props.

Variable R : relation term.
Variable MorR : morphism R.

Lemma lem_comp_morphism : morphism (comp_clos R).
Proof.
  unfold morphism.
  intros x y H.
  induction H; intros x0 y0 Heq1 Heq2.
  - constructor; pose_term_eq; sauto.
  - rewrite H0 in Heq1.
    inversion Heq1; subst; intuition; fold term_eq in *;
      inversion Heq2; subst; intuition; fold term_eq in *;
        solve [ constructor; pose_term_eq; eauto ].
  - rewrite H0 in Heq1.
    inversion Heq1; subst; intuition; fold term_eq in *;
      inversion Heq2; subst; intuition; fold term_eq in *;
        solve [ constructor; pose_term_eq; eauto ].
  - inversion Heq1; subst; intuition; fold term_eq in *;
      inversion Heq2; subst; intuition; fold term_eq in *;
        solve [ constructor; pose_term_eq; eauto ].
Qed.

Add Parametric Morphism : (comp_clos R) with
    signature term_eq ==> term_eq ==> iff as comp_mor.
Proof.
  split; intro; eapply lem_comp_morphism; pose_term_eq; eauto.
Qed.

Add Parametric Morphism : (star R) with
    signature term_eq ==> term_eq ==> iff as star_mor.
Proof.
  split; intro; eapply lem_star_morphism; pose_term_eq; eauto.
Qed.

(******************************************************************************)

Definition red R := star (comp_clos R).
Hint Unfold red.

Add Parametric Morphism : (red R) with
    signature term_eq ==> term_eq ==> iff as red_mor.
Proof.
  split; intro; eapply lem_star_morphism; pose lem_comp_morphism; pose_term_eq; eauto.
Qed.

Lemma lem_red_refl : forall x y, x == y -> red R x y.
Proof.
  yelles 2.
Qed.

Lemma lem_red_refl_0 : reflexive term (red R).
Proof.
  pose_term_eq; yelles 2.
Qed.

Lemma lem_red_trans : transitive term (red R).
Proof.
  generalize lem_comp_morphism; unfold transitive; pose_star; eauto.
Qed.

Lemma lem_red_step : forall x y z, comp_clos R x y -> red R y z -> red R x z.
Proof.
  generalize lem_comp_morphism; pose_star; eauto.
Qed.

Lemma lem_red_app_l : forall x x', red R x x' -> forall y, red R (app x y) (app x' y).
Proof.
  intros x x' H.
  induction H; intro.
  - rewrite H; apply lem_red_refl_0.
  - apply lem_red_step with (y := app y y0).
    + constructor 2; pose_term_eq; eauto.
    + auto.
Qed.

Lemma lem_red_app_r : forall y y', red R y y' -> forall x, red R (app x y) (app x y').
Proof.
  intros y y' H.
  induction H; intro.
  - rewrite H; apply lem_red_refl_0.
  - apply lem_red_step with (y := app x0 y).
    + constructor 3; pose_term_eq; eauto.
    + auto.
Qed.

Lemma lem_red_app : forall x x' y y', red R x x' -> red R y y' ->
                                      red R (app x y) (app x' y').
Proof.
  eauto using lem_red_app_l, lem_red_app_r, lem_red_trans.
Qed.

Lemma lem_red_abs : forall x x', red R x x' -> red R (abs x) (abs x').
Proof.
  intros x x' H.
  induction H.
  - rewrite H; apply lem_red_refl_0.
  - apply lem_red_step with (y := abs y); csolve.
Qed.

Lemma lem_red_step_rev : forall x y z, red R x y -> comp_clos R y z -> red R x z.
Proof.
  intros x y z H.
  revert z.
  induction H.
  - intros; rewrite H; econstructor 2; [ eauto | constructor; pose_term_eq; eauto ].
  - eauto using lem_red_step.
Qed.

Lemma lem_step_to_red : forall x y, comp_clos R x y -> red R x y.
Proof.
  intros; eapply lem_red_step; eauto using lem_red_refl_0.
Qed.

(******************************************************************************)

Lemma lem_inf_morphism : morphism (inf_clos (star R)).
Proof.
  assert (Hm: morphism (star R)) by eauto using lem_star_morphism.
  unfold morphism.
  enough (forall x y, inf_clos (star R) x y ->
                      forall x' y', y == y' -> x == x' ->
                                    inf_clos (star R) x' y') by ycrush.
  coinduct CH; intros x1 y1 Heq1 Heq2;
    inversion Heq1; subst; intuition; fold term_eq in *; econstructor; pose_term_eq; eauto.
Qed.

Lemma lem_inf_refl_0 : reflexive term (inf_clos (star R)).
Proof.
  pose_star; coinduction on 0.
Qed.

(* Lemma 4.3, (1) *)
Lemma lem_inf_refl : forall x y, x == y -> inf_clos (star R) x y.
Proof.
  pose_star; pose_term_eq; coinduction on 0.
Qed.

(* Lemma 4.3, (2) *)
Lemma lem_inf_prepend : forall x y z, star R x y -> inf_clos (star R) y z -> inf_clos (star R) x z.
Proof.
  pose_star; csolve on 4.
Qed.

(* Lemma 4.3, (3) *)
Lemma lem_star_to_inf : forall x y, star R x y -> inf_clos (star R) x y.
Proof.
  Reconstr.reasy (lem_inf_refl_0, lem_inf_prepend) (reflexive).
Qed.

(* Lemma 4.4 *)
Lemma lem_inf_subset (S : relation term) : (forall x y, R x y -> S x y) ->
                       forall x y, inf_clos (star R) x y -> inf_clos (star S) x y.
Proof.
  pose_star; coinduction using eauto.
Qed.

Lemma lem_comp_subst_closed : subst_closed R -> subst_closed (comp_clos R).
Proof.
  unfold subst_closed.
  intros H x x'.
  enough (comp_clos R x x' -> forall n y, comp_clos R (x [n := y]) (x' [n := y])) by scrush.
  intro H1; induction H1; intros; try rewrite H0; pose_term_eq; csolve.
Qed.

Lemma lem_comp_shift_closed : shift_closed R -> shift_closed (comp_clos R).
Proof.
  unfold shift_closed.
  intro H.
  enough (forall t t', comp_clos R t t' -> forall d c, comp_clos R (shift d c t) (shift d c t')) by scrush.
  intros t t' H1; induction H1; intros; try rewrite H0; pose_term_eq; csolve.
Qed.

Lemma lem_star_subst_closed : subst_closed R -> subst_closed (star R).
Proof.
  unfold subst_closed.
  intro H; sauto.
  induction H0; try rewrite H0; pose_star; eauto.
Qed.

Lemma lem_star_shift_closed : shift_closed R -> shift_closed (star R).
Proof.
  unfold shift_closed.
  intro H; sauto.
  induction H0; try rewrite H0; pose_star; eauto.
Qed.

Lemma lem_inf_shift_closed : shift_closed R -> shift_closed (inf_clos R).
Proof.
  unfold shift_closed.
  intro H0.
  coinduction H using auto.
  - autorewrite with shints.
    constructor.
    assert (shift d c bot = bot) by (autorewrite with shints; reflexivity).
    yelles 1.
  - clear H; autorewrite with shints; ysplit.
    + constructor.
      assert (shift d c (var n) = var (n + d)) by (autorewrite with shints; sauto).
      yelles 1.
    + constructor.
      assert (shift d c (var n) = var n) by (autorewrite with shints; sauto).
      yelles 1.
  - autorewrite with shints.
    apply inf_clos_app with (x := shift d c x) (y := shift d c y).
    + assert (app (shift d c x) (shift d c y) = shift d c (app x y)) by (autorewrite with shints; reflexivity).
      yelles 1.
    + auto.
    + auto.
  - autorewrite with shints.
    apply inf_clos_abs with (x := shift d (c + 1) x).
    + assert (abs (shift d (c + 1) x) = shift d c (abs x)) by (autorewrite with shints; reflexivity).
      yelles 1.
    + auto.
Qed.

End Basic_clos_props.

(******************************************************************************)

(* Lemma 4.5, generalised *)
Lemma lem_inf_subst (R : relation term):
  morphism R -> subst_closed R -> shift_closed R ->
  forall s s' t t', inf_clos (star R) s s' -> inf_clos (star R) t t' ->
                    forall n, inf_clos (star R) (subst n t s) (subst n t' s').
Proof.
  intros Hm H0 H1.
  assert (Hs0: subst_closed (star R)) by auto using lem_star_subst_closed.
  clear H0; unfold subst_closed in Hs0.
  assert (Hs1: shift_closed (star R)) by auto using lem_star_shift_closed.
  clear H1; unfold shift_closed in Hs1.
  coinduct H.
  - clear H; intros; autorewrite with shints.
    constructor.
    assert (HH: bot = bot [n := t]) by (autorewrite with shints; auto).
    rewrite HH; clear HH.
    eauto.
  - clear H; intros.
    assert (inf_clos (star R) (var n [n0 := t]) (var n [n0 := t'])).
    autorewrite with shints; repeat ysplit.
    + solve [ constructor; pose_star; sauto ].
    + generalize lem_inf_shift_closed; unfold shift_closed; auto.
    + solve [ constructor; pose_star; sauto ].
    + eapply lem_inf_prepend; sauto.
  - intros; autorewrite with shints.
    apply inf_clos_app with (x := x[n := t]) (y := y[n := t]).
    + assert (HH: app (x [n := t]) (y [n := t]) = (app x y) [n := t]) by
          (autorewrite with shints; reflexivity).
      rewrite HH.
      auto.
    + eauto.
    + eauto.
  - intros; autorewrite with shints.
    apply inf_clos_abs with (x := x [n + 1 := t]).
    + assert (HH: abs (x [n + 1 := t]) = abs x [n := t]) by
          (autorewrite with shints; reflexivity).
      rewrite HH.
      auto.
    + eauto.
Qed.

Definition appendable (R : relation term) :=
  forall t1 t2 t3, inf_clos R t1 t2 -> R t2 t3 -> inf_clos R t1 t3.

(* Lemma 6.2, generalised Lemma 4.7 *)
Lemma lem_inf_trans (R : relation term) : appendable R -> transitive term (inf_clos R).
Proof.
  unfold appendable; unfold transitive.
  intro Ha.
  coinduction H on 4 using eauto.
  - assert (HH: inf_clos R x (app x0 y0)) by eauto.
    inversion HH; subst.
    econstructor; eauto.
  - assert (HH: inf_clos R x (abs x0)) by eauto.
    inversion HH; subst.
    econstructor; eauto.
Qed.

Lemma lem_inf_reflexive (R : relation term) : reflexive term R -> reflexive term (inf_clos R).
Proof.
  intro; coinduction on 0.
Qed.

Lemma lem_R_to_inf (R : relation term) : morphism R -> reflexive term R ->
  forall x y, R x y -> inf_clos R x y.
Proof.
  intros Hm Hr.
  pose lem_inf_reflexive; coinduction CH on 1.
Qed.

Lemma lem_inf_to_aux (R : relation term) : morphism R ->
  forall x y, inf_clos (star R) x y -> aux_clos R x y.
Proof.
  unfold aux_clos.
  pose lem_inf_morphism; pose lem_R_to_inf; pose lem_inf_refl_0; ycrush.
Qed.

Lemma lem_inf_prepend_step (R : relation term) :
  transitive term R -> forall x y z, R x y -> inf_clos R y z -> inf_clos R x z.
Proof.
  csolve on 5.
Qed.

Lemma lem_aux_to_inf (R : relation term) :
  appendable (star R) -> forall x y, aux_clos R x y -> inf_clos (star R) x y.
Proof.
  intros Ha.
  unfold aux_clos.
  coinduction CH using eauto.
  - inversion H0; subst.
    assert (inf_clos (inf_clos (star R)) x1 x') by (pose lem_inf_prepend_step; pose lem_inf_trans; ycrush).
    assert (inf_clos (inf_clos (star R)) y y') by (pose lem_inf_prepend_step; pose lem_inf_trans; ycrush).
    cosolve CH.
  - inversion H0; subst.
    assert (inf_clos (inf_clos (star R)) x1 x') by (pose lem_inf_prepend_step; pose lem_inf_trans; ycrush).
    cosolve CH.
Qed.


(**
「スタックモナド」でスタック計算機を作る
========

@suharahiromichi 2014_02_01

Stack Monad を使ってスタック計算機を定義してみて、
スタックモナドの使い方の実例を示す。

また、スタックを使った演算の複数の定義が同じ結果になることを示す。
本当にモナドになっていることも示す。
証明は SSReflect を使っておこなう。
 *)

Require Import ssreflect ssrbool ssrnat seq eqtype ssrfun.

(**
# Stack Monad

Stack Monad は State Monad のひとつで、
Stackという「状態」を関数型言語から使いやすくするものである。
*)

(**
## スタックモナド Stack Monad の定義

スタックは seq nat (natのリスト) で表す。
「->」の右が直積になっているのは、
スタックをpopした結果を置くためである。
また、後でモナド則を証明するために、T型にしている。
*)
Definition MStack (T : Type) :=
  seq nat -> (T * seq nat).

(**
## スタックをpush,popする関数

スタック (MStack nat) 型の関数を定義する。
*)
Definition push : nat -> MStack nat :=
  fun n : nat =>
    fun q : seq nat =>
      (0, n :: q).

Definition pop : MStack nat :=
  fun q : seq nat =>
    match q with
      | n :: q' => (n, q')
      | _ => (0, q)
    end.

(**
空のスタックを作る関数も用意する。
 *)
Definition empty : MStack nat :=
  fun _ => (0, [::]).

(**
## スタックモナド Stack Monad の基本演算
*)
Definition ret {T : Type} : T -> MStack T :=
  fun n : T => fun q : seq nat => (n, q).

(**
bind (>>=) は右結合で、優先順位は(=)より強い。(=)の有線順位は70)
 *)
Definition bind {T S : Type} : MStack T -> (T -> MStack S) -> MStack S :=
  fun s : MStack T =>
    fun c : T -> MStack S =>
      fun q : seq nat =>
        let (n, q') := s q in c n q'.
Infix ">>=" := bind (right associativity, at level 61).

(**
(>>) は右結合で、(>>=)と同じ優先順位とする。
 *)
Definition bind2 {T S : Type} : MStack T -> MStack S -> MStack S :=
  fun s1 : MStack T =>
    fun s2 : MStack S =>
      s1 >>= fun _ => s2.
Infix ">>" := bind2 (right associativity, at level 61).

(**
### おまけの関数

以下は、モナド則の証明だけに使うので、「_」を付けた名前にする。
*)

Definition id_ {T : Type} (v : T) : T := v.

Definition fmap_ {T S : Type} (f : T -> S) (mx : MStack T) : MStack S :=
  mx >>= (fun x => ret (f x)).

Definition join_ {T : Type} (s : MStack (MStack T)) : MStack T :=
  s >>= id_.

(**
### do記法
*)

Notation "'do' [ a <- A ; B ]" :=
  (A >>= fun a => B)
    (at level 100, right associativity).
Notation "'do' [ a <- A ; b <- B ; C ]" :=
  (A >>= fun a => B >>= fun b => C)
    (at level 100, right associativity).
Notation "'do' [ a <- A ; b <- B ; c <- C ; D ]" :=
  (A >>= fun a => B >>= fun b => C >>= fun c => D)
    (at level 100, right associativity).
Notation "'do' [ a <- A ; b <- B ; c <- C ; d <- D ; E ]" :=
  (A >>= fun a => B >>= fun b => C >>= fun c => D >>= fun d => E)
    (at level 100, right associativity).

(**
# 演算のいろいろな定義

前節で用意した関数を使って、実際に加減乗の演算を定義してみる。
 *)

(**
## 直接定義する方法

加減乗算をスタック (MStack nat) を使って直接定義する。
*)
Definition binary_op2 (op : nat -> nat -> nat) : MStack nat :=
  fun q : seq nat =>
    match q with
      | n :: m :: q' => (0, (op m n) :: q')
      | _ => (0, [::0])
    end.
Definition SPlus2 := binary_op2 plus.
Definition SMinus2 := binary_op2 minus.
Definition SMult2 := binary_op2 mult.

(**
## push, popだけで定義する方法

モナドの基本演算を使わないで定義する。
*)
Definition binary_op1 (op : nat -> nat -> nat) : MStack nat :=
  fun q : seq nat =>
    let (n, q') := pop q in
    let (m, q'') := pop q' in
    push (op m n) q''.
Definition SPlus1 := binary_op1 plus.
Definition SMinus1 := binary_op1 minus.
Definition SMult1 := binary_op1 mult.

(**
## モナドの基本演算 bind, ret を使う方法

モナドの基本演算を使って定義する。
*)
Definition binary_op (op : nat -> nat -> nat) : MStack nat :=
  pop >>=
      fun n => pop >>=                      (* n は後にpushしたもの。 *)
                   fun m => push (op m n).  (* m は先にpushしたもの。 *)
Definition SPlus : MStack nat := binary_op plus.
Definition SMinus : MStack nat := binary_op minus.
Definition SMult : MStack nat := binary_op mult.

(**
## do記法を使う方法

モナドの基本演算、ただし、do記法を使って定義する。
*)

Definition binary_op' (op : nat -> nat -> nat) : MStack nat :=
  do [ n <- pop;
       m <- pop;
       push (op m n) ].
Definition SPlus' : MStack nat := binary_op' plus.
Definition SMinus' : MStack nat := binary_op' minus.
Definition SMult' : MStack nat := binary_op' mult.

(**
# 実行例
*)

(**
3 + (5 - 2) = 6 を実行してみる。
 *)
Eval compute in
    empty >> push 3 >> push 5 >> push 2 >> SMinus >> SPlus >> pop.
Eval compute in
    empty >> push 3 >> push 5 >> push 2 >> SMinus1 >> SPlus1 >> pop.
Eval compute in
    empty >> push 3 >> push 5 >> push 2 >> SMinus2 >> SPlus2 >> pop.
Eval compute in
    empty >> push 3 >> push 5 >> push 2 >> SMinus' >> SPlus' >> pop.

(**
# 演算の定義が等しいことの証明

SPlus を使った計算と SPlus1 を使った計算が同じことを証明する。
*)
Goal forall n m,
       empty >> push n >> push m >> SPlus >> pop =
       empty >> push n >> push m >> SPlus1 >> pop.
Proof.
    by [].
Qed.

Goal SPlus = SPlus1.
    by [].
Qed.

(**
SPlus を使った計算と SPlus2 を使った計算が同じことを証明する。
*)
Goal forall n m,
       empty >> push n >> push m >> SPlus >> pop =
       empty >> push n >> push m >> SPlus2 >> pop.
Proof.
    by [].
Qed.

Eval compute in SPlus [::].
Eval compute in SPlus1 [::].
Eval compute in SPlus2 [::].

Goal forall s : seq nat, SPlus1 s = SPlus2 s.
Admitted.

Goal SPlus1 = SPlus2.
Admitted.

(**
# ifelse

ここでは使わないが、Postscript風の ifelse の定義は以下のようになる。
*)
Definition ifelse (s1 : MStack nat) (s2 : MStack nat) : MStack nat :=
  pop >>= fun n => if n == 0 then s2 else s1.

Eval compute in
    push 1 >> ifelse (push 0) (push 1) >> pop.

(**
do記法を使うと以下のようになる。
*)
Definition ifelse' (s1 : MStack nat) (s2 : MStack nat) : MStack nat :=
  do [ n <- pop;
       if n == 0 then s2 else s1 ].

(**
# モナド則の証明

スタックモナドがモナド則を満たすことを証明しておく。

## functional_extensionality を使う場合

関数が等しいことを示す公理 ∀q. f q = g q -> f = g を導入する必要がある。
 *)

Axiom functional_extensionality :
  forall {T : Type},
  forall {f g : MStack T},
    (forall (q : seq nat), f q = g q) -> f = g.

(**
### モナド則 その1
 *)
Theorem monad_1 :
  forall (T S : Type),
  forall (f : T -> MStack S) (n : T),
    ret n >>= f = f n.
Proof.
    by [].
Qed.

(**
### モナド則 その2
 *)
Theorem monad_2 :
  forall (T : Type),
  forall (s : MStack T),
    s >>= ret = s.
Proof.
  move=> T s.
  apply: functional_extensionality.
  move=> q.
  rewrite /bind /ret.
    by elim: s.
Qed.

(**
### モナド則 その3
 *)
Theorem monad_3 :
  forall (T S R : Type),
  forall (f : T -> MStack S) (g : S -> MStack R) (s : MStack T),
    (s >>= f) >>= g =
    s >>= (fun n => f n >>= g).
Proof.
  move=> T S R f g s.
  apply: functional_extensionality.
  move=> q.
  rewrite /bind.
    by elim: s.
Qed.

(**
## 可換図式を証明する

### 結合則
 *)
Theorem assoc_law :
  forall (T : Type) (s : MStack (MStack (MStack T))),
    join_ (join_ s) = join_ ((fmap_ join_) s).
Proof.
  move => T s.
  rewrite /join_ /fmap_ /ret.
    by rewrite ! monad_3.
Qed.

(**
### 左単位元
 *)
Theorem unit_left_law :
  forall (T : Type) (s : MStack (MStack T)),
    join_ (ret s) = id_ s.
Proof.
  move => T s.
  rewrite /join_.
    by rewrite monad_1.
Qed.

(**
### 右単位元
 *)
Theorem unit_right_law :
  forall (T : Type) (m : MStack (MStack T)),
    join_ ((fmap_ ret) m) = id_ m.
Proof.
  move=> A m.
  rewrite /join_ /fmap_ /id_.
  by rewrite monad_3 monad_2.
Qed.

(**
## 「=1」での成立を示す

SSReflectでは、ssrfun.vで
functional_extensionality のもとで関数が同じことを示す等号
「=1」が導入されている。
「=」の代わりに「=1」を使うと、
公理functional_extensionalityを追加する必要がなくなる。
このほうが、SSReflectらしいのだろう。
 *)

Theorem monad_1' :
  forall (T S : Type),
  forall (f : T -> MStack S) (n : T),
    ret n >>= f =1 f n.
Proof.
    by [].
Qed.

Theorem monad_2' :
  forall (T : Type),
  forall (s : MStack T),
    s >>= ret =1 s.
Proof.
  move=> T s q.
  rewrite /bind /ret.
    by elim: s.
Qed.

Theorem monad_3' :
  forall (T S R : Type),
  forall (f : T -> MStack S) (g : S -> MStack R) (s : MStack T),
    (s >>= f) >>= g =1 s >>= (fun n => f n >>= g).
Proof.
  move=> T S R f g s q.
  rewrite /bind.
    by elim: s.
Qed.

(**
# 補足

## do 記法の別の定義
*)

Notation "'do' a <- A ; B" :=
  (A >>= fun a => B)
    (at level 100, right associativity).

Definition binary_op'' (op : nat -> nat -> nat) : MStack nat :=
  do n <- pop;
  do m <- pop;
  push (op m n).

(**
# 参考

1. Haskellでスタックを利用した加減乗除の計算機を作ってみる
   http://kzfm.github.io/laskell/stackCalc.html

2. ソフトウェアの基礎 単純な命令型プログラム 練習問題 stack_compiler
   http://proofcafe.org/sf/Imp_J.html
 *)

(* $Id: ssr_monad_stack_monad.v,v 1.42 2014/04/30 09:20:34 suhara Exp suhara $ *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Nota : this file is OBSOLETE, and left only for compatibility.
    Please consider instead predicates [Nat.Even] and [Nat.Odd]
    and Boolean functions [Nat.even] and [Nat.odd]. *)

(** Here we define the predicates [even] and [odd] by mutual induction
    and we prove the decidability and the exclusion of those predicates.
    The main results about parity are proved in the module Div2. *)

Require Import PeanoNat.

Local Open Scope nat_scope.

Implicit Types m n : nat.

(** * Inductive definition of [even] and [odd] *)

Inductive even : nat -> Prop :=
  | even_O : even 0
  | even_S : forall n, odd n -> even (S n)
with odd : nat -> Prop :=
    odd_S : forall n, even n -> odd (S n).

Hint Constructors even: arith.
Hint Constructors odd: arith.

(** * Equivalence with predicates [Nat.Even] and [Nat.odd] *)

Lemma even_equiv : forall n, even n <-> Nat.Even n.
Proof.
 fix even_equiv 1.
 destruct n as [|[|n]]; simpl.
 - split; [now exists 0 | constructor].
 - split.
   + inversion_clear 1. inversion_clear H0.
   + now rewrite <- Nat.even_spec.
 - rewrite Nat.Even_succ_succ, <- even_equiv.
   split.
   + inversion_clear 1. now inversion_clear H0.
   + now do 2 constructor.
Qed.

Lemma odd_equiv : forall n, odd n <-> Nat.Odd n.
Proof.
 fix odd_equiv 1.
 destruct n as [|[|n]]; simpl.
 - split.
   + inversion_clear 1.
   + now rewrite <- Nat.odd_spec.
 - split; [ now exists 0 | do 2 constructor ].
 - rewrite Nat.Odd_succ_succ, <- odd_equiv.
   split.
   + inversion_clear 1. now inversion_clear H0.
   + now do 2 constructor.
Qed.

(** Basic facts *)

Lemma even_or_odd n : even n \/ odd n.
Proof.
  induction n.
  - auto with arith.
  - elim IHn; auto with arith.
Qed.

Lemma even_odd_dec n : {even n} + {odd n}.
Proof.
  induction n.
  - auto with arith.
  - elim IHn; auto with arith.
Defined.

Lemma not_even_and_odd n : even n -> odd n -> False.
Proof.
  induction n.
  - intros Ev Od. inversion Od.
  - intros Ev Od. inversion Ev. inversion Od. auto with arith.
Qed.

(** * Facts about [even] & [odd] wrt. [plus] *)

Ltac parity2bool :=
 rewrite ?even_equiv, ?odd_equiv, <- ?Nat.even_spec, <- ?Nat.odd_spec.

Ltac parity_binop_spec :=
 rewrite ?Nat.even_add, ?Nat.odd_add, ?Nat.even_mul, ?Nat.odd_mul.

Ltac parity_binop :=
 parity2bool; parity_binop_spec; unfold Nat.odd;
 do 2 destruct Nat.even; simpl; tauto.

Lemma even_plus_split n m :
  even (n + m) -> even n /\ even m \/ odd n /\ odd m.
Proof. parity_binop. Qed.

Lemma odd_plus_split n m :
  odd (n + m) -> odd n /\ even m \/ even n /\ odd m.
Proof. parity_binop. Qed.

Lemma even_even_plus n m : even n -> even m -> even (n + m).
Proof. parity_binop. Qed.

Lemma odd_plus_l n m : odd n -> even m -> odd (n + m).
Proof. parity_binop. Qed.

Lemma odd_plus_r n m : even n -> odd m -> odd (n + m).
Proof. parity_binop. Qed.

Lemma odd_even_plus n m : odd n -> odd m -> even (n + m).
Proof. parity_binop. Qed.

Lemma even_plus_aux n m :
    (odd (n + m) <-> odd n /\ even m \/ even n /\ odd m) /\
    (even (n + m) <-> even n /\ even m \/ odd n /\ odd m).
Proof. parity_binop. Qed.

Lemma even_plus_even_inv_r n m : even (n + m) -> even n -> even m.
Proof. parity_binop. Qed.

Lemma even_plus_even_inv_l n m : even (n + m) -> even m -> even n.
Proof. parity_binop. Qed.

Lemma even_plus_odd_inv_r n m : even (n + m) -> odd n -> odd m.
Proof. parity_binop. Qed.

Lemma even_plus_odd_inv_l n m : even (n + m) -> odd m -> odd n.
Proof. parity_binop. Qed.

Lemma odd_plus_even_inv_l n m : odd (n + m) -> odd m -> even n.
Proof. parity_binop. Qed.

Lemma odd_plus_even_inv_r n m : odd (n + m) -> odd n -> even m.
Proof. parity_binop. Qed.

Lemma odd_plus_odd_inv_l n m : odd (n + m) -> even m -> odd n.
Proof. parity_binop. Qed.

Lemma odd_plus_odd_inv_r n m : odd (n + m) -> even n -> odd m.
Proof. parity_binop. Qed.

(** * Facts about [even] and [odd] wrt. [mult] *)

Lemma even_mult_aux n m :
  (odd (n * m) <-> odd n /\ odd m) /\ (even (n * m) <-> even n \/ even m).
Proof. parity_binop. Qed.

Lemma even_mult_l n m : even n -> even (n * m).
Proof. parity_binop. Qed.

Lemma even_mult_r n m : even m -> even (n * m).
Proof. parity_binop. Qed.

Lemma even_mult_inv_r n m : even (n * m) -> odd n -> even m.
Proof. parity_binop. Qed.

Lemma even_mult_inv_l n m : even (n * m) -> odd m -> even n.
Proof. parity_binop. Qed.

Lemma odd_mult n m : odd n -> odd m -> odd (n * m).
Proof. parity_binop. Qed.

Lemma odd_mult_inv_l n m : odd (n * m) -> odd n.
Proof. parity_binop. Qed.

Lemma odd_mult_inv_r n m : odd (n * m) -> odd m.
Proof. parity_binop. Qed.

Hint Resolve
 even_even_plus odd_even_plus odd_plus_l odd_plus_r
 even_mult_l even_mult_r even_mult_l even_mult_r odd_mult : arith.


(** * Higher-order functors

  This file defines higher-order functors and well-formedness properties for them,
   which are from Johann and Ghani's work on primitive nested types in Haskell
   (See https://core.ac.uk/download/pdf/345082304.pdf).

   Higher-order functors have a functorial structure over higher-order functions.

   We use higher-order functor well-formedness properties for stating well-formedness
   properties over monad transformers, which are higher order functors (similarly
   to how monads form a functor).

   We provide higher-order functor instances for ID, State, and Error transformers
   and show that the higher-order functor well-formedness properties are closed under
   nesting these monad transformers. *)

(* begin hide *)
From Coq Require Import
     Program
     Setoid
     Morphisms
     RelationClasses.

From Paco Require Import paco.

From ITree Require Import
     Basics.Basics
     Basics.MonadState
     Basics.Category
     Basics.CategoryKleisli
     Basics.CategoryKleisliFacts
     Basics.HeterogeneousRelations
     Basics.Tacs
     Basics.MonadFail
     Core.ITreeDefinition
     Core.KTree
     Core.KTreeFacts
     Core.Subevent
     Eq.Eq
     Eq.UpToTaus
     Eq.Paco2
     Indexed.Sum
     Indexed.Function
     Interp.Interp.

From ITree.EqmR Require Import
     EqmRMonad EqmRMonadT
     Monads.ITree_weak
     Monads.StateT Monads.ErrorT.

From ExtLib Require Import
     Structures.Functor
     Structures.Monad.

Set Primitive Projections.

Import RelNotations.
Import ITreeNotations.
Import FunctorNotation.
Import MonadNotation.
Import CatNotations.
Local Open Scope relationH_scope.
Local Open Scope cat_scope.
Local Open Scope monad_scope.
(* end hide *)

(** ** Higher-order functors

    Higher-order functors are higher-order functions that are functorial.
    It comes with two operations:
    - [fmap]: non-higher order fmap operator
    - [hfmap]: higher order fmap operator *)
Class HFunctor (f : (Type -> Type) -> Type -> Type) := {
  ffmap : forall A B g, Functor g -> (A -> B) -> f g A -> f g B;
  hfmap : forall g h, (g ~> h) -> (f g ~> f h) }.

Arguments ffmap {_ _ _ _ _ _} _ _.
Arguments hfmap {_ _ _ _} F [_].

(** Higher-order fmap respects [eqmR] *)
Definition pointwise_eqmR
    (g h : Type -> Type)
    {g_Monad : Monad g} {h_Monad : Monad h} {g_EqmR : EqmR g} {h_EqmR : EqmR h} : relation (g ~> h).
Proof.
  repeat intro.
  exact (forall (T1 T2 : Type) x y (RR:T1->T2->Prop), eqmR RR x y -> eqmR RR (X _ x) (X0 _ y)).
Defined.

Definition pointwise_eqmR_eq
    (g h : Type -> Type)
    {g_Monad : Monad g} {h_Monad : Monad h} {g_EqmR : EqmR g} {h_EqmR : EqmR h} : relation (g ~> h).
Proof.
  repeat intro.
  exact (forall (T : Type) (x y : g T), eqmR eq x y -> eqmR eq (X _ x) (X0 _ y)).
Defined.

Class HFmapProperH f (f_Hfunctor : HFunctor f) `{f_WF_MonadTLaws : WF_IterativeMonadT f} : Type :=
  hfmap_properH_ :
    forall (g h : Type -> Type)
      {g_Monad : Monad g} {h_Monad : Monad h} {g_EqmR : EqmR g} {h_EqmR : EqmR h}
      {g_EQM : EQM g _} {h_EQM : EQM h _} X1 X2 RR,
      ProperH (pointwise_eqmR g h ~~> eqmR (m := f g) RR ~~> eqmR (m := f h) RR)
              (fun x => @hfmap f _ g h x X1)
              (fun x => @hfmap f _ g h x X2).

Class HFmapProper f (f_Hfunctor : HFunctor f) `{f_WF_MonadTLaws : WF_IterativeMonadT f} : Type :=
  hfmap_proper_ :
    forall (g h : Type -> Type)
      {g_Monad : Monad g} {h_Monad : Monad h} {g_EqmR : EqmR g} {h_EqmR : EqmR h}
      {g_EQM : EQM g _} {h_EQM : EQM h _} X,
      Proper (pointwise_eqmR_eq g h ==> eqmR (m := f g) eq ==> eqmR (m := f h) eq)
             (fun x => @hfmap f _ g h x X).

Class HFmapMorphProper f (f_Hfunctor : HFunctor f) `{f_WF_MonadTLaws : WF_IterativeMonadT f} : Type :=
  hfmap_morph_proper_ :
    forall (g h : Type -> Type)
      {g_Monad : Monad g} {h_Monad : Monad h} {g_EqmR : EqmR g} {h_EqmR : EqmR h}
      {g_EQM : EQM g _} {h_EQM : EQM h _} (f : g ~> h) (f_Proper: @MorphProper _ _ _ _ f),
      @MorphProper _ _ _ _ (hfmap f).

(** ** Higher-order functor laws
    Higher-order functors satisfy should satisfy functor laws, form a natural
    transformation when lifting functions that operate on monads, and respect
    [eqmR].

    - [hfmap_id] and [hfmap_comp] are functor laws
    - [hfmap_nat] states that if when lifting a functor [F] that operate on
      monads, the higher-order functor should form a monad morphism, i.e.
      commute with [ret] and [bind]
    - [hfmap_proper] states that the functor respects [eqmR]. *)
Class HFunctorLaws (f : (Type -> Type) -> Type -> Type)
      {f_Hfunctor : HFunctor f}
      `{f_WF_MonadTLaws : WF_IterativeMonadT f} := {
    hfmap_id :
      forall T (g : Type -> Type) `{g_EQM : EQM g} (t : f g T),
        hfmap (fun _ x => x) t ≈{eq} t;
    hfmap_comp :
    forall T (g h i: Type -> Type)
           {g_Monad : Monad g} {h_Monad : Monad h} {i_Monad : Monad i}
           {g_EqmR : EqmR g} {h_EqmR : EqmR h} {i_EqmR : EqmR i}
           {g_EQM : EQM g _} {h_EQM : EQM h _} {i_EQM : EQM i _}
           (f1 : g ~> h) (f2 : h ~> i)
           (f1_Proper: @MorphProper _ _ _ _ f1)
           (f2_Proper: @MorphProper _ _ _ _ f2) (t : f g T),
      hfmap (fun X x => f2 _ (f1 _ x)) t ≈{eq} hfmap f2 (hfmap f1 t);
    hfmap_nat :>
      forall (g h : Type -> Type)
        {g_Monad : Monad g} {h_Monad : Monad h} {g_EqmR : EqmR g} {h_EqmR : EqmR h}
        {g_EQM : EQM g _} {h_EQM : EQM h _}
        (F : forall T, g T -> h T) {F_Nat : MonadMorphism _ _ F},
        MonadMorphism _ _ (hfmap F);
    hfmap_proper :> HFmapProper f f_Hfunctor;
    hfmap_morph_proper :> HFmapMorphProper f f_Hfunctor
  }.

(** ** Higher-order functor laws for Iterative Monads *)
(** Well-formedness properties of higher-order functors w.r.t. iterative monads
    - [hfmap_lift] states that [hfmap] commutes with the [lift] operation on
      monad transformers
    - [hfmap_iter] states that given a monad morphism [F] over iterative monads
      which commutes with the [iter] operator, [hfmap F] also commutes with the
      [iter] operator. *)
Class HFunctorLawsExtra (f : (Type -> Type) -> Type -> Type)
      {f_Hfunctor : HFunctor f}
      `{f_WF_MonadTLaws : WF_IterativeMonadT f} :=
  { hfmap_lift :
    forall (T : Type) (g h : Type -> Type)
           `{g_IM : WF_IterativeMonad g} `{h_IM : WF_IterativeMonad h}
           (F : g ~> h) {F_MNT : MonadMorphism _ _ F} (t : g T),
      hfmap (f := f) F (EqmRMonadT.lift t) ≈{eq} EqmRMonadT.lift (F _ t);
    hfmap_iter :
    forall (g h : Type -> Type)
           `{g_IM : WF_IterativeMonad g} `{h_IM : WF_IterativeMonad h}
           (F : forall T : Type, g T -> h T),
      @MonadMorphism g h _ _ _ _ F ->
      @IterMorphism g h _ F _ _ ->
      @IterMorphism (f g) (f h) _ (@hfmap _ f_Hfunctor g h F) _ _;
  }.

(** All well-formedness laws for HFunctors that we need for the interpretation
    theory in [InterpFacts.v] *)
Class WF_HFunctor (T : (Type -> Type) -> Type -> Type) {T_HFunctor : HFunctor T}
      `{M_IterativeMonadT : WF_IterativeMonadT T}:= {
  T_HFunctorLaws :> HFunctorLaws T;
  T_HFunctorLawsExtra :> HFunctorLawsExtra T; }.

Import Monads.

(** *** Instances for HFunctors *)
Section HFunctorInstances.

  (** State transformer forms a higher-order functor and respects well-formedness
    laws. *)
  #[global] Instance stateT_HFunctor {S} : HFunctor (stateT S) :=
  {| ffmap := fun A B g _ f x s => fmap (fun '(s', a) => (s', f a)) (x s);
    hfmap := fun g h f _ x s => f _ (x s) |}.

  #[global] Existing Instance stateT_HFunctor | 0.

  Arguments EqmRMonadT.lift /.

  #[global] Instance stateT_HFunctorLaws {S} {inh_S : inhabited S}:
    @HFunctorLaws (stateT S) _ _ _
                  (stateT_WF_IterativeMonadT inh_S).
  Proof.
    constructor.
    - intros. cbn. intros; subst; eapply reflexivity.
    - intros. cbn. intros; subst; eapply reflexivity.
    - intros; constructor; intros; cbn in *; cycle 1.
      { repeat intro. destruct F_Nat. intros; subst.
        eapply Proper_eqmR_cong. cbn. eapply morph_ret; eauto. eapply reflexivity.
        apply eqmR_ret; eauto. typeclasses eauto. }
      { repeat intro. subst.
        destruct F_Nat. intros; subst. eapply morph_bind; eauto. intros. destruct a, a'.
        inv H1. eapply H0; eauto; eauto.
        all : inv H2; cbn; eauto. }
      { repeat intro. subst. cbn. eapply morph_proper; eauto; try typeclasses eauto. }
      { constructor; try typeclasses eauto. }
      Unshelve.
      destruct F_Nat. auto.
    - repeat intro. cbn. eapply Proper_eqmR. setoid_rewrite prod_rel_eq.
      reflexivity.
      eapply H. cbn in H0.
      eapply Proper_eqmR_mono; eauto.
      repeat intro. repeat inv H2 ;eauto.
    - repeat intro. cbn. eapply f_Proper. eauto.
  Qed.

  Definition prod_sum_dist_rel {A B C} : relationH (A * B + A * C) (A * (B + C)) :=
    (fun x '(s, y) => match x with
                    | inl (s', i) =>
                      match y with
                      | inl i' => s' = s /\ i = i' | _ => False
                      end
                    | inr (s', r) =>
                      match y with
                      | inr r' => s' = s /\ r = r' | _ => False
                      end
                    end).

  Definition sum_comm_rel {A B C} : relationH (A + (B + C)) (B + (A + C)) :=
    (fun x y => match x, y with
            | inl a, inr (inl a') => a = a'
            | inr (inl b), inl b' => b = b'
            | inr (inr c), inr (inr c') => c = c'
            | _, _ => False
            end).

  Arguments prod_sum_dist_rel /.

  Ltac crush :=
    crunch;
    repeat match goal with
            | [ H : (_ * _)%type |- _ ] => destruct H
            | [ H : (_ + _)%type |- _ ] => destruct H
          end.

  Ltac done := intros; subst; solve [apply final; reflexivity | crush ; eapply final; crush;
              cbn in *; crush; subst; solve [eauto | tauto | reflexivity]].

  #[global] Instance stateT_HFunctorLawsExt {S} {inh_S : inhabited S} :
    @HFunctorLawsExtra (stateT S) _ _ _
                  (stateT_WF_IterativeMonadT inh_S).
  Proof.
    constructor.
    - repeat intro.
      destruct F_MNT.
      subst. cbn. unfold fmap.
      subst. eapply Proper_eqmR_cong.
      eapply morph_bind. eauto.
      all : repeat intro; subst ; try reflexivity.
      subst. Unshelve. 3 : exact (fun x => ret (s', x)). cbn in H; subst. reflexivity.
      eapply Proper_eqmR. rewrite prod_rel_eq. reflexivity.
      cbn.
      eapply Proper_bind. reflexivity. intros; subst.
      setoid_rewrite morph_ret. reflexivity. eauto.
    - repeat intro. subst.
      eapply Proper_eqmR.
      { rewrite prod_rel_eq; reflexivity. }
      unfold EqmRMonadT.morph in *. cbn in *. subst.
      eapply H0. intros; cbn. destruct i0. cbn in *.
      specialize (H1 i0 s _ eq_refl).
      eapply Proper_eqmR in H1; cycle 1.
      { rewrite prod_rel_eq; reflexivity. }
      etransitivity;cycle 1.
      { eapply Proper_bind with (k1 := fun a2 => ret match snd a2 with
                      | inl i' => inl (fst a2, i')
                      | inr r => inr (fst a2, r)
                      end). eapply H1.
        all : intros; subst; reflexivity. }
      etransitivity; cycle 1.
      { eapply Proper_eqmR_mono; cycle 1.
        { eapply Proper_bind with
              (A1 := (S*I + S*R)%type)
              (RR := prod_sum_dist_rel) (RB := eq) (k1 := ret); try done.
          eapply MM_morph_proper with
              (x := (x <- t i0 s ;; ret match x with
                                        | (s, inl i) => (inl (s, i))
                                        | (s, inr r) => (inr (s, r))
                                      end)).
          typeclasses eauto.
          eapply Proper_eqmR_cong.
          2 : symmetry; eapply bind_ret_r. reflexivity.
          eapply Proper_bind with (RR := eq); [ reflexivity | ..]; done. }
        apply subrelation_refl. }
      { destruct g_IM, h_IM, M_EQM, M_EQM0. rename H into F_Nat.
        destruct F_Nat.
        repeat red in MM_morph_bind. cbn in MM_morph_bind.
        rewrite bind_ret_r.
        specialize (MM_morph_bind (S * (I + R))%type _ (S*I + S*R)%type _ eq eq (t i0 s) (t i0 s)).
        erewrite MM_morph_bind; try solve [ done | reflexivity ].
        etransitivity.
        { eapply Proper_bind; [ reflexivity | .. ]; intros; subst;
          apply MM_morph_ret ; eauto. }
        setoid_rewrite <- bind_ret_r at 5.
        eapply Proper_bind.
        { apply MM_morph_proper. setoid_rewrite <- bind_ret_r at 1.
          eapply Proper_bind with (RB := flip prod_sum_dist_rel); [ reflexivity | .. ]; done. }
        all : done. }
  Qed.

  (** Error transformer forms a higher-order functor and respects well-formedness
    laws. *)
  #[global] Instance errorT_HFunctor {exn} : HFunctor (errorT exn) :=
  {| ffmap := fun A B g _ f x =>
      fmap (fun e => match e with
                  | inl e => inl e
                  | inr a => inr (f a)
                  end) x;
    hfmap := fun g h f _ x => f _ x |}.

  #[global] Existing Instance errorT_HFunctor | 0.

  #[global] Instance errorT_HFunctorLaws {exn} : HFunctorLaws (errorT exn).
  Proof.
    constructor.
    - intros. cbn. reflexivity.
    - intros. cbn. reflexivity.
    - constructor; intros; cbn in *;cycle 1.
      { destruct F_Nat. intros; subst. repeat intro.
        eapply Proper_eqmR_cong. cbn. eapply morph_ret; eauto.
        eapply reflexivity. cbn. eapply eqmR_ret; eauto. typeclasses eauto. }
      { destruct F_Nat. repeat intro. cbn.
        eapply Proper_eqmR_cong.
        { eapply morph_bind; [eapply reflexivity | ..].
          intros; subst.
          Unshelve.
          3 : {
            intros. destruct X. exact (ret (m := g) (inl e)).
            eapply (k a). }
          cbn. reflexivity. shelve.
        }
        reflexivity.
        eapply Proper_bind. cbn. eapply morph_proper; eauto.
        intros. all : try inv H1; eauto. cbn.
        eapply MM_morph_proper; eauto. }
      { destruct F_Nat. repeat intro. cbn. eapply morph_proper; eauto. }
      constructor; typeclasses eauto.
   - repeat intro. cbn.
      eapply Proper_eqmR. rewrite sum_rel_eq. reflexivity.
      cbn in H0. eapply H.
      eapply Proper_eqmR_mono; eauto.
      repeat intro. repeat inv H1; eauto.
    - repeat intro. cbn. eapply f_Proper. eauto.
  Qed.

  #[global] Instance errorT_HFunctorLawsExt {exn} :
    HFunctorLawsExtra (errorT exn).
  Proof.
    constructor.
    { repeat intro. cbn. unfold fmap.
      destruct F_MNT; eauto.
      eapply Proper_eqmR. rewrite sum_rel_eq. reflexivity.
      subst. etransitivity. eapply morph_bind.
      2 , 3 : repeat intro; try reflexivity. eauto.
      Unshelve. 6 : exact (fun x => ret (inr x)). subst; reflexivity.
      cbn. subst; eapply reflexivity.
      eapply Proper_bind. reflexivity. intros; subst.
      eapply morph_ret. eauto. }
    { repeat intro. cbn in *.
      eapply Proper_eqmR.
      { rewrite sum_rel_eq; reflexivity. }
      unfold EqmRMonadT.morph in *. cbn in *. rename H0 into F_IM.
      eapply F_IM. intros; cbn.
      specialize (H1 i0).
      eapply Proper_eqmR in H1; cycle 1.
      { rewrite sum_rel_eq; reflexivity. }
      symmetry.
      rewrite <- H1. rename H into F_Nat. destruct F_Nat. symmetry.
      repeat red in MM_morph_proper; cbn in MM_morph_proper.
      etransitivity; cycle 1.
      { eapply Proper_eqmR_mono; cycle 1.
        { eapply Proper_bind with (RR := sum_comm_rel) (RB := eq) (k1 := ret); try done.
          eapply MM_morph_proper with
                (x := x <- (t i0 : g (exn + (I + R))%type) ;; ret
                          match x with
                              | inl e => inr (inl e)
                              | inr (inl i) => inl i
                              | inr (inr r) => inr (inr r)
                          end).
          eapply Proper_eqmR_cong; [ reflexivity | ..].
          { cbn. symmetry. apply bind_ret_r. }
          eapply Proper_bind with (RR := eq); [ reflexivity | ..]; done. }
        apply subrelation_refl. }
      { repeat red in MM_morph_bind. cbn in MM_morph_bind.
        symmetry.
        rewrite bind_ret_r.
        specialize (MM_morph_bind _ _ (I + (exn + R))%type _ eq eq (t i0) (t i0)).
        erewrite MM_morph_bind; try solve [ done | reflexivity ]. } }
  Qed.

  (** ID transformer forms a higher-order functor and respects well-formedness
    laws. *)
  #[global] Instance MonadT_ID : MonadT (fun x : Type -> Type => x).
  econstructor; eauto.
  intros. repeat red. eauto.
  Defined.

  #[global] Instance ID_HFunctor : HFunctor (fun x : Type -> Type => x).
  econstructor; intros; eauto. exact (fmap X0 X1).
  Defined.

  #[global] Program Instance ID_WF_IterativeMonadT : WF_IterativeMonadT (fun x : Type -> Type => x) _ _.
  Next Obligation.
    econstructor; eauto.
    repeat intro; eauto. econstructor; repeat intro; eauto. cbn.
    eapply eqmR_ret; eauto. typeclasses eauto.
    cbn. eapply Proper_bind; eauto.
  Defined.

  #[global] Program Instance ID_WF_HFunctor : WF_HFunctor (fun x : Type -> Type => x).
  Next Obligation.
    econstructor; try typeclasses eauto; repeat intro; eauto; cbn.
    reflexivity. reflexivity.
    repeat intro. cbn. eapply f_Proper. eauto.
  Qed.
  Next Obligation.
    econstructor; try typeclasses eauto; repeat intro; eauto; cbn.
    reflexivity.
  Qed.

  #[global] Program Instance stateT_WF_HFunctor {S} {inh_S : inhabited S} : WF_HFunctor (stateT S).

  #[global] Program Instance errorT_WF_HFunctor {exn} : WF_HFunctor (errorT exn).

  Lemma stateT_morph_ret:
    forall S : Type, inhabited S ->
      forall (E F : Type -> Type) (f : forall T : Type, E T -> stateT S (itree F) T),
        MorphRet (itree E) (stateT S (itree F)) (itree_interp f).
  Proof.
    intros S inh_S E F f.
    repeat intro.
    rewrite itree_eta. cbn.
    apply eqit_Ret; eauto.
  Qed.

  Definition _interp_state {E F S R}
            (f : E ~> stateT S (itree F)) (ot : itreeF E R _)
    : stateT S (itree F) R := fun s =>
    match ot with
    | RetF r => Ret (s, r)
    | TauF t => Tau (interp f t s)
    | VisF e k => f _ e s >>= (fun sx => Tau (interp f (k (snd sx)) (fst sx)))
    end.

  Lemma unfold_interp_state {E F S R} (h : E ~> Monads.stateT S (itree F))
        (t : itree E R) s :
      eq_itree eq
        (interp h t s)
        (_interp_state h (observe t) s).
  Proof.
    unfold interp, Basics.iter, MonadIter_stateT0, Basics.iter, MonadIter_itree; cbn.
    setoid_rewrite unfold_iter; cbn.
    rewrite Eq.bind_bind. setoid_rewrite Eq.bind_ret_l. unfold interp_body.
    destruct observe; cbn; try setoid_rewrite Eq.bind_ret_l; cbn.
    - reflexivity.
    - reflexivity.
    - setoid_rewrite Eq.bind_bind.
      setoid_rewrite Eq.bind_ret_l. cbn. reflexivity.
  Qed.

  #[global]
  Instance eq_itree_interp_state {E F S R} (h : E ~> Monads.stateT S (itree F)) :
    Proper (eq_itree eq ==> eq ==> eq_itree eq)
          (interp h (T0 := R)).
  Proof.
    revert_until R.
    ginit. gcofix CIH. intros h x y H0 x2 _ [].
    rewrite !unfold_interp_state.
    punfold H0; repeat red in H0.
    destruct H0; subst; pclearbot; try discriminate; cbn.
    - gstep; constructor; auto.
    - gstep; constructor; auto with paco.
    - guclo eqit_clo_bind. econstructor.
      + reflexivity.
      + intros [] _ []. gstep; constructor; auto with paco.
  Qed.

  #[global]
  Instance eutt_interp_state {E F: Type -> Type} {S : Type}
          (h : E ~> Monads.stateT S (itree F)) R RR :
    Proper (eutt RR ==> eq ==> eutt (prod_rel eq RR)) (interp h (T0 :=R)).
  Proof.
    repeat intro. subst. revert_until RR.
    einit. ecofix CIH. intros.

    rewrite !unfold_interp_state. punfold H0. red in H0.
    induction H0; intros; subst; simpl; pclearbot.
    - eret.
    - etau.
    - ebind. econstructor; [reflexivity|].
      intros; subst.
      etau. ebase.
    - rewrite tau_euttge, unfold_interp_state; eauto.
    - rewrite tau_euttge, unfold_interp_state; eauto.
  Qed.

  #[global]
  Definition euttH_interp_state {E F: Type -> Type} {S : Type}
          (h : E ~> Monads.stateT S (itree F)) R1 R2 RR :
    ProperH (eutt RR ~~> eq ~~> eutt (prod_rel eq RR)) (interp h (T0:=R1)) (interp h (T0:=R2)).
  Proof.
    repeat intro. subst. revert_until RR.
    einit. ecofix CIH. intros.

    rewrite !unfold_interp_state. punfold H0. red in H0.
    induction H0; intros; subst; simpl; pclearbot.
    - eret.
    - etau.
    - ebind. econstructor; [reflexivity|].
      intros; subst.
      etau. ebase.
    - rewrite tau_euttge, unfold_interp_state; eauto.
    - rewrite tau_euttge, unfold_interp_state; eauto.
  Qed.

  Lemma interp_state_tau {E F : Type -> Type} S {T : Type}
        (t : itree E T) (h : E ~> Monads.stateT S (itree F)) (s : S)
    : interp h (Tau t) s ≅ Tau (interp h t s).
  Proof.
    rewrite unfold_interp_state; reflexivity.
  Qed.

  Lemma interp_state_vis {E F : Type -> Type} {S T U : Type}
        (e : E T) (k : T -> itree E U) (h : E ~> Monads.stateT S (itree F)) (s : S)
    : interp h (Vis e k) s
    ≅ h T e s >>= fun sx => Tau (interp h (k (snd sx)) (fst sx)).
  Proof.
    rewrite unfold_interp_state; reflexivity.
  Qed.

  Lemma interp_state_bind {E F : Type -> Type} {A B S : Type}
        (f : E ~> Monads.stateT S (itree F))
        (t : itree E A) (k : A -> itree E B)
        (s : S) :
    (interp f (t >>= k) s)
      ≅
      (interp f t s >>= fun st => interp f (k (snd st)) (fst st)).
  Proof.
    revert t k s.
    ginit. pcofix CIH.
    intros t k s.
    setoid_rewrite unfold_bind at 1.
    setoid_rewrite (unfold_interp_state f _) at 2.
    destruct (observe t).
    - cbn. rewrite !Eq.bind_ret_l. cbn.
      apply reflexivity.
    - cbn. rewrite !bind_tau, interp_state_tau.
      gstep. red. apply EqTau. gbase. apply CIH.
    - cbn. rewrite interp_state_vis, Eq.bind_bind.
      guclo eqit_clo_bind. econstructor.
      + reflexivity.
      + intros u2 ? [].
        rewrite bind_tau.
        gstep; constructor.
        ITree.fold_subst.
        auto with paco.
  Qed.

  Lemma stateT_morph_bind:
    forall S : Type,
      inhabited S ->
      forall (E F : Type -> Type) (f : forall T : Type, E T -> stateT S (itree F) T),
        MorphBind (itree E) (stateT S (itree F)) (itree_interp f).
  Proof.
    repeat intro. setoid_rewrite interp_state_bind.
    eapply eutt_clo_bind; eauto.
    eapply euttH_interp_state; eauto.
    intros.
    eapply euttH_interp_state; eauto; inv H3; eauto.
    cbn. eapply H1; eauto.
  Qed.

  (* These are the base interpretations into state and error monads. *)
  #[global] Instance stateT_MonadMorphism :
    forall S {inh_S : inhabited S} (E F : Type -> Type) (f : E ~> stateT S (itree F)),
      MonadMorphism _ _ (itree_interp f).
  Proof.
    constructor; [ typeclasses eauto |
                  apply stateT_morph_ret; eauto |
                  apply stateT_morph_bind; eauto | ..].
    repeat intro. eapply euttH_interp_state; eauto.
  Qed.

  #[global] Instance stateT_IterMorphism:
    forall S {inh_S : inhabited S} (E F : Type -> Type) (f : E ~> stateT S (itree F)),
      IterMorphism (itree_interp f).
  Proof.
    unfold IterMorphism. cbn. setoid_rewrite prod_rel_eq.
    ginit. gcofix CIH; intros. cbn.
    setoid_rewrite unfold_iter at 2.
    setoid_rewrite unfold_iter at 2. cbn.
    rewrite !Eq.bind_bind.
    setoid_rewrite Eq.bind_ret_l.
    pose proof @interp_state_bind. setoid_rewrite H. clear H.
    guclo eqit_clo_bind; econstructor; eauto.
    - apply H0; eauto.
    - intros [s'' [|]] [s''' [ |]] []; cbn; subst.
      + subst. setoid_rewrite interp_state_tau.
        gstep; constructor. gfinal. left. eapply CIH; eauto.
      + subst. setoid_rewrite interp_state_tau.
        gstep; constructor. gfinal. left. eapply CIH; eauto.
      + pose proof @stateT_morph_ret. cbn in H. unfold MorphRet in H.
        unfold morph in H.
        specialize (H S _ E F f R _ eq r0 _ eq_refl s'' _ eq_refl).
        gfinal. right. cbn in H. rewrite prod_rel_eq in H.
        eapply paco2_mon; eauto; intros; contradiction.
      + pose proof @stateT_morph_ret. cbn in H. unfold MorphRet in H.
        unfold morph in H.
        specialize (H S _ E F f R _ eq r0 _ eq_refl s'' _ eq_refl).
        gfinal. right. cbn in H. rewrite prod_rel_eq in H.
        eapply paco2_mon; eauto; intros; contradiction.
  Qed.

  (** Unfolding of [interp_errorT]. *)
  Definition _interp_errorT {exn E F R} (f : E ~> errorT exn (itree F)) (ot : itreeF E R _)
    : errorT exn (itree F) R :=
    match ot with
    | RetF r => ret r
    | TauF t => Tau (interp f t)
    | VisF e k => bind (f _ e) (fun x => Tau (interp f (k x)))
    end.

  (** Unfold lemma. *)
  Lemma unfold_interp_errorT {exn E F R} (f : E ~> errorT exn (itree F)) (t : itree E R) :
    interp f t ≅
          (_interp_errorT f (observe t)).
  Proof.
    unfold interp. unfold Basics.iter, _interp_errorT, itree_interp
      , errorT_iter, Basics.iter, MonadIter_itree.
    rewrite unfold_iter. cbn.
    rewrite Eq.bind_bind. setoid_rewrite  Eq.bind_ret_l.
    unfold interp_body.
    destruct (observe t).
    tau_steps. reflexivity.
    tau_steps. reflexivity.
    setoid_rewrite Eq.bind_bind.
    apply eq_itree_clo_bind with (UU := Logic.eq); [reflexivity | intros x ? <-].
    destruct x as [x|].
    - cbn. rewrite Eq.bind_ret_l; reflexivity.
    - cbn. rewrite Eq.bind_ret_l; reflexivity.
  Qed.

  Lemma errorT_morph_ret:
    forall (exn : Type) (E F : Type -> Type) (f : forall T : Type, E T -> errorT exn (itree F) T),
      MorphRet (itree E) (errorT exn (itree F)) (itree_interp f).
  Proof.
    intros exn E F f.
    repeat intro. setoid_rewrite unfold_interp_errorT.
    eapply eqmR_ret; eauto. typeclasses eauto.
  Qed.

  Global Instance interp_errorT_eq_itree {exn X E F} {R : X -> X -> Prop}
        (h : E ~> errorT exn (itree F)) :
    Proper (eq_itree R ==> eq_itree (eq ⊕ R)) (interp h (T0 := X)).
  Proof.
    repeat red.
    ginit.
    pcofix CIH.
    intros s t EQ.
    rewrite 2 unfold_interp_errorT.
    punfold EQ; red in EQ.
    destruct EQ; cbn; subst; try discriminate; pclearbot; try (gstep; constructor; eauto with paco; fail).
    guclo eqit_clo_bind; econstructor; [reflexivity | intros x ? <-].
    destruct x as [x|]; gstep; econstructor; eauto with paco.
  Qed.

  Global Instance interp_errorT_eq_itree_eq {exn X E F} (h : E ~> errorT exn (itree F)) :
    Proper (eq_itree eq ==> eq_itree eq) (interp h (T0 := X)).
  Proof.
    repeat intro. rewrite <- sum_rel_eq.
    eapply interp_errorT_eq_itree; auto.
  Qed.

  Global Instance interp_errorT_eutt {exn X E F R} (h : E ~> errorT exn (itree F)) :
    Proper (eutt R ==> eutt (eq ⊕ R)) (interp h (T0 := X)).
  Proof.
    repeat red.
    einit.
    ecofix CIH.
    intros s t EQ.
    setoid_rewrite unfold_interp_errorT.
    punfold EQ; red in EQ.
    induction EQ; intros; cbn; subst; try discriminate; pclearbot; try (estep; constructor; eauto with paco; fail).
    - ebind; econstructor; [reflexivity |].
      intros [] [] EQ; inv EQ.
      + estep; ebase.
      + estep; ebase.
    - rewrite tau_euttge, unfold_interp_errorT; eauto.
    - rewrite tau_euttge, unfold_interp_errorT; eauto.
  Qed.

  Global Definition interp_errorT_euttH {exn X1 X2 E F} (R : X1 -> X2 -> Prop)
        (h : E ~> errorT exn (itree F)) :
    ProperH (eutt R ~~> eutt (eq ⊕ R)) (interp h (T0 := X1)) (interp h (T0 := X2)).
  Proof.
    repeat red.
    einit.
    ecofix CIH.
    intros s t EQ.
    setoid_rewrite unfold_interp_errorT.
    punfold EQ; red in EQ.
    induction EQ; intros; cbn; subst; try discriminate; pclearbot; try (estep; constructor; eauto with paco; fail).
    - ebind; econstructor; [reflexivity |].
      intros [] [] EQ; inv EQ.
      + estep; ebase.
      + estep; ebase.
    - rewrite tau_euttge, unfold_interp_errorT; eauto.
    - rewrite tau_euttge, unfold_interp_errorT; eauto.
  Qed.

  Global Instance interp_errorT_eutt_eq {exn X E F} (h : E ~> errorT exn (itree F)) :
    Proper (eutt eq ==> eutt eq) (interp h (T0 := X)).
  Proof.
    repeat intro.
    rewrite <- sum_rel_eq.
    apply interp_errorT_eutt; auto.
  Qed.

  Lemma interp_errorT_tau {exn E F R} {f : E ~> errorT exn (itree F)} (t: itree E R):
    eq_itree eq (interp f (Tau t)) (Tau (interp f t)).
  Proof. rewrite unfold_interp_errorT. reflexivity. Qed.

  Lemma interp_errorT_vis {E F : Type -> Type} {T U exn : Type}
        (e : E T) (k : T -> itree E U) (h : E ~> errorT exn (itree F))
    : interp h (Vis e k)
                  ≅ bind (h T e) (fun mx => Tau (interp h (k mx))).
  Proof.
    rewrite unfold_interp_errorT. reflexivity.
  Qed.

  Lemma interp_errorT_bind : forall {exn X Y E F} (t : itree _ X) (k : X -> itree _ Y)
                              (h : E ~> errorT exn (itree F)),
      interp h (bind t k) ≅
                  bind (interp h t) (fun x => interp h (k x)).
  Proof.
    intros exn X Y E F; ginit; gcofix CIH; intros.
    pose proof (@unfold_interp_errorT exn E F X h t).
    unfold interp, itree_interp in *. cbn.
    rewrite H.
    setoid_rewrite unfold_bind at 1.
    destruct (observe t) eqn:EQ; cbn.
    - rewrite Eq.bind_ret_l. apply reflexivity.
    - cbn. rewrite bind_tau. setoid_rewrite interp_errorT_tau.
      gstep. econstructor; eauto with paco.
      cbn in CIH. gbase. eapply CIH.
    - rewrite Eq.bind_bind. setoid_rewrite interp_errorT_vis.
      guclo eqit_clo_bind; econstructor.
      reflexivity.
      intros [] ? <-; cbn.
      + rewrite Eq.bind_ret_l.
        apply reflexivity.
      + rewrite bind_tau.
        gstep; constructor.
        ITree.fold_subst. gbase. eapply CIH.
  Qed.

  Lemma errorT_morph_bind:
    forall (exn : Type) (E F : Type -> Type) (f : forall T : Type, E T -> errorT exn (itree F) T),
      MorphBind (itree E) (errorT exn (itree F)) (itree_interp f).
  Proof.
    repeat intro. setoid_rewrite interp_errorT_bind.
    eapply eutt_clo_bind; eauto.
    eapply interp_errorT_euttH; eauto.
    intros. inv H1; try apply eqit_Ret; eauto.
    eapply interp_errorT_euttH; eauto. eapply H0; eauto.
  Qed.

  #[global] Instance errorT_MonadMorphism :
    forall exn (E F : Type -> Type) (f : E ~> errorT exn (itree F)),
      MonadMorphism _ _ (itree_interp f).
  Proof.
    constructor; [constructor; try typeclasses eauto |
                  apply errorT_morph_ret |
                  apply errorT_morph_bind |..].
    repeat intro; eapply interp_errorT_euttH; eauto.
  Qed.

  #[global] Instance errorT_IterMorphism:
    forall exn (E F : Type -> Type) (f : E ~> errorT exn (itree F)),
      IterMorphism (itree_interp f).
  Proof.
    unfold IterMorphism. cbn. setoid_rewrite sum_rel_eq.
    ginit. gcofix CIH; intros. cbn.
    setoid_rewrite unfold_iter at 2.
    setoid_rewrite unfold_iter at 2. cbn.
    rewrite !Eq.bind_bind.
    setoid_rewrite Eq.bind_ret_l.
    pose proof @interp_errorT_bind. setoid_rewrite H. clear H.
    guclo eqit_clo_bind; econstructor; eauto.
    - apply H0; eauto.
    - intros [s'' | [|]] [s''' | [ |]] H; cbn; subst; inv H.
      + gstep; constructor; eauto.
      + subst. setoid_rewrite interp_errorT_tau.
        gstep; constructor. gfinal. left. eapply CIH; eauto.
      + pose proof @errorT_morph_ret. cbn in H. unfold MorphRet in H.
        unfold morph in H.
        specialize (H exn E F f R _ eq r1 _ eq_refl).
        gfinal. right. cbn in H. rewrite sum_rel_eq in H.
        eapply paco2_mon; eauto; intros; contradiction.
  Qed.

End HFunctorInstances.

(** ** Nesting HFunctors *)
(** HFunctors compose(nest) to make a HFunctor, and also the well-formedness
  properties are closed under nesting as well. *)
Section ComposeHFunctors.

  #[local] Instance compose_HFunctor {S T : (Type -> Type) -> Type -> Type} `{HFunctor S} `{HFunctor T}:
    HFunctor (fun x => S (T x)).
  Proof.
    constructor.
    - intros. eapply (ffmap X0 X1).
      Unshelve.
      constructor. exact (fun x y F X => ffmap F X).
    - intros. exact (hfmap (hfmap X) X0).
  Defined.

  #[local] Instance compose_WF_HFunctor {S T : (Type -> Type) -> Type -> Type} `{WF_HFunctor S} `{WF_HFunctor T}:
    WF_HFunctor (fun x => S (T x)).
  Proof.
    econstructor; constructor; intros.
    - cbn. etransitivity. eapply @hfmap_proper; try typeclasses eauto.
      repeat intro; eauto. Unshelve. 4 : exact (fun _ X => X).
      cbn. eapply Proper_eqmR_cong.
      eapply hfmap_id; eauto. reflexivity. auto. reflexivity.
      eapply hfmap_id; eauto. typeclasses eauto.
    - cbn. etransitivity. eapply @hfmap_proper; try typeclasses eauto.
      repeat intro; eauto.
      cbn. eapply Proper_eqmR_cong.
      eapply hfmap_comp; eauto. reflexivity.
      eapply hfmap_morph_proper; try eauto.
      eapply hfmap_morph_proper; try eauto. reflexivity.
      eapply hfmap_comp; eauto. all : try typeclasses eauto.
      eapply hfmap_morph_proper; try eauto.
      eapply hfmap_morph_proper; try eauto.
    - cbn; constructor; try typeclasses eauto; repeat intro.
      + cbn.
        destruct H.
        destruct T_HFunctorLaws0.
        pose proof (hfmap_nat0 (T g) (T h) _ _ _ _ _ _ (@hfmap _ _ g h F) _).
        destruct H. repeat red in MM_morph_ret. cbn in *. eapply MM_morph_ret; eauto.
      + cbn.
        destruct H.
        destruct T_HFunctorLaws0.
        pose proof (hfmap_nat0 (T g) (T h) _ _ _ _ _ _ (@hfmap _ _ g h F) _).
        destruct H. repeat red in MM_morph_bind. cbn in *. eapply MM_morph_bind; eauto.
      + cbn.
        destruct H.
        destruct T_HFunctorLaws0.
        pose proof (hfmap_nat0 (T g) (T h) _ _ _ _ _ _ (@hfmap _ _ g h F) _).
        destruct H. repeat red in MM_morph_proper. cbn in *. eapply MM_morph_proper; eauto.
    - repeat intro. cbn.
      eapply (@hfmap_proper S); try typeclasses eauto.
      repeat intro.
      eapply (@hfmap_proper T); try typeclasses eauto; repeat intro; eauto. eauto.
    - repeat intro. cbn. eapply hfmap_morph_proper; try typeclasses eauto; eauto.
      repeat intro. cbn. eapply hfmap_morph_proper; try typeclasses eauto; eauto.
    - cbn -[lift].
      etransitivity.
      eapply (@hfmap_lift S); try typeclasses eauto.
      econstructor; try typeclasses eauto.
      econstructor; try typeclasses eauto.
      eapply morph_proper.
      eapply (@hfmap_lift T); try typeclasses eauto.
    - repeat intro. cbn.
      etransitivity.
      eapply (@hfmap_iter S); try typeclasses eauto.
      econstructor; try typeclasses eauto.
      econstructor; try typeclasses eauto.
      destruct H0. destruct T_HFunctorLawsExtra0. eapply hfmap_iter0; typeclasses eauto.
      eauto. reflexivity.
      Unshelve.
  Defined.

End ComposeHFunctors.


Require Import Prelim.

(** * Decidable predicates *)

Definition dec (X: Prop) : Type := {X} + {~ X}.

Coercion dec2bool P (d: dec P) := if d then true else false.

Existing Class dec.

Definition Dec (X: Prop) (d: dec X) : dec X := d.
Arguments Dec X {d}.

Lemma Dec_reflect (X: Prop) (d: dec X) :
  Dec X <-> X.
Proof.
  destruct d as [A|A]; cbn; tauto.
Qed.

Notation Decb X := (dec2bool (Dec X)).

Lemma Dec_reflect_eq (X Y: Prop) (d: dec X) (e: dec Y) :
 Decb X = Decb Y <->  (X <-> Y).
Proof.
  destruct d as [D|D], e as [E|E]; cbn; intuition congruence.
Qed.

Lemma Dec_auto (X: Prop) (d: dec X) :
  X -> Dec X.
Proof.
  destruct d as [A|A]; cbn; tauto.
Qed.

Lemma Dec_auto_not (X: Prop) (d: dec X) :
  ~ X -> ~ Dec X.
Proof.
  destruct d as [A|A]; cbn; tauto.
Qed.

Hint Resolve Dec_auto Dec_auto_not.
Hint Extern 4 =>  (* Improves type class inference *)
match goal with
  | [  |- dec ((fun _ => _) _) ] => cbn
end : typeclass_instances.

Tactic Notation "decide" constr(p) :=
  destruct (Dec p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (Dec p) as i.
Tactic Notation "decide" "_" :=
  destruct (Dec _).
Tactic Notation "have" constr(E) := let X := fresh "E" in decide E as [X|X]; subst; try congruence; try omega; clear X.

Lemma Dec_true P {H : dec P} : dec2bool (Dec P) = true -> P.
Proof.
  decide P; cbv in *; firstorder.
Qed.

Lemma Dec_false P {H : dec P} : dec2bool (Dec P) = false -> ~P.
Proof.
  decide P; cbv in *; firstorder.
Qed.

Lemma Dec_true' (P : Prop) (d : dec P) : P -> Decb P = true.
Proof. intros H. decide P; cbn; tauto. Qed.

Lemma Dec_false' (P : Prop) (d : dec P) : (~ P) -> Decb P = false.
Proof. intros H. decide P; cbn; tauto. Qed.

Hint Extern 4 =>
match goal with
  [ H : dec2bool (Dec ?P) = true  |- _ ] => apply Dec_true in  H
| [ H : dec2bool (Dec ?P) = false |- _ ] => apply Dec_false in H
| [ |- dec2bool (Dec ?P) = true] => apply Dec_true'
| [ |- dec2bool (Dec ?P) = false] => apply Dec_false'
end.

(** Decided propositions behave classically *)

Lemma dec_DN X :
  dec X -> ~~ X -> X.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_and X Y :
  dec X -> dec Y -> ~ (X /\ Y) -> ~ X \/ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_impl X Y :
  dec X -> dec Y -> ~ (X -> Y) -> X /\ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

(** Propagation rules for decisions *)

Fact dec_transfer P Q :
  P <-> Q -> dec P -> dec Q.
Proof.
  unfold dec. tauto.
Defined.

Instance bool_dec (b: bool) :
  dec b.
Proof.
  unfold dec. destruct b; cbn; auto.
Defined.

Instance True_dec :
  dec True.
Proof.
  unfold dec; tauto.
Defined.

Instance False_dec :
  dec False.
Proof.
  unfold dec; tauto.
Defined.

Instance impl_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X -> Y).
Proof.
  unfold dec; tauto.
Defined.

Instance and_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X /\ Y).
Proof.
  unfold dec; tauto.
Defined.

Instance or_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X \/ Y).
Proof.
  unfold dec; tauto.
Defined.

(* Coq standard modules make "not" and "iff" opaque for type class inference,
   can be seen with Print HintDb typeclass_instances. *)

Instance not_dec (X : Prop) :
  dec X -> dec (~ X).
Proof.
  unfold not. auto.
Defined.

Instance iff_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X <-> Y).
Proof.
  unfold iff. auto.
Defined.

(** ** Discrete types *)

Notation "'eq_dec' X" := (forall x y : X, dec (x=y)) (at level 70).

Structure eqType :=
  EqType {
      eqType_X :> Type;
      eqType_dec : eq_dec eqType_X
    }.

Arguments EqType X {_} : rename.

Canonical Structure eqType_CS X (A: eq_dec X) := EqType X.

Existing Instance eqType_dec.

(** Print the base type of [eqType] in the Canonical Structure. *)
Arguments eqType_CS (X) {_}.

Instance unit_eq_dec :
  eq_dec unit.
Proof.
  unfold dec. decide equality.
Defined.

Instance bool_eq_dec :
  eq_dec bool.
Proof.
  unfold dec. decide equality.
Defined.

Instance nat_eq_dec :
  eq_dec nat.
Proof.
  unfold dec. decide equality.
Defined.

Instance prod_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X * Y).
Proof.
  unfold dec. decide equality.
Defined.

Instance list_eq_dec X :
  eq_dec X -> eq_dec (list X).
Proof.
  unfold dec. decide equality.
Defined.

Instance sum_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X + Y).
Proof.
  unfold dec. decide equality.
Defined.

Instance option_eq_dec X :
  eq_dec X -> eq_dec (option X).
Proof.
  unfold dec. decide equality.
Defined.

Instance Empty_set_eq_dec:
  eq_dec Empty_set.
Proof.
  unfold dec. decide equality.
Defined.

Instance True_eq_dec:
  eq_dec True.
Proof.
  intros x y. destruct x,y. now left.
Defined.

Instance False_eq_dec:
  eq_dec False.
Proof.
  intros [].
Defined.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

Require Import Coq.Arith.Arith.
Require Import Coq.Arith.Max.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Lists.List.
Require Import Coq.Logic.DecidableTypeEx.

Require Import CoqFSetDecide.
Require Import CoqListFacts.
Require Import FSetExtra.
Require Import FSetWeakNotin.
Require Import LibTactics.

(* ********************************************************************** *)
(** * Defining atoms *)

(** Atoms are structureless objects such that we can always generate
    one fresh from a finite collection.  Equality on atoms is [eq] and
    decidable.  We use Coq's module system to make abstract the
    implementation of atoms. *)

Module Type ATOM.

  Parameter atom : Set.

  Parameter eq_atom_dec : forall x y : atom, {x = y} + {x <> y}.

  Parameter atom_fresh_for_list :
    forall (xs : list atom), {x : atom | ~ List.In x xs}.

  Hint Resolve eq_atom_dec.

End ATOM.

(** The implementation of the above interface is hidden for
    documentation purposes. *)

Module AtomImpl : ATOM.

  (* begin hide *)

  Definition atom := nat.

  Definition eq_atom_dec := eq_nat_dec.

  Lemma max_lt_r : forall x y z,
    x <= z -> x <= max y z.
  Proof.
    induction x. auto with arith.
    induction y. auto with arith.
      simpl. induction z. omega. auto with arith.
  Qed.

  Lemma nat_list_max : forall (xs : list nat),
    { n : nat | forall x, List.In x xs -> x <= n }.
  Proof.
    induction xs as [ | x xs [y H] ].
    (* case: nil *)
    exists 0. inversion 1.
    (* case: cons x xs *)
    exists (max x y). intros z J. simpl in J. destruct J as [K | K].
      subst. auto with arith.
      auto using max_lt_r.
  Qed.

  Lemma atom_fresh_for_list :
    forall (xs : list atom), { n : atom | ~ List.In n xs }.
  Proof.
    intros xs. destruct (nat_list_max xs) as [x H].
    exists (S x). intros J. lapply (H (S x)). omega. trivial.
  Qed.

  (* end hide *)

End AtomImpl.

(** We make [atom], [eq_atom_dec], and [atom_fresh_for_list] available
    without qualification. *)

Export AtomImpl.

(** It is trivial to implement the [DecidableType] interface with [atom]. *)

Module AtomDT <: UsualDecidableType with Definition t := atom.

  Definition t := atom.

  Definition eq := @eq t.
  Definition eq_refl := @refl_equal t.
  Definition eq_sym := @sym_eq t.
  Definition eq_trans := @trans_eq t.

  Definition eq_dec := eq_atom_dec.

End AtomDT.

(** It is trivial to declare an instance of [EqDec] for [atom]. *)

Instance EqDec_atom : @EqDec atom eq eq_equivalence.
Proof. exact eq_atom_dec. Defined.

(* ********************************************************************** *)
(** * Finite sets of atoms *)

(** We use our implementation of atoms to obtain an implementation of
    finite sets of atoms.  We give the resulting type an intuitive
    name, as well as import names of set operations for use within
    this library.  In order to avoid polluting Coq's namespace, we do
    not use [Module Export]. *)

Module Import AtomSetImpl : FSetExtra.WSfun AtomDT :=
  FSetExtra.Make AtomDT.

Notation atoms :=
  AtomSetImpl.t.

(** The [AtomSetDecide] module provides the [fsetdec] tactic for
    solving facts about finite sets of atoms. *)

Module Export AtomSetDecide := CoqFSetDecide.WDecide_fun AtomDT AtomSetImpl.

(** The [AtomSetNotin] module provides the [destruct_notin] and
    [solve_notin] for reasoning about non-membership in finite sets of
    atoms, as well as a variety of lemmas about non-membership. *)

Module Export AtomSetNotin := FSetWeakNotin.Notin_fun AtomDT AtomSetImpl.

(** Given the [fsetdec] tactic, we typically do not need to refer to
    specific lemmas about finite sets.  However, instantiating
    functors from the FSets library makes a number of setoid rewrites
    available.  These rewrites are crucial to developments since they
    allow us to replace a set with an extensionally equal set (see the
    [Equal] relation on finite sets) in propositions about finite
    sets. *)

Module AtomSetFacts := FSetFacts.WFacts_fun AtomDT AtomSetImpl.
Module AtomSetProperties := FSetProperties.WProperties_fun AtomDT AtomSetImpl.

(* ********************************************************************** *)
(** * Properties *)

(** For any given finite set of atoms, we can generate an atom fresh
    for it. *)

Lemma atom_fresh : forall L : atoms, { x : atom | ~ In x L }.
Proof.
  intros L. destruct (atom_fresh_for_list (elements L)) as [a H].
  exists a. intros J. contradiction H.
  rewrite <- CoqListFacts.InA_iff_In. auto using @elements_1.
Qed.

(* ********************************************************************** *)
(** * Tactic support for picking fresh atoms *)

(* begin hide *)

(** The auxiliary tactic [simplify_list_of_atom_sets] takes a list of
    finite sets of atoms and unions everything together, returning the
    resulting single finite set. *)

Ltac simplify_list_of_atom_sets L :=
  let L := eval simpl in L in
  let L := ltac_remove_dups L in
  let L := eval simpl in (List.fold_right union empty L) in
  match L with
    | context C [union ?E empty] => context C [ E ]
  end.

(* end hide *)

(** [gather_atoms_with F] returns the union of all the finite sets
    [F x] where [x] is a variable from the context such that [F x]
    type checks. *)

Ltac gather_atoms_with F :=
  let apply_arg x :=
    match type of F with
      | _ -> _ -> _ -> _ => constr:(@F _ _ x)
      | _ -> _ -> _ => constr:(@F _ x)
      | _ -> _ => constr:(@F x)
    end in
  let rec gather V :=
    match goal with
      | H : _ |- _ =>
        let FH := apply_arg H in
        match V with
          | context [FH] => fail 1
          | _ => gather (union FH V)
        end
      | _ => V
    end in
  let L := gather empty in eval simpl in L.

(** [beautify_fset V] assumes that [V] is built as a union of finite
    sets and returns the same set cleaned up: empty sets are removed
    and items are laid out in a nicely parenthesized way. *)

Ltac beautify_fset V :=
  let rec go Acc E :=
     match E with
     | union ?E1 ?E2 => let Acc2 := go Acc E2 in go Acc2 E1
     | empty => Acc
     | ?E1 => match Acc with
                | empty => E1
                | _ => constr:(union E1 Acc)
              end
     end
  in go empty V.

(** The tactic [pick fresh Y for L] takes a finite set of atoms [L]
    and a fresh name [Y], and adds to the context an atom with name
    [Y] and a proof that [~ In Y L], i.e., that [Y] is fresh for [L].
    The tactic will fail if [Y] is already declared in the context.

    The variant [pick fresh Y] is similar, except that [Y] is fresh
    for "all atoms in the context."  This version depends on the
    tactic [gather_atoms], which is responsible for returning the set
    of "all atoms in the context."  By default, it returns the empty
    set, but users are free (and expected) to redefine it. *)

Ltac gather_atoms :=
  constr:empty.

Tactic Notation "pick" "fresh" ident(Y) "for" constr(L) :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (atom_fresh L) as [Y Fr]).

Tactic Notation "pick" "fresh" ident(Y) :=
  let L := gather_atoms in
  pick fresh Y for L.

Ltac pick_fresh y :=
  pick fresh y.

(** Example: We can redefine [gather_atoms] to return all the
    "obvious" atoms in the context using the [gather_atoms_with] thus
    giving us a "useful" version of the "[pick fresh]" tactic. *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  constr:(union A B).

Lemma example_pick_fresh_use : forall (x y z : atom) (L1 L2 L3: atoms), True.
(* begin show *)
Proof.
  intros x y z L1 L2 L3.
  pick fresh k.

  (** At this point in the proof, we have a new atom [k] and a
      hypothesis [Fr] that [k] is fresh for [x], [y], [z], [L1], [L2],
      and [L3]. *)

  trivial.
Qed.
(* end show *)