(** * AltAuto: A Streamlined Treatment of Automation *)

(** This chapter gives an alternative treatment of Coq automation that
    does not depend on [Imp].  It contains most of the automation
    material from that chapter, and most of the existing [Auto]
    chapter except for material on [match].  It is suitable, e.g., for
    a course that wants to move quickly on to VFA (which covers
    [match]) without doing any language metatheory at all. *)

    Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
    From Coq Require Import Lia Arith.
    From LF Require Import IndProp.

    (** Up to now, we've used the more manual part of Coq's tactic
        facilities.  In this chapter, we'll learn more about some of Coq's
        powerful automation features.

        As a simple illustration of the benefits of automation, let's
        consider another problem on regular expressions, which we
        formalized in [IndProp].  A given set of strings can be
        denoted by many different regular expressions.  For example, [App
        EmptyString re] matches exactly the same strings as [re].  We can
        write a function that "optimizes" any regular expression into a
        potentially simpler one by applying this fact throughout the
        r.e.  (Note that, for simplicity, the function does not optimize
        expressions that arise as the result of other optimizations.) *)

    Fixpoint re_opt_e {T:Type} (re: reg_exp T) : reg_exp T :=
      match re with
      | App EmptyStr re2 => re_opt_e re2
      | App re1 re2 => App (re_opt_e re1) (re_opt_e re2)
      | Union re1 re2 => Union (re_opt_e re1) (re_opt_e re2)
      | Star re => Star (re_opt_e re)
      | _ => re
      end.

    (** We would like to show the equivalence of re's with their "optimized" form.
    One direction of this equivalence looks like this (the other is similar).
    *)

    Lemma re_opt_e_match : forall T (re: reg_exp T) s,
      s =~ re -> s =~ re_opt_e re.
    Proof.
      intros T re s M.
      induction M
        as [| x'
            | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
            | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
            | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2].
      - (* MEmpty *) simpl. apply MEmpty.
      - (* MChar *) simpl. apply MChar.
      - (* MApp *) simpl.
        destruct re1.
        + apply MApp. apply IH1. apply IH2.
        + inversion Hmatch1. simpl.  apply IH2.
        + apply MApp. apply IH1. apply IH2.
        + apply MApp. apply IH1. apply IH2.
        + apply MApp. apply IH1. apply IH2.
        + apply MApp. apply IH1. apply IH2.
      - (* MUnionL *) simpl. apply MUnionL. apply IH.
      - (* MUnionR *) simpl. apply MUnionR. apply IH.
      - (* MStar0 *) simpl. apply MStar0.
      - (* MStarApp *) simpl. apply MStarApp. apply IH1.  apply IH2.
    Qed.

    (* ################################################################# *)
    (** * Coq Automation *)

    (** The amount of repetition in this last proof is rather
        annoying.  And if we wanted to extend the optimization function to
        handle other, similar, rewriting opportunities,
        it would start to be a real problem.

        So far, we've been doing all our proofs using just a small handful
        of Coq's tactics and completely ignoring its powerful facilities
        for constructing parts of proofs automatically.  This section
        introduces some of these facilities, and we will see more over the
        next several chapters.  Getting used to them will take some
        energy -- Coq's automation is a power tool -- but it will allow us
        to scale up our efforts to more complex definitions and more
        interesting properties without becoming overwhelmed by boring,
        repetitive, low-level details. *)

    (* ################################################################# *)
    (** * Tacticals *)

    (** _Tacticals_ is Coq's term for tactics that take other tactics as
        arguments -- "higher-order tactics," if you will.  *)

    (* ----------------------------------------------------------------- *)
    (** *** The [try] Tactical *)

    (** If [T] is a tactic, then [try T] is a tactic that is just like [T]
        except that, if [T] fails, [try T] _successfully_ does nothing at
        all (instead of failing). *)

    Theorem silly1 : forall n,  1 + n = S n.
    Proof. try reflexivity. (* this just does [reflexivity] *) Qed.

    Theorem silly2 : forall (P : Prop), P -> P.
    Proof.
      intros P HP.
      try reflexivity. (* just [reflexivity] would have failed *)
      apply HP. (* we can still finish the proof in some other way *)
    Qed.

    (** There is no real reason to use [try] in completely manual
        proofs like these, but it is very useful for doing automated
        proofs in conjunction with the [;] tactical, which we show
        next. *)

    (* ----------------------------------------------------------------- *)
    (** *** The [;] Tactical (Simple Form) *)

    (** In its most common form, the [;] tactical takes two tactics as
        arguments.  The compound tactic [T;T'] first performs [T] and then
        performs [T'] on _each subgoal_ generated by [T]. *)

    (** For example, consider the following trivial lemma: *)

    Lemma foo : forall n,  n+1 =? 0 = false.
    Proof.
      intros.
      destruct n eqn:E.
        (* Leaves two subgoals, which are discharged identically...  *)
        - (* n=0 *) simpl. reflexivity.
        - (* n=Sn' *) simpl. reflexivity.
    Qed.

    (** We can simplify this proof using the [;] tactical: *)

    Lemma foo' : forall n, n+1 =? 0 = false.
    Proof.
      intros.
      (* [destruct] the current goal *)
      destruct n;
      (* then [simpl] each resulting subgoal *)
      simpl;
      (* and do [reflexivity] on each resulting subgoal *)
      reflexivity.
    Qed.

    (** Using [try] and [;] together, we can get rid of the repetition in
        the proof that was bothering us a little while ago. *)

    Lemma re_opt_e_match' : forall T (re: reg_exp T) s,
      s =~ re -> s =~ re_opt_e re.
    Proof.
      intros T re s M.
      induction M
        as [| x'
            | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
            | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
            | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2];
        (* Do the [simpl] for every case here: *)
        simpl.
      - (* MEmpty *) apply MEmpty.
      - (* MChar *) apply MChar.
      - (* MApp *)
        destruct re1;
        (* Most cases follow by the same formula.
           Notice that [apply MApp] gives two subgoals:
           [try apply IH1] is run on both of them and
           succeeds on the first but not the second;
           [apply IH2] is then run on this remaining goal. *)
        try (apply MApp; try apply IH1; apply IH2).
        (* The interesting case, on which [try...] does nothing,
           is when [re1 = EmptyStr]. In this case, we have
           to appeal to the fact that [re1] matches only the
           empty string: *)
        inversion Hmatch1. simpl. apply IH2.
      - (* MUnionL *) apply MUnionL. apply IH.
      - (* MUnionR *) apply MUnionR. apply IH.
      - (* MStar0 *) apply MStar0.
      - (* MStarApp *)  apply MStarApp. apply IH1.  apply IH2.
    Qed.

    (* ----------------------------------------------------------------- *)
    (** *** The [;] Tactical (General Form) *)

    (** The [;] tactical also has a more general form than the simple
        [T;T'] we've seen above.  If [T], [T1], ..., [Tn] are tactics,
        then

          T; [T1 | T2 | ... | Tn]

        is a tactic that first performs [T] and then performs [T1] on the
        first subgoal generated by [T], performs [T2] on the second
        subgoal, etc.

        So [T;T'] is just special notation for the case when all of the
        [Ti]'s are the same tactic; i.e., [T;T'] is shorthand for:

          T; [T' | T' | ... | T']
    *)

    (** We can use this mechanism to give a slightly neater version
        of our optimization proof: *)

    Lemma re_opt_e_match'' : forall T (re: reg_exp T) s,
      s =~ re -> s =~ re_opt_e re.
    Proof.
      intros T re s M.
      induction M
        as [| x'
            | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
            | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
            | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2];
        (* Do the [simpl] for every case here: *)
        simpl.
      - (* MEmpty *) apply MEmpty.
      - (* MChar *) apply MChar.
      - (* MApp *)
        destruct re1;
        try (apply MApp; [apply IH1 | apply IH2]).  (* <=== *)
        inversion Hmatch1. simpl. apply IH2.
      - (* MUnionL *) apply MUnionL. apply IH.
      - (* MUnionR *) apply MUnionR. apply IH.
      - (* MStar0 *) apply MStar0.
      - (* MStarApp *)  apply MStarApp; [apply IH1 |  apply IH2].  (* <=== *)
    Qed.

    (* ----------------------------------------------------------------- *)
    (** *** The [repeat] Tactical *)

    (** The [repeat] tactical takes another tactic and keeps applying this
        tactic until it fails or stops making progress. Here is an example
        showing that [10] is in a long list using repeat. *)

    Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
    Proof.
      repeat (try (left; reflexivity); right).
    Qed.

    (** The tactic [repeat T] never fails: if the tactic [T] doesn't apply
        to the original goal, then repeat still succeeds without changing
        the original goal (i.e., it repeats zero times). *)

    Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10].
    Proof.
      repeat (left; reflexivity).
      repeat (right; try (left; reflexivity)).
    Qed.

    (** The tactic [repeat T] also does not have any upper bound on the
        number of times it applies [T].  If [T] is a tactic that always
        succeeds, then repeat [T] will loop forever (e.g., [repeat simpl]
        loops, since [simpl] always succeeds).  While evaluation in Coq's
        term language, Gallina, is guaranteed to terminate, tactic
        evaluation is not!  This does not affect Coq's logical
        consistency, however, since the job of [repeat] and other tactics
        is to guide Coq in constructing proofs; if the construction
        process diverges, this simply means that we have failed to
        construct a proof, not that we have constructed a wrong one. *)

    (** **** Exercise: 3 stars, standard (re_opt) *)

    (** Consider this more powerful version of the regular expression optimizer. *)

    Fixpoint re_opt {T:Type} (re: reg_exp T) : reg_exp T :=
      match re with
      | App _ EmptySet => EmptySet
      | App EmptyStr re2 => re_opt re2
      | App re1 EmptyStr => re_opt re1
      | App re1 re2 => App (re_opt re1) (re_opt re2)
      | Union EmptySet re2 => re_opt re2
      | Union re1 EmptySet => re_opt re1
      | Union re1 re2 => Union (re_opt re1) (re_opt re2)
      | Star EmptySet => EmptyStr
      | Star EmptyStr => EmptyStr
      | Star re => Star (re_opt re)
      | EmptySet => EmptySet
      | EmptyStr => EmptyStr
      | Char x => Char x
      end.

    (* Here is an incredibly tedious manual proof of (one direction of) its correctness: *)

    Lemma re_opt_match : forall T (re: reg_exp T) s,
      s =~ re -> s =~ re_opt re.
    Proof.
      intros T re s M.
      induction M
        as [| x'
            | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
            | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
            | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2].
      - simpl. apply MEmpty.
      - simpl. apply MChar.
      - simpl.
        destruct re1.
        + inversion IH1.
        + inversion IH1. simpl. destruct re2.
          * apply IH2.
          * apply IH2.
          * apply IH2.
          * apply IH2.
          * apply IH2.
          * apply IH2.
        + destruct re2.
          * inversion IH2.
          * inversion IH2. rewrite app_nil_r. apply IH1.
          * apply MApp. apply IH1. apply IH2.
          * apply MApp. apply IH1. apply IH2.
          * apply MApp. apply IH1. apply IH2.
          * apply MApp. apply IH1. apply IH2.
        + destruct re2.
          * inversion IH2.
          * inversion IH2. rewrite app_nil_r.  apply IH1.
          * apply MApp. apply IH1. apply IH2.
          * apply MApp. apply IH1.  apply IH2.
          * apply MApp. apply IH1.  apply IH2.
          * apply MApp. apply IH1.  apply IH2.
        + destruct re2.
          * inversion IH2.
          * inversion IH2. rewrite app_nil_r. apply IH1.
          * apply MApp. apply IH1.  apply IH2.
          * apply MApp. apply IH1.  apply IH2.
          * apply MApp. apply IH1.  apply IH2.
          * apply MApp. apply IH1.  apply IH2.
        + destruct re2.
          * inversion IH2.
          * inversion IH2. rewrite app_nil_r. apply IH1.
          * apply MApp. apply IH1.  apply IH2.
          * apply MApp. apply IH1.  apply IH2.
          * apply MApp. apply IH1.  apply IH2.
          * apply MApp. apply IH1.  apply IH2.
      - simpl.
        destruct re1.
        + inversion IH.
        + destruct re2.
          * apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
        + destruct re2.
          * apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
        + destruct re2.
          * apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
        + destruct re2.
          * apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
        + destruct re2.
          * apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
          * apply MUnionL. apply IH.
      - simpl.
        destruct re1.
        + apply IH.
        + destruct re2.
          * inversion IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
        + destruct re2.
          * inversion IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
        + destruct re2.
          * inversion IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
        + destruct re2.
          * inversion IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
        + destruct re2.
          * inversion IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
          * apply MUnionR. apply IH.
     - simpl.
        destruct re.
        + apply MEmpty.
        + apply MEmpty.
        + apply MStar0.
        + apply MStar0.
        + apply MStar0.
        + simpl.
          destruct re.
          * apply MStar0.
          * apply MStar0.
          * apply MStar0.
          * apply MStar0.
          * apply MStar0.
          * apply MStar0.
     - simpl.
       destruct re.
       + inversion IH1.
       + inversion IH1. inversion IH2. apply MEmpty.
       + apply star_app.
         * apply MStar1. apply IH1.
         * apply IH2.
       + apply star_app.
         * apply MStar1.  apply IH1.
         * apply IH2.
       + apply star_app.
         * apply MStar1.  apply IH1.
         * apply IH2.
       + apply star_app.
         * apply MStar1.  apply IH1.
         * apply IH2.
    Qed.

    (* Use the automation tools described so far to shorten the proof. *)

    Hint Constructors exp_match : core.
    Ltac re_opt_match_empty := inversion IH2; try rewrite app_nil_r; auto.

    Lemma re_opt_match' : forall T (re: reg_exp T) s,
      s =~ re -> s =~ re_opt re.
    Proof.
      intros T re s M.
      induction M
        as [| x'
            | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
            | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
            | re1 | s1 s2 re1 Hmatch1 IH1 Hmatch2 IH2]; simpl; auto.
      - destruct re1; try solve [ destruct re2; auto; re_opt_match_empty ].
        + inversion IH1. simpl. destruct re2; auto.
      - destruct re1; try destruct re2; auto; try inversion IH.
      - destruct re1; try destruct re2; auto; try inversion IH.
      - destruct re1; auto.
      - destruct re1; auto; inversion IH1. inversion IH2. apply MEmpty.
    Qed.

    (* Do not modify the following line: *)
    Definition manual_grade_for_re_opt : option (nat*string) := None.
    (** [] *)

    (* ================================================================= *)
    (** ** A Few More Handy Tactics *)

    (** By the way, here are some miscellaneous tactics that you may find
        convenient as we continue.

         - [clear H]: Delete hypothesis [H] from the context.

         - [rename... into...]: Change the name of a hypothesis in the
           proof context.  For example, if the context includes a variable
           named [x], then [rename x into y] will change all occurrences
           of [x] to [y].

         - [subst x]: Find an assumption [x = e] or [e = x] in the
           context, replace [x] with [e] throughout the context and
           current goal, and clear the assumption.

         - [subst]: Substitute away _all_ assumptions of the form [x = e]
           or [e = x].

        We'll see examples as we go along. *)

    (* ================================================================= *)
    (** ** Defining New Tactics *)

    (** Coq also provides several ways of "programming" tactic
    scripts.

        - Coq has a built-in language called [Ltac] with primitives that
          can examine and modify the proof state.  The full details are a
          bit too complicated to get into here (and it is generally agreed
          that [Ltac] is not the most beautiful part of Coq's design!),
          but they can be found in the reference manual and other books on
          Coq. Simple use cases are not too difficult.

        - There is also an OCaml API, which can be used to build tactics
          that access Coq's internal structures at a lower level, but this
          is seldom worth the trouble for ordinary Coq users.
    *)

    (**    Here is a simple [Ltac] example: *)

    Ltac impl_and_try c := simpl; try c.

    (** This defines a new tactical called [simpl_and_try] that takes one
        tactic [c] as an argument and is defined to be equivalent to the
        tactic [simpl; try c].  Now writing "[simpl_and_try reflexivity.]"
        in a proof will be the same as writing "[simpl; try
        reflexivity.]" *)

    (* ################################################################# *)
    (** * Decision Procedures *)

    (** So far, the automation we have considered has primarily been
        useful for removing repetition. Another important category of
        automation consists of built-in decision procedures for specific
        kinds of problems.  There are several of these, but the [lia]
        tactic is the most important to start with. *)

    (* ================================================================= *)
    (** ** The [lia] Tactic *)

    (** The [lia] tactic implements a decision procedure for integer linear
        arithmetic, a subset of propositional logic and arithmetic.

        If the goal is a formula made out of

          - variables and constants of type [nat] (or other integer types)

          - numeric constants, addition ([+] and [S]), subtraction ([-]
            and [pred]), and multiplication by constants
            (this is what makes it linear arithmetic)

          - equality ([=] and [<>]) and ordering ([<=]), and

          - the logical connectives [/\], [\/], [~], [->], and [<->].

        then invoking [lia] will either solve the goal or fail, meaning
        that the goal is actually false.  (If the goal is _not_ of this
        form, [lia] will also fail.) *)

    Example silly_lia_example : forall m n o p,
      m + n <= n + o /\ o + 3 = p + 3 ->
      m <= p.
    Proof.
      intros. lia.
    Qed.

    (* ################################################################# *)
    (** * Search Tactics *)

    (** Another very important category of automation tactics
        helps us construct proofs by _searching_ for relevant facts
        These tactics include the [auto] tactic for backwards reasoning,
        automated forward reasoning via the [Ltac] hypothesis matching
        machinery, and deferred instantiation of existential variables
        using [eapply] and [eauto].  Using these features together with
        Ltac's scripting facilities will enable us to make our proofs
        startlingly short!  Used properly, they can also make proofs more
        maintainable and robust to changes in underlying definitions.  A
        deeper treatment of [auto] and [eauto] can be found in the
        [UseAuto] chapter in _Programming Language Foundations_. *)

    (* ================================================================= *)
    (** ** The [constructor] tactic. *)

    (** A simple first example of a search tactic is [constructor],
        which tries to find a constructor [c] (from some
        [Inductive] definition in the current environment) that can be
        applied to solve the current goal.  If one is found, behave
        like [apply c]. *)

    Print ev.
    (* ===>
       Inductive ev : nat -> Prop :=
        ev_0 : ev 0
      | ev_SS : forall n : nat, ev n -> ev (S (S n))
    *)

    Example constructor_example: forall (n:nat),
        ev (n+n).
    Proof.
      induction n; simpl.
      - constructor. (* applies ev_0 *)
      - rewrite add_comm. simpl. constructor. (* applies ev_SS *) auto.
    Qed.

    (** This saves us from needing to remember the names of our constructors.
        Warning: if more than one constructor can apply, [constructor] picks
        the first one (in the order in which they were defined in the [Inductive])
        which is not necessarily the one we want! *)

    (* ================================================================= *)
    (** ** The [auto] Tactic *)

    (** Thus far, our proof scripts mostly apply relevant hypotheses or
        lemmas by name, and one at a time. *)

    Example auto_example_1 : forall (P Q R: Prop),
      (P -> Q) -> (Q -> R) -> P -> R.
    Proof.
      intros P Q R H1 H2 H3.
      apply H2. apply H1. apply H3.
    Qed.

    (** The [auto] tactic frees us from this drudgery by _searching_ for a
        sequence of applications that will prove the goal: *)

    Example auto_example_1' : forall (P Q R: Prop),
      (P -> Q) -> (Q -> R) -> P -> R.
    Proof.
      auto.
    Qed.

    (** The [auto] tactic solves goals that are solvable by any combination of
         - [intros] and
         - [apply] (of hypotheses from the local context, by default). *)

    (** Using [auto] is always "safe" in the sense that it will never fail
        and will never change the proof state: either it completely solves
        the current goal, or it does nothing. *)

    (** Here is a more interesting example showing [auto]'s power: *)

    Example auto_example_2 : forall P Q R S T U : Prop,
      (P -> Q) ->
      (P -> R) ->
      (T -> R) ->
      (S -> T -> U) ->
      ((P -> Q) -> (P -> S)) ->
      T ->
      P ->
      U.
    Proof. auto. Qed.

    (** Proof search could, in principle, take an arbitrarily long time,
        so there are limits to how far [auto] will search by default. *)

    Example auto_example_3 : forall (P Q R S T U: Prop),
      (P -> Q) ->
      (Q -> R) ->
      (R -> S) ->
      (S -> T) ->
      (T -> U) ->
      P ->
      U.
    Proof.
      (* When it cannot solve the goal, [auto] does nothing *)
      auto.
      (* Optional argument says how deep to search (default is 5) *)
      auto 6.
    Qed.

    (** When searching for potential proofs of the current goal,
        [auto] considers the hypotheses in the current context together
        with a _hint database_ of other lemmas and constructors.  Some
        common lemmas about equality and logical operators are installed
        in this hint database by default. *)

    Example auto_example_4 : forall P Q R : Prop,
      Q ->
      (Q -> R) ->
      P \/ (Q /\ R).
    Proof. auto. Qed.

    (** If we want to see which facts [auto] is using, we can use
        [info_auto] instead. *)

    Example auto_example_5: 2 = 2.
    Proof.
      (* auto subsumes reflexivity because eq_refl is in hint database *)
      info_auto.
    Qed.

    (** We can extend the hint database just for the purposes of one
        application of [auto] by writing "[auto using ...]". *)

    Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
    Proof. intros. lia. Qed.

    Example auto_example_6 : forall n m p : nat,
      (n <= p -> (n <= m /\ m <= n)) ->
      n <= p ->
      n = m.
    Proof.
      auto using le_antisym.
    Qed.

    (** Of course, in any given development there will probably be
        some specific constructors and lemmas that are used very often in
        proofs.  We can add these to the global hint database by writing

          Hint Resolve T : core.

        at the top level, where [T] is a top-level theorem or a
        constructor of an inductively defined proposition (i.e., anything
        whose type is an implication).  As a shorthand, we can write

          Hint Constructors c : core.

        to tell Coq to do a [Hint Resolve] for _all_ of the constructors
        from the inductive definition of [c].

        It is also sometimes necessary to add

          Hint Unfold d : core.

        where [d] is a defined symbol, so that [auto] knows to expand uses
        of [d], thus enabling further possibilities for applying lemmas that
        it knows about. *)

    (** It is also possible to define specialized hint databases that can
        be activated only when needed.  See the Coq reference manual for
        more. *)

    Hint Resolve le_antisym : core.

    Example auto_example_6' : forall n m p : nat,
      (n<= p -> (n <= m /\ m <= n)) ->
      n <= p ->
      n = m.
    Proof.
      auto. (* picks up hint from database *)
    Qed.

    Definition is_fortytwo x := (x = 42).

    Example auto_example_7: forall x,
      (x <= 42 /\ 42 <= x) -> is_fortytwo x.
    Proof.
      auto.  (* does nothing *)
    Abort.

    Hint Unfold is_fortytwo : core.

    Example auto_example_7' : forall x,
      (x <= 42 /\ 42 <= x) -> is_fortytwo x.
    Proof. info_auto. Qed.

    (** **** Exercise: 3 stars, advanced (pumping_redux)

        Use [auto], [lia], and any other useful tactics from this chapter to
        shorten your proof (or the "official" solution proof) of the weak Pumping
        Lemma exercise from [IndProp]. *)
    Import Pumping.

    Ltac app_assoc_eq := repeat rewrite app_assoc; auto.

    Ltac split_all := repeat (try split).

    Lemma napp_star' : forall T s (re : reg_exp T)  m, s =~ Star re -> napp m s =~ Star re.
    Proof.
      intros.
      induction m.
      - simpl. constructor.
      - simpl. apply star_app; auto.
    Qed.

    Theorem leb_false_rev : forall n m,
       n <=? m = false -> m <=? n = true.
    Proof.
      intros.
      generalize dependent m.
      induction n; intros.
      - destruct m.
        + auto.
        + simpl in H. discriminate.
      - destruct m; auto.
        + simpl in *. apply IHn, H.
    Qed.

    Theorem le_plus_r: forall a b, a <= b + a.
    Proof.
      intros.
      rewrite add_comm.
      apply le_plus_l.
    Qed.

    Lemma negb_true_iff : forall b, (negb b = true) <-> b = false.
      split; intros; destruct b; try auto.
    Qed.

    Hint Resolve le_trans : core.
    Hint Resolve le_plus_l : core.
    Hint Resolve le_plus_r : core.
    Hint Resolve leb_complete : core.
    Hint Resolve leb_false_rev : core.
    Hint Resolve plus_le_compat_l : core.
    Hint Resolve plus_le_compat_r : core.
    Hint Resolve napp_star : core.
    Hint Resolve napp_star' : core.

    Hint Rewrite app_nil_r : core_rw.

    Lemma weak_pumping : forall T (re : reg_exp T) s,
      s =~ re ->
      pumping_constant re <= length s ->
      exists s1 s2 s3,
        s = s1 ++ s2 ++ s3 /\
        s2 <> [] /\
        forall m, s1 ++ napp m s2 ++ s3 =~ re.
    Proof.
      intros T re s Hmatch.
      induction Hmatch
        as [ | x | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
           | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
           | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2 ].
      - (* MEmpty *)
        simpl. intros contra. inversion contra.
      -
        simpl. intros contra. inversion contra. inversion H0.
      -
        simpl. intros. rewrite app_length in H. apply add_le_cases in H. destruct H as [H1 | H2].
        + apply IH1 in H1. destruct H1 as [s2' [s3' [s4' [Heq [Hs3notempty Hs234pumping]]]]].
          exists s2', s3', (s4' ++ s2). all : split_all.
          * rewrite Heq. app_assoc_eq.
          * auto.
          * intros. assert (s2' ++ (napp m s3') ++ s4' ++ s2 = (s2' ++ (napp m s3') ++ s4') ++ s2). { app_assoc_eq. }
            rewrite H. auto.
       + apply IH2 in H2. destruct H2 as [s2' [s3' [s4' [Heq [Hs3notempty Hs234pumping]]]]].
          exists (s1 ++ s2'), s3', s4'. all : split_all.
          * rewrite Heq. app_assoc_eq.
          * auto.
          * intros. assert (((s1 ++ s2') ++ napp m s3' ++ s4') = (s1 ++ (s2' ++ napp m s3' ++ s4'))). { app_assoc_eq. }
            rewrite H. auto.
      -
        simpl. intros. apply plus_le in H. destruct H as [H1 H2].
        apply IH in H1. destruct H1 as [s2' [s3' [s4' [Heq [Hs3notempty Hs234pumping]]]]].
        exists s2', s3', s4'. all : split_all; auto.
      -
        simpl. intros. apply plus_le in H. destruct H as [H1 H2].
        apply IH in H2. destruct H2 as [s2' [s3' [s4' [Heq [Hs3notempty Hs234pumping]]]]].
        exists s2', s3', s4'. all : split_all; auto.
      -
        simpl. intros. inversion H. apply pumping_constant_0_false in H1.  inversion H1.
      -
        intros.
        assert ((eqb (length s1) 0) && (eqb (length s2) 0) || (negb (eqb (length s1) 0) || negb (eqb (length s2) 0)) = true).
        apply all3_spec. apply orb_true_iff in H0. inversion H0.
        + (* length s1 = 0 && length s2 ==0 *)
          apply andb_true_iff in H1. destruct H1 as [H0lens1 H0lens2].
          apply eqb_eq in H0lens1, H0lens2.
          rewrite app_length in H. rewrite H0lens1, H0lens2 in H. simpl in H.
          inversion H. apply pumping_constant_0_false in H2. inversion H2.
        + (* length s1 <> 0 || length s2 <> 0 *)
          apply orb_true_iff in H1. inversion H1.
          * apply negb_true_iff in H2. apply eqb_neq in H2.
            exists [], s1, s2. all : split_all; auto.
            -- unfold not. intros. subst s1. simpl in H2. specialize (H2 (eq_refl 0)). contradiction.
            -- intros. apply napp_star; auto.
          * apply negb_true_iff in H2. apply eqb_neq in H2.
            exists s1, s2, []. all : split_all; auto.
            -- rewrite app_nil_r. auto.
            -- unfold not. intros. subst s2. simpl in H2. specialize (H2 (eq_refl 0)). contradiction.
            -- intros. rewrite app_nil_r. auto.
    Qed.
    (* Do not modify the following line: *)
    Definition manual_grade_for_pumping_redux : option (nat*string) := None.
    (** [] *)

    (** **** Exercise: 3 stars, advanced, optional (pumping_redux_strong)

        Use [auto], [lia], and any other useful tactics from this chapter to
        shorten your proof (or the "official" solution proof) of the stronger
        Pumping Lemma exercise from [IndProp]. *)
    Import Pumping.
    Lemma pumping : forall T (re : reg_exp T) s,
      s =~ re ->
      pumping_constant re <= length s ->
      exists s1 s2 s3,
        s = s1 ++ s2 ++ s3 /\
        s2 <> [] /\
        length s1 + length s2 <= pumping_constant re /\
        forall m, s1 ++ napp m s2 ++ s3 =~ re.
    (** You may want to copy your proof of weak_pumping below. *)
    Proof.
      intros T re s Hmatch.
      induction Hmatch
        as [ | x | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
           | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
           | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2 ].
      - (* MEmpty *)
        simpl. intros contra. inversion contra.
      -
        simpl. intros contra. inversion contra. inversion H0.
      -
        simpl. intros. rewrite app_length in H. apply add_le_cases in H. destruct H as [H1 | H2].
        + apply IH1 in H1. destruct H1 as [s2' [s3' [s4' [Heq [Hs3notempty [Hs234len Hs234pumping]]]]]]. auto.
          exists s2', s3', (s4' ++ s2). all : split_all; eauto.
          * rewrite Heq. app_assoc_eq.
          * intros. assert (s2' ++ (napp m s3') ++ s4' ++ s2 = (s2' ++ (napp m s3') ++ s4') ++ s2). { app_assoc_eq. }
            rewrite H. auto.
        + apply IH2 in H2. destruct H2 as [s2' [s3' [s4' [Heq' [Hs3'notempty [Hs'234len Hs'234pumping]]]]]].
          destruct (leb (pumping_constant re1) (length s1)) eqn: Hpcre1.
          * apply leb_iff in Hpcre1. apply IH1 in Hpcre1.
            destruct Hpcre1 as [s2'' [s3'' [s4'' [Heq'' [Hs3''notempty [Hs''234len Hs''234pumping]]]]]].
            exists s2'', s3'', (s4'' ++ s2). all : split_all; eauto.
            -- rewrite Heq''. app_assoc_eq.
            -- intros. assert (s2'' ++ napp m s3'' ++ s4'' ++ s2 = (s2'' ++ napp m s3'' ++ s4'') ++ s2). { app_assoc_eq. }
               rewrite H. auto.
          * exists (s1 ++ s2'), s3', s4'. all : split_all; auto.
            -- rewrite Heq'. app_assoc_eq.
            -- rewrite app_length. apply le_trans with (n:=pumping_constant re1 + length s2' + length s3').
               ++ auto.
               ++ rewrite <- add_assoc. auto.
            -- intros. simpl. assert ((s1 ++ s2') ++ napp m s3' ++ s4' = s1 ++ (s2' ++ napp m s3' ++ s4')). { app_assoc_eq. }
               rewrite H. auto.
      -
        simpl. intros.
        assert (H1: pumping_constant re1 <= length s1). { eauto. }
        apply IH in H1. destruct H1 as [s2' [s3' [s4' [Heq [Hs3notempty [Hs234len Hs234pumping]]]]]].
        exists s2', s3', s4'. all : split_all; eauto.
      -
        simpl. intros.
        assert (H2: pumping_constant re2 <= length s2). { eauto. }
        apply IH in H2. destruct H2 as [s2' [s3' [s4' [Heq [Hs3notempty [Hs234len Hs234pumping]]]]]].
        exists s2', s3', s4'. all : split_all; eauto.
      -
        simpl. intro contra. inversion contra. apply pumping_constant_0_false in H0. contradiction.
      -
        intros.
        destruct (leb (pumping_constant re) (length s1)) eqn: Hpcre1.
        +
          apply leb_complete in Hpcre1.
          apply IH1 in Hpcre1.
          destruct Hpcre1 as [s2' [s3' [s4' [Heq [Hs3notempty [Hs234len Hs234pumping]]]]]].
          exists s2', s3', (s4' ++ s2). all : split_all; auto.
          * subst. app_assoc_eq.
          * intros. assert (s2' ++ napp m s3' ++ s4' ++ s2 = (s2' ++ napp m s3' ++ s4') ++ s2). { app_assoc_eq. }
            rewrite H0. auto.
        +
          destruct (eqb (length s1) 0) eqn:Hlens1eq0.
          **
             assert (s1 = []). { destruct s1. auto. inversion Hlens1eq0. } subst s1.
             destruct (leb (pumping_constant re) (length s2)) eqn: Hpcre2; auto.
          **
             exists [], s1, s2. all : split_all; auto.
             --- unfold not. intros. subst s1. inversion Hlens1eq0.
             --- simpl. auto.
    Qed.

    (* Do not modify the following line: *)
    Definition manual_grade_for_pumping_redux_strong : option (nat*string) := None.
    (** [] *)

    (* ================================================================= *)
    (** ** The [eapply] and [eauto] variants *)

    (** To close the chapter, we'll introduce one more convenient feature
        of Coq: its ability to delay instantiation of quantifiers. To motivate
        this feature, consider again this simple example: *)

    Example trans_example1:  forall a b c d,
        a <= b + b*c  ->
        (1+c)*b <= d ->
        a <= d.
    Proof.
      intros a b c d H1 H2.
      apply le_trans with (b+ b*c).  (* <-- We must supply the intermediate value *)
      + apply H1.
      + simpl in H2. rewrite mul_comm. apply H2.
    Qed.

    (** In the first step of the proof, we had to explicitly provide a
        longish expression to help Coq instantiate a "hidden" argument to
        the [le_trans] constructor. This was needed because the definition
        of [le_trans]...

        le_trans : forall m n o : nat, m <= n -> n <= o -> m <= o

       is quantified over a variable, [n], that does not appear in its
       conclusion, so unifying its conclusion with the goal state doesn't
       help Coq find a suitable value for this variable.  If we leave
       out the [with], this step fails ("Error: Unable to find an
       instance for the variable [n]").

       We already know one way to avoid an explicit [with] clause, namely
       to provide [H1] as the (first) explicit argument to [le_trans].
       But here's another way, using the [eapply tactic]: *)

    Example trans_example1':  forall a b c d,
        a <= b + b*c  ->
        (1+c)*b <= d ->
        a <= d.
    Proof.
      intros a b c d H1 H2.
      eapply le_trans.  (* 1 *)
      + apply H1.  (* 2 *)
      + simpl in H2. rewrite mul_comm. apply H2.
    Qed.

    (** The [eapply H] tactic behaves just like [apply H] except
        that, after it finishes unifying the goal state with the
        conclusion of [H], it does not bother to check whether all the
        variables that were introduced in the process have been given
        concrete values during unification.

        If you step through the proof above, you'll see that the goal
        state at position [1] mentions the _existential variable_ [?n]
        in both of the generated subgoals.  The next step (which gets us
        to position [2]) replaces [?n] with a concrete value.  When we
        start working on the second subgoal (position [3]), we observe
        that the occurrence of [?n] in this subgoal has been replaced
        by the value that it was given during the first subgoal. *)

    (** Several of the tactics that we've seen so far, including [exists],
        [constructor], and [auto], have [e...] variants.  For example,
        here's a proof using [eauto]: *)

    Example trans_example2:  forall a b c d,
        a <= b + b*c  ->
        b + b*c <= d ->
        a <= d.
    Proof.
      intros a b c d H1 H2.
      info_eauto using le_trans.
    Qed.

    (** The [eauto] tactic works just like [auto], except that it uses
        [eapply] instead of [apply].

        Pro tip: One might think that, since [eapply] and [eauto] are more
        powerful than [apply] and [auto], it would be a good idea to use
        them all the time.  Unfortunately, they are also significantly
        slower -- especially [eauto].  Coq experts tend to use [apply] and
        [auto] most of the time, only switching to the [e] variants when
        the ordinary variants don't do the job. *)

    (* 2021-08-11 15:08 *)


From Coq Require Import List.
From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Inductive nonempty_list A : Type :=
| NonemptyList : forall (hd : A) (tl : list A), nonempty_list A.

Definition nonempty_list_to_list A (l : nonempty_list A) : list A :=
  match l with
  | NonemptyList hd tl => hd::tl
  end.

Coercion nonempty_list_to_list : nonempty_list >-> list.

Definition nonempty_hd A (l : nonempty_list A) : A :=
  match l with
  | NonemptyList hd tl => hd
  end.

From Coq Require Import SetoidList.
From mathcomp Require Import eqtype ssrbool seq.

Section INA.

  Variable S : eqType.

  Lemma in_inA (x : S) (l : seq S) :
    (x \in l) -> (SetoidList.InA (fun x y => x == y) x l).
  Proof.
    elim: l x => /=.
    - move=> x Hin.
      rewrite in_nil in Hin.
      discriminate.
    - move=> hd tl IH x Hin.
      case Hx: (x == hd).
      + apply: InA_cons_hd.
        assumption.
      + rewrite in_cons Hx /= in Hin.
        apply: InA_cons_tl.
        exact: (IH _ Hin).
  Qed.

  Lemma inA_in (x : S) (l : seq S) :
    (SetoidList.InA (fun x y => x == y) x l) -> (x \in l).
  Proof.
    elim: l x => /=.
    - move=> x Hin; by inversion_clear Hin.
    - move=> hd tl IH x Hin.
      rewrite in_cons.
      inversion_clear Hin.
      + by rewrite H.
      + apply/orP; right; apply: IH.
        assumption.
  Qed.

  Lemma InAP (x : S) (l : seq S) : reflect (SetoidList.InA (fun x y => x == y) x l) (x \in l).
  Proof.
    case Hin: (x \in l).
    - apply: ReflectT.
      exact: (in_inA Hin).
    - apply: ReflectF.
      move=> HinA.
      move/negP: Hin; apply.
      exact: (inA_in HinA).
  Qed.

End INA.


Require Import
  Coq.Program.Program
  Coq.Unicode.Utf8
  Coq.micromega.Lia
  Coq.Classes.Morphisms
  Coq.Relations.Relation_Definitions
  Coq.Strings.String
  Coq.Vectors.Vector
  Coq.Lists.List
  Coq.Sets.Ensembles
  Coq.Logic.EqdepFacts.

From Equations Require Import Equations.
Require Import Equations.Type.EqDec.
Set Equations With UIP.

Generalizable All Variables.

Import ListNotations.

Inductive TyVar : nat → Type :=
  | ZTYVAR {u} : TyVar (S u)
  | STYVAR {u} : TyVar u → TyVar (S u).

Inductive Ty u :=
  | TYVAR : TyVar u → Ty u
  | ARR   : Ty u → Ty u → Ty u
  | ALL   : Ty (S u) → Ty u.

Arguments TYVAR : default implicits.
Arguments ARR : default implicits.
Arguments ALL : default implicits.

Infix "⟶" := ARR (at level 30, right associativity).

Definition RenT u w := TyVar u → TyVar w.
Definition SubT u w := TyVar u → Ty w.

Program Definition RTyL `(r : RenT u w) : RenT (S u) (S w) :=
  λ v, match v with
       | ZTYVAR      => ZTYVAR
       | STYVAR var' => STYVAR (r var')
       end.

Fixpoint RTyT `(r : RenT u w) (t : Ty u) : Ty w :=
  match t with
  | TYVAR v   => TYVAR (r v)
  | ARR t1 t2 => ARR (RTyT r t1) (RTyT r t2)
  | ALL t     => ALL (RTyT (RTyL r) t)
  end.

Definition ShTyT {u} : Ty u → Ty (S u) := RTyT (@STYVAR _).

Program Definition STyL `(s : SubT u w) : SubT (S u) (S w) :=
  λ v, match v with
       | ZTYVAR    => TYVAR ZTYVAR
       | STYVAR v' => ShTyT (s v')
       end.

Fixpoint STyT `(s : SubT u w) (t : Ty u) : Ty w :=
  match t with
  | TYVAR v   => s v
  | ARR t1 t2 => ARR (STyT s t1) (STyT s t2)
  | ALL t     => ALL (STyT (STyL s) t)
  end.

Definition Env u := list (Ty u).

Fixpoint STyE `(sub : SubT u w) (env : Env u) : Env w :=
  match env with
  | []      => []
  | T :: TS => STyT sub T :: STyE sub TS
  end.

Inductive Var {u} : Env u → Ty u → Set :=
  | ZVAR {Γ τ}    : Var (τ :: Γ) τ
  | SVAR {Γ τ τ'} : Var Γ τ → Var (τ' :: Γ) τ.

Arguments ZVAR : default implicits.
Arguments SVAR : default implicits.

Definition shSubT {u} : SubT u (S u) := λ v, TYVAR (STYVAR v).

(* Notation "Γ ∋ A ： τ" := (@Var _ _ Γ τ A) (at level 80, no associativity). *)

Definition idSubT {Γ} : SubT Γ Γ := @TYVAR Γ.

Equations consSubT {u w} (e : Ty u) (s : SubT u w)
          (v : TyVar w) : Ty w :=
  consSubT e s ZTYVAR      := _ e;
  consSubT e s (STYVAR v') := s v'.

Notation "{| e ; .. ; f |}" := (consSub e .. (consSub f idSub) ..).

Inductive Exp `(Γ : Env u) : Ty u → Type :=
  | VAR {τ}       : Var Γ τ → Exp Γ τ
  | LAM {dom cod} : Exp (dom :: Γ) cod → Exp Γ (dom ⟶ cod)
  | APP {dom cod} : Exp Γ (dom ⟶ cod) → Exp Γ dom → Exp Γ cod
  | TAPP {τ}      : Exp Γ (ALL τ) → ∀ τ' : Ty u, Exp Γ (STyT [| τ' |] τ)
  | TLAM {τ}      : Exp (u:=S u) (STyE (shSubT _) Γ) τ → Exp Γ (ALL τ).

Arguments VAR : default implicits
Arguments LAM : default implicits
Arguments APP : default implicits.
Arguments TAPP : default implicits.
Arguments TLAM : default implicits.

Lemma STyExp_cast1 `(sub : SubT u w) (env : Env u)
      (ty : Ty (S u)) (ty' : Ty u) :
  @eq Type
      (Exp (STyE sub env) (STyT [| STyT sub ty' |] (STyT (STyL sub) ty)))
      (Exp (STyE sub env) (STyT sub (STyT [| ty' |] ty))).

Lemma STyExp_cast2 `(sub : SubT u w) (env : Env u) (ty : Ty (S u)),
  @eq Type
      (Exp (STyE (STyL sub) (STyE (shSubT u) env)) (STyT (STyL sub) ty))
      (Exp (STyE (shSubT _) (STyE sub env)) (STyT (STyL sub) ty)).

Fixpoint STyExp u w (s : SubT u w) (E : Env u) t (e : Exp E t) :
  Exp (STyE s E) (STyT s t) :=
  match e with
  | VAR v     => VAR (STyVar s v)
  | APP e1 e2 => APP (STyExp s e1) (STyExp s e2)
  | LAM e     => LAM (STyExp s e)
  | TAPP e t' => cast (STyExp_cast1 _ _ _ _) (TAPP (STyExp s e) (STyT s t'))
  | TLAM e    => TLAM (cast (STyExp_cast2 _ _ _) (STyExp (STyL s) e))
  end.

Definition Sub Γ Γ' := ∀ τ, Var Γ τ → Exp Γ' τ.

Definition idSub {Γ} : Sub Γ Γ := @VAR Γ.

(*
Program Definition consSub {Γ Γ' τ} (e : Exp Γ' τ)
        (s : Sub Γ Γ') : Sub (τ :: Γ) Γ' :=
  λ _ v, match v with
         | ZV    => e
         | SV v' => s _ v'
         end.
*)

Equations consSub {Γ Γ' τ} (e : Exp Γ' τ) (s : Sub Γ Γ')
          τ' (v : Var (τ :: Γ) τ') : Exp Γ' τ' :=
  consSub e s τ' ZV      := e;
  consSub e s τ' (SV v') := s _ v'.

Notation "{| e ; .. ; f |}" := (consSub e .. (consSub f idSub) ..).

Definition tlSub {Γ Γ' τ} (s : Sub (τ :: Γ) Γ') : Sub Γ Γ' :=
  λ τ' v => s τ' (SV v).
Definition hdSub {Γ Γ' τ} (s : Sub (τ :: Γ) Γ') : Exp Γ' τ := s τ ZV.

Definition Ren Γ Γ' := ∀ τ, Var Γ τ → Var Γ' τ.

Definition idRen {Γ} : Ren Γ Γ := λ _, id.

Definition tlRen {Γ Γ' τ} (r : Ren (τ :: Γ) Γ') : Ren Γ Γ' :=
  λ τ' v => r τ' (SV v).
Definition hdRen {Γ Γ' τ} (r : Ren (τ :: Γ) Γ') : Var Γ' τ := r τ ZV.

Definition skip1 {Γ τ} : Ren Γ (τ :: Γ) := λ _, SV.

Equations skipn {Γ} Γ' : Ren Γ (Γ' ++ Γ) :=
  skipn []        := λ _, id;
  skipn (x :: xs) := λ τ v, SV (skipn xs τ v).

(*
Program Definition RTmL {Γ Γ' τ} (r : Ren Γ Γ') :
        Ren (τ :: Γ) (τ :: Γ') :=
  λ _ v, match v with
         | ZV    => ZV
         | SV v' => SV (r _ v')
         end.
*)

(* This version gives better rewriting equations. *)
Equations RTmL {Γ Γ' τ} (r : Ren Γ Γ')
          τ' (v : Var (τ :: Γ) τ') : Var (τ :: Γ') τ' :=
  RTmL r τ' ZV      := ZV;
  RTmL r τ' (SV v') := SV (r _ v').

Lemma RTmL_id {Γ τ} : @RTmL Γ Γ τ (λ _, id) = λ _, id.
Proof.
  extensionality τ'.
  extensionality v.
  dependent induction v.
  - now rewrite RTmL_equation_1.
  - now rewrite RTmL_equation_2.
Qed.

Fixpoint RTmExp {Γ Γ' τ} (r : Ren Γ Γ') (e : Exp Γ τ) : Exp Γ' τ :=
  match e with
  | VAR v     => VAR (r _ v)
  | APP e1 e2 => APP (RTmExp r e1) (RTmExp r e2)
  | LAM e     => LAM (RTmExp (RTmL r) e)
  end.

Definition wk {Γ τ τ'} : Exp Γ τ → Exp (τ' :: Γ) τ := RTmExp (λ _, SV).

(*
Program Definition STmL {Γ Γ' τ} (s : Sub Γ Γ') :
        Sub (τ :: Γ) (τ :: Γ') :=
  λ _ v, match v with
         | ZV    => VAR ZV
         | SV v' => wk (s _ v')
         end.
*)

Equations STmL {Γ Γ' τ} (s : Sub Γ Γ') τ' (v : Var (τ :: Γ) τ') :
  Exp (τ :: Γ') τ' :=
  STmL _ τ' ZV      := VAR ZV;
  STmL _ τ' (SV v') := wk (s _ v').

Fixpoint STmExp {Γ Γ' τ} (s : Sub Γ Γ') (e : Exp Γ τ) : Exp Γ' τ :=
  match e with
  | VAR v     => s _ v
  | APP e1 e2 => APP (STmExp s e1) (STmExp s e2)
  | LAM e     => LAM (STmExp (STmL s) e)
  end.

Inductive Ev : ∀ {τ}, Exp [] τ → Exp [] τ → Prop :=
  | EvAbs t1 t2 (e : Exp [t1] t2) : Ev (LAM e) (LAM e)
  | EvApp t1 t2 e v w (e1 : Exp [] (t1 ⟶ t2)) e2 :
    Ev e1 (LAM e) → Ev e2 w → Ev (STmExp {| w |} e) v →
    Ev (APP e1 e2) v.

(* Notation "Γ ⊢ e ： τ" := (Judgment Γ τ e) (at level 80, no associativity). *)

Definition identity Γ τ : Exp Γ (τ ⟶ τ) := LAM (VAR ZV).

Definition compose {Γ τ τ' τ''}
           (f : Exp Γ (τ' ⟶ τ''))
           (g : Exp Γ (τ ⟶ τ')) : Exp Γ (τ ⟶ τ'') :=
  LAM (APP (wk f) (APP (wk g) (VAR ZV))).

Definition RcR {Γ Γ' Γ''} (r : Ren Γ' Γ'') (r' : Ren Γ Γ') :=
  (λ τ v, r τ (r' τ v)) : Ren Γ Γ''.

Definition ScR {Γ Γ' Γ''} (s : Sub Γ' Γ'') (r : Ren Γ Γ') :=
  (λ τ v, s τ (r τ v)) : Sub Γ Γ''.

Definition RcS {Γ Γ' Γ''} (r : Ren Γ' Γ'') (s : Sub Γ Γ') :=
  (λ τ v, RTmExp r (s τ v)) : Sub Γ Γ''.

Definition ScS {Γ Γ' Γ''} (s : Sub Γ' Γ'') (s' : Sub Γ Γ') :=
  (λ τ v, STmExp s (s' τ v)) : Sub Γ Γ''.

Lemma LiftRcR Γ Γ' Γ'' τ (r : Ren Γ' Γ'') (r' : Ren Γ Γ') :
  RTmL (τ := τ) (RcR r r') = RcR (RTmL r) (RTmL r').
Proof.
  extensionality τ'.
  extensionality v.
  now dependent induction v.
Qed.

Corollary tlRen_skip1 Γ τ τ' :
  @tlRen _ (τ :: τ' :: Γ) _ skip1 = RcR skip1 skip1.
Proof. reflexivity. Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) y)) (append (rev y) x).
Proof.
   induction x.
   - intros. simpl. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite append_assoc. rewrite IHx. simpl.
 lfind. Admitted.


Require Import Reals.
Require Import List.
Require Import Fourier.
Require Import Basics.
(* Require Import Coq.Init.Tactics. *)

(* Tested with coq 8.5pl1 *)

(* my own version of non-negative reals, I think just for the better names *)
Record NNR : Type := mkNNR { NNRr :> R; NNR_pos : 0 <= NNRr }.

Ltac nnr_fourier :=
  simpl;
  destruct_all NNR;
  repeat (intros; eauto;
          try fourier;
          try apply Rplus_le_compat;
          try apply Rmult_le_compat;
          try apply NNR_pos
         ); fail.

Program Definition NNR_0 := mkNNR 0 _.
Solve Obligations with nnr_fourier.
Program Definition NNR_1 := mkNNR 1 _.
Solve Obligations with nnr_fourier.
Notation "0" := NNR_0.
Notation "1" := NNR_1.

Program Definition NNR_plus (a b : NNR) : NNR := @mkNNR (a + b) _.
Next Obligation.
  case a, b.
  nnr_fourier.
Qed.

Infix "+" := NNR_plus.

Program Definition NNR_mult (a b : NNR) : NNR := @mkNNR (a * b) _.
Next Obligation.
  case a, b.
  apply Rmult_le_pos; auto.
Qed.
Infix "*" := NNR_mult.

(* Shorthand for decidability of T *)
Definition dec_def (T : Type) := forall a b : T, {a = b} + {a <> b}.
Hint Transparent dec_def.
Hint Unfold dec_def.

Module Type PCFG_params.
  Parameter Σ : Type. (* The terminal type *)
  Parameter Σ_dec : forall a b : Σ, {a = b} + {a <> b}.
End PCFG_params.

Module PCFG (params : PCFG_params).
  Import params.
  Hint Resolve Σ_dec.

  Definition string := list Σ.
  Definition string_dec := list_eq_dec Σ_dec.

  (* a useful definition of monotonic functions ℕ -> ℝ⁺, eqivalent (not needed
     or proven here) to the standard (a <= b -> f(a) <= f(b)). *)
  Definition natNNRMono (f : nat -> NNR) :=
    forall d, f d <= f (S d).

  Record monoFn := mkMonoFn { monoFnFn :> nat -> NNR;
                              monoFnMono : natNNRMono monoFnFn }.

  (* definition of expressions, ideally U would take (Expr * NNR), but depth
     indexing causes some awkwardness here. Nullability calculations will be
     placed in this position, and they will need a depth index. This is saved as
     a function to make the derivative depth-agnostic; only language generation
     will muck with depth. While only nullability and constant functions will
     appear here, it's generalized to all monotonic (nat -> NNR). *)
  Inductive Expr {NT} :=
  | emp : Expr
  | ε : Expr
  | term : Σ -> Expr
  | U : Expr -> monoFn -> Expr -> monoFn -> Expr
  | seq : Expr -> Expr -> Expr
  | nonterm : NT -> Expr.
  Arguments Expr : clear implicits.

  Notation "⟨ e0 , p0 ⟩ ∪ ⟨ e1 , p1 ⟩" := (U e0 p0 e1 p1).

  Notation "∅" := emp.
  Infix "·" := seq (right associativity, at level 80).

  (* A mapping from non-terminals to expressions is almost a grammar, we'll add
  the start expression later *)
  Definition rules NT := NT -> Expr NT.

  (* We need a stronger induction hypothesis that takes into account both
  structural recursion and depth-indexed non-terminal recursion *)
  Lemma pcfg_super_rect
          {NT : Type}
          (rho : rules NT)
          (P : nat -> Expr NT -> Type)
          (f5 : forall r, P O r)
          (f : forall d, P d emp)
          (f0 : forall d, P d ε)
          (f1 : forall σ d, P d (term σ))
          (f2 : forall (d : nat)
                       (r0 r1 : Expr NT)
                       (p0 p1 : monoFn),
                    P d r0 -> P d r1 ->
                    P d (⟨r0, p0⟩ ∪ ⟨r1, p1⟩))
          (f3 : forall r d,
                  P d r ->
                  forall r0 : Expr NT,
                    P d r0 -> P d (seq r r0))
          (f4 : forall d nt, P d (rho nt) -> P (S d) (nonterm nt))
    : forall r d, P d r.
  Proof.
    induction r; intuition.
    revert n.
    induction d; intuition.
    apply f4.
    induction (rho n); auto.
  Qed.

  (* instance Functor Expr *)
  Fixpoint exprMap {A B} (f : A -> B) (a : Expr A) : Expr B :=
    match a with
      | ∅ => ∅
      | ε => ε
      | term σ => term σ
      | ⟨l, l_prob⟩ ∪ ⟨r, r_prob⟩ => ⟨exprMap f l, l_prob⟩ ∪ ⟨exprMap f r, r_prob⟩
      | l · r => exprMap f l · exprMap f r
      | nonterm nt => nonterm (f nt)
    end.
  Hint Unfold exprMap.

  Check const.

  Program Definition constMono (x : NNR) : monoFn := mkMonoFn (const x) _.
  Next Obligation.
    unfold const, natNNRMono.
    nnr_fourier.
  Qed.

  Record pcfg {NT} := mkPcfg { pcfgRules : rules NT ;
                               pcfgStart : Expr NT }.
  Arguments pcfg : clear implicits.
  Arguments mkPcfg [NT] _ _.

  (* Now that PCFGs are defined, we define the languages they generate *)

  (* a language is a discrete measure on strings *)
  Definition lang := string -> NNR.

  Definition finite_sum : list NNR -> NNR := fold_right NNR_plus 0.

  Program Fixpoint finite_sum_eq_proof_irrelevence
          (l0 l1 : list NNR)
          (map_eq : map NNRr l0 = map NNRr l1)
  : NNRr (finite_sum l0) = NNRr (finite_sum l1) :=
    match l0, l1 with
      | nil, nil => _
      | x :: xs, y :: ys => _ (finite_sum_eq_proof_irrelevence xs ys)
      | nil, _ :: _ => False_rect _ _
      | _ :: _, nil => False_rect _ _
    end.
  Next Obligation.
    intuition.
  Qed.

  Fixpoint relate_lists {A B} (P : A -> B -> Prop) (la : list A) (lb : list B) : Prop :=
    match la, lb with
      | nil, nil => True
      | nil, _ :: _ => False
      | _ :: _, nil => False
      | a :: la', b :: lb' => P a b /\ relate_lists P la' lb'
    end.

  Lemma relate_lists_map {A B} (P : B -> B -> Prop) (f g : A -> B) :
    forall (l : list A),
      (forall a, P (f a) (g a)) ->
      relate_lists P (map f l) (map g l).
  Proof.
    intros.
    induction l; simpl; auto.
  Qed.

  Program Fixpoint finite_sum_all_le
          (l0 l1 : list NNR)
          (map_le : relate_lists (Rle) (map NNRr l0) (map NNRr l1))
  : NNRr (finite_sum l0) <= NNRr (finite_sum l1) :=
    match l0, l1 with
      | nil, nil => _
      | x :: xs, y :: ys => _ (finite_sum_all_le xs ys)
      | nil, _ :: _ => False_rect _ _
      | _ :: _, nil => False_rect _ _
    end.
  Solve Obligations with nnr_fourier.
  Next Obligation.
    inversion map_le.
    nnr_fourier.
  Qed.

  Fixpoint all_splits {A} (l : list A) : list (list A * list A) :=
  match l with
    | nil => (nil, nil) :: nil
    | c :: l' =>
      let splits := all_splits l' in
      (nil, l) :: map (fun x => (c :: (fst x), snd x)) splits
  end.

  (* SECTION: language generation *)

  (* gen will be a depth-indexed function that converts a PCFG into a language.
     We can't tie the depth-indexed knot yet, so we need to take in both the
     depth recursive part (gen) and the current depth (d) for any suspended
     nullabilities. *)
  Fixpoint gen_unfixed {NT}
           (gen : Expr NT -> lang)
           (d : nat)
           (rho : rules NT)
           (e : Expr NT)
           (s : string)
  : NNR :=
    match e with
      | ∅ => 0
      | ε => if string_dec s nil then 1 else 0
      | term c => if string_dec s (c :: nil) then 1 else 0
      | ⟨l, pl⟩ ∪ ⟨r, pr⟩ =>
        pl d * gen_unfixed gen d rho l s +
        pr d * gen_unfixed gen d rho r s
      | l · r =>
        finite_sum
          (map (fun (lr : string * string) =>
                  gen_unfixed gen d rho l (fst lr) *
                  gen_unfixed gen d rho r (snd lr))
               (all_splits s))
      | nonterm nt => gen (rho nt) s
    end.

  Lemma gen_unfixed_mono {NT}
        (gen' : nat -> Expr NT -> lang)
        (gen'_mono : forall e s, natNNRMono (fun d => gen' d e s))
        (rho : rules NT)
        (e : Expr NT)
  : forall s, natNNRMono (fun d => gen_unfixed (gen' d) d rho e s).
  Proof.
    unfold natNNRMono.
    induction e;
      intros;
      simpl;
      try nnr_fourier.
    +
      destruct_all monoFn.
      nnr_fourier.
    +
      apply finite_sum_all_le.
      repeat rewrite map_map.
      apply relate_lists_map.
      nnr_fourier.
    +
      apply gen'_mono.
  Qed.

  (* Tie the knot *)
  Fixpoint gen {NT} (d : nat) (rho : rules NT) (e : Expr NT) : lang :=
    match d with
      | O => (fun s => NNR_0)
      | S d' => gen_unfixed (gen d' rho) d' rho e
    end.

  (* TODO: this proof is largely duplicated from genn_mono *)
  Lemma gen_mono {NT} (rho : rules NT) (e : Expr NT) (s : string)
  : natNNRMono (fun d => gen d rho e s).
    unfold natNNRMono.
    intros.
    revert s.
    induction e, d using (pcfg_super_rect rho);
      intros;
      try (induction d; [apply NNR_pos; fail|]);
      simpl;
      try (destruct_all monoFn; nnr_fourier).

    apply finite_sum_all_le.
    repeat rewrite map_map.
    apply relate_lists_map.
    nnr_fourier.
  Qed.

  Definition pcfg_gen {NT} (depth : nat) (gr : pcfg NT) : lang :=
    gen depth (pcfgRules gr) (pcfgStart gr).

  (* nullability is easily defined in terms of gen *)
  Definition δ {NT} (d : nat) (rho : rules NT) (e : Expr NT) : NNR :=
    gen_unfixed (gen d rho) d rho e nil.

  Lemma δ_mono {NT} {rho : rules NT} {e : Expr NT}
  : natNNRMono (fun d => δ d rho e).
  Proof.
    unfold natNNRMono, δ.
    apply gen_unfixed_mono.
    apply gen_mono.
  Qed.

  (* SECTION: definition for derivatives of PCFGs *)

  (* A differentiated (or not) non-terminal, after deriving an expression by
  'x', any non-terminals N become either N_ε or N_'x' *)
  Inductive dNT {NT} :=
  | justNT : NT -> dNT
  | derived : Σ -> NT -> dNT.
  Arguments dNT : clear implicits.

  (* The expression derivative: remove σ from expr, rho is needed for the
  nullability computation that takes place in sequencing *)
  Fixpoint eD {NT} (σ : Σ) (rho : rules NT) (e : Expr NT) : Expr (dNT NT) :=
    match e with
      | ∅ => ∅
      | ε => ∅
      | term σ' => if Σ_dec σ σ' then ε else ∅
      | ⟨l, l_prob⟩ ∪ ⟨r, r_prob⟩ => ⟨eD σ rho l, l_prob⟩ ∪ ⟨eD σ rho r, r_prob⟩
      | l · r => ⟨eD σ rho r, mkMonoFn (fun d => δ d rho l) δ_mono⟩
                   ∪ ⟨eD σ rho l · exprMap justNT r, constMono NNR_1⟩
      | nonterm n => nonterm (derived σ n)
    end.

  (* lift the definition of derivatives to rules *)
  Definition liftedD {NT} (rho : rules NT) : rules (dNT NT) :=
    fun s =>
      match s with
        | justNT s' => exprMap justNT (rho s')
        | derived σ s' => eD σ rho (rho s')
      end.

  (* derivative of PCFGs *)
  Definition gD {NT} (d : nat) (σ : Σ) (g : pcfg NT) : pcfg (dNT NT) :=
    mkPcfg (liftedD (pcfgRules g))
           (eD σ (pcfgRules g) (pcfgStart g)).

  (* SECTION: correctness of gD *)

  (* Definition of language derivative, this is the standard of correctness *)
  Definition lD (c : Σ) (l : lang) : lang :=
    fun s => l (c :: s).
  Transparent lD.

  (* definition of correctness for one expression: lD(gen(e)) = gen(gD(e)) *)
  Definition eD_gen_commute_defn NT (d : nat) (rho : rules NT) (e : Expr NT) :=
    forall (σ : Σ) (s : string),
      NNRr (lD σ (gen d rho e) s) = NNRr (gen d (liftedD rho) (eD σ rho e) s).
  Transparent eD_gen_commute_defn.
  Hint Unfold eD_gen_commute_defn.

  (* case by case on e *)
  Lemma emp_commutes {NT} d rho : eD_gen_commute_defn NT d rho ∅ .
  Proof.
    induction d; auto.
  Qed.

  Lemma eps_commutes {NT} d rho : eD_gen_commute_defn NT d rho ε.
  Proof.
    induction d; auto.
  Qed.

  Lemma term_commutes {NT} σ d rho : eD_gen_commute_defn NT d rho (term σ).
  Proof.
    unfold eD_gen_commute_defn; intros.
    induction d; auto.
    unfold lD.
    simpl.
    induction string_dec, Σ_dec; simpl; auto.
    +
      rewrite a.
      auto.
    +
      induction string_dec; auto.
      contradiction.
  Qed.

  Lemma U_commutes {NT} :
    forall d rho l lp r rp,
      eD_gen_commute_defn NT d rho l ->
      eD_gen_commute_defn NT d rho r ->
      eD_gen_commute_defn NT d rho (⟨l, lp⟩ ∪ ⟨r, rp⟩).
  Proof.
    unfold eD_gen_commute_defn.
    intros.
    induction d; auto.
    unfold lD in *.
    simpl in *.
    repeat apply f_equal2; auto.
  Qed.

  Lemma seq_commutes {NT} :
    forall rho d l r,
      eD_gen_commute_defn NT d rho l ->
      eD_gen_commute_defn NT d rho r ->
      eD_gen_commute_defn NT d rho (l · r).
  Proof.
    unfold eD_gen_commute_defn.
    intros.
    revert s.
    induction d; intros; auto.
    unfold lD in *.
    simpl in *.

    repeat apply f_equal2; auto.

    rewrite Rmult_1_l.

    apply finite_sum_eq_proof_irrelevence.
    repeat rewrite map_map.
    apply map_ext.
    induction a.
    simpl.
    apply f_equal2; auto.

    replace (gen_unfixed (gen d rho) d rho r b) with (gen (S d) rho r b) by auto.

    (* liftedD should return a superset of the existing rules *)
    Let liftedD_preserves
        {NT} (e : Expr NT) (rho : rules NT) (d : nat) :
      forall s,
        gen d rho e s = gen d (liftedD rho) (exprMap justNT e) s.
    Proof.
      induction e, d using (pcfg_super_rect rho);
        unfold exprMap;
        fold @exprMap;
        intros;
        eauto;
        induction d; auto;
        simpl in *.
      +
        rewrite IHd, IHd0.
        auto.
      +
        apply f_equal.
        apply map_ext.
        induction a.
        apply f_equal2; auto.
    Qed.

    rewrite liftedD_preserves.
    auto.
  Qed.

  (* glue all the cases together *)
  Lemma eD_comutes {NT} e (rho : rules NT) d : eD_gen_commute_defn NT d rho e.
  Proof.
    induction e, d using (pcfg_super_rect rho).
    +
      auto.
    +
      apply emp_commutes.
    +
      apply eps_commutes.
    +
      apply term_commutes.
    +
      apply U_commutes; auto.
    +
      apply seq_commutes; auto.
    +
      apply IHd.
  Qed.

  Theorem gD_commutes :
    forall {NT} (pg : pcfg NT) (σ : Σ) (s : list Σ) (d : nat),
      NNRr (lD σ (pcfg_gen d pg) s) = NNRr (pcfg_gen d (gD d σ pg) s).
  Proof.
    intros.
    case pg as [e rho].
    unfold pcfg_gen.
    simpl.
    apply eD_comutes.
  Qed.

  Print Assumptions gD_commutes.
End PCFG.

(* --- definitions complete, examples and scratch space below --- *)

Inductive aΣ := Σx.
Module aPCFG_params <: PCFG_params.
  Definition Σ := aΣ.
  Definition Σ_dec : dec_def Σ.
    unfold dec_def.
    decide equality.
  Defined.
End aPCFG_params.
Module aPCFG := PCFG aPCFG_params.
Import aPCFG.

Print Assumptions gD_commutes.

Inductive NT := SS.
Definition NT_dec : dec_def NT.
  unfold dec_def.
  decide equality.
Defined.

Definition prod_start : Expr NT := nonterm SS.
Definition prod_1 : Expr NT := nonterm SS · nonterm SS.
Definition prod_2 : Expr NT := nonterm SS · term Σx.
Definition prod_3 : Expr NT := ε.

Fixpoint list_U {NT} (m : list (Expr NT * NNR)) : Expr NT :=
  match m with
    | nil => ∅
    | (r, p) :: m' => ⟨r, constMono p⟩ ∪ ⟨list_U m', constMono NNR_1⟩
  end.

Program Definition rho : rules NT :=
  (fun nt =>
     match nt with
       | SS =>
         list_U
           ((prod_1, mkNNR (1 / 3) _) ::
            (prod_2, mkNNR (1 / 3) _) ::
            (prod_3, mkNNR (1 / 3) _) :: nil)
     end).
Solve Obligations with nnr_fourier.

Definition g : pcfg NT := mkPcfg rho (rho SS).

(* scratch computations *)

Lemma computation a :
  let d := 2%nat in
  let (g', e) := (gD d Σx g) in
  a = NNRr (gen d g' e nil).

  compute; field_simplify.
Abort.

Lemma computation :
  let d := 2%nat in
  NNRr (lD Σx (gen d rho (rho SS)) nil)
  = NNRr (pcfg_gen d (gD d Σx g) nil).
Proof.
  compute; field_simplify.
Abort.


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.theory.rationals
               HoTT.Classes.orders.orders
               HoTT.Classes.theory.premetric
               HoTT.Classes.implementations.assume_rationals
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe
               TruncType Types.Sigma
               HIT.quotient.

Require Import HoTTClasses.partiality
               sierpinsky
               dedekind.

Require Export Rlow Opens Functions.

Set Implicit Arguments.

(** * D_op: operator which takes a function and a rational
and gives the open in which the function is bigger than the
rational *)

(** see a similart construction with Dedekind cuts in
Coquand-Spitters 09, Integrals and valuations *)

Section Dop.

Context `{Funext} `{Univalence}.

Definition D_op {A :hSet} (q : Q) : mf A -> OS A :=
   fun f z => let (rl,_) := (f z) in (elt rl q).

(** Correctness of the definition *)
Lemma D_op_correct {A:hSet}: forall f q (x:A),
    (D_op q f) x <->  QRlow q < (f x).
Proof.
intros f q x; split; intro HH.
+ unfold D_op in HH.
  destruct (f x); simpl.
  red; unfold Rllt.
  apply tr.
  exists q.
  split; trivial.
  unfold QRlow.
  simpl; intros Hn.
  unfold semi_decide, Rllt_semi_dec,
         decidable_semi_decide in Hn.
  destruct (dec (q < q)).
  generalize (@eq_not_lt Q).
  intros SS; specialize (SS _ _ q q).
  apply SS.
  reflexivity.
  apply l.
  case (not_bot Hn).
+ unfold D_op.
  red in HH.
  destruct (f x).
  simpl in H.
  unfold QRlow in H.
  unfold Rllt in H.
  revert HH; apply (Trunc_ind _);
  intros (s,(E1,E2)).
  simpl in E2.
  unfold semi_decide, Rllt_semi_dec,
         decidable_semi_decide in E2.
  destruct (dec (s < q)) in E2.
  case E2; apply top_greatest.
  assert (Hsq : Qle q s).
  apply Fpo_Qle_Qlt; trivial.
  apply Rlow_mon with rl s.
  trivial.
  unfold Rlle; trivial.
  trivial.
Qed.

(** Monotonicity of the operator on the functional arg*)
Lemma D_op_mon_f {A:hSet}: forall q (f:mf A) g,
    fle f g -> D_op q f ⊆  D_op q g.
Proof.
intros q f g Hfg z; unfold D_op.
assert (Hle : Rlle (f z) (g z)).
apply Hfg.
destruct (f z).
destruct (g z).
apply imply_le.
exact (Hle q).
Qed.

(** Monotonicity of the operator on the rational arg*)
Lemma D_op_mon_q {A:hSet} : forall p q (f : mf A),
    Qle p q -> D_op q f ⊆  D_op p f.
Proof.
intros p q f Hpq.
assert (Haux : forall z, D_op q f z -> D_op p f z).
intros z.
intros Hq.
apply D_op_correct.
apply D_op_correct in Hq.
red; red in Hq.
unfold Rllt in *.
revert Hq; apply (Trunc_ind _).
intros Hq; apply tr.
destruct Hq as (s,(Hq1,Hq2)).
exists s; split.
+ trivial.
+ intros Ho. apply Hq2.
  apply Rlow_mon with (QRlow p) s.
  reflexivity.
  intros v Hv.
  unfold QRlow.
  simpl in *.
  unfold semi_decide, Rllt_semi_dec,
         decidable_semi_decide in *.
  destruct (dec (v < q)).
  apply top_greatest.
  destruct (dec (v < p)).
  assert (Hr : v < q).
  apply orders.lt_le_trans with p; try trivial.
  case (n Hr).
  trivial. trivial.
+ intros z; apply imply_le; exact (Haux z).
Qed.

Hint Resolve D_op_mon_f D_op_mon_q.

End Dop.


Require Import UniMath.Foundations.Generalities.uu0.
Require Import UniMath.Foundations.hlevel1.hProp.
Require Import UniMath.Foundations.hlevel2.hSet.

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import UnicodeNotations.
Require Import UniMath.RezkCompletion.whiskering.
Require Import SubstSystems.Auxiliary.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Local Notation "G ∙ F" := (functor_composite _ _ _ F G) (at level 35).

Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Section one_product_precategory.

Variables C D : precategory.

Definition product_precategory_ob_mor : precategory_ob_mor.
Proof.
  exists (C × D).
  exact (λ cd cd', pr1 cd ⇒ pr1 cd' × pr2 cd ⇒ pr2 cd').
Defined.

Definition product_precategory_data : precategory_data.
Proof.
  exists product_precategory_ob_mor.
  split.
  - intro cd.
    exact (dirprodpair (identity (pr1 cd)) (identity (pr2 cd))).
  - intros cd cd' cd'' fg fg'.
    exact (dirprodpair (pr1 fg ;; pr1 fg') (pr2 fg ;; pr2 fg')).
Defined.

Lemma is_precategory_product_precategory_data : is_precategory product_precategory_data.
Proof.
  repeat split; simpl; intros.
  - apply dirprodeq; apply id_left.
  - apply dirprodeq; apply id_right.
  - apply dirprodeq; apply assoc.
Qed.

Definition product_precategory : precategory
  := tpair _ _ is_precategory_product_precategory_data.

Definition has_homsets_product_precategory (hsC : has_homsets C) (hsD : has_homsets D) :
  has_homsets product_precategory.
Proof.
  intros a b.
  apply isasetdirprod.
  - apply hsC.
  - apply hsD.
Qed.

Section functor_fix_snd_arg.

Variable E : precategory.
Variable F: functor product_precategory E.
Variable d: D.

Definition functor_fix_snd_arg_ob (c:C): E := F(tpair _ c d).
Definition functor_fix_snd_arg_mor (c c':C)(f: c ⇒ c'): functor_fix_snd_arg_ob c ⇒ functor_fix_snd_arg_ob c'.
Proof.
  apply (#F).
  split; simpl.
  exact f.
  exact (identity d).
Defined.
Definition functor_fix_snd_arg_data : functor_data C E.
Proof.
  red.
  exists functor_fix_snd_arg_ob.
  exact functor_fix_snd_arg_mor.
Defined.

Lemma is_functor_functor_fix_snd_arg_data: is_functor functor_fix_snd_arg_data.
Proof.
  red.
  split; red.
  + intros c.
    unfold functor_fix_snd_arg_data; simpl.
    unfold functor_fix_snd_arg_mor; simpl.
    unfold functor_fix_snd_arg_ob; simpl.
    assert (functor_id_inst := functor_id F).
    rewrite <- functor_id_inst.
    apply maponpaths.
    apply idpath.
  + intros c c' c'' f g.
    unfold functor_fix_snd_arg_data; simpl.
    unfold functor_fix_snd_arg_mor; simpl.
    assert (functor_comp_inst := functor_comp F (dirprodpair c d) (dirprodpair c' d) (dirprodpair c'' d)).
    rewrite <- functor_comp_inst.
    apply maponpaths.
    unfold compose at 2.
    unfold product_precategory; simpl.
    rewrite id_left.
    apply idpath.
Qed.

Definition functor_fix_snd_arg: functor C E.
Proof.
  exists functor_fix_snd_arg_data.
  exact is_functor_functor_fix_snd_arg_data.
Defined.

End functor_fix_snd_arg.

Section nat_trans_fix_snd_arg.

Variable E : precategory.
Variable F F': functor product_precategory E.
Variable α: F ⟶ F'.
Variable d: D.

Definition nat_trans_fix_snd_arg_data (c:C): functor_fix_snd_arg E F d c ⇒ functor_fix_snd_arg E F' d c := α (tpair _ c d).

Lemma nat_trans_fix_snd_arg_ax: is_nat_trans _ _ nat_trans_fix_snd_arg_data.
Proof.
  red.
  intros c c' f.
  unfold nat_trans_fix_snd_arg_data, functor_fix_snd_arg; simpl.
  unfold functor_fix_snd_arg_mor; simpl.
  assert (nat_trans_ax_inst := nat_trans_ax α).
  apply nat_trans_ax_inst.
Qed.

Definition nat_trans_fix_snd_arg: functor_fix_snd_arg E F d ⟶ functor_fix_snd_arg E F' d.
Proof.
  exists nat_trans_fix_snd_arg_data.
  exact nat_trans_fix_snd_arg_ax.
Defined.

End nat_trans_fix_snd_arg.

End one_product_precategory.


Require Import Arith.
Require Import List.
Require Import ZArith.

Structure DecidableEquality :=
    { dec_eq_type :> Set
    ; dec_eq_decide : forall (x y : dec_eq_type), { x = y } + { x <> y }
    }.

Arguments Build_DecidableEquality [_] _.

Definition eq_dec {A : DecidableEquality} (x y : A) : { x = y } + { x <> y } :=
    dec_eq_decide A x y.
Hint Resolve eq_dec : eq_dec.

Canonical Structure dec_eq_nat :=
    Build_DecidableEquality eq_nat_dec.

Canonical Structure dec_eq_Z :=
    Build_DecidableEquality Z.eq_dec.

Canonical Structure dec_eq_list (A : DecidableEquality) :=
    Build_DecidableEquality (list_eq_dec (@eq_dec A)).

Definition prod_eq_dec {A B}
        (A_eq_dec : forall (x y : A), { x = y } + { x <> y })
        (B_eq_dec : forall (x y : B), { x = y } + { x <> y })
        (x y : A * B) : { x = y } + { x <> y } :=
    ltac:(decide equality).

Canonical Structure dec_eq_prod (A B : DecidableEquality) :=
    @Build_DecidableEquality _ (prod_eq_dec (@eq_dec A) (@eq_dec B)).


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Monoid.
Require Import Blech.Group.

Import BishopNotations.
Import MonoidNotations.
Import GroupNotations.

Open Scope bishop_scope.
Open Scope monoid_scope.
Open Scope group_scope.

(* The abstract AST of a monoid subject to setoid quotient. Very
inefficient. You probably want List *)

#[universes(cumulative)]
Inductive free (S: Bishop) := η (_: S) | e | app (_ _: free S) | invert (_: free S).

Arguments η {S}.
Arguments e {S}.
Arguments app {S}.
Arguments invert {S}.

Inductive equiv {S: Bishop} : relation (free S) :=
| reflexive: reflexive _ equiv
| symmetric: symmetric _ equiv
| transitive: transitive _ equiv

| η_compat: Proper (SetoidClass.equiv ==> equiv) η

| app_assoc f g h: equiv (app f (app g h)) (app (app f g) h)
| app_e_left f: equiv (app e f) f
| app_e_right f: equiv (app f e) f

| app_compat: Proper (equiv ==> equiv ==> equiv) app

| app_invert_left f: equiv (app (invert f) f) e
| app_invert_right f: equiv (app f (invert f)) e

| invert_compat: Proper (equiv ==> equiv) invert
.
#[global]
Existing Instance η_compat.
#[global]
Existing Instance app_compat.
#[global]
Existing Instance invert_compat.

#[global]
#[program]
Instance free_Setoid (S: Bishop): Setoid (free S) := {
  equiv := equiv ;
}.
Next Obligation.
Proof.
  exists.
  - apply reflexive.
  - apply symmetric.
  - apply transitive.
Qed.

Definition Free (S: Bishop): Group := {|
  M := {|
    S := free S /~ free_Setoid S ;

    Monoid.e := e ;
    Monoid.app := app ;

    Monoid.app_assoc := app_assoc ;
    Monoid.app_e_left := app_e_left ;
    Monoid.app_e_right := app_e_right ;
    Monoid.app_compat := app_compat ;
  |} ;

  Group.invert := invert ;
  Group.app_invert_left := app_invert_left ;
  Group.app_invert_right := app_invert_right ;
  Group.invert_compat := invert_compat ;
|}.

Fixpoint ε {G: Group} (g: Free G): G :=
  match g with
  | η x => x
  | e => Monoid.e
  | app x y => ε x · ε y
  | invert x => (ε x) ⁻¹
  end.


(** * Left and right identity laws of adjunction composition *)
Require Import Category.Core Functor.Core.
Require Import Adjoint.Composition.Core Adjoint.Core Adjoint.Identity.
Require Adjoint.Composition.LawsTactic.
Require Import Types.Sigma Types.Prod.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope adjunction_scope.
Local Open Scope morphism_scope.

Section identity_lemmas.
  Local Notation AdjunctionWithFunctors C D :=
    { fg : Functor C D * Functor D C
    | fst fg -| snd fg }.

  Context `{Funext}.

  Variables C D : PreCategory.

  Variable F : Functor C D.
  Variable G : Functor D C.

  Variable A : F -| G.

  Local Open Scope adjunction_scope.

  Lemma left_identity
  : ((_, _); 1 o A) = ((_, _); A) :> AdjunctionWithFunctors C D.
  Proof.
    apply path_sigma_uncurried; simpl.
    (exists (path_prod'
               (Functor.Composition.Laws.left_identity _)
               (Functor.Composition.Laws.right_identity _))).
    Adjoint.Composition.LawsTactic.law_t.
  Qed.

  Lemma right_identity
  : ((_, _); A o 1) = ((_, _); A) :> AdjunctionWithFunctors C D.
  Proof.
    apply path_sigma_uncurried; simpl.
    (exists (path_prod'
               (Functor.Composition.Laws.right_identity _)
               (Functor.Composition.Laws.left_identity _))).
    Adjoint.Composition.LawsTactic.law_t.
  Qed.
End identity_lemmas.

#[export]
Hint Rewrite @left_identity @right_identity : category.
#[export]
Hint Immediate left_identity right_identity : category.


Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Composition.Core.
Require Import NaturalTransformation.Paths NaturalTransformation.Composition.Core.
Require Import Category.Morphisms FunctorCategory.Core.
Require Import Pseudofunctor.Core.
Require Import NaturalTransformation.Composition.Laws.
Require Import Trunc Types.Sigma.
Require Import Basics.Tactics.

Import Functor.Identity.FunctorIdentityNotations.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.
Local Open Scope category_scope.
Local Open Scope type_scope.

(** Quoting David Spivak:

    David: ok
       so an object of [FC ⇓ D] is a pair [(X, G)], where [X] is a
       finite category (or a small category or whatever you wanted)
       and [G : X --> D] is a functor.
       a morphism in [FC ⇓ D] is a ``natural transformation diagram''
       (as opposed to a commutative diagram, in which the natural
       transformation would be ``identity'')
       so a map in [FC ⇓ D] from [(X, G)] to [(X', G')] is a pair
       [(F, α)] where [F : X --> X'] is a functor and
       [α : G --> G' ∘ F] is a natural transformation
       and the punchline is that there is a functor
       [colim : FC ⇓ D --> D]

     David: consider for yourself the case where [F : X --> X'] is
       identity ([X = X']) and (separately) the case where
       [α : G --> G ∘ F] is identity.
       the point is, you've already done the work to get this colim
       functor.
       because every map in [FC ⇓ D] can be written as a composition
       of two maps, one where the [F]-part is identity and one where
       the [α]-part is identity.
       and you've worked both of those cases out already.
       *)

Module Import LaxCommaCategoryParts.
  Section lax_comma_category_parts.
    Context `{Funext}.
    Variables A B : PreCategory.

    Variable S : Pseudofunctor A.
    Variable T : Pseudofunctor B.

    Context `{forall a b, IsHSet (Functor (S a) (T b))}.

    Record object :=
      {
        a : A;
        b : B;
        f : Functor (S a) (T b)
      }.

    Local Notation object_sig_T :=
      ({ a : A
       | { b : B
         | Functor (S a) (T b) }}).

    Lemma issig_object
    : object_sig_T <~> object.
    Proof.
      issig.
    Defined.

    Global Instance trunc_object `{IsTrunc n A, IsTrunc n B}
           `{forall s d, IsTrunc n (Functor (S s) (T d))}
    : IsTrunc n object.
    Proof.
      eapply istrunc_equiv_istrunc;
      [ exact issig_object | ].
      typeclasses eauto.
    Qed.

    Lemma path_object (x y : object)
    : forall (Ha : x.(a) = y.(a))
             (Hb : x.(b) = y.(b)),
        match Ha in _ = X, Hb in _ = Y return Functor (S X) (T Y) with
          | idpath, idpath => x.(f)
        end = y.(f)
        -> x = y.
    Proof.
      destruct x, y; simpl.
      intros; path_induction; reflexivity.
    Defined.

    Definition path_object_uncurried x y
               (H : { HaHb : (x.(a) = y.(a)) * (x.(b) = y.(b))
                    | match fst HaHb in _ = X, snd HaHb in _ = Y return Functor (S X) (T Y) with
                        | idpath, idpath => x.(f)
                      end = y.(f) })
    : x = y
      := @path_object x y (fst H.1) (snd H.1) H.2.

    Lemma ap_a_path_object x y Ha Hb Hf
    : ap (@a) (@path_object x y Ha Hb Hf) = Ha.
    Proof.
      destruct x, y; simpl in *.
      destruct Ha, Hb, Hf; simpl in *.
      reflexivity.
    Qed.

    Lemma ap_b_path_object x y Ha Hb Hf
    : ap (@b) (@path_object x y Ha Hb Hf) = Hb.
    Proof.
      destruct x, y; simpl in *.
      destruct Ha, Hb, Hf; simpl in *.
      reflexivity.
    Qed.

    Global Opaque path_object.

    Record morphism (abf a'b'f' : object) :=
      {
        g : Category.Core.morphism A (abf.(a)) (a'b'f'.(a));
        h : Category.Core.morphism B (abf.(b)) (a'b'f'.(b));
        p : NaturalTransformation (p_morphism_of T h o abf.(f))
                                  (a'b'f'.(f) o p_morphism_of S g)
      }.

    Local Notation morphism_sig_T abf a'b'f' :=
      ({ g : Category.Core.morphism A (abf.(a)) (a'b'f'.(a))
       | { h : Category.Core.morphism B (abf.(b)) (a'b'f'.(b))
         | NaturalTransformation (p_morphism_of T h o abf.(f))
                                 (a'b'f'.(f) o p_morphism_of S g) }}).

    Lemma issig_morphism abf a'b'f'
    : (morphism_sig_T abf a'b'f')
        <~> morphism abf a'b'f'.
    Proof.
      issig.
    Defined.

    Global Instance trunc_morphism abf a'b'f'
           `{IsTrunc n (Category.Core.morphism A (abf.(a)) (a'b'f'.(a)))}
           `{IsTrunc n (Category.Core.morphism B (abf.(b)) (a'b'f'.(b)))}
           `{forall m1 m2,
               IsTrunc n (NaturalTransformation
                            (p_morphism_of T m2 o abf.(f))
                            (a'b'f'.(f) o p_morphism_of S m1))}
    : IsTrunc n (morphism abf a'b'f').
    Proof.
      eapply istrunc_equiv_istrunc;
      [ exact (issig_morphism _ _) | ].
      typeclasses eauto.
    Qed.

    Lemma path_morphism abf a'b'f'
          (gh g'h' : morphism abf a'b'f')
    : forall
        (Hg : gh.(g) = g'h'.(g))
        (Hh : gh.(h) = g'h'.(h)),
        match Hg in _ = g, Hh in _ = h
              return NaturalTransformation
                       (p_morphism_of T h o abf.(f))
                       (a'b'f'.(f) o p_morphism_of S g)
        with
          | idpath, idpath => gh.(p)
        end = g'h'.(p)
         -> gh = g'h'.
    Proof.
      intros Hg Hh Hp.
      destruct gh, g'h'; simpl in *.
      destruct Hg, Hh, Hp.
      reflexivity.
    Qed.

    Definition path_morphism_uncurried abf a'b'f' gh g'h'
               (H : { HgHh : (gh.(g) = g'h'.(g)) * (gh.(h) = g'h'.(h))
                    | match fst HgHh in _ = g, snd HgHh in _ = h
                            return NaturalTransformation
                                     (p_morphism_of T h o abf.(f))
                                     (a'b'f'.(f) o p_morphism_of S g)
                      with
                        | idpath, idpath => gh.(p)
                      end = g'h'.(p) })
    : gh = g'h'
      := @path_morphism abf a'b'f' gh g'h' (fst H.1) (snd H.1) H.2.

    Lemma path_morphism'_helper abf a'b'f'
          (gh g'h' : morphism abf a'b'f')
    : forall
        (Hg : gh.(g) = g'h'.(g))
        (Hh : gh.(h) = g'h'.(h)),
        ((_ oL (Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ S _ _) Hg) : Category.Core.morphism _ _ _))
           o (gh.(p))
           o ((Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ T _ _) Hh) : Category.Core.morphism _ _ _)^-1 oR _)
         = g'h'.(p))%natural_transformation
        -> match Hg in _ = g, Hh in _ = h
                 return NaturalTransformation
                          (p_morphism_of T h o abf.(f))
                          (a'b'f'.(f) o p_morphism_of S g)
           with
             | idpath, idpath => gh.(p)
           end = g'h'.(p).
    Proof.
      simpl; intros Hg Hh Hp.
      destruct g'h'; simpl in *.
      destruct Hg, Hh, Hp; simpl in *.
      path_natural_transformation.
      autorewrite with functor morphism.
      reflexivity.
    Qed.

    Definition path_morphism' abf a'b'f'
               (gh g'h' : morphism abf a'b'f')
               (Hg : gh.(g) = g'h'.(g))
               (Hh : gh.(h) = g'h'.(h))
               (Hp : ((_ oL (Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ S _ _) Hg) : Category.Core.morphism _ _ _))
                        o (gh.(p))
                        o ((Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ T _ _) Hh) : Category.Core.morphism _ _ _)^-1 oR _)
                      = g'h'.(p))%natural_transformation)
    : gh = g'h'
      := @path_morphism abf a'b'f' gh g'h' Hg Hh
                        (@path_morphism'_helper abf a'b'f' gh g'h' Hg Hh Hp).

    Definition path_morphism'_uncurried abf a'b'f' gh g'h'
               (H : { HgHh : (gh.(g) = g'h'.(g)) * (gh.(h) = g'h'.(h))
                    | ((_ oL (Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ S _ _) (fst HgHh)) : Category.Core.morphism _ _ _))
                         o (gh.(p))
                         o ((Category.Morphisms.idtoiso (_ -> _) (ap (@p_morphism_of _ _ T _ _) (snd HgHh)) : Category.Core.morphism _ _ _)^-1 oR _)
                       = g'h'.(p))%natural_transformation })
    : gh = g'h'
      := @path_morphism' abf a'b'f' gh g'h' (fst H.1) (snd H.1) H.2.

    Definition compose s d d'
               (gh : morphism d d') (g'h' : morphism s d)
    : morphism s d'.
    Proof.
      exists (gh.(g) o g'h'.(g)) (gh.(h) o g'h'.(h)).
      exact ((_ oL (p_composition_of S _ _ _ _ _)^-1)
               o (associator_1 _ _ _)
               o (gh.(p) oR _)
               o (associator_2 _ _ _)
               o (_ oL g'h'.(p))
               o (associator_1 _ _ _)
               o ((p_composition_of T _ _ _ _ _ : Category.Core.morphism _ _ _)
                    oR _))%natural_transformation.
    Defined.

    Global Arguments compose _ _ _ _ _ / .

    Definition identity x : morphism x x.
    Proof.
      exists (identity (x.(a))) (identity (x.(b))).
      exact ((_ oL (p_identity_of S _ : Category.Core.morphism _ _ _)^-1)
               o (right_identity_natural_transformation_2 _)
               o (left_identity_natural_transformation_1 _)
               o ((p_identity_of T _ : Category.Core.morphism _ _ _)
                    oR _))%natural_transformation.
    Defined.

    Global Arguments identity _ / .
  End lax_comma_category_parts.
End LaxCommaCategoryParts.


Require Import Coq.Program.Basics.
Require Import FunctionalExtensionality.
Require Export functor.
Require Import monad.

Definition cont R A := (A -> R) -> R.

Instance Fmap_cont R : Fmap (cont R) :=
  fun _ _ f m k => m (k ∘ f).

Instance Functor_cont R : Functor (cont R).
Proof. firstorder. Qed.

Instance Return_cont R : Return (cont R) :=
  fun _ => flip apply.

Instance Join_cont R : Join (cont R) :=
  fun _ m r => m (flip apply r).

Instance Jmonad_cont R : Jmonad (cont R).
Proof. firstorder. Qed.