(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*           [*] Affiliation Univ. Lorraine - CNRS - LORIA    *)
(*           [+] Affiliation VERIMAG - Univ. Grenoble Alpes   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*        CeCILL v2.1 FREE SOFTWARE LICENSE AGREEMENT         *)
(**************************************************************)

From Coq Require Import Utf8.

From MuRec Require Import sigma relations arith_mini between schemes computable_def linear_search.

Section umin_compute.

  Variable (F : nat → nat → Prop)
           (Ffun : functional F)
           (f : ∀n, computable (F n)).

  Arguments Ffun {_ _ _}.

  (* Instanciation of Dtest, P, Q and PQ_abs *)
  Let Dtest := def_at F.
  Let P := ze_at F.
  Let Q := pos_at F.
  Local Fact PQ_abs : ∀n, Dtest n → P n → Q n → False.
  Proof. intros n _ p (y & q). now generalize (Ffun p q). Qed.

  (* Instanciation of 𝔻ls, ℙre_ls, ℙost_ls and ℙre_𝔻ls using Dtest, P and Q *)
  Let 𝔻 := 𝔻ls Dtest P.
  Let 𝔻_π₁ := λ {n} (d : 𝔻 n), 𝔻ls_π₁ Dtest P d.
  Let 𝔻_π₂ := λ {n} (d : 𝔻 n) q, 𝔻ls_π₂ Dtest P Q PQ_abs d q.
  Let ℙre := ℙre_ls Dtest P.
  Let ℙost := ℙost_ls Dtest P Q.
  Let ℙre_𝔻 {s} : ex (ℙre s) → 𝔻 s := ℙre_ls_𝔻ls Dtest P.

  Variable (s : nat).

  (* ---------------------------------------------------------------------- *)
  (* The algorithm below can be derived from the one in linear_search.v.
     umin F s, that is ze_at F ∧₁ btwn (pos_at F) s, is at the same time the
     pre and the post-condition of the intended algorithm (umin_compute), by
     the definition of computable.
     It is also an opportunistic version of ℙost.
     See umin_compute_details.v for details. *)
  (* ---------------------------------------------------------------------- *)

  (* The Let before the Fixpoint below forces the inlining of loop inside
     linear_search *)
  Let Fixpoint loop n (d : 𝔻 n) (b : btwn (pos_at F) s n) : sig (umin F s) :=
    let (k,Hk) := f n (𝔻_π₁ d) in
    match k return F _ k → _ with
    | 0   => λ e, ⟪n, ⟨e,b⟩ₚ⟫
    | S _ => λ e, loop (S n) (𝔻_π₂ d ⟪_,e⟫ₚ) (btwn_next b ⟪_,e⟫ₚ)
    end Hk.

  (* Copied from linear_search.v, with ℙost replaced by umin F *)
  Let linear_search : ex (ℙre s) → sig (umin F s) :=
    λ e, loop s (ℙre_𝔻 e) btwn_refl.

  (* umin F is stronger than (actually equivalent to) the pre-condition
     allowing us to compute the initial termination certificate. *)
  Local Fact umin_ℙre :  umin F s ⊆₁ ℙre s.
    (* ze_at F ∧₁ btwn (pos_at F) s ⊆₁ (def_at F ∧₁ ze_at F) ∧₁ btwn (def_at F) s *)
  Proof.
    (* structural rules *)
    apply and₁_monotonic; [ apply and₁_intro; [ | apply included₁_refl] | apply btwn_monotonic₁].
    - apply ze_at_def_at.
    - apply pos_at_def_at.
  Qed.

  Definition umin_compute : computable (umin F s) :=
    linear_search  ∘  ex_monotonic umin_ℙre.

End umin_compute.

Arguments umin_compute {F} Ffun Fcomp n : rename.

Section umin₀_compute.

  Variable (F : nat → nat → Prop)
           (Ffun : functional F)
           (f : ∀n, computable (F n)).

  Definition umin₀_compute : computable (umin₀ F) :=
    sig_monotonic umin_umin₀  ∘  umin_compute Ffun f 0  ∘  ex_monotonic umin₀_umin.

End umin₀_compute.

Arguments umin₀_compute {F} Ffun Fcomp n : rename.


(** ***************************************************************

Contents:
 - Category of coalgebras over an endofunctor.
 - Dual of Lambek's lemma: if (A,α) is terminal coalgebra, α is an isomorphism.
 - Primitive corecursion.

******************************************************************)

Require Import UniMath.Foundations.Propositions.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.bincoproducts.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Local Open Scope cat.

Section Coalgebra_Definition.

  Context {C : category} (F : functor C C).

  Definition coalgebra_disp_cat_ob_mor : disp_cat_ob_mor C.
  Proof.
    use tpair.
    - exact (λ x, x --> F x).
    - exact (λ x y hx hy f, hx · #F f = f · hy).
  Defined.

  Definition coalgebra_disp_cat_id_comp
    : disp_cat_id_comp C coalgebra_disp_cat_ob_mor.
  Proof.
    split.
    - intros x hx ; cbn.
      rewrite !functor_id.
      rewrite id_left, id_right.
      apply idpath.
    - intros x y z f g hx hy hz hf hg ; cbn in *.
      rewrite !functor_comp.
      rewrite !assoc.
      rewrite hf.
      rewrite !assoc'.
      rewrite hg.
      apply idpath.
  Qed.

  Definition coalgebra_disp_cat_data : disp_cat_data C
    := coalgebra_disp_cat_ob_mor ,, coalgebra_disp_cat_id_comp.

  Definition coalgebra_disp_cat_axioms
    : disp_cat_axioms C coalgebra_disp_cat_data.
  Proof.
    repeat split ; intros ; try (apply homset_property).
    apply isasetaprop.
    apply homset_property.
  Qed.

  Definition coalgebra_disp_cat : disp_cat C
    := coalgebra_disp_cat_data ,, coalgebra_disp_cat_axioms.

  Definition CoAlg_category : category
    := total_category coalgebra_disp_cat.

  Definition coalgebra_ob : UU := ob CoAlg_category.

  Definition coalg_carrier (X : coalgebra_ob) : C := pr1 X.
  Local Coercion coalg_carrier : coalgebra_ob >-> ob.

  Definition coalg_map (X : coalgebra_ob) : C ⟦X, F X ⟧ := pr2 X.

  (** A homomorphism of F-coalgebras (F A, α : C ⟦A, F A⟧) and (F B, β : C ⟦B, F B⟧)
    is a morphism f : C ⟦A, B⟧ s.t. the below diagram commutes.
<<
         f
     A -----> B
     |        |
     | α      | β
     |        |
     V        V
    F A ---> F B
        F f
>>
*)

  Definition is_coalgebra_mor (X Y : coalgebra_ob) (f : coalg_carrier X --> coalg_carrier Y) : UU
    := coalg_map X · #F f = f · coalg_map Y.

  Definition coalgebra_mor (X Y : coalgebra_ob) : UU := CoAlg_category⟦X,Y⟧.
  Coercion mor_from_coalgebra_mor {X Y : coalgebra_ob} (f : coalgebra_mor X Y) : C⟦X, Y⟧ := pr1 f.

  Lemma coalgebra_mor_commutes {X Y : coalgebra_ob} (f : coalgebra_mor X Y)
    : coalg_map X · #F f = pr1 f · coalg_map Y.
  Proof.
    exact (pr2 f).
  Qed.

  Definition coalgebra_homo_eq {X Y : coalgebra_ob}
             (f g : coalgebra_mor X Y) : (f : C ⟦X, Y⟧) = g ≃ f = g.
  Proof.
    apply invweq.
    apply subtypeInjectivity.
    intro. apply homset_property.
  Defined.

End Coalgebra_Definition.

Section Lambek_dual.
(** Dual of Lambeks Lemma : If (A,α) is terminal F-coalgebra, then α is an iso *)

Context (C : category)
        (F : functor C C)
        (X : coalgebra_ob F).

Local Notation F_CoAlg := (CoAlg_category F).

Context (isTerminalX : isTerminal F_CoAlg X).

Definition TerminalX : Terminal F_CoAlg := make_Terminal _ isTerminalX.

Local Notation α := (coalg_map F (TerminalObject TerminalX)).
Local Notation A := (coalg_carrier F (TerminalObject TerminalX)).

(** FX := (FA,Fα) is also an F-coalgebra *)
Definition FX : ob F_CoAlg := tpair _ (F A) (#F α).

(** By terminality there is an arrow α' : FA → A, s.t.:
<<
         α'
    FA ------> A
    |          |
    | Fα       | α
    V          V
   FFA ------> FA
         Fα'
>>
  commutes *)

Definition f : F_CoAlg ⟦FX, TerminalX⟧ := (@TerminalArrow F_CoAlg TerminalX FX).

Definition α' : C ⟦F A, A⟧ := mor_from_coalgebra_mor F f.

Definition αα'_mor : coalgebra_mor F X X.
Proof.
  exists (α · α').
  simpl.
  rewrite <- assoc.
  apply cancel_precomposition.
  rewrite functor_comp.
  apply (coalgebra_mor_commutes F f).
Defined.

Definition αα'_idA : α · α' = identity A
  := maponpaths pr1 (TerminalEndo_is_identity (T:=TerminalX) αα'_mor).

Lemma α'α_idFA : α' · α = identity (F A).
Proof.
  rewrite <- functor_id.
  rewrite <- αα'_idA.
  rewrite functor_comp.
  unfold α'.
  apply pathsinv0.
  apply (coalgebra_mor_commutes F f).
Defined.

Lemma terminalcoalgebra_is_z_iso : is_z_isomorphism α.
Proof.
  use make_is_z_isomorphism.
  - exact α'.
  - split.
    + exact αα'_idA.
    + exact α'α_idFA.
Defined.

Definition terminalcoalgebra_z_iso : z_iso A (F A) := α,, terminalcoalgebra_is_z_iso.

(* Definition terminalcoalgebra_iso : iso A (F A) := z_iso_to_iso terminalcoalgebra_z_iso. *)

End Lambek_dual.

Section PrimitiveCorecursion.

  Context {C : category} (CP : BinCoproducts C)
          {F : functor C C} {νF : coalgebra_ob F}
          (isTerminalνF : isTerminal (CoAlg_category F) νF).

  Context {x : C} (ϕ : C⟦x, F(CP x (pr1 νF))⟧).

  Definition X_coproduct_νF_coalgebra : coalgebra_ob F.
  Proof.
    exists (CP x (pr1 νF)).
    exact (BinCoproductArrow (CP x (pr1 νF)) ϕ (pr2 νF · #F (BinCoproductIn2 (CP x (pr1 νF))))).
  Defined.

  Let h : C⟦x, pr1 νF⟧
      := (BinCoproductIn1 (CP x (pr1 νF)) · pr1 (@TerminalArrow (CoAlg_category F) (νF,,isTerminalνF) X_coproduct_νF_coalgebra)).

  Lemma X_coproduct_νF_coalgebra_morphism_into_νF_aux :
    pr2 X_coproduct_νF_coalgebra -->[ BinCoproductArrow (CP x (pr1 νF)) h (identity (pr1 νF))] pr2 νF.
  Proof.
    cbn.

    etrans.
    1: apply postcompWithBinCoproductArrow.
    etrans.
    2: apply pathsinv0, postcompWithBinCoproductArrow.

    assert (p0 : ϕ · # F (BinCoproductArrow (CP x (pr1 νF)) h (identity (pr1 νF))) = h · pr2 νF).
    {
      unfold h.
      set (t := pr2 (TerminalArrow (νF,, isTerminalνF) X_coproduct_νF_coalgebra)).
      cbn in t.

      etrans.
      2: apply assoc.
      etrans.
      2: apply maponpaths, t.
      etrans.
      2: apply assoc'.
      etrans.
      2: apply maponpaths_2, pathsinv0, BinCoproductIn1Commutes.
      do 2 apply maponpaths.

      assert (p1 : identity (pr1 νF) = BinCoproductIn2 (CP x (pr1 νF)) ·  pr1 (TerminalArrow (νF,, isTerminalνF) X_coproduct_νF_coalgebra)).
      {
        etrans.
        1: apply (base_paths _ _ (TerminalArrowUnique (νF,,isTerminalνF) νF (identity _))).

        transparent assert (f : ((CoAlg_category F)⟦νF,νF⟧)).
        {
          refine (_ · (TerminalArrow (νF,, isTerminalνF) X_coproduct_νF_coalgebra)).
          exists (BinCoproductIn2 (CP x (pr1 νF))).
          apply pathsinv0, BinCoproductIn2Commutes.
        }
        exact (! base_paths _ _ (TerminalArrowUnique (νF,,isTerminalνF) νF f)).
      }
      rewrite p1.
      apply pathsinv0, BinCoproductArrowEta.
    }

    rewrite p0.
    apply maponpaths.

    etrans.
    1: apply assoc'.
    etrans. {
      apply maponpaths.
      etrans.
      1: apply pathsinv0, functor_comp.
      apply maponpaths.
      apply BinCoproductIn2Commutes.
    }
    etrans. {
      apply maponpaths.
      apply functor_id.
    }
    exact (id_right _ @ ! id_left _).
  Qed.

  Definition X_coproduct_νF_coalgebra_morphism_into_νF : (CoAlg_category F ⟦ X_coproduct_νF_coalgebra, νF⟧).
  Proof.
    exists (BinCoproductArrow (CP x (pr1 νF)) h (identity (pr1 νF))).
    exact X_coproduct_νF_coalgebra_morphism_into_νF_aux.
  Defined.

  Definition primitive_corecursion_characteristic_formula (h :  C⟦x, pr1 νF⟧) : UU :=
    h · (pr2 νF) = ϕ · #F (BinCoproductArrow (CP _ _) h (identity _)).

  Lemma primitive_corecursion_existence : primitive_corecursion_characteristic_formula h.
  Proof.
    etrans. { apply assoc'. }
    etrans. {
      apply maponpaths.
      exact (! pr2 (@TerminalArrow (CoAlg_category F) (νF,,isTerminalνF) X_coproduct_νF_coalgebra)).
    }
    cbn.
    etrans. { apply assoc. }
    etrans. {
      apply maponpaths_2.
      apply BinCoproductIn1Commutes.
    }
    do 2 apply maponpaths.
    apply pathsinv0.
    exact (base_paths _ _ (TerminalArrowUnique (νF,, isTerminalνF) _ X_coproduct_νF_coalgebra_morphism_into_νF)).
  Qed.

  Lemma primitive_corecursion_aux (p : ∑ h : C ⟦ x, pr1 νF ⟧, primitive_corecursion_characteristic_formula h) :
    p = h,, primitive_corecursion_existence.
  Proof.
    use total2_paths_f.
    - assert (q : (pr1 p = BinCoproductIn1 (CP x (pr1 νF)) · (BinCoproductArrow (CP _ _) (pr1 p) (identity _)))).
      {
        apply pathsinv0, BinCoproductIn1Commutes.
      }

      etrans.
      1: exact q.
      simpl.
      apply maponpaths.

      transparent assert ( f : ( CoAlg_category F ⟦ X_coproduct_νF_coalgebra, νF⟧)).
      {
        exists ( BinCoproductArrow (CP x (pr1 νF)) (pr1 p) (identity (pr1 νF))).
        cbn.

        etrans.
        1: apply postcompWithBinCoproductArrow.
        etrans.
        2: apply pathsinv0, postcompWithBinCoproductArrow.

        use (BinCoproductArrowUnique _ _ _ (CP x (pr1 νF)) (F (pr1 νF))).
        - etrans.
          1: apply BinCoproductIn1Commutes.
          exact (! pr2 p).
        - etrans.
          1: apply BinCoproductIn2Commutes.
          etrans.
          1: apply assoc'.
          etrans. {
            apply maponpaths.
            etrans.
            1: apply pathsinv0, functor_comp.
            apply maponpaths.
            apply BinCoproductIn2Commutes.
          }
          etrans. {
            apply maponpaths.
            apply functor_id.
          }
          exact (id_right _ @ ! id_left _).
      }
      exact (base_paths _ _ (TerminalArrowUnique  (νF,, isTerminalνF)  X_coproduct_νF_coalgebra f)).
    - apply homset_property.
  Qed.

  Definition primitive_corecursion
    : ∃! h : C⟦x, pr1 νF⟧, primitive_corecursion_characteristic_formula h.
  Proof.
    exists (h ,, primitive_corecursion_existence).
    apply primitive_corecursion_aux.
  Defined.

End PrimitiveCorecursion.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.CCC.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.
Require Import Basic_Cons.Terminal.
Require Import PreSheaf.PreSheaf.

Section Terminal.
  Context (C : Category).

  (** The terminal element of the category of presheaves. *)
  Program Definition PSh_Term_PreSheaf : Functor (C^op) Type_Cat :=
    {|
      FO := fun _ => unit
    |}.

  Local Hint Resolve NatTrans_eq_simplify.
  Local Hint Extern 1 =>
  match goal with
    [|- ?A = ?B] => try destruct A; try destruct B; trivial; fail
  end.

  (** The functor that maps to the unit type in coq is the terminal object
      of presheaves. *)
  Program Instance PSh_Terminal : (𝟙_ (PShCat C))%object :=
    {
      terminal := PSh_Term_PreSheaf;
      t_morph := fun _ => {|Trans := fun _ _ => tt|}
    }.

End Terminal.


From melocoton.ml_lang Require Export lang notation metatheory.
From Autosubst Require Import Autosubst.
From iris.prelude Require Import options.

Inductive type :=
  | TUnit : type
  | TNat : type
  | TBool : type
  | TProd : type → type → type
  | TSum : type → type → type
  | TArrow : type → type → type
  | TRec (τ : {bind 1 of type})
  | TVar (x : var)
  | TForall (τ : {bind 1 of type})
  | TExist (τ : {bind 1 of type})
  | TArray (τ : type).

Global Instance Ids_type : Ids type. derive. Defined.
Global Instance Rename_type : Rename type. derive. Defined.
Global Instance Subst_type : Subst type. derive. Defined.
Global Instance SubstLemmas_typer : SubstLemmas type. derive. Qed.

Definition binop_arithmetic (op : bin_op) : bool :=
  match op with
  | PlusOp | MinusOp| MultOp| QuotOp| RemOp| AndOp| OrOp| XorOp| ShiftLOp| ShiftROp => true
  | LeOp| LtOp| EqOp => false
  end.

Definition binop_arithmetic_to_bool (op : bin_op) : bool :=
  match op with
  | PlusOp | MinusOp| MultOp| QuotOp| RemOp| AndOp| OrOp| XorOp| ShiftLOp| ShiftROp | EqOp => false
  | LeOp| LtOp => true
  end.

Definition binop_boolish (op : bin_op) : bool :=
  match op with
  | AndOp| OrOp| XorOp => true
  | _ => false
  end.

Inductive EqType : type → Prop :=
  | EqTUnit : EqType TUnit
  | EqTNat : EqType TNat
  | EqTBool : EqType TBool
  | EQTArray τ : EqType (TArray τ).

Inductive program_type := FunType : list type -> type -> program_type.
Definition subst_prog_type (f : var → type) : program_type → program_type := fun '(FunType tv tr) => FunType (fmap (subst f) tv) (subst f tr).
Definition program_env := gmap string program_type.
Definition subst_prog_env f (p : program_env) := fmap (subst_prog_type f) p.

Section IndDef.

Reserved Notation "P ;; Γ ⊢ₜ e : τ" (at level 74, e, τ at next level).
Unset Elimination Schemes.
Inductive typed (P : program_env) (Γ : gmap string type) : expr → type → Prop :=
  | Var_typed x τ : Γ !! x = Some τ → P ;; Γ ⊢ₜ Var x : τ
  | Unit_typed : P ;; Γ ⊢ₜ  #LitUnit : TUnit
  | Nat_typed (n:Z) : P ;; Γ ⊢ₜ # n : TNat
  | Bool_typed (b:bool) : P ;; Γ ⊢ₜ # b : TBool
  | BinOp_typed_nat_nat op e1 e2 :
     binop_arithmetic op = true →
     P ;; Γ ⊢ₜ e1 : TNat → P ;; Γ ⊢ₜ e2 : TNat → P ;; Γ ⊢ₜ BinOp op e1 e2 : TNat
  | BinOp_typed_nat_bool op e1 e2 :
     binop_arithmetic_to_bool op = true →
     P ;; Γ ⊢ₜ e1 : TNat → P ;; Γ ⊢ₜ e2 : TNat → P ;; Γ ⊢ₜ BinOp op e1 e2 : TBool
  | BinOp_typed_bool op e1 e2 :
     binop_boolish op = true →
     P ;; Γ ⊢ₜ e1 : TBool → P ;; Γ ⊢ₜ e2 : TBool → P ;; Γ ⊢ₜ BinOp op e1 e2 : TBool
  | BinOp_typed_eq T e1 e2 :
     EqType T →
     P ;; Γ ⊢ₜ e1 : T → P ;; Γ ⊢ₜ e2 : T → P ;; Γ ⊢ₜ BinOp EqOp e1 e2 : TBool
  | Pair_typed e1 e2 τ1 τ2 : P ;; Γ ⊢ₜ e1 : τ1 → P ;; Γ ⊢ₜ e2 : τ2 → P ;; Γ ⊢ₜ Pair e1 e2 : TProd τ1 τ2
  | Fst_typed e τ1 τ2 : P ;; Γ ⊢ₜ e : TProd τ1 τ2 → P ;; Γ ⊢ₜ Fst e : τ1
  | Snd_typed e τ1 τ2 : P ;; Γ ⊢ₜ e : TProd τ1 τ2 → P ;; Γ ⊢ₜ Snd e : τ2
  | InjL_typed e τ1 τ2 : P ;; Γ ⊢ₜ e : τ1 → P ;; Γ ⊢ₜ InjL e : TSum τ1 τ2
  | InjR_typed e τ1 τ2 : P ;; Γ ⊢ₜ e : τ2 → P ;; Γ ⊢ₜ InjR e : TSum τ1 τ2
  | Case_typed e0 e1 e2 τ1 τ2 τ3 :
     P ;; Γ ⊢ₜ e0 : TSum τ1 τ2 → P ;; Γ ⊢ₜ e1 : (TArrow τ1 τ3) → P ;; Γ ⊢ₜ e2 : (TArrow τ2 τ3) →
     P ;; Γ ⊢ₜ Case e0 e1 e2 : τ3
  | If_typed e0 e1 e2 τ :
     P ;; Γ ⊢ₜ e0 : TBool → P ;; Γ ⊢ₜ e1 : τ → P ;; Γ ⊢ₜ e2 : τ → P ;; Γ ⊢ₜ If e0 e1 e2 : τ
  | Rec_typed f x e τ1 τ2 :
     P ;; (binder_insert f (TArrow τ1 τ2) (binder_insert x τ1 Γ)) ⊢ₜ e : τ2 → P ;; Γ ⊢ₜ Rec f x e : TArrow τ1 τ2
  | App_typed e1 e2 τ1 τ2 :
     P ;; Γ ⊢ₜ e1 : TArrow τ1 τ2 → P ;; Γ ⊢ₜ e2 : τ1 → P ;; Γ ⊢ₜ App e1 e2 : τ2
  | TLam_typed e τ :
     subst_prog_env (ren (+1)) P ;; subst (ren (+1)) <$> Γ ⊢ₜ e : τ → P ;; Γ ⊢ₜ TLam e : TForall τ
  | TApp_typed e τ τ' : P ;; Γ ⊢ₜ e : TForall τ → P ;; Γ ⊢ₜ TApp e : τ.[τ'/]
  | Pack_typed e τ τ' :
     P ;; Γ ⊢ₜ e : τ.[τ'/] → P ;; Γ ⊢ₜ Pack e : TExist τ
  | UnpackIn_typed x e1 e2 τ τ' :
     P ;; Γ ⊢ₜ e1 : TExist τ →
     subst_prog_env (ren (+1)) P ;; binder_insert x τ (subst (ren (+1)) <$> Γ) ⊢ₜ e2 : τ'.[ren (+1)] →
     P ;; Γ ⊢ₜ UnpackIn x e1 e2 : τ'
  | TRoll e τ : P ;; Γ ⊢ₜ e : τ.[TRec τ/] → P ;; Γ ⊢ₜ Roll e : TRec τ
  | TUnroll e τ : P ;; Γ ⊢ₜ e : TRec τ → P ;; Γ ⊢ₜ Unroll e : τ.[TRec τ/]
  | TAllocN e1 e2 τ : P ;; Γ ⊢ₜ e1 : TNat → P ;; Γ ⊢ₜ e2 : τ → P ;; Γ ⊢ₜ AllocN e1 e2 : TArray τ
  | TLoadN e1 e2 τ : P ;; Γ ⊢ₜ e1 : TArray τ → P ;; Γ ⊢ₜ e2 : TNat → P ;; Γ ⊢ₜ LoadN e1 e2 : τ
  | TStoreN e1 e2 e3 τ : P ;; Γ ⊢ₜ e1 : TArray τ → P ;; Γ ⊢ₜ e2 : TNat → P ;; Γ ⊢ₜ e3 : τ → P ;; Γ ⊢ₜ StoreN e1 e2 e3 : TUnit
  | TExtern s el tl tr :
      P !! s = Some (FunType tl tr) →
      Forall2 (typed P Γ) el tl →
      P ;; Γ ⊢ₜ (Extern s el) : tr
where "P ;; Γ ⊢ₜ e : τ" := (typed P Γ e τ).

(* Forall2 (typed Γ) requires special care *)
Lemma typed_ind (P : program_env → gmap string type → expr → type → Prop) :
    (∀ (P0 : program_env) (Γ : gmap string type) (x : string) (τ : type), Γ !! x = Some τ → P P0 Γ x τ)
  → (∀ (P0 : program_env) (Γ : gmap string type), P P0 Γ #() TUnit)
  → (∀ (P0 : program_env) (Γ : gmap string type) (n : Z), P P0 Γ #n TNat)
  → (∀ (P0 : program_env) (Γ : gmap string type) (b : bool), P P0 Γ #b TBool)
  → (∀ (P0 : program_env) (Γ : gmap string type) (op : bin_op) (e1 e2 : expr), binop_arithmetic op = true → P0;; Γ ⊢ₜ e1 : TNat → P P0 Γ e1 TNat → P0;; Γ ⊢ₜ e2 : TNat → P P0 Γ e2 TNat → P P0 Γ (BinOp op e1 e2) TNat)
  → (∀ (P0 : program_env) (Γ : gmap string type) (op : bin_op) (e1 e2 : expr), binop_arithmetic_to_bool op = true → P0;; Γ ⊢ₜ e1 : TNat → P P0 Γ e1 TNat → P0;; Γ ⊢ₜ e2 : TNat → P P0 Γ e2 TNat → P P0 Γ (BinOp op e1 e2) TBool)
  → (∀ (P0 : program_env) (Γ : gmap string type) (op : bin_op) (e1 e2 : expr), binop_boolish op = true → P0;; Γ ⊢ₜ e1 : TBool → P P0 Γ e1 TBool → P0;; Γ ⊢ₜ e2 : TBool → P P0 Γ e2 TBool → P P0 Γ (BinOp op e1 e2) TBool)
  → (∀ (P0 : program_env) (Γ : gmap string type) (T : type) (e1 e2 : expr), EqType T → P0;; Γ ⊢ₜ e1 : T → P P0 Γ e1 T → P0;; Γ ⊢ₜ e2 : T → P P0 Γ e2 T → P P0 Γ (BinOp EqOp e1 e2) TBool)
  → (∀ (P0 : program_env) (Γ : gmap string type) (e1 e2 : expr) (τ1 τ2 : type), P0;; Γ ⊢ₜ e1 : τ1 → P P0 Γ e1 τ1 → P0;; Γ ⊢ₜ e2 : τ2 → P P0 Γ e2 τ2 → P P0 Γ (e1, e2)%MLE (TProd τ1 τ2))
  → (∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (τ1 τ2 : type), P0;; Γ ⊢ₜ e : TProd τ1 τ2 → P P0 Γ e (TProd τ1 τ2) → P P0 Γ (Fst e) τ1)
  → (∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (τ1 τ2 : type), P0;; Γ ⊢ₜ e : TProd τ1 τ2 → P P0 Γ e (TProd τ1 τ2) → P P0 Γ (Snd e) τ2)
  → (∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (τ1 τ2 : type), P0;; Γ ⊢ₜ e : τ1 → P P0 Γ e τ1 → P P0 Γ (InjL e) (TSum τ1 τ2))
  → (∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (τ1 τ2 : type), P0;; Γ ⊢ₜ e : τ2 → P P0 Γ e τ2 → P P0 Γ (InjR e) (TSum τ1 τ2))
  → (∀ (P0 : program_env) (Γ : gmap string type) (e0 e1 e2 : expr) (τ1 τ2 τ3 : type), P0;; Γ ⊢ₜ e0 : TSum τ1 τ2 → P P0 Γ e0 (TSum τ1 τ2) → P0;; Γ ⊢ₜ e1 : TArrow τ1 τ3 → P P0 Γ e1 (TArrow τ1 τ3) → P0;; Γ ⊢ₜ e2 : TArrow τ2 τ3 → P P0 Γ e2 (TArrow τ2 τ3) → P P0 Γ (Case e0 e1 e2) τ3)
  → (∀ (P0 : program_env) (Γ : gmap string type) (e0 e1 e2 : expr) (τ : type), P0;; Γ ⊢ₜ e0 : TBool → P P0 Γ e0 TBool → P0;; Γ ⊢ₜ e1 : τ → P P0 Γ e1 τ → P0;; Γ ⊢ₜ e2 : τ → P P0 Γ e2 τ → P P0 Γ (if: e0 then e1 else e2)%MLE τ)
  → (∀ (P0 : program_env) (Γ : gmap string type) (f14 x : binder) (e : expr) (τ1 τ2 : type), P0;; binder_insert f14 (TArrow τ1 τ2) (binder_insert x τ1 Γ) ⊢ₜ e : τ2 → P P0 (binder_insert f14 (TArrow τ1 τ2) (binder_insert x τ1 Γ)) e τ2 → P P0 Γ (rec: f14 x := e)%MLE (TArrow τ1 τ2))
  → (∀ (P0 : program_env) (Γ : gmap string type) (e1 e2 : expr) (τ1 τ2 : type), P0;; Γ ⊢ₜ e1 : TArrow τ1 τ2 → P P0 Γ e1 (TArrow τ1 τ2) → P0;; Γ ⊢ₜ e2 : τ1 → P P0 Γ e2 τ1 → P P0 Γ (e1 e2) τ2)
  → (∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (τ : type), subst_prog_env (ren (+1)) P0;; subst (ren (+1)) <$> Γ ⊢ₜ e : τ → P (subst_prog_env (ren (+1)) P0) (subst (ren (+1)) <$> Γ) e τ → P P0 Γ (Λ: <>, e)%MLE (TForall τ))
  → (∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (τ τ' : {bind type}), P0;; Γ ⊢ₜ e : TForall τ → P P0 Γ e (TForall τ) → P P0 Γ (TApp e) τ.[τ'/])
  → (∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (τ τ' : type), P0;; Γ ⊢ₜ e : τ.[τ'/] → P P0 Γ e τ.[τ'/] → P P0 Γ (pack:e)%MLE (TExist τ))
  → (∀ (P0 : program_env) (Γ : gmap string type) (x : binder) (e1 e2 : expr) (τ : {bind type}) (τ' : type), P0;; Γ ⊢ₜ e1 : TExist τ → P P0 Γ e1 (TExist τ) → subst_prog_env (ren (+1)) P0;; binder_insert x τ (subst (ren (+1)) <$> Γ) ⊢ₜ e2 : τ'.[ren (+1)] → P (subst_prog_env (ren (+1)) P0) (binder_insert x τ (subst (ren (+1)) <$> Γ)) e2 τ'.[ren (+1)] → P P0 Γ (unpack: x := e2 in e1)%MLE τ')
  → (∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (τ : {bind type}), P0;; Γ ⊢ₜ e : τ.[TRec τ/] → P P0 Γ e τ.[TRec τ/] → P P0 Γ (roll:e)%MLE (TRec τ))
  → (∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (τ : {bind type}), P0;; Γ ⊢ₜ e : TRec τ → P P0 Γ e (TRec τ) → P P0 Γ (unroll:e)%MLE τ.[TRec τ/])
  → (∀ (P0 : program_env) (Γ : gmap string type) (e1 e2 : expr) (τ : type), P0;; Γ ⊢ₜ e1 : TNat → P P0 Γ e1 TNat → P0;; Γ ⊢ₜ e2 : τ → P P0 Γ e2 τ → P P0 Γ (AllocN e1 e2) (TArray τ))
  → (∀ (P0 : program_env) (Γ : gmap string type) (e1 e2 : expr) (τ : type), P0;; Γ ⊢ₜ e1 : TArray τ → P P0 Γ e1 (TArray τ) → P0;; Γ ⊢ₜ e2 : TNat → P P0 Γ e2 TNat → P P0 Γ (LoadN e1 e2) τ)
  → (∀ (P0 : program_env) (Γ : gmap string type) (e1 e2 e3 : expr) (τ : type), P0;; Γ ⊢ₜ e1 : TArray τ → P P0 Γ e1 (TArray τ) → P0;; Γ ⊢ₜ e2 : TNat → P P0 Γ e2 TNat → P0;; Γ ⊢ₜ e3 : τ → P P0 Γ e3 τ → P P0 Γ (StoreN e1 e2 e3) TUnit)
  → (∀ (P0 : program_env) (Γ : gmap string type) (s : string) (el : list expr) (tl : list type) (tr : type), P0 !! s = Some (FunType tl tr) → Forall2 (typed P0 Γ) el tl → Forall2 (P P0 Γ) el tl → P P0 Γ (Extern s el) tr)
  →  ∀ (P0 : program_env) (Γ : gmap string type) (e : expr) (t : type), P0;; Γ ⊢ₜ e : t → P P0 Γ e t.
Proof.
  do 27 intros ?.
  fix IH 5. intros ????; destruct 1; eauto 5.
  enough (Forall2 (P P0 Γ) el tl) by (eapply H25; clear IH; done).
  clear H26.
  revert el tl H27. fix IHf 3.
  intros el tl; destruct 1; econstructor.
  1: by eapply IH.
  by eapply IHf.
Qed.

Definition env_subst := subst_all.

Lemma env_subst_lookup vs x v :
  vs !! x = Some v → env_subst vs (Var x) = of_val v.
Proof.
  intros H. cbn. rewrite H. done.
Qed.

Lemma typed_closed P Γ τ e : P ;; Γ ⊢ₜ e : τ → is_closed_expr (dom Γ) e.
Proof.
  intros H; induction H using typed_ind; cbn; eauto.
  - by eapply bool_decide_pack, elem_of_dom_2.
  - rewrite !dom_binder_insert in IHtyped.
    destruct x, f14; cbn in *; try apply IHtyped.
  - by erewrite dom_fmap_L in IHtyped.
  - rewrite !dom_binder_insert !dom_fmap_L in IHtyped2. eauto.
  - eapply forallb_True, Forall2_Forall_l. 1:done.
    eapply Forall_true. done.
Qed.
Set Elimination Schemes.
End IndDef.

Notation "P ;; Γ ⊢ₜ e : τ" := (typed P Γ e τ) (at level 74, e, τ at next level).


(* Acc is a prop *)

Parameter dfunext : forall A B (f g:forall x:A,B x),
  (forall x, f x = g x) -> f = g.

Lemma Acc_prop A (R:A->A->Prop) x (h h':Acc R x) : h=h'.
revert x h h'.
fix 2.
intros.
destruct h.
destruct h'.
f_equal.
apply dfunext; intros y.
apply dfunext; intros r.
apply Acc_prop.
Defined.

Require Import Lambda.

Parameter neutral : term->Prop.
Parameter neutral_red : forall m m',
  neutral m -> red m m' -> neutral m'.
Parameter neutral_not_abs : forall m,
  ~ neutral (Abs m).
Parameter neutral_var : forall n, neutral (Ref n).
Parameter neutral_app : forall m n,
  neutral m -> sn n -> neutral (App m n).
Parameter neutral_sn : forall m, neutral m -> sn m.

Inductive max_dup : term -> nat -> Prop :=
| max_dup_var m : max_dup (Ref m) 1
| max_dup_app m n k1 k2 :
    neutral m ->
    max_dup m k1 ->
    max_dup n k2 ->
    max_dup (App m n) (k1+k2)
| max_dup_abs m k :
    max_dup m k ->
    max_dup (Abs m) k
| max_dup_step m n k1 k2 k3 :
    max_dup (subst n m) k1 ->
    max_dup m k2 ->
    max_dup n k3 ->
    max_dup (App (Abs m) n) (k1+k2+k3).

Lemma redp_dup_decr m n k :
  max_dup m k ->
  redpar m n ->
  exists2 k', k' <= k & max_dup n k'.
intro.
revert n; induction H; intros.
 inversion_clear H.
 exists 1; auto with *.
 constructor.

 inversion H2.
  subst m; apply neutral_not_abs in H; contradiction.

  destruct IHmax_dup1 with (1:=H5).
  destruct IHmax_dup2 with (1:=H7).
  exists (x+x0).
   omega.
  constructor; trivial.
  apply neutral_red with m; auto with *.
  apply rp2.
  apply t_step; trivial.

 inversion_clear H0.
 destruct IHmax_dup with (1:=H1).
 exists x; trivial.
 constructor; trivial.

 inversion H2.
  destruct IHmax_dup1 with (subst n' m').
   apply rp_subst; trivial.
  exists x; trivial.
  omega.

  inversion_clear H5.
  destruct IHmax_dup1 with (subst n' m'0).
   apply rp_subst; trivial.
  destruct IHmax_dup2 with (1:=H8).
  destruct IHmax_dup3 with (1:=H7).
  exists (x+x0+x1).
   omega.
  apply max_dup_step; trivial.
Qed.

Lemma sn_subterm_ind (P:term->Prop) :
  (forall n, P (Ref n)) ->
  (forall m n, sn m -> P m -> sn n -> P n -> P (App m n)) ->
  (forall m, sn m -> P m -> P (Abs m)) ->
  (forall m m', sn m -> red1 m m' -> P m' -> P m) ->
  forall t, sn t -> P t.
Admitted.

Lemma sn_neutral_dec m :
  sn m -> neutral m \/ exists m', red m (Abs m').
Admitted.
(*induction 1; intros.
revert H0.
assert (sn x).
 constructor; trivial.
clear H; revert H0.
induction x; intros.
 left; apply neutral_var.

 right; exists x; auto with *.

 destruct x1.
  left; apply neutral_app.
   apply neutral_var.
   apply subterm_sn with (App (Ref n) x2); trivial.

  destruct H1 with (subst x2 x1).
   constructor.

   left; admit.

   destruct H.
   right; exists x.
   admit.

  destruct IHx1.
   apply subterm_sn with (1:=H0).
   constructor.

   intros.

   trivial.

*)

Lemma sn_ex_dup m :
  sn m -> exists k, max_dup m k.
induction 1 using sn_subterm_ind.
 exists 1; constructor.

 destruct sn_neutral_dec with (1:=H).
  destruct IHsn1.
  destruct IHsn2.
  exists (x+x0); constructor; trivial.

  destruct H1.
  destruct IHsn1.
  destruct IHsn2.
  assert (exists k, max_dup (Abs x) k).
   revert x0 H2; elim H1; intros; auto.
    exists x0; trivial.

    destruct H4 with (1:=H6).
    destruct redp_dup_decr with (1:=H7) (n:=N).
     admit.
    exists x3; trivial.
  destruct H4.
  inversion_clear H4.
  exists (

induction 1.
assert (forall m' k, clos_refl_trans _ subterm m' x -> exists k, max_dup m' k).
intros.
revert H0.
induction H1; intros.
 inversion H0.

Require Import List.

Inductive repl : term -> list term -> term -> Prop :=
| repl_app m m' n n' l1 l2 :
    repl m l1 m' ->
    repl n l2 n' ->
    repl (App m n) (l1++l2) (App m' n')
| repl_abs m l m' :
    repl m l m' ->
    repl (Abs m) l (Abs m')
| repl_var n m :
    repl (Ref n) (m::nil) m.

Lemma sn_subst_neu : forall m n,
  sn m -> neutral n -> sn (subst n m).
Admitted.

Lemma sn_app_neu : forall m n,
  sn m -> neutral n -> sn (App m n).
intros.
revert n H0.
induction H; intros.
unfold transp in H0.
assert (snn := neutral_sn _ H1).
revert H1; elim snn; intros.
constructor; intros.
red in H4.
inversion H4.
 apply sn_subst_neu; trivial.
 apply sn_abs_inv with x; auto.
 constructor; trivial.

 apply H0; auto.

 apply H2; trivial.
 apply neutral_red with x0; auto with *.
Qed.


Require Import ConstructiveEpsilon.
Definition WO_nat := constructive_indefinite_ground_description_nat.

Notation "'Sigma' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'Sigma'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.
Definition iffT (X Y: Type) : Type := (X -> Y) * (Y -> X).
Notation "X <=> Y" := (iffT X Y) (at level 95, no associativity).
Notation p1 := projT1.
Notation p2 := projT2.

Definition stable P := ((P -> False) -> False) -> P.

Definition dec (P : Prop) := {P} + {~P}.
Definition Dec {X} p := forall x : X, dec (p x).

Definition sdec (P : Prop) := exists (f : nat -> bool), P <-> exists n, f n = true.
Definition Sdec {X} p := exists (f : nat -> X -> bool), forall x, p x <-> exists n, f n x = true.
Definition enum {X} p := exists f, forall x : X, p x <-> exists n : nat, f n = Some x.

Definition LEM := forall X, X \/ ~X.
Definition wLEM := forall X, ~~X \/ ~X.
Definition MP := forall P, sdec P -> stable P.

Definition Enum X := Sigma f, forall x : X, exists n : nat, f n = Some x.
Definition EQ X := forall x y : X, dec (x = y).
Definition AP X := forall x y : X, dec (~ x = y).

Definition surj {X Y} (f : X -> Y) := forall y, exists x, f x = y.
Definition inj {X Y} (f : X -> Y) := forall x x', f x = f x' -> x = x'.
Definition inv {X Y} (g: Y -> X) (f: X -> Y) := forall x, g (f x) = x.

Inductive Bij (X Y : Type) : Type :=
| Bijection: forall (f: X -> Y) (g: Y -> X), inv f g -> inv g f -> Bij X Y.
Arguments Bijection {X Y}.

Lemma Skolem {X Y} (R : X -> Y -> Prop) :
  (forall x, Sigma y, R x y) -> Sigma f, forall x, R x (f x).
Proof.
  intros H. unshelve eexists; intros x; cbn; now destruct (H x) as [y ].
Defined.

Module DN.
Definition ret_ {A : Prop} : A -> ~~A.                     tauto. Defined.
Definition bind_ {A B : Prop} : ~~A -> (A -> ~~B) -> ~~B.  tauto. Defined.
Definition remove_ {A B} : ~~A -> (A -> ~B) -> ~B.         tauto. Defined.
Definition lem_ X : ~~(X \/ ~X).                           tauto. Defined.
Definition dne_ X : ~~(~~X -> X).                          tauto. Defined.

Ltac ret := apply ret_.
Ltac bind H := apply (bind_ H); clear H; intros H; try tauto.
Ltac lem P := apply (bind_ (lem_ P)); try tauto.
Ltac dne P := apply (bind_ (dne_ P)); try tauto.
Ltac remove_dn :=
  repeat match goal with
  | H : ~ ~ _ |- False
    => apply H; clear H; intros H
  | H : ~ ~ _ |- _ -> False
    => intros G; apply H; clear H; intros H; revert G
  end.
End DN.


Require Import VST.floyd.proofauto.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.MathUAdjMatGraph.
Require Export CertiGraph.graph.SpaceAdjMatGraph2.
Require Import CertiGraph.lib.List_ext.

Local Open Scope logic.

Section Spatial_UAdjMat_Model_2.
  (* Model 2 is for a stack-allocated graph,
     where the graph is declared on the stack
     as a single-dimension array of size "size^2".
     Access to graph[u][v] is via graph[size*u + v].
   *)

Context {size : Z}.
Context {inf : Z}.

Definition graph_to_symm_mat g :=
  @graph_to_mat size g eformat.

Lemma graph_to_mat_eq:
  forall (g: AdjMatLG) i j, 0 <= i < size -> 0 <= j < size ->
    (Znth i (Znth j (graph_to_symm_mat g))) = elabel g (eformat (i,j)).
Proof.
  intros.
  symmetry. rewrite eformat_symm.
  apply elabel_Znth_graph_to_mat; lia.
Qed.

Lemma graph_to_mat_symmetric:
  forall (g: AdjMatLG) i j,
    0 <= i < size -> 0 <= j < size ->
    (Znth i (Znth j (graph_to_symm_mat g))) =
    (Znth j (Znth i (graph_to_symm_mat g))).
Proof.
  intros. repeat rewrite graph_to_mat_eq; trivial.
  f_equal. apply eformat_symm.
Qed.

Lemma graph_to_mat_inf:
  forall (g: @AdjMatGG size inf) u v,
    0 <= u < v ->
    v < size ->
    ~ evalid g (u,v) ->
    Znth v (Znth u (graph_to_symm_mat g)) =
    inf.
Proof.
  intros. unfold graph_to_symm_mat.
  rewrite <- elabel_Znth_graph_to_mat; try lia.
  rewrite eformat1.
  apply (MathAdjMatGraph.invalid_edge_weight); auto.
  simpl; lia.
Qed.

Context {size_rep': 0 < size <= Int.max_signed}.
Context {inf_rep: 0 < inf < Int.max_signed}.

Definition edgeless_graph' := @edgeless_graph size inf inf_rep size_rep'.
Definition adde := @UAdjMatGG_adde size inf.
Definition eremove := @UAdjMatGG_eremove size inf.

Lemma edgeless_vert_rep:
  forall v,
    0 <= v < size ->
    (@vert_to_list size edgeless_graph' eformat v) =
    list_repeat (Z.to_nat size) inf.
Proof.
  unfold vert_to_list; intros. rewrite map_map. apply list_eq_Znth.
+rewrite Zlength_map, nat_inc_list_Zlength, Zlength_list_repeat'; auto.
+intros. rewrite Zlength_map, nat_inc_list_Zlength, Z2Nat.id in H0. 2: lia.
rewrite Znth_list_repeat_inrange by auto.
rewrite Znth_map, nat_inc_list_i. simpl; auto.
rewrite Z2Nat.id; lia.
rewrite nat_inc_list_Zlength.
rewrite Z2Nat.id; lia.
Qed.

Lemma edgeless_to_symm_mat:
  graph_to_symm_mat edgeless_graph' =
  list_repeat (Z.to_nat size) (list_repeat (Z.to_nat size) inf).
Proof.
  unfold graph_to_symm_mat, graph_to_mat. apply list_eq_Znth.
+rewrite Zlength_map, nat_inc_list_Zlength, Zlength_list_repeat'; auto.
+intros. rewrite Zlength_map, nat_inc_list_Zlength, Z2Nat.id in H by lia.
rewrite Znth_list_repeat_inrange by lia.
rewrite Znth_map. rewrite nat_inc_list_i. apply edgeless_vert_rep; lia.
rewrite Z2Nat.id by lia; lia.
rewrite nat_inc_list_Zlength, Z2Nat.id; lia.
Qed.

End Spatial_UAdjMat_Model_2.


(** * Adjunctions as universal morphisms *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Identity Functor.Composition.Core.
Require Import Functor.Dual Category.Dual.
Require Import Adjoint.Core Adjoint.UnitCounit Adjoint.UnitCounitCoercions Adjoint.Dual.
Require Comma.Core.
Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *)
Import Comma.Core.
Local Set Warnings Append "notation-overridden".
Require Import UniversalProperties Comma.Dual InitialTerminalCategory.Core InitialTerminalCategory.Functors.

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

Local Open Scope morphism_scope.

Section adjunction_universal.
  (** ** [F ⊣ G] gives an initial object of [(Y / G)] for all [Y : C] *)
  Section initial.
    Variables C D : PreCategory.
    Variable F : Functor C D.
    Variable G : Functor D C.
    Variable A : F -| G.
    Variable Y : C.

    Definition initial_morphism__of__adjunction
    : object (Y / G)
      := @CommaCategory.Build_object
           _ D C
           (! Y) G
           (center _)
           (F Y)
           ((unit A) Y).

    Definition is_initial_morphism__of__adjunction
    : IsInitialMorphism initial_morphism__of__adjunction
      := Build_IsInitialMorphism
           _
           _
           _
           _
           ((A : AdjunctionUnit _ _).2 _).
  End initial.

  Global Arguments initial_morphism__of__adjunction [C D F G] A Y.
  Global Arguments is_initial_morphism__of__adjunction [C D F G] A Y _.

  (** ** [F ⊣ G] gives a terminal object of [(F / X)] for all [X : D] *)
  Section terminal.
    Variables C D : PreCategory.
    Variable F : Functor C D.
    Variable G : Functor D C.
    Variable A : F -| G.
    Variable X : D.

    Definition terminal_morphism__of__adjunction
    : object (F / X)
      := Eval simpl in
          dual_functor
            (! X)^op F^op
            (initial_morphism__of__adjunction A^op X).

    Definition is_terminal_morphism__of__adjunction
    : IsTerminalMorphism terminal_morphism__of__adjunction
      := is_initial_morphism__of__adjunction A^op X.
  End terminal.

  Global Arguments terminal_morphism__of__adjunction [C D F G] A X.
  Global Arguments is_terminal_morphism__of__adjunction [C D F G] A X _.
End adjunction_universal.

Section adjunction_from_universal.
  (** ** an initial object of [(Y / G)] for all [Y : C] gives a left adjoint to [G] *)
  Section initial.
    Variables C D : PreCategory.

    Variable G : Functor D C.
    Context `(HM : forall Y, @IsInitialMorphism _ _ Y G (M Y)).

    Local Notation obj_of Y :=
      (IsInitialMorphism_object (@HM Y))
        (only parsing).

    Local Notation mor_of Y0 Y1 f :=
      (let etaY1 := IsInitialMorphism_morphism (@HM Y1) in
       IsInitialMorphism_property_morphism (@HM Y0) _ (etaY1 o f))
        (only parsing).

    Lemma identity_of Y : mor_of Y Y 1 = 1.
    Proof.
      simpl.
      erewrite IsInitialMorphism_property_morphism_unique; [ reflexivity | ].
      rewrite ?identity_of, ?left_identity, ?right_identity.
      reflexivity.
    Qed.

    Lemma composition_of x y z g f
    : mor_of _ _ (f o g) = mor_of y z f o mor_of x y g.
    Proof.
      simpl.
      erewrite IsInitialMorphism_property_morphism_unique; [ reflexivity | ].
      rewrite ?composition_of.
      repeat
        try_associativity_quick
        rewrite IsInitialMorphism_property_morphism_property.
      reflexivity.
    Qed.

    Definition functor__of__initial_morphism : Functor C D
      := Build_Functor
           C D
           (fun x => obj_of x)
           (fun s d m => mor_of s d m)
           composition_of
           identity_of.

    Definition adjunction__of__initial_morphism
    : functor__of__initial_morphism -| G.
    Proof.
      refine (adjunction_unit_counit__of__adjunction_unit _).
      eexists (Build_NaturalTransformation
                1
                (G o functor__of__initial_morphism)
                (fun x => IsInitialMorphism_morphism (@HM x))
                (fun s d m =>
                   symmetry
                     _ _
                     (IsInitialMorphism_property_morphism_property (@HM s) _ _))).
      simpl.
      exact (fun c => @IsInitialMorphism_property _ _ c G (M c) (@HM c)).
    Defined.
  End initial.

  (** ** a terminal object of [(F / X)] for all [X : D] gives a right adjoint to [F] *)
  Section terminal.
    Variables C D : PreCategory.

    Variable F : Functor C D.
    Context `(HM : forall X, @IsTerminalMorphism _ _ F X (M X)).

    Definition functor__of__terminal_morphism : Functor D C
      := (@functor__of__initial_morphism
            (D^op) (C^op)
            (F^op)
            (fun x : D => dual_functor F !x (M x)) HM)^op.

    Definition adjunction__of__terminal_morphism
    : F -| functor__of__terminal_morphism
      := ((@adjunction__of__initial_morphism
             (D^op) (C^op)
             (F^op)
             (fun x : D => dual_functor F !x (M x)) HM)^op)%adjunction.
  End terminal.
End adjunction_from_universal.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require Import ZOdiv.
Require int.Int.
Require int.Abs.
Require int.ComputerDivision.

Parameter sum_multiple_3_5_lt: Z -> Z.

Axiom SumEmpty : ((sum_multiple_3_5_lt 0%Z) = 0%Z).

Axiom SumNo : forall (n:Z), (0%Z <= n)%Z -> (((~ ((ZOmod n 3%Z) = 0%Z)) /\
  ~ ((ZOmod n 5%Z) = 0%Z)) ->
  ((sum_multiple_3_5_lt (n + 1%Z)%Z) = (sum_multiple_3_5_lt n))).

Axiom SumYes : forall (n:Z), (0%Z <= n)%Z -> ((((ZOmod n 3%Z) = 0%Z) \/
  ((ZOmod n 5%Z) = 0%Z)) ->
  ((sum_multiple_3_5_lt (n + 1%Z)%Z) = ((sum_multiple_3_5_lt n) + n)%Z)).

Axiom div2 : forall (x:Z), exists y:Z, (x = (2%Z * y)%Z) \/
  (x = ((2%Z * y)%Z + 1%Z)%Z).

Axiom mod_div_unique : forall (x:Z) (y:Z) (q:Z) (r:Z), ((0%Z <= x)%Z /\
  ((0%Z < y)%Z /\ ((x = ((q * y)%Z + r)%Z) /\ ((0%Z <= r)%Z /\
  (r < y)%Z)))) -> ((q = (ZOdiv x y)) /\ (r = (ZOmod x y))).

Axiom mod_succ_1 : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
  ((~ ((ZOmod (x + 1%Z)%Z y) = 0%Z)) ->
  ((ZOmod (x + 1%Z)%Z y) = ((ZOmod x y) + 1%Z)%Z)).

Axiom mod_succ_2 : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
  (((ZOmod (x + 1%Z)%Z y) = 0%Z) -> ((ZOmod x y) = (y - 1%Z)%Z)).

Axiom div_succ_1 : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
  (((ZOmod (x + 1%Z)%Z y) = 0%Z) ->
  ((ZOdiv (x + 1%Z)%Z y) = ((ZOdiv x y) + 1%Z)%Z)).

Axiom div_succ_2 : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
  ((~ ((ZOmod (x + 1%Z)%Z y) = 0%Z)) ->
  ((ZOdiv (x + 1%Z)%Z y) = (ZOdiv x y))).

Axiom mod2_mul2 : forall (x:Z), ((ZOmod (2%Z * x)%Z 2%Z) = 0%Z).

Axiom mod2_mul2_aux : forall (x:Z) (y:Z),
  ((ZOmod (y * (2%Z * x)%Z)%Z 2%Z) = 0%Z).

Axiom mod2_mul2_aux2 : forall (x:Z) (y:Z) (z:Z) (t:Z),
  ((ZOmod ((y * (2%Z * x)%Z)%Z + (z * (2%Z * t)%Z)%Z)%Z 2%Z) = 0%Z).

Axiom div2_mul2 : forall (x:Z), ((ZOdiv (2%Z * x)%Z 2%Z) = x).

Axiom div2_mul2_aux : forall (x:Z) (y:Z),
  ((ZOdiv (y * (2%Z * x)%Z)%Z 2%Z) = (y * x)%Z).

Axiom div2_add : forall (x:Z) (y:Z), (((ZOmod x 2%Z) = 0%Z) /\
  ((ZOmod y 2%Z) = 0%Z)) ->
  ((ZOdiv (x + y)%Z 2%Z) = ((ZOdiv x 2%Z) + (ZOdiv y 2%Z))%Z).

Axiom div2_sub : forall (x:Z) (y:Z), (((ZOmod x 2%Z) = 0%Z) /\
  ((ZOmod y 2%Z) = 0%Z)) ->
  ((ZOdiv (x - y)%Z 2%Z) = ((ZOdiv x 2%Z) - (ZOdiv y 2%Z))%Z).

Axiom tr_mod_2 : forall (n:Z), (0%Z <= n)%Z ->
  ((ZOmod (n * (n + 1%Z)%Z)%Z 2%Z) = 0%Z).

(* Why3 assumption *)
Definition tr(n:Z): Z := (ZOdiv (n * (n + 1%Z)%Z)%Z 2%Z).

Axiom tr_repr : forall (n:Z), (0%Z <= n)%Z ->
  ((n * (n + 1%Z)%Z)%Z = (2%Z * (tr n))%Z).

Axiom tr_succ : forall (n:Z), (0%Z <= n)%Z ->
  ((tr (n + 1%Z)%Z) = (((tr n) + n)%Z + 1%Z)%Z).

(* Why3 assumption *)
Definition closed_formula_aux(n:Z): Z := let n3 := (ZOdiv n 3%Z) in let n5 :=
  (ZOdiv n 5%Z) in let n15 := (ZOdiv n 15%Z) in
  (((3%Z * (tr n3))%Z + (5%Z * (tr n5))%Z)%Z - (15%Z * (tr n15))%Z)%Z.

(* Why3 assumption *)
Definition p(n:Z): Prop :=
  ((sum_multiple_3_5_lt (n + 1%Z)%Z) = (closed_formula_aux n)).

Axiom mod_15 : forall (n:Z), ((ZOmod n 15%Z) = 0%Z) <->
  (((ZOmod n 3%Z) = 0%Z) /\ ((ZOmod n 5%Z) = 0%Z)).

Axiom Closed_formula_0 : (p 0%Z).

Axiom Closed_formula_n : forall (n:Z), (0%Z < n)%Z -> ((p (n - 1%Z)%Z) ->
  (((~ ((ZOmod n 3%Z) = 0%Z)) /\ ~ ((ZOmod n 5%Z) = 0%Z)) -> (p n))).

Axiom Closed_formula_n_3 : forall (n:Z), (0%Z < n)%Z -> ((p (n - 1%Z)%Z) ->
  ((((ZOmod n 3%Z) = 0%Z) /\ ~ ((ZOmod n 5%Z) = 0%Z)) -> (p n))).

Axiom Closed_formula_n_5 : forall (n:Z), (0%Z < n)%Z -> ((p (n - 1%Z)%Z) ->
  (((~ ((ZOmod n 3%Z) = 0%Z)) /\ ((ZOmod n 5%Z) = 0%Z)) -> (p n))).

Axiom Closed_formula_n_15 : forall (n:Z), (0%Z < n)%Z -> ((p (n - 1%Z)%Z) ->
  ((((ZOmod n 3%Z) = 0%Z) /\ ((ZOmod n 5%Z) = 0%Z)) -> (p n))).

Axiom Induction : (forall (n:Z), (0%Z <= n)%Z -> ((forall (k:Z),
  ((0%Z <= k)%Z /\ (k < n)%Z) -> (p k)) -> (p n))) -> forall (n:Z),
  (0%Z <= n)%Z -> (p n).

Axiom Induction_bound : (forall (n:Z), (0%Z <= n)%Z -> ((forall (k:Z),
  ((0%Z <= k)%Z /\ (k < n)%Z) -> (p k)) -> (p n))) -> forall (n:Z),
  (0%Z <= n)%Z -> (p n).

Axiom Closed_formula_ind : forall (n:Z), (0%Z <= n)%Z -> (p n).

(* Why3 assumption *)
Definition closed_formula(n:Z): Z := let n3 := (ZOdiv n 3%Z) in let n5 :=
  (ZOdiv n 5%Z) in let n15 := (ZOdiv n 15%Z) in
  (ZOdiv (((3%Z * (n3 * (n3 + 1%Z)%Z)%Z)%Z + (5%Z * (n5 * (n5 + 1%Z)%Z)%Z)%Z)%Z - (15%Z * (n15 * (n15 + 1%Z)%Z)%Z)%Z)%Z 2%Z).

Axiom div_15 : forall (n:Z), (0%Z <= n)%Z -> (0%Z <= (ZOdiv n 15%Z))%Z.

Axiom div_5 : forall (n:Z), (0%Z <= n)%Z -> (0%Z <= (ZOdiv n 5%Z))%Z.

Axiom div_3 : forall (n:Z), (0%Z <= n)%Z -> (0%Z <= (ZOdiv n 3%Z))%Z.

(* Why3 goal *)
Theorem Closed_Formula : forall (n:Z), (0%Z <= n)%Z ->
  ((sum_multiple_3_5_lt (n + 1%Z)%Z) = (closed_formula n)).
intros n Hn.
rewrite Closed_formula_ind; auto.
unfold closed_formula_aux, closed_formula.
repeat rewrite tr_repr.
rewrite div2_sub.
rewrite div2_mul2_aux.
rewrite div2_add.
do 2 rewrite div2_mul2_aux.
auto.
repeat rewrite mod2_mul2_aux; auto.
rewrite mod2_mul2_aux; auto.
rewrite mod2_mul2_aux2; auto.
apply div_15; auto.
apply div_5; auto.
apply div_3; auto.
Qed.


Require Import Braun.monad.monad Braun.common.log Braun.common.finite_sums.
Require Import Braun.common.util Braun.common.big_oh Braun.common.le_util.
Require Import Arith Arith.Even Arith.Div2.
Require Import Coq.Program.Wf Arith.Even Arith.Div2 Arith Init.Wf.
Require Import Braun.arith.sub1.

Include WfExtensionality.

Fixpoint sub1_linear_time n :=
  match n with
    | 0 => 3
    | S n' => sub1_time n + sub1_linear_time n' + 7
  end.

Definition sub1_linear_loop_result (n:nat) (res:nat) (c:nat) :=
  c = sub1_linear_time n.
Hint Unfold sub1_linear_loop_result.

Load "sub1_linear_loop_gen.v".

Next Obligation.
Proof.
  rename H into SUB1R.
  destruct SUB1R.
  omega.
Qed.

Next Obligation.
Proof.
  clear H2 am0 am H3 sub1_linear_loop.
  rename H1 into SUB1_RESULT.

  unfold sub1_linear_loop_result in *.
  destruct SUB1_RESULT.
  subst an an0 n'.
  unfold sub1_linear_time; fold sub1_linear_time.
  replace (S wildcard' - 1) with wildcard'; omega.
Qed.

Definition sub1_linear_time1 n := (sum 0 n (fun n => sub1_time n + 7)) - 7.

Lemma sub1_linear_time01 :
  forall n,
    sub1_linear_time n = sub1_linear_time1 n.
Proof.
  intros n.
  induction n.
  simpl.
  unfold sub1_linear_time1.
  simpl; auto.

  unfold sub1_linear_time.
  fold sub1_linear_time.
  rewrite IHn.
  unfold sub1_linear_time1.
  rewrite sum_S_j;[|omega].

  assert (sum 0 n (fun n0 : nat => sub1_time n0 + 7) >= 7); try omega.

  induction n.
  simpl; omega.
  rewrite sum_S_j; omega.
Qed.

Definition sub1_linear_time2 n := (sum 0 n (fun n => sub1_time n + 7)).

Lemma sub1_linear_time12 : big_oh sub1_linear_time1 sub1_linear_time2.
Proof.
  unfold sub1_linear_time2.
  unfold sub1_linear_time1.
  exists 0. exists 1.
  intros n _.
  omega.
Qed.

Definition sub1_linear_time3 n := (sum 0 n (fun n => sub1_time n)) + 7*(n+1).

Lemma sub1_linear_time23 : forall n, sub1_linear_time2 n = sub1_linear_time3 n.
Proof.
  intros n.
  unfold sub1_linear_time2; unfold sub1_linear_time3.
  replace (fun n0 : nat => sub1_time n0 + 7)
  with (fplus sub1_time (const 7)); [| unfold fplus; unfold const; reflexivity].
  rewrite <- sum_over_fns.
  unfold const.
  rewrite (sum_constant 0 n 7 n); [|omega].
  intuition.
Qed.

Definition sub1_linear_time4 n := sum 0 n (fun n => sub1_time n).

Lemma sub1_linear_time4_linear : big_oh sub1_linear_time4 (fun n => n).
Proof.
  exists 1.
  exists 32.
  intros n LT.
  destruct n;[intuition|clear LT].

  apply (well_founded_induction
           lt_wf
           (fun n => sub1_linear_time4 (S n) <= 32 * (S n))).
  clear n.
  intros n IND.
  destruct n.
  unfold sub1_linear_time4.
  rewrite sum_S_j; auto.
  rewrite sum_eq.
  compute.
  omega.

  unfold sub1_linear_time4.
  rewrite sum_div2.
  unfold shift_2x.
  unfold shift.

  replace (sum 0 (div2 (S n)) (fun n0 : nat => sub1_time (S (n0 + n0))))
  with (sum 0 (div2 (S n)) (fun n0 => 8));
    [|apply sum_extensionality; intros; rewrite sub1_time_double; auto].

  unfold sub1_linear_time4 in IND.

  apply (le_trans
           (sum 0 (div2 (S (S n))) (fun n0 : nat => sub1_time (n0 + n0)) +
            sum 0 (div2 (S n)) (fun _ : nat => 8))
           (sum 0 (div2 (S (S n))) (fun n0 : nat => sub1_time n0 + 12) +
            sum 0 (div2 (S n)) (fun _ : nat => 8))).
  apply plus_le_compat; auto.
  apply sum_preserves_order.
  intros n0 _.
  apply sub1_time_S_double.
  replace (fun n0 : nat => sub1_time n0 + 12)
  with (fplus (fun n0 : nat => sub1_time n0) (fun n0 => 12));
    [|unfold fplus; auto].

  rewrite <- sum_over_fns.

  replace (div2 (S (S n))) with (S (div2 n));[|auto].

  apply (le_trans
           (sum 0 (S (div2 n)) (fun n0 : nat => sub1_time n0) +
            sum 0 (S (div2 n)) (fun _ : nat => 12) +
            sum 0 (div2 (S n)) (fun _ : nat => 8))
           (32 * (S (div2 n)) +
            sum 0 (S (div2 n)) (fun _ : nat => 12) +
            sum 0 (div2 (S n)) (fun _ : nat => 8))).
  apply plus_le_compat;auto.
  apply plus_le_compat;auto.
  rewrite (sum_constant 0 (S (div2 n)) 12 (S (div2 n))); auto.
  rewrite (sum_constant 0 (div2 (S n)) 8 (div2 (S n))); auto.

  replace (32 * S (div2 n) + (S (div2 n) + 1) * 12 + (div2 (S n) + 1) * 8)
          with
          (44 * div2 n + 8 * (div2 (S n)) + 64);[|omega].
  replace (32 * (S (S n))) with (32 * n + 64);[|omega].
  apply plus_le_compat;auto.

  destruct (even_odd_dec n).

  (* even case *)
  rewrite <- even_div2; auto.
  rewrite (even_double n) at 3; auto.
  unfold double.
  omega.

  rewrite <- odd_div2; auto.
  rewrite (odd_double n) at 3; auto.
  unfold double.
  omega.
Qed.

Theorem sub1_linear_time_linear :
  big_oh sub1_linear_time (fun n => n).
Proof.
  apply (big_oh_trans sub1_linear_time sub1_linear_time1).
  apply big_oh_eq.
  apply sub1_linear_time01.

  apply (big_oh_trans sub1_linear_time1 sub1_linear_time2).
  apply sub1_linear_time12.

  apply (big_oh_trans sub1_linear_time2 sub1_linear_time3).
  apply big_oh_eq.
  apply sub1_linear_time23.

  unfold sub1_linear_time3.
  apply big_oh_plus.

  fold sub1_linear_time4.
  apply sub1_linear_time4_linear.

  exists 1.
  exists 14.
  intros n LT.
  destruct n.
  intuition.
  omega.
Qed.


(** Example of function: the identity *)
Require Import beta_reduction compiler compiler_correct closed_lterm krivine lterm.

Definition l_id: lterm := Lambda (Var O)
.

Definition krivine_id : krivine_code := Grab (Access 0 Nop)
.

(** Identity is closed *)
Theorem closed_id:
  closed l_id.
Proof.
  unfold closed.
  unfold l_id.
  simpl.
  auto with arith.
Save.

(** Compilation *)
Theorem compile_id:
  comp l_id = krivine_id.
Proof.
  unfold l_id.
  unfold krivine_id.
  trivial.
Save.

(** Reverse compilation *)
Theorem tau_id:
  tau_code krivine_id = Some l_id.
Proof.
  unfold l_id.
  unfold krivine_id.
  trivial.
Save.

(** Correct state *)
Definition kstate_id : krivine_env := krivine_state krivine_id KEnv_nil KEnv_nil
.

Theorem closed_code_id:
  closed_code O krivine_id.
Proof.
  unfold closed_code.
  exists l_id.
  elim tau_id.
  split; trivial.
  apply closed_id.
Save.

Theorem correct_id:
  correct_state kstate_id.
Proof.
  apply correct_env_is_state.
  apply Correct_env; simpl.
  apply closed_code_id.
  apply Correct_env_nil.
  apply Correct_env_nil.
Save.

(** Identity is a final state in krivine machine *)
Theorem final_step_id:
  krivine_step kstate_id = kstate_id.
Proof.
  trivial.
Save.

(** Second example, with apply *)
Definition l_id2 : lterm := Apply l_id l_id
.
Definition krivine_id2 : krivine_code := Push krivine_id krivine_id
.
Definition kstate_id2 : krivine_env := krivine_state krivine_id2 KEnv_nil KEnv_nil
.
Theorem closed_id2:
  closed l_id2.
Proof.
  unfold closed; unfold l_id2. simpl.
  auto with arith.
Save.
Theorem compile_id2:
  comp l_id2 = krivine_id2.
Proof.
  unfold l_id2. unfold krivine_id2. trivial.
Save.
Theorem tau_id2:
  tau_code krivine_id2 = Some l_id2.
Proof.
  unfold l_id2. unfold krivine_id2. trivial.
Save.
Theorem closed_code_id2:
  closed_code O krivine_id2.
Proof.
  unfold closed_code.
  exists l_id2.
  elim tau_id2.
  split; trivial.
  apply closed_id2.
Save.
Theorem correct_id2:
  correct_state kstate_id2.
Proof.
  apply correct_env_is_state.
  apply Correct_env; simpl.
    apply closed_code_id2.
    apply Correct_env_nil.
    apply Correct_env_nil.
Save.

(** Krivine steps on id2 *)
Theorem krivine_steps_id2:
  krivine_step kstate_id2 = krivine_state krivine_id KEnv_nil kstate_id /\
  krivine_step (krivine_step kstate_id2) =
    krivine_state (Access 0 Nop) kstate_id KEnv_nil /\
  krivine_step (krivine_step (krivine_step kstate_id2)) = kstate_id.
Proof.
  split; trivial; split; trivial.
Save.


(*
    NOTES:
    - ultimately we want to denote an Imp program from
    the RA. For select it seems like this will allow us
    to write proofs that the impExecute(impDenote ra) = raExecute ra. impDenote will be like the datalogcompiler code

    First we would like to skip the pseudo-denotation process
    and just write a single operator alone: that selectRA = selectImp. This means
    our select Imp will have an apply-pred operation. Then to
    support other query plans we will add denotation.
        *)

(*
    choices: untyped and write proofs as execute produces something
    vs if typed then proceeds*)

Load Relational.
(* If Relational.vo exists, then can Require Import Relational. *)

Module Imp.

(* Initial typed start

(* operators that go from type*type -> BExp *)
Inductive binop : Set :=
    | Eq.

Inductive IIBinop : Set :=
    | Plus.

Inductive IValue : Set :=
 | Int : nat -> IValue.   (* sticking to nats *)

Inductive IExp : Set :=
 | IExpValue : IValue -> IExp.

Inductive bbinop : Set :=
  | And
  | Or.

Inductive BValue : Set :=
 | Bool : bool -> Value.

Inductive BExp : Set :=
 | BExpValue : BValue -> BExp
 | BBinop : bbinop -> BExp -> BExp -> BExp
 | IBinop : ibinop -> IExp -> IExp -> BExp.

*)

Inductive Val : Set :=
    | Int : nat -> Val
    | Bool : bool -> Val.

Inductive Tuple : Set :=
    | Tnil : Tuple
    | Tcons : Val -> Tuple -> Tuple.

Inductive Relation : Set :=
    | Rnil : Relation
    | Rcons : Tuple -> Relation -> Relation.

Inductive Exp : Set :=
    | ValExp : Val -> Exp
    | TupleExp : Tuple -> Exp
    | Append : Exp -> Exp -> Exp  (* Exp are Tuple, Relation *)
    | Var : nat -> Exp
    | RelationExp : Relation -> Exp
    | ApplyPred : Pred -> Exp -> Exp.

Inductive VarName : Set :=
    | VarLHS : nat -> VarName.

Inductive Statement : Set :=
    | Seq : Statement -> Statement -> Statement
    | Forall : VarName -> Relation -> Statement -> Statement
    | If : Exp -> Statement -> Statement -> Statement
    | Assign : VarName -> Exp -> Statement
    | Skip : Statement.

(* Pred: t -> bool *)

(* Fill in exactly Relational.Pred.
It is not technically in the Imp language, but we will pretend
until we have denotation *)

(* t = var 1
   ans = var 0 *)
Definition ImpSelect (pred : Pred) (rel : Relation) : Statement :=
    Seq (Assign (VarLHS 0) (RelationExp Rnil)) (Forall (VarLHS 1) rel (If (ApplyPred pred (Var 1)) (Assign (VarLHS 0) (Append (Var 1) (Var 0))) Skip )).

Eval compute in ImpSelect (BConst true) (Rcons (Tcons (Int 1) Tnil) Rnil).

(* TODO: semantics for execute, then theorem *)

Inductive heap : Set :=
  | hnil : heap
  | hcons : nat (*key*) -> nat (*value*) -> heap -> heap.

Fixpoint impExecuteStep (h : heap) (s : Statement) : heap * Statement :=
  match s with
    | Seq s1 s2 => match s1 with
                     | Skip => (h, s2)
                     | _ => let (h', s1') := impExecuteStep h s1 in
                       (h', (Seq s1' s2))
                   end
    | If e s1 s2 => let c := impEvalExp h e in
                       if c then (h, s1) else (h, s2)
    | Assign vn e => let c := impEvalExp h e in
                       (insert h vn c, Skip)
    | Forall vn r s' => match r with
                            | Rnil => (h, Skip)
                            | Rcons t rem => let h' := (replaceH h vn t) in
                              (h', Seq s' (Forall vn rem s'))
                        end
    end.

(* steps

choose simplest query
define Query
define semantics separately

define IMP-
define semantics separately

prove equivalance of semantics(RA)=semantics(IMP query)

update compile

queries:
true
false
project
select(t.0) where tuple vals are boolean
...
*)


(***************************************************************************
* Safety for STLC with Datatypes - Infrastructure                          *
* Extented from "Type Safety for STLC" by                                  *
* Arthur Charguéraud, July 2007, Coq v8.1                                  *
***************************************************************************)

Set Implicit Arguments.
Require Import List Metatheory STLC_Data_Definitions.

(* ********************************************************************** *)
(** ** Additional Definitions used in the Proofs *)

(** Computing free variables of a term. *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i j  => {}
  | trm_fvar x    => {{x}}
  | trm_abs t1    => (fv t1)
  | trm_fix t1    => (fv t1)
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  | trm_match t1 p1 e t2 => (fv t1) \u (fv e) \u (fv t2)
  | trm_unit      => {}
  | trm_pair t1 t2 => (fv t1) \u (fv t2)
  | trm_inj1 t1   => (fv t1)
  | trm_inj2 t1   => (fv t1)
  end.

(** Computing free variables of a list of terms. *)

Definition fv_list :=
  List.fold_right (fun t acc => fv t \u acc) {}.

(** Free variables of the default term. *)

Lemma trm_def_fresh : fv trm_def = {}.
Proof.
  auto.
Qed.

(** Substitution for names *)

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i j  => trm_bvar i j
  | trm_fvar x    => if x == z then u else (trm_fvar x)
  | trm_abs t1    => trm_abs (subst z u t1)
  | trm_fix t1    => trm_fix (subst z u t1)
  | trm_match t1 p1 e t2 => trm_match (subst z u t1) p1
                               (subst z u e)
                               (subst z u t2)
  | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2)
  | trm_unit      => trm_unit
  | trm_pair t1 t2 => trm_pair (subst z u t1) (subst z u t2)
  | trm_inj1 t1  => trm_inj1 (subst z u t1)
  | trm_inj2 t1  => trm_inj2 (subst z u t1)
  end.

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

(** Iterated substitution *)

Fixpoint substs (zs : list var) (us : list trm) (t : trm)
   {struct zs} : trm :=
  match zs, us with
  | z::zs', u::us' => substs zs' us' ([z ~> u]t)
  | _, _ => t
  end.

(** Predicate caraterizing lists of a given number of terms *)

Definition terms := list_for_n term.

(** Iterated typing *)

Inductive typings (E : env) : list trm -> list typ -> Prop :=
  | typings_nil : typings E nil nil
  | typings_cons : forall ts Us t U,
      typings E ts Us ->
      typing E t U ->
      typings E (t::ts) (U::Us).

(* ********************************************************************** *)
(** ** Instanciation of Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => {{ x }}) in
  let C := gather_vars_with (fun x : env => dom x) in
  let D := gather_vars_with (fun x : trm => fv x) in
  let E := gather_vars_with (fun x : list trm => fv_list x) in
  constr:(A \u B \u C \u D \u E).

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

Ltac pick_freshes n Y :=
  let L := gather_vars in (pick_freshes_gen L n Y).

Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base_simple T gather_vars.

Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; auto*.

Hint Constructors term value red typing typings.

Hint Extern 1 (_ \notin fv trm_def) =>
  rewrite trm_def_fresh.

Hint Extern 1 (terms _ _) => split; auto.

Hint Extern 1 (fresh (dom (_ & _)) _ _) => simpl_env.

(* ********************************************************************** *)
(** ** Properties of iterated operators *)

Lemma fv_list_map : forall ts1 ts2,
  fv_list (ts1 ++ ts2) = fv_list ts1 \u fv_list ts2.
Proof.
  induction ts1; simpl; intros.
  rewrite* union_empty_l.
  rewrite IHts1. rewrite* union_assoc.
Qed.

Lemma typings_concat : forall E ts1 Us1 ts2 Us2,
  typings E ts1 Us1 ->
  typings E ts2 Us2 ->
  typings E (ts1++ts2) (Us1++Us2).
Proof.
  induction ts1; introv Typ1 Typ2; inversions Typ1; simpl*.
Qed.

(* ********************************************************************** *)
(** ** Properties of substitution *)

(* begin hide *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ;
  simpl in *; inversion* Equ; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; f_equal*.
  pick_fresh x. forward~ (H0 x) as K.
   apply* (@open_rec_term_core t1 0 (trm_fvars (x::nil))).
  pick_fresh x. pick_fresh f. forward~ (H0 x f) as K.
   apply* (@open_rec_term_core t1 0 (trm_fvars (x::f::nil))).
  pick_freshes (pat_arity p) xs. forward~ (H1 xs) as K.
   apply* (@open_rec_term_core e 0 (trm_fvars xs)).
Qed.

(* end hide *)

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin fv t ->
  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; f_equal*.
  case_var*. notin_contradiction.
Qed.

Lemma subst_fresh_list : forall z u ts,
  z \notin fv_list ts ->
  ts = List.map (subst z u) ts.
Proof.
  induction ts; simpl; intros Fr.
  auto. f_equal. rewrite~ subst_fresh. auto.
Qed.

Lemma subst_fresh_trm_fvars : forall z u xs,
  fresh ({{z}}) (length xs) xs ->
  trm_fvars xs = List.map (subst z u) (trm_fvars xs).
Proof.
  intros. apply subst_fresh_list.
  induction xs; simpls. auto.
    destruct H. notin_simpls; auto.
Qed.

Lemma substs_fresh : forall xs us t,
  fresh (fv t) (length xs) xs ->
  substs xs us t = t.
Proof.
  induction xs; simpl; intros us t Fr.
  auto. destruct us. auto.
  inversions Fr. rewrite* subst_fresh.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ (List.map (subst x u) t2).
Proof.
  intros. unfold open, opens. simpl. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. unfold trm_nth.
   apply list_map_nth. apply* subst_fresh.
  case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_vars : forall x ys u t,
  fresh {{x}} (length ys) ys ->
  term u ->
  ([x ~> u]t) ^ ys = [x ~> u] (t ^ ys).
Proof.
  introv Fr Tu. rewrite* subst_open.
  unfold trm_fvars. f_equal.
  induction ys; simpls. auto.
  destruct Fr. case_var.
    notin_contradiction. f_equal*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma substs_intro_ind : forall t xs us vs,
  fresh (fv t \u fv_list vs \u fv_list us) (length xs) xs ->
  terms (length xs) us ->
  terms (length vs) vs ->
  t ^^ (vs ++ us) = substs xs us (t ^^ (vs ++ (trm_fvars xs))).
Proof.
  induction xs; simpl; introv Fr Tu Tv;
   destruct Tu; destruct us; try solve [ contradictions ].
  auto.
  inversions H0. inversions Fr. clear H0 Fr. simpls.
  rewrite list_concat_right.
  forward (IHxs us (vs++t0::nil)) as K; clear IHxs.
    rewrite* fv_list_map.
    auto.
    split~. inversions Tv. apply* list_forall_concat.
  rewrite K. clear K.
  f_equal. rewrite~ subst_open. rewrite~ subst_fresh.
  f_equal. rewrite map_app.
  simpl. case_var; try solve [ contradictions* ].
  rewrite <- list_concat_right.
  f_equal. apply~ subst_fresh_list.
  f_equal. apply* subst_fresh_trm_fvars.
Qed.

Lemma substs_intro : forall xs t us,
  fresh (fv t \u fv_list us) (length xs) xs ->
  terms (length xs) us ->
  t ^^ us = substs xs us (t ^ xs).
Proof.
  intros. apply* (@substs_intro_ind t xs us nil).
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpl*.
  case_var*.
  apply_fresh term_abs. intros y Fr.
   rewrite* subst_open_vars.
  apply_fresh term_fix. intros y f Fr.
   rewrite* subst_open_vars.
  apply_fresh* term_match. intros ys Fr.
   rewrite* subst_open_vars.
Qed.

Hint Resolve subst_term.

(** Terms are stable by iterated substitution *)

Lemma substs_terms : forall xs us t,
  terms (length xs) us ->
  term t ->
  term (substs xs us t).
Proof.
  induction xs; destruct us; introv TU TT; simpl; auto.
  inversions TU. simpls. inversions H. inversions* H0.
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> bodys 1 t1.
Proof.
  intros. unfold bodys. inversions* H.
  exists L. intros.
  destruct xs; simpl in H0; destruct H0.
  destruct xs; simpl in H2; destruct H2. auto.
Qed.

Lemma body_to_term_abs : forall t1,
  bodys 1 t1 -> term (trm_abs t1).
Proof.
  destruct 1. apply_fresh* term_abs.
Qed.

Lemma term_fix_to_body : forall t1,
  term (trm_fix t1) -> bodys 2 t1.
Proof.
  intros. unfold bodys. inversions* H.
  exists L. intros.
  destruct xs; simpl in H0; destruct H0.
  destruct xs; simpl in H2; destruct H2.
  destruct xs; simpl in H3; destruct H3.
  auto.
Qed.

Lemma body_to_term_fix : forall t1,
  bodys 2 t1 -> term (trm_fix t1).
Proof.
   destruct 1. apply_fresh* term_fix.
Qed.

Lemma term_match_to_body : forall t1 t2 e p,
  term (trm_match t1 p e t2) -> bodys (pat_arity p) e.
Proof.
  intros. unfold bodys. inversions* H.
Qed.

Lemma body_to_term_match : forall t1 t2 e p,
  term t1 -> term t2 -> bodys (pat_arity p) e ->
  term (trm_match t1 p e t2).
Proof.
  destruct 3. apply_fresh* term_match.
Qed.

Hint Resolve body_to_term_abs term_abs_to_body
             body_to_term_fix term_fix_to_body
             body_to_term_match.

Hint Extern 1 (bodys (pat_arity ?p) ?e) =>
  match goal with H: context [trm_match ?t1 p e ?t2] |- _ =>
    apply (@term_match_to_body t1 t2) end.

(** ** Opening a body with a term gives a term *)

Lemma open_terms : forall t us,
  bodys (length us) t ->
  terms (length us) us ->
  term (t ^^ us).
Proof.
  introv [L K] WT. pick_freshes (length us) xs. poses Fr' Fr.
  rewrite (fresh_length _ _ _  Fr) in WT, Fr'.
  rewrite* (@substs_intro xs). apply* substs_terms.
Qed.

Hint Resolve open_terms.

(** The matching function returns a list of terms of the expected length. *)

Lemma pat_match_terms : forall p t ts,
  (pat_match p t) = Some ts -> term t ->
  terms (pat_arity p) ts.
Proof.
  induction p; simpl; introv EQ TT;
   try solve [ inversions EQ; auto ];
   destruct t; inversions EQ; inversions TT; auto*.
  remember (pat_match p1 t1) as K1. symmetry in HeqK1.
   remember (pat_match p2 t2) as K2. symmetry in HeqK2.
   destruct K1 as [ts1|]; destruct K2 as [ts2|]; try discriminate.
   inversions EQ. unfolds terms. apply* list_for_n_concat.
Qed.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** A typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

Lemma typing_regular : forall E e T,
  typing E e T -> ok E /\ term e.
Proof.
  split; induction* H.
  pick_fresh x. forward~ (H0 x) as K. inversions* K.
  pick_fresh x. pick_fresh f. forward~ (H0 x f) as K.
   inversions K. inversions* H3.
Qed.

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall e,
  value e -> term e.
Proof.
  induction 1; auto*.
Qed.

(** A reduction relation only holds on pairs of locally-closed terms. *)

Lemma red_regular : forall e e',
  red e e' -> term e /\ term e'.
Proof.
  induction 1; use value_regular.
  splits*. forward~ (@pat_match_terms p t1 ts) as K.
  rewrite (proj1 K) in H0, K. auto*.
Qed.

(** Automation for reasoning on well-formedness. *)

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: typing E _ _ |- _ => apply (proj1 (typing_regular H))
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ t _ |- _ => apply (proj2 (typing_regular H))
  | H: red t _ |- _ => apply (proj1 (red_regular H))
  | H: red _ t |- _ => apply (proj2 (red_regular H))
  | H: value t |- _ => apply (value_regular H)
  end.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e448m2e224m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e416m2e208m1_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e141m9_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e127m1_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e150m5_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


From PIPE     Require Import TagDomain.
From HLL      Require Import Policy.
From Utils    Require Import Defns Smallstep Behaviours.
From RTLgenT  Require Import Inj.
From RGTpf    Require Import Inj.
From DCTpf    Require Export MatchingSim.
Import List Notations.

Module Thm (Export FTags  : TagDomain.FrontEnd)
           (Export HRules : HLL.Policy.Sig FTags)
           (Export HFlags : HLL.Policy.Props FTags HRules)
           (Export Tags   : TagDomain_MiddleTgn FTags)
           (Export Rules  : RTLT_Policy_Tgn FTags Tags HRules HFlags)
           (Export Lang   : RTLT.Language.Sig Tags)
           (Import Sem    : RTLT.Semantics.Sig Tags Rules Lang)
           (Import Flags  : RTLT_Policy_PropT FTags HRules HFlags Tags Rules Lang).

Module Import Simulation := MatchingSim.Functor
                              FTags HRules HFlags
                              Tags Rules Lang Sem Flags.

(* Some commands that may help with understanding the theorem. *)
(* Locate program_behaves.
Print  program_behaves.
Locate behaviour_improves.
Print  behaviour_improves.
Locate not_wrong.
Print  not_wrong. *)

Section Proof.
Variable  prog : Lang.program.
Variable tprog : Lang.program.
Hypothesis TRANSL : match_prog prog tprog.

Let SrcProg := Sem.RTLT_semantics  prog. (* is the semantics of RTLT param-ed by prog *)
Let TgtProg := Sem.RTLT_semantics tprog.

Theorem Semantic_Preservation  :
  (forall behS, program_behaves SrcProg behS -> not_wrong behS) ->
   forall behT, program_behaves TgtProg behT -> exists behS,
  program_behaves SrcProg behS /\ behaviour_matches match_atom match_TagErr behS behT.
Proof Simulation.refinement_for_safe_programs prog tprog TRANSL.

End Proof.
End Thm.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e416m2e208m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e448m2e224m1_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e127m1_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.