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


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.


 (*****************************************************************************************)
(*****************************************************************************************)
(*This file gives the SN proof after embedding the theory*)
(*There are two main steps to prove SN :*)
(*1. Soundness of the first order theory*)
(*2. New proof of the conversion rule*)
(*To prove 2, just need to prove eq_fotrm can be embedded in eq_typ*)
(*****************************************************************************************)
(*****************************************************************************************)

Require Import AbsTheoryIntp.

Import AbsTheorySyn AbsTheorySem.
Import Esub GenLemmas.
Import SN_CC_Real.
Import ZF SN CCSN.

(*SN for the abstract theory*)
Module Abs_SN_Theory (Msyn : TheorySyn) (Msem : TheorySem) (Mintp : TheoryIntp Msyn Msem).

Import Msyn Msem Mintp.
Import MAI MSI.

Lemma intp_sound : forall hyp P, deriv hyp P ->
  exists p, typ ((intp_hyp hyp)) p (intp_fofml P).
induction 1; simpl.
(*hyp*)
 exists (Ref n); red; simpl; intros. unfold val_ok in H1.
 rewrite <- lift_intp_lift_fml. apply H1. apply intp_hyp_nth_fml; trivial.

(*ax_intro*)
 apply intp_ax; trivial.

(*true_intro*)
 apply True_symb_intro.

(*false_elim*)
 destruct IHderiv. exists (App x (intp_fofml f)).
 apply False_symb_elim; [|apply intp_fofml_prop]; trivial.

(*neg_intro*)
 destruct IHderiv as (p, IH). exists p.
 apply Neg_intro; trivial.

(*neg_elim*)
 destruct IHderiv. exists x.
 apply Neg_elim; trivial.

(*conj_intro*)
 destruct IHderiv1 as (x, IH1).
 destruct IHderiv2 as (x', IH2).
 apply Conj_intro with (u:=x) (v:=x'); [apply intp_fofml_prop; apply deriv_well_typed
   |apply intp_fofml_prop; apply deriv_well_typed|split]; trivial.

(*conj_elim1*)
 destruct IHderiv as (t, IH). apply deriv_well_typed in H. simpl in IH.
 apply Conj_elim1 with (B:=(intp_fofml f2)) (t:=t);
   [apply intp_fofml_prop|apply intp_fofml_prop|trivial];
   unfold wf_fml, fv_fml in H |- *; simpl in H |- *; intros; apply H;
     rewrite in_app_iff; [left|right]; trivial.

(*conj_elim2*)
 destruct IHderiv as (t, IH). apply deriv_well_typed in H.
 apply Conj_elim2 with (A:=(intp_fofml f1)) (t:=t);
   [apply intp_fofml_prop|apply intp_fofml_prop|trivial];
   unfold wf_fml, fv_fml in H |- *; simpl in H; intros; apply H;
     rewrite in_app_iff; [left|right]; trivial.

(*disj_intro1*)
 destruct IHderiv.
 apply Disj_intro1 with (t:=x); [apply intp_fofml_prop; apply deriv_well_typed
   |apply intp_fofml_prop|]; trivial.

(*disj_intro2*)
 destruct IHderiv.
 apply Disj_intro2 with (t:=x); [apply intp_fofml_prop
   |apply intp_fofml_prop; apply deriv_well_typed|]; trivial.

(*disj_elim*)
 destruct IHderiv1, IHderiv2, IHderiv3. simpl in H3, H4.
 apply deriv_well_typed in H. apply deriv_well_typed in H0.
 apply wf_weakening in H0.
 apply Disj_elim with (t:=x) (t1:=x0) (t2:=x1) (A:=intp_fofml f1) (B:=intp_fofml f2);
   [apply intp_fofml_prop|apply intp_fofml_prop|apply intp_fofml_prop
     | |rewrite lift_intp_lift_fml|rewrite lift_intp_lift_fml]; trivial;
   unfold wf_fml, fv_fml in H |- *; intros; apply H; simpl;
     rewrite in_app_iff; [left|right]; trivial.

(*impl_intro*)
 destruct IHderiv as (p, IH). simpl in IH.
 rewrite <- lift_intp_lift_fml in IH.
 exists (Abs (intp_fofml f1) p).
 apply Impl_intro; [apply intp_fofml_prop|destruct f2; simpl; discriminate|]; trivial.

(*impl_elim*)
 destruct IHderiv1, IHderiv2. exists (App x x0).
 apply Impl_elim with (A:=intp_fofml f1); trivial; [destruct f1 | destruct f2];
   simpl; discriminate.

(*fall_intro*)
 destruct IHderiv. simpl in H0. exists ((Abs sort x)).
 apply Fall_intro; trivial.
  replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)); trivial.
  apply intp_fofml_prop. apply deriv_well_typed; trivial.

(*fall_elim*)
 destruct IHderiv. exists (App x (intp_fotrm u)).
 rewrite <- subst_intp_subst_fml.
 apply Fall_elim; [| |apply intp_fotrm_sort]; trivial.
  replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)); trivial.
  apply intp_fofml_prop. apply deriv_well_typed in H0.
  unfold wf_fml, fv_fml in H0 |- *; intros.
  destruct n; simpl; trivial.
   apply H0. apply in_S_fv_fml; trivial.

(*exst_intro*)
 destruct IHderiv. apply intp_fotrm_sort in H.
 rewrite <- subst_intp_subst_fml in H1.
 apply Exst_intro with (a:=(intp_fotrm N)) (p:=x); trivial.
  replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)); trivial.
  apply intp_fofml_prop. apply deriv_well_typed in H0.
  unfold wf_fml, fv_fml in H0 |- *; intros.
  destruct n; simpl; trivial.
   apply H0. unfold fv_fml, subst_fml in H2 |- *.
   apply (in_fv_fml_subst _ n N 0 0); trivial.

(*exst_elim*)
 destruct IHderiv1, IHderiv2.
 rewrite <- lift_intp_lift_fml in H2. simpl in H2.
 unfold lift_fml in H0; rewrite lift_fml_split in H0.
 fold (lift_fml f1 1) in H0. fold (lift_fml (lift_fml f1 1) 1) in H0.
 apply deriv_well_typed in H0.
 do 2 apply wf_weakening in H0.
 apply Exst_elim with (t1:=x) (t2:=x0) (A:=intp_fofml f); trivial;
   [replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)) by trivial|];
   apply intp_fofml_prop; trivial.
  apply deriv_well_typed in H. unfold wf_fml, fv_fml in H |- *; intros.
  destruct n; simpl; trivial.
   apply H; apply in_S_fv_fml; trivial.
Qed.

Lemma SN_T : forall e x y,
  (exists hyp a b es,
    x = app_esub es (intp_fotrm a) /\
    y = app_esub es (intp_fotrm b) /\
    wf_clsd_env (intp_hyp hyp) /\
    typ_esub e es (intp_hyp hyp) /\
    deriv hyp (eq_fotrm a b)) ->
  eq_typ e x y.
intros e x y Hyp.
destruct Hyp as (hyp, (a, (b, (es, (Hx, (Hy, (Hclsd, (He, Hderiv)))))))).
(*a and b are well typed in theory syntax*)
specialize deriv_well_typed with (1:=Hderiv); intro Hwf.
assert (wf_trm hyp a /\ wf_trm hyp b) as Hwfab.
 unfold wf_fml, fv_fml in Hwf; simpl in Hwf.
 unfold wf_trm; split; intros; apply Hwf; rewrite in_app_iff; [left|right]; trivial.

destruct Hwfab as (Hwfa, Hwfb); clear Hwf.
(*Therefore they have type sort in semantic*)
apply intp_fotrm_sort in Hwfa.
apply intp_fotrm_sort in Hwfb.

(*EQ_trm (intp_trm a) (intp_trm b) can be proved*)
specialize intp_sound with (1:=Hderiv); clear Hderiv; intro HEQ.
destruct HEQ as (p, HEQ); simpl in HEQ.

(*EQ_trm can be embedded in eq_typ*)
apply EQ_trm_elim in HEQ; [|exact Hclsd|exact Hwfa|exact Hwfb].

(*eq_typ relation maintains after variable recocation*)
subst x y.
apply explicit_sub_eq_typ with (3:=He);
  [apply intp_fotrm_not_kind|apply intp_fotrm_not_kind|exact HEQ].
Qed.

End Abs_SN_Theory.


(*
    Properties of to_N and to_C.
    Ideally we wnat (to_N (to_C G)) = G, but that is not the case;
    the actual theorems are slightly different (G_subset_toN_toC_G and toN_toC_G_subset_G).
*)
From mathcomp Require Import all_ssreflect.
Require Import Coq.Strings.String Coq.Bool.Bool Coq.Lists.List.
Import ListNotations.
From Coq.Arith Require Import Arith EqNat.
Open Scope string_scope.
Open Scope list_scope.
From Taxiway Require Import To_complete To_naive Types.
From Hammer Require Import Hammer.
Set Hammer ReconstrLimit 20.

Require Import Coq.Program.Equality.
Require Import Arith.
Require Import Setoid.
Require Import Relations.
Require Import Compare_dec.
Require Import ArithRing.
Require Import Omega.
Require Import Coq.Program.Tactics.

(* ============= partial identity   ================*)

(* outputs in (previous_edges ne bg) are in bg *)
Lemma prev_edge_in_bi_G: forall G ne prev_ne,
    In ne G ->
    In prev_ne (previous_edges ne (undirect_to_bidirect G)) ->
    In prev_ne (undirect_to_bidirect G).
Proof.
intros.
unfold previous_edges in H0.
remember (undirect_to_bidirect G) as bg.
apply filter_In in H0. destruct H0. assumption.
Qed.

Lemma prev_edge_prop: forall prev_ne ne G,
    In ne G ->
    In prev_ne (previous_edges ne (undirect_to_bidirect G)) ->
    prev_ne.1.1 =v= ne.1.2 /\ prev_ne.1.2 >v< ne.1.1.
Proof.
intros. unfold previous_edges in H0. apply filter_In in H0. destruct H0. apply andb_true_iff in H1. easy.
Qed.

(* undirect_to_bidirect preserve original edges *)
Lemma undirect_edge_in_bi_G: forall G undir_e,
    In undir_e G ->
    undir_e.1.1 >v< input ->
    In undir_e (undirect_to_bidirect G).
Proof. intros. unfold undirect_to_bidirect. apply filter_In. split.
- apply in_flat_map. exists undir_e. split. intuition. intuition.
- intuition.
Qed.

Definition no_self_loop (G: N_Graph_type) : Prop :=  (forall ne, In ne G -> ne.1.1 <> ne.1.2).

(* A spec on graph, ensuring that no self-looping *)
Lemma no_self_loop_in_bg:
    forall G,
    no_self_loop G -> no_self_loop (undirect_to_bidirect G).
Proof.
intros G H. unfold no_self_loop. intros. unfold undirect_to_bidirect in *.
apply filter_In in H0. destruct H0. apply in_flat_map in H0. destruct H0 as [e hyp]; destruct hyp.
unfold no_self_loop in H.
simpl in H2. destruct H2.
- hammer.
- hammer.
Qed.

(* Check if there's "input" vertex *)
Definition no_input_vertex (G: N_Graph_type) : Prop :=
    (forall ne, In ne G -> (ne.1.1 >v< input) /\ (ne.1.2 >v< input)).

(* a lemma to ensure there's no input vertices left *)
Lemma no_input_vertex_in_bg:
    forall G,
    no_input_vertex G -> no_input_vertex (undirect_to_bidirect G).
Proof. intros. unfold no_input_vertex. intros. unfold undirect_to_bidirect in H0.
apply filter_In in H0. destruct H0. apply in_flat_map in H0. destruct H0 as [e hyp]; destruct hyp.
unfold no_self_loop in H.
simpl in H2. destruct H2.
- hammer.
- hammer.
Qed.

(* vertices in the naive graph, ARB *)
Example AA3 : Vertex := index 1.
Example AB := index 2.
Example AC := index 3.
Example AA1 := index 4.
Example Ch := index 5.
Example BC := index 6.
Example A3r := index 7.
Example A2r := index 8.
Example A1r := index 9.

(* taxiway name *)
Example A : Taxiway_type := "A".
Example B := "B".
Example C := "C".
Example A1 := "A1".
Example A2 := "A2".
Example A3 := "A3".

(* input edges have taxiway name "" *)
Example naive_ann_arbor : N_Graph_type :=[
    ((Ch, input), "");
    ((A1r, input), "");
    ((A2r, input), "");
    ((A3r, input), "");
    ((BC, input), "");
    ((Ch, BC), C);
    ((BC, AB), B);
    ((AB, AA3), A);
    ((AA3, A3r), A3);
    ((AB, A2r), A2);
    ((BC, AC), C);
    ((AB, AC), A);
    ((AC, AA1), A);
    ((AA1, A1r), A1)
].

 (* Example G1 : N_Graph_type := [
    ((AA1, AC), A);
    ((AA1, A1r), A)
    ].

Theorem toC_toN_id : forall (ne: Edge_type) ,
    no_self_loop G1 -> (* no self loop *)
    In ne G1 ->
    (exists prev_ne, In prev_ne (previous_edges ne (undirect_to_bidirect G1))) -> (* ne has a previous edge in the bidirect graph *)
    (forall ne, In ne G1 ->
        (ne.1.1 >v< input) /\ (ne.1.2 >v< input)) -> (* input vertex should not appear in any naive graph *)
        In ne (to_N (to_C G1)) \/ In (Edge_inv ne) (to_N (to_C G1)).
Proof. intros. simpl in H0. destruct H0.
hammer. hammer. Qed.  *)

(* TODO o put it in types.v *)
Lemma negb_eqv_refl: forall v1 v2, v1 >v< v2 <-> v2 >v< v1.
Proof. intros. split.
- hammer.
- hammer.
Qed.

Lemma negb_eqv_false_equiv: forall v1 v2, (v1 =v= v2) = false -> (v2 =v= v1) = false.
Proof. intros.
apply eqv_rewrite_2. apply negb_eqv_refl. hammer.
Qed.

Lemma bidirected_graph_no_edge_end_with_input:
    forall ne G,
    In ne (undirect_to_bidirect G) ->
    ne.1.1 >v< input.
Proof. intros. unfold undirect_to_bidirect in H.
apply filter_In in H. destruct H. assumption. Qed.

(*  Here we prove "most" of the edges in G are in (to_N (to_C G)).
    Specifically, an edge ne in undirected graph G is also in (to_N (to_C G)) if:
    1. there's no self-loop in G
    2. ne is not an input edge
    3. there exists a previous edge of ne in the bidirected graph.
      Because our undirect graph uses an ordered pair [A,B] (a directed edge) to represent {[A,B],[B,A]},
      this is equivalent to say that there is an edge e in the undirect graph, s.t. e or reverse_e is ne's previous edge, under condition 2
*)
Theorem G_subset_toN_toC_G : forall (ne: Edge_type) (G: N_Graph_type),
    no_self_loop G -> (* no self loop *)
    In ne G ->
    (exists prev_ne,
        (* ne has a previous edge in the bidirect graph *)
        (In prev_ne (previous_edges ne (undirect_to_bidirect G)))
    ) ->
    (ne.1.2 >v< input /\ ne.1.1 >v< input) -> (* ne is not an input edge *)
    In ne (to_N (to_C G)).

Proof. intros ne G Hno_self_loop Hne_in_G Hexist_prev H_ne_not_input.
destruct H_ne_not_input as [H_ne_not_input1 H_ne_not_input2].
unfold to_C.
remember (undirect_to_bidirect G) as bg.
unfold generate_edges.
destruct Hexist_prev as [prev_ne Hprev_ne].

remember (to_N (to_C [ne; prev_ne] )) as G''.
destruct ne as [neEndStart neTaxi] eqn:Hne1.
destruct neEndStart as [neEnd neStart] eqn:Hne2.
simpl in H_ne_not_input1, H_ne_not_input2.
assert (Hne3: neStart >v< neEnd). {
    apply Hno_self_loop in Hne_in_G; simpl in Hne_in_G.
    apply eqv_inv. hammer.
}
assert(Hne4: (neEnd >v< neStart)). {
    apply negb_eqv_refl. assumption.
}
assert(Hne5: (neEnd =v= neStart) = false). {
    hammer.
}
assert(Hne5_2: (neStart =v= neEnd) = false). {
    apply negb_eqv_false_equiv. assumption.
}
(* properties about ne and prev_ne *)

assert(Hprev_ne_in_bg: In prev_ne bg). {
    rewrite -> Heqbg.
    apply prev_edge_in_bi_G with (ne:= ne). hammer.
    hammer.
}

assert (Hprev_ne1: (prev_ne.1.1 >v< input) ) by hammer.
assert (Hprev_ne3: prev_ne.1.1 =v= ne.1.2 /\ prev_ne.1.2 >v< ne.1.1). {
    apply prev_edge_prop with (G:=G). hammer. hammer.
}
rewrite -> Hne1 in Hprev_ne3; simpl in Hprev_ne3.
destruct Hprev_ne3 as [Hprev_ne3 Hprev_ne4].
assert (Hprev_ne5: (prev_ne.1.1 >v< prev_ne.1.2)). {
    rewrite -> Heqbg in Hprev_ne_in_bg.
    apply no_self_loop_in_bg in Hprev_ne_in_bg.
    apply eqv_inv.
    assumption.
    assumption.
}

assert  (Hprev_ne6: (prev_ne.1.2 =v= neStart) = false). {
    apply eqv_eq in Hprev_ne3. rewrite Hprev_ne3 in Hprev_ne5.
    clear - Hprev_ne5. apply eqv_rewrite_2 in Hprev_ne5.
    destruct (prev_ne.1.2 =v= neStart) eqn: Htemp.
    - apply eqv_eq in Htemp. symmetry in Htemp. apply eqv_eq in Htemp. rewrite Hprev_ne5 in Htemp. intuition.
    - intuition.
}

assert (lemma: In ne G'' ). {
    (* 4 situations, whether ne_start/end ?= Types.input *)
        rewrite -> HeqG''. rewrite <- Hne1. unfold to_C.
        remember (undirect_to_bidirect [ne; prev_ne ]) as b_G' eqn: Hbg_ne. (* bidirected graph from [ne] *)
        rewrite -> Hne1 in Hbg_ne.
        (* eval bg_ne *)
        unfold undirect_to_bidirect in Hbg_ne. simpl in Hbg_ne.
        rewrite -> H_ne_not_input1 in Hbg_ne; rewrite -> H_ne_not_input2 in Hbg_ne.
        rewrite -> Hprev_ne1 in Hbg_ne.
        destruct (prev_ne.1.2 >v< input) eqn: Hprev_ne2.
        -  simpl in Hbg_ne.
            unfold Edge_inv in Hbg_ne; simpl in Hbg_ne.
            (* eval (generate_edges bg_ne) *)
            unfold generate_edges, previous_edges.
            rewrite -> Hbg_ne. simpl.

            Ltac choose_branch term hyp :=
                assert (hyp: term) by hammer; rewrite hyp; simpl.
            choose_branch ((neEnd =v= neStart) && (neStart >v< neEnd) = false) branch1.
            choose_branch ((neStart =v= neStart) && (neEnd >v< neEnd) = false) branch2.
            choose_branch ((prev_ne.1.1 =v= neStart) && (prev_ne.1.2 >v< neEnd) = true) branch3.
            left. unfold c_to_n; simpl. easy.
        -  rewrite Hbg_ne. simpl. unfold Edge_inv, generate_edges. simpl.
        choose_branch ((neEnd =v= neStart) && (neStart >v< neEnd) = false) branch1.
        choose_branch ((neStart =v= neStart) && (neEnd >v< neEnd) = false) branch2.
        choose_branch ((prev_ne.1.1 =v= neStart) && (prev_ne.1.2 >v< neEnd) = true) branch3.
        left. unfold c_to_n; simpl. easy.
}

assert(Hne8: (neStart =v= neStart)) by hammer.
assert(Hne9: (neEnd =v= neEnd)) by hammer.
assert (Hprev_ne7: (prev_ne.1.1 =v= neEnd) = false). {
    apply eqv_rewrite_2. apply eqv_inv. apply eqv_eq in Hprev_ne3. rewrite Hprev_ne3.
    apply eqv_inv. assumption.
}

(* eval G''*)
unfold In, to_N, to_C, undirect_to_bidirect, generate_edges, previous_edges in HeqG''; simpl in HeqG''.

Ltac unfold_undir_to_bidir Hprev_ne1  Hne7 H :=
    unfold undirect_to_bidirect in H; simpl in H;
    rewrite -> Hprev_ne1, Hne7 in H; simpl.

Ltac choose_branch_2 term hyp H:=
    assert (hyp: term) by first [apply negb_eqv_false_equiv; easy |  hammer];
    rewrite -> hyp in H; simpl in H.

unfold Edge_inv in HeqG''. simpl in HeqG''.
apply eqv_rewrite_2 in Hprev_ne4.
apply eqv_rewrite_2 in Hne3.
apply eqv_rewrite_2 in Hprev_ne1.
apply eqv_rewrite_2 in Hprev_ne5.

destruct (prev_ne.1.2 >v< input) eqn:Hprev_ne_not_input.
-   repeat (
            try rewrite -> Hne3 in HeqG'';
            try rewrite -> Hne4 in HeqG'';
            try rewrite -> Hne5 in HeqG'';
            try rewrite -> Hne5_2 in HeqG'';
            try rewrite -> Hne8 in HeqG'';
            try rewrite -> Hne9 in HeqG'';
            try rewrite -> H_ne_not_input1 in HeqG'';
            try rewrite -> H_ne_not_input2 in HeqG'';
            try rewrite -> Hprev_ne_in_bg in HeqG'';
            try rewrite -> Hprev_ne1 in HeqG'';
            try rewrite -> Hprev_ne3 in HeqG'';
            try rewrite -> Hprev_ne4 in HeqG'';
            try rewrite -> Hprev_ne5 in HeqG'';
            try rewrite -> Hprev_ne6 in HeqG'';

            try rewrite -> Hprev_ne7 in HeqG'';
            try rewrite -> Hne1 in HeqG'';
            try unfold Edge_inv in HeqG'';
            try simpl in HeqG'';
            try unfold c_to_n in HeqG''
    ).

    choose_branch_2 ((neEnd =v= prev_ne.1.2) = false) hyp1 HeqG''.
    choose_branch_2 ((neStart =v= prev_ne.1.2) = false) hyp2 HeqG''.
    choose_branch_2 ((prev_ne.1.2 =v= prev_ne.1.2)) hyp3 HeqG''.
    choose_branch_2 ((prev_ne.1.1 =v= prev_ne.1.1)) hyp4 HeqG''.
    choose_branch_2 ((neEnd =v= prev_ne.1.1) = false) hyp5 HeqG''.
    choose_branch_2 (((neStart =v= prev_ne.1.1))) hyp6 HeqG''.
    choose_branch_2 ((prev_ne.1.2 =v= prev_ne.1.1) = false) hyp7 HeqG''.

    assert(lemma2: In ne (to_N (to_C G))). {
        (* destruct Hprev_ne0 as [L Hprev_ne0].
        rewrite <- Hprev_ne0. *)
        unfold to_C. rewrite <- Heqbg.
        simpl.
        (* evaluate the first generate_edges *)
        Ltac temp Hne1 Hne3 Hne4 Hne5 Hne5_2 Hne6 Hne7 Hne8 Hne9
        Hprev_ne1 Hprev_ne2 Hprev_ne3 Hprev_ne4 Hprev_ne5 Hprev_ne6 Hprev_ne7 Hprev_ne
        hyp1 hyp2 hyp3 hyp4 hyp5 hyp6 hyp7 hyp8 hyp9:=
            unfold generate_edges at 1; simpl;
            repeat (
                try rewrite -> Hne1;
                try rewrite -> Hne3;
                try rewrite -> Hne4;
                try rewrite -> Hne5;
                try rewrite -> Hne5_2;
                try rewrite -> Hne6;
                try rewrite -> Hne7;
                try rewrite -> Hne8;
                try rewrite -> Hne9;
                try rewrite -> Hprev_ne1;
                try rewrite -> Hprev_ne2;
                try rewrite -> Hprev_ne3;
                try rewrite -> Hprev_ne4;
                try rewrite -> Hprev_ne5;
                try rewrite -> Hprev_ne6;
                try rewrite -> Hprev_ne7;
                try rewrite -> hyp1;
                try rewrite -> hyp2;
                try rewrite -> hyp3;
                try rewrite -> hyp4;
                try rewrite -> hyp5;
                try rewrite -> hyp6;
                try rewrite -> hyp7;
                try rewrite -> hyp8;
                try rewrite -> hyp9;
                try unfold Edge_inv;
                try simpl
            );
            unfold c_to_n; simpl.
        temp Hne1 Hne3 Hne4 Hne5 Hne5_2 Hne6 Hne7 Hne8 Hne9
            Hprev_ne1 Hprev_ne2 Hprev_ne3 Hprev_ne4 Hprev_ne5 Hprev_ne6 Hprev_ne7 Hprev_ne
            hyp1 hyp2 hyp3 hyp4 hyp5 hyp6 hyp7 hyp8 hyp9.
        unfold to_N. apply in_map_iff.
        exists (prev_ne.1, (neEnd, neStart), neTaxi).
        split.
        - easy.
        - apply in_flat_map. exists ne. split.
            + rewrite Heqbg. apply undirect_edge_in_bi_G.
                * hammer. * hammer.
            + apply in_map_iff. exists prev_ne. split. hammer. hammer.
    }
    hammer.
(* the proof for this case is kind of redundant with the previous one *)
- repeat (
        try rewrite -> Hne3 in HeqG'';
        try rewrite -> Hne4 in HeqG'';
        try rewrite -> Hne5 in HeqG'';
        try rewrite -> Hne5_2 in HeqG'';
        try rewrite -> Hne8 in HeqG'';
        try rewrite -> Hne9 in HeqG'';
        try rewrite -> H_ne_not_input1 in HeqG'';
        try rewrite -> H_ne_not_input2 in HeqG'';
        try rewrite -> Hprev_ne_in_bg in HeqG'';
        try rewrite -> Hprev_ne1 in HeqG'';
        try rewrite -> Hprev_ne3 in HeqG'';
        try rewrite -> Hprev_ne4 in HeqG'';
        try rewrite -> Hprev_ne5 in HeqG'';
        try rewrite -> Hprev_ne6 in HeqG'';

        try rewrite -> Hprev_ne7 in HeqG'';
        try rewrite -> Hne1 in HeqG'';
        try unfold Edge_inv in HeqG'';
        try simpl in HeqG'';
        try unfold c_to_n in HeqG''
    ).
    choose_branch_2 ((neEnd =v= prev_ne.1.2) = false) hyp1 HeqG''.
    choose_branch_2 ((neStart =v= prev_ne.1.2) = false) hyp2 HeqG''.
    assert(lemma2: In ne (to_N (to_C G))). {
    unfold to_C. rewrite <- Heqbg.
    simpl.
        unfold c_to_n; simpl.
    temp Hne1 Hne3 Hne4 Hne5 Hne5_2 Hne6 Hne7 Hne8 Hne9
        Hprev_ne1 Hprev_ne2 Hprev_ne3 Hprev_ne4 Hprev_ne5 Hprev_ne6 Hprev_ne7 Hprev_ne
        hyp1 hyp2 hyp3 hyp4 hyp5 hyp6 hyp7 hyp8 hyp9.
        unfold to_N. apply in_map_iff.
        exists (prev_ne.1, (neEnd, neStart), neTaxi).
        split.
        - easy.
        - apply in_flat_map. exists ne. split.
            + rewrite Heqbg. apply undirect_edge_in_bi_G.
                * hammer. * hammer.
            + apply in_map_iff. exists prev_ne. split. hammer. hammer.
    }
    hammer.
Qed.

(*  (to_N (to_C G)) \subset  (undirect_to_bidirect G) *)
Theorem toN_toC_G_subset_G : forall (G: N_Graph_type),
    incl (to_N (to_C G)) (undirect_to_bidirect G).
Proof. intros. unfold incl. intro ne. intros.
unfold to_N, to_C in H.
remember (undirect_to_bidirect G) as bg.
apply in_map_iff in H. destruct H as [A H]. destruct H.
apply in_flat_map in H0. destruct H0 as [e H1]. destruct H1 as [H1 H2].
unfold generate_edges in H2. apply in_map_iff in H2. destruct H2 as [V H2]. destruct H2 as [H2 H3].
assert (e = ne) by hammer.
rewrite <- H0. assumption.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C Bprime : Universe, ((wd_ O E /\ (wd_ A Eprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Bprime Eprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O A Eprime /\ (col_ E A Eprime /\ col_ Bprime O Eprime)))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*****************************************************)
(*****************************************************)
(****                                             ****)
(****   The category of categories and functors   ****)
(****                                             ****)
(*****************************************************)
(*****************************************************)

Require Import Main.CategoryTheory.Category.
Require Import Main.CategoryTheory.Functor.

Definition catCategory : category := newCategory
  category
  (functor)
  (fun _ _ _ => compFunctor)
  (fun _ => idFunctor)
  (@compFunctorAssoc)
  (@compFunctorIdentLeft)
  (@compFunctorIdentRight).


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lia.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
Import ListNotations.
From QE Require Import Maps.

Inductive expr : Type :=
| Tru
| Fls
| If (e0 : expr) (e1 : expr) (e2 : expr)
| Raise (γ : string)
| Handle (e1 : expr) (γ : string) (e2 : expr).

(* bool is the only type here *)
Inductive ty : Type :=
| TBool : ty.

Inductive eval : expr -> expr -> Prop :=
| E_If_t : forall e2 e3, eval (If Tru e2 e3) e2
| E_If_f : forall e2 e3, eval (If Fls e2 e3) e3
| E_If_g : forall e1 e1' e2 e3,
    eval e1 e1' ->
    eval (If e1 e2 e3) (If e1' e2 e3)
| E_If_r : forall e2 e3 γ,
    eval (If (Raise γ) e2 e3) (Raise γ)
| E_handle_t : forall γ e2, eval (Handle Tru γ e2) Tru
| E_handle_f : forall γ e2, eval (Handle Fls γ e2) Fls
| E_handle_r : forall γ e2, eval (Handle (Raise γ) γ e2) e2
| E_handle_e : forall e1 e1' γ e2,
    eval e1 e1' ->
    eval (Handle e1 γ e2) (Handle e1' γ e2)
| E_handle_h : forall γ γ' e2,
    γ <> γ' ->
    eval (Handle (Raise γ) γ' e2) (Raise γ).

Definition context := total_map nat.

Inductive value : expr -> Prop :=
| v_t : value Tru
| v_f : value Fls.

Inductive has_type : context -> expr -> ty -> Prop :=
| T_Tru : forall Γ, has_type Γ Tru TBool
| T_Fls : forall Γ, has_type Γ Fls TBool
| T_Raise : forall Γ γ, (Γ γ) = 1 -> has_type Γ (Raise γ) TBool
| T_If : forall Γ e1 e2 e3,
    has_type Γ e1 TBool ->
    has_type Γ e2 TBool ->
    has_type Γ e3 TBool ->
    has_type Γ (If e1 e2 e3) TBool
| T_Handle : forall Γ γ e1 e2,
    (Γ γ) = 0 ->
    has_type (γ !-> 1 ; Γ) e1 TBool ->
    has_type Γ e2 TBool ->
    has_type Γ (Handle e1 γ e2) TBool.

Hint Constructors eval : core.
Hint Constructors has_type : core.
Hint Constructors value : core.

Local Open Scope string_scope.

Theorem e_progress : forall e T Γ,
    has_type Γ e T ->
    value e \/ (exists γ, (Γ γ) = 1 -> e = Raise γ) \/ exists e', eval e e'.
Proof with eauto.
  intros.
  induction H...
  - inversion H; subst...
    destruct IHhas_type1. inversion H5.
    destruct H5. destruct H5.
    right. left. exists x. intros. apply H5 in H6. discriminate H6.
    right. right. destruct H5...
    destruct IHhas_type1. inversion H5.
    destruct H5. destruct H5.
    right. left. exists x. intros. apply H5 in H6. discriminate H6.
    right. right. destruct H5...
  - inversion H0; subst...
    destruct IHhas_type1. inversion H3.
    destruct H3. destruct H3.
    (* need some related to string eqb *)
    Admitted.

(* Theorem e_progress : forall e T Γ, *)
(*     has_type Γ e T -> *)
(*     value e \/ (exists γ, e = Raise γ) \/ exists e', eval e e'. *)
(* Proof with eauto. *)
(*   intros. *)
(*   induction H... *)
(*   - right. right. *)
(*     destruct IHhas_type1. *)
(*     inversion H2... *)
(*     destruct H2. destruct H2. *)
(*     inversion H; subst... *)
(*     discriminate H7. *)
(*     discriminate H7. *)
(*     destruct H2... *)
(*   - right. right. *)
(*     destruct IHhas_type1. *)
(*     inversion H2; subst... *)
(*     destruct H2. *)
(*     destruct H2. *)
(*     inversion H0; subst... *)
(*     rewrite <- H5 in H0. *)
(*     exists (Raise γ0). constructor. *)


(************************************************************************)
(* Copyright (c) 2010, Martijn Vermaat <martijn@vermaat.name>           *)
(*                     Dimitri Hendriks <diem@cs.vu.nl>                 *)
(*                                                                      *)
(* Licensed under the MIT license, see the LICENSE file or              *)
(* http://en.wikipedia.org/wiki/Mit_license                             *)
(************************************************************************)

(** This library defines some preliminaries, mostly used in the [Vector]
   library. *)

Set Implicit Arguments.

Notation "!" := (False_rect _).

Definition S_eq : forall (n m : nat), n = m -> S n = S m :=
  fun n m H => f_equal S H.

(*
Definition S_eq_inv : forall (n m : nat), S n = S m -> n = m :=
  fun n m H => eq_add_S n m H.
*)

Definition S_eq_inv : forall (n m : nat), S n = S m -> n = m :=
  fun (n m : nat) (H : S n = S m) =>
  match (sym_eq H) in (_ = Sn) return pred Sn = pred (S m) with
  | refl_equal => refl_equal (pred (S m))
end.

Definition disc_O_S : forall (n : nat), O <> S n :=
  fun n H =>
  let P := (fun q : nat => match q with 0 => (False -> False) | S q => False end) in
  match H in (_ = q) return P q with refl_equal => (fun a => a) end.

Definition disc_S_O : forall (n : nat), S n <> O :=
  fun n H => disc_O_S (sym_eq H).