(** * Auto: More Automation *)

Set Warnings "-notation-overridden,-parsing".
Require Import Coq.omega.Omega.
Require Import Maps.
Require Import Imp.

(** 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: proof search via the [auto] tactic,
    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_.

    There's another major category of automation we haven't discussed
    much yet, namely built-in decision procedures for specific kinds
    of problems: [omega] is one example, but there are others.  This
    topic will be deferred for a while longer.

    Our motivating example will be this proof, repeated with just a
    few small changes from the [Imp] chapter.  We will simplify
    this proof in several stages. *)

Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *)
    reflexivity.
  - (* b evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.  Qed.

(* ################################################################# *)
(** * 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. assumption.
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.

(** 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. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  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.

    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.

    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.

    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.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  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.

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

(** Now let's take a first pass over [ceval_deterministic] to simplify
    the proof script.
 *)

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

(** When we are using a particular tactic many times in a proof, we
    can use a variant of the [Proof] command to make that tactic into
    a default within the proof.  Saying [Proof with t] (where [t] is
    an arbitrary tactic) allows us to use [t1...] as a shorthand for
    [t1;t] within the proof.  As an illustration, here is an alternate
    version of the previous proof, using [Proof with auto]. *)

Theorem ceval_deterministic'_alt: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
           intros st2 E2; inv E2...
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

(* ################################################################# *)
(** * Searching For Hypotheses *)

(** The proof has become simpler, but there is still an annoying
    amount of repetition. Let's start by tackling the contradiction
    cases. Each of them occurs in a situation where we have both

      H1: beval st b = false

    and

      H2: beval st b = true

    as hypotheses.  The contradiction is evident, but demonstrating it
    is a little complicated: we have to locate the two hypotheses [H1]
    and [H2] and do a [rewrite] following by an [inversion].  We'd
    like to automate this process.

    (In fact, Coq has a built-in tactic [congruence] that will do the
    job in this case.  But we'll ignore the existence of this tactic
    for now, in order to demonstrate how to build forward search
    tactics by hand.)

    As a first step, we can abstract out the piece of script in
    question by writing a little function in Coq's tactic programming
    language, Ltac. *)

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rwinv H H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rwinv H H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

(** That was is a bit better, but not much.  We really want Coq to
    discover the relevant hypotheses for us.  We can do this by using
    the [match goal] facility of Ltac. *)

Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwinv H1 H2
  end.

(** The [match goal] tactic looks for two distinct hypotheses that
    have the form of equalities, with the same arbitrary expression
    [E] on the left and with conflicting boolean values on the right.
    If such hypotheses are found, it binds [H1] and [H2] to their
    names and applies the [rwinv] tactic to [H1] and [H2].

    Adding this tactic to the ones that we invoke in each case of the
    induction handles all of the contradictory cases. *)

Theorem ceval_deterministic''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

(** Let's see about the remaining cases. Each of them involves
    applying a conditional hypothesis to extract an equality.
    Currently we have phrased these as assertions, so that we have to
    predict what the resulting equality will be (although we can then
    use [auto] to prove it).  An alternative is to pick the relevant
    hypotheses to use and then [rewrite] with them, as follows: *)

Theorem ceval_deterministic'''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    rewrite (IHE1_1 st'0 H1) in *. auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

(** Now we can automate the task of finding the relevant hypotheses to
    rewrite with. *)

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

(** The pattern [forall x, ?P x -> ?L = ?R] matches any hypothesis of
    the form "for all [x], _some property of [x]_ implies _some
    equality_."  The property of [x] is bound to the pattern variable
    [P], and the left- and right-hand sides of the equality are bound
    to [L] and [R].  The name of this hypothesis is bound to [H1].
    Then the pattern [?P ?X] matches any hypothesis that provides
    evidence that [P] holds for some concrete [X].  If both patterns
    succeed, we apply the [rewrite] tactic (instantiating the
    quantified [x] with [X] and providing [H2] as the required
    evidence for [P X]) in all hypotheses and the goal.

    One problem remains: in general, there may be several pairs of
    hypotheses that have the right general form, and it seems tricky
    to pick out the ones we actually need.  A key trick is to realize
    that we can _try them all_!  Here's how this works:

    - each execution of [match goal] will keep trying to find a valid
      pair of hypotheses until the tactic on the RHS of the match
      succeeds; if there are no such pairs, it fails;
    - [rewrite] will fail given a trivial equation of the form [X = X];
    - we can wrap the whole thing in a [repeat], which will keep doing
      useful rewrites until only trivial ones are left. *)

Theorem ceval_deterministic''''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

(** The big payoff in this approach is that our proof script
    should be robust in the face of modest changes to our language.
    For example, we can add a [REPEAT] command to the language. *)

Module Repeat.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

(** [REPEAT] behaves like [WHILE], except that the loop guard is
    checked _after_ each execution of the body, with the loop
    repeating as long as the guard stays _false_.  Because of this,
    the body will always execute at least once. *)

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.

Notation "c1 '/' st '\\' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

(** Our first attempt at the determinacy proof is disappointing: the
    [E_RepeatEnd] and [E_RepeatLoop] cases are not handled by our
    previous automation. *)

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  - (* E_RepeatEnd *)
    + (* b evaluates to false (contradiction) *)
       find_rwinv.
       (* oops: why didn't [find_rwinv] solve this for us already?
          answer: we did things in the wrong order. *)
  - (* E_RepeatLoop *)
     + (* b evaluates to true (contradiction) *)
        find_rwinv.
Qed.

(** Fortunately, to fix this, we just have to swap the invocations of
    [find_eqn] and [find_rwinv]. *)

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.

End Repeat.

(** These examples just give a flavor of what "hyper-automation" can
    achieve in Coq.  The details of [match goal] are a bit tricky, and
    debugging scripts using it is, frankly, not very pleasant.  But it
    is well worth adding at least simple uses to your proofs, both to
    avoid tedium and to "future proof" them. *)

(* ----------------------------------------------------------------- *)
(** *** [eapply] and [eauto] *)

(** To close the chapter, we'll introduce one more convenient feature
    of Coq: its ability to delay instantiation of quantifiers.  To
    motivate this feature, recall this example from the [Imp]
    chapter: *)

Example ceval_example1:
    (X ::= ANum 2;;
     IFB BLe (AId X) (ANum 1)
       THEN Y ::= ANum 3
       ELSE Z ::= ANum 4
     FI)
   / empty_state
   \\ (t_update (t_update empty_state X 2) Z 4).
Proof.
  (* We supply the intermediate state [st']... *)
  apply E_Seq with (t_update empty_state X 2).
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
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 [E_Seq] constructor.  This was needed because the definition
    of [E_Seq]...

          E_Seq : forall c1 c2 st st' st'',
            c1 / st  \\ st' ->
            c2 / st' \\ st'' ->
            (c1 ;; c2) / st \\ st''

   is quantified over a variable, [st'], 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 [st']").

   What's silly about this error is that the appropriate value for [st']
   will actually become obvious in the very next step, where we apply
   [E_Ass].  If Coq could just wait until we get to this step, there
   would be no need to give the value explicitly.  This is exactly what
   the [eapply] tactic gives us: *)

Example ceval'_example1:
    (X ::= ANum 2;;
     IFB BLe (AId X) (ANum 1)
       THEN Y ::= ANum 3
       ELSE Z ::= ANum 4
     FI)
   / empty_state
   \\ (t_update (t_update empty_state X 2) Z 4).
Proof.
  eapply E_Seq. (* 1 *)
  - apply E_Ass. (* 2 *)
    reflexivity. (* 3 *)
  - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(** The tactic [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_ [?st']
    in both of the generated subgoals.  The next step (which gets us
    to position [2]) replaces [?st'] with a concrete value.  This new
    value contains a new existential variable [?n], which is
    instantiated in its turn by the following [reflexivity] step,
    position [3].  When we start working on the second
    subgoal (position [4]), we observe that the occurrence of [?st']
    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]: *)

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := t_update (t_update empty_state X 1) Y 2.
Definition st21 := t_update (t_update empty_state X 2) Y 1.

Example auto_example_8 : exists s',
  (IFB (BLe (AId X) (AId Y))
    THEN (Z ::= AMinus (AId Y) (AId X))
    ELSE (Y ::= APlus (AId X) (AId Z))
  FI) / st21 \\ s'.
Proof. eauto. Qed.

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

(** $Date: 2017-09-06 10:45:52 -0400 (Wed, 06 Sep 2017) $ *)


(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
Ltac typeof X := type of X.
Require Import ssrmatching.
From mathcomp Require Import all_ssreflect.
From mathcomp Require boolp.
Require Import monae_lib.
From HB Require Import structures.
Require Import hierarchy.

(******************************************************************************)
(*  Properties and examples of functors, natural transformations, and monads  *)
(*                                                                            *)
(*            liftM2 h m1 m2 == as in Haskell                                 *)
(*      examples of functors : squaring, curry_F, uncurry_F, exponential_F    *)
(*                       NId == identity natural transformation               *)
(*                        \v == vertical composition of natural               *)
(*                              transformations                               *)
(*                        \h == horizontal composition of natural             *)
(*                              transformations                               *)
(*                    F ## n == application of the functor F to the natural   *)
(*                              transformation n                              *)
(*                      fork == the natural transformation fun A a => (a, a)  *)
(*                    F -| G == adjoint functors                              *)
(*   Module monad_of_adjoint == derivation of a monad from an adjunction      *)
(* Section composite_adjoint == composition of adjunctions                    *)
(*                                                                            *)
(*            E.-operation M == sigma operation for a monad M given a         *)
(*                              functor E                                     *)
(*           algebraicity op == the operation op is algebraic                 *)
(*          E .-aoperation M == algebraic E.-operation M                      *)
(*                                                                            *)
(*                  mpair xy := xy.1 >>= (fun u => xy.2 >>=                   *)
(*                                (fun v => (Ret (u, v)))                     *)
(*             commute m n f := (m >>= n >>= f) = (n >>= m >>= f)             *)
(*                              (ref: definition 4.2, mu2019tr3)              *)
(*             preserves f g := the monadic function f : A -> M A preserves   *)
(*                              the value of the function g : A -> B          *)
(*                  rep n mx == mx >> mx >> ... >> mx, n times                *)
(*                                                                            *)
(******************************************************************************)

Reserved Notation "f ^`2" (format "f ^`2", at level 3).
Reserved Notation "F ## g" (at level 11).
Reserved Notation "E .-operation M" (at level 2, format "E  .-operation  M").
Reserved Notation "E .-aoperation M" (at level 2, format "E  .-aoperation  M").

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope monae_scope.

Lemma bind_if (M : monad) (A B : UU0) (b : bool) (m : M A) (f g : A -> M B) :
  m >>= (fun x => if b then f x else g x) = if b then m >>= f else m >>= g.
Proof. by case: ifPn. Qed.

Lemma if_bind (M : monad) (A B : UU0) (b : bool) (m n : M A) (f : A -> M B) :
  (if b then m else n) >>= f = (if b then m >>= f else n >>= f).
Proof. by case: ifPn. Qed.

Local Open Scope mprog.
Lemma mfoldl_rev {M : monad} (T R : UU0) (f : R -> T -> R) (z : R) (s : seq T -> M (seq T)) :
  foldl f z (o) (rev (o) s) = foldr (fun x => f^~ x) z (o) s.
Proof.
apply boolp.funext => x; rewrite !fcompE 3!fmapE !bindA.
bind_ext => ?; by rewrite bindretf /= -foldl_rev.
Qed.
Local Close Scope mprog.

Definition liftM2 {M : monad} (A B C : UU0) (h : A -> B -> C) m1 m2 : M C :=
  m1 >>= (fun a => m2 >>= (fun b => Ret (h a b))).

Section liftM2_lemmas.
Variables (M : monad) (A B C : UU0) (h : A -> B -> C).

Lemma liftM2E m1 m2 D (f : C -> M D) : liftM2 h m1 m2 >>= f =
  m1 >>= (fun x => m2 >>= fun y => f (h x y)) :> M _.
Proof.
rewrite /liftM2 bindA; under eq_bind do rewrite bindA.
by bind_ext => s; under eq_bind do rewrite bindretf.
Qed.

Lemma liftM2_ret a b : liftM2 h (Ret a) (Ret b) = Ret (h a b) :> M _.
Proof. by rewrite /liftM2 !bindretf. Qed.

Lemma bind_liftM2_size (f : seq A -> seq B -> seq C)
    (m1 : M (seq A)) (m2 : M (seq B)) n :
  (forall a b, size (f a b) = size a + size b + n) ->
  liftM2 f m1 m2 >>= (fun x => Ret (x, size x)) =
  liftM2 (fun a b => (f a.1 b.1, a.2 + b.2 + n))
          (m1 >>= (fun x => Ret (x, size x)))
          (m2 >>= (fun x => Ret (x, size x))).
Proof.
move=> hf.
rewrite /liftM2 !bindA; bind_ext => x1.
rewrite !bindretf !bindA.
bind_ext=> x2.
by rewrite !bindretf /= hf.
Qed.

End liftM2_lemmas.
Arguments bind_liftM2_size {M A B C} {f} m1 m2 n.

Definition Squaring (A : UU0) := (A * A)%type.
Definition squaring_f (A B : UU0) (f : A -> B) : Squaring A -> Squaring B :=
  fun x => (f x.1, f x.2).
Lemma squaring_f_id : FunctorLaws.id squaring_f.
Proof. by move=> A /=; apply boolp.funext => -[x1 x2]. Qed.
Lemma squaring_f_comp : FunctorLaws.comp squaring_f.
Proof. by move=> A B C g h /=; apply boolp.funext => -[x1 x2]. Qed.
HB.instance Definition _ :=
  isFunctor.Build Squaring squaring_f_id squaring_f_comp.
Definition squaring : functor := [the functor of Squaring].
Notation "f ^`2" := (squaring # f).
Lemma squaringE (A B : UU0) (f : A -> B) x : (f ^`2) x = (f x.1, f x.2).
Proof. by []. Qed.

Section curry_functor.
Variable X : UU0.
Definition curry_M : UU0 -> UU0 := fun B => (X * B)%type.
Definition curry_f (A B : UU0) (f : A -> B) : curry_M A -> curry_M B :=
  fun x : X * A => (x.1, f x.2).
Lemma curry_f_id : FunctorLaws.id curry_f.
Proof.
by rewrite /FunctorLaws.id => A; rewrite /curry_f; apply boolp.funext => -[].
Qed.
Lemma curry_f_comp : FunctorLaws.comp curry_f.
Proof.
by rewrite /FunctorLaws.comp => A B C g h; rewrite /curry_f; apply boolp.funext => -[].
Qed.
HB.instance Definition _ :=
  @isFunctor.Build curry_M curry_f curry_f_id curry_f_comp.
Definition curry_F : functor := [the functor of curry_M].
End curry_functor.

Section uncurry_functor.
Definition uncurry_M (X : UU0) : UU0 -> UU0 := fun B => X -> B.
Definition uncurry_f (X A B : UU0) (f : A -> B) : uncurry_M X A -> uncurry_M X B :=
  fun g : X -> A => f \o g.
Lemma uncurry_f_id X : FunctorLaws.id (@uncurry_f X).
Proof.
rewrite /FunctorLaws.id => A; rewrite /uncurry_f; apply boolp.funext => ?.
by rewrite compidf.
Qed.
Lemma uncurry_f_comp X : FunctorLaws.comp (@uncurry_f X).
Proof.
rewrite /FunctorLaws.comp => A B C g h; rewrite /uncurry_f; apply boolp.funext => ?.
by rewrite compE compA.
Qed.
HB.instance Definition _ X :=
  isFunctor.Build (@uncurry_M X) (uncurry_f_id X) (uncurry_f_comp X).
Definition uncurry_F X : functor := [the functor of @uncurry_M X].
End uncurry_functor.

Section exponential_functor.
Variable A : UU0.
Definition exponential_M (X : UU0) := A -> X.
Definition exponential_f (X Y : UU0) (f : X -> Y) :
  exponential_M X -> exponential_M Y := fun e => f \o e.
Lemma exponential_f_id : FunctorLaws.id exponential_f. Proof. by []. Qed.
Lemma exponential_f_comp : FunctorLaws.comp exponential_f.
Proof. by []. Qed.
HB.instance Definition _ :=
  @isFunctor.Build exponential_M exponential_f exponential_f_id exponential_f_comp.
Definition exponential_F : functor := [the functor of exponential_M].
End exponential_functor.

Lemma fmap_oE (M : functor) (A B C : UU0) (f : A -> B) (g : C -> A) (m : M C) :
  (M # (f \o g)) m = (M # f) ((M # g) m).
Proof. by rewrite functor_o. Qed.

Section id_natural_transformation.
Variables C : functor.
Definition NId := fun A => @id (C A).
Definition natural_id : naturality C C NId. Proof. by []. Qed.
HB.instance Definition _ := isNatural.Build C C NId natural_id.
End id_natural_transformation.
Arguments NId C [A].

Section vertical_composition.
Variables (C D E : functor) (g : D ~> E) (f : C ~> D).

Definition vcomp := locked (fun (A : UU0) => g A \o f A).

Definition natural_vcomp : naturality _ _ vcomp.
Proof.
by move=> A B h; rewrite /vcomp; unlock; rewrite compA natural -compA natural.
Qed.

HB.instance Definition _ := isNatural.Build C E vcomp natural_vcomp.

Definition VComp : C ~> E := [the C ~> E of vcomp].

End vertical_composition.

Notation "f \v g" := [the _ ~> _ of vcomp f g].

Lemma vcompE (F G H : functor) (n1 : F ~> H) (n2 : G ~> F) X :
  (n1 \v n2) X = n1 X \o n2 X.
Proof. by rewrite /= /vcomp /=; unlock. Qed.

Lemma vassoc (F1 F2 G H : functor) (f : F1 ~> F2) (g : G ~> F1) (h : H ~> G) :
  f \v g \v h = f \v (g \v h).
Proof. by apply/nattrans_ext => a /=; rewrite !vcompE. Qed.

Section horizontal_composition.
Variables (F G F' G' : functor) (s : F ~> G) (t : F' ~> G').

Definition hcomp : F' \o F ~~> G' \o G :=
  fun (A : UU0) => @t (G A) \o F' # (@s A).

Lemma natural_hcomp :
  naturality [the functor of F' \o F] [the functor of G' \o G] hcomp.
Proof.
move=> A B h.
rewrite [LHS]compA (natural t) -[LHS]compA -[in RHS]compA.
by congr (_ \o _); rewrite FCompE -2!functor_o (natural s).
Qed.

HB.instance Definition _ := isNatural.Build
  [the functor of F' \o F] [the functor of G' \o G] hcomp natural_hcomp.

Definition HComp : [the functor of F' \o F] ~> [the functor of G' \o G] :=
  [the _ ~> _ of hcomp].

End horizontal_composition.

Notation "f \h g" := (HComp g f).

Section functor_natural_transformation.
Variables (S F G : functor) (nt : F ~> G).

Definition fun_app_nt : S \o F ~~> S \o G :=
  fun (A : UU0) => S # (nt A).

Lemma natural_fun_app_nt :
  naturality [the functor of S \o F] [the functor of S \o G] fun_app_nt.
Proof.
by move=> *; rewrite /fun_app_nt 2!FCompE -2!(@functor_o S) natural.
Qed.

HB.instance Definition _ := isNatural.Build
  [the functor of S \o F] [the functor of S \o G] fun_app_nt natural_fun_app_nt.

Definition functor_app_natural :
    [the functor of S \o F] ~> [the functor of S \o G] :=
  [the _ ~> _ of fun_app_nt].
End functor_natural_transformation.

Arguments functor_app_natural S {_} {_}.
Notation "F '##' g" := (functor_app_natural F g).

Lemma functor_app_naturalE (S F G : functor) (nt : F ~> G) X :
  (S ## nt) X = S # nt X.
Proof. by []. Qed.

Lemma functor_app_natural_hcomp (S F G : functor) (nt : F ~> G) :
  S ## nt = [the _ ~> _ of NId S] \h nt.
Proof. by apply nattrans_ext => a; rewrite functor_app_naturalE. Qed.

Section natural_transformation_example.
Definition fork' : FId ~~> squaring := fun (A : UU0) (a : A) => (a, a).

Lemma fork_natural : naturality _ _ fork'. Proof. by []. Qed.

HB.instance Definition _ := isNatural.Build FId squaring fork' fork_natural.

Definition fork : FId ~> squaring := [the _ ~> _ of fork'].

End natural_transformation_example.

Definition eta_type (f g : functor) := FId ~> [the functor of g \o f].
Definition eps_type (f g : functor) := [the functor of f \o g] ~> FId.
Module TriangularLaws.
Section triangularlaws.
Variables (F G : functor) (eps : eps_type F G) (eta : eta_type F G).
Definition left := forall A, eps (F A) \o (F # eta A) = @id (F A).
Definition right := forall A, (G # eps A) \o eta (G A) = @id (G A).
End triangularlaws.
End TriangularLaws.

Module AdjointFunctor.
Section adjointfunctor.
Variables F G : functor.
Record t := mk {
  eta : eta_type F G ;
  eps : eps_type F G ;
  tri_left : TriangularLaws.left eps eta ;
  tri_right : TriangularLaws.right eps eta}.
End adjointfunctor.
Section lemmas.
Variables (F G : functor) (H : t F G).
Definition hom_iso (A B : UU0) (h : F A -> B) : A -> G B := (G # h) \o @eta _ _ H A.
Definition hom_inv (A B : UU0) (h : A -> G B) : F A -> B := @eps _ _ H B \o (F # h).
End lemmas.
End AdjointFunctor.
Arguments AdjointFunctor.t : clear implicits.

Notation "F -| G" := (AdjointFunctor.t F G).

Section adjoint_example.
Variable (X : UU0).
Definition curry_fun : curry_F X \o uncurry_F X ~~> idfun :=
  fun (A : UU0) (af : X * (X -> A)) => af.2 af.1.
Lemma curry_naturality : naturality [the functor of curry_F X \o uncurry_F X] FId curry_fun.
Proof. by []. Qed.
HB.instance Definition _ := isNatural.Build
  [the functor of curry_F X \o uncurry_F X] FId curry_fun curry_naturality.
Definition curry_eps : eps_type (curry_F X) (uncurry_F X) :=
  [the nattrans [the functor of curry_F X \o uncurry_F X] FId of curry_fun].

Definition curry_fun2 : FId ~~> uncurry_F X \o curry_F X :=
  fun (A : UU0) (a : A) => pair^~ a.
Lemma curry_naturality2 :
  naturality _ [the functor of uncurry_F X \o curry_F X] curry_fun2.
Proof. by []. Qed.
HB.instance Definition _ := isNatural.Build
   _ [the functor of uncurry_F X \o curry_F X] curry_fun2 curry_naturality2.

Definition curry_eta : eta_type (curry_F X) (uncurry_F X) :=
  [the nattrans _ _ of curry_fun2].
Lemma adjoint_currry : curry_F X -| uncurry_F X.
Proof.
apply: (@AdjointFunctor.mk _ _ curry_eta curry_eps).
by move=> A; rewrite /TriangularLaws.left; apply boolp.funext => -[].
move=> A; rewrite /TriangularLaws.right /uncurry_F /curry_eps /curry_eta /uncurry_M.
by rewrite /= /uncurry_f /= /comp /=; apply boolp.funext => f; apply boolp.funext.
Qed.
End adjoint_example.

Module monad_of_adjoint.
Section def.
Variables (F G : functor) (eps : eps_type F G) (eta : eta_type F G).
Definition M := [the functor of G \o F].
Definition mu : M \o M ~~> M := fun A => G # eps (F A).
Definition bind A B (m : M A) (f : A -> M B) : M B := mu ((M # f) m).
End def.
Section prop.
Variables f g : functor.
Hypothesis Had : f -| g.
Let eps : eps_type f g := AdjointFunctor.eps Had.
Let eta : eta_type f g := AdjointFunctor.eta Had.
Section mu_eps_natural.
Notation M := (M f g).
Notation mu := (mu eps).
Lemma muM_natural : naturality _ _ mu.
Proof.
move => A B h.
rewrite (_ : [the functor of M \o M] # h = g # ([the functor of f \o g] # (f # h))) //.
rewrite (_ : _ \o g # ([the functor of f \o g] # (f # h)) =
  g # (@eps (f B) \o ([the functor of f \o g] # (f # h)))); last by rewrite -functor_o.
rewrite -natural FIdE.
rewrite [in LHS]FCompE.
rewrite /mu.
by rewrite -[in LHS](@functor_o g).
Qed.
Lemma epsC A : @eps _ \o @eps _ = @eps _ \o f # (g # (@eps _)) :> ((f \o g) ((f \o g) A) -> A).
Proof. by rewrite -natural. Qed.
Lemma muMA A : @mu A \o @mu (M A) = @mu A \o (M # @mu A).
Proof.
have -> : g # eps (f A) \o g # eps (f (M A)) =
  g # (@eps (f A) \o @eps (f (M A))) by rewrite functor_o.
by rewrite epsC functor_o.
Qed.
End mu_eps_natural.
Lemma bindetaf : BindLaws.left_neutral (bind eps) eta.
Proof.
rewrite /BindLaws.left_neutral => A B a h.
rewrite /bind /mu.
rewrite -(compE ([the functor of g \o f] # h)) (natural eta) -(compE (g # _)) compA.
by rewrite AdjointFunctor.tri_right.
Qed.
Lemma bindmeta : BindLaws.right_neutral (bind eps) eta.
Proof.
rewrite /BindLaws.right_neutral => A m.
rewrite /bind /mu -(compE (g # _)).
by rewrite -functor_o AdjointFunctor.tri_left functor_id.
Qed.
Lemma law3 : BindLaws.associative (bind eps).
Proof.
rewrite /BindLaws.associative => A B C x ab bc.
rewrite /bind.
set N := M f g.  set j := mu eps.
rewrite [X in _ = j C X](_ : _ = (N # (j C)) ((N # (N # bc)) ((N # ab) x))); last first.
  rewrite functor_o.
  rewrite compE.
  congr ((N # j C) _).
  rewrite functor_o.
  by rewrite (compE _ _ x).
move: muMA (muM_natural bc).
rewrite -/N -/j.
move=> muMA.
(*rewrite FCompE.*)
have -> : (N # bc) (j B ((N # ab) x)) = (N # bc \o j B) ((N # ab) x) by [].
move=> ->.
rewrite compE.
rewrite [LHS](_ : _ = (j C \o j (N C)) ((N # (N # bc)) ((N # ab) x))) //.
by rewrite muMA.
Qed.
End prop.
End monad_of_adjoint.

Section composite_adjoint.
Variables (F0 U0 : functor).
Hypothesis H0 : F0 -| U0.
Let eta0 : eta_type F0 U0 := AdjointFunctor.eta H0.
Let eps0 : eps_type F0 U0 := AdjointFunctor.eps H0.
Variables (F U : functor).
Hypothesis H : F -| U.
Let eta : eta_type F U := AdjointFunctor.eta H.
Let eps : eps_type F U := AdjointFunctor.eps H.

Definition uni_fun : FId ~~> (U0 \o U) \o (F \o F0) :=
  fun A : UU0 => U0 # eta (F0 A) \o eta0 A.

Lemma uni_naturality :
  naturality [the functor of idfun] [the functor of (U0 \o U) \o (F \o F0)] uni_fun.
Proof.
move=> A B h; rewrite FIdE.
rewrite -[RHS]compA.
rewrite -(natural (AdjointFunctor.eta H0)).
rewrite [LHS]compA.
rewrite [RHS]compA.
congr (_ \o _).
rewrite (FCompE U0 F0) -[in RHS](@functor_o U0) -[in LHS](@functor_o U0).
congr (_ # _).
by rewrite -(natural (AdjointFunctor.eta H)).
Qed.
HB.instance Definition _ := isNatural.Build _ _ uni_fun uni_naturality.

Let uni : @eta_type [the functor of F \o F0] [the functor of U0 \o U] :=
  [the nattrans _ [the functor of (U0 \o U) \o (F \o F0)] of uni_fun].

Definition couni_fun : ((F \o F0) \o (U0 \o U)) ~~> idfun :=
  fun A : UU0 => eps A \o F # eps0 (U A).

Lemma couni_naturality :
  naturality [the functor of (F \o F0) \o (U0 \o U)] _ couni_fun.
Proof.
move=> A B h.
rewrite [LHS]compA.
rewrite {}(natural (AdjointFunctor.eps H)).
rewrite -[LHS]compA.
rewrite -[RHS]compA; congr (_ \o _).
rewrite [in LHS]FCompE -[in LHS](@functor_o F) [in LHS](natural (AdjointFunctor.eps H0)).
by rewrite -[in RHS](@functor_o F).
Qed.
HB.instance Definition _ := isNatural.Build _ _ couni_fun couni_naturality.

Let couni : @eps_type [the functor of F \o F0] [the functor of U0 \o U] :=
  [the _ ~> _ of couni_fun].

Lemma composite_adjoint : [the functor of F \o F0] -| [the functor of U0 \o U].
Proof.
apply: (@AdjointFunctor.mk _ _ uni couni).
  rewrite /TriangularLaws.left => A.
  (*rewrite /couni /uni /=.*)
  rewrite FCompE -[LHS]compA.
  rewrite -(@functor_o F).
  rewrite (_ : @eps0 _ \o F0 # _ = @eta (F0 A)); first exact: (AdjointFunctor.tri_left H).
  rewrite functor_o [LHS]compA -FCompE.
  rewrite -(natural (AdjointFunctor.eps H0)) /= FIdE -compA.
  by rewrite (AdjointFunctor.tri_left H0) compfid.
rewrite /TriangularLaws.right => A.
rewrite /couni /uni /=.
rewrite compA -[RHS](AdjointFunctor.tri_right H0 (U A)); congr (_ \o _).
rewrite FCompE -functor_o; congr (_ # _).
rewrite functor_o -compA -FCompE.
rewrite (natural (AdjointFunctor.eta H)) FIdE.
by rewrite compA (AdjointFunctor.tri_right H) compidf.
Qed.

End composite_adjoint.

Definition operation (E : functor) (M : monad) := [the functor of E \o M] ~> M.
Notation "E .-operation M" := (operation E M).

Section algebraicity.
Variables (E : functor) (M : monad).
Definition algebraicity (op : (*E.-operation M*)E \o M ~~> M) :=
  forall (A B : UU0) (f : A -> M B) (t : E (M A)),
    op A t >>= f = op B ((E # (fun m => m >>= f)) t).
End algebraicity.

HB.mixin Record isAOperation (E : functor) (M : monad) (op : E \o M ~~> M) := {
  algebraic : algebraicity op }.
HB.structure Definition AOperation (E : functor) (M : monad) :=
  {op of isAOperation E M op &
         isNatural [the functor of E \o M] M op (*NB: this is an operation in fact*)}.
Notation aoperation := AOperation.type.
Arguments algebraic {E} {M} s.

(*Module AOperation.
Section aoperation.
Variables (E : functor) (M : monad).
Record mixin_of (op : E \O M ~> M) := Mixin { _ : algebraicity op }.
Record class_of (op : E \O M ~~> M) := Class {
  base : Natural.mixin_of op ;
  mixin : mixin_of (Natural.Pack base) }.
Structure t := Pack { m : E \O M ~~> M ; class : class_of m }.
Definition baseType (o : t) := Natural.Pack (base (class o)).
End aoperation.
Module Exports.
Arguments m {E} {M}.
Notation aoperation := t.
Coercion baseType : aoperation >-> nattrans.
Canonical baseType.
End Exports.
End AOperation.
Export AOperation.Exports.*)

Notation "E .-aoperation M" := (aoperation E M).

Section algebraic_operation_interface.
Variables (E : functor) (M : monad) (op : E.-aoperation M).
Lemma aoperation_ext (f g : E.-aoperation M) :
  f = g <-> forall a, (f a = g a :> (_ -> _)).
Proof.
split => [ -> // |]; move: f g => [f Hf] [g Hg] /= fg.
have ? : f = g by exact: funext_dep.
subst g; congr (AOperation.Pack _).
case: Hf => -[Hf1] [Hf2].
case: Hg => -[Hg1] [Hg2].
by f_equal; f_equal; exact/proof_irr.
Qed.

End algebraic_operation_interface.

(* TODO:
Lemma monad_of_ret_bind_ext (F G : functor) (RET1 : FId ~> F) (RET2 : FId ~> G)
  (bind1 : forall A B : UU0, F A -> (A -> F B) -> F B)
  (bind2 : forall A B : UU0, G A -> (A -> G B) -> G B) :
  forall (FG : F = G),
  RET1 = eq_rect _ (fun m : functor => FId ~> m) RET2 _ ((*beuh*) (esym FG)) ->
  bind1 = eq_rect _ (fun m : functor => forall A B : UU0, m A -> (A -> m B) -> m B) bind2 _ (esym FG) ->
  forall H1 K1 H2 K2 H3 K3,
  Monad_of_ret_bind F RET1 bind1 H1 H2 H3 =
  Monad_of_ret_bind G RET2 bind2 K1 K2 K3.
Proof.
move=> FG; subst G; move=> HRET; subst RET1; move=> HBIND; subst bind1 => H1 K1 H2 K2 H3 K3.
rewrite /Monad_of_ret_bind; congr Monad.Pack; simpl in *.
have <- : H1 = K1 by exact/proof_irr.
have <- : H2 = K2 by exact/proof_irr.
have <- : H3 = K3 by exact/proof_irr.
by [].
Qed. *)

(*
(* monads on Type are strong monads *)
Section strength.
Variable M : monad.
Definition strength A B (xy : (A * M B)%type) : M (A * B)%type :=
  let (x,my) := xy in my >>= (fun y => Ret (x,y)).
Lemma strengthE A B (x:A) (my:M B) : strength (x,my) = my >>= (fun y => Ret (x,y)).
Proof. done. Qed.
Lemma strength_unit A : snd = M # snd \o strength (A:=unit) (B:=A).
Proof.
apply functional_extensionality => x.
case: x => i ma.
rewrite compE strengthE.
rewrite -fmapE fmap_bind fcomp_def.
rewrite bindE.
have ->: Join ((M # (M # snd \o (fun y : A => Ret (i, y)))) ma) =
((M # snd \o Join) \o M # (fun y : A => Ret (i, y))) ma
  by rewrite functor_o join_naturality.
rewrite functor_o.
have ->: ((M # snd \o Join) \o (M # Ret \o M # pair i)) ma =
(M # snd \o (Join \o M # Ret) \o M # pair i) ma by done.
rewrite joinMret compfid.
rewrite -functor_o.
have ->: snd \o pair i = id by done.
by rewrite functor_id.
Qed.
End strength.
*)

Definition mpair {M : monad} {A} (xy : (M A * M A)%type) : M (A * A)%type :=
  let (mx, my) := xy in
  mx >>= (fun x => my >>= fun y => Ret (x, y)).

Lemma mpairE (M : monad) A (mx my : M A) :
  mpair (mx, my) = mx >>= (fun x => my >>= fun y => Ret (x, y)).
Proof. by []. Qed.

Lemma naturality_mpair (M : monad) (A B : UU0) (f : A -> B) (g : A -> M A):
  (M # f^`2) \o (mpair \o g^`2) = mpair \o ((M # f) \o g)^`2.
Proof.
rewrite boolp.funeqE => -[a0 a1].
rewrite compE fmap_bind.
rewrite compE mpairE compE bind_fmap; bind_ext => a2.
rewrite fcompE fmap_bind 2!compE bind_fmap; bind_ext => a3.
by rewrite fcompE -(compE (M # f^`2)) (natural ret) FIdE.
Qed.

Definition commute {M : monad} A B (m : M A) (n : M B) C (f : A -> B -> M C) : Prop :=
  m >>= (fun x => n >>= (fun y => f x y)) = n >>= (fun y => m >>= (fun x => f x y)) :> M _.

Definition preserves {M : monad} (A B : UU0) (f : A -> M A) (g : A -> B) :=
  forall x, (f x >>= fun y => Ret (y, g y)) = (f x >>= fun y => Ret (y, g x)).

(*Local Notation "[ \o f , .. , g , h ]" := (f \o .. (g \o h) ..)
  (at level 0) (*, format "[ \o '['  f , '/' .. , '/' g , '/' h ']' ]"
  ).*) : test_scope.

Local Open Scope test_scope.

Lemma naturality_mpair' (M : monad) A B (f : A -> B) (g : A -> M A):
  (M # f^`2) \o (mpair \o g^`2) = mpair \o ((M # f) \o g)^`2.
Proof.
rewrite funeqE => -[a0 a1].
change ((M # f^`2 \o (mpair \o g^`2)) (a0, a1)) with
    ((M # f^`2) (mpair (g a0, g a1))).
change ((mpair \o (M # f \o g)^`2) (a0, a1)) with
    (mpair ((M # f \o g) a0,(M # f \o g) a1)).
rewrite !mpairE.
rewrite !bindE.
evar (T : Type);evar (RHS : A -> T).
have ->: (fun x : A => do y <- g a1; Ret (x, y)) = RHS.
  rewrite funeqE => x; rewrite bindE.
  rewrite functor_o.
  change (Join ([\o M # Ret,M # pair x] (g a1))) with
        ([\o Join,M # Ret,M # pair x] (g a1)).
    rewrite joinMret'.
  exact: erefl.
rewrite /RHS {RHS}; rewrite {T}.
change ((M # f^`2) (Join ((M # (fun x : A => (M # pair x) (g a1))) (g a0)))) with
    ((M # f^`2 \o Join) ((M # (fun x : A => (M # pair x) (g a1))) (g a0))).
rewrite join_naturality.
evar (T : Type);evar (RHS : T).
have->:(M # (fun x : B => do y <- (M # f \o g) a1; Ret (x, y))) = RHS.
- rewrite functor_o.
  rewrite bindE'.
  rewrite functor_o.
  exact: erefl.
rewrite/RHS{RHS};rewrite{T}.
change
  (
    Join
    (((M # Join \o M # (Fun M (B:=M (B * B)%type))^~ ((M # f \o g) a1)) \o
        M # (fun x y : B => Ret (x, y))) ((M # f \o g) a0))
  ) with
    (
      (
        [ \o Join ,
          (M # Join) ,
          (M # (Fun M (B:=M (B * B)%type))^~ ((M # f \o g) a1)) ,
          (M # (fun x y : B => Ret (x, y))) ,
          (M # f \o g) ]
      ) a0)
    .
rewrite joinA'.
(*
rewrite fmap_bind. compE [in RHS]/= bind_fmap; bind_ext => a2.
rewrite fcompE fmap_bind compE bind_fmap; bind_ext => a3.
by rewrite fcompE -(compE (fmap M # f^`2)) fmap_ret.
Qed.
*)
Abort.

Local Close Scope test_scope.
*)

Section rep.
Context {M : monad}.

Fixpoint rep n (mx : M unit) := if n is n.+1 then mx >> rep n mx else skip.

Lemma repS mx n : rep n.+1 mx = rep n mx >> mx.
Proof.
elim: n => /= [|n IH]; first by rewrite bindmskip bindskipf.
by rewrite bindA IH.
Qed.

Lemma rep1 mx : rep 1 mx = mx. Proof. by rewrite repS bindskipf. Qed.

Lemma rep_addn m n mx : rep (m + n) mx = rep m mx >> rep n mx.
Proof.
elim: m n => [|m IH /=] n; by
  [rewrite bindskipf add0n | rewrite -addnE IH bindA].
Qed.

End rep.

(* example from Gibbons and Hinze, ICFP 2011 *)
Section MonadCount.

Variable M : monad.
Variable tick : M unit.

Fixpoint hanoi n : M unit :=
  if n is n.+1 then hanoi n >> tick >> hanoi n else skip.

Lemma hanoi_rep n : hanoi n = rep (2 ^ n).-1 tick.
Proof.
elim: n => // n IH /=.
rewrite IH -repS prednK ?expn_gt0 // -rep_addn.
by rewrite -subn1 addnBA ?expn_gt0 // addnn -muln2 -expnSr subn1.
Qed.

End MonadCount.


(*Library for heterogeneous lists*)
Inductive Het : Type :=
|HetConstr : forall A, A -> Het.

Inductive hlist : Type :=
| HNil : hlist
| HCons : forall {A},  A -> hlist -> hlist.

Notation "{{ x ; .. ; y }}" := (HCons x .. (HCons y HNil) ..) : hetlist_scope.
Open Scope hetlist_scope.

(*Hack for generalize dependent of multiple parameters*)
Ltac genDeps xs :=
  match xs with
    |HCons ?x ?xs => generalize dependent x; genDeps xs
    |HNil => idtac
  end.


(** * QuickChickInterface: QuickChick Reference Manual *)

From QuickChick Require Import QuickChick.
Require Import ZArith Strings.Ascii Strings.String.

From ExtLib.Structures Require Import Functor Applicative.

(** QuickChick provides a large collection of combinators and
    notations for writing property-based random tests.  This file
    documents the entire public interface (the module type
    [QuickChickSig]). *)

Set Warnings "-already-existing-class, -automation".
Module Type QuickChickSig.

(* #################################################################### *)
(** * The [Show] Typeclass *)

(** [Show] typeclass allows the test case to be printed as a string. *)
(** [[
    Class Show (A : Type) : Type :=
      {
        show : A -> string
      }.
]]
*)

(** Here are some [Show] instances for some basic types: *)
#[global]
Declare Instance showNat    : Show nat.
#[global]
Declare Instance showBool   : Show bool.
#[global]
Declare Instance showZ      : Show Z.
#[global]
Declare Instance showString : Show string.

#[global]
Declare Instance showList :
  forall {A : Type} `{Show A}, Show (list A).
#[global]
Declare Instance showPair :
  forall {A B : Type} `{Show A} `{Show B}, Show (A * B).
#[global]
Declare Instance showOpt :
  forall {A : Type} `{Show A}, Show (option A).
#[global]
Declare Instance showEx :
  forall {A} `{Show A} P, Show ({x : A | P x}).

(** When defining [Show] instance for your own datatypes, you sometimes need to
    start a new line for better printing. [nl] is a shorthand for it. *)
Definition nl : string := String (ascii_of_nat 10) EmptyString.

(* #################################################################### *)
(** * Generators *)

(* #################################################################### *)
(** ** Fundamental Types *)

(** A [RandomSeed] represents a particular starting point in a
    pseudo-random sequence. *)
Parameter RandomSeed : Type.

(** [G A] is the type of random generators for type [A]. *)
Parameter G : Type -> Type.

(** Run a generator with a size parameter (a natural number denoting
    the maximum depth of the generated A) and a random seed. *)
Parameter run  : forall {A : Type}, G A -> nat -> RandomSeed -> A.

(* #################################################################### *)
(** ** Structural Combinators *)

(** Generators are also instances of several generic typeclasses.
    Many handy generator combinators can be found in the [Monad],
    [Functor], [Applicative], [Foldable], and [Traversable] modules in
    the [ExtLib.Structures] library from [coq-ext-lib]. *)

#[global]
Declare Instance Monad_G : Monad G.
#[global]
Declare Instance Functor_G : Functor G.
#[global]
Declare Instance Applicative_G : Applicative G.

(** A variant of bind for the [(G (option --))] monad.  Useful for
    chaining generators that can fail / backtrack. *)
Parameter bindGenOpt : forall {A B : Type},
    G (option A) -> (A -> G (option B)) -> G (option B).

(* #################################################################### *)
(** ** Basic Generator Combinators *)

(** The [listOf] and [vectorOf] combinators construct generators for
    [list A], provided a generator [g] for type [A]: [listOf g] yields
    an arbitrary-sized list (which might be empty), while [vectorOf n
    g] yields a list of fixed size [n]. *)
Parameter listOf : forall {A : Type}, G A -> G (list A).
Parameter vectorOf : forall {A : Type}, nat -> G A -> G (list A).

(** [elems_ a l] constructs a generator from a list [l] and a
    default element [a]. If [l] is non-empty, the generator picks an
    element from [l] uniformly; otherwise it always yields [a]. *)
Parameter elems_ : forall {A : Type}, A -> list A -> G A.

(** Similar to [elems_], instead of choosing from a list of [A]s,
    [oneOf_ g l] returns [g] if [l] is empty; otherwise it uniformly
    picks a generator for [A] in [l]. *)
Parameter oneOf_ : forall {A : Type}, G A -> list (G A) -> G A.

(** We can also choose generators with distributions other than the
    uniform one. [freq_ g l] returns [g] if [l] is empty;
    otherwise it chooses a generator from [l], where the first field
    indicates the chance that the second field is chosen. For example,
    [freq_ z [(2, x); (3, y)]] has 40%% probability of choosing
    [x] and 60%% probability of choosing [y]. *)
Parameter freq_ :
  forall {A : Type}, G A -> list (nat * G A) -> G A.

(** Try all generators until one returns a [Some] value or all failed once with
    [None]. The generators are picked at random according to their weights
    (like [frequency]), and each one is run at most once. *)
Parameter backtrack :
  forall {A : Type}, list (nat * G (option A)) -> G (option A).

(** Internally, the G monad hides a [size] parameter that can be accessed by
    generators. The [sized] combinator provides such access. The [resize]
    combinator sets it. *)
Parameter sized : forall {A: Type}, (nat -> G A) -> G A.
Parameter resize : forall {A: Type}, nat -> G A -> G A.

(** Generate-and-test approach to generate data with preconditions. *)
Parameter suchThatMaybe :
  forall {A : Type}, G A -> (A -> bool) -> G (option A).
Parameter suchThatMaybeOpt :
  forall {A : Type}, G (option A) -> (A -> bool) -> G (option A).

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

(** The [elems_], [oneOf_], and [freq_] combinators all take
    default values; these are only used if their list arguments are
    empty, which should not normally happen. The [QcDefaultNotation]
    sub-module exposes notation (without the underscores) to hide this default.
*)

Module QcDefaultNotation.

  (** [elems] is a shorthand for [elems_] without a default argument. *)
  Notation " 'elems' [ x ] " :=
    (elems_ x (cons x nil)) : qc_scope.
  Notation " 'elems' [ x ; y ] " :=
    (elems_ x (cons x (cons y nil))) : qc_scope.
  Notation " 'elems' [ x ; y ; .. ; z ] " :=
    (elems_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'elems' ( x ;; l ) " :=
    (elems_ x (cons x l)) (at level 1, no associativity) : qc_scope.

  (** [oneOf] is a shorthand for [oneOf_] without a default argument. *)
  Notation " 'oneOf' [ x ] " :=
    (oneOf_ x (cons x nil)) : qc_scope.
  Notation " 'oneOf' [ x ; y ] " :=
    (oneOf_ x (cons x (cons y nil))) : qc_scope.
  Notation " 'oneOf' [ x ; y ; .. ; z ] " :=
    (oneOf_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'oneOf' ( x ;; l ) " :=
    (oneOf_ x (cons x l))  (at level 1, no associativity) : qc_scope.

  (** [freq] is a shorthand for [freq_] without a default argument. *)
  Notation " 'freq' [ x ] " :=
    (freq_ x (cons x nil)) : qc_scope.
  Notation " 'freq' [ ( n , x ) ; y ] " :=
    (freq_ x (cons (n, x) (cons y nil))) : qc_scope.
  Notation " 'freq' [ ( n , x ) ; y ; .. ; z ] " :=
    (freq_ x (cons (n, x) (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'freq' ( ( n , x ) ;; l ) " :=
    (freq_ x (cons (n, x) l)) (at level 1, no associativity) : qc_scope.

End QcDefaultNotation.

(** The original version of QuickChick used [elements], [oneof] and [frequency]
    as the default-argument versions of the corresponding combinators.
    These have since been deprecated in favor of a more consistent
    naming scheme.
*)

(* #################################################################### *)
(** ** Choosing from Intervals *)

(** The combinators above allow us to generate elements by enumeration
    and lifting. However, for numeric data types, we sometimes hope to
    choose from an interval without writing down all the possible
    values.

    Such intervals can be defined on ordered data types, instances of
    [OrdType], whose ordering [leq] satisfies reflexive, transitive,
    and antisymmetric predicates. *)

Existing Class OrdType.

#[global]
Declare Instance OrdBool : OrdType bool.
#[global]
Declare Instance OrdNat  : OrdType nat.
#[global]
Declare Instance OrdZ    : OrdType Z.

(** We also expect the random function to be able to pick every element in any
    given interval. *)

Existing Class ChoosableFromInterval.

(** QuickChick has provided some instances for ordered data types that are
    choosable from intervals, including [bool], [nat], and [Z]. *)

(*
#[global]
Declare Instance ChooseBool : ChoosableFromInterval bool.
*)
#[global]
Declare Instance ChooseNat : ChoosableFromInterval nat.
#[global]
Declare Instance ChooseZ : ChoosableFromInterval Z.

(** [choose l r] generates a value between [l] and [r], inclusive the two
    extremes. It causes a runtime error if [r < l]. *)
Parameter choose :
  forall {A : Type} `{ChoosableFromInterval A}, (A * A) -> G A.

(* #################################################################### *)
(** ** The [Gen] and [GenSized] Typeclasses *)

(** [GenSized] and [Gen] are typeclasses whose instances can be generated
    randomly. More specifically, [GenSized] depends on a generator for any given
    natural number that indicate the size of output. *)
(** [[
    Class GenSized (A : Type) := { arbitrarySized : nat -> G A }.
    Class Gen (A : Type) := { arbitrary : G A }.
]]
*)

(** Given an instance of [GenSized], we can convert it to [Gen] automatically,
    using [sized] function. *)
#[global]
Declare Instance GenOfGenSized {A} `{GenSized A} : Gen A.

(** Here are some basic instances for generators: *)
#[global]
Declare Instance genBoolSized : GenSized bool.
#[global]
Declare Instance genNatSized  : GenSized nat.
#[global]
Declare Instance genZSized    : GenSized Z.

#[global]
Declare Instance genListSized :
  forall {A : Type} `{GenSized A}, GenSized (list A).
#[global]
Declare Instance genList :
  forall {A : Type} `{Gen A}, Gen (list A).
#[global]
Declare Instance genOption :
  forall {A : Type} `{Gen A}, Gen (option A).
#[global]
Declare Instance genPairSized :
  forall {A B : Type} `{GenSized A} `{GenSized B}, GenSized (A*B).
#[global]
Declare Instance genPair :
  forall {A B : Type} `{Gen A} `{Gen B}, Gen (A * B).

(* #################################################################### *)
(** ** Generators for Data Satisfying Inductive Predicates *)

(** Just as QuickChick provides the [GenSized] and [Gen] typeclasses
    for generators of type [A], it provides constrained variants for
    generators of type [A] such that [P : A -> Prop] holds of all
    generated values.  Since it is not guaranteed that any such [A]
    exist, these generators are partial.  *)
(** [[
     Class GenSizedSuchThat (A : Type) (P : A -> Prop) :=
       {
         arbitrarySizeST : nat -> G (option A)
       }.

     Class GenSuchThat (A : Type) (P : A -> Prop) :=
       {
         arbitraryST : G (option A)
       }.
]]
 *)

(** So, for example, if you have a typing relation
    [has_type : exp -> type -> Prop] for some language, you could,
    given some type [T] as input, write (or derive as we will see later on)
    an instance of [GenSizedSuchThat (fun e => has_type e T)], that produces
    an expression of with type [T].

    Calling [arbitraryST] through such an instance would require
    making an explicit application to [@arbitraryST] as follows:
[[
    @arbitraryST _ (fun e => has_type e T) _
]]
    where the first placeholder is the type of expressions [exp]
    and the second placeholder is the actual instance to be inferred.

    To avoid this, QuickChick also provides convenient notation to call
    by providing only the predicate [P] that constraints the generation.
    The typeclass constraint is inferred. *)

Notation "'genSizedST' x" := ((@arbitrarySizeST _ x _)) (at level 10).
Notation "'genST' x" := ((@arbitraryST _ x _)) (at level 10).

(* #################################################################### *)
(** * Shrinking *)

(** ** The [Shrink] Typeclass *)

(** [Shrink] is a typeclass whose instances have an operation for
    shrinking larger elements to smaller ones, allowing QuickChick to
    search for a minimal counter example when errors occur. *)
(** [[
    Class Shrink (A : Type) :=
      {
        shrink : A -> list A
      }.
]]
*)

(** Default shrinkers for some basic datatypes: *)
#[global]
Declare Instance shrinkBool : Shrink bool.
#[global]
Declare Instance shrinkNat : Shrink nat.
#[global]
Declare Instance shrinkZ : Shrink Z.

#[global]
Declare Instance shrinkList {A : Type} `{Shrink A} : Shrink (list A).
#[global]
Declare Instance shrinkPair {A B} `{Shrink A} `{Shrink B} : Shrink (A * B).
#[global]
Declare Instance shrinkOption {A : Type} `{Shrink A} : Shrink (option A).

(* #################################################################### *)
(** ** The [Arbitrary] Typeclass *)

(** The [Arbitrary] typeclass combines generation and shrinking. *)
(** [[
    Class Arbitrary (A : Type) `{Gen A} `{Shrink A}.
]]
*)

(* #################################################################### *)
(** ** The Generator Typeclass Hierarchy *)

(** [[
                            GenSized
                               |
                               |
                              Gen   Shrink
                                \    /
                                 \  /
                               Arbitrary
]]
*)

(** If a type has a [Gen] and a [Shrink] instance, it automatically gets
    an [Arbitrary] one. *)
#[global]
Declare Instance ArbitraryOfGenShrink :
  forall {A} `{Gen A} `{Shrink A}, Arbitrary A.

(* #################################################################### *)
(** * Checkers *)

(** ** Basic Definitions *)

(** [Checker] is the opaque type of QuickChick properties. *)
Parameter Checker : Type.

(** The [Checkable] class indicates we can check a type A. *)
(** [[
    Class Checkable (A : Type) : Type :=
      {
        checker : A -> Checker
      }.
]]
*)

(** Boolean checkers always pass or always fail. *)
#[global]
Declare Instance testBool : Checkable bool.

(** The unit checker is always discarded (that is, it represents a
    useless test).  It is used, for example, in the implementation of
    the "implication [Checker]" combinator [==>]. *)
#[global]
Declare Instance testUnit : Checkable unit.

(** Given a generator for showable [A]s, construct a [Checker]. *)
Parameter forAll :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A)  (pf : A -> prop), Checker.

(** Given a generator and a shrinker for showable [A]s, construct a
    [Checker]. *)
Parameter forAllShrink :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A) (shrinker : A -> list A) (pf : A -> prop), Checker.

(** Lift ([Show], [Gen], [Shrink]) instances for [A]
    to a [Checker] for functions [A] -> prop.  This is what makes it
    possible to write (for some example property [foo := fun x => x >?
    0], say) [QuickChick foo] instead of [QuickChick (forAllShrink
    arbitrary shrink foo)]. *)
#[global]
Declare Instance testFun :
  forall {A prop : Type} `{Show A} `{Arbitrary A} `{Checkable prop},
    Checkable (A -> prop).

(** Lift products similarly. *)
#[global]
Declare Instance testProd :
  forall {A : Type} {prop : A -> Type} `{Show A} `{Arbitrary A}
         `{forall x : A, Checkable (prop x)},
    Checkable (forall (x : A), prop x).

(** Lift polymorphic functions by instantiating to 'nat'. :-) *)
#[global]
Declare Instance testPolyFun :
  forall {prop : Type -> Type} `{Checkable (prop nat)},
    Checkable (forall T, prop T).

(* #################################################################### *)
(** ** Checker Combinators *)

(** Print a specific string if the property fails. *)
Parameter whenFail :
  forall {prop : Type} `{Checkable prop} (str : string), prop -> Checker.

(** Record an expectation that a property should fail, i.e.
    the property will fail if all the tests succeed. *)
(* SOONER: Don't understand this explanation. A Checker, in my model
   of the world, maps a random seed to the outcome of a *single* test.
   This seems to suggest that an expectFailure checker somehow knows
   the value of the test on *all* random seeds... *)
(* SOONER: I think I need help with the phrasing here. What I mean is
   QuickChick will run its default number of tests (whether that is
   100 or 10000000 doesn't matter). If all of those 100 or 10000000
   tests succeed, then an [expectFailure property] is considered to
   fail because a failure was expected but not found.  Does this make
   sense?

   BCP: Sort of, but not really.  E.g., can I nest uses of
   expectFailure?  What happens then?  (How many tests get run?)  Or,
   what happens if I conjoin an expectFailure with some other
   checkers?  I guess I need a model for how it is
   implemented.  (Which I think we didn't give in QC.v, right?)*)
Parameter expectFailure :
  forall {prop: Type} `{Checkable prop} (p: prop), Checker.

(** Collect statistics across all tests. *)
Parameter collect :
  forall {A prop : Type} `{Show A} `{Checkable prop} (x : A),
    prop -> Checker.

(** Set the reason for failure.  Will only count shrinks as valid if
    they preserve the tag. *)
(* SOONER: Explain better. *)
Parameter tag :
  forall {prop : Type} `{Checkable prop} (t : string), prop -> Checker.

(** Form the conjunction / disjunction of a list of checkers. *)
(* SOONER: We are not very consistent about when we name arguments and
   when we do not.  E.g. [l] here: *)
(* SOONER: We name all non-implicit/Typeclass ones, no? *)
(* SOONER: whenFail does not.  Nor does, for example (of many) resize. *)
(* SOONER: What convention would you prefer to keep? Delete all names?
   Keep all non-implicit names? Something else? I can do a consistency
   pass after we fix everything. *)
(* SOONER: BCP: I think keeping is best. *)
Parameter conjoin : forall (l : list Checker), Checker.
Parameter disjoin : forall (l : list Checker), Checker.

(** Define a checker for a conditional property. Invalid generated
    inputs (ones for which the antecedent fails) are discarded. *)
Parameter implication :
  forall {prop : Type} `{Checkable prop} (b : bool) (p : prop), Checker.

(** Notation for implication. Clashes with many other notations in
    other libraries, so it lives in its own module. Note that this
    includes the notations for the generator combinators above
    to avoid needing to import two modules.
 *)
Module QcNotation.
  Export QcDefaultNotation.

  Notation "x ==> y" :=
    (implication x y) (at level 55, right associativity)
    : Checker_scope.
End QcNotation.

(* #################################################################### *)
(** * Decidability *)

(** ** The [Dec] Typeclass *)
(** Decidability typeclass using ssreflect's 'decidable'. *)
(** [[
     Class Dec (P : Prop) : Type := { dec : decidable P }.
]]
*)

(** Decidable properties are Checkable. *)
#[global]
Declare Instance testDec {P} `{H : Dec P} : Checkable P.

(** Logic Combinator instances. *)
#[global]
Declare Instance Dec_neg {P} {H : Dec P} : Dec (~ P).
#[global]
Declare Instance Dec_conj {P Q} {H : Dec P} {I : Dec Q} : Dec (P /\ Q).
#[global]
Declare Instance Dec_disj {P Q} {H : Dec P} {I : Dec Q} : Dec (P \/ Q).

(* SOONER: We had discussed changing this to the partial decision procedure at some point. *)
(** A convenient notation for coercing a decidable proposition to a [bool]. *)
Notation "P '?'" := (match (@dec P _) with
                     | left _ => true
                     | right _ => false
                     end) (at level 100).

(** ** The [Dec_Eq] Typeclass *)

(** [[
     Class Dec_Eq (A : Type) :=
       {
         dec_eq : forall (x y : A), decidable (x = y)
       }.
]]
*)

(** Automation and conversions for Dec. *)
#[global]
Declare Instance Dec_Eq_implies_DecEq {A} `{H : Dec_Eq A} (x y : A) : Dec (x = y).

(** Since deciding equalities is a very common requirement in testing,
    QuickChick provides a tactic that can define instances of the form
    [Dec_Eq].
*)
(** [[
     Ltac dec_eq.
]]
*)

(** QuickChick also lifts common decidable instances to the [Dec] typeclass. *)
#[global]
Declare Instance Dec_eq_unit   : Dec_Eq unit.
#[global]
Declare Instance Dec_eq_bool   : Dec_Eq bool.
#[global]
Declare Instance Dec_eq_nat    : Dec_Eq nat.
#[global]
Declare Instance Dec_eq_Z      : Dec_Eq Z.
#[global]
Declare Instance Dec_eq_N      : Dec_Eq N.
#[global]
Declare Instance Dec_eq_ascii  : Dec_Eq ascii.
#[global]
Declare Instance Dec_eq_string : Dec_Eq string.

#[global]
Declare Instance Dec_eq_opt  (A : Type)
        `{Dec_Eq A}             : Dec_Eq (option A).
#[global]
Declare Instance Dec_eq_prod (A B : Type)
        `{Dec_Eq A} `{Dec_Eq B} : Dec_Eq (A * B).
#[global]
Declare Instance Dec_eq_sum  (A B : Type)
        `{Dec_Eq A} `{Dec_Eq B} : Dec_Eq (A + B).
#[global]
Declare Instance Dec_eq_list (A : Type)
        `{Dec_Eq A}             : Dec_Eq (list A).

(* #################################################################### *)
(** * Automatic Instance Derivation *)

(** QuickChick allows the automatic derivation of typeclass instances
    for simple types:
[[
       Derive <class> for T.
]]
    Here [<class>] must be one of [GenSized], [Shrink], [Arbitrary],
    or [Show], and [T] must be an inductive defined datatype (think
    Haskell/OCaml).

    To derive multiple classes at once, write:
[[
       Derive (<class>,...,<class>) for T.
]]
*)

(** QuickChick also allows for the automatic derivation of generators
    satisfying preconditions in the form of inductive relations:

     Derive ArbitrarySizedSuchThat for (fun x => P x1 ... x .... xn).

    <P> must be an inductively defined relation.
    <x> is the function to be generated.
    <x1...xn> are (implicitly universally quantified) variable names.
*)

(** QuickChick also allows automatic derivations of proofs of
    correctness of its derived generators! For more, look
    at:

    - A paper on deriving QuickChick generators for a large class of
      inductive relations.
      {http://www.cis.upenn.edu/~llamp/pdf/GeneratingGoodGenerators.pdf}

    - Leo's PhD dissertation.
      {https://lemonidas.github.io/pdf/Leo-PhD-Thesis.pdf}

    - examples/DependentTest.v

*)

(* #################################################################### *)
(** * Top-level Commands and Settings *)

(** QuickChick provides a series of toplevel commands to sample
    generators, test properties, and derive useful typeclass
    instances. *)

(** The [Sample] command samples a generator. The argument [g] needs
    to have type [G A] for some showable type [A]. *)
(** [[
    Sample g.
]]
*)

(** The main testing command, [QuickChick], runs a test. The argument
    [prop] must belong to a type that is an instance of [Checkable]. *)
(** [[
     QuickChick prop.
]]
*)

(** QuickChick uses arguments to customize execution. *)
Record Args :=
  MkArgs
    {
      (* Re-execute a test. *)
      (* Default: None *)
      replay     : option (RandomSeed * nat);
      (* Maximum number of successful tests to run. *)
      (* Default: 10000 *)
      maxSuccess : nat;
      (* Maximum number of discards to accept. *)
      (* Default: 20000 *)
      maxDiscard : nat;
      (* Maximum number of shrinks to perform before terminating. *)
      (* Default : 1000 *)
      maxShrinks : nat;
      (* Maximum size of terms to generate (depth). *)
      (* Default : 7 *)
      maxSize    : nat;
      (* Verbosity. Note: Doesn't do much... *)
      (* Default true. *)
      chatty     : bool
    }.

(** Instead of record updates, you should overwrite extraction constants. *)
(** [[
   Extract Constant defNumTests    => "10000".
   Extract Constant defNumDiscards => "(2 * defNumTests)".
   Extract Constant defNumShrinks  => "1000".
   Extract Constant defSize        => "7".
]]
*)

(* Semantics of Generators *)

(* To reason about generators, we need to import the Proofs module
from QuickChick. *)
Set Warnings "-notation-overwritten, -parsing".
Set Warnings "-require-in-module, -fragile]".

From QuickChick Require Import Proofs.
Local Open Scope set_scope.

(** The semantics of a generator is its set of possible outcomes. *)
Parameter semGen : forall {A : Type} (g : G A), set A.
Parameter semGenSize : forall {A : Type} (g : G A) (size : nat), set A.
(* SOONER: Where does [set] come from?? Where can I read about what
   operations / theorems are available? *)
(* SOONER: [set] comes from src/Sets.v. I think Maxime/Zoe wrote most
   of that file quite a while ago (during her thesis at Catalin). It
   is not really documented... would you want all of that file
   here? *)
(* SOONER: I want this file to be a complete description of what most
   people need to know to use QC.  One possible approach could be to
   split this interface into a "programming interface" for most users
   and a "proving interface" for people that also want to do proofs
   involving the QC semantics.  Then the functions from Sets.v would
   be relevant only to the second.  (I actually kind of like this
   idea, as it would streamline what most people need to think
   about.) *)
(* SOONER: It *is* a complete description of what _the vast majority_ people need
   to know to use QC. There are exactly three uses of the set library:
   1) Allow derivation of correctness proofs. Here, the user doesn't
      need to know all the lemmas that the proof uses in order to enjoy
      the benefits of an end-to-end specification (but the lemmas
      need to be exposed).
   2) Allow manual correctness proofs. I don't think anyone has ever
      done that outside of ourselves to practice before writing the
      generic derivation of proofs. Writing correctness proofs for
      generators is hard and not really worth it from the user's
      perspective.
   3) The only potential use of the set library from a user would
      be in forAllProof variants to define dependently typed data. However,
      this intrinsic verification approach is very rarely used and
      comes with more severe testing problems than an undocumented
      set library.

   My thinking was to have [semGen] and [forAllProof] here as a small
   glance into the world of generator semantics. I do think that
   presenting the view that a generator is characterized by its set of
   outcomes is a very useful notion, even if a user never has to
   actively play with that notion. Do you want to just remove every
   mention to [set]/[semGen] from this file to keep it a "programming
   only" interface?

   Besides, what would the "proving interface" entail?
   We can't really document the entirety of the sets library. That's like
   200 low-level lemmas that are only expanded to facilitate proof
   derivation... For example, we have lemmas like the following:

[[
Lemma isSome_subset {A : Type} (s1 s2 s1' s2' : set (option A)) :
  isSome :&: s1 \subset isSome :&: s2 ->
  isSome :&: (s1 :|: ([set None] :&: s1')) \subset isSome :&: (s2 :|: ([set None] :&: s2')).
]]

   This says that if the set of all "Some"s in s1 is a subset of all the
   "Some"s in s2, then the set of all "Some"s in the the union of s1 with
   [the intersection of {None} and s1'] is a subset of the set of all somes in
   the union of s2 with [the intersection of {None} and s2']. Of course, the intersection of
   {None} with any set is at most {None}, and that none will be filtered
   out by [isSome], so this looks like a completely useless lemma. However,
   we do need this lemma because of the particular structure of the
   proofs involving the backtrack combinator. How can we explain this
   lemma and its point to a user if we turn this file into a complete
   documentation of everything that needs to be exposed?

 *)

(** A variant of monadic bind where the continuation also takes a
    _proof_ that the value received is within the set of outcomes of
    the first generator. *)
Parameter bindGen' : forall {A B : Type} (g : G A),
    (forall (a : A), (a \in semGen g) -> G B) -> G B.

(** A variant of [forAll] that provides evidence that the generated
    values are members of the semantics of the generator. (Such evidence
    can be useful when constructing dependently typed data, such as
    bounded integers.) *)
Parameter forAllProof :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A)  (pf : forall (x : A), semGen gen x -> prop), Checker.

(* #################################################################### *)
(** * The [quickChick] Command-Line Tool *)

(** QuickChick comes with a command-line tool that supports:
      - Batch processing, compilation and execution of tests
      - Mutation testing
      - Sectioning of tests and mutants

    Comments that begin with an exclamation mark are special to the
    QuickChick command-line tool parser and signify a test, a section,
    or a mutant. *)

(** ** Test Annotations *)

(** A test annotation is just a [QuickChick] command wrapped inside
    a comment with an exclamation mark.
[[
    (*! QuickChick prop. *)
]]
   Only tests that are annotated this way will be processed. Only property
   names are allowed. *)

(** ** Mutant Annotations *)

(** A mutant annotation consists of 4 components. First an anottation
    that signifies the beginning of the mutant [(*! *)]. That is followed
    by the actual code. Then, we can include an optional annotation
    (in a comment with double exclamation marks) that corresponds to
    the mutant names. Finally, we can add a list of mutations inside
    normal annotated comments. Each mutant should be able to be
    syntactically substituted in for the normal code.

[[
    (*! *)
    Normal code
    (*!! mutant-name *)
    (*! mutant 1 *)
    (*! mutant 2 *)
    ... etc ...
]]
*)

(** ** Section Annotations *)

(** To organize larger developments better, we can group together
    different tests and mutants in sections. A section annotation is
    a single annotation that defines the beginning of the section
    (which lasts until the next section or the end of the file).
[[
      (*! Section section-name *)
]]
    Optionally, one can include an extends clause
[[
      (*! Section section-name *)(*! extends other-section-name *)
]]
   This signifies that the section being defined also
   contains all tests and mutants from [other-section-name].
*)

(** ** Command-Line Tool Flags *)

(** The QuickChick command line tool can be passed the following options:
    - [-s <section>]: Specify which sections properties and mutants to test
    - [-v]: Verbose mode for debugging
    - [-failfast]: Stop as soon as a problem is detected
    - [-color]: Use colors on an ANSI-compatible terminal
    - [-cmd <command>]: What compile command is used to compile the current directory
      if it is not [make]
    - [-top <name>]: Specify the name of the top-level logical module. That should
      be the same as the [-Q] or [-R] directive in [_CoqProject] or [Top]
      which is the default
    - [-ocamlbuild <args>]: Any arguments necessary to pass to ocamlbuild when
      compiling the extracted code (e.g. linked libraries)
    - [-nobase]: Pass this option to not test the base mutant
    - [-m <number>]: Pass this to only test a mutant with a specific id number
    - [-tag <name>]: Pass this to only test a mutant with a specific tag
    - [-include <name>]: Specify a to include in the compilation
    - [-exclude <names>]: Specify files to be excluded from compilation. Must be the last argument passed.
*)

(* #################################################################### *)
(** * Deprecated Features *)

(** The following features are retained for backward compatibility,
    but their use is deprecated. *)

(** Use the monad notations from [coq-ext-lib] instead of the
    [QcDoNotation] sub-module: *)
Module QcDoNotation.
  Notation "'do!' X <- A ; B" :=
    (bindGen A (fun X => B))
    (at level 200, X name, A at level 100, B at level 200).
  Notation "'do\'' X <- A ; B" :=
    (bindGen' A (fun X H => B))
    (at level 200, X name, A at level 100, B at level 200).
  Notation "'doM!' X <- A ; B" :=
    (bindGenOpt A (fun X => B))
    (at level 200, X name, A at level 100, B at level 200).
End QcDoNotation.

End QuickChickSig.


Require Import mathcomp.ssreflect.all_ssreflect.
Require Import mathcomp.finmap.set.

Generalizable All Variables.
Set Implicit Arguments.
Unset Strict Implicit.

Import Prenex Implicits.

Require Import Setoid.

(** Utility for testing multiple conditions **)
Fixpoint mif_args (n : nat) (A : Type) : Type :=
  match n with
  | 0 => A -> A
  | n.+1 => bool * A -> mif_args n A
  end.

Fixpoint mif_return A (n : nat) (a : A) : mif_args n A :=
  match n with
  | 0 => fun _ => a
  | n.+1 => fun _ => mif_return n a
  end.

Fixpoint mif A (n : nat) : mif_args n A :=
  match n return mif_args n A with
  | 0 => fun x => x
  | n.+1 => fun c1 =>
              let: (b, a) := c1 in
              if b then mif_return n a
              else mif A n
  end.

Definition mif3 {A} := @mif A 3.

Definition lbl (A : nat -> Type) : Type := {n & A n}.

Definition zero (A : Type) :=
  fun n =>
    match n with
    | 0 => A
    | _ => False
    end.

Definition unpack A (x : lbl (zero A)) : A :=
  match x with
  | existT 0 a => a
  | existT n.+1 F => match F with end
  end.

Definition Sum (A B : Type) :=
  lbl (fun n =>
         match n with
         | 0 => A
         | 1 => B
         | _ => False
         end).

Definition from_sum {A B} (x : A + B) : Sum A B
    := match x with
       | inl y => existT _ 0 y
       | inr y => existT _ 1 y
       end.

Definition to_sum {A B} (x : Sum A B) : A + B
  := match x with
     | existT 0 y => inl y
     | existT 1 y => inr y
     | existT n.+2 y => match y with end
     end.

Lemma Sum_sum_iso A B (x : A + B) (y : Sum A B)
  : y = from_sum x <-> to_sum y = x.
Proof. by split=>[->|<-]; [case: x|case: y=>[[|[]]]]. Qed.

Corollary Sum_sum_iso_l A B (x : A + B) : to_sum (from_sum x) = x.
Proof. by apply/Sum_sum_iso. Qed.

Corollary Sum_sum_iso_r A B (x : Sum A B) : from_sum (to_sum x) = x.
Proof. by symmetry; apply/Sum_sum_iso. Qed.

(** Coinductive interaction trees (copy of simplification) **)
CoInductive itree (E : Type -> Type) (R : Type) : Type :=
| Ret (r : R)
| Tau (t : itree E R)
| Vis {A} (e : E A) (l : A -> itree E R).

Arguments Ret [E R] _.
Arguments Tau [E R] _.
Arguments Vis [E R A] _ _.

Definition peek_itree E R (t : itree E R) :=
  match t with
  | Ret x => Ret x
  | Tau t => Tau t
  | Vis _ e k => Vis e k
  end.

Lemma unfold_itree E R (t : itree E R) : peek_itree t = t.
Proof. by case: t. Qed.

Inductive Ev (E : Type -> Type) : Type -> Type :=
| Ev_some {A} (e : E A) : Ev E unit
| Ev_none {A} (e : E A) (f : A -> False) : Ev E False.

Definition itrace E A := itree (Ev E) A.

Module MPST.
  Context (P : eqType).

  Inductive GActs : seq Type -> Type :=
  | GEnd : GActs [::]
  | GMsg (p q : P) A B (G : GActs B) : GActs (A :: B).

  Inductive OneOf (T : seq Type) : Type := | Sel.

  Inductive GProtocol : Type -> Type :=
  | GNext T (a : GActs T) : GProtocol (OneOf T).

  (* Inductive LProtocol : Type -> Type := *)
  (* | LSend (p : P) (A : nat -> Type) : LProtocol nat *)
  (* | LRecv (p : P) (A : nat -> Type) : LProtocol nat. *)

  Inductive LProtocol : Type -> Type :=
  | LSend (p : P) (A : Type) : LProtocol A
  | LRecv (p : P) (A : Type) : LProtocol A.

  Inductive Comm : Type -> Type :=
  | Send (p : P) A (a : A) : Comm unit
  | Recv (p : P) A : Comm A.

  Definition typeOf A (c : Comm A) : Type :=
    match c with
    | @Send _ A _ => A
    | @Recv _ A => A
    end.

  Definition erase A (c : Comm A) : LProtocol (typeOf c) :=
    match c with
    | @Send p A _ => LSend p A
    | @Recv p A => LRecv p A
    end.

  (** Hint, this is "simulation?", just as with traces? *)
  CoInductive OfLt A : itree Comm A -> itree LProtocol A -> Prop :=
  | LT_Ret  x   : OfLt (Ret x) (Ret x)
  | LT_TauL a b : OfLt a b -> OfLt (Tau a) b
  | LT_TauR a b : OfLt a b -> OfLt a (Tau b)
  | LT_Send S a b p (x : S) :
      OfLt (a tt) (b x) -> OfLt (Vis (Send p x) a) (Vis (LSend p S) b)
  | LT_Recv S a b p :
      (forall x, OfLt (a x) (b x)) -> OfLt (Vis (Recv p S) a) (Vis (LRecv p S) b)
  .

  (** Examples **)
  Variable (p q : P).

  Inductive NatOrBool := | Nat (n : nat) | Bool (b : bool).

  Definition example1 :=
    Vis (Recv p nat)
        (fun k =>
           if k == 3 then
             Vis (Send p (Nat 1)) (fun _ => Ret true)
           else
             Vis (Send p (Bool true)) (fun _ => Ret false)
        ).

  (* L = p?nat . p ! { Nat. end ; Bool. end } *)

  Definition lt1 :=
    Vis (LRecv p nat) (fun _ => Vis (LSend p NatOrBool) (fun x =>
                                                           match x with
                                                           | Nat _ => Ret true
                                                           | Bool _ => Ret false
                                                           end)).

  Goal OfLt example1 lt1.
    constructor=>[]x; case: ifP; constructor; constructor.
  Qed.

  (** Problem: Unclear how to produce "well-typed terms" by construction, without
      such proofs *)

End MPST.

Module Attempt2.
Section ConstrainedITrees.

  Set Primitive Projections.

  Inductive ITreeType  : Type :=
  | vis (A : Type)
  | tau
  | ret.

  Definition continuation (ev : ITreeType) :=
    match ev with
    | vis A => A
    | tau => unit
    | ret => False
    end.

  Definition itreeEvent (E : Type -> Type) (R : Type) (it : ITreeType) :=
    match it with
    | vis A => E A
    | tau => unit
    | ret => R
    end.

  Set Primitive Projections.
  CoInductive ctree (E : Type -> Type) (R : Type) : Type :=
    { ctype : ITreeType;
      event : itreeEvent E R ctype;
      continue : continuation ctype -> ctree E R
    }.
  Unset Primitive Projections.
  Arguments continue [E R] _.

  (* All events are internal *)
  CoFixpoint cspin E R : ctree E R :=
    {| ctype := tau;
       event := tt;
       continue := fun _ => cspin E R
    |}.

  Definition skip E R (t : ctree E R) : ctree E R :=
    {| ctype := tau;
       event := tt;
       continue := fun _ => t
    |}.

  Definition pure E R (r : R) : ctree E R :=
    {| ctype := ret;
       event := r;
       continue := fun f => match f with end
    |}.
  Arguments pure {E} [R] r.

  Definition cast_event E R R' A (x : itreeEvent E R (vis A))
    : itreeEvent E R' (vis A) := x.
  Arguments cast_event [E R R' A] _.

  Definition bind E R R' (m : ctree E R) (f : R -> ctree E R') : ctree E R' :=
    (cofix bind_f (m : ctree E R) :=
      match ctype m as Ty
            return itreeEvent E R Ty -> (continuation Ty -> ctree E R) -> ctree E R'
      with
      | ret => fun ev _ => f ev
      | tau => fun ev k => {| ctype := tau;
                              event := tt;
                              continue := fun _ => bind_f (k tt)
                           |}
      | vis A => fun ev k => {| ctype := vis A;
                                event := cast_event ev;
                                continue := fun x => bind_f (k x)
                             |}
      end (event m) (continue m)) m.
  Arguments bind [E R R'] _ _.

  Context (P : Type) (p : P).
  Inductive LProtocol : Type -> Type :=
  | LSend (p : P) (A : Type) : LProtocol A
  | LRecv (p : P) (A : Type) : LProtocol A.

  Definition l_send (p : P) A : ctree LProtocol A :=
    {| ctype := vis A;
       event := LSend p A;
       continue := fun k => pure k
    |}.
  Definition l_recv (p : P) A : ctree LProtocol A :=
    {| ctype := vis A;
       event := LRecv p A;
       continue := fun k => pure k
    |}.
  Notation "A >>= F" := (bind A F) (at level 42, left associativity).
  Notation "'do' X <- A ; B" := (bind A (fun X => B)) (at level 200, X ident, A at level 100, B at level 200).

  Inductive NatOrBool := | End (n : nat) | Continue (b : bool).

  Definition rec {E R} (t : ctree E R) :=
    {| ctype := tau;
       event := tt;
       continue := fun _ => t
    |}.

  (** This "naive" way of writing recursion does not work *)
  CoFixpoint example1 : ctree LProtocol unit :=
    do _ <- l_recv p nat;
    do c <- l_send p NatOrBool;
       match c with
       | End _ => do _ <- l_send p bool; pure tt
       | Continue _ => rec example1
       end.

End ConstrainedITrees.


(* M. Dummett. A propositional calculus with denumerable matrix. J. Symbolic Logic, 24(2):97–106, 1959. *)
(* K. G¨odel. On the intuitionistic propositional calculus. In S. Feferman, J. W. D. Jr, S. C. Kleene, G. H. Moore, R. M. Solovay, and J. van Heijenoort, editors, Collected Works, volume 1. Oxford University Press, 1986. *)

Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.ExtensionTactic.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Class GodelDummettPropositionalLogic (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} (Gamma: Provable L) {minAX: MinimumAxiomatization L Gamma} {ipAX: IntuitionisticPropositionalLogic L Gamma} := {
  impp_choice: forall x y, |-- (x --> y) || (y --> x)
}.

Section GodelDummett.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {gdpAX: GodelDummettPropositionalLogic L Gamma}.
(*
Lemma derivable_impp_choice: forall (Phi: context) (x y: expr),
  Phi |-- (x --> y) || (y --> x).
Proof.
  intros.
  pose proof impp_choice x.
  apply deduction_weaken0; auto.
Qed.
*)
Instance GodelDummett2DeMorgan: DeMorganPropositionalLogic L Gamma.
Proof.
  constructor.
  AddSequentCalculus.
  intros.
  rewrite provable_derivable.
  set (Phi := empty_context).
  clearbody Phi.

  pose proof impp_choice x (~~ x).
  apply deduction_weaken0 with (Phi0 := Phi) in H.

  assert (Phi |-- (x --> ~~ x) --> (x --> FF)).
  {
    rewrite <- deduction_theorem.
    rewrite <- deduction_theorem.
    eapply deduction_weaken with (Union _ (Union _ (Union _ Phi (Singleton _ (x --> ~~ x))) (Singleton _ x)) (Singleton _ x)).
    + intros y ?.
      destruct H0; [| right; auto].
      destruct H0; [| right; auto].
      left; auto.
    + rewrite deduction_theorem.
      rewrite deduction_theorem.
      apply derivable_assum1.
  }
  assert (Phi |-- (~~ x --> x) --> (~~ x --> FF)).
  {
    rewrite <- deduction_theorem.
    pose proof derivable_assum1 Phi (~~ x --> x).
    set (Psi := Union expr Phi (Singleton expr (~~ x --> x))) in H1 |- *; clearbody Psi.
    rewrite <- deduction_theorem in H1 |- *.
    pose proof derivable_assum1 Psi (~~ x).
    pose proof deduction_modus_ponens _ _ _ H1 H2.
    auto.
  }

  rewrite <- deduction_theorem in H0, H1.
  apply (deduction_orp_intros1 _ _ (~~ x --> FF)) in H0.
  apply (deduction_orp_intros2 _ (x --> FF)) in H1.
  rewrite deduction_theorem in H0, H1.
  pose proof deduction_orp_elim' _ _ _ _ H0 H1.
  pose proof deduction_modus_ponens _ _ _ H H2.
  auto.
Qed.

End GodelDummett.


From Undecidability.L Require Export LTerm Por Decidability Lbeta_nonrefl.
Import L_Notations.

(* * Definition of L-acceptability *)

Definition pi (s t:term) := converges (s (ext t)).

Definition lacc (P : term -> Prop) :=
  exists u, proc u /\ forall t, P t <-> pi u t.

(* * Properties of acceptance *)

Goal forall s1 s2 t, s1 == s2 -> (pi s1 t <-> pi s2 t).
Proof.
  intros s1 s2 t H; intuition; unfold pi; [now rewrite <- H | now rewrite H].
Qed.

(* * L-acceptable predicates are closed under conjunction and disjunction *)

Definition acc_conj (p q : term) := lam ((lam (q #1)) (p #0) ).
#[export] Hint Unfold acc_conj : cbv.

Lemma acc_conj_correct p q s : closed p -> closed q -> (pi (acc_conj p q) s <-> pi p s /\ pi q s).
Proof.
  intros cls_p cls_q.
  split.
  - intros [x [Hx lx]].
    assert (H : converges (lam( q (enc s)) (p (enc s)))). { exists x;split;auto. symmetry. symmetry in Hx. unfold acc_conj in Hx. rewrite Hx. redStep. LsimplRed. }
    destruct (app_converges H) as [_ [y [Hy ly]]]. split.
    + eexists; split;eassumption.
    + exists x;split;auto. rewrite <- Hx. symmetry. clear Hx. unfold acc_conj. LsimplRed. rewrite Hy.  LsimplRed.
  - intros [[x [Hx ?]] [y [Hy ?]]]. exists y. split. unfold acc_conj. LsimplRed. rewrite Hx. LsimplRed. tauto. Lproc.
Qed.

Lemma lacc_conj P Q : lacc P -> lacc Q -> lacc (conj P Q).
Proof.
  intros [u1 [[? ?] Hu1]] [u2 [[? ?] Hu2]].
  exists (acc_conj u1 u2). split. unfold acc_conj. Lproc.
  intros; rewrite acc_conj_correct; firstorder.
Qed.

Lemma lacc_disj M N : lacc M -> lacc N -> lacc (disj M N).
Proof.
  intros [u [[lam_u cls_u] Hu]] [v [[lam_v cls_v] Hv]].
  unfold lacc, disj.
  exists (lam (Por ((ext app) (enc u) ((ext (term_enc) #0))) (((ext app) (enc v) ((ext (term_enc)) #0))))).
  split. Lproc. intros t.

  rewrite Hu, Hv; unfold pi.
  evar (t':term).
  (* todo: nicer way?*)
  assert (R':(lam(
      (Por ((ext app) (ext u) ((ext (term_enc)) 0)))
      ((ext app) (ext v) ((ext (term_enc)) 0))) (ext t)) >* t'). subst t'. now Lsimpl.
  rewrite R'. subst t'.
  split. intros [A|B].
  -destruct (Por_correct_1a (v (enc t)) A) as [s [R ls]]. exists s. split;try Lproc. eassumption.
  -destruct (Por_correct_1b (u (enc t)) B) as [s [R ls]]. exists s. split;try Lproc. eassumption.
  -intros [s [H ls]]. edestruct Por_correct_2 as [].
   { exists s. split;auto.
     rewrite !ext_is_enc.
     unfold Por.
     rewrite <- R'. Lsimpl. eassumption. }
   apply Por_correct' in H0. destruct x;auto.
Qed.

(* * L-ecidable predicates are L-acceptable (and their complement too) *)

Lemma dec_lacc M : ldec M -> lacc M.
Proof.
  intros [u [[cls_u lam_u] dec_u_M]].
  exists (lam (u #0 I (lam Omega) I)); split. Lproc.
    + intros t. specialize (dec_u_M t).
      split; intros H; destruct dec_u_M; try tauto.
      * destruct H0 as [u_true ?]. eexists;split;[|eexists;reflexivity]. redSteps. rewrite u_true. destruct x. now Lsimpl. tauto.
      * destruct H0. destruct x. tauto.
        assert ((lam ((((u #0) I) (lam Omega)) I)) (enc t) == Omega). clear H. LsimplRed. rewrite H0. Lrewrite.
        now Lsimpl_old. destruct H as [H [? []]]. subst H. rewrite H2 in H3.
        destruct (Omega_diverges H3).
Qed.

Lemma dec_acc : forall M, ldec M -> lacc M /\ lacc (complement M).
Proof.
  intros M decM; split.
  - eapply (dec_lacc decM).
  - eapply ldec_complement in decM. eapply (dec_lacc decM).
Qed.