Require Import GenGraph.
Require Import fintype.
Require Import SetoidList List.
Require Import FunctionalExtensionality.

Ltac in_inv :=
  simpl in *;
  match goal with
  | H : InA ?eq ?elt nil |- _ =>
    inversion H
  | H : InA ?eq ?x (?h::?t) |- _ =>
    inversion H; subst
  end.

Ltac solve_InA_In :=
  match goal with
  | H : InA eq ?x ?l |- In ?x ?l =>
    apply In_InAeq_iff; auto
  | H : In  ?x ?l |- InA eq ?x ?l =>
    apply In_InAeq_iff; auto
  end.

Lemma equivlistAeq_refl : forall A eqA (a : list A) ,
    Equivalence eqA ->
    equivlistA eqA a a.
Proof.
  split; intros; auto.
Qed.

Ltac rewrite_equiv :=
  match goal with
  | H : equivlistA eq ?s ?s' |- _ =>
    rewrite H in *
  | H : equivlistA eq (_::?s) nil |- _ =>
    apply equivlistA_cons_nil in H; [exfalso; exact H |typeclasses eauto]
  | |- equivlistA eq ?a ?a =>
    apply equivlistAeq_refl; try typeclasses eauto
  end.

Hint Extern 1 => in_inv : equiv.
Hint Extern 1 => rewrite_equiv; auto : equiv.
Hint Extern 1 => solve_InA_In : equiv.
Hint Constructors InA.

Section AllMIS.
Variable T : Type.
Variable Tdec : forall t1 t2 : T, {t1 = t2} + {t1 <> t2}.

Lemma map_InA_cons : forall s' a s,
    InA (equivlistA eq) s' (map (fun l1 : list T => a :: l1) s) ->
    InA eq a s'.
Proof.
  intros.
  {
    induction s; simpl in H; auto with equiv.
  }
Qed.

Lemma inA_map_iff:
  forall (A B : Type) (f : A -> B) (l : list A) (y : B)
         (eqB : relation B)
         (eqA : relation A),
    (* (forall a, Proper (eqA ==> flip impl) (eq (f a))) -> *)
    Proper (eqA ==> eqB) f ->
    Equivalence eqA ->
    Equivalence eqB ->
  InA eqB y (map f l) <-> (exists x : A, eqB (f x) y /\ InA eqA x l).
Proof.
  intros A B f l y eqB eqA Hprop Aeq Beq.
  split; intros H0.
  {
    induction l; eauto with equiv.
    +
      simpl in H0.
      inversion H0.
      {
        subst.
        exists a.
        split; auto.
        {
          apply eqasym; auto with equiv.
        }
        {
          left; auto.
          apply Aeq.
      (*   apply IHl in H1; eauto. *)
      (*   destruct H2; eauto. *)
      (* exists x; eauto. *)
      (* intuition. *)
        }
      }
      {
        subst.
        apply IHl in H1; eauto.
        destruct H1; eauto.
        exists x; eauto.
        intuition.
      }
  }
  {
    induction l; eauto with equiv.
    {
      simpl in *.
      destruct H0; intuition.
    }
    {
      simpl.
      destruct H0.
      destruct H; auto.
      inversion H0; subst; eauto.
      left.
      rewrite <- H2.
      apply Beq; auto.
    }
  }
Qed.

Lemma remove_NotIn_Id :
  forall a x, ~InA eq a x ->
              remove Tdec a (a :: x) = x.
  intros a0 x Hnot.
  simpl.
  destruct Tdec; subst; auto.
  {
    {
      induction x; auto with equiv.
      simpl.
      destruct Tdec; subst; auto with equiv.
      exfalso; auto.
      rewrite IHx; auto.
    }
  }
  {
    contradiction.
  }
Qed.

Lemma equivlistA_remove : forall a x s' s,
  equivlistA eq (a :: x) s' ->
      InA eq x s ->
      ~ InA eq a x ->
      equivlistA eq x (remove Tdec a s').
Proof.
  intros.
  replace (remove Tdec a s') with
      (removeA Tdec a s') by
      (unfold removeA; auto).
  apply removeA_equivlistA; auto; typeclasses eauto.
Qed.

Lemma InAeq_InAequivlistA : forall A (x : list A) (s : list (list A)),
    InA eq x s ->
    InA (equivlistA eq) x s.
Proof.
  induction s; intros; auto with equiv.
Qed.

Lemma map_cons : forall (s' : list T) (a : T) (s : list (list T)),
    InA (equivlistA eq)  s' (map (fun l1 : list T => a :: l1) s) <->
    InA eq a s' /\
    (InA (equivlistA eq) s' s \/ InA (equivlistA eq)  (remove Tdec a s') s).
Proof.
  intros.
  split; intros; auto.
  {
    split.
    {
      eapply map_InA_cons; eauto.
    }
    {
      rewrite inA_map_iff in H; try typeclasses eauto; auto.
      destruct H.
      destruct H; subst.
      destruct (InA_dec Tdec a x).
      {
        left.
        rewrite <- H.
        induction s; [inversion H0| ].
        inversion H0; subst.
        auto with equiv.
        left; auto.
        rewrite H.
        {
          split; intros; auto with equiv.
          {
            rewrite <- H in H1.
            inversion H1; subst; auto.
          }
          {
            rewrite <- H; auto.
          }
        }
        auto with equiv.
      }
      {
        assert (equivlistA eq x (remove Tdec a s')) by
            (eapply equivlistA_remove; eauto).
        right.
        rewrite <- H1.
        clear -H0.
        apply InAeq_InAequivlistA; auto.
      }
    }
  }
  {
    destruct H.
    destruct H0.
    {
      apply inA_map_iff with (eqA := (equivlistA eq)) ; try typeclasses eauto.
      {
        do 2 red; intros.
        rewrite H1; auto with equiv.
      }
      exists s'.
      split; auto.
      {
        split; intros; auto with equiv.
      }
    }
    apply inA_map_iff with (eqA := (equivlistA eq));
      try typeclasses eauto.
    {
      do 2 red; intros;
        rewrite H1; auto with equiv.
    }
    {
      exists (remove Tdec a s').
      split; auto with equiv.
      clear - H.
      {
        replace (remove Tdec a s') with
            (removeA Tdec a s') by
            (unfold removeA; auto).
        destruct (InA_dec Tdec a s').
        {
          split; intros; auto with equiv.
          {
            inversion H0; subst; auto with equiv.
            +
              apply removeA_InA in H2; try typeclasses eauto.
              destruct H2.
              auto.
          }
          {
            destruct (Tdec x a); subst; auto.
            right.
            apply removeA_InA; try typeclasses eauto.
            split; auto with equiv.
          }
        }
        {
          split; intros; auto with equiv.
          {
            inversion H0; subst; auto with equiv.
            +
              apply removeA_InA in H2; try typeclasses eauto.
              destruct H2.
              contradiction.
          }
          {
            right.
            apply removeA_InA; try typeclasses eauto.
            split; auto.
          }
        }
      }
    }
  }
Qed.

Lemma all_subsets_list_subset :
  forall  (l l0 : list T),
    InA (equivlistA eq) l0 (fintype.all_subsets l) <-> (forall x, InA eq x l0 -> InA eq x l).
Proof.
  intros.
  generalize dependent l0.
  induction l.
  {
    split; intros.
    {
      simpl in H.
      inversion H; subst;
        try rewrite H2 in H0.
      inversion H0.
      inversion H2.
    }
    destruct l0.
    simpl; left; auto.
    {
      constructor; intros; auto.
    }
    assert (InA eq t nil).
    apply H; left; auto.
    inversion H0.
  }
  intros.
  simpl.
  rewrite InA_app_iff.
  rewrite map_cons.
  do 2 rewrite IHl.
  split; intros.
  {
    intuition.
    destruct (Tdec x a).
    subst; auto with equiv.
    right.
    apply H1.
    rewrite In_InAeq_iff.
    apply remove_mem; intuition.
  }
  {
    destruct (InA_dec Tdec a l0); auto with equiv.
    {
      right.
      intuition.
      {
        right.
        intros.
        auto with equiv.
        apply In_InAeq_iff in H0.
        apply remove_mem in H0.
        destruct H0; auto with equiv.
        simpl in *.
        apply In_InAeq_iff in H0.
        apply H in H0.
        inversion H0;
        intuition.
      }
    }
    {
      clear - H n.
      left.
      intros.
      destruct (Tdec x a).
      subst.
      contradiction.
      apply H in H0.
      inversion H0.
      subst.
      contradiction.
      auto.
    }
  }
Qed.

Hint Constructors NoDup.
Hint Constructors NoDupA.

Lemma NoDupA_map : forall a l,
    (forall sub : list T,
       InA (equivlistA eq) sub l -> ~ InA eq a sub) ->
    NoDupA (equivlistA eq) l ->
    NoDupA (equivlistA eq)
         (map (fun l0 : list T => a :: l0) l).
Proof.
  intros.
  induction H0.
  simpl in *.
  auto.
  {
    simpl.
    constructor; auto.
    intros Hnot.
    rewrite inA_map_iff in Hnot; try typeclasses eauto; eauto.
    destruct Hnot.
    destruct H2.
    clear IHNoDupA.
    assert (~ InA eq a x).
    {
      apply H; left; auto.
      apply equivlistAeq_refl; try typeclasses eauto.
    }
    assert (~ InA eq a x0).
    {
      apply H.
      right; auto.
      apply InAeq_InAequivlistA; auto.
    }
    assert (equivlistA eq x0 x).
    {
      red in H2.
      split; intros; eauto.
      +
        assert (InA eq x1 (a :: x)).
        apply H2; auto.
        inversion H7; subst; eauto.
        contradiction.
      +
        assert (InA eq x1 (a :: x0)).
        apply H2; auto.
        inversion H7; subst; eauto.
        contradiction.
    }
    apply H0.
    rewrite<-  H6.
    apply InAeq_InAequivlistA; auto.
  }
Qed.

Lemma no_dups_powerset :
  forall (A : Type) (l: list T),
    NoDup l ->
    NoDupA (equivlistA eq)  (fintype.all_subsets l).
Proof.
  intros.
  pose proof (map_cons).
  assert (forall l (a : T) (s : list (list T)),
             InA (equivlistA eq) l (map (fun l1 : list T => a :: l1) s) ->
             InA eq a l /\
       (InA (equivlistA eq) l s \/
        InA (equivlistA eq) (remove Tdec a l) s)).
  intros.
  apply H0; auto.
  clear H0.
  induction l.
  simpl.
  apply NoDupA_singleton.
  simpl.
  apply SetoidList.NoDupA_app; try typeclasses eauto; eauto.
  {
    apply IHl; auto.
    inversion H; subst; auto.
  }
  {
    inversion H; subst.
    apply IHl in H4.
    apply NoDupA_map; auto.
    intros.
    clear -H3 H0 Tdec.
    induction l.
    simpl in H0.
    inversion H0; subst; auto with equiv.
    {
      rewrite all_subsets_list_subset in H0.
      intros Hnot.
      apply H0 in Hnot.
      apply In_InAeq_iff in Hnot.
      contradiction.
    }
  }
  {
    inversion H; subst.
    intros.
    apply map_cons in H2.
    destruct H2; eauto.
    destruct H5; eauto.
    {
      rewrite all_subsets_list_subset in H0.
      assert (InA eq a l) by auto.
      apply In_InAeq_iff in H6.
      contradiction.
    }
    {
      rewrite all_subsets_list_subset in H0.
      assert (InA eq a l).
      auto.
      apply In_InAeq_iff in H6; eauto.
    }
  }
Qed.

Definition Teq (t1 t2 : T) :=
  match Tdec t1 t2 with
  | left _ => true
  | right _ => false
  end.

Require Import Bool.
Definition list_mem (x : T) (l : list T) : bool :=
  existsb (fun elt => if Tdec elt x then true else false) l.

Definition IndependentProg (G : @GenGraph T) (x : list T) :
  bool :=
  forallb (fun v1 => (forallb
        (fun v2 => negb (existsb
        (fun edge =>
           Teq (fst edge) v1 &&
           Teq (snd edge) v2)
        (gE _ G))) x))  x.

Definition ValidSetProg (G : @GenGraph T) (x : list T) :=
  forallb (fun elt => list_mem elt (gV _ G)) x.

Definition MaximalIndSetProg (G : @GenGraph T) (x : list T) :
  bool :=
  (ValidSetProg G x) &&
  (IndependentProg G x) &&
  (forallb (fun v1 => if negb (list_mem v1 x) then
     (existsb (fun edge =>
                 Teq (fst edge) v1 &&
                     Teq v1 (fst edge) &&
                     (list_mem (snd edge) x) &&
                     (list_mem (snd edge) (gV T G)))
              (gE _ G))
                 else
                   true) (gV _ G)).
(* forall x y : T, In x l -> In y l -> ~ In (x, y) (gE T G) *)

(* IndSet_E G l -> *)
(*               (forall x : T, *)
(*                In x (gV T G) -> *)
(*                ~ In x l -> *)
(*                exists y : T, *)
(*                  In y (gV T G) /\ In y l /\ In (x, y) (gE T G)) -> *)
(*               MaximalIndSet_E G l *)

Lemma list_mem_In : forall x1 x,
  In x1 x <-> list_mem x1 x = true.
Proof.
  split;
  intros.
  {
    unfold list_mem.
    apply existsb_exists.
    exists x1; intuition.
    destruct Tdec; subst; auto.
  }
  {
    unfold list_mem in H.
    apply existsb_exists in H.
    destruct H.
    destruct H; auto.
    destruct Tdec; subst; auto.
    discriminate.
  }
Qed.

Lemma forallb_false1
      (f: T -> bool)
      (l: list T) :
  forallb f l = false ->
  (exists x: T, In x l /\ f x = false).
Proof.
  induction l.
  { inversion 1. }
  simpl.
  rewrite andb_false_iff.
  intros H.
  destruct H.
  { exists a; split; auto. }
  destruct (IHl H) as [x [H3 H4]].
  exists x; split; auto.
Qed.

Lemma forallb_false2
      (f: T -> bool)
      (l: list T) :
  (exists x: T, In x l /\ f x = false) ->
  forallb f l = false.
Proof.
  induction l.
  { intros [x [A B]]. inversion A. }
  intros [x [A B]].
  simpl.
  inversion A.
  { subst.
    rewrite B; auto. }
  rewrite andb_false_iff; right.
  apply IHl.
  exists x.
  split; auto.
Qed.

Lemma forallb_false
      (f: T -> bool)
      (l: list T) :
  forallb f l = false <->
  (exists x: T, In x l /\ f x = false).
Proof. split. apply forallb_false1. apply forallb_false2. Qed.

Lemma forallb_equivlistA
      (f: T -> bool)
      (l1 l2: list T)
      (H: equivlistA eq l1 l2) :
      forallb f l1 = forallb f l2.
Proof.
  destruct (forallb f l2) eqn:H2.
  { rewrite forallb_forall; intros x Hin.
    { destruct (H x) as [A B].
      rewrite forallb_forall in H2.
      apply H2; auto.
      rewrite <-In_InAeq_iff; apply A; rewrite In_InAeq_iff; auto. }}
  rewrite forallb_false in H2.
  destruct H2 as [x [Hin H3]].
  rewrite forallb_false.
  exists x; split; auto.
  destruct (H x); rewrite <-In_InAeq_iff; apply H1; rewrite In_InAeq_iff; auto.
Qed.

Lemma existsb_demorgan
      (A: Type)
      (f: A -> bool)
      (l: list A) :
  existsb f l = negb (forallb (fun x => negb (f x)) l).
Proof.
  induction l; auto.
  simpl.
  rewrite negb_andb, negb_involutive.
  f_equal.
  rewrite IHl; auto.
Qed.

Lemma existsb_equivlistA
      (f: T -> bool)
      (l1 l2: list T)
      (H: equivlistA eq l1 l2) :
      existsb f l1 = existsb f l2.
Proof.
  do 2 rewrite existsb_demorgan.
  f_equal.
  apply forallb_equivlistA; auto.
Qed.

Lemma Teq_refl (x: T): Teq x x = true.
Proof.
  unfold Teq.
  destruct (Tdec x x); auto.
Qed.

Lemma Teq_eq (x y: T): Teq x y = true -> x=y.
Proof.
  unfold Teq.
  destruct (Tdec x y); auto.
  inversion 1.
Qed.

Lemma MaxProg_iff :forall G x, MaximalIndSetProg G x = true <->
                          MaximalIndSet_E G x.
Proof.
  split; intros.
  unfold MaximalIndSetProg in H.
  unfold IndependentProg in H.
  destruct G.
  simpl in *.
  rewrite andb_true_iff in H.
  rewrite andb_true_iff in H.
  do 2 destruct H.
  unfold ValidSetProg in H.
  rewrite  forallb_forall in H0,H,H1.
  induction gV; simpl in *; auto.
  {
    constructor; eauto.
    {
      constructor; auto.
      {
        red; intros.
        simpl in *.
        apply H in H2; discriminate.
      }
      {
        red; intros.
        simpl.
        intros Hnot.
        apply gE_subset_l in Hnot.
        exact Hnot.
      }
    }
    {
      intros.
      simpl in *.
      inversion H2.
    }
  }
  {
    constructor.
    {
      constructor.
      {
        red; intros.
        simpl.
        specialize (H _ H2).
        destruct (Tdec a x0).
        { subst; auto. }
        rewrite orb_false_l in H.
        unfold list_mem in H.
        rewrite existsb_exists in H.
        destruct H as [y [Hx Hy]].
        right.
        destruct (Tdec y x0).
        { subst; auto. }
        inversion Hy.
      }
      red; intros.
      simpl.
      intros Hnot.
      specialize (gE_subset_l _ _ Hnot).
      generalize (H _ H2).
      generalize (H _ H3).
      destruct gE_subset_l.
      { subst.
        destruct (Tdec x0 x0); intros A B; try inversion B. clear B.
        destruct (Tdec x0 y).
        { clear A.
          subst.
          eapply gE_irref; eauto. }
        rewrite orb_false_l in A.
        unfold list_mem in A.
        rewrite existsb_exists in A. destruct A as [z [Hz1 Hz2]].
        destruct (Tdec z y); try inversion Hz2.
        subst. clear Hz2.
        clear e.
        generalize (H1 _ H2).
        generalize (H1 _ H3).
        do 2 rewrite forallb_forall.
        intros A B.
        specialize (A _ H2).
        specialize (B _ H3).
        rewrite negb_true_iff in A, B.
        clear A.
        assert (B' : existsb (fun edge : T * T => Teq (fst edge) x0 && Teq (snd edge) y) gE = true).
        { rewrite existsb_exists.
          exists (x0,y).
          split; auto.
          simpl.
          rewrite andb_true_iff.
          split.
          unfold Teq; destruct (Tdec _ _); auto.
          unfold Teq; destruct (Tdec _ _); auto. }
        rewrite B' in B; congruence.
        apply n; auto. }
      generalize (H1 _ H2). intros A.
      generalize (H1 _ H3). intros B.
      rewrite forallb_forall in A, B.
      specialize (A _ H3).
      rewrite existsb_demorgan, negb_involutive, forallb_forall in A.
      specialize (A (x0,y) Hnot). simpl in A. rewrite negb_true_iff in A.
      rewrite andb_false_iff in A. exfalso. destruct A as [A|A]; rewrite Teq_refl in A; congruence. }
    simpl.
    intros x0 [A|A]; intros B.
    { subst.
      specialize (H0 x0 (or_introl _ eq_refl)).
      assert (C: negb (list_mem x0 x) = true).
      { unfold list_mem; rewrite existsb_demorgan, negb_involutive, forallb_forall.
        intros x1 Hin.
        destruct (Tdec x1 x0); auto.
        subst. exfalso; apply B; auto.
      }
      rewrite C in H0.
      rewrite existsb_exists in H0.
      destruct H0 as [[a b] [X Y]].
      simpl in Y.
      do 3 rewrite andb_true_iff in Y.
      destruct Y as [[[Z1 Z2] Y1b] Y2].
      apply Teq_eq in Z1.
      apply Teq_eq in Z2.
      subst.
      clear Z2.
      exists b.
      split.
      { right.
        destruct (gE_subset_l _ _ (gE_symm _ _ X)); auto.
        subst. exfalso; apply (gE_irref _ X). }
      split; auto.
      unfold list_mem in Y1b.
      rewrite existsb_exists in Y1b. destruct Y1b as [xx [Q R]].
      destruct (Tdec xx b). subst. auto. congruence. }
    { specialize (H0 x0 (or_intror _ A)).
      assert (C: negb (list_mem x0 x) = true).
      { unfold list_mem; rewrite existsb_demorgan, negb_involutive, forallb_forall.
        intros x1 Hin.
        destruct (Tdec x1 x0); auto.
        subst. exfalso; apply B; auto.
      }
      rewrite C in H0.
      rewrite existsb_exists in H0.
      destruct H0 as [[aa b] [X Y]].
      simpl in Y.
      do 3 rewrite andb_true_iff in Y.
      destruct Y as [[[Z1 Z2] Y1b] Y2].
      apply Teq_eq in Z1.
      apply Teq_eq in Z2.
      subst.
      clear Z2.
      exists b.
      split.
      { apply (gE_subset_l _ _ (gE_symm _ _ X)).
      }
      split; auto.
      unfold list_mem in Y1b.
      rewrite existsb_exists in Y1b. destruct Y1b as [xx [Q R]].
      destruct (Tdec xx b). subst. auto. congruence. }
  }
  inversion H.
  unfold MaximalIndSetProg.
  destruct G; simpl in *.
  do 2 rewrite andb_true_iff.
  split.
  {
    split.
    {
      unfold ValidSetProg.
      rewrite  forallb_forall.
      intros.
      inversion H0.
      red in H3.
      apply H3 in H2.
      clear -H2.
      simpl in *.
      unfold list_mem.
      apply existsb_exists; auto.
      exists x0.
      split; auto.
      destruct Tdec; subst; auto.
    }
    {
      unfold IndependentProg.
      rewrite  forallb_forall.
      intros.
      rewrite  forallb_forall.
      intros.
      simpl.
      inversion H0.
      red in H5.
      clear -H5 H2 H3.
      simpl in H5.
      specialize (H5 x0 x1 H2 H3).
      destruct ((existsb
                   (fun edge : T * T => Teq (fst edge) x0 && Teq (snd edge) x1) gE))
               eqn:N.
      {
        rewrite existsb_exists in N.
        destruct N; auto.
        destruct H.
        rewrite andb_true_iff in H0.
        destruct H0.
        unfold Teq in *.
        destruct (Tdec (fst x2) x0); subst; auto.
        destruct (Tdec (snd x2) x1); subst; auto.
        exfalso.
        apply H5.
        destruct x2; auto.
      }
      {
        auto.
      }
    }
  }
  {
    rewrite  forallb_forall.
    intros.
    destruct (negb (list_mem x0 x)) eqn:N; auto.
    unfold negb in N.
    unfold list_mem in N.
    destruct (existsb (fun elt : T => if Tdec elt x0 then true else false) x) eqn:Hn.
    {
      discriminate.
    }
    assert ( ~ In x0 x).
    {
      clear -Hn.
      intros Hnot.
      assert ((exists x' , In x' x /\
                (if Tdec x' x0 then true else false) = true)).
      exists x0.
      split; auto.
      {
        destruct Tdec; subst; auto.
      }
      apply existsb_exists in H.
      rewrite Hn in H.
      discriminate.
    }
    {
      apply H1 in H3; auto.
      {
        clear -H3.
        apply existsb_exists.
        destruct H3.
        exists (x0,x1).
        simpl.
        intuition.
        unfold Teq.
        destruct (Tdec x0 x0); subst; simpl; auto.
        apply list_mem_In in H.
        apply list_mem_In in H0.
        rewrite H0,H.
        auto.
      }
    }
  }
Qed.

Definition AllMIS (G : @GenGraph T) :=
  filter (fun x => MaximalIndSetProg G x) (fintype.all_subsets (gV _ G)).

Lemma MaximalIndSetProg_equivlistA
  (G : GenGraph T)
  (x : list T)
  (H : MaximalIndSet_E G x)
  (x0 y : list T)
  (H0 : equivlistA eq x0 y) :
  MaximalIndSetProg G x0 = MaximalIndSetProg G y.
Proof.
  unfold MaximalIndSetProg.
  f_equal.
  {
    f_equal.
    { unfold ValidSetProg.
      apply forallb_equivlistA; auto. }
    unfold IndependentProg.
    rewrite (forallb_equivlistA _ x0 y); auto.
    f_equal.
    apply functional_extensionality; intros x1.
    rewrite (forallb_equivlistA _ x0 y); auto.
  }
  f_equal.
  apply functional_extensionality; intros x1.
  unfold list_mem.
  rewrite (existsb_equivlistA _ x0 y); auto.
  destruct (negb _); auto.
  f_equal.
  apply functional_extensionality; intros x2.
  f_equal.
  f_equal.
  apply existsb_equivlistA; auto.
Qed.

Lemma AllMIS_spec : forall G,
  MIS_set_gGraph G (AllMIS G).
Proof.
  unfold AllMIS.
  constructor.
  intros.
  apply filter_In in H.
  destruct H.
  apply MaxProg_iff.
  auto.
  apply filter_NoDupA.
  assert (NoDup (gV T G)).
  {
    destruct G; auto.
  }
  {
    apply no_dups_powerset in H; auto.
  }
  intros.
  apply filter_InA.
  {
    red.
    red.
    intros.
    eapply MaximalIndSetProg_equivlistA; eauto.
  }
  split.
  {
    destruct G.
    simpl in *.
    assert (forall x0 : T, In x0 x -> In x0 gV).
    {
      inversion H; intuition; simpl in *; subst.
      inversion H0; subst.
      simpl in *.
      unfold valid_E in H3.
      simpl in *.
      clear -H3 H2.
      apply H3.
      auto.
    }
    apply all_subsets_list_subset; auto.
    intros.
    rewrite In_InAeq_iff.
    apply H0; auto.
    apply In_InAeq_iff.
    auto.
  }
  {
    apply MaxProg_iff; auto.
  }
Qed.

Lemma MIS_exists :
  forall G,
    exists (l : list (list T)), MIS_set_gGraph G l.
Proof.
  intros.
  exists (AllMIS G).
  apply AllMIS_spec.
Qed.

End AllMIS.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-02-09

signature for algebraic terms with arity
*)

Set Implicit Arguments.

From CoLoR Require Import EqUtil ListUtil LogicUtil.

(***********************************************************************)
(** Variables are represented by natural numbers. *)

Notation variable := nat (only parsing).

(***********************************************************************)
(** Signature with a decidable set of symbols of fixed arity. *)

Record Signature : Type := mkSignature {
  symbol :> Type;
  arity : symbol -> nat;
  beq_symb : symbol -> symbol -> bool;
  beq_symb_ok : forall x y, beq_symb x y = true <-> x = y
}.

Arguments mkSignature [symbol] _ [beq_symb] _.
Arguments arity [s] _.
Arguments beq_symb [s] _ _.
Arguments beq_symb_ok {s x y}.

Ltac case_beq_symb Sig := EqUtil.case_beq (@beq_symb Sig) (@beq_symb_ok Sig).

Definition eq_symb_dec Sig := dec_beq (@beq_symb_ok Sig).

Arguments eq_symb_dec [Sig] _ _.

(***********************************************************************)
(** Tactic for proving beq_symb_ok *)

Ltac beq_symb_ok := intros f g; split;
  [destruct f; destruct g; simpl; intro; (discr || refl)
    | intro; subst g; destruct f; refl].

(***********************************************************************)
(** Modules and module types for signatures *)

Module Type SIG.
  Parameter Sig : Signature.
End SIG.

(* DecidableType *)
From Coq Require Import DecidableType.
Module DecType (Import S : SIG) <: DecidableType.
  Definition t := @symbol Sig.
  Definition eq := @eq t.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.
  Definition eq_dec := EqUtil.dec_beq (@beq_symb_ok Sig).
End DecType.

(* finite signature *)
Module Type FSIG.
  Parameter Sig : Signature.
  Parameter Fs : list Sig.
  Parameter Fs_ok : forall f, In f Fs.
End FSIG.

(***********************************************************************)
(** Weighted signatures *)

Module Type WSIG.
  Parameter Sig : Signature.
  Parameter weight : Sig -> nat.
  Parameter weight_inj : forall f g, weight f = weight g -> f = g.
End WSIG.

From CoLoR Require Import NatUtil BoolUtil.

Section weight_inj.

  Variable Sig : Signature.
  Variable Fs : list Sig.
  Variable Fs_ok : forall f, In f Fs.
  Variable weight : Sig -> nat.

  Definition bweight_inj :=
    forallb (fun f => forallb (fun g =>
      implb (beq_nat (weight f) (weight g)) (beq_symb f g)) Fs) Fs.

  Lemma bweight_inj_ok : bweight_inj = true <->
    (forall f g, weight f = weight g -> f = g).

  Proof.
    unfold bweight_inj. apply forallb_ok_fintype. 2: hyp. intro f.
    apply forallb_ok_fintype. 2: hyp. intro g. unfold implb.
    case_eq (beq_nat (weight f) (weight g)).
    rewrite beq_nat_ok, beq_symb_ok. tauto.
    rewrite (beq_ko beq_nat_ok). tauto.
  Qed.

End weight_inj.

(*Arguments bweight_inj_ok [Sig Fs] _ [weight].*)

Ltac weight_inj Fs_ok := rewrite <- (bweight_inj_ok Fs_ok);
  (check_eq || fail 10 "non-injective weight function").

(***********************************************************************)
(** Ordered signatures *)

From Coq Require Import OrderedType.

Module OrdType (Import S : WSIG) <: OrderedType.

  Include (DecType S).

  Definition lt f g := weight f < weight g.

  Lemma lt_trans : forall x y z, lt x y -> lt y z -> lt x z.

  Proof. unfold lt. intros. lia. Qed.

  Lemma lt_not_eq : forall x y, lt x y -> x <> y.

  Proof. unfold lt. intros x y l e. subst. lia. Qed.

  Definition blt f g := bgt_nat (weight g) (weight f).

  Lemma blt_ok : forall f g, blt f g = true <-> lt f g.

  Proof. intros f g. unfold blt, lt. apply bgt_nat_ok. Qed.

  Lemma lt_total : forall f g,
    beq_symb f g = false -> blt f g = false -> blt g f = true.

  Proof.
    intros f g. unfold blt.
    rewrite bgt_nat_ok, bgt_nat_ko, (beq_ko (@beq_symb_ok Sig)). intros.
    destruct (eq_nat_dec (weight f) (weight g)).
    ded (weight_inj e). subst g. cong.
    lia.
  Qed.

  Definition compare : forall x y, Compare lt (@Logic.eq t) x y.

  Proof.
    intros x y. case_eq (beq_symb x y); intro H.
    rewrite beq_symb_ok in H. apply (EQ H).
    case_eq (blt x y); intro H0.
    rewrite blt_ok in H0. apply (LT H0).
    eapply GT. rewrite <- blt_ok. apply lt_total; hyp.
  Defined.

End OrdType.


Require Export SepTypes.OrderedType.
Require Export SepTypes.OExpr.

(***
 *** The monad typeclass
 ***)

Class MonadOps M `{OTypeF M} : Type :=
  { return_ofun : forall {A} `{OType A}, A -o> M A _;
    bind_ofun : forall {A B} `{OType A} `{OType B},
        M A _ -o> (A -o> M B _) -o> M B _ }.

Notation oreturn := (oconst return_ofun).
Notation obind := (oconst bind_ofun).
(*
Definition oreturn {ctx} `{MonadOps} {A} `{OType A} : OExpr ctx (A -o> M A _) :=
  oconst return_ofun.
Definition obind {ctx} `{MonadOps} {A B} `{OType A} `{OType B} :
  OExpr ctx (M A _ -o> (A -o> M B _) -o> M B _) :=
  oconst bind_ofun.
*)
Notation "'do' x <- m1 ; m2" :=
  (obind @o@ m1 @o@ mkLam (fun x => m2))
    (at level 60, m1 at level 59, right associativity).

Class Monad M `{MonadOps M} : Prop :=
  {
    monad_return_bind :
      forall {ctx A B} `{OType A} `{OType B} (f: OExpr ctx (A -o> M B _)) x,
        obind @o@ (oreturn @o@ x) @o@ f =o= f @o@ x;

    monad_bind_return :
      forall {ctx A} `{OType A} (m: OExpr ctx (M A _)),
        obind @o@ m @o@ oreturn =o= m;

    monad_assoc_raw :
      forall {ctx A B C} `{OType A} `{OType B} `{OType C}
             m (f: OExpr ctx (A -o> M B _)) (g: OExpr ctx (B -o> M C _)),
        obind @o@ (obind @o@ m @o@ f) @o@ g
        =o=
        obind @o@ m @o@ (ofun x => obind @o@ (ovar f @o@ ovar x) @o@ ovar g);
  }.

(* This version of associativity of bind is easier to use in practice, because
it does the weakening for you *)
Lemma monad_assoc `{Monad} {ctx A B C} `{OType A} `{OType B} `{OType C}
      m (f: OExpr ctx (A -o> M B _)) (f': OExpr (ctx :> A) (A -o> M B _))
      (g: OExpr ctx (B -o> M C _)) (g': OExpr (ctx :> A) (B -o> M C _))
      {wf: WeakensTo f (PreExtendsToBase _) f'}
      {wg: WeakensTo g (PreExtendsToBase _) g'} :
  obind @o@ (obind @o@ m @o@ f) @o@ g
  =o=
  obind @o@ m @o@ (ofun x => obind @o@ (f' @o@ ovar x) @o@ g').
Proof.
  unfold WeakensTo in * |- *. simpl in wf; simpl in wg.
  rewrite monad_assoc_raw. f_equiv. apply mkLamExt. f_equiv.
  - f_equiv. rewrite <- wf. reflexivity.
  - rewrite <- wg. reflexivity.
Qed.

(***
 *** The Identity Monad
 ***)

Definition Identity A `{OType A} := A.

Instance OTypeF_Identity : OTypeF Identity :=
  fun _ ot => ot.

Instance IdMonad_MonadOps : MonadOps Identity :=
  { return_ofun := fun A _ => oexpr (ofun x => x);
    bind_ofun := fun A B _ _ =>
                   oexpr (ofun m => ofun (f : A -o> B ) => ovar f @o@ ovar m) }.

Instance IdMonad : Monad Identity.
Proof.
  constructor; intros; apply funOExt; intros; simpl; reflexivity.
Qed.


Require Import bedrock2.NotationsCustomEntry.

Import Syntax Syntax.Coercions BinInt String List.ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.

Definition indirect_add : func :=
  ("indirect_add", (["a"; "b"; "c"], [], bedrock_func_body:(
  store(a, load(b) + load(c))
))).

Definition indirect_add_twice : func :=
  ("indirect_add_twice", (["a";"b"], [], bedrock_func_body:(
  indirect_add(a, a, b);
  indirect_add(a, a, b)
))).

Require Import bedrock2.WeakestPrecondition.
Require Import coqutil.Word.Interface coqutil.Map.Interface bedrock2.Map.SeparationLogic.
Require Import bedrock2.Semantics bedrock2.FE310CSemantics.

Require bedrock2.WeakestPreconditionProperties.
From coqutil.Tactics Require Import letexists eabstract.
Require Import bedrock2.ProgramLogic bedrock2.Scalars.

Section WithParameters.
  Context {word: word.word 32} {mem: map.map word Byte.byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.

  Definition f (a b : word) := word.add (word.add a b) b.

  Local Notation "m =* P" := (P%sep m) (at level 70, only parsing). (* experiment *)
  Instance spec_of_indirect_add : spec_of "indirect_add" :=
    fnspec! "indirect_add" a b c / va Ra vb Rb vc Rc,
    { requires t m := m =* scalar a va * Ra /\ m =* scalar b vb * Rb /\ m =* scalar c vc * Rc;
      ensures t' m' := t=t' /\ m' =* scalar a (word.add vb vc) * Ra }.
  Instance spec_of_indirect_add_twice : spec_of "indirect_add_twice" :=
    fnspec! "indirect_add_twice" a b / va vb R,
    { requires t m := m =* scalar a va * scalar b vb * R;
      ensures t' m' := t=t' /\ m' =* scalar a (f va vb) * scalar b vb * R }.

  Lemma indirect_add_ok : program_logic_goal_for_function! indirect_add.
  Proof. repeat straightline; []; eauto. Qed.

  Lemma indirect_add_twice_ok : program_logic_goal_for_function! indirect_add_twice.
  Proof.
    repeat straightline.
    straightline_call.
    { split; [ecancel_assumption|]. split; ecancel_assumption. }
    repeat straightline.
    straightline_call.
    { split; [ecancel_assumption|]. split; ecancel_assumption. }
    repeat straightline.
    { split; trivial. split; trivial. cbv [f]. ecancel_assumption. }
  Qed.

  Example link_both : spec_of_indirect_add_twice (indirect_add_twice::indirect_add::nil).
  Proof. auto using indirect_add_twice_ok, indirect_add_ok. Qed.

  (* Print Assumptions link_swap_swap_swap_swap. *)
  (* SortedList.* SortedListString.* *)

  (*
  From bedrock2 Require Import ToCString Bytedump.
  Local Open Scope bytedump_scope.
  Goal True.
    let c_code := eval cbv in (String.list_byte_of_string (c_module (indirect_add_twice::indirect_add::nil))) in
    idtac c_code.
  Abort.
  *)

  Definition indirect_add_three : Syntax.func :=
    ("indirect_add_three", (["a";"b";"c"], [], bedrock_func_body:(
    indirect_add(a, a, b);
    indirect_add(a, a, c)
  ))).

  Definition g (a b c : word) := word.add (word.add a b) c.
  Instance spec_of_indirect_add_three : spec_of "indirect_add_three" :=
    fnspec! "indirect_add_three" a b c / va vb vc Rb R,
    { requires t m := m =* scalar a va * scalar c vc * R /\ m =* scalar b vb * Rb;
      ensures t' m' := t=t' /\ m' =* scalar a (g va vb vc) * scalar c vc * R }.

  Lemma indirect_add_three_ok : program_logic_goal_for_function! indirect_add_three.
  Proof.
    repeat straightline.
    straightline_call.
    { split; [ecancel_assumption|]. split; ecancel_assumption. }
    repeat straightline.
    straightline_call.
    { split; [ecancel_assumption|]. split; ecancel_assumption. }
    repeat straightline.
    { split; trivial. split; trivial. cbv [g]. ecancel_assumption. }
  Qed.

  Definition indirect_add_three' : Syntax.func :=
    ("indirect_add_three'", (["out";"a";"b";"c"], [], bedrock_func_body:(
    stackalloc 4 as v;
    indirect_add(v, a, b);
    indirect_add(out, v, c)
  ))).

  Instance spec_of_indirect_add_three' : spec_of "indirect_add_three'" :=
    fnspec! "indirect_add_three'" out a b c / vout va vb vc Ra Rb Rc R,
    { requires t m :=
        m =* scalar out vout * R /\
        m =* scalar a va * Ra /\
        m =* scalar b vb * Rb /\
        m =* scalar c vc * Rc;
      ensures t' m' := t=t' /\ m' =* scalar out (g va vb vc) * R }.

  Lemma indirect_add_three'_ok : program_logic_goal_for_function! indirect_add_three'.
  Proof.
    repeat straightline.
    (* note: we want to introduce only one variable for stack contents
     * and use it in a all separation-logic facts in the symbolic state *)

    repeat match goal with
           | H : _ |- _ =>
               seprewrite_in_by scalar_of_bytes H
                 ltac:(Lia.lia);
                 let x := fresh "x" in
                 set (word.of_Z _) as x in H; clearbody x; move x at top
           end.
    clear dependent mStack.

    (*
H1 : (scalar a0 x ⋆ (scalar out vout ⋆ R))%sep m2
H2 : (scalar a0 x0 ⋆ (scalar a va ⋆ Ra))%sep m2
H3 : (scalar a0 x1 ⋆ (scalar b vb ⋆ Rb))%sep m2
H4 : (scalar a0 x2 ⋆ (scalar c vc ⋆ Rc))%sep m2
     *)

    straightline_call.
    { split; [exact H1|split]; ecancel_assumption. }

    repeat straightline.
    (*
H15 : (scalar a0 (word.add va vb) ⋆ (scalar out vout ⋆ R))%sep a2
     *)
    (* H15 is an updated version of H1,
       but we really wanted to carry over H2,H3, and H4 as well *)
  Abort.

  (* trying again with non-separating conjunction *)
  Lemma indirect_add_three'_ok : program_logic_goal_for_function! indirect_add_three'.
  Proof.
    do 12 straightline.

    assert (
      id (fun m => (scalar out vout ⋆ R)%sep m /\ (scalar a va ⋆ Ra)%sep m /\  (scalar b vb ⋆ Rb)%sep m /\  (scalar c vc ⋆ Rc)%sep m) m) by (cbv [id]; eauto); clear H1 H2 H3 H4.

    repeat straightline.
    (* note: we want to introduce only one variable for stack contents
     * and use it in a all separation-logic facts in the symbolic state *)

    repeat match goal with
           | H : _ |- _ =>
               seprewrite_in_by scalar_of_bytes H
                 ltac:(Lia.lia);
                 let x := fresh "x" in
                 set (word.of_Z _) as x in H; clearbody x; move x at top
           end.
    clear dependent mStack.

    cbv [id] in *.
    (*
H7 : (scalar a0 x
      ⋆ (fun m : mem =>
         (scalar out vout ⋆ R) m /\
         (scalar a va ⋆ Ra) m /\ (scalar b vb ⋆ Rb) m /\ (scalar c vc ⋆ Rc) m))%sep
       m
     *)
    pose proof H7 as H7'.
    eapply sep_and_r_fwd in H7; destruct H7 as [? H7].
    eapply sep_and_r_fwd in H7; destruct H7 as [? H7].
    eapply sep_and_r_fwd in H7; destruct H7 as [? H7].

    straightline_call.
    { split; [>|split]; ecancel_assumption. }

    repeat straightline.

    (*
H9 : (scalar a0 (word.add va vb)
      ⋆ (fun m : mem =>
         (scalar out vout ⋆ R) m /\
         (scalar a va ⋆ Ra) m /\ (scalar b vb ⋆ Rb) m /\ (scalar c vc ⋆ Rc) m))%sep
       a2
     *)
    rename m into m'.
    rename a2 into m.
    eapply sep_and_r_fwd in H9; destruct H9 as [? H9].
    eapply sep_and_r_fwd in H9; destruct H9 as [? H9].
    eapply sep_and_r_fwd in H9; destruct H9 as [? H9].

    straightline_call.
    { split; [>|split]; try ecancel_assumption. }
    repeat straightline.

    (* casting scalar to bytes for stack deallocation *)
    cbv [scalar truncated_word truncated_scalar littleendian ptsto_bytes.ptsto_bytes] in *.
    rewrite !HList.tuple.to_list_of_list.
    repeat match goal with H : _ |- _ => rewrite !HList.tuple.to_list_of_list in H end.
    set ((LittleEndianList.le_split (bytes_per access_size.word) (word.unsigned (word.add va vb)))) as stackbytes in *.
    assert (Datatypes.length stackbytes = 4%nat) by exact eq_refl.
    repeat straightline; eauto.
  Qed.

  (* let's see how this would look like with an alternate spec of [indirect_add] *)

  Remove Hints spec_of_indirect_add : typeclass_instances.
  Instance spec_of_indirect_add_gen : spec_of "indirect_add" :=
    fnspec! "indirect_add" a b c / va Ra vb Rb vc Rc,
    { requires t m := m =* scalar a va * Ra /\ m =* scalar b vb * Rb /\ m =* scalar c vc * Rc;
      ensures t' m' := t=t' /\
        forall va Ra, m =* scalar a va * Ra -> m' =* scalar a (word.add vb vc) * Ra }.

  Lemma indirect_add_gen_ok : program_logic_goal_for_function! indirect_add.
  Proof.
    repeat straightline; []; split; [>|split]; trivial; [].
    (* This goal is unprovable as shown.
       It could be made provable by revealing how the memory was updated
         by modifying the straightline rule for store.
       I don't know how I would do this systematically for non-leaf functions, though. *)
 Abort.

  (* an potential alternative to changing this spec would be to
     - prove  wp.call (post:=p) /\ wp.call(post=q) -> wp.call (post:=p/\q)
     - instantiate the spec of indirect_add multiple times at the call site
       (existentials in postcondition are duplicated for each instantiation)
     but for now, let's prototype with changed spec:
  *)

  Lemma indirect_add_three'_ok' : program_logic_goal_for_function! indirect_add_three'.
  Proof.
    repeat straightline.
    (* note: we want to introduce only one variable for stack contents
     * and use it in a all separation-logic facts in the symbolic state.
     * here we get away with doing it wrong anyway. *)

    repeat match goal with
           | H : _ |- _ =>
               seprewrite_in_by scalar_of_bytes H
                 ltac:(Lia.lia);
                 let x := fresh "x" in
                 set (word.of_Z _) as x in H; clearbody x; move x at top
           end.
    clear dependent mStack.

    straightline_call.
    { split; [exact H1|split]; ecancel_assumption. }
    repeat straightline.
    rename a2 into m.
    (*
H15 : forall (va0 : word) (Ra : mem -> Prop),
      (scalar a0 va0 ⋆ Ra)%sep m2 -> (scalar a0 (word.add va vb) ⋆ Ra)%sep m
     *)
    eapply H15 in H1.
    eapply H15 in H2.
    eapply H15 in H3.
    eapply H15 in H4.
    clear H15.

    straightline_call.
    { split; [>|split]; try ecancel_assumption. }
    repeat straightline.
    rename a3 into m'.
    (*
H15 : forall (va0 : word) (Ra : mem -> Prop),
      (scalar out va0 ⋆ Ra)%sep m ->
      (scalar out (word.add (word.add va vb) vc) ⋆ Ra)%sep m'
     *)
    specialize (H15 _ _ ltac:(ecancel_assumption)).

    (* unrelated: stack deallocation proof, would need scalar-to-bytes lemma *)
  Abort.

End WithParameters.


Require Import squiggle4.
Require Import ReflParam.unusedVar.
Require Import JMeq.
Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import ReflParam.indProp.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.Trecord.

Require Import ReflParam.unusedVar.
Declare ML Module "myplug".
Section Test.
Variables (A A₂ : Set)
(Ra : A -> A₂ -> Prop)
(pta : TotalHeteroRel Ra)
(B B₂ : Set)
(Rb : B -> B₂ -> Prop)
(ptb : TotalHeteroRel Rb)
(poa : oneToOne Ra)
.
Check(
fun (pob : oneToOne Rb) =>
let A_R := (@Build_GoodRel allProps _ _ Ra pta poa) in
let B_R := (@Build_GoodRel allProps _ _ Rb ptb pob) in
Top_squiggle4_obsEq_pmtcty_RR _ _ A_R _ _ B_R
).
Time
ReduceAwayLamVar sthm := (
fun (pob : oneToOne Rb) =>
let A_R := (@Build_GoodRel allProps _ _ Ra pta poa) in
let B_R := (@Build_GoodRel allProps _ _ Rb ptb pob) in
Top_squiggle4_obsEq_pmtcty_RR _ _ A_R _ _ B_R
).

Check sthm.
Lemma testDefn (pob : oneToOne Rb):
let A_R := (@Build_GoodRel allProps _ _ Ra pta poa) in
let B_R := (@Build_GoodRel allProps _ _ Rb ptb pob) in
JMeq
  (Top_squiggle4_obsEq_pmtcty_RR _ _ A_R _ _ B_R)
  sthm.
Proof using.
  reflexivity.
Qed.

End Test.

Section Test2.
Variables (A A₂ : Set)
(Ra : A -> A₂ -> Prop)
(pta : TotalHeteroRel Ra)
(B B₂ : Set)
(Rb : B -> B₂ -> Prop)
(ptb : TotalHeteroRel Rb).

Check (
fun (poa : oneToOne Ra) =>
@sthm _ _ Ra pta _ _ Rb poa
).
Time Detect
(
fun (poa : oneToOne Ra) =>
sthm _ _ Ra pta _ _ Rb poa
).
(*The first argument may be omitted. The reduced term is:...
Finished transaction in 0.411 secs (0.327u,0.016s) (successful)
*)

Time
ReduceAwayLamVar sthm2 :=
(
fun (poa : oneToOne Ra) =>
sthm A A₂ Ra pta B B₂ Rb poa
).

(*
Finished transaction in 0.26 secs (0.219u,0.004s) (successful)
*)

End Test2.

Lemma obsEqExistsAOneFreeImpl  : existsAOneFreeImpl2
  (Top_squiggle4_obsEq_pmtcty_RR).
Proof.
  eexists.
  eexists (sthm2 A A₂ Ra pta B B₂ Rb). intros. reflexivity.
(*simpl in *.
  intros. simpl in *.
  eapply sthm2; eauto.
  set (fvv:= Top_squiggle4_obsEq_pmtcty_RR _ _ A_R _ _ B_R).
  Time lazy in fvv. *)
Qed.

(*
Lemma dependsOnlyOnTotdivergesIff  : existsAOneFreeImpl
  (Top_squiggle2_divergesIff_pmtcty_RR).
Proof.
  eexists.
  eexists.
  intros.
  set (fvv:= Top_squiggle2_divergesIff_pmtcty_RR _ _ V_R).
  simpl in *.
  lazy in fvv.
  reflexivity. (* works *)
Defined.
*)
(*
Lemma dependsOnlyOnTotdivergesIff (V V₂ : Set) : @dependsOnlyOnRelTot V V₂ _
  (Top_squiggle2_divergesIff_pmtcty_RR V V₂).
Proof.
  intros ? ? ?.
  destruct V_R1.
  reflexivity.
Qed.
*)


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Limit.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Definition Complete {C : Category} := ∀ (D : Category) (F : D ⟶ C), Limit F.

Definition Cocomplete {C : Category} := ∀ (D : Category) (F : D ⟶ C), Colimit F.


Require Import Coqlib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import HoareDef.
Require Import Mem1.
Require Import ProofMode.
Require Import KnotHeader.
Require Import Invariant.
Require Import STB.

Set Implicit Arguments.

Section KNOT.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG invRA Σ}.
  Context `{@GRA.inG memRA Σ}.
  Context `{@GRA.inG knotRA Σ}.

  Variable RecStb: Sk.t -> gname -> option fspec.
  Variable FunStb: Sk.t -> gname -> option fspec.
  Variable GlobalStb: Sk.t -> gname -> option fspec.

  Section SKENV.
    Variable sk: Sk.t.

    Definition rec_spec:    fspec :=
      mk_fspec_inv
        (mk_simple (X:=(nat -> nat) * nat)
                   (fun '(f, n) => (
                        (ord_pure (2 * n + 1)%nat),
                        (fun varg =>
                           (⌜varg = [Vint (Z.of_nat n)]↑ /\ (intrange_64 n)⌝)
                             ** (OwnM (knot_frag (Some f)))
                        ),
                        (fun vret =>
                           (⌜vret = (Vint (Z.of_nat (f n)))↑⌝)
                             ** (OwnM (knot_frag (Some f)))
                        )
                   ))).

    Definition fun_gen (f: nat -> nat): fspec :=
      mk_fspec_inv
        (mk_simple (X:=nat)
                   (fun n => (
                        (ord_pure (2 * n)%nat),
                        (fun varg =>
                           (⌜exists fb,
                                 varg = [Vptr fb 0; Vint (Z.of_nat n)]↑ /\ (intrange_64 n) /\
                                 fb_has_spec (Sk.load_skenv sk) (RecStb sk) fb rec_spec⌝)
                             ** OwnM (knot_frag (Some f))
                        ),
                        (fun vret =>
                           (⌜vret = (Vint (Z.of_nat (f n)))↑⌝)
                             ** OwnM (knot_frag (Some f))
                        )
                   ))).

    Definition KnotRecStb: list (gname * fspec) := [("rec", rec_spec)].

    Definition knot_spec:    fspec :=
      mk_fspec_inv
        (mk_simple (X:=(nat -> nat))
                   (fun f => (
                        (ord_pure 1%nat),
                        (fun varg =>
                           (⌜exists fb,
                                 varg = [Vptr fb 0]↑ /\
                                 fb_has_spec (Sk.load_skenv sk) (FunStb sk) fb (fun_gen f)⌝)
                             ** (∃ old, OwnM (knot_frag old))
                        ),
                        (fun vret =>
                           (⌜exists fb,
                                 vret = (Vptr fb 0)↑ /\
                                 fb_has_spec (Sk.load_skenv sk) (RecStb sk) fb rec_spec⌝)
                             ** OwnM (knot_frag (Some f))
                        )
                   ))).

    Definition knot_spec2:    fspec :=
      mk_simple (X:=(nat -> nat))
                (fun f => (
                     (ord_pure 1%nat),
                     (fun varg =>
                        (⌜exists fb,
                              varg = [Vptr fb 0]↑ /\
                              fb_has_spec (Sk.load_skenv sk) (FunStb sk) fb (fun_gen f)⌝)
                          ** OwnM (knot_init)
                          ** inv_closed
                     ),
                     (fun vret =>
                        (∃ INV,
                            (⌜exists fb,
                                  vret = (Vptr fb 0)↑ /\
                                  fb_has_spec (Sk.load_skenv sk) (RecStb sk) fb (mrec_spec f INV)⌝)
                              ** INV)%I
                     )
                )).

    Definition KnotStb: list (gname * fspec) := [("rec", rec_spec); ("knot", knot_spec)].

    Definition KnotSbtb: list (gname * fspecbody) :=[("rec", mk_specbody rec_spec (fun _ => trigger (Choose _)));
                                                    ("knot", mk_specbody knot_spec (fun _ => trigger (Choose _)))].

    Definition SKnotSem: SModSem.t := {|
      SModSem.fnsems := KnotSbtb;
      SModSem.mn := "Knot";
      SModSem.initial_mr := (GRA.embed (var_points_to (Sk.load_skenv sk) "_f" (Vint 0))) ⋅ (GRA.embed (knot_full None)) ;
      SModSem.initial_st := tt↑;
    |}
    .
  End SKENV.

  Definition SKnot: SMod.t := {|
    SMod.get_modsem := SKnotSem;
    SMod.sk := [("rec", Sk.Gfun); ("knot", Sk.Gfun); ("_f", Sk.Gvar 0)];
  |}
  .

  Definition Knot: Mod.t := (SMod.to_tgt GlobalStb) SKnot.
End KNOT.

Section WEAK.
  Context `{Σ: GRA.t}.
  Context `{@GRA.inG invRA Σ}.
  Context `{@GRA.inG knotRA Σ}.

  Lemma rec_spec_weaker f: fspec_weaker (mrec_spec f (OwnM (knot_frag (Some f)) ** inv_closed)) rec_spec.
  Proof.
    ii. ss. exists (f, x_src). esplits; ss; et.
    { refl. }
    { intros arg_src arg_tgt. ss.
      iIntros "H". iDestruct "H" as "[[% [H0 H1]] %]".
      iModIntro. iFrame. et. }
    { intros ret_src ret_tgt. ss.
      iIntros "H". iDestruct "H" as "[H0 [[% H2] %]]".
      iModIntro. iFrame. et. }
  Qed.
End WEAK.

Section WEAK.
  Context `{Σ: GRA.t}.
  Context `{@GRA.inG invRA Σ}.
  Context `{@GRA.inG knotRA Σ}.

  Variable RecStb: Sk.t -> gname -> option fspec.
  Variable FunStb: Sk.t -> gname -> option fspec.

  Lemma knot_spec2_weaker sk: fspec_weaker (knot_spec2 RecStb FunStb sk) (knot_spec RecStb FunStb sk).
  Proof.
    ii. ss. exists x_src. esplits; ss; et.
    { refl. }
    { intros arg_src arg_tgt.
      iIntros "H". iDestruct "H" as "[[[% H0] H1] %]".
      des. subst. iModIntro. iSplitL "H1"; ss. iSplitL; ss; et. iSplitR; et.
    }
    { intros ret_src ret_tgt.
      iIntros "H". iDestruct "H" as "[H0 [[% H1] %]]".
      des. subst.
      iModIntro. iSplitL; ss.
      iExists (OwnM (knot_frag (Some x_src)) ** inv_closed).
      iFrame. iPureIntro. des. eexists.
      split; eauto. eapply fb_has_spec_weaker; eauto.
      eapply rec_spec_weaker.
    }
  Qed.
End WEAK.


Require Import Bool.

Require Import propInv5.
Require Import to_array.
Local Open Scope Z.

Definition _timer1 :=36000.
Definition _timer0 := _timer1-1.
Definition _logvar := OFF.
Definition _ctrlTimer0 :=(10-1).
Definition _ctrlTimer1 := _ctrlTimer0 + 1.

Lemma _timer1_can_be_length : 0<=(_timer1+1) <=(to_Z max_length).
Proof.
split.
unfold _timer1.
auto with zarith.
replace (_timer1+1) with (to_Z (of_Z (_timer1 +1))).
apply leb_spec.
auto.
symmetry.
apply is_int.
split.
unfold _timer1.
auto with zarith.
unfold _timer1.
replace (2^(to_Z digits)) with wB.
unfold wB.
unfold size.
auto with zarith.
auto.
Qed.

Definition hands_fun (n : Z) := negb ((_timer0 - _ctrlTimer0+1 <=?n) && (n<=? _timer0))%bool.
Definition h := to_array hands_fun (_timer1+1) _timer1_can_be_length.
Definition _dryer0 := make (of_Z (_timer1+1)) ON.
Definition _dryer1 := _dryer0.[of_Z _timer1 <- _dryer0.[of_Z (_timer1-1)]].
Definition _ctrlState0 := (make (of_Z (_timer1+1)) ctrlDrying).
Definition _ctrlState1 := _ctrlState0.[of_Z _timer1 <- _ctrlState0.[of_Z (_timer1-1)]].
Definition _dryer2 := _dryer1.[of_Z _timer1 <- ON].
Definition _ctrlState2 := _ctrlState1.[of_Z _timer1 <- ctrlWaiting].
Definition _ctrlTimer2 := 0.

Theorem proof5_6 :
 exists hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1 ctrlState2 ctrlTimer2
(logvar : bool),
 ~((startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1 logvar) /\
    ctrlState1.[of_Z timer1]<>ctrlWaiting /\ ctrlState1.[of_Z timer1]=ctrlDrying /\ hands1.[of_Z timer1]<>ON /\ ctrlTimer1>=10 /\
 ctrlTimer2=0 /\ ctrlState2=ctrlState1.[of_Z timer1 <- ctrlWaiting] ->
    (inv hands1 dryer1 ctrlState2 ctrlTimer2 timer1)).

Proof.
elim h.
intro _hands0.
intro.
exists _hands0.
exists  _hands0.[of_Z _timer1 <- _logvar].
exists _dryer0.
exists _dryer1.
exists _ctrlState0.
exists _ctrlState1.
exists _ctrlTimer0.
exists _ctrlTimer1.
exists _timer0.
exists _timer1.
exists _ctrlState2.
exists _ctrlTimer2.
exists _logvar.
unfold not.
intros.
assert (Hcond :
 (startnewloop _hands0 _hands0.[of_Z _timer1 <- _logvar]  _dryer0 _dryer1 _ctrlState0 _ctrlState1 _ctrlTimer0 _ctrlTimer1
   _timer0 _timer1 _logvar) /\
   _ctrlState1.[of_Z _timer1]<>ctrlWaiting /\ _ctrlState1.[of_Z _timer1]=ctrlDrying /\
   _hands0.[of_Z _timer1 <- _logvar].[of_Z _timer1]<>ON /\   _ctrlTimer1>=10 /\  _ctrlTimer2=0 /\
   _ctrlState2=_ctrlState1.[of_Z _timer1 <- ctrlWaiting]).

split.
split.
split.
(*proving propInv for timer0*)
unfold propInv5.
intros.
unfold _timer0 in H0.
unfold _timer1 in H0.
elimtype False.
auto with zarith.
(*proving extraInv for timer0*)
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
unfold _timer0.
unfold _timer1.
auto with zarith.
split.
unfold _ctrlTimer0.
auto with zarith.
split.
intros.
right.
unfold _ctrlState0.
apply get_make.
intros.
assert (hands_values :
 (length _hands0 = of_Z (_timer1+1)) /\
 (forall i, _timer0-_ctrlTimer0+1<=i /\ i<=_timer0 -> _hands0.[of_Z i]=OFF) /\
  (forall i, 0<=i /\ i<= _timer0 - _ctrlTimer0 -> _hands0.[of_Z i]=ON)).
split.
apply p.
split.
intros.
inversion_clear p.
rewrite H3.
unfold hands_fun.
apply negb_false_iff.
apply andb_true_iff.
split; apply Z.leb_le; apply H1.
unfold _timer0 in H1.
unfold _ctrlTimer0 in H1.
unfold _timer1.
unfold _timer1 in H1.
auto with zarith.
intros.
inversion_clear p.
rewrite H3.
unfold hands_fun.
apply negb_true_iff.
apply andb_false_iff.
left.
apply not_true_is_false.
unfold not.
intro.
apply Z.leb_le in H4.
auto with zarith.
unfold _timer0 in H1.
unfold _ctrlTimer0 in H1.
auto with zarith.
inversion_clear hands_values.
inversion_clear H2.
repeat split.
apply H4.
unfold _timer0.
unfold _ctrlTimer0.
unfold _timer1.
auto with zarith.
apply H3.
assumption.
unfold _dryer0.
apply get_make.
repeat split.
repeat split.
unfold _ctrlState1.
rewrite get_set_same.
unfold _ctrlState0.
rewrite get_make.
discriminate.
auto.
unfold _ctrlState1.
rewrite get_set_same.
unfold _ctrlState0.
rewrite get_make.
reflexivity.
auto.
rewrite get_set_same.
discriminate.
inversion_clear p.
rewrite H0.
auto.
unfold _ctrlTimer1.
unfold _ctrlTimer0.
auto with zarith.

(*proving negating requirement for timer1*)
apply H in Hcond.
inversion_clear Hcond.
unfold propInv5 in H0.
specialize (H0 (_timer1-(36000-1))).
assert (Hpremise :
  (0< (_timer1-(36000-1)) /\ (_timer1-(36000-1))<=(_timer1-(36000-1)) /\ _dryer1.[of_Z (_timer1-(36000-1))]=ON)).
unfold _timer1.
auto with zarith.
apply H0 in Hpremise.
elim Hpremise.
intros.
inversion_clear H2.
inversion_clear H4.
inversion_clear H5.
replace _dryer1.[of_Z x] with _dryer0.[of_Z x] in H6.
unfold _dryer0 in H6.
rewrite get_make in H6.
contradict H6.
discriminate.
auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D E F Aprime Cprime Dprime Fprime A0 C0 D0 F0 : Universe, ((wd_ Cprime B /\ (wd_ C B /\ (wd_ Dprime E /\ (wd_ D E /\ (wd_ Fprime E /\ (wd_ F E /\ (wd_ Aprime B /\ (wd_ A B /\ (wd_ B A0 /\ (wd_ E F0 /\ (wd_ E D0 /\ (wd_ B C0 /\ (wd_ D D0 /\ (wd_ C C0 /\ (wd_ A A0 /\ (wd_ F F0 /\ (col_ E F F0 /\ (col_ E D D0 /\ (col_ B C C0 /\ (col_ B A A0 /\ (col_ E Fprime F /\ (col_ E Dprime D /\ (col_ B Cprime C /\ col_ B Aprime A))))))))))))))))))))))) -> col_ B Cprime C0)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Axioms.
Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Ofe.
Require Import Syntax.
Require Import Ofe.
Require Import Uniform.
Require Import Spaces.
Require Import Urelsp.
Require Import Ceiling.
Require Import Candidate.
Require Import Intensional.
Require Import IntensionalNerect.
Require Import Ordinal.
Require Import Candidate.

Section level.

Variable cur : ordinal.

Definition meta_truncate_main (a : car (meta_ofe (obj cur))) : car (pi_ofe nat (fun _ => meta_ofe (obj cur))).
Proof.
apply
   (meta_nerect cur (pi_ofe nat (fun _ => meta_ofe (obj cur)))
      (fun I n => meta_nats (nats_min I (nat_nats (S n))))
      (fun R f g n =>
         meta_fn
           (ceiling (S n) R)
           (nearrow_compose
              (neapi g n)
              (embed_ceiling_ne (S n) R)))
      (fun _ x _ y n => meta_pair (x n) (y n))
      (fun _ x n =>
         meta_half
           (match n with
            | 0 => meta_nats (nat_nats 0)
            | S n' => x n'
            end))
      (fun pg n => meta_page pg)).

(* nats *)
{
intros i I J Hdist.
intro n.
apply meta_dist_nats.
intros j Hj.
cbn.
split; intro H; destruct H; split; auto; apply Hdist; auto.
}

(* fn *)
{
intros i A B e f g h HAB Hef Hgh n.
apply meta_dist_fn.
  {
  apply ceiling_nonexpansive; auto.
  }

  {
  intros C D HCD.
  cbn.
  apply Hgh; auto.
  }
}

(* pair *)
{
intros i p p' q q' x x' y y' _ _ Hx Hy n.
apply meta_dist_pair; auto.
}

(* half *)
{
intros i p p' x x' _ Hx n.
apply meta_dist_half.
destruct n as [| n].
  {
  apply dist_refl.
  }

  {
  apply Hx.
  }
}

(* argument *)
{
exact a.
}
Defined.

Lemma meta_truncate_main_nonexpansive :
  nonexpansive meta_truncate_main.
Proof.
apply meta_nerect_nonexpansive.
Qed.

Definition meta_truncate (n : nat) (a : car (meta_ofe (obj cur))) : car (meta_ofe (obj cur))
  :=
  match n with
  | 0 => meta_nats (nat_nats 0)
  | S n' => meta_truncate_main a n'
  end.

Lemma meta_truncate_nonexpansive :
  forall n, nonexpansive (meta_truncate n).
Proof.
intro n.
unfold meta_truncate, meta_truncate_main.
destruct n as [| n'].
  {
  apply const_nonexpansive.
  }

  {
  intros i x y Hxy.
  exact (meta_truncate_main_nonexpansive i x y Hxy n').
  }
Qed.

Definition meta_truncate_ne (n : nat) : meta_ofe (obj cur) -n> meta_ofe (obj cur)
  :=
  expair (meta_truncate n) (meta_truncate_nonexpansive n).

Lemma meta_truncate_zero :
  forall a, meta_truncate 0 a = meta_nats (nat_nats 0).
Proof.
intros a.
unfold meta_truncate.
reflexivity.
Qed.

Lemma meta_truncate_nats :
  forall n I, meta_truncate n (meta_nats I) = meta_nats (nats_min I (nat_nats n)).
Proof.
intros n I.
unfold meta_truncate.
destruct n as [| n].
  {
  f_equal.
  apply exT_extensionality_prop.
  cbn.
  fextensionality 1.
  intro i.
  pextensionality; omega.
  }
unfold meta_truncate_main.
rewrite -> meta_nerect_nats.
reflexivity.
Qed.

Lemma meta_truncate_fn :
  forall n R f (Hpos : n > 0),
    meta_truncate n (meta_fn R f)
    =
    meta_fn
      (ceiling n R)
      (nearrow_compose
         (meta_truncate_ne n)
         (nearrow_compose f (embed_ceiling_ne n R))).
Proof.
intros n R f Hpos.
unfold meta_truncate.
destruct n as [| n].
  {
  omega.
  }
unfold meta_truncate_main.
rewrite -> meta_nerect_fn.
f_equal.
apply exT_extensionality_prop.
reflexivity.
Qed.

Lemma meta_truncate_term :
  forall n R C (Hpos : n > 0),
    meta_truncate n (meta_term R C)
    =
    meta_term (ceiling n R) (proj_ceiling n Hpos R C).
Proof.
intros k R C Hpos.
unfold meta_term.
rewrite -> meta_truncate_fn; auto.
f_equal.
apply nearrow_extensionality.
intro D.
cbn.
rewrite -> meta_truncate_nats.
f_equal.
apply exT_extensionality_prop.
fextensionality 1.
intro i.
cbn.
unfold urelsp_sim_pred.
pextensionality.
  {
  intros ((m & HCm & HDm) & Hi).
  cbn.
  eauto.
  }

  {
  intros (m & HCm & HDm).
  destruct HCm as (Hi & HCm).
  cbn.
  eauto.
  }
Qed.

Lemma meta_truncate_pair :
  forall n x y (Hpos : n > 0),
    meta_truncate n (meta_pair x y)
    =
    meta_pair (meta_truncate n x) (meta_truncate n y).
Proof.
intros n x y Hpos.
unfold meta_truncate.
destruct n as [| n].
  {
  omega.
  }
unfold meta_truncate_main.
rewrite -> meta_nerect_pair.
reflexivity.
Qed.

Lemma meta_truncate_half :
  forall n x (Hpos : n > 0),
    meta_truncate n (meta_half x)
    =
    meta_half (meta_truncate (pred n) x).
Proof.
intros n x Hpos.
unfold meta_truncate.
destruct n as [| n].
  {
  omega.
  }
unfold meta_truncate_main.
rewrite -> meta_nerect_half.
cbn.
reflexivity.
Qed.

Lemma meta_truncate_page :
  forall n pg (Hpos : n > 0),
    meta_truncate n (meta_page pg)
    =
    meta_page pg.
Proof.
intros n pg Hpos.
unfold meta_truncate.
destruct n as [| n].
  {
  omega.
  }
unfold meta_truncate_main.
rewrite -> meta_nerect_page.
reflexivity.
Qed.

Hint Rewrite meta_truncate_zero meta_truncate_nats meta_truncate_fn meta_truncate_pair meta_truncate_half meta_truncate_page : meta_truncate.

Lemma meta_truncate_near :
  forall n (a : car (meta_ofe (obj cur))), dist n (meta_truncate n a) a.
Proof.
intros n a.
revert n.
pattern a.
apply meta_rect; clear a.

(* nats *)
{
intros I n.
rewrite -> meta_truncate_nats.
apply meta_dist_nats.
intros i Hi.
cbn.
split; intro H; [destruct H | split]; auto.
}

(* fn *)
{
intros R f IH n.
apply dist_if_pos.
intro Hpos.
rewrite -> (meta_truncate_fn _#3 Hpos).
apply meta_dist_fn.
  {
  apply ceiling_near.
  }
intros C D HCD.
eapply dist_trans.
2:{
  apply IH.
  }
cbn -[dist].
apply meta_truncate_nonexpansive.
apply (pi2 f).
intros i Hi.
cbn.
apply HCD; auto.
}

(* pair *)
{
intros x IH1 y IH2 n.
apply dist_if_pos.
intro Hpos.
rewrite -> meta_truncate_pair; auto.
apply meta_dist_pair; auto.
}

(* half *)
{
intros x IH n.
apply dist_if_pos.
intro Hpos.
rewrite -> meta_truncate_half; auto.
destruct n as [| n].
  {
  omega.
  }
apply meta_dist_half; auto.
}

(* page *)
{
intros pg n.
apply dist_if_pos.
intro Hpos.
rewrite -> meta_truncate_page; auto.
apply dist_refl.
}
Qed.

Definition iutruncate (n : nat) (r : car (wiurel_ofe cur)) : car (wiurel_ofe cur)
  :=
  (ceiling n (fst r), meta_truncate n (snd r)).

Lemma iutruncate_nonexpansive :
  forall n, nonexpansive (iutruncate n).
Proof.
intros n.
intros i r s Hrs.
destruct Hrs as (H1 & H2).
split.
  {
  cbn.
  apply ceiling_nonexpansive; auto.
  }

  {
  cbn.
  apply meta_truncate_nonexpansive; auto.
  }
Qed.

Definition iutruncate_ne (n : nat) : wiurel_ofe cur -n> wiurel_ofe cur
  :=
  expair (iutruncate n) (iutruncate_nonexpansive n).

Lemma iutruncate_near :
  forall n (r : car (wiurel_ofe cur)),
    dist n (iutruncate n r) r.
Proof.
intros n r.
split.
  {
  apply ceiling_near.
  }

  {
  apply meta_truncate_near.
  }
Qed.

Lemma ceiling_collapse :
  forall i (A B : car (wurel_ofe cur)),
    dist i A B
    -> ceiling i A = ceiling i B.
Proof.
intros i A B Hdist.
apply urel_extensionality.
fextensionality 3.
intros j m n.
cbn.
pextensionality.
  {
  intros (Hj & Hmn).
  split; auto.
  rewrite <- Hdist; auto.
  }

  {
  intros (Hj & Hmn).
  split; auto.
  rewrite -> Hdist; auto.
  }
Qed.

Lemma meta_truncate_collapse :
  forall i (a b : car (meta_ofe (obj cur))),
    dist i a b
    -> meta_truncate i a = meta_truncate i b.
Proof.
intros i a b Hdist.
so (lt_dec 0 i) as [Hpos | Hnpos].
2:{
  assert (i = 0) by omega; subst i.
  rewrite -> !meta_truncate_zero.
  reflexivity.
  }
revert i b Hdist Hpos.
pattern a.
apply meta_rect; clear a.

(* nats *)
{
intros I i b Hdist Hpos.
so (meta_dist_nats_invert _#4 Hpos Hdist) as (J & -> & Hdist').
rewrite -> !meta_truncate_nats.
f_equal.
apply exT_extensionality_prop.
fextensionality 1.
intro n.
cbn.
pextensionality.
  {
  intros (H, Hn).
  split; auto.
  rewrite <- (Hdist' n); auto.
  }

  {
  intros (H, Hn).
  split; auto.
  rewrite -> (Hdist' n); auto.
  }
}

(* fn *)
{
intros A f IH i b Hdist Hpos.
so (meta_dist_fn_invert _#5 Hpos Hdist) as (B & g & -> & HAB & Hfg).
rewrite -> !meta_truncate_fn; auto.
so (ceiling_collapse _#3 HAB) as Heq.
apply meta_fn_extensionality.
apply (eq_impl_eq_dep _#6 Heq).
apply nearrow_extensionality.
intro C.
rewrite -> (pi1_transport_dep_lift _ _ (fun R h => @nonexpansive (urelsp R) (meta_ofe (obj cur)) h) _ _ Heq).
rewrite -> app_transport_dom.
cbn.
apply IH; auto.
apply Hfg.
intros j Hj.
cbn.
rewrite -> (pi1_transport_dep_lift _ _ urelsp_car_rhs _ _ (eqsymm Heq)).
rewrite -> transport_const.
reflexivity.
}

(* pair *)
{
intros x IH1 y IH2 i b Hdist Hpos.
so (meta_dist_pair_invert _#5 Hpos Hdist) as (x' & y' & -> & Hx & Hy).
rewrite -> !meta_truncate_pair; auto.
f_equal; auto.
}

(* half *)
{
intros x IH i b Hdist Hpos.
so (meta_dist_half_invert _#4 Hpos Hdist) as (x' & -> & Hx).
rewrite -> !meta_truncate_half; auto.
f_equal.
remember (pred i) as j eqn:Heq.
destruct j as [| j].
  {
  rewrite -> !meta_truncate_zero.
  reflexivity.
  }
apply IH; auto.
omega.
}

(* page *)
{
intros pg i b Hdist Hpos.
so (meta_dist_page_invert _#4 Hpos Hdist); subst b.
reflexivity.
}
Qed.

Lemma iutruncate_collapse :
  forall n a b,
    dist n a b
    -> iutruncate n a = iutruncate n b.
Proof.
intros n a b Hdist.
destruct Hdist as (Hdist1, Hdist2).
apply prod_extensionality.
  {
  cbn.
  apply ceiling_collapse; auto.
  }

  {
  cbn.
  apply meta_truncate_collapse; auto.
  }
Qed.

Lemma den_iutruncate :
  forall n a,
    den (iutruncate n a) = ceiling n (den a).
Proof.
intros n a.
reflexivity.
Qed.

Lemma meta_truncate_combine :
  forall i j (a : meta (obj cur)),
    meta_truncate i (meta_truncate j a)
    = meta_truncate (min i j) a.
Proof.
intros i j a.
so (lt_dec 0 i) as [Hposi | Hnpos].
2:{
  assert (i = 0) by omega; subst i.
  rewrite -> Nat.min_0_l.
  rewrite -> !meta_truncate_zero.
  reflexivity.
  }
so (lt_dec 0 j) as [Hposj | Hnpos].
2:{
  assert (j = 0) by omega; subst j.
  rewrite -> Nat.min_0_r.
  rewrite -> !meta_truncate_zero.
  rewrite -> meta_truncate_nats.
  rewrite -> nats_min_min.
  cbn.
  reflexivity.
  }
assert (min i j > 0) as Hposij.
  {
  apply Nat.min_glb_lt; auto.
  }
revert i j Hposi Hposj Hposij.
pattern a.
apply meta_rect; clear a.

(* nats *)
{
intros I i j _ _ _.
rewrite -> !meta_truncate_nats.
rewrite <- nats_min_assoc.
rewrite -> nats_min_min.
rewrite -> Nat.min_comm.
reflexivity.
}

(* fn *)
{
intros A f IH i j Hposi Hposj Hposij.
rewrite -> !meta_truncate_fn; auto.
apply meta_fn_extensionality.
so (ceiling_combine _ i j A) as Heq.
apply (eq_impl_eq_dep _#6 Heq).
apply nearrow_extensionality.
intro C.
rewrite -> (pi1_transport_dep_lift _ _ (fun R h => @nonexpansive (urelsp R) (meta_ofe (obj cur)) h) _ _ Heq).
rewrite -> app_transport_dom.
cbn.
rewrite -> IH; auto.
f_equal.
f_equal.
apply exT_extensionality_prop.
cbn.
fextensionality 2.
intros k m.
rewrite -> (pi1_transport_dep_lift _ _ urelsp_car_rhs _ _ (eqsymm Heq)).
rewrite -> transport_const.
reflexivity.
}

(* pair *)
{
intros x IH1 y IH2 i j Hposi Hposj Hposij.
rewrite -> !meta_truncate_pair; auto.
f_equal; auto.
}

(* half *)
{
intros x IH i j Hposi Hposj Hposij.
rewrite -> !meta_truncate_half; auto.
f_equal.
destruct i as [| i].
  {
  omega.
  }
destruct j as [| j].
  {
  omega.
  }
cbn.
destruct i as [| i].
  {
  rewrite -> Nat.min_0_l.
  cbn.
  reflexivity.
  }
destruct j as [| j].
  {
  rewrite -> Nat.min_0_r.
  rewrite -> meta_truncate_zero.
  rewrite -> meta_truncate_nats.
  rewrite -> nats_min_min.
  reflexivity.
  }
apply IH; try omega.
apply Nat.min_glb_lt; omega.
}

(* page *)
{
intros pg i j Hposi Hposj Hposij.
rewrite -> !meta_truncate_page; auto.
}
Qed.

Lemma iutruncate_combine :
  forall i j a,
    iutruncate i (iutruncate j a) = iutruncate (min i j) a.
Proof.
intros i j a.
apply prod_extensionality; cbn.
  {
  apply ceiling_combine.
  }

  {
  apply meta_truncate_combine.
  }
Qed.

Lemma iutruncate_combine_le :
  forall i j (a : wiurel cur),
    i <= j
    -> iutruncate i (iutruncate j a) = iutruncate i a.
Proof.
intros i j a Hle.
rewrite -> iutruncate_combine.
rewrite -> Nat.min_l; auto.
Qed.

Lemma iutruncate_combine_ge :
  forall i j (a : wiurel cur),
    j <= i
    -> iutruncate i (iutruncate j a) = iutruncate j a.
Proof.
intros i j a Hle.
rewrite -> iutruncate_combine.
rewrite -> Nat.min_r; auto.
Qed.

Lemma iutruncate_idem :
  forall i (A : wiurel cur), iutruncate i (iutruncate i A) = iutruncate i A.
Proof.
intros i A.
rewrite -> iutruncate_combine_le; auto.
Qed.

Lemma meta_truncate_null :
  forall n,
    meta_truncate n meta_null = meta_null.
Proof.
intros n.
unfold meta_null.
rewrite -> meta_truncate_nats.
f_equal.
apply exT_extensionality_prop.
cbn.
fextensionality 1.
intro i.
pextensionality; omega.
Qed.

Lemma meta_truncate_urel :
  forall n (R : wurel cur) (Hpos : n > 0),
    meta_truncate n (meta_urel R)
    =
    meta_urel (ceiling n R).
Proof.
intros n R Hpos.
unfold meta_urel.
rewrite -> meta_truncate_fn; auto.
f_equal.
apply nearrow_extensionality.
intro x.
cbn.
apply meta_truncate_null.
Qed.

Lemma meta_truncate_iurel :
  forall n (r : wiurel cur) (Hpos : n > 0),
    meta_truncate n (meta_iurel r)
    =
    meta_iurel (iutruncate n r).
Proof.
intros n r Hpos.
unfold meta_iurel.
rewrite -> meta_truncate_pair; auto.
f_equal.
apply meta_truncate_urel; auto.
Qed.

Lemma iutruncate_iubase :
  forall n (R : wurel cur),
    iutruncate n (iubase R) = iubase (ceiling n R).
Proof.
intros n R.
unfold iutruncate, iubase.
f_equal.
apply meta_truncate_null.
Qed.

Lemma iutruncate_zero :
  forall A,
    iutruncate 0 A = iubase empty_urel.
Proof.
intros A.
unfold iutruncate, iubase.
f_equal.
apply ceiling_zero.
Qed.

End level.

(* Truncate has to be 0-indexed.  If we used 1-indexing, the qfut case
   wouldn't work because truncating at (pred i) would fail to trivialize the
   object.
*)

Fixpoint truncate_ne (i : nat) (k : qkind) { struct k } : space k -n> space k
  :=
  match k with
  | qone =>
      nearrow_const unit_ofe unit_ofe tt

  | qtype w =>
      iutruncate_ne w i

  | qarrow k1 k2 =>
      composer (space k1) (space k2) (space k2) (truncate_ne i k2)

  | qtarrow w A k2 =>
      composer (urelsp A) (space k2) (space k2) (truncate_ne i k2)

  | qprod k1 k2 =>
      mpair_ne (truncate_ne i k1) (truncate_ne i k2)

  | qfut k =>
      nearrow_half _ _ (truncate_ne (pred i) k)
  end.

Definition truncate (i : nat) (k : qkind) : car (space k) -> car (space k)
  := pi1 (truncate_ne i k).

Definition truncate_nonexpansive (i : nat) (k : qkind) : nonexpansive (truncate i k)
  :=
  pi2 (truncate_ne i k).

Lemma truncate_near :
  forall i k (x : spcar k),
    dist i (truncate i k x) x.
Proof.
intros i k.
revert i.
induct k.

(* one *)
{
intros i x.
cbn.
trivial.
}

(* type *)
{
intros w i A.
cbn [truncate].
apply iutruncate_near.
}

(* arrow *)
{
intros k1 _ k2 IH i f.
intros x.
cbn.
apply IH.
}

(* tarrow *)
{
intros w A k IH i f.
intros C.
cbn.
apply IH.
}

(* prod *)
{
intros k1 IH1 k IH2 i x.
destruct x as (x, y).
cbn.
split; cbn; [apply IH1 | apply IH2].
}

(* fut *)
{
intros k IH i x.
cbn.
destruct i as [| i].
  {
  apply dist_zero.
  }
cbn.
apply IH.
}
Qed.

Lemma truncate_collapse :
  forall i k (x y : spcar k),
    dist i x y
    -> truncate i k x = truncate i k y.
Proof.
intros i k.
revert i.
induct k.

(* one *)
{
intros i x y _.
cbn.
reflexivity.
}

(* type *)
{
intros w i A B Hdist.
cbn.
apply iutruncate_collapse; auto.
}

(* arrow *)
{
intros k1 _ k2 IH i f g Hfg.
apply exT_extensionality_prop.
cbn.
fextensionality 1.
intro x.
fold (space k1) in x.
apply IH.
apply Hfg.
}

(* tarrow *)
{
intros w A k2 IH i f g Hfg.
apply exT_extensionality_prop.
cbn.
fextensionality 1.
intro x.
apply IH.
apply Hfg.
}

(* prod *)
{
intros k1 IH1 k2 IH2 i x y Hxy.
destruct x as (x1, x2).
destruct y as (y1, y2).
destruct Hxy as (Hxy1, Hxy2).
cbn.
f_equal; [apply IH1 | apply IH2]; auto.
}

(* fut *)
{
intros k IH i x y Hxy.
apply IH.
destruct i as [| i].
  {
  cbn.
  apply dist_zero.
  }
cbn in Hxy |- *.
exact Hxy.
}
Qed.

Lemma truncate_idem :
  forall i k (x : spcar k),
    truncate i k (truncate i k x) = truncate i k x.
Proof.
intros i k x.
apply truncate_collapse.
apply truncate_near.
Qed.

Lemma extract_nonexpansive :
  forall i K (l : qkind) (f : car K -> spcar l),
    (forall j x y, j <= i -> dist j x y -> dist j (f x) (f y))
    -> existsT (f' : K -n> space l),
         forall x, dist i (f x) (pi1 f' x).
Proof.
intros i K l f Hsim.
assert (nonexpansive (fun x => truncate i l (f x))) as Hne.
  {
  intros j x y Hxy.
  so (le_ge_dec j i) as [Hji | Hij].
    {
    apply (truncate_nonexpansive i l).
    apply Hsim; auto.
    }

    {
    apply dist_refl'.
    apply truncate_collapse.
    apply Hsim; auto.
    eapply dist_downward_leq; eauto.
    }
  }
exists (expair _ Hne).
intro x.
cbn.
apply dist_symm.
apply truncate_near.
Qed.

(* This ought to be an instance of something more general, but the more general thing
   doesn't seem to be as good for rewriting.
*)
Lemma transport_truncate :
  forall i k k' (h : k = k') (x : spcar k),
    transport h spcar (truncate i k x) = truncate i k' (transport h spcar x).
Proof.
intros i k k' h x.
subst k'.
cbn.
reflexivity.
Qed.

Arguments meta_truncate {cur}.
Arguments meta_truncate_ne {cur}.
Arguments iutruncate {cur}.
Arguments iutruncate_ne {cur}.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C I K J M G : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ I B /\ (wd_ I C /\ (wd_ J K /\ (wd_ I M /\ (wd_ I A /\ (wd_ A M /\ (wd_ J A /\ (wd_ J I /\ (col_ I A M /\ (col_ K I C /\ (col_ G C A /\ (col_ G M K /\ (col_ J A I /\ (col_ I B C /\ col_ I M C))))))))))))))))) -> col_ C I A)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Import securite.

Lemma POinvprel4 :
 forall (l l0 : list C) (k k0 k1 k2 : K) (c c0 c1 c2 : C)
   (d d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19
    d20 : D),
 inv0
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 inv1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 invP
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 rel4
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l)
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0) ->
 invP
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0).

Proof.
do 32 intro.
unfold rel4 in |- *; intros Inv0 Inv1 InvP and4.
elim and4; intros t1 and2; elim and2; intros t2 and3; elim and3;
 intros t3 eq_l0.
elim eq_l0; assumption.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrnat.
Require Import seq.
Require Import cfmap.
Require Import cfreducible.
Require Import configurations.
Require Import job589to610.
Require Import job611to617.
Require Import job618to622.
Require Import job623to633.

Lemma red588to633 : reducible_in_range 588 633 the_configs.
Proof.
have red633: (reducible_in_range 633 633 the_configs).
  by apply check_reducible_in_range; left.
CatReducible red588to610 red610to617 red617to622 red622to633 red633.
(*
  CatReducible red588to610 red610to617 red617to622 red622to633.
*)
Qed.


Require Import RelationClasses.
Require Import Setoid.
Require Import ExtLib.Core.Type.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Proper.
Require Import ExtLib.Structures.MonadLaws.
Require Import ExtLib.Data.Monads.ReaderMonad.
Require Import ExtLib.Tactics.TypeTac.

Set Implicit Arguments.
Set Strict Implicit.

(*
Section Laws.
  Variable m : Type -> Type.
  Variable Monad_m : Monad m.
  Variable mtype : forall T, type T -> type (m T).
  Variable mtypeOk : forall T (tT : type T), typeOk tT -> typeOk (mtype tT).
  Variable ML_m : MonadLaws Monad_m mtype.

  Variable S : Type.
  Variable type_S : type S.
  Variable typeOk_S : typeOk type_S.

  Definition readerT_eq T (tT : type T) (a b : readerT S m T) : Prop :=
    equal (runReaderT a) (runReaderT b).

  Global Instance type_readerT (T : Type) (tT : type T) : type (readerT S m T) :=
    type_from_equal (readerT_eq tT).

  Global Instance typeOk_readerT (T : Type) (tT : type T) (tOkT : typeOk tT)
    : typeOk  (type_readerT tT).
  Proof.
    eapply typeOk_from_equal.
    { simpl. unfold readerT_eq. intros.
      generalize (only_proper _ _ _ H); intros.
      split; do 4 red; intuition. }
    { red. unfold equal; simpl. unfold readerT_eq; simpl.
      unfold Morphisms.respectful; simpl. firstorder. }
    { red. unfold equal; simpl. unfold readerT_eq; simpl.
      unfold Morphisms.respectful; simpl. intros.
      etransitivity. eapply H; eauto.
      destruct (only_proper _ _ _ H1).
      eapply H0. eapply preflexive; eauto with typeclass_instances. }
  Qed.

  Theorem mproper_red : forall (C : Type) (tC : type C) (o : readerT S m C),
    proper o ->
    proper (runReaderT o).
  Proof. clear. intros. apply H. Qed.

  Global Instance proper_runReaderT T (tT : type T) : proper (@runReaderT S m T).
  Proof.
    repeat red; intros.
    apply H in H0. apply H0.
  Qed.

  Global Instance proper_mkReaderT T (tT : type T) : proper (@mkReaderT S m T).
  Proof.
    repeat red; intros.
    apply H in H0. apply H0.
  Qed.

  Ltac unfold_readerT :=
    red; simpl; intros; do 2 (red; simpl); intros.

  Global Instance MonadLaws_readerT : MonadLaws (@Monad_readerT S _ Monad_m) _.
  Proof.
    constructor.
    { (* bind_of_return *)
      unfold_readerT.
      erewrite bind_of_return; eauto with typeclass_instances; type_tac. }
    { (* return_of_bind *)
      unfold_readerT.
      rewrite return_of_bind; intros; eauto with typeclass_instances.
      intros. eapply H0. eassumption. }
    { (* bind_associativity *)
      unfold_readerT.
      rewrite bind_associativity; eauto with typeclass_instances; type_tac. }
    { unfold_readerT. red; intros.
      type_tac. }
    { intros. unfold bind; simpl. red; intros. red; intros.
      red; simpl. red; simpl; intros. solve_equal. }
  Qed.

(*
  Global Instance MonadTLaws_readerT : @MonadTLaws (readerT S m) (@Monad_readerT S m _)
    r_mleq m Monad_m (@MonadT_readerT _ m).
  Proof.
    constructor; intros; simpl; eapply lower_meq; unfold liftM; simpl; monad_norm;
      reflexivity.
  Qed.
*)

End Laws.
*)


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Risc V total order model *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition Acq := unknown_set "Acq".
Definition AcqRel := unknown_set "AcqRel".
Definition Fence_r_r := unknown_set "Fence.r.r".
Definition Fence_r_rw := unknown_set "Fence.r.rw".
Definition Fence_r_w := unknown_set "Fence.r.w".
Definition Fence_rw_r := unknown_set "Fence.rw.r".
Definition Fence_rw_rw := unknown_set "Fence.rw.rw".
Definition Fence_rw_w := unknown_set "Fence.rw.w".
Definition Fence_tso := unknown_set "Fence.tso".
Definition Fence_w_r := unknown_set "Fence.w.r".
Definition Fence_w_rw := unknown_set "Fence.w.rw".
Definition Fence_w_w := unknown_set "Fence.w.w".
Definition Rel := unknown_set "Rel".
Definition Sc := unknown_set "Sc".
Definition X := unknown_set "X".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition fence_r_r := [R] ⋅ (fencerel Fence_r_r ⋅ [R]).
Definition fence_r_w := [R] ⋅ (fencerel Fence_r_w ⋅ [W]).
Definition fence_r_rw := [R] ⋅ (fencerel Fence_r_rw ⋅ [M]).
Definition fence_w_r := [W] ⋅ (fencerel Fence_w_r ⋅ [R]).
Definition fence_w_w := [W] ⋅ (fencerel Fence_w_w ⋅ [W]).
Definition fence_w_rw := [W] ⋅ (fencerel Fence_w_rw ⋅ [M]).
Definition fence_rw_r := [M] ⋅ (fencerel Fence_rw_r ⋅ [R]).
Definition fence_rw_w := [M] ⋅ (fencerel Fence_rw_w ⋅ [W]).
Definition fence_rw_rw := [M] ⋅ (fencerel Fence_rw_rw ⋅ [M]).
Definition fence_tso := let f := fencerel Fence_tso in [W] ⋅ (f ⋅ [W]) ⊔ [R] ⋅ (f ⋅ [M]).
Definition fence := fence_r_r ⊔ (fence_r_w ⊔ (fence_r_rw ⊔ (fence_w_r ⊔ (fence_w_w ⊔ (fence_w_rw ⊔ (fence_rw_r ⊔ (fence_rw_w ⊔ (fence_rw_rw ⊔ fence_tso)))))))).
Definition po_loc_no_w := po_loc ⊓ !((po_loc ⊔ 1) ⋅ ([W] ⋅ po_loc)).
Definition rsw := rf° ⋅ rf.
Definition AcqRel_0 := AcqRel ⊔ Sc.
Definition AQ := Acq ⊔ AcqRel_0.
Definition RL := Rel ⊔ AcqRel_0.
Definition AMO := (*failed: try AMO with R ⊓ W*) R ⊓ W.
Definition RCsc := (Acq ⊔ (Rel ⊔ AcqRel_0)) ⊓ (AMO ⊔ X).
Definition r1 := [M] ⋅ (po_loc ⋅ [W]).
Definition r2 := [R] ⋅ (po_loc_no_w ⋅ [R]) ⊓ !rsw.
Definition r3 := [(AMO ⊔ X)] ⋅ (rfi ⋅ [R]).
Definition r4 := fence.
Definition r5 := [AQ] ⋅ (po ⋅ [M]).
Definition r6 := [M] ⋅ (po ⋅ [RL]).
Definition r7 := [RCsc] ⋅ (po ⋅ [RCsc]).
Definition r8 := rmw.
Definition r9 := [M] ⋅ (addr ⋅ [M]).
Definition r10 := [M] ⋅ (data ⋅ [W]).
Definition r11 := [M] ⋅ (ctrl ⋅ [W]).
Definition r12 := [M] ⋅ ((addr ⊔ data) ⋅ ([W] ⋅ (rfi ⋅ [R]))).
Definition r13 := [M] ⋅ (addr ⋅ ([M] ⋅ (po ⋅ [W]))).
Definition ppo := r1 ⊔ (r2 ⊔ (r3 ⊔ (r4 ⊔ (r5 ⊔ (r6 ⊔ (r7 ⊔ (r8 ⊔ (r9 ⊔ (r10 ⊔ (r11 ⊔ (r12 ⊔ r13))))))))))).
Definition gmo0 := loc ⊓ [(W ⊓ !FW)] ⋅ top ⋅ [FW] ⊔ (ppo ⊔ rfe).
Variable gmo : relation events.
Definition gmo_0 := gmo ⊔ loc ⊓ [IW] ⋅ top ⋅ [(M ⊓ !IW)].
Definition WR := loc ⊓ [W] ⋅ ((gmo_0 ⊔ po) ⋅ [R]).
Definition rfGMO := WR ⊓ !((loc ⊓ [W] ⋅ gmo_0) ⋅ WR).
Definition RfCons := is_empty (rf ⊓ !rfGMO ⊔ rfGMO ⊓ !rf).
Definition infloc := (gmo_0 ⊓ loc)°.
Definition inflocext := infloc ⊓ ext.
Definition winside := infloc ⋅ (rmw ⋅ inflocext) ⊓ (infloc ⋅ (rf ⋅ (rmw ⋅ inflocext)) ⊓ [W]).
Definition Atomic := is_empty winside.
Definition witness_conditions := linearisations (M ⊓ !IW) gmo0 gmo.
Definition model_conditions := RfCons /\ Atomic.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc Acq AcqRel Fence_r_r Fence_r_rw Fence_r_w Fence_rw_r Fence_rw_rw Fence_rw_w Fence_tso Fence_w_r Fence_w_rw Fence_w_w Rel Sc X tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW fence_r_r fence_r_w fence_r_rw fence_w_r fence_w_w fence_w_rw fence_rw_r fence_rw_w fence_rw_rw fence_tso fence po_loc_no_w rsw AcqRel_0 AQ RL AMO RCsc r1 r2 r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 ppo gmo0 gmo_0 WR rfGMO RfCons infloc inflocext winside Atomic witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists gmo : relation (events c),
    witness_conditions c gmo /\
    model_conditions c gmo.

(* End of translation of model Risc V total order model *)


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement proof for MALInit layer                         *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MBoot layer and MALInit layer*)
Require Import Coqlib.
Require Import XOmega.
Require Import AST.
Require Import LAsm.
Require Import AuxStateDataType.
Require Import Integers.
Require Import Constant.
Require Import AuxLemma.

Lemma size_chunk_range:
  forall chunk,
    size_chunk chunk <= 8.
Proof.
  induction chunk; simpl; omega.
Qed.

Lemma list_forall2_sep:
  forall {A B: Type} (f: A -> B -> Prop) a2 b2 a1 b1,
    list_forall2 f (a1 ++ a2) (b1 ++ b2) ->
    length a1 = length b1 ->
    list_forall2 f a1 b1 /\ list_forall2 f a2 b2.
Proof.
  induction a1; simpl; intros.
  - destruct b1.
    + simpl in H. split; auto. constructor.
    + inv H0.
  - destruct b1.
    + inv H0.
    + inv H.
      assert (Heq: length a1 = length b1).
      {
        simpl in H0. omega.
      }
      specialize (IHa1 _ H6 Heq).
      destruct IHa1 as [IH1 IH2].
      split; trivial.
      constructor; assumption.
Qed.

Lemma PTADDR_range:
  forall i i1 chunk,
    (i mod PgSize) <= PgSize - size_chunk chunk ->
    0 <= (PTADDR (Int.unsigned i1 / 4096) i) <= adr_max - size_chunk chunk.
Proof.
  unfold PTADDR. intros.
  specialize (Int.unsigned_range_2 i1).
  rewrite int_max.
  intros.
  xomega.
Qed.

Lemma PTX_range:
  forall i,
    0 <= PTX (Int.unsigned i) <= 1023.
Proof.
  unfold PTX. intros.
  specialize (Z_mod_lt (Int.unsigned i/PgSize) one_k).
  omega.
Qed.

Lemma PTX_Addr_range:
  forall i i1,
    0 <= Int.unsigned i / PgSize * PgSize + PTX (Int.unsigned i1) * 4 <= adr_max - 4.
Proof.
  intros. specialize (Int.unsigned_range_2 i).
  specialize (PTX_range i1). rewrite int_max.
  intros. xomega.
Qed.

Lemma divide_chunk_PgSize:
  forall chunk,
    (align_chunk chunk | PgSize).
Proof.
  intros.
  assert (1 | 4096).
  {
    unfold Z.divide.
    exists 4096; reflexivity.
  }
  assert (2 | 4096).
  {
    unfold Z.divide.
    exists 2048; reflexivity.
  }
  assert (4 | 4096).
  {
    unfold Z.divide.
    exists 1024; reflexivity.
  }
  assert (8 | 4096).
  {
    unfold Z.divide.
    exists 512; reflexivity.
  }
  destruct chunk; simpl; assumption.
Qed.

Lemma PTADDR_divide:
  forall i i1 chunk,
    (align_chunk chunk | i mod PgSize) ->
    (align_chunk chunk | PTADDR (Int.unsigned i1 / PgSize) i).
Proof.
  unfold PTADDR.
  intros. specialize (divide_chunk_PgSize chunk). intros.
  unfold Z.divide in *.
  destruct H as [z1 H]. rewrite H.
  destruct H0 as [z2 H0].
  set (Int.unsigned i1 / 4096) as v.
  rewrite H0. exists (v * z2 + z1).
  rewrite Z.mul_add_distr_r.
  rewrite <- Z.mul_assoc.
  reflexivity.
Qed.

Lemma PTX_Addr_divide:
  forall i i1,
    (4 | Int.unsigned i / PgSize * PgSize + PTX (Int.unsigned i1) * 4).
Proof.
  intros. apply Zdivide_plus_r.
  - apply Zdivide_mult_r. unfold Z.divide. exists 1024. reflexivity.
  - apply Zdivide_mult_r. apply Zdivide_refl.
Qed.

Lemma PTX_Addr_range':
  forall i i1,
    0 <= Int.unsigned i / PgSize * PgSize + PTX (Int.unsigned i1) * 4 <= Int.max_unsigned.
Proof.
  intros. specialize (PTX_Addr_range i i1). intros.
  rewrite int_max. omega.
Qed.

Lemma list_forall2_memval_undef:
  forall f n b,
    length b = n ->
    list_forall2 (memval_inject f) (list_repeat n Undef) b.
Proof.
  induction n; simpl; destruct b.
  - constructor.
  - inversion 1.
  - inversion 1.
  - constructor.
    + constructor.
    + inv H. eapply IHn; trivial.
Qed.

Lemma list_forall2_memval_undef_chunk:
  forall f v1 v2 chunk,
    list_forall2 (memval_inject f) (list_repeat (length (encode_val chunk v1)) Undef)
                 (encode_val chunk v2).
Proof.
  intros. apply list_forall2_memval_undef.
  repeat rewrite encode_val_length.
  reflexivity.
Qed.