Require Import Iron.Language.SystemF2Store.Step.
Require Import Iron.Language.SystemF2Store.TyJudge.
Require Import Iron.Language.SystemF2Store.Exp.

(* A well typed expression is either a well formed value,
   or can transition to the next state. *)
Theorem progress
 :  forall ds se s x t
 ,  WfS ds se s
 -> TYPE ds nil nil se x t
 -> value x \/ (exists s' x', STEP s x s' x').
Proof.
 intros. gen t.
 induction x using exp_mutind with
  (PA := fun a => a = a)
  ; intros.

 Case "XVar".
  nope.

 Case "XLoc".
  left. eauto 6.

 Case "XLAM".
  left. apply type_wfX in H0. eauto.

 Case "XAPP".
  inverts keep H0.
  edestruct IHx. eauto.
  SCase "x value".
   right. inverts H1. inverts H3.
    SSCase "x = XVar". nope.
    SSCase "x = XLoc". nope.
    SSCase "x = XLAM". exists s. exists (substTX 0 t2 x1). eapply EsLAMAPP.
    SSCase "x = XAPP". nope.
    SSCase "x = XApp". nope.
    SSCase "x = XCon".
     inverts_type.
     have (takeTCon (TCon tc0) = takeTCon (TForall t0)). nope.
    SSCase "x = XCase".
     nope.
  SCase "x steps".
   right.
    shift s'. dest x'.
    exists (XAPP x' t2).
    lets D: EsContext XcAPP H1.
    eauto.

 Case "XLam".
  left. eapply type_wfX in H0. eauto.

 Case "XApp".
  right.
  inverts_type.
  edestruct IHx1; eauto.
  SCase "value x1".
   edestruct IHx2; eauto.
    SSCase "value x2".
     have (exists t x, x1 = XLam t x) as HF.
     destruct HF as [t11].
     destruct H2 as [x12].
     subst.
     exists s.
     exists (substXX 0 x2 x12).
     apply EsLamApp; eauto.
    SSCase "x2 steps".
     shift s'.
     destruct H1 as [x2'].
     exists (XApp x1 x2'). auto.
  SCase "x1 steps".
   shift s'.
   destruct H0  as [x1'].
   exists (XApp x1' x2).
   eapply (EsContext (fun xx => XApp xx x2)); auto.

 Case "XCon".
  inverts_type.
  (* All ctor args are either wnf or can step *)
  assert (Forall (fun x => wnfX x \/ (exists s' x', STEP s x s' x')) xs) as HWS.
   repeat nforall. intros.
   have (exists t, TYPE ds nil nil se x t). dest t.
   have (value x \/ (exists s' x', STEP s x s' x')). intuition.

  (* All ctor args are wnf, or there is a context where one can step *)
  lets D: (@exps_ctx_run exp exp) HWS.
  inverts D.

   (* All ctor args are wnf *)
   right.
   assert (Forall (wfT 0) ts).
    rrwrite (0 = length (@nil ki)).
    eapply kind_wfT_Forall2. eauto.

   assert (Forall (wfX 0 0 (length se)) xs).
    have    (0 = length (@nil ki)) as HKL. rewrite HKL at 1.
    rrwrite (0 = length (@nil ty)). eauto.

   assert (exists svs, Forall2 svalueOf xs svs).
    eapply (Forall2_exists_right_all value). auto.
    assert (Forall closedX xs).
     repeat nforall. eauto.
     repeat nforall. eauto.
     dest svs.

   exists (snoc (SObj dc svs) s).
   exists (XLoc (length s)).
   eauto.

   (* There is a context where one ctor arg can step *)
   right.
    dest C. dest x'. rip. dest s'.
    lets D: step_context_XCon_exists H2 H1.
    destruct D as [x'']. eauto.

 Case "XCase".
  right.
  inverts keep H1.
  have (value x \/ (exists s' x', STEP s x s' x')) as HS.
  inverts HS. clear IHx.

  (* Discriminant is a value *)
  SCase "x value".
   destruct x; nope.

    (* When we have a well typed case match on some data object,
       then there is a corresponding alternative. *)
    SSCase "XLoc".
     lets D: store_has_sbind_for_XLoc_and_alt H H1.
     dest dc. rip.
     destruct H8  as [svs].
     destruct H10 as [x].
     exists s.
     have (exists vs, Forall2 svalueOf vs svs).
     dest vs.
     exists (substXXs 0 vs x).
     eauto.

    (* Can't happen,
       TForall has no data type constructor *)
    SSCase "XCase (XLAM x) aa".
     have (exists t', tObj = TForall t').
     dest t'. subst. false.

    (* Can't happen,
       tFun has no data type constructor *)
    SSCase "XCase (XLam t x) aa".
     have (exists t11 t12, tObj = tFun t11 t12).
     dest t11. dest t12. subst.
     unfold tFun in H6. simpl in H6. inverts H6.
     inverts H.
     have (DEFOK ds (DefType TyConFun ks dcs)) as HD.
     inverts HD. false.

  (* Discriminant steps *)
  SCase "x steps".
   destruct H2 as [s'].
   destruct H2 as [x'].
   exists s'.
   exists (XCase x' aa).
   lets D: EsContext XcCase; eauto.

 Case "XUpdate".
  right.
  inverts_type.
  edestruct IHx1; eauto.

  SCase "value x1".
   edestruct IHx2; eauto.

   SSCase "value x2".
    assert (exists l, x1 = XLoc l).
     eapply value_loc; eauto.
     have (DEFOK ds (DefType tcObj ks dcs)).
      inverts H2. auto.
    dest l. subst.
    have (exists dc svs, get l s = Some (SObj dc svs)) as HJ.
    destruct HJ as [dc'].
    destruct H2 as [svs].

    (* Case on whether the data constructor matches *)
    have (dc' = dc \/ ~(dc' = dc)) as HM.
     inverts HM.

     SSSCase "dc' = dc".
      have (exists sv2, svalueOf x2 sv2).
      dest sv2.
      exists (replace l (SObj dc (replace i sv2 svs)) s).
      exists xUnit.
      eapply EsUpdate; eauto.

     SSSCase "dc <> dc".
      exists s.
      exists xUnit.
      eapply EsUpdateSkip; eauto.

   SSCase "x2 steps".
    destruct H1 as [s'].
    destruct H1 as [x1'].
    lets D: EsContext XcUpdate2 H1; eauto.

   SSCase "x1 steps".
    destruct H0 as [s'].
    destruct H0 as [x1'].
    lets D: EsContext XcUpdate1 H0; eauto.

 Case "XAlt".
   auto.
Qed.


Set Implicit Arguments.

Class Monoid (bin : Type) :=
  { mappend : bin -> bin -> bin;
    mempty : bin;
    bin_measure : bin -> nat;
    mappend_measure :
      forall b b', bin_measure (mappend b b') =
                   bin_measure b + bin_measure b';
    mempty_left : forall l, mappend mempty l = l;
    mempty_right : forall l, mappend l mempty = l;
    mappend_assoc : forall l m n, mappend l (mappend m n) = mappend (mappend l m) n }.

Class MonoidUnit (bin : Type) (trans : Monoid bin) (T : Type) :=
  { mappend_push : T -> bin -> bin;
    mappend_pop : bin -> T * bin;
    mappend_push_pop : forall t m, mappend_pop (mappend_push t m) = (t, m);
    mappend_push_step : forall t m n, mappend (mappend_push t m) n =
                                        mappend_push t (mappend m n) }.

Class MonoidUnitOpt (bin : Type) (trans : Monoid bin) (T : Type) :=
  { T_measure : T -> nat;
    T_measure_gt_0 : forall t, 0 < T_measure t;
    mappend_push_opt : T -> bin -> bin;
    mappend_pop_opt : bin -> option (T * bin);
    measure_push :
      forall t b,
        bin_measure (mappend_push_opt t b) = bin_measure b + T_measure t;
    measure_pop_Some :
      forall b' t b,
        mappend_pop_opt b = Some (t, b')
        -> bin_measure b = bin_measure b' + T_measure t;
    mappend_push_pop_opt :
      forall t m, mappend_pop_opt (mappend_push_opt t m) = Some (t, m);
    mappend_push_step_opt
    : forall t m n, mappend (mappend_push_opt t m) n =
                    mappend_push_opt t (mappend m n);
    mappend_pop_opt_inj :
      forall t m b b',
        mappend_pop_opt b = Some (t, m) ->
        mappend_pop_opt b' = Some (t, m) ->
        b = b'
  }.

Class QueueMonoidOpt (bin : Type) (trans : Monoid bin) (B : Type) :=
  { B_measure : B -> nat;
    B_measure_gt_0 : forall b, 0 < B_measure b;
    enqueue_opt : B -> bin -> bin;
    dequeue_opt : bin -> option (B * bin);
    measure_enqueue :
      forall b b',
        bin_measure (enqueue_opt b b') = bin_measure b' + B_measure b;
    measure_dequeue_Some :
      forall b' t b,
        dequeue_opt b = Some (t, b')
        -> bin_measure b = bin_measure b' + B_measure t;
    dequeue_mappend_opt :
      forall t b b' b'',
        dequeue_opt b = Some (t, b')
        -> dequeue_opt (mappend b b'') = Some (t, mappend b' b'');
    enqueue_mappend_opt :
      forall b b' b'',
        enqueue_opt b (mappend b' b'') = mappend b' (enqueue_opt b b'');
    dequeue_head_opt :
      forall t,
        dequeue_opt (enqueue_opt t mempty) = Some (t, mempty);
    dequeue_None :
        dequeue_opt mempty = None;
    dequeue_opt_inj :
      forall t m b b',
        dequeue_opt b = Some (t, m) ->
        dequeue_opt b' = Some (t, m) ->
        b = b'
  }.

  Definition lt_B {B} {monoid : Monoid B} (b b' : B) : Prop :=
    bin_measure b < bin_measure b'.

  Definition le_B {B} {monoid : Monoid B} (b b' : B) : Prop :=
    bin_measure b <= bin_measure b'.

  Lemma well_founded_lt_b {B}
        {monoid : Monoid B}
    : well_founded lt_B.
  Proof.
    constructor.
    unfold lt_B; induction (bin_measure a); intros.
    - inversion H.
    - inversion H; subst.
      + constructor; eauto.
      + eauto.
  Qed.

  Lemma measure_mempty {B} `{Monoid B} :
    bin_measure mempty = 0.
  Proof.
    assert (forall m n, n = n + m -> m = 0) by
        (induction n; simpl; eauto).
    eapply H0.
    etransitivity.
    - eapply (mappend_measure mempty mempty).
    - rewrite mempty_left; reflexivity.
  Qed.

Class RichMonoidOpt (bin : Type) (trans : Monoid bin) :=
  {
    mappend_inj : forall (t1 t2 t : bin), mappend t1 t = mappend t2 t -> t1 = t2
  }.


(**

Definition of binding signatures ([BindingSig]) and translation from from binding signatures to
monads ([BindingSigToMonad]). This is defined in multiple steps:

- Binding signature to a signature with strength ([BindingSigToSignature])
- Construction of initial algebra for a signature with strength ([SignatureInitialAlgebra])
- Signature with strength and initial algebra to a HSS ([SignatureToHSS])
- Construction of a monad from a HSS ([Monad_from_hss] in MonadsFromSubstitutionSystems.v)
- Composition of these maps to get a function from binding signatures to monads ([BindingSigToMonad])

Written by: Anders Mörtberg, 2016

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.Combinatorics.Lists.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.Chains.All.
Require Import UniMath.CategoryTheory.Monads.Monads.

Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Structures.

Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SignatureExamples.
Require Import UniMath.SubstitutionSystems.SumOfSignatures.
Require Import UniMath.SubstitutionSystems.BinProductOfSignatures.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.

Local Open Scope cat.

Local Notation "[ C , D ]" := (functor_category C D).
Local Notation "'chain'" := (diagram nat_graph).

(** * Definition of binding signatures *)
Section BindingSig.

(** A binding signature is a collection of lists of natural numbers indexed by types I *)
Definition BindingSig : UU := ∑ (I : UU) (h : isaset I), I → list nat.

Definition BindingSigIndex : BindingSig -> UU := pr1.
Definition BindingSigIsaset (s : BindingSig) : isaset (BindingSigIndex s) :=
  pr1 (pr2 s).
Definition BindingSigMap (s : BindingSig) : BindingSigIndex s -> list nat :=
  pr2 (pr2 s).

Definition make_BindingSig {I : UU} (h : isaset I) (f : I -> list nat) : BindingSig := (I,,h,,f).

(** Sum of binding signatures *)
Definition SumBindingSig : BindingSig -> BindingSig -> BindingSig.
Proof.
intros s1 s2.
use tpair.
- apply (BindingSigIndex s1 ⨿ BindingSigIndex s2).
- use tpair.
  + apply (isasetcoprod _ _ (BindingSigIsaset s1) (BindingSigIsaset s2)).
  + induction 1 as [i|i]; [ apply (BindingSigMap s1 i) | apply (BindingSigMap s2 i) ].
Defined.

End BindingSig.

(** * Translation from a binding signature to a monad
<<
          S : BindingSig
      |-> functor(S) : functor [C,C] [C,C]
      |-> Initial (Id + functor(S))
      |-> I := Initial (HSS(func(S), θ)
      |-> M := Monad_from_HSS(I)
>>
*)
Section BindingSigToMonad.

Context {C : category}.

Local Notation "'[C,C]'" := (functor_category C C).

(** Form "_ o option^n" and return Id if n = 0 *)
Definition precomp_option_iter (BCC : BinCoproducts C) (TC : Terminal C) (n : nat) : functor [C,C] [C,C].
Proof.
induction n as [|n IHn].
- apply functor_identity.
- apply (pre_composition_functor _ _ _  (iter_functor1 _ (option_functor BCC TC) n)).
Defined.

Lemma is_omega_cocont_precomp_option_iter
  (BCC : BinCoproducts C) (TC : Terminal C)
  (CLC : Colims_of_shape nat_graph C) (n : nat) :
  is_omega_cocont (precomp_option_iter BCC TC n).
Proof.
destruct n; simpl.
- apply is_omega_cocont_functor_identity.
- apply is_omega_cocont_pre_composition_functor, CLC.
Defined.

Definition precomp_option_iter_Signature (BCC : BinCoproducts C)
  (TC : Terminal C) (n : nat) : Signature C C C.
Proof.
  use tpair.
  - exact (precomp_option_iter BCC TC n).
  - destruct n; simpl.
    + apply θ_functor_identity.
    + exact (pr2 (θ_from_δ_Signature C _ (DL_iter_functor1 C (option_functor BCC TC) (option_DistributiveLaw C TC BCC) n))).
Defined.

(* will not be used, is just a confirmation of proper construction *)
Local Lemma functor_in_precomp_option_iter_Signature_ok  (BCC : BinCoproducts C)
      (TC : Terminal C) (n : nat) : Signature_Functor (precomp_option_iter_Signature BCC TC n) = precomp_option_iter BCC TC n.
Proof.
apply idpath.
Qed.

(* From here on all constructions need these hypotheses *)
Context (BPC : BinProducts C) (BCC : BinCoproducts C).

(** [nat] to a Signature *)
Definition Arity_to_Signature (TC : Terminal C) (xs : list nat) : Signature C C C:=
  foldr1 (BinProduct_of_Signatures _ _ _ BPC)
         (ConstConstSignature C C C (TerminalObject TC))
        (map (precomp_option_iter_Signature BCC TC) xs).

Let BPC2 BPC := BinProducts_functor_precat C C BPC.
Let constprod_functor1 := constprod_functor1 (BPC2 BPC).

(** The H assumption follows directly if [C,C] has exponentials *)
Lemma is_omega_cocont_Arity_to_Signature
  (TC : Terminal C) (CLC : Colims_of_shape nat_graph C)
  (H : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F))
  (xs : list nat) :
  is_omega_cocont (Arity_to_Signature TC xs).
Proof.
destruct xs as [[|n] xs].
- destruct xs; apply is_omega_cocont_constant_functor.
- induction n as [|n IHn].
  + destruct xs as [m []]; simpl.
    unfold Arity_to_Signature.
    apply is_omega_cocont_precomp_option_iter, CLC.
  + destruct xs as [m [k xs]].
    apply is_omega_cocont_BinProduct_of_Signatures.
    * apply is_omega_cocont_precomp_option_iter, CLC.
    * apply (IHn (k,,xs)).
    * assumption.
    * intro x; apply (H x).
Defined.

(** ** Binding signature to a signature with strength *)
Definition BindingSigToSignature (TC : Terminal C)
  (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) :
  Signature C C C.
Proof.
  apply (Sum_of_Signatures (BindingSigIndex sig)).
  - apply CC.
  - intro i; apply (Arity_to_Signature TC (BindingSigMap sig i)).
Defined.

Lemma is_omega_cocont_BindingSigToSignature
  (TC : Terminal C) (CLC : Colims_of_shape nat_graph C)
  (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F))
  (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) :
  is_omega_cocont (BindingSigToSignature TC sig CC).
Proof.
  unfold BindingSigToSignature.
  apply is_omega_cocont_Sum_of_Signatures.
  now intro i; apply is_omega_cocont_Arity_to_Signature, HF.
Defined.

Let Id_H := Id_H C BCC.

(** ** Construction of initial algebra for a signature with strength *)
Definition SignatureInitialAlgebra
  (IC : Initial C) (CLC : Colims_of_shape nat_graph C)
  (H : Presignature C C C) (Hs : is_omega_cocont H) :
  Initial (FunctorAlg (Id_H H)).
Proof.
use colimAlgInitial.
- apply (Initial_functor_precat _ _ IC).
- apply (is_omega_cocont_Id_H _ _ _ Hs).
- apply ColimsFunctorCategory_of_shape, CLC.
Defined.

(** ** Construction of datatype specified by a binding signature *)
Definition DatatypeOfBindingSig
  (IC : Initial C) (TC : Terminal C) (CLC : Colims_of_shape nat_graph C)
  (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F))
  (sig : BindingSig) (CC : Coproducts (BindingSigIndex sig) C) :
  Initial (FunctorAlg (Id_H (Presignature_Signature(BindingSigToSignature TC sig CC)))).
Proof.
apply SignatureInitialAlgebra; trivial.
now apply is_omega_cocont_BindingSigToSignature.
Defined.

Let HSS := @hss_category C BCC.

(* Redefine this here so that it uses the arguments above *)
Let InitialHSS
  (IC : Initial C) (CLC : Colims_of_shape nat_graph C)
  (H : Presignature C C C) (Hs : is_omega_cocont H) :
  Initial (HSS H).
Proof.
apply InitialHSS; assumption.
Defined.

(** ** Signature with strength and initial algebra to a HSS *)
Definition SignatureToHSS
  (IC : Initial C) (CLC : Colims_of_shape nat_graph C)
  (H : Presignature C C C) (Hs : is_omega_cocont H) :
  HSS H.
Proof.
now apply InitialHSS; assumption.
Defined.

(** The above HSS is initial *)
Definition SignatureToHSSisInitial
  (IC : Initial C) (CLC : Colims_of_shape nat_graph C)
  (H : Presignature C C C) (Hs : is_omega_cocont H) :
  isInitial _ (SignatureToHSS IC CLC H Hs).
Proof.
now unfold SignatureToHSS; destruct InitialHSS.
Qed.

(* Redefine this here so that it uses the arguments above *)
Let Monad_from_hss (H : Signature C C C) : HSS H → Monad C.
Proof.
exact (Monad_from_hss _ BCC H).
Defined.

(** ** Function from binding signatures to monads *)
Definition BindingSigToMonad
  (TC : Terminal C) (IC : Initial C) (CLC : Colims_of_shape nat_graph C)
  (HF : ∏ (F : [C,C]), is_omega_cocont (constprod_functor1 F))
  (sig : BindingSig)
  (CC : Coproducts (BindingSigIndex sig) C) :
  Monad C.
Proof.
use Monad_from_hss.
- apply (BindingSigToSignature TC sig CC).
- apply (SignatureToHSS IC CLC).
  apply (is_omega_cocont_BindingSigToSignature TC CLC HF _ _).
Defined.

End BindingSigToMonad.

(** * Specialized versions of some of the above functions for HSET *)
Section BindingSigToMonadHSET.

(** ** Binding signature to signature with strength for HSET *)
Definition BindingSigToSignatureHSET (sig : BindingSig) : Signature HSET HSET HSET.
Proof.
use BindingSigToSignature.
- apply BinProductsHSET.
- apply BinCoproductsHSET.
- apply TerminalHSET.
- apply sig.
- apply CoproductsHSET, (BindingSigIsaset sig).
Defined.

Lemma is_omega_cocont_BindingSigToSignatureHSET (sig : BindingSig) :
  is_omega_cocont (BindingSigToSignatureHSET sig).
Proof.
apply is_omega_cocont_Sum_of_Signatures.
intro i; apply is_omega_cocont_Arity_to_Signature.
+ apply ColimsHSET_of_shape.
+ intros F.
  apply is_omega_cocont_constprod_functor1.
  apply Exponentials_functor_HSET.
Defined.

(** ** Construction of initial algebra for a signature with strength for HSET *)
Definition SignatureInitialAlgebraHSET (s : Presignature HSET _ _) (Hs : is_omega_cocont s) :
  Initial (FunctorAlg (Id_H _ BinCoproductsHSET s)).
Proof.
apply SignatureInitialAlgebra; try assumption.
- apply InitialHSET.
- apply ColimsHSET_of_shape.
Defined.

(** ** Binding signature to a monad for HSET *)
Definition BindingSigToMonadHSET : BindingSig → Monad HSET.
Proof.
intros sig; use (BindingSigToMonad _ _ _ _ _ _ sig).
- apply BinProductsHSET.
- apply BinCoproductsHSET.
- apply TerminalHSET.
- apply InitialHSET.
- apply ColimsHSET_of_shape.
- intros F.
  apply is_omega_cocont_constprod_functor1.
  apply Exponentials_functor_HSET.
- apply CoproductsHSET.
  apply BindingSigIsaset.
Defined.

End BindingSigToMonadHSET.

(* Old code for translation from lists of lists *)

(* (* [[nat]] to Signature *) *)
(* Definition SigToSignature : Sig -> Signature HSET has_homsets_HSET. *)
(* Proof. *)
(* intro xs. *)
(* generalize (map_list Arity_to_Signature xs). *)
(* apply foldr1_list. *)
(* - apply (BinSum_of_Signatures _ _ BinCoproductsHSET). *)
(* - apply IdSignature. *)
(* Defined. *)

(* Lemma is_omega_cocont_SigToSignature (s : Sig) : is_omega_cocont (SigToSignature s). *)
(* Proof. *)
(* destruct s as [n xs]. *)
(* destruct n. *)
(* - destruct xs. *)
(*   apply (is_omega_cocont_functor_identity has_homsets_HSET2). *)
(* - induction n. *)
(*   + destruct xs as [xs []]; simpl. *)
(*     apply is_omega_cocont_Arity_to_Signature. *)
(*   + destruct xs as [m xs]. *)
(*     generalize (IHn xs). *)
(*     destruct xs. *)
(*     intro IH. *)
(*     apply is_omega_cocont_BinSum_of_Signatures. *)
(*     apply is_omega_cocont_Arity_to_Signature. *)
(*     apply IH. *)
(*     apply BinProductsHSET. *)
(* Defined. *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(*********************************************************)
(**          Definitions for the axiomatization          *)
(*********************************************************)

Declare ML Module "r_syntax_plugin".
Require Export ZArith_base.

Parameter R : Set.

(* Declare Scope positive_scope with Key R *)
Delimit Scope R_scope with R.

(* Automatically open scope R_scope for arguments of type R *)
Bind Scope R_scope with R.

Local Open Scope R_scope.

Parameter R0 : R.
Parameter R1 : R.
Parameter Rplus : R -> R -> R.
Parameter Rmult : R -> R -> R.
Parameter Ropp : R -> R.
Parameter Rinv : R -> R.
Parameter Rlt : R -> R -> Prop.
Parameter up : R -> Z.

Infix "+" := Rplus : R_scope.
Infix "*" := Rmult : R_scope.
Notation "- x" := (Ropp x) : R_scope.
Notation "/ x" := (Rinv x) : R_scope.

Infix "<" := Rlt : R_scope.

(***********************************************************)

(**********)
Definition Rgt (r1 r2:R) : Prop := r2 < r1.

(**********)
Definition Rle (r1 r2:R) : Prop := r1 < r2 \/ r1 = r2.

(**********)
Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2.

(**********)
Definition Rminus (r1 r2:R) : R := r1 + - r2.

(**********)
Definition Rdiv (r1 r2:R) : R := r1 * / r2.

(**********)

Infix "-" := Rminus : R_scope.
Infix "/" := Rdiv   : R_scope.

Infix "<=" := Rle : R_scope.
Infix ">=" := Rge : R_scope.
Infix ">"  := Rgt : R_scope.

Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope.
Notation "x <= y < z"  := (x <= y /\ y <  z) : R_scope.
Notation "x < y < z"   := (x <  y /\ y <  z) : R_scope.
Notation "x < y <= z"  := (x <  y /\ y <= z) : R_scope.

(**********************************************************)
(** *    Injection from [Z] to [R]                        *)
(**********************************************************)

(* compact representation for 2*p *)
Fixpoint IPR_2 (p:positive) : R :=
  match p with
  | xH => R1 + R1
  | xO p => (R1 + R1) * IPR_2 p
  | xI p => (R1 + R1) * (R1 + IPR_2 p)
  end.

Definition IPR (p:positive) : R :=
  match p with
  | xH => R1
  | xO p => IPR_2 p
  | xI p => R1 + IPR_2 p
  end.
Arguments IPR p%positive : simpl never.

(**********)
Definition IZR (z:Z) : R :=
  match z with
  | Z0 => R0
  | Zpos n => IPR n
  | Zneg n => - IPR n
  end.
Arguments IZR z%Z : simpl never.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf1 : natural) (y : natural) (lf2 : natural) : natural := lf1.


Require Import Fiat.Common Fiat.Computation Coq.Sets.Ensembles
        Fiat.ADT.ADTSig Fiat.ADT.Core
        Fiat.ADTRefinement.Core Fiat.ADTRefinement.SetoidMorphisms
        Fiat.ADTRefinement.GeneralRefinements.

Generalizable All Variables.
Set Implicit Arguments.

(** Oftentimes in order to show that a refinement is valid, we need
    some invariant to hold on an ADT's representation- a value cached
    in an ADT's representation should be the result of running an
    observer on the current state, for example.

    One solution to this problem is to use dependent products to
    package proofs of an invariant into an ADT's representation: [
    {rep | Invariant rep} ].
    While conceptually simple, this forces methods to be 'internally'
    verified- mutator methods in particular have to simultaneously
    produce a new state /and/ a proof that it satisfies the ADT's
    invariant.  This can make derivations more painful while
    potentially being bewildering to those unfamiliar with dependent
    products.

    Dependent products introduce another wrinkle to refinement: since
    an ADT refinement can change the proof produced by a method, we
    can't always use equality as the abstraction relation in
    [ADTrefine]. (As an example of a case where the proof changes, a
    refinement might use a cached value instead of running a method on
    the current state.)

    An alternative approach is to have the [ADT] include invariants
    and the corresponding proofs that methods maintain them as a
    separate fields. This more familiar presentation allows method
    refinements to be defined and then verified interactively during a
    derivation, at the cost of polluting ADT definitions with extra
    fields. Since proofs aren't packaged into the representation in
    this approach, equality suffices for expressing method refinement.

    Yet another approach is to use the abstract relation to derive
    an ad hoc invariant for a particular refinement step. The basic
    idea is that the abstraction relation relates two equal states for
    which the invariant holds. By baking the invariant into the
    abstraction relation, it becomes a hypothesis to all of our
    refinement proofs.  The cost of this approach is that it requires
    a proof that each mutator preserves the invariant on an ad hoc
    basis, which could leave to some duplicate proofs (One way to
    mitigate this would be to include invariant hypotheses around in
    the context, which we could bake into the honing
    tactics). Otherwise, I would argue it includes the best of
    both worlds- there's no need to pollute the definition of [ADT]
    with [repInv] /and/ methods don't have to bother with maintaining
    proofs.

 *)

Section RepInv.

  Variable rep : Type.
  Variable repInv : Ensemble rep.

  (** This is the abstraction relation we use to mimic invariants- the
      representations are always the same /and/ the invariant
      holds. *)

  Definition repInvAbsR (r_o r_n : rep) :=
    r_o = r_n /\ repInv r_n.

  (** Refining an adt using the [repInvAbsR] relation allows us to
      utilize [repInv] when proving method refinement. Of course, we
      also have to show that mutators preserve the invariant.
      Hopefully we can include additional information into the honing
      tactics to avoid reproving invariant preservation.  *)

  Lemma refineADT_Build_ADT_RepInv
        Sig
  : forall constr constr',
      (forall idx, @refineConstructor _ _ repInvAbsR
                                  (ConstructorDom Sig idx)
                                  (constr idx) (constr' idx))
      -> forall meth meth',
           (forall idx, @refineMethod _ _ repInvAbsR
                                        (fst (MethodDomCod Sig idx))
                                        (snd (MethodDomCod Sig idx))
                                        (meth idx) (meth' idx))
           -> refineADT (@Build_ADT Sig rep constr meth)
                        (@Build_ADT Sig rep constr' meth').
  Proof.
    intros; eapply refineADT_Build_ADT_Rep; eauto; reflexivity.
  Qed.

  Lemma refine_pick_repInvAbsR :
    forall r_o, repInv r_o ->
    refineEquiv {r_n | repInvAbsR r_o r_n}
                (ret r_o).
  Proof.
    unfold repInvAbsR; split; intros v CompV; computes_to_inv; intuition;
    subst; computes_to_econstructor; eauto.
  Qed.

  Lemma refine_pick_repInvAbsR' :
    forall r_n, repInv r_n ->
    refineEquiv {r_o | repInvAbsR r_o r_n}
                (ret r_n).
  Proof.
    unfold repInvAbsR; split; intros v CompV; computes_to_inv; intuition;
    subst; econstructor; eauto.
  Qed.

End RepInv.

(* A more user-friendly version of [refineADT_Build_ADT_Rep]. *)

(*Lemma refinesADTRepInv Sig
      (adt : ADT Sig)
      (repInv : Ensemble (Rep adt))
      Constructors'
      Methods'
      (RefConstr : forall idx d,
                  refine
                    (r_o' <- Constructors adt idx d;
                      {r_n  | r_o' = r_n /\ repInv r_n})
                    (Constructors' idx d))
      (RefMeth : forall idx (r : Rep adt) n,
                  repInv r ->
                  refine
                    (r' <- Methods adt idx r n;
                     r'' <- {r'' : Rep adt |
                             repInvAbsR repInv (fst r') r''};
                    ret (r'', snd r'))
                    (Methods' idx r n))
      (cachedIndex : ConstructorIndex Sig)
: refineADT adt
            {| Rep := Rep adt;
               Constructors := Constructors';
               Methods := Methods'
            |}.
Proof.
  destruct adt.
  eapply refineADT_Build_ADT_RepInv with
  (repInv := repInv); unfold pointwise_relation, repInvAbsR in *;
  simpl in *; intros; intuition; subst; eauto.
Qed.

Tactic Notation "hone" "method" constr(mutIdx) "using" constr(mutBody)
       "under" "invariant" constr(repInv) :=
    let A :=
        match goal with
            |- Sharpened ?A => constr:(A) end in
    let ASig := match type of A with
                    ADT ?Sig => Sig
                end in
    let mutIdx_eq' := fresh in
    let Rep' := eval simpl in (Rep A) in
    let MethodIndex' := eval simpl in (MethodIndex ASig) in
    let ConstructorIndex' := eval simpl in (ConstructorIndex ASig) in
    let Methods' := eval simpl in (Methods A) in
    let Constructors' := eval simpl in (Constructors A) in
      assert (forall idx idx' : MethodIndex', {idx = idx'} + {idx <> idx'})
        as mutIdx_eq' by (decide equality);
      eapply SharpenStep;
        [eapply (@refineADT_Build_ADT_RepInv Rep' repInv
                   _
                   _
                   (fun idx : MethodIndex ASig => if (mutIdx_eq' idx mutIdx) then
                                 mutBody
                               else
                                 Methods' idx));
          try instantiate (1 := Constructors')
        | idtac]; cbv beta in *; simpl in *. *)


Require Utf8.

Require Import S00_setoid_basics S01_Wty S30_IdType S32_IdWty.

(* Pointwise equality on W-types *)

(* Definition 5.2 *)

Definition EqWty_aux {X : Set}(Y : X → Set) : Wty Y ∧ Wty Y → Set
  := @DWty (Wty Y ∧ Wty Y)
           (λ z, Wty_node Y (fst z) == Wty_node Y (snd z))
           (λ z p, TotEq Y p)
           (λ z p v, (Wty_ist (fst z) (fstTotEq Y v) , Wty_ist (snd z) (sndTotEq Y v))).

Definition EqWty {X : Set}(Y : X → Set) : Wty Y → Wty Y → Set
  := λ w w', EqWty_aux Y (w , w').

(* Useful functions and proof that it is an equivalence relation *)

Section EqWty.
  Context {X : Set}{Y : X → Set}.

  Definition isEqWty {w w': Wty Y}(p : Wty_node Y w == Wty_node Y w')
             (br : ∀ v : TotEq Y p, EqWty Y (Wty_ist w (fstTotEq Y v))
                                          (Wty_ist w' (sndTotEq Y v)))
    : EqWty Y w w'.
    apply supd with (i := (w , w'))
                    (a := p).
    apply br.
  Defined.

  Definition nodeEqWty {w w': Wty Y}
    : EqWty Y w w' → Wty_node Y w == Wty_node Y w'
    := DWty_node _ _ (w , w').

  Definition subtEqWty {w w': Wty Y}(E : EqWty Y w w')
             {y : Y (Wty_node Y w)}{y' : Y (Wty_node Y w')}
    : y ==[nodeEqWty E] y' → EqWty Y (Wty_ist w y) (Wty_ist w' y')
    := λ q, DWty_ist _ _ (w , w') E (isTotEq Y (nodeEqWty E) y y' q).

  Lemma EqWty_symm_aux : ∀ z, EqWty_aux Y z → EqWty_aux Y (snd z , fst z).
  Proof.
    intros z E. induction E as [[w w'] p br IH]. simpl in *|-. simpl.
    apply (isEqWty (w := w') (w' := w) (p ⁻¹)).
    cut (∀ y y', EqOver Y p y y' → EqWty_aux Y (Wty_ist w' y', Wty_ist w y)).
    intros H [[y' y] q]. simpl in *|-. cbn.
    apply (H y y'). unfold EqOver.
    apply (transpflip_inv Y). apply (q ⁻¹).
    intros y y' q. apply (IH (existT _ (y , y') q)).
  Qed.

  Lemma EqWty_symm : ∀ w w', EqWty Y w w' → EqWty Y w' w.
  Proof.
    intros w w'. apply EqWty_symm_aux.
  Qed.

  Lemma EqWty_trans_aux : ∀ z, EqWty_aux Y z
                         → (∀ w, EqWty Y w (fst z) → EqWty_aux Y (w , snd z)).
  Proof.
    intros z E. induction E as [[w' w''] p' br' IH]. intros w [p br]. simpl in *|-. simpl.
    apply supd with (i := (w , w''))
                    (a := p⊙ᵐp').
    cut (∀ y' y'', ∀ q' : EqOver Y p' y' y'', ∀ w : Wty Y,
                EqWty Y w (Wty_ist w' y')
                → EqWty_aux Y (w, Wty_ist w'' y'')).
    intros H [[y y''] qq]. cbn. simpl in *|-.
    apply (H (Y•ᵐp y) y''). unfold EqOver.
    apply transpfunct_rev. apply qq.
    apply (br (existT _ (y , Y•ᵐp y) rfl)).
    intros y' y'' q'. apply (IH (existT _ (y' , y'') q')).
  Qed.

  Lemma EqWty_trans : ∀ w w' w'', EqWty Y w w' → EqWty Y w' w'' → EqWty Y w w''.
  Proof.
    intros w w' w'' E E'. apply (EqWty_trans_aux (w', w'') E' w E).
  Qed.
End EqWty.

(* Lemma 5.3 *)

Lemma Id2EqWty {X : Set}(Y : X → Set){w : Wty Y}
  : forall {w'}, w == w' → EqWty Y w w'.
Proof.
  induction w as [a f IH]. set (w := sup Y a f).
  intros w' r. induction r. apply (isEqWty rfl).
  intros [[y y'] q]. cbn. simpl in q. unfold EqOver in q.
  apply IH. apply ap. apply q.
Qed.

(* Setoid of pointwise equal trees *)

Definition PtwTrees {X : Set}(Y : X → Set) : setoid.

  apply (Build_setoid (Wty Y) (EqWty Y)).
  apply Build_setoidaxioms.
  intro w. apply Id2EqWty. apply rfl.
  apply EqWty_symm.
  apply EqWty_trans.
Defined.

(* Lemma 5.4 *)

Lemma EqWty2Id_aux (funext : forall {A : Set}, forall {B : A → Set}, forall {f f' : (∀ x, B x)},
                           (∀ x, f x =={B x} f' x) → f =={∀ x, B x} f')
                   {X : Set}(Y : X → Set)
  : ∀ z : Wty Y ∧ Wty Y, EqWty_aux Y z → fst z == snd z.
Proof.
  intros z E. induction E as [[w w'] p br IH]. simpl. simpl in IH. simpl in br. simpl in p.
  refine ((ηWty w) ⁻¹ ⊙ᵐ _ ⊙ᵐ ηWty w').
  apply isIdWty with (p0 := p).
  apply funext. intro y.
  apply (IH (existT _ (y , Y •ᵐ p y) rfl)).
Qed.

Lemma EqWty2Id (funext : forall {A : Set}, forall {B : A → Set}, forall {f f' : (∀ x, B x)},
                           (∀ x, f x =={B x} f' x) → f =={∀ x, B x} f')
                   {X : Set}(Y : X → Set){w w' : Wty Y}
  : EqWty Y w w' → w == w'.
Proof.
  intro E. apply (EqWty2Id_aux funext Y (w , w') E).
Qed.

(* End Lemma 5.4 *)


(** * Bounds on the rounding error of dotproduct $\sum_{i=0}^n a_i b_i$#\sum_{i=0}^n a_i b_i#

    Notations are similar to the one in [fsum]. *)

Require Import Reals Flocq.Core.Fcore_Raux.

Require Import ValidSDP.misc.

Require Import Psatz.

Require Import mathcomp.ssreflect.ssreflect mathcomp.ssreflect.ssrbool mathcomp.ssreflect.ssrfun mathcomp.ssreflect.eqtype mathcomp.ssreflect.ssrnat mathcomp.ssreflect.seq.
Require Import mathcomp.ssreflect.fintype mathcomp.ssreflect.finfun mathcomp.algebra.ssralg mathcomp.ssreflect.bigop.

Require Import Rstruct.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope R_scope.
Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Require Import gamma fsum.

Section Fdotprod.

Variable fs : Float_spec.

(** Sum [\sum a_i b_i] computed in float from left to right. *)
Definition fdotprod_l2r n (a b : FS fs ^ n) : FS fs :=
  fsum_l2r [ffun i => fmult (a i) (b i)].

Lemma fdotprod_l2r_eq n (a1 b1 : FS fs ^ n) (a2 b2 : FS fs ^ n) :
  (forall i, a1 i = a2 i :> R) -> (forall i, b1 i = b2 i :> R) ->
  fdotprod_l2r a1 b1 = fdotprod_l2r a2 b2 :> R.
Proof.
by move=> Ha Hb; apply fsum_l2r_eq => i; rewrite !ffunE /fmult Ha Hb.
Qed.

Lemma fdotprod_l2r_r n (a b : FS fs ^ n.+2) :
  fdotprod_l2r a b
  = fplus (fdotprod_l2r [ffun i : 'I_n.+1 => a (inord i)]
                        [ffun i : 'I_n.+1 => b (inord i)])
          (fmult (a (inord n.+1)) (b (inord n.+1))) :> R.
Proof.
rewrite /fdotprod_l2r fsum_l2r_r.
rewrite /fplus; do 2 apply f_equal; apply f_equal2.
{ by apply fsum_l2r_eq => i; rewrite !ffunE. }
by rewrite ffunE.
Qed.

Lemma fdotprod_l2r_err_gamma n (Hn : 2 * INR n * eps fs < 1) (a b : FS fs ^ n) :
  exists ta : (b_gamma fs n * b_eta fs) ^ n,
  (fdotprod_l2r a b
   = \sum_i (a i * b i + (ta i).1 * (a i * b i) + 2 * (ta i).2)%Re :> R)%Re.
Proof.
case: n Hn a b => [|n] Hn a b.
{ exists [ffun=> (b_gamma_0 (bg_2 Hn), eta_0 fs)].
  by rewrite big_ord0 /fdotprod_l2r /fsum_l2r. }
set (amb := [ffun i : 'I_n.+1 => fmult (a i) (b i)]).
have [ta Hta] := fsum_l2r_err_gamma (bg_2pred Hn) amb.
set (F := fun i : 'I_n.+1 => ((1 + ta i) * amb i)%Re).
set (F' := fun (i : 'I_n.+1) (tte : b_gamma fs n.+1 * b_eta fs) =>
             (a i * b i + tte.1 * (a i * b i) + 2 * tte.2)%Re).
suff H : forall i, exists e, F i = F' i e.
{ have [ea Hea] := big_exists 0%R +%R (b_gamma_0 (bg_2 Hn), eta_0 fs) H.
  by exists ea; rewrite -Hea -Hta. }
move=> i.
have [d [e Hde]] := fmult_spec (a i) (b i).
have [t' Ht'] := gammap1_mult_epsp1 Hn (ta i) d.
have H := b_gammap1_le_2_Rabs (bg_2pred Hn) (ta i).
have [e' He'] := bounded_larger_factor (Rlt_le _ _ (eta_pos fs)) e H.
exists (t', e').
rewrite /F /F' /amb ffunE Hde /=.
by rewrite !Rmult_plus_distr_l (Rmult_comm _ e) He' -Rmult_assoc Ht'; ring.
Qed.

Lemma fdotprod_l2r_err n (Hn : 2 * INR n * eps fs < 1) (a b : FS fs ^ n) :
  exists t : b_gamma fs n, exists e : b_eta fs,
  (fdotprod_l2r a b
   = \sum_i (a i * b i)%Re + t * (\sum_i Rabs (a i * b i)%Re)
     + 2 * INR n * e :> R)%Re.
Proof.
have [ta Hta] := fdotprod_l2r_err_gamma Hn a b.
have [t' Ht'] := big_bounded_distrl (gamma_pos (bg_2 Hn)) [ffun i => (ta i).1]
                                    [ffun i => (a i * b i)%Re].
have [e He] := big_bounded_distrl (Rlt_le _ _ (eta_pos fs))
                                  [ffun i => (ta i).2] [ffun=> 2].
exists t'; exists e.
rewrite -big_Rabs_ffunE -Ht' Hta !big_split /=; apply f_equal2.
{ by apply Rplus_eq_compat_l, eq_big; [|move=> i; rewrite !ffunE]. }
rewrite Rmult_comm (Rmult_comm 2) -big_sum_const.
have H : 0 <= 2; [by lra|rewrite -(big_Rabs_pos_eq _ _ (fun _ => H))].
rewrite -big_Rabs_ffunE -He.
by apply eq_bigr => i; rewrite !ffunE Rmult_comm.
Qed.

Lemma fdotprod_l2r_err_abs n (Hn : 2 * INR n * eps fs < 1) (a b : FS fs ^ n) :
  Rabs (fdotprod_l2r a b - \sum_i (a i * b i)%Re)
  <= gamma fs n * (\sum_i Rabs (a i * b i)) + 2 * INR n * eta fs.
Proof.
have [t [e Hte]] := fdotprod_l2r_err Hn a b.
rewrite Hte.
replace (_ - _)%Re with (t * (\sum_i Rabs (a i * b i)%Re)
                         + 2 * INR n * e)%Re by ring.
apply (Rle_trans _ _ _ (Rabs_triang _ _)), Rplus_le_compat; rewrite Rabs_mult.
{ rewrite (Rabs_pos_eq (\sum__ _)); [|by apply big_sum_Rabs_pos].
  apply Rmult_le_compat_r; [by apply big_sum_Rabs_pos|].
  by case t. }
have H : 0 <= 2 * INR n by apply Rmult_le_pos; [lra|apply pos_INR].
by rewrite Rabs_pos_eq; [apply Rmult_le_compat_l; [|case e]|].
Qed.

End Fdotprod.


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibProd LibContainer LibSet
     LibRelation LibPer.
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import TLCBuffer UnionFind01Data.

(* -------------------------------------------------------------------------- *)

(* In an empty graph, every vertex is its own representative. *)

Lemma is_repr_empty:
  forall V x,
  is_repr (@empty V) x x.
Proof using.
  unfold is_repr, is_root. eauto with rtclosure.
Qed.

(* The empty relation is a disjoint set forest. *)

Lemma is_dsf_empty:
  forall V,
  is_dsf \{} (@empty V).
  (* This would be true of an arbitrary domain [D], but we fix the empty set
     because this is more specific and sufficient for our purposes. *)
Proof using.
  unfold empty.
  repeat split.
    false.
    false.
    eauto using functional_empty.
    intro x. exists x. eapply is_repr_empty.
Qed.

(* -------------------------------------------------------------------------- *)

(* If [F] is a disjoint set forest with respect to some domain [D1], then it
   is also a disjoint set forest with respect to to a larger domain [D2]. In
   other words, introducing new isolated vertices preserves the validity of
   a forest. *)

Lemma is_dsf_covariant_in_D:
  forall V (D1 D2 : set V) F,
  is_dsf D1 F ->
  D1 \c D2 ->
  is_dsf D2 F.
Proof using.
  unfold is_dsf. intros. jauto_set.
    { split; eapply incl_inv; eauto 2 with confined. }
    { eauto. }
    { eauto. }
Qed.

(* -------------------------------------------------------------------------- *)

(* In particular, adding a single isolated vertex is permitted, and the
   effect of this operation on the PER is to add a new equivalence class. *)

Lemma is_dsf_create:
  forall V (D : set V) x F,
  is_dsf D F ->
  is_dsf (D \u \{x}) F.
Proof using.
  intros. eapply is_dsf_covariant_in_D. eauto. eauto using incl_union_l, reflexivity.
Qed.

Lemma dsf_per_create:
  forall V (D : set V) F x,
  is_dsf D F ->
  dsf_per (D \u \{x}) F =
  per_add_node (dsf_per D F) x.
Proof using.
  unfold per_add_node, per_single, union.
  unfold dsf_per, confine.
  intros. extens. intros y z.
  split; intros; unpack.
    { rew_set in *. intuition eauto with sticky. }
    { branches; unpack; subst; splits; rew_set; (try now apply _); eauto using is_equiv_refl. }
Qed.


Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import ddT.
Require Import gen_tacs.
Require Import gen_seq.
Require Import List_lemmasT.
Require Import existsT.
Require Import univ_gen_ext.
Require Import dd_fc.
Require Import PeanoNat.

Declare Scope My_scope.
Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

(* In this file we define two calculi based on multisets for the propositonal modal logic
   GL. The first one, called GLS, is the main calculus for GL. The second one, named PSGLS,
   is essentially the calculus GLS with further restrictions on the application of the
   rules. In other words, the calculus PSGLS is a proof-search oriented version of GLS. *)

(* ---------------------------------------------------------------------------------------------------------------------------------- *)

(* Definitions Language *)

(* First, we use a set of propositional variables on which equality is decidable. *)

Global Parameter V : Set.

Parameter eq_dec_propvar : forall x y : V, {x = y}+{x <> y}.

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(* Secondt, let us define the propositional formulas we use here. *)

Inductive MPropF : Type :=
 | Var : V -> MPropF
 | Bot : MPropF
 | Imp : MPropF -> MPropF -> MPropF
 | Box : MPropF -> MPropF
.

Notation "# P" := (Var P) (at level 1) : My_scope.
Notation "A → B" := (Imp A B) (at level 16, right associativity) : My_scope.
Notation "⊥" := Bot (at level 0)  : My_scope.

Lemma eq_dec_form : forall x y : MPropF, {x = y}+{x <> y}.
Proof.
induction x.
- intros. destruct y.
  * pose (eq_dec_propvar v v0). destruct s. left. subst. reflexivity.
    right. intro. inversion H. apply n. assumption.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * left. reflexivity.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n.
    assumption.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx y). destruct s. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption.
Qed.

Fixpoint size_form (A : MPropF) : nat :=
match A with
 | # P => 1
 | Bot => 1
 | Imp B C => 1 + (size_form B) + (size_form C)
 | Box B => 1 + (size_form B)
end.

(* Now, we can prove that some properties of formulae hold. *)

Definition is_atomicT (A : MPropF) : Type :=
                  (existsT2 (P : V), A = # P) + (A = Bot).

Definition is_boxedT (A : MPropF) : Type :=
                  exists (B : MPropF), A = Box B.

Definition is_primeT (A : MPropF) : Type :=
                  is_atomicT A + is_boxedT A.

(* We can define some types of lists formulae. For example, we can define
   lists of formulae which contain only propositional variables, or
   boxed formulae, or a combination of both. These are useful to define
   the rules. *)

Definition is_Atomic (Γ : list (MPropF)) : Prop :=
    forall (A : MPropF), (In A Γ) -> ((exists (P : V), A = # P) \/ (A = Bot)).

Definition is_Boxed_list (Γ : list (MPropF)) : Prop :=
    forall (A : MPropF), (In A Γ) -> (exists (B : MPropF), A = Box B).

Definition is_Prime (Γ : list (MPropF)) : Prop :=
    forall (A : MPropF), (In A Γ) ->
    (exists (B : MPropF), A = Box B) \/ (exists (P : V), A = # P) \/ (A = Bot).

(* With these properties we can define restrictions of univ_gen_ext on
   formulae. *)

Definition atom_gen_ext := univ_gen_ext (fun x => (is_atomicT x)).

Definition nobox_gen_ext := univ_gen_ext (fun x => (is_boxedT x) -> False).

Definition prim_gen_ext := univ_gen_ext (fun x => (is_primeT x)).

(* Some lemmas about gen_ext. *)

Lemma nobox_gen_ext_injective : forall (l0 l1 l : list (MPropF)), (is_Boxed_list l0) -> (is_Boxed_list l1) ->
                                (nobox_gen_ext l0 l) -> (nobox_gen_ext l1 l) -> l1 = l0.
Proof.
intros l0 l1 l Hl0 Hl1 gen. generalize dependent l1.
induction gen.
- intros. inversion X. reflexivity.
- intros. inversion X.
  * subst. assert (l0 = l). apply IHgen. intro. intros. apply Hl0. apply in_cons. assumption.
    intro. intros. apply Hl1. apply in_cons. assumption. assumption. rewrite H. reflexivity.
  * subst. exfalso. apply H1. apply Hl0. apply in_eq.
- intros. apply IHgen. intro. intros. apply Hl0. assumption.
  intro. intros. apply Hl1. assumption. inversion X.
  subst. exfalso. apply p. apply Hl1. apply in_eq. subst. assumption.
Qed.

(* The next definitions help to define the combination of a list of boxed
   formulae and the unboxing of all the formulae in that list. *)

Definition unBox_formula (A : MPropF) : MPropF :=
  match A with
              | # P => # P
              | Bot => Bot
              | A → B => A → B
              | Box A => A
              end
.

Fixpoint XBoxed_list (Γ : list (MPropF)) : list (MPropF):=
  match Γ with
  | [ ] => [ ]
  | h :: t => (unBox_formula h :: h :: XBoxed_list t)
  end
.

Fixpoint top_boxes (l : list (MPropF)) : list (MPropF) :=
match l with
  | nil => nil
  | h :: t => match h with
                | Box A => (Box A) :: top_boxes t
                | _ => top_boxes t
              end
end.

(* Now that we have defined these, we can prove some properties about them. *)

Lemma XBox_app_distrib :
  forall (l1 l2: list (MPropF)), XBoxed_list (l1 ++ l2) = (XBoxed_list l1) ++ (XBoxed_list l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l with (l:=l2). simpl. reflexivity.
- intro l2. simpl. rewrite IHl1. reflexivity.
Qed.

Lemma subl_of_boxl_is_boxl {V : Set}:
  forall (l1 l2: list (MPropF)), (incl l1 l2) -> (is_Boxed_list l2) -> (is_Boxed_list l1).
Proof.
intros. unfold is_Boxed_list. intros. apply H in H1. apply H0 in H1.
destruct H1. exists x. assumption.
Qed.

Lemma tl_of_boxl_is_boxl {V : Set}:
  forall (h : MPropF) (t l : list (MPropF)) (H: l = h :: t),
         (is_Boxed_list l) -> (is_Boxed_list t).
Proof.
intros. unfold is_Boxed_list. intros. assert (Hyp: In A l).
rewrite H. simpl. right. apply H1. apply H0 in Hyp. destruct Hyp.
exists x. assumption.
Qed.

Lemma list_preserv_XBoxed_list : forall (l : list (MPropF)), incl l (XBoxed_list l).
Proof.
induction l.
- simpl. unfold incl. intros. inversion H.
- simpl. unfold incl. intros. inversion H.
  * subst. apply in_cons. apply in_eq.
  * apply in_cons. apply in_cons. apply IHl. assumption.
Qed.

Lemma is_box_is_in_boxed_list : forall l (A : MPropF), In A l -> is_Boxed_list l -> (exists B, Box B = A).
Proof.
induction l.
- intros. inversion H.
- intros. inversion H.
  + subst. unfold is_Boxed_list in H0. pose (H0 A).
    apply e in H. destruct H. exists x. symmetry. assumption.
  + apply IHl. assumption. unfold is_Boxed_list. intros. unfold is_Boxed_list in H0.
    pose (H0 A0). apply e. apply in_cons. assumption.
Qed.

Lemma top_boxes_distr_app : forall (l1 l2 : list (MPropF)),
      top_boxes (l1 ++ l2) = (top_boxes l1) ++ (top_boxes l2).
Proof.
induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct a ; try apply IHl1.
  simpl. rewrite IHl1. reflexivity.
Qed.

Lemma box_in_top_boxes : forall l1 l2 A, existsT2 l3 l4, top_boxes (l1 ++ Box A :: l2) = l3 ++ Box A :: l4.
Proof.
intros. exists (top_boxes l1). exists (top_boxes l2). rewrite top_boxes_distr_app. auto.
Qed.

Lemma is_Boxed_list_top_boxes : forall l, is_Boxed_list (top_boxes l).
Proof.
intros. induction l.
- simpl. intro. intros. inversion H.
- intro. destruct a.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. apply IHl in H. assumption.
  + simpl. intros. destruct H.
    * exists a. auto.
    * apply IHl. assumption.
Qed.

Lemma nobox_gen_ext_top_boxes : forall l, nobox_gen_ext (top_boxes l) l.
Proof.
induction l.
- simpl. apply univ_gen_ext_refl.
- destruct a.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_extra. intros. inversion X. inversion H. assumption.
  * simpl. apply univ_gen_ext_cons. assumption.
Qed.

(* We use a macro for sequents *)

Definition Seq := (prod (list MPropF) (list MPropF)).

(* ---------------------------------------------------------------------------------------------------------------------------------- *)

(* Finally, we can define the rules which constitute our calculi. We gather
   them in cacluli in a definition appearing later. *)

Inductive IdPRule : rlsT Seq :=
  | IdPRule_I : forall (P : V) (Γ0 Γ1 Δ0 Δ1 : list (MPropF)),
          IdPRule [] (pair (Γ0 ++ # P :: Γ1) (Δ0 ++ # P :: Δ1))
.

Inductive IdBRule : rlsT Seq :=
  | IdBRule_I : forall A Γ0 Γ1 Δ0 Δ1,
          IdBRule [] (pair (Γ0 ++ Box A :: Γ1) (Δ0 ++ Box A :: Δ1))
.

Inductive BotLRule : rlsT Seq :=
  | BotLRule_I : forall Γ0 Γ1 Δ,
          BotLRule [] (pair (Γ0 ++ (Bot) :: Γ1) Δ)
.

Inductive ImpRRule : rlsT Seq :=
  | ImpRRule_I : forall A B Γ0 Γ1 Δ0 Δ1,
          ImpRRule [(pair (Γ0 ++ A :: Γ1) (Δ0 ++ B :: Δ1))]
                    (pair (Γ0 ++ Γ1) (Δ0 ++ (A → B) :: Δ1))
.

Inductive ImpLRule : rlsT Seq :=
  | ImpLRule_I : forall A B Γ0 Γ1 Δ0 Δ1,
          ImpLRule ((pair (Γ0 ++ Γ1) (Δ0 ++ A :: Δ1)) ::
                     [(pair (Γ0 ++ B :: Γ1) (Δ0 ++ Δ1))])
                    (pair (Γ0 ++ (A → B) :: Γ1) (Δ0 ++ Δ1))
.

Inductive GLRRule : rlsT Seq :=
  | GLRRule_I : forall A BΓ Γ0 Δ0 Δ1,
          (is_Boxed_list BΓ) -> (* have MS of boxed formulae prem L*)
          (nobox_gen_ext BΓ Γ0) -> (* extend BΓ in Γ0, the L of the ccl *)
         GLRRule [(pair ((XBoxed_list BΓ) ++ [Box A]) [A])] (pair Γ0 (Δ0 ++ Box A :: Δ1))
.

(* At last we can define our calculus GLS and its proof-search version PSGLS. *)

Inductive GLS_rules : rlsT Seq :=
  | IdP : forall ps c, IdPRule ps c -> GLS_rules ps c
  | BotL : forall ps c, BotLRule ps c -> GLS_rules ps c
  | ImpR : forall ps c, ImpRRule ps c -> GLS_rules ps c
  | ImpL : forall ps c, ImpLRule ps c -> GLS_rules ps c
  | GLR : forall ps c, GLRRule ps c -> GLS_rules ps c
.

Inductive PSGLS_rules : rlsT Seq :=
  | PSIdP : forall ps c, IdPRule ps c -> PSGLS_rules ps c
  | PSIdB : forall ps c, IdBRule ps c -> PSGLS_rules ps c
  | PSBotL : forall ps c, BotLRule ps c -> PSGLS_rules ps c
  | PSImpR : forall ps c, ImpRRule ps c ->
                          PSGLS_rules ps c
  | PSImpL : forall ps c, ImpLRule ps c ->
                          PSGLS_rules ps c
  | PSGLR : forall ps c, (IdPRule [] c -> False) ->
                       (IdBRule [] c -> False) ->
                       (BotLRule [] c -> False) ->
                       GLRRule ps c ->
                         PSGLS_rules ps c
.

(* We can show that all identities are provable in GLS. *)

Lemma Id_all_form : forall (A : MPropF) l0 l1 l2 l3,
          derrec GLS_rules (fun _ => False) (l0 ++ A :: l1, l2 ++ A :: l3).
Proof.
assert (DersNilF: dersrec GLS_rules  (fun _ : rel (list (MPropF)) => False) []).
apply dersrec_nil.

induction A.
- intros. assert (IdPRule [] (l0 ++ # v :: l1, l2 ++ # v :: l3)). apply IdPRule_I. apply IdP in H.
  pose (derI (rules:=GLS_rules) (prems:=fun _ : rel (list (MPropF)) => False) (ps:=[])
  (l0 ++ # v :: l1, l2 ++ # v :: l3) H DersNilF). assumption.
- intros. assert (BotLRule [] (l0 ++ ⊥ :: l1, l2 ++ ⊥ :: l3)). apply BotLRule_I. apply BotL in H.
  pose (derI (rules:=GLS_rules) (prems:=fun _ : rel (list (MPropF)) => False) (ps:=[])
  (l0 ++ ⊥ :: l1, l2 ++ ⊥ :: l3) H DersNilF). assumption.
- intros. assert (ImpRRule [(l0 ++ A1 :: A1 → A2 :: l1, l2 ++ A2 :: l3)] (l0 ++ A1 → A2 :: l1, l2 ++ A1 → A2 :: l3)).
  apply ImpRRule_I. apply ImpR in H.
  assert (ImpLRule [((l0 ++ [A1]) ++ l1, l2 ++ A1 :: A2 :: l3); ((l0 ++ [A1]) ++ A2 :: l1, l2 ++ A2 :: l3)] ((l0 ++ [A1]) ++ A1 → A2 :: l1, l2 ++ A2 :: l3)).
  apply ImpLRule_I. repeat rewrite <- app_assoc in H0. simpl in H0. apply ImpL in H0.
  pose (IHA1 l0 l1 l2 (A2 :: l3)). pose (IHA2 (l0 ++ [A1]) l1 l2 l3). repeat rewrite <- app_assoc in d0. simpl in d0.
  pose (dlCons d0 DersNilF). pose (dlCons d d1).
  pose (derI (rules:=GLS_rules) (prems:=fun _ : rel (list (MPropF)) => False) (ps:=[(l0 ++ A1 :: l1, l2 ++ A1 :: A2 :: l3); (l0 ++ A1 :: A2 :: l1, l2 ++ A2 :: l3)])
  (l0 ++ A1 :: A1 → A2 :: l1, l2 ++ A2 :: l3) H0 d2). pose (dlCons d3 DersNilF).
  pose (derI (rules:=GLS_rules) (prems:=fun _ : rel (list (MPropF)) => False) (ps:=[(l0 ++ A1 :: A1 → A2 :: l1, l2 ++ A2 :: l3)])
  (l0 ++ A1 → A2 :: l1, l2 ++ A1 → A2 :: l3) H d4). assumption.
- intros. assert (GLRRule [(XBoxed_list (top_boxes (l0 ++ Box A :: l1)) ++ [Box A], [A])] (l0 ++ Box A :: l1, l2 ++ Box A :: l3)).
  apply GLRRule_I. apply is_Boxed_list_top_boxes. rewrite top_boxes_distr_app. simpl. apply univ_gen_ext_combine.
  apply nobox_gen_ext_top_boxes. apply univ_gen_ext_cons. apply nobox_gen_ext_top_boxes.
  rewrite top_boxes_distr_app in X. simpl in X. rewrite XBox_app_distrib in X. simpl in X.
  repeat rewrite <- app_assoc in X. simpl in X.
  pose (IHA (XBoxed_list (top_boxes l0)) (Box A :: XBoxed_list (top_boxes l1) ++ [Box A]) [] []).
  simpl in d. pose (dlCons d DersNilF). apply GLR in X.
  pose (derI (rules:=GLS_rules) (prems:=fun _ : rel (list (MPropF)) => False) (ps:=[(XBoxed_list (top_boxes l0) ++ A :: Box A :: XBoxed_list (top_boxes l1) ++ [Box A], [A])])
  (l0 ++ Box A :: l1, l2 ++ Box A :: l3) X d0). assumption.
Qed.

Definition GLS_prv s := derrec GLS_rules (fun _ => False) s.
Definition GLS_drv s := derrec GLS_rules (fun _ => True) s.
Definition PSGLS_prv s := derrec PSGLS_rules (fun _ => False) s.
Definition PSGLS_drv s := derrec PSGLS_rules (fun _ => True) s.

Section Subformulas.

Require Import Ensembles.

Fixpoint subform (A : MPropF) : Ensemble (MPropF) :=
match A with
 | # P => Singleton _ (# P)
 | Bot => Singleton _ (Bot)
 | Imp B C => Union _ (Singleton _ (Imp B C)) (Union _ (subform B) (subform C))
 | Box B =>  Union _ (Singleton _ (Box B)) (subform B)
end.

End Subformulas.


(***************************************************************************
* Preservation and Progress for mini-ML with structural polymorphism       *
* Jacques Garrigue, May 2008                                               *
***************************************************************************)

Set Implicit Arguments.
Require Import Lib_FinSet Lib_FinSetImpl Metatheory List ListSet Arith.
Require Import ML_SP_Inference_wf.
Require Import ML_SP_Eval.
Require Import Omega.

Section ListSet.
  Variable A : Type.
  Hypothesis eq_dec : forall x y:A, {x = y} + {x <> y}.

  Definition set_incl : forall (s1 s2 : list A),
    sumbool (incl s1 s2) (~incl s1 s2).
    intros.
    induction s1. left*.
    case_eq (set_mem eq_dec a s2); intros.
      destruct IHs1.
        left*; intros x Hx. simpl in Hx; destruct Hx.
        subst; apply* set_mem_correct1. apply* i.
      right*.
    right*. intro; elim (set_mem_complete1 eq_dec _ _ H).
    apply* H0.
  Defined.
End ListSet.

Module Cstr.
  Definition attr := nat.
  Definition eq_dec := eq_nat_dec.
  Inductive ksort := Ksum | Kprod | Kbot.
  Record cstr_impl : Set := C {
    cstr_sort : ksort;
    cstr_low  : list nat;
    cstr_high : option (list nat) }.
  Definition cstr := cstr_impl.
  Definition valid c :=
    cstr_sort c <> Kbot /\
    match cstr_high c with
    | None => True
    | Some h => incl (cstr_low c) h
    end.
  Definition le_sort s1 s2 :=
    s1 = Kbot \/ s1 = s2.
  Definition entails c1 c2 :=
    le_sort (cstr_sort c1) (cstr_sort c2) /\
    incl (cstr_low c2) (cstr_low c1) /\
    match cstr_high c2 with
    | None => True
    | Some h2 =>
      match cstr_high c1 with
      | None => False
      | Some h1 => incl h1 h2
      end
     end.
  Lemma entails_refl : forall c, entails c c.
  Proof.
    intros.
    split. right*.
    split. apply incl_refl.
    destruct* (cstr_high c).
  Qed.

  Lemma entails_trans : forall c1 c2 c3,
    entails c1 c2 -> entails c2 c3 -> entails c1 c3.
  Proof.
    introv. intros [CS1 [CL1 CH1]] [CS2 [CL2 CH2]].
    split.
      unfold le_sort.
      destruct* CS1.
      rewrite H. destruct* CS2.
    split. apply* incl_tran.
    clear CL1 CL2.
    destruct* (cstr_high c3).
    destruct* (cstr_high c2).
    destruct* (cstr_high c1).
  Qed.

  Definition unique c v := set_mem eq_nat_dec v (cstr_low c).

  Definition sort_lub s1 s2 :=
    match s1, s2 with
    | Ksum, Ksum => Ksum
    | Kprod, Kprod => Kprod
    | _, _ => Kbot
    end.

  Definition lub c1 c2 :=
    C (sort_lub (cstr_sort c1) (cstr_sort c2))
    (set_union eq_nat_dec (cstr_low c1) (cstr_low c2))
    (match cstr_high c1, cstr_high c2 with
     | None, h => h
     | h, None => h
     | Some s1, Some s2 => Some (set_inter eq_nat_dec s1 s2)
     end).

  Lemma ksort_dec : forall s, {s=Kbot} + {s<>Kbot}.
    intro; destruct* s; right*; intro; discriminate.
  Qed.

  Hint Resolve incl_tran : core.
  Lemma entails_lub : forall c1 c2 c,
    (entails c c1 /\ entails c c2) <-> entails c (lub c1 c2).
  Proof.
    unfold entails, lub; simpl; split; intros.
      intuition.
          destruct (ksort_dec (cstr_sort c)).
            rewrite e; left*.
          destruct* H.
          destruct* H0.
          rewrite <- H, <- H0.
          right*; destruct* (cstr_sort c).
        intros x Hx; destruct* (set_union_elim _ _ _ _ Hx).
      case_rewrite R1 (cstr_high c1);
      case_rewrite R2 (cstr_high c2);
      try case_rewrite R3 (cstr_high c); intuition.
      intros x Hx; apply set_inter_intro. apply* H4. apply* H5.
    destruct H as [HS [HL HH]].
    split; split; try split;
      try (intros x Hx; apply HL;
           solve [ apply* set_union_intro2 | apply* set_union_intro1 ]);
      try solve [
        case_rewrite R1 (cstr_high c1);
        case_rewrite R2 (cstr_high c2);
        try case_rewrite R3 (cstr_high c); intuition;
        intros x Hx; destruct* (set_inter_elim _ _ _ _ (HH _ Hx))];
      clear -HS; destruct HS; try solve [left*];
      rewrite H;
      unfold le_sort; destruct (cstr_sort c1); destruct* (cstr_sort c2).
  Qed.

  Definition valid_dec : forall c, sumbool (valid c) (~valid c).
    intros.
    unfold valid.
    destruct* (ksort_dec (cstr_sort c)).
    case_eq (cstr_high c); intros.
      destruct (set_incl eq_nat_dec (cstr_low c) l). left*.
      right*.
    auto.
  Defined.

  Lemma entails_unique : forall c1 c2 v,
    entails c1 c2 -> unique c2 v = true -> unique c1 v = true.
  Proof.
    unfold entails, unique.
    intros.
    destruct H as [_ [H _]].
    apply set_mem_correct2.
    apply H.
    apply* set_mem_correct1.
  Qed.

  Lemma entails_valid : forall c1 c2,
    entails c1 c2 -> valid c1 -> valid c2.
  Proof.
    unfold entails, valid.
    intros.
    destruct H as [HS [HL HH]]; destruct H0.
    destruct* HS.
    rewrite <- H1. split2*.
    case_rewrite R1 (cstr_high c1); case_rewrite R2 (cstr_high c2);
    auto*.
  Qed.
End Cstr.

Section NoDup.
  Fixpoint nodup (l:list nat) :=
    match l with
    | nil => nil
    | v :: l' =>
      if In_dec eq_nat_dec v l' then nodup l' else v :: nodup l'
    end.
  Lemma nodup_elts : forall a l, In a l <-> In a (nodup l).
  Proof.
    induction l; split2*; simpl; intro; destruct IHl.
      destruct H. subst.
        destruct* (In_dec eq_nat_dec a l).
      destruct* (In_dec eq_nat_dec a0 l).
    destruct* (In_dec eq_nat_dec a0 l).
    simpl in H; destruct* H.
  Qed.
  Lemma NoDup_nodup : forall l, NoDup (nodup l).
  Proof.
    induction l; simpl. constructor.
    destruct* (In_dec eq_nat_dec a l).
    constructor; auto.
    intro Ha. elim n. apply (proj2 (nodup_elts _ _) Ha).
  Qed.
End NoDup.

Module Const.
  Inductive ops : Set :=
    | tag     : Cstr.attr -> ops
    | matches : forall (l:list Cstr.attr), NoDup l -> ops
    | record  : forall (l:list Cstr.attr), NoDup l -> ops
    | sub     : Cstr.attr -> ops
    | recf    : ops.
  Definition const := ops.
  Definition arity op :=
    match op with
    | tag _       => 1
    | @matches l _ => length l
    | @record l _  => length l
    | sub _       => 0
    | recf        => 1
    end.
End Const.

Module Infer := MkInfer(Cstr)(Const).
Import Infer.
Import Unify.MyEval.
(* Module MyEval := MkEval(Cstr)(Const).
Import MyEval. *)
Import Rename.Sound.Infra.
Import Defs.

Lemma list_snd_combine : forall (A B:Set) (l1:list A) (l2:list B),
  length l1 = length l2 ->
  list_snd (combine l1 l2) = l2.
Proof.
  induction l1; destruct l2; intros; try discriminate. reflexivity.
  inversions H.
  simpl. rewrite* (IHl1 l2).
Qed.

Module Delta.
  Definition matches_arg n := typ_arrow (typ_bvar n) (typ_bvar 1).

  Lemma valid_tag : forall s t,
    s <> Cstr.Kbot -> Cstr.valid (Cstr.C s (t::nil) None).
  Proof.
    intros. split2*. compute. auto.
  Qed.

  Lemma ksum : Cstr.Ksum <> Cstr.Kbot.
    intro; discriminate.
  Qed.

  Lemma kprod : Cstr.Kprod <> Cstr.Kbot.
    intro; discriminate.
  Qed.

  Lemma coherent_tag : forall s t,
    coherent (Cstr.C s (t::nil) None) ((t, typ_bvar 0) :: nil).
  Proof.
    intros s t x; intros.
    destruct H0; destruct H1; try contradiction.
    inversions H0. inversions* H1.
  Qed.

  Lemma valid_matches : forall s l,
    s <> Cstr.Kbot -> Cstr.valid (Cstr.C s nil (Some l)).
  Proof.
    intros; split2*. simpl*.
  Qed.

  Lemma coherent_matches : forall s n l,
    NoDup l ->
    coherent (Cstr.C s nil (Some l))
      (combine l (map typ_bvar (seq n (length l)))).
  Proof.
    intros; intro; intros.
    clear H0; revert H1 H2; gen n.
    induction H; simpl; intros. elim H1.
    destruct H1. inversions H1.
      destruct H2. inversions* H2.
      elim (H (in_combine_l _ _ _ _ H2)).
    destruct H2. inversions H2.
      elim (H (in_combine_l _ _ _ _ H1)).
    apply* (IHNoDup (S n)).
  Qed.

  Definition type (op:Const.const) :=
    match op with
    | Const.tag t =>
      Sch (typ_arrow (typ_bvar 0) (typ_bvar 1))
        (None :: Some (Kind (valid_tag t ksum) (@coherent_tag _ t)) :: nil)
    | @Const.matches l ND =>
      Sch (fold_right typ_arrow (typ_arrow (typ_bvar 0) (typ_bvar 1))
             (map matches_arg (seq 2 (length l))))
        (Some (Kind (@valid_matches _ l ksum) (coherent_matches 2 ND)) ::
         map (fun _ => None) (seq 0 (S (length l))))
    | @Const.record l ND =>
      Sch (fold_right typ_arrow (typ_bvar 0) (map typ_bvar (seq 1 (length l))))
        (Some (Kind (@valid_matches _ l kprod) (coherent_matches 1 ND)) ::
         map (fun _ => None) (seq 0 (length l)))
    | Const.sub f =>
      Sch (typ_arrow (typ_bvar 1) (typ_bvar 0))
        (None :: Some (Kind (valid_tag f kprod) (@coherent_tag _ f)) :: nil)
    | Const.recf =>
      let T := typ_arrow (typ_bvar 0) (typ_bvar 1) in
      Sch (typ_arrow (typ_arrow T T) T) (None :: None :: nil)
    end.

  Definition trm_default := trm_abs trm_def.

  Fixpoint record_args (t : trm) tl {struct t} : list nat * list trm :=
    match t with
    | trm_app t1 t2 => record_args t1 (t2 :: tl)
    | trm_cst (@Const.record l _) => (l, tl)
    | _ => (nil, nil)
    end.

  Lemma record_args_ok : forall l nd tl tl',
    record_args (const_app (@Const.record l nd) tl) tl' = (l, tl++tl').
  Proof.
    induction tl using rev_ind; simpl; intros. auto.
    rewrite const_app_app, app_ass; simpl.
    apply* IHtl.
  Qed.

  Definition is_record c :=
    match c with
    | Const.record _ => true
    | _ => false
    end.

  Lemma record_args_other : forall c tl tl',
    is_record c = false -> record_args (const_app c tl) tl' = (nil, nil).
  Proof.
    induction tl using rev_ind; simpl; intros. destruct* c. discriminate.
    rewrite const_app_app. simpl.
    apply* IHtl.
  Qed.

  Definition reduce c tl (vl:list_for_n value (S(Const.arity c)) tl) :=
    match c with
    | Const.tag _ => trm_default
    | @Const.matches l nd =>
      match nth (length l) tl trm_def with
      | trm_app (trm_cst (Const.tag t)) t1 =>
        match index eq_nat_dec 0 t l with
        | Some i => trm_app (nth i tl trm_def) t1
        | None => trm_default
        end
      | _ => trm_default
      end
    | Const.record _ => trm_default
    | Const.sub f =>
      match tl with
      | nil    => trm_default
      | t :: _ =>
        let (l, fl) := record_args t nil in
        match index eq_nat_dec 0 f l with
        | Some i => nth i fl trm_default
        | None => trm_default
        end
      end
    | Const.recf =>
      match tl with
      | f :: a :: _ => trm_app (trm_app f (trm_app (trm_cst Const.recf) f)) a
      | _ => trm_default
      end
    end.

  Lemma term_default : term trm_default.
  Proof.
    unfold trm_default, trm_def.
    apply (@term_abs {}).
    intros. unfold trm_open; simpl. auto.
  Qed.
  Hint Resolve term_default : core.

  Lemma value_term : forall e,
    value e -> term e.
  Proof.
    intros. destruct H. induction H; auto.
  Qed.
  Hint Resolve value_term : core.

  Lemma term : forall c tl vl,
    term (@reduce c tl vl).
  Proof.
    intros.
    case vl; clear vl; intros.
    destruct c; simpl in *; auto.
    (* matches *)
    assert (length l0 < S (length l0)) by auto.
    rewrite e in H.
    case_eq (nth (length l0) tl trm_def); intros; auto.
    destruct* t.
    destruct* c.
    case_eq (index eq_nat_dec 0 a l0); intros; auto.
    apply term_app.
      destruct (index_ok _ 0 _ _ H1).
      apply value_term.
      apply* (list_forall_out l).
      apply* nth_In.
      unfold Cstr.attr in *; omega.
    assert (term (nth (length l0) tl trm_def)).
      apply value_term.
      apply* (list_forall_out l).
      apply* nth_In.
    rewrite H0 in H2.
    inversion* H2.
    (* sub *)
    destruct* tl.
    case_eq (record_args t nil); intros.
    assert (list_forall value l1).
      inversions l.
      clear -H H3.
      assert (list_forall value nil) by auto.
      revert H H0. generalize (@nil trm).
      destruct H3.
      induction H; simpl; intros; try solve [inversions* H0].
        destruct c; inversions* H.
      apply* (IHvalu1 _ H1).
      constructor; auto.
      exists* n2.
    clear -H0.
    destruct* (index eq_nat_dec 0 a l0).
    gen n; induction H0; simpl; intros; auto; destruct* n.
    (* recf *)
    inversions* l; clear l.
    inversions* H; clear H.
  Qed.

  Lemma closed : forall c, sch_fv (Delta.type c) = {}.
  Proof.
    intros.
    induction c; unfold sch_fv; simpl.
    (* tag *)
    unfold kind_fv; simpl.
    repeat rewrite union_empty_l. auto.
    (* matches *)
    set (x := 1). unfold x at 1.
    unfold kind_fv_list, kind_fv; simpl.
    generalize x; clear.
    induction l; simpl in *; intros;
      repeat rewrite union_empty_l.
      auto.
    use (IHl (S x)); clear IHl. rewrite union_empty_l in H. auto.
    (* record *)
    set (x := 0). unfold x at 1.
    unfold kind_fv_list, kind_fv; simpl.
    generalize x; clear.
    induction l; simpl in *; intros;
      repeat rewrite union_empty_l.
      auto.
    use (IHl (S x)).
    (* sub *)
    unfold kind_fv; simpl.
    repeat rewrite union_empty_l. auto.
    (* recf *)
    simpl.
    repeat rewrite union_empty_l. auto.
  Qed.

  Lemma type_nth_typ_vars : forall n Xs,
    n < length Xs -> Defs.type (nth n (typ_fvars Xs) typ_def).
  Proof.
    induction n; destruct Xs; simpl; intros; try (elimtype False; omega).
      auto.
    apply IHn; omega.
  Qed.

  Hint Extern 1 (Defs.type (nth _ (typ_fvars _) typ_def)) =>
    solve [apply type_nth_typ_vars; omega] : core.

  Lemma scheme : forall c, scheme (Delta.type c).
  Proof.
    intros. intro; intros.
    unfold typ_open_vars.
    destruct c; simpl in *.
    (* tag *)
    do 3 (destruct Xs; try discriminate).
    simpl.
    split2*.
    unfold All_kind_types.
    repeat (constructor; simpl*).
    (* matches *)
    rewrite map_length, seq_length in H.
    split.
      do 2 (destruct Xs; try discriminate).
      inversion H; clear H.
      replace Xs with (nil ++ Xs) by simpl*.
      set (Xs0 := nil(A:=var)).
      replace 2 with (S (S (length Xs0))) by simpl*.
      gen Xs; generalize Xs0; induction n; simpl; intros. auto.
      destruct Xs; try discriminate.
      constructor.
        unfold typ_fvars.
        rewrite map_app.
        rewrite app_nth2 by (rewrite map_length; omega).
        rewrite map_length.
        replace (length Xs1 - length Xs1) with 0 by omega.
        simpl*.
      replace (v1 :: Xs) with ((v1 :: nil) ++ Xs) by simpl*.
      rewrite <- app_ass.
      simpl in IHn.
      replace (S (length Xs1)) with (length (Xs1 ++ v1 :: nil))
        by (rewrite app_length; simpl; omega).
      apply* IHn.
    unfold All_kind_types.
    repeat (constructor; auto).
      induction (seq 1 (length l)); simpl; try constructor; simpl*.
    simpl.
    assert (length Xs >= 2 + length l) by omega.
    clear H; revert H0.
    generalize 2; induction n; simpl; intros. auto.
    constructor. apply* IHn. omega.
    simpl*.
    (* record *)
    rewrite map_length, seq_length in H.
    assert (1 + length l = length Xs) by omega. clear H.
    split.
      assert (0 < 1) by omega.
      revert H0 H.
      generalize 1 Xs. clear.
      induction (length l); simpl; intros. auto.
      constructor. auto.
      apply* IHn.
    repeat (constructor; auto).
      clear; generalize 0; induction (length l); simpl*.
    unfold All_kind_types. simpl.
    rewrite list_snd_combine by (rewrite map_length, seq_length; auto).
    revert H0; generalize 1.
    unfold Cstr.attr in *.
    clear; induction (length l); simpl; intros. auto.
    constructor. apply* IHn.
    simpl*.
    (* sub *)
    split. simpl*.
    repeat (constructor; auto).
    apply type_nth_typ_vars; omega.
    unfold All_kind_types. simpl.
    repeat (constructor; simpl*).
  Qed.
End Delta.

Module Infer2 := Infer.Mk2(Delta).
Import Infer2.MyEval2.
(* Module MyEval2 := Mk2(Delta).
Import MyEval2. *)
Import Rename2.Sound2.
Import JudgInfra.
Import Judge.

Module SndHyp.
  Lemma fold_arrow_eq : forall T1 TL1 T2 TL2 Us,
    typ_open (fold_right typ_arrow T1 TL1) Us = fold_right typ_arrow T2 TL2 ->
    length TL1 = length TL2 ->
    typ_open T1 Us = T2 /\
    list_forall2 (fun U1 U2 => typ_open U1 Us = U2) TL1 TL2.
  Proof.
    induction TL1; intros; destruct* TL2; simpl in *; try discriminate; auto.
    inversions H.
    destruct* (IHTL1 T2 TL2 Us).
  Qed.

  Lemma gc_lower_false : forall gc, gc_lower (false, gc) = (false, gc).
  Proof. destruct gc; simpl*. Qed.

  Lemma fold_app_inv : forall K E gc t tl T,
    K ; E |(false,gc)|= fold_left trm_app tl t ~: T ->
    exists TL,
      K ; E |(false,gc)|= t ~: fold_right typ_arrow T TL /\
      list_forall2 (typing (false,gc) K E) tl TL.
  Proof.
    induction tl using rev_ind; simpl; intros.
      exists* (nil(A:=typ)).
    rewrite fold_left_app in *; simpl in *.
    inversions H; try discriminate. rewrite gc_lower_false in *.
    destruct (IHtl (typ_arrow S T) H4).
    exists (x0 ++ S :: nil).
    rewrite fold_right_app; simpl.
    split2*.
  Qed.

  Lemma map_nth : forall (A B:Set) d1 d2 (f:A->B) k l,
    k < length l -> nth k (map f l) d1 = f (nth k l d2).
  Proof.
    induction k; intros; destruct l; simpl in *; auto; try elim (lt_n_O _ H).
    apply IHk.
    apply* lt_S_n.
  Qed.

  Hint Rewrite combine_length combine_nth : list.

  Definition delta_typed_cst c :=
    forall tl vl K E gc T TL,
    K; E | (false, gc) |= trm_cst c ~: fold_right typ_arrow T TL ->
    list_forall2 (typing (false, gc) K E) tl TL ->
    K ; E |(false,gc)|= @Delta.reduce c tl vl ~: T.

  Lemma delta_typed_tag : forall v, delta_typed_cst (Const.tag v).
  Proof.
    intros; intro; introv TypC TypA.
    elimtype False.
    destruct vl as [Hv _].
    inversions TypC; try discriminate. clear TypC H4.
    destruct* tl; try destruct* tl; try destruct* tl; try discriminate.
    inversions TypA; clear TypA.
    inversions H6; clear H6.
    inversions H8; clear H8.
    unfold sch_open in H0.
    simpl in H0.
    inversions H0. clear H0.
    destruct H5 as [_ WK]. simpl in WK.
    inversions WK; clear WK.
    inversions H7; clear H7.
    inversions H5; clear H5.
    discriminate.
  Qed.

  Lemma typing_value_inv : forall gc K E t T n,
    K;E |(false,gc)|= t ~: T -> valu n t ->
    (exists t1, t = trm_abs t1) \/
    (exists c, exists vl, t = const_app c vl /\
      n <= Const.arity c /\ list_for_n value (Const.arity c - n) vl).
  Proof.
    intros.
    gen K E T. induction H0; intros.
        left*.
      right*; exists c; exists (@nil trm).
      split2*.
      rewrite <- minus_n_n. split2*. split2*.
    clear IHvalu2.
    inversions H; clear H; try discriminate.
    rewrite gc_lower_false in *.
    destruct (IHvalu1 _ _ _ H4); clear IHvalu1.
      destruct H. subst. inversion H0_.
    destruct H as [c [vl [HE [HC HV]]]].
    subst.
    right*; exists c; exists (vl ++ t2 :: nil).
    rewrite const_app_app. split2*.
    split. omega.
    destruct HV. split2*.
    assert (value t2) by exists* n2.
    apply* list_forall_app.
  Qed.

  Lemma value_fvar_is_const : forall K E gc t x k,
    K; E |(false,gc)|= t ~: typ_fvar x ->
    binds x (Some k) K ->
    value t ->
    match Cstr.cstr_sort (kind_cstr k) with
    | Cstr.Ksum =>
      exists v, exists t2, t = trm_app (trm_cst (Const.tag v)) t2
    | Cstr.Kprod =>
      exists l, exists nd, exists tl,
      t = const_app (@Const.record l nd) tl /\ length tl = length l
    | Cstr.Kbot => True
    end.
  Proof.
    introv Typ B HV.
    destruct HV as [i vi].
    destruct (typing_value_inv Typ vi).
      destruct H. subst. inversions Typ. discriminate.
    destruct H as [c [vl [HE [HA Hvl]]]].
    subst.
    destruct (fold_app_inv _ _ Typ) as [TL [Typ0 TypA]]; clear Typ.
    inversions Typ0; clear Typ0; try discriminate.
    unfold sch_open in H0. destruct H5. clear H.
    destruct c; simpl in *.
    (* tag *)
    destruct TL; try discriminate.
    inversions H0; clear H0.
    inversions H2; clear H2.
    inversions H7; clear H7.
    simpl in H5.
    inversions H2; clear H2.
    destruct TL; try discriminate.
    inversions H9; clear H9.
    puts (binds_func H0 B). inversions H; clear H H0.
    puts (proj1 (proj1 H7)). simpl in H.
    destruct H; rewrite* H.
    (* Ksum *)
    inversions TypA; clear TypA; try discriminate.
    inversions H9; clear H9; try discriminate.
    esplit; esplit; reflexivity.
    (* matches *)
    case_eq (cut (length TL) (map Delta.matches_arg (seq 2 (length l))));
      introv R1.
    assert (length TL <= length (map Delta.matches_arg (seq 2 (length l)))).
      rewrite map_length, seq_length.
      rewrite <- (list_forall2_length TypA). rewrite <- (proj1 Hvl).
      omega.
    destruct (cut_ok _ H R1). clear H. rewrite H5 in H0.
    rewrite fold_right_app in H0.
    destruct* (fold_arrow_eq _ _ _ _ _ H0).
    destruct l1; discriminate.
    (* record *)
    case_eq (cut (length TL) (map typ_bvar (seq 1 (length l)))); introv R1.
    assert (length TL <= length (map typ_bvar (seq 1 (length l)))).
      rewrite map_length, seq_length.
      rewrite <- (list_forall2_length TypA). rewrite <- (proj1 Hvl).
      omega.
    destruct (cut_ok _ H R1). clear H. rewrite H5 in H0.
    rewrite fold_right_app in H0.
    destruct* (fold_arrow_eq _ _ _ _ _ H0).
    destruct l1; try discriminate.
    inversions H2; clear H2. simpl in H; subst.
    inversions H9; clear H9.
    puts (binds_func H8 B). inversions H; clear H H8.
    puts (proj1 (proj1 H10)). simpl in H.
    destruct H; rewrite~ H.
    (* Kprod *)
    rewrite <- app_nil_end in H5.
    exists l. exists n. exists vl.
    split2*. subst. length_hyps. rewrite seq_length in *. omega.
    (* sub *)
    destruct Hvl.
    inversions TypA; try discriminate.
    (* recf *)
    destruct Hvl.
    inversions TypA; clear TypA; try discriminate.
    inversions H0; clear H0.
    inversions H6; clear H6; try discriminate.
    destruct i; discriminate.
  Qed.

  Lemma fold_right_app_end : forall T1 T2 TL,
    fold_right typ_arrow (typ_arrow T1 T2) TL =
    fold_right typ_arrow T2 (TL ++ T1 :: nil).
  Proof.
    intros; rewrite* fold_right_app.
  Qed.

  Lemma in_matches_types : forall i l TL Us,
    i < length l ->
    In (nth i l 0, nth i Us typ_def)
    (map_snd (fun T => typ_open T (TL ++ Us))
      (combine l (map typ_bvar (seq (length TL) (length l))))).
  Proof.
    intros.
    remember (0 + i) as m.
    pattern i at 2.
    replace i with (0+i) by reflexivity. rewrite <- Heqm.
    generalize 0 at 1. intro d.
    replace (length TL) with (0 + length TL) by auto.
    gen i; generalize 0; induction l; intros.
    simpl in H; elimtype False; omega.
    destruct i; simpl.
      replace m with n; auto. rewrite app_nth2.
      replace (n + length TL - length TL) with n by omega.
      auto.  omega. omega.
    right*.
    apply (IHl (S n) i). simpl in H. omega.
    omega.
  Qed.

  Lemma delta_typed_matches : forall l n, delta_typed_cst (@Const.matches l n).
  Proof.
    intros; intro; introv Typ0 TypA.
    inversions Typ0; try discriminate; clear Typ0.
    clear H1 H4.
    unfold sch_open in H0; simpl in H0.
    rewrite fold_right_app_end in H0.
    poses Hlen (proj1 vl). simpl in Hlen.
    destruct (fold_arrow_eq _ _ _ _ _ H0) as [HT HA]; clear H0.
      autorewrite with list. simpl*.
    forward~ (list_forall2_nth trm_def typ_def TypA (n:=length l)) as Typn.
      rewrite* <- Hlen.
    forward~ (list_forall2_nth typ_def typ_def HA (n:=length l)) as Eqn.
      autorewrite with list. simpl. omega.
    rewrite app_nth2 in Eqn by (rewrite map_length, seq_length; auto).
    autorewrite with list in Eqn.
    rewrite <- minus_n_n in Eqn.
    simpl in Eqn.
    destruct H5 as [_ WUs]. simpl in WUs.
    inversions WUs; clear WUs.
    inversions H3; clear H3.
    simpl in Eqn.
    inversions H1; clear H1 H2.
    rewrite <- H6 in *; clear H6.
    puts (value_fvar_is_const Typn H0).
    assert (Cstr.cstr_sort (kind_cstr k') = Cstr.Ksum).
      destruct H4 as [[HE _] _]. simpl in HE. destruct* HE.
      clear -H1. destruct k'.
      elimtype False. simpl in H1.
      destruct* kind_valid0.
    rewrite H1 in H; clear H1.
    destruct H as [v [t2 Hv]].
      apply* (list_forall_out (proj2 vl)). apply* nth_In. omega.
    simpl.
    rewrite Hv in *; clear Hv.
    inversions Typn; clear Typn; try discriminate.
    rewrite gc_lower_false in *.
    inversions H6; clear H6; try discriminate.
    destruct H11.
    destruct H as [H _]. simpl in H.
    do 3 (destruct Us; try discriminate). clear H.
    simpl in *.
    inversions H1; clear H1 H9 H10.
    inversions H12; clear H12 H7.
    inversions H3; clear H3 H9.
    puts (binds_func H6 H0).
    inversions H; clear H H0 H6 H5.
    destruct H4; destruct H7. destruct H; destruct H1.
    destruct k' as [[ks kcl kch] kv kr kh]; simpl in *.
    destruct* kch.
    assert (Hvt: In (v,t) kr) by auto*. clear H2 H1.
    unfold Cstr.valid in kv; simpl in kv.
    assert (Hvl: In v l) by auto*.
    case_eq (index eq_nat_dec 0 v l); introv R2;
      try elim (index_none_notin _ _ _ _ R2 Hvl).
    destruct (index_ok _ 0 _ _ R2).
    unfold Cstr.attr in *.
    forward~ (list_forall2_nth trm_def typ_def TypA (n:=n0)) as Typv.
      omega.
    forward~ (list_forall2_nth typ_def typ_def HA (n:=n0)) as Eqv.
      rewrite (list_forall2_length HA).
      rewrite <- (list_forall2_length TypA).
      omega.
    rewrite <- Eqv in Typv; clear HA TypA Eqv.
    rewrite app_nth1 in Typv by (rewrite map_length, seq_length; auto).
    rewrite (map_nth _ 0) in Typv by rewrite* seq_length.
    rewrite seq_nth in Typv by auto.
    simpl in Typv.
    rewrite (kh v (nth n0 lb0 typ_def) t) in Typv; auto.
        eapply typing_app; rewrite* gc_lower_false.
      unfold Cstr.unique. simpl. apply* set_mem_correct2.
      unfold set_In; auto*.
    rewrite <- H2; apply H0.
    apply* (@in_matches_types n0 l (typ_fvar x :: b0 :: nil) lb0).
  Qed.

  Lemma delta_typed_record : forall l n, delta_typed_cst (@Const.record l n).
  Proof.
    intros; intro; introv Typ0 TypA.
    elimtype False.
    inversions Typ0; try discriminate.
    puts (proj1 vl).
    simpl in H.
    unfold sch_open in H0. simpl in H0.
    destruct TL using rev_ind. inversion TypA. subst; discriminate.
    clear IHTL. rewrite fold_right_app in H0.
    puts (fold_arrow_eq _ _ _ _ _ H0).
    rewrite map_length, seq_length in H2.
    puts (list_forall2_length TypA). rewrite app_length in H3; simpl in H3.
    destruct H2. omega.
    destruct H5.
    simpl in H7. inversions H7; clear H7.
    inversions H10; clear H10. discriminate.
  Qed.

  Lemma delta_typed_sub : forall a, delta_typed_cst (Const.sub a).
  Proof.
    intros; intro; introv Typ0 TypA.
    inversions Typ0; clear Typ0; try discriminate.
    puts (proj1 vl). simpl in H.
    do 2 (destruct tl; try discriminate).
    inversions TypA; clear TypA H H1 H4.
    inversions H8; clear H8.
    unfold sch_open  in H0; simpl in H0.
    destruct H5.
    inversions H1; clear H1.
    inversions H7; clear H7 H4.
    inversions H8; clear H8; simpl in *.
    inversions H0; clear H0 H.
    inversions H3; clear H3.
    puts (value_fvar_is_const H6 H0).
    assert (Cstr.cstr_sort (kind_cstr k') = Cstr.Kprod).
      destruct H2 as [[HE _] _]. simpl in HE. destruct* HE.
      clear -H1. destruct k'.
      elimtype False. simpl in H1.
      destruct* kind_valid0.
    rewrite H1 in H; clear H1.
    destruct* H as [l' [nd [tl [HE HL]]]].
      destruct vl. inversions* H1.
    clear vl; subst.
    rewrite Delta.record_args_ok. rewrite <- app_nil_end.
    destruct (fold_app_inv _ _ H6) as [TL [Typ0 TypA]]; clear H6.
    inversions Typ0; clear Typ0; try discriminate.
    unfold sch_open in H1; simpl in H1; clear H3 H6.
    destruct (fold_arrow_eq _ _ _ _ _ H1) as [Hx HTL].
      rewrite map_length, seq_length. auto.
    clear H1; destruct H7 as [_ WS].
    simpl in WS.
    inversions WS; clear WS.
    simpl in Hx; subst.
    inversions H3; clear H5 H3.
    puts (binds_func H6 H0).
    inversions H; clear H H0 H6.
    puts (proj33 (proj1 H7)).
    puts (proj32 (proj1 H2)).
    destruct k' as [[ks kl km] kv kr kh]; simpl in *.
    destruct* km.
    puts (proj2 kv). simpl in H1.
    assert (In a l') by auto. clear H H1.
    case_eq (index eq_nat_dec 0 a l'); introv R1;
      [|elim (index_none_notin _ _ _ _ R1 H3)].
    destruct (index_ok _ 0  _ _ R1).
    forward~ (list_forall2_nth Delta.trm_default typ_def TypA (n:=n)) as Typ.
      rewrite* HL.
    rewrite (kh a T (nth n TL typ_def)). auto.
        unfold Cstr.unique. simpl. apply* set_mem_correct2. apply* H0.
      apply* (proj2 H2).
    forward~ (list_forall2_nth typ_def typ_def HTL (n:=n)) as Eqv.
      rewrite map_length, seq_length; auto.
    rewrite <- Eqv; clear Eqv.
    rewrite (map_nth _ 0) by rewrite* seq_length.
    rewrite* seq_nth.
    apply (proj2 H7).
    simpl.
    rewrite <- H1.
    apply* (@in_matches_types n l' (typ_fvar x::nil) lb).
  Qed.

  Lemma delta_typed : forall c tl vl K E gc T,
    K ; E |(false,gc)|= const_app c tl ~: T ->
    K ; E |(false,gc)|= @Delta.reduce c tl vl ~: T.
  Proof.
    intros.
    destruct (fold_app_inv _ _ H) as [TL [Typ0 TypA]]; clear H.
    destruct c.
    apply* delta_typed_tag.
    apply* delta_typed_matches.
    apply* delta_typed_record.
    apply* delta_typed_sub.
    (* recf *)
    puts (proj1 vl).
    inversions TypA; clear TypA; try discriminate.
    inversions H1; clear H1; try discriminate.
    inversions H3; clear H3; try discriminate.
    simpl in *.
    inversions Typ0; try discriminate.
    eapply typing_app; rewrite* gc_lower_false.
    eapply typing_app; rewrite* gc_lower_false.
    eapply typing_app; rewrite* gc_lower_false.
  Qed.

  Definition reduce_clos c (cl : list clos) :=
    match c with
    | Const.tag _ | Const.record _ => (clos_def, nil)
    | @Const.matches l nd =>
      match nth (length l) cl clos_def with
      | clos_const (Const.tag t) (cl1 :: nil) =>
        match index eq_nat_dec 0 t l with
        | Some i => (nth i cl clos_def, cl1 :: nil)
        | None => (clos_def, nil)
        end
      | _ => (clos_def, nil)
      end
    | Const.sub f =>
      match cl with
      | clos_const (@Const.record l nd) cls :: _ =>
        match index eq_nat_dec 0 f l with
        | Some i => (nth i cls clos_def, nil)
        | None => (clos_def, nil)
        end
      | _ => (clos_def, nil)
      end
    | Const.recf =>
      match cl with
      | cl1 :: rem => (cl1, clos_const Const.recf (cl1::nil) :: rem)
      | _ => (clos_def, nil)
      end
    end.

  Lemma reduce_clos_sound :
    forall c cls (CLS : list_for_n clos_ok (S(Const.arity c)) cls) K E T,
      K; E |Gc|= const_app c (List.map clos2trm cls) ~: T ->
      let (cl', cls') := reduce_clos c cls in
      clos_ok cl' /\ list_forall clos_ok cls' /\
      fold_left trm_app (List.map clos2trm cls') (clos2trm cl') =
      Delta.reduce c (list_for_n_value CLS).
  Proof.
    intros.
    clear H. (* Simpler to prove it independently of typability *)
    unfold Delta.reduce.
    destruct c; try solve [simpl*].
    (* matches *)
    poses Hlen (proj1 CLS). simpl in Hlen.
    rewrite (map_nth _ clos_def); try omega.
    unfold reduce_clos.
    case_eq (nth (length l) cls clos_def); introv R1; simpl*.
    unfold const_app.
    destruct l0; simpl. destruct* c.
    destruct l0 using rev_ind; simpl.
      destruct* c.
      case_eq (index eq_nat_dec 0 a l); introv R2; simpl*.
      destruct (index_ok _ 0 _ _ R2).
      unfold Cstr.attr in *.
      rewrite (map_nth _ clos_def); try omega.
      intros.
      split.
        apply (list_forall_out (proj2 CLS)).
        apply* nth_In.
        omega.
      assert (Htag: clos_ok (nth (length l) cls clos_def)).
        apply (list_forall_out (proj2 CLS)).
        apply* nth_In. omega.
      rewrite R1 in Htag.
      inversion* Htag.
    clear IHl0.
    rewrite map_app; rewrite fold_left_app; simpl.
    destruct l0 using rev_ind; simpl.
      destruct* c.
    clear IHl0.
    rewrite map_app; rewrite fold_left_app; simpl.
    destruct l0; destruct c; simpl*.
    (* sub *)
    poses Hlen (proj1 CLS). simpl in Hlen.
    do 2 (destruct cls; try discriminate).
    simpl.
    destruct c; simpl*.
    assert (clos_ok (clos_const c l)).
      destruct* CLS.
    inversions H.
    case_eq (Delta.is_record c); introv R1.
      destruct c; try discriminate.
      rewrite Delta.record_args_ok. rewrite <- app_nil_end.
      case_eq (index eq_nat_dec 0 a l0); introv R2; simpl*.
      destruct (le_lt_dec (length l) n0).
        rewrite* nth_overflow.
        rewrite* nth_overflow.
        rewrite* map_length.
      rewrite (map_nth _ clos_def); auto.
    rewrite (Delta.record_args_other _ _ _ R1).
    destruct c; try discriminate; simpl*.
    (* recf *)
    poses Hlen (proj1 CLS). simpl in Hlen.
    do 3 (destruct cls; try discriminate).
    simpl.
    destruct CLS.
    inversions* H0.
  Qed.

  Ltac advance :=
    match goal with H: (match ?t with end) = (_, _) |- _ => destruct t end.

  Ltac eq_pair :=
    match goal with H: (_,_) = (_,_) |- _ => inversions H end.

  Lemma reduce_clos_regular : forall c cls cl' cls',
    reduce_clos c cls = (cl', cls') ->
    list_forall clos_ok cls ->
    list_forall clos_ok (cl' :: cls').
  Proof.
    Hint Extern 1 (list_forall _ _) => eq_pair : core.
    destruct c; simpl; intros; auto.
    (* matches *)
    puts (clos_ok_nth (length l) H0). intuition.
    destruct (nth (length l) cls clos_def); inversions* H1.
    destruct* c.
    destruct* l0.
    destruct* l0.
    destruct* (index eq_nat_dec 0 a l).
    (* sub *)
    destruct* cls.
    destruct* c.
    destruct* c.
    destruct~ (index eq_nat_dec 0 a l0).
    inversions H0; clear H0.
    inversions H4; clear H4.
    use (clos_ok_nth n0 H2).
    (* recf *)
    destruct~ cls.
    inversions H0.
    inversions* H.
  Qed.

  Lemma reduce_clos_ext : forall c args args',
    list_forall2 equiv_clos args args' ->
    let (cl,arg) := reduce_clos c args in
    let (cl',arg') := reduce_clos c args' in
    equiv_clos cl cl' /\ list_forall2 equiv_clos arg arg'.
  Proof.
    Hint Resolve equiv_cl_nth : core.
    destruct c; simpl; intros; auto*.
    (* matches *)
    puts (equiv_cl_nth (length l) H).
    inversions* H0.
    destruct* c.
    inversions* H3.
    inversions* H5.
    destruct* (index eq_nat_dec 0 a l).
    (* sub *)
    inversions* H.
    inversions* H0.
    destruct* c.
    destruct* (index eq_nat_dec 0 a l).
    (* recf *)
    inversions* H.
  Qed.
End SndHyp.

Module Sound3 := Infer2.MyEval2.Mk3(SndHyp).


(** * Nest as an instance of LNDT *)

Require Import Spreadable.
Require Import LNDT.
Require Import PerfectTree.
Require Import Lia.

Definition Nest : TT := PerfectTree 1.

(** ** Nest is spread-able because PerfectTree is spread-able *)
Definition nest_spreadable : SpreadAble (Nest) := pt_spreadable 1.

Definition nest_map         := pt_map         1.
Definition nest_cng_map     := pt_cng_map     1.
Definition nest_cmp_map     := pt_cmp_map     1.
Definition nest_foldr       := pt_foldr       1.
Definition nest_foldl       := pt_foldl       1.
Definition nest_size        := pt_size        1.
Definition nest_flatten     := pt_flatten     1.
(* Definition nest_any     := pt_show        1. *)
Definition nest_any         := pt_any         1.
Definition nest_dec_any     := pt_dec_any     1.
Definition nest_all         := pt_all         1.
Definition nest_dec_all     := pt_dec_all     1.
Definition nest_in_prop     := pt_in_prop     1.
Definition nest_empty       := pt_empty       1.
Definition nest_dec_in_prop := pt_dec_in_prop 1.
Definition nest_dec_eq      := pt_dec_eq      1.

Require Import Tuple.

(** ** Example of inhabitant of Nest nat *)

Definition example : Nest nat :=
  nest _ _ 7
   (nest _ _ (1, 2)
     (nest _ _ ((6, 7), (7, 4))
       (nest _ _ (((2, 5), (7, 1)), ((3, 8), (9, 3)))
         (empty _ _)))).
(* equivalent to
    7 ∷ (1 , 2) ∷ ((6 , 7) , (7 , 4))
       ∷ (((2 , 5) , (7 , 1)) , ((3 , 8) , (9 , 3))) ∷ [] *)

(** ** Examples of function calls over this example *)

Definition exampleMap : Nest nat :=
  nest_map _ _ (fun x => x + 3) example.

Eval compute in exampleMap.

Eval compute in (nest_map _ _ ff example).

Definition exampleFoldr : nat :=
  nest_foldr _ _ (fun x y => x + y) 0 example.

Eval compute in exampleFoldr.

Definition exampleFoldl : nat :=
  nest_foldl _ _ (fun x y => x + y) 0 example.

Eval compute in exampleFoldl.

Definition exampleSize : nat := nest_size _ example.

Eval compute in exampleSize.

(** ** Examples of predications over these examples *)

Lemma exampleAny : nest_any _ (fun x => x > 8) example.
Proof. unfold nest_any, example, pt_any. simpl. lia. Defined.

Lemma exampleAll : nest_all _ (fun x => x >= 1) example.
Proof. unfold nest_all, example, pt_all. simpl. repeat split;lia. Defined.


Require Export Iron.Language.SystemF2Store.Exp.

(********************************************************************)
(* Storeable values are the ones that we can keep directly in
   store bindings *)
Inductive svalue :=
 | SLoc  : nat -> svalue
 | SLAM  : exp -> svalue
 | SLam  : ty  -> exp -> svalue.
Hint Constructors svalue.

Definition takeSValueOfExp (xx : exp) : option svalue :=
 match xx with
 | XLoc n    => Some (SLoc n)
 | XLAM x    => Some (SLAM x)
 | XLam t x  => Some (SLam t x)
 | _         => None
 end.

Definition expOfSValue (s: svalue) : exp :=
 match s with
 | SLoc n    => XLoc n
 | SLAM x    => XLAM x
 | SLam t x  => XLam t x
 end.

Definition svalueOf (xx : exp) (sv : svalue) : Prop
 := takeSValueOfExp xx = Some sv.

(* There is an expression for every store value *)
Lemma exp_from_svalue
 : forall sv, exists v, svalueOf v sv.
Proof.
 intros.
 destruct sv.
  exists (XLoc n).   burn.
  exists (XLAM e).   burn.
  exists (XLam t e). burn.
Qed.
Hint Resolve exp_from_svalue.

(* There is a store value for every expression value. *)
Lemma svalue_from_value
 : forall v, value v -> (exists sv, svalueOf v sv).
Proof.
 intros.
 destruct v; nope.
  exists (SLoc  n).  burn.
  exists (SLAM  v).  burn.
  exists (SLam t v). burn.
Qed.
Hint Resolve svalue_from_value.

Lemma svalue_of_expOfSValue
 : forall sv : svalue, svalueOf (expOfSValue sv) sv.
Proof.
 intros. destruct sv; burn.
Qed.
Hint Resolve svalue_of_expOfSValue.

Lemma svalueOf_is_expOfSValue
 :  forall v sv
 ,  svalueOf v sv
 -> v = expOfSValue sv.
Proof.
 intros.
 inverts H.
  destruct sv;
   destruct v; try burn; simpl in *; inverts H1; auto.
Qed.
Hint Resolve svalueOf_is_expOfSValue.

Lemma svalueOf_forall_expOfSValue
 :  forall vs svs
 ,  Forall2 svalueOf vs svs
 -> vs = map expOfSValue svs.
Proof.
 intros. induction H; burn.
Qed.
Hint Resolve svalueOf_forall_expOfSValue.