(** * ImpCEvalFun: Evaluation Function for Imp *)

(** We saw in the [Imp] chapter how a naive approach to defining a
    function representing evaluation for Imp runs into difficulties.
    There, we adopted the solution of changing from a functional to a
    relational definition of evaluation.  In this optional chapter, we
    consider strategies for getting the functional approach to
    work. *)

(* ################################################################# *)
(** * A Broken Evaluator *)

(* IMPORTS *)
Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Arith.
Require Import Imp.
Require Import Maps.
(* /IMPORTS *)

(** Here was our first try at an evaluation function for commands,
    omitting [WHILE]. *)

Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        t_update st l (aeval st a1)
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st  (* bogus *)
  end.

(** As we remarked in chapter [Imp], in a traditional functional
    programming language like ML or Haskell we could write the WHILE
    case as follows:

    | WHILE b1 DO c1 END => if (beval st b1) then ceval_step1 st (c1;;
        WHILE b1 DO c1 END) else st

    Coq doesn't accept such a definition ([Error: Cannot guess
    decreasing argument of fix]) because the function we want to
    define is not guaranteed to terminate. Indeed, the changed
    [ceval_step1] function applied to the [loop] program from [Imp.v]
    would never terminate. Since Coq is not just a functional
    programming language, but also a consistent logic, any potentially
    non-terminating function needs to be rejected. Here is an
    invalid(!) Coq program showing what would go wrong if Coq allowed
    non-terminating recursive functions:

     Fixpoint loop_false (n : nat) : False := loop_false n.

    That is, propositions like [False] would become
    provable (e.g., [loop_false 0] would be a proof of [False]), which
    would be a disaster for Coq's logical consistency.

    Thus, because it doesn't terminate on all inputs, the full version
    of [ceval_step1] cannot be written in Coq -- at least not without
    one additional trick... *)

(* ################################################################# *)
(** * A Step-Indexed Evaluator *)

(** The trick we need is to pass an _additional_ parameter to the
    evaluation function that tells it how long to run.  Informally, we
    start the evaluator with a certain amount of "gas" in its tank,
    and we allow it to run until either it terminates in the usual way
    _or_ it runs out of gas, at which point we simply stop evaluating
    and say that the final result is the empty memory.  (We could also
    say that the result is the current state at the point where the
    evaluator runs out fo gas -- it doesn't really matter because the
    result is going to be wrong in either case!) *)

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_state
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          t_update st l (aeval st a1)
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.

(** _Note_: It is tempting to think that the index [i] here is
    counting the "number of steps of evaluation."  But if you look
    closely you'll see that this is not the case: for example, in the
    rule for sequencing, the same [i] is passed to both recursive
    calls.  Understanding the exact way that [i] is treated will be
    important in the proof of [ceval__ceval_step], which is given as
    an exercise below.

    One thing that is not so nice about this evaluator is that we
    can't tell, from its result, whether it stopped because the
    program terminated normally or because it ran out of gas.  Our
    next version returns an [option state] instead of just a [state],
    so that we can distinguish between normal and abnormal
    termination. *)

Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (t_update st l (aeval st a1))
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.

(** We can improve the readability of this version by introducing a
    bit of auxiliary notation to hide the plumbing involved in
    repeatedly matching against optional states. *)

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (t_update st l (aeval st a1))
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

 Compute
     (test_ceval empty_state
         (X ::= ANum 2;;
          IFB BLe (AId X) (ANum 1)
            THEN Y ::= ANum 3
            ELSE Z ::= ANum 4
          FI)).
  (** ====>
      Some (2, 0, 4)   *)

(** **** Exercise: 2 stars, recommended (pup_to_n)  *)
(** Write an Imp program that sums the numbers from [1] to
   [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y].  Make sure
   your solution satisfies the test that follows. *)

Definition pup_to_n : com :=
    Y ::= ANum 0;;
    WHILE (BLe (ANum 1) (AId X)) DO
        Y ::= APlus (AId Y)  (AId X);;
        X ::= AMinus (AId X) (ANum 1)
    END.

Example pup_to_n_1 :
  test_ceval (t_update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (peven)  *)
(** Write a [While] program that sets [Z] to [0] if [X] is even and
    sets [Z] to [1] otherwise.  Use [ceval_test] to test your
    program. *)

Definition judge_even : com :=
    Z ::= ANum 0;;
    Y ::= (AId X);;
    WHILE (BLe (ANum 1) (AId Y)) DO
        Z ::= AMinus (ANum 1) (AId Z);;
        Y ::= AMinus (AId Y) (ANum 1)
    END.

Example judge_even_3 :
    test_ceval (t_update empty_state X 3) judge_even
    = Some (3, 0, 1).
Proof. reflexivity. Qed.
(** [] *)

(* ################################################################# *)
(** * Relational vs. Step-Indexed Evaluation *)

(** As for arithmetic and boolean expressions, we'd hope that
    the two alternative definitions of evaluation would actually
    amount to the same thing in the end.  This section shows that this
    is the case. *)

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      c / st \\ st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].

  - (* i = 0 -- contradictory *)
    intros c st st' H. inversion H.

  - (* i = S i' *)
    intros c st st' H.
    destruct c;
           simpl in H; inversion H; subst; clear H.
      + (* SKIP *) apply E_Skip.
      + (* ::= *) apply E_Ass. reflexivity.

      + (* ;; *)
        destruct (ceval_step st c1 i') eqn:Heqr1.
        * (* Evaluation of r1 terminates normally *)
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        * (* Otherwise -- contradiction *)
          inversion H1.

      + (* IFB *)
        destruct (beval st b) eqn:Heqr.
        * (* r = true *)
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        * (* r = false *)
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.

      + (* WHILE *) destruct (beval st b) eqn :Heqr.
        * (* r = true *)
         destruct (ceval_step st c i') eqn:Heqr1.
         { (* r1 = Some s *)
           apply E_WhileLoop with s. rewrite Heqr.
           reflexivity.
           apply IHi'. rewrite Heqr1. reflexivity.
           apply IHi'. simpl in H1. assumption. }
         { (* r1 = None *) inversion H1. }
        * (* r = false *)
          inversion H1.
          apply E_WhileEnd.
          rewrite <- Heqr. subst. reflexivity.  Qed.

(** **** Exercise: 4 stars (ceval_step__ceval_inf)  *)
(** Write an informal proof of [ceval_step__ceval], following the
    usual template.  (The template for case analysis on an inductively
    defined value should look the same as for induction, except that
    there is no induction hypothesis.)  Make your proof communicate
    the main ideas to a human reader; do not simply transcribe the
    steps of the formal proof.

(* I'm not good at informal proof. However, the
   proposition [ceval_step__ceval] proves is quite obvious in that
   the program terminates in limited steps. *)
[]
*)

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  - (* i1 = 0 *)
    simpl in Hceval. inversion Hceval.
  - (* i1 = S i1' *)
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by lia.
    destruct c.
    + (* SKIP *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ::= *)
      simpl in Hceval. inversion Hceval.
      reflexivity.
    + (* ;; *)
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* st1'o = None *)
        inversion Hceval.

    + (* IFB *)
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval;
        assumption.

    + (* WHILE *)
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      * (* st1'o = Some *)
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      * (* i1'o = None *)
        simpl in Hceval. inversion Hceval.  Qed.

(** **** Exercise: 3 stars, recommended (ceval__ceval_step)  *)
(** Finish the following proof.  You'll need [ceval_step_more] in a
    few places, as well as some basic facts about [<=] and [plus]. *)
Theorem leb_false : forall n m,
    leb n m = false -> leb m n = true.
Proof.
    induction n.
    - intros. inversion H.
    - intros. inversion H. destruct m.
        + simpl. reflexivity.
        + simpl. simpl in H. apply IHn in H. apply H.
Qed.

Theorem ceval__ceval_step: forall c st st',
      c / st \\ st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  - exists 1. simpl. reflexivity.
  - exists 1. simpl. rewrite H. reflexivity.
  - inversion IHHce1. inversion IHHce2.
    remember (x <=? x0) as b. destruct b.
    + exists (S x0). simpl.
      assert (ceval_step st c1 x0 = Some st'). {
        apply (ceval_step_more x x0 st st').
        - assert ((x <=? x0) = true). { rewrite Heqb. reflexivity. }
          rewrite leb_iff in H1. apply H1.
        - apply H.
      }
      rewrite H1. apply H0.
    + exists (S x). simpl.
      rewrite H.
      apply (ceval_step_more x0 x st' st'').
      -- assert ((x <=? x0) = false). { rewrite Heqb. reflexivity. }
         apply leb_false in H1. apply leb_iff in H1. apply H1.
      -- apply H0.
  - inversion IHHce. exists (S x).
    simpl. rewrite H. apply H0.
  - inversion IHHce. exists (S x).
    simpl. rewrite H. apply H0.
  - exists 1. simpl. rewrite H. reflexivity.
  - inversion IHHce1. inversion IHHce2. remember (x <=? x0) as b1.
    destruct b1.
    + exists (S x0). simpl. rewrite H.
      assert (ceval_step st c x0 = Some st'). {
          apply (ceval_step_more x x0 st st').
          - assert ((x <=? x0) = true). { rewrite Heqb1. reflexivity. }
            rewrite leb_iff in H2. apply H2.
          - apply H0.
      }
      rewrite H2. apply H1.
    + exists (S x). simpl. rewrite H.
      rewrite H0.
      apply (ceval_step_more x0 x st' st'').
      -- assert ((x <=? x0) = false). { rewrite Heqb1. reflexivity. }
         apply leb_false in H2. apply leb_iff in H2. apply H2.
      -- apply H1.
Qed.

(** [] *)

Theorem ceval_and_ceval_step_coincide: forall c st st',
      c / st \\ st'
  <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

(* ################################################################# *)
(** * Determinism of Evaluation Again *)

(** Using the fact that the relational and step-indexed definition of
    evaluation are the same, we can give a slicker proof that the
    evaluation _relation_ is deterministic. *)

Theorem ceval_deterministic' : forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  lia. lia.  Qed.

(** $Date: 2016-10-22 20:19:37 -0400 (Sat, 22 Oct 2016) $ *)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************)
(** This is a simplification of Alexandre Miquel's encoding of          *)
(** Russell's paradox in system U and U-.                               *)
(** Extraction yields a looping combinator                              *)
(***********************************************************************)
(** Formalized by Hugo Herbelin, 2001                                   *)
(***********************************************************************)
(**
   Reference:

   - [Miquel] A. Miquel, "Le Calcul des Constructions Implicites",
     thèse de doctorat de l'université Paris7, 2001.
*)

(** The basic idea is to encode sets by pointed graphs over a given
universe U, a pointed graph being a relation expressing on the
universe U the subset ordering structure of a set from a given
root.

  E.g., the following relation on U, starting from point a denotes the
set {{empty},empty} (= 2 in set theory).

                   a
                  / \
                 b   c
                 |
                 d

  Notice that the same relation, considered from c or d denotes the
empty set. From b it denotes the singleton {empty}.

  Pointed graphs are considered up to bissimulation. E.g, the relation

                   a
                  /\
                 b  |
                  \ |
                   c

considered from a has the same underlying structure as the previous
set and hence denotes the same set {{empty},empty}.
*)

(**
   In order to get a shorter proof, then a shorter extracted program,
   the following simplifications have been performed:

   - Inlining of the definitions of elt, eqv, ELT.
   - Encodings of there is and or by means of for all, implication and False.
   - Removal of extra double negations.
   - Replacement of EQV by an EMB order, the only equivalence used in both
     way in the proof is the equivalence between (A,a) and (elt,i(A,a)).
   - Replacement of arbitrary elements in u by out as much as possible.
   - Replacement of elt in FOLD by just a link in some set B.
*)

Require Extraction.

Inductive False : Set :=.
Inductive True : Set :=
    I : True.

(** As shown in Coquand ("An Analysis of Girard Paradox", LICS'86), we
  can define in system U- a type (let's call it U also) which is a
  "universal system of notations" for pointed graphs, that is U:Type
  comes with an injection i from pointed graphs on U into U itself *)

(** Definitions of U, i and out typable in U but not in CIC
Definition Type1 := Type.
Definition U := (forall U:Type1, (U->U->Set)->U->Set)->Set : Type1.
Definition i (A:U->U->Set) (a:U) : U := fun H => H U A a.
Definition out : U := fun _ => False.
*)

Parameter U : Type.
Parameter i : (U -> U -> Set) -> U -> U.
Parameter out : U.

Definition eq (u v : U) := forall P : U -> Set, P u -> P v.
Infix "=" := eq (at level 70, no associativity) : type_scope.

Lemma refl_eq : forall u : U, u = u.
Proof fun _ _ x => x.

Notation Sim := (U -> U -> Set).
Notation Graph := Sim.

(** The property [gemb A B R] expresses that R is an embedding of graph
    A into graph B

                    R
                a ------ b
                |        |
             A  |          B
                |    R   |
                a' - - - b'
*)

Definition gemb (A B R : Graph) :=
  forall a a' b : U,
  A a' a -> R a b -> (forall b' : U, R a' b' -> B b' b -> False) -> False.

Notation "A <= B [ R ]" := (gemb A B R)
  (at level 70, B at next level, no associativity).

(** [EMB A a B b] means there a simulation between (A,a) and (B,b) as
    pointed graphs; [NOTEMB] is its contrary *)

Definition NOTEMB (A : Graph) (a : U) (B : Graph) (b : U) :=
  forall R : Graph, A <= B [R] -> R a b -> False.

Definition EMB (A : Graph) (a : U) (B : Graph) (b : U) :=
  NOTEMB A a B b -> False.

Notation "( A , a )  <= ( B , b )" := (EMB A a B b) (at level 0).

(** Basic lemmas on [gemb] and [EMB] *)

Lemma eq_gemb : forall A : Graph, A <= A [eq].
Proof
  fun A a a' a0 Ha'a Heq H => H a' (refl_eq a') (Heq (fun a => A a' a) Ha'a).

Lemma refl_EMB : forall (A : Graph) (a : U), (A, a) <= (A, a).
Proof fun A a H => H eq (eq_gemb A) (refl_eq a).

(** At some time, we need to compose 4 embeddings *)
(** [comp4 R S T V] denotes the composed embedding *)

Definition comp4 (R S T V : Graph) (x y : U) :=
  (forall z1 z2 z3 : U, R x z1 -> S z1 z2 -> T z2 z3 -> V z3 y -> False) ->
  False.

Lemma comp4_top :
 forall (R S T V : Graph) (a b c d e : U),
 R a b -> S b c -> T c d -> V d e -> comp4 R S T V a e.
Proof fun R S T V a b c d e Hab Hbc Hcd Hde H => H b c d Hab Hbc Hcd Hde.

Lemma comp4_gemb :
 forall A B C D R S T V : Graph,
 A <= B [R] ->
 B <= C [S] -> C <= D [T] -> D <= A [V] -> A <= A [comp4 R S T V].
Proof
  fun A B C D R S T V HsubAB HsubBC HsubCD HsubDA a a' a0 Ha'a Haa0 H =>
  Haa0
    (fun b c d Hab Hbc Hcd Hda0 =>
     HsubAB a a' b Ha'a Hab
       (fun b' Ha'b' Hb'b =>
        HsubBC b b' c Hb'b Hbc
          (fun c' Hb'c' Hc'c =>
           HsubCD c c' d Hc'c Hcd
             (fun d' Hc'd' Hd'd =>
              HsubDA d d' a0 Hd'd Hda0
                (fun a0' Hd'a0' Ha0'a0 =>
                 H a0' (fun H' => H' b' c' d' Ha'b' Hb'c' Hc'd' Hd'a0')
                   Ha0'a0))))).

(** [comp2 R S] denotes the composition of R and S *)

Definition comp2 (R S : Graph) (x y : U) :=
  (forall z : U, R x z -> S z y -> False) -> False.

Infix "o" := comp2 (at level 30, right associativity).

Lemma comp2_top :
 forall (R S : Graph) (a b c : U), R a b -> S b c -> (R o S) a c.
Proof fun R S a b c Hab Hbc H => H b Hab Hbc.

Lemma comp2_gemb :
 forall A B C R S : Graph, A <= B [R] -> B <= C [S] -> A <= C [R o S].
Proof
  fun A B C R S HsubAB HsubBC a a' c Ha'a Hac H =>
  Hac
    (fun b Hab Hbc =>
     HsubAB a a' b Ha'a Hab
       (fun b' Ha'b' Hb'b =>
        HsubBC b b' c Hb'b Hbc
          (fun c' Hb'c' Hc'c => H c' (fun H' => H' b' Ha'b' Hb'c') Hc'c))).

(** [out_spec] provable in U but not provable in CIC

Lemma out_spec : forall (A:Graph) (a:U), i A a = out -> False.
Proof fun A a H => H (fun u => u (fun X A a => True) I).
*)

Axiom out_spec : forall (A : Graph) (a : U), i A a = out -> False.

(** Abstraction of EMB over the universes as a step towards
    proving injectivity of I which cannot be done in CIC *)

Definition GEMB (X : Type) (A : X -> X -> Set) (a : X)
  (Y : Type) (B : Y -> Y -> Set) (b : Y) :=
  (forall R : X -> Y -> Set,
   (forall (a a' : X) (b : Y),
    A a' a -> R a b -> (forall b' : Y, R a' b' -> B b' b -> False) -> False) ->
   R a b -> False) -> False.

(** [inj] provable in U but not in CIC
Lemma inj : forall (A B:Graph) (a b:U), (i A a)=(i B b) -> (A,a)<=(B,b).
Proof fun A B a b H =>
      (H (fun u:U => u (fun (Z:Type) (C:Z->Z->Prop) (c:Z) => GEMB U A a Z C c))
         (refl_EMB A a)).
*)

Axiom inj : forall (A B : Graph) (a b : U), i A a = i B b -> (A, a) <= (B, b).

Definition P0 (A : Graph) := forall a' : U, A a' out -> NOTEMB A out A a'.

Definition FOLDP0 (u v : U) :=
  (forall (B : Graph) (b b' : U), u = i B b' -> i B b = v -> B b' b -> False) ->
  (forall A : Graph, i A out = u -> v = out -> P0 A -> False) -> False.

Lemma injr : P0 FOLDP0 -> FOLDP0 (i FOLDP0 out) out.
Proof fun H _ H1 => H1 FOLDP0 (refl_eq (i FOLDP0 out)) (refl_eq out) H.

(** Reification from (A,a) into (FOLDP0,i(A,a)) *)

(** There is a bissimulation, that is a relation (REIFY A a) which
    satisfies gemb in both way and relates a and i(A,a) *)

Definition REIFY_sim (A : Graph) (a0 a u : U) :=
  (forall (B : Graph) (b : U),
   i B b = u -> forall R : Graph, A <= B [R] -> R a b -> False) -> False.

Definition REIFY_sim_rev (A : Graph) (a0 u a : U) :=
  (forall (B : Graph) (b : U),
   u = i B b -> forall R : Graph, B <= A [R] -> R b a -> False) -> False.

Lemma REIFY_gemb : forall (A : Graph) (a : U), A <= FOLDP0 [REIFY_sim A a].
Proof
  fun A0 a0 a a' u Ha'a HREIFYau H =>
  HREIFYau
    (fun B b Heq R Rsub Rtop =>
     Rsub a a' b Ha'a Rtop
       (fun b' HRa'b' Hb'b =>
        H (i B b') (fun H0 => H0 B b' (refl_eq (i B b')) R Rsub HRa'b')
          (fun Hl Hr => Hl B b b' (refl_eq (i B b')) Heq Hb'b))).

Lemma REIFY_gemb_rev :
 forall (A : Graph) (a : U), FOLDP0 <= A [REIFY_sim_rev A a].
Proof.
red in |- *; intros A0 a0 u u' a Hu'u HREIFYua H.
apply HREIFYua.
intros B b Heq R Rsub Rtop.
apply (Heq (fun u => FOLDP0 u' u) Hu'u).
2: intros C H1 H2 H3; apply out_spec with (A := B) (a := b); exact H2.
intros B0 b0 b0' Hequ' Hequb0 Hb0'b0.
apply (inj _ _ _ _ Hequb0).
red in |- *; intros R' R'sub R'top.
(* We have
               a  <=  b  <=  b0
                             |
                             b0'
                  |       |
             in A | in B  | in B0
                  |       |
*)
(* We successively find b' then a' s.t.

               a  <=  b  <=  b0
               |      |      |
               a' <=  b' <=  b0'
                  |       |
             in A | in B  | in B0
                  |       |
*)
apply (R'sub b0 b0' b Hb0'b0 R'top).
intros b' R'b0'b' Hb'b.
apply (Rsub b b' a Hb'b Rtop).
intros a' Rb'a' Ha'a.
apply
 (Hequ'
    (fun u' => forall b' : U, REIFY_sim_rev A0 a0 u' b' -> A0 b' a -> False)
    H a').
(* We prove (REIFY_sim_rev A0 a0 u' a') *)
red in |- *; intro H'.
apply
 (H' B0 b0' (refl_eq (i B0 b0')) (R' o R)
    (comp2_gemb B0 B A0 R' R R'sub Rsub)
    (comp2_top R' R b0' b' a' R'b0'b' Rb'a')).
exact Ha'a.
Qed.

Lemma REIFY_top : forall A : Graph, REIFY_sim A out out (i A out).
Proof
  fun (A : Graph) H =>
  H A out (refl_eq (i A out)) eq (eq_gemb A) (refl_eq out).

Lemma REIFY_top_rev : forall (A : Graph) (a : U), REIFY_sim_rev A a (i A a) a.
Proof
  fun (A : Graph) (a : U) H =>
  H A a (refl_eq (i A a)) eq (eq_gemb A) (refl_eq a).

(** Used in extraction to trace the infinite loop *)
Parameter f : forall A : Set, (A -> False) -> A -> False.

Lemma p : P0 FOLDP0 -> False.
Proof
  fun H =>
  H (i FOLDP0 out) (injr H) (REIFY_sim FOLDP0 out)
    (REIFY_gemb FOLDP0 out) (REIFY_top FOLDP0).

Lemma q : P0 FOLDP0.
Proof.
(* We assume there is some a s.t. "a FOLDP0 out" and "out EMB a" *)
(* i.e.
               out => a
                |
                a
*)
unfold P0, NOTEMB in |- *; intros a Hle Remb Remb_sub.
apply (f (Remb out a)). (* ... to trace the execution *)
intro Remb_top.
(* We apply the definition of "a FOLDP0 out" *)
apply Hle.
  (* Absurd case of FOLDP0, impossible because v==out *)
  unfold NOTEMB in |- *.
  intros B b b' H H0 H1.
  apply out_spec with (A := B) (a := b). exact H0.
(* From FOLDP0, we get B s.t. a==i(B,out) and P0(B) *)
(* "a' FOLDP0 a" and "a EMB a'" *)
intros B Heq H HP0.
(* By projecting "a FOLDP0 out" along "out EMB a" *)
(* we get B s.t. a==i(B,out) and P0(B) *)
(* i.e.
               out => a
                |     |
    i(B,out) == a  => a'
*)
apply (Remb_sub out a a Hle Remb_top).
apply (Heq (fun a => forall b' : U, Remb a b' -> FOLDP0 b' a -> False)).
intros a' Remb_top_aa' Hle'.
(* Since, we have (FOLDP0 a' i(B,out)), we get B0, b, b' s.t.

                                      out => a
                                       |     |
       b0  <=  i(B0,b0) == i(B,out) == a  => a'
       |                               |
       b0' <=    i(B0,b0')     ==      a'
            |
      in B0 |    i n    F O L D  P 0
            |
*)
apply Hle'.
2: intros C H1 H2 H3; apply out_spec with (A := B) (a := out); exact H2.
intros B0 b0 b0' Heqa' HeqB Hleb0.
apply (inj _ _ _ _ HeqB).
intros RB0B RBOB_sub RB0B_top_b0out.
(* Since i(B0,b0) == i(B,out), we get i(B0,b0) <= i(B,out) and then get
   b' below out in B

                                              out => a
           RB0B                                |     |
        out <=  b0  <= i(B0,b0) == i(B,out) == a  => a'
         |      |                              |
         b' <=  b0' <=   i(B0,b0')    ==       a'
             |       |
        in B | in B0 |    i n    F O L D  P 0
             |       |
*)
apply (RBOB_sub b0 b0' out Hleb0 RB0B_top_b0out).
intros b' RB0B_top_b0'b' Hleb'.
(* We get the contradiction, since out does not contain itself wrt B *)
unfold P0, NOTEMB in HP0.
(* That (B,out) => (B,b') comes from

          REIFY          Remb          REIFY_rev      RB0B
   (B,out)  => (FOLDP0,a) ==> (FOLDP0,a') ==> (B0,b0') ==> (B,b')
*)
apply
 (HP0 b' Hleb' (comp4 (REIFY_sim B out) Remb (REIFY_sim_rev B0 b0') RB0B)).
apply
 (comp4_gemb B FOLDP0 FOLDP0 B0 (REIFY_sim B out) Remb
    (REIFY_sim_rev B0 b0') RB0B (REIFY_gemb B out) Remb_sub
    (REIFY_gemb_rev B0 b0') RBOB_sub).
apply
 (comp4_top (REIFY_sim B out) Remb (REIFY_sim_rev B0 b0') RB0B out
    (i B out) (i B0 b0') b0' b' (REIFY_top B)
    (Heqa' (fun a' => Remb (i B out) a') Remb_top_aa')
    (REIFY_top_rev B0 b0') RB0B_top_b0'b').
Qed.

Theorem Russell : False.
Proof p q.

Extract Constant U => "Out | I of u".
Extract Constant out => "Out".
Extract Constant i => "fun x -> I x".

Extract Constant inj => "fun a b (h:eq) -> Obj.magic h __ (refl_EMB a)".
Extract Constant out_spec => "fun _ _ -> failwith ""Impossible""".

(** To trace the recursive loop *)
Extract Constant f => "fun x -> print_char '.'; flush stdout; x".

Extraction "russell.ml" refl_EMB Russell.


(** * Pseudofunctors *)
Require Import Category.Core Functor.Core.
Require Import Category.Morphisms FunctorCategory.Morphisms.
Require Import Functor.Composition.Core Functor.Identity.
Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws.
Require Import FunctorCategory.Core.

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

Local Open Scope morphism_scope.

Section pseudofunctor.
  Local Open Scope natural_transformation_scope.
  Context `{Funext}.

  Variable C : PreCategory.

  (** Quoting from nCatLab (http://ncatlab.org/nlab/show/pseudofunctor):

      Given bicategories [C] and [D], a pseudofunctor (or weak 2-functor,
      or just functor) [P : C → D] consists of:

      - for each object [x] of [C], an object [P_x] of [D];

      - for each hom-category [C(x,y)] in [C], a functor [P_{x,y} :
        C(x,y) → D(P_x, P_y)];

      - for each object [x] of [C], an invertible 2-morphism (2-cell)
        [P_{id_x} : id_{P_x} ⇒ P_{x,x}(id_x)];

      - for each triple [x],[y],[z] of [C]-objects, a isomorphism
        (natural in [f : x → y] and [g : y → z]) [P_{x,y,z}(f,g) :
        P_{x,y}(f);P_{y,z}(g) ⇒ P_{x,z}(f;g)];

      - for each hom-category [C(x,y)],
<<
                                    id_{Pₓ} ; P_{x, y}(f)
                                      //              \\
                                    //                  \\
        P_{idₓ} ; id_{P_{x,y}(f)} //                      \\  λ_{P_{x,y}(f)}
                                //                          \\
                               ⇙                              ⇘
              Pₓ,ₓ(idₓ) ; P_{x,y}(f)                       P_{x,y}(f)
                               \\                             ⇗
                                 \\                         //
                P_{x,x,y}(idₓ, f)  \\                     // P_{x,y}(λ_f)
                                     \\                 //
                                       ⇘              //
                                        P_{x,y}(idₓ ; f)
>>

        and

<<
                                    P_{x, y}(f) ; id_{P_y}
                                      //              \\
                                    //                  \\
       id_{P_{x,y}(f)} ; P_{id_y} //                      \\  ρ_{P_{x,y}(f)}
                                //                          \\
                               ⇙                              ⇘
              P_{x,y}(f) ; P_{y,y}(id_y)                   P_{x,y}(f)
                               \\                             ⇗
                                 \\                         //
                P_{x,y,y}(f, id_y) \\                     // P_{x,y}(ρ_f)
                                     \\                 //
                                       ⇘              //
                                       P_{x,y}(f ; id_y)
>>
        commute; and

      - for each quadruple [w],[x],[y],[z] of [C]-objects,
<<
                                                  α_{P_{w,x}(f),P_{x,y}(g),P_{y,z}(h)}
        (P_{w,x}(f) ; P_{x,y}(g)) ; P_{y,z}(h) ========================================⇒ P_{w,x}(f) ; (P_{x,y}(g) ; P_{y,z}(h))
                                         ∥                                                   ∥
                                         ∥                                                   ∥
        P_{w,x,y}(f,g) ; id_{P_{y,z}(h)} ∥                                                   ∥ id_{P_{w,x}(f)} ; P_{x,y,z}(g, h)
                                         ∥                                                   ∥
                                         ⇓                                                   ⇓
                   P_{w,y}(f ; g) ; P_{y,z}(h)                                           P_{w,x}(f) ; P_{x,z}(g ; h)
                                         ∥                                                   ∥
                                         ∥                                                   ∥
                     P_{w,y,z}(f ; g, h) ∥                                                   ∥ P_{w,x,z}(f, g ; h)
                                         ∥                                                   ∥
                                         ⇓                                                   ⇓
                          P_{w,z}((f ; g) ; h) ========================================⇒ P_{w,z}(f ; (g ; h))
                                                          P_{w,z}(α_{f,g,h})
>>
        commutes.
*)

  (* To obtain the [p_composition_of_coherent] type, I ran
<<
  Unset Implicit Arguments.
  Variable F : Pseudofunctor.
  Goal forall (w x y z : C) (f : morphism C w x) (g : morphism C x y) (h : morphism C y z), Type.
  Proof.
    intros.
    pose ((idtoiso (_ -> _) (ap (p_morphism_of F w z) (associativity C _ _ _ _ f g h))) : morphism _ _ _).
    pose ((p_composition_of F w y z h (g ∘ f)) : NaturalTransformation _ _).
    pose (p_morphism_of F y z h ∘ p_composition_of F w x y g f).

    pose (associator_1 (p_morphism_of F y z h) (p_morphism_of F x y g) (p_morphism_of F w x f)).
    pose (p_composition_of F x y z h g ∘ p_morphism_of F w x f).
    pose ((p_composition_of F w x z (h ∘ g) f) : NaturalTransformation _ _).
    simpl in *.
    repeat match goal with
             | [ H : _, H' : _ |- _ ] => unique_pose_with_body (NTComposeT H H'); subst H H'
           end.
    match goal with
      | [ H := _, H' := _ |- _ ] => assert (H = H'); subst H H'
    end.
>>

<<
  Unset Implicit Arguments.
  Variable F : Pseudofunctor.
  Goal forall (x y : C) (f : morphism C x y), Type.
  Proof.
    intros.
    pose (p_identity_of F y ∘ p_morphism_of F x y f).
    pose (p_composition_of F x y y (Identity y) f : NaturalTransformation _ _).
    pose (idtoiso (_ -> _) (ap (p_morphism_of F x y) (left_identity _ _ _ f)) : morphism _ _ _).
    pose (left_identity_natural_transformation_2 (p_morphism_of F x y f)).
    simpl in *.
    repeat match goal with
             | [ H : _, H' : _ |- _ ] => unique_pose_with_body (NTComposeT H H'); subst H H'
           end.
    match goal with
      | [ H := _, H' := _ |- _ ] => assert (H = H'); subst H H'
    end.
>>

<<
  Unset Implicit Arguments.
  Variable F : Pseudofunctor.
  Goal forall (x y : C) (f : morphism C x y), Type.
  Proof.
    intros.
    pose (p_morphism_of F x y f ∘ p_identity_of F x).
    pose (p_composition_of F x x y f (Identity x) : NaturalTransformation _ _).
    pose (idtoiso (_ -> _) (ap (p_morphism_of F x y) (right_identity _ _ _ f)) : morphism _ _ _).
    pose (right_identity_natural_transformation_2 (p_morphism_of F x y f)).
    simpl in *.
    repeat match goal with
             | [ H : _, H' : _ |- _ ] => unique_pose_with_body (NTComposeT H H'); subst H H'
           end.
    match goal with
      | [ H := _, H' := _ |- _ ] => assert (H = H'); subst H H'
    end.
>>
 *)

  Record Pseudofunctor :=
    {
      p_object_of :> C -> PreCategory;
      p_morphism_of : forall s d, morphism C s d
                                  -> Functor (p_object_of s) (p_object_of d);
      p_composition_of : forall s d d'
                                (m1 : morphism C d d') (m2 : morphism C s d),
                           (p_morphism_of _ _ (m1 o m2))
                             <~=~> (p_morphism_of _ _ m1 o p_morphism_of _ _ m2)%functor;
      p_identity_of : forall x, p_morphism_of x x 1 <~=~> 1%functor;
      p_composition_of_coherent
      : forall w x y z
               (f : morphism C w x) (g : morphism C x y) (h : morphism C y z),
          ((associator_1 (p_morphism_of y z h) (p_morphism_of x y g) (p_morphism_of w x f))
             o ((p_composition_of x y z h g oR p_morphism_of w x f)
                  o (p_composition_of w x z (h o g) f)))
          = ((p_morphism_of y z h oL p_composition_of w x y g f)
               o ((p_composition_of w y z h (g o f))
                    o (Category.Morphisms.idtoiso (_ -> _) (ap (p_morphism_of w z) (Category.Core.associativity C w x y z f g h)) : morphism _ _ _)));
      p_left_identity_of_coherent
      : forall x y (f : morphism C x y),
          ((p_identity_of y oR p_morphism_of x y f)
             o p_composition_of x y y 1 f)
          = ((left_identity_natural_transformation_2 (p_morphism_of x y f))
               o (Category.Morphisms.idtoiso (_ -> _) (ap (p_morphism_of x y) (Category.Core.left_identity C x y f)) : morphism _ _ _));
      p_right_identity_of_coherent
      : forall x y (f : morphism C x y),
          ((p_morphism_of x y f oL p_identity_of x)
             o p_composition_of x x y f 1)
          = ((right_identity_natural_transformation_2 (p_morphism_of x y f))
               o (Category.Morphisms.idtoiso (_ -> _) (ap (p_morphism_of x y) (Category.Core.right_identity C x y f)) : morphism _ _ _))
    }.
End pseudofunctor.

Declare Scope pseudofunctor_scope.
Delimit Scope pseudofunctor_scope with pseudofunctor.
Bind Scope pseudofunctor_scope with Pseudofunctor.

Create HintDb pseudofunctor discriminated.

Arguments p_object_of {_} {C%category} F%pseudofunctor / c%object : rename.
Arguments p_morphism_of {_} {C%category} F%pseudofunctor / {s d}%object m%morphism : rename.

(*Notation "F ₀ x" := (p_object_of F x) : object_scope.
Notation "F ₁ m" := (p_morphism_of F m) : morphism_scope.*)


Definition transport {A} (P : A -> Type) {x y : A} (e : x = y) : P x -> P y
  := fun u => eq_rect x P u y e.

Notation "p # x" := (transport _ p x) (right associativity, at level 65).

(* to convert some eq_rects into transports *)
Lemma eq_rect_transport A x P u y p
  : @eq_rect A x P u y p = transport P p u.
Proof. reflexivity. Defined.


Require Import SystemT.

Set Default Goal Selector "!".

Tactic Notation "take" "step" := eapply Relation_Operators.rt1n_trans.
Ltac iterate := match goal with
                | |- iter _ _ zero |-> _ =>
                  apply step_iter2
                | |- iter _ _ (succ _) |-> _ =>
                  apply step_iter3; [ now auto ]
                | |- iter _ _ _ |-> _ =>
                  apply step_iter1
                end.
Tactic Notation "succ" "steps" := repeat apply step_s.
Ltac finish := match goal with
               | |- ?a |->* ?a =>
                 apply Relation_Operators.rt1n_refl
               end.

Section AddExample.

  Definition add Gamma (n m: expr Gamma natTy) : expr Gamma natTy :=
    iter m (succ (var var_here)) n.

  Example add_2_3 : add (Gamma:=[]) (succ (succ zero)) (succ (succ (succ zero))) |->*
                        (succ (succ (succ (succ (succ zero))))).
  Proof.
    unfold add.
    take step.
    { iterate. }
    cbn.
    take step.
    { succ steps.
      iterate. }
    cbn.
    take step.
    { succ steps.
      iterate. }
    finish.
  Qed.

End AddExample.

(* Local Variables: *)
(* company-coq-local-symbols: (("Gamma" . ?Γ) ("gamma" . ?γ)) *)
(* End: *)


Require Import Braun.monad.monad.

Require Import Braun.common.sequence.
Require Import Braun.common.list_util.

Require Import Braun.common.braun.
Require Import Braun.common.util.
Require Import Braun.common.le_util.
Require Import Braun.common.big_oh.
Require Import Braun.common.pow.

Require Import List Omega.

Definition cinterleave_time_best (n:nat) (m:nat) :=
  3 + 9 * (min n m).
Definition cinterleave_time_worst (n:nat) (m:nat) :=
  3 + 9 * (n + m).

Definition cinterleave_result (A:Set) (e:list A) (o:list A) (xs:list A) (c:nat) :=
  xs = interleave e o /\
  cinterleave_time_best (length e) (length o)
  <= c <= cinterleave_time_worst (length e) (length o).

Load "cinterleave_gen.v".

Next Obligation.
Proof.
  clear cinterleave.
  unfold cinterleave_result, cinterleave_time_best, cinterleave_time_worst.
  rewrite interleave_nil2. split. auto.
  simpl. omega.
Qed.

Next Obligation.
Proof.
  clear cinterleave.
  unfold cinterleave_result, cinterleave_time_best, cinterleave_time_worst.
  simpl. rewrite app_length. rewrite app_length. omega.
Qed.

Next Obligation.
Proof.
  clear cinterleave.
  unfold cinterleave_result, cinterleave_time_best, cinterleave_time_worst in *.
  clear am H1.
  rename H0 into REC_P.
  destruct REC_P as [EQ REC_P].
  subst xsp.
  rewrite interleave_case2. split. auto.
  simpl length.
  replace (S (length xs) + length o) with (S (length o + length xs)); try omega.
  remember (length o + length xs) as L.
  rewrite Mult.mult_succ_r.
  rewrite Min.min_comm.
  destruct (Min.min_spec (length o) (length xs)) as [[LT EQ] | [LT EQ]].
  rewrite EQ in REC_P.
  rewrite Min.min_l. omega. omega.
  rewrite EQ in REC_P.
  apply Min.min_case_strong; intros LE.
  omega.
  omega.
Qed.

Fixpoint tln_time n :=
  match n with
    | O =>
      3
    | S n' =>
      15 + (3 + 9 * n') + 2 * tln_time n'
  end.

Lemma tln_time_bigger:
  forall tn,
    3 <= tln_time tn.
Proof.
  induction tn as [|tn]; simpl; omega.
Qed.

Lemma tln_time_split:
  forall sn tn,
    tln_time sn + tln_time tn <= 2 * tln_time (sn + tn).
Proof.
  induction sn as [|sn]; simpl; intros tn.
  remember (tln_time_bigger tn) as P. omega.

  assert (tln_time sn + tln_time tn <= 2 * tln_time (sn + tn)) as LE.
  auto. omega.
Qed.

Definition to_list_naive_result (A:Set) b (xs:list A) (c:nat) :=
  SequenceR b xs
  /\ c <= tln_time (length xs).

Load "to_list_naive_gen.v".

Next Obligation.
Proof.
  unfold to_list_naive_result. simpl.
  split. eauto. auto.
Qed.

Next Obligation.
Proof.
  clear am0 H5 am1 H4.
  clear am H3.
  unfold to_list_naive_result in *.
  destruct H1 as [SEQt ANt].
  destruct H2 as [SEQs ANs].
  unfold cinterleave_result, cinterleave_time_best, cinterleave_time_worst in *.
  destruct H0 as [EQxs ANi].
  subst xs.
  simpl length.
  rewrite <- interleave_length_split.
  remember (length sl) as sn.
  remember (length tl) as tn.
  split; eauto.
  clear SEQs SEQt A x s t sl tl Heqtn Heqsn.
  remember (an + 15) as p.
  replace (an1 + (an0 + p)) with
          (p + (an1 + an0)); try omega.
  replace (tln_time (S (sn + tn))) with
    (15 + (3 + 9 * (sn + tn)) + 2 * tln_time (sn + tn)); try auto.
  subst p.
  replace (an + 15 + (an1 + an0)) with (15 + an + (an0 + an1)); try omega.
  apply le_add.
  apply le_add. auto. omega.

  apply Le.le_trans with (tln_time sn + tln_time tn); try omega.
  apply tln_time_split.
Qed.

Theorem tln_time_big_oh:
  big_oh tln_time (fun n => pow 3 n).
Proof.
  unfold big_oh.
  exists 0. exists 18.
  intros n _. generalize n. clear n.
  induction n as [|n].
  simpl. omega.
  replace (tln_time (S n)) with (15 + (3 + 9 * n) + 2 * tln_time n); try auto.
  simpl pow.
  replace (18 * (pow 3 n + (pow 3 n + (pow 3 n + 0))))
    with (18 * pow 3 n + 2 * 18 * pow 3 n); try omega.
  apply le_add. clear IHn.
  replace (15 + (3 + 9 * n)) with (9 * n + 18); try omega.

  induction n as [|n]. simpl. auto.
  simpl pow. rewrite Mult.mult_succ_r.
  replace (9 * n + 9 + 18) with (9 + (9 * n + 18)); try omega.
  rewrite <- Mult.mult_assoc.
  apply le_mult. auto.
  auto.
Qed.


(**************************************************************************)
(*  This is part of EXCEPTIONS-CL, it is distributed under the terms of   *)
(*         the GNU Lesser General Public License version 3                *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Import Le Gt Minus Bool Setoid.
Set Implicit Arguments.

Module Type T.

 Parameter EName: Type.
 Parameter Val: EName -> Type.
 Parameter Exc_dec: forall i j: EName, {i=j}+{i<>j}.
 Inductive empty_set : Type :=.
 Inductive unit: Type := unt.

End T.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Functor.Bifunctor.
Require Export Category.Structure.Monoidal.
Require Export Category.Structure.Monoidal.Internal.Product.
Require Import Category.Structure.Cartesian.Closed.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section MonoidObject.

Context {C : Category}.
Context `{M : @Monoidal C}.

Class MonoidObject (mon : C) := {
mempty  : I ~> mon;
mappend : mon ⨂ mon ~> mon;

mempty_left : mappend ∘ bimap mempty id ≈ to (@unit_left C _ mon);
mempty_right : mappend ∘ bimap id mempty ≈ to (@unit_right C _ mon);

mappend_assoc :
mappend ∘ bimap mappend id ≈ mappend ∘ bimap id mappend ∘ to tensor_assoc
}.

Context (mon : C).
Context `{@MonoidObject mon}.

Lemma mappend_assoc_sym :
mappend ∘ bimap id mappend ≈ mappend ∘ bimap mappend id ∘ (tensor_assoc ⁻¹).
Proof. hammer_hook "Monoid" "Monoid.mappend_assoc_sym".
rewrite mappend_assoc.
rewrite <- comp_assoc.
rewrite iso_to_from.
cat.
Qed.

End MonoidObject.

Notation "mempty[ M ]" := (@mempty _ _ _ M)
(at level 9, format "mempty[ M ]") : category_scope.
Notation "mappend[ M ]" := (@mappend _ _ _ M)
(at level 9, format "mappend[ M ]") : category_scope.

Section Monoid.

Context {C : Category}.
Context `{@Cartesian C}.
Context `{@Terminal C}.

Definition Monoid := @MonoidObject C InternalProduct_Monoidal.

Global Program Instance Product_Monoid `(X : Monoid x) `(Y : Monoid y) :
@MonoidObject C InternalProduct_Monoidal (x × y) := {|
mempty  := @mempty _ _ _ X △ @mempty _ _ _ Y;
mappend := split (@mappend _ _ _ X) (@mappend _ _ _ Y) ∘ toggle
|}.
Next Obligation.
spose (@mempty_left _ _ _ X) as HX.
spose (@mempty_left _ _ _ Y) as HY.
assert ((mempty[X] △ mempty[Y] ∘ exl) △ (id[x × y] ∘ exr)
≈ split (mempty[X] △ mempty[Y]) id[x × y])
by (unfork; cat).
rewrite X0; clear X0.
unfold toggle.
rewrite <- !comp_assoc.
rewrite <- fork_comp.
rewrite !split_comp.
rewrite exl_fork, exr_fork.
rewrite !id_right.
rewrite <- (id_right mempty[X]).
rewrite <- (id_left exl).
rewrite <- (id_right mempty[Y]).
rewrite <- (id_left exr).
rewrite <- !split_comp.
rewrite split_fork.
rewrite !comp_assoc.
rewrite HX, HY.
unfold split; cat.
now rewrite fork_comp; cat.
Qed.
Next Obligation.
spose (@mempty_right _ _ _ X) as HX.
spose (@mempty_right _ _ _ Y) as HY.
assert ((id[x × y] ∘ exl) △ (mempty[X] △ mempty[Y] ∘ exr)
≈ split id[x × y] (mempty[X] △ mempty[Y]))
by (unfork; cat).
rewrite X0; clear X0.
unfold toggle.
rewrite <- !comp_assoc.
rewrite <- fork_comp.
rewrite !split_comp.
rewrite exl_fork, exr_fork.
rewrite !id_right.
rewrite <- (id_right mempty[X]).
rewrite <- (id_left exl).
rewrite <- (id_right mempty[Y]).
rewrite <- (id_left exr).
rewrite <- !split_comp.
rewrite split_fork.
rewrite !comp_assoc.
rewrite HX, HY.
unfold split; cat.
now rewrite fork_comp; cat.
Qed.
Next Obligation.
spose (@mappend_assoc _ _ _ X) as HX.
spose (@mappend_assoc _ _ _ Y) as HY.
assert ((split mappend[X] mappend[Y] ∘ toggle ∘ exl) △ (id[x × y] ∘ exr)
≈ split (split mappend[X] mappend[Y] ∘ toggle) id[x × y])
by (unfork; cat).
rewrite X0; clear X0.
assert ((id[x × y] ∘ exl) △ (split mappend[X] mappend[Y] ∘ toggle ∘ exr)
≈ split id[x × y] (split mappend[X] mappend[Y] ∘ toggle))
by (unfork; cat).
rewrite X0; clear X0.
unfold toggle.
rewrite !split_fork.
rewrite <- !fork_comp.
rewrite <- !comp_assoc.
rewrite !split_fork.
rewrite !id_left.
rewrite !comp_assoc.
rewrite !exl_fork.
rewrite !exr_fork.
rewrite <- !comp_assoc.
rewrite !split_comp.
rewrite !exl_fork.
rewrite !exr_fork.
rewrite !id_right.
rewrite <- (id_left (exl (x:=x) (y:=y))) at 1.
rewrite <- (id_left (exr (x:=x) (y:=y))) at 1.
rewrite <- !split_comp.
rewrite !comp_assoc.
rewrite HX, HY.
rewrite !id_left.
apply fork_respects; clear;
now unfold split; unfork; cat.
Qed.

Context `{@Closed C _}.

Definition doppel {x y z : C} : x × y × z ~> x × z × (y × z) :=
first exl △ first exr.

Lemma uncurry_exl_fork_exr {x y : C} :
uncurry exl △ uncurry exr ≈ split eval eval ∘ @doppel (y ^ x) (y ^ x) x.
Proof. hammer_hook "Monoid" "Monoid.uncurry_exl_fork_exr".
unfold doppel.
rewrite split_fork.
now rewrite !eval_first.
Qed.

Global Program Instance Hom_Monoid {x} `(Y : Monoid y) :
@MonoidObject C InternalProduct_Monoidal (y ^ x) := {
mempty  := curry (@mempty _ _ _ Y ∘ exl);
mappend := curry (@mappend _ _ _ Y ∘ uncurry exl △ uncurry exr)
}.
Next Obligation.
spose (@mempty_left _ _ _ Y) as HY.
remember ((curry _ ∘ exl) △ (id[y ^ x] ∘ exr)) as h.
assert (h ≈ split (curry (mempty[Y] ∘ exl)) id[y ^ x])
by (rewrite Heqh; unfork; cat).
rewrite X; clear X Heqh h.
rewrite uncurry_exl_fork_exr.
unfold doppel.
rewrite split_fork.
rewrite curry_comp_l.
rewrite <- comp_assoc.
rewrite <- fork_comp.
rewrite <- !comp_assoc.
rewrite <- !first_comp.
rewrite exl_split.
rewrite exr_split.
rewrite !eval_first.
rewrite !uncurry_comp.
rewrite !uncurry_curry.
rewrite <- !comp_assoc.
rewrite !exl_first.
rewrite <- split_fork.
rewrite <- (id_right mempty[Y]) at 1.
rewrite <- (id_left (uncurry id[y ^ x])).
rewrite <- split_comp.
rewrite !comp_assoc.
rewrite HY; clear HY.
rewrite <- comp_assoc.
rewrite split_fork.
rewrite exr_fork.
rewrite eval_first.
now rewrite curry_uncurry.
Qed.
Next Obligation.
spose (@mempty_right _ _ _ Y) as HY.
remember ((id[y ^ x] ∘ exl) △ (curry _ ∘ exr)) as h.
assert (h ≈ split id[y ^ x] (curry (mempty[Y] ∘ exl)))
by (rewrite Heqh; unfork; cat).
rewrite X; clear X Heqh h.
rewrite uncurry_exl_fork_exr.
unfold doppel.
rewrite split_fork.
rewrite curry_comp_l.
rewrite <- comp_assoc.
rewrite <- fork_comp.
rewrite <- !comp_assoc.
rewrite <- !first_comp.
rewrite exl_split.
rewrite exr_split.
rewrite !eval_first.
rewrite !uncurry_comp.
rewrite !uncurry_curry.
rewrite <- !comp_assoc.
rewrite !exl_first.
rewrite <- split_fork.
rewrite <- (id_right mempty[Y]) at 1.
rewrite <- (id_left (uncurry id[y ^ x])).
rewrite <- split_comp.
rewrite !comp_assoc.
rewrite HY; clear HY.
rewrite <- comp_assoc.
rewrite split_fork.
rewrite exl_fork.
rewrite eval_first.
now rewrite curry_uncurry.
Qed.
Next Obligation.
spose (@mappend_assoc _ _ _ Y) as HY.
rewrite uncurry_exl_fork_exr.
remember ((curry _ ∘ exl) △ (id[y ^ x] ∘ exr)) as h.
assert (h ≈ split (curry (mappend[Y] ∘ split eval eval ∘ doppel)) id[y ^ x])
by (rewrite Heqh; unfork; cat).
rewrite X; clear X Heqh h.
remember ((id[y ^ x] ∘ exl) △ (curry _ ∘ exr)) as h.
assert (h ≈ split id[y ^ x] (curry (mappend[Y] ∘ split eval eval ∘ doppel)))
by (rewrite Heqh; unfork; cat).
rewrite X; clear X Heqh h.
unfold doppel.
rewrite <- !comp_assoc.
rewrite !split_fork.
rewrite !eval_first.
simpl.
rewrite split_fork.
rewrite !eval_first.
unfold split.
rewrite !id_left.
rewrite !curry_comp_l.
rewrite <- !comp_assoc.
rewrite <- !fork_comp.
rewrite <- !uncurry_comp.
rewrite exl_fork.
rewrite exr_fork.
rewrite !uncurry_curry.
rewrite <- (id_left (uncurry exr)).
rewrite <- split_fork.
rewrite comp_assoc.
rewrite HY; clear HY.
rewrite id_left.
rewrite <- !comp_assoc.
rewrite <- !fork_comp.
rewrite <- !comp_assoc.
rewrite !exl_fork.
rewrite !exr_fork.
now rewrite uncurry_curry.
Qed.

End Monoid.


(** * Equivalence on syntax *)
Require Import Coq.Lists.List.
Require Import Fiat.Parsers.Reflective.Syntax.

Local Open Scope list_scope.

Section Term_equiv.
  Context (var1 var2 : TypeCode -> Type).

  Definition vpair := { t : TypeCode & var1 t * var2 t }%type.
  Definition vars t (x1 : var1 t) (x2 : var2 t) : vpair := existT _ _ (x1, x2).
  Definition ctxt := list vpair.

  Local Unset Elimination Schemes.
  Inductive Term_equiv : ctxt -> forall {t}, Term var1 t -> Term var2 t -> Prop :=
  | EqVar : forall G t (v1 : var1 t) v2,
    List.In (vars v1 v2) G
    -> Term_equiv G (#v1) (#v2)

  | EqLiteralApp : forall G T f v1 v2,
      args_for_related_ind (@Term_equiv G) v1 v2
      -> Term_equiv G (@RLiteralApp var1 T f v1) (@RLiteralApp var2 T f v2)

  | EqApp : forall G t1 t2 (f1 : Term _ (t1 --> t2)) (x1 : Term _ t1) f2 x2,
    Term_equiv G f1 f2
    -> Term_equiv G x1 x2
    -> Term_equiv G (f1 @ x1) (f2 @ x2)
  | EqLambda : forall G t1 t2 (f1 : var1 t1 -> Term var1 t2) f2,
    (forall v1 v2, Term_equiv (vars v1 v2 :: G) (f1 v1) (f2 v2))
    -> Term_equiv G (RLambda f1) (RLambda f2).

  Section ind_in.
    Context (P : ctxt -> forall t, Term var1 t -> Term var2 t -> Prop)
            (EqVarCase : forall G t v1 v2,
                In (vars v1 v2) G -> P G t (#v1)%term (#v2)%term)
            (EqLiteralAppCase : forall G T f v1 v2,
                args_for_related_ind (@Term_equiv G) v1 v2
                -> (forall A vv1 vv2, @aIn2 _ _ A _ vv1 vv2 v1 v2
                                      -> P G A vv1 vv2)
                -> P G (range_of T) (RLiteralApp f v1) (RLiteralApp f v2))
            (EqAppCase : forall G t1 t2 f1 x1 f2 x2,
                Term_equiv G f1 f2
                -> P G (t1 --> t2)%typecode f1 f2
                -> Term_equiv G x1 x2
                -> P G t1 x1 x2
                -> P G t2 (f1 @ x1)%term (f2 @ x2)%term)
            (EqLambdaCase : forall G t1 t2 f2 f3,
                (forall v1 v2, Term_equiv (vars v1 v2 :: G) (f2 v1) (f3 v2))
                -> (forall v1 v2, P (vars v1 v2 :: G) t2 (f2 v1) (f3 v2))
                -> P G (t1 --> t2)%typecode (\ x, f2 x)%term (\ x, f3 x)%term).

    Fixpoint Term_equiv_ind_in (c : ctxt) (t : TypeCode) (t0 : Term var1 t) (t1 : Term var2 t)
             (H : @Term_equiv c t t0 t1)
      : @P c t t0 t1.
    Proof.
      refine match H in @Term_equiv c t t0 t1 return @P c t t0 t1 with
             | EqVar G t v1 v2 x => EqVarCase _ _ _ x
             | EqLiteralApp G T f v1 v2 x => EqLiteralAppCase _ x _
             | EqApp G t1 t2 f1 x1 f2 x2 x x0 => EqAppCase
                                                   x
                                                   (@Term_equiv_ind_in _ _ _ _ x)
                                                   x0
                                                   (@Term_equiv_ind_in _ _ _ _ x0)
             | EqLambda G t1 t2 f1 f2 x => EqLambdaCase _ _ x (fun v1 v2 => @Term_equiv_ind_in _ _ _ _ (x v1 v2))
             end.
      clear f.
      induction x as [A B ?? x xs e es IHxs|].
      { specialize (Term_equiv_ind_in G _ _ _ e).
        simpl.
        intros ??? [[pf [H0 H1]]|H'].
        { destruct pf, H0, H1; simpl.
          exact Term_equiv_ind_in. }
        { apply IHxs; assumption. } }
      { simpl.
        intros ??? []. }
    Qed.
  End ind_in.

  Section ind.
    Context (P : ctxt -> forall t, Term var1 t -> Term var2 t -> Prop)
            (EqVarCase : forall G t v1 v2,
                In (vars v1 v2) G -> P G t (#v1)%term (#v2)%term)
            (EqLiteralAppCase : forall G T f v1 v2,
                args_for_related_ind (@Term_equiv G) v1 v2
                -> args_for_related_ind (@P G) v1 v2
                -> P G (range_of T) (RLiteralApp f v1) (RLiteralApp f v2))
            (EqAppCase : forall G t1 t2 f1 x1 f2 x2,
                Term_equiv G f1 f2
                -> P G (t1 --> t2)%typecode f1 f2
                -> Term_equiv G x1 x2
                -> P G t1 x1 x2
                -> P G t2 (f1 @ x1)%term (f2 @ x2)%term)
            (EqLambdaCase : forall G t1 t2 f2 f3,
                (forall v1 v2, Term_equiv (vars v1 v2 :: G) (f2 v1) (f3 v2))
                -> (forall v1 v2, P (vars v1 v2 :: G) t2 (f2 v1) (f3 v2))
                -> P G (t1 --> t2)%typecode (\ x, f2 x)%term (\ x, f3 x)%term).

    Fixpoint Term_equiv_ind (c : ctxt) (t : TypeCode) (t0 : Term var1 t) (t1 : Term var2 t)
             (H : @Term_equiv c t t0 t1)
      : @P c t t0 t1.
    Proof.
      refine match H in @Term_equiv c t t0 t1 return @P c t t0 t1 with
             | EqVar G t v1 v2 x => EqVarCase _ _ _ x
             | EqLiteralApp G T f v1 v2 x => EqLiteralAppCase _ x _
             | EqApp G t1 t2 f1 x1 f2 x2 x x0 => EqAppCase
                                                   x
                                                   (@Term_equiv_ind _ _ _ _ x)
                                                   x0
                                                   (@Term_equiv_ind _ _ _ _ x0)
             | EqLambda G t1 t2 f1 f2 x => EqLambdaCase _ _ x (fun v1 v2 => @Term_equiv_ind _ _ _ _ (x v1 v2))
             end.
      clear f.
      induction x as [A B ?? x xs e es IHxs|].
      { specialize (Term_equiv_ind G _ _ _ e).
        simpl.
        constructor.
        { exact Term_equiv_ind. }
        { exact IHxs. } }
      { simpl.
        constructor. }
    Qed.
  End ind.
End Term_equiv.

Arguments vars {var1 var2 t} _ _.
(*
Definition invert_args_for_equiv {var1 var2 G T v1 v2}
           (H : @args_for_equiv var1 var2 G T v1 v2)
  : match T return args_for var1 T -> args_for var2 T -> Prop
    with
    | csimple _ => fun v1 v2 => v1 = noargs /\ v2 = noargs
    | carrow A B
      => fun v1 v2
         => exists h1 t1 h2 t2,
             v1 = an_arg h1 t1 /\ v2 = an_arg h2 t2
             /\ Term_equiv G h1 h2
             /\ args_for_equiv G t1 t2
    end v1 v2.
Proof.
  destruct H; repeat esplit; assumption.
Defined.
*)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Extraction.

(** Autogenerated False_rect uses singleton elimination (SE) *)

Check False_rect.
Print False_rect.
Recursive Extraction False_rect.

Extract Inductive unit => "unit" [ "()" ].

(** But we can build False_elim without SE *)

Section False_elim_Acc.

  Variable (X : Type).

  Let R : unit -> unit -> Prop := fun _ _ => True.

  Theorem False_elim0 : False -> X.
  Proof.
    intros C.
    apply Fix_F with (P := fun _ => X) (R := R) (x := tt).
    + intros x H; apply (H tt), I.
    + destruct C.
  Defined.

End False_elim_Acc.

Check False_elim0.
Print False_elim0.
Recursive Extraction False_elim0.

Section False_elim_inline_Fix_F.

  Variable (X : Type).

  Let R : unit -> unit -> Prop := fun _ _ => True.

  Let loop : forall x, Acc R x -> X.
  Proof.
    refine (fix loop x Hx := loop tt _).
    destruct Hx; apply H, I.
  Defined.

  Theorem False_elim1 : False -> X.
  Proof.
    intros C; apply (loop tt).
    destruct C.
  Defined.

End False_elim_inline_Fix_F.

Check False_elim1.
Print False_elim1.
Recursive Extraction False_elim1.

Fixpoint False_elim2 X (C : False) : X := False_elim2 X (match C with end).

Check False_elim2.
Print False_elim2.
Recursive Extraction False_elim2.

Definition False_elim3 X : False -> X.
Proof.
  generalize tt.
  exact (fix loop (_ : unit) (C : False) : X := loop tt (match C with end)).
Defined.

Check False_elim3.
Print False_elim3.
Recursive Extraction False_elim3.

Fixpoint False_elim4 X Y (x : X) (C : False) : Y :=
   False_elim4 _ _ x (match C with end).

Check False_elim4.
Print False_elim4.
Recursive Extraction False_elim4.