Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
(* Require Import Coq.Logic.FunctionalExtensionality. *)

Require Export functor.
Require Import identity.

Open Scope program_scope.
Open Scope functor_scope.

Lemma equal_f : forall {A B : Type} {f g : A -> B},
  f = g -> forall x, f x = g x.
Proof. intros; rewrite H; auto. Qed.

(** Monads (return and bind). *)
Class Return (T : Type -> Type) : Type :=
  ret : forall {A}, A -> T A.

Class Bind (T : Type -> Type) : Type :=
  bind : forall {A B}, T A -> (A -> T B) -> T B.

Notation "f =<< g" := (bind g f) (at level 60) : monad_scope.
Notation "f << g" := (bind g (fun _ => f)) (at level 60) : monad_scope.
Notation "f >>= g" := (bind f g) (at level 60) : monad_scope.
Notation "f >> g" := (bind f (fun _ => g)) (at level 60) : monad_scope.

Notation "x <-- f ; m" := (bind f (fun x => m))
  (at level 100, right associativity, only parsing) : monad_scope.
Notation "f ;; m" := (bind f (fun _ => m))
  (at level 100, right associativity, only parsing) : monad_scope.

Open Scope monad_scope.

Class Monad (T : Type -> Type) `{Functor T} {r : Return T} {b : Bind T}
  : Prop :=
  { monad_left_id : forall A B x (f : A -> T B), ret x >>= f = f x
  ; monad_right_id : forall A (m : T A), m >>= ret = m
  ; monad_assoc : forall A B C (m : T A) (f : A -> T B) (g : B -> T C),
      (m >>= f) >>= g = m >>= (fun x => f x >>= g)
}.

(** Composition of kleisli arrows. *)
Definition kleisli_comp {T : Type -> Type} `{Monad T} {A B C}
  : (A -> T B) -> (B -> T C) -> A -> T C :=
  fun f g x => f x >>= g.

Notation "f >=> g" := (kleisli_comp f g) (at level 60) : monad_scope.
Notation "f <=< g" := (kleisli_comp g f) (at level 60) : monad_scope.

(** Chickenbutt (applicative functor thing) *)
Definition ap {T : Type -> Type} `{Monad T} {A B}
  : T (A -> B) -> T A -> T B :=
  fun f m => f >>= fun g => g <$> m.

Notation "f <*> x" := (ap f x) (at level 60) : monad_scope.
Notation "x *> y" := (flip const x y) (at level 60) : monad_scope.
(* Notation "x <* y" := (const x y) (at level 60) : monad_scope. *)

Definition liftA2 {T : Type -> Type} `{Monad T} {A B C}
  : (A -> B -> C) -> T A -> T B -> T C :=
  fun f x y => ret f <*> x <*> y.

(*
Naturality condition for any α:

      F f
 F A  ->  F B

  |α      |α

 G A  ->  G B
      G f

G f ∘ α = α ∘ F f
*)

(** Monads in terms of return and join. Instances of the other monad
classes can be derived from this one, so it's probably good to define
a Jmonad instance whenever possible. It's also the closest to the
categorical definition of a monad as a monoid object in the category
of endofunctors (from whatever category we are in back to itself). *)

Class Join (T : Type -> Type) : Type :=
  join : forall {A}, T (T A) -> T A.

Notation "'μ'" := join : monad_scope.

(*
Naturality condition for return:

      f
 A   ->   B

 |η      |η

T A  ->  T B
     T f

I.e.,  F f ∘ η = η ∘ f

Naturality condition for join:

         T (T f)
 T (T A)   ->     T (T B)

   |μ               |μ

  T A      ->      T B
           T f

I.e.,  T f ∘ μ = μ ∘ T (T f)
*)

(* These laws seem a bit nicer when defined pointwise. *)
(* TODO: define the naturality conditions using the general definition
         of natural? *)
Class Jmonad (T : Type -> Type) `{Functor T} {r : Return T} {j : Join T}
  : Prop :=
  { jmonad_left_id : forall A (m : T A), μ (ret m) = m
  ; jmonad_right_id : forall A (m : T A), μ (ret <$> m) = m
  ; jmonad_assoc : forall A (m : T (T (T A))), μ (μ m) = μ (μ <$> m)
  ; jmonad_ret_nat : forall A B (f : A -> B), fmap f ∘ ret = ret ∘ f
  ; jmonad_bind_nat : forall A B (f : A -> B), fmap f ∘ μ = μ ∘ fmap (fmap f) }.

(* Construction of Monad instance from JMonad.*)
Instance Bind_join (T : Type -> Type) `{Functor T} `{Join T} : Bind T :=
  fun _ _ m f => μ (f <$> m).

(* It seems that we need the naturality conditions for this proof. *)
Instance Monad_Jmonad (T : Type -> Type) `{Jmonad T} : Monad T.
Proof.
  constructor.
  - intros A B x f.
    destruct H0.
    unfold bind, Bind_join.
    specialize (jmonad_ret_nat0 A (T B) f).
    eapply equal_f in jmonad_ret_nat0.
    unfold compose in jmonad_ret_nat0.
    rewrite jmonad_ret_nat0. auto.
  - intros A m.
    unfold bind, Bind_join.
    destruct H0; auto.
  - intros A B C m f g.
    unfold bind, Bind_join.
    destruct H0 as [_ _ Hassoc _ Hbind].
    unfold compose in Hbind.
    pose proof (Hbind B (T C) g) as H0.
    eapply equal_f in H0; rewrite H0.
    rewrite Hassoc; destruct H as [_ Hcomp].
    unfold compose in Hcomp.
    pose proof (Hcomp _ _ _ (fmap g ∘ f) μ) as H1.
    unfold compose in H1; rewrite H1.
    pose proof (Hcomp _ _ _ f (fmap g)) as H2.
    rewrite H2; auto.
Qed.

(* Construction of JMonad instance from Monad.*)
(* Instance Join_bind (T : Type -> Type) `{Functor T} `{Bind T} : Join T := *)
(*   fun _ m => bind m id. *)

(* Instance Jmonad_Monad (T : Type -> Type) `{Monad T} : Jmonad T. *)
(* Proof. *)
(*   constructor. *)
(*   - intros A m; unfold join, Join_bind; destruct H0; rewrite monad_left_id0; easy. *)
(*   - intros A m. unfold join, Join_bind. destruct H0. *)
(*     destruct H.  *)
(*     assert (forall x, ret x >>= id *)
(*     destruct r. *)

(* unfold ret. unfold fmap. *)
(* Admitted. *)

(** The identity monad. *)
Instance Return_id : Return id := fun _ => id.
Instance Join_id : Join id := fun _ => id.
Instance Jmonad_id : Jmonad id.
Proof. constructor; firstorder. Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Require Import NaryFunctions.
Require Import Wf_nat.
Require Export ZArith.
Require Export DoubleType.

(** * 31-bit integers *)

(** This file contains basic definitions of a 31-bit integer
  arithmetic. In fact it is more general than that. The only reason
  for this use of 31 is the underlying mecanism for hardware-efficient
  computations by A. Spiwack. Apart from this, a switch to, say,
  63-bit integers is now just a matter of replacing every occurrences
  of 31 by 63. This is actually made possible by the use of
  dependently-typed n-ary constructions for the inductive type
  [int31], its constructor [I31] and any pattern matching on it.
  If you modify this file, please preserve this genericity.  *)

(** GMALECHA: Replaced 31 -> 32 *)
Definition size := 32%nat.

(** Digits *)

Inductive digits : Type := D0 | D1.

(** The type of 32-bit integers *)

(** The type [int32] has a unique constructor [I32] that expects
   32 arguments of type [digits]. *)

Definition digits32 t := Eval compute in nfun digits size t.

Inductive int32 : Type := I32 : digits32 int32.

(*
(* spiwack: Registration of the type of integers, so that the matchs in
   the functions below perform dynamic decompilation (otherwise some segfault
   occur when they are applied to one non-closed term and one closed term). *)
Register digits as int32 bits in "coq_int32" by True.
Register int32 as int32 type in "coq_int32" by True.
*)

Delimit Scope int32_scope with int32.
Bind Scope int32_scope with int32.
Local Open Scope int32_scope.

(** * Constants *)

(** Zero is [I32 D0 ... D0] *)
Definition On : int32 := Eval compute in napply_cst _ _ D0 size I32.

(** One is [I32 D0 ... D0 D1] *)
Definition In : int32 := Eval compute in (napply_cst _ _ D0 (size-1) I32) D1.

(** The biggest integer is [I32 D1 ... D1], corresponding to [(2^size)-1] *)
Definition Tn : int32 := Eval compute in napply_cst _ _ D1 size I32.

(** Two is [I32 D0 ... D0 D1 D0] *)
Definition Twon : int32 := Eval compute in (napply_cst _ _ D0 (size-2) I32) D1 D0.

(** * Bits manipulation *)

(** [sneakr b x] shifts [x] to the right by one bit.
   Rightmost digit is lost while leftmost digit becomes [b].
   Pseudo-code is
    [ match x with (I32 d0 ... dN) => I32 b d0 ... d(N-1) end ]
*)

Fixpoint fmap_nfun {V T U : Type} n (f : T -> U) : nfun V n T -> nfun V n U :=
  match n as n return nfun V n T -> nfun V n U with
  | 0 => f
  | S n => fun v x => fmap_nfun n f (v x)
  end.

Definition sneakr : digits -> int32 -> int32 := Eval compute in
 fun b => int32_rect _ (napply_except_last _ _ (size-1) (I32 b)).
Definition sneakr_cps {T} (k : int32 -> T) : digits -> int32 -> T := Eval compute in
 fun b => int32_rect (fun _ => T) (napply_except_last _ _ (size-1) (fmap_nfun 31 k (I32 b))).

(** [sneakl b x] shifts [x] to the left by one bit.
   Leftmost digit is lost while rightmost digit becomes [b].
   Pseudo-code is
    [ match x with (I32 d0 ... dN) => I32 d1 ... dN b end ]
*)

Definition sneakl : digits -> int32 -> int32 := Eval compute in
 fun b => int32_rect _ (fun _ => napply_then_last _ _ b (size-1) I32).
Definition sneakl_cps {T} (k : int32 -> T) : digits -> int32 -> T := Eval compute in
 fun b => int32_rect (fun _ => T) (fun _ => fmap_nfun 31 k (napply_then_last _ _ b (size-1) I32)).

(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct
    consequences of [sneakl] and [sneakr]. *)

Definition shiftl := sneakl D0.
Definition shiftr := sneakr D0.

Fixpoint shiftln (n : nat) : int32 -> int32 :=
  match n with
  | 0 => fun x => x
  | S n => sneakl_cps (shiftln n) D0
  end.

Fixpoint shiftrn (n : nat) : int32 -> int32 :=
  match n with
  | 0 => fun x => x
  | S n => sneakr_cps (shiftrn n) D0
  end.

Definition twice := sneakl D0.
Definition twice_plus_one := sneakl D1.

(** [firstl x] returns the leftmost digit of number [x].
    Pseudo-code is [ match x with (I32 d0 ... dN) => d0 end ] *)

Definition firstl : int32 -> digits := Eval compute in
 int32_rect _ (fun d => napply_discard _ _ d (size-1)).

(** [firstr x] returns the rightmost digit of number [x].
    Pseudo-code is [ match x with (I32 d0 ... dN) => dN end ] *)

Definition firstr : int32 -> digits := Eval compute in
 int32_rect _ (napply_discard _ _ (fun d=>d) (size-1)).

(** [iszero x] is true iff [x = I32 D0 ... D0]. Pseudo-code is
    [ match x with (I32 D0 ... D0) => true | _ => false end ] *)

Definition iszero : int32 -> bool := Eval compute in
 let f d b := match d with D0 => b | D1 => false end
 in int32_rect _ (nfold_bis _ _ f true size).

(* NB: DO NOT transform the above match in a nicer (if then else).
   It seems to work, but later "unfold iszero" takes forever. *)

(** [base] is [2^32], obtained via iterations of [Z.double].
   It can also be seen as the smallest b > 0 s.t. phi_inv b = 0
   (see below) *)

Definition base := Eval compute in
 iter_nat size Z Z.double 1%Z.

(** * Recursors *)

Fixpoint recl_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int32->A->A)
 (i:int32) : A :=
  match n with
  | O => case0
  | S next =>
          if iszero i then
             case0
          else
             let si := shiftl i in
             caserec (firstl i) si (recl_aux next A case0 caserec si)
  end.

Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int32->A->A)
 (i:int32) : A :=
  match n with
  | O => case0
  | S next =>
          if iszero i then
             case0
          else
             let si := shiftr i in
             caserec (firstr i) si (recr_aux next A case0 caserec si)
  end.

Definition recl := recl_aux size.
Definition recr := recr_aux size.

(** * Conversions *)

(** From int32 to Z, we simply iterates [Z.double] or [Z.succ_double]. *)

Definition phi : int32 -> Z :=
 recr Z (0%Z)
  (fun b _ => match b with D0 => Z.double | D1 => Z.succ_double end).

(** From positive to int32. An abstract definition could be :
      [ phi_inv (2n) = 2*(phi_inv n) /\
        phi_inv 2n+1 = 2*(phi_inv n) + 1 ] *)

Fixpoint phi_inv_positive p :=
  match p with
    | xI q => twice_plus_one (phi_inv_positive q)
    | xO q => twice (phi_inv_positive q)
    | xH => In
  end.

(** The negative part : 2-complement  *)

Fixpoint complement_negative p :=
  match p with
    | xI q => twice (complement_negative q)
    | xO q => twice_plus_one (complement_negative q)
    | xH => twice Tn
  end.

(** A simple incrementation function *)

Definition incr : int32 -> int32 :=
 recr int32 In
   (fun b si rec => match b with
     | D0 => sneakl D1 si
     | D1 => sneakl D0 rec end).

(** We can now define the conversion from Z to int32. *)

Definition phi_inv : Z -> int32 := fun n =>
 match n with
 | Z0 => On
 | Zpos p => phi_inv_positive p
 | Zneg p => incr (complement_negative p)
 end.

(** [phi_inv2] is similar to [phi_inv] but returns a double word
    [zn2z int32] *)

Definition phi_inv2 n :=
  match n with
  | Z0 => W0
  | _ => WW (phi_inv (n/base)%Z) (phi_inv n)
  end.

(** [phi2] is similar to [phi] but takes a double word (two args) *)

Definition phi2 nh nl :=
  ((phi nh)*base+(phi nl))%Z.

(** * Addition *)

(** Addition modulo [2^32] *)

Definition add32 (n m : int32) := phi_inv ((phi n)+(phi m)).
Notation "n + m" := (add32 n m) : int32_scope.

(** Addition with carry (the result is thus exact) *)

(* spiwack : when executed in non-compiled*)
(* mode, (phi n)+(phi m) is computed twice*)
(* it may be considered to optimize it *)

Definition add32c (n m : int32) :=
  let npm := n+m in
  match (phi npm ?= (phi n)+(phi m))%Z with
  | Eq => C0 npm
  | _ => C1 npm
  end.
Notation "n '+c' m" := (add32c n m) (at level 50, no associativity) : int32_scope.

(**  Addition plus one with carry (the result is thus exact) *)

Definition add32carryc (n m : int32) :=
  let npmpone_exact := ((phi n)+(phi m)+1)%Z in
  let npmpone := phi_inv npmpone_exact in
  match (phi npmpone ?= npmpone_exact)%Z with
  | Eq => C0 npmpone
  | _ => C1 npmpone
  end.

(** * Substraction *)

(** Subtraction modulo [2^32] *)

Definition sub32 (n m : int32) := phi_inv ((phi n)-(phi m)).
Notation "n - m" := (sub32 n m) : int32_scope.

(** Subtraction with carry (thus exact) *)

Definition sub32c (n m : int32) :=
  let nmm := n-m in
  match (phi nmm ?= (phi n)-(phi m))%Z with
  | Eq => C0 nmm
  | _ => C1 nmm
  end.
Notation "n '-c' m" := (sub32c n m) (at level 50, no associativity) : int32_scope.

(** subtraction minus one with carry (thus exact) *)

Definition sub32carryc (n m : int32) :=
  let nmmmone_exact := ((phi n)-(phi m)-1)%Z in
  let nmmmone := phi_inv nmmmone_exact in
  match (phi nmmmone ?= nmmmone_exact)%Z with
  | Eq => C0 nmmmone
  | _ => C1 nmmmone
  end.

(** Opposite *)

Definition opp32 x := On - x.
Notation "- x" := (opp32 x) : int32_scope.

(** Multiplication *)

(** multiplication modulo [2^32] *)

Definition mul32 (n m : int32) := phi_inv ((phi n)*(phi m)).
Notation "n * m" := (mul32 n m) : int32_scope.

(** multiplication with double word result (thus exact) *)

Definition mul32c (n m : int32) := phi_inv2 ((phi n)*(phi m)).
Notation "n '*c' m" := (mul32c n m) (at level 40, no associativity) : int32_scope.

(** * Division *)

(** Division of a double size word modulo [2^32] *)

Definition div3221 (nh nl m : int32) :=
  let (q,r) := Z.div_eucl (phi2 nh nl) (phi m) in
  (phi_inv q, phi_inv r).

(** Division modulo [2^32] *)

Definition div32 (n m : int32) :=
  let (q,r) := Z.div_eucl (phi n) (phi m) in
  (phi_inv q, phi_inv r).
Notation "n / m" := (div32 n m) : int32_scope.

(** * Unsigned comparison *)

Definition compare32 (n m : int32) := ((phi n)?=(phi m))%Z.
Notation "n ?= m" := (compare32 n m) (at level 70, no associativity) : int32_scope.

Definition eqb32 (n m : int32) :=
 match n ?= m with Eq => true | _ => false end.

(** Computing the [i]-th iterate of a function:
    [iter_int32 i A f = f^i] *)

Definition iter_int32 i A f :=
  recr (A->A) (fun x => x)
   (fun b si rec => match b with
      | D0 => fun x => rec (rec x)
      | D1 => fun x => f (rec (rec x))
    end)
    i.

(** Combining the [(32-p)] low bits of [i] above the [p] high bits of [j]:
    [addmuldiv32 p i j = i*2^p+j/2^(32-p)]  (modulo [2^32]) *)

Definition addmuldiv32 p i j :=
 let (res, _ ) :=
 iter_int32 p (int32*int32)
  (fun ij => let (i,j) := ij in (sneakl (firstl j) i, shiftl j))
  (i,j)
 in
 res.

(** Bitwise operations *)

Definition lor32 n m := phi_inv (Z.lor (phi n) (phi m)).
Definition land32 n m := phi_inv (Z.land (phi n) (phi m)).
Definition lxor32 n m := phi_inv (Z.lxor (phi n) (phi m)).

(*
Register add32 as int32 plus in "coq_int32" by True.
Register add32c as int32 plusc in "coq_int32" by True.
Register add32carryc as int32 pluscarryc in "coq_int32" by True.
Register sub32 as int32 minus in "coq_int32" by True.
Register sub32c as int32 minusc in "coq_int32" by True.
Register sub32carryc as int32 minuscarryc in "coq_int32" by True.
Register mul32 as int32 times in "coq_int32" by True.
Register mul32c as int32 timesc in "coq_int32" by True.
Register div3221 as int32 div21 in "coq_int32" by True.
Register div32 as int32 diveucl in "coq_int32" by True.
Register compare32 as int32 compare in "coq_int32" by True.
Register addmuldiv32 as int32 addmuldiv in "coq_int32" by True.
Register lor32 as int32 lor in "coq_int32" by True.
Register land32 as int32 land in "coq_int32" by True.
Register lxor32 as int32 lxor in "coq_int32" by True.
*)

Definition lnot32 n := lxor32 Tn n.
Definition ldiff32 n m := land32 n (lnot32 m).

Fixpoint euler (guard:nat) (i j:int32) {struct guard} :=
  match guard with
    | O => In
    | S p => match j ?= On with
               | Eq => i
               | _ => euler p j (let (_, r ) := i/j in r)
             end
  end.

Definition gcd32 (i j:int32) := euler (2*size)%nat i j.

(** Square root functions using newton iteration
    we use a very naive upper-bound on the iteration
    2^32 instead of the usual 32.
**)

Definition sqrt32_step (rec: int32 -> int32 -> int32) (i j: int32)  :=
Eval lazy delta [Twon] in
  let (quo,_) := i/j in
  match quo ?= j with
    Lt => rec i (fst ((j + quo)/Twon))
  | _ =>  j
  end.

Fixpoint iter32_sqrt (n: nat) (rec: int32 -> int32 -> int32)
          (i j: int32) {struct n} : int32 :=
  sqrt32_step
   (match n with
      O =>  rec
   | S n => (iter32_sqrt n (iter32_sqrt n rec))
   end) i j.

Definition sqrt32 i :=
Eval lazy delta [On In Twon] in
  match compare32 In i with
    Gt => On
  | Eq => In
  | Lt => iter32_sqrt 32 (fun i j => j) i (fst (i/Twon))
  end.

Definition v30 := Eval compute in (addmuldiv32 (phi_inv (Z.of_nat size - 1)) In On).

Definition sqrt322_step (rec: int32 -> int32 -> int32 -> int32)
   (ih il j: int32)  :=
Eval lazy delta [Twon v30] in
  match ih ?= j with Eq => j | Gt => j | _ =>
  let (quo,_) := div3221 ih il j in
  match quo ?= j with
    Lt => let m := match j +c quo with
                    C0 m1 => fst (m1/Twon)
                  | C1 m1 => fst (m1/Twon) + v30
                  end in rec ih il m
  | _ =>  j
  end end.

Fixpoint iter322_sqrt (n: nat)
          (rec: int32  -> int32 -> int32 -> int32)
          (ih il j: int32) {struct n} : int32 :=
  sqrt322_step
   (match n with
      O =>  rec
   | S n => (iter322_sqrt n (iter322_sqrt n rec))
   end) ih il j.

Definition sqrt322 ih il :=
Eval lazy delta [On In] in
  let s := iter322_sqrt 32 (fun ih il j => j) ih il Tn in
           match s *c s with
            W0 => (On, C0 On) (* impossible *)
          | WW ih1 il1 =>
             match il -c il1 with
                C0 il2 =>
                  match ih ?= ih1 with
                    Gt => (s, C1 il2)
                  | _  => (s, C0 il2)
                  end
              | C1 il2 =>
                  match (ih - In) ?= ih1 with (* we could parametrize ih - 1 *)
                    Gt => (s, C1 il2)
                  | _  => (s, C0 il2)
                  end
              end
          end.

Fixpoint p2i n p : (N*int32)%type :=
  match n with
    | O => (Npos p, On)
    | S n => match p with
               | xO p => let (r,i) := p2i n p in (r, Twon*i)
               | xI p => let (r,i) := p2i n p in (r, Twon*i+In)
               | xH => (N0, In)
             end
  end.

Definition positive_to_int32 (p:positive) := p2i size p.

(** Constant 32 converted into type int32.
    It is used as default answer for numbers of zeros
    in [head0] and [tail0] *)

Definition T32 : int32 := Eval compute in phi_inv (Z.of_nat size).

Definition head032 (i:int32) :=
  recl _ (fun _ => T32)
   (fun b si rec n => match b with
     | D0 => rec (add32 n In)
     | D1 => n
    end)
   i On.

Definition tail032 (i:int32) :=
  recr _ (fun _ => T32)
   (fun b si rec n => match b with
     | D0 => rec (add32 n In)
     | D1 => n
    end)
   i On.

(*
Register head032 as int32 head0 in "coq_int32" by True.
Register tail032 as int32 tail0 in "coq_int32" by True.
*)


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

Require Import tools language lklc.

Section language.
  (** * Language interpretation *)
  Context { X : Set }.

  (** We interpret expressions as languages in the obvious way: *)
  Global Instance to_lang_𝐄 {Σ}: semantics 𝐄 language X Σ :=
    fix to_lang_𝐄 σ e:=
      match e with
      | 1 => 1%lang
      | 0 => 0%lang
      | 𝐄_var a => (σ a)
      | e + f => ((to_lang_𝐄 σ e) + (to_lang_𝐄 σ f))%lang
      | e ⋅ f => ((to_lang_𝐄 σ e) ⋅ (to_lang_𝐄 σ f))%lang
      | e ∩ f => ((to_lang_𝐄 σ e) ∩ (to_lang_𝐄 σ f))%lang
      | e ¯ => (to_lang_𝐄 σ e)¯%lang
      | e⁺ => (to_lang_𝐄 σ e)⁺%lang
      end.

  (* begin hide *)
  Global Instance semSmaller_𝐄 : SemSmaller (𝐄 X) :=
    (@semantic_containment _ _ _ _ _).
  Global Instance semEquiv_𝐄 : SemEquiv (𝐄 X) :=
    (@semantic_equality _ _ _ _ _).
  Hint Unfold semSmaller_𝐄 semEquiv_𝐄 : semantics.

  Section rsimpl.
    Context { Σ : Set }{σ : 𝕬[X→Σ] }.
    Lemma 𝐄_union e f : (⟦ e+f ⟧σ) = ((⟦e⟧σ) + ⟦f⟧σ)%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄_prod e f :  (⟦ e⋅f ⟧σ) = ((⟦e⟧σ) ⋅ ⟦f⟧σ)%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄_intersection e f : (⟦ e∩f ⟧σ) = ((⟦e⟧σ) ∩ ⟦f⟧σ)%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄_mirror e :  (⟦ e ¯⟧σ) = (⟦e⟧σ)¯%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄_iter_l e :  (⟦ e⁺⟧σ) = (⟦e⟧σ)⁺%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄_variable a : (⟦𝐄_var a⟧ σ) = σ a.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄_unit : (⟦1⟧σ) = 1%lang.
    Proof. unfold interprete;simpl;auto. Qed.
    Lemma 𝐄_empty : (⟦0⟧σ) = 0%lang.
    Proof. unfold interprete;simpl;auto. Qed.
  End rsimpl.
  Hint Rewrite @𝐄_unit @𝐄_empty @𝐄_variable @𝐄_intersection
       @𝐄_prod @𝐄_union @𝐄_mirror @𝐄_iter_l
    : simpl_typeclasses.

  Global Instance sem_incl_𝐄_plus :
    Proper (ssmaller ==> ssmaller ==> ssmaller) (@𝐄_plus X).
  Proof.
    intros e f E g h F ? ?;simpl;rsimpl;revert E F;
      repeat autounfold with semantics;firstorder.
  Qed.
  Global Instance sem_incl_𝐄_fois :
    Proper (ssmaller ==> ssmaller ==> ssmaller) (@𝐄_seq X).
  Proof.
    intros e f E g h F Σ σ;simpl;revert E F;rsimpl;
      repeat autounfold with semantics;firstorder.
  Qed.
  Global Instance sem_incl_𝐄_inter :
    Proper (ssmaller ==> ssmaller ==> ssmaller) (@𝐄_inter X).
  Proof.
    intros e f E g h F Σ σ;simpl;revert E F;rsimpl;
      repeat autounfold with semantics;firstorder.
  Qed.
  Global Instance sem_incl_𝐄_conv :
    Proper (ssmaller ==> ssmaller) (@𝐄_conv X).
  Proof.
    intros e f E Σ σ;simpl;revert E;rsimpl;
      repeat autounfold with semantics;firstorder.
  Qed.
  Global Instance sem_incl_𝐄_iter :
    Proper (ssmaller ==> ssmaller) (@𝐄_iter X).
  Proof.
    intros e f E Σ σ;simpl.
    autorewrite with simpl_typeclasses.
    apply iter_lang_incl,E.
  Qed.
  Global Instance sem_eq_𝐄_plus :
    Proper (sequiv ==> sequiv ==> sequiv) (@𝐄_plus X).
  Proof. eapply (@sem_eq_op _ _ ssmaller);once (typeclasses eauto). Qed.
  Global Instance sem_eq_𝐄_seq :
    Proper (sequiv ==> sequiv ==> sequiv) (@𝐄_seq X).
  Proof. eapply (@sem_eq_op _ _ ssmaller);once (typeclasses eauto). Qed.
  Global Instance sem_eq_𝐄_inter :
    Proper (sequiv ==> sequiv ==> sequiv) (@𝐄_inter X).
  Proof. eapply (@sem_eq_op _ _ ssmaller);once (typeclasses eauto). Qed.
  Global Instance sem_eq_𝐄_conv :
    Proper (sequiv ==> sequiv) (@𝐄_conv X).
  Proof.
    intros e f E Σ σ;simpl;autounfold;rsimpl.
    intro w;rewrite (E Σ σ (rev w));tauto.
  Qed.
  Global Instance sem_eq_𝐄_iter :
    Proper (sequiv ==> sequiv) (@𝐄_iter X).
  Proof.
    intros e f E Σ σ;simpl.
    autorewrite with simpl_typeclasses.
    apply iter_lang_eq,E.
  Qed.
  Global Instance 𝐄_sem_equiv :
    Equivalence (fun e f : 𝐄 X => e ≃ f).
  Proof. once (typeclasses eauto). Qed.
  Global Instance 𝐄_sem_PreOrder :
    PreOrder (fun e f : 𝐄 X => e ≲ f).
  Proof. once (typeclasses eauto). Qed.
  Global Instance 𝐄_sem_PartialOrder :
    PartialOrder (fun e f : 𝐄 X => e ≃ f)
                 (fun e f : 𝐄 X => e ≲ f).
  Proof.
    eapply semantic_containment_PartialOrder;once (typeclasses eauto).
  Qed.

  (* end hide *)

  Lemma lang_iter_prod_last {Σ}(l: language Σ) n : (l ^{S n} ≃ l ^{n} ⋅ l)%lang.
  Proof.
    induction n.
    - simpl;intros w;split;intros (u&v&I1&I2&->).
      + rewrite I2,app_nil_r;exists [],u;split;reflexivity||auto.
      + rewrite I1;exists v,[];rewrite app_nil_r;repeat split;auto.
    - intros x;split.
      + intros (u&?&I1&I2&->).
        apply IHn in I2 as (v&w&I2&I3&->).
        exists (u++v),w;rewrite app_ass;repeat split;auto.
        exists u,v;tauto.
      + intros (?&w&(u&v&I1&I2&->)&I3&->).
        cut (l^{S n}%lang (v++w));[|apply IHn;exists v,w;tauto].
        intro I';exists u,(v++w);rewrite app_ass;repeat split;auto.
  Qed.

  (** This interpretation is sound in the sense that axiomatically
  equivalent expressions are semantically equivalent. Differently put,
  the axioms we imposed hold in every algebra of languages. *)
  Theorem 𝐄_eq_equiv_lang : forall e f : 𝐄 X, e ≡ f ->  e ≃ f.
  Proof.
    assert (dumb : forall A (w:list A), rev w = nil <-> w = nil)
      by (intros A w;split;[intro h;rewrite <-(rev_involutive w),h
                           |intros ->];reflexivity).
    intros e f E Σ σ;induction E;rsimpl;try firstorder.
    - apply iter_lang_eq,IHE.
    -  destruct H;rsimpl;repeat autounfold with semantics;try (now firstorder).
       + intro w;firstorder.
         * rewrite H1,H3;clear x0 w H1 H3;rewrite<- app_ass.
           eexists;eexists;split;[eexists;eexists;split;[|split]
                                 |split];eauto.
         * rewrite H1,H3;clear x w H1 H3;rewrite app_ass.
           eexists;eexists;split;
             [|split;[eexists;eexists;split;[|split]|]];eauto.
       + intro w;firstorder subst.
         * simpl in *;auto.
         * exists nil;exists w;simpl;auto.
       + intro w;firstorder subst.
         * rewrite app_nil_r;auto.
         * exists w;exists nil;rewrite app_nil_r;auto.
       + intro w;rewrite rev_involutive;tauto.
       + intro w;firstorder.
         * rewrite <- (rev_involutive w),H1,rev_app_distr;eauto.
           exists (rev x0);exists (rev x).
           setoid_rewrite rev_involutive;auto.
         * rewrite H1,rev_app_distr;eauto.
       + intros w;split.
         * intros (n&Iu);exists n.
           generalize dependent (S n);clear n;intros n;revert w.
           induction n;intro w;[simpl;apply dumb|].
           intro I;apply lang_iter_prod_last in I as (u&v&Iu&Iv&E).
           replace w with (rev v++rev u) in * by (now rewrite <- rev_app_distr,<-E,rev_involutive).
           clear w E.
           exists (rev v),(rev u);rewrite rev_involutive.
           repeat split;auto.
           apply IHn;rewrite rev_involutive;assumption.
         * intros (n&Iu);exists n.
           generalize dependent (S n);clear n;intros n;revert w.
           induction n;intro w;[simpl;apply dumb|].
           intro I;apply lang_iter_prod_last in I as (u&v&Iu&Iv&->).
           exists (rev v),(rev u);rewrite rev_app_distr.
           repeat split;auto.
       + intros w;split.
         * intros ([]&Iu).
           -- left;destruct Iu as (u'&?&Iu&->&->).
              rewrite app_nil_r;assumption.
           -- right;destruct Iu as (u&v&Iu&Iv&->).
              exists u,v;repeat split;auto.
              exists n;assumption.
         * intros [Iu|(u&v&Iu&(m&Iv)&->)].
           -- exists 0%nat,w,[];rewrite app_nil_r;repeat split;assumption.
           -- exists (S m),u,v;tauto.
       + intros w;split.
         * intros ([]&Iu).
           -- left;destruct Iu as (u'&?&Iu&->&->).
              rewrite app_nil_r;assumption.
           -- apply lang_iter_prod_last in Iu.
              right;destruct Iu as (u&v&Iu&Iv&->).
              exists u,v;repeat split;auto.
              exists n;assumption.
         * intros [Iu|(u&v&(m&Iu)&Iv&->)].
           -- exists 0%nat,w,[];rewrite app_nil_r;repeat split;assumption.
           -- exists (S m);apply lang_iter_prod_last.
              exists u,v;tauto.
       + intros w;firstorder subst.
         * destruct x;[|destruct x0];auto; discriminate.
         * destruct x;destruct x0;try discriminate;auto.
         * exists [];exists [];subst;auto.
       + intro w;firstorder subst;simpl in *;auto.
       + intro w;firstorder subst;simpl in *.
         * exists x0;exists [];rewrite app_nil_r;auto.
         * exists [];exists x;rewrite app_nil_r;auto.
       + intro w;firstorder subst;simpl in *;auto.
       + intros w;split.
         * intros (n&In);revert w In;induction n;intros w Iw.
           -- destruct Iw as (u&v&Iu&->&->);rewrite app_nil_r.
              destruct Iu as [Iu|(v&w&(->&Iv)&Iw&->)].
              ++ left;exists 0%nat,u,[];rewrite app_nil_r;repeat split;auto.
              ++ right;exists [],w;repeat split;auto.
                 exists 0%nat,w,[];rewrite app_nil_r;repeat split;auto.
           -- destruct Iw as (u&v&Iu&Iv&->).
              apply IHn in Iv.
              destruct Iv as [(m&Iv)|(v1&v2&(->&Iv1)&(m&Im)&->)];
                destruct Iu as [Iu|(?&u'&(->&I1)&I2&->)];simpl;repeat rewrite app_nil_r.
              ++ left;exists (S m),u,v;repeat split;auto.
              ++ right;exists [],(u'++v);repeat split;auto.
                 exists (S m),u',v;repeat split;auto.
                 assert (⟦ g ⟧ σ ≲ ⟦g + f⟧ σ) as E
                   by (rsimpl;repeat autounfold with semantics;intuition).
                 eapply (iter_prod_lang_incl E) in Iv;try reflexivity;clear E.
                 apply Iv.
              ++ right;exists [],(u++v2);split;[tauto|split;[|tauto]].
                 exists (S m),u,v2;tauto.
              ++ right;exists [],(u'++v2);split;[tauto|split;[|tauto]].
                 exists (S m),u',v2;tauto.
         * intros [I|I].
           -- assert (g≲ g + (1∩e)⋅f) as E
                 by (intro;intros;rsimpl;repeat autounfold with semantics;intuition).
              pose proof (E _ σ) as E';clear E.
              apply iter_lang_incl in E'.
              apply E',I.
           -- destruct I as (?&u&(->&Ie)&I&->);simpl.
              assert (⟦g+f⟧ σ≲ ⟦g + (1∩e)⋅f⟧σ) as E.
              ++ intros v [Iv|Iv];[left;apply Iv|right;exists [],v;repeat split;assumption].
              ++ apply iter_lang_incl in E.
                 apply E,I.
    - destruct H.
      + assert (ih : ⟦e⋅f⟧σ≲⟦f⟧σ) by (intros u Iu;apply (IHE u);left;apply Iu);clear IHE.
        cut (⟦e⁺⋅f⟧σ≲⟦f⟧σ);[intros E u;split;[intros [I|I];[apply E|]|intro;right];assumption|].
        intros w (u&v&(n&Iu)&Iv&->).
        revert u v Iu Iv;induction n;intros u v Iu Iv.
        * destruct Iu as (u'&?&Iu&->&->).
          rewrite app_nil_r;apply ih;exists u',v;tauto.
        * apply lang_iter_prod_last in Iu as (u1&u2&Iu1&Iu2&->);rewrite app_ass.
          apply IHn;[assumption|].
          apply ih;exists u2,v;tauto.
      + assert (ih : ⟦f⋅e⟧σ≲⟦f⟧σ) by (intros u Iu;apply (IHE u);left;apply Iu);clear IHE.
        cut (⟦f⋅e⁺⟧σ≲⟦f⟧σ);[intros E u;split;[intros [I|I];[apply E|]|intro;right];assumption|].
        intros w (u&v&Iu&(n&Iv)&->).
        revert u v Iu Iv;induction n;intros u v Iu Iv.
        * destruct Iv as (v'&?&Iv&->&->).
          rewrite app_nil_r;apply ih;exists u,v';tauto.
        * destruct Iv as (v1&v2&Iv1&Iv2&->);rewrite <- app_ass.
          apply IHn;[|assumption].
          apply ih;exists u,v1;tauto.
  Qed.

  (** This extends to ordering as well. *)
  Lemma 𝐄_inf_incl_lang (e f : 𝐄 X) : e ≤ f -> e ≲ f.
  Proof.
    intro E;apply smaller_equiv,𝐄_eq_equiv_lang in E.
    intros Σ σ w I;apply E;rsimpl;left;left;auto.
  Qed.

  (** A word is in the language of a sum if and only if it is in the
  language of one of its components. *)
  Lemma sum_lang l A (σ:𝕬[X→A]) w :
    (w ∊ ⟦Σ l⟧ σ) <-> (exists t : 𝐄 X, t ∈ l /\ (⟦ t ⟧ σ) w).
  Proof.
    rewrite (𝐄_eq_equiv_lang (sum_fold _) _ _).
    induction l;simpl;rsimpl;autounfold with semantics.
    - firstorder.
    - split;[intros [h|IH];[|apply IHl in IH as (t&I&IH)]
            |intros (t&[<-|I]&IH)];auto.
      -- exists a;split;auto.
      -- exists t;split;auto.
      -- right;apply IHl;eauto.
  Qed.

  Global Instance incl_assign A : SemSmaller 𝕬[X → A] :=
    fun σ τ => forall x, σ x ≲ τ x.
  Global Instance eq_assign A : SemEquiv 𝕬[X → A] :=
    fun σ τ => forall x, σ x ≃ τ x.

  Global Instance incl_assign_PreOrder A : PreOrder (@ssmaller 𝕬[X → A] _).
  Proof.
    split.
    - intros σ x;reflexivity.
    - intros σ1 σ2 σ3 E1 E2 x;transitivity (σ2 x);auto.
  Qed.

  Global Instance eq_assign_Equivalence A : Equivalence (@sequiv 𝕬[X → A] _).
  Proof.
    split.
    - intros σ x;reflexivity.
    - intros σ τ E x;symmetry;auto.
    - intros σ1 σ2 σ3 E1 E2 x;transitivity (σ2 x);auto.
  Qed.
  Global Instance incl_assign_PartialOrder A : PartialOrder _ (@ssmaller 𝕬[X → A] _).
  Proof.
    intros σ τ;split;unfold Basics.flip.
    - intro E;split;intro x;rewrite (E x);reflexivity.
    - intros (E1&E2) x;apply lang_incl_PartialOrder;unfold Basics.flip;split;auto.
  Qed.

  Global Instance assign_monotone A :
    Proper (ssmaller ==> ssmaller ==> ssmaller) (fun (σ : 𝕬[X → A]) e => ⟦e⟧σ).
  Proof.
    intros σ τ E e f E'.
    transitivity (⟦e⟧τ).
    - clear f E'.
      induction e;rsimpl;reflexivity||auto.
      + rewrite IHe1,IHe2;reflexivity.
      + rewrite IHe1,IHe2;reflexivity.
      + rewrite IHe1,IHe2;reflexivity.
      + rewrite IHe;reflexivity.
      + rewrite IHe;reflexivity.
    - apply E'.
  Qed.

  Global Instance assign_morph A :
    Proper (sequiv ==> sequiv ==> sequiv) (fun (σ : 𝕬[X → A]) e => ⟦e⟧σ).
  Proof.
    intros σ τ E e f E'.
    apply lang_incl_PartialOrder;unfold Basics.flip;split;apply assign_monotone;auto.
    - rewrite E;reflexivity.
    - rewrite E';reflexivity.
    - rewrite E;reflexivity.
    - rewrite E';reflexivity.
  Qed.

  Lemma test_is_one (A : list X) 𝐀 (σ : 𝕬[X→𝐀]) :
    A ⊢ σ -> ⟦ test A ⟧ σ ≃ 1%lang.
  Proof.
    induction A;simpl;[reflexivity|].
    - intros h;rsimpl.
      assert ([] ∊ σ a /\ A ⊢ σ) as (Ia&V)
          by (split;[apply h;now left|intros b Ib;apply h;now right]).
      apply IHA in V;rewrite <- V.
      intros u;split;intro Iu;repeat split;auto.
      + rsimpl;destruct Iu as ((I&_)&I');auto.
      + apply V in Iu as ->;auto.
      + apply V in Iu as ->;auto.
  Qed.

  Lemma test_is_one_inv (A : list X) 𝐀 (σ : 𝕬[X→𝐀]) :
    forall u, u ∊ (⟦ test A ⟧ σ) -> A ⊢ σ /\ u = [].
  Proof.
    intros u;induction A as [|a A].
    - intros ->;split;auto.
      intros ? F;exfalso;apply F.
    - simpl;rsimpl.
      intros ((Ia&_)&Ih).
      apply IHA in Ih as (V&->);split;auto.
      intros b [<-|Ib];auto.
  Qed.

  Context {decX : decidable_set X}.
  Lemma nil_lang {𝐀 : Set} (σ : 𝕬[X→𝐀]) e :
    [] ∊ (⟦e⟧σ) <-> exists A, test A ≤ e /\ A ⊢ σ.
  Proof.
    split;
      [|intros (A&E&V);eapply 𝐄_inf_incl_lang;[eauto|apply test_is_one;[assumption
                                                                       |reflexivity]]].
    induction e;rsimpl.
    - intros _; exists [];split.
      + reflexivity.
      + intros a;simpl;tauto.
    - intros F;exfalso;apply F.
    - rsimpl;intros I;exists [x];split;simpl.
      + repeat rewrite inf_ax_inter_l;reflexivity.
      + intros ? [<-|F];simpl in *;tauto.
    - intros (u1&u2&I1&I2&E).
      symmetry in E;apply app_eq_nil in E as (->&->).
      apply IHe1 in I1 as (A1&T1&V1).
      apply IHe2 in I2 as (A2&T2&V2).
      exists (A1++A2);split.
      + repeat rewrite test_app.
        rewrite <-T1,<-T2,test_prod_cap;reflexivity.
      + apply test_compatible_app;auto.
    - intros (I1&I2).
      apply IHe1 in I1 as (A1&T1&V1);apply IHe2 in I2 as (A2&T2&V2).
      exists (A1++A2);split.
      + repeat rewrite test_app.
        apply inter_smaller;assumption.
      + apply test_compatible_app;auto.
    - intros [I1|I2];[apply IHe1 in I1 as (A&T&V)|apply IHe2 in I2 as (A&T&V)];
        exists A;rewrite T;(split;[|assumption]);[apply plus_left|apply plus_right];reflexivity.
    - intros I.
      apply IHe in I as (A&T&V).
      exists A;split;[rewrite <- T,test_conv;reflexivity|assumption].
    - intros (n&x&y&I&_&E).
      symmetry in E;apply app_eq_nil in E as (->&_);clear n y.
      apply IHe in I as (A&T&V).
      exists A;split;[rewrite <- T,test_iter;reflexivity|assumption].
  Qed.

End language.
(* begin hide *)
Hint Rewrite @𝐄_unit @𝐄_empty @𝐄_variable @𝐄_intersection
     @𝐄_prod @𝐄_union @𝐄_mirror @𝐄_iter_l
  : simpl_typeclasses.
(* end hide *)


From Hammer Require Import Hammer.

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Setoids.Setoid.

Set Implicit Arguments.
Set Strict Implicit.
Set Asymmetric Patterns.

Section parametric.
Variable T : Type.
Variable R : T -> T -> Prop.

Inductive makeRefl (x : T) : T -> Prop :=
| RRefl : makeRefl x x
| RStep : forall y, R x y -> makeRefl x y.

Global Instance Refl_makeRefl : Reflexive makeRefl.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.Refl_makeRefl".
constructor.
Qed.

Global Instance Refl_makeTrans : Transitive R -> Transitive makeRefl.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.Refl_makeTrans".
intro. intro. intros. inversion H0; clear H0; subst; auto.
inversion H1; clear H1; subst; auto using RStep.
apply RStep. etransitivity; eauto.
Qed.

Inductive makeTrans (x y : T) : Prop :=
| TStep : R x y -> makeTrans x y
| TTrans : forall z, makeTrans x z -> makeTrans z y -> makeTrans x y.

Global Instance Trans_makeTrans : Transitive makeTrans.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.Trans_makeTrans".
intro. intros; eapply TTrans; eassumption.
Qed.

Global Instance Trans_makeRefl : Reflexive R -> Reflexive makeTrans.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.Trans_makeRefl".
intro. intro. apply TStep. reflexivity.
Qed.

Inductive leftTrans (x y : T) : Prop :=
| LTFin : R x y -> leftTrans x y
| LTStep : forall z, R x z -> leftTrans z y -> leftTrans x y.

Inductive rightTrans (x y : T) : Prop :=
| RTFin : R x y -> rightTrans x y
| RTStep : forall z, rightTrans x z -> R z y -> rightTrans x y.

Fixpoint leftTrans_rightTrans_acc x y (l : leftTrans y x) : forall z, rightTrans z y -> rightTrans z x :=
match l with
| LTFin pf => fun z pfR => RTStep pfR pf
| LTStep _ pf pfL => fun z pfR =>
leftTrans_rightTrans_acc pfL (RTStep pfR pf)
end.

Fixpoint rightTrans_leftTrans_acc x y (l : rightTrans x y) : forall z, leftTrans y z -> leftTrans x z :=
match l with
| RTFin pf => fun z pfR => LTStep pf pfR
| RTStep _ pf pfL => fun z pfR =>
rightTrans_leftTrans_acc pf (LTStep pfL pfR)
end.

Theorem leftTrans_rightTrans : forall x y,
leftTrans x y <-> rightTrans x y.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.leftTrans_rightTrans".
split.
{ destruct 1. apply RTFin; assumption.
eapply leftTrans_rightTrans_acc. eassumption. eapply RTFin. eassumption. }
{ destruct 1. apply LTFin. assumption.
eapply rightTrans_leftTrans_acc. eassumption. eapply LTFin. eassumption. }
Qed.

Fixpoint leftTrans_makeTrans_acc x y (l : leftTrans x y) : makeTrans x y :=
match l with
| LTFin pf => TStep pf
| LTStep _ pf pfL =>
TTrans (TStep pf) (leftTrans_makeTrans_acc pfL)
end.

Fixpoint leftTrans_trans x y (l : leftTrans x y) : forall z (r : leftTrans y z), leftTrans x z :=
match l with
| LTFin pf => fun _ pfL => LTStep pf pfL
| LTStep _ pf pfL => fun _ pfR => LTStep pf (leftTrans_trans pfL pfR)
end.

Theorem makeTrans_leftTrans : forall s s',
makeTrans s s' <-> leftTrans s s'.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.makeTrans_leftTrans".
split; intros.
{ induction H. eapply LTFin. eassumption.
eapply leftTrans_trans; eassumption. }
{ apply leftTrans_makeTrans_acc. assumption. }
Qed.

Theorem makeTrans_rightTrans : forall s s',
makeTrans s s' <-> rightTrans s s'.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.makeTrans_rightTrans".
intros. etransitivity. apply makeTrans_leftTrans. apply leftTrans_rightTrans.
Qed.

Definition RTStep_left : forall x y z : T, R x y -> rightTrans y z -> rightTrans x z.
intros. revert H. revert x.
induction H0.
{ intros. eapply RTStep. eapply RTFin. eassumption. eassumption. }
{ intros. eapply RTStep. eapply IHrightTrans. eassumption. eassumption. }
Defined.

End parametric.

Section param.
Variable T : Type.
Variable R : T -> T -> Prop.

Theorem makeTrans_idem : forall s s',
makeTrans (makeTrans R) s s' <-> makeTrans R s s'.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.makeTrans_idem".
split.
{ induction 1; eauto using TTrans. }
{ eapply TStep. }
Qed.

Theorem makeTrans_makeRefl_comm : forall s s',
makeTrans (makeRefl R) s s' <-> makeRefl (makeTrans R) s s'.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.makeTrans_makeRefl_comm".
split.
{ induction 1;
repeat match goal with
| [ H : makeRefl _ _ _ |- _ ] => inversion H; clear H; subst
end; eauto using RRefl, RStep, TStep, TTrans. }
{ intros. inversion H; clear H; subst; auto. apply TStep. apply RRefl.
induction H0; eauto using RStep, TStep, TTrans. }
Qed.

Theorem makeRefl_idem : forall s s',
makeRefl (makeRefl R) s s' <-> makeRefl R s s'.
Proof. hammer_hook "TransitiveClosure" "TransitiveClosure.makeRefl_idem".
split; inversion 1; subst; eauto using RStep, RRefl.
Qed.

End param.


Require Import MyUtils.
Require Import Atom.
Require Import List.
Require Import Metatheory.

(*

Case (cas) is written such that it only destructures a single sum.
Evaluation of a case statement consists in application of the left or
right branch in a single abstraction to the term inside of inl/inr
constructor.  Applications are of arity one.

Types such as Nat have to be represented as:

Nat = Z | S Nat  ->   Nat := inl unit OR inr Nat

List is represented as:

List_A := Nil | Cons A List_A  ->  List_A := inl unit OR inr (prod A List_A)

This is a very inconvenient syntax, but yields very efficient proofs.

*)

(* preterms *)
Inductive term : Set :=
| bvar : nat -> term
| fvar : atom -> term
| abs : term -> term
| fp : term -> term
| app : term -> term -> term
| proj1 : term -> term
| proj2 : term -> term
| prod : term -> term -> term
| inl : term -> term
| inr : term -> term
| unit : term
| cas : term -> term -> term -> term.
Coercion bvar : nat >-> term.
Coercion fvar : atom >-> term.

(* this is even easier to write than the SML equivalent! *)
Definition term_eq_dec : forall t t' : term, {t = t'} + {t <> t'}.
Proof.
  decide equality. auto with arith. auto using eq_atom_dec.
Defined.

Fixpoint fv (t:term) :=
  match t with
    | bvar n => {}
    | fvar a => singleton a
    | abs t' => fv t'
    | fp t' => fv t'
    | app m n => (fv m) `union` (fv n)
    | proj1 t' => fv t'
    | proj2 t' => fv t'
    | prod m n => (fv m) `union` (fv n)
    | inl l => fv l
    | inr r => fv r
    | unit => {}
    | cas x l r => (fv x) `union` (fv l) `union` (fv r)
  end.

Fixpoint subst (z : atom) (u : term) (e : term) {struct e} : term :=
  match e with
    | bvar i => bvar i
    | fvar v => if v == z then u else (fvar v)
    | proj1 t' => proj1 (subst z u t')
    | proj2 t' => proj2 (subst z u t')
    | abs e1 => abs (subst z u e1)
    | app e1 e2 => app (subst z u e1) (subst z u e2)
    | prod e1 e2 => prod (subst z u e1) (subst z u e2)
    | inl l => inl (subst z u l)
    | inr r => inr (subst z u r)
    | cas e e1 e2 =>
      cas (subst z u e) (subst z u e1) (subst z u e2)
    | fp e1 => fp (subst z u e1)
    | unit => unit
  end.

Notation "[ z ~> u ] e" := (subst z u e) (at level 68).

(* replace a bvar with a term *)
Fixpoint open_rec (k : nat) (u : term) (e : term) {struct e} : term :=
  match e with
    | bvar i => if k === i then u else (bvar i)
    | fvar x => fvar x
    | abs e1 => abs (open_rec (S k) u e1)
    | fp e => fp (open_rec (S k) u e)
    | app e1 e2 => app (open_rec k u e1) (open_rec k u e2)
    | proj1 t => proj1 (open_rec k u t)
    | proj2 t => proj2 (open_rec k u t)
    | prod a b => prod (open_rec k u a) (open_rec k u b)
    | inl l => inl (open_rec k u l)
    | inr r => inr (open_rec k u r)
    | cas e e1 e2 =>
      cas (open_rec k u e)
      (open_rec (S k) u e1)
      (open_rec (S k) u e2)
    | unit => unit
  end.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).

(* opening that just replaces an outermost abstraction *)
Definition open e u := open_rec 0 u e.

Definition open_times n e u :=
  match n with
    | 0 => e
    | S n' => open_rec n' u e
  end.

(* local closure: well formedness wrt lambda abstraction *)
Inductive lc : term -> Prop :=
| lc_fvar : forall x, lc (fvar x)
| lc_abs : forall L e,
  (forall x:atom, x `notin` L -> lc (open e (fvar x))) ->
  lc (abs e)
| lc_app : forall e1 e2,
  lc e1 ->
  lc e2 ->
  lc (app e1 e2)
| lc_unit : lc unit
| lc_fp : forall L e,
  (forall x:atom, x `notin` L -> lc (open e (fvar x))) ->
  lc (fp e)
| lc_proj1 : forall e,
  lc e ->
  lc (proj1 e)
| lc_proj2 : forall e,
  lc e ->
  lc (proj2 e)
| lc_prod : forall e1 e2, lc e1 -> lc e2 -> lc (prod e1 e2)
| lc_inl : forall e, lc e -> lc (inl e)
| lc_inr : forall e, lc e -> lc (inr e)
| lc_cas : forall L e e1 e2,
  lc e ->
  (forall x:atom, x `notin` L -> lc (open e1 (fvar x))) ->
  (forall x:atom, x `notin` L -> lc (open e2 (fvar x))) ->
  lc (cas e e1 e2).
Hint Constructors lc.

Lemma open_lc_diff : forall e j v i u,
  i <> j ->
  {j ~> v} e = {i ~> u} ({j ~> v} e) ->
  e = {i ~> u} e.
Proof.
  induction e ; intros j v i u Hdiff ; try ( intros ; simpl in * ; f_equal ; intros ; inversion H ; eauto ; fail).
  (* bvar *)
  simpl in *. case (j === n) ; case (i === n) ; intros ; auto with arith ; try congruence. subst. simpl in H.
  case_eq (n===n). intros. rewrite H0 in H. auto. intros. congruence.
Defined.

Lemma open_lc : forall k u e, lc e -> e = {k ~> u} e.
Proof.
  intros.  generalize dependent k.
  induction H ; simpl ; try (intros ; f_equal ; intuition)
    ; pick fresh x for L ; intros ;
      apply open_lc_diff with (i := S k) (j := 0) (u := u) (v := (fvar x)) ; auto ;
        unfold open in H0 ; eauto ; firstorder.
Defined.

Lemma subst_open_rec : forall e1 e2 u x k,
  lc u ->[x ~> u] ({k ~> e2} e1) = {k ~> [x ~> u] e2} ([x ~> u] e1).
Proof.
  induction e1; intros e2 u x k Hlc; try (simpl in *; f_equal; auto ; fail).
  (* bvar *)
  simpl ; case (k === n) ; intros ; auto.
  (* fvar *)
  simpl ; case (a == x) ; intros ; eapply open_lc ; auto.
Defined.

Lemma subst_open_var : forall (x y : atom) u e,
  y <> x ->
  lc u ->
  open ([x ~> u] e) y = [x ~> u] (open e y).
Proof.
  intros x y u e Neq H.
  unfold open.
  rewrite subst_open_rec with (e2 := y).
  simpl.
  destruct (y == x).
    Case "y=x".
    destruct Neq. auto.
    Case "y<>x".
    auto.
  auto.
Qed.

Ltac pick_fresh Y :=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
    set (Y := (A `union` B)).

Lemma subst_lc : forall (x : atom) u e,
  lc e ->
  lc u ->
  lc ([x ~> u] e).
Proof.
  intros x u e He Hu.
  induction He ; try (simpl in * ; f_equal ; eauto ; intuition ; fail).
  Case "lc_var".
   simpl.
   destruct (x0 == x).
     auto.
     auto.
  Case "lc_abs".
   simpl.
    apply lc_abs with (L := L `union` singleton x).
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
  Case "lc_fp".
   simpl.
    apply lc_fp with (L := L `union` singleton x).
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
  Case "lc_cas".
   simpl.
    apply lc_cas with (L := L `union` singleton x) ; auto.
    (* inl *)
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
    (* inr *)
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
Defined.

(* single step operational semantics *)
Inductive eval : term -> term -> Prop :=
| eval_beta : forall e1 e2,
  lc (abs e1) ->
  lc e2 ->
  eval (app (abs e1) e2) (open e1 e2)
| eval_fp : forall e1,
  lc (fp e1) ->
  eval (fp e1) (open e1 (fp e1))
| eval_app_1 : forall e1 e1' e2,
  lc e2 ->
  eval e1 e1' ->
  eval (app e1 e2) (app e1' e2)
| eval_app_2 : forall e1 e2 e2',
  lc e1 ->
  eval e2 e2' ->
  eval (app e1 e2) (app e1 e2')
| eval_proj1 : forall e1 e2,
  lc e1 ->
  lc e2 ->
  eval (proj1 (prod e1 e2)) e1
| eval_proj2 : forall e1 e2,
  lc e1 ->
  lc e2 ->
  eval (proj2 (prod e1 e2)) e2
| eval_cas_1 : forall e e' e1 e2,
  lc e ->
  lc (abs e1) ->
  lc (abs e2) ->
  eval e (inl e') ->
  eval (cas e e1 e2) (open e1 e')
| eval_cas_2 : forall e e' e1 e2,
  lc e ->
  lc (abs e1) ->
  lc (abs e2) ->
  eval e (inr e') ->
  eval (cas e e1 e2) (open e2 e').

Hint Constructors eval.

Lemma subst_fresh : forall (x : atom) e u,
  x `notin` fv e -> [x ~> u] e = e.
Proof.
  intros x e u H.
  induction e ; try (simpl in * ; f_equal ; auto ; auto).
  Case "fvar".
   simpl.
   destruct (a == x).
    Case "a=x".
      subst. simpl fv in H. decideFSet.
    Case "a<>x".
      auto.
Qed.

Lemma subst_intro : forall (x : atom) u e,
  x `notin` (fv e) ->
  lc u ->
  open e u = [x ~> u](open e x).
Proof.
  intros x u e H J.
  unfold open.
  rewrite subst_open_rec; auto.
  simpl.
  destruct (x == x).
  Case "x = x".
    rewrite subst_fresh; auto.
  Case "x <> x".
    destruct n; auto.
Qed.

Lemma open_abs : forall e u,
  lc (abs e) ->
  lc u ->
  lc (open e u).
Proof with auto using subst_lc.
  intros e u H J.
  inversion H; subst.
  pick fresh y for (L `union` (fv e)).
  rewrite (subst_intro y). eauto using subst_lc. eauto. eauto.
Qed.

Lemma open_fp : forall e u,
  lc (fp e) ->
  lc u ->
  lc (open e u).
Proof with auto using subst_lc.
  intros e u H J.
  inversion H; subst.
  pick fresh y for (L `union` (fv e)).
  rewrite (subst_intro y). eauto using subst_lc. eauto. eauto.
Defined.

Lemma eval_regular : forall e1 e2,
  eval e1 e2 -> lc e1 /\ lc e2.
Proof.
  intros e1 e2 H. induction H; intuition ; auto using open_abs, open_fp.
  (* inl *)
  apply lc_cas with (L:= (fv e1)). auto.
  intros. apply open_abs. auto. inversion H4. subst. auto.
  intros. apply open_abs. auto. inversion H4. subst. auto.
  intros. apply open_abs. auto. inversion H4. subst. auto.
  (* inr *)
  apply lc_cas with (L:= (fv e2)). auto.
  intros. apply open_abs. auto. inversion H4. subst. auto.
  intros. apply open_abs. auto. inversion H4. subst. auto.
  intros. apply open_abs. auto. inversion H4. subst. auto.
Qed.

(* reduction relation *)
Inductive reduces : term -> Prop :=
| reduces_base :
  forall a, (exists b, eval a b) -> reduces a.

(* multi-step reduction relation *)
Inductive multistep : term -> term -> Prop :=
| multistep_refl : forall a, multistep a a
| multistep_eval : forall a b, eval a b -> multistep a b.

Inductive evaluates : term -> term -> Prop :=
| evaluates_base : forall a b, multistep a b -> ~(reduces b) -> evaluates a b.

Inductive converges : term -> Prop :=
| converges_base : forall a, (exists b, evaluates a b) -> converges a.

Inductive diverges : term -> Prop :=
| diverges_base : forall a, (forall b, multistep a b -> reduces b) -> diverges a.

Hint Constructors evaluates multistep converges diverges.

Lemma diverges_imp_not_converge : forall a, diverges a -> ~(converges a).
Proof.
  intros a H.
  (* -> *)
  inversion H. subst.
  unfold not. intros HC. inversion HC. subst. inversion H1. inversion H2. subst.
  unfold not in H4. apply H4. apply H0. auto.
Defined.

Lemma converges_imp_not_diverge : forall a, converges a -> ~(diverges a).
Proof.
  intros.
  inversion H. subst. inversion H0. inversion H1. subst.
  unfold not. intros Hd. apply H3. inversion Hd. subst. apply H4 in H2. auto.
Defined.

(* omega diverges, for fun *)
Lemma omega_diverges : diverges (fp 0).
Proof.
  intros. constructor. intros. inversion H. subst.
  (* ->* refl *)
  constructor. exists (open 0 (fp 0)). apply eval_fp.
  apply lc_fp with (L := {}). intros. compute. apply lc_fvar.
  subst.
  (* ->* eval *)
  constructor.
  inversion H0. subst. compute in *.
  exists (fp 0). auto.
Defined.

Inductive value : term -> Prop :=
| value_abs : forall t, lc (abs t) -> value (abs t)
| value_unit : value unit
| value_prod : forall t1 t2, lc (prod t1 t2) -> value (prod t1 t2)
| value_inl : forall t, lc (inl t) -> value (inl t)
| value_inr : forall t, lc (inr t) -> value (inr t).

Hint Constructors value.

Lemma value_not_reduces : forall t, value t -> ~ (reduces t).
Proof.
  induction t ; intros Hv ; inversion Hv ; unfold not ; intros Hr ; inversion Hr as [x He] ;
    subst ; inversion He as [x H] ; inversion H.
Defined.

Lemma reduces_not_value : forall t, reduces t -> ~ value t.
Proof.
  induction t ; intros Hr ; inversion Hr as [x He] ; subst ; unfold not ; intros Hv ; inversion Hv;
    subst ; inversion He as [x H] ; inversion H.
Defined.

Inductive active : term -> Prop :=
| active_prod : forall t1 t2, lc (prod t1 t2) -> active (prod t1 t2)
| active_inl : forall t, lc (inl t) -> active (inl t)
| active_inr : forall t, lc (inr t) -> active (inr t).

Inductive passive : term -> Prop :=
| passive_unit : passive unit
| passive_abs : forall t, lc (abs t) -> passive (abs t)
| passive_fp : forall t, lc (fp t) -> passive (fp t).

Inductive label : Set :=
| label_fst
| label_snd
| label_inl
| label_inr
| label_fp
| label_app : forall (b : term), label.

(* we need an arbitrary divergent term of active type *)
Definition inf := inl (fp (inl 0)).

(* create a transition system for our functional programs *)
Inductive trans : term -> label -> term -> Prop :=
| trans_fst : forall t1 t2, lc (prod t1 t2) -> trans (prod t1 t2) label_fst t1
| trans_snd : forall t1 t2, lc (prod t1 t2) -> trans (prod t1 t2) label_snd t2
| trans_inl : forall t, lc (inl t) -> trans (inl t) label_inl t
| trans_inr : forall t, lc (inr t) -> trans (inr t) label_inr t
| trans_fp : forall t, lc (fp t) -> trans (fp t) label_fp  (open t (fp t))
| trans_app : forall t1 t2, lc t1 -> lc t2 -> trans t1 (label_app t2) (app t1 t2)
| trans_next : forall t1 t2 t3 l, lc t1 -> eval t1 t2 -> trans t2 l t3 -> trans t1 l t3.

(* terms remain locally closed by undergoing a transition *)
Lemma trans_regular : forall t1 t2 l, trans t1 l t2 -> lc t1 /\ lc t2.
Proof.
  intros t1 t2 l H. induction H ; subst ; try (split ; auto ; inversion H ; subst ; auto ; fail ).
  (* fp *)
  split. auto. apply open_fp. auto. auto.
  (* next *)
  split. auto. inversion IHtrans. auto.
Defined.

CoInductive simulates : term -> term -> Prop :=
| simulates_base : forall a a' b l,
  trans a l a' ->
  (exists b', trans b l b' -> simulates a' b') ->
  simulates a b.

CoInductive bisimulates : term -> term -> Prop :=
| bisimulates_base : forall a a' b b' l,
  trans a l a' ->
  (exists b'', trans b l b'' -> bisimulates a' b'') ->
  trans b l b' ->
  (exists a'', trans a l a'' -> bisimulates a'' b') ->
  bisimulates a b.

Lemma bisimulation_impl_simulation_right : forall a b, bisimulates a b -> simulates a b.
Proof.
  refine
    (cofix bisim (a b : term) (Hb : bisimulates a b) : simulates a b :=
      _).
  inversion Hb. subst. inversion H0.
  eapply simulates_base. eexact H.
  exists x. intros. apply H3 in H4. apply bisim. auto.
Defined.

Lemma bisimulation_impl_simulation_left : forall a b, bisimulates a b -> simulates b a.
Proof.
  refine
    (cofix bisim (a b : term) (Hb : bisimulates a b) : simulates b a :=
      _).
  inversion Hb. subst. inversion H2.
  eapply simulates_base. eexact H1.
  exists x. intros. apply H3 in H4. apply bisim. auto.
Defined.

Lemma simulation_refl : forall a, simulates a a.
Proof.
  refine
    (cofix sim (a:term) : simulates a a := _).
  eapply simulates_base ; destruct a.
  Focus 2. exists

(* behavioural equivalence relation *)
CoInductive b_eq : term -> term -> Prop :=
| b_eq_base :
  forall a b b',

(* hard to prove...
Lemma value_is_eval : forall t, value t <-> exists b, evaluates b t.
Proof.
  intros t ; split.
  (* -> *)
  intros Hv. exists t. apply evaluates_base. apply multistep_refl.
  unfold not. intros Hr. inversion Hv ; subst ; inversion Hr as [x He] ; subst ;
    inversion He as [x Hes] ;
      inversion Hes.
  (* <- *)
  intros He. inversion He. inversion H. subst.
  induction t. inversion H0. subst.
  inversion He. inversion H2. subst. inversion H3. subst.
  inversion H0. subst.
*)

Fixpoint raise (t : term) :=
  match t with
    | unit => unit
    | fp t' => fp (raise t')
    | fvar s => fvar s
    | bvar n => bvar (S n)
    | abs t' => abs (raise t')
    | app m n => app (raise m) (raise n)
    | prod e1 e2 => prod (raise e1) (raise e2)
    | proj1 e => proj1 (raise e)
    | proj2 e => proj2 (raise e)
    | inl e => inl (raise e)
    | inr e => inr (raise e)
    | cas e e1 e2 => cas (raise e) (raise e1) (raise e2)
  end.

(* case distributivity *)
Fixpoint case_dist (t : term) : term :=
  match t with
    | cas (cas e e1 e2) f1 f2 =>
      cas e
      (cas e1 (raise (case_dist f1)) (raise (case_dist f2)))
      (cas e2 (raise (case_dist f1)) (raise (case_dist f2)))
    | unit => unit
    | fp t' => fp (case_dist t')
    | fvar s => fvar s
    | bvar n => bvar (S n)
    | abs t' => abs (case_dist t')
    | app m n => app (case_dist m) (case_dist n)
    | prod e1 e2 => prod (case_dist e1) (case_dist e2)
    | proj1 e => proj1 (case_dist e)
    | proj2 e => proj2 (case_dist e)
    | inl e => inl (case_dist e)
    | inr e => inr (case_dist e)
    | cas e e1 e2 => cas (case_dist e) (case_dist e1) (case_dist e2)
  end.

(* eval_big : big step operational semantics

------
e => e

e => e' e' -> e''
-----------------
     e => e''

*)

(* eval_coind : big step coinductive operational semantics *)

CoInductive diverges : term -> Prop :=
| diverges_app_1 : forall e e', diverges e -> diverges (app e e')
| diverges_app_2 : forall e1 e2 e2', eval_big e e' -> diverges
| diverges_cas : forall e e1 e2, diverges e -> diverges (cas e e1 e2)
| diverges

Notation "`case` t `of` { A | B }" := (cas t A B).

(* nat := 1 + nat *)
Definition Zero := inl unit.
Definition Succ := (fun x => inr x).
(* bool := 1 + 1 *)
Definition T := inl unit.
Definition F := inr unit.

(* Nat = 1 + Nat *)
Definition One := Succ Zero.
Definition Two := Succ One.
Definition Three := Succ Two.
Definition add := (fp (abs (abs (abs (cas 2 (abs 2) (abs (Succ (app (app 3 0) 2)))))))).

Ltac lc_abs_run :=
  let L := fresh "L" in
    intros ; compute ; pick_fresh L ; apply (lc_abs L).

Ltac prove_lc :=
  match goal with
    | |- lc (fp ?x) => apply lc_fp
    | |- lc (abs ?x) => lc_abs_run ; intros ; compute
    | |- lc (cas ?x ?y ?z) => apply lc_cas
    | |- lc (inr ?x) => apply lc_inr
    | |- lc (inl ?x) => apply lc_inl
    | |- lc ?x => auto
  end.

Lemma add_lc : lc add.
Proof.
  unfold add.
  repeat prove_lc.
Defined.

Lemma eval_add : eval (app (app add One) Two) Three.
Proof.
  compute.


(****************************************************************************)
(****************************************************************************)
(****                                                                    ****)
(****   Restrictions imposed by Coq to ensure consistency of the logic   ****)
(****                                                                    ****)
(****************************************************************************)
(****************************************************************************)

(********************************************************)
(* All functions must be statically known to terminate. *)
(********************************************************)

(* Coq rejects all nonterminating functions, such as: *)

Fail Fixpoint f (n : nat) : False := f n.

(*
  ```
  The command has indeed failed with message:
  Recursive definition of f is ill-formed.
  In environment
  f : nat -> False
  n : nat
  Recursive call to f has principal argument equal to
  "n" instead of a subterm of "n".
  Recursive definition is: "fun n : nat => f n".
  ```

  If we were allowed to write that function, we could use it to prove `False`:

  ```
  Definition paradox : False := f 0.
  ```

  To prevent this, Coq requires that recursive functions have some argument
  which is structurally "decreasing" at every recursive call. Coq can
  automatically figure out which argument that is.
*)

(***************************************************)
(* A brief summary of the universe behavior in Coq *)
(***************************************************)

(*
  Consider a type, such as `nat`. What is its type? Suppose we call it `Type`,
  so `nat : Type`. Then what is the type of `Type`?

  One might guess that `Type` is its own type, i.e., `Type : Type`. However, in
  a rather convoluted way, this would allow one to define a nonterminating
  function and prove `False`. This is called Girard's paradox, and you can find
  it in this repo here:

    https://github.com/stepchowfun/proofs/blob/main/proofs/TypeTheory/Girard.v

  So, instead of having `Type : Type`, we have an infinite heirarchy of
  universes `Type_i` for all `i` >= 0. For convenience, universes are
  cumulative, so `x : Type_i` implies `x : Type_{i+1}`. `Type_0` is called
  `Set`. All of these `Type_i` universes, including `Set`, are "predicative",
  which will be explained below. However, in the universe containing `Set`
  (namely, `Type_1`), we also have an "impredicative" universe called `Prop`.
*)

(*
  If `A, B : Type_i`, then `A -> B : Type_i`. This is called *predicativity*.
*)

Check bool -> nat. (* `Set` *)
Check Set -> Set. (* `Type@{Set+1}` *)
Check Prop -> Set. (* `Type@{Set+1}` *)

(*
  If `A` and `B` are in different universes, there will be some higher universe
  which contains them both due to cumulativity.
*)

Check Set -> nat. (* `Type@{Set+1}` *)

(* If `B : Prop`, then `A -> B : Prop`. This is called *impredicativity*. *)

Check nat -> True. (* `Prop` *)
Check Set -> True. (* `Prop` *)
Check Prop -> True. (* `Prop` *)

(* Here are some identity functions for different universes: *)

Definition idProp (t : Prop) (x : t) := x.
Definition idSet  (t : Set) (x : t) := x.

(* Because `Prop` is impredicative, we can apply `idProp` to itself. *)

Check idProp (forall t : Prop, t -> t) idProp. (* `forall t : Prop, t -> t` *)

(*
  But `Set` (a.k.a. `Type_0`) is predicative, so we can't apply `idSet` to
  itself:
*)

Fail Check idSet (forall t : Set, t -> t) idSet.

(*
  ```
  The command has indeed failed with message:
  The term "forall t : Set, t -> t" has type "Type"
  while it is expected to have type "Set"
  (universe inconsistency: Cannot enforce Set+1 <= Set).
  ```

  When we write `Type`, Coq automatically figures out which level `i` should be
  used. In fact, there is no way to explicitly specify it.

  Let's fix some particular universe and let Coq choose some level `i` for it.
*)

Definition universe := Type.

(* Here's an identity function for that universe: *)

Definition idUniverse (t : universe) (x : t) := x.

(* Like with `idSet`, predicativity forbids the following: *)

Fail Check idUniverse (forall t : universe, t -> t) idUniverse.

(*
  ```
  The command has indeed failed with message:
  The term "forall t : universe, t -> t" has type "Type"
  while it is expected to have type "universe"
  (universe inconsistency: Cannot enforce universe.u0 < universe.u0 because
  universe.u0 = universe.u0).
  ```
*)

(*********************************)
(* Universes and inductive types *)
(*********************************)

(* Let's define a universe larger than `Set`. *)

Definition large := Type.

Definition constraint : large := Set.

(*
  If an inductive type in `Type_i` has a constructor which takes an argument of
  type `T` in universe `Type_j`, `i` must be at least as large as `j`.
  Parameter arguments are not considered.
*)

Inductive foo1 : Set :=
| makeFoo1 : nat -> foo1.

Fail Inductive foo2 : Set :=
| makeFoo2 : Set -> foo2.

(*
  ```
  The command has indeed failed with message:
  Large non-propositional inductive types must be in Type.
  ```
*)

Inductive foo3 : large :=
| makeFoo3 : Set -> foo3.

(* This restriction doesn't apply to inductive types in `Prop`. *)

Inductive foo4 : Prop :=
| makeFoo4 : Set -> foo4.

(*
  There are no constraints between the universe of an inductive type and the
  universes of its indices.
*)

Inductive foo5 : large -> Set :=
| makeFoo5 : foo5 Set.

Inductive foo6 : large -> Prop :=
| makeFoo6 : foo6 Set.

(*
  There are no constraints between the universe of an inductive type and the
  universes of its parameters.
*)

Inductive foo7 (x : large) : Set :=
| makeFoo7 : foo7 x.

Inductive foo8 (x : large) : Prop :=
| makeFoo8 : foo8 x.

(***********************************************************)
(* Inductive types have a "strict positivity requirement". *)
(***********************************************************)

(* The following type is allowed, even though it has no inhabitants. *)

Inductive weird :=
| makeWeird : weird -> weird.

(* This "reflexive" type is also allowed: *)

Inductive weirder :=
| makeWeirder : (nat -> weirder) -> weirder.

(* However, the following is not allowed: *)

Fail Inductive bad :=
| makeBad : (bad -> nat) -> bad.

(*
  ```
  The command has indeed failed with message:
  Non strictly positive occurrence of "bad" in "(bad -> nat) -> bad".
  ```

  Why does coq reject `bad`? Suppose it were allowed. Consider the following
  function:

  ```
  Definition evil (x : bad) : nat :=
    match x with
    | makeBad f => f x
    end.
  ```

  We could use `evil` to construct the following diverging term:

  ```
  Definition catastrophe : nat := evil (makeBad evil).
  ```

  This is also rejected:
*)

Fail Inductive alsoBad :=
| makeAlsoBad : ((alsoBad -> nat) -> nat) -> alsoBad.

(*
  `alsoBad` could be used to construct a diverging function in an impredicative
  universe, as demonstrated in this paper:

    Coquand, T., Paulin, C. (1990). Inductively defined types. In: Martin-Löf,
    P., Mints, G. (eds) COLOG-88. COLOG 1988. Lecture Notes in Computer
    Science, vol 417. Springer, Berlin, Heidelberg.
    https://doi.org/10.1007/3-540-52335-9_47

  `alsoBad` is not known to cause any theoretical issues in predicative
  universes, but Coq still rejects it regardless of the universe in which it's
  defined.
*)

(*************)
(* Exercises *)
(*************)

(*
  1. Explain why Coq requires that all functions terminate on all inputs. How
     does Coq enforce this?
  2. No type can be its own type, yet `Check Type` reports `Type : Type`.
     What's really going on here?
  3. Describe cumulativity. Can you think of an example in which it's useful?
  4. Describe impredicativity. Does `Set` have it? Does `Prop` have it? Do the
     `Type` universes have it?
  5. Describe the restrictions Coq imposes on inductive data types.
*)


Inductive ForallT {A : Type} (P : A -> Type) : list A -> Type :=
| ForallT_nil : ForallT P nil
| ForallT_cons a l :
  P a -> ForallT P l ->
  ForallT P (cons a l).

(* A non-empty rose-tree. If empty rose-trees are necessary, use
   [option] of this type, or add a nil constructor. (These two
   approaches yield different results.) *)
Inductive RTree (A : Type) : Type :=
| RTree_cons : A -> list (RTree A) -> RTree A.

Arguments RTree_cons {_} _ _.

Require Import List.
Import ListNotations.

Inductive RTForallT {A : Type} (P : A -> Type) : RTree A -> Type :=
| RTF_nil a :
  P a -> RTForallT P (RTree_cons a [])
| RTF_cons a l b :
  RTForallT P b ->
  RTForallT P (RTree_cons a l) ->
  RTForallT P (RTree_cons a (b :: l)).

Lemma RTForallT_inv_root A P a l :
  @RTForallT A P (RTree_cons a l) ->
  P a.
Proof.
  intros.
  induction l.
  { inversion X; subst; clear X.
    assumption.
  }
  inversion X; subst; clear X.
  auto.
Qed.

Lemma RTForallT_inv_list A P a l :
  @RTForallT A P (RTree_cons a l) ->
  ForallT (RTForallT P) l.
Proof.
  intros.
  induction l.
  { constructor. }
  constructor.
  { inversion X; subst; clear X.
    assumption.
  }
  inversion X; subst; clear X.
  auto.
Qed.

Inductive RTForallT0 {A : Type} (P : A -> Type) : RTree A -> Type :=
| RTF0_cons (a : A) (l : list (RTree A)) :
  P a -> ForallT (RTForallT0 P) l ->
  RTForallT0 P (RTree_cons a l).

Lemma RTForallT0_complete {A : Type} (P : A -> Type) t :
  RTForallT P t -> RTForallT0 P t.
Proof.
  intros.
  induction X.
  { constructor; try assumption.
    constructor.
  }
  inversion IHX2; subst; clear IHX2.
  constructor; try assumption.
  constructor; try assumption.
Qed.

Section RTree_rect.
  Context {A : Type}.
  Variable (P : RTree A -> Type).
  Variable (Q : A -> Type).

  Hypothesis Hcons :
    forall (a : A) (l : list (RTree A)),
      Q a -> ForallT P l ->
      P (RTree_cons a l).

  Fixpoint RTree_rect1 (t : RTree A) (H : RTForallT0 Q t) : P t.
  Proof.
    intros.
    induction H.
    apply Hcons; try assumption.
    induction f; constructor.
    { now apply RTree_rect1. }
    assumption.
  Defined.

  Corollary RTree_rect0 (t : RTree A) (H : RTForallT Q t) : P t.
  Proof.
    apply RTree_rect1.
    apply RTForallT0_complete.
    assumption.
  Defined.
End RTree_rect.

Definition RTree_root {A : Type} (t : RTree A) : A :=
  match t with
  | RTree_cons e _ => e
  end.

Fixpoint RTForallT_True {A : Type} t :
  RTForallT (fun _ : A => True) t.
Proof.
  induction t.
  induction l.
  { constructor.
    constructor.
  }
  constructor.
  { apply RTForallT_True. }
  assumption.
Defined.

Lemma RTForallT_forall {A : Type} (P : A -> Type) :
  (forall a : A, P a) ->
  forall t, RTForallT P t.
Proof.
  intros.
  apply RTree_rect0 with (Q := (fun _ => True)).
  2: {
    apply RTForallT_True.
  }
  intros.
  induction X0; constructor; auto.
Qed.

Lemma ForallT_dec {A : Type} (P : A -> Type) :
  (forall a : A, P a + (P a -> False)) ->
  forall l, ForallT P l + (ForallT P l -> False).
Proof.
Admitted.

Lemma ForallT_dec_lift {A : Type} (P : A -> Type) l :
  ForallT (fun D => (P D) + (P D -> False))%type l ->
  ForallT P l + (ForallT P l -> False).
Proof.
  intros.
  induction X.
  { left. constructor. }
  destruct p.
  2: {
    right.
    intros.
    inversion X0; subst; clear X0.
    contradiction.
  }
  destruct IHX.
  - left. constructor; assumption.
  - right. intros.
    inversion X0; subst; clear X0.
    contradiction.
Qed.

Fixpoint ForallT_map {A : Type} {P : A -> Type} {Q : A -> Type} (f : forall a, P a -> Q a)
      (l : list A) (H : ForallT P l) :
  list { a & { b : P a & Q a } } :=
  match H with
  | ForallT_nil _ => []
  | ForallT_cons _ a l Ha Hl => (existT _ a (existT _ Ha (f a Ha))) :: (ForallT_map f l Hl)
  end.

Lemma ForallT_impl {A : Type} {P Q : A -> Type} :
  (forall a, P a -> Q a) ->
  forall l,
    ForallT P l ->
    ForallT Q l.
Proof.
  intros.
  induction X0; constructor; auto.
Defined.

Lemma ForallT_map0 {A B : Type} (f : A -> B) (P : B -> Type) (l : list A) :
  ForallT (fun x : A => P (f x)) l ->
  ForallT P (map f l).
Proof.
  intros.
  induction X.
  { constructor. }
  simpl.
  constructor; assumption.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.

Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.

Implicit Arguments old.

Inductive list (a:Type) :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Set Contextual Implicit.
Implicit Arguments Nil.
Unset Contextual Implicit.
Implicit Arguments Cons.

Set Implicit Arguments.
Fixpoint mem (a:Type)(x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem x r)
  end.
Unset Implicit Arguments.

Set Implicit Arguments.
Fixpoint infix_plpl (a:Type)(l1:(list a)) (l2:(list a)) {struct l1}: (list
  a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.
Unset Implicit Arguments.

Axiom Append_assoc : forall (a:Type), forall (l1:(list a)) (l2:(list a))
  (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall (a:Type), forall (l:(list a)), ((infix_plpl l
  (Nil:(list a))) = l).

Set Implicit Arguments.
Fixpoint length (a:Type)(l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.
Unset Implicit Arguments.

Axiom Length_nonnegative : forall (a:Type), forall (l:(list a)),
  (0%Z <= (length l))%Z.

Axiom Length_nil : forall (a:Type), forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil:(list a))).

Axiom Append_length : forall (a:Type), forall (l1:(list a)) (l2:(list a)),
  ((length (infix_plpl l1 l2)) = ((length l1) + (length l2))%Z).

Axiom mem_append : forall (a:Type), forall (x:a) (l1:(list a)) (l2:(list a)),
  (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x l2)).

Axiom mem_decomp : forall (a:Type), forall (x:a) (l:(list a)), (mem x l) ->
  exists l1:(list a), exists l2:(list a), (l = (infix_plpl l1 (Cons x l2))).

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall (a:Type) (b:Type), (map a b) -> a -> b.

Implicit Arguments get.

Parameter set: forall (a:Type) (b:Type), (map a b) -> a -> b -> (map a b).

Implicit Arguments set.

Axiom Select_eq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall (b:Type) (a:Type), b -> (map a b).

Set Contextual Implicit.
Implicit Arguments const.
Unset Contextual Implicit.

Axiom Const : forall (b:Type) (a:Type), forall (b1:b) (a1:a), ((get (const(
  b1):(map a b)) a1) = b1).

Inductive array (a:Type) :=
  | mk_array : Z -> (map Z a) -> array a.
Implicit Arguments mk_array.

Definition elts (a:Type)(u:(array a)): (map Z a) :=
  match u with
  | (mk_array _ elts1) => elts1
  end.
Implicit Arguments elts.

Definition length1 (a:Type)(u:(array a)): Z :=
  match u with
  | (mk_array length2 _) => length2
  end.
Implicit Arguments length1.

Definition get1 (a:Type)(a1:(array a)) (i:Z): a := (get (elts a1) i).
Implicit Arguments get1.

Definition set1 (a:Type)(a1:(array a)) (i:Z) (v:a): (array a) :=
  match a1 with
  | (mk_array xcl0 _) => (mk_array xcl0 (set (elts a1) i v))
  end.
Implicit Arguments set1.

Inductive tree  :=
  | Empty : tree
  | Node : tree -> tree -> tree .

Set Implicit Arguments.
Fixpoint size(t:tree) {struct t}: Z :=
  match t with
  | Empty => 0%Z
  | (Node l r) => ((1%Z + (size l))%Z + (size r))%Z
  end.
Unset Implicit Arguments.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem size_nonneg : forall (t:tree), (0%Z <= (size t))%Z.
(* YOU MAY EDIT THE PROOF BELOW *)
induction t; intuition.
unfold size; fold size; omega.
Qed.
(* DO NOT EDIT BELOW *)