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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* ---                        monoid.v                                  --- *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(*
 A monoid on some M:Set is a structure composed of a binary
 associative operation o:M->M->M, and a neutral element u:M
 for o.
*)

Require Import Arith.
Require Import Constants.

Section monoid_def.

Variable M : Set.

Record monoid : Set := mkmonoid
  {u : M;
   o : M -> M -> M;
   point_assoc : forall a b c : M, o a (o b c) = o (o a b) c;
   u_neutral_l : forall a : M, o u a = a;
   u_neutral_r : forall a : M, o a u = a}.

Hint Resolve point_assoc u_neutral_r u_neutral_l: arith.

Variable MO : monoid.
Let u' := u MO.
Let o' := o MO.
Remark o'_assoc : forall a b c : M, o' a (o' b c) = o' (o' a b) c.
exact (point_assoc MO).
Qed.
Hint Resolve o'_assoc: arith.

Remark u'_neutral_l : forall a : M, o' u' a = a.
exact (u_neutral_l MO).
Qed.
Hint Resolve u'_neutral_l: arith.

Remark u'_neutral_r : forall a : M, o' a u' = a.
exact (u_neutral_r MO).
Qed.
Hint Resolve u'_neutral_r: arith.

(* powering
************)
Fixpoint power (x : M) (n : nat) {struct n} : M :=
  match n with
  | O => u'
  | S n => o' x (power x n)
  end.

(* some lemmas on powering *)
(***************************)

Lemma power_u : forall m : nat, power u' m = u'.
(******************************)
Proof.
 simple induction m; simpl in |- *.
 auto with arith.
 intros.
 rewrite H; auto with arith.
Qed.
Hint Resolve power_u: arith.

Lemma power_plus :
 forall (a : M) (n p : nat), power a (n + p) = o' (power a n) (power a p).
(****************************************************)
Proof.
 simple induction n; simpl in |- *; [ auto with arith | intros ].
 rewrite (H p); auto with arith.
Qed.
Hint Resolve power_plus: arith.

Lemma power_1 : forall a : M, power a 1 = a.
(***********************************)
Proof.
 intro; simpl in |- *; auto with arith.
Qed.

Lemma power_sym :
 forall (a : M) (n p : nat),
 o' (power a n) (power a p) = o' (power a p) (power a n).
(*************************************************************)
Proof.
 intros.
 rewrite <- power_plus.
 rewrite <- power_plus.
 rewrite plus_comm; auto with arith.
Qed.
Hint Resolve power_sym: arith.

Lemma power_mult :
 forall (a : M) (n p : nat), power a (p * n) = power (power a n) p.
(*****************************************************)
Proof.
 simple induction p; simpl in |- *.
 auto with arith.
 intros n0 H.
 rewrite power_plus.
 elim H; auto with arith.
Qed.
Hint Resolve power_mult: arith.

Lemma a2x : forall (a : M) (x : nat), power (o' a a) x = power a (x + x).
(***************************************************************)
Proof.
 simple induction x; simpl in |- *.
 auto with arith.
 intros; simpl in |- *.
 rewrite <- plus_n_Sm.
 simpl in |- *.
 rewrite o'_assoc; elim H; auto with arith.
Qed.

Lemma power_eucl :
 forall (m : M) (b q r : nat),
 power m (q * b + r) = o' (power (power m b) q) (power m r).
(*************************************************************)
Proof.
 intros; rewrite power_plus.
 rewrite power_mult.
 auto with arith.
Qed.
Hint Resolve power_eucl: arith.

End monoid_def.


(*
REFERENCES:
The code contained in this file is heavily based on the code from
    - "Software Foundations 1: Logical Foundations, Imp.v. Maps.v"
        "https://softwarefoundations.cis.upenn.edu/lf-current/Imp.html"
    - "Software Foundations 2: Programming Language Foundations, Hoare.v"
        "https://softwarefoundations.cis.upenn.edu/plf-current/Hoare.html"
Both by Benjamin C. Pierce, et al. 2021.
The base of this code has been taken directly from these files,
    and some code has been taken and edited to fit our project.
All additions and edits to the code has been by, or in coorporation with, ITU associate professor Alessandro Bruni.
The project has been supervised by course teacher Jesper Bengtson.

Code comments are provided to indicate authorship of the code.
  'Edited' mean code taken and edited from the books,
  no comment means code taken directly from the book.
*)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Lists.List. Import ListNotations.
From mathcomp.ssreflect Require Import all_ssreflect.
From mathcomp Require Import finmap.
From infotheo Require Import fsdist proba.
Require Import Reals.

(*Added by Alessandro*)
Definition var := ordinal 64.

(*Edited by Alessandro*)
Definition state := {ffun var -> nat}.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AId (x : var)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Coercion AId : var >-> aexp.
Coercion ANum : nat >-> aexp.

Declare Custom Entry com.
Declare Scope com_scope.
Notation "<{ e }>" := e (at level 0, e custom com at level 99) : com_scope.
Notation "( x )" := x (in custom com, x at level 99) : com_scope.
Notation "x" := x (in custom com at level 0, x constr at level 0) : com_scope.
Notation "f x .. y" := (.. (f x) .. y)
                  (in custom com at level 0, only parsing,
                  f constr at level 0, x constr at level 9,
                  y constr at level 9) : com_scope.
Notation "x + y" := (APlus x y) (in custom com at level 50, left associativity).
Notation "x - y" := (AMinus x y) (in custom com at level 50, left associativity).
Notation "x * y" := (AMult x y) (in custom com at level 40, left associativity).
Notation "'true'"  := true (at level 1).
Notation "'true'"  := BTrue (in custom com at level 0).
Notation "'false'"  := false (at level 1).
Notation "'false'"  := BFalse (in custom com at level 0).
Notation "x <= y" := (BLe x y) (in custom com at level 70, no associativity).
Notation "x = y"  := (BEq x y) (in custom com at level 70, no associativity).
Notation "x && y" := (BAnd x y) (in custom com at level 80, left associativity).
Notation "'~' b"  := (BNot b) (in custom com at level 75, right associativity).

Open Scope com_scope.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | <{a1 + a2}> => (aeval st a1) + (aeval st a2)
  | <{a1 - a2}> => (aeval st a1) - (aeval st a2)
  | <{a1 * a2}> => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | <{true}> => true
  | <{false}> => false
  | <{a1 = a2}> => (aeval st a1) =? (aeval st a2)
  | <{a1 <= a2}> => (aeval st a1) <=? (aeval st a2)
  | <{~ b1}> => negb (beval st b1)
  | <{b1 && b2}> => andb (beval st b1) (beval st b2)
  end.

(*Edited by Alessandro*)
Definition t_empty v : state := [ffun x => v].

(*Edited by Alessandro*)
Definition t_update st i v : state :=
  [ffun x => if i == x then v else st x].

Notation "'_' '!->' v " := (t_empty v)
  (at level 100, right associativity).

Notation "x '!->' v ';' m" := (t_update m x v)
  (at level 100, v at next level, right associativity).

(*Edited and proved by Alessandro*)
Lemma t_apply_empty : forall x v,
(_ !-> v) x = v.
Proof.
move => x v.
rewrite /t_empty=> /=.
by rewrite ffunE.
Qed.

(*Edited by Alessandro*)
Inductive com : Type :=
  | CSkip
  | CAsgn (x : var) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CPlus (p : Reals_ext.Prob.t) (c1 c2 : com).

Notation "'skip'"  :=
    CSkip (in custom com at level 0) : com_scope.
Notation "x := y"  :=
    (CAsgn x y)
       (in custom com at level 0, x constr at level 0,
        y at level 85, no associativity) : com_scope.
Notation "x ; y" :=
    (CSeq x y)
      (in custom com at level 90, right associativity) : com_scope.
Notation "'if' x 'then' y 'else' z 'end'" :=
    (CIf x y z)
      (in custom com at level 89, x at level 99,
       y at level 99, z at level 99) : com_scope.

(*Added by Alessandro*)
Notation "c1 '[+' p ']' c2" := (CPlus p c1 c2)
       (in custom com at level 90, p at level 85, right associativity) : com_scope.

(*Added by Alessandro*)
Fixpoint sample x a1 as_ :=
  match as_ with
  | [] => (<{x := a1}>)
  | (a2::as__) => <{ x := a1 [+ (Reals_ext.probdivRnnm 1 (List.length as_))] (sample x a2 as__)}>
  end.

(*Added by Alessandro*)
Notation "x '$=' { a1 ; a2 ; .. ; an }" := (sample x a1 (cons a2 .. (cons an nil) ..))
  (in custom com at level 0, x constr at level 0,
  a1 at level 85, a2 at level 85, an at level 85, no associativity) : com_scope.

(*Added by Alessandro in collaboration w. group*)
Definition half : Reals_ext.Prob.t := Reals_ext.probdivRnnm 1 2.

(*Edited by group in collaboration w. Alessandro*)
Fixpoint ceval (st : state) (c : com) :=
  match c with
  | <{ skip }> => FSDist1.d st
  | <{ x := a }> => FSDist1.d (x !-> (aeval st a) ; st)
  | <{ c1 ; c2 }> =>
      let st' := ceval st c1 in
      FSDistBind.d st' (fun st => ceval st c2)
  | <{ if b then c1 else c2 end }> =>
      if (beval st b)
        then ceval st c1
        else ceval st c2
  | <{ c1 [+ p] c2}> => ConvFSDist.d p (ceval st c1) (ceval st c2)
  end.

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
    forall st, P st -> Q st.

Definition Aexp : Type := state -> nat.

Definition assert_of_Prop (P : Prop) : Assertion := fun _ => P.
Definition Aexp_of_nat (n : nat) : Aexp := fun _ => n.
Definition Aexp_of_aexp (a : aexp) : Aexp := fun st => aeval st a.

Coercion assert_of_Prop : Sortclass >-> Assertion.
Coercion Aexp_of_nat : nat >-> Aexp.
Coercion Aexp_of_aexp : aexp >-> Aexp.

Arguments assert_of_Prop /.
Arguments Aexp_of_nat /.
Arguments Aexp_of_aexp /.

Declare Scope assertion_scope.
Bind Scope assertion_scope with Assertion.
Bind Scope assertion_scope with Aexp.
Delimit Scope assertion_scope with assertion.

Notation assert P := (P%assertion : Assertion).
Notation mkAexp a := (a%assertion : Aexp).
Notation "~ P" := (fun st => ~ assert P st) : assertion_scope.
Notation "P /\ Q" := (fun st => assert P st /\ assert Q st) : assertion_scope.
Notation "P \/ Q" := (fun st => assert P st \/ assert Q st) : assertion_scope.
Notation "P -> Q" := (fun st => assert P st ->  assert Q st) : assertion_scope.
Notation "P <-> Q" := (fun st => assert P st <->  assert Q st) : assertion_scope.
Notation "a = b" := (fun st => mkAexp a st = mkAexp b st) : assertion_scope.
Notation "a <> b" := (fun st => mkAexp a st <> mkAexp b st) : assertion_scope.
Notation "a <= b" := (fun st => mkAexp a st <= mkAexp b st) : assertion_scope.
Notation "a < b" := (fun st => mkAexp a st < mkAexp b st) : assertion_scope.
Notation "a >= b" := (fun st => mkAexp a st >= mkAexp b st) : assertion_scope.
Notation "a > b" := (fun st => mkAexp a st > mkAexp b st) : assertion_scope.
Notation "a + b" := (fun st => mkAexp a st + mkAexp b st) : assertion_scope.
Notation "a - b" := (fun st => mkAexp a st - mkAexp b st) : assertion_scope.
Notation "a * b" := (fun st => mkAexp a st * mkAexp b st) : assertion_scope.

(* ####### HOARE QUADRUPLE ####### *)

(*Added by Alessandro*)
Local Open Scope proba_scope.

(*Added by Alessandro*)
Local Open Scope com_scope.

(*Added by group in collaboration with Alessandro, under supervision from Jesper*)
Definition hoare_quad
            (P : Assertion) (c : com) (Q : Assertion) (d : R) : Prop :=
    forall st,
        P st ->
        let dst' := (ceval st c) in
        forall (s : {set [finType of finsupp dst']}),
        (forall st', st' \in s <-> Q (fsval st')) ->
        Pr (fdist_of_Dist dst') s = d.

(*Added by group in collaboration with Alessandro*)
Theorem test_skip: forall P,
hoare_quad P CSkip P 1.
Proof.
move => P /=.
rewrite /hoare_quad.
    move => st HPst s HQs //.
    rewrite /FSDist1.d /FSDist1.f.
    (*apply HPst in HQs.*) Admitted.

(*Added by group under supervision from Jesper*)
Theorem test_seq : forall P Q R d1 d2 c1 c2,
    hoare_quad Q c2 R d1 ->
    hoare_quad P c1 Q d2 ->
    hoare_quad P (CSeq c1 c2) R (d1 * d2).
Proof. Admitted.

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Coercion bassn : bexp >-> Assertion.

Arguments bassn /.

(*Added by group under supervision from Jesper*)
Theorem test_if : forall P Q (b: bexp) d c1 c2,
  hoare_quad (P /\ bassn b) c1 Q d ->
  hoare_quad (P /\ ~b) c2 Q d ->
  hoare_quad P (CIf b c1 c2) Q d.
Proof. Admitted.

(*Added by group under supervision from Jesper (does not compile)*)
(*Theorem test_plus : forall P Q c1 c2 p,
  hoare_quad P c1 Q p ->
  hoare_quad P c2 Q (1-p) ->
  hoare_quad P (CPlus p c1 c2) Q.*)

(*Added by group*)
Lemma twoCoins : forall x y,
hoare_quad
    BTrue
    (CSeq (CPlus half (CAsgn x (ANum 1)) (CAsgn x (ANum 2))) (CPlus half (CAsgn y (ANum 1)) (CAsgn y (ANum 2))))
    (x + y = 3)
    (Reals_ext.Prob.p half).
Proof.
intros. unfold hoare_quad. intros. destruct x. Admitted.


Require Import Coq.NArith.NArith Coq.Arith.Div2.
Set Implicit Arguments.
Set Asymmetric Patterns.

Inductive word : nat -> Set :=
| WO : word O
| WS : bool -> forall n, word n -> word (S n).

Fixpoint mod2 (n : nat) : bool :=
  match n with
  | 0 => false
  | 1 => true
  | S (S n') => mod2 n'
  end.

Fixpoint wordToN sz (w : word sz) : N :=
  match w with
  | WO => 0
  | WS false _ w' => 2 * wordToN w'
  | WS true _ w' => Nsucc (2 * wordToN w')
  end%N.

Fixpoint natToWord (sz n : nat) : word sz :=
  match sz with
  | O => WO
  | S sz' => WS (mod2 n) (natToWord sz' (div2 n))
  end.

Definition bar (n n0 : nat)
           (_32 := 10)
           (_4 : nat) (P : Set) (w : forall _ : N, P)
  : @eq P (w (@wordToN _32 (natToWord _32 (n + n0)%nat))) (w (@wordToN _32 (natToWord _32 (n * _4)%nat))).
  Time Timeout 1 repeat esplit.
Abort.

Definition foo (n n0 : nat)
           (_32 := 32)
           (_4 : nat) (P : Set) (w : forall _ : N, P)
  : @eq P (w (@wordToN _32 (natToWord _32 (n + n0)%nat))) (w (@wordToN _32 (natToWord _32 (n * _4)%nat))).
  Time Timeout 1 repeat esplit.
Abort.

Definition baz (n n0 : nat)
           (_32 := 64)
           (_4 : nat) (P : Set) (w : forall _ : N, P)
  : @eq P (w (@wordToN _32 (natToWord _32 (n + n0)%nat))) (w (@wordToN _32 (natToWord _32 (n * _4)%nat))).
  Time Timeout 2 repeat esplit.
Abort.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Definitions from Section 3.5.1 *)
(* Brian Milnes *)

Set Implicit Arguments.
Require Export TLC.LibLN TLC.LibNat TLC.LibEnv.
Require Export LibVarPathEnv.

(* Question: can var be the same for types and programming variables? He does so in ML. *)
(* Arthur uses Set not type, switching. I wonder if it matters. *)

Inductive Kappa : Set :=
 | B                         (* 'boxed' kind. *)
 | A.                        (* 'any'   kind. *)

Inductive Phi : Set :=
 | witnesschanges  : Phi     (* Allowing witness changes. \delta *)
 | aliases        : Phi.     (* Allowing aliases as the opened type. \amp *)

Inductive IPE: Set :=
 | zero_pe
 | one_pe.

Inductive PE : Set :=
 | i_pe      : IPE -> PE
 | u_pe      : PE.

(* Question: will list PE work as paths in TLC? *)
Definition Path : Set := list PE.

Inductive I  : Set :=
 | i_i       : nat -> I.                 (* An integer value in an expression or statement. *)

Inductive V : Set :=
 | bevar      : nat -> V                 (* A bound expression variable, a de Bruijn index. *)
 | fevar      : var -> V.                 (* A free expression variable. *)

Inductive St : Set :=                    (* Terms for statements. *)
 | e_s       : E   -> St                 (* An expression in a statement. *)
 | retn      : E   -> St                 (* Returns are required in this syntax. *)
 | seq       : St  -> St -> St           (* Statement sequencing. *)
 | if_s      : E   -> St -> St   -> St   (* if expression in a statement. *)
 | while     : E   -> St -> St           (* A while statement. *)
 | letx      : E   -> St -> St           (* A let expression. *)
 | openx     : E   -> St -> St           (* open an existential package (elimination) to a value. *)
 | openstar  : E   -> St -> St           (* open an existential package (elimination) with a pointer to the value. *)
with E : Set :=                          (* Terms for expressions. *)
 | v_e        : V -> E                   (* Put a variable into an expression, either bound or free. *)
 | i_e        : I -> E                   (* An integer value in an expression. *)
 | p_e        : V -> list PE -> E        (* This is a term that derefences a path into the value of the variable. *)
 | f_e        : F -> E                   (* A function identifier in an expression or statement. *)
 | amp        : E -> E                   (* Take the address of an expression. *)
 | star       : E -> E                   (* Derefence an expression of a pointer type. *)
 | cpair      : E -> E -> E              (* A pair in an expression. *)
 | dot        : E -> IPE -> E            (* A deference of a pair. *)
 | assign     : E -> E -> E              (* Assignment. *)
 | appl       : E -> E -> E              (* Application expression. app is append. *)
 | call       : St -> E                  (* A call expression for the semantics use. *)
 | inst       : E -> Tau -> E            (* Type instantiation, e[\tau]. *)
 | pack       : Tau -> E -> Tau -> E     (* Existential type introduction. *)
with F : Set :=
 | dfun       : Tau -> Tau -> St -> F    (* Function definition. *)
 | ufun       : Kappa -> F -> F         (* Univerally quantified polymorphic function definition.  *)
with Tau : Set :=
 | btvar  : nat -> Tau                   (* A bound type variable, a de Bruijn index. *)
 | ftvar  : var -> Tau                   (* A free type variable. *)
 | cint   : Tau                          (* Cyclone's Integers. *)
 | cross  : Tau -> Tau -> Tau            (* Pairs. *)
 | arrow  : Tau -> Tau -> Tau            (* Function    type. *)
 | ptype  : Tau -> Tau                   (* Pointer     type. *)
 | utype  : Kappa -> Tau -> Tau          (* Universal   type. *)
 | etype  : Phi -> Kappa -> Tau -> Tau.  (* Existential type. *)

Inductive Term : Set :=
  | term_st : St -> Term
  | term_e :  E -> Term
  | term_f :  F -> Term.

(* Question: what about an inductive schema? *)

Scheme St_ind_mutual := Induction for St Sort Prop
with    E_ind_mutual := Induction for E Sort Prop
with    F_ind_mutual := Induction for F Sort Prop.
Combined Scheme Term_ind_mutual from St_ind_mutual, E_ind_mutual, F_ind_mutual.

Lemma test_wacky_induction:
  forall (t : St),
    t = t.
Proof.
  apply(A_St_ind_mutual
          (fun (t : St) => t = t)
          (fun (t : E) => t = t)
          (fun (t : F) => t = t)
          (fun (t : Tau) => t = t)); reflexivity.

(* Question: do I need lc? Yes I think so. So this has to move also. *)

Inductive Value : E -> Prop :=
 | IIsAValue    : forall (i : I),              Value (i_e i)

 | AmpIsAValue  : forall (v : V) (p : Path),   Value (amp (p_e v p))

 | DfunIsAValue : forall (t1 t2 : Tau) (s : St),
                        Value (f_e (dfun t1 t2 s))
 | UfunIsAValue :
     forall (k : Kappa) (f : F),
       Value (f_e (ufun k f))
 | PairIsAValue :
     forall (v0 v1 : E),
       Value v0 ->
       Value v1 ->
       Value (cpair v0 v1)
 | PackIsAValue :
     forall (tau tau': Tau) (v : E),
       Value v ->
       Value (pack tau v tau').

(* Problem: With pathing contexts and heaps we may run into problems with TLC, as it
really must map a variable path pair to a Type.

  TLC has 200 lines of definitions and 1000 lines of theorems in LibEnv that
 may need to be rebuilt or generalized.

  Additionally, Heap is defined as mapping free variables to values so this Heap is overly
 general for the thesis.

  Finally, should these be free variables or LibLN style variables?
*)

Definition Heap  := env E.
Definition State := prod Heap St.
Definition Delta := env Kappa.
Definition Gamma := env Tau.
Definition Upsilon := LVPE.varpathenv E.

(*
   BUG: This has a GIANT problem. Arthur's env are abstract and yet I want
   to compute with them to build the free variable list.
*)


(**

Reference : "Initial Semantics for Strengthened Signatures" (André Hirschowitz , Marco Maggesi)

Let (H, θ) be a strengthened signature, M an endo-functor.
If M has a structure of (left) module over a monad T, then it can be lifted to endow
H(M) with a structure of module over T.

Let T be the initial Id+H algebra. Then T is the initial representation in the sense of H&M.

Note : A shorter proof of this statment could be formalized by using the proof of initiality
in the category of heterogeneous substitution systems, provided we weaken the notion of heterogeneous
substitution system so that the bracket associated to the functor is not unique.
The proof of initiality in the category of "weak" heterogeneous substitution systems is the same
as the one one already proved formally for the standard notion of heterogeneous substitution system.

version for simplified notion of HSS by Ralph Matthes (2022, 2023)
the file is identical to the homonymous file in the parent directory, except for importing files from the present directory

*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.MoreFoundations.Propositions.
Require Import UniMath.CategoryTheory.PointedFunctors.
Require Import UniMath.CategoryTheory.PointedFunctorsComposition.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.FunctorCategory.
Local Open Scope cat.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.
Require Import UniMath.CategoryTheory.Monads.LModules.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.whiskering.

Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems.
Require Import UniMath.CategoryTheory.HorizontalComposition.

Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.Chains.All.
Require Import UniMath.CategoryTheory.Presheaf.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt.
Require Import UniMath.SubstitutionSystems.GenMendlerIteration_alt.
Require Import UniMath.CategoryTheory.limits.initial.

(** A monad is a pointed endofunctor *)
Definition ptd_from_mon {C:category} (T:Monad C) : category_Ptd C :=
  ((T:functor C C),, η T).

(** Let (Z, e : 1 -> Z) be a pointed endofunctor.
Then e is a morphism (actually the initial morphism) in the category of pointed endofunctors *)

Lemma is_ptd_mor_pt {C : category} (F : ptd_obj C)
  : is_ptd_mor _ (F:=id_Ptd C) (ptd_pt _ F).
Proof.
  intro c; apply id_left.
Qed.

Definition ptd_mor_pt {C:category} (F:ptd_obj C) : ptd_mor _ (id_Ptd C) F :=
  (ptd_pt _ F ,, is_ptd_mor_pt F).

Local Notation σ := (lm_mult _).

Section SignatureLiftModule.

Context {C D : category} (H : Signature C D C).

(** The forgetful functor from pointed endofunctors to endofunctors *)
Local Notation "'U'" := (functor_ptd_forget C).
(** The category of pointed endofunctors on [C] *)
Local Notation "'Ptd'" := (category_Ptd C).
(** The category of endofunctors on [C] *)
Local Notation "'EndC'":= ([C, C]) .

Variables (T : Monad C) (M : LModule T C).

Local Notation Mf := (M : functor _ _).
Local Notation "'p' T" := (ptd_from_mon T) (at level 3).

(** The pointed functor TT *)
Let  T2 := (ptd_compose _ (p T) (p T)) .

(** The multiplication of a monad is a morphism of pointed endofunctors *)
Lemma is_ptd_mor_μ : is_ptd_mor _ (F:= T2) (G:=p T)  (μ T).
Proof.
  intro c. unfold T2. unfold ptd_compose. rewrite functorial_composition_pre_post.
  cbn.
  rewrite <- assoc.
  etrans; [|apply id_right].
  apply cancel_precomposition.
  apply Monad_law2.
Qed.

Definition ptd_mor_from_μ : ptd_mor _ T2 (p T) := (_ ,, is_ptd_mor_μ).

Let strength_law1_pw M x :=
  nat_trans_eq_pointwise
    (θ_Strength1_int_implies_θ_Strength1 _ (Sig_strength_law1 H ) M) x.

(** A pointwise version of the second strength law with only one identity instead
    of two α_functor *)
Lemma strength_law2_pw :
  ∏ (X : EndC) (Z Z' : Ptd) x,
  ((theta H) (X ⊗ (Z p• Z')) : nat_trans _ _) x =
  ((theta H) (X ⊗ Z') •• (U Z):nat_trans _ _) x
  ·
  ((theta H) ((functor_compose (U Z') X) ⊗ Z):nat_trans _ _) x
  ·
  (# H (identity (functor_compose (U Z ∙ U Z') X)
        : [C, C] ⟦ functor_compose (U Z) (U Z' ∙ X : [C, C]),
          functor_compose (U Z ∙ U Z') X ⟧) : nat_trans _ _) x.
Proof.
  intros X Z Z' x.
  etrans; revgoals.
  { apply (nat_trans_eq_pointwise
             (θ_Strength2_int_implies_θ_Strength2 _
                                                  (Sig_strength_law2 H) X Z Z'
                                                  _
                                                  (identity _) ) x). }
  etrans;[eapply pathsinv0;apply id_right|].
  apply cancel_precomposition.
  apply pathsinv0.
  etrans.
  { eapply nat_trans_eq_pointwise.
    apply (functor_id H).
  }
  apply idpath.
Qed.

Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)).
Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H) ).

(** The module multiplication is given by

         Θ_M,T        H(σ)
H(M) T ------> H(MT) ------> H(M)

*)
Local Definition lift_lm_mult : [C,D] ⟦ T ∙ H Mf , H Mf⟧ :=
  nat_trans_comp ((theta H) ((M : C ⟶ C),, ptd_from_mon T)) (# H (σ M)).

Local Definition lift_LModule_data : LModule_data T D :=
  tpair (fun x=> [C,D] ⟦  T ∙ x, x⟧) (H Mf) lift_lm_mult.

Local Lemma lift_lm_mult_laws : LModule_laws _ lift_LModule_data.
Proof.
  split.
  - intro c.
    etrans; [apply assoc|].
    etrans.
    {  apply cancel_postcomposition.
       apply ( θ_nat_2_pw Mf (id_Ptd C) (p T) (ptd_mor_pt _) c). }
    etrans.
    { apply cancel_postcomposition.
      rewrite horcomp_pre_post.
      rewrite (functor_comp H).
      etrans; [apply assoc|].
      apply cancel_postcomposition.
      rewrite pre_whisker_identity; try assumption.
      apply strength_law1_pw. }
    etrans;[|apply id_right].
    rewrite <- assoc.
    apply cancel_precomposition.
    etrans; [ apply functor_comp_pw|].
    etrans; [|apply (nat_trans_eq_pointwise (functor_id H Mf))].
    apply functor_cancel_pw.
    apply nat_trans_eq_alt.
    apply (LModule_law1).
  - intro c.
    cbn.
    etrans.
    { rewrite assoc.
      apply cancel_postcomposition.
      etrans; [ apply (θ_nat_2_pw Mf _ _ (ptd_mor_from_μ)  c)|].
      apply cancel_postcomposition.
      apply (strength_law2_pw Mf (p T) (p T)).  }
    etrans; revgoals.
    { rewrite <- assoc.
      apply cancel_precomposition.
      rewrite assoc.
      apply cancel_postcomposition.
      eapply pathsinv0.
      apply (θ_nat_1_pw _ _ (σ M) (p T) c). }
    cbn.
    repeat rewrite <- assoc.
    apply cancel_precomposition.
    apply cancel_precomposition.
    etrans; revgoals.
    { eapply pathsinv0.
      apply (functor_comp_pw _ _ H). }
    etrans.
    { apply cancel_precomposition.
      apply (functor_comp_pw _ _ H). }
    etrans; [ apply (functor_comp_pw _ _ H)|].
    apply functor_cancel_pw.
    apply nat_trans_eq_alt.
    intro x.
    cbn. unfold horcomp_data; simpl.
    repeat rewrite id_left.
    rewrite functor_id,id_right.
    apply LModule_law2.
Qed.

Local Definition lift_lmodule : LModule T D := (lift_LModule_data,, lift_lm_mult_laws).

End SignatureLiftModule.

Section InitialRep.

(** ** Some variables and assumptions *)

(** Assume having a precategory [C] whose hom-types are sets *)
Variable C : category.
Variable CP : BinCoproducts C.

Local Notation "'EndC'":= ([C, C]) .
Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP.

(** Assume having a signature on [C] *)
Variable H : Signature C C C.
Let θ := theta H.

Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)).
Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H)).

Let Id_H : functor EndC EndC
  := BinCoproduct_of_functors _ _ CPEndC
                              (constant_functor _ _ (functor_identity _ : EndC))
                              H.

Let Alg : category := FunctorAlg Id_H.

(** The category of endofunctors on [C] *)
Local Notation "'EndC'":= ([C, C]) .
Local Notation "'p' T" := (ptd_from_alg T) (at level 3).
Local Notation η := @eta_from_alg.

(** Let [T] be a heterogeneous substitution system.
  Then [τ : H T --> T] is a module morphism
 *)

Section TauModuleMorphism.

Variable T : hss CP H.
Local Notation T_mon := (Monad_from_hss _ _ _ T).
Local Notation T_mod := (tautological_LModule T_mon).
Local Notation HT_mod := (lift_lmodule H _ T_mod).

Lemma τ_lmodule_laws : LModule_Mor_laws T_mon (T:=HT_mod) (T' := T_mod) (τ T).
Proof.
  intro a.
  apply pathsinv0.
  (* It is precisely the square diagram satisfied by μ = { id } *)
  exact (nat_trans_eq_pointwise (fbracket_τ T  (Z:= p T)(identity _ )) a).
Qed.

Definition τ_lmodule_mor :  LModule_Mor  _ _ _ :=
  tpair (λ x, LModule_Mor_laws _ x) _ τ_lmodule_laws.

End TauModuleMorphism.

(**
Let (M, τ_M) be a representation in the sense of Hirschowitz & Maggesi :
      - M is a monad
      - [τ_M : HM ---> M] is a module morphism

Then there exists a unique monad morphism j : T --> M that is compatible with τ_M, τ_T
     where T is the initial HSS.

In other words, T is the initial representation in the sense of H&M

*)

Variables (IC : Initial C)
          (CC : Colims_of_shape nat_graph C)
          (HH : is_omega_cocont H).

Let T := InitHSS _ CP IC CC H HH.

Local Notation T_alg := (alg_from_hetsubst _ _ _ (hetsubst_from_hss _ _ _ T)).
Local Notation T_mon := (Monad_from_hss _ _ _ T).
Local Notation T_func := (T_mon : functor _ _).
Local Notation T_hss := (T:hss _ _).

Section fix_a_representation.

Variables (M : Monad C).
Local Notation M_mod := (tautological_LModule M).
Local Notation HM_mod := (lift_lmodule H _ M_mod).

Variable (τ_M: LModule_Mor M HM_mod M_mod).

Local Definition M_alg : Alg.
Proof.
  apply (tpair (λ x, EndC ⟦ Id_H x, x ⟧) (M:functor _ _)).
  apply BinCoproductArrow.
  - apply Monads.η.
  - apply τ_M.
Defined.

(** j : T --> M is the initial Id+H-algebra morphism *)
Let j : Alg ⟦T_alg, M_alg⟧ := InitialArrow _ M_alg.

Let InitialEndC : Initial EndC.
Proof.
  apply Initial_functor_precat, IC.
Defined.

Let Colims_of_shape_nat_graph_EndC : Colims_of_shape nat_graph EndC.
Proof.
  apply colimits.ColimsFunctorCategory_of_shape, CC.
Defined.

Let is_omega_cocont_Id_H' := LiftingInitial_alt.is_omega_cocont_Id_H C CP H HH.

Local Notation j_mor := ((mor_from_algebra_mor _ j):nat_trans _ _).

(**
  Following Ralph's proof : we want to prove the square diagram for the
  monad morphism induced by
  the initial algebra morphism j : T --> M :
<<
       jj
  TT ------> MM
   |         |
μ_T|         | μ_M
   |         |
   V         V
   T ------> M
       j
>>

The strategy is to show that both paths of the diagram satisfy the characteristic equation of
the same Mendler iterator. We use Lemma 8 from "Heteregenous substitution system revisited"
  (Benedikt Ahrens & Ralph Matthes) with the following parameters :

    X := M
    L Z := Z·T
    F Z := (Id+H) Z

  And for any Z : EndC, h : LZ -> X

    ψ_Z(h)  := [j, τ_M ∘ H h ∘ Θ_Z,(T,η)]

*)

Let L := (pre_composition_functor C C C T_func).
Let X := (M:functor _ _).

(* inspired by LiftingInitial_alt *)
Local Lemma HL : is_omega_cocont L.
Proof.
  apply OmegaCocontFunctors.is_omega_cocont_pre_composition_functor, CC.
Defined.

Let isInitial_precomp' : isInitial [C, C] (L InitialEndC) :=
  LiftingInitial_alt.isInitial_pre_comp C IC p T_hss : isInitial [C, C] (L InitialEndC).

Local Definition ψ_pw (Z:[C,C]) : Core.hset_precategory ⟦ψ_source(D:=[C,C]) X L Z, ψ_target(D:=[C,C]) Id_H X L Z⟧ .
Proof.
  intros h.
  cbn.
  apply (BinCoproductArrow (a:= `T_hss) (b:= functor_composite `T_hss (H Z)) (CPEndC _ _) (c:=X)).
  - apply j.
  - apply ((θ  (Z ⊗ (p T_hss)))·#H h· (τ_M:nat_trans _ _)).
Defined.

Local Lemma ψ_nt : is_nat_trans (ψ_source(D:=[C,C]) X L) (ψ_target(D:=[C,C]) Id_H X L) ψ_pw.
Proof.
  intros x x' a.
  cbn in a.
  apply weqfunextsec.
  intros f.
  apply nat_trans_eq_alt.
  intro c.
  etrans; revgoals.
  { eapply pathsinv0.
    apply (precompWithBinCoproductArrow C (CP _ _) (CP _ _)
                                        (identity _) (((# H a):nat_trans _ _) (T_func c))). }
  use (maponpaths_12 (@BinCoproductArrow _ _ _ _ _)).
  + apply pathsinv0,id_left.
  + apply pathsinv0.
    etrans; [ apply assoc |].
    apply cancel_postcomposition.
    etrans; [ apply assoc |].
    etrans.
    { apply cancel_postcomposition.
      apply (θ_nat_1_pw _ _ a (p T_alg)). }
    rewrite <- assoc.
    apply cancel_precomposition.
    etrans; revgoals.
    { eapply pathsinv0.
      eapply nat_trans_eq_pointwise.
      apply (functor_comp H (_:EndC⟦ T_mon ∙ x', T_mon ∙ x⟧)). }
    apply cancel_postcomposition.
    apply functor_cancel_pw.
    apply nat_trans_eq_alt.
    intro c'.
    etrans; [| apply id_right ].
    apply cancel_precomposition.
    apply (functor_id x).
Qed.

Local Definition ψ  : (PreShv EndC)⟦ψ_source(D:=[C,C]) X L , ψ_target(D:=[C,C]) Id_H X L⟧ :=
  (ψ_pw ,, ψ_nt).

(** Uniqueness of the Mendler iterator characteristized by its equation *)
Local Definition uniq_iter :
  ∃! h : [C, C] ⟦ L `T_hss, X ⟧,
         # L (alg_map Id_H T_alg) · h = (ψ:nat_trans _ _) `T_alg h
  :=
    GenMendlerIteration InitialEndC Colims_of_shape_nat_graph_EndC Id_H
                        is_omega_cocont_Id_H' (D:=[C,C]) X _ isInitial_precomp' HL ψ.

(** The previous characteristic equation can be split as an equality between coproduct of arrows :
- h ∘ η_T = j_mor
- h ∘ τ_T = τ_M ∘ H h ∘ Θ_T,T

where [η_T, τ_T] : Id + HT --> T
*)

Local Lemma coprod_iter_eq (h:nat_trans _ _) :
  (∏ x,
   BinCoproductIn1 (CP (_ (T_mon x)) ((H T_func:functor _ _) (T_mon x))) ·
                   (# L (alg_map Id_H T_alg):nat_trans _ _) x ·
                   h x = j_mor x) ->
  (∏ x,
   BinCoproductIn2 (CP (_ (T_mon x)) ((H T_func:functor _ _) (T_mon x))) ·
                   (# L (alg_map Id_H T_alg):nat_trans _ _) x · h x =
   (θ (`T_alg ⊗ p T_alg):nat_trans _ _) x · (# H h:nat_trans _ _) x · τ_M x) ->
    # L (alg_map Id_H T_alg) · h = (ψ:nat_trans _ _) `T_alg h.
Proof.
  intros hB1 hB2.
  apply nat_trans_eq_alt.
  intros x.
  etrans.
  { etrans.
    { apply cancel_postcomposition.
      apply BinCoproductArrowEta. }
      apply postcompWithBinCoproductArrow. }
  use maponpaths_12.
  - apply hB1.
  - apply hB2.
Qed.

Let τT := τ_lmodule_mor T.

(** j is a morphism of representation.
    It is exactly the 'H' part of the Id + H algebra morphism diagram *)
Lemma j_mor_rep x : τT x · j_mor x = (# H j_mor:nat_trans _ _) x · τ_M x.
Proof.
  etrans; [ apply assoc' |].
  etrans.
  { apply cancel_precomposition.
    apply (nat_trans_eq_pointwise (algebra_mor_commutes _ _ _ j) x). }
  etrans; [ apply assoc |].
  etrans.
  { apply cancel_postcomposition.
    apply BinCoproductIn2Commutes. }
  etrans; [ apply assoc' |].
  apply cancel_precomposition.
  apply BinCoproductIn2Commutes.
Qed.

(** j satisfies the η-related diagram of monad morphism.
         This is Id part of the Id+H-algebra morphism diagram *)
Lemma j_mon_η :   ∏ a : C, (Monads.η T_mon) a · j_mor a = (Monads.η M) a.
Proof.
  intro a.
  etrans; [ apply assoc' |].
  etrans.
  { apply cancel_precomposition.
    apply (nat_trans_eq_pointwise (algebra_mor_commutes _ _ _ j) a). }
  etrans; [ apply assoc |].
  etrans.
  { apply cancel_postcomposition.
    apply BinCoproductIn1Commutes. }
  etrans; [ apply assoc' |].
  etrans.
  { apply cancel_precomposition.
    apply BinCoproductIn1Commutes. }
  apply id_left.
Qed.

Let j_ptd : category_Ptd C ⟦ ptd_from_mon T_mon, ptd_from_mon M⟧.
Proof.
  use tpair.
  - apply j.
  - intros x.
    apply j_mon_η.
Defined.

(** j is a monad morphism (following Ralph's proof). For the square diagram,
     we show that both parts satisfies the same Mendler iterator characteristic equation *)
Lemma j_mon_square_eq1 : # L (alg_map Id_H T_alg) · ((μ T_mon : EndC ⟦_, _⟧) · j_mor) =
                         (ψ : nat_trans _ _) `T_alg  ((μ T_mon : EndC ⟦_, _⟧) · j_mor).
Proof.
  apply coprod_iter_eq; intro x.
  - (* T monad law *)
    etrans; [ apply assoc |].
    etrans.
    { apply cancel_postcomposition.
      apply (Monad_law1 (T:=T_mon)). }
    apply id_left.
  - (* tau_T is a module morphism *)
    etrans; [ apply assoc |].
    etrans.
    { apply cancel_postcomposition.
      apply (LModule_Mor_σ _  τT). }
    etrans; [ apply assoc' |].
    etrans; [ apply assoc' |].
    etrans; [| apply assoc ].
    apply cancel_precomposition.
    rewrite functor_comp.
    etrans; [| apply assoc ].
    apply cancel_precomposition.
    apply j_mor_rep.
Qed.

Lemma j_mon_square_eq2 :
  # L (alg_map Id_H T_alg) ·
    ((j_mor ø T_mon : EndC ⟦_∙_, _∙_⟧) · (M ∘ j_mor : EndC ⟦_∙_, _∙_⟧) · μ M)
  =
  (ψ : nat_trans _ _) `T_alg
                      ((j_mor ø T_mon : EndC ⟦_∙_, _∙_⟧) · (M ∘ j_mor : EndC ⟦_∙_, _∙_⟧) · μ M).
Proof.
  apply coprod_iter_eq; intro x.
  - etrans; [ apply assoc |].
    etrans.
    { apply cancel_postcomposition.
      etrans; [ apply assoc |].
      apply cancel_postcomposition.
      apply j_mon_η. }
    etrans.
    { apply cancel_postcomposition.
      eapply pathsinv0.
      apply (nat_trans_ax (Monads.η M )). }
    etrans; [| apply id_right ].
    rewrite <- assoc.
    apply cancel_precomposition.
    apply Monad_law1.
  - etrans; [ apply assoc |].
    etrans.
    { apply cancel_postcomposition.
      etrans; [ apply assoc |].
      etrans.
      { apply cancel_postcomposition.
        apply j_mor_rep. }
      rewrite <- assoc.
      apply cancel_precomposition.
      eapply pathsinv0.
      apply (nat_trans_ax τ_M). }
    etrans.
    { repeat rewrite <- assoc.
      apply cancel_precomposition.
      apply cancel_precomposition.
      apply (LModule_Mor_σ _  τ_M ( x)). }
    repeat rewrite assoc.
    apply cancel_postcomposition.
    etrans.
    { repeat rewrite <- assoc.
      apply cancel_precomposition.
      etrans; [ apply assoc |].
      apply cancel_postcomposition.
      apply (θ_nat_2_pw _ _ _ j_ptd). }
    etrans.
    { repeat rewrite assoc.
      apply cancel_postcomposition.
      apply cancel_postcomposition.
      apply (θ_nat_1_pw _ _ j_mor (ptd_from_mon T_mon)). }
    repeat rewrite <- assoc.
    apply cancel_precomposition.
    rewrite functor_comp.
    rewrite functor_comp.
    repeat rewrite assoc.
    apply cancel_postcomposition.
    rewrite <- functor_comp.
    etrans; [ apply functor_comp_pw |].
    apply functor_cancel_pw.
    apply nat_trans_eq_alt.
    intro y.
    etrans.
    { apply cancel_postcomposition.
      etrans.
      { apply cancel_precomposition.
        apply functor_id. }
      apply id_right. }
    apply cancel_precomposition.
    apply id_left.
Qed.

Lemma j_mon_laws : Monad_Mor_laws (T:=T_mon) (T':=M) (mor_from_algebra_mor _ j).
Proof.
  split.
  - apply (nat_trans_eq_pointwise (a:= compose (C:=EndC)  (μ T_mon) j_mor)
                                  (a':= compose(C:=EndC)
                                               (compose (C:=EndC)
                                                        (a:=_∙_)
                                                        (b:=_∙_)
                                                        (c:=_∙_)
                                                        (j_mor ø T_mon ) (M ∘ j_mor) )
                                               (μ M))).
    apply (uniqueExists uniq_iter).
    + exact j_mon_square_eq1.
    + exact j_mon_square_eq2.
  - apply j_mon_η.
Qed.

Definition j_mon : Monad_Mor T_mon M :=   _ ,, j_mon_laws.

End fix_a_representation.

(** TODO:

  To assemble the above results into a concise statement,
  we would need to define the category of representations
  of a signature (H,θ).

*)

End InitialRep.


Require Import FunctionalExtensionality JMeq ProofIrrelevance.
Require Export Category CategoryIsomorphisms InitialTerminalCategory Functor ComputableCategory.
Require Import Common FEqualDep.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section SmallCat.
  Definition SmallCat := ComputableCategory _ SUnderlyingCategory.
  Definition LocallySmallCat := ComputableCategory _ LSUnderlyingCategory.
End SmallCat.

Local Ltac destruct_simple_types :=
  repeat match goal with
           | [ |- context[?T] ] => let T' := type of T in
                                   let T'' := fresh in
                                   match eval hnf in T' with
                                     | unit => set (T'' := T); destruct T''
                                     | _ = _ => set (T'' := T); destruct T''
                                   end
         end.

Section Objects.
  Hint Unfold Morphism Object.

  Local Arguments Object / {obj} C : rename.
  Local Arguments Morphism / {obj} _ _ _ : rename.

  Hint Extern 1 => destruct_simple_types.
  Hint Extern 3 => destruct_to_empty_set.

  Lemma TerminalCategory_Terminal : IsTerminalObject (C := SmallCat) TerminalCategory.
    repeat intro;
    exists (FunctorToTerminal _).
    abstract (
        repeat intro; functor_eq; eauto
      ).
  Defined.

  Lemma InitialCategory_Initial : IsInitialObject (C := SmallCat) InitialCategory.
    repeat intro;
    exists (FunctorFromInitial _).
    abstract (
        repeat intro; functor_eq; eauto
      ).
  Qed.
End Objects.


From Autosubst Require Export Autosubst.
From stdpp Require Import base.

From DN Require Import autosubst_preds.
From DN.DMin Require syn.

Section synty.
  Inductive tm : Type :=
    | tv : vl → tm
    | tapp : tm → tm → tm
    | tproj : vl → tm
    | tskip : tm -> tm
  with vl : Type :=
    | var_vl : var → vl
    | vnat : nat → vl
    | vabs : tm → vl
    | vpack : ty → tm → vl
  with ty : Type :=
    | TProj : vl → ty.

  Implicit Types (t: tm) (v: vl) (T: ty).

  Scheme tm_mut := Induction for tm Sort Prop
  with   vl_mut := Induction for vl Sort Prop
  with   ty_mut := Induction for ty Sort Prop.
  Combined Scheme syntax_mutind from tm_mut, vl_mut, ty_mut.

  Section transf.
    Variable (α: Type) (m_α: ty → α).
    Fixpoint m_vl (v: vl): syn.vl α :=
    match v with
    | var_vl i => syn.var_vl i
    | vnat n => syn.vnat n
    | vabs t => syn.vabs (m_tm t)
    | vpack T t => syn.vpack (m_α T) (m_tm t)
    end
    with m_tm (t: tm): syn.tm α :=
    match t with
    | tv v => syn.tv (m_vl v)
    | tskip t => syn.tskip (m_tm t)
    | tapp t1 t2 => syn.tapp (m_tm t1) (m_tm t2)
    | tproj v => syn.tproj (m_vl v)
    end.
  End transf.
End synty.


Require Import Datatypes.
Require Import ZArith.
Require Import Coq.Strings.String.

From QuickChick Require Import Show.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

Require Import Utils.

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

Definition zreplicate {A:Type} (n:Z) (a:A) : option (seq A) :=
  if Z_lt_dec n 0 then None
  else Some (nseq (Z.to_nat n) a).

Lemma nth_error_Z_zreplicate: forall A z (a:A) z' l,
  zreplicate z a = Some l ->
  nth_error_Z l z' = if Z_le_dec 0 z' then
                        if Z_lt_dec z' z then Some a else None
                     else None.
Proof.
  unfold zreplicate, nth_error_Z; intros.
  destruct (Z_lt_dec z 0); try congruence.
  inv H.
  destruct (z' <? 0)%Z eqn:Ez.
  - rewrite -> Z.ltb_lt in Ez.
    destruct Z_lt_dec; try omega.
    destruct Z_le_dec; auto; omega.
  - assert (~ (z' < 0 )%Z).
    rewrite <- Z.ltb_lt; try congruence.
    destruct Z_le_dec; try omega; simpl in *; inv H.
    rewrite (_ : is_left (Z_lt_dec z' z) = (Z.to_nat z' < Z.to_nat z)).
      elim: (Z.to_nat z') (Z.to_nat z) {n Ez H0 l0}=> [|n IH] [|n'] //=.
      by rewrite IH ltnS.
    assert ( (z'<z)%Z <-> (Z.to_nat z' < Z.to_nat z)%coq_nat).
      apply Z2Nat.inj_lt; try omega.
    by apply/sumboolP/ltP; intuition.
Qed.

Inductive alloc_mode := Global | Local.

(* Frames are parameterized over the type of block and the type of Label *)
(* Cannot make this a parameter because we don't want it opaque.
   Keep it outside for now, until I figure out what's better *)
(* Any better solutions than the implicit arguments welcome *)
Inductive frame {A S} := Fr (label : S) : seq A -> @frame A S.

Section FrameEqType.

Variables A S : eqType.

Definition frame_eq (fr1 fr2 : @frame A S) : bool :=
  let: Fr l1 xs1 := fr1 in
  let: Fr l2 xs2 := fr2 in
  [&& l1 == l2 & xs1 == xs2].

Lemma frame_eqP : Equality.axiom frame_eq.
Proof.
move=> [l1 xs1] [l2 xs2]; apply/(iffP andP).
  by move=> [/eqP -> /eqP ->].
by move => [-> ->]; rewrite !eqxx.
Qed.

Definition frame_eqMixin := EqMixin frame_eqP.

Canonical frame_eqType := Eval hnf in EqType (@frame A S) frame_eqMixin.

End FrameEqType.

Module Type MEM.
  (* Type of memory is parameterized by the type of stamps and the type of block *)
  Parameter t : Type -> Type -> Type.

  Parameter block : Type -> Type.
  Parameter stamp : forall {S}, block S -> S.

  Parameter block_eq : forall (S : eqType), block S -> block S -> bool.

  Parameter block_eqP : forall S, Equality.axiom (@block_eq S).

  Definition block_eqMixin (S : eqType) := EqMixin (@block_eqP S).
  Canonical block_eqType (S : eqType) :=
    EqType (block S) (block_eqMixin S).

  (* For generation *)
  Parameter put_stamp : forall {S}, S -> block S -> block S.
  (* For indistinguishability - return all frames with stamps
     less than a label (called with top) *)

 (* For printing *)
  Declare Instance show_block : forall {S} {_: Show S}, Show (block S).

  (* DD -> DP : is a block some kind of "stamped pointer"? *)
  Parameter get_frame : forall {A S}, t A S -> block S -> option (@frame A S).
  Parameter upd_frame :
    forall {A} {S:eqType}, t A S -> block S -> @frame A S -> option (t A S).

  Parameter upd_get_frame : forall A (S : eqType) (m:t A S) (b:block S) fr fr',
    get_frame m b = Some fr ->
    exists m',
      upd_frame m b fr' = Some m'.
  Parameter get_upd_frame : forall A (S : eqType) (m m':t A S) (b:block S) fr,
    upd_frame m b fr = Some m' ->
    forall b',
      get_frame m' b' = if b == b' then Some fr else get_frame m b'.
  Parameter upd_frame_defined : forall A (S : eqType) (m m':t A S) (b:block S) fr,
    upd_frame m b fr = Some m' ->
    exists fr', get_frame m b = Some fr'.

  Parameter memory_extensionality :
    forall {A} {S : eqType} (m1 m2 : t A S),
    (forall (b : block S), get_frame m1 b = get_frame m2 b) -> m1 = m2.

  Parameter get_blocks : forall {A S} , seq S -> t A S -> seq (block S).

  Parameter get_blocks_spec:
    forall {A} {S : eqType} (labs : seq S) (mem: t A S) (b: block S),
      (stamp b \in labs) && get_frame mem b <->
      b \in get_blocks labs mem.

  Parameter empty : forall A S, t A S.
  Parameter get_empty : forall A S (b:block S), get_frame (empty A S) b = None.

  (* Create a memory with some block initialized to a frame *)
  (* Parameter init : forall A S {eqS:EqDec S eq}, *)
  (*                    alloc_mode -> *)
  (*                    block S -> *)
  (*                    @frame A S -> *)
  (*                    t A S. *)

  (* Parameter get_init_eq : forall A S {eqS:EqDec S eq} *)
  (*                                mode (b : block S) (f : @frame A S), *)
  (*                           get_frame (init A S mode b f) b = Some f. *)

  (* Parameter get_init_neq : forall A S {eqS:EqDec S eq} *)
  (*                                 mode (b b' : block S) (f : @frame A S), *)
  (*                            b' <> b -> *)
  (*                            get_frame (init A S mode b f) b' = None. *)

  Parameter alloc :
    forall {A} {S : eqType}, alloc_mode -> t A S -> S -> @frame A S -> (block S * t A S).
  Parameter alloc_stamp : forall A (S : eqType) am (m m':t A S) s fr b,
    alloc am m s fr = (b,m') -> stamp b = s.
  Parameter alloc_get_fresh : forall A (S : eqType) am (m m':t A S) s fr b,
    alloc am m s fr = (b,m') -> get_frame m b = None.
  Parameter alloc_get_frame : forall A (S : eqType) am (m m':t A S) s fr b,
    alloc am m s fr = (b,m') ->
    forall b', get_frame m' b' = if b == b' then Some fr else get_frame m b'.
  Parameter alloc_upd : forall A (S : eqType) am (m:t A S) b fr1 s fr2 m',
    upd_frame m b fr1 = Some m' ->
    fst (alloc am m' s fr2) = fst (alloc am m s fr2).
  Parameter alloc_local :
    forall A (S : eqType) (m1 m2:t A S) s fr1 fr2,
      (forall b, stamp b = s -> get_frame m1 b = get_frame m2 b :> bool) ->
      (alloc Local m1 s fr1).1 = (alloc Local m2 s fr2).1.

  Parameter map : forall {A B S}, (@frame A S -> @frame B S) -> t A S -> t B S.
  Parameter map_spec : forall A B S (f: @frame A S -> @frame B S) (m:t A S),
    forall b, get_frame (map f m) b = option_map f (get_frame m b).

End MEM.

(* For indist/generation purposes, our implementation has to be less generic or
   give our labels a function "allLabelsBelow". For now do the latter *)
Module Mem: MEM.
  Definition block S := (Z * S)%type.

  Definition block_eq (S : eqType) (b1 b2 : block S) := b1 == b2.

  Lemma block_eqP (S : eqType) : Equality.axiom (@block_eq S).
  Proof. move=> ??; exact/eqP. Qed.

  Definition block_eqMixin (S : eqType) := EqMixin (@block_eqP S).
  Canonical block_eqType (S : eqType) :=
    EqType (block S) (block_eqMixin S).

  Definition stamp S : block S -> S := @snd _ _.
  Definition put_stamp S (s : S) (b : block S) : block S :=
    let (z,_) := b in (z,s).

  Record _t {A S} := MEM {
     content :> block S -> option (@frame A S);
     next : S -> Z;
     content_next : forall s i, (1 <= i < next s)%Z  <->
                                (exists fr, content (i,s) = Some fr);
     next_pos : forall s, (1 <= next s)%Z
     (* content_some :  *)
     (*   forall s i, (1 <= i <= (next s) -1)%Z <->  *)
     (*               (exists fr, content (i, s) = Some fr) *)
  }.

  Implicit Arguments _t [].
  Implicit Arguments MEM [A S].
  Definition t := _t.

  Definition get_frame {A S} (m:t A S) := content m.

  Definition memory_extensionality {A} {S : eqType} (m1 m2 : t A S)
             (H : forall b, get_frame m1 b = get_frame m2 b) : m1 = m2.
    admit.
  Admitted.

  Definition Z_seq z1 z2 := map Z.of_nat (iota (Z.to_nat z1) (Z.to_nat z2)).

  Definition get_blocks_at_level {A S} (m : t A S) (s : S):=
    let max := next m s in
    let indices := Z_seq 1%Z (max - 1) in
    map (fun ind => (ind,s)) indices.

  Definition get_blocks {A S} (ss : list S) (m : t A S) : seq (block S) :=
    flatten (map (get_blocks_at_level m) ss).

  Instance show_block {S} {_: Show S}: Show (block S) :=
  {|
    show b :=
      let (z,s) := (b : block S) in
      ("(" ++ show z ++ " @ " ++ show s ++ ")")%string
  |}.

  Program Definition map {A B S} (f:@frame A S -> @frame B S) (m:t A S) : t B S:=
    MEM
      (fun b => omap f (get_frame m b))
      (next m)
      _ _.
  Next Obligation.
    split.
    - intros Hrng. destruct (content_next m s i) as [H _]. destruct H.
      assumption. eexists. unfold get_frame. rewrite H. reflexivity.
    - intros [fr Heq]. destruct (content_next m s i) as [_ H].
      apply H. unfold get_frame in Heq. destruct (m (i, s)).
      eexists. reflexivity. discriminate.
  Qed.
  Next Obligation.
    destruct m. auto.
  Qed.

  Lemma map_spec : forall A B S (f:@frame A S -> @frame B S) (m:t A S),
    forall b, get_frame (map f m) b = omap f (get_frame m b).
  Proof.
    auto.
  Qed.

  Program Definition empty A S : t A S := MEM
    (fun b => None) (fun _ => 1%Z) _ _.
  Next Obligation.
    split. omega. intros [fr contra]. congruence.
  Qed.

  Lemma get_empty : forall A S b, get_frame (empty A S)  b = None.
  Proof. auto. Qed.

  (* Program Definition init A S {eqS : EqDec S eq} (am : alloc_mode) b f : t A S:= MEM *)
  (*   (fun b' : block S => if b' == b then Some f else None) *)
  (*   (fun s => if s == stamp _ b then fst b + 1 else 1)%Z *)
  (*   _.  *)
  (* Next Obligation. *)
  (*   simpl in *. *)
  (*   destruct (s == s0) as [EQ | NEQ]. *)
  (*   - compute in EQ. subst s0. *)
  (*     destruct (equiv_dec (i,s)) as [contra|]; trivial. *)
  (*     inv contra. *)
  (*     omega. *)
  (*   - destruct (equiv_dec (i,s)) as [E|E]; try congruence. *)
  (* Qed. *)

  (* Lemma get_init_eq : forall A S {eqS:EqDec S eq} *)
  (*                            mode (b : block S) (f : @frame A S), *)
  (*                       get_frame (init A S mode b f) b = Some f. *)
  (* Proof. *)
  (*   unfold init. simpl. *)
  (*   intros. *)
  (*   match goal with *)
  (*     | |- context [if ?b then _ else _] => *)
  (*       destruct b; congruence *)
  (*   end. *)
  (* Qed. *)

  (* Lemma get_init_neq : forall A S {eqS:EqDec S eq} *)
  (*                             mode (b b' : block S) (f : @frame A S), *)
  (*                        b' <> b -> *)
  (*                        get_frame (init A S mode b f) b' = None. *)
  (* Proof. *)
  (*   unfold init. simpl. *)
  (*   intros. *)
  (*   match goal with *)
  (*     | |- context [if ?b then _ else _] => *)
  (*       destruct b; congruence *)
  (*   end. *)
  (* Qed. *)

  Program Definition upd_frame_rich {A} {S : eqType} (m:t A S) (b0:block S) (fr:@frame A S)
  : option { m' : (t A S) |
             (forall b',
                get_frame m' b' = if b0 == b' then Some fr else get_frame m b')
           /\ forall s, next m s = next m' s} :=
    match m b0 with
      | None => None
      | Some _ =>
        Some (MEM
                (fun b => if b0 == b then Some fr else m b)
                (next m) _ _)
    end.
  Next Obligation.
    split.
    - have [e|ne] := altP (b0 =P _).
      + destruct b0; inv e. eexists. reflexivity.
      + apply content_next; auto.
    - have [e|ne] := altP (b0 =P _).
      + case=> [? [?]]; inv e.
        destruct (content_next m s i) as [_ H]. apply H.
        eexists. symmetry. exact Heq_anonymous.
      + destruct (content_next m s i) as [_ H]. apply H.
  Qed.
  Next Obligation.
    destruct m. auto.
  Qed.

  Definition upd_frame {A} {S : eqType} (m:t A S) (b0:block S) (fr:@frame A S)
  : option (t A S) :=
    match upd_frame_rich m b0 fr with
      | None => None
      | Some (exist m' _) => Some m'
    end.

  Program Lemma upd_get_frame : forall A (S : eqType) (m:t A S) (b:block S) fr fr',
    get_frame m b = Some fr ->
    exists m',
      upd_frame m b fr' = Some m'.
  Proof.
    unfold upd_frame, upd_frame_rich, get_frame.
    intros.
    generalize (@erefl (option (@frame A S)) (m b)).
    generalize (@upd_frame_rich_obligation_3 A S m b fr').
    generalize (@upd_frame_rich_obligation_2 A S m b fr').
    generalize (@upd_frame_rich_obligation_1 A S m b fr').
    simpl.
    (* rewrite H. intros. eauto. *)
  Admitted.

  Lemma get_upd_frame : forall A (S : eqType) (m m':t A S) (b:block S) fr,
    upd_frame m b fr = Some m' ->
    forall b',
      get_frame m' b' = if b == b' then Some fr else get_frame m b'.
  Proof.
    unfold upd_frame; intros.
    destruct (upd_frame_rich m b fr); try congruence.
    destruct s; inv H; intuition.
  Qed.

  Lemma upd_frame_defined : forall A (S : eqType) (m m':t A S) (b:block S) fr,
    upd_frame m b fr = Some m' ->
    exists fr', get_frame m b = Some fr'.
  Proof.
    unfold upd_frame, upd_frame_rich, get_frame.
    intros until 0.
    generalize (@erefl (option (@frame A S)) (@content A S m b)).
    generalize (@upd_frame_rich_obligation_3 A S m b fr).
    generalize (@upd_frame_rich_obligation_2 A S m b fr).
    generalize (@upd_frame_rich_obligation_1 A S m b fr).
    simpl.
    intros.
    (* destruct (m b); eauto; congruence. *)
  Admitted.

  Opaque Z.add.

  Program Definition alloc
             {A} {S : eqType} (am:alloc_mode) (m:t A S) (s:S) (fr:@frame A S)
            : (block S * t A S) :=
    ((next m s,s),
     MEM
       (fun b' => if (next m s,s) == b' then Some fr else get_frame m b')
       (fun s' => if s == s' then (1 + next m s)%Z else next m s')
       _ _).
  Next Obligation.
    have [e|ne] := (next m s, s) =P _.
    - inv e; rewrite eqxx; split.
      + intros Hrng. eexists. reflexivity.
      + intros [fr' Heq]. inv Heq. split.
        apply next_pos. omega.
    - have [e|ne'] := s =P s0.
      + inv e. split.
        * intros [Hrng1 Hrng2]. destruct (content_next m s0 i) as [H _].
          apply H. split; first assumption.
          apply Zlt_is_le_bool in Hrng2.
          rewrite -> Z.add_comm, <- Z.add_sub_assoc, Z.add_0_r in Hrng2.
          apply Zle_bool_imp_le in Hrng2. apply Zle_lt_or_eq in Hrng2.
          destruct Hrng2 as [Hrng2 | Hrng2]. assumption.
          subst. exfalso. apply ne. reflexivity.
        * intros [fr' Heq]. destruct (content_next m s0 i) as [_ H].
          unfold get_frame in Heq.
          assert (ex: (exists fr0 : frame, m (i, s0) = Some fr0))
            by (eexists; eassumption).
          destruct (H ex) as [H1 H2]. split; omega.
      + split; intro Hrng; destruct (content_next m s0 i) as [H1 H2]; auto.
  Qed.
  Next Obligation.
    have [e|ne] := s =P s0; destruct m; simpl.
    - specialize (next_pos0 s); try omega.
    - specialize (next_pos0 s0); assumption.
  Qed.

  Lemma alloc_stamp : forall A (S : eqType) am (m m':t A S) s fr b,
    alloc am m s fr = (b,m') -> stamp b = s.
  Proof.
    unfold alloc; intros.
    inv H; auto.
  Qed.

  Lemma alloc_get_fresh : forall A (S : eqType) am (m m':t A S) s fr b,
    alloc am m s fr = (b,m') -> get_frame m b = None.
  Proof.
    unfold alloc; intros.
    inv H.
    destruct (content_next m s (next m s)) as [_ H].
    unfold get_frame.
    destruct (m (next m s, s)).
    - assert (ex: exists fr0 : frame, Some f = Some fr0)
        by (eexists; reflexivity).
      specialize (H ex). omega.
    - reflexivity.
  Qed.

  Lemma alloc_get_frame : forall A (S : eqType) am (m m':t A S) s fr b,
    alloc am m s fr = (b,m') ->
    forall b', get_frame m' b' = if b == b' then Some fr else get_frame m b'.
  Proof.
    unfold alloc; intros.
    inv H; auto.
  Qed.

  Lemma alloc_upd : forall A (S : eqType) am (m:t A S) b fr1 s fr2 m',
    upd_frame m b fr1 = Some m' ->
    fst (alloc am m' s fr2) = fst (alloc am m s fr2).
  Proof.
    intros A S am m b fr1 s fr2 m' H.
    unfold alloc, upd_frame in *; simpl.
    destruct (upd_frame_rich m b fr1); try congruence.
    destruct s0; inv H.
    destruct a as [_ T].
    rewrite T; auto.
  Qed.

  Lemma alloc_local :
    forall A (S : eqType) (m1 m2:t A S) s fr1 fr2,
      (forall b, stamp b = s -> get_frame m1 b = get_frame m2 b :> bool) ->
      (alloc Local m1 s fr1).1 = (alloc Local m2 s fr2).1.
  Proof.
    move=> A S [c1 n1 cn1 np1] [c2 n2 cn2 np2] s fr1 fr2.
    rewrite /get_frame /alloc /= => Pc12; congr pair.
    suff: forall i, (1 <= i < n1 s)%Z <-> (1 <= i < n2 s)%Z.
      move: (n1 s) (n2 s) (np1 s) (np2 s)=> {np1 np2} s1 s2 np1 np2 H.
      have: forall s1 s2, (1 <= s1)%Z -> (1 <= s2)%Z ->
                          (forall i, (1 <= i < s1)%Z -> (1 <= i < s2)%Z) ->
                          (s1 <= s2)%Z.
        move=> {s1 s2 np1 np2 H} s1 s2 np1 np2 H.
        have [?|p]: (s1 = 1)%Z \/ (1 < s1)%Z by omega.
          by subst s1.
        suff: (s1 - 1 < s2)%Z by move=> ?; omega.
        move: (H (s1 - 1)%Z) => ?; omega.
      move=> H'.
      move: (H' _ _ np1 np2 (fun i => (H i).1)) => H1.
      move: (H' _ _ np2 np1 (fun i => (H i).2)) => H2.
      omega.
    move=> i; rewrite -> cn1, -> cn2.
    move: (Pc12 (i, s) erefl).
    case: (c1 _) => [fr1'|]; case: (c2 _) => [fr2'|] //= _; intuition eauto.
  Qed.

  Lemma in_seq_Z:
    forall z start len,
      (0 <= start)%Z ->
      (0 <= len)%Z ->
      ((start <= z < len + start)%Z <->
       z \in (Z_seq start len)).
  Proof.
    intros z s l. intros Hle1 Hle2. split.
    - intros [H1 H2]. unfold Z_seq.
      apply/mapP. exists (Z.to_nat z); last by rewrite Z2Nat.id; omega.
      apply Z2Nat.inj_lt in H2; try omega.
      rewrite Z2Nat.inj_add in H2; try omega.
      apply Z2Nat.inj_le in H1; try omega.
      apply Z2Nat.inj_le in Hle1; try omega.
      apply Z2Nat.inj_le in Hle2; try omega.
      simpl in *. remember (Z.to_nat s) as start.
      remember (Z.to_nat l) as len.
      remember (Z.to_nat z) as z'. clear Heqlen l Heqstart s Heqz' z Hle1.
      generalize dependent start. generalize dependent z'.
      induction len as [| l IHl]; intros s start Hle1 Hle3.
      + omega.
      + simpl in *. apply le_lt_or_eq in Hle1. destruct Hle1 as [H1 | H2].
        rewrite inE; apply/orP; right. apply IHl; try omega.
        rewrite inE; apply/orP; left; apply/eqP; congruence.
    - intros HIn. unfold Z_seq in HIn.
      move/mapP in HIn. destruct HIn as [z' HIn Heq]. subst.
      assert (H: Z.to_nat s <= z' < (Z.to_nat l) + (Z.to_nat s) ->
                 (s <= (Z.of_nat z') < l + s)%Z).
      { move=> /andP [H1 H2]. split.
        apply Z2Nat.inj_le; try omega. rewrite Nat2Z.id. apply/leP. assumption.
        apply Z2Nat.inj_lt; try omega. rewrite Nat2Z.id Z2Nat.inj_add;
         try omega. apply/ltP. assumption. }
      apply H.
      apply Z2Nat.inj_le in Hle1; try omega.
      apply Z2Nat.inj_le in Hle2; try omega.
      remember (Z.to_nat s) as start.
      remember (Z.to_nat l) as len.
      clear H Heqlen l Heqstart s.
      generalize dependent start. generalize dependent z'.
      induction len as [| len IHlen].
      + by [].
      + intros z' start Hle; rewrite /= inE => /orP HIn. simpl in *.
        case: HIn => [/eqP ?|HIn]; subst.
          rewrite addnE /addn_rec; apply/andP; split; [apply/leP|apply/ltP]; omega.
        * rewrite addSn -addnS.
        assert (H': S start <= z' < len + S start ->
                    start <= z' < len + S start).
        { rewrite addnE /addn_rec.
          move=> /andP [/leP H1 /ltP H2].
          apply/andP; split; [apply/leP| apply/ltP]; try omega. }
        apply H'. apply IHlen; try omega. assumption.
  Qed.

  Lemma get_blocks_spec :
    forall A (S : eqType) (labs : seq S) (mem: t A S) b,
      (stamp b \in labs) && get_frame mem b <->
      b \in get_blocks labs mem.
  Proof.
    intros A S labs mem b.
    split.
    - case/andP => HIn.
      case Hget: get_frame => [fr|] //= _.
      unfold get_blocks; apply/flatten_mapP.
      eexists; [eassumption|].
      unfold get_blocks_at_level. apply/mapP. exists b.1;
      destruct b=> //.
      apply in_seq_Z; try omega.
      * apply Zle_minus_le_0. apply next_pos.
      * rewrite <- Z.sub_sub_distr, Z.sub_0_r. simpl.
        apply content_next. eexists. eassumption.
    - intros HIn. unfold get_blocks, get_blocks_at_level in *.
      move/flatten_mapP in HIn. destruct HIn as [l HInl HIn].
      move/mapP in HIn. destruct HIn as [z HIn Heq]. subst.
      rewrite HInl /=.
      unfold get_frame.
      suff [fr ->] : exists fr, mem (z, l) = Some fr by [].
      apply content_next. apply in_seq_Z in HIn; try omega.
      apply Zle_minus_le_0. apply next_pos.
  Qed.

End Mem.

Canonical Mem.block_eqType.

Lemma alloc_get_frame_old :
  forall T (S : eqType) mode mem (stamp : S) (f f' : @frame T S) b b' mem'
         (ALLOC : Mem.alloc mode mem stamp f' = (b', mem'))
         (FRAME : Mem.get_frame mem b = Some f),
    Mem.get_frame mem' b = Some f.
Proof.
  intros.
  erewrite Mem.alloc_get_frame; eauto.
  have [e|//] := altP (b' =P b).
  exploit Mem.alloc_get_fresh; eauto.
  congruence.
Qed.

Lemma alloc_get_frame_new :
  forall T (S : eqType) mode mem (stamp : S) (frame : @frame T S) b mem'
         (ALLOC : Mem.alloc mode mem stamp frame = (b, mem')),
    Mem.get_frame mem' b = Some frame.
Proof.
  intros.
  erewrite Mem.alloc_get_frame; eauto.
  by rewrite eqxx; simpl in *; auto.
Qed.

Lemma get_frame_upd_frame_eq :
  forall T (S : eqType)
         (m : Mem.t T S) b f m'
         (UPD : Mem.upd_frame m b f = Some m'),
    Mem.get_frame m' b = Some f.
Proof.
  intros.
  erewrite Mem.get_upd_frame; eauto.
  by rewrite eqxx.
Qed.

Lemma get_frame_upd_frame_neq :
  forall T (S : eqType)
         (m : Mem.t T S) b b' f m'
         (UPD : Mem.upd_frame m b f = Some m')
         (NEQ : b' <> b),
    Mem.get_frame m' b' = Mem.get_frame m b'.
Proof.
  intros.
  erewrite Mem.get_upd_frame; eauto.
  have [?|?] := (b =P b'); simpl in *; congruence.
Qed.


Require Import Atom.
Require Import String Morph Var Context Relative.

(* -=ECC Definition=- *)

Inductive exp {V: nat}: Type :=
  | Id (x: @atom V)
  | Uni (U: universe)
  | Pi (A: exp) (B: @exp (S V))
  | Abs (A: exp) (e: @exp (S V))
  | App  (e1 e2: exp)
  | Let (e1: exp) (e2: @exp (S V))
  | Sig (A: exp) (B: @exp (S V))
  | Pair (e1 e2 A: exp)
  | Fst (e: exp)
  | Snd (e: exp)
  | If (e e1 e2: exp)
  | Tru
  | Fls
  | Bool
.
Hint Constructors exp.

Module ECCTerm <: Term.
  Definition term := @exp.
  Definition unit {N}: morph (@var) N (@term) N :=
    morph_inject (@Id).

  Fixpoint kleisli {N M} (f : morph (@var) N (@term) M) V t :=
      match t with
      | Id x => f V x
      | Abs A e =>
        Abs (kleisli f V A) (nset_push (kleisli f (S V) (nset_pop e)))
      | Pi A B =>
        Pi (kleisli f V A) (nset_push (kleisli f (S V) (nset_pop B)))
      | Let e1 e2 =>
        Let (kleisli f V e1) (nset_push (kleisli f (S V) (nset_pop e2)))
      | Sig A B =>
        Sig (kleisli f V A) (nset_push (kleisli f (S V) (nset_pop B)))
      | App e1 e2 =>
        App (kleisli f V e1) (kleisli f V e2)
      | Pair e1 e2 A =>
        Pair (kleisli f V e1) (kleisli f V e2) (kleisli f V A)
      | Fst e => Fst (kleisli f V e)
      | Snd e => Snd (kleisli f V e)
      | Uni U => Uni U
      | Tru => Tru
      | Fls => Fls
      | Bool => Bool
      | If e e1 e2 => If (kleisli f V e) (kleisli f V e1) (kleisli f V e2)
      end.

  Lemma left_identity :
    forall N M (f : morph (@var) N (@term) M) V t,
      kleisli f V (unit V t) = f V t.
  Proof. reflexivity. Qed.

  Lemma right_identity :
    forall N V (t : @term (N + V)),
      @kleisli N N unit V t = t.
  Proof.
    intros.
    inductT t; simplT; reflexivity.
  Qed.

  Lemma associativity :
      forall N M L
        (f : morph (@var) N (@term) M)
        (g : morph (@var) M (@term) L) V t,
        kleisli (fun V' t' => kleisli g V' (f V' t')) V t
        = kleisli g V (kleisli f V t).
    Proof.
      intros.
      inductT t; simplT; reflexivity.
    Qed.

  Lemma unit_extend :
    forall N V v,
      morph_extend (@unit N) V v = unit V v.
  Proof.
    intros.
    apply morph_extend_inject.
  Qed.

  Lemma kleisli_extend :
    forall N M (f : morph (@var) N (@term) M) V t,
      morph_extend (kleisli f) V t
      = kleisli (morph_extend f) V t.
  Proof.
    intros.
    inductT t; simplT; reflexivity.
  Qed.

  Lemma extensional :
    forall N M (f g : morph (@var) N (@term) M) V t,
      (forall V t, f V t = g V t) ->
      kleisli f V t = kleisli g V t.
  Proof.
    intros.
    inductT t; simplT; auto.
  Qed.

End ECCTerm.

Module ECCRen := Renamings(ECCTerm).
Import ECCTerm.
Import ECCRen.

(* -=ECC Environments=- *)

Inductive ctxmem:=
| Assum (A: @exp 0)
| Def (e: @exp 0) (A: @exp 0)
.

Definition env:= @context (@ctxmem).

Definition assumes (g: env) (x: atom) (A: exp) :=
(has g x (Assum A)) \/ (exists (e: exp), (has g x (Def e A))).
Hint Unfold assumes.

Bind Scope ECC_scope with exp.
Bind Scope ECC_scope with env.
Delimit Scope ECC_scope with ECC.

Inductive RedStep : env -> exp -> exp -> Prop :=
  | R_ID (g: env) (x: atom) (e' A: exp) :
    (has g x (Def e' A)) -> RedStep g (Id x) e'
  | R_App (g: env) (A body arg: exp) :
    RedStep g (App (Abs A body) arg) (bind arg body) (*do anything with env here?*)
  | R_Fst (g: env) (e1 e2 A: exp) :
    RedStep g (Fst (Pair e1 e2 A)) e1
  | R_Snd (g: env) (e1 e2 A: exp) :
    RedStep g (Snd (Pair e1 e2 A)) e2
  | R_Let (g: env) (e1 e2: exp) :
      RedStep g (Let e1 e2) (bind e1 e2)  (*or here?*)
  | R_IfTru (g: env) (e1 e2: exp) :
    RedStep g (If Tru e1 e2) e1
  | R_IfFls (g: env) (e1 e2: exp) :
    RedStep g (If Fls e1 e2) e2
.

Hint Constructors RedStep.

(* Reflective Transitive Closure of step*)
Inductive RedClos : env -> exp -> exp -> Prop :=
  | R_RedR (g g': env) (e e': exp): (* maybe don't need this one? it follows from refl + trans*)
      RedStep g e e' ->
      RedClos g e e'
  | R_Refl (g: env) (e: exp):
      RedClos g e e
  | R_Trans (g: env) (e e' e'': exp) :
      RedClos g e e' ->
      RedClos g e' e'' ->
      RedClos g e e''
  | R_CongLet (g: env) (e A: exp) (e1 e2: exp) (x: name) :
      (* We need to restrict A somehow maybe  *)
      RedClos (g & x ~ Def e A) (open x e1) (open x e2) ->
      RedClos g (Let e e1) (Let e e2)
  | R_CongLam1 (g: env) (A A' e e': exp) (x: name) :
      RedClos g A A' ->
      RedClos (g & x ~ Assum A) (open x e) (open x e') ->
      RedClos g (Abs A e) (Abs A' e')
  | R_CongPi (g: env) (A A' B B': exp) (x: name) :
      RedClos g A A' ->
      RedClos (g & x ~ Assum A) (open x B) (open x B') ->
      RedClos g (Pi A B) (Pi A' B')
  | R_CongSig (g: env) (A A' B B': exp) (x: name) :
      RedClos g A A' ->
      RedClos (g & x ~ Assum A) (open x B) (open x B')->
      RedClos g (Sig A B) (Sig A' B')
  | R_CongPair (g: env) (e1 e1' e2 e2' A A': exp) :
      RedClos g e1 e1' ->
      RedClos g e2 e2' ->
      RedClos g A A'   ->
      RedClos g (Pair e1 e2 A) (Pair e1' e2' A')
  | R_CongApp (g: env) (e1 e1' e2 e2': exp) :
      RedClos g e1 e1' ->
      RedClos g e2 e2' ->
      RedClos g (App e1 e2) (App e1' e2')
  | R_CongFst (g: env) (V V': exp) :
      RedClos g V V' ->
      RedClos g (Fst V) (Fst V')
  | R_CongSnd (g: env) (V V': exp) :
      RedClos g V V' ->
      RedClos g (Snd V) (Snd V')
  | R_CongIf (g: env) (e e' e1 e1' e2 e2': exp) :
      RedClos g e e' ->
      RedClos g e1 e1' ->
      RedClos g e2 e2' ->
      RedClos g (If e e1 e2) (If e' e1' e2')
.

Hint Constructors RedClos.

Inductive Equiv: env -> exp -> exp -> Prop :=
  | E_Equiv (g: env) (e e1 e2: exp) :
      RedClos g e1 e ->
      RedClos g e2 e ->
      Equiv g e1 e2
  | E_EquivIta1 (g: env) (e1 A e e2 e2': exp) (x: name) :
      RedClos g e1 (Abs A e) ->
      RedClos g e2 e2' ->
      Equiv (g & x ~ Assum A) (open x e) (App e2' (Id (free x))) ->
      Equiv g e1 e2
  | E_EquivIta2 (g: env) (e e1 e1' e2 A : exp) (x: name) :
      RedClos g e1 e1' ->
      RedClos g e2 (Abs A e) ->
      Equiv (g & x ~ Assum A) (App e1' (Id (free x))) (open x e) ->
      Equiv g e1 e2
(*   | E_EquivAlpha (g: env) (e1 e2: exp):
      ECC_Aeq e1 e2 ->
      Equiv g e1 e2 *)
.

Hint Constructors Equiv.

(* Typing *)

Inductive SubTypes: env -> exp -> exp -> Prop :=
| ST_Cong (g: env) (A B: exp) :
  Equiv g A B ->
  SubTypes g A B
| ST_Cum (g: env) (i: nat) :
  SubTypes g (Uni (uType i)) (Uni (uType (S i)))
| ST_Pi (g: env) (A1 A2 B1 B2: exp) (x: name) :
  (Equiv g A1 A2) ->
  (SubTypes (g & x ~ Assum A2) (open x B1) (open x B2)) ->
  (SubTypes g (Pi A1 B1) (Pi A2 B2))
| ST_Trans (g: env) (A A' B: exp) :
  (SubTypes g A A') ->
  (SubTypes g A' B) ->
  (SubTypes g A B)
| ST_Prop (g: env) :
  (SubTypes g (Uni (uProp)) (Uni (uType 0)))
| ST_Sig (g: env) (A1 A2 B1 B2: exp) (x: name):
  (SubTypes g A1 A2) ->
  (SubTypes (g & x ~ Assum A2) (open x B1) (open x B2)) ->
  (SubTypes g (Sig A1 B1) (Sig A2 B2))
.

Hint Constructors SubTypes.
Reserved Notation "g '⊢' a ':' b" (at level 250, a at level 99).
Reserved Notation "'⊢' g" (at level 250).
Inductive Types: env -> exp -> exp -> Prop :=
| T_Ax_Prop (g: env) :
  WellFormed g ->
  (Types g (Uni uProp) (Uni (uType 0)))
| T_Ax_Type (g: env) (i: nat) :
  WellFormed g ->
  (Types g (Uni (uType i)) (Uni (uType (S i))))
| T_Var (g: env) (x: atom) (A: exp) :
  (assumes g x A) -> (* this needs adjustment *)
  (Types g (Id x) A)
| T_Let (g: env) (e e' A B: exp) (x: name):
  (Types g e A) ->
  (Types (g & x ~ Def e A) (open x e') (open x B)) ->
  (Types g (Let e e') (bind e B)) (* FIXME: review if this is correct *)
| T_Prod_Prop (g: env) (x: name) (A B: exp) (i: nat):
  (Types g A (Uni (uType i))) ->
  (Types (g & x ~ Assum A) (open x B) (Uni (uProp))) ->
  (Types g (Pi A B) (Uni (uProp)))
| T_Prod_Type (g: env) (x: name) (A B: exp) (i: nat):
  (Types g A (Uni (uType i))) ->
  (Types (g & x ~ Assum A) (open x B) (Uni (uType i))) ->
  (Types g (Pi A B) (Uni (uType i)))
| T_Lam (g: env) (x: name ) (A e B: exp) :
  (Types (g & x ~ Assum A) (open x e) (open x B)) -> (* FIXME: hmm...*)
  (Types g (Abs A e) (Pi A B))
| T_App (g: env) (x: name) (e e' A' B: exp) :
  (Types g e (Pi A' B)) ->
  (Types g e' A') ->
  (Types g (App e e') (bind e B))
| T_Sig (g: env) (x: name) (A B: exp) (i: nat) :
  (Types g A (Uni (uType i))) ->
  (Types (g & x ~ Assum A) (open x B) (Uni (uType i))) -> (* should these be the same i*)
  (Types g (Sig A B) (Uni (uType i)))
| T_Pair (g: env) (e1 e2 A B: exp):
  (Types g e1 A) ->
  (Types g e2 (bind e1 B)) ->
  (Types g (Pair e1 e2 (Sig A B)) (Sig A B))
| T_Fst (g: env) (e A B: exp):
  (Types g e (Sig A B)) ->
  (Types g (Fst e) A)
| T_Snd (g: env) (e A B: exp):
  (Types g e (Sig A B)) ->
  (Types g (Snd e) (bind (Fst e) B))
| T_Bool (g: env):
  WellFormed g ->
  (Types g (Bool) (Uni (uType 0)))
| T_True (g: env):
  WellFormed g ->
  (Types g (Tru) (Bool))
| T_False (g: env):
  WellFormed g ->
  (Types g (Fls) (Bool))
| T_If (g: env) (B: @exp 1) (U e e1 e2: exp) (x: name):
  (Types (g & x ~ Assum Bool) (open x B) U) ->
  (Types g e (Bool)) ->
  (Types g e1 (bind (Tru) B)) ->
  (Types g e2 (bind (Fls) B)) ->
  (Types g (If e e1 e2) (bind e B))
| T_Conv (g: env) (e A B U: exp) :
  (Types g e A) ->
  (Types g B U) ->
  (SubTypes g A B) ->
  (Types g e B)
where "g '⊢' a ':' b" := (Types g a b) : ECC_scope
with
(* ECC Well-Formed Environments *)
WellFormed: env -> Prop :=
| W_Empty :
  WellFormed ctx_empty
| W_Assum (g: env) (x: name) (A U: exp) :
  WellFormed g ->
  Types g A U ->
  WellFormed (g & x ~ Assum A)
| W_Def (g: env) (x: name) (e A U: exp) :
  WellFormed g ->
  Types g A U ->
  Types g e A ->
  WellFormed (g & x ~ Def e A)
where "'⊢' g" := (WellFormed g) : ECC_scope
.
Hint Constructors WellFormed.
Hint Constructors Types.

(* Mutual induction Scheme *)
Scheme type_env_mut := Induction for Types Sort Prop
with env_type_mut := Induction for WellFormed Sort Prop.

(* "induction on the mutually defined judgments ..." Scheme.
 * Think this is "simultaneous induction"? *)
Combined Scheme type_env_comb from env_type_mut, type_env_mut.

(* ECC Notation *)

Coercion Id: atom >-> exp.

Notation "'type' x" := (Uni (uType x)) (at level 50):  ECC_scope.
Notation "'prop'" := (Uni uProp) (at level 50):  ECC_scope.
Notation "{ e1 e2 }" := (App e1 e2) (at level 50,e1 at level 9):  ECC_scope.
Notation "'LET' x ':=' A 'in' B" := (Let A B) (at level 50, format "'[v' 'LET'  x  ':='  A '/' 'in' '['  B ']' ']'") : ECC_scope.
Notation "'Π': A '->' B" := (Pi A B) (at level 50, A at level 9) : ECC_scope.
Notation "'λ' : A  '->'  B" := (Abs A B) (at level 50,  A at level 9) : ECC_scope.
Notation "'Σ' : A '..' B" := (Sig A B) (at level 50, A at level 1): ECC_scope.
Notation "< e1 , e2 > 'as' A" := (Pair e1 e2 A) (at level 50, e1 at level 5, e2 at level 5, A at level 5): ECC_scope.
Notation "'fst' e" := (Fst e) (at level 50, e at level 5): ECC_scope.
Notation "'snd' e" := (Snd e) (at level 50, e at level 5): ECC_scope.

Example ex_fst: Types ctx_empty (fst (< Tru, Fls> as (Σ : Bool .. Bool)))%ECC Bool.
Proof.
eapply T_Fst. auto.
Qed.

Require Import Lia.
Fixpoint size {V: nat} (e: @exp V) : nat :=
  match e with
  | Id _ => 1
  | Uni _ => 1
  | Pi A B => 1 + (size A) + (size B)
  | Abs A e => 1 + (size A) + (size e)
  | App e1 e2 => 1 + (size e1) + (size e2)
  | Let e1 e2 => 1 + (size e1) + (size e2)
  | Sig A B => 1 + (size A) + (size B)
  | Pair e1 e2 A => 1 + (size e1) + (size e2) + (size A)
  | Fst e => 1 + (size e)
  | Snd e => 1 + (size e)
  | If e e1 e2 => 1 + (size e) + (size e1) + (size e2)
  | Tru => 1
  | Fls => 1
  | Bool => 1
end.

Lemma size_non_zero : forall V e, 0 < @size V e.
Proof.
  induction e; simpl; lia.
Qed.

Lemma size_open_id : forall {V: nat} (e: @exp (1 + V)) x, @size (V) (open x e) = @size (1 + V) e.
Proof. intros.
  inductT e; induction V0; cbn; try easy; try (rewrite IHe1; try easy; rewrite IHe2; try easy; try (rewrite IHe3; try easy)).
  all: ( rewrite IHe; try easy).
Qed.

Lemma size_close_id : forall {V: nat} (e: @exp (V)) x, @size (1 + V) (close x e) = @size (V) e.
Proof. intros. induction e; names; auto.
Qed.

Lemma size_wk_id : forall {V: nat} (e: @exp (V)), @size (1 + V) (wk e) = @size (V) e.
Proof. intros. induction e; names; auto.
Qed.

Hint Resolve size_open_id size_close_id size_wk_id.

(*=============================
========Induction principle====
===============================*)

Inductive Vclosed : @term 0 -> Set :=
  | vc_Id (X: @atom 0) : Vclosed (Id X)
  | vc_Uni (U: universe) : Vclosed (Uni U)
  | vc_Pi (A: exp) (B: @exp 1) : Vclosed A -> (forall x, Vclosed (open x B)) -> Vclosed (Pi A B)
  | vc_Abs (A: exp) (B: @exp 1) : Vclosed A -> (forall x, Vclosed (open x B)) -> Vclosed (Abs A B)
  | vc_Sig (A: exp) (B: @exp 1) : Vclosed A -> (forall x, Vclosed (open x B)) -> Vclosed (Sig A B)
  | vc_Pair (v1 v2: exp) (A: exp) : Vclosed v1 -> Vclosed v2 -> Vclosed A -> Vclosed (Pair v1 v2 A)
  | vc_Tru : Vclosed (Tru)
  | vc_Fls : Vclosed (Fls)
  | vc_Bool: Vclosed (Bool)
  | vc_Let (A: exp) (B: @exp 1) : Vclosed A -> (forall n, Vclosed (open n B)) -> Vclosed (Let A B)
  | vc_If (v: exp) (e1 e2: exp) : Vclosed v -> Vclosed e1 -> Vclosed e2 -> Vclosed (If v e1 e2)
  | vc_App (v1 v2: exp) : Vclosed v1 -> Vclosed v2 -> Vclosed (App v1 v2)
  | vc_Fst (v: exp) : Vclosed v -> Vclosed (Fst v)
  | vc_Snd (v: exp) : Vclosed v -> Vclosed (Snd v).

Check Vclosed_ind.

Fixpoint Vclosedk (V : nat) : @term V -> Set :=
  match V with
  | 0 => fun t => Vclosed t
  | S V => fun t => forall n, Vclosedk V (open n t)
  end.

Fixpoint always_Vclosedk {V : nat} (t : term) {struct t} : Vclosedk V t :=
  match t with
  | Id x =>
    let fix go {V} : forall (x : @atom V), Vclosedk V (Id x) :=
      match V with
      | 0 => vc_Id
      | S V => fun v n => go _
      end
    in go x
  | Uni U =>
    let fix go {V} : forall (U : universe), Vclosedk V (Uni U) :=
      match V with
      | 0 => vc_Uni
      | S V => fun v n => go _
      end
    in go U
  | Pi A B =>
    let fix go {V} : forall A B, Vclosedk (V) A ->
                      Vclosedk (S V) B ->
                      Vclosedk V (Pi A B) :=
      match V with
      | 0 => vc_Pi
      | S V => fun _ _ vca vcb a=> go _ _ (vca a) (vcb a)
      end
    in go _ _ (always_Vclosedk A) (always_Vclosedk B)
  | Abs A B =>
    let fix go {V} : forall A B, Vclosedk (V) A ->
                      Vclosedk (S V) B ->
                      Vclosedk V (Abs A B) :=
      match V with
      | 0 => vc_Abs
      | S V => fun _ _ vca vcb a=> go _ _ (vca a) (vcb a)
      end
    in go _ _ (always_Vclosedk A) (always_Vclosedk B)
  | Sig A B =>
    let fix go {V} : forall A B, Vclosedk (V) A ->
                      Vclosedk (S V) B ->
                      Vclosedk V (Sig A B) :=
      match V with
      | 0 => vc_Sig
      | S V => fun _ _ vca vcb a=> go _ _ (vca a) (vcb a)
      end
    in go _ _ (always_Vclosedk A) (always_Vclosedk B)
  | Pair v1 v2 A =>
    let fix go {V} : forall v e1 e2, Vclosedk V v ->
                                     Vclosedk V e1 ->
                                     Vclosedk V e2 ->
                                     Vclosedk V (Pair v e1 e2) :=
      match V with
      | 0 => vc_Pair
      | S V => fun _ _ _ vv1 vv2 va a => go _ _ _ (vv1 a) (vv2 a) (va a)
      end
    in go _ _ _ (always_Vclosedk v1) (always_Vclosedk v2) (always_Vclosedk A)
  | Tru =>
    let fix go {V} : Vclosedk V _ :=
      match V with 0 => vc_Tru | S V => fun _ => go end in
    go
  | Fls =>
    let fix go {V} : Vclosedk V _ :=
      match V with 0 => vc_Fls | S V => fun _ => go end in
    go
  | Bool =>
    let fix go {V} : Vclosedk V _ :=
      match V with 0 => vc_Bool | S V => fun _ => go end in
    go
  | Let A B =>
    let fix go {V} : forall A B, Vclosedk (V) A ->
                      Vclosedk (S V) B ->
                      Vclosedk V (Let A B) :=
      match V with
      | 0 => vc_Let
      | S V => fun _ _ vca vcb a=> go _ _ (vca a) (vcb a)
      end
    in go _ _ (always_Vclosedk A) (always_Vclosedk B)
  | If v e1 e2 =>
    let fix go {V} : forall v e1 e2, Vclosedk V v ->
                                     Vclosedk V e1 ->
                                     Vclosedk V e2 ->
                                     Vclosedk V (If v e1 e2) :=
      match V with
      | 0 => vc_If
      | S V => fun _ _ _ vv ve1 ve2 a => go _ _ _ (vv a) (ve1 a) (ve2 a)
      end
    in go _ _ _ (always_Vclosedk v) (always_Vclosedk e1) (always_Vclosedk e2)
  | App f e  =>
    let fix go {V} : forall f e, Vclosedk V f ->
                                 Vclosedk V e ->
                                 Vclosedk V (App f e) :=
      match V with
      | 0 => vc_App
      | S V => fun _ _ vf ve a => go _ _ (vf a) (ve a)
      end
    in go _ _ (always_Vclosedk f) (always_Vclosedk e)
  | Fst v =>
    let fix go {V} : forall v, Vclosedk V v ->
                                 Vclosedk V (Fst v) :=
      match V with
      | 0 => vc_Fst
      | S V => fun _ vv a => go _ (vv a)
      end
    in go _ (always_Vclosedk v)
  | Snd v =>
    let fix go {V} : forall v, Vclosedk V v ->
                                 Vclosedk V (Snd v) :=
      match V with
      | 0 => vc_Snd
      | S V => fun _ vv a => go _ (vv a)
      end
    in go _ (always_Vclosedk v)
end.

Check Vclosed_ind.

Definition term_ind
             (P : @exp 0 -> Prop)
             (IDD : forall (v : atom), P (Id v))
             (UNI : forall (U : universe), P (Uni U))
             (TRU : P (Tru))
             (FLS : P (Fls))
             (BOO : P (Bool))
             (ABS : forall (A B : exp),
                 P (A) ->
                 (forall (n : name), P (open n B)) ->
                 P (Abs A B))
             (PIE : forall (A B : exp),
                 P (A) ->
                 (forall (n : name), P (open n B)) ->
                 P (Pi A B))
             (SIG : forall (A B : exp),
                 P (A) ->
                 (forall (n : name), P (open n B)) ->
                 P (Sig A B))
             (LeT : forall (A B : exp),
                 P (A) ->
                 (forall (n : name), P (open n B)) ->
                 P (Let A B))
             (APP : forall (f e : exp), P f -> P e -> P (App f e))
             (PAI : forall (v1 v2 A : exp), P v1 -> P v2 -> P A -> P (Pair v1 v2 A))
             (IFF : forall (v e1 e2 : exp), P v -> P e1 -> P e2 -> P (If v e1 e2))
             (FST : forall (v : exp), P v -> P (Fst v))
             (SND : forall (v : exp), P v -> P (Snd v))
             (tm : exp) : P tm :=
    Vclosed_ind (fun tm _ => P tm)
       IDD UNI
       (fun a b _ Ha _ Hb => PIE a b Ha Hb)
       (fun a b _ Ha _ Hb => ABS a b Ha Hb)
       (fun a b _ Ha _ Hb => SIG a b Ha Hb)
       (fun v1 v2 a _ Hv1 _ Hv2 _ Ha => PAI v1 v2 a Hv1 Hv2 Ha)
       TRU FLS BOO
       (fun a b _ Ha _ Hb => LeT a b Ha Hb)
       (fun v e1 e2 _ Hv _ He1 _ He2 => IFF v e1 e2 Hv He1 He2)
       (fun f e _ F _ E => APP f e F E)
       (fun v _ V => FST v V)
       (fun v _ V => SND v V)
       tm (always_Vclosedk tm).

Check Vclosed_ind.

(* Definition example_Type := (type 3)%ECC: exp.
Definition example_Prop := (prop)%ECC: exp.
Definition example_App := { X Y }%ECC: exp.
Definition example_Let := (LET X := Y in Z)%ECC : exp.
Print example_Let.
Definition F:= fresh (X::Y::Z::nil).
Definition example_Let2 := (LET X := (type 3) in LET F := (LET X := (type 2) in X) in ({X F}))%ECC.
Print example_Let2.
Definition example_Pi := (P X : F -> Y)%ECC : exp.
Definition example_Abs := (\ X: Y -> Z)%ECC : exp.
Definition example_Sig := (Si X : Y .. Z)%ECC : exp.
Definition example_Pair := (< X, Y > as (Si X : Y .. Z))%ECC : exp. *)

(*
Definition example_ycombinator := (\F:(type 3) -> ({(\X:(type 2) -> ({F {X X}})) (\X:(type 2) -> ({F {X X}}))}))%ECC.
Print example_ycombinator.
 *)(*
Compute subst X Y (LET Y := type 1 in X).

Goal RedClos Empty (LET X := Y in LET Y := type 1 in X) Y.
Proof.
cut (RedStep Empty (LET X := Y in LET Y := type 1 in X)%ECC (subst X (Id Y) (LET Y := type 1 in X))%ECC).
- cut (RedStep Empty (subst X (Id Y) (LET Y := type 1 in X))%ECC Y).
  + eauto.
  + cbv. apply R_Let.
- cbv. apply R_Let.
Qed.

Goal Types Empty (fst (<Tru , Fls> as
                            (Si X : Bool .. (If X Bool (P Y : Bool -> Bool))))) Bool.
Proof.
eapply T_Fst. eapply T_Pair.
  - apply T_True.
  - cbv. apply T_Conv with (A := Bool) (U := Uni (uType 0)).
    + apply T_False.
    + eapply T_Conv.
      * apply T_If with (U:=(type 1)%ECC).
        -- auto.
        -- auto.
        -- auto.
        -- cbn. eapply T_Prod_Type.
          ++ auto.
          ++ auto.
      * auto.
      * cbn. apply ST_Cong. apply E_EquivAlpha. apply aeq_id.
    + apply ST_Cong. apply E_Equiv with (e:= Bool).
      * auto.
      * eauto.
Unshelve. exact 1.
Qed. *)

(* -=ECC Evaluation=- *)

(* -Lookup- *)
(* Substitution *)

(* Fixpoint FV (e: exp) : atoms :=
match e with
  | Id x => singleton x
  | Uni U => empty
  | Pi x A B =>  union (FV A) (remove x (FV B))
  | Abs x A e => union (FV A) (remove  x (FV e))
  | App  e1 e2 => (union (FV e1) (FV e2))
  | Let x e1 e2 => union (FV e1) (remove  x (FV e2))
  | Sig x A B => (union (FV A) (remove  x (FV B)))
  | Pair e1 e2 A => (union (union  (FV e1) (FV e2)) (FV A))
  | Fst e => (FV e)
  | Snd e => (FV e)
(*   | If e e1 e2 => (union (union  (FV e) (FV e1)) (FV e2)) *)
  | Tru => empty
  | Fls => empty
  | Bool => empty
end. *)

(*Let's get nominal!*)
(* LET'S NOT *)
(* Fixpoint swap (x:atom) (y:atom) (t:exp) : exp :=
  match t with
  | Id z     => Id (swap_var x y z)
  | Abs z A t1  => Abs (swap_var x y z) (swap x y A) (swap x y t1)
  | App t1 t2 => App (swap x y t1) (swap x y t2)
  | Pi x' A B => Pi (swap_var x y x') (swap x y A) (swap x y B)
  | Let x' e1 e2 => Let (swap_var x y x') (swap x y e1) (swap x y e2)
  | Sig x' A B => Sig (swap_var x y x') (swap x y A) (swap x y B)
  | Pair e1 e2 A => Pair (swap x y e1) (swap x y e2) (swap x y A)
  | Fst e => (Fst (swap x y e))
  | Snd e => (Snd (swap x y e))
(*   | If e e1 e2 => (If (swap x y e) (swap x y e1) (swap x y e2)) *)
  | _ => t
  end.

Lemma swap_size_eq : forall x y t,
    size (swap x y t) = size t.
Proof.
  induction t; simpl; auto.
Qed. *)

(* If there are free variables in the substitute,
   and if the term being substituted in binds one of them,
   then we need to perform an alpha conversion of the term being substituted in
   that avoids capturing any free variables in the substitute or in the body
   of the term being substituted in. *)
(* Require Import Recdef.
Function substWork (x: atom) (arg body: exp) {measure size body}:=
if (AtomSetImpl.mem x (FV body)) then
  match body with
    | Id x' => if (x == x') then arg else body
    | Abs x' A e =>
        if (x == x')
          then (Abs x' (substWork x arg A) e)
          else let (xnew,_) := atom_fresh (union (FV arg) (FV e)) in
                      (Abs xnew (substWork x arg A) (substWork x arg (swap x' xnew e)))
    | Pi x' A B =>
        if (x == x')
          then (Pi x' (substWork x arg A) B)
          else let (xnew,_) := atom_fresh (union (FV arg) (FV B)) in
                  (Pi xnew (substWork x arg A) (substWork x arg (swap x' xnew B)))
    | Let x' A B =>
        if (x == x')
          then (Let x' (substWork x arg A) B)
          else let (xnew,_) := atom_fresh (union (FV arg) (FV B)) in
                  (Let xnew (substWork x arg A) (substWork x arg (swap x' xnew B)))
    | Sig x' A B =>
        if (x == x')
          then (Sig x' (substWork x arg A) B)
          else let (xnew,_) := atom_fresh (union (FV arg) (FV B)) in
                  (Sig xnew (substWork x arg A) (substWork x arg (swap x' xnew B)))
    | App e1 e2 => (App (substWork x arg e1) (substWork x arg e2))
    | Pair e1 e2 A => (Pair (substWork x arg e1) (substWork x arg e2) (substWork x arg A))
    | Fst e => (Fst (substWork x arg e))
    | Snd e => (Snd (substWork x arg e))
  (*   | If e e1 e2 => (If (substWork x arg e FVInArg) (substWork x arg e1 FVInArg) (substWork x arg e2 FVInArg)) *)
    | _ => body
  (*   | eSubst a b c => eSubst (substWork x arg a FVInArg) (substWork x arg b FVInArg) (substWork x arg c FVInArg) (**) *)
  end
else body.
Proof.
1-19: try (Tactics.program_simpl; cbn; omega).
1-4: try (Tactics.program_simpl; cbn; rewrite -> swap_size_eq; omega).
Qed.
 *)

(* Definition subst (x: atom) (arg body: exp):= substWork x arg body. *)
(*
Inductive ECC_Aeq : exp -> exp -> Prop :=
  | aeq_id (e: exp):
    ECC_Aeq e e
  | aeq_var (x: atom):
     ECC_Aeq (Id x) (Id x)
  | aeq_abs_same (x: atom) (t1 t2 b1 b2: exp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (Abs x t1 b1) (Abs x t2 b2)
  | aeq_abs_diff (x y: atom) (t1 t2 b1 b2: exp):
     x <> y ->
     x `notin` (FV b2) ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (Abs x t1 b1) (Abs y t2 b2)
  | aeq_pi_same (x: atom) (t1 t2 b1 b2: exp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (Pi x t1 b1) (Pi x t2 b2)
  | aeq_pi_diff (x y: atom) (t1 t2 b1 b2: exp):
     x <> y ->
     x `notin` (FV b2) ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (Pi x t1 b1) (Pi y t2 b2)
  | aeq_let_same (x: atom) (t1 t2 b1 b2: exp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (Let x t1 b1) (Let x t2 b2)
  | aeq_let_diff (x y: atom) (t1 t2 b1 b2: exp):
     x <> y ->
     x `notin` (FV b2) ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (Let x t1 b1) (Let y t2 b2)
  | aeq_sig_same (x: atom) (t1 t2 b1 b2: exp):
     ECC_Aeq t1 t2 ->
     ECC_Aeq b1 b2 ->
     ECC_Aeq (Sig x t1 b1) (Sig x t2 b2)
  | aeq_sig_diff (x y: atom) (t1 t2 b1 b2: exp):
     x <> y ->
     x `notin` (FV b2) ->
     ECC_Aeq b1 (swap y x b2) ->
     ECC_Aeq t1 t2 ->
     ECC_Aeq (Sig x t1 b1) (Sig y t2 b2)
  | aeq_app (t1 t2 t1' t2': exp):
     ECC_Aeq t1 t1' -> ECC_Aeq t2 t2' ->
     ECC_Aeq (App t1 t2) (App t1' t2')
  | aeq_pair (t1 t2 t1' t2' A A': exp):
     ECC_Aeq t1 t1' -> ECC_Aeq t2 t2' ->
     ECC_Aeq A A' ->
     ECC_Aeq (Pair t1 t2 A) (Pair t1' t2' A')
  | aeq_Fst (e e': exp):
     ECC_Aeq e e' ->
     ECC_Aeq (Fst e) (Fst e')
  | aeq_Snd (e e': exp):
     ECC_Aeq e e' ->
     ECC_Aeq (Snd e) (Snd e')
(*   | aeq_if (e1 e2 e3 e1' e2' e3': exp):
     ECC_Aeq e1 e1' ->
     ECC_Aeq e2 e2' ->
     ECC_Aeq e3 e3' ->
     ECC_Aeq (If e1 e2 e3) (If e1' e2' e3') *)
.

Hint Constructors ECC_Aeq.
 *)
(* -Step- *)


(**

Copyright (C) Faissole

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)
Require Import Reals.

From mathcomp
  Require Import all_ssreflect ssralg matrix.

From Flocq.Core
Require Import Core.

Require Import Rstruct Compl Norms.

Set Implicit Arguments.

Section Def_schemes.

Variables (beta : radix)
          (emin prec : Z)
          (choice : Z -> bool).

Definition r_flt := (round beta
    (FLT_exp emin prec) (ZnearestE)).

Variable d : nat.

(** Type Sc of schemes : fun W => fun y(n) => y(n+1) *)
Definition Sc : Type := (R -> R) -> 'cV[R]_d -> 'cV[R]_d.

(* Roundings and schemes :
   W_Id : exact R(h,l)
   W_FLT : FLT format on scheme R~(h~,l~,y~) *)

Definition W_Id := (fun meth : Sc => meth ssrfun.id).
Definition W_FLT := (fun meth : Sc => meth r_flt).

(** Mathematical equivalence between schemes *)
Definition eq_math_Sc (meth1 meth2 : Sc) : Prop :=
               forall x, W_Id meth1 x = W_Id meth2 x.

(** Stability property *)
Definition stable (meth : Sc) : Prop :=
               forall x, ||| (W_Id meth x) ||| <= ||| x |||.

Definition meth_iter (meth : Sc) n (y0 : 'cV_d) (W : R -> R)
                     := Nat.iter n (meth W) (\matrix_(i,j) (W (y0 i j))).

(** global roundoff error of the scheme after N iteration
   == En *)
Definition error_glob (meth : Sc) (n : nat) (y0 : 'cV_d) (W : R -> R)
  := ||| (meth_iter meth n y0 W - meth_iter meth n y0 id) |||.

(** local roundoff error of the scheme at iteration n
   == epsilon n+1 *)
Definition error_loc (meth : Sc) (n : nat) (y0 : 'cV_d) (W : R -> R)
  := ||| (meth W (meth_iter meth n y0 W)  - meth id (meth_iter meth n y0 W)) |||.

Notation "S1 ≡ S2" := (eq_math_Sc S1 S2) (at level 35).

(** Characterization of RK + linear systems, i.e. R(h,A) *)
Definition is_RK_lin (meth : Sc) (Rmeth : 'M_d) :=
      forall y, W_Id meth y = (Rmeth *m y)%R.

Notation "x ^ y" := (Rpow_def.pow x y).

(** Simplification of exact n-th iteration *)
Lemma is_RK_Rmeth meth Rm (is_RKm : is_RK_lin meth Rm) y0 :
   forall N, ||| (meth_iter meth N y0 (fun x : R => x)) |||
           <= ||| Rm ||| ^ N * ||| y0 |||.
Proof.
induction 0.
+ simpl.
  rewrite Rmult_1_l.
  apply Req_le.
  f_equal.
  apply matrixP=> i j.
  rewrite !mxE.
  reflexivity.
+ simpl; unfold W_Id in *.
  unfold W_Id in *.
  simpl; unfold is_RK_lin in is_RKm.
  unfold W_Id in *.
  rewrite is_RKm.
  apply Rle_trans with (||| Rm |||*||| (meth_iter meth N y0 id) |||).
  apply norm_submult.
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  apply matrix_norm_pos.
  apply IHN.
Qed.

End Def_schemes.


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

(**********************************************************************)
(*                      SF_Normal.v                                   *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max.
Require Import IntensionalLib.SF_calculus.SF_Terms.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.SF_calculus.SF_Tactics.
Require Import IntensionalLib.SF_calculus.SF_reduction.

Inductive status_val :=
| Active : status_val
| Passive : status_val
.

Fixpoint status M :=
match M with
| Ref _ => Active
| Op _ => Passive
| App (App (App (Op Fop) M1) _ ) _ => status M1
| App M1 _ => status M1
end.

(* normal terms *)

Inductive normal : SF -> Prop :=
| nf_ref : forall n, normal (Ref n)
| nf_op : forall o, normal (Op o)
| nf_active : forall M1 M2, normal M1 -> normal M2 ->
                              status (App M1 M2) = Active ->
                              normal (App M1 M2)
| nf_compound : forall M1 M2, normal M1 -> normal M2 ->
                              compound (App M1 M2) -> normal (App M1 M2)
.

Hint Constructors normal.

Definition irreducible M (red:termred) := forall N, red M N -> False.

Lemma ref_irreducible : forall n, irreducible (Ref n) sf_seqred1.
Proof. intro n. red. split_all. inversion H; auto. Qed.

Lemma normal_is_irreducible:
forall M, normal M -> irreducible M sf_seqred1.
Proof.
intros M nor; induction nor; split_all.
(* 4 *)
eapply2 ref_irreducible.
(* 3 *)
red; split_all. inversion H.
(* 2 *)
intro. intro. inversion H0; subst; simpl in *; try discriminate.
(* 4 *)
eapply2 IHnor1.
(* 3 *)
eapply2 IHnor2.
(* 2 *)
  inv1 compound; subst; split_all; discriminate.
(* 1 *)
intro. intro. inversion H0; subst; simpl in *; try (inversion H; fail).
eapply2 IHnor1.
eapply2 IHnor2.
Qed.

Theorem SF_progress : forall (M : SF), normal M \/ (exists N, sf_seqred1 M N) .
Proof.
induction M; try (inversion IHM); subst; split_all; eauto.
(* 1 *)
inversion IHM1; split_all. 2: right; inversion H; exist (App x M2).
inversion IHM2; split_all.  2:right; inversion H0; exist (App M1 x).
gen_case H M1. case o; try (right; eauto; fail); left; auto.
inversion H; subst.
(* 2 *)
left; auto.
eapply2 nf_active. gen_case H5 s. gen_case H5 s1. discriminate.
(* 1 *)
gen2_case H3 H5 s.
left; case o; auto.
gen2_case H3 H5 s1.
gen2_case H3 H5 o; try (right; eauto; fail).
inversion H3; subst. inversion H8.
inversion H7; subst. left; eapply2 nf_active.
right; eauto. left; eapply2 nf_active.
right; eauto. inversion H5.
Qed.