Require Import Coq.Logic.Decidable.
Require Import PeanoNat.
Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Bool.
Require Import Nat.

Require Import LIR.maps.

Require Import LIR.lir.
Require Import LIR.pallene.

(*
** Convert a Pallene type to its corresponding Lir type
*)
Definition PT2IRT (t : PType) : IRType :=
  match t with
  | PTStar => IRTStar
  | PTNil => Tag2Type TgNil
  | PTInt => Tag2Type TgInt
  | PTArr _ => Tag2Type TgTbl
  | PTFun _ _ =>  Tag2Type TgFun
  end.

Lemma PT2IRTFun : forall T1 T2,
    PT2IRT (PTFun T1 T2) = IRTFun.
Proof. intros T1 T2. unfold PT2IRT. trivial. Qed.

(*
** Convert a Pallene environment to a Lir environment
*)
Fixpoint TP2TGamma (Γ : Map PType) : IREnvironment :=
  match Γ with
  | MEmpty => MEmpty
  | MCons var T Γ' => MCons var (PT2IRT T) (TP2TGamma Γ')
  end.

Lemma TP2TGammaIn : forall Γ var T,
    In Γ var = Some T -> In (TP2TGamma Γ) var = Some (PT2IRT T).
Proof.
  induction Γ; intros var T H; breakStrDec;
  auto;
  congruence.
Qed.

(*
** Casts an expression of type 't1' to one of type 't2'.
*)
Definition Cast (t1 t2 : IRType) (e : IRE) : IRE :=
  match t1, t2 with
  | IRTStar, IRTStar => e
  | IRTStar, Tag2Type t => IREBox t e
  | Tag2Type t, IRTStar => IREUnbox t e
  | Tag2Type t1', Tag2Type t2' => if dec_Tag t1' t2' then e
                                  else IREUnbox t1' (IREBox t2' e)
  end.

Notation "'<' t1 '<=' t2 '>' e" := (Cast t1 t2 e)
    (at level 50, t1 at next level, t2 at next level).

Lemma SubstCast : forall var e1 e2 T T',
  [var := e1] (<T <= T'> e2) = (<T <= T'> [var := e1] e2).
Proof.
  intros.
  destruct T; destruct T'; simpl; trivial.
  destruct (dec_Tag t t0); subst; trivial.
Qed.

Lemma StCastF : forall m e T T',
  m / e --> fail  ->
  m / (<T <= T'> e) --> fail.
Proof.
  intros.
  destruct T; destruct T'; simpl; eauto using stepF.
  destruct (dec_Tag t t0); eauto using stepF.
Qed.

Lemma CastStep : forall t1 t2 e m e' m',
  m / e --> m' / e' ->
  m / (<t1 <= t2> e) --> m' / (<t1 <= t2> e').
Proof.
  intros * HSt.
  unfold Cast.
  destruct t1; destruct t2; eauto using step.
  destruct (dec_Tag t t0); eauto using step.
Qed.

Lemma CastStepF : forall t1 t2 e m,
  m / e --> fail ->
  m / (<t1 <= t2> e) --> fail.
Proof.
  intros * HSt.
  unfold Cast.
  destruct t1; destruct t2; eauto using stepF.
  destruct (dec_Tag t t0); eauto using stepF.
Qed.

Lemma CongCast : forall t1 t2 e m e' m',
  m / e -->* m' / e' ->
  m / (<t1 <= t2> e) -->* m' / (<t1 <= t2> e').
Proof.
  intros * HSt.
  induction HSt; eauto using multistep, CastStep.
Qed.

(*
** Get the ground type of an expression; if correctly typed;
** otherwise assume nil. (The expression will always be correctly
** typed.)
*)
Definition GtypeOf Γ e : IRType :=
  match typeOf Γ e with
  | Some T => PT2IRT T
  | None => IRTNil
  end.

Lemma GtypeOfT : forall Γ e T, typeOf Γ e = Some T -> GtypeOf Γ e = PT2IRT T.
Proof. intros. unfold GtypeOf. rewrite H. trivial. Qed.

Lemma GtypeOfT' : forall Γ e T, Γ |p= e : T -> GtypeOf Γ e = PT2IRT T.
Proof. eauto using GtypeOfT, typeOfCorrect'. Qed.

Lemma tagStar2type : forall Γ e,
    GtypeOf Γ e = IRTStar -> typeOf Γ e = Some PTStar.
Proof.
  unfold GtypeOf.
  intros Γ e H.
  destruct (typeOf Γ e) eqn:?; try easy.
  destruct p; easy.
Qed.

(*
** Translation (compilation) of Pallene programs to Lir
*)
Fixpoint Pall2Lir (Γ : PEnvironment) (e : PE) : IRE :=
  match e with
  | PENil => IRENil
  | PENum a => IRENum a
  | PEPlus e1 e2 => IREPlus (Pall2Lir Γ e1) (Pall2Lir Γ e2)
  | PENew _ => IRENew
  | PETAddr a _ => IRETAddr a
  | PEFAddr a _ _ => IREFAddr a
  | PEGet e1 e2 =>
         <GtypeOf Γ e <= IRTStar>
           (IREGet (Pall2Lir Γ e1) (<IRTStar <= (Tag2Type TgInt)> (Pall2Lir Γ e2)))
  | PESet e1 e2 e3 =>
         (IRESet (Pall2Lir Γ e1)
                 (<IRTStar <= Tag2Type TgInt> (Pall2Lir Γ e2))
                 (<IRTStar <= GtypeOf Γ e3> Pall2Lir Γ e3))
  | PEVar var => IREVar var
  | PEFun var T body _  => let Γ' := (var |=> T; Γ) in
        IREFun var
          (IRELet var (PT2IRT T) (<PT2IRT T <= IRTStar> (IREVar var))
                     (<IRTStar <= GtypeOf Γ' body> (Pall2Lir Γ' body)))
  | PELet var T init body =>
      IRELet var (PT2IRT T) (Pall2Lir Γ init) (Pall2Lir (var |=> T; Γ) body)
  | PEApp e1 e2 => <GtypeOf Γ e <= IRTStar>
         (IREApp (Pall2Lir Γ e1)
                  (<IRTStar <= (GtypeOf Γ e2)> Pall2Lir Γ e2))
  | PECast e1 t => <PT2IRT t <= GtypeOf Γ e1> (Pall2Lir Γ e1)
  end.

Lemma invertCall : forall {Γ e1 e2 T1 T2},
  typeOf Γ e1 = Some (PTFun T1 T2) ->
  typeOf Γ e2 = Some T1 ->
  typeOf Γ (PEApp e1 e2) = Some T2.
Proof.
  intros Γ e1 r2 T1 T2 H1 H2.
  simpl. rewrite H1. rewrite H2.
  destruct (dec_TP T1 T1); congruence.
Qed.

Lemma invertFun : forall {Γ e1 e2 T1 T2},
    typeOf Γ e1 = Some (PTFun T1 T2) ->
    GtypeOf Γ (PEApp e1 e2) = IRTStar ->
    T2 = PTStar.
Proof.
  intros Γ e1 e2 T1 T2 H1 H2.
  unfold GtypeOf in H2.
  destruct (typeOf Γ (PEApp e1 e2)) eqn:?; try easy.
  apply typeOfCorrect'' in H1.
  apply typeOfCorrect'' in Heqo.
  destruct p; try easy.
  inversion Heqo; subst.
  apply (PTypeUnique _ _ _ _ H1) in H4.
  congruence.
Qed.

Ltac breakTagOf :=
  match goal with
  [H: typeOf _ ?E = Some ?T |- context C [GtypeOf _ ?E] ] =>
    apply GtypeOfT in H; rewrite H; destruct (PT2IRT T) eqn:?;
    eauto using IRTyping
  end.

Lemma PT2IRTag : forall {tg T},
  PT2IRT T = Tag2Type tg -> T <> PTStar.
Proof.
  intros * Heq HCnt.
  destruct T; discriminate.
Qed.

Lemma PTStarB : forall (T : PType),
    PT2IRT T = IRTStar -> T = PTStar.
Proof.
  intros T H.
  destruct T; inversion H; easy.
Qed.

Ltac T2Star :=
  repeat match goal with
  |[H: PT2IRT _ = IRTStar |- _] => rewrite (PTStarB _ H) in *
  end.

Lemma typeStar : forall {Γ e T},
    typeOf Γ e = Some T -> GtypeOf Γ e = IRTStar -> T = PTStar.
Proof.
  intros Γ e T HT Htg.
  unfold GtypeOf in Htg.
  rewrite HT in Htg.
  auto using PTStarB.
Qed.

Lemma typeTag : forall {Γ e T tg},
    typeOf Γ e = Some T ->
    GtypeOf Γ e = Tag2Type tg ->
    PT2IRT T = Tag2Type tg.
Proof.
  intros Γ e T tg HT Htg.
  unfold GtypeOf in Htg.
  rewrite HT in Htg.
  auto.
Qed.

(*
** Compilation of well-typed programs results in well-typed code
*)
Theorem Pall2LirWellTyped : forall Γ Γ' (e : PE) T T',
    Γ |p= e : T ->
    TP2TGamma Γ = Γ' ->
    PT2IRT T = T' ->
    Γ' |= (Pall2Lir Γ e) : T'.
Proof with eauto using IRTyping.
  intros * H Eq1 Eq2. subst.
  induction H; simpl in *;
  eauto using IRTyping, TP2TGammaIn;
  repeat match goal with
  | [H: PTyping ?G ?E ?T |- _] =>
      apply typeOfCorrect in H
  end.

  - (* Get *)
    unfold GtypeOf. simpl. rewrite H. rewrite H0.
    destruct (PT2IRT T) eqn:?; simpl; eauto using IRTyping.

  - (* Set *)
    unfold GtypeOf. rewrite H1.
    destruct (PT2IRT T) eqn:?; simpl; eauto using IRTyping.

  - (* Fun *)
    apply IRTyFun. eapply IRTyLet.
    + destruct (GtypeOf (var |=> Tvar; Γ)) eqn:?; subst.
      * apply IRTyBox.
        eapply inclusion_typing.
        ** unfold GtypeOf in Heqi. rewrite H in Heqi.
           rewrite <- Heqi. eauto.
        ** eapply inclusion_shadow'.
      *  unfold GtypeOf in Heqi. rewrite H in Heqi.
        rewrite Heqi in IHPTyping.
        simpl in IHPTyping.
        eapply inclusion_typing; eauto.
        apply inclusion_shadow'.
    + unfold Cast.
      destruct (PT2IRT Tvar) eqn:?.
      * apply IRTyUnbox.
        ** trivial.
        ** apply IRTyVar. apply InEq.
      * subst. simpl.
        apply IRTyVar. apply InEq.

  - (* App *)
    destruct (GtypeOf Γ (PEApp e1 e2)) eqn:?.
    + specialize (invertCall H H0) as H2.
      unfold GtypeOf in Heqi. rewrite H2 in Heqi.
      simpl.
      apply IRTyUnbox; trivial.
      eapply IRTyApp; eauto.
      destruct (GtypeOf Γ e2) eqn:?.
      * apply IRTyBox.
        specialize (typeTag H0 Heqi0) as HTt.
        rewrite <- HTt. trivial.
      * replace T1 with PTStar in * by (symmetry; eauto using typeStar).
        trivial.
    + unfold Cast.
      specialize (invertFun H Heqi); intros; subst; simpl.
      destruct (GtypeOf Γ e2) eqn:?.
      * eapply IRTyApp; eauto using IRTyping.
        eapply IRTyBox.
        replace (Tag2Type t) with (PT2IRT T1); trivial.
        eauto using typeTag.
      * eapply IRTyApp; eauto using IRTyping.
        replace T1 with PTStar in * by (symmetry; eauto using typeStar).
        trivial.

  - (* Cast *)
    unfold Cast.
    destruct (PT2IRT T2) eqn:?;
    unfold GtypeOf;
    rewrite H;
    destruct (PT2IRT T1) eqn:?.
    + destruct (dec_Tag t t0); subst; trivial.
      eapply IRTyUnbox; trivial.
      eapply IRTyBox.
      trivial.
    + apply IRTyUnbox; trivial.
  + apply IRTyBox. trivial.
  + unfold PT2IRT in *.
    trivial.
Qed.

Lemma typeOfEq : forall Γ1 e1 Γ2 e2 T,
  Γ1 |p= e1 : T ->
  Γ2 |p= e2 : T ->
  typeOf Γ1 e1 = typeOf Γ2 e2.
Proof.
  intros * HTy1 HTy2.
  erewrite typeOfCorrect'; eauto.
  erewrite typeOfCorrect'; eauto.
Qed.

Lemma GtypeOfEq : forall Γ1 e1 Γ2 e2 T,
  Γ1 |p= e1 : T ->
  Γ2 |p= e2 : T ->
  GtypeOf Γ1 e1 = GtypeOf Γ2 e2.
Proof.
  intros * HTy1 HTy2.
  unfold GtypeOf.
  erewrite typeOfEq; eauto.
Qed.

Ltac GtypeOf2T :=
  repeat   (* replace GtypeOfs with theirs types *)
      (erewrite GtypeOfT';
       eauto 4 using PTyping, PinclusionType, inclusion_update,
                   Psubst_typing, inclusion_shadow, inclusion_permute,
                   PexpPreservation).

Lemma Pall2LirEEnv : forall Γ Γ' e T,
  Γ |p= e : T ->
  inclusion Γ Γ' ->
  Pall2Lir Γ e = Pall2Lir Γ' e.
Proof.
  intros * HTy HIn.
  generalize dependent Γ'.
  induction HTy; intros; subst; trivial;
  simpl;   (* expose GtypeOfs *)
  GtypeOf2T;
  repeat match goal with   (* do the rewrites from the hypotheses *)
  | [ H: _ -> _ -> _ = _ |- _] =>
     erewrite H; eauto using inclusion_update; clear H
  end.
Qed.

Lemma Psubst : forall Γ var Tvar e1 e2 te,
  (var |=> Tvar; Γ) |p= e2 : te ->
  MEmpty |p= e1 : Tvar ->
  Pall2Lir Γ ([var := e1]p e2) =
    [var := (Pall2Lir MEmpty e1)] (Pall2Lir (var |=> Tvar; Γ) e2).
Proof.
  intros * HTy2 HTy1.
  generalize dependent te.
  generalize dependent Γ.
  induction e2; intros * HTy2; trivial; inversion HTy2; subst;
  simpl;

  repeat match goal with   (* do the rewrites from the hypotheses *)
  | [ H: _ -> _ -> _ -> _ = _ |- _] =>
     erewrite H; eauto using inclusion_update, PTyping; clear H
  end.

  - GtypeOf2T.
    destruct (PT2IRT te); trivial.

  - simpl.
    GtypeOf2T.
    destruct (PT2IRT T); trivial.

  - breakStrDec.
    symmetry. eauto using Pall2LirEEnv, PinclusionType, inclusion_empty.

  - simpl.
    GtypeOf2T.
    destruct (PT2IRT te).
    + destruct t; simpl; destruct (PT2IRT T1); trivial.
    + simpl.
      destruct (PT2IRT T1); trivial.

   - breakStrDec; simpl.
     + GtypeOf2T.
       replace (Pall2Lir (s |=> p; (s |=> Tvar; Γ)) e2)
         with (Pall2Lir (s |=> p; Γ) e2); trivial.
       eauto using Pall2LirEEnv,  inclusion_shadow,
         PinclusionType, inclusion_shadow'.
     + destruct (PT2IRT p); subst.
       * GtypeOf2T.
         destruct t;
         simpl;
            f_equal;
            f_equal;
            breakStrDec;
           destruct (PT2IRT p0); simpl;
               f_equal;
                    replace (Pall2Lir (s |=> p; (var |=> Tvar; Γ)) e2)
                      with  (Pall2Lir (var |=> Tvar; (s |=> p; Γ)) e2);
                    eauto using Pall2LirEEnv, inclusion_permute,
                                   PinclusionType.
      * simpl.
        f_equal.
        f_equal.
        ** breakStrDec.
        ** GtypeOf2T.
           destruct (PT2IRT p0); simpl;
           f_equal;
           replace (Pall2Lir (s |=> p; (var |=> Tvar; Γ)) e2)
             with  (Pall2Lir (var |=> Tvar; (s |=> p; Γ)) e2);
           eauto using Pall2LirEEnv, inclusion_permute, PinclusionType.

  - destruct (string_dec var s) eqn:HVeq; subst.
    + simpl. f_equal;
       eauto using Pall2LirEEnv,  inclusion_shadow,
         PinclusionType, inclusion_shadow'.
    + simpl. f_equal; eauto.
      replace (Pall2Lir (s |=> p; (var |=> Tvar; Γ)) e2_2)
      with (Pall2Lir (var |=> Tvar; (s |=> p; Γ)) e2_2) by
           eauto using Pall2LirEEnv, inclusion_permute, PinclusionType.
      eauto using Pall2LirEEnv, inclusion_permute, PinclusionType.

  - simpl. GtypeOf2T.
    destruct (PT2IRT te); subst; destruct (PT2IRT T1); subst; simpl;
    try destruct (dec_Tag t t0); subst; eauto.
Qed.

Theorem PValueValue : forall e, PValue e -> Value (Pall2Lir MEmpty e).
Proof.
  intros * PV.
  induction PV; simpl; eauto using Value.
  destruct (GtypeOf MEmpty v); eauto using Value.
Defined.

Fixpoint MPall2Lir (m : PMem) : Mem :=
  match m with
  | PEmptyMem => EmptyMem
  | PUpdateT addr idx (PEV v ev) m =>
      UpdateT addr
              idx
              (EV (Pall2Lir MEmpty v) (PValueValue v ev))
              (MPall2Lir m)
  | PUpdateF addr var T body m =>
      UpdateF addr
              var
              (IRELet var (PT2IRT T) (<PT2IRT T <= IRTStar> (IREVar var))
                 (Pall2Lir (var |=> T; MEmpty) body))
              (MPall2Lir m)
  end.

Lemma MPall2LirCorrect : forall m,
  Pmem_correct m -> mem_correct (MPall2Lir m).
Proof.
  induction m; intros H; only 1: constructor;
  inversion H; subst.
  - destruct p. eauto using mem_correct, Pall2LirWellTyped.
  - constructor; auto.
    constructor.
    + eauto using inclusion_typing, inclusion_shadow', Pall2LirWellTyped.
    + destruct (PT2IRT p); eauto using IRTyping, InEq.
Qed.

Lemma sameFreeaux : forall m,
  Pfreshaux m = freshaux (MPall2Lir m).
Proof.
  induction m; trivial.
  - destruct p. simpl. congruence.
  - simpl. congruence.
Qed.

Lemma P2LfreshT : forall m m' free,
  (free, m') = PfreshT m ->
  (free, MPall2Lir m') = freshT (MPall2Lir m).
Proof.
  unfold PfreshT,  freshT.
  intros * HEq.
  induction m; injection HEq; intros; subst; trivial;
  try (destruct p); rewrite sameFreeaux; trivial.
Qed.

Lemma TagFromType : forall e T,
  MEmpty |p= e : T ->
  GtypeOf MEmpty e = PT2IRT T.
Proof.
  unfold GtypeOf. intros * HTy.
  replace (typeOf MEmpty e) with (Some T); trivial.
  symmetry; eauto using typeOfCorrect'.
Qed.

Lemma PreserveTagOf' : forall m e T m' e',
  Pmem_correct m ->
  m / e -p-> m' / e' ->
  MEmpty |p= e : T ->
  GtypeOf MEmpty e' = PT2IRT T.
Proof.
  intros * HM HSt HTy.
  eauto using TagFromType, PexpPreservation.
Qed.

Lemma PreserveTagOf : forall m e t m' e',
  Pmem_correct m ->
  MEmpty |p= e : t ->
  m / e -p-> m' / e' ->
  GtypeOf MEmpty e = GtypeOf MEmpty e'.
Proof.
  unfold GtypeOf. intros * HM HTy Hst.
  replace (typeOf MEmpty e') with (typeOf MEmpty e)
        by eauto using pstep, PexpPreservTypeOf.
  trivial.
Qed.

Opaque Index_dec.

Lemma PqueryT2 : forall {m a idx v},
  Pmem_correct m ->
  PqueryT a idx m = v ->
  queryT a (IREBox TgInt (IRENum idx)) (MPall2Lir m) = Pall2Lir MEmpty v.
Proof.
  intros * HMC HQr.
  generalize dependent v.
  induction HMC; intros * HEq.
  - simpl in HEq. subst. trivial.
  - destruct v.
    subst. simpl.
    breakIndexDec; subst; auto.
  - simpl. inversion HMC; subst; auto.
Qed.

Lemma PqueryF2 : forall {m a var T body body'},
  Pmem_correct m ->
  (var, T, body) = PqueryF a m ->
  (var, body') = queryF a (MPall2Lir m) ->
  body'= IRELet var (PT2IRT T) (< PT2IRT T <= IRTStar > IREVar var)
               (Pall2Lir (var |=> T; MEmpty) body).
Proof.
  intros * HMC.
  induction m; intros * HQr1 HQr2; inversion HMC; subst.
  - injection HQr1; injection HQr2; intros; subst; trivial.
  - destruct p. eauto.
  - simpl in *. destruct (Nat.eq_dec a a0); eauto.
    injection HQr1; injection HQr2; intros; subst; trivial.
Qed.

Lemma PqueryF2V : forall {m a var var' T body body'},
  Pmem_correct m ->
  (var, T, body) = PqueryF a m ->
  (var', body') = queryF a (MPall2Lir m) ->
  var = var'.
Proof.
  intros * HMC.
  induction m; intros * HQr1 HQr2; inversion HMC; subst.
  - injection HQr1; injection HQr2; intros; subst; trivial.
  - destruct p. eauto.
  - simpl in *. destruct (Nat.eq_dec a a0); eauto.
    injection HQr1; injection HQr2; intros; subst; trivial.
Qed.

Lemma PQueryQuery : forall {s type body a m},
  Pmem_correct m ->
  (s, type, body) = PqueryF a m ->
  (s, IRELet s (PT2IRT type) (< PT2IRT type <= IRTStar > IREVar s)
         (Pall2Lir (s |=> type; MEmpty) body)) = queryF a (MPall2Lir m).
Proof.
  intros * HM HEq.
  destruct (queryF a (MPall2Lir m)) eqn:HEq1.
  symmetry in HEq1.
  specialize (PqueryF2V HM HEq HEq1) as ?; subst.
  specialize (PqueryF2 HM HEq HEq1) as ?; subst.
  trivial.
Qed.

Lemma PCastBox : forall v T v' t,
  MEmpty |p= v : PTStar ->
  PValue v ->
  PCast v T = Some v' ->
  PT2IRT T = Tag2Type t ->
  Pall2Lir MEmpty v = IREBox t (Pall2Lir MEmpty v').
Proof.
  intros * HTy HV HCst Heq.
  assert (T <> PTStar) by (intros contra; subst; discriminate).
  specialize (ValStar _ HV HTy) as [v'' [Heq' HV']]; subst.
  simpl in *.
  assert (HCst': PCast v'' T = Some v') by (destruct T; easy).
  inversion HTy; subst.
  clear HCst HV HTy.
  generalize dependent T.
  generalize dependent t.
  generalize dependent T1.
  induction HV'; intros * HTy * HEq HNEq HCst.

  - destruct T; simpl in *; try discriminate.
    injection HEq; injection HCst; intros; subst. trivial.

  - destruct T; simpl in *; try discriminate.
    injection HEq; injection HCst; intros; subst. trivial.

  - destruct T0; simpl in *; try discriminate.
    injection HEq; injection HCst; intros; subst. trivial.

  - destruct T; simpl in *; try discriminate.
    injection HEq; injection HCst; intros; subst. trivial.

  - unfold GtypeOf.
    replace (typeOf MEmpty (PECast v PTStar)) with (Some T1)
      by (symmetry; eauto using typeOfCorrect').
    inversion HTy; subst.
    simpl.
    eapply IHHV'; clear IHHV'; eauto.
    subst. simpl in *.
    destruct T; trivial; discriminate.
Qed.

Lemma subsCast : forall var e T,
  [var := e] (< T <= IRTStar > IREVar var) =
  < T <= IRTStar > e.
Proof.
  intros.
  destruct T; breakStrDec.
Qed.

Lemma PCast2Star : forall {v v' T tg},
  PValue v ->
  MEmpty |p= v : T ->
  PT2IRT T = Tag2Type tg ->
  PCast v PTStar = Some v' ->
  Pall2Lir MEmpty v' = IREBox tg (Pall2Lir MEmpty v).
Proof.
  intros * HV HTy HEq HCast.
  specialize (PT2IRTag HEq) as ?.
  assert (v' = PECast v PTStar).
  { induction HV; simpl in *;
  injection HCast; try congruence.
  exfalso.
  inversion HTy; subst; eauto. }
  subst; simpl.
  GtypeOf2T.
  destruct T; only 1: easy;
  inversion HEq; subst; trivial.
Qed.

Lemma PCast2NStar : forall {v v' tg1 T1 tg2 T2},
  PValue v ->
  PT2IRT T1 = Tag2Type tg1 ->
  PT2IRT T2 = Tag2Type tg2 ->
  MEmpty |p= v : T1 ->
  PCast v T2 = Some v' ->
  tg1 = tg2.
Proof.
  intros * HV HEq1 HEq2 HTy HCst.
  destruct T1; only 1: (exfalso; eapply PT2IRTag in HEq1; easy);
  destruct T2; only 1: (exfalso; eapply PT2IRTag in HEq2; easy);
  inversion HEq1; inversion HEq2; subst; trivial;
  inversion HTy; subst; discriminate.
Qed.

Lemma castTags : forall v v' T1 T2 t,
  PValue v ->
  MEmpty |p= v : T1 ->
  PCast v T2 = Some v' ->
  PT2IRT T1 = Tag2Type t ->
  PT2IRT T2 = Tag2Type t ->
  Pall2Lir MEmpty v = Pall2Lir MEmpty v'.
Proof.
  intros * HV HTy HCst HEq1 HEq2.
  induction HV; inversion HTy; subst; inversion HEq1; subst;
  destruct T2; try discriminate;
  simpl in HCst; try congruence;
  injection HCst; intros; subst; trivial.
Qed.

Lemma castStar : forall v v' T t,
  PValue v ->
  MEmpty |p= v : T ->
  PCast v PTStar = Some v' ->
  PT2IRT T = Tag2Type t ->
  IREBox t (Pall2Lir MEmpty v) = Pall2Lir MEmpty v'.
Proof.
  intros * HV HTy HCst HEq.
  induction HV; inversion HTy; subst; inversion HEq; subst;
  simpl in HCst;
  injection HCst; intros; subst; trivial.
Qed.

Lemma castFStar : forall v v' T t,
  PValue v ->
  MEmpty |p= v : PTStar ->
  PCast v T = Some v' ->
  PT2IRT T = Tag2Type t ->
  (Pall2Lir MEmpty v) = IREBox t (Pall2Lir MEmpty v').
Proof.
  intros * HV HTy HCst HEq.
  induction HV; inversion HTy; subst.
  simpl.
  GtypeOf2T.
  assert (PCast v T = Some v') by (destruct T; easy).
  destruct (PT2IRT T1) eqn:?.
  - replace t with t0 by eauto using PCast2NStar.
    f_equal.
    destruct HV; simpl;
    destruct T; try easy;
      try (simpl in H; injection H; intros; subst; trivial);
      inversion H1; subst; discriminate.
  - T2Star.
    auto.
Qed.

Theorem SimPallLir : forall m e T m' e',
  Pmem_correct m ->
  MEmpty |p= e : T ->
  m / e -p-> m' / e' ->
  multistep (MPall2Lir m) (Pall2Lir MEmpty e)
            (MPall2Lir m') (Pall2Lir MEmpty e').
Proof.
  intros * HM HTy HSt.
  generalize dependent T.
  induction HSt; intros * HTy;
  inversion HTy; subst;

  (* instantiate induction hipothesis *)
  try match goal with
    | [H: Pmem_correct ?m -> forall _, PTyping MEmpty ?E _ -> _,
       HM: Pmem_correct ?m,
       HTy: PTyping MEmpty ?E _ |- _] =>
      specialize (H HM _ HTy)
  end;
  simpl;

  try (GtypeOf2T;
       simpl; eauto using step, multistep1, PValueValue, P2LfreshT,
              CongPlus1, CongPlus2, CongCast, CongGet1, CongUnbox,
              CongGet1, CongGet2, CongBox, CongLet; fail).

  - inversion H2; subst.
    erewrite <- PqueryT2; eauto.
    GtypeOf2T.
    2:{ eauto using PMCTy. }
    eauto using CongCast, multistep1, step, Value.

  - destruct (GtypeOf MEmpty e3); eauto using CongSet1.

  - destruct (GtypeOf MEmpty e3); eauto using CongSet2, CongBox, PValueValue.

  - GtypeOf2T.
    destruct (PT2IRT T0);
      eapply CongSet3; eauto using CongBox, PValueValue, Value.

 - eapply multistep1.
   eapply StSet.
   eauto using Value.

  - eapply multistep1.
    eapply StFun.
    fold Pall2Lir.
    unfold PfreshF in H.
    injection H; intros; subst.
    unfold freshF.
    rewrite sameFreeaux. trivial.

  - (* Let *)
    eapply multistep1.
    erewrite Psubst; eauto using step, PValueValue.

  - GtypeOf2T.
    destruct (PT2IRT T);
    eauto using CongUnbox, CongApp1.

  - GtypeOf2T.
    destruct (PT2IRT T);
      destruct (PT2IRT T1);
      eauto using CongUnbox, CongApp2, PValueValue, CongBox.

  - GtypeOf2T.
    2:{ eapply PTyLet.
        - eauto using PTyCast.
        - eapply PMCTyF; eauto. }
    inversion H4; subst.
    simpl.
    eapply CongCast.
    destruct (PT2IRT T0) eqn:?.
    + eapply MStMStep.
      * eapply StApp.
        ** eauto using PValueValue, Value.
        ** eapply PQueryQuery; eauto.
      * eapply MStMStep.
        ** eapply StLet; eauto using PValueValue, Value.
        ** simpl. destruct (string_dec var var); try easy.
           rewrite SubstCast. simpl.
           destruct (string_dec var var); try easy.
           simpl.
           destruct (PT2IRT type) eqn:?; simpl.
           *** destruct (dec_Tag t0 t) eqn:?; subst; simpl.
               ++ eapply multistep1. eauto using step, PValueValue.
               ++ eapply MStRefl.
           *** eapply MStRefl.

    + eapply MStMStep.
      * eapply StApp.
        ** eauto using PValueValue, Value.
        ** eapply PQueryQuery; eauto.
      * eapply MStMStep.
        ** eapply StLet; eauto using PValueValue, Value.
        ** simpl. destruct (string_dec var var); try easy.
           rewrite SubstCast. simpl.
           destruct (string_dec var var); try easy.
           simpl.
           eapply MStRefl.

  - GtypeOf2T.
    destruct (PT2IRT T0) eqn:?; destruct (PT2IRT T1) eqn:?; simpl;
    T2Star.
    + replace t0 with t in * by (symmetry; eauto using PCast2NStar).
      destruct (dec_Tag t t); try easy.
      erewrite castTags; eauto using multistep.
    + erewrite PCastBox; eauto using multistep1, step, PValueValue,
                                     CastValue.
    + erewrite <- PCast2Star; eauto using multistep.
    + rewrite CastToItsType in H1; trivial.
      replace v' with v by congruence.
      constructor.
Qed.

(*
** Simulation for Fails
*)

(*
** A cast to a type IR-equivalent to its onw type never fails.
*)
Lemma CastToItsIRType : forall v T T',
  PCast v T' = None ->
  MEmpty |p= v : T ->
  PValue v ->
  PT2IRT T = PT2IRT T'->
  False.
Proof.
  intros * HEq HTy HV.
  inversion HV; subst; inversion HTy; subst;
  destruct T' eqn:?; easy.
Qed.

Lemma CastToStar': forall v, PCast v PTStar = None -> False.
Proof.
  intros.
  specialize (CastToStar v) as [? ?].
  congruence.
Qed.

Ltac CastToStarNone :=
  try match goal with
  |[H: PCast _ PTStar = None |- _] =>
 exfalso; apply (CastToStar' _ H)
end.

(*
** Main lemma for fail simulation: A failed cast in Pallene will
** fail when translated to Lir.
*)
Lemma CastFail : forall {v} m {T T'},
  PValue v ->
  MEmpty |p= v : T ->
  PCast v T' = None ->
  (MPall2Lir m) / (< PT2IRT T' <= PT2IRT T > Pall2Lir MEmpty v) --> fail.
Proof.
  intros * HV HTy HC.
  induction HV; inversion HTy; subst;
  destruct T'; simpl in HC;
   (* easy cases *)
      (* impossible cases (PCast could not fail) *)
      try discriminate;
      (* cases that actually fail *)
      try (eapply StUnboxF; try easy; eauto using Value; fail);
   (* not so easy cases *)
   destruct T1; simpl; GtypeOf2T; simpl;
      (* specialize induction hypothesis *)
      try (specialize (IHHV H3 HC); simpl in IHHV; trivial);
      (* cases that actually fail *)
      try (eapply StUnboxF; auto using stepF, PValueValue; easy);
      (* impossible cases (PCast could not fail) *)
      try (exfalso; eauto using CastToItsIRType; fail).
 Qed.

(*
** 'CastFail' when original type is *
*)
Lemma CastFailStar : forall v m t T,
  PValue v ->
  MEmpty |p= v : PTStar ->
  PCast v T = None ->
  PT2IRT T = Tag2Type t ->
  (MPall2Lir m) /  (IREUnbox t (Pall2Lir MEmpty v)) --> fail.
Proof.
  intros * HV HTy HCst Heq.
  specialize (CastFail m HV HTy HCst) as ?.
  simpl in H. unfold Cast in H. rewrite Heq in H.
  trivial.
Qed.

(*
** Similar to 'CastFail', but pass through * when going from T to T'
*)
Lemma DoubleCastFail : forall v m T T',
  PCast v T' = None ->
  PValue v ->
  MEmpty |p= v : T  ->
  (MPall2Lir m) /
    (<PT2IRT T' <= IRTStar> (<IRTStar <= PT2IRT T> Pall2Lir MEmpty v)) --> fail.
Proof.
  intros * HCst HV HTy.
  destruct (PT2IRT T') eqn:?; T2Star.
  * destruct (PT2IRT T) eqn:?; simpl; T2Star.
    ** eapply StUnboxF; eauto using PValueValue.
       intros ?. subst.
       eapply CastToItsIRType; eauto. congruence.
    ** specialize (CastFail m HV HTy HCst) as ?.
       destruct (PT2IRT T'); inversion Heqi; subst; trivial.
  * CastToStarNone.
Qed.

Lemma WCast : forall t v,
      (match t with | Tag2Type t => IREBox t v | IRTStar => v end) =
      Cast IRTStar t v.
Proof. trivial. Qed.

Lemma CanonQuery : forall m a idx,
  Pmem_correct m ->
    exists (o : IRE) (t : Tag),
         Pall2Lir MEmpty (PqueryT a idx m) = IREBox t o /\ Value o.
Proof.
  intros * HM.
  specialize (PMCTy m a idx MEmpty HM) as ?.
  specialize (PMCValue m a idx) as ?.
  remember (PqueryT a idx m) as v.
  assert (MEmpty |= (Pall2Lir MEmpty v) : IRTStar)
    by eauto using Pall2LirWellTyped.
  assert (Value (Pall2Lir MEmpty v)) by eauto using PValueValue.
  specialize (valbox MEmpty (Pall2Lir MEmpty v) H1 H2)
     as [? [? [? [? ?]]]].
  eexists; eexists; eauto.
Qed.

Lemma SimPallLirF : forall m e T,
  Pmem_correct m ->
  MEmpty |p= e : T ->
  m / e -p-> fail ->
  multistepF (MPall2Lir m) (Pall2Lir MEmpty e).
Proof.
  intros * HM HTy HSt.
  generalize dependent T.
  induction HSt; intros * HTy;
  inversion HTy; subst;

  (* instantiate induction hipothesis *)
  try match goal with
    | [H: Pmem_correct ?m -> forall _, PTyping MEmpty ?E _ -> _,
       HM: Pmem_correct ?m,
       HTy: PTyping MEmpty ?E _ |- _] => specialize (H HM _ HTy)
    end;
    try (inversion IHHSt; subst;
         eauto 12 using multistepF, stepF, PValueValue, Value,
           CongCast, CastStepF,
           CongPlus1, CongPlus2, CongGet1, CongGet2, CongBox,
           CongSet1, CongSet2, CongSet3, CongApp1, CongApp2, CongLet;
         fail);
     simpl; GtypeOf2T;
       eauto using multistep, multistepF, CastFail.

Qed.


(** This file extends the HeapLang program logic with some derived laws (not
using the lifting lemmas) about arrays and prophecies.

For utility functions on arrays (e.g., freeing/copying an array), see
[heap_lang.lib.array].  *)

From stdpp Require Import fin_maps.
From iris.bi Require Import lib.fractional.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Export primitive_laws.
From iris.heap_lang Require Import tactics notation.
From iris.prelude Require Import options.

(** The [array] connective is a version of [mapsto] that works
with lists of values. *)

Definition array `{!heapGS_gen hlc Σ} (l : loc) (dq : dfrac) (vs : list val) : iProp Σ :=
  [∗ list] i ↦ v ∈ vs, (l +ₗ i) ↦{dq} v.

Notation "l ↦∗ dq vs" := (array l dq vs)
  (at level 20, dq custom dfrac  at level 1, format "l  ↦∗ dq  vs") : bi_scope.

(** We have [FromSep] and [IntoSep] instances to split the fraction (via the
[AsFractional] instance below), but not for splitting the list, as that would
lead to overlapping instances. *)

Section lifting.
Context `{!heapGS_gen hlc Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val → iProp Σ.
Implicit Types σ : state.
Implicit Types v : val.
Implicit Types vs : list val.
Implicit Types l : loc.
Implicit Types sz off : nat.

Global Instance array_timeless l q vs : Timeless (array l q vs) := _.

Global Instance array_fractional l vs : Fractional (λ q, l ↦∗{#q} vs)%I := _.
Global Instance array_as_fractional l q vs :
  AsFractional (l ↦∗{#q} vs) (λ q, l ↦∗{#q} vs)%I q.
Proof. split; done || apply _. Qed.

Lemma array_nil l dq : l ↦∗{dq} [] ⊣⊢ emp.
Proof. by rewrite /array. Qed.

Lemma array_singleton l dq v : l ↦∗{dq} [v] ⊣⊢ l ↦{dq} v.
Proof. by rewrite /array /= right_id Loc.add_0. Qed.

Lemma array_app l dq vs ws :
  l ↦∗{dq} (vs ++ ws) ⊣⊢ l ↦∗{dq} vs ∗ (l +ₗ length vs) ↦∗{dq} ws.
Proof.
  rewrite /array big_sepL_app.
  setoid_rewrite Nat2Z.inj_add.
  by setoid_rewrite Loc.add_assoc.
Qed.

Lemma array_cons l dq v vs : l ↦∗{dq} (v :: vs) ⊣⊢ l ↦{dq} v ∗ (l +ₗ 1) ↦∗{dq} vs.
Proof.
  rewrite /array big_sepL_cons Loc.add_0.
  setoid_rewrite Loc.add_assoc.
  setoid_rewrite Nat2Z.inj_succ.
  by setoid_rewrite Z.add_1_l.
Qed.

Global Instance array_cons_frame l dq v vs R Q :
  Frame false R (l ↦{dq} v ∗ (l +ₗ 1) ↦∗{dq} vs) Q →
  Frame false R (l ↦∗{dq} (v :: vs)) Q | 2.
Proof. by rewrite /Frame array_cons. Qed.

Lemma update_array l dq vs off v :
  vs !! off = Some v →
  ⊢ l ↦∗{dq} vs -∗ ((l +ₗ off) ↦{dq} v ∗ ∀ v', (l +ₗ off) ↦{dq} v' -∗ l ↦∗{dq} <[off:=v']>vs).
Proof.
  iIntros (Hlookup) "Hl".
  rewrite -[X in (l ↦∗{_} X)%I](take_drop_middle _ off v); last done.
  iDestruct (array_app with "Hl") as "[Hl1 Hl]".
  iDestruct (array_cons with "Hl") as "[Hl2 Hl3]".
  assert (off < length vs) as H by (apply lookup_lt_is_Some; by eexists).
  rewrite take_length min_l; last by lia. iFrame "Hl2".
  iIntros (w) "Hl2".
  clear Hlookup. assert (<[off:=w]> vs !! off = Some w) as Hlookup.
  { apply list_lookup_insert. lia. }
  rewrite -[in (l ↦∗{_} <[off:=w]> vs)%I](take_drop_middle (<[off:=w]> vs) off w Hlookup).
  iApply array_app. rewrite take_insert; last by lia. iFrame.
  iApply array_cons. rewrite take_length min_l; last by lia. iFrame.
  rewrite drop_insert_gt; last by lia. done.
Qed.

(** * Rules for allocation *)
Lemma mapsto_seq_array l dq v n :
  ([∗ list] i ∈ seq 0 n, (l +ₗ (i : nat)) ↦{dq} v) -∗
  l ↦∗{dq} replicate n v.
Proof.
  rewrite /array. iInduction n as [|n'] "IH" forall (l); simpl.
  { done. }
  iIntros "[$ Hl]". rewrite -fmap_S_seq big_sepL_fmap.
  setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
  setoid_rewrite <-Loc.add_assoc. iApply "IH". done.
Qed.

Lemma twp_allocN s E v n :
  (0 < n)%Z →
  [[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  [[{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hzs Φ) "_ HΦ". iApply twp_allocN_seq; [done..|].
  iIntros (l) "Hlm". iApply "HΦ".
  iDestruct (big_sepL_sep with "Hlm") as "[Hl $]".
  by iApply mapsto_seq_array.
Qed.
Lemma wp_allocN s E v n :
  (0 < n)%Z →
  {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  {{{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (? Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN; [auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_allocN_vec s E v n :
  (0 < n)%Z →
  [[{ True }]]
    AllocN #n v @ s ; E
  [[{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hzs Φ) "_ HΦ". iApply twp_allocN; [ lia | done | .. ].
  iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
Qed.
Lemma wp_allocN_vec s E v n :
  (0 < n)%Z →
  {{{ True }}}
    AllocN #n v @ s ; E
  {{{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (? Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN_vec; [auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

(** * Rules for accessing array elements *)
Lemma twp_load_offset s E l dq off vs v :
  vs !! off = Some v →
  [[{ l ↦∗{dq} vs }]] ! #(l +ₗ off) @ s; E [[{ RET v; l ↦∗{dq} vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_load with "Hl1"). iIntros "Hl1". iApply "HΦ".
  iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
  iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_load_offset s E l dq off vs v :
  vs !! off = Some v →
  {{{ ▷ l ↦∗{dq} vs }}} ! #(l +ₗ off) @ s; E {{{ RET v; l ↦∗{dq} vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_load_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_load_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) :
  [[{ l ↦∗{dq} vs }]] ! #(l +ₗ off) @ s; E [[{ RET vs !!! off; l ↦∗{dq} vs }]].
Proof. apply twp_load_offset. by apply vlookup_lookup. Qed.
Lemma wp_load_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) :
  {{{ ▷ l ↦∗{dq} vs }}} ! #(l +ₗ off) @ s; E {{{ RET vs !!! off; l ↦∗{dq} vs }}}.
Proof. apply wp_load_offset. by apply vlookup_lookup. Qed.

Lemma twp_store_offset s E l off vs v :
  is_Some (vs !! off) →
  [[{ l ↦∗ vs }]] #(l +ₗ off) <- v @ s; E [[{ RET #(); l ↦∗ <[off:=v]> vs }]].
Proof.
  iIntros ([w Hlookup] Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_store with "Hl1"). iIntros "Hl1".
  iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_store_offset s E l off vs v :
  is_Some (vs !! off) →
  {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ <[off:=v]> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  [[{ l ↦∗ vs }]] #(l +ₗ off) <- v @ s; E [[{ RET #(); l ↦∗ vinsert off v vs }]].
Proof.
  setoid_rewrite vec_to_list_insert. apply twp_store_offset.
  eexists. by apply vlookup_lookup.
Qed.
Lemma wp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ vinsert off v vs }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store_offset_vec with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_xchg_offset s E l off vs v v' :
  vs !! off = Some v →
  [[{ l ↦∗ vs }]] Xchg #(l +ₗ off) v' @ s; E [[{ RET v; l ↦∗ <[off:=v']> vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_xchg with "Hl1"). iIntros "Hl1".
  iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_xchg_offset s E l off vs v v' :
  vs !! off = Some v →
  {{{ ▷ l ↦∗ vs }}} Xchg #(l +ₗ off) v' @ s; E {{{ RET v; l ↦∗ <[off:=v']> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_xchg_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_xchg_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  [[{ l ↦∗ vs }]] Xchg #(l +ₗ off) v @ s; E [[{ RET (vs !!! off); l ↦∗ vinsert off v vs }]].
Proof.
  setoid_rewrite vec_to_list_insert. apply twp_xchg_offset.
  by apply vlookup_lookup.
Qed.
Lemma wp_xchg_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
   {{{ ▷ l ↦∗ vs }}} Xchg #(l +ₗ off) v @ s; E {{{ RET (vs !!! off); l ↦∗ vinsert off v vs }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_xchg_offset_vec with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
  vs !! off = Some v' →
  v' = v1 →
  vals_compare_safe v' v1 →
  [[{ l ↦∗ vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (v', #true); l ↦∗ <[off:=v2]> vs }]].
Proof.
  iIntros (Hlookup ?? Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_cmpxchg_suc with "Hl1"); [done..|].
  iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
  vs !! off = Some v' →
  v' = v1 →
  vals_compare_safe v' v1 →
  {{{ ▷ l ↦∗ vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (v', #true); l ↦∗ <[off:=v2]> vs }}}.
Proof.
  iIntros (??? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off = v1 →
  vals_compare_safe (vs !!! off) v1 →
  [[{ l ↦∗ vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }]].
Proof.
  intros. setoid_rewrite vec_to_list_insert.
  apply twp_cmpxchg_suc_offset; [|done..].
  by apply vlookup_lookup.
Qed.
Lemma wp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off = v1 →
  vals_compare_safe (vs !!! off) v1 →
  {{{ ▷ l ↦∗ vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }}}.
Proof.
  iIntros (?? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc_offset_vec with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail_offset s E l dq off vs v0 v1 v2 :
  vs !! off = Some v0 →
  v0 ≠ v1 →
  vals_compare_safe v0 v1 →
  [[{ l ↦∗{dq} vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (v0, #false); l ↦∗{dq} vs }]].
Proof.
  iIntros (Hlookup HNEq Hcmp Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_cmpxchg_fail with "Hl1"); first done.
  { destruct Hcmp; by [ left | right ]. }
  iIntros "Hl1". iApply "HΦ". iDestruct ("Hl2" $! v0) as "Hl2".
  rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_cmpxchg_fail_offset s E l dq off vs v0 v1 v2 :
  vs !! off = Some v0 →
  v0 ≠ v1 →
  vals_compare_safe v0 v1 →
  {{{ ▷ l ↦∗{dq} vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (v0, #false); l ↦∗{dq} vs }}}.
Proof.
  iIntros (??? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_fail_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off ≠ v1 →
  vals_compare_safe (vs !!! off) v1 →
  [[{ l ↦∗{dq} vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (vs !!! off, #false); l ↦∗{dq} vs }]].
Proof.
  intros. apply twp_cmpxchg_fail_offset; [|done..].
  by apply vlookup_lookup.
Qed.
Lemma wp_cmpxchg_fail_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off ≠ v1 →
  vals_compare_safe (vs !!! off) v1 →
  {{{ ▷ l ↦∗{dq} vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (vs !!! off, #false); l ↦∗{dq} vs }}}.
Proof.
  intros. eapply wp_cmpxchg_fail_offset; [|done..].
  by apply vlookup_lookup.
Qed.

Lemma twp_faa_offset s E l off vs (i1 i2 : Z) :
  vs !! off = Some #i1 →
  [[{ l ↦∗ vs }]] FAA #(l +ₗ off) #i2 @ s; E
  [[{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_faa with "Hl1").
  iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_faa_offset s E l off vs (i1 i2 : Z) :
  vs !! off = Some #i1 →
  {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
  {{{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa_offset with "H"); [by eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
  vs !!! off = #i1 →
  [[{ l ↦∗ vs }]] FAA #(l +ₗ off) #i2 @ s; E
  [[{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }]].
Proof.
  intros. setoid_rewrite vec_to_list_insert. apply twp_faa_offset.
  by apply vlookup_lookup.
Qed.
Lemma wp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
  vs !!! off = #i1 →
  {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
  {{{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa_offset_vec with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

(** Derived prophecy laws *)

(** Lemmas for some particular expression inside the [Resolve]. *)
Lemma wp_resolve_proph s E (p : proph_id) (pvs : list (val * val)) v :
  {{{ proph p pvs }}}
    ResolveProph (Val $ LitV $ LitProphecy p) (Val v) @ s; E
  {{{ pvs', RET (LitV LitUnit); ⌜pvs = (LitV LitUnit, v)::pvs'⌝ ∗ proph p pvs' }}}.
Proof.
  iIntros (Φ) "Hp HΦ". iApply (wp_resolve with "Hp"); first done.
  iApply lifting.wp_pure_step_later; first done.
  iIntros "!> _". iApply wp_value. iIntros (vs') "HEq Hp". iApply "HΦ". iFrame.
Qed.

Lemma wp_resolve_cmpxchg_suc s E l (p : proph_id) (pvs : list (val * val)) v1 v2 v :
  vals_compare_safe v1 v1 →
  {{{ proph p pvs ∗ ▷ l ↦ v1 }}}
    Resolve (CmpXchg #l v1 v2) #p v @ s; E
  {{{ RET (v1, #true) ; ∃ pvs', ⌜pvs = ((v1, #true)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦ v2 }}}.
Proof.
  iIntros (Hcmp Φ) "[Hp Hl] HΦ".
  iApply (wp_resolve with "Hp"); first done.
  assert (val_is_unboxed v1) as Hv1; first by destruct Hcmp.
  iApply (wp_cmpxchg_suc with "Hl"); [done..|]. iIntros "!> Hl".
  iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.

Lemma wp_resolve_cmpxchg_fail s E l (p : proph_id) (pvs : list (val * val)) dq v' v1 v2 v :
  v' ≠ v1 → vals_compare_safe v' v1 →
  {{{ proph p pvs ∗ ▷ l ↦{dq} v' }}}
    Resolve (CmpXchg #l v1 v2) #p v @ s; E
  {{{ RET (v', #false) ; ∃ pvs', ⌜pvs = ((v', #false)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦{dq} v' }}}.
Proof.
  iIntros (NEq Hcmp Φ) "[Hp Hl] HΦ".
  iApply (wp_resolve with "Hp"); first done.
  iApply (wp_cmpxchg_fail with "Hl"); [done..|]. iIntros "!> Hl".
  iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.

End lifting.

Typeclasses Opaque array.


Require Crypto.Algebra.Hierarchy.
Require Import Crypto.Util.Notations.
(*Require Crypto.Curves.Montgomery.XZ.*)

Module MxDH. (* from RFC7748 *)
  Section MontgomeryLadderKeyExchange.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} {Feq_dec:Decidable.DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "x ^ 2" := (x*x).
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Notation "2" := (1+1). Local Notation "4" := (2+2).

    Context {a b: F}. (* parameters of the Montgomery curve *)
    Context {nonsquare_aa_m4:~exists sqrt, sqrt^2 = a^2-4} {five_neq_zero:1+4<>0}.

    (* Implemention from RFC7748. Note that this differs from EFD and
       Montgomery '87 in the choice of which precomputed constant to use
       for [a] *)
    (* Ideally we would want to verify that this correspons to
       x-coordinate addition on the relevant elliptic curve, as
       specified by addition formulas in Montgomery coordinates.
       However, even if we did get to doing that, we still would not
       want to change the type of the ladder function to talk about
       points that are on the curve -- there are contexts where this
       can be, carefully, used with values that are not verified to
       be on the curve *)
    Context {a24:F} {a24_correct:4*a24 = a-2}.
    Section generic.
      Context (F4 : Type)
              (pair4 : F -> F -> F -> F -> F4)
              (let_in : F -> (F -> F4) -> F4).
      Local Notation "'llet' x := y 'in' z" := (let_in y (fun x => z)).
      Definition ladderstep_gen (X1:F) (P1 P2:F * F) : F4 :=
        let '(X2, Z2) := P1 in
        let '(X3, Z3) := P2 in
        llet A := X2+Z2 in
        llet AA := A^2 in
        llet B := X2-Z2 in
        llet BB := B^2 in
        llet E := AA-BB in
        llet C := X3+Z3 in
        llet D := X3-Z3 in
        llet DA := D*A in
        llet CB := C*B in
        llet X5 := (DA+CB)^2 in
        llet Z5 := X1*(DA-CB)^2 in
        llet X4 := AA*BB in
        llet Z4 := E*(AA + a24*E) in
        pair4 X4 Z4 X5 Z5.
    End generic.

    (** TODO: Make this the only ladderstep? *)
    Definition ladderstep_other_assoc (X1:F) (P1 P2:F*F) : F*F*F*F :=
      Eval cbv beta delta [ladderstep_gen] in
        @ladderstep_gen
            (F*F*F*F)
            (fun X3 Y3 Z3 T3 => (X3, Y3, Z3, T3))
            (fun x f => let y := x in f y)
            X1 P1 P2.

    Definition ladderstep (X1:F) (P1 P2:F*F) : (F*F)*(F*F) :=
      Eval cbv beta delta [ladderstep_gen] in
        @ladderstep_gen
            ((F*F)*(F*F))
            (fun X3 Y3 Z3 T3 => ((X3, Y3), (Z3, T3)))
            (fun x f => let y := x in f y)
            X1 P1 P2.

    (*Import Curves.Montgomery.XZ.
    Goal forall X1 P1 P2, Logic.eq (ladderstep X1 P1 P2) (@M.xzladderstep F Fadd Fsub Fmul a24 X1 P1 P2).
    Proof.
      intros ? [? ?] [? ?].
      reflexivity.
    Qed.*)

    Context {cswap:bool->F*F->F*F->(F*F)*(F*F)}.

    Fixpoint downto_iter (i:nat) : list nat :=
      match i with
      | Datatypes.S i' => cons i' (downto_iter i')
      | O => nil
      end.

    Definition downto {state} init count (step:state->nat->state) : state :=
      List.fold_left step (downto_iter count) init.

    Local Notation xor := Coq.Init.Datatypes.xorb.

    (* Ideally, we would verify that this corresponds to x coordinate
    multiplication *)
    Definition montladder bound (testbit:nat->bool) (u:F) :=
      let '(P1, P2, swap) :=
          downto
            ((1, 0), (u, 1), false)
            bound
            (fun state i =>
               let '(P1, P2, swap) := state in
               let s_i := testbit i in
               let swap := xor swap s_i in
               let '(P1, P2) := cswap swap P1 P2 in
               let swap := s_i in
               let '(P1, P2) := ladderstep u P1 P2 in
               (P1, P2, swap)
            ) in
      let '((x, z), _) := cswap swap P1 P2 in
      x * Finv z.
  End MontgomeryLadderKeyExchange.
End MxDH.

(* see [Test.Curve25519SpecTestVectors] for sanity-checks *)


Require Import UniMath.Foundations.Generalities.uu0.
Require Import UniMath.Foundations.hlevel1.hProp.
Require Import UniMath.Foundations.hlevel2.hSet.

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import SubstSystems.UnicodeNotations.
Require Import UniMath.RezkCompletion.whiskering.
Require Import UniMath.RezkCompletion.Monads.
Require Import UniMath.RezkCompletion.FunctorAlgebras.
Require Import UniMath.RezkCompletion.limits.coproducts.
Require Import SubstSystems.Auxiliary.
Require Import SubstSystems.PointedFunctors.
Require Import SubstSystems.ProductPrecategory.
Require Import SubstSystems.HorizontalComposition.
Require Import SubstSystems.PointedFunctorsComposition.
Require Import SubstSystems.EndofunctorsMonoidal.
Require Import SubstSystems.Signatures.
(* Require Import SubstSystems.FunctorAlgebraViews. *)
Require Import SubstSystems.FunctorsPointwiseCoproduct.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .
Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35).
Local Notation "α ∙∙ β" := (hor_comp β α) (at level 20).
Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Local Notation "α 'ø' Z" := (pre_whisker Z α)  (at level 25).
Local Notation "Z ∘ α" := (post_whisker _ _ _ _ α Z) (at level 35).

Local Notation "C ⟦ a , b ⟧" := (precategory_morphisms (C:=C) a b) (at level 50).

Section def_hss.

(** ** Some variables and assumptions *)

(** Assume having a precategory [C] whose hom-types are sets *)
Variable C : precategory.
Variable hs : has_homsets C.

Variable CP : Coproducts C.

Local Notation "'EndC'":= ([C, C, hs]) .
Let hsEndC : has_homsets EndC := functor_category_has_homsets C C hs.
Let CPEndC : Coproducts EndC := Coproducts_functor_precat _ _ CP hs.

Variable H : Signature C hs.

Let θ := theta H.

Let θ_strength1_int := Sig_strength_law1 _ _ H.
Let θ_strength2_int := Sig_strength_law2 _ _ H.

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

(*
(** [H] is a rank-2 endofunctor on endofunctors *)
Variable H : functor [C, C, hs] [C, C, hs].
*)
(** The forgetful functor from pointed endofunctors to endofunctors *)
Local Notation "'U'" := (functor_ptd_forget C hs).
(** The precategory of pointed endofunctors on [C] *)
Local Notation "'Ptd'" := (precategory_Ptd C hs).
(** The category of endofunctors on [C] *)
Local Notation "'EndC'":= ([C, C, hs]) .
(** The product of two precategories *)
Local Notation "A 'XX' B" := (product_precategory A B) (at level 2).
(** Pre-whiskering defined as morphism part of the functor given by precomposition
    with a fixed functor *)
Local Notation "α 'øø' Z" :=  (# (pre_composition_functor_data _ _ _ hs _  Z) α) (at level 25).

Local Notation "A ⊗ B" := (prodcatpair _ _ A B) (at level 10).

Local Coercion alg_carrier : algebra_ob >-> ob.

(* Local Notation "'τ'" := (tau). *)

(** ** Definition of algebra structure [τ] of a pointed functor *)
(*
Definition AlgStruct (T : Ptd) : UU := pr1 (H(U T)) ⟶ pr1 (U T).

Definition Alg : UU := Σ T : Ptd, AlgStruct T.

Coercion PtdFromAlg (T : Alg) : Ptd := pr1 T.

Definition τ (T : Alg) : pr1 (H (U T)) ⟶ pr1 (U T) := pr2 T.
*)

(* An Id_H algebra is a pointed functor *)

Definition eta_from_alg (T : algebra_ob _ Id_H) : EndC ⟦ functor_identity _,  T ⟧.
Proof.
  exact (CoproductIn1 _ _ ;; alg_map _ _ T).
Defined.

Definition ptd_from_alg (T : algebra_ob _ Id_H) : Ptd.
Proof.
  exists (pr1 T).
  exact (eta_from_alg T).
Defined.

Definition tau_from_alg (T : algebra_ob _ Id_H) : EndC ⟦H T, T⟧.
Proof.
  exact (CoproductIn2 _ _ ;; alg_map _ _ T).
Defined.

Local Notation "'p' T" := (ptd_from_alg T) (at level 3).

(*
Coercion functor_from_algebra_ob (X : algebra_ob _ Id_H) : functor C C  := pr1 X.
*)
Local Notation "` T" := (alg_carrier _ _ T : functor C C) (at level 3).

Local Notation "f ⊕ g" := (CoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) f g) (at level 40).

(*
Definition bracket (T : algebra_ob _ Id_H) : UU :=
  ∀ (Z : Ptd) (f : Z ⇒ ptd_from_alg T), iscontr
   (Σ h : `T ∙ (U Z)  ⇒ T,
          alg_map _ _ T øø (U Z) ;; h =
          CoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) (identity (U Z)) (θ (`T ⊗ Z)) ;;
          CoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) (identity (U Z)) (#H h) ;;
          CoproductArrow _ (CPEndC _ _ ) (#U f) (tau_from_alg T )).
*)

Definition bracket_property (T : algebra_ob _ Id_H) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
           (h : `T ∙ (U Z)  ⇒ T) : UU
  :=
    alg_map _ _ T øø (U Z) ;; h =
          identity (U Z) ⊕ θ (`T ⊗ Z) ;;
          identity (U Z) ⊕ #H h ;;
          CoproductArrow _ (CPEndC _ _ ) (#U f) (tau_from_alg T).

Definition bracket_at (T : algebra_ob _ Id_H) {Z : Ptd} (f : Z ⇒ ptd_from_alg T): UU :=
  iscontr
   (Σ h : `T ∙ (U Z)  ⇒ T, bracket_property T f h).

Definition bracket (T : algebra_ob _ Id_H) : UU
  := ∀ (Z : Ptd) (f : Z ⇒ ptd_from_alg T), bracket_at T f.

Definition bracket_property_parts (T : algebra_ob _ Id_H) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
           (h : `T ∙ (U Z)  ⇒ T) : UU
  :=
    (#U f = eta_from_alg T øø (U Z) ;; h) ×
     (θ (`T ⊗ Z) ;; #H h ;; tau_from_alg T  = tau_from_alg T øø (U Z) ;;  h).

Definition bracket_parts_at (T : algebra_ob _ Id_H) {Z : Ptd} (f : Z ⇒ ptd_from_alg T) : UU :=
   iscontr
   (Σ h : `T ∙ (U Z)  ⇒ T, bracket_property_parts T f h).

Definition bracket_parts (T : algebra_ob _ Id_H) : UU
  := ∀ (Z : Ptd) (f : Z ⇒ ptd_from_alg T), bracket_parts_at T f.

(* show that for any h of suitable type, the following are equivalent *)

Lemma parts_from_whole (T : algebra_ob _ Id_H) (Z : Ptd) (f : Z ⇒ ptd_from_alg T)
      (h :  `T ∙ (U Z)  ⇒ T) :
  bracket_property T f h → bracket_property_parts T f h.
  (*
    alg_map _ _ T øø (U Z) ;; h =
          identity (U Z) ⊕ θ (`T ⊗ Z) ;;
          identity (U Z) ⊕ #H h ;;
          CoproductArrow _ (CPEndC _ _ ) (#U f) (tau_from_alg T ) →
   (#U f = eta_from_alg T øø (U Z) ;; h) ×
     (θ (`T ⊗ Z) ;; #H h ;; tau_from_alg T  = tau_from_alg T øø (U Z) ;;  h ).
*)
Proof.
  intro Hyp.
(*  assert (Hyp_inst :=  maponpaths (fun m:EndC⟦_,_⟧ => CoproductIn1 ([C, C] hs)
      (CPEndC
         ((constant_functor ([C, C] hs) ([C, C] hs) (functor_identity C)) T)
         (H T));;m) Hyp). *)
  split.
  + unfold eta_from_alg.
    apply nat_trans_eq; try (exact hs).
    intro c.
    simpl.
    unfold coproduct_nat_trans_in1_data.
    assert (Hyp_inst := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c); clear Hyp.
    apply (maponpaths (fun m =>  CoproductIn1 C (CP _ _);; m)) in Hyp_inst.
    match goal with |[ H1 : _  = ?f |- _ = _   ] =>
         pathvia (f) end.

    * clear Hyp_inst.
      rewrite <- assoc.
      apply CoproductIn1Commutes_right_in_ctx_dir.
      rewrite id_left.
      apply CoproductIn1Commutes_right_in_ctx_dir.
      rewrite id_left.
      apply CoproductIn1Commutes_right_dir.
      apply idpath.
    * rewrite <- Hyp_inst; clear Hyp_inst.
      rewrite <- assoc.
      apply idpath.
  + unfold tau_from_alg.
    apply nat_trans_eq; try (exact hs).
    intro c.
    simpl.
    unfold coproduct_nat_trans_in2_data.
    assert (Hyp_inst := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c); clear Hyp.
    apply (maponpaths (fun m =>  CoproductIn2 C (CP _ _);; m)) in Hyp_inst.
    match goal with |[ H1 : _  = ?f |- _ = _   ] =>
         pathvia (f) end.

    * clear Hyp_inst.
      do 2 rewrite <- assoc.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      rewrite <- assoc.
      apply maponpaths.
      unfold tau_from_alg.
      apply CoproductIn2Commutes_right_dir.
      apply idpath.
    * rewrite <- Hyp_inst; clear Hyp_inst.
      rewrite <- assoc.
      apply idpath.
Qed.

Lemma whole_from_parts (T : algebra_ob _ Id_H) (Z : Ptd) (f : Z ⇒ ptd_from_alg T)
      (h :  `T ∙ (U Z)  ⇒ T) :
  bracket_property_parts T f h → bracket_property T f h.
(*
  (#U f = eta_from_alg T øø (U Z) ;; h) ×
  (θ (`T ⊗ Z) ;; #H h ;; tau_from_alg T  = tau_from_alg T øø (U Z) ;;  h )
   →
    alg_map _ _ T øø (U Z) ;; h =
          identity (U Z) ⊕ θ (`T ⊗ Z) ;;
          identity (U Z) ⊕ #H h ;;
          CoproductArrow _ (CPEndC _ _ ) (#U f) (tau_from_alg T ).
*)
Proof.
  intros [Hyp1 Hyp2].
  apply nat_trans_eq; try (exact hs).
  intro c.
  apply CoproductArrow_eq_cor.
  + clear Hyp2.
    assert (Hyp1_inst := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp1 c); clear Hyp1.
    rewrite <- assoc.
    apply CoproductIn1Commutes_right_in_ctx_dir.
    rewrite id_left.
    apply CoproductIn1Commutes_right_in_ctx_dir.
    rewrite id_left.
    apply CoproductIn1Commutes_right_dir.
    rewrite Hyp1_inst.
    simpl.
    apply assoc.
  + clear Hyp1.
    assert (Hyp2_inst := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp2 c); clear Hyp2.
    rewrite <- assoc.
    apply CoproductIn2Commutes_right_in_ctx_dir.
    simpl.
    rewrite assoc.
    eapply pathscomp0.
    * eapply pathsinv0.
      exact Hyp2_inst.
    * clear Hyp2_inst.
      simpl.
      do 2 rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn2Commutes_right_dir.
      apply idpath.
Qed.

(* show bracket_parts_point is logically equivalent to bracket_point, then
   use it to show that bracket_parts is equivalent to bracket using [weqonsecfibers:
  ∀ (X : UU) (P Q : X → UU),
  (∀ x : X, P x ≃ Q x) → (∀ x : X, P x) ≃ (∀ x : X, Q x)] *)

Definition hss : UU := Σ T, bracket T.

Coercion alg_from_hss (T : hss) : algebra_ob _ Id_H := pr1 T.

Definition fbracket (T : hss) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
  : `T ∙ (U Z) ⇒ T
  := pr1 (pr1 (pr2 T Z f)).

(** The bracket operation [fbracket] is unique *)

Definition fbracket_unique_pointwise (T : hss) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
  : ∀ (α : functor_composite (U Z) `T ⟶ `T),
     (∀ c : C, pr1 (#U f) c = pr1 (eta_from_alg T) (pr1 (U Z) c) ;; α c) →
     (∀ c : C, pr1 (θ (`T ⊗ Z))  c ;; pr1 (#H α) c ;; pr1 (tau_from_alg T) c =
        pr1 (tau_from_alg T) (pr1 (U Z) c) ;; α c) → α = fbracket T f.
Proof.
  intros α H1 H2.
  apply path_to_ctr.
  apply whole_from_parts.
  split.
  - apply nat_trans_eq; try assumption.
  - apply nat_trans_eq; assumption.
Qed.

Definition fbracket_unique (T : hss) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
: ∀ α : functor_composite (U Z)(`T) ⟶ `T,
    bracket_property_parts T f α
(*
     (#U f = eta_from_alg T øø ((U Z)) ;; α) →
     (θ (`T ⊗ Z) ;; #H α ;; tau_from_alg T = tau_from_alg T øø (U Z) ;; α)
*)
   → α = fbracket T f.
Proof.
  intros α [H1 H2].
  apply path_to_ctr.
  apply whole_from_parts.
  split;  assumption.
Qed.

Definition fbracket_unique_target_pointwise (T : hss) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
: ∀ α : functor_composite (U Z)(`T) ⟶ `T,
        bracket_property_parts T f α
(*
     (#U f =  eta_from_alg T øø U Z ;; α) →
     (θ (`T ⊗ Z) ;; #H α ;; tau_from_alg T = tau_from_alg T øø U Z ;; α)
*)
   → ∀ c, α c = pr1 (fbracket T f) c.
Proof.
  intros α H12.
  set (t:= fbracket_unique _ _ α H12).
  apply (nat_trans_eq_weq _ _ hs _ _ _ _ t).
Qed.

(** Properties of [fbracket] by definition: commutative diagrams *)

Lemma fbracket_η (T : hss) : ∀ {Z : Ptd} (f : Z ⇒ ptd_from_alg T),
   #U f = eta_from_alg T øø U Z ;; fbracket T f.
Proof.
  intros Z f.
  (* assert (H' := parts_from_whole T Z f (fbracket _ f)) . *)
  exact (pr1 (parts_from_whole _ _ _ _  (pr2 (pr1 (pr2 T Z f))))).
Qed.

Lemma fbracket_τ (T : hss) : ∀ {Z : Ptd} (f : Z ⇒ ptd_from_alg T),
    θ (`T ⊗ Z) ;; #H (fbracket T f) ;; tau_from_alg T
    =
    tau_from_alg T øø U Z ;; (fbracket T f).
Proof.
  intros Z f.
  exact (pr2 (parts_from_whole _ _ _ _ (pr2 (pr1 (pr2 T Z f))))).
Qed.

(** [fbracket] is also natural *)

Lemma fbracket_natural (T : hss) {Z Z' : Ptd} (f : Z ⇒ Z') (g : Z' ⇒ ptd_from_alg T)
  : post_whisker _ _ _ _ (#U f)(`T) ;; fbracket T g = fbracket T (f ;; g).
Proof.
  apply fbracket_unique_pointwise.
  - simpl. intro c.
    rewrite assoc.
    set (H':=nat_trans_ax (eta_from_alg T)).
    simpl in H'.
    rewrite <- H'; clear H'.
    rewrite <- assoc.
    apply maponpaths.
    set (X:= nat_trans_eq_weq _ _ hs _ _ _ _  (fbracket_η T g)).
    simpl in X. exact (X _ ).
  - intro c; simpl.
    assert (H':=nat_trans_ax (tau_from_alg T)).
    simpl in H'.
    eapply pathscomp0. Focus 2. apply (!assoc _ _ _ _ _ _ _ _ ).
    eapply pathscomp0. Focus 2.  apply  cancel_postcomposition. apply H'.
    clear H'.
    set (H':=fbracket_τ T g).
    simpl in H'.
    assert (X:= nat_trans_eq_pointwise _ _  _ _ _ _ H' c).
    simpl in X.
    rewrite  <- assoc.
    rewrite  <- assoc.
    transitivity (  # (pr1 (H ((`T)))) (pr1 (pr1 f) c) ;;
                     (pr1 (θ ((`T) ⊗ Z')) c);; pr1 (# H (fbracket T g)) c;; pr1 (tau_from_alg T) c).
    Focus 2.
      rewrite <- assoc.
      rewrite <- assoc.
      apply maponpaths.
      repeat rewrite assoc.
      apply X.
    clear X.
    set (A:=θ_nat_2_pointwise).
    simpl in *.
    set (A':= A _ hs H θ (`T) Z Z').
    simpl in A'.
    set (A2:= A' f).
    clearbody A2; clear A'; clear A.
    rewrite A2; clear A2.
    repeat rewrite <- assoc.
    apply maponpaths.
    simpl.
    repeat rewrite assoc.
    apply cancel_postcomposition.
    set (A := functor_comp H).
    simpl in A.
    rewrite A.
    apply cancel_postcomposition.
    clear A. clear H'.
    set (A:=horcomp_id_postwhisker C _ _ hs hs).
    rewrite A.
    apply idpath.
Qed.

(** As a consequence of naturality, we can compute [fbracket f] from [fbracket identity] *)

Lemma compute_fbracket (T : hss) : ∀ {Z : Ptd} (f : Z ⇒ ptd_from_alg T),
  fbracket T f = post_whisker _ _ _ _ (#U f)(`T) ;; fbracket T (identity _ ).
Proof.
  intros Z f.
  assert (A : f = f ;; identity _ ).
  { rewrite id_right; apply idpath. }
  rewrite A.
  rewrite <- fbracket_natural.
  rewrite id_right.
  apply idpath.
Qed.

(** ** Morphisms of heterogeneous substitution systems *)

(** A morphism [f] of pointed functors is an algebra morphism when... *)
(*
Definition isAlgMor {T T' : Alg} (f : T ⇒ T') : UU :=
  #H (# U f) ;; τ T' = compose (C:=EndC) (τ T) (#U f).

Lemma isaprop_isAlgMor (T T' : Alg) (f : T ⇒ T') : isaprop (isAlgMor f).
Proof.
  apply isaset_nat_trans.
  apply hs.
Qed.
*)

(** a little preparation for much later *)
Lemma τ_part_of_alg_mor  (T T' : algebra_ob ([C, C] hs) Id_H)
  (β : algebra_mor ([C, C] hs) Id_H T T'): #H β ;; tau_from_alg T' = compose (C:=EndC) (tau_from_alg T) β.
Proof.
  assert (β_is_alg_mor := pr2 β).
  simpl in β_is_alg_mor.
  assert (β_is_alg_mor_inst := maponpaths (fun m:EndC⟦_,_⟧ => (CoproductIn2 EndC (CPEndC _ _));; m) β_is_alg_mor); clear β_is_alg_mor.
  simpl in β_is_alg_mor_inst.
  apply nat_trans_eq; try (exact hs).
  intro c.
  assert (β_is_alg_mor_inst':= nat_trans_eq_pointwise _ _ _ _ _ _ β_is_alg_mor_inst c); clear β_is_alg_mor_inst.
  simpl in β_is_alg_mor_inst'.
  rewrite assoc in β_is_alg_mor_inst'.
  eapply pathscomp0.
Focus 2.
  eapply pathsinv0.
  exact β_is_alg_mor_inst'.
  clear β_is_alg_mor_inst'.
  apply CoproductIn2Commutes_right_in_ctx_dir.
  simpl.
  rewrite <- assoc.
  apply idpath.
Qed.

(** A morphism [β] of pointed functors is a bracket morphism when... *)

Lemma is_ptd_mor_alg_mor (T T' : algebra_ob ([C, C] hs) Id_H)
  (β : algebra_mor ([C, C] hs) Id_H T T') :
  @is_ptd_mor C (ptd_from_alg T) (ptd_from_alg T') (pr1 β).
Proof.
  simpl.
  unfold is_ptd_mor. simpl.
  intro c.
  rewrite <- assoc.
  assert (X:=pr2 β).
  assert (X':= nat_trans_eq_pointwise _ _ _ _ _ _ X c).
  simpl in *.
  eapply pathscomp0. apply maponpaths. apply X'.
  unfold coproduct_nat_trans_in1_data.
  repeat rewrite assoc.
  unfold coproduct_nat_trans_data.
  eapply pathscomp0.
  apply cancel_postcomposition.
  apply CoproductIn1Commutes.
  simpl.
  repeat rewrite <- assoc.
  apply id_left.
Qed.

Definition ptd_from_alg_mor {T T' : algebra_ob _ Id_H} (β : algebra_mor _ _ T T')
: ptd_from_alg T ⇒ ptd_from_alg T'.
Proof.
  exists (pr1 β).
  apply is_ptd_mor_alg_mor.
Defined.

(* show functor laws for [ptd_from_alg] and [ptd_from_alg_mor] *)

Definition ptd_from_alg_functor_data : functor_data (precategory_FunctorAlg _ Id_H hsEndC) Ptd.
Proof.
  exists ptd_from_alg.
  intros T T' β.
  apply ptd_from_alg_mor.
  exact β.
Defined.

Lemma is_functor_ptd_from_alg_functor_data : is_functor ptd_from_alg_functor_data.
Proof.
  split; simpl; intros.
  + unfold functor_idax.
    intro T.
    (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *)
    apply (invmap (eq_ptd_mor_precat _ hs _ _)).
    apply (invmap (eq_ptd_mor _ hs _ _)).
    (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *)
    apply idpath.
  + unfold functor_compax.
    intros T T' T'' β β'.
    apply (invmap (eq_ptd_mor_precat _ hs _ _)).
    apply (invmap (eq_ptd_mor _ hs _ _)).
    apply idpath.
Qed.

Definition ptd_from_alg_functor: functor (precategory_FunctorAlg _ Id_H hsEndC) Ptd :=
  tpair _ _ is_functor_ptd_from_alg_functor_data.

Definition isbracketMor {T T' : hss} (β : algebra_mor _ _ T T') : UU :=
    ∀ (Z : Ptd) (f : Z ⇒ ptd_from_alg T),
       fbracket _ f ;;  β
       =
       (β)øø (U Z) ;; fbracket _ (f ;; # ptd_from_alg_functor β ).

Lemma isaprop_isbracketMor (T T':hss) (β : algebra_mor _ _ T T') : isaprop (isbracketMor β).
Proof.
  do 2 (apply impred; intro).
  apply isaset_nat_trans.
  apply hs.
Qed.

(** A morphism of hss is a pointed morphism that is compatible with both
    [τ] and [fbracket] *)

Definition ishssMor {T T' : hss} (β : algebra_mor _ _ T T') : UU
  :=   isbracketMor β.

Definition hssMor (T T' : hss) : UU
  := Σ β : algebra_mor _ _ T T', ishssMor β.

Coercion ptd_mor_from_hssMor (T T' : hss) (β : hssMor T T') : algebra_mor _ _ T T' := pr1 β.

(*
Definition isAlgMor_hssMor {T T' : hss} (β : hssMor T T')
  : isAlgMor β := pr1 (pr2 β).
*)
Definition isbracketMor_hssMor {T T' : hss} (β : hssMor T T')
  : isbracketMor β := pr2 β.

(** **** Equality of morphisms of hss *)

Section hssMor_equality.

(** Show that equality of hssMor is equality of underlying nat. transformations *)

Variables T T' : hss.
Variables β β' : hssMor T T'.
Definition hssMor_eq1 : β = β' ≃ (pr1 β = pr1 β').
Proof.
  apply total2_paths_isaprop_equiv.
  intro γ.
  apply isaprop_isbracketMor.
Defined.

Definition hssMor_eq : β = β' ≃ (β : EndC ⟦ _ , _ ⟧) = β'.
Proof.
  eapply weqcomp.
  - apply hssMor_eq1.
  - apply total2_paths_isaprop_equiv.
    intro.
    apply isaset_nat_trans.
    apply hs.
Defined.

End hssMor_equality.

Lemma isaset_hssMor (T T' : hss) : isaset (hssMor T T').
Proof.
  intros β β'.
  apply (isofhlevelweqb _ (hssMor_eq _ _ β β')).
  apply isaset_nat_trans.
  apply hs.
Qed.

(** ** The precategory of hss *)

(** *** Identity morphism of hss *)

Lemma ishssMor_id (T : hss) : ishssMor (identity (C:=precategory_FunctorAlg _ _ hsEndC ) (pr1 T)).
Proof.
  unfold ishssMor.
  unfold isbracketMor.
  intros Z f.
  rewrite id_right.
  rewrite functor_id.
  rewrite id_right.
  apply pathsinv0.
  set (H2:=pre_composition_functor _ _ C _ hs (U Z)).
  set (H2' := functor_id H2). simpl in H2'.
  simpl.
  rewrite H2'.
  rewrite (id_left EndC).
  apply idpath.
Qed.

Definition hssMor_id (T : hss) : hssMor _ _ := tpair _ _ (ishssMor_id T).

(** *** Composition of morphisms of hss *)

Lemma ishssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'')
  : ishssMor (compose (C:=precategory_FunctorAlg _ _ hsEndC) (pr1 β)  (pr1 γ)).
Proof.
  unfold ishssMor.
  unfold isbracketMor.
  intros Z f.
  eapply pathscomp0.
    apply assoc.
  (* match goal with | [|- ?l = _ ] => assert (Hyp : l = fbracket T f;; pr1 β;; pr1 γ) end. *)
  eapply pathscomp0.
    apply cancel_postcomposition.
    apply isbracketMor_hssMor.
  rewrite <- assoc.
  eapply pathscomp0.
    apply maponpaths.
    apply isbracketMor_hssMor.
  rewrite assoc.
  rewrite functor_comp.
  rewrite assoc.
  apply cancel_postcomposition.
  set (H2:=functor_comp (pre_composition_functor _ _ C _ hs (U Z)) ).
  apply pathsinv0.
  apply H2.
Qed.

Definition hssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'')
  : hssMor T T'' := tpair _ _ (ishssMor_comp β γ).

Definition hss_obmor : precategory_ob_mor.
Proof.
  exists hss.
  exact hssMor.
Defined.

Definition hss_precategory_data : precategory_data.
Proof.
  exists hss_obmor.
  split.
  - exact hssMor_id.
  - exact @hssMor_comp.
Defined.

Lemma is_precategory_hss : is_precategory hss_precategory_data.
Proof.
  repeat split; intros.
  - apply (invmap (hssMor_eq _ _ _ _ )).
    apply (id_left EndC).
  - apply (invmap (hssMor_eq _ _ _ _ )).
    apply (id_right EndC).
  - apply (invmap (hssMor_eq _ _ _ _ )).
    apply (assoc EndC).
Qed.

Definition hss_precategory : precategory := tpair _ _ is_precategory_hss.

End def_hss.

Arguments hss {_ _} _  _ .
Arguments hssMor {_ _ _ _ } _ _ .
Arguments fbracket {_ _ _ _ } _ {_} _ .
Arguments fbracket_η {_ _ _ _ } _ {_} _ .
Arguments fbracket_τ {_ _ _ _} _ {_} _ .
Arguments fbracket_unique_target_pointwise {_ _ _ _ } _ {_ _ _} _ _  .
Arguments fbracket_unique {_ _ _ _ } _ {_} _ _ _  .
(* Arguments Alg {_ _} _. *)
Arguments hss_precategory {_ _} _ _ .


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj12synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus lv0 lv1) (plus (plus Zero (plus lv0 lv2)) (mult lv3 lv2))).
Admitted.
QuickChick conj12synthconj1.


Require Import base.
Require Import z_theory_base.
Require Import z_theory_bool.
Require Import z_theory_N.
Require Import Classical.
Require Import Ltac.
Require Import Logic.
Require Import Specif.
Require Import Coq.Init.Tactics.

Section ZNums.
Definition Zset :=
	E{ p in cartesian Nnat Nnat | exists a b : _, (E(a, b) =E p) /\ ((a =E N O) \/ (b =E N O)) }.
Lemma Zminimize (v : Ensemble) (vin : v inE cartesian Nnat Nnat) :
	let (tmpm, tmp) := cartesian_is_product _ _ _ vin in
	let (tmpn, tmp2) := tmp in
	let (tmp3, veq) := tmp2 in
	let (minN, ninN) := tmp3 in
	let (m, _) := minN in
	let (n, _) := ninN in
	Eexists z in Zset, exists a b : _, (E(N a, N b) =E z) /\ (addN m b = addN n a).
	specialize (cartesian_is_product _ _ _ vin) as [m [n [[minN ninN] veq]]].
	unfold In, cartesian, separation_cons, Nnat, power_set_cons, pair_union_cons, pairing_cons, ens_union_cons in vin.
	Unset Printing Notations.
	destruct vin as [l r].
Definition Zadd l r :=

End ZNums.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult (Succ Zero) lv0) (plus lv1 (Succ lv2))).
Admitted.
QuickChick conj3synthconj3.


Require Import Stlc.SpecTyping.
Require Import Stlc.SpecEquivalent.
Require Import Stlc.LemmasEvaluation.
Require Import Utlc.SpecEquivalent.
Require Import Utlc.LemmasEvaluation.

Require Import Compiler.Erase.
Require Import Compiler.ProtectConfine.

Require Import LogRel.PseudoType.
Require Import LogRel.LemmasPseudoType.
Require Import LogRel.LR.
Require Import LogRel.LemmasLR.

Require Import Omega.

Definition compile (τ : S.Ty) (t : S.Tm) : U.UTm :=
  U.app (protect τ) (erase t).

Definition compile_pctx (τ : S.Ty) (C : S.PCtx) : U.PCtx :=
  U.pctx_cat (U.papp₂ (confine τ) U.phole) (erase_pctx C).

Lemma equivalenceReflection {t₁ t₂ τ} :
  ⟪ S.empty ⊢ t₁ : τ ⟫ →
  ⟪ S.empty ⊢ t₂ : τ ⟫ →
  ⟨ 0 ⊢ compile τ t₁ ≃ compile τ t₂ ⟩ →
  ⟪ S.empty ⊢ t₁ ≃ t₂ : τ ⟫.
Proof.
  revert t₁ t₂ τ.
  enough (∀ {t₁ t₂} τ,
            ⟪ S.empty ⊢ t₁ : τ ⟫ →
            ⟪ S.empty ⊢ t₂ : τ ⟫ →
            ⟨ 0 ⊢ compile τ t₁ ≃ compile τ t₂ ⟩ →
            ∀ C τ', ⟪ ⊢ C : S.empty , τ → S.empty, τ' ⟫ →
                    S.Terminating (S.pctx_app t₁ C) → S.Terminating (S.pctx_app t₂ C)) as Hltor
      by (intros t₁ t₂ τ ty1 ty2 eq C τ';
          assert (⟨ 0 ⊢ compile τ t₂ ≃ compile τ t₁ ⟩)
            by (apply U.pctx_equiv_symm; assumption);
          split;
          refine (Hltor _ _ τ _ _ _ C τ' _); assumption).

  intros t₁ t₂ τ ty1 ty2 eq C τ' tyC term.

  destruct (S.Terminating_TerminatingN term) as [n termN]; clear term.

  assert (⟪ pempty ⊩ t₁ ⟦ dir_lt , S n ⟧ compile τ t₁ : embed τ ⟫) as lrt₁ by
      (unfold compile;
       apply protect_transp_open;
       exact (erase_correct ty1)).
  assert (⟪ ⊩ C ⟦ dir_lt , S n ⟧ erase_pctx C : pempty , embed τ → pempty , embed τ' ⟫) as lrC_lt
    by (apply (erase_ctx_correct tyC)).
  apply lrC_lt in lrt₁.

  assert (U.Terminating (U.pctx_app (compile τ t₁) (erase_pctx C)))
    as termu₁ by (apply (adequacy_lt lrt₁ termN); omega).

  assert (U.Terminating (U.pctx_app (compile τ t₂) (erase_pctx C)))
    by (apply eq; try assumption;
        apply (erase_pctx_scope C _ _ _ _ tyC)).

  destruct (U.Terminating_TerminatingN H) as [n' termN']; clear H.

  assert (⟪ ⊩ C ⟦ dir_gt , S n' ⟧ erase_pctx C : pempty , embed τ → pempty , embed τ' ⟫) as lrC_gt
    by (apply (erase_ctx_correct tyC)).
  assert (⟪ pempty ⊩ t₂ ⟦ dir_gt , S n' ⟧ compile τ t₂ : embed τ ⟫) as lrt₂ by
      (unfold compile;
       apply protect_transp_open;
       exact (erase_correct ty2)).
  apply lrC_gt in lrt₂.

  apply (adequacy_gt lrt₂ termN'); omega.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B D T Bprimeprime : Universe, ((wd_ A B /\ (wd_ A D /\ (wd_ A T /\ (wd_ B D /\ (wd_ B T /\ (wd_ D T /\ (wd_ Bprimeprime T /\ (wd_ D Bprimeprime /\ (wd_ B Bprimeprime /\ (col_ Bprimeprime B D /\ (col_ B Bprimeprime T /\ col_ T D A))))))))))) -> col_ A B T)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Cprime P Q : Universe, ((wd_ A B /\ (wd_ P Q /\ (wd_ Q C /\ (wd_ P C /\ (wd_ C Cprime /\ (col_ A B C /\ (col_ A B Cprime /\ (col_ P Q A /\ (col_ P Q B /\ (col_ P Q Cprime /\ col_ P A B)))))))))) -> col_ Q A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import String.
Require Import Names.
Require Import PNames.
Require Import Bool.
Require Import Lambda.
Require Import Bool_Lambda.
Require Import Functors.
(* Require Import MonadLib. *)

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := BType :+: LType.

End Type_Test_Section.

Section Test_Section.

  Definition E (A : Set) := Bool :+: (Lambda D A).

  Global Instance Fun_E : forall (A : Set),
    Functor (E A).
  Proof.
    eauto with typeclass_instances.
  Defined.

  Instance D_typeof T : FAlgebra TypeofName T (typeofR D) (E (typeofR D)).
    eauto 150 with typeclass_instances.
  Defined.

  Definition V := StuckValue :+: BotValue :+: (ClosValue E) :+: BoolValue.

  Instance V_eval : FAlgebra EvalName (Exp E nat) (evalR V) (E nat).
    eauto 150 with typeclass_instances.
  Defined.

  Definition SV := (SubValue_refl V) ::+:: (SubValue_Bot V) ::+:: (SubValue_Clos E V).

   Definition EV_Alg : PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (E _) SV))) (E nat).
    eauto 150 with typeclass_instances.
   Defined.

  Definition eval_continuous : forall m,
    forall (e : Exp E nat) (gamma gamma' : Env _),
      forall n (Sub_G_G' : Sub_Environment V SV gamma gamma'),
        m <= n ->
        SubValueC _ SV (beval _ _ m e gamma) (beval _ _ n e gamma').
    eapply beval_continuous with (eval_continuous_Exp_E := EV_Alg);
      eauto 150 with typeclass_instances.
  Qed.

  Eval compute in ("Continuity of Evaluation Proven!").

  Definition Eqv (A B : Set) := (NP_Functor_eqv E Bool A B) ::+:: (Lambda_eqv D E A B).
  Definition WFV := (WFValue_Clos D E V Eqv ((fun e => typeof _ _ (proj1_sig e)))) ::+::
    (WFValue_Bot D V) ::+:: (WFValue_VB D V).

  Instance eq_DType_eq_alg : (PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D).
    eauto 250 with typeclass_instances.
  Defined.

  Global Instance Bool_Soundness_alg P_bind P pb typeof_rec eval_rec :
    PAlgebra eval_Soundness_alg_Name
    (sig (UP'_P2 (eval_alg_Soundness_P D V (E nat) WFV P_bind P
      (E (typeofR D)) (Functor_Plus Bool (Lambda D (typeofR D))) pb typeof_rec eval_rec
      f_algebra f_algebra))) Bool.
  Proof.
    eauto 100 with typeclass_instances.
  Defined.

  Theorem soundness : forall n gamma gamma' gamma'' e' e'',
    E_eqvC _ Eqv gamma gamma' e' e'' ->
    forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
      exists T, lookup gamma b = Some T)
    (WF_gamma2 : List.length gamma = List.length gamma')
    (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
    (WF_gamma'' : WF_Environment _ _ WFV gamma'' gamma) T,
    typeof D (E _) (proj1_sig e') = Some T -> WFValueC _ _ WFV (beval _ _ n e'' gamma'') T.
  Proof.
    apply soundness_X with (eval_continuous_Exp_E := EV_Alg);
      eauto 350 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Lambda :+: Boolean Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import list_examples.

Require Import ZArith.
Require Import List.

Definition head_code :=
  SReturn (ELoad (EVar "x")).

Lemma head_spec : forall c, kcell c = kra (KStmt head_code) kdot ->
    forall xv,
      store c ~= ("x" s|-> KInt xv) ->
    forall hd tl m,
      heap c |= rep_list (hd :: tl) xv :* litP m
     -> sound kstep (returns c hd).
Proof.
list_solver.
Qed.


Require Export himp_cfg_and_prims.
Require Import equate_map_reflection.
Require Import patterns.

Require Import himp_claims.

Require Import Setoid.
Require Import ZArith.

Fixpoint stk_equiv (s1 s2 : list Frame) : Prop :=
  match s1, s2 with
    | nil, nil => True
    | frame k1 e1::s1', frame k2 e2::s2' =>
      k1 = k2 /\ e1 ~= e2 /\ stk_equiv s1' s2'
    | _, _ => False
  end.

Definition kequiv (k1 k2 : kcfg) : Prop :=
  match k1, k2 with
    | KCfg k1 store1 stk1 heap1 funs1 mark1,
      KCfg k2 store2 stk2 heap2 funs2 mark2 =>
      k1 = k2 /\ store1 ~= store2 /\ stk_equiv stk1 stk2
      /\ heap1 ~= heap2 /\ funs1 ~= funs2 /\ mark1 = mark2
  end.

Add Morphism KCfg with signature
  @eq k ==> MapEquiv ==> stk_equiv ==> MapEquiv ==> MapEquiv ==> @eq Z ==> kequiv as KCfg_mor.
Proof. firstorder. Qed.

(** A predicate saying two stacks are equivalent,
    requires exact equality of the code but compares
    environments up to map equality *)

Definition returning' c e c' : Prop :=
     match c' with
       | KCfg (kra (KStmt (SReturn e')) _) _ stack' heap' functions' _ =>
         match c with
           | KCfg kcell _ stack heap functions alloc_mark =>
               e = e'
               /\ stk_equiv stack stack'
               /\ heap ~= heap'
               /\ functions ~= functions'
         end
       | _ => False
     end.

Lemma returning_returns : forall c e c', returning' c e c' ->
  exists krest,
  kcell c' = kra (KStmt (SReturn e)) krest.
Proof.
destruct c'.
simpl;intro H.
repeat match type of H with
| (match ?x with _ => _ end) => destruct x;try solve[destruct H];[idtac]
end.
intuition.
exists kcell.
congruence.
Qed.

Definition returning c v := returning' c (ECon v).
Inductive returns (c : kcfg) (v : Z) : kcfg -> (kcfg -> Prop) -> Prop :=
  returns_claim : returns c v c (returning c v).

Definition returning_bool c b := returning' c (BCon b).
Inductive returns_bool (c : kcfg) (v : bool) : kcfg -> (kcfg -> Prop) -> Prop :=
  returns_bool_claim : returns_bool c v c (returning_bool c v).

Definition get_returning (c : kcfg) : option Z :=
  match kcell c with
    | kra (KStmt (SReturn (ECon v'))) _ => Some v'
    | _ => None
  end.
Lemma get_returning_returns : forall c,
  match get_returning c with
    | Some v => exists krest, kcell c = kra (KStmt (SReturn (ECon v))) krest
    | None => True
  end.
Proof.
destruct c.
unfold get_returning. simpl.
repeat match goal with
| [|- match (match ?x with _ => _ end) with _ => _ end]
   => destruct x;try (exact I)
end.
eexists.
reflexivity.
Qed.

Lemma use_returning : forall ckcell cstore cstk cheap cfunctions cmark
     e (Q : kcfg -> (kcfg -> Prop) -> Prop) (P : kcfg -> Prop),
  (forall kstore kheap kfunctions kmark,
    cheap ~= kheap ->
    cfunctions ~= kfunctions ->
   forall kstk,
    stk_equiv cstk kstk ->
   forall krest,
    Q (KCfg (kra (KStmt (SReturn e)) krest)
            kstore kstk kheap kfunctions kmark) P
   ) ->
  (forall k', returning'
     (KCfg ckcell cstore cstk cheap cfunctions cmark)
    e k' -> Q k' P).
intros.
pose proof (returning_returns _ _ _ H0).
destruct H1.
destruct k';simpl in * |- *;subst.
intuition.
Qed.

Lemma expose_frame : forall p m stk (Q : list Frame -> Prop),
  (forall m' stk',
     m' ~= m -> stk_equiv stk stk' -> Q (frame p m'::stk')) ->
  (forall stk',
     stk_equiv (frame p m::stk) stk' -> Q stk').
intros.
destruct stk';[solve[destruct H0]|].
destruct f.
simpl in H0.
intuition. subst.
symmetry in H0.
auto.
Qed.

(* Somehow simple "apply" doesn't unify well enough *)
Ltac use_expose_frame := refine (expose_frame _ _ _ _ _).


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Functor.
Require Import Blech.Category.Over.
Require Import Blech.Category.Bsh.

Require Blech.Reflect.

Import CategoryNotations.
Import FunctorNotations.
Import BishopNotations.
Import OverNotations.

Open Scope category_scope.
Open Scope object_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[local]
Definition pullback {A B C: Bsh} (f: Bsh A C) (g: Bsh B C) :=
  { '(x, y) | proj1_sig f x == proj1_sig g y }.

#[program]
Instance pullback_Setoid {A B C: Bsh} (f: Bsh A C) (g: Bsh B C): Setoid (pullback f g) := {
  equiv x y := fst (proj1_sig x) == fst (proj1_sig y) ∧ snd (proj1_sig x) == snd (proj1_sig y) ;
}.

Next Obligation.
Proof.
  exists.
  - intros [[? ?] p].
    cbn in *.
    split.
    all: reflexivity.
  - intros [[? ?] p] [[? ?] q] [r l].
    cbn in *.
    rewrite r, l.
    split.
    all: reflexivity.
  - intros [[? ?] ?] [[? ?] ?] [[? ?] ?] [p q] [r s].
    cbn in *.
    rewrite p, q, r, s.
    split.
    all: reflexivity.
Qed.

#[program]
Definition Basechange {A B: Bsh} (f: Bsh A B): Functor (Bsh/B) (Bsh/A) := {|
  op (u: Bsh/B) := lub (pullback f (π u) /~ pullback_Setoid f (π u)), λ x, fst (proj1_sig x) ;
  map '(lub _, _) '(lub _, _) f '(x, y) := (x, f y) ;
|}.

Next Obligation.
Proof.
  intros ? ? [p q].
  auto.
Qed.

Next Obligation.
Proof.
  rewrite (H _).
  cbn in *.
  destruct pat.
  cbn in *.
  destruct x0.
  cbn in *.
  inversion Heq_anonymous.
  subst.
  apply e.
Qed.

Next Obligation.
Proof.
  intros ? ? [p q].
  cbn.
  rewrite p, q.
  split.
  all: reflexivity.
Qed.

Next Obligation.
Proof.
  exists.
  all: cbn.
  - intros.
    split.
    all: reflexivity.
  - intros.
    split.
    all: reflexivity.
  - intros ? ? [? ?] [? ?] r [[? ?] ?].
    cbn in *.
    split.
    1: reflexivity.
    apply r.
Qed.


Set Implicit Arguments.
Unset Strict Implicit.

Module Type SIG.
  Parameter id : forall A : Set, A -> A.
End SIG.

Module M (X: SIG).
  Definition idid := X.id X.id.
  Definition id := idid X.id.
End M.

Module N := M.

Module Nat.
  Definition T := nat.
  Definition x := 0.
  Definition id (A : Set) (x : A) := x.
End Nat.

Module Z := N Nat.

Check (Z.idid 0).

Module P (Y: SIG) := N.

Module Y := P Nat Z.

Check (Y.id 0).


Require Import Coq.Logic.Classical.
Require Import Coq.Lists.List.
Require Import Coq.Sets.Ensembles.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.floyd.sublist.
Require Import compcert.lib.Integers.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.Relation_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.reachable_computable.
Require Export CertiGraph.graph.FiniteGraph.
Require Export CertiGraph.graph.MathGraph.
Require Export CertiGraph.graph.LstGraph.
Require Export CertiGraph.msl_application.UnionFindGraph.

Local Open Scope logic.
Local Open Scope Z_scope.

Instance Z_EqDec : EqDec Z eq. Proof. hnf. intros. apply Z.eq_dec. Defined.

Definition is_null_Z: DecidablePred Z := existT (fun P : Z -> Prop => forall a : Z, {P a} + {~ P a}) (fun x : Z => x < 0) (fun a : Z => Z_lt_dec a 0).

Definition UFGraph := (@UFGraph Z Z _ _ is_null_Z id nat unit unit).
Definition LGraph := (@LGraph Z Z _ _ nat unit unit).
Definition UFGraph_LGraph (G: UFGraph): LGraph := lg_gg G.

Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Instance maGraph(G: UFGraph): MathGraph G is_null_Z := maGraph G.
Instance finGraph (G: UFGraph): FiniteGraph G := finGraph G.
Instance liGraph (G: UFGraph):  LstGraph G id := liGraph G.

Definition vgamma := (@vgamma Z Z _ _ is_null_Z id nat unit unit).
Definition Graph_gen_redirect_parent (g: UFGraph) (x: Z) (pa: Z) (H: weak_valid g pa) (Hv: vvalid g x) (Hn: ~ reachable g pa x): UFGraph :=
    Graph_gen_redirect_parent g x pa H Hv Hn.

Class SpatialArrayGraphAssum (Pred : Type):=
  {
    SGP_ND: NatDed Pred;
    SGP_SL : SepLog Pred;
    SGP_ClSL: ClassicalSep Pred;
    SGP_CoSL: CorableSepLog Pred
  }.

Fixpoint makeSet_discrete_PreGraph (size: nat) : PreGraph Z Z :=
  match size with
  | O => Build_PreGraph Z_EqDec Z_EqDec (fun _ => False) (fun _ => False) (fun _ => -1) (fun _ => -1)
  | S n => pregraph_add_edge (pregraph_add_vertex (makeSet_discrete_PreGraph n) (Z.of_nat n)) (Z.of_nat n) (Z.of_nat n) (-1)
  end.

Lemma makeSet_vvalid: forall size x, vvalid (makeSet_discrete_PreGraph size) x <-> 0 <= x < Z.of_nat size.
Proof.
  induction size; simpl; intros; split; intros.
  - exfalso; auto.
  - destruct H. intuition.
  - unfold addValidFunc in H. rewrite Zpos_P_of_succ_nat, <- Z.add_1_r. destruct H; [rewrite IHsize in H|]; intuition.
  - unfold addValidFunc. rewrite Zpos_P_of_succ_nat, <- Z.add_1_r in H. rewrite IHsize. lia.
Qed.

Lemma makeSet_evalid: forall size e, evalid (makeSet_discrete_PreGraph size) e <-> 0 <= e < Z.of_nat size.
Proof.
  induction size; simpl; intros; split; intros.
  - exfalso. auto.
  - destruct H; intuition.
  - unfold addValidFunc in H. rewrite Zpos_P_of_succ_nat, <- Z.add_1_r. destruct H; [apply IHsize in H | subst e]; intuition.
  - unfold addValidFunc. rewrite Zpos_P_of_succ_nat, <- Z.add_1_r in H. rewrite IHsize. lia.
Qed.

Lemma makeSet_evalid_src: forall size e, evalid (makeSet_discrete_PreGraph size) e -> src (makeSet_discrete_PreGraph size) e = e.
Proof.
  induction size; simpl; intros.
  - exfalso; auto.
  - unfold addValidFunc in H. unfold updateEdgeFunc. destruct (equiv_dec (Z.of_nat size) e).
    + unfold Equivalence.equiv in e0. auto.
    + unfold Equivalence.equiv in c. unfold complement in c. destruct H. 1: apply IHsize; auto. exfalso; intuition.
Qed.

Lemma makeSet_dst: forall size e, dst (makeSet_discrete_PreGraph size) e = -1.
Proof. induction size; simpl; intros; auto. unfold updateEdgeFunc. destruct (equiv_dec (Z.of_nat size) e); auto. Qed.

Definition makeSet_discrete_MathGraph (size: nat) : MathGraph (makeSet_discrete_PreGraph size) is_null_Z.
Proof.
  constructor; intros; [split|].
  - rewrite (makeSet_evalid_src _ _ H). rewrite makeSet_evalid in H. rewrite makeSet_vvalid. auto.
  - left. rewrite makeSet_dst. hnf. rewrite Z.compare_lt_iff. intuition.
  - rewrite makeSet_vvalid in H. hnf in H0. rewrite Z.compare_lt_iff in H0. intuition.
Qed.

Definition makeSet_discrete_LstGraph (size: nat) : LstGraph (makeSet_discrete_PreGraph size) id.
Proof.
  constructor; intros.
  - unfold id. split; intros.
    + destruct H0. apply makeSet_evalid_src in H1. intuition.
    + subst e. split.
      * rewrite makeSet_vvalid, <- makeSet_evalid in H. apply makeSet_evalid_src; auto.
      * rewrite makeSet_vvalid in H. rewrite makeSet_evalid. auto.
  - destruct p as [v p]. destruct H as [[? ?] [? ?]]. simpl in H. subst v. clear H2. destruct p; auto. simpl in H1. destruct H1.
    assert (strong_evalid (makeSet_discrete_PreGraph size) z) by (destruct p; [|destruct H1]; auto). clear H1. destruct H2 as [_ [_ ?]].
    rewrite makeSet_dst in H1. rewrite makeSet_vvalid in H1. exfalso; intuition.
Qed.

Fixpoint makeSet_discrete_list (size: nat) :=
  match size with
  | O => nil
  | S n => Z.of_nat n :: makeSet_discrete_list n
  end.

Lemma makeSet_discrete_list_iff: forall size x, List.In x (makeSet_discrete_list size) <-> 0 <= x < Z.of_nat size.
Proof.
  induction size; intros; simpl; split; intros.
  - exfalso; auto.
  - destruct H; intuition.
  - rewrite Zpos_P_of_succ_nat, <- Z.add_1_r. rewrite IHsize in H. intuition.
  - rewrite Zpos_P_of_succ_nat, <- Z.add_1_r in H. rewrite IHsize. lia.
Qed.

Lemma makeSet_discrete_list_NoDup: forall size, NoDup (makeSet_discrete_list size).
Proof. induction size; simpl; constructor; auto; intro. rewrite makeSet_discrete_list_iff in H. intuition. Qed.

Definition makeSet_discrete_FiniteGraph (size: nat) : FiniteGraph (makeSet_discrete_PreGraph size).
Proof.
  constructor; unfold EnumEnsembles.Enumerable, In; exists (makeSet_discrete_list size); split; intros.
  - apply makeSet_discrete_list_NoDup.
  - rewrite makeSet_discrete_list_iff, makeSet_vvalid. intuition.
  - apply makeSet_discrete_list_NoDup.
  - rewrite makeSet_discrete_list_iff, makeSet_evalid. intuition.
Qed.

Definition makeSet_discrete_sound (size: nat) : @LiMaFin _ _ _ _ is_null_Z id (makeSet_discrete_PreGraph size).
Proof. constructor. exact (makeSet_discrete_LstGraph size). exact (makeSet_discrete_MathGraph size). exact (makeSet_discrete_FiniteGraph size). Qed.

Definition makeSet_discrete_LabeledGraph (size: nat) : LGraph := Build_LabeledGraph _ _ _ (makeSet_discrete_PreGraph size) (fun _ => O) (fun _ => tt) tt.

Definition makeSet_discrete_Graph (size: nat) : UFGraph := Build_GeneralGraph _ _ _ _ (makeSet_discrete_LabeledGraph size) (makeSet_discrete_sound size).

Corollary makeSet_discrete_Graph_dst:
  forall size e, dst (makeSet_discrete_Graph size) e = -1.
Proof.
apply makeSet_dst.
Qed.

Class SpatialArrayGraph (Addr: Type) (Pred: Type) := vcell_array_at: Addr -> list (nat * Z) -> Pred.

Existing Instances SGP_ND SGP_SL SGP_ClSL SGP_CoSL.

Section SpaceArrayGraph.

  Context {Pred: Type}.

  Context {SAGP: SpatialArrayGraphAssum Pred}.

  Context {Addr: Type}.

  Context {SAG: SpatialArrayGraph Addr Pred}.

  Definition graph_vcell_at (g: UFGraph) (P: Z -> Prop) (x: Addr) :=
    EX l: list Z, !!(forall v, List.In v l <-> P v) && !! NoDup l && vcell_array_at x (map (fun x => vgamma (lg_gg g) x) l).

  Definition full_graph_at (g: UFGraph) (x: Addr) :=
    EX n: nat, !!(forall v, 0 <= v < Z.of_nat n <-> vvalid (pg_lg (lg_gg g)) v) && !!(Z.of_nat n <= Int.max_signed / 8) && vcell_array_at x (map (fun x => vgamma (lg_gg g) x) (nat_inc_list n)).

End SpaceArrayGraph.