(* Multiple inputs and outputs, blocking reads *)
Require Import Merges.Tactics.
Require Import Merges.Map.

Require Import Merges.List.List.
Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.
Require Import Coq.Logic.FunctionalExtensionality.

Module Base.
Section Machine.
  Variable Label : Set.

  Definition Value := nat.

  Variable StreamV : Set.
  Variable StreamVEqDec : EqDec StreamV.

  Definition Heap := Map StreamV (list Value).
  Definition Pred := Heap -> Prop.

  Let streamUpdate := Map.update StreamV (list Value) StreamVEqDec.

  Inductive StreamTypeT :=
   | Input | Output | Ignore.
  Variable StreamType : StreamV -> StreamTypeT.

  Inductive Block : Type :=
   (* Blocking pull, wait forever until we get something *)
   | BlockPull : StreamV -> Label -> Block
   (* Release the thing we just pulled.
      When two machines are pulling from same thing, this
      signals to other machine that it can now pull if it wants *)
   | BlockRelease : StreamV -> Label -> Block
   (* Push a constant value *)
   | BlockPush : StreamV -> Value -> Label -> Block
   (* Jump to another label without doing anything *)
   | BlockJump   : Label -> Block
   .

  Variable Blocks : Label -> Block.
  Variable LabelPre  : Label -> Pred.

  Inductive EvalB : Heap -> Label
                 -> Heap -> Label -> Prop :=
   | EvalBPullOk l v lok i h
      : Blocks l = BlockPull v lok
     -> StreamType v = Input
     -> EvalB h l
              (streamUpdate v (h v ++ [i]) h) lok

   (* Release does nothing *)
   | EvalBRelease l v l' h
      : Blocks l = BlockRelease v l'
     -> StreamType v = Input
     -> EvalB h l
              h l'

   | EvalBPush l v push l' h
      : Blocks l = BlockPush v push l'
     -> StreamType v = Output
     -> EvalB h l
              (streamUpdate v (h v ++ [push]) h) l'

   | EvalBJump l l' h
      : Blocks l = BlockJump l'
     -> EvalB h l
              h l'

   | EvalBIgnore l v i h
      : StreamType v = Ignore
     -> EvalB h l
              (streamUpdate v (h v ++ [i]) h) l
   .
  Hint Constructors EvalB.

  Variable Init : Label.
  Variable InitPre : LabelPre Init (fun _ => []).

  Inductive EvalBs : Heap -> Label -> Prop :=
   | EvalBs0
      : EvalBs (fun _ => []) Init
   | EvalBs1 l l' h h'
      : EvalBs h l
     -> EvalB  h l h' l'
     -> EvalBs h' l'
   .
  Hint Constructors EvalBs.

  Definition BlocksPreT :=
    forall h h' l l',
    EvalBs h l ->
    LabelPre l h ->
    EvalB  h l h' l' ->
    LabelPre l' h'.

  Hypothesis BlocksPre: BlocksPreT.

  (*
  This is not true, since BlockPull does not require StreamType v = Input,
  but EvalB does.
  I don't think this is a real problem though, it wasn't used in any
  of the earlier proofs.

  Theorem EvalB_Step l h
         : exists l' h'
         , EvalB h  l h' l'.
  *)

  Theorem EvalBs_Hoare l h
   (hEvB : EvalBs h l)
         : LabelPre l h.
  Proof.
   !induction hEvB.
  Qed.
End Machine.

End Base.

Module Program.
 Module B := Base.

 Record Program (Label : Set) (StreamVar : Set) : Type
  := mkProgram
   { Init     : Label
   ; Blocks   : Label -> B.Block Label StreamVar

   ; StreamVarEqDec : EqDec StreamVar
   ; StreamType : StreamVar -> B.StreamTypeT

   ; LabelPre : Label -> B.Pred StreamVar
   ; BlocksPre: B.BlocksPreT StreamVarEqDec StreamType Blocks LabelPre Init
   ; InitPre  : LabelPre Init (fun _ => [])
   }.

  Definition EvalBs (Label : Set) (StreamVar : Set) (P : Program Label StreamVar)
   := B.EvalBs (StreamVarEqDec P) (StreamType P) (Blocks P) (Init P).

End Program.

Module Fuse.
  Module B := Base.
  Module P := Program.

  Parameter SV : Set.
  Parameter L1 : Set.
  Parameter P1 : P.Program L1 SV.

  Parameter L2 : Set.
  Parameter P2 : P.Program L2 SV.

  (* Figure out what the fused StreamType will be *)
  Definition StreamType (s : SV) : B.StreamTypeT :=
  match P.StreamType P1 s, P.StreamType P2 s with
  (* If left ignores, take whatever right does *)
  | B.Ignore, t
  => t
  (* Vice versa *)
  | t, B.Ignore
  => t
  (* If either is an output, it will be an output in the fused *)
  | B.Output, _
  => B.Output
  | _, B.Output
  => B.Output
  (* If both are inputs, end result is an input *)
  | B.Input, B.Input
  => B.Input
  end.

  Inductive State :=
    | FakeValue
    | HaveValue
    | NoValue
    .

  Inductive IsValid :=
    | Valid
    | INVALID
    .

  Inductive L' :=
    | LX (l1 : L1) (l2 : L2) (s1 : SV -> State) (s2 : SV -> State) (v : IsValid).

  Definition stateUpdate := Map.update SV State (P.StreamVarEqDec P1).
  Check stateUpdate.

  Inductive BlockOption :=
    | BlockOk (b : B.Block L' SV)
    | BlockTryOther
    | BlockINVALID
    .

  Definition makeBlock
    (LA : Set)
    (mkLabel : LA -> (SV -> State) -> (SV -> State) -> L')
    (block : B.Block LA SV)
    (sThis sOther : SV -> State)
    (typeThis : SV -> B.StreamTypeT)
    (typeOther : SV -> B.StreamTypeT)
           : BlockOption :=
   match block with
    | B.BlockJump _ l'
    => BlockOk (B.BlockJump _ (mkLabel l' sThis sOther))

    (* Releases are fairly simple, so let's start with them *)
    | B.BlockRelease sv l'
    => match typeThis sv, typeOther sv, sThis sv with
       (* If the other machine ignores this, we can just release as normal *)
       (* We require sThis to be 'NoValue' even though there is something: *)
       (* it doesn't need to be tracked because it's ignored *)
       | B.Input, B.Ignore, NoValue
       => BlockOk (B.BlockRelease sv (mkLabel l' sThis sOther))

       (* Both machines want to pull from this, so let's see.
          This machine must have a value for sv in its state now:
          sThis sv = HaveValue
          But it depends whether the other machine has it
       *)
       | B.Input, B.Input, HaveValue
       => match sOther sv with
          (* If other machine still has one, we only pretend to release *)
          | HaveValue
          | FakeValue
          => BlockOk (B.BlockJump _ (mkLabel l' (stateUpdate sv NoValue sThis) sOther))
          (* Other machine has already pretended to release *)
          | NoValue
          => BlockOk (B.BlockRelease sv (mkLabel l' (stateUpdate sv NoValue sThis) sOther))
          end

       (* The other machine has pushed this, so only pretend release *)
       | B.Input, B.Output, HaveValue
       => BlockOk (B.BlockJump _ (mkLabel l' (stateUpdate sv NoValue sThis) sOther))

       (* Otherwise sThis sv is invalid *)
       | _, _, _
       => BlockINVALID
       end

    (* Pulls are a bit more interesting *)
    | B.BlockPull sv l'
    => match typeThis sv, typeOther sv, sThis sv with
       (* Ignore is easy *)
       | B.Input, B.Ignore, NoValue
       => BlockOk (B.BlockPull sv (mkLabel l' sThis sOther))

       (* Both machines want to pull from this, so let's see. *)
       (* We already have a fake one, ready to go. Just a jump *)
       | B.Input, B.Input, FakeValue
       => BlockOk (B.BlockJump _ (mkLabel l' (stateUpdate sv HaveValue sThis) sOther))
       | B.Input, B.Input, NoValue
       => match sOther sv with
          (* If other machine has one but we don't, that means
             we have already pulled and released, but they haven't released yet.
             They need to run a bit and hopefully release.
           *)
          | HaveValue
          | FakeValue
          => BlockTryOther
          (* Neither machine has it, but we both want it.
             We end up with a real value, and them a fake. *)
          | NoValue
          => BlockOk (B.BlockPull sv (mkLabel l' (stateUpdate sv HaveValue sThis) (stateUpdate sv FakeValue sOther)))
          end

       (* The other machine must push. Have they given us anything yet? *)
       | B.Input, B.Output, NoValue
       => match sThis sv with
          (* Yes. We have a fake value on top, so we can turn it into a real one *)
          | FakeValue
          => BlockOk (B.BlockJump _ (mkLabel l'  (stateUpdate sv HaveValue sThis) sOther))
          (* We can't have a real one yet!!! *)
          | HaveValue
          => BlockINVALID
          (* No, we have to wait. Try to let the other machine run *)
          | NoValue
          => BlockTryOther
          end

       (* Otherwise sThis sv is invalid *)
       | _, _, _
       => BlockINVALID
       end

    (* Pushes are pretty similar *)
    | B.BlockPush sv v l'
    => match typeThis sv, typeOther sv, sThis sv with
       (* Ignore is easy *)
       | B.Output, B.Ignore, NoValue
       => BlockOk (B.BlockPush sv v (mkLabel l' sThis sOther))
       (* Check if the other machine is ready to scoop a new one *)
       | B.Output, B.Input, NoValue
       => match sOther sv with
          (* No. The other machine has a value it hasn't already used *)
          | HaveValue
          | FakeValue
          => BlockTryOther
          (* Other machine is empty and ready to receive *)
          | NoValue
          (*=> BlockOk (B.BlockJump _ (mkLabel l' sThis (stateUpdate sv FakeValue sOther)))*)
          => BlockOk (B.BlockPush sv v (mkLabel l' sThis (stateUpdate sv FakeValue sOther)))
          end
       (* Both programs cannot push to the same output *)
       | _, B.Output, _
       => BlockINVALID
       (* sThis sv is invalid *)
       | _, _, _
       => BlockINVALID
       end
   end.

  Definition Blocks (l : L') : B.Block L' SV :=
   match l with
   | LX l1 l2 s1 s2 v
   => let invalid := B.BlockJump _ (LX l1 l2 s1 s2 INVALID) in
      match v
    , makeBlock (fun l1' s1' s2' => LX l1' l2 s1' s2' Valid) (P.Blocks P1 l1) s1 s2 (P.StreamType P1) (P.StreamType P2)
    , makeBlock (fun l2' s2' s1' => LX l1 l2' s1' s2' Valid) (P.Blocks P2 l2) s2 s1 (P.StreamType P2) (P.StreamType P1)
      with
      | Valid, BlockINVALID, _
      => invalid
      | Valid, _, BlockINVALID
      => invalid
      | Valid, BlockOk block, _
      => block
      | Valid, _, BlockOk block
      => block
      | _, _, _
      => invalid
      end
    end.

  Definition Evalish (LA : Set) (P : P.Program LA SV) (s : SV -> State) (iss : B.Heap SV) (l : LA) : Prop :=
   exists iss',
  (* It turns out the proof is slightly easier if we put the EvalBs first.
     Because the EvalBs is more likely to instantiate the existential *)
    P.EvalBs P iss' l /\
    (forall sv,
     match s sv with
      | FakeValue => exists i, iss sv = iss' sv ++ [i]
      | HaveValue => iss' sv = iss sv
      | NoValue   => iss' sv = iss sv
     end /\
     (P.StreamType P sv = B.Ignore -> s sv = NoValue)
     ).

  Definition LabelPre (l : L') : B.Pred SV :=
   match l with
   | LX l1 l2 s1 s2 INVALID
   => fun _ => True
   | LX l1 l2 s1 s2 Valid
   => fun iss
   => Evalish P1 s1 iss l1
   /\ Evalish P2 s2 iss l2
   end.
  Hint Unfold LabelPre.

  Program Definition r
  := {| P.Blocks := Blocks
      ; P.LabelPre := LabelPre
      ; P.Init := LX (P.Init P1) (P.Init P2) (fun _ => NoValue) (fun _ => NoValue) Valid
      ; P.StreamType := StreamType
      ; P.StreamVarEqDec := P.StreamVarEqDec P1
      |}.

  Next Obligation.
   Ltac doit X := try solve [(!eapply B.EvalBs1); (!eapply X)].

  Ltac destruct_apps FUN :=
  repeat match goal with
  | [ _ : context [ FUN ?a ] |- _ ]
  => let x := fresh "destruct_" FUN in remember (FUN a) as x
     ; destruct x
     ; tryfalse
     ; repeat match goal with
       | [ H : _ = FUN a |- _ ] => gen H
       end
  end;
   intros.

  Ltac matchmaker Heq :=
   match goal with
  | [ Heq : _ = match ?A with | _ => _ end |- _ ]
  => let x    := fresh "scrut_" Heq
  in let Heqx := fresh "Heq_" x
  in remember A as x eqn:Heqx; destruct x; try rewrite <- Heqx in *; tryfalse
   ; try matchmaker Heqx
  end.

   unfolds B.BlocksPreT.
   introv hEvBs hLbl hEvB.
   clear hEvBs.
   destruct l; destruct l'.
   !destruct v0; destruct v; try solve [inverts hEvB; tryfalse].

   simpls; unfolds Evalish; unfolds Blocks; unfolds makeBlock.

  inverts hEvB.
  - (* BlockPull *)
    symmetry in H0.
    symmetry in H; matchmaker H.
    all: inject_all.
    all: !jauto_set
      ; doit B.EvalBPullOk
      ; doit B.EvalBIgnore
      ; try assumption
      .

    all: intros; unfolds stateUpdate; forwards: H0 sv; forwards: H2 sv.
    all: try match goal with
          | [ |- context [match update SV _ _ ?A _ _ ?B with | _ => _ end] ]
          => destruct (P.StreamVarEqDec P1 A B); substs
         end; substs.
    all: jauto_set.
    all: repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.
    all: !intros; jauto.
    all: tryfalse.
    all: !repeat rewrite update_eq_is.
    all: try solve [!repeat rewrite update_ne_is].

    all: try match goal with
          | [ |- context [update SV _ _ ?A _ _ ?B] ]
          => destruct (P.StreamVarEqDec P1 A B); substs
         end; !substs.
    all: !repeat rewrite update_eq_is.
    all: try solve [!repeat rewrite update_ne_is].

    all: !repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.

    all: !try match goal with
          | [ ABC : (?A = ?A) -> _ = _ |- _]
          => !rewrite ABC in *
         end.

    all: !repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.

  - (* BlockRelease *)
    symmetry in H0.
    symmetry in H; matchmaker H.
    all: inject_all.
    all: !jauto_set
      ; doit B.EvalBRelease
      ; try assumption
      .
    all: !intros; jauto_set.

    all: !intros.
    all: unfolds stateUpdate; forwards: H0 sv; forwards: H2 sv.

    all: try match goal with
          | [ |- context [update SV _ _ ?A _ _ ?B] ]
          => destruct (P.StreamVarEqDec P1 A B); substs
         end; !substs.
    all: !repeat rewrite update_eq_is.
    all: try solve [!repeat rewrite update_ne_is].

    all: !jauto_set.
    all: !repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.

  - (* BlockPush *)
    symmetry in H0.
    symmetry in H; matchmaker H.
    all: inject_all.
    all: !jauto_set
      ; doit B.EvalBIgnore
      ; doit B.EvalBPush
      .
    all: !intros; unfolds stateUpdate; forwards: H0 sv; forwards: H2 sv; jauto_set.

    all: try match goal with
          | [ |- context [update SV _ _ ?A _ _ ?B] ]
          => destruct (P.StreamVarEqDec P1 A B); substs
         end; !substs.
    all: !repeat rewrite update_eq_is.
    all: try solve [!repeat rewrite update_ne_is].

    all: !repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.
    all: !try match goal with
          | [ ABC : (?A = ?A) -> _ = _ |- _]
          => !rewrite ABC in *
         end.
    all: !repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.

    all: intros; tryfalse.

  - (* BlockJump *)
    jauto_set_hyps; intros.
    symmetry in H; matchmaker H.
    all: inject_all.
    all: try forwards: H1 s; try forwards: H1 s4; try forwards: H3 s; try forwards: H3 s4.
    all: jauto_set_hyps.
    all: intros.

    all: !repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.
    all: !try match goal with
          | [ ABC : (?A = ?A) -> _ = _ |- _]
          => !rewrite ABC in *
         end.
    all: !repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.

(*

Heq_scrut_Heq_scrut_H0 : P.B.BlockJump SV l = P.Blocks P2 l2
H4 : P.B.Input = B.Ignore -> FakeValue = NoValue
H6 : P.B.Input = B.Ignore -> s2 sv = NoValue
Heq_scrut_Heq_scrut_H : P.B.BlockPull sv l4 = P.Blocks P1 l1
Heq_scrut_Heq_scrut_H1 : P.B.Input = P.StreamType P1 sv
Heq_scrut_Heq_scrut_H2 : P.B.Input = P.StreamType P2 sv
Heq_scrut_Heq_scrut_H3 : FakeValue = s1 sv

*)
    all: !jauto_set.
    all: doit B.EvalBJump.
    all: doit B.EvalBPullOk.
    all: doit B.EvalBIgnore.
    all: doit B.EvalBRelease.
    all: doit B.EvalBPush.

    all: !intros; unfolds stateUpdate; forwards: H1 sv; forwards: H3 sv; jauto_set.
    all: !intros; tryfalse.

    all: !repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.
    all: jauto_set.

    all: try match goal with
          | [ |- context [update SV _ _ ?A _ _ ?B] ]
          => destruct (P.StreamVarEqDec P1 A B); substs
         end; !substs.

    all: !repeat rewrite update_eq_is.
    all: try solve [!repeat rewrite update_ne_is].
    all: tryfalse.
    all: !repeat match goal with
    | [ ABC : _ = _  |- _]
    => rewrite <- ABC in *
    end.

  - (* Ignore! *)
    unfolds StreamType.
    !destruct (P.StreamType P1 v) eqn:StreamType1; destruct (P.StreamType P2 v) eqn:StreamType2; tryfalse.
    jauto_set.
    all: doit B.EvalBIgnore.
    all: intros.
    all: forwards: H0 sv; forwards: H2 sv.
    all: !jauto_set.
    all: destruct (P.StreamVarEqDec P1 v sv); substs.
    all: !repeat rewrite update_eq_is.
    all: try solve [!repeat rewrite update_ne_is].

    all: rewrite StreamType1 in *.
    all: rewrite StreamType2 in *.
    !rewrite H5 in *.
    rewrite H4. reflexivity.

    !rewrite H7 in *.
    rewrite H6. reflexivity.
 Qed.
 Next Obligation.
  unfolds Evalish.
  jauto_set;
  try apply B.EvalBs0;
  !jauto_set.
 Qed.
End Fuse.


From Ltac2 Require Import Ltac2 Control Fresh.
Set Default Proof Mode "Classic".
From iris.proofmode Require Import reduction proofmode.
From iris.proofmode Require Import environments.
From cap_machine Require Import stdpp_extra rules_base map_simpl.

Section denote_domain.
   Variable K: Type.
   Hypothesis HeqdecK: EqDecision K.
   Hypothesis HcountK: Countable K.

   (* if map_simpl is called first, the below will not contain overhead *)
   Fixpoint denote_domain {A : Type} (rm: @rgmap A) (fm: nat -> option K) (mdom : gset K): gset K :=
      match rm with
      | Ins k a rm =>
        match fm k with
        | Some k => {[k]} ∪ denote_domain rm fm mdom
        | None => denote_domain rm fm mdom end
      | Del k rm =>
        match fm k with
        | Some k => denote_domain rm fm mdom ∖ {[k]}
        | None => denote_domain rm fm mdom end
      | Symb => mdom
      end.

   Local Arguments denote {_ _ _ _} _ _ _.
   Lemma denote_domain_correct {A : Type} (rm: @rgmap A) (fm: nat -> option K) (m : gmap K A) (mdom : gset K) : dom m = mdom → dom (denote rm fm m) = denote_domain rm fm mdom.
     intro Hmdom.
     induction rm; cbn [denote denote_domain].
     - case_eq (fm k); intros; set_solver + IHrm.
     - case_eq (fm k); intros; set_solver + IHrm.
     - done.
   Qed.
End denote_domain.

Arguments denote_domain {_ _ _ _} _ _ _.
Arguments denote {_ _ _ _} _ _ _.

Ltac2 get_map_dom0 k a m hdom :=
  let (x', m, fm) := (reify_helper k a m []) in
  let env := make_list fm in
  assert ($hdom := denote_domain_correct $k _ _ $x' (fun n => @list_lookup _ n $env) $m _ ltac:(first [ assumption | set_solver+]) );
  rewrite ?dom_empty_L in $hdom;
  cbn [denote denote_domain list_lookup lookup] in $hdom.

Ltac get_map_dom0 k a m hdom :=
  let f := ltac2:(k a m hdom |- get_map_dom0 (Option.get (Ltac1.to_constr k)) (Option.get (Ltac1.to_constr a)) (Option.get (Ltac1.to_constr m)) (Option.get (Ltac1.to_ident hdom))) in f k a m ident:(hdom).

(* generate a domain hypothesis for a given gmap *)
Tactic Notation "get_map_dom" constr(m) "as" ident(hdom) :=
  match type of m with
  | ?t => match eval compute in t with (* type will not compute for very large maps *)
         | gmap ?K ?A => let hdom' := fresh "hdom" in get_map_dom0 K A m ident:(hdom'); rename hdom' into hdom end end.

(* solving goals with map domains faster than set_solver *)
Tactic Notation "solve_map_dom" :=
  let Hdom := fresh "Hdom" in
  match goal with | |- dom ?m = ?dom => get_map_dom m as Hdom; rewrite Hdom; clear Hdom; set_solver+ end.

(* try to find concrete value in gmap *)
Ltac solve_lookup_some :=
repeat (
    lazymatch goal with
    | |- (<[ ?reg := ?w ]> ?rmap) !! ?reg = Some _ =>
        rewrite lookup_insert; reflexivity
    | |- (<[ ?reg := ?w ]> ?rmap) !! ?reg' = Some _ =>
        rewrite lookup_insert_ne; [ | solve [auto]]
    | |- (delete ?reg ?rmap) !! ?reg' = Some _ =>
        rewrite lookup_delete_ne; [ | solve [auto]]
    | |- _ !! ?reg = Some _ => exact
    end ); fail.

Ltac extract_pointsto_map regs Hmap rname Hrdom Hreg :=
  let rval := fresh "v"rname in
  let Hsome := fresh "Hsome" in
  first [ eassert (regs !! rname = Some _) as Hsome by solve_lookup_some (* Try to reuse existing value, if any *) |
  assert (is_Some (regs !! rname)) as [rval Hsome] by (rewrite -elem_of_dom Hrdom; set_solver +) ];
  let str_destr := constr:(("[" ++ Hreg ++ " " ++ Hmap ++ "]")%string) in
  iDestruct (big_sepM_delete _ _ rname with Hmap) as str_destr; first exact Hsome; clear Hsome.

Ltac iExtract_core m' Hmap rnames Hregs Hrdom :=
  match rnames with
  | nil => idtac
  | ?rname :: ?rtail =>
      match Hregs with
      | nil => idtac
      | ?Hname :: ?Htail =>
          extract_pointsto_map m' Hmap rname Hrdom Hname;
          (* rewrite hrdom with the deleted register `rname` in mind *)
          apply (f_equal (fun x => x ∖ {[rname]})) in Hrdom;
          rewrite -dom_delete_L in Hrdom;
          iExtract_core (delete rname m') Hmap rtail Htail Hrdom
      end
  end.

Ltac iExtract0 Hmap rnames Hregs :=
  lazymatch goal with
    | |- envs_entails ?H _ =>
      lazymatch pm_eval (envs_lookup Hmap H) with
      | Some (_, ?X) =>
        lazymatch X with
        | ([∗ map] _↦_ ∈ ?m', _)%I =>
          let Hrdom := fresh "Hrdom" in
            get_map_dom m' as Hrdom;
            iExtract_core m' Hmap rnames Hregs Hrdom;
            clear Hrdom;
            map_simpl Hmap
        end
      end
    end.

Tactic Notation "iExtract" constr(Hmap) constr(rname) "as" constr(Hreg):=
    iExtract0 Hmap [rname] [Hreg].

Tactic Notation "iExtractList" constr(Hmap) constr(rnames) "as" constr(Hregs):=
    iExtract0 Hmap rnames Hregs.

Ltac insert_pointsto_map regs Hmap rname Hrdom Hreg :=
  let Hsome := fresh "Hsome" in
  assert (regs !! rname = None) as Hsome by (rewrite -not_elem_of_dom Hrdom; set_solver +);
  let str_destr := constr:(("[ $" ++ Hmap ++ " $" ++ Hreg ++ "]")%string) in
  iDestruct (big_sepM_insert _ _ rname with str_destr) as Hmap; first exact Hsome; clear Hsome.

Ltac iInsert_core m' Hmap rnames Hrdom :=
  match rnames with
  | nil => idtac
  | ?rname :: ?rtail =>
      match goal with |- context [ Esnoc _ (INamed ?Hname) ?mtch ] =>
          lazymatch mtch with | context [(rname ↦ᵣ ?rval)%I] =>
            insert_pointsto_map m' Hmap rname Hrdom Hname;
            (* rewrite hrdom with the inserted register `rname` in mind *)
            apply (f_equal (fun x => ({[rname]} ∪ x))) in Hrdom;
            rewrite -(dom_insert_L _ _ rval) in Hrdom;
            iInsert_core (<[rname:=rval]> m') Hmap rtail Hrdom
          end
      end
  end.

Ltac iInsert0 Hmap rnames :=
  lazymatch goal with
    | |- envs_entails ?H _ =>
      lazymatch pm_eval (envs_lookup Hmap H) with
      | Some (_, ?X) =>
        lazymatch X with
        | ([∗ map] _↦_ ∈ ?m', _)%I =>
          let Hrdom := fresh "Hrdom" in
            get_map_dom m' as Hrdom;
            iInsert_core m' Hmap rnames Hrdom;
            clear Hrdom;
            map_simpl Hmap
        end
      end
    end.

Tactic Notation "iInsert" constr(Hmap) constr(rname):=
    iInsert0 Hmap [rname].

Tactic Notation "iInsertList" constr(Hmap) constr(rnames):=
    iInsert0 Hmap rnames.

(* From cap_machine Require Import stdpp_extra rules_base. *)
(* Section test. *)
(*   Context `{memG Σ, regG Σ}. *)

(*   Lemma foo (w1 w2 w3: Word) rmap: *)
(*     dom (gset RegName) rmap = all_registers_s ∖ {[r_t1]}  → *)
(*     ([∗ map] k↦y ∈ (<[r_t3:=w1]> (<[r_t2:=w2]> (<[r_t1:=w3]> rmap))), k ↦ᵣ y) -∗ *)
(*     r_t1 ↦ᵣ w1 ∗ r_t2 ↦ᵣ w2. *)
(*   Proof. *)
(*     iIntros (Hdomm) "Hregm". *)
(*     iExtractList "Hregm" [r_t1;r_t2] as ["Hr_t1";"Hr_t2"]. *)
(*   Abort. *)

(*   Lemma extract_opaque rmap : *)
(*     dom (gset RegName) rmap = all_registers_s ∖ {[PC; r_t0]} → *)
(*     ([∗ map] r↦w ∈ rmap, r ↦ᵣ w) -∗ True. *)
(*   Proof. *)
(*     iIntros (Hdomm) "Hregm". *)
(*     iExtract "Hregm" r_t8 as "Hr_t8" . *)
(*   Abort. *)

(*   Definition r_env : RegName := r_t30. *)
(*   Lemma  foo (w1 w2 : Word) b2 e2 rmap: *)
(*     dom (gset RegName) rmap = all_registers_s ∖ {[PC; r_t0; r_env; r_t1; r_t2]} → *)
(*       ([∗ map] r_i↦w_i ∈ <[r_t2:=WInt 0]> (<[r_t3:=WInt 0]> (<[r_t4:=WInt 0]> (<[r_t5:=WInt 0]> (delete r_t1 (<[r_env:=WCap E b2 e2 b2]> (<[r_t1:=w1]> (<[r_t2:=w2]> (<[r_t6:=w1]> (<[r_t7:=w2]> rmap))))))))), r_i ↦ᵣ w_i) -∗ r_t1 ↦ᵣ w1. *)
(*   Proof. iIntros (Hdom) "Hregs". *)
(*      iExtractList "Hregs" [r_env;r_t2;r_t6;r_t7] as ["Hr_env";"Hr_t2";"Hr_t6";"Hr_t7"]. *)
(*   Abort. *)
(* End test. *)


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* FSet infrastructure from Lambda_JAR paper. *)
(* Brian Milnes 2016 *)

Set Implicit Arguments.
Require Import TLC.LibLN TLC.LibNat.

(** Tactics for equalities between sets *)

Lemma subset_union_2p : forall E1 E2 F1 F2 G : vars,
  E1 \c (F1 \u G) -> E2 \c (F2 \u G) -> (E1 \u E2) \c ((F1 \u F2) \u G).
Proof.
  introv H1 H2. intros x. specializes H1 x. specializes H2 x.
  repeat rewrite in_union in *.
  auto_star.
Qed.

Lemma subset_remove_11 : forall x y : var,
  x <> y -> \{x} \c (\{x} \- \{y}).
Proof.
  introv H. intros z M. rewrite in_singleton in M. subst.
  rewrite in_remove. split. rewrite~ in_singleton. auto.
Qed.

Lemma subset_remove_2p : forall E1 E2 F1 F2 G : vars,
  E1 \c (F1 \- G) -> E2 \c (F2 \- G) -> (E1 \u E2) \c ((F1 \u F2) \- G).
Proof. introv H1 H2. forwards: subset_union_2 H1 H2. rewrite~ union_remove. Qed.

Hint Resolve subset_union_weak_l subset_union_weak_r subset_refl
  subset_union_2 subset_union_2p subset_empty_l
  subset_remove_2p subset_remove_11 : fset.

Ltac fset := first [ auto with fset ].


(** The low-level assember. *)
Require Import Arith.

Set Implicit Arguments.

Module Instr.
  Open Local Scope type.

  Definition lt_type (S : Set) (L : nat -> S -> Type) :=
    {ip : nat & {s : S & L ip s}} -> {ip : nat & {s : S & L ip s}} -> Prop.

  Definition t (S : Set) (L : nat -> S -> Type) (lt : lt_type L) (ip : nat) : Type :=
    forall s, {ip' : nat & {s' : S &
      forall (l : L ip s), {l' : L ip' s' |
        lt (existT _ _ (existT _ _ l')) (existT _ _ (existT _ _ l)) }}}.
End Instr.

Module Program.
  Inductive t (S : Set) (L : nat -> S -> Type) (lt : Instr.lt_type L) (ip0 : nat) :=
  | nil
  | cons (i : Instr.t lt ip0) (p : t lt (Datatypes.S ip0)).

  Fixpoint length (S : Set) (L : nat -> S -> Type) (lt : Instr.lt_type L)
    (ip0 : nat) (p : t lt ip0) : nat :=
    match p with
    | nil _ _ => 0
    | cons _ p => 1 + length p
    end.

  (** Sub-proofs are made transparent to allow reductions. *)
  Fixpoint nth (S : Set) (L : nat -> S -> Type) (lt : Instr.lt_type L)
    (ip0 : nat) (p : t lt ip0) (n : nat) (H : n < length p)
    : Instr.t lt (ip0 + n).
    destruct p as [|i p]; simpl in H.
    - destruct (lt_n_0 _ H).

    - destruct n as [|n].
        assert (Haux : forall a, a + 0 = a).
          induction a; simpl; trivial.
          now rewrite IHa.
        rewrite Haux.
        exact i.

        assert (Haux : forall a b, a + Datatypes.S b = Datatypes.S a + b).
          intros a b; induction a; simpl; trivial.
          simpl; now rewrite IHa.
        rewrite Haux.
        refine (nth _ _ _ _ p _ _).
        now apply lt_S_n.
  Defined.

  Definition eval (S : Set) (L : nat -> S -> Type) (lt : Instr.lt_type L) (Hwf : well_founded lt)
    (p : t lt 0) (ip : nat) (s : S) (l : L ip s)
    : {ip' : nat & {s' : S & ((length p <= ip') * L ip' s') % type}}.
    refine (let aux : {ip' : nat & {s' : S & L ip' s'}} -> _ := _ in
      aux (existT _ _ (existT _ _ l))).
    clear ip s l.
    refine (well_founded_induction_type Hwf _ _).
    intros input eval.
    destruct input as (ip, (s, l)).
    destruct (le_lt_dec (length p) ip) as [Hle | Hlt].
    - (* ip >= length p, the program is terminated. *)
      exact (existT _ _ (existT _ _ (Hle, l))).

    - (* ip < length p, one instruction is executed. *)
      refine (let i := nth p Hlt in _).
      destruct (i s) as (ip', (s', fl)).
      destruct (fl l) as (l', Hl'_lt_l).
      exact (eval (existT _ _ (existT _ _ l')) Hl'_lt_l).
  Defined.

  Module Test.
    Definition S := nat.

    Definition L (ip : nat) (n : S) : Prop :=
      3 <= n.

    Definition size := 2.

    Definition f_lt T (x : {ip : nat & T ip}) : nat :=
      if leb size (projT1 x) then
        0
      else
        (projT1 x) + 1.

    Definition lt : Instr.lt_type L := fun x y =>
      f_lt _ x < f_lt _ y.

    (** Has to be transparent to reduce the well-founded recursion. *)
    Lemma lt_wf : well_founded lt.
      apply well_founded_ltof.
    Defined.

    (** A program where the state is a single natural number, and the logical world
        a proof that it is greater or equal to three. *)
    Definition progr : Program.t lt 0.
      refine (
        cons (fun n => existT _ size (existT _ (n + 1) _)) ( (* n := n + 1 *)
        cons (fun n => existT _ 0 (existT _ 12 _)) ( (* n := 12 *)
        (nil _ _))));
        unfold L, lt, f_lt; intro l;
        [assert (H : 3 <= n + 1) | assert (H : 3 <= 12)]; unfold L; auto with arith;
        exists H; auto.
    Defined.

    Check eq_refl : 13 = projT1 (projT2 (eval lt_wf progr 1 23 (leb_complete 3 23 eq_refl))).
  End Test.
End Program.


(* Check that tactics (here dependent inversion) do not generate
   conversion problems T <= U with sup's of universes in U *)

(* Submitted by David Nowak *)

Inductive list (A:Set) : nat -> Set :=
| nil : list A O
| cons : forall n, A -> list A n -> list A (S n).

Definition f (n:nat) : Type :=
  match n with
  | O => bool
  | _ => unit
  end.

Goal forall A n, list A n -> f n.
intros A n.
dependent inversion n.


Require Import Core.Core Core.Notations Lib.Lib  Lib.DWT.Exec.Der_write_tags
       Lib.BCT.Exec.
From ExtLib.Structures Require Import Monad MonadWriter MonadExc.
From ExtLib.Data Require Import Monads.OptionMonad.

Section Encoder.

(* writes tags, copies ls and outputs the number of encoded bytes *)
Definition primitive_encoder td struct_len buf_size ls : errW1 Z :=
  der_write_tags td struct_len 0 0 0 buf_size >>=
                 fun x => tell ls >>=
                            fun _ => ret (encoded x + struct_len).

End Encoder.

Section Decoder.

Definition primitive_decoder td ctx size sizeofval sizemax ls : option (list byte * Z) :=
    match ls with
    | [] => None
    | _ => '(c, l) <- ber_check_tags_primitive (map Int.repr (map Byte.unsigned ls))
           td ctx size sizeofval sizemax ;;
           if (Zlength ls - c <? l)
           then None
           else let y := skipn (Z.to_nat c) ls in
                Some (y, c + 1)
    end.

End Decoder.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Tactics.
From nbits Require Import NBits.

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

(* ===== bit_blast_lneg ===== *)

Definition bit_blast_lneg g (a : literal) : generator * cnf * literal :=
  let (g', r) := gen g in
  let cs := [:: [:: r; a]; [:: neg_lit r; neg_lit a]] in
  (g', cs, r).

Definition mk_env_lneg E g (a : literal) : env * generator * cnf * literal :=
  let (g', r) := gen g in
  let E' := env_upd E (var_of_lit r) (~~interp_lit E a) in
  let cs := [:: [:: r; a]; [:: neg_lit r; neg_lit a]] in
  (E', g', cs, r).

Lemma bit_blast_lneg_correct :
  forall g (b : bool) E g' (l: literal) cs lr,
    bit_blast_lneg g l = (g', cs, lr) ->
    enc_bit E l b ->
    interp_cnf E (add_prelude cs) ->
    enc_bit E lr (~~b).
Proof.
  move => g b E g' l cs lr. rewrite /bit_blast_lneg.
  case => _ <- <- Henc. rewrite /enc_bit /=.
  rewrite add_prelude_cons !add_prelude_singleton !interp_clause_cons.
  rewrite !interp_lit_neg_lit /=.
  rewrite (eqP Henc). move /andP => [/andP [_ H1] /andP [_ H2]]. move: H1 H2.
  by case: (E g); case: (b).
Qed.

Lemma mk_env_lneg_is_bit_blast_lneg :
  forall E g (l : literal) E' g' cs lr,
    mk_env_lneg E g l = (E', g', cs, lr) ->
    bit_blast_lneg g l = (g', cs, lr).
Proof.
  rewrite /mk_env_lneg /bit_blast_lneg /=; intros; dcase_hyps; subst; reflexivity.
Qed.

Lemma mk_env_lneg_newer_gen :
  forall E g (l : literal) E' g' cs lr,
    mk_env_lneg E g l = (E', g', cs, lr) ->
    (g <=? g')%positive.
Proof.
  move=> E g l E' g' cs lr. case=> _ <- _ _.
  t_auto_newer.
Qed.

Lemma mk_env_lneg_newer_res :
  forall E g (l : literal) E' g' cs lr,
    mk_env_lneg E g l = (E', g', cs, lr) ->
    newer_than_lit g' lr.
Proof.
  move=> E g l E' g' cs lr. case=> _ <- _ <-.
  t_auto_newer.
Qed.

Lemma mk_env_lneg_newer_cnf :
  forall E g (l : literal) E' g' cs lr,
    mk_env_lneg E g l = (E', g', cs, lr) ->
    newer_than_lit g l ->
    newer_than_cnf g' cs.
Proof.
  move=> E g l E' g' cs lr. case=> _ <- <- _ Hnew_l /=.
  split_andb_goal; t_auto_newer.
Qed.

Lemma mk_env_lneg_preserve :
  forall E g (l : literal) E' g' cs lr,
    mk_env_lneg E g l = (E', g', cs, lr) ->
    env_preserve E E' g.
Proof.
  move=> E g l E' g' cs lr. case=> <- _ _ _. t_auto_preserve.
Qed.

Lemma mk_env_lneg_sat :
  forall E g (l : literal) E' g' cs lr,
    mk_env_lneg E g l = (E', g', cs, lr) ->
    newer_than_lit g l ->
    interp_cnf E' cs.
Proof.
  move=> E g l E' g' cs lr. case=> <- _ <- Hlr /= Hnew.
  rewrite !interp_lit_neg_lit. rewrite env_upd_eq.
  rewrite (interp_lit_env_upd_neq _ _ (newer_than_lit_neq Hnew)).
  by case: (interp_lit E l).
Qed.

Lemma mk_env_lneg_env_equal E1 E2 g ls E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_lneg E1 g ls = (E1', g1', cs1, lrs1) ->
  mk_env_lneg E2 g ls = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_lneg=> Heq. dcase (gen g) => [[g' r'] Hg'].
  case=> ? ? ? ?; case=> ? ? ? ?; subst. rewrite !(env_equal_interp_lit _ Heq).
  repeat split. apply: env_equal_upd. assumption.
Qed.


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(* Module with Certified Checking
   of Simple Module.

   Last Update: Tue, 23 May 2017
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..".

Require Import ConceptParams.AuxTactics.LibTactics.
Require Import ConceptParams.AuxTactics.BasicTactics.

Require Import ConceptParams.SetMapLib.List2Set.
Require Import ConceptParams.SetMapLib.ListPair2FMap.

Require Import ConceptParams.GenericModuleLib.SharedDataDefs.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Bool.Bool.

Require Import Coq.Structures.Orders.
Require Import Coq.Structures.Equalities.

(* ***************************************************************** *)
(** * Simple Module *)

(** Simple Module is well-defined if
    all names are different
    and all members are well-defined (independtly of each other). *)
(* ***************************************************************** *)
(* ***************************************************************** *)

(* ################################################################# *)
(** ** Shared Parameters of all building blocks *)
(* ################################################################# *)

Module Type SimpleModuleBase.
  Include ModuleBase.
  Declare Module MD : DataC.
End SimpleModuleBase.

(* ################################################################# *)
(** ** Propositional Part *)
(* ################################################################# *)

Module SimpleModuleDefs (Import MMB : SimpleModuleBase)
       (Import TOkD : DataCOkDef MMB.MD).

  Module HelperD.
    Export MD.
    Definition dt := t.

    (** Aux definition "all members in a list are ok" *)
    Definition members_ok' (c : ctx) (dts : list dt) : Prop :=
      List.Forall (fun elem => is_ok c elem) dts.

    Definition members_ok (c : ctx) (decls : list (id * dt)) :=
        members_ok' c (map snd decls).

    (** We can use generic implementation of module-welldefinedness *)
    Module MGM := GenericModule_ModuleOk MId.

  End HelperD.
  Import HelperD.

  (** Simple Module given as the AST [ds]
   ** is well-defined in the context [c] *)
  Definition module_ok (c : ctx) (decls : list (id * dt)) : Prop :=
    MGM.module_ok dt ctx members_ok c decls.

(*
  (** The finite map [imap] corresponds to the given well-defined
   ** AST [iast] of an interface *)
  Definition intrfs_ast_has_eq_map (c : ctx)
             (iast : intrfs_ast) (imap : intrfs_map) : Prop :=
    (* interface is well-defined *)
    intrfs_ok c iast
    (* map is equal to ast *)
    /\ IdLPM.eq_list_map iast imap.
*)
End SimpleModuleDefs.

(* ################################################################# *)
(** ** Computable Part (static checker of the interpreter) *)
(* ################################################################# *)

Module SimpleModuleInterp (Import MMB : SimpleModuleBase)
       (Import TOkI : DataCOkInterp MMB.MD).

  Module HelperI.
    Export MD.
    Definition dt := t.

    Definition members_ok'_b (c : ctx) (dts : list dt) : bool :=
      List.forallb (fun elem => is_ok_b c elem) dts.

    Definition members_ok_b (c : ctx) (decls : list (id * dt)) :=
      members_ok'_b c (map snd decls).

    (** We can use generic implementation of module-welldefinedness *)
    Module MGM := GenericModule_ModuleOk MId.

  End HelperI.
  Import HelperI.

  (** Checks that an interface given as an AST [ds]
   ** is well-defined in the context [c] *)
  Definition module_ok_b (c : ctx) (decls : list (id * dt)) : bool :=
    MGM.module_ok_b dt ctx members_ok_b c decls.

(*
  (** If an interface with the AST [iast] is well-defined,
   ** converts it to the equal finite map *)
  Definition intrfs_ast_to_eq_map (c : ctx)
             (iast : intrfs_ast) : option intrfs_map :=
    (* if interface is well-defined *)
    if intrfs_ok_b c iast then
      (* generate map from ast *)
      Some (IdLPM.map_from_list iast)
    else None.
*)
End SimpleModuleInterp.

(* ################################################################# *)
(** ** Proofs of Correctness *)
(* ################################################################# *)

Module SimpleModuleProps
       (Import MMB : SimpleModuleBase)
       (Import TOkD : DataCOkDef MMB.MD)
       (Import TOkI : DataCOkInterp MMB.MD)
       (Import TOkP : DataCOkProp MMB.MD TOkD TOkI)
.
  Module Import MMD := SimpleModuleDefs   MMB TOkD.
  Module Import MMI := SimpleModuleInterp MMB TOkI.
  Import MMD.HelperD. Import MMI.HelperI.

  Module Helper.

    Lemma members_ok'_b__sound : forall (c : ctx) (dts : list dt),
      members_ok'_b c dts = true ->
      members_ok' c dts.
    Proof.
      intros c dts. unfold members_ok'_b.
      induction dts as [| tp dts'];
        intros H.
      - (* ts = nil *)
        apply Forall_nil.
      - (* ts = tp :: ts' *)
        simpl in H. rewrite -> andb_true_iff in H.
        inversion H as [Htp Hdts']; clear H.
        apply IHdts' in Hdts'.
        apply TOkP.is_ok_b__sound in Htp.
        apply Forall_cons; auto.
    Qed.

    Lemma members_ok'_b__complete : forall (c : ctx) (ts : list dt),
        members_ok' c ts ->
        members_ok'_b c ts = true.
    Proof.
      intros c ts. unfold members_ok'_b.
      induction ts as [| tp ts' IHts'];
        intros H.
      - (* ts = nil *)
        reflexivity.
      - (* ts = tp :: ts' *)
        inversion H; subst.
        simpl. rewrite -> andb_true_iff. split.
        + apply TOkP.is_ok_b__complete. assumption.
        + apply IHts'. assumption.
    Qed.

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

    (** We can use generic implementation of module-welldefinedness *)
    Module MGM := GenericModule_ModuleOk MId.

    Theorem members_ok_b__sound :
      forall (c : ctx) (decls : list (id * dt)),
        members_ok_b c decls = true ->
        members_ok c decls.
    Proof.
      intros c decls H.
      unfold members_ok_b in H.
      unfold members_ok.
      apply members_ok'_b__sound. assumption.
    Qed.

    Theorem members_ok_b__complete :
      forall (c : ctx) (decls : list (id * dt)),
        members_ok c decls ->
        members_ok_b c decls = true.
    Proof.
      intros c decls H.
      unfold members_ok_b.
      unfold members_ok in H.
      apply members_ok'_b__complete. assumption.
    Qed.

  End Helper.

  Theorem module_ok_b__sound : forall (c : ctx) (decls : list (id * dt)),
      module_ok_b c decls = true ->
      module_ok c decls.
  Proof.
    apply MGM.module_ok_b__sound.
    apply Helper.members_ok_b__sound.
  Qed.

  Theorem module_ok_b__complete : forall (c : ctx) (decls : list (id * dt)),
      module_ok c decls ->
      module_ok_b c decls = true.
  Proof.
    apply MGM.module_ok_b__complete.
    apply Helper.members_ok_b__complete.
  Qed.

(*
  Theorem module_ok__cons : forall (c : ctx) (ds : list (id * ty))
                                   (nm : id) (tp : ty),
      intrfs_ok c ((nm, tp) :: ds) ->
      intrfs_ok c ds.
  Proof.
    intros c ds nm tp H.
    unfold intrfs_ok in *. simpl in *.
    destruct (split ds) as [nms tps] eqn:Heq.
    propositional.
    inversion H0. assumption.
    inversion H1. assumption.
  Qed.

  Theorem intrfs_ok_b__cons : forall (c : ctx) (ds : list (id * ty))
                                   (nm : id) (tp : ty),
      intrfs_ok_b c ((nm, tp) :: ds) = true ->
      intrfs_ok_b c ds = true.
  Proof.
    intros c ds nm tp H.
    unfold intrfs_ok_b in *. simpl in *.
    destruct (split ds) as [nms tps] eqn:Heq.
    apply andb_true_iff. apply andb_true_iff in H.
    propositional.
    apply IdLS.Props.ids_are_unique__cons with (x := nm); assumption.
    apply types_ok_b__complete.
    apply types_ok_b__sound in H1. inversion H1. assumption.
  Qed.
*)

(*
(* ----------------------------------------------------------------- *)
(** *** Helper Props  *)
(* ----------------------------------------------------------------- *)

  Module Helper.

    Lemma intrfs_ast_has_eq_map__iso :
      forall (c : ctx) (Iast : intrfs_ast) (Imap1 Imap2 : intrfs_map),
        intrfs_ast_has_eq_map c Iast Imap1 ->
        intrfs_ast_has_eq_map c Iast Imap2 ->
        IdLPM.IdMap.Equal Imap1 Imap2.
    Proof.
      intros c Iast Imap1 Imap2.
      unfold intrfs_ast_has_eq_map.
      intros [Hok Heq1] [Hok2 Heq2]. clear Hok2.
      apply IdLPM.Props.eq_list_map__same_list__eq_maps with (ps := Iast);
        assumption.
    Qed.

  End Helper.

  Theorem eq__split_fst__map_fst :
    forall {A B : Type} (l : list (prod A B)) (xs : list A) (ys : list B),
      split l = (xs, ys) ->
      map fst l = xs.
  Proof.
    intros A B l. induction l as [| h l' IHl'].
    - (* l = nil *)
      intros xs ys H. simpl in H. inversion H; subst.
      reflexivity.
    - (* l = h :: l' *)
      intros xs ys H. destruct h eqn:eqh.
      simpl in H. destruct (split l'). simpl.
      destruct xs as [| x xs']. destruct ys as [| y ys'].
      + inversion H.
      + inversion H.
      + inversion H; subst. apply f_equal.
        apply IHl' with (ys := l0). reflexivity.
  Qed.

  Theorem intrfs_ast_to_eq_map__sound :
    forall (c : ctx) (iast : intrfs_ast) (imap : intrfs_map),
    intrfs_ast_to_eq_map c iast = Some imap ->
    intrfs_ast_has_eq_map c iast imap.
  Proof.
    intros c ast mp H.
    unfold intrfs_ast_to_eq_map, intrfs_ast_has_eq_map in *.
    destruct (intrfs_ok_b c ast) eqn:Hok;
    [ apply intrfs_ok_b__sound in Hok | idtac ];
    split ; try inversion H.
    - assumption.
    - inversion H. subst.
      apply IdLPM.Props.eq_list_map_from_list.
      unfold intrfs_ok in *.
      destruct (split ast) as [nms tps] eqn:Heq; subst.
      inversion Hok as [Hdup Htypes].
      apply eq__split_fst__map_fst in Heq. subst.
      assumption.
  Qed.

  Theorem intrfs_ast_to_eq_map__complete :
    forall (c : ctx) (iast : intrfs_ast) (imap imap' : intrfs_map),
      intrfs_ast_has_eq_map c iast imap ->
      intrfs_ast_to_eq_map c iast = Some imap' ->
      IdLPM.IdMap.Equal imap imap'.
  Proof.
    intros c ast mp mp' Htype Hcheck.
    apply intrfs_ast_to_eq_map__sound in Hcheck.
    apply Helper.intrfs_ast_has_eq_map__iso with (c := c) (Iast := ast);
      assumption.
  Qed.
*)
End SimpleModuleProps.


Require Export med_mods.
Require Import Rel At ST pos_SO vsSahlq_setup Is_Pos_Rep_Pred.

Lemma pos_rep_pred : forall (alpha : SecOrder) (P : predicate)
                                (cond : SecOrder) (x : FOvariable),
  FO_frame_condition cond = true ->
    pos_SO alpha ->
      pos_SO (replace_pred alpha P x cond).
Proof.
  intros alpha P cond x Hunary Huni.
  intros Q HQ.  apply P_is_pos_rep_pred; auto.
  apply Huni. apply Pred_in_SO_rep_pred in HQ; auto.
Qed.

Lemma FOv_att_P_REL : forall rel P,
  REL rel = true ->
  FOv_att_P rel P = nil.
Proof.
  induction rel; intros P H; try (discriminate). reflexivity.
  simpl in *.
  case_eq (REL rel1); intros H2; rewrite H2 in *. 2 : discriminate.
  simpl in *. rewrite IHrel1. rewrite IHrel2. all : try reflexivity.
  assumption.
Qed.

Lemma FOv_att_P_l_conjSO_rel : forall lP rel atm,
  REL rel = true ->
  FOv_att_P_l (conjSO rel atm) lP =
  FOv_att_P_l atm lP.
Proof.
  induction lP; intros rel atm Hrel. reflexivity.
  simpl. rewrite FOv_att_P_REL.
  rewrite IHlP. reflexivity.
  all : assumption.
Qed.

Lemma pos_SO_rep_pred_l : forall lP n beta,
  pos_SO beta ->
  pos_SO (replace_pred_l beta lP (nlist_list _ (nlist_var n (Var 1)))
      (nlist_list _ (nlist_empty n))).
Proof.
  induction lP; intros n beta Hun.
    simpl. assumption.

    simpl. destruct n. simpl. assumption.
    simpl. apply pos_rep_pred. reflexivity.
    apply IHlP. assumption.
Qed.

Lemma lem1 : forall alpha P,
  ~ Pred_in_SO alpha P ->  FOv_att_P alpha P = nil.
Proof.
  induction alpha; intros P H; unfold Pred_in_SO in *;
    auto; simpl in *; try solve [apply IHalpha; auto].
  + simpl in *. if_then_else_dest_blind; firstorder.
    apply except. firstorder.
  + rewrite IHalpha1; firstorder; apply IHalpha2;
    firstorder.
  + rewrite IHalpha1; firstorder; apply IHalpha2;
    firstorder.
  + rewrite IHalpha1; firstorder; apply IHalpha2;
    firstorder.
Qed.

Lemma lem10 : forall alpha P,
  SOQFree_P alpha P = true ->
  Pred_in_SO alpha P ->
  ~(FOv_att_P alpha P = nil).
Proof.
  induction alpha; intros P Hno H; unfold Pred_in_SO in *;
    simpl in *; try contradiction;
      try solve [ apply IHalpha; auto].
  + destruct H. subst. pred_dec_l_rep. firstorder. contradiction.
  + apply in_app_or in H. unfold andb in *. if_then_else_hyp.
    intros HH; apply app_eq_nil in HH. firstorder.
  + apply in_app_or in H. unfold andb in *. if_then_else_hyp.
    intros HH; apply app_eq_nil in HH. firstorder.
  + apply in_app_or in H. unfold andb in *. if_then_else_hyp.
    intros HH; apply app_eq_nil in HH. firstorder.
  + if_then_else_hyp_dep. destruct H. auto.
    apply IHalpha; auto.
  + if_then_else_hyp_dep. destruct H. auto.
    apply IHalpha; auto.
Qed.

Lemma closed_except_ST : forall phi x,
  closed_except (ST phi x) x.
Proof.
  induction phi; intros x; simpl.
  + destruct p. simpl. FOv_dec_l_rep.
    constructor; simpl; auto. FOv_dec_l_rep.
    intros y Hy.
    rewrite FOvariable_dec_r; auto.
  + firstorder.
  + destruct (IHphi1 x) as [IH1 IH1'].
    destruct (IHphi2 x) as [IH2 IH2'].
    constructor; intros; simpl. rewrite IH1. auto.
    rewrite IH1'; auto.
  + destruct (IHphi1 x) as [IH1 IH1'].
    destruct (IHphi2 x) as [IH2 IH2'].
    constructor; intros; simpl. rewrite IH1. auto.
    rewrite IH1'; auto.
  + destruct (IHphi1 x) as [IH1 IH1'].
    destruct (IHphi2 x) as [IH2 IH2'].
    constructor; intros; simpl. rewrite IH1. auto.
    rewrite IH1'; auto.
  + constructor. simpl. FOv_dec_l_rep. rewrite FOvariable_dec_r. auto.
    pose proof next_FOv_not. auto.
    intros y Hy. simpl.
    destruct (FOvariable_dec y (next_FOv x)). auto.
    rewrite FOvariable_dec_r; auto. firstorder.
  + constructor. simpl. FOv_dec_l_rep. rewrite FOvariable_dec_r. auto.
    pose proof next_FOv_not. auto.
    intros y Hy. simpl.
    destruct (FOvariable_dec y (next_FOv x)). auto.
    rewrite FOvariable_dec_r; auto. firstorder.
Qed.

Lemma FO_frame_condition_list_closed_allFO : forall lx alpha,
  FO_frame_condition (list_closed_allFO alpha lx) =
  FO_frame_condition alpha.
Proof.
  induction lx; intros alpha.
    simpl. reflexivity.

    simpl. destruct a. apply IHlx.
Qed.

Lemma FO_frame_condition_preds_in_rev : forall alpha,
preds_in alpha = nil ->
FO_frame_condition alpha = true.
Proof.
  intros alpha H.
  case_eq (FO_frame_condition alpha); intros H2.
    reflexivity.

    apply FO_frame_condition_preds_in_f in H2.
    rewrite H in H2. simpl in *.
    contradiction (H2 eq_refl).
Qed.

Lemma jj9_gen : forall alpha x P cond,
  FO_frame_condition cond = true ->
  preds_in (replace_pred alpha P x cond) =
  rem_pred (preds_in alpha) P.
Proof.
  induction alpha; intros x P cond Hun;
    try solve [    dest_FOv_blind; auto].

  + simpl. destruct (predicate_dec P p); simpl; auto.
    rewrite preds_in_rep_FOv.
    apply FO_frame_condition_preds_in. auto.
  + dest_FOv_blind; simpl; apply IHalpha; auto.
  + dest_FOv_blind; simpl; apply IHalpha; auto.
  + simpl. apply IHalpha; auto.
  + simpl. rewrite rem_pred_app.
    rewrite IHalpha1; auto. rewrite IHalpha2; auto.
  + simpl. rewrite rem_pred_app.
    rewrite IHalpha1; auto. rewrite IHalpha2; auto.
  + simpl. rewrite rem_pred_app.
    rewrite IHalpha1; auto. rewrite IHalpha2; auto.
  + simpl. destruct (predicate_dec P p); simpl; auto.
    rewrite IHalpha; auto.
  + simpl. destruct (predicate_dec P p); simpl; auto.
    rewrite IHalpha; auto.
Qed.

Lemma please3 : forall l alpha P x cond ,
  FO_frame_condition cond = true ->
  incl (preds_in alpha) l ->
  incl (preds_in (replace_pred alpha P x cond)) (rem_pred l P).
Proof.
  intros l alpha P x cond Hun H1 Q H2.
  destruct (predicate_dec P Q); subst.
  + apply In_preds_in_rep_pred in H2.
    rewrite (FO_frame_condition_preds_in cond) in H2; auto.
    firstorder.
  + apply preds_in_rep_pred_In in H2.
    rewrite (FO_frame_condition_preds_in cond) in H2; auto.
    apply in_rem_pred; auto.  apply H1.
    rewrite app_nil_r in H2. auto.
Qed.

Lemma please4 : forall l alpha P x cond ,
  FO_frame_condition cond = true ->
  incl (preds_in alpha) (cons P l) ->
  incl (preds_in (replace_pred alpha P x cond)) l.
Proof.
  intros l alpha P x cond Hun Hin.
  apply (please3 _ alpha P x cond) in Hin.
  rewrite rem_pred_cons_same in Hin.
  apply (incl_trans _ _ _ _ Hin (incl_rem_pred_l _ _)).
  assumption.
Qed.

Lemma preds_in_rename_FOv : forall alpha x y,
  preds_in (replace_FOv alpha x y) = preds_in alpha.
Proof.
  induction alpha; intros x y;
    try solve [simpl; dest_FOv_dec_blind; simpl; auto];
    try (simpl; rewrite IHalpha1; rewrite IHalpha2; auto);
    (simpl; rewrite IHalpha; auto).
Qed.

Lemma preds_in_strip_exFO : forall alpha n,
  preds_in (strip_exFO alpha n) = preds_in alpha.
Proof.
  induction alpha; intros n; try (destruct n; reflexivity).
  destruct f. simpl. destruct n.  reflexivity.
  apply IHalpha.
Qed.

Lemma preds_in_list_closed_exFO : forall l alpha,
  preds_in (list_closed_exFO alpha l) = preds_in alpha.
Proof.
  induction l; intros alpha.
    simpl. reflexivity.

    simpl. destruct a. apply IHl.
Qed.

Lemma aa22_pre_1_pre : forall cond x z,
  (forall y : FOvariable, var_in_SO cond y -> x = y) ->
  (forall y : FOvariable, var_in_SO (replace_FOv cond x z) y -> z = y).
Proof.
  induction cond; intros x z H y H2; simpl in *;
    try solve [(eapply IHcond; firstorder)].
  + dest_FOv_dec_blind; subst. inversion H2; auto.
    contradiction.  inversion H2. subst. firstorder.
    firstorder.
  + dest_FOv_dec_blind; subst; inversion H2;
    subst; try contradiction; try firstorder.
  + dest_FOv_dec_blind; subst; inversion H2;
    subst; try contradiction; try firstorder.
  + dest_FOv_dec_blind; subst; inversion H2;
      subst; try contradiction; try solve [firstorder].
    eapply IHcond. intros yy HH. apply H. firstorder. auto.
  + dest_FOv_dec_blind; subst; inversion H2;
      subst; try contradiction; try solve [firstorder].
    eapply IHcond. intros yy HH. apply H. firstorder. auto.
  + pose proof (var_in_SO_conjSO cond1 cond2).
    apply var_in_SO_conjSO in H2. destruct H2 as [H3 | H3].
    ++ eapply IHcond1; auto. intros yy HH. apply H.
       apply var_in_SO_conjSO. auto. auto.
    ++ eapply IHcond2; auto. intros yy HH. apply H.
       apply var_in_SO_conjSO. auto. auto.
  + pose proof (var_in_SO_conjSO cond1 cond2).
    apply var_in_SO_conjSO in H2. destruct H2 as [H3 | H3].
    ++ eapply IHcond1; auto. intros yy HH. apply H.
       apply var_in_SO_conjSO. auto. auto.
    ++ eapply IHcond2; auto. intros yy HH. apply H.
       apply var_in_SO_conjSO. auto. auto.
  + pose proof (var_in_SO_conjSO cond1 cond2).
    apply var_in_SO_conjSO in H2. destruct H2 as [H3 | H3].
    ++ eapply IHcond1; auto. intros yy HH. apply H.
       apply var_in_SO_conjSO. auto. auto.
    ++ eapply IHcond2; auto. intros yy HH. apply H.
       apply var_in_SO_conjSO. auto. auto.
Qed.

Lemma aa22_pre_1 : forall cond x z,
  (forall y : FOvariable, x <> y -> ~ var_in_SO cond y) ->
  (forall y : FOvariable, z <> y ->
     ~ var_in_SO (replace_FOv cond x z) y).
Proof.
  intros cond x z H1 y H2 H3.
  apply aa22_pre_1_pre in H3. contradiction.
  clear H3.
  intros yy HH. destruct (FOvariable_dec x yy). auto.
  apply H1 in HH. contradiction. auto.
Qed.

Lemma var_in_SO_rep_FOv : forall cond x y,
  var_in_SO cond x ->  var_in_SO (replace_FOv cond x y) y.
Proof.
  intros cond x y H. unfold var_in_SO in *. rewrite rep__ren_list.
  apply in_rename_FOv_list_2. auto.
Qed.

Lemma aa22_pre : forall cond xn ym,
  var_in_SO cond (Var xn) ->
  (forall y : FOvariable, Var xn <> y -> ~ var_in_SO cond y) ->
(max_FOv (replace_FOv cond (Var xn) (Var ym))) <= ym.
Proof.
  intros cond xn ym Hocc Hnocc.
  pose proof (aa22_pre_1 cond (Var xn) (Var ym) Hnocc) as H.
  apply var_in_SO_rep_FOv with (y := (Var ym)) in Hocc.
  rewrite (aa22_pre_2 _ ym); try assumption. lia.
Qed.

Lemma aa22 : forall beta P x cond,
  var_in_SO cond x ->
  (forall y, ~ x = y -> ~ var_in_SO cond y) ->
  (max_FOv (replace_pred beta P x cond)) <= (max_FOv beta).
Proof.
  induction beta; intros P x cond Hocc Hnocc; auto; simpl in *.
  + destruct (predicate_dec P p); auto. dest_FOv_blind.
    rewrite max_FOv_predSO. simpl. apply aa22_pre; auto.
  + dest_FOv_blind. rewrite max_FOv_allFO. simpl.
    apply PeanoNat.Nat.max_le_compat_l. auto.
  + dest_FOv_blind. rewrite max_FOv_exFO. simpl.
    apply PeanoNat.Nat.max_le_compat_l. auto.
  + apply IHbeta; auto.
  + do 2 rewrite max_FOv_conjSO.
    apply PeanoNat.Nat.max_le_compat. apply IHbeta1; auto.
    apply IHbeta2; auto.
  + do 2 rewrite max_FOv_disjSO.
    apply PeanoNat.Nat.max_le_compat. apply IHbeta1; auto.
    apply IHbeta2; auto.
  + do 2 rewrite max_FOv_implSO.
    apply PeanoNat.Nat.max_le_compat. apply IHbeta1; auto.
    apply IHbeta2; auto.
  + destruct (predicate_dec P p); simpl; apply IHbeta; auto.
  + destruct (predicate_dec P p); simpl; apply IHbeta; auto.
Qed.

Lemma   aa21 : forall lP lx lcond beta,
   var_in_SO_l lcond lx ->
   var_not_in_SO_l lcond lx ->
  (max_FOv (replace_pred_l beta lP lx lcond)) <= (max_FOv beta).
Proof.
  induction lP; intros lx lcond beta Hocc Hnocc. firstorder.
  destruct lx. firstorder.
  destruct lcond.  firstorder.
  simpl in *. inversion Hocc. subst. inversion Hnocc. subst.
  apply (PeanoNat.Nat.le_trans _ (max_FOv (replace_pred_l beta lP lx lcond))).
  apply aa22; auto.   apply IHlP; auto.
Qed.

Lemma aa25 : forall n,
  var_in_SO_l (nlist_list n (nlist_empty _))
                   (nlist_list n (nlist_var _ (Var 1))).
Proof. induction n; simpl; constructor; firstorder. Qed.

Lemma aa26 : forall n,
  var_not_in_SO_l (nlist_list n (nlist_empty _ ))
                    (nlist_list n (nlist_var _ (Var 1))).
Proof. induction n; simpl; constructor; firstorder. Qed.

Lemma rep_pred_l_list_closed_allFO : forall l lP lx lcond alpha,
  replace_pred_l (list_closed_allFO alpha l) lP lx lcond =
  list_closed_allFO (replace_pred_l alpha lP lx lcond) l.
Proof.
  induction l; intros lP lx lcond alpha.
    simpl. reflexivity.

    simpl. rewrite <- IHl. rewrite rep_pred_l_allFO.
    reflexivity.
Qed.

Lemma calc_cons_SO_ST : forall phi x,
  calc_cons_SO (ST phi x) = ST (calc_cons_modal phi) x.
Proof.
  induction phi; intros [xn]; try reflexivity.
    destruct p as [Pn]; reflexivity.
Qed.

Lemma calc_ante_SO_ST : forall phi x,
  calc_ante_SO (ST phi x) = ST (calc_ante_modal phi) x.
Proof.
  induction phi; intros [xn]; try reflexivity.
    destruct p as [Pn]; reflexivity.
Qed.
Lemma SOQFree_rel : forall rel,
  REL rel = true ->
  SOQFree rel = true.
Proof.
  induction rel; intros H;
    try (simpl in *; discriminate).
    destruct f; destruct f0;
      reflexivity.

    simpl.
    pose proof (REL_conjSO_l _ _ H) as H2.
    apply REL_conjSO_r in H.
    rewrite IHrel1.
    apply IHrel2.
    all : assumption.
Qed.

Lemma SOQFree_atm : forall atm,
  AT atm = true ->
  SOQFree atm = true.
Proof.
  induction atm; intros H;
    try (simpl in *; discriminate).
    destruct f; destruct p;
      reflexivity.

    simpl.
    pose proof (AT_conjSO_l _ _ H) as H2.
    apply AT_conjSO_r in H.
    rewrite IHatm1.
    apply IHatm2.
    all : assumption.
Qed.

Lemma SOQFree_calc_cons_SO_ST : forall phi x,
  vsSahlq phi ->
SOQFree (calc_cons_SO (ST phi x)) = true.
Proof.
  intros phi x Hvs.
  destruct (vsSahlq_dest_ex phi Hvs) as [phi1 [phi2 [Heq [Hvs1 Hun]]]].
  rewrite Heq.
  simpl.
  apply SOQFree_ST.
Qed.

Lemma SOQFree_vsS_pp_3_ra : forall phi rel atm x,
  REL rel = true ->
  AT atm = true ->
  vsSahlq phi ->
SOQFree (implSO (conjSO rel atm) (calc_cons_SO (ST phi x))) = true.
Proof.
  intros phi rel atm [xn] HREL HAT Hvs.
  simpl.
  rewrite SOQFree_rel.
  rewrite SOQFree_atm.
  apply SOQFree_calc_cons_SO_ST.
  all : assumption.
Qed.

Lemma SOQFree_vsS_pp_3_r : forall phi rel x,
  REL rel = true ->
  vsSahlq phi ->
SOQFree (implSO rel (calc_cons_SO (ST phi x))) = true.
Proof.
  intros phi rel [xn] HREL Hvs.
  simpl.
  rewrite SOQFree_rel.
  apply SOQFree_calc_cons_SO_ST.
  all :assumption.
Qed.

Lemma SOQFree_vsS_pp_3_a : forall phi atm x,
  AT atm = true ->
  vsSahlq phi ->
SOQFree (implSO atm (calc_cons_SO (ST phi x))) = true.
Proof.
  intros phi atm [xn] HAT Hvs.
  simpl.
  rewrite SOQFree_atm.
  apply SOQFree_calc_cons_SO_ST.
  all :assumption.
Qed.

Lemma pos_SO_calc_cons_SO: forall phi x,
  vsSahlq phi ->
  pos_SO (calc_cons_SO (ST phi x)).
Proof.
  intros phi x Hvs.
  destruct (vsSahlq_dest_ex phi Hvs) as [phi1 [phi2 [Heq [Hvs1 Hun]]]].
  rewrite Heq.
  simpl. apply pos__SO.
  assumption.
Qed.

Lemma list_closed_SO_app : forall l1 l2 alpha,
  list_closed_SO alpha (app l1 l2) =
  list_closed_SO (list_closed_SO alpha l2) l1.
Proof.
  induction l1; intros l2 alpha.
    reflexivity.

    destruct a as [Pn].
    simpl.
    rewrite IHl1.
    reflexivity.
Qed.
Lemma preds_in_list_closed_allFO : forall l alpha,
  preds_in (list_closed_allFO alpha l) = preds_in alpha.
Proof.
  induction l; intros alpha.
    reflexivity.

    simpl.
    apply IHl.
Qed.

Lemma att_allFO_var_ST_gen : forall phi n m,
  n <= m ->
  ~ att_allFO_var (ST phi (Var m)) (Var n).
Proof.
  induction phi; intros n m H1 H2; simpl in *;
    try solve [inversion H2; subst; firstorder].
  + destruct p. inversion H2.
  + inversion H2; subst; try lia;
    inversion H4; subst. lia. inversion H5.
    apply IHphi in H5; auto. lia.
  + inversion H2; subst; try lia.
    inversion H4; subst. inversion H5.
    apply IHphi in H5; auto. lia.
Qed.

Lemma att_allFO_var_ST : forall phi x,
  ~ att_allFO_var (ST phi x) x.
Proof. intros phi [xn]. apply att_allFO_var_ST_gen. lia. Qed.

Lemma att_exFO_var_ST_gen : forall phi n m,
  n <= m ->
  ~ att_exFO_var (ST phi (Var m)) (Var n).
Proof.
  induction phi; intros n m H1 H2; simpl in *;
    try solve [inversion H2; subst; firstorder].
  + destruct p. inversion H2.
  + inversion H2; subst; try lia;
    inversion H4; subst. inversion H5.
    apply IHphi in H5; auto. lia.
  + inversion H2; subst; try lia.
    inversion H4; subst. lia.
    inversion H4; subst. inversion H5.
    apply IHphi in H5; auto. lia.
Qed.

Lemma att_exFO_var_ST : forall phi x,
  ~ att_exFO_var (ST phi x) x.
Proof. intros phi [xn]. apply att_exFO_var_ST_gen. lia. Qed.

Lemma preds_in_replace_FOv_max_conj : forall alpha beta x,
  preds_in (replace_FOv_max_conj alpha beta x) =
  preds_in alpha.
Proof.
  unfold replace_FOv_max_conj.
  intros. rewrite preds_in_rename_FOv.
  reflexivity.
Qed.

Lemma rep_pred_l_list_rel_compl : forall l2 alpha,
  replace_pred_l alpha (list_rel_compl l2 (preds_in alpha))
    (nlist_list _ (nlist_var (length (list_rel_compl l2 (preds_in alpha))) (Var 1)))
    (nlist_list _ (nlist_empty (length (list_rel_compl l2 (preds_in alpha))))) =
  alpha.
Proof.
  induction l2; intros alpha. auto.
  simpl. destruct (in_predicate_dec a (preds_in alpha)) as [H1 | H1].
  apply IHl2. simpl.  rewrite IHl2. rewrite rep_pred_not_in; auto.
Qed.

Lemma closed_except_inst_cons_empty' : forall beta alpha x,
  closed_except beta x ->
  closed_except (instant_cons_empty' alpha beta) x.
Proof.
  unfold instant_cons_empty'.
  intros. apply kk11. assumption.
Qed.

Lemma list_rel_compl_nlist_P_cons : forall n P,
  list_rel_compl  (nlist_list n (nlist_P _ P)) (cons P nil) = nil.
Proof.
  induction n; intros P.  reflexivity.
  simpl. destruct (in_predicate_dec P (P :: nil)); auto.
  firstorder.
Qed.

Lemma list_rel_compl_P : forall n1 n2 P,
  list_rel_compl (nlist_list (S n2) (nlist_P _ P)) (nlist_list (S n1) (nlist_P _ P)) = nil.
Proof.
  intros n1 n2. revert n1.
  induction n2; intros n1 P. simpl.
  destruct (in_predicate_dec P (P :: nlist_list n1 (nlist_P n1 P))); firstorder.
  simpl in *. specialize (IHn2 n1 P).
  destruct (in_predicate_dec P (P :: nlist_list n1 (nlist_P n1 P))).
  apply IHn2. firstorder.
Qed.

Lemma instant_cons_empty_implSO : forall alpha beta,
  instant_cons_empty (implSO alpha beta) =
    implSO alpha
  (replace_pred_l beta (list_rel_compl (preds_in beta) (preds_in alpha))
     (nlist_list _
        (nlist_var (length (list_rel_compl  (preds_in beta) (preds_in alpha))) (Var 1)))
     (nlist_list _
        (nlist_empty (length (list_rel_compl  (preds_in beta) (preds_in alpha)))))).
Proof.
  intros alpha beta. unfold instant_cons_empty. simpl.
  rewrite rep_pred_l_implSO. rewrite rep_pred_l_list_rel_compl. auto.
Qed.

Lemma instant_cons_empty_nil : forall alpha beta,
  preds_in alpha = nil ->
  preds_in beta = nil ->
  instant_cons_empty (implSO alpha beta) = implSO alpha beta.
Proof.
  intros alpha beta H1 H2. unfold instant_cons_empty.
  simpl.  rewrite H1.  rewrite H2. auto.
Qed.

Lemma list_rel_compl_is_in_t : forall l1 l2 P,
  In P l1 ->
  list_rel_compl (cons P l2) l1 = list_rel_compl l2 l1.
Proof.
  induction l1; intros l2 P Hin. firstorder.
  simpl in *. destruct Hin. subst.
  pose proof (@in_predicate_dec_l (list predicate) P (P :: l1)).
  rewrite H. firstorder. firstorder.
  destruct (in_predicate_dec P (a :: l1)) as [H1 | H1]. firstorder.
  simpl in H1. apply not_or_and in H1.
  destruct H1. contradiction.
Qed.

Lemma incl_rep_pred_allSO : forall alpha P x cond Q,
  (forall (P : predicate) (x : FOvariable) (cond : SecOrder),
          FO_frame_condition cond = true ->
          incl (preds_in (replace_pred alpha P x cond)) (preds_in alpha)) ->
  FO_frame_condition cond = true ->
  incl (preds_in (replace_pred (allSO Q alpha) P x cond))
  (preds_in (allSO Q alpha)).
Proof.
  intros alpha P x cond Q IHalpha Hun.
    simpl. destruct (predicate_dec P Q). subst.
    simpl. apply incl_rcons. auto.
    simpl. apply incl_cons. firstorder.
    apply incl_rcons. auto.
Qed.

Lemma incl_rep_pred_exSO : forall alpha P x cond Q,
  (forall (P : predicate) (x : FOvariable) (cond : SecOrder),
          FO_frame_condition cond = true ->
          incl (preds_in (replace_pred alpha P x cond)) (preds_in alpha)) ->
  FO_frame_condition cond = true ->
incl (preds_in (replace_pred (exSO Q alpha) P x cond))
  (preds_in (exSO Q alpha)).
Proof.
  intros alpha P x cond Q IHalpha Hun.
    simpl. destruct (predicate_dec P Q). subst.
    simpl. apply incl_rcons. auto.
    simpl. apply incl_cons. firstorder.
    apply incl_rcons. auto.
Qed.

Lemma incl_rep_pred : forall alpha P x cond,
  FO_frame_condition cond = true ->
  incl (preds_in (replace_pred alpha P x cond))
               (preds_in alpha).
Proof.
  induction alpha; intros P x cond Hun; auto;
    try solve [firstorder];
    try (    simpl; apply incl_app_gen; auto).

    simpl. destruct (predicate_dec P p). subst.
    rewrite preds_in_rep_FOv. apply FO_frame_condition_preds_in in Hun.
    rewrite Hun. firstorder.
    simpl. apply incl_refl.

    apply incl_rep_pred_allSO; auto.
    apply incl_rep_pred_exSO; auto.
Qed.

Lemma incl_rep_pred_l : forall lP lv lcond alpha,
  FO_frame_condition_l lcond = true ->
  incl (preds_in (replace_pred_l alpha lP lv lcond))
               (preds_in alpha).
Proof.
  induction lP; intros lv lcond alpha Hun. apply incl_refl.
  simpl. destruct lv. apply incl_refl.
  destruct lcond. apply incl_refl.
  simpl in Hun. case_eq (FO_frame_condition s); intros Hun1;
    rewrite Hun1 in *.
    pose proof (incl_rep_pred (replace_pred_l alpha lP lv lcond)
                                    a f s Hun1) as H.
    specialize (IHlP lv lcond alpha Hun).
    apply incl_trans with (l2 := (preds_in (replace_pred_l alpha lP lv lcond)));
          assumption. discriminate.
Qed.

Lemma vsSahlq_pp_Lemma4 : forall alpha beta,
  incl (preds_in (instant_cons_empty (implSO alpha beta)))
               (preds_in (implSO alpha beta)).
Proof.
  intros alpha beta.
  unfold instant_cons_empty.  simpl.
  apply incl_rep_pred_l.
  apply FO_frame_condition_l_empty_n.
Qed.

Lemma max_FOv_l_ren_FOv_list : forall l x ym,
    In x l ->
    max_FOv_l (rename_FOv_list l x (Var ym)) <= Init.Nat.max (max_FOv_l l) ym.
Proof.
  induction l; intros [xn] ym H. simpl. firstorder.
  destruct a as [zn]. simpl in H.
  rewrite rename_FOv_list_cons. destruct H.
  rewrite FOvariable_dec_l; auto. simpl.
  destruct (in_dec FOvariable_dec (Var xn) l).
  specialize (IHl _ ym i). lia.
  rewrite rename_FOv_list_not_in.  lia. auto.
  destruct (FOvariable_dec (Var xn) (Var zn)) as [H1 | H1].
  inversion H1. subst. simpl. apply IHl with (ym := ym) in H.
  firstorder. lia. simpl.  apply IHl with (ym := ym) in H. lia.
Qed.

Lemma max_FOv_rep_FOv2 : forall alpha x ym,
  var_in_SO alpha x ->
 (max_FOv (replace_FOv alpha x (Var ym))) <= (max (max_FOv alpha) ym).
Proof.
  intros alpha x ym H. unfold max_FOv.
  rewrite rep__ren_list.
  apply max_FOv_l_ren_FOv_list. firstorder.
Qed.

Lemma le_max_FOv_replace_FOv : forall alpha x n,
  (max_FOv (replace_FOv alpha x (Var n))) <=
          (max (max_FOv alpha) n) .
Proof.
  intros alpha x n. unfold max_FOv.
  rewrite rep__ren_list.
  destruct (in_dec FOvariable_dec x (FOvars_in alpha)).
  apply max_FOv_l_ren_FOv_list.  auto.
  rewrite rename_FOv_list_not_in; auto. lia.
Qed.

Lemma list_rel_compl_rem_pred : forall l2 l P,
  list_rel_compl l2 (cons P l) =
  rem_pred (list_rel_compl l2 l) P.
Proof.
  induction l2; intros l P. auto.
  simpl. destruct (in_predicate_dec a (P :: l)) as [H | H].
  simpl in H. destruct H. subst.
  destruct (in_predicate_dec a l). apply IHl2.
  simpl. rewrite predicate_dec_l. apply IHl2. auto.
  rewrite in_predicate_dec_l. apply IHl2. auto.
  simpl in H. apply not_or_and in H. rewrite in_predicate_dec_r.
  simpl. rewrite predicate_dec_r. rewrite IHl2. auto.
  all : firstorder.
Qed.

Lemma jj9 : forall alpha x y z P,
  preds_in (replace_pred alpha P x (negSO (eqFO y z))) =
  rem_pred (preds_in alpha) P.
Proof.
  induction alpha; intros x y z P; simpl; auto;
  try (  rewrite IHalpha1; rewrite IHalpha2; rewrite rem_pred_app; auto).
  + dest_FOv_dec_blind; destruct (predicate_dec P p); auto.
  + destruct (predicate_dec P p); simpl; rewrite IHalpha; auto.
  + destruct (predicate_dec P p); simpl; rewrite IHalpha; auto.
Qed.

Lemma  jj10 : forall l2 l1,
  incl (list_rel_compl  l2 l1) l2.
Proof.
  induction l2; intros l1; simpl. firstorder.
  destruct (in_predicate_dec a l1).
  apply incl_rcons. auto.
  apply incl_cons_cons. auto.
Qed.

Lemma jj12 : forall l1 l2 P,
  In P l1 ->
  ~ In P (list_rel_compl l2 l1) .
Proof.
  induction l1; intros l2 P H; auto.
  simpl in *. destruct H; subst.
  + rewrite list_rel_compl_rem_pred.
    apply is_in_pred_rem_pred_eq.
  + intros H2. rewrite list_rel_compl_rem_pred in H2.
    apply IHl1 with (l2 := l2) in H.
    destruct (predicate_dec P a). subst.
    apply is_in_pred_rem_pred_eq in H2. auto.
    apply jj13 in H2. contradiction.  auto.
Qed.

Lemma jj11 : forall l2 l1,
  list_rel_compl l2 (list_rel_compl l2 l1) = cap_pred l2 l1.
Proof.
  induction l2; intros l1. auto.
  simpl. destruct (in_predicate_dec a l1) as [H2 | H2].
  +  rewrite IHl2. destruct (in_dec predicate_dec a l1).
     apply jj12 with (l2 := l2) in H2.
     rewrite in_predicate_dec_r; auto.
     contradiction.
  +  rewrite list_rel_compl_rem_pred. rewrite IHl2.
     rewrite in_predicate_dec_l. destruct (in_dec predicate_dec a l1).
     firstorder. apply rem_pred_not_in. apply in_cap_pred. auto.
     firstorder.
Qed.

Lemma sumtin : forall l2 lb l beta,
  incl (preds_in beta) lb ->
  cap_pred_empty l2 (preds_in (replace_pred_l beta (list_rel_compl lb l)
      (nlist_list _ (nlist_var (length (list_rel_compl lb l)) (Var 1)))
      (nlist_list _ (nlist_empty (length (list_rel_compl lb l)))))) = true ->
  replace_pred_l
    (replace_pred_l beta (list_rel_compl lb l)
      (nlist_list _ (nlist_var (length (list_rel_compl lb l)) (Var 1)))
      (nlist_list _ (nlist_empty (length (list_rel_compl lb l)))))
    l2
    (nlist_list (length l2) (nlist_var (length l2) (Var 1)))
    (nlist_list (length l2) (nlist_empty (length l2))) =
    (replace_pred_l beta (list_rel_compl lb l)
      (nlist_list _ (nlist_var (length (list_rel_compl lb l)) (Var 1)))
      (nlist_list _ (nlist_empty (length (list_rel_compl lb l))))).
Proof.
  induction l2; intros lb l beta H1 H2. auto.
  simpl in *. destruct (in_dec predicate_dec a
           (preds_in
              (replace_pred_l beta (list_rel_compl lb l)
                 (nlist_list (length (list_rel_compl lb l))
                    (nlist_var (length (list_rel_compl lb l)) (Var 1)))
                 (nlist_list (length (list_rel_compl lb l))
                    (nlist_empty (length (list_rel_compl lb l))))))).
    rewrite in_predicate_dec_l in H2. discriminate. auto.
  rewrite in_predicate_dec_r in H2; auto.
  rewrite IHl2; try assumption.  rewrite rep_pred_not_in.
  all : auto.
Qed.

Lemma jj8 : forall l beta,
  incl l (preds_in beta) ->
  preds_in (replace_pred_l beta l
      (nlist_list _ (nlist_var (length l) (Var 1)))
      (nlist_list _ (nlist_empty (length l)))) =
  list_rel_compl (preds_in beta) l.
Proof.
  induction l; intros beta H; simpl in *.
    rewrite list_rel_compl_nil. auto.
  pose proof (incl_lcons _ _ _ _ H).
  rewrite list_rel_compl_rem_pred. rewrite jj9.
  rewrite IHl; auto.
Qed.

Lemma jj7 : forall l beta P,
  ~ In P l ->
  ~ In P (preds_in (replace_pred_l beta
      (list_rel_compl (preds_in beta) l)
          (nlist_list (length (list_rel_compl (preds_in beta) l))
             (nlist_var (length (list_rel_compl (preds_in beta) l)) (Var 1)))
          (nlist_list (length (list_rel_compl (preds_in beta) l))
             (nlist_empty (length (list_rel_compl (preds_in beta) l)))))).
Proof.
  induction l; intros beta P H H2.
  + rewrite list_rel_compl_nil in H2.
    rewrite FO_frame_condition_preds_in in H2. assumption.
    apply FO_frame_condition_rep_pred_l.
    apply FO_frame_condition_l_empty_n.
  + simpl in *. rewrite jj8 in H2.
    rewrite jj11 in H2. rewrite cap_pred_comm in H2. simpl in H2.
    destruct (in_predicate_dec a (preds_in beta)).
    ++ simpl in *. destruct H2 as [H2 | H2]. firstorder.
       apply in_pred_cap_pred_f1 in H2; auto.
    ++ apply in_pred_cap_pred_f1 in H2; auto.
    ++ apply jj10.
Qed.

Lemma jj6 : forall lb1 la beta2,
cap_pred_empty (list_rel_compl lb1 la)
  (preds_in
     (replace_pred_l beta2 (list_rel_compl (preds_in beta2) la)
        (nlist_list (length (list_rel_compl (preds_in beta2) la))
           (nlist_var (length (list_rel_compl (preds_in beta2) la)) (Var 1)))
        (nlist_list (length (list_rel_compl (preds_in beta2) la))
           (nlist_empty (length (list_rel_compl (preds_in beta2) la)))))) =
true.
Proof.
  induction lb1; intros la beta2. auto.
  simpl. destruct (in_predicate_dec a la). apply IHlb1.
  simpl. rewrite IHlb1. rewrite in_predicate_dec_r. auto.
  apply jj7. auto.
Qed.

Lemma instant_cons_empty'_conjSO : forall alpha beta1 beta2,
  instant_cons_empty' alpha (conjSO beta1 beta2) =
  conjSO (instant_cons_empty' alpha beta1) (instant_cons_empty' alpha beta2).
Proof.
  intros. unfold instant_cons_empty'.
  rewrite rep_pred_l_conjSO. simpl.
  rewrite list_rel_compl_app.
  do 2 rewrite rep_pred_l_app.
  rewrite rep_pred_l_switch.
  rewrite sumtin.
  rewrite sumtin. reflexivity.
  apply incl_refl.
  apply jj6. apply incl_refl.
  apply jj6.
Qed.

Lemma instant_cons_empty'_disjSO : forall alpha beta1 beta2,
  instant_cons_empty' alpha (disjSO beta1 beta2) =
  disjSO (instant_cons_empty' alpha beta1) (instant_cons_empty' alpha beta2).
Proof.
  intros. unfold instant_cons_empty'.
  rewrite rep_pred_l_disjSO. simpl.
  rewrite list_rel_compl_app.
  do 2 rewrite rep_pred_l_app.
  rewrite rep_pred_l_switch.
  rewrite sumtin.
  rewrite sumtin. reflexivity.
  apply incl_refl.
  apply jj6.  apply incl_refl.
  apply jj6.
Qed.

Lemma instant_cons_empty'_implSO : forall alpha beta1 beta2,
  instant_cons_empty' alpha (implSO beta1 beta2) =
  implSO (instant_cons_empty' alpha beta1) (instant_cons_empty' alpha beta2).
Proof.
  intros. unfold instant_cons_empty'.
  rewrite rep_pred_l_implSO. simpl.
  rewrite list_rel_compl_app.
  do 2 rewrite rep_pred_l_app.
  rewrite rep_pred_l_switch.
  rewrite sumtin.
  rewrite sumtin. reflexivity.
  apply incl_refl.
  apply jj6.  apply incl_refl.
  apply jj6.
Qed.

Lemma free_FO_instant_cons_empty'_f : forall beta alpha y,
  SOQFree beta = true  ->
  free_FO beta y = false ->
  free_FO (instant_cons_empty' alpha beta) y = false.
Proof.
  induction beta; intros alpha x Hno H; auto.
    simpl in *.  unfold instant_cons_empty'.
    simpl. destruct (in_predicate_dec p (preds_in alpha)).
    simpl. auto. simpl. rewrite predicate_dec_l.
    FOv_dec_l_rep. simpl. repeat rewrite H. auto. auto.

    rewrite instant_cons_empty'_allFO. simpl in *.
    destruct (FOvariable_dec x f). auto. apply IHbeta; auto.

    rewrite instant_cons_empty'_exFO. simpl in *.
    destruct (FOvariable_dec x f). auto. apply IHbeta; auto.

    rewrite instant_cons_empty'_negSO.
    simpl in *. apply IHbeta; assumption.

    rewrite instant_cons_empty'_conjSO.
    simpl in *. case_eq (SOQFree beta1);
      intros H2; rewrite H2 in *. 2 : discriminate.
    case_eq (free_FO beta1 x); intros H3;
      rewrite H3 in H. discriminate.
    rewrite IHbeta1. apply IHbeta2. all : try assumption.
    reflexivity.

    rewrite instant_cons_empty'_disjSO.
    simpl in *. case_eq (SOQFree beta1);
      intros H2; rewrite H2 in *. 2 : discriminate.
    case_eq (free_FO beta1 x); intros H3;
      rewrite H3 in H. discriminate.
    rewrite IHbeta1. apply IHbeta2. all : try assumption.
    reflexivity.

    rewrite instant_cons_empty'_implSO.
    simpl in *. case_eq (SOQFree beta1);
      intros H2; rewrite H2 in *. 2 : discriminate.
    case_eq (free_FO beta1 x); intros H3;
      rewrite H3 in H. discriminate.
    rewrite IHbeta1. apply IHbeta2. all : try assumption.
    reflexivity.

    simpl in *. destruct p. discriminate.

    simpl in *. destruct p. discriminate.
Qed.

Lemma want9 : forall l2 l1 beta1,
  (forall P,
    In P l2 /\  In P (preds_in beta1) ->  In P l1) ->
  replace_pred_l beta1 (app l1 l2)
      (nlist_list (length l1 + length l2) (nlist_var (length l1 + length l2) (Var 1)))
      (nlist_list (length l1 + length l2) (nlist_empty (length l1 + length l2))) =
  replace_pred_l beta1 l1 (nlist_list (length l1) (nlist_var _ (Var 1)))
      (nlist_list (length l1) (nlist_empty _)).
Proof.
  induction l2; intros l1 beta1 H.
  + simpl. rewrite app_nil_r. rewrite Nat.add_0_r. auto.
  + pose proof (rep_pred_l_app beta1 l1 (cons a l2)) as H2.
    simpl in *. rewrite app_length in H2. simpl in H2. rewrite H2.
    destruct (in_dec predicate_dec a l2).
    ++ destruct (nlist_list_ex (length l2) l2 eq_refl) as [lP H4].
      rewrite <- H4.
      rewrite length_nlist_list.
      rewrite rep_pred__l_is_in.
      rewrite H4.
      pose proof (rep_pred_l_app beta1 l1 l2) as H5.
      rewrite <- H5. rewrite app_length. simpl.
      apply IHl2. firstorder. rewrite H4. auto.
      apply FO_frame_condition_l_empty_n. auto.
    ++ rewrite Rep_Pred_FOv.rep_pred__l_switch_empty.
      pose proof (rep_pred_l_app beta1 l1 l2) as H5.
      rewrite <- H5. rewrite app_length. simpl.
      rewrite IHl2.
      specialize (H a). destruct a as [Qm]. simpl.
      destruct (in_dec predicate_dec (Pred Qm) l1).
      destruct (nlist_list_ex (length l1) l1 eq_refl) as [lP H4].
      rewrite <- H4.
      rewrite length_nlist_list.
      rewrite rep_pred__l_is_in. reflexivity.
      rewrite H4. assumption.
      apply FO_frame_condition_l_empty_n. auto.
      rewrite <- Rep_Pred_FOv.rep_pred__l_switch_empty.
      destruct (in_dec predicate_dec (Pred Qm) (preds_in beta1)).
      firstorder. rewrite rep_pred_Pred_in_SO_f; auto.
      firstorder.
Qed.

Lemma kk1 : forall beta alpha y,
  In y (FOvars_in alpha) ->  In y (FOvars_in beta)  ->
  In y (FOvars_in (instant_cons_empty' alpha beta)).
Proof.
  unfold instant_cons_empty'.
  induction beta; intros alpha y H1 H2; simpl in *.
  + destruct (in_predicate_dec p (preds_in alpha)).
    firstorder. simpl. FOv_dec_l_rep.  pred_dec_l_rep.  firstorder.
  + firstorder. + firstorder.
  + rewrite rep_pred_l_allFO. firstorder.
  + rewrite rep_pred_l_exFO. firstorder.
  + rewrite rep_pred_l_negSO. firstorder.
  + rewrite list_rel_compl_app. rewrite rep_pred_l_conjSO.
    simpl. rewrite app_length. rewrite want9. rewrite <- app_length.
    rewrite rep_pred_l_app. rewrite rep_pred_l_switch.
    rewrite <- rep_pred_l_app. rewrite app_length. rewrite want9.
    apply in_or_app. apply in_app_or in H2.
    destruct H2; auto.  apply want11. apply want11.
  + rewrite list_rel_compl_app. rewrite rep_pred_l_disjSO.
    simpl. rewrite app_length. rewrite want9. rewrite <- app_length.
    rewrite rep_pred_l_app. rewrite rep_pred_l_switch.
    rewrite <- rep_pred_l_app. rewrite app_length. rewrite want9.
    apply in_or_app. apply in_app_or in H2.
    destruct H2; auto.  apply want11. apply want11.
  + rewrite list_rel_compl_app. rewrite rep_pred_l_implSO.
    simpl. rewrite app_length. rewrite want9. rewrite <- app_length.
    rewrite rep_pred_l_app. rewrite rep_pred_l_switch.
    rewrite <- rep_pred_l_app. rewrite app_length. rewrite want9.
    apply in_or_app. apply in_app_or in H2.
    destruct H2; auto.  apply want11. apply want11.
  + destruct (in_predicate_dec p (preds_in alpha)); rewrite kk2. firstorder.
    simpl. apply kk6. auto.
  + destruct (in_predicate_dec p (preds_in alpha)); rewrite kk2_exSO. firstorder.
    simpl. apply kk6. auto.
Qed.

Lemma kk8 : forall lP beta x,
  ~ In x (FOvars_in beta) ->
  ~ In x (FOvars_in
   (replace_pred_l beta lP (nlist_list (length lP) (nlist_var _ (Var 1)))
      (nlist_list (length lP) (nlist_empty _)))).
Proof.
  induction lP; intros beta x H. auto.
  simpl in *. intros H2. apply IHlP in H.
  apply kk5 in H2. contradiction (H H2).
Qed.

Lemma kk7 : forall beta alpha a,
  ~ In a (FOvars_in beta) ->
  ~ In a (FOvars_in (instant_cons_empty' alpha beta)).
Proof.  unfold instant_cons_empty'. intros. apply kk8; auto. Qed.

Lemma var_in_SO_instant_cons_empty' : forall beta alpha x,
  var_in_SO beta x -> var_in_SO (instant_cons_empty' alpha beta) x.
Proof.
  unfold instant_cons_empty'.  intros.
  apply var_in_SO_instant_cons_empty'_pre. auto.
Qed.

Lemma max_FOv_rep_pred : forall alpha P x,
  max_FOv (replace_pred alpha P x (negSO (eqFO x x))) =
  max_FOv alpha.
Proof.
  intros alpha P x. unfold max_FOv.
  apply max_FOv_l_in_eq. apply kk5. apply kk6.
Qed.

Lemma max_FOv_instant_cons_empty'_pre: forall l beta,
max_FOv
  (replace_pred_l beta l (nlist_list (length l) (nlist_var _ (Var 1)))
          (nlist_list (length l) (nlist_empty _))) =
max_FOv beta.
Proof.
  induction l; intros beta. auto.
  simpl. rewrite max_FOv_rep_pred. apply IHl.
Qed.

Lemma max_FOv_instant_cons_empty': forall beta alpha,
  (max_FOv (instant_cons_empty' alpha beta)) =
  max_FOv beta.
Proof.
  unfold instant_cons_empty'. intros.
  apply max_FOv_instant_cons_empty'_pre.
Qed.

Lemma kk19_2 : forall alpha xn,
  var_in_SO alpha (Var xn) -> xn <= (max_FOv alpha).
Proof.
  intros alpha x H. unfold var_in_SO in H.
  unfold max_FOv. apply want19_pre. auto.
Qed.

Lemma kk19 : forall alpha xn,
  closed_except alpha (Var xn) -> ~(S (max_FOv alpha)) <= xn.
Proof.
  intros alpha xn H.
  apply PeanoNat.Nat.nle_gt. unfold lt.
  apply le_n_S. apply kk19_2. apply free_FO_var_in.
  firstorder.
Qed.

Lemma var_in_SO_max_FOv_gen2 : forall beta n,
  var_in_SO beta (Var n) -> ~ (S (max_FOv beta)) <= n.
Proof.
  intros beta n H1 H2. unfold var_in_SO in H1.
  unfold max_FOv in H2. apply want19_pre in H1.
  firstorder.
Qed.

Lemma aa18_pre : forall l x n,
 S (max_FOv_l l) <= n ->
  (In x l -> max_FOv_l (rename_FOv_list l x (Var n)) = n) /\
  (~ In x l ->
   max_FOv_l (rename_FOv_list l x (Var n)) = max_FOv_l l).
Proof.
  intros l x n H. apply conj; intros H2.
  + apply PeanoNat.Nat.le_antisymm.
    apply (PeanoNat.Nat.le_trans _ _ _ ( max_FOv_l_ren_FOv_list _ _ _ H2)).
    lia. eapply in_rename_FOv_list_2 in H2. eapply want19_pre in H2.
    apply H2.
  + rewrite rename_FOv_list_not_in; auto.
Qed.

Lemma aa18 : forall alpha x n,
  (S (max_FOv alpha)) <= n ->
  (var_in_SO alpha x ->
    max_FOv (replace_FOv alpha x (Var n)) = n) /\
  (~ var_in_SO alpha x ->
    max_FOv (replace_FOv alpha x (Var n)) = max_FOv alpha).
Proof.
  intros alpha x n H. unfold var_in_SO.
  unfold max_FOv in *. rewrite rep__ren_list.
  apply aa18_pre. auto.
Qed.

Lemma aa18_t : forall alpha x n,
  (S (max_FOv alpha)) <= n ->
  var_in_SO alpha x ->
    max_FOv (replace_FOv alpha x (Var n)) = n.
Proof. intros. apply aa18; assumption. Qed.

Lemma aa17 : forall alpha ln n x,
  closed_except alpha x ->
  (S (max_FOv alpha)) <= (min_l ln) ->
  (S (max_l ln)) <= n ->
  free_FO alpha (Var n) = false.
Proof.
  intros alpha ln n x Hc H1 H2.
  apply var_in_SO_free_FO.
  intros H3. apply var_in_SO_max_FOv_gen2 in H3.
  apply H3. pose proof (le_min__max_l ln). lia.
Qed.
Lemma aa20: forall alpha beta,
(max_FOv (instant_cons_empty' alpha beta)) <= (max_FOv (implSO alpha beta)).
Proof.
  intros alpha beta.  unfold instant_cons_empty'.
  apply (PeanoNat.Nat.le_trans _ (max_FOv beta)).
  + apply aa21. apply aa25. apply aa26.
  + rewrite max_FOv_implSO. lia.
Qed.

Lemma instant_cons_empty__' : forall alpha beta,
  instant_cons_empty (implSO alpha beta) =
  implSO alpha (instant_cons_empty' alpha beta).
Proof.
  intros alpha beta.
  unfold instant_cons_empty.
  unfold instant_cons_empty'.
  simpl. rewrite rep_pred_l_implSO.
  rewrite rep_pred_l_list_rel_compl.
  auto.
Qed.

Lemma something3 : forall beta alpha,
  incl (preds_in (instant_cons_empty' alpha beta))
    (preds_in beta).
Proof.
  intros beta alpha.
  unfold instant_cons_empty'.
  rewrite jj8; apply jj10.
Qed.

Lemma preds_in_replace_FOv_A_pre: forall  n l alpha beta,
  preds_in (replace_FOv_A_pre alpha beta l n) =
  preds_in alpha.
Proof.
  induction n; intros l alpha beta.
    simpl. reflexivity.

    simpl. destruct l. reflexivity.
    rewrite IHn.
    rewrite preds_in_strip_exFO.
    rewrite preds_in_replace_FOv_max_conj.
    apply preds_in_list_closed_exFO.
Qed.

Lemma preds_in_replace_FOv_A : forall l alpha beta,
  preds_in (replace_FOv_A alpha beta l)  =
  preds_in alpha.
Proof.
  induction l; intros alpha beta; unfold replace_FOv_A.
    simpl. reflexivity.

    simpl. rewrite preds_in_replace_FOv_A_pre.
    rewrite preds_in_strip_exFO.
    rewrite preds_in_replace_FOv_max_conj.
    apply preds_in_list_closed_exFO.
Qed.


(** * Simulation up to taus *)

(** A preorder [sutt t1 t2], where every visible step
  ([RetF] or [VisF]) on the left must be matched with a corresponding
  step on the right, ignoring [TauF].

  In particular, [spin := Tau spin] is less than everything.

  The induced equivalence relation is [eutt].
[[
  Theorem sutt_eutt : sutt eq t u -> sutt eq u t -> eutt eq t u.
]]
  Various lemmas about [eutt] may be more easily proved as
  [Proper] lemmas about [sutt] first, and then symmetrizing using
  [eutt_sutt] and [sutt_eutt].
 *)

From Paco Require Import paco.

From Coq Require Import
     Morphisms.

From ITree Require Import
     Axioms
     Basics.Tacs
     Core.ITreeDefinition
     Eq.Eqit
     Eq.UpToTaus
     Eq.Shallow
     Eq.Paco2.

Section SUTT.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Inductive suttF (sutt: itree' E R1 -> itree' E R2 -> Prop) :
  itree' E R1 -> itree' E R2 -> Prop :=
| suttF_ret r1 r2 : RR r1 r2 -> suttF sutt (RetF r1) (RetF r2)
| suttF_vis u (e : E u) k1 k2
      (SUTTK: forall x, sutt (observe (k1 x)) (observe (k2 x))):
    suttF sutt (VisF e k1) (VisF e k2)
| suttF_tau_right ot1 t2
      (EQTAUS: suttF sutt ot1 (observe t2)):
    suttF sutt ot1 (TauF t2)
| suttF_tau_left t1 ot2
      (EQTAUS: sutt (observe t1) ot2):
    suttF sutt (TauF t1) ot2
.
Hint Constructors suttF : itree.

Definition sutt (t1 : itree E R1) (t2 : itree E R2) :=
  paco2 suttF bot2 (observe t1) (observe t2).
Hint Unfold sutt : itree.

End SUTT.

Global Hint Constructors suttF : itree.
Global Hint Unfold sutt : itree.

Section SUTT_rel.

Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop).

Lemma reflexive_suttF `{Reflexive _ RR} sutt (r1:Reflexive sutt) : Reflexive (@suttF E _ _ RR sutt).
Proof.
  unfold Reflexive. intros x.
  destruct x; eauto with itree.
Qed.

End SUTT_rel.

Section SUTT_facts.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Lemma monotone_suttF : monotone2 (@suttF E _ _ RR).
Proof. repeat red; intros. induction IN; eauto with itree. Qed.
Hint Resolve monotone_suttF : paco.

End SUTT_facts.

Global Hint Resolve monotone_suttF : paco.

Lemma suttF_inv_vis {E R1 R2} (RR : R1 -> R2 -> Prop) sutt :
  forall X e (k1 : X -> itree E R1) (k2 : X -> itree E R2),
    suttF RR sutt (VisF e k1) (VisF e k2) ->
    forall x, sutt (observe (k1 x)) (observe (k2 x)).
Proof.
  intros. inv H. ddestruction; auto.
Qed.

Lemma sutt_inv_vis {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall X e (k1 : X -> itree E R1) (k2 : X -> itree E R2),
  sutt RR (Vis e k1) (Vis e k2) ->
  forall x, sutt RR (k1 x) (k2 x).
Proof.
  intros. pstep. punfold H. simpl in *.
  eapply suttF_inv_vis in H; pclearbot; punfold H.
Qed.

Lemma sutt_tau_right {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    sutt RR t1 t2 ->
    sutt RR t1 (Tau t2).
Proof.
  intros. punfold H. pstep.
  repeat red. repeat red in H. constructor.
  auto.
Qed.

Lemma sutt_tau_left {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    sutt RR t1 t2 ->
    sutt RR (Tau t1) t2.
Proof.
  intros. punfold H. pstep.
  repeat red. repeat red in H. constructor.
  eauto with paco.
Qed.

Lemma sutt_elim_tau_right {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1: itree E R1) (t2: itree E R2),
    sutt RR t1 (Tau t2) ->
    sutt RR t1 t2.
Proof.
  pcofix CIH. pstep. intros.
  punfold H0. repeat red in H0.
  inv H0.
  - eapply monotone_suttF; eauto using upaco2_mon_bot with paco.
  - constructor. pclearbot. eauto with paco.
Qed.

Lemma suttF_inv_tau_left {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1: itree E R1) ot2,
    suttF RR (upaco2 (suttF RR) bot2) (TauF t1) ot2 ->
    suttF RR (upaco2 (suttF RR) bot2) (observe t1) ot2.
Proof.
  intros.
  remember (TauF t1) as ott1.
  induction H; intros; subst; try dependent destruction Heqott1; eauto with itree.
  pclearbot. punfold EQTAUS.
Qed.

Lemma sutt_inv_tau_left {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1: itree E R1) (t2: itree E R2),
    sutt RR (Tau t1) t2 ->
    sutt RR t1 t2.
Proof.
  intros.
  punfold H. pstep. repeat red in H |- *.
  apply suttF_inv_tau_left; auto.
Qed.

Theorem sutt_eutt {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    sutt RR t1 t2 -> sutt (flip RR) t2 t1 -> eutt RR t1 t2.
Proof.
  pcofix CIH. intros.
  punfold H0. punfold H. pstep. red.
  induction H0; intros; subst; auto with itree.
  - constructor. intro. right. eapply suttF_inv_vis in H. pclearbot. eauto with paco itree.
  - constructor; eauto. eapply IHsuttF; auto. eapply suttF_inv_tau_left; auto.
  - (* doing induction when one of the trees is a tau doesn't work well *)
    inv H; pclearbot.
    + clear t1 t2. genobs t0 ot0.
      hinduction EQTAUS0 before CIH; intros; subst; pclearbot.
      * constructor; eauto. simpobs. constructor. eauto.
      * constructor; eauto. simpobs. constructor. intros.
        right. apply CIH; auto with itree. eapply sutt_inv_vis in EQTAUS; eauto with itree.
      * constructor; eauto. simpobs. eapply IHEQTAUS0; eauto.
        rewrite (itree_eta' ot1). apply sutt_inv_tau_left; auto.
      * constructor. right. apply CIH; auto. apply sutt_elim_tau_right; auto.
    + constructor. right. apply CIH; apply sutt_elim_tau_right; auto.
Qed.

Theorem eutt_sutt {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    eutt RR t1 t2 -> sutt RR t1 t2.
Proof.
  pcofix CIH. pstep. intros.
  punfold H0. red in H0.
  induction H0; constructor; pclearbot; eauto 7 with paco itree.
Qed.

(** Generalized heterogeneous version of [eutt_bind] *)
Lemma sutt_bind' {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}:
  forall t1 t2,
    sutt RR t1 t2 ->
    forall s1 s2, (forall r1 r2, RR r1 r2 -> sutt SS (s1 r1) (s2 r2)) ->
                  @sutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2).
Proof.
  pcofix self. pstep. intros.
  punfold H0. unfold observe; cbn.
  induction H0; intros.
  - simpl. apply H1 in H. punfold H. eapply monotone_suttF; eauto using upaco2_mon_bot.
  - simpl. pclearbot. econstructor. eauto with itree.
  - constructor. eauto with paco.
  - constructor. pclearbot.
    right. specialize (self t0 (go ot2) EQTAUS _ _ H1).
    apply self.
Qed.

(* todo: this could be made stronger with eutt rather than eq_itree
 *)
#[global] Instance Proper_sutt {E : Type -> Type} {R1 R2 : Type} r
: Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
       (@sutt E R1 R2 r).
Proof.
  repeat red. pcofix CIH; pstep. intros.
  punfold H0; punfold H1; punfold H2. red in H0, H1.
  (* rename H1 into H2, Hxy into H1.  *)
  hinduction H2 before CIH; subst; intros.
  - inv H0; try discriminate. inv H1; try discriminate. econstructor. eauto.
  - dependent destruction H0; try discriminate.
    dependent destruction H1; try discriminate.
    simpobs. pclearbot.
    constructor. intros. right. eauto 7 with paco itree.
  - dependent destruction H1; try discriminate.
    simpobs. pclearbot. punfold REL. auto with itree.
  - dependent destruction H0; try discriminate.
    simpobs. pclearbot. constructor.
    right. rewrite (itree_eta' ot2) in *. eauto with itree.
Qed.