(* -*- mode: coq -*- *)
(* Time-stamp: <2014/8/23 21:0:44> *)
(*
  substitute.v
  - mathink : Author
 *)

(* Program libraries for [Program] *)
(* Map Skelton *)
Require Import
Ssreflect.ssreflect
Ssreflect.ssrfun
Ssreflect.ssrbool
Ssreflect.eqtype.

Set Implicit Arguments.
Unset Strict Implicit.

Require Import MSL.lambda.

Delimit Scope map with map_scope.
Open Scope map_scope.
Unset Strict Implicit.
Import Prenex Implicits.

(* Notations for Maybe *)
Definition bind {X Y: Type}(f: X -> option Y)(m: option X): option Y :=
  if m is Some x then f x else None.
Notation emb := Some.
Notation "m >>= f" := (bind f m) (at level 65, left associativity).
Notation "m >> p" := (bind (fun _ => p) m) (at level 65, left associativity).
Notation "x <- m ; p" := (m >>= fun x => p) (at level 60, right associativity).
Notation "(: x , y :) <- m ; p" := (m >>= fun tup:_*_ => let: (x,y) := tup in p) (at level 60, right associativity).
Notation "'do' m" := m (at level 100, right associativity).
Notation "'mlet' x := m ; p" := (x <- emb m ; p) (at level 60, right associativity).

Section HoleFilling.
  Open Scope map_scope.
  Context {T: eqType}.

  Notation "[=]" := (box T).
  Let sexp := sexp T.
  Let lambda := lambda T.

  Arguments asL {T}(s H): rename.

  Check (fun s (b: is_true (wfb 0 s)) =>(elimT (wfbP 0 s) b)).
  Notation "[ 'L' s | b ]" :=
    (Lam (introT (isLbP s) (elimT (isLbP s) b)))
  (at level 0, format "[ 'L' s | b ]"): map_scope.
  Notation "'L.' s" := (asL s _)
  (at level 0, format "'L.' s"): map_scope.
  Notation "[ 'S' M ]" := (body M)
  (at level 0, format "[ 'S' M ]"): map_scope.
  Notation "'S.' M" := (body M)
  (at level 0, format "'S.' M"): map_scope.
  Definition asL (s: sexp): 0#s -> lambda :=
    fun H => Lam (introT (isLbP s) (wf_sexp_is_lambda H)).

  Fixpoint HF_aux (P: lambda)(m: map)(s: sexp){struct s}: option sexp :=
    match m, s with
      | 1, box => Some S.P
      | 0, box => Some [=]
      | 0, free x => Some (free x)
      | 1, free x => None
      | 0, M@N =>
       match HF_aux P 0 M, HF_aux P 0 N with
         | Some MmP, Some NnP  => Some (MmP@NnP)
         | _, _  => None end
      | minl m, M@N =>
       match HF_aux P m M, HF_aux P 0 N with
         | Some MmP, Some NnP  => Some (MmP@NnP)
         | _, _  => None end
      | minr n, M@N =>
       match HF_aux P 0 M, HF_aux P n N with
         | Some MmP, Some NnP  => Some (MmP@NnP)
         | _, _  => None end
      | mcons m n, M@N =>
       match HF_aux P m M, HF_aux P n N with
         | Some MmP, Some NnP  => Some (MmP@NnP)
         | _, _  => None end
      | m, n\N =>
        if wfb n N && orthb n m then
          if HF_aux P m N is Some NmP then Some (n\NmP) else None
        else None
      |  _,_  => None
    end.

  Functional Scheme HF_aux_ind := Induction for HF_aux Sort Prop.

  Lemma HF_0 M (P: lambda): 0#M -> emb M = HF_aux P 0 M.
  Proof.
    elim: M => [x||M1 IH1 M2 IH2|m M IH] Hwf //=.
    - rewrite -mapp_00_0 in Hwf; inversion Hwf; subst.
      rewrite H; rewrite -mapp_00_0 in H.
      by move: H H2 H3 => /eqP; rewrite mapp_injective;
        move=> /andP [/eqP -> /eqP ->] H1 H2;
          rewrite -(IH1 H1) -(IH2 H2). 2!emb_bind //=.
    - rewrite orthb_symm //= andbT.
      inversion Hwf; subst.
      by move: H3 => /wfbP ->; rewrite -(IH H1).
  Qed.

(*   Lemma orth_wf_HF_wf m1 m2 t t1 P: *)
(*     m1!m2 -> m1#t -> emb t1 = HF_aux P m1 t -> m2#t1. *)
(*   Proof. *)
(*     move: m2 t1. *)
(*     pattern (HF_aux P m1 t); apply HF_aux_ind => // m0 s0. *)
(*     - move=> _{m0} x _{s0} m s Hor Hwf [] -> //=. *)
(*       inversion Hor. *)
(*     elim/HF_aux_ind: P t /(HF_aux P m1 t). *)
(* Check HF_aux_ind. *)
(*     elim=> [m|n|m n m' n' Ho IH Ho' IH'] Hwf Heq /=. *)
(*     - elim: t m Hwf Heq => [x||s1 IHs1 s2 IHs2|m s1 IH] /=. *)
(*       + move=> m Hwfm; inversion Hwfm; subst. *)
(*         by move=> Heq; apply emb_mono in Heq; subst. *)
(*       + move=> m Hwfm; inversion Hwfm; subst. *)
(*         * by move=> Heq; apply emb_mono in Heq; subst. *)
(*         * move=> Heq; apply emb_mono in Heq; subst. *)
(*           apply lambda_is_wf. *)
(*       + move=> m Hwfm; inversion Hwfm; subst. *)
(*         destruct m0, n; simpl in *. *)
(*         * rewrite -(HF_0 _ H2) -(HF_0 _ H3) 2!emb_bind; *)
(*           by move=> Heq; apply emb_mono in Heq; move: Heq => ->. *)
(*         * rewrite -(HF_0 _ H2) emb_bind. *)

  Lemma HF_aux_wf s m P:
    m#s -> exists t: sexp, emb t = HF_aux P m s/\isLb t.
  Proof.
    elim=> [y|||m1 m2 s1 s2 H1 IH1 H2 IH2|m1 m2 t H1 IH1 H2 IH2 Horth] .
    - exists (free y); repeat split; constructor.
    - by exists [=]; repeat split; constructor.
    - by exists (S.P); repeat split; try constructor; destruct P.
    - move: IH1 IH2 => [t1 [Heq1 HL1]] [t2 [Heq2 HL2]].
      exists (t1@t2).
      destruct m1, m2; simpl in *;
      (rewrite -Heq1 -Heq2;
       repeat split; try done; last by apply /andP; split).
    - move: IH1 IH2 => [t1 [Heq1 HL1]] [t2 [Heq2 HL2]].
      exists (m2\t1); split.
      + simpl HF_aux.
        rewrite -Heq1 /=.
        case: (m2!P m1) => [Hor|Hnor]; rewrite ?andbT ?andbF.
        * case: (m2#P t) => [Hwf|Hnwf]; rewrite ?andbT.
          clear Heq1 H1 Horth Hor.
          destruct m1; try done.
          destruct m0; try done.
        * destruct m1; try done.
      + apply orth_symm in Horth; contradiction.
    - apply/isLbP; apply labs; first by apply/isLbP.
  (* have: m1!m2 -> m1#t -> emb t1 = HF_aux t m1 P -> m2#t1 *)
      Abort.
  Qed.

  Notation "[ M '_' m { P } ]" := (HF_ M m P).

  Program Fixpoint HoleFill (s: sexp)(m: map)(s: lambda): F lambda :=
    match M , m return F lambda with
      | Lam (free x) _, 0 => emb L.(free x)
      | Lam box _, 1 => emb P
      | Lam box _, 0 => emb L.[]
      | Lam (M@N) H, 0 =>
        do mlet m := 0;
           mlet n := 0;
           MmP <- HoleFill L.M m P;
           NnP <- HoleFill L.N n P;
           emb L.(S.MmP @ S.NnP)
      | _, _ => failure lambda
    end; try by constructor.
    Proof.
      - rewrite -mapp_00_0; apply wf_mapp_app; apply lambda_is_wf.
      - move: H => /isLbP.
        destruct term.
apply lambda_is_wf.

      | M@N, minl m =>
        do mlet n := 0;
           MmP <- HoleFill L.M m P;
           NnP <- HoleFill L.N n P;
           emb L.(S.MmP @ S.NnP)
      | M@N, minr n =>
        do mlet m := 0;
           MmP <- HoleFill M m P;
           NnP <- HoleFill N n P;
           emb (MmP@NnP)
       | M@N, mcons m n =>
         do MmP <- HoleFill M m P;
            NnP <- HoleFill N n P;
            emb (MmP@NnP)
       | n\N, m =>
         do NmP <- HoleFill N m P;
            emb (n\NmP)
      | _, _ => failure lambda
    end).
          | _,_ => failure sexP
        end.

      Notation "[ M '_' m { P } ]" := (HoleFill M m P).

      (*      Lemma wf_wf m x: 0#x -> m#x.
      Proof.
        move=> H0x; move: x H0x m.
        elim=> [y||s IHs t IHt|m s IHs] Hwf m'; try constructor. *)

      (* Lemma HoleFill_wf m M N: *)
      (*   (exists x, emb x = HoleFill M m N) -> m#M. *)

      Lemma HoleFill_wf m M N:
        m#M -> 0#N -> exists x, 0#x /\ emb x = HoleFill M m N.
      Proof.
        move=> HmM H0N.
        elim: HmM =>  //= [x||
                          | m1 m2 s t H1 IH1 H2 IH2
                          | m1 m2 s H1 IH1 H2 IH2] /=.
        - exists (free x); split; try by constructor.
        - exists box; split; try by constructor.
        - exists N; split; done.
          move: IH1 IH2 => [x1 [Hx1 Heq1]] [x2 [Hx2 Heq2]] /=.
          exists (x1@x2); split;
          first (rewrite -mapp_00_0; apply wf_mapp_app; done).
          case: m1 H1 Heq1 => /=.
          + case: m2 H2 Heq2 => /=.
            * move=> _ Heq1 _ Heq2.
                by rewrite emb_bind emb_bind
                   -Heq1 -Heq2 emb_bind emb_bind.
            * move=> m' _ Heq1 _ Heq2.
                by rewrite emb_bind -Heq1 -Heq2 emb_bind emb_bind.
          + case: m2 H2 Heq2 => /=.
            * move=> _ Heq1 n' _ Heq2.
                by rewrite emb_bind -Heq1 -Heq2 emb_bind emb_bind.
            * move=> m' _ Heq1 n' _ Heq2.
                by rewrite -Heq1 -Heq2 emb_bind emb_bind.
        - move: IH1 IH2 => [x1 [Hx1 Heq1]] [x2 [Hx2 Heq2]] Horth.
          rewrite -Heq1 emb_bind.
          exists (m2\x1); split; last done.
          apply wf_abs; first done; try by constructor.
          (*   Heq2 : emb x2 = [s _ m2 {N}] means m2#x1 *)

      Fixpoint mapf (x: T)(s: sexp): map :=
        match s with
          | free y => if x == y then 1 else 0
          | box => 0
          | M@N => mapf x M*mapf x N
          | m\M => mapf x M
        end.

      Fixpoint skelf (x: T)(s: sexp): sexp :=
        match s with
          | free y => if x == y then box else free y
          | box => box
          | M@N => skelf x M@skelf x N
          | m\M => m\skelf x M
        end.

      Definition lam (x: T)(M: sexp) := mapf x M\skelf x M.

      Lemma mapp_0 m n: m*n = 0 -> m = 0 /\ n = 0.
      Proof.
        case: m => [|m] /=; case: n => [| n] /=; try done.
      Qed.

      Lemma wf_skelf m x s: m#s -> m#skelf x s.
      Proof.
        elim=> [y|||m1 m2 s1 s2 H1 IH1 H2 IH2|m1 m2 t H1 IH1 H2 IH2 H] /=;
          try by constructor.
        - case: (x == y) => /=; try by constructor.
      Qed.

(*      Lemma orth_mapf m x s: 0#s -> 0!m -> (mapf x s)!m.
        elim: s => [y||s IHs t IHt|n s IHs] /= Hwf Horth;
                  try by constructor.
        - case: (x == y) => /=; try by constructor.
          simpl.
        move=> Horth; move: Horth x s.
        elim=> [m'|n'|m1 n1 m2 n2 H1 IH1 H2 IH2] x s; try by constructor.
      Lemma orth_mapf m x s: 0!m -> mapf x s!m.
      Proof.
        move=> Horth; move: Horth x s.
        elim=> [_|n|m1 n1 m2 n2 H1 IH1 H2 IH2]; try by constructor.
        - case: (x == y) => /=; try by constructor.
      Qed.
       *)

      (*
      Lemma map_skeleton_aux:
        forall x m M,
          m#M ->
          m*mapf x M # skelf x M -> mapf x M # m\skelf x M.
      Proof.
        move=> x m M Hwf.
        elim: Hwf => [y||
                     |m1 m2 s1 s2 H1 IH1 H2 IH2
                     |m1 m2 s H1 IH1 H2 IH2 Horth] /=;
          try by constructor.
        - case: (x == y) => /=; try by constructor.
          + move=> H; inversion H.
          + move=> H; inversion H.
            apply wf_abs; try by constructor.
        - move=> H; apply wf_abs; try by constructor.
        - move=> H; apply wf_abs; try by constructor.
        - move=> H; inversion H; subst.
          move: H3 => /eqP; rewrite mapp_injective;
            move=> -/andP [-/eqP Heq1 -/eqP Heq2]; subst.
          apply wf_abs; try done.
          apply wf_mapp_app; try done.
          + apply wf_mapp_app; try done.

        move=> x m M; simpl; auto.
      Qed.
       *)

      Definition substitute (M: sexp)(x: T)(p: sexp) :=
        HoleFill (skelf x M) (mapf x M) p.

      Lemma substitute_app M N x P:
        substitute (M@N) x P = do MxP <- substitute M x P;
                                  NxP <- substitute N x P;
                                  emb (MxP@NxP).
      Proof.
        rewrite /substitute //=.
        case: (mapf x M) => //=.
        - case: (mapf x N) => //=.
          + by rewrite emb_bind emb_bind.
          + by move=> m; rewrite emb_bind.
        - move=> m.
          case: (mapf x N) => //=.
          + by rewrite emb_bind.
      Qed.

      Lemma substitute_abs m M x P:
        substitute (m\M) x P = do MxP <- substitute M x P;
                                  emb (m\MxP).
      Proof.
        rewrite /substitute //=.
      Qed.

      Lemma fresh_on_skelf x P:
        fresh_on x P -> skelf x P = P.
      Proof.
        elim: P => //= [y|s IHs t IHt| m s IHs] /=.
        - apply ifN_eq.
        - by move=> /andP [Hs Ht]; rewrite (IHs Hs) (IHt Ht).
        - by move=> H; rewrite (IHs H).
      Qed.

      Lemma fresh_on_mapf x P:
        fresh_on x P -> mapf x P = 0.
      Proof.
        elim: P => //= [y|s IHs t IHt] /=.
        - apply ifN_eq.
        - by move=> /andP [Hs Ht]; rewrite (IHs Hs) (IHt Ht).
      Qed.

      Lemma HF_0 P M: emb P = HoleFill P 0 M.
      Proof.
        { elim: P => [x||s IHs t IHt|m s IHs] //=.
          - rewrite emb_bind emb_bind //= -IHs -IHt.
            rewrite emb_bind emb_bind //=.
          - by rewrite -IHs emb_bind. }
      Qed.

      Lemma substitute_lemma x y P M N:
        x <> y -> fresh_on x P ->
        (do MxN <- substitute M x N;
            substitute MxN y P)
        =
        (do MyP <- substitute M y P;
            NyP <- substitute N y P;
            substitute MyP x NyP).
      Proof.
        move=> Hneq Hfresh.
        rewrite /substitute; induction M; move=> //=.
        - case Hxx0: (x == x0) => //=.
          + rewrite emb_bind //=.
            case Hyy0: (y == x0) => //=.
            * move: Hxx0 Hyy0 => /eqP Hxx0 /eqP Hyy0 //=; subst.
                by elim Hneq.
            * by rewrite emb_bind //= Hxx0 //= bind_emb.
          + rewrite emb_bind //=.
            case Hyy0: (y == x0) => //=.
            * rewrite emb_bind //=.
              rewrite (fresh_on_mapf Hfresh)
                      (fresh_on_skelf Hfresh) //=.
              { elim: N => [x1||s IHs t IHt| m s IHs] //=.
                - case Hyx1: (y == x1) => //=.
                  + rewrite emb_bind.
                    apply: (HF_0 P P).
                  + rewrite emb_bind.
                    apply: (HF_0 P _).
                - rewrite emb_bind.
                  apply: (HF_0 P _).
                - destruct (mapf y s); simpl.
                  + destruct (mapf y t); simpl.
                    * rewrite emb_bind emb_bind.
                      by rewrite -(HF_0 _ P) -(HF_0 _ P)
                        emb_bind emb_bind emb_bind -(HF_0 _ _).
                    * rewrite emb_bind -(HF_0 _ _) emb_bind //=.
                      rewrite bind_assoc IHt.
                      apply bind_subst; try done.
                      by move=> x1;
                          rewrite emb_bind -(HF_0 _ _) -(HF_0 _ _).
                  + destruct (mapf y t); simpl.
                    * rewrite emb_bind bind_assoc IHs.
                      apply bind_subst; try done.
                      move=> x1.
                      rewrite bind_assoc -(HF_0 _ _) IHt.
                      apply bind_subst; try done.
                      move=> x2.
                      by rewrite emb_bind -(HF_0 _ _) -(HF_0 _ _).
                    * rewrite bind_assoc IHs.
                      apply bind_subst; try done.
                      move=> x1.
                      rewrite bind_assoc -(HF_0 _ _) IHt.
                      apply bind_subst; try done.
                      move=> x2.
                      by rewrite emb_bind -(HF_0 _ _) -(HF_0 _ _).
                - rewrite bind_assoc IHs.
                  apply bind_subst; try done.
                  move=> x1.
                    by rewrite emb_bind -(HF_0 _ _) -(HF_0 _ _). }
            * rewrite emb_bind //= Hxx0 /=.


Require Import compcert.backend.Cminor.
Require Import compcert.common.AST.
Require Import compcert.common.Errors.
Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Maps.
Require Import InetDiag.
Require Import InetDiagConf.
Import ListNotations.

Open Local Scope error_monad_scope.

Definition reg_entry: ident := 1%positive.

Definition transl_load_field (f: field) : Cminor.expr :=
  match f with
  | (ty, offset) =>
    let addr := Ebinop Oadd (Evar reg_entry) (Econst (Ointconst offset)) in
    Eload ty addr
  end.

Definition transl_jmp (loc: location) (nextlbl: nat) : Cminor.stmt :=
  match loc with
  | Reject => Sreturn (Some (Econst (Ointconst Int.zero)))
  | Loc n => Sgoto (P_of_succ_nat (nextlbl - n - 1))
  end.

Definition transl_cond (cond: InetDiag.condition) :=
  let v := transl_load_field (cond_field cond) in
  match cond with
  | Sge p => Ebinop (Ocmpu Cge) v (Econst (Ointconst p))
  | Sle p => Ebinop (Ocmpu Cle) v (Econst (Ointconst p))
  | Dge p => Ebinop (Ocmpu Cge) v (Econst (Ointconst p))
  | Dle p => Ebinop (Ocmpu Cle) v (Econst (Ointconst p))
  end.

Definition transl_instr (instr: instruction) (nextlbl: nat) : Cminor.stmt :=
  match instr with
  | Nop => Sskip
  | Jmp loc => transl_jmp loc nextlbl
  | Cjmp cond loc => Sifthenelse (transl_cond cond) Sskip (transl_jmp loc nextlbl)
  end.

Fixpoint transl_code (c: code) : res Cminor.stmt :=
  match c with
  | nil => OK (Sreturn (Some (Econst (Ointconst Int.one))))
  | instr :: rest =>
    let n := length rest in
    do ts <- transl_code rest;
    let hs := transl_instr instr (S n) in
    OK (Sseq hs (Slabel (P_of_succ_nat n) ts))
  end.

Definition transl_function (f: function) : res Cminor.function :=
  do body <- transl_code f;
  let params := [ reg_entry ] in
  let vars := [] in
  let stackspace := 0 in
  OK (Cminor.mkfunction signature_main params vars stackspace body).

Definition transl_fundef (fd: fundef) : res Cminor.fundef :=
  match fd with
  | Internal f => do f' <- transl_function f; OK (Internal f')
  | External f => Error (msg "no external function allowed")
  end.

Definition transl_program (p: program) : res Cminor.program :=
  transform_partial_program transl_fundef p.

Definition example1 :=
  [ Cjmp (Sge (Int.repr 21)) Reject
  ; Cjmp (Sge (Int.repr 1024)) (Loc 1)
  ; Jmp Reject
  ; Nop
  ].


Require Import Coq.ZArith.ZArith.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Crypto.Rewriter.AllTacticsExtra.
Require Import Crypto.Rewriter.RulesProofs.

Module Compilers.
  Import Language.Compilers.
  Import Language.API.Compilers.
  Import Language.Wf.Compilers.
  Import Language.WfExtra.Compilers.
  Import Rewriter.AllTacticsExtra.Compilers.RewriteRules.GoalType.
  Import Rewriter.AllTactics.Compilers.RewriteRules.Tactic.
  Import Compilers.Classes.

  Module Import RewriteRules.
    Section __.
      Context (which_bitwidths : list Z).

      Definition VerifiedRewriterRelaxBitwidthAdcSbb : VerifiedRewriter_with_args false false true (relax_bitwidth_adc_sbb_rewrite_rules_proofs which_bitwidths).
      Proof using All. make_rewriter. Defined.

      Definition default_opts := Eval hnf in @default_opts VerifiedRewriterRelaxBitwidthAdcSbb.
      Let optsT := Eval hnf in optsT VerifiedRewriterRelaxBitwidthAdcSbb.

      Definition RewriteRelaxBitwidthAdcSbb (opts : optsT) {t : API.type} := Eval hnf in @Rewrite VerifiedRewriterRelaxBitwidthAdcSbb opts t.

      Lemma Wf_RewriteRelaxBitwidthAdcSbb opts {t} e (Hwf : Wf e) : Wf (@RewriteRelaxBitwidthAdcSbb opts t e).
      Proof. now apply VerifiedRewriterRelaxBitwidthAdcSbb. Qed.

      Lemma Interp_RewriteRelaxBitwidthAdcSbb opts {t} e (Hwf : Wf e) : expr.Interp (@Compilers.ident_interp) (@RewriteRelaxBitwidthAdcSbb opts t e) == expr.Interp (@Compilers.ident_interp) e.
      Proof. now apply VerifiedRewriterRelaxBitwidthAdcSbb. Qed.
    End __.
  End RewriteRules.

  Module Export Hints.
#[global]
    Hint Resolve Wf_RewriteRelaxBitwidthAdcSbb : wf wf_extra.
#[global]
    Hint Opaque RewriteRelaxBitwidthAdcSbb : wf wf_extra interp interp_extra rewrite.
#[global]
    Hint Rewrite @Interp_RewriteRelaxBitwidthAdcSbb : interp interp_extra.
  End Hints.
End Compilers.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import terms2.

Lemma deq_nvar_refl :
  forall v, deq_nvar v v = left eq_refl.
Proof.
  introv.
  destruct (deq_nvar v v); sp.
  generalize (@UIPReflDeq NVar deq_nvar v e); intro k.
  rw k; auto.
Qed.

Ltac boolvar_step :=
  match goal with
    | [ |- context[beq_var ?v ?v] ] => rewrite <- beq_var_refl
    | [ |- context[deq_nvar ?v ?v] ] => rewrite deq_nvar_refl
    | [ |- context[deq_nvar ?v1 ?v2] ] =>
      destruct (deq_nvar v1 v2);[try(subst v1)|];try(complete auto)
    | [ |- context[memvar ?v ?s] ] =>
        let name := fresh "b" in
          remember (memvar v s) as name;
        match goal with
          | [ H : name = memvar v s |- _ ] =>
              symmetry in H;
              destruct name;
              [ rewrite fold_assert in H;
                  trw_h assert_memvar H;
                  simpl in H
              | trw_h not_of_assert H;
                  trw_h assert_memvar H;
                  simpl in H
              ]
        end
    | [ |- context[beq_var ?v1 ?v2] ] =>
        let name := fresh "b" in
          remember (beq_var v1 v2) as name;
        match goal with
          | [ H : name = beq_var v1 v2 |- _ ] =>
            destruct name;
              [ apply beq_var_true in H; try subst
              | apply beq_var_false in H
              ]
        end

    | [ H : context[beq_var ?v ?v] |- _ ] => rewrite <- beq_var_refl in H
    | [ H : context[deq_nvar ?v ?v] |- _ ] => rewrite deq_nvar_refl in H
    | [ H : context[deq_nvar ?v1 ?v2] |- _ ] =>
      destruct (deq_nvar v1 v2);[try(subst v1)|];try(complete auto)
    | [ H : context[memvar ?v ?s] |- _ ] =>
      let name := fresh "b" in
      remember (memvar v s) as name;
        match goal with
          | [ J : name = memvar v s |- _ ] =>
            symmetry in J;
              destruct name;
              [ rewrite fold_assert in J;
                trw_h assert_memvar J;
                simpl in J
              | trw_h not_of_assert J;
                trw_h assert_memvar J;
                simpl in J
              ]
        end
    | [ H : context[beq_var ?v1 ?v2] |- _ ] =>
        let name := fresh "b" in
        remember (beq_var v1 v2) as name;
          match goal with
            | [ J : name = beq_var v1 v2 |- _ ] =>
              destruct name;
                [ apply beq_var_true in J; try subst
                | apply beq_var_false in J
                ]
          end

    | [ |- context[if ?x then _ else _] ] =>
      match type of x with
        | {_} + {_} => destruct x
      end
    | [ |- context[if ?x then _ else _] ] =>
      match type of x with
        | sum _ _ => destruct x
      end
    | [ |- context[if ?x then _ else _] ] =>
      match type of x with
        | decidable _ => destruct x
      end
    | [ |- context[d2b ?x] ] =>
      match type of x with
        | decidable _ => destruct x
      end

    | [H : context[if ?x then _ else _] |- _ ] =>
      match type of x with
        | {_} + {_} => destruct x
      end
    | [H : context[if ?x then _ else _] |- _ ] =>
      match type of x with
        | sum _ _ => destruct x
      end
    | [H : context[if ?x then _ else _] |- _ ] =>
      match type of x with
        | decidable _ => destruct x
      end
    | [H : context[d2b ?x] |- _ ] =>
      match type of x with
        | decidable _ => destruct x
      end

    | [ |- context[deq_nat           ?x ?y] ] => destruct (deq_nat           x y)
    | [ |- context[String.string_dec ?x ?y] ] => destruct (String.string_dec x y)
    | [ |- context[opsign_dec        ?x ?y] ] => destruct (opsign_dec        x y)
    | [ |- context[Z_noteq_dec       ?x ?y] ] => destruct (Z_noteq_dec       x y)
    | [ |- context[parameter_dec     ?x ?y] ] => destruct (parameter_dec     x y)
    | [ |- context[parameters_dec    ?x ?y] ] => destruct (parameters_dec    x y)

    | [ H : context[deq_nat           ?x ?y] |- _ ] => destruct (deq_nat           x y)
    | [ H : context[String.string_dec ?x ?y] |- _ ] => destruct (String.string_dec x y)
    | [ H : context[opsign_dec        ?x ?y] |- _ ] => destruct (opsign_dec        x y)
    | [ H : context[Z_noteq_dec       ?x ?y] |- _ ] => destruct (Z_noteq_dec       x y)
    | [ H : context[parameter_dec     ?x ?y] |- _ ] => destruct (parameter_dec     x y)
    | [ H : context[parameters_dec    ?x ?y] |- _ ] => destruct (parameters_dec    x y)

    | [ H : context[if memberb _ _ _ then _ else _] |- _ ] => rewrite memberb_din in H
    | [ |- context[if memberb _ _ _ then _ else _] ] => rewrite memberb_din
  end.

Ltac boolvar := repeat boolvar_step.

Lemma fold_mk_prod {o} :
  forall (a : @NTerm o) v b,
    v = newvar b
    -> mk_product a v b = mk_prod a b.
Proof.
  introv e; subst; sp.
Qed.

Lemma fold_mk_fun {o} :
  forall (a : @NTerm o) v b,
    v = newvar b
    -> mk_function a v b = mk_fun a b.
Proof.
  introv e; subst; sp.
Qed.

Lemma fold_mk_ufun {o} :
  forall (a : @NTerm o) v b,
    v = newvar b
    -> mk_isect a v b = mk_ufun a b.
Proof.
  introv e; subst; sp.
Qed.

Lemma int_zero {o} :
  @mk_integer o 0 = mk_zero.
Proof. sp. Qed.

Definition absolute_value {o} (t : @NTerm o) :=
  mk_less t mk_zero (mk_minus t) t.

Ltac fold_terms_step :=
  match goal with
    | [ |- context[@oterm ?p (Can NAxiom) []] ] => fold (@mk_axiom p)
    | [ |- context[@oterm ?p (Can NInt) []] ] => fold (@mk_int p)
    | [ |- context[@oterm ?p (Can (NUTok ?a)) []] ] => fold (@mk_utoken p a)
    | [ |- context[@oterm ?p (Can (NTok ?a)) []] ] => fold (@mk_token p a)
    | [ |- context[@mk_approx ?p mk_axiom mk_axiom] ] => fold (@mk_true p)
    | [ |- context[@mk_approx ?p mk_axiom mk_bot] ] => fold (@mk_false p)
    | [ |- context[@mk_lam ?p nvarx (mk_var nvarx)] ] => fold (@mk_id p)
    | [ |- context[@mk_fix ?p mk_id] ] => fold (@mk_bottom p)
    | [ |- context[@mk_bottom ?p] ] => fold (@mk_bot p)
    | [ |- context[@bterm ?p [] ?x] ] => fold (@nobnd p x)
    | [ |- context[@vterm ?p ?v] ] => fold (@mk_var p v)
    | [ |- context[@oterm ?p (Can (Nint ?z)) []] ] => fold (@mk_integer p z)
    | [ |- context[@mk_integer ?p (Z.of_nat ?n)] ] => fold (@mk_nat p n)
    | [ |- context[@mk_nat ?p 0] ] => fold (@mk_zero p)
    | [ |- context[@oterm ?p (Can (Nseq ?f)) []] ] => fold (@mk_nseq p f)
    | [ |- context[oterm (Can NLambda) [bterm [?v] ?t]] ] => fold (mk_lam v t)
    | [ |- context[oterm (Can NApprox) [nobnd ?a, nobnd ?b]] ] => fold (mk_approx a b)
    | [ |- context[oterm (Can NEquality) [nobnd ?a, nobnd ?b, nobnd ?c]] ] => fold (mk_equality a b c)
    | [ |- context[oterm (Can NFunction) [nobnd ?a, bterm [?v] ?b]] ] => fold (mk_function a v b)
    | [ |- context[oterm (Can NProduct) [nobnd ?a, bterm [?v] ?b]] ] => fold (mk_product a v b)
    | [ |- context[oterm (Can NUnion) [nobnd ?x, nobnd ?y]] ] => fold (mk_union x y)
    | [ |- context[oterm (Can NTExc) [nobnd ?x, nobnd ?y]] ] => fold (mk_texc x y)
    | [ |- context[oterm (NCan NApply) [nobnd ?x, nobnd ?y]] ] => fold (mk_apply x y)
    | [ |- context[oterm (NCan NEApply) [nobnd ?x, nobnd ?y]] ] => fold (mk_eapply x y)
    | [ |- context[oterm (NCan (NApseq ?f)) [nobnd ?x] ] ] => fold (mk_apseq f x)
    | [ |- context[oterm (NCan NDecide) [nobnd ?d, bterm [?x] ?f, bterm [?y] ?g]] ] => fold (mk_decide d x f y g)
    | [ |- context[oterm (NCan NSpread) [nobnd ?p, bterm [?x,?y] ?f]] ] => fold (mk_spread p x y f)
    | [ |- context[oterm (NCan NTryCatch) [nobnd ?a, nobnd ?b, bterm [?v] ?c]] ] => fold (mk_try a b v c)
    | [ |- context[oterm (NCan NFix) [nobnd ?x]] ] => unfold nobnd; fold (mk_fix x); try (fold nobnd)
    | [ |- context[oterm (NCan NCbv) [nobnd ?a, bterm [?v] ?b]] ] => fold (mk_cbv a v b)
    | [ |- context[oterm (NCan NFresh) [bterm [?v] ?b]] ] => fold (mk_fresh v b)
    | [ |- context[oterm (NCan (NCompOp CompOpLess)) [nobnd ?a, nobnd ?b, nobnd ?c, nobnd ?d]] ] => fold (mk_less a b c d)
    | [ |- context[oterm Exc [nobnd ?a, nobnd ?x]] ] => fold (mk_exception a x)
    | [ |- context[oterm (Can NIsect) [nobnd ?a, bterm [?v] ?b] ] ] => fold (mk_isect a v b)
    | [ |- context[oterm (Can NSet) [nobnd ?a, bterm [?v] ?b] ] ] => fold (mk_set a v b)
    | [ |- context[oterm (NCan NMinus) [nobnd ?a] ] ] => fold (mk_minus a)
    | [ |- context[mk_equality ?t ?t ?T] ] => fold (mk_member t T)
    | [ |- context[mk_less ?t mk_zero (mk_minus ?t) ?t] ] => fold (absolute_value t)
    | [ |- context[mk_less ?a ?b mk_true mk_false] ] => fold (mk_less_than a b)
    | [ |- context[@mk_integer ?o 0] ] => rewrite (@int_zero o)
    | [ |- context[@mk_false ?o] ] => fold (@mk_void o)
    | [ |- context[mk_fun ?a mk_void] ] => fold (mk_not a)
    | [ |- context[mk_not (mk_less_than ?b ?a)] ] => fold (mk_le a b)

    | [ H : ?v = newvar ?b |- context[mk_product ?a ?v ?b] ] => rewrite (fold_mk_prod a v b H)
    | [ H : ?v = newvar ?b |- context[mk_function ?a ?v ?b] ] => rewrite (fold_mk_fun a v b H); auto
    | [ H : ?v = newvar ?b |- context[mk_isect ?a ?v ?b] ] => rewrite (fold_mk_ufun a v b H); auto

    | [ H : context[@oterm ?p (Can NAxiom) []] |- _ ] => fold (@mk_axiom p) in H
    | [ H : context[@oterm ?p (Can NInt) []] |- _ ] => fold (@mk_int p) in H
    | [ H : context[@oterm ?p (Can (NUTok ?a)) []] |- _ ] => fold (@mk_utoken p a) in H
    | [ H : context[@oterm ?p (Can (NTok ?a)) []] |- _ ] => fold (@mk_token p a) in H
    | [ H : context[@mk_approx ?p mk_axiom mk_axiom] |- _ ] => fold (@mk_true p) in H
    | [ H : context[@mk_approx ?p mk_axiom mk_bot] |- _ ] => fold (@mk_false p) in H
    | [ H : context[@mk_lam ?p nvarx (mk_var nvarx)] |- _ ] => fold (@mk_id p) in H
    | [ H : context[@mk_fix ?p mk_id] |- _ ] => fold (@mk_bottom p) in H
    | [ H : context[@mk_bottom ?p] |- _ ] => fold (@mk_bot p) in H
    | [ H : context[@bterm ?p [] ?x] |- _ ] => fold (@nobnd p x) in H
    | [ H : context[@vterm ?p ?v] |- _ ] => fold (@mk_var p v) in H
    | [ H : context[@oterm ?p (Can (Nint ?z)) []] |- _ ] => fold (@mk_integer p z) in H
    | [ H : context[@mk_integer ?p (Z.of_nat ?n)] |- _ ] => fold (@mk_nat p n) in H
    | [ H : context[@mk_nat ?p 0] |- _ ] => fold (@mk_zero p) in H
    | [ H : context[@oterm ?p (Can (Nseq ?f)) []] |- _ ] => fold (@mk_nseq p f) in H
    | [ H : context[oterm (Can NLambda) [bterm [?v] ?t]] |- _ ] => fold (mk_lam v t) in H
    | [ H : context[oterm (Can NApprox) [nobnd ?a, nobnd ?b]] |- _ ] => fold (mk_approx a b) in H
    | [ H : context[oterm (Can NEquality) [nobnd ?a, nobnd ?b, nobnd ?c]] |- _ ] => fold (mk_equality a b c) in H
    | [ H : context[oterm (Can NFunction) [nobnd ?a, bterm [?v] ?b]] |- _ ] => fold (mk_function a v b) in H
    | [ H : context[oterm (Can NProduct) [nobnd ?a, bterm [?v] ?b]] |- _ ] => fold (mk_product a v b) in H
    | [ H : context[oterm (Can NUnion) [nobnd ?x, nobnd ?y]] |- _ ] => fold (mk_union x y) in H
    | [ H : context[oterm (Can NTExc) [nobnd ?x, nobnd ?y]] |- _ ] => fold (mk_texc x y) in H
    | [ H : context[oterm (NCan NApply) [nobnd ?x, nobnd ?y]] |- _ ] => fold (mk_apply x y) in H
    | [ H : context[oterm (NCan NEApply) [nobnd ?x, nobnd ?y]] |- _ ] => fold (mk_eapply x y) in H
    | [ H : context[oterm (NCan (NApseq ?f)) [nobnd ?x] ] |- _ ] => fold (mk_apseq f x) in H
    | [ H : context[oterm (NCan NDecide) [nobnd ?d, bterm [?x] ?f, bterm [?y] ?g]] |- _ ] => fold (mk_decide d x f y g) in H
    | [ H : context[oterm (NCan NSpread) [nobnd ?p, bterm [?x,?y] ?f]] |- _ ] => fold (mk_spread p x y f) in H
    | [ H : context[oterm (NCan NTryCatch) [nobnd ?a, nobnd ?b, bterm [?v] ?c]] |- _ ] => fold (mk_try a b v c) in H
    | [ H : context[oterm (NCan NFix) [nobnd ?x]] |- _ ] => unfold nobnd in H; fold (mk_fix x) in H; try (fold nobnd in H)
    | [ H : context[oterm (NCan NCbv) [nobnd ?a, bterm [?v] ?b]] |- _ ] => fold (mk_cbv a v b) in H
    | [ H : context[oterm (NCan NFresh) [bterm [?v] ?b]] |- _ ] => fold (mk_fresh v b) in H
    | [ H : context[oterm (NCan (NCompOp CompOpLess)) [nobnd ?a, nobnd ?b, nobnd ?c, nobnd ?d]] |- _ ] => fold (mk_less a b c d) in H
    | [ H : context[oterm Exc [nobnd ?a, nobnd ?x]] |- _ ] => fold (mk_exception a x) in H
    | [ H : context[oterm (Can NIsect) [nobnd ?a, bterm [?v] ?b] ] |- _ ] => fold (mk_isect a v b) in H
    | [ H : context[oterm (Can NSet) [nobnd ?a, bterm [?v] ?b] ] |- _ ] => fold (mk_set a v b) in H
    | [ H : context[oterm (NCan NMinus) [nobnd ?a] ] |- _ ] => fold (mk_minus a) in H
    | [ H : context[mk_equality ?t ?t ?T] |- _ ] => fold (mk_member t T) in H
    | [ H : context[mk_less ?t mk_zero (mk_minus ?t) ?t] |- _ ] => fold (absolute_value t) in H
    | [ H : context[mk_less ?a ?b mk_true mk_false] |- _ ] => fold (mk_less_than a b) in H
    | [ H : context[@mk_integer ?o 0] |- _ ] => rewrite (@int_zero o) in H
    | [ H : context[@mk_false ?o] |- _ ] => fold (@mk_void o) in H
    | [ H : context[mk_fun ?a mk_void] |- _ ] => fold (mk_not a) in H
    | [ H : context[mk_not (mk_less_than ?b ?a)] |- _ ] => fold (mk_le a b) in H

    | [ H : ?v = newvar ?b, J : context[mk_product ?a ?v ?b] |- _ ] => rewrite (fold_mk_prod a v b H) in J; auto
    | [ H : ?v = newvar ?b, J : context[mk_function ?a ?v ?b] |- _ ] => rewrite (fold_mk_fun a v b H) in J; auto
    | [ H : ?v = newvar ?b, J : context[mk_isect ?a ?v ?b] |- _ ] => rewrite (fold_mk_ufun a v b H) in J; auto

  end.

Ltac fold_terms := repeat fold_terms_step.


From iris.algebra Require Import agree auth gmap.
From iris.proofmode Require Import proofmode.
Require Import Eqdep_dec List.
From cap_machine Require Import macros_helpers addr_reg_sample macros_new.
From cap_machine Require Import rules logrel contiguous fundamental.
From cap_machine Require Import arch_sealing interval_arch malloc interval_closure_arch.
From cap_machine Require Import solve_pure proofmode map_simpl register_tactics.

Section interval_client.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealg: sealStoreG Σ}
          {nainv: logrel_na_invs Σ}
          `{MP: MachineParameters}.

  (* r_t1 : interval input *)
  (* r_env : capability containing the three entry points: makeint, imin, imax *)
  (* pc_b : environment table containing the assert subroutine *)
  Definition check_interval f_a :=
    encodeInstrsW [ Mov r_temp1 r_t1;
                  Mov r_temp2 r_env;
                  Mov r_temp3 r_t0;
                  (* load imin subroutine *)
                  Lea r_env 1;
                  Load r_t2 r_env;
                  (* jmp to imin *)
                  Mov r_t0 PC;
                  Lea r_t0 3;
                  Jmp r_t2;
                  (* copy the result *)
                  Mov r_temp4 r_t1;
                  (* load imax subroutine *)
                  Lea r_temp2 2;
                  Load r_t2 r_temp2;
                  (* jmp to imax *)
                  Mov r_t1 r_temp1;
                  Mov r_t0 PC;
                  Lea r_t0 3;
                  Jmp r_t2;
                  (* compare the two results *)
                  Lt r_t4 r_t1 r_temp4; (* if r_t1 is 1 then z2 < z1, and the assert should fail *)
                  Mov r_t5 0]
                  ++ assert_instrs f_a ++ (* assert (r_t4 = r_t5) *)
                  (* register cleanup*)
    encodeInstrsW [ Mov r_temp1 0;
                  Mov r_temp2 0;
                  Mov r_t0 r_temp3;
                  Mov r_temp3 0;
                  Mov r_t20 0;
                  Mov r_t1 0;
                  Mov r_t2 0;
                  Jmp r_t0 ].

  (* the interval library environment must contain:
   (1) the activation code for makeint, imax, imin
   (2) a linking table with the assert subroutine *)

  (* the subroutines for makeint imax and imin will be
     in separate invariants. So will the relevant parts of its environment table *)

  Definition interval_env d1 d4 benv0 eenv p b e a f_m b1 e1 b2 e2 b3 e3: iProp Σ :=
    (∃ d2 d3, ⌜(d1 + 1 = Some d2 ∧ d2 + 1 = Some d3 ∧ d3 + 1 = Some d4)%a⌝
          ∗ d1 ↦ₐ WCap E b1 e1 b1
          ∗ d2 ↦ₐ WCap E b2 e2 b2
          ∗ d3 ↦ₐ WCap E b3 e3 b3 ∗
          let wvar := WCap RWX benv0 eenv benv0 in
          let wcode1 := WCap p b e a in
          let wcode2 := WCap p b e (a ^+ length (makeint f_m))%a in
          let wcode3 := WCap p b e (a ^+ length (makeint f_m) ^+ length (imin))%a in
          ⌜(b1 + 8)%a = Some e1 ∧ (b2 + 8)%a = Some e2 ∧ (b3 + 8)%a = Some e3⌝
          ∗ ⌜ExecPCPerm p ∧ SubBounds b e a (a ^+ length (makeint f_m) ^+ length imin
                                               ^+ length imax)%a⌝
          ∗ [[b1,e1]]↦ₐ[[activation_instrs wcode1 wvar]]
          ∗ [[b2,e2]]↦ₐ[[activation_instrs wcode2 wvar]]
          ∗ [[b3,e3]]↦ₐ[[activation_instrs wcode3 wvar]]
    )%I.

  Local Existing Instance interp_weakening.if_persistent.
  Lemma check_interval_spec pc_p pc_b pc_e (* PC *)
        wret (* return cap *)
        iw (* input interval. If they are sealed intervals, the program crashes *)
        d1 d4 (* dynamically allocated interval environment *)
        a_first (* special adresses *)
        ι0 ι1 ι2 ι3 ι4 ι5 ι6 o (* invariant/gname names *)
        f_a b_r e_r a_r a_r' b_a e_a a_flag assertN (* assert environment *)
        rmap (* register map *)
        benv0 eenv p_i b_i e_i a_i f_m_i b1 e1 b2 e2 b3 e3 (* interval library *)
        ll ll' p_s b_s e_s a_s Φs(* nested seal environment *) :

    (* PC assumptions *)
    ExecPCPerm pc_p →

    (* Program adresses assumptions *)
    SubBounds pc_b pc_e a_first (a_first ^+ length (check_interval f_a))%a →

    (* environment table: required by the seal and malloc spec *)
    withinBounds b_r e_r a_r' = true →
    (a_r + f_a)%a = Some a_r' →

    dom rmap = all_registers_s ∖ {[ PC; r_t0; r_env; r_t1; r_t20]} →

    (* The two invariants have different names *)
    (up_close (B:=coPset)ι2 ⊆ ⊤ ∖ ↑ι1) ->
    up_close (B:=coPset)ι0 ## ↑ι3 →
    up_close (B:=coPset)ι6 ## ↑ι0 →
    up_close (B:=coPset)ι6 ## ↑ι3 →
    up_close (B:=coPset)ι0 ## ↑ι5 →
    up_close (B:=coPset)ι6 ## ↑ι5 →
    up_close (B:=coPset)ι4 ⊆ ⊤ ∖ ↑ι1 →
    up_close (B:=coPset)ι1 ## ↑assertN →
    up_close (B:=coPset)ι4 ## ↑assertN →

    {{{ PC ↦ᵣ WCap pc_p pc_b pc_e a_first
       ∗ r_t0 ↦ᵣ wret
       ∗ r_env ↦ᵣ WCap RWX d1 d4 d1
       ∗ r_t1 ↦ᵣ iw
       (* proof that the provided value has been validly sealed *)
       ∗ ▷ (if is_sealed_with_o iw o then valid_sealed iw o Φs else True)
       ∗ (∃ w, r_t20 ↦ᵣ w)
       ∗ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i)
       (* invariant for the seal (must be an isInterval seal) and the seal/unseal pair environment,
          and the interval library environment *)
       ∗ na_inv logrel_nais ι0 (seal_env benv0 eenv ll ll' p_s b_s e_s a_s)
       ∗ seal_state ι6 ll o isInterval
       ∗ na_inv logrel_nais ι2 (interval_env d1 d4 benv0 eenv p_i b_i e_i a_i f_m_i b1 e1 b2 e2 b3 e3)
       (* code for imin and imax subroutines *)
       ∗ na_inv logrel_nais ι3 (codefrag (a_i ^+ length (makeint f_m_i))%a imin)
       ∗ na_inv logrel_nais ι5 (codefrag ((a_i ^+ length (makeint f_m_i)) ^+ length imin)%a imax)
       (* token which states all non atomic invariants are closed *)
       ∗ na_own logrel_nais ⊤
       (* callback validity *)
       ∗ interp wret
       (* assert and environment table *)
       ∗ na_inv logrel_nais ι4 (pc_b ↦ₐ WCap RO b_r e_r a_r ∗ a_r' ↦ₐ WCap E b_a e_a b_a)
       ∗ na_inv logrel_nais assertN (assert_inv b_a a_flag e_a)
       (* trusted code *)
       ∗ na_inv logrel_nais ι1 (codefrag a_first (check_interval f_a))
       (* the remaining registers are all valid *)
       ∗ ([∗ map] _↦w_i ∈ rmap, interp w_i) }}}
      Seq (Instr Executable)
      {{{ v, RET v; ⌜v = HaltedV⌝ →
                    ∃ r, full_map r ∧ registers_mapsto r
                         ∗ na_own logrel_nais ⊤ }}}.
  Proof.
    iIntros (Hvpc Hbounds Hwb Ha_r' Hdom Hι0 Hι1 Hι2 Hι3 Hι4 Hι5 Hι6 ? ? Φ)
            "(HPC & Hr_t0 & Hr_env & Hr_t1 & #Hseal_valid & Hr_t20 & Hregs & #Hseal_env & #HsealLL & #Hinterval_env & #Himin & #Himax &
              Hown & #Hwret_valid & #Htable & #Hassert & #Hcheck_interval & #Hregs_valid) HΦ".
    iMod (na_inv_acc with "Hcheck_interval Hown") as "(>Hcode & Hown & Hcls)";auto.
    iMod (na_inv_acc with "Hinterval_env Hown") as "(>Hint & Hown & Hcls')";[auto..|].
    iDestruct "Hint" as (d2 d3 (Hd2&Hd3&Hd4))
                          "(Hd1 & Hd2 & Hd3 & %Hcond & %Hi_pc & Hact1 & Hact2 & Hact3)".
    destruct Hcond as (He1 & He2 & He3).
    destruct Hi_pc as (Hvpci & Hboundsi).

    iExtractList "Hregs" [r_temp1;r_temp2;r_temp3;r_temp4;r_t2] as ["Hr_temp1";"Hr_temp2";"Hr_temp3";"Hr_temp4";"Hr_t2"].

    rewrite /check_interval.
    focus_block_0 "Hcode" as "Hblock" "Hcont".
    iGo "Hblock". split;auto. solve_addr+Hd2 Hd3 Hd4.
    iGo "Hblock".
    unfocus_block "Hblock" "Hcont" as "Hcode".

    iDestruct "Hr_t20" as (w5) "Hr_t20".
    iApply closure_activation_spec;iFrameAutoSolve. iFrame "Hact2".
    iNext. iIntros "(HPC & Hr_t20 & Hr_env & Hact2)".

    rewrite updatePcPerm_cap_non_E;[|by inv Hvpci].
    iMod ("Hcls'" with "[$Hown Hact1 Hact2 Hact3 Hd1 Hd2 Hd3]") as "Hown".
    { iNext. iExists _,_. iFrame "Hact1 Hact2 Hact3". iFrame. auto. }
    iMod ("Hcls" with "[$Hown $Hcode]") as "Hown".
    iExtractList "Hregs" [r_t3;r_t4;r_t5] as ["Hr_t3";"Hr_t4";"Hr_t5"].
    iApply imin_spec;iFrameAutoSolve;[..|iFrame "HsealLL Hseal_env Himin Hown HΦ"];[|eauto..|].
    solve_addr+Hboundsi.
    iSplitR; [iExact "Hseal_valid"|].
    iSplitL "Hr_t2";[eauto|]. iSplitL "Hr_t5";[eauto|]. iSplitL "Hr_t20";[eauto|].
    iSplitR.
    { iNext. iIntros (Hcontr); inversion Hcontr. }
    iNext. iIntros "Hres".
    iDestruct "Hres" as (z1 z2 w)
                          "(%Heqiw & #His_int & HPC & Hr_t1 & Hr_t2
                          & Hr_t5 & Hr_t20 & Hr_env & Hr_t0 & Hown)".
    subst iw.

    iMod (na_inv_acc with "Hcheck_interval Hown") as "(>Hcode & Hown & Hcls)";auto.
    iMod (na_inv_acc with "Hinterval_env Hown") as "(>Hint & Hown & Hcls')";[auto..|].
    iDestruct "Hint" as (d2' d3' (Hd2'&Hd3'&Hd4'))
                          "(Hd1 & Hd2 & Hd3 & %Hcond & %Hi_pc & Hact1 & Hact2 & Hact3)".
    destruct Hcond as (He1' & He2' & He3').
    destruct Hi_pc as (Hvpci' & Hboundsi').
    simplify_eq.

    focus_block_0 "Hcode" as "Hblock" "Hcont".
    rewrite updatePcPerm_cap_non_E;[|by inv Hvpc].
    iGo "Hblock". instantiate (1:=d3). solve_addr +Hd2 Hd3 Hd4.
    iGo "Hblock". split;auto. solve_addr +Hd2 Hd3 Hd4.
    iGo "Hblock". unfocus_block "Hblock" "Hcont" as "Hcode".

    iApply closure_activation_spec;iFrameAutoSolve. iFrame "Hact3".
    iNext. iIntros "(HPC & Hr_t20 & Hr_env & Hact3)".

    rewrite updatePcPerm_cap_non_E;[|by inv Hvpci].
    iMod ("Hcls'" with "[$Hown Hact1 Hact2 Hact3 Hd1 Hd2 Hd3]") as "Hown".
    { iNext. iExists _,_. iFrame "Hact1 Hact2 Hact3". iFrame. auto. }
    iMod ("Hcls" with "[$Hown $Hcode]") as "Hown".

    iApply imax_spec;iFrameAutoSolve;[..|iFrame "HsealLL Hseal_env Himax Hown"];[|eauto..|].
    solve_addr+Hboundsi.
    iSplitR; [iExact "Hseal_valid"|].
    iSplitL "Hr_t2";[eauto|]. iSplitL "Hr_t5";[eauto|]. iSplitL "Hr_t20";[eauto|].

    iSplitR;[|iSplitR].
    2: { iNext. iIntros (v). iIntros "H". iExact "H". }
    iNext. iIntros (Hcontr);inversion Hcontr.

    iNext. iIntros "Hres".
    iDestruct "Hres" as (z0 z3 w')
                          "(%Heq & #His_int' & HPC & Hr_t1 & Hr_t2 & Hr_t5
                           & Hr_t20 & Hr_env & Hr_t0 & Hown)".
    inv Heq.

    (* (* we must now use the sealLL invariant to conclude that w = w' *) *)
    (* iMod (na_inv_acc with "HsealLL Hown") as "(Hseal_inv & Hown & Hcls)";auto. *)
    (* iDestruct "Hseal_inv" as (hd) "(>Hll & Hhd)". *)
    (* iDestruct "Hhd" as (awvals) "(HisList & >Hexact & #Hintervals)". *)
    (* iDestruct (know_pref with "Hexact Hpref") as %Hprefix. *)
    (* iDestruct (know_pref with "Hexact Hpref'") as %Hprefix'. *)
    (* iAssert (▷ ⌜NoDup awvals.*1⌝)%I as "#>%HnoDup". *)
    (* { iNext. iApply isList_NoDup. iFrame. } *)
    (* rewrite Hincr in Hincr'. inv Hincr'. *)
    (* pose proof (elem_of_prefix_eq b01 w w' pbvals pbvals' awvals Hin Hin' Hprefix Hprefix' HnoDup) as <-. *)
    (* iMod ("Hcls" with "[$Hown Hll HisList Hexact]") as "Hown". *)
    (* { iNext. iExists _. iFrame. iExists _. iFrame. auto. } *)
    (* next, we can use isInterval property to conclude that z1 = z0 and z2 = z3 *)
    iDestruct (intervals_agree with "His_int His_int'") as %(Heq & Heq'). subst z0 z3.

    (* we can now finish the program, knowing that z1 <= z2 *)
    iMod (na_inv_acc with "Hcheck_interval Hown") as "(>Hcode & Hown & Hcls)";auto.
    rewrite updatePcPerm_cap_non_E;[|by inv Hvpc].
    focus_block_0 "Hcode" as "Hblock" "Hcont".
    iGo "Hblock". unfocus_block "Hblock" "Hcont" as "Hcode".

    iDestruct "His_int'" as (a1 a2 a3 _) "(_&_&%Hle)".
    assert (z2 <? z1 = false)%Z as ->. lia.

    focus_block 1 "Hcode" as a_mid Ha_mid "Hblock" "Hcont".
    iMod (na_inv_acc with "Htable Hown") as "(>(Hpc_b & Ha_r') & Hown & Hcls')";auto.
    iApply (assert_success with "[- $Hassert $Hown]");iFrameAutoSolve. solve_ndisj. by auto.
    iNext. iIntros "(HPC & Hr_t0 & Hr_t1 & Hr_t2 & Hr_t3 & Hr_t4 & Hr_t5 & Hblock & Hown & Hpc_b & Ha_r')".
    iMod ("Hcls'" with "[$Hown $Hpc_b $Ha_r']") as "Hown".
    unfocus_block "Hblock" "Hcont" as "Hcode".

    iDestruct (jmp_to_unknown _ with "Hwret_valid") as "Hcallback_now".

    focus_block 2 "Hcode" as a_mid0 Ha_mid0 "Hblock" "Hcont".
    iGo "Hblock".
    unfocus_block "Hblock" "Hcont" as "Hcode".
    iMod ("Hcls" with "[$Hown $Hcode]") as "Hown".
    iInsertList "Hregs" [r_t5;r_t4;r_t3;r_t2;r_temp1;r_temp2;r_temp3;r_temp4;r_t1;r_t0;r_t20;r_env].

    iApply ("Hcallback_now" with "[] [$HPC Hregs $Hown]");cycle 1.
    { iApply big_sepM_sep. iFrame.
      repeat (iApply big_sepM_insert_2; first by iApply fixpoint_interp1_eq).
      iApply big_sepM_insert_2. iFrame "#".
      repeat (iApply big_sepM_insert_2; first by iApply fixpoint_interp1_eq).
      iFrame "#". }
    iPureIntro. rewrite !dom_insert_L Hdom. rewrite !singleton_union_difference_L. set_solver+.
  Qed.

End interval_client.


Require Export CatSem.PROP_untyped.initial.
Require Export CatSem.CAT.SO.

Require Import Coq.Program.Equality.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Automatic Introduction.
Unset Transparent Obligations.

Notation "[[ x ; .. ; y ]]" := (cons x .. (cons y nil) ..).

Notation "[ T ]" := (list T) (at level 5).

(** ** Propositional arities and their representations
	given a signature [S], we define
	- half-equations
	- algebraic half-equations
	- (in)equations over [S] as pairs of half-equations
	- representations of (in)equations as a predicate on representations of [S]
*)

(** ** Modules with codomain [wPO] *)

(** given a relative module [M:Set -> PO] over a relative monad [P] over Delta,
       the data of [M] defines a [P]-module [M : Set -> wPO ] *)

Section wPO_taut_mod.

Variable P : RMonad Delta.
Variable M : RModule P Ord.

Obligation Tactic := unfold Proper, respectful; mauto;
        try apply (rmkl_eq M);
        try rew (rmklmkl M);
        try rew (rmkleta M); mauto.

Program Instance wOrd_RMod_struct : RModule_struct P wOrd M := {
  rmkleisli a b f := rmkleisli (RModule_struct:= M) f }.

Definition wOrd_RMod : RModule P wOrd := Build_RModule wOrd_RMod_struct.

End wPO_taut_mod.

(*
Section monadic_subst_as_mod_hom.

Variable P : RMonad Delta.

(*
Print RModule_Hom.

Definition bla:
(forall c : TYPE,
  (product (C:= RMOD P wPO) (wPO_RMod ((DER_RMOD_not PO P) P)) (wPO_RMod P)) c --->
  (wPO_RMod P) c).
simpl.
intro c.
apply (fun y => Rsubstar_not (snd y) (fst y)).
Defined.

(*
apply substar_not.
intro c.
apply (substar
*)
Print bla.
*)

Ltac elim_option := match goal with [H : option _ |- _ ] =>
                     destruct H end.

Ltac t := mauto ; repeat (unfold Rsubstar_not ||
         match goal with [H: prod _ _ |-_] => destruct H end ||
         rew (rklkl P) || app (rkl_eq P) || elim_option ||
         rew (rkleta P) || rew (retakl P ) ||
         rew (rlift_rkleisli P) || rew (rkleisli_rlift P) ||
         unfold rlift || rew (rkleta_eq (FM:=P)) || mauto ).

(*
Obligation Tactic := t.
Check Der_RMod_not.
Program Instance Rsubstar_mod_hom_struct : RModule_Hom_struct
   (M := product (C:=RMOD P wPO) ((DER_RMOD_not _ _ (wPO_RMod P))) (wPO_RMod P))
   (N := wPO_RMod P)
   (fun c y => Rsubstar_not (snd y) (fst y)).
Definition Rsubstar_mod_hom := Build_RModule_Hom Rsubstar_mod_hom_struct.
*)

End monadic_subst_as_mod_hom.
*)

(** ** S-Modules and Equations
   given signature [S], we define equations and the predicate [satisfies_prop_sig]
     on representations of [S]
*)

Section S_Mods_and_Eqs.

Variable S : Signature.

(** an S_Module over [S] should be a functor from representations of [S]
      to the category whose objects are pairs of a monad P and a module over P.
   we don't need the functor properties, and use dependent types instead of the cumbersome
   category of pairs
*)

(*
Class S_Module_s (Tau : forall R : REP S, RMOD R wOrd) := {
   S_Mod_Hom : forall (R S : REP S) (f : R ---> S),
      Tau R ---> PbRMod f (Tau S)  }.
*)

Record S_Module := {
  s_mod :> forall R : REP S, RMOD R wOrd ;
  s_mod_hom :> forall (R T : REP S)(f : R ---> T),
         s_mod R ---> PbRMod f (s_mod T)  }.

(** a half-equation is a natural transformation of between S-Modules.
    we need the naturality condition in the following *)

(*Notation "U @ f" := (S_Mod_Hom (S_Module_s := U) f)(at level 4).*)

Notation "U @ f" := (s_mod_hom U f)(at level 4).

Class half_equation_struct (U V : S_Module)
    (half_eq : forall R : REP S, (*s_mod*) U R ---> (*s_mod*) V R) := {
  comm_eq_s : forall (R T : REP S)  (f : R ---> T),
      U @ f ;; PbRMod_Hom _ (half_eq T) ==  half_eq R ;; V @ f }.

(*
Class half_equation_struct (U V : S_Module)
    (half_eq : forall R : REP S, s_mod U R ---> s_mod V R) := {
  comm_eq_s : forall (R S : REP S)  (f : R ---> S),
     S_Mod_Hom (*S_Module_s := U*) f ;; PbRMod_Hom _ (half_eq S) ==
                half_eq R ;; S_Mod_Hom (S_Module_s := V) f }.
*)

(*
Class half_equation_struct (U V : S_Module)
    (half_eq : forall R : REP S, s_mod U R ---> s_mod V R) := {
  comm_eq_s : forall (R S : REP S)  (f : R ---> S),
     S_Mod_Hom (*S_Module_s := U*) f ;; PbRMod_Hom _ (half_eq S) ==
                half_eq R ;; S_Mod_Hom (S_Module_s := V) f }.
*)

Record half_equation (U V : S_Module) := {
  half_eq :> forall R : REP S, U R --->  V R ;
  half_eq_s :> half_equation_struct half_eq }.

Section S_Module_classic.

(** ** Classic S-Modules and Equations

we are interested in classic S-Modules, i.e. of the form PROD_i P^{n(i)} *)

Variable l : [nat].

(** classic S-Modules on objects *)

Section ob.

Variable P : RMonad Delta.
Variable M : RModule P Ord.

Obligation Tactic := mauto; repeat (t || unfold Proper, respectful ||
                             app pm_mkl_eq || rew pm_mkl_mkl || app pm_mkl_weta).

Program Instance S_Mod_classic_ob_s : RModule_struct P wOrd (fun V => prod_mod_po M V l) := {
  rmkleisli a b f := pm_mkl f }.

Definition S_Mod_classic_ob : RMOD P wOrd := Build_RModule S_Mod_classic_ob_s.

End ob.

Section mor.

(** classic S-Modules on morphisms *)

Variables P Q : RMonad Delta.
Variable f : RMonad_Hom P Q.

Obligation Tactic := repeat (mauto || rew prod_mod_c_kl || app pm_mkl_eq).

Program Instance S_Mod_classic_mor_s : RModule_Hom_struct
       (M := S_Mod_classic_ob P) (N := PbRMod f (S_Mod_classic_ob Q))
       (@Prod_mor_c _ _ f l).

Definition S_Mod_classic_mor := Build_RModule_Hom S_Mod_classic_mor_s.

End mor.

Definition S_Mod_classic := {|
      s_mod := fun R => S_Mod_classic_ob R ;
      s_mod_hom R T f := S_Mod_classic_mor f |}.
(*
Instance S_Mod_classic_s : S_Module_s (fun R => S_Mod_classic_ob R) := {
  S_Mod_Hom R S f := S_Mod_classic_mor f }.
*)
(*Definition S_Mod_classic := Build_S_Module S_Mod_classic_s.*)

End S_Module_classic.

(** ** Example : substitution *)

Section substitution.

(** substitiution is an example of half-equation *)

(** the carrier is - for the moment - defined by tactics. Buh!
     we don't care, since it's just an example *)

Definition subst_carrier (P : REP S) :
(forall c : TYPE, (S_Mod_classic_ob [[1; 0]] P) c ---> (S_Mod_classic_ob [[0]] P) c) .
simpl.
intros.
simpl in *.
inversion X.
simpl in *.
inversion X1.
simpl in X2.
constructor.
simpl.
apply (Rsubstar_not X2 X0).
apply TTT.
Defined.

(*
Print subst_carrier.

Definition subst_carrier_exp (P : REP S) :
(forall c : TYPE, (S_Mod_classic_ob [[1; 0]] P) c ---> (S_Mod_classic_ob [[0]] P) c) :=
  fun c X => match X in (prod_mod_c _ _ l) return
       (match l with
        | TTT => False_rect _ _ _
        | CONSTR a b => match b with

Definition subst_carrier2 (P : REP S) :
(forall c : TYPE, (S_Mod_classic_ob [[1; 0]] P) c ---> (S_Mod_classic_ob [[0]] P) c) .
simpl; intros.
pose (diag x := match x with cons a b => prod_mod_c (fun x => P x) x [[0]])
  fun c X => match X in
          prod_mod_c (fun x : Type => P x) _ l return

*)

Program Instance sub_struct (P : REP S) : RModule_Hom_struct
  (M:=S_Mod_classic_ob [[1;0]] P) (N:=S_Mod_classic_ob [[0]] P) (subst_carrier (P:=P)).
Next Obligation.
Proof.
  dependent destruction x.
  dependent destruction x.
  simpl in *.
  apply CONSTR_eq; auto.
  unfold Rsubstar_not.
  rew (rklkl P).
  rew (rklkl P).
  apply (rkl_eq P).
  simpl.
  mauto.
  destruct x0; simpl.
  unfold rlift.
  simpl.
  rew (retakl P).
  rew (rklkl P).
  rew (rkleta_eq (FM:=P)).
  intros.
  rew (retakl P).
  rew (retakl P).
Qed.

Definition subst_module_mor (P : REP S) := Build_RModule_Hom (sub_struct P).

Program Instance subst_half_s : half_equation_struct
      (U:= (S_Mod_classic [[1 ; 0]])) (V:=S_Mod_classic [[0]]) subst_module_mor.
Next Obligation.
Proof.

  dependent destruction x.
  dependent destruction x.
  dependent destruction x.

  simpl.
  apply CONSTR_eq; auto.
  unfold Rsubstar_not.

  rew (rmon_hom_rkl f).
  app (rkl_eq T).
  intros.
  match goal with [H:option _ |- _]=>destruct H end;
  simpl.
  rew (rmon_hom_rweta f).
  auto.
Qed.

Definition subst_half_eq := Build_half_equation subst_half_s.

End substitution.

(** end of example *)

(** ** Algebraic stuff cont.

an algebraic half-equation is a half-equation with algebraic codomain, and
	an arbitrary domain *)

Definition half_eq_classic (U : S_Module)(codl : [nat]) :=
      half_equation U (S_Mod_classic codl).

(** an algebraic (in)equation is given by
       - an arbitrary domain [domS]
       - an algebraic codomain [S_Mod_alg codl]
       - two half-equations [eq1 eq2 : domS -> S_Mod_alg codl] *)

Record ineq_classic := {
  Dom : S_Module ;
  Cod : [nat] ;
  half_eq_l : half_eq_classic Dom Cod ;
  half_eq_r : half_eq_classic Dom Cod }.

(*
Definition satisfies_eq l l' (e : eq_alg l l') (P : REP S) : Prop.
intros.
destruct e.
simpl in *.
destruct eq3.
destruct eq4.
Check S_Mod_alg. Print S_Module.
apply (forall c : TYPE,
         forall x : s_mod_rep (S_Mod_alg l) P c, half_eq0 P _ x << half_eq1 _ _ x).
Defined.

*)

(** ** Representation of (a set of) (in)equations

a representation [P] satisfies an equation [e] iff for any element in the domain [domS e P c],
 ([c] a set of variables) its two images under e1 and e2 are related
*)

(*
Definition satisfies_eq (e : eq_alg) (P : REP S) :=
  forall c (x : s_mod_rep (domS e) P c),
       (*half_eq*) (eq1 e) P _ x << (*half_eq*) (eq2 e)_ _ x.
*)

Definition satisfies_ineq (e : ineq_classic) (P : REP S) :=
  forall c (x : Dom e P c),
        half_eq_l _ _ _ x <<  half_eq_r _ _ _ x.

(** a set of (in)equations, indexed by a set A *)

Definition Inequations (A : Type) := A -> ineq_classic.

(** [R] satisfies [T] iff it satisfies any equation of [T] *)

Definition satisfies_ineqs A (T : Inequations A) (R : REP S) :=
      forall a, satisfies_ineq (T a) R.

(** ** Subcategory of Rep(S) of representations satisfying equations *)

Section subcat.

(** given any set of (in)equations [T], we consider the following subcategory of
    the category of representations:
     - objects : representations that satisfy [T]
     - morphisms : morphisms that satisfy [True], hence any
*)

Variable A : Type.
Variable T : Inequations A.

(** lemma stating that the properties are closed under composition and
    identity *)

Program Instance Ineq_Rep : SubCat_compat (REP S)
     (fun P => satisfies_ineqs T P) (fun a b f => True).

(** hence we obtain a category, the category of representations of [(S, T)] *)

Definition INEQ_REP : Cat := SubCat Ineq_Rep.

(** * Initiality in the subcategory
We proceed with the construction of its initial object *)

(** ** Order induced by a set of equations
first thing to do is to build the correct order on the set of terms:
     - two terms [x] and [y] are related if their images under any
        initial morphism towards a rep of [(S, T)] is
     - this initial morphism is actually in the category of representations of
     [S], hence we must inject [R] into the big category
*)

Definition prop_rel_c X (x y : UTS S X) : Prop :=
      forall R : INEQ_REP, init (FINJ _ R) x << init (FINJ _ R) y.

(** this ordering is a preorder *)

Program Instance prop_rel_po X : PreOrder (@prop_rel_c X).
Next Obligation.
Proof.
  unfold Reflexive.
  unfold prop_rel_c.
  reflexivity.
Qed.
Next Obligation.
Proof.
  unfold Transitive.
  unfold prop_rel_c.
  simpl; intros.
  transitivity (init (proj1_sig R) y);
  auto.
Qed.

Definition prop_rel_po_s X := Build_PO_obj_struct (prop_rel_po X).

Definition prop_rel X := Build_PO_obj (prop_rel_po_s X).

(** ** Substitution compatible with new order
substitution as defined previously is compatible with this order *)

Program Instance subst_prop_rel_s X Y (f : X ---> UTS S Y) :
   PO_mor_struct (a := prop_rel X) (b := prop_rel Y) (subst f).
Next Obligation.
Proof.
  unfold Proper, respectful.
  unfold prop_rel_c.
  simpl. intros.
  assert (H':= init_kleisli (proj1_sig R)).
  simpl in H'.
  assert (H2 := H' X x _ (Sm_ind f)).
  simpl in H2.
  rewrite H2.
  clear H2.
  assert (H3 := H' X y _ (Sm_ind f)).
  rew H3.
  clear H3.
  apply PO_mor_monotone.
  auto.
Qed.

Definition subst_prop_rel X Y f := Build_PO_mor (subst_prop_rel_s X Y f).

(** now this gives a new relative monad
     - the set of terms is the same as [UTS_sm]
     - the order on any set of terms is different
*)

Obligation Tactic := cat;
      repeat (unfold Proper, respectful ||
       rewrite subst_var || app subst_eq ||
       rewrite subst_subst || cat).

(** ** Monad with previously defined terms but new order, induced by equations *)

Program Instance UTS_prop_rel_rmonad_s : RMonad_struct Delta prop_rel := {
  rweta c := Sm_ind (@Var S c);
  rkleisli := subst_prop_rel
}.

Definition UTSP := Build_RMonad (UTS_prop_rel_rmonad_s).

(** ** an experiment *)
Section higher_order_monotonicity.

(** see the content of this section in _variant *)

(*
Variables X Y : TYPE.
Variables f g : X -> UTSP Y.
Hypothesis H : forall x, f x << g x.
Check H.

Lemma higher_order_mon X (t : UTSP X) Y (f g : X -> UTSP Y)
           (H : forall x, f x << g x)
         : subst_prop_rel f t << subst_prop_rel g t.
Proof.
  simpl in *.
  Check (prod_mod_c_rel (M:= prop_rel)).
 Check prop_rel.
  Check prod_mod_c.
  Check (@UTSind S
           (fun X (t : UTSP  X) =>
              forall Y (f g : X ---> UTS S Y),
             (forall x : X, prop_rel_c (f x) (g x)) ->
            prop_rel_c (subst f t) (subst g t))

           (fun X l (v : UTS_list S X l) =>
              forall Y (f g : X ---> UTS S Y),
                 (forall x : X, prop_rel_c (f x) (g x)) ->

           Rel
            prod_mod_c_rel (M:=prop_rel) (list_subst v f) (list_subst v g))).

).

       Rel (PO_obj_struct := prod_mod_po (SC_inj_ob R) V l)
  (Prod_mor_c (init_mon (S:=S) (SC_inj_ob R)) x)
  (Prod_mor_c (init_mon (S:=S) (SC_inj_ob R)) y) ) :
prod_mod_c_rel (M:=prop_rel) x y.
          (forall x : X, forall R, init (proj1_sig R) (f x) << init _ (g x))
            -> forall t : UTSP X, subst_prop_rel f t << subst_prop_rel g t)).

 set (H:= (@UTSind S
            (fun (X : Type) (T : UTS S X) =>
             forall (Y : Type) (f g : X -> UTS S Y),
         (forall x : X, forall R, init (proj1_sig R) (f x) << init _ (g x))
            -> forall t : UTSP X, subst_prop_rel f t << subst_prop_rel g t))).

app (@UTSlistind
      (fun V x => forall W (f g : V ---> UTS W)
              (H:f == g), x >== f = x >== g)
      (fun V l (v : UTS_list V l) =>
               forall W (f g : V ---> UTS W)(H:f == g),
           v >>== f = v >>== g) );

app (@UTSind
       (fun (a : Type) (v : UTS a) =>
            forall (b : Type)(f g : a ---> b),
         (f == g) ->
         rename (W:=b) f v = rename (W:=b) g v)
       (fun V l (v : UTS_list V l) =>
            forall (b : TYPE)(f g : V ---> b),
         (f == g) ->
         v //-- f =  v //-- g))

  unfold po_obj_struct in H.
  unfold prop_rel in H.
*)
End higher_order_monotonicity.

(** ** Important Lemma
This lemma corresponds to one direction of Lemma 36 *)
(** it says : the relation defined by the set of equations
       behaves well when doing products and derivations.
 this is why we restrict ourselves to algebraic codomains
*)

Lemma lemma36 (l : [nat]) (V : Type)
    (x y : prod_mod_c (fun x : Type => UTS S x) V l)
    (H : prod_mod_c_rel (M:=prop_rel) x y)
    (R : INEQ_REP):
Rel (PO_obj_struct := prod_mod_po (SC_inj_ob R) V l)
  (Prod_mor_c (init_mon (SC_inj_ob R)) x)
  (Prod_mor_c (init_mon (SC_inj_ob R)) y).

(*
Lemma lemma36 (l : [nat]) (V : Type)
    (x y : prod_mod_c (fun x : Type => UTS Sig x) V l)
    (H : prod_mod_c_rel (M:=prop_rel) x y)
    (R : subob (fun P : Representation Sig => satisfies_prop_sig (A:=A) T P)):
Rel (PO_obj_struct := prod_mod_po (SC_inj_ob R) V l)
  (Prod_mor_c (init_mon (SC_inj_ob R)) x)
  (Prod_mor_c (init_mon (SC_inj_ob R)) y).
*)

Proof.
  simpl.
  induction l; simpl;
  intros.
  dependent destruction x.
  dependent destruction y.
  constructor.
  dependent destruction x.
  simpl.
  dependent destruction y.
  simpl.
  constructor.
  simpl.
  Focus 2.
  apply IHl.
  dependent destruction H.
  auto.
  dependent destruction H.
  unfold prop_rel in H. simpl in H.
  unfold prop_rel_c in H.
  apply (H R).
Qed.

(** ** Representation in the new monad
we now pass to representations of [S] in our new shiny monad. the carrier is
    the same as for the diagonal monad. we have to prove that it is compatible with
    the new order on terms *)

Program Instance Build_prop_pos (i : sig_index S) V : PO_mor_struct
  (a := prod_mod UTSP (sig i) V) (b := UTSP V)
  (fun X => Build (i:=i) (UTSl_f_pm (V:=V) X)).
Next Obligation.
Proof.
  unfold Proper; red.
  intros; simpl.
  unfold prop_rel_c.
  simpl.
  intros.
  assert (H2:= repr_hom_s (Representation_Hom_struct := init_representic (SC_inj_ob R))).
  simpl in H2.
  unfold commute in H2.
  simpl in H2.
  rewrite <- H2.
  rewrite <- H2.
  apply PO_mor_monotone.
  apply lemma36.
  auto.
Qed.

Definition Build_prop_po i V := Build_PO_mor (Build_prop_pos i V).

(** these lemmas are the same as for the other monad *)
(** perhaps we could reuse some code here, but that is not urgent *)

Lemma _lshift_lshift_eq2 (b : nat) (X W : TYPE) (f : PO_mor (sm_po X) (prop_rel W))
   (x : X ** b):
 lshift_c (P:=UTSP) (l:=b) (V:=X) (W:=W) f x =
    _lshift (S:=S) (l:=b) (V:=X) (W:=W) f x .
Proof.
  induction b;
  simpl; intros.
  auto.
  rewrite IHb.
  apply _lshift_eq.
  simpl.
  intros.
  destruct x0; simpl;
  auto.
  unfold inj.
  rewrite subst_eq_rename.
  auto.
Qed.

Lemma sts_list_subst2 l X (v : prod_mod (UTSP) l X)
       W (f : Delta X ---> UTSP W):
  UTSl_f_pm  (pm_mkl f v ) = list_subst (UTSl_f_pm v) f.
Proof.
  induction v; simpl;
  intros. auto.
  apply constr_eq.
  apply subst_eq.
  intros.
  rewrite _lshift_lshift_eq2.
  auto.
  auto.
Qed.

Hint Resolve sts_list_subst : fin.
Hint Rewrite sts_list_subst : fin.

(** we need module morphisms for the representation *)

Program Instance Build_prop_s i : RModule_Hom_struct (Build_prop_po i).
Next Obligation.
Proof.
  rewrite sts_list_subst2.
  auto.
Qed.

(** [Build_prop i] represents the arity [i] *)

Definition Build_prop i := Build_RModule_Hom (Build_prop_s i).

(**  UTSP has a structure as a representation of S *)

Canonical Structure UTSPrepr : Repr S UTSP := Build_prop.

Canonical Structure UTSProp : REP S :=
       Build_Representation (@UTSPrepr).

(** ** Important Lemma, other direction
other direction of Lemma 36
    - also here some code savings possible
    - this is actually not the variant we need: point is,
      we have V (init) = V (init_prop) (cf. later)
    - here is the version with V (init)
*)

Lemma lemma36_2 (l : [nat]) (V : Type)
    (x y : prod_mod_c (fun x : Type => UTS S x) V l)
    (H : forall R : INEQ_REP,
        Rel (PO_obj_struct := prod_mod_po (SC_inj_ob R) V l)
  (Prod_mor_c (init_mon (S:=S) (SC_inj_ob R)) x)
  (Prod_mor_c (init_mon (S:=S) (SC_inj_ob R)) y) ) :
prod_mod_c_rel (M:=prop_rel) x y.

(*
Lemma lemma36_2 (l : [nat]) (V : Type)
    (x y : prod_mod_c (fun x : Type => UTS Sig x) V l)
    (H : forall R : subob (fun P : Representation Sig => satisfies_prop_sig (A:=A) T P),
        Rel (PO_obj_struct := prod_mod_po (SC_inj_ob R) V l)
  (Prod_mor_c (init_mon (Sig:=Sig) (SC_inj_ob R)) x)
  (Prod_mor_c (init_mon (Sig:=Sig) (SC_inj_ob R)) y) ) :
prod_mod_c_rel (M:=prop_rel) x y.
*)

Proof.
  simpl.
  induction l; simpl;
  intros.
  constructor.
  dependent destruction x.
  dependent destruction y.
  simpl.
  constructor.
  simpl.
  Focus 2.
  apply IHl.
  intros.
  assert (h:= H R).
  clear H.
  dependent destruction h.
  apply h.
  unfold prop_rel_c.
  intros.
  assert (h:= H R).
  dependent destruction h.
  apply H0.
Qed.

(** ** A morphism of representations
we produce a morphism of representations from [UTSP_sm] to
     [UTSPREPR]
     - this is in fact the identity morphism
     - just the order becomes bigger
*)
(** we use this morphism to show that an equation is the same on
  [UTSM_sm] (diagonal order) and [UTSP] (order induced by equations)
*)

Program Instance Id_UTSM_UTSPs :
   RMonad_Hom_struct (P:=UTSM S) (Q:=UTSP)
   (fun c => Sm_ind (id (UTS S c))).

Definition Id_UTSM_sm_UTSP := Build_RMonad_Hom Id_UTSM_UTSPs.

Lemma id_UTSM_sm_UTSP l c (x : prod_mod_c (fun x => UTS S x) c l) :
      Prod_mor_c Id_UTSM_sm_UTSP x = x.
Proof.
  induction x; simpl; intros;
  auto; apply CONSTR_eq; auto.
Qed.

Obligation Tactic := unfold commute; simpl; intros;
     repeat (apply f_equal || apply id_UTSM_sm_UTSP || auto).

Program Instance debi2s :
     Representation_Hom_struct (P:=UTSRepr S) (Q:=UTSProp) Id_UTSM_sm_UTSP.

Definition UTSM_sm_UTSP_rep_hom := Build_Representation_Hom debi2s.

Existing Instance UTS_initial.

Lemma half_eq_const_on_carrier : forall c x,
   init_rep UTSProp c x = x.
Proof.
  simpl;
  assert (H:=InitMorUnique (C:=REP S) UTSM_sm_UTSP_rep_hom);
  simpl in H;
  auto.
Qed.

(*

(** this lemma states that half-equations are constant on
    representations whose underlying sets of terms are the same and the
     order gets bigger *)
(** when passing from [UTSM_sm] to [UTSP], the equations remain the same *)

Lemma debi3s a c x:
forall h : half_eq_alg (domS (T a)) (codl (T a)),
    (h (UTSRepr Sig)) c x = (h UTSPROPRepr) c x.
Proof.
  simpl.
  intros.
  destruct h.
  simpl in *.
  destruct half_eq_s0.
  simpl in *.
  assert (H:= comm_eq_s0 _ _ (debi2) c x).
  rewrite debi25 in H.
  rewrite debi25 in H.
  auto.
Qed.

*)

(** [UTSPROPRepr] satisfies (in)equations
the new nice representation [UTSPROPRepr] satisfies the equations of [T], contrary
    to the old one, [UTSRepr] *)

(** ** Weak Initiality
     we will use the weak initial morphism in the proof that
     UTSPROPRepr satisfies the equations

*)

Section weak_init.

Variable R : INEQ_REP.

(** the initial morphism is the same as before
      - we need to show that it is monotone, which is by definition
      - that it is a morphism of monads
      - morphism of representations
      - unicity
*)

Program Instance init_prop_s V : PO_mor_struct
    (a:=(UTSProp) V) (b:=(FINJ _ R) V) (init (FINJ _ R) (V:=V)).
Next Obligation.
Proof.
  unfold Proper, respectful;
  intros.
  simpl in *.
  unfold prop_rel_c in H.
  simpl in H.
  apply H.
Qed.

Definition init_prop_po V := Build_PO_mor (init_prop_s V).

Obligation Tactic := cat; rewrite init_kleisli2;
           app (rkl_eq (proj1_sig R)).

(** monadicity *)

Program Instance init_prop_mon_s : RMonad_Hom_struct
      (P:=UTSProp)(Q:=FINJ _ R) init_prop_po.

Definition init_prop_mon := Build_RMonad_Hom init_prop_mon_s.

(** representativity asks for a lemma, same as for case without equations *)

Lemma prod_mor_eq_init_list2 (i : sig_index S) V
       (x : prod_mod_c (fun V => UTS S V) V (sig i)) :
  Prod_mor_c init_prop_mon x = init_list _ (UTSl_f_pm x).
Proof.
  induction x;
  simpl; auto.
  unfold FINJ in IHx. simpl in *.
  rewrite  IHx.
  simpl. auto.
Qed.

Obligation Tactic := repeat (cat || unfold commute ||
             rewrite prod_mor_eq_init_list2).

Program Instance init_prop_rep : Representation_Hom_struct
       init_prop_mon.

Definition init_prop_re := Build_Representation_Hom init_prop_rep.

End weak_init.

(** ** V (init) = V (init_prop)
*)

Lemma bb2b (R : INEQ_REP) a l (x : prod_mod_c (fun x : Type => UTS S x) a l):
  Prod_mor_c (init_prop_mon R) x = Prod_mor_c (init_mon (SC_inj_ob R)) x.
Proof.
  reflexivity.
Qed.

(** ** Version of lemma36_2 using init_prop
*)

Lemma lemma36_2a (l : [nat]) (V : Type)
    (x y : prod_mod_c (fun x : Type => UTS S x) V l)
    (H : forall R : INEQ_REP,
        Rel (PO_obj_struct := prod_mod_po (SC_inj_ob R) V l)
  (Prod_mor_c (init_prop_mon  (R)) x)
  (Prod_mor_c (init_prop_mon  (R)) y) ) :
prod_mod_c_rel (M:=prop_rel) x y.
Proof.
  simpl; intros.
  apply lemma36_2.
  simpl; intros.
  rewrite <- bb2b.
  rewrite <- bb2b.
  apply H.
Qed.

(** ** [UTSPROPRepr satisfies equations
      - we use  a1(x) < a2(x) in V(Sigma)(X) iff
                  forall R, V(init_R) (a1(x)) < V(init_R) (a2(x))
      - we rewrite V(init_R)(a1(x)) = a1 (U (init_R) x)
      - and for a2 as well
*)

Lemma UTSPRepr_sig_prop : satisfies_ineqs T UTSProp.
Proof.
  unfold satisfies_ineqs, satisfies_ineq.
  simpl; intros.
  apply lemma36_2a.
  intros.
  assert (H4:=comm_eq_s (half_equation_struct := half_eq_l (T a))).
  assert (H5:=H4 _ _ (init_prop_re R)).

  assert (H4':=comm_eq_s (half_equation_struct := half_eq_r (T a))).
  assert (H5':=H4' _ _ (init_prop_re R)).

  clear H4 H4'.
  simpl in *.

  rewrite <- H5.
  rewrite <- H5'.

  destruct R as [R v].
  unfold satisfies_ineqs in v.
  unfold satisfies_ineq in v.
  simpl in *.
  apply v.
Qed.

(*
  simpl in *.
  assert (H6:=H5 c x).
  simpl in *.
  rewrite <- bbb.
  Check Prod_mor_c.
  Check ((eq1 (T a) UTSPROPRepr) c x).
  assert (H:
       Prod_mor_c1
                             (init_prop_mon
                                (exist
                                   (fun a : Representation Sig =>
                                    satisfies_prop_sig (A:=A) T a) x0 v))
                             (((eq1 (T a)) UTSPROPRepr) c x) =
  Prod_mor_c1 (init_mon (Sig:=Sig) x0) (((eq1 (T a)) UTSPROPRepr) c x)).
  simpl. auto.
  rerew  H.
  clear H.
  rewrite <- H6.
  clear H5 H6.

  assert (H1:
       Prod_mor_c1
      (init_prop_mon
         (exist (fun a : Representation Sig => satisfies_prop_sig (A:=A) T a)
            x0 v)) (((eq2 (T a)) UTSPROPRepr) c x) =
        Prod_mor_c1 (init_mon (Sig:=Sig) x0) (((eq2 (T a)) UTSPROPRepr) c x)).
  simpl; auto.
  rerew H1.
  rewrite <- H5'.

  unfold satisfies_prop_sig in v.
  unfold satisfies_eq in v.
  simpl in v.
  apply v.
Qed.
*)

(** ** yielding an object of the subcategory
*)

Definition UTSPROP : INEQ_REP :=
 exist (fun R : Representation S => satisfies_ineqs (*A:=A*) T R) UTSProp
  UTSPRepr_sig_prop.

(** ** Initiality in the subcategory *)

Section init.

Variable R : INEQ_REP.

(** the initial morphism is the same as before
      - we need to show that it is monotone, which is by definition
      - that it is a morphism of monads
      - morphism of representations
      - unicity
*)

(** ** Weak Initial morphism in subcategory
    was already defined *)

Definition init_prop : UTSPROP ---> R := exist _ (init_prop_re R) I.

Section unique.

(** ** Initiality in subcategory *)

Variable f : UTSPROP ---> R.

Existing Instance REP_struct.

(** the proof uses initiality of init in the case without equations
     - unicity is only concerned with data
     - for data, the initial morphisms in the category of reps and in
       the subcategory are the same
*)

Lemma init_prop_unique : f == init_prop.
Proof.
  simpl. intros.
  destruct f.
  simpl in *.
  clear t.
  clear f.
  unfold SC_inj_ob in x1.
  simpl in x1.
  destruct R.
  simpl in *.
  clear R.
  assert (H:= InitMorUnique (Initial := UTS_initial S)
                         (UTSM_sm_UTSP_rep_hom ;; x1)).
  simpl in H.
  auto.
Qed.

(*
Lemma init_prop_unique : f == init_prop.
Proof.
  simpl. intros.
  destruct f.
  simpl in *.
  clear t.
  clear f.
  unfold SC_inj_ob in x1.
  simpl in x1.
  destruct R.
  simpl in *.
  clear R.

  apply (@UTSind Sig
     (fun V v => x1 V v = init x2 v)
     (fun V l v => Prod_mor x1 l V (pm_f_STSl v) = init_list _ v));
  simpl; intros;
  auto.
  rew (rmon_hom_rweta x1).
  rewrite <- (one_way u).
  assert (H':=@repr_hom_s _ _ _ x1 x1).
  unfold commute in H'.
  simpl in H'.
  rewrite <- H'.

  rewrite one_way.
  rewrite H. auto.
  rewrite H0. simpl.
  rewrite H.
  auto.
Qed.
*)

End unique.

End init.

(** ** Initiality verified by Coq *)

Program Instance INITIAL_INEQ_REP : Initial INEQ_REP := {
  Init := UTSPROP ;
  InitMor := init_prop ;
  InitMorUnique := init_prop_unique
}.

End subcat.
End S_Mods_and_Eqs.

(* Print Assumptions INITIAL_INEQ_REP. *)


From iris.proofmode Require Import coq_tactics reduction.
From iris.proofmode Require Import tactics.

From Perennial.goose_lang Require Import notation proofmode typing.
From Perennial.goose_lang.lib Require Import typed_mem.

Import uPred.

Section goose_lang.
Context `{ffi_sem: ffi_semantics} `{!ffi_interp ffi} `{!heapGS Σ}.
Context {ext_ty: ext_types ext}.

Lemma tac_wp_store Δ Δ' Δ'' s E i K l v v' Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ v)%I →
  envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ' = Some Δ'' →
  envs_entails Δ'' (WP fill K (Val $ LitV LitUnit) @ s; E {{ Φ }}) →
  envs_entails Δ (WP fill K (Store (LitV l) (Val v')) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_unseal=> ????.
  rewrite -wp_bind. eapply wand_apply; first by eapply wp_store.
  rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.

End goose_lang.

Tactic Notation "wp_untyped_store" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_untyped_store: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_store _ _ _ _ _ _ K))
      |fail 1 "wp_untyped_store: cannot find 'Store' in" e];
    [tc_solve
    |solve_mapsto ()
    |pm_reflexivity
    |first [wp_seq|wp_finish]]
  | _ => fail "wp_untyped_store: not a 'wp'"
  end.


Require Import compcert.common.Memory.
Require Import compcert.common.Values.
Require Import VST.sepcomp.structured_injections.

Definition full_comp (j1 j2: meminj) :=
  forall b0 b1 delta1, j1 b0 = Some (b1, delta1) -> exists b2 delta2, j2 b1 = Some (b2, delta2).

Definition full_ext (mu1 mu2: SM_Injection) :=
  full_comp (extern_of mu1) (extern_of mu2).


Require Import Bool String List.
Require Import Lib.CommonTactics Lib.ilist Lib.Word.
Require Import Lib.Struct Lib.FMap Lib.StringEq Lib.Indexer.
Require Import Kami.Syntax Kami.Semantics Kami.RefinementFacts Kami.Renaming Kami.Wf.
Require Import Kami.Renaming Kami.Specialize Kami.Inline Kami.InlineFacts Kami.Decomposition.
Require Import Kami.Tactics Kami.Notations.
Require Import Ex.MemTypes Ex.SC Ex.NativeFifo Ex.MemAsync Ex.ProcFetchDecode Ex.ProcFDInl.
Require Import Eqdep ProofIrrelevance.

Set Implicit Arguments.

Section Invariants.
  Variables addrSize iaddrSize instBytes dataBytes rfIdx: nat.

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes)
            (dec: AbsDec addrSize instBytes dataBytes rfIdx).

  Variable (d2eElt: Kind).
  Variable (d2ePack:
              forall ty,
                Expr ty (SyntaxKind (Bit 2)) -> (* opTy *)
                Expr ty (SyntaxKind (Bit rfIdx)) -> (* dst *)
                Expr ty (SyntaxKind (Bit addrSize)) -> (* addr *)
                Expr ty (SyntaxKind (Array Bool dataBytes)) -> (* byteEn *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* val1 *)
                Expr ty (SyntaxKind (Data dataBytes)) -> (* val2 *)
                Expr ty (SyntaxKind (Data instBytes)) -> (* rawInst *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* curPc *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* nextPc *)
                Expr ty (SyntaxKind Bool) -> (* epoch *)
                Expr ty (SyntaxKind d2eElt)).

  Variable (f2dElt: Kind).
  Variable (f2dPack:
              forall ty,
                Expr ty (SyntaxKind (Data instBytes)) -> (* rawInst *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* curPc *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* nextPc *)
                Expr ty (SyntaxKind Bool) -> (* epoch *)
                Expr ty (SyntaxKind f2dElt)).
  Variables
    (f2dRawInst: forall ty, fullType ty (SyntaxKind f2dElt) ->
                            Expr ty (SyntaxKind (Data instBytes)))
    (f2dCurPc: forall ty, fullType ty (SyntaxKind f2dElt) ->
                          Expr ty (SyntaxKind (Pc addrSize)))
    (f2dNextPc: forall ty, fullType ty (SyntaxKind f2dElt) ->
                           Expr ty (SyntaxKind (Pc addrSize)))
    (f2dEpoch: forall ty, fullType ty (SyntaxKind f2dElt) ->
                          Expr ty (SyntaxKind Bool)).

  Hypotheses (Hf2dRawInst: forall rawInst curPc nextPc epoch,
                 evalExpr (f2dRawInst _ (evalExpr (f2dPack rawInst curPc nextPc epoch))) =
                 evalExpr rawInst)
             (Hf2dCurPc: forall rawInst curPc nextPc epoch,
                 evalExpr (f2dCurPc _ (evalExpr (f2dPack rawInst curPc nextPc epoch))) =
                 evalExpr curPc)
             (Hf2dNextPc: forall rawInst curPc nextPc epoch,
                 evalExpr (f2dNextPc _ (evalExpr (f2dPack rawInst curPc nextPc epoch))) =
                 evalExpr nextPc)
             (Hf2dEpoch: forall rawInst curPc nextPc epoch,
                 evalExpr (f2dEpoch _ (evalExpr (f2dPack rawInst curPc nextPc epoch))) =
                 evalExpr epoch).

  Variables (pcInit : ConstT (Pc addrSize)).

  Definition fetchDecodeInl := projT1 (fetchDecodeInl
                                         fetch dec
                                         d2ePack f2dPack f2dRawInst f2dCurPc f2dNextPc f2dEpoch
                                         pcInit).

  Definition fetchDecode_inv_body
             (pcv: fullType type (SyntaxKind (Pc addrSize)))
             (pgmv: fullType type (SyntaxKind (Vector (Data instBytes) iaddrSize)))
             (fepochv: fullType type (SyntaxKind Bool))
             (f2dfullv: fullType type (SyntaxKind Bool))
             (f2deltv: fullType type (SyntaxKind f2dElt)) :=
    f2dfullv = true ->
    let rawInst := evalExpr (f2dRawInst _ f2deltv) in
    (rawInst = pgmv (evalExpr (toIAddr _ (evalExpr (f2dCurPc _ f2deltv)))) /\
     evalExpr (f2dNextPc _ f2deltv) = pcv /\
     evalExpr (f2dEpoch _ f2deltv) = fepochv).

  Record fetchDecode_inv (o: RegsT) : Prop :=
    { pcv : fullType type (SyntaxKind (Pc addrSize));
      Hpcv : M.find "pc"%string o = Some (existT _ _ pcv);
      pinitv : fullType type (SyntaxKind Bool);
      Hpinitv : M.find "pinit"%string o = Some (existT _ _ pinitv);
      pinitRqv : fullType type (SyntaxKind Bool);
      HpinitRqv : M.find "pinitRq"%string o = Some (existT _ _ pinitRqv);
      pinitRqOfsv : fullType type (SyntaxKind (Bit iaddrSize));
      HpinitRqOfsv : M.find "pinitRqOfs"%string o = Some (existT _ _ pinitRqOfsv);
      pinitRsOfsv : fullType type (SyntaxKind (Bit iaddrSize));
      HpinitRsOfsv : M.find "pinitRsOfs"%string o = Some (existT _ _ pinitRsOfsv);

      pgmv : fullType type (SyntaxKind (Vector (Data instBytes) iaddrSize));
      Hpgmv : M.find "pgm"%string o = Some (existT _ _ pgmv);
      fepochv : fullType type (SyntaxKind Bool);
      Hfepochv : M.find "fEpoch"%string o = Some (existT _ _ fepochv);

      f2dfullv : fullType type (SyntaxKind Bool);
      Hf2dfullv : M.find "full.f2d"%string o = Some (existT _ _ f2dfullv);
      f2deltv : fullType type (SyntaxKind f2dElt);
      Hf2deltv : M.find "elt.f2d"%string o = Some (existT _ _ f2deltv);

      Hinv0 : pinitv = false -> f2dfullv = false;
      Hinv1 : fetchDecode_inv_body pcv pgmv fepochv f2dfullv f2deltv
    }.

  #[local] Hint Unfold fetchDecode_inv_body : InvDefs.

  Ltac fetchDecode_inv_old :=
    repeat match goal with
           | [H: fetchDecode_inv _ |- _] => destruct H
           end;
    kinv_red.

  Ltac fetchDecode_inv_new :=
    econstructor; (* let's prove that the invariant holds for the next state *)
    try (findReify; (reflexivity || eassumption); fail);
    kregmap_clear; (* for improving performance *)
    kinv_red; (* unfolding invariant definitions *)
    repeat (* cheaper than "intuition" *)
      (match goal with
       | [ |- _ /\ _ ] => split
       end);
    try eassumption; intros; try reflexivity;
    intuition kinv_simpl; intuition idtac.

  Ltac f2d_abs_tac :=
    try rewrite Hf2dRawInst in *;
    try rewrite Hf2dCurPc in *;
    try rewrite Hf2dNextPc in *;
    try rewrite Hf2dEpoch in *.

  Ltac fetchDecode_inv_tac := fetchDecode_inv_old; fetchDecode_inv_new; f2d_abs_tac.

  Lemma fetchDecode_inv_ok':
    forall init n ll,
      init = initRegs (getRegInits fetchDecodeInl) ->
      Multistep fetchDecodeInl init n ll ->
      fetchDecode_inv n.
  Proof. (* SKIP_PROOF_ON
    induction 2.

    - fetchDecode_inv_old.
      unfold getRegInits, fetchDecodeInl, ProcFDInl.fetchDecodeInl, projT1.
      fetchDecode_inv_new; simpl in *; kinv_simpl.

    - kinvert.
      + mred.
      + mred.
      + kinv_dest_custom fetchDecode_inv_tac.
      + kinv_dest_custom fetchDecode_inv_tac.
      + kinv_dest_custom fetchDecode_inv_tac.
      + kinv_dest_custom fetchDecode_inv_tac.
      + kinv_dest_custom fetchDecode_inv_tac.
      + kinv_dest_custom fetchDecode_inv_tac; kinv_eq.
      + kinv_dest_custom fetchDecode_inv_tac.
      + kinv_dest_custom fetchDecode_inv_tac.
      + kinv_dest_custom fetchDecode_inv_tac.
        END_SKIP_PROOF_ON *) apply cheat.
  Qed.

  Lemma fetchDecode_inv_ok:
    forall o,
      reachable o fetchDecodeInl ->
      fetchDecode_inv o.
  Proof.
    intros; inv H; inv H0.
    eapply fetchDecode_inv_ok'; eauto.
  Qed.

End Invariants.

#[global] Hint Unfold fetchDecode_inv_body : InvDefs.


Require Export FcEtt.tactics.
Require Export FcEtt.ett_inf.

Require Import FcEtt.utils.
Require Import FcEtt.imports.
Require Import FcEtt.notations.

Require Import FcEtt.ett_ind.
Require Import FcEtt.toplevel.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Generalizable All Variables.

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

(* TODO (tactics): integrate *)
Ltac solve_binds :=
  match goal with
    | [ b : binds ?v _ ?G
      , H : forall v' _, binds v' _ ?G -> _ [<=] dom ?G ∧ _ [<=] dom ?G
      |- _ ] =>
      apply H in b; simpl in b; autofwd; (done || fsetdec)
  end.

Import AtomSetImpl.

Lemma in_singleton_subset : forall x (G : context), x `in` dom G -> singleton x [<=] dom G.
Proof.
  unfold Subset.
  intros.
  apply singleton_1 in H0.
  subst.
  done.
Qed.

Hint Unfold AtomSetImpl.Subset.
Hint Resolve binds_In AtomSetImpl.singleton_1 in_singleton_subset.

Theorem rctx_uniq : forall W a R, roleing W a R -> uniq W.
Proof. intros. induction H; eauto. pick fresh x.
       simpl in *. eapply uniq_cons_1. eauto.
       pick fresh c. simpl in *. eapply uniq_cons_1. eauto. Unshelve. exact.
Qed.

Theorem rctx_fv_tm_co : forall W a R, roleing W a R ->
        fv_tm_tm_tm a [<=] dom W /\ fv_co_co_tm a [<=] empty.
Proof. intros. induction H; simpl in *; split; split_hyp; autounfold.
       all: try (intros y h; apply empty_iff in h; contradiction).
       all: try (intros y h; apply union_iff in h; inversion h as [h1 | h2];
            eauto; fail).
       all: try (intros; eapply AtomSetProperties.in_subset;
                   [ eauto | rewrite union_empty_r; auto ]).
       all: try (intros; eapply AtomSetProperties.in_subset;
                   [ eauto | apply AtomSetProperties.union_subset_3;
                      [ auto | apply AtomSetProperties.union_subset_3; auto ]]).
       all: try (intros y h; pick fresh z;
            match goal with
             [ Q : forall _, _ -> _ /\ _  |- _ ] =>
             move: (Q z ltac:(auto)) => h'; split_hyp
            end).
       all: try (apply union_iff in h; inversion h).
       all: try (eapply AtomSetProperties.in_subset; eauto; fail).
       all: try (eapply add_3; [ eauto |
            eapply AtomSetProperties.in_subset; [ eauto |
            erewrite fv_tm_tm_tm_open_tm_wrt_tm_lower; eauto]]; fail).
       all: try (eapply add_3; [ eauto |
            eapply AtomSetProperties.in_subset; [ eauto |
            erewrite fv_co_co_tm_open_tm_wrt_tm_lower; eauto]]; fail).
       all: try (eapply AtomSetProperties.in_subset;
            [ eauto | erewrite fv_tm_tm_tm_open_tm_wrt_co_lower; eauto]; fail).
       all: try (eapply AtomSetProperties.in_subset;
            [ eauto | erewrite fv_co_co_tm_open_tm_wrt_co_lower; eauto]; fail).
       all: repeat (with (In _ (_ ∪ _)) do ltac:(fun h => apply union_iff in h; inv h)).
       all: try by eapply AtomSetProperties.in_subset; eauto.
       all: try by intros; fsetdec.
       - intros.
         with In do ltac:(fun h => apply singleton_iff in h; subst).
         eapply binds_In; eauto.
Qed.

Lemma rctx_fv : forall W a R, roleing W a R -> fv_tm_tm_tm a [<=] dom W.
Proof. intros. eapply rctx_fv_tm_co; eauto.
Qed.

Lemma rctx_fv_co : forall W a R, roleing W a R -> fv_co_co_tm a [<=] empty.
Proof. intros. eapply rctx_fv_tm_co; eauto.
Qed.

Lemma pat_ctx_fv : forall W G D F A p B, PatternContexts W G D F A p B ->
                                       dom W [<=] fv_tm_tm_tm p.
Proof. intros. induction H; simpl; fsetdec.
Qed.

Lemma axiom_body_fv_in_pattern : forall F p b A R Rs,
      binds F (Ax p b A R Rs) toplevel -> fv_tm_tm_tm b [<=] fv_tm_tm_tm p.
Proof.
  intros.
  with binds do applyin toplevel_inversion.
  autofwd.
  with roleing do applyin rctx_fv.
  with PatternContexts do applyin pat_ctx_fv.
  by fsetdec.
Qed.

Lemma axiom_body_fv_co : forall F p b A R Rs,
      binds F (Ax p b A R Rs) toplevel -> fv_co_co_tm b [<=] empty.
Proof.
  intros.
  with binds do applyin toplevel_inversion.
  autofwd.
  by with roleing do applyin rctx_fv_co.
Qed.

Theorem context_fv_mutual :
  (forall G (a : tm) A (H: Typing G a A),
      fv_tm_tm_tm a [<=] dom G /\ fv_co_co_tm a [<=] empty /\
      fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] empty)
  /\
  (forall G phi  (H : PropWff G phi ),
      fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] empty)
  /\
  (forall G D p1 p2  (H : Iso G D p1 p2 ),
      fv_tm_tm_constraint p1 [<=] dom G /\ fv_co_co_constraint p1 [<=] empty /\
      fv_tm_tm_constraint p2 [<=] dom G /\ fv_co_co_constraint p2 [<=] empty)
  /\
  (forall G D A B T R (H : DefEq G D A B T R),
      (fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] empty /\
      fv_tm_tm_tm B [<=] dom G /\ fv_co_co_tm B [<=] empty /\
      fv_tm_tm_tm T [<=] dom G /\ fv_co_co_tm T [<=] empty))

  /\
  (forall G (H : Ctx G),
      (forall x A,
          binds x (Tm A)   G ->
          fv_tm_tm_tm         A   [<=] dom G /\ fv_co_co_tm         A   [<=] empty) /\
      (forall c phi,
          binds c (Co phi) G ->
          fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] empty)).

Proof.
  (* TODO: this needs maintenance *)
  eapply typing_wff_iso_defeq_mutual.
  all: autounfold.

  (* We can't just use `repeat split` because we don't want to split under foralls *)
  all: intros; repeat match goal with |- _ ∧ _ => split end; split_hyp; simpl.
  all: eauto 1.
  (* split all asummptions about unions *)

  (* Do the cases about the context at the end. *)
  all: try (intros x0 A0 BI).
  all: try solve [intros; autofv].
  all: try (match goal with |- _ ∧ _ => split end).

  all: try (intros y h1; inversion BI; [
              match goal with
                [ H5 : (_,_) = (_,_) |- _ ] =>
                inversion H5; subst; clear H5; eauto end|
              match goal with
                [ H5 : List.In (?x0, ?s ?a) ?G,
                  H : forall x A, binds x (?s A) ?G -> _ |- _ ] =>
                destruct (H x0 _ H5); eauto end]).

 (* rest of the cases *)
  all: intros y IN.

  (* more splitting, assumption has a union type *)
  all: try match goal with
    [ H7 : ?y `in` union ?A ?B |- _ ] =>
    apply F.union_iff in H7; destruct H7; eauto end.

  all: try solve [ destruct (H _ _ b); eauto ].

  all: try solve [apply H1; eauto; simpl; auto].
  all: try solve [apply H2; eauto; simpl; auto].
  all: try solve [apply H3; eauto; simpl; auto].
  all: try solve [apply H0; eauto; simpl; auto].

  all: try match goal with
    [ H5 : forall x : atom, (x `in` ?L -> False) -> ( _ /\ _ ) |- _ ] =>
    pick fresh x; destruct (H5 x); eauto; split_hyp
           end.

  all: try match goal with
    [ H4 : ?y `in` fv_tm_tm_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_tm_tm_tm (open_tm_wrt_tm ?B (a_Var_f ?x))
            → a `in` dom (?x ~ ?s ++ ?G) |- _ ] =>
    assert (h0: y `in` dom (x ~ s ++ G)) by
    (eapply H5; eauto;
    eapply fv_tm_tm_tm_open_tm_wrt_tm_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.

  all: try match goal with
    [ H4 : ?y `in` fv_tm_tm_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_tm_tm_tm (open_tm_wrt_co ?B (g_Var_f ?x))
            → a `in` dom (?x ~ ?s ++ ?G) |- _ ] =>
    assert (h0: y `in` dom (x ~ s ++ G)) by
    (eapply H5; eauto;
    eapply fv_tm_tm_tm_open_tm_wrt_co_lower; auto);
    simpl in h0; apply F.add_neq_iff in h0; auto
           end.

  all: try (simpl in *; eapply fv_tm_tm_tm_open_tm_wrt_tm_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).
  all: try (simpl in *; eapply fv_co_co_tm_open_tm_wrt_tm_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).
  all: try (simpl in *; eapply fv_tm_tm_tm_open_tm_wrt_co_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).
  all: try (simpl in *; eapply fv_co_co_tm_open_tm_wrt_co_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).

  all: try (apply H0 in IN; apply notin_empty_1 in IN; contradiction).
  all: try (apply H1 in IN; apply notin_empty_1 in IN; contradiction).

  all: try match goal with
    [ H7 : ?y `in` union ?A ?B |- _ ] =>
    apply F.union_iff in H7; destruct H7; eauto end.

  all: try (simpl in *; match goal with [ H : ?y `in` Metatheory.empty |- _ ] => apply notin_empty_1 in H; done end).

  all: try solve [destruct phi1; simpl in *; eauto].

  all: try solve [ simpl in *; eauto].

  all: try solve [ assert (c = y) by auto; subst; eapply binds_In; eauto ].
  all: try solve [ destruct (H0 _ _ b0); simpl in *; eauto].

  all: try match goal with
    [ H4 : ?y `in` fv_co_co_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_co_co_tm (open_tm_wrt_tm ?B (a_Var_f ?x))
            → a `in` empty |- _ ] =>
    (eapply H5; eauto;
    eapply fv_co_co_tm_open_tm_wrt_tm_lower; auto)
      end.

  all: try match goal with
    [ H4 : ?y `in` fv_co_co_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_co_co_tm (open_tm_wrt_co ?B (g_Var_f ?x))
            → a `in` empty |- _ ] =>
    eapply H5; eauto;
    eapply fv_co_co_tm_open_tm_wrt_co_lower; auto
  end.

Qed.

Definition Typing_context_fv  := first context_fv_mutual.
Definition ProfWff_context_fv := second context_fv_mutual.
Definition Iso_context_fv     := third context_fv_mutual.
Definition DefEq_context_fv   := fourth context_fv_mutual.

Ltac show_fresh :=
  match goal with
  | [H: Typing _ ?T _ |- ?c `notin` _ ?T ] =>
    move: (Typing_context_fv H) => ?; autofwd; auto
  | [H: Typing _ _ ?T |- ?c `notin` _ ?T ] =>
    move: (Typing_context_fv H) => ?; autofwd; auto

  end.