From stdpp Require Import base.
From iris.base_logic Require Import upred.
From iris.base_logic.lib Require Import iprop own.
From iris.bi Require Import updates.
From iris.algebra Require Import ofe cmra gmap_view.
From iris.proofmode Require Import tactics.

Definition tag := positive.
Canonical Structure tagO : ofe := discreteO tag.

Definition loc := positive.

Inductive value : Set :=
  | IntV (n : Z)
  | LocV (ℓ : loc).

(* interpretation of types *)
Definition sem_typeO (Σ : gFunctors) : ofe := value -d> iPropO Σ.

Class sem_heapG (Σ : gFunctors) : Set := SemHeapG {
  sem_heapG_heap :> inG Σ (gmap_viewR loc (prodO tagO (laterO (sem_typeO Σ))));
}.

Inductive lang_ty :=
  | IntT
  | UnionT (A : lang_ty) (B : lang_ty)
  | ClassT (t : tag).
Canonical Structure lang_tyO : ofe := leibnizO lang_ty.

(* classe types have a single field, for now *)
Definition class_def := lang_ty.
Definition class_defs := gmap tag class_def.

Section proofs.
Context `{!sem_heapG Σ}.
Notation iProp := (iProp Σ).

(* assume a given set of class definitions *)
Context (Δ : class_defs).

(* the interpretation of types is simply given by
   the carrier set of the sem_typeO ofe *)
Notation interpO := (sem_typeO Σ).
Definition interp := ofe_car interpO.
Eval hnf in interp.

(* now, let's interpret some types *)

Definition interp_int : interp :=
  λ (v : value), ⌜∃ n, v = IntV n⌝%I.

Definition interp_union (iA : interp) (iB : interp) : interp :=
  λ (w : value), (iA w ∨ iB w)%I.

(* name for the semantic heap *)
Context (γ : gname).

Notation sem_heap_mapsto ℓ t iF :=
  (own γ (gmap_view_frag ℓ DfracDiscarded (t, Next iF))).

Notation ty_interpO := (lang_ty -d> interpO).

(* interpret a class type given the tag and the
   interpretation for the unique field type *)
Definition interp_class (t : tag) (rec : ty_interpO) : interp :=
  λ (w : value),
    (∃ ℓ fty, ⌜w = LocV ℓ ∧ Δ !! t = Some fty⌝ ∗
              sem_heap_mapsto ℓ t (rec fty))%I.

(* we use a blend of Coq/Iris recursion, the
   Coq recursion lets us handle simple structural
   cases, and we use Iris' recursion to deal with
   the more complicated case of class types *)
Definition interp_type_pre (rec : ty_interpO) : ty_interpO :=
  λ (ty : lang_ty),
    (fix go (ty : lang_ty) : interp :=
       match ty with
       | IntT => interp_int
       | UnionT A B => interp_union (go A) (go B)
       | ClassT t => interp_class t rec
       end) ty.

(* we cannot use solve_contractive out of the box
   because of the 'fix' combinator above *)
Local Instance interp_type_pre_contractive :
  Contractive interp_type_pre.
Proof.
  move=>????. elim=>*/=; solve_proper_core
      ltac:(fun _ => first [done | f_contractive | f_equiv]).
Qed.

(* the interpretation of types can now be
   defined as a fixpoint (because class types
   can be (mutually) recursive) *)
Definition interp_type := fixpoint interp_type_pre.

Lemma interp_type_unfold (ty : lang_ty) (v : value) :
  interp_type ty v ⊣⊢ interp_type_pre interp_type ty v.
Proof.
  rewrite {1}/interp_type.
  apply (fixpoint_unfold interp_type_pre ty v).
Qed.

Global Instance interp_type_persistent (ty : lang_ty) (v : value) :
  Persistent (interp_type ty v).
Proof.
  elim: ty => [].
  - rewrite interp_type_unfold. apply _.
  - move=>>. rewrite interp_type_unfold /=.
    rewrite /interp_union. rewrite -!interp_type_unfold.
    by apply bi.or_persistent.
  - move=>>. rewrite interp_type_unfold. apply _.
Qed.

(* that is a bit of an awkward lemma;
   I am not yet sure it "scales" *)
Lemma interp_type_loc_inversion ty ℓ :
  interp_type ty (LocV ℓ) -∗
  ∃ t, interp_type (ClassT t) (LocV ℓ).
Proof.
  rewrite interp_type_unfold. elim: ty => /=.
  - iIntros "%". naive_solver.
  - move=>? IH1 ? IH2. iIntros "[H|H]".
    by iApply IH1. by iApply IH2.
  - move=> t. iIntros "H". iExists t.
    by rewrite interp_type_unfold /=.
Qed.

(* language statics & semantics *)

Definition var := positive.

Inductive lang_expr : Type :=
  | VarE (v : var)
  | LitE (lit : Z)
  | OpE (op : Z → Z → Z)
        (lhs rhs : lang_expr).

Inductive lang_cmd : Type :=
  | LetC (v : var) (e : lang_expr)  (* local def *)
  | NewC (v : var) (t : tag)        (* allocation *)
  | GetC (v : var) (e : lang_expr)  (* field read *)
  | SetC (lhs rhs : lang_expr)      (* fiels store *)
  | SeqC (fstc sndc : lang_cmd)     (* sequence *)
  | CondC (cnd : lang_expr)
          (ifc elc : lang_cmd)      (* conditional *)
  | CondTagC (v : var) (t : tag)
             (cmd : lang_cmd)       (* tag test
                                       "if ($v is C) { ... }" *)
  | WhileC (cnd : lang_expr)
           (cmd : lang_cmd)         (* while loop *).

(* programs are a command and a 'return'
   expression *)
Record lang_prog : Type :=
  Prog { prog_body : lang_cmd;
         prog_ret : lang_expr }.

Definition local_tys := gmap var lang_ty.

Inductive expr_has_ty (lty : local_tys) :
    lang_expr → lang_ty → Prop :=
  | VarTy (v : var) (ty : lang_ty) :
      lty !! v = Some ty →
      expr_has_ty lty (VarE v) ty
  | LitTy (lit : Z) :
      expr_has_ty lty (LitE lit) IntT
  | OpTy (op : Z → Z → Z) (lhs rhs : lang_expr) :
      expr_has_ty lty lhs IntT →
      expr_has_ty lty rhs IntT →
      expr_has_ty lty (OpE op lhs rhs) IntT.

(* continuation-based typing for commands *)
Inductive cmd_has_ty :
    local_tys → lang_cmd → local_tys → Prop :=
  | LetTy lty v e ty :
      expr_has_ty lty e ty →
      cmd_has_ty lty (LetC v e) (<[v:=ty]> lty)
  | NewTy lty v t :
      cmd_has_ty lty (NewC v t) (<[v:=ClassT t]> lty)
  | GetTy lty v e t ty :
      Δ !! t = Some ty →
      expr_has_ty lty e (ClassT t) →
      cmd_has_ty lty (GetC v e) (<[v:=ty]> lty)
  | SetTy lty lhs rhs t ty :
      Δ !! t = Some ty →
      expr_has_ty lty lhs (ClassT t) →
      expr_has_ty lty rhs ty →
      cmd_has_ty lty (SetC lhs rhs) lty
  | SeqTy lty1 lty2 lty3 fstc sndc :
      cmd_has_ty lty1 fstc lty2 →
      cmd_has_ty lty2 sndc lty3 →
      cmd_has_ty lty1 (SeqC fstc sndc) lty3
  | CondTy lty1 lty2 cnd ifc elc :
      expr_has_ty lty1 cnd IntT →
      cmd_has_ty lty1 ifc lty2 →
      cmd_has_ty lty1 elc lty2 →
      cmd_has_ty lty1 (CondC cnd ifc elc) lty2
  | CondTagTy lty v t cmd :
      (* we do not care about v's type but it's
         got to have one! (i.e., be defined) *)
      is_Some (lty !! v) →
      cmd_has_ty (<[v:=ClassT t]> lty) cmd lty →
      cmd_has_ty lty (CondTagC v t cmd) lty
  | WhileTy lty cnd cmd :
      expr_has_ty lty cnd IntT →
      cmd_has_ty lty cmd lty →
      cmd_has_ty lty (WhileC cnd cmd) lty.

Inductive prog_has_ty : lang_prog → lang_ty → Prop :=
  | ProgTy lty ty body ret :
      cmd_has_ty ∅ body lty →
      expr_has_ty lty ret ty →
      prog_has_ty (Prog body ret) ty.

Definition local_env := gmap var value.

Inductive expr_eval (le : local_env) :
    lang_expr → value → Prop :=
  | VarEv v val :
      le !! v = Some val →
      expr_eval le (VarE v) val
  | LitEv lit :
      expr_eval le (LitE lit) (IntV lit)
  | OpEv op lhs rhs nl nr :
      expr_eval le lhs (IntV nl) →
      expr_eval le rhs (IntV nr) →
      expr_eval le (OpE op lhs rhs) (IntV (op nl nr)).

Definition value_trueish := λ v,
  match v with
  | IntV n => n <> 0
  | _ => True
  end.

Global Instance value_trueish_decision (v : value) :
  Decision (value_trueish v).
Proof. move: v => []; apply _. Defined.

Definition heap : Type := gmap loc (tag * value).

Definition tag_match (st : local_env * heap) v t :=
  ∃ l, st.1 !! v = Some (LocV l) ∧
       ∃ v, st.2 !! l = Some (t, v).

Global Instance tag_match_decision st v t:
    Decision (tag_match st v t).
Proof.
  move: st => [le h]. rewrite /tag_match /=.
  move: (le !! v) => [[]|];
    try (right; naive_solver).
  move=> l. case_eq (h !! l);
    last (right; naive_solver).
  move=> [t' ?] ?.
  destruct (decide (t = t')) as [->|];
    last (right; naive_solver).
  left. eauto.
Defined.

Inductive cmd_eval :
    (local_env * heap) → lang_cmd →
    (local_env * heap) → Prop :=
  | LetEv le h v e ve :
      expr_eval le e ve →
      cmd_eval (le, h) (LetC v e) (<[v:=ve]> le, h)
  | NewEv le h l v t :
      h !! l = None →
      Δ !! t = Some IntT →
      cmd_eval (le, h) (NewC v t)
               (<[v:=LocV l]> le, <[l:=(t,IntV 0)]> h)
  | GetEv le h v e l tl vl :
      expr_eval le e (LocV l) →
      h !! l = Some (tl, vl) →
      cmd_eval (le, h) (GetC v e) (<[v:=vl]> le, h)
  | SetEv le h lhs rhs l tl vr :
      expr_eval le lhs (LocV l) →
      (∃ vl, h !! l = Some (tl, vl)) →
      expr_eval le rhs vr →
      cmd_eval (le, h) (SetC lhs rhs) (le, <[l:=(tl,vr)]> h)
  | SeqEv st1 st2 st3 fstc sndc :
      cmd_eval st1 fstc st2 →
      cmd_eval st2 sndc st3 →
      cmd_eval st1 (SeqC fstc sndc) st3
  | Cond1Ev st1 st2 cnd vc ifc elc :
      expr_eval st1.1 cnd vc →
      value_trueish vc →
      cmd_eval st1 ifc st2 →
      cmd_eval st1 (CondC cnd ifc elc) st2
  | Cond2Ev st1 st2 cnd vc ifc elc :
      expr_eval st1.1 cnd vc →
      ¬value_trueish vc →
      cmd_eval st1 elc st2 →
      cmd_eval st1 (CondC cnd ifc elc) st2
  | CondTag1Ev st1 st2 v t cmd :
      tag_match st1 v t →
      cmd_eval st1 cmd st2 →
      cmd_eval st1 (CondTagC v t cmd) st2
  | CondTag2Ev st v t cmd :
      ¬tag_match st v t →
      cmd_eval st (CondTagC v t cmd) st
  | While1Ev st1 st2 st3 cnd vc cmd :
      expr_eval st1.1 cnd vc →
      value_trueish vc →
      cmd_eval st1 cmd st2 →
      cmd_eval st2 (WhileC cnd cmd) st3 →
      cmd_eval st1 (WhileC cnd cmd) st3
  | While2Ev st cnd vc cmd :
      expr_eval st.1 cnd vc →
      ¬value_trueish vc →
      cmd_eval st (WhileC cnd cmd) st.

Inductive prog_eval :
    lang_prog → value → Prop :=
  | ProgEv body le h ret val :
      cmd_eval (∅,∅) body (le,h) →
      expr_eval le ret val →
      prog_eval (Prog body ret) val.

(* heap models relation; the semantic heap does
   not appear because it is hidden in iProp  *)
Definition heap_models (h : heap) : iProp :=
  ∃ (sh : gmap loc (prodO tagO (laterO interpO))),
    own γ (gmap_view_auth 1 sh) ∗ ⌜dom (gset loc) sh = dom _ h⌝ ∗
    □ ∀ (ℓ : loc) (t : tag) (v : value),
      ⌜h !! ℓ = Some (t, v)⌝ -∗
        ∃ (iF : interp), sh !! ℓ ≡ Some (t, Next iF) ∗ ▷ iF v.

Definition interp_local_tys
    (lty : local_tys) (le : local_env) : iProp :=
  (∀ v ty, ⌜lty !! v = Some ty⌝ -∗
           ∃ val, ⌜le !! v = Some val⌝ ∗ interp_type ty val)%I.

Lemma expr_adequacy e lty le ty val :
  expr_eval le e val →
  expr_has_ty lty e ty →
  interp_local_tys lty le -∗
  interp_type ty val.
Proof.
  (* the language is this simple that no
     induction is necessary *)
  case.
  - move=> v val' ?. inversion_clear 1.
    iIntros "#Hlty".
    iDestruct ("Hlty" with "[//]") as (?) "[% H]".
    simplify_eq. done.
  - move=> lit. inversion_clear 1.
    iIntros "_". rewrite interp_type_unfold /=.
    rewrite /interp_int. by eauto.
  - move=> op lhs rhs nl nr _ _.
    inversion_clear 1.
    iIntros "_". rewrite interp_type_unfold /=.
    rewrite /interp_int. by eauto.
Qed.

Lemma interp_local_tys_update v lty le ty val :
  interp_local_tys lty le -∗
  interp_type ty val -∗
  interp_local_tys (<[v:=ty]>lty) (<[v:=val]>le).
Proof.
  iIntros "#Hi #?". iIntros (v' ty') "H".
  rewrite lookup_insert_Some.
  iDestruct "H" as %[[<- <-]|[??]].
  - iExists _. rewrite lookup_insert. by iSplit.
  - rewrite lookup_insert_ne; last done. by iApply "Hi".
Qed.

Lemma heap_models_lookup l h tl vl t :
  h !! l = Some (tl, vl) →
  heap_models h -∗
  interp_type (ClassT t) (LocV l) -∗
  ∃ fty, heap_models h ∗
         ⌜t = tl ∧ Δ !! t = Some fty⌝ ∗
         ▷ interp_type fty vl.
Proof.
  move=>?. iIntros "Hh Hc".
  rewrite interp_type_unfold /=.
  iDestruct "Hc" as (??) "[H H◯]".
  iDestruct "H" as %[[= <-]Hfty].
  iDestruct "Hh" as (sh) "(H●&%&#Hh)".
  iDestruct (own_valid_2 with "H● H◯") as "#Hv".
  rewrite gmap_view_both_validI.
  iDestruct "Hv" as "[_ HΦ]".
  iDestruct ("Hh" with "[//]") as (?) "[H H▷]".
  iRewrite "H" in "HΦ".
  rewrite option_equivI prod_equivI /=.
  iDestruct "HΦ" as "[-> HΦ]".
  rewrite later_equivI.
  iExists fty.
  iSplitL. { iExists _. iFrame. by iSplit. }
  iSplitR; first done.
  iNext. rewrite discrete_fun_equivI.
  iSpecialize ("HΦ" $! vl).
  by iRewrite "HΦ" in "H▷".
Qed.

Lemma heap_models_update h l t v
      (Φ : interpO) `{∀ v, Persistent (Φ v)} :
  heap_models h -∗ (* ▷ *) Φ v -∗
  sem_heap_mapsto l t Φ -∗
  heap_models (<[l:=(t,v)]> h).
Proof.
  iIntros "Hh #HΦ #H◯".
  iDestruct "Hh" as (sh) "(H●&%&#Hh)".
  iDestruct (own_valid_2 with "H● H◯") as "#Hv".
  rewrite gmap_view_both_validI.
  iDestruct "Hv" as "[_ Hsh]".
  iExists sh. iFrame.
  iAssert ⌜is_Some (sh !! l)⌝%I as %?.
  { move: (sh !! l) => [>|].
    by iPureIntro; eauto.
    by rewrite option_equivI;
       iDestruct "Hsh" as "[]". }
  iSplitR.
  - iPureIntro.
    rewrite dom_insert_lookup_L; first done.
    apply (elem_of_dom (D:=gset loc)).
    by rewrite -H0 elem_of_dom.
  - iModIntro. iIntros (l' t' v') "H".
    rewrite lookup_insert_Some.
    iDestruct "H" as %[[<- [= <- <-]]|[??]].
    + iExists Φ. by iSplit.
    + by iApply "Hh".
Qed.

Notation "|=▷^ n Q" := (Nat.iter n (λ P, |==> ▷ P) Q)%I
  (at level 99, n at level 9, Q at level 200,
   format "|=▷^ n  Q") : bi_scope.

Lemma updN_zero (Q : iProp) : (|=▷^0 Q) ⊣⊢ Q.
Proof. done. Qed.

Lemma updN_S n (Q : iProp) :
  (|=▷^(S n) Q) ⊣⊢ |==> ▷ |=▷^n Q.
Proof. done. Qed.

Lemma updN_mono n (P Q : iProp) :
  (P -∗ Q) → (|=▷^n P) -∗ (|=▷^n Q).
Proof.
  elim: n => [//|n HI H].
  rewrite !updN_S.
  iApply bupd_mono.
  iApply bi.later_mono.
  by iApply HI.
Qed.

(* (* We may want something like that to improve the
      proof mode with the updN modality *)
Global Instance into_wand_updN n p q (R P Q : iProp) :
  IntoWand p q R P Q → IntoWand p q (|=▷=>^n R) (|=▷=>^n P) (|=▷=>^n Q).
Proof.
  rewrite /IntoWand /= => HR.
  by rewrite !later_intuitionistically_if_2 -later_wand HR.
Qed.
Global Instance into_wand_later_args p q R P Q :
  IntoWand p q R P Q → IntoWand' p q R (▷ P) (▷ Q).
Proof.   rewrite /IntoWand' /IntoWand /= => HR.
           by rewrite !later_intuitionistically_if_2
         (later_intro (□?p R)) -later_wand HR.
Qed.
*)

Lemma cmd_adequacy lty lty' st cmd st' :
  cmd_eval st cmd st' →
  cmd_has_ty lty cmd lty' →
  ∃ n,
    heap_models st.2 ∗ interp_local_tys lty st.1 -∗ |=▷^n
    heap_models st'.2 ∗ interp_local_tys lty' st'.1.
Proof.
  move=> E. move: lty lty'. elim: E.
  - move=>> ? /=. inversion_clear 1.
    exists 0. iIntros "[? #Hle]".
    rewrite updN_zero. iFrame.
    iDestruct (expr_adequacy with "Hle")
      as "#?"; try done.
    by iApply interp_local_tys_update.
  - move=>?? l v t ?? /=. inversion_clear 1.
    (* we need one modality to update the
       semantic heap *)
    exists 1. iIntros "[Hh #Hle]".
    rewrite updN_S updN_zero.
    iDestruct "Hh" as (sh) "(H●&Hdom&#Hh)".
    iDestruct "Hdom" as %Hdom.
    iMod (own_update with "H●") as "[H● H◯]".
    { apply (gmap_view_alloc _ l DfracDiscarded
        (t, Next (interp_type IntT)));
        last done.
    apply (not_elem_of_dom (D:=gset loc)).
    by rewrite Hdom not_elem_of_dom. }
    iIntros "!> !>". iDestruct "H◯" as "#H◯".
    iAssert (interp_type (ClassT t) (LocV l))
      with "[]" as "#Hl".
    { rewrite interp_type_unfold /=.
      iExists _, _. by iSplit. }
    iSplitL; last first.
    by iApply interp_local_tys_update.
    iExists _. iFrame. iSplit.
    by rewrite !dom_insert_L Hdom.
    iModIntro. iIntros (???) "Hlook".
    rewrite lookup_insert_Some.
    iDestruct "Hlook" as %[[<- [= <- <-]]|[Hℓ Hlook]].
    + iExists _. rewrite lookup_insert.
      iSplitR; first done.
      rewrite (interp_type_unfold IntT) /=.
      rewrite /interp_int. by eauto.
    + rewrite lookup_insert_ne; last done.
      by iApply "Hh".
  - move=>> ?? /=. inversion_clear 1.
    exists 1. iIntros "[Hh #Hle]".
    iModIntro. (* keep the later *)
    iDestruct (expr_adequacy with "Hle")
      as "#He"; try done.
    iDestruct (heap_models_lookup with "Hh He")
      as (fty) "(Hh&Ht&Hv)"; first done.
    rewrite H0. iDestruct "Ht" as %[?[=<-]].
    rewrite bi.later_sep.
    iSplitL "Hh"; first done.
    iNext. by iApply interp_local_tys_update.
  - move=>?? lhs rhs > ?[??]? /=.
    inversion_clear 1. exists 0.
    iIntros "[Hh #Hle]".
    rewrite updN_zero. iSplitL; last done.
    iDestruct (expr_adequacy lhs with "Hle")
      as "#Hlhs"; try done.
    iDestruct (expr_adequacy rhs with "Hle")
      as "#Hrhs"; try done.
    iDestruct (heap_models_lookup with "Hh Hlhs")
      as (fty) "(Hh&Ht&?)"; first done.
    rewrite H0. iDestruct "Ht" as %[[=<-][=<-]].
    rewrite interp_type_unfold.
    iDestruct "Hlhs" as (??) "(H&?)".
    rewrite H0. iDestruct "H" as %[[=<-][=<-]].
    iApply (heap_models_update with "Hh");
      try done. by intros; apply _.
  - move=>> ? Hfst ? Hsnd. inversion_clear 1.
    apply Hfst in H0. apply Hsnd in H1.
    clear Hfst Hsnd.
    destruct H0 as [n1 Hfst].
    destruct H1 as [n2 Hsnd].
    exists (n1 + n2).
    iIntros "H".
    iDestruct (Hfst with "H") as "H".
    iPoseProof (updN_mono with "H") as "H";
      first done.
    by rewrite Nat_iter_add.
  - move=>> ?? ? Hifc ??. inversion_clear 1.
    apply Hifc in H1. clear Hifc.
    destruct H1 as [n Hifc]. exists n.
    iIntros "H". iPoseProof (Hifc with "H") as "H".
    done.
  - move=>> ?? ? Helc ??. inversion_clear 1.
    apply Helc in H2. clear Helc.
    destruct H2 as [n Helc]. exists n.
    iIntros "H". iPoseProof (Helc with "H") as "H".
    done.
  - move=>[le1 h1] ? v t ? [l /= [? [v' ?]]] ? H.
    inversion_clear 1. apply H in H2. clear H.
    destruct H2 as [n Hcmd]. exists n.
    iIntros "H". iApply Hcmd. clear Hcmd n.
    (* now for some fun :) *)
    iDestruct "H" as "[Hh #Hlty]".
    destruct H1 as [ty Hvty].
    iDestruct ("Hlty" $! v with "[//]")
      as (?) "[Hlev Hv]".
    iDestruct "Hlev" as %Hlev.
    rewrite -> Hlev in *. simplify_eq.
    iDestruct (interp_type_loc_inversion with "Hv")
      as (t') "Hv'".
    iDestruct (heap_models_lookup with "Hh Hv'")
      as (fty) "(Hh&Ht&_)"; first done.
    iDestruct "Ht" as %[[=->]HΔ].
    iFrame. (* not quite interp_local_tys_update *)
    iIntros (??) "H". rewrite lookup_insert_Some.
    iDestruct "H" as %[[<- <-]|[??]].
    by iExists _; iSplit.
    by iApply "Hlty".
  - move=>> ?. inversion_clear 1.
    by exists 0.
  - (* this exactly the same thing as in the
       sequence case *)
    move=>> ??? Hitr_ ? Hcnt_. inversion 1; subst.
    move: (Hitr_ _ _ H5) => [n1 Hitr]. clear Hitr_.
    move: (Hcnt_ _ _ H) => [n2 Hcnt]. clear Hcnt_.
    exists (n1 + n2).
    iIntros "H".
    iDestruct (Hitr with "H") as "H".
    iPoseProof (updN_mono with "H") as "H";
      first done.
    by rewrite Nat_iter_add.
  - move=>> ???. inversion_clear 1.
    by exists 0.
Qed.

End proofs.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Machine- and ABI-dependent layout information for activation records. *)

Require Import Coqlib.
Require Import Memory Separation.
Require Import Bounds.

(** In the PowerPC/EABI application binary interface,
  the general shape of activation records is as follows,
  from bottom (lowest offsets) to top:
- 8 reserved bytes.  The first 4 bytes hold the back pointer to the
  activation record of the caller.  The next 4 bytes are reserved
  for called functions to store their return addresses.
  Since we would rather store our return address in our own
  frame, we will not use these 4 bytes, and just reserve them.
- Space for outgoing arguments to function calls.
- Local stack slots.
- Saved values of callee-save registers used by the function.
- Space for the stack-allocated data declared in Cminor.

The [frame_env] compilation environment records the positions of
the boundaries between areas in the frame part.
*)

Definition fe_ofs_arg := 8.

(** Computation of the frame environment from the bounds of the current
  function. *)

Definition make_env (b: bounds) :=
  let ol := align (8 + 4 * b.(bound_outgoing)) 8 in    (* locals *)
  let ora := ol + 4 * b.(bound_local) in (* saved return address *)
  let ocs := ora + 4 in            (* callee-saves *)
  let oendcs := size_callee_save_area b ocs in
  let ostkdata := align oendcs 8 in (* stack data *)
  let sz := align (ostkdata + b.(bound_stack_data)) 16 in
  {| fe_size := sz;
     fe_ofs_link := 0;
     fe_ofs_retaddr := ora;
     fe_ofs_local := ol;
     fe_ofs_callee_save := ocs;
     fe_stack_data := ostkdata;
     fe_used_callee_save := b.(used_callee_save) |}.

(** Separation property *)

Local Open Scope sep_scope.

Lemma frame_env_separated:
  forall b sp m P,
  let fe := make_env b in
  m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P ->
  m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b)
       ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b)
       ** range sp (fe_ofs_link fe) (fe_ofs_link fe + 4)
       ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4)
       ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe))
       ** P.
Proof.
Local Opaque Z.add Z.mul sepconj range.
  intros; simpl.
  set (ol := align (8 + 4 * b.(bound_outgoing)) 8).
  set (ora := ol + 4 * b.(bound_local)).
  set (ocs := ora + 4).
  set (oendcs := size_callee_save_area b ocs).
  set (ostkdata := align oendcs 8).
  generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
  unfold fe_ofs_arg.
  assert (8 + 4 * b.(bound_outgoing) <= ol) by (apply align_le; lia).
  assert (ol <= ora) by (unfold ora; lia).
  assert (ora <= ocs) by (unfold ocs; lia).
  assert (ocs <= oendcs) by (apply size_callee_save_area_incr).
  assert (oendcs <= ostkdata) by (apply align_le; lia).
(* Reorder as:
     back link
     outgoing
     locals
     retaddr
     callee-save *)
  rewrite sep_swap3.
(* Apply range_split and range_split2 repeatedly *)
  apply range_drop_right with 8. lia.
  apply range_split. lia.
  apply range_split_2. fold ol; lia. lia.
  apply range_split. lia.
  apply range_split. lia.
  apply range_drop_right with ostkdata. lia.
  eapply sep_drop2. eexact H.
Qed.

Lemma frame_env_range:
  forall b,
  let fe := make_env b in
  0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe.
Proof.
  intros; simpl.
  set (ol := align (8 + 4 * b.(bound_outgoing)) 8).
  set (ora := ol + 4 * b.(bound_local)).
  set (ocs := ora + 4).
  set (oendcs := size_callee_save_area b ocs).
  set (ostkdata := align oendcs 8).
  generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
  unfold fe_ofs_arg.
  assert (8 + 4 * b.(bound_outgoing) <= ol) by (apply align_le; lia).
  assert (ol <= ora) by (unfold ora; lia).
  assert (ora <= ocs) by (unfold ocs; lia).
  assert (ocs <= oendcs) by (apply size_callee_save_area_incr).
  assert (oendcs <= ostkdata) by (apply align_le; lia).
  split. lia. apply align_le. lia.
Qed.

Lemma frame_env_aligned:
  forall b,
  let fe := make_env b in
     (8 | fe_ofs_arg)
  /\ (8 | fe_ofs_local fe)
  /\ (8 | fe_stack_data fe)
  /\ (4 | fe_ofs_link fe)
  /\ (4 | fe_ofs_retaddr fe).
Proof.
  intros; simpl.
  set (ol := align (8 + 4 * b.(bound_outgoing)) 8).
  set (ora := ol + 4 * b.(bound_local)).
  set (ocs := ora + 4).
  set (oendcs := size_callee_save_area b ocs).
  set (ostkdata := align oendcs 8).
  split. exists (fe_ofs_arg / 8); reflexivity.
  split. apply align_divides; lia.
  split. apply align_divides; lia.
  split. apply Z.divide_0_r.
  apply Z.divide_add_r.
    apply Z.divide_trans with 8. exists 2; auto. apply align_divides; lia.
    apply Z.divide_factor_l.
Qed.


Require Import HoTT.
Close Scope mc_scope. (* to make notations like [A * B] work easily *)

Require Import Auxiliary.Coproduct.
Require Import Auxiliary.Family.
Require Import Syntax.ScopeSystem.
Require Import Syntax.All.
Require Import Typing.All.
Require Import Presented.PresentedRawTypeTheory.

(* Main goals of this file:

- [is_tight_type_theory]: tightness of a raw type theory
- [unique_typing]: theorem giving unique typing, for any tight type theory
*)

(* TODO: upstream contents of this section periodically, but keep this section as a holding pen as long as the file is under heavy development. *)
Section Auxiliary.

  (* TODO: maybe better as [Contr { y : B & R x y }]?  Try refactoring; see how it plays with coercions. *)
  Record functional_relation {A B} (R : A -> B -> Type) : Type
  := {
    total (x:A) : { y : B & R x y } ;
    unique {x} {y y'}: R x y -> R x y' -> y = y'
  }.

  Definition function_of_functional_relation
      {A B} {R : A -> B -> Type} (R_fun : functional_relation R)
    : A -> B
  := fun a => (total _ R_fun a).1.

  Coercion function_of_functional_relation : functional_relation >-> Funclass.

  Definition function_of_functional_relation_is_related
      {A B} {R : A -> B -> Type} (R_fun : functional_relation R)
    : forall a : A, R a (R_fun a)
  := fun a => (total _ R_fun a).2.

  Record is_one_to_one_correspondence {A B} (R : A -> B -> Type)
  := {
    forward : functional_relation R ;
    backward : functional_relation (flip R)
  }.

End Auxiliary.

Section Fix_Scope_System.

Context {σ : scope_system}.

Definition raw_rule_object_premise {Σ : signature σ} (R : raw_rule Σ)
    : Type
  := {i : raw_rule_premise R
          & Judgement.is_object (raw_rule_premise R i)}.

(* TODO: unify this with the similar construction in [Presented.AlgebraicExtension.judgement_of_premise]. *)
Definition meta_generic_application {Σ : signature σ} {a : arity σ} (i : a)
  : raw_expression (Metavariable.extend Σ a)
      (argument_class i) (argument_scope i).
Proof.
  simple refine (raw_symbol' _ _ _).
  * apply inr, i.
  * reflexivity.
  * intro j. apply raw_variable.
    exact (coproduct_inj1 scope_is_sum j).
Defined.

Definition premise_introduces_meta {Σ : signature σ} {R : raw_rule Σ}
    (p : raw_rule_object_premise R) (m : raw_rule_metas R)
  : Type.
Proof.
  simple refine { e : _ * _ & _}.
  - exact (class_of (raw_rule_premise R p.1)
          = argument_class m).
  - exact ((context_of_judgement (raw_rule_premise R p.1) : σ)
          = argument_scope m).
  - exact (transport _ (snd e)
           (transport (fun cl => raw_expression _ cl _) (fst e)
             (Judgement.head (raw_rule_premise R p.1) p.2))
            = meta_generic_application m).
Defined.

Definition is_tight_rule {Σ : signature σ} (R : raw_rule Σ)
  : Type
:= is_one_to_one_correspondence (@premise_introduces_meta _ R).

Definition raw_type_theory_object_rule
    {Σ : signature σ} (T : raw_type_theory Σ)
  : Type
:= { R :T & Judgement.is_object (raw_rule_conclusion (T R)) }.

Coercion pr1_raw_type_theory_object_rule
    {Σ : signature σ} (T : raw_type_theory Σ)
  : raw_type_theory_object_rule T -> T
  := pr1.

(* TODO: unify this with the similar construction in [Presented.RawTypeTheory]. *)
Definition symbol_generic_application {Σ : signature σ} (S : Σ)
  : raw_expression (Metavariable.extend Σ (symbol_arity S))
      (symbol_class S) (scope_empty _).
Proof.
  srapply raw_symbol'.
  * apply inl, S.
  * reflexivity.
  * intro m.
    refine (rename _ (meta_generic_application m)).
    apply (coproduct_inj2 scope_is_sum).
Defined.

Record rule_introduces_symbol {Σ : signature σ} (R : raw_rule Σ) (S : Σ)
:= {
  symbol_rule_metas : raw_rule_metas R = symbol_arity S;
  symbol_rule_is_object : Judgement.is_object (raw_rule_conclusion R);
  symbol_rule_class : class_of (raw_rule_conclusion R) = symbol_class S;
  symbol_rule_context
    : (context_of_judgement (raw_rule_conclusion R) : σ) = scope_empty _;
  symbol_rule_conclusion
    : (transport _ symbol_rule_context
      (transport (fun cl => raw_expression _ cl _) symbol_rule_class
      (transport (fun a => raw_expression (_ a) _ _) symbol_rule_metas
        (Judgement.head (raw_rule_conclusion R) symbol_rule_is_object))))
    = symbol_generic_application S
}.
(* Note: this definition involves transport along an equality of signatures.
  [Metavariable.extend Σ (raw_rule_metas R))
  = Metavariable.extend Σ (symbol_arity S)]
coming from the equality [raw_rule_metas R = symbol_arity S].

If it turns out that transport in the signature is unpleasant to work with,
we could instead use a translation along the signature map induced by the equality,
or even replace the equality with an equivalence of arities.

Presumably this will be easiest to work with by setting things up so that the raw rule is abstract, and so it and the equalities can be destructed. *)

Definition is_tight_type_theory {Σ : signature σ} (T : raw_type_theory Σ)
    : Type
  := (forall R : T, is_tight_rule (T R))
     * is_one_to_one_correspondence
         (fun (R : raw_type_theory_object_rule T) S
              => rule_introduces_symbol (T R.1) S).

(* We can now state the main goal of the file: *)
Theorem unique_typing {Σ : signature σ} (T : raw_type_theory Σ)
    (T_tight : is_tight_type_theory T)
    (Γ : raw_context Σ) (a : raw_term Σ Γ) (A A' : raw_type Σ Γ)
    (d : RawTypeTheory.derivation T [<>] [! Γ |- a ; A !])
    (d' : RawTypeTheory.derivation T [<>] [! Γ |- a ; A' !])
  : RawTypeTheory.derivation T [<>] [! Γ |- A ≡ A' !].
Proof.
Admitted.
(* TODO: make sure this is updated to include extra hypothesis that may be needed (e.g. possibly substitutivity). *)

(* Sketch proof: we will take a slightly different approach from the paper, proving first the “natural type” theorem, and then deducing unique typing as a corollary. *)

Definition natural_type {Σ : signature σ}
    {T : raw_type_theory Σ} (T_tight : is_tight_type_theory T)
    (Γ : raw_context Σ) (t : raw_term Σ Γ)
  : raw_type Σ Γ.
Proof.
  destruct Γ as [γ Γ]. simpl in t |- *.

  induction t as [ γ i | γ S t_args nat_ty_t_args].
  (* For a variable: look up its type in the context. *)
  { exact (Γ i). }
  (* For a symbol application,
  - find the rule introducing the symbol;
  - take the type from the conclusion of this rule,
  - instantiated using the arguments of the application.
   *)
  assert { R_S : raw_rule Σ
                 & is_tight_rule R_S * rule_introduces_symbol R_S S }
    as [R_S [R_S_tight R_S_introduces_S]].
  { simple refine (_;_); try split.
    - exact (T (backward _ (snd T_tight) S)).
    - apply (fst (T_tight)).
    - apply (function_of_functional_relation_is_related
               (backward _ (snd T_tight))).
  }
  refine (rename _ (instantiate_expression _ _)).
  - exact (scope_sum_empty_inl γ)^-1.
  - admit. (* [t_args] should be viewable as an instantiation of [R_S]. Maybe factor this out? *)
  - admit. (* extract the type of the conclusion of [R_S] *)
Admitted.
(* TODOs:
- implicit args for [forward], [backward]
- define access functions for tightness?
*)

(* TODO: consider naming *)
(* TODO: further acceptability hypotheses on [T] may be necessary *)
Definition natural_type_theorem
    {Σ : signature σ} {T : raw_type_theory Σ}
    (T_tight : is_tight_type_theory T)
    (Γ : raw_context Σ) (a : raw_term Σ Γ) (A : raw_type Σ Γ)
    (d : RawTypeTheory.derivation T [<>] [! Γ |- a ; A !])
    (T_a := natural_type T_tight Γ a)
  : RawTypeTheory.derivation T [<>] [! Γ |- a ; T_a  !]
    * RawTypeTheory.derivation T [<>] [! Γ |- A ≡ T_a !].
Admitted.

(* TODO: now conclude unique typing as corollary of this. *)

End Fix_Scope_System.


Require Import Prelude.

Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.

Inductive Duple@{i k j} (a : Type@{i}) (b : Type@{k}) : Type@{j} :=
  mkDuple : a -> b -> Duple a b.

CoInductive Mealy@{i k j} (a : Type@{i}) (b : Type@{k}) : Type@{j} :=
  mkMealy : (a -> Duple@{k j j} b (Mealy a b)) -> Mealy a b.

Definition deMealy@{i k j} (a : Type@{i}) (b : Type@{k}) (x : Mealy@{i k j} a b)
  : a -> Duple@{k j j} b (Mealy@{i k j} a b)
  := match x with mkMealy _ _ x' => x' end.

Definition id_Mealy@{i k} (a : Type@{i}) : Mealy@{i i k} a a :=
  cofix go : Mealy@{i i k} a a :=
    mkMealy a a (fun x_a => mkDuple@{i k k} a (Mealy@{i i k} a a) x_a go).


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 P Q A B C Aprime : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P B /\ (wd_ A Aprime /\ (wd_ A C /\ (wd_ A B /\ (wd_ C Aprime /\ (wd_ Q A /\ (wd_ P A /\ (wd_ C P /\ (col_ P Q Aprime /\ (col_ P Q B /\ col_ A B C)))))))))))) -> col_ Aprime P B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Raft.

Require Import CommonDefinitions.

Section UniqueIndicesInterface.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition uniqueIndices_host_invariant net :=
    (forall h, uniqueIndices (log (nwState net h))).

  Definition uniqueIndices_nw_invariant net :=
    forall p t leaderId prevLogIndex prevLogTerm entries leaderCommit,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                              entries leaderCommit ->
      uniqueIndices entries.

  Definition UniqueIndices net : Prop :=
    uniqueIndices_host_invariant net /\ uniqueIndices_nw_invariant net.

  Class unique_indices_interface : Prop :=
    {
      UniqueIndices_invariant :
        forall net,
          raft_intermediate_reachable net ->
          UniqueIndices net
    }.
End UniqueIndicesInterface.


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 U V P D : Universe, ((wd_ U V /\ (wd_ A P /\ (wd_ V B /\ (wd_ U B /\ (wd_ A D /\ (wd_ A B /\ (col_ U V P /\ (col_ A U A /\ (col_ A U V /\ (col_ A P D /\ col_ A P B)))))))))) -> col_ U V B)).
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 I H1 H2 : Universe, ((wd_ H1 B /\ (wd_ H2 B /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ I H2 /\ (wd_ I H1 /\ (wd_ I B /\ (col_ B C H2 /\ (col_ B A I /\ col_ B H1 A)))))))))) -> col_ H1 B I)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Functor.Bifunctor.
Require Import Category.Structure.Terminal.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Monoidal.
Require Import Category.Structure.Monoidal.Symmetric.
Require Import Category.Structure.Monoidal.Relevance.
Require Import Category.Structure.Monoidal.Semicartesian.
Require Import Category.Structure.Monoidal.Semicartesian.Proofs.
Require Import Category.Structure.Monoidal.Cartesian.
Require Import Category.Structure.Monoidal.Cartesian.Proofs.

Generalizable All Variables.

Section CartesianMonoidalCartesian.

Context `{@CartesianMonoidal C}.

Program Definition CartesianMonoidal_Cartesian : @Cartesian C := {|
  product_obj := fun x y => (x ⨂ y)%object;
  Cartesian.fork := @fork _ _;
  exl  := fun _ _ => proj_left;
  exr  := fun _ _ => proj_right
|}.
Next Obligation.
  unfold fork.
  split; intros.
  - split.
    + rewrites.
      rewrite comp_assoc.
      rewrite proj_left_natural.
      rewrite <- comp_assoc.
      rewrite proj_left_diagonal; cat.
    + rewrites.
      rewrite comp_assoc.
      rewrite proj_right_natural.
      rewrite <- comp_assoc.
      rewrite proj_right_diagonal; cat.
  - rewrite <- (fst X), <- (snd X).
    rewrite bimap_comp.
    rewrite <- !comp_assoc.
    srewrite diagonal_natural.
    rewrite comp_assoc.
    rewrite proj_left_right_diagonal; cat.
Qed.

End CartesianMonoidalCartesian.

Coercion CartesianMonoidal_Cartesian : CartesianMonoidal >-> Cartesian.


From PetitC Require Import InbuiltFunc Memory Output Values.

From Coq Require Import Lists.List ZArith.
Import ListNotations.

Inductive inbuilt_func_step : inbuilt_func -> list value -> option value ->
                              memory -> output -> memory -> output -> Prop :=

      (* i should check if there's a defined behavior on memory overflow *)
  | IFSMalloc : forall size_nat size_int_value ptr mem mem' out,
        Z.of_nat size_nat = int_value_to_Z size_int_value ->
        (ptr, mem') = malloc mem size_nat ->
      inbuilt_func_step Malloc [IntValue size_int_value]
                               (Some (PtrValue ptr))
                               mem out mem' out

  | IFSPutchar : forall char_int_value mem out,
      inbuilt_func_step Putchar [IntValue char_int_value] None
                                mem out mem (char_int_value::out).


Require Import VerdiRaft.Raft.

Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.RaftMsgRefinementInterface.

Section GhostLogAllEntriesInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition ghost_log_allEntries net :=
    forall p e,
      In p (nwPackets net) ->
      In e (fst (pBody p)) ->
      exists t,
        In (t, e) (allEntries (fst (nwState net (pSrc p)))).

  Class ghost_log_allEntries_interface : Prop :=
    {
      ghost_log_allEntries_invariant :
        forall net,
          msg_refined_raft_intermediate_reachable net ->
          ghost_log_allEntries net
    }.

End GhostLogAllEntriesInterface.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^224 - 2^96 + 1
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 32;
    bitwidth := 32;
    s := 2^224;
    c := [(1, -1); (2^96, 1)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import micromega.Lia.
From Coq Require Import micromega.Zify.
From Coq Require Import Lists.List.
From Coq Require Import Reals.Reals.
From Coq Require Import Logic.FunctionalExtensionality.
Import ListNotations.

From ATL Require Import ATL Common Tactics CommonTactics.

Theorem ll_concat_l {X Y} `{TensorElem X} :
  forall (a : Y -> list X) (b : list X) (e : Y),
    (tlet a' := e in a a') <++> b = tlet a' := e in (a a') <++> b.
Proof. trivial. Qed.

Theorem ll_concat_r {X Y} `{TensorElem X} :
  forall (a : Y -> list X) (b : list X) (e : Y),
    b <++> (tlet a' := e in a a') = tlet a' := e in b <++> (a a').
Proof. trivial. Qed.

Theorem ll_bin_l {X Y} `{TensorElem X} : forall (a : Y -> X) (b : X) (e : Y),
    (tlet a' := e in a a') <+> b = tlet a' := e in (a a') <+> b.
Proof. trivial. Qed.

Theorem ll_bin_r {X Y} `{TensorElem X} : forall (a : Y -> X) (b : X) (e : Y),
    b <+> (tlet a' := e in a a') = tlet a' := e in b <+> (a a').
Proof. trivial. Qed.

Theorem ll_plus_l {X} : forall (e0 : X) (e1 : X -> R) (e2 : R),
    Rplus (tlet x := e0 in e1 x) e2 = tlet x := e0 in Rplus (e1 x) e2.
Proof. trivial. Qed.

Theorem ll_plus_r {X} : forall (e0 : X) (e1 : X -> R) (e2 : R),
    Rplus e2 (tlet x := e0 in e1 x) = tlet x := e0 in Rplus e2 (e1 x).
Proof. trivial. Qed.

Theorem ll_mult_l {X} : forall (e0 : X) (e1 : X -> R) (e2 : R),
    Rmult (tlet x := e0 in e1 x) e2 = tlet x := e0 in Rmult (e1 x) e2.
Proof. trivial. Qed.

Theorem ll_mult_r {X} : forall (e0 : X) (e1 : X -> R) (e2 : R),
    Rmult e2 (tlet x := e0 in e1 x) = tlet x := e0 in Rmult e2 (e1 x).
Proof. trivial. Qed.

Theorem ll_div_l {X} : forall (e0 : X) (e1 : X -> R) (e2 : R),
    Rdiv (tlet x := e0 in e1 x) e2 = tlet x := e0 in Rdiv (e1 x) e2.
Proof. trivial. Qed.

Theorem ll_div_r {X} : forall (e0 : X) (e1 : X -> R) (e2 : R),
    Rdiv e2 (tlet x := e0 in e1 x) = tlet x := e0 in Rdiv e2 (e1 x).
Proof. trivial. Qed.

Theorem ll_arg {X Y Z} : forall (f : Y -> Z) (e0 : X) (e1 : X -> Y),
    f (tlet x := e0 in e1 x) = tlet x := e0 in f (e1 x).
Proof. trivial. Qed.

Theorem ll_tuple_l {X Y Z} : forall (e0 : X) (e1 : X -> Y) (e2 : Z),
    (tlet x := e0 in e1 x, e2) = tlet x := e0 in (e1 x,e2).
Proof. trivial. Qed.

Theorem ll_tuple_r {X Y Z} : forall (e0 : X) (e1 : Y) (e2 : X -> Z),
    (e1, tlet x := e0 in e2 x) = tlet x := e0 in (e1,e2 x).
Proof. trivial. Qed.

Theorem ll_fst {X Y Z} : forall (e0 : X) (e1 : X -> Y * Z),
    fst (tlet x := e0 in e1 x) = tlet x := e0 in fst (e1 x).
Proof. trivial. Qed.

Theorem ll_snd {X Y Z} : forall (e0 : X) (e1 : X -> Y * Z),
    snd (tlet x := e0 in e1 x) = tlet x := e0 in snd (e1 x).
Proof. trivial. Qed.

Theorem ll_gen {X Y} `{TensorElem X} `{TensorElem Y}:
  forall N (e0 : Z -> X) (e1 : X -> Z -> Y),
  GEN [ n' < N ] (tlet x := e0 n' in e1 x n')
  = tlet x := GEN [ i < N ] e0 i in
    GEN [ n' < N ] e1 (x _[ n' ]) n'.
Proof.
  intros. simpl.
  apply gen_eq_bound.
  intros. f_equal. symmetry.
  rewrite get_gen_some; auto with crunch.
Qed.

Theorem ll_gen_indep {X Y} `{TensorElem X} `{TensorElem Y}:
  forall N (e0 : X) (e1 : X -> Z -> Y),
  GEN [ n' < N ] (tlet x := e0 in e1 x n')
  = tlet x := e0 in
    GEN [ n' < N ] e1 x n'.
Proof.
  intros. simpl. reflexivity.
Qed.

Theorem ll_gen_bound {X Y} `{TensorElem X} `{TensorElem Y}:
  forall N (e0 : Z -> X) (e1 : X -> Z -> Y) k s,
    (k <= N)%Z ->
    (0 < k)%Z ->
    (forall x, consistent (e0 x) s) ->
  GEN [ n' < N ] (tlet x := (|[ n' <? k ]| e0 n') in e1 x n')
  = tlet x := GEN [ n' < k ] e0 n' in
    GEN [ n' < N ] e1 (x _[n']) n'.
Proof.
  intros. unfold let_binding.
  apply gen_eq_bound; intros.
  destruct (i <? k)%Z eqn:e; unbool_hyp.
  - rewrite true_iverson.
    rewrite get_gen_some by auto.
    reflexivity.
  - rewrite get_gen_null by lia.
    f_equal.
    unfold iverson. eapply mul_0_absorb; eauto.
Qed.

Theorem ll_sumr {X Y} `{TensorElem X} `{TensorElem Y}:
  forall N m (e0 : Z -> X) (e1 : X -> Z -> Y),
  SUM [ m <= n' < N ] (tlet x := e0 n' in e1 x n')
  = tlet x := GEN [ m <= i < N ] e0 i in
    SUM [ m <= n' < N ] e1 (x _[ n' - m ]) n'.
Proof.
  intros. simpl.
  apply sumr_eq_bound.
  intros. unfold let_binding.
  rewrite get_genr_some; try lia.
  rewrite Zplus_minus. reflexivity.
Qed.

Theorem ll_sum {X Y} `{TensorElem X} `{TensorElem Y}:
  forall N (e0 : Z -> X) (e1 : X -> Z -> Y),
  SUM [ n' < N ] (tlet x := e0 n' in e1 x n')
  = tlet x := GEN [ i < N ] e0 i in
    SUM [ n' < N ] e1 (x _[ n' ]) n'.
Proof.
  intros. simpl.
  apply sum_eq_bound.
  intros. f_equal. symmetry.
  rewrite get_gen_some; auto with crunch.
Qed.

Theorem ll_sum_indep {X Y} `{TensorElem X} `{TensorElem Y}:
  forall N (e0 : X) (e1 : X -> Z -> Y),
  SUM [ n' < N ] (tlet x := e0 in e1 x n')
  = tlet x := e0 in
    SUM [ n' < N ] e1 x n'.
Proof.
  intros. simpl. reflexivity.
Qed.

Theorem ll_get {X Y} `{TensorElem X} `{TensorElem Y} :
  forall (I : Z) (e0 : X) (e1 : X -> list Y),
    (tlet x := e0 in e1 x) _[ I ] = tlet x := e0 in (e1 x) _[ I ].
Proof. trivial. Qed.

Theorem ll_iverson {X Y} `{TensorElem X} `{TensorElem Y} :
  forall (p : bool) (e0 : X) (e1 : X -> Y) a s,
    consistent e0 s ->
    (forall x, consistent x s -> consistent (e1 x) a) ->
    (|[ p ]| (tlet x := e0 in e1 x)) = tlet x := |[ p ]| e0 in |[ p ]| (e1 x).
Proof.
  unfold iverson.
  unfold let_binding.
  destruct p; intros.
  repeat rewrite mul_1_id. reflexivity.
  eapply mul_0_absorb; eauto.
  eapply H2.
  eapply consistent_mul. auto.
Qed.

Theorem ll_iverson_ {X Y} `{TensorElem Y} :
  forall (p : bool) (e0 : X) (e1 : X -> Y),
    (|[ p ]| (tlet x := e0 in e1 x)) = tlet x := e0 in |[ p ]| (e1 x).
Proof.
  unfold iverson.
  unfold let_binding.
  intros. auto.
Qed.

Theorem let_let_same {X Y} `{TensorElem Y} :
  forall e1 (f : X -> X -> Y),
  (tlet x := e1 in (tlet y := e1 in f x y)) =
  tlet x := e1 in f x x.
Proof. intros. unfold let_binding. reflexivity. Qed.

Theorem let_let_flip {X Y Z} `{TensorElem Z} `{TensorElem Y} :
  forall (e1 : X) (f : X -> Y) (g : Y -> Z),
    let_binding (let_binding e1 f) g =
    let_binding e1 (fun x => g (f x)).
Proof.
  intros. unfold let_binding. reflexivity.
Qed.

Theorem let_rotate_concat_right {X Y} `{TensorElem X} `{TensorElem X} :
  forall (e1 e2 : list X) (f : list X -> Y),
    let_binding (e1 <++> e2) f = let_binding e1 (fun e => f (e <++> e2)).
Proof. intros. unfold let_binding. reflexivity. Qed.

Theorem let_rotate_concat_left {X Y} `{TensorElem X} `{TensorElem X} :
  forall (e1 e2 : list X) (f : list X -> Y),
    let_binding (e1 <++> e2) f = let_binding e2 (fun e => f (e1 <++> e)).
Proof. intros. unfold let_binding. reflexivity. Qed.

Lemma let_guard_lift {X Y} `{TensorElem X} `{TensorElem Y} :
  forall p (e1 : X) (e2 : X -> Y) s s',
    consistent e1 s ->
    (forall x, consistent x s -> consistent (e2 x) s') ->
    let_binding e1 (fun x => |[ p ]| e2 x) =
    let_binding (|[ p ]| e1) (fun x => |[ p ]| e2 x).
Proof.
  intros. unfold let_binding.
  destruct p. repeat rewrite true_iverson. auto.
  unfold iverson.
  eapply mul_0_absorb.
  eauto. apply H2.
  apply consistent_mul. auto. auto.
Qed.