Require Import ModelProperties.

 (*SUBJECT, Property and TransFunc*)
Ltac OpDontChangeStPSS :=
  intros s t Sub SS TF; inversion TF;
   match goal with
   | id:(s = t) |- _ => rewrite <- id; auto
   end.

Ltac OpDontChangeStPSP :=
  intros s t Sub SP TF;  (* SUBJECT, Property and TransFunc *)
   inversion TF; match goal with
                 | id:(s = t) |- _ => rewrite <- id; auto
                 end.

Ltac StartPSS := intros s t Sub SS TF; inversion TF.

Ltac BreakSS :=
  match goal with
  | SS:(SecureState _) |- _ =>
      unfold SecureState in SS; elim SS; intros DAC MAC
  end.

Ltac StartPSP := intros s t Sub SP TF; inversion TF.

Lemma ReadWriteImpRead :
 forall s : SFSstate,
 DACSecureState s ->
 forall (u : SUBJECT) (o : OBJECT),
 match fsecmat (secmat s) o with
 | Some y => set_In u (ActReaders y) -> PreDACRead s u o
 | None => True
 end.
unfold DACSecureState in |- *.
intros.
cut
 match fsecmat (secmat s) o with
 | Some y =>
     (set_In u (ActReaders y) -> PreDACRead s u o) /\
     (set_In u (ActWriters y) -> PreDACWrite s u o)
 | None => True
 end.
elim (fsecmat (secmat s) o).
intros.
elim H0; intros.
auto.

auto.

apply H.

Qed.

Lemma ReadWriteImpWrite :
 forall s : SFSstate,
 DACSecureState s ->
 forall (u : SUBJECT) (o : OBJECT),
 match fsecmat (secmat s) o with
 | Some y => set_In u (ActWriters y) -> PreDACWrite s u o
 | None => True
 end.
unfold DACSecureState in |- *.
intros.
cut
 match fsecmat (secmat s) o with
 | Some y =>
     (set_In u (ActReaders y) -> PreDACRead s u o) /\
     (set_In u (ActWriters y) -> PreDACWrite s u o)
 | None => True
 end.
elim (fsecmat (secmat s) o).
intros.
elim H0; intros.
auto.

auto.

apply H.

Qed.

Lemma TwoImpLeft :
 forall (s : SFSstate) (u : SUBJECT),
 (forall rw : ReadersWriters,
  set_In rw (ransecmat (secmat s)) ->
  ~ set_In u (ActReaders rw) /\ ~ set_In u (ActWriters rw)) ->
 forall rw : ReadersWriters,
 set_In rw (ransecmat (secmat s)) -> ~ set_In u (ActReaders rw).
intros.
cut (~ set_In u (ActReaders rw) /\ ~ set_In u (ActWriters rw)).
tauto.

auto.

Qed.

Lemma TwoImpRight :
 forall (s : SFSstate) (u : SUBJECT),
 (forall rw : ReadersWriters,
  set_In rw (ransecmat (secmat s)) ->
  ~ set_In u (ActReaders rw) /\ ~ set_In u (ActWriters rw)) ->
 forall rw : ReadersWriters,
 set_In rw (ransecmat (secmat s)) -> ~ set_In u (ActWriters rw).
intros.
cut (~ set_In u (ActReaders rw) /\ ~ set_In u (ActWriters rw)).
tauto.

auto.

Qed.

Lemma UniqNames :
 forall (s : SFSstate) (o : OBJECT),
 FuncPre1 s ->
 ~ set_In (ObjName o, File) (domf (files s)) ->
 ~ set_In (ObjName o, Directory) (domd (directories s)) ->
 ~ set_In o (DOM OBJeq_dec (acl s)).
intro; intro; unfold FuncPre1 in |- *; elim o; simpl in |- *; intros.
cut
 ((forall o : OBJECT,
   set_In o (DOM OBJeq_dec (directories s)) -> ObjType o = Directory) /\
  (forall o : OBJECT, set_In o (DOM OBJeq_dec (files s)) -> ObjType o = File) /\
  DOM OBJeq_dec (acl s) =
  set_union OBJeq_dec (DOM OBJeq_dec (files s))
    (DOM OBJeq_dec (directories s))).
intro CUT; elim CUT; intros.
elim H3; intros.
rewrite H5; intro.
cut
 (set_In (a, File) (domf (files s)) \/
  set_In (a, Directory) (domd (directories s))).
intro H7; elim H7; intro.
auto.

auto.

generalize H6; elim b; intro.
left; cut (~ set_In (a, File) (DOM OBJeq_dec (directories s))).
intro; unfold domf in |- *.
cut
 (set_In (a, File)
    (set_union OBJeq_dec (DOM OBJeq_dec (directories s))
       (DOM OBJeq_dec (files s)))).
intro; eauto.

auto.

intro; absurd (ObjType (a, File) = Directory).
simpl in |- *.
intro H11; discriminate H11.

auto.

auto.
right.
cut (~ set_In (a, Directory) (DOM OBJeq_dec (files s))).
intro; unfold domd in |- *; eauto.

intro; absurd (ObjType (a, Directory) = File).
simpl in |- *.
intro H11; discriminate H11.

auto.

auto.

Qed.

Hint Resolve UniqNames.

Lemma eq_scIMPLYle_sc : forall a b : SecClass, eq_sc a b -> le_sc a b.
unfold eq_sc, le_sc in |- *; intros.
elim H; intros.
rewrite H0; rewrite H1.
auto.
Qed.

Lemma NotInDOMIsUndef2 :
 forall (s : SFSstate) (o1 o2 : OBJECT),
 ~ set_In o1 (domsecmat (secmat s)) ->
 o1 = o2 -> None = fsecmat (secmat s) o2.
intros.
symmetry  in |- *.
rewrite H0 in H.
unfold fsecmat in |- *; apply NotInDOMIsUndef; auto.

Qed.

Lemma NotInDOMIsUndef3 :
 forall (s : SFSstate) (p : OBJNAME) (o : OBJECT),
 FuncPre1 s ->
 FuncPre3 s ->
 ~ set_In (p, File) (domf (files s)) ->
 ~ set_In (p, Directory) (domd (directories s)) ->
 p = ObjName o -> None = fsecmat (secmat s) o.
intros until o; elim o; simpl in |- *.
intros until b; elim b; intros.
rewrite <- H3.
symmetry  in |- *; unfold fsecmat in |- *; apply NotInDOMIsUndef.
cut (~ set_In (p, File) (DOM OBJeq_dec (acl s))).
unfold FuncPre3, Included in H3.
unfold FuncPre3, Included in H0.
auto.

apply UniqNames; auto.

rewrite <- H3.
symmetry  in |- *; unfold fsecmat in |- *; apply NotInDOMIsUndef.
cut (~ set_In (p, Directory) (DOM OBJeq_dec (acl s))).
unfold FuncPre3, Included in H3.
unfold FuncPre3, Included in H0.
auto.

apply UniqNames; auto.

Qed.

Lemma EqfOSC6 :
 forall (s : SFSstate) (o1 o2 : OBJECT) (sc : SecClass),
 o1 <> o2 -> fOSC (objectSC s) o2 = fOSC (chobjsc_SC s o1 sc) o2.
intros; unfold fOSC, chobjsc_SC in |- *.
elim (fOSC (objectSC s) o1).
intro; apply AddRemEq; auto.

auto.

Qed.

Lemma EqfOSC5 :
 forall (s : SFSstate) (o : OBJECT) (p : OBJNAME),
 FuncPre1 s ->
 FuncPre2 s ->
 ~ set_In (p, File) (domf (files s)) ->
 ~ set_In (p, Directory) (domd (directories s)) ->
 p = ObjName o -> None = fOSC (objectSC s) o.
intros.
symmetry  in |- *; unfold fOSC in |- *; apply NotInDOMIsUndef.
replace (DOM OBJeq_dec (objectSC s)) with (DOM OBJeq_dec (acl s)).
rewrite H3 in H1; rewrite H3 in H2.
auto.

Qed.

Lemma EqfOSC1 :
 forall (s : SFSstate) (o : OBJECT) (p : OBJNAME) (u : SUBJECT),
 p <> ObjName o -> fOSC (objectSC s) o = fOSC (create_oSC s u p) o.
intros.
unfold create_oSC in |- *.
elim (fSSC (subjectSC s) u); elim (fsecmat (secmat s) (MyDir p)).
intros; unfold fOSC in |- *; apply AddEq.
intro; apply H.
rewrite H0; simpl in |- *; auto.

auto.

auto.

auto.

Qed.

Lemma EqfOSC2 :
 forall (s : SFSstate) (o : OBJECT) (p : OBJNAME) (u : SUBJECT),
 p <> ObjName o -> fOSC (objectSC s) o = fOSC (mkdir_oSC s u p) o.
intros.
unfold mkdir_oSC in |- *.
elim (fSSC (subjectSC s) u); elim (fsecmat (secmat s) (MyDir p)).
intros; unfold fOSC in |- *; apply AddEq.
intro; apply H.
rewrite H0; simpl in |- *; auto.

auto.

auto.

auto.

Qed.

Lemma EqfOSC3 :
 forall (s : SFSstate) (o1 o2 : OBJECT),
 o1 <> o2 -> fOSC (objectSC s) o2 = fOSC (unlink_oSC s o1) o2.
intros.
unfold unlink_oSC in |- *.
elim (fOSC (objectSC s) o1).
intro; unfold fOSC in |- *; apply RemEq.
auto.

auto.

Qed.

Lemma Eqfacl1 :
 forall (s : SFSstate) (o : OBJECT) (p : OBJNAME) (u : SUBJECT)
   (perms : PERMS),
 p <> ObjName o -> facl (acl s) o = facl (create_acl s u p perms) o.
intros.
unfold create_acl in |- *.
elim (fSSC (subjectSC s) u); elim (fsecmat (secmat s) (MyDir p)).
intros; unfold facl in |- *; apply AddEq.
intro y1; apply H; rewrite y1; simpl in |- *; auto.

auto.

auto.

auto.

Qed.

Lemma Eqfacl2 :
 forall (s : SFSstate) (o : OBJECT) (p : OBJNAME) (u : SUBJECT)
   (perms : PERMS),
 p <> ObjName o -> facl (acl s) o = facl (mkdir_acl s u p perms) o.
intros.
unfold mkdir_acl in |- *.
elim (fSSC (subjectSC s) u); elim (fsecmat (secmat s) (MyDir p)).
intros; unfold facl in |- *; apply AddEq.
intro y1; apply H; rewrite y1; simpl in |- *; auto.

auto.

auto.

auto.

Qed.

Lemma Eqfacl3 :
 forall (s : SFSstate) (o1 o2 : OBJECT),
 o1 <> o2 -> facl (acl s) o2 = facl (unlink_acl s o1) o2.
intros.
unfold unlink_acl in |- *.
elim (facl (acl s) o1).
intros; unfold facl in |- *; apply RemEq.
auto.

auto.

Qed.

 (*Seguir aqui*)
Lemma Eqfacl4 :
 forall (s : SFSstate) (o : OBJECT) (y z : AccessCtrlListData),
 FuncPre4 s ->
 facl (acl s) o = Some y -> facl (rmdir_acl s o) o = Some z -> False.
unfold facl in |- *.
intros until z.
cut
 match PARTFUNC OBJeq_dec (acl s) o with
 | Some y => set_In (o, y) (acl s)
 | None => ~ set_In o (DOM OBJeq_dec (acl s))
 end.
unfold rmdir_acl in |- *.
unfold facl in |- *.
elim (PARTFUNC OBJeq_dec (acl s) o).
intros.
cut (PARTFUNC OBJeq_dec (set_remove ACLeq_dec (o, a) (acl s)) o = None).
rewrite H2.
intro.
discriminate H3.

auto.

intros.
discriminate H1.

apply DOMFuncRel4.
Qed.

Lemma Eqfacl5 :
 forall (s : SFSstate) (o : OBJECT) (y z : AccessCtrlListData),
 FuncPre4 s ->
 facl (acl s) o = Some y -> facl (unlink_acl s o) o = Some z -> False.
unfold facl in |- *.
intros until z.
cut
 match PARTFUNC OBJeq_dec (acl s) o with
 | Some y => set_In (o, y) (acl s)
 | None => ~ set_In o (DOM OBJeq_dec (acl s))
 end.
unfold unlink_acl in |- *.
unfold facl in |- *.
elim (PARTFUNC OBJeq_dec (acl s) o).
intros.
cut (PARTFUNC OBJeq_dec (set_remove ACLeq_dec (o, a) (acl s)) o = None).
rewrite H2.
intro.
discriminate H3.

auto.

intros.
discriminate H1.

apply DOMFuncRel4.
Qed.

Lemma EqfOSC4 :
 forall (s : SFSstate) (o : OBJECT) (y z : SecClass),
 FuncPre6 s ->
 fOSC (objectSC s) o = Some y -> fOSC (rmdir_oSC s o) o = Some z -> False.
unfold fOSC in |- *.
intros until z.
cut
 match PARTFUNC OBJeq_dec (objectSC s) o with
 | Some y => set_In (o, y) (objectSC s)
 | None => ~ set_In o (DOM OBJeq_dec (objectSC s))
 end.
unfold rmdir_oSC in |- *.
unfold fOSC in |- *.
elim (PARTFUNC OBJeq_dec (objectSC s) o).
intros.
cut (PARTFUNC OBJeq_dec (set_remove OSCeq_dec (o, a) (objectSC s)) o = None).
rewrite H2.
intro.
discriminate H3.

auto.

intros.
discriminate H1.

apply DOMFuncRel4.
Qed.

Lemma EqfOSC7 :
 forall (s : SFSstate) (o : OBJECT) (y z : SecClass),
 FuncPre6 s ->
 fOSC (objectSC s) o = Some y -> fOSC (unlink_oSC s o) o = Some z -> False.
unfold fOSC in |- *.
intros until z.
cut
 match PARTFUNC OBJeq_dec (objectSC s) o with
 | Some y => set_In (o, y) (objectSC s)
 | None => ~ set_In o (DOM OBJeq_dec (objectSC s))
 end.
unfold unlink_oSC in |- *.
unfold fOSC in |- *.
elim (PARTFUNC OBJeq_dec (objectSC s) o).
intros.
cut (PARTFUNC OBJeq_dec (set_remove OSCeq_dec (o, a) (objectSC s)) o = None).
rewrite H2.
intro.
discriminate H3.

auto.

intros.
discriminate H1.

apply DOMFuncRel4.
Qed.

Lemma NoDACChange :
 forall (s : SFSstate) (o : OBJECT) (SSC : set (SUBJECT * SecClass))
   (OSC : set (OBJECT * SecClass)) (FILES : set (OBJECT * FILECONT))
   (DIRECTS : set (OBJECT * DIRCONT)) (SM : set (OBJECT * ReadersWriters)),
 ~
 DACCtrlAttrHaveChanged s
   (mkSFS (groups s) (primaryGrp s) SSC (AllGrp s)
      (RootGrp s) (SecAdmGrp s) OSC (acl s) SM FILES DIRECTS) o.
intros.
intro.
inversion H; simpl in H1; cut (y = z).
intro EQ; rewrite EQ in H2; inversion H2; auto.

rewrite H0 in H1; injection H1; auto.

intro EQ; rewrite EQ in H2; inversion H2; auto.

rewrite H0 in H1; injection H1; auto.

Qed.

Lemma NoDACChange2 :
 forall (s : SFSstate) (o : OBJECT), ~ DACCtrlAttrHaveChanged s s o.
intros; intro;
 eapply
  (NoDACChange s o (subjectSC s) (objectSC s) (files s)
     (directories s) (secmat s)).
generalize H; elim s; simpl in |- *; auto.

Qed.

Lemma NoMACObjChange :
 forall (s : SFSstate) (o : OBJECT) (FILES : set (OBJECT * FILECONT))
   (DIRECTS : set (OBJECT * DIRCONT))
   (ACL : set (OBJECT * AccessCtrlListData)) (SSC : set (SUBJECT * SecClass))
   (SM : set (OBJECT * ReadersWriters)),
 ~
 MACObjCtrlAttrHaveChanged s
   (mkSFS (groups s) (primaryGrp s) SSC (AllGrp s)
      (RootGrp s) (SecAdmGrp s) (objectSC s) ACL SM FILES DIRECTS) o.
intros; intro.
inversion H; simpl in H1.
cut (x = y).
intro EQ; rewrite EQ in H2; inversion H2; auto.

rewrite H0 in H1; injection H1; auto.

Qed.

Lemma NoMACObjChange2 :
 forall (s : SFSstate) (o : OBJECT), ~ MACObjCtrlAttrHaveChanged s s o.
intros; intro;
 eapply
  (NoMACObjChange s o (files s) (directories s) (acl s)
     (subjectSC s) (secmat s)).
generalize H; elim s; simpl in |- *; auto.

Qed.

Lemma NoMACSubChange :
 forall (s : SFSstate) (u : SUBJECT)
   (ACL : set (OBJECT * AccessCtrlListData)) (OSC : set (OBJECT * SecClass))
   (FILES : set (OBJECT * FILECONT)) (DIRECTS : set (OBJECT * DIRCONT))
   (SM : set (OBJECT * ReadersWriters)),
 ~
 MACSubCtrlAttrHaveChanged s
   (mkSFS (groups s) (primaryGrp s) (subjectSC s) (AllGrp s)
      (RootGrp s) (SecAdmGrp s) OSC ACL SM FILES DIRECTS) u.
intros; intro; inversion H.
simpl in H1.
cut (x = y).
intro EQ; rewrite EQ in H2; inversion H2; auto.

rewrite H0 in H1; injection H1; auto.

Qed.

Lemma NoMACSubChange2 :
 forall (s : SFSstate) (u : SUBJECT), ~ MACSubCtrlAttrHaveChanged s s u.
intros; intro;
 eapply
  (NoMACSubChange s u (acl s) (objectSC s) (files s)
     (directories s) (secmat s)).
generalize H; elim s; simpl in |- *; auto.

Qed.

Lemma eq_scSym : forall a b : SecClass, eq_sc a b -> eq_sc b a.
unfold eq_sc in |- *; intros.
elim H; intros.
rewrite H0; rewrite H1.
auto.
Qed.

Lemma ChsubscPSS1 :
 forall (s : SFSstate) (u : SUBJECT) (y : ReadersWriters),
 (forall rw : ReadersWriters,
  ~ set_In u (ActReaders rw) /\ ~ set_In u (ActWriters rw)) ->
 ~ (set_In u (ActReaders y) \/ set_In u (ActWriters y)).
intros.
cut (~ set_In u (ActReaders y) /\ ~ set_In u (ActWriters y)).
tauto.

auto.

Qed.

Lemma EqfSSC1 :
 forall (s : SFSstate) (u u0 : SUBJECT) (sc : SecClass),
 u <> u0 -> fSSC (subjectSC s) u0 = fSSC (chsubsc_SC s u sc) u0.
intros; unfold chsubsc_SC in |- *.
elim (fSSC (subjectSC s) u).
intros; unfold fSSC in |- *; apply AddRemEq; auto.

auto.

Qed.

Lemma Close_smCorr :
 forall (s : SFSstate) (Sub : SUBJECT) (o : OBJECT),
 FuncPre5 s ->
 match fsecmat (secmat s) o with
 | Some y => set_In Sub (set_union SUBeq_dec (ActReaders y) (ActWriters y))
 | None => False
 end ->
 match fsecmat (close_sm s Sub o) o with
 | None => True
 | Some y => ~ set_In Sub (ActReaders y) /\ ~ set_In Sub (ActWriters y)
 end.
intros until o.
cut
 match fsecmat (secmat s) o with
 | Some y => set_In (o, y) (secmat s)
 | None => ~ set_In o (DOM OBJeq_dec (secmat s))
 end.
unfold close_sm in |- *.
elim (fsecmat (secmat s) o); intros.
elim (set_remove SUBeq_dec Sub (ActReaders a));
 elim (set_remove SUBeq_dec Sub (ActWriters a)).
replace (fsecmat (set_remove SECMATeq_dec (o, a) (secmat s)) o) with
 (None (A:=ReadersWriters)).
auto.

symmetry  in |- *; unfold fsecmat in |- *; unfold FuncPre5 in H0; auto.

intros.
replace
 (fsecmat
    (set_add SECMATeq_dec (o, NEWRW Sub o a)
       (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
 (Some (NEWRW Sub o a)).
unfold NEWRW in |- *; simpl in |- *; split; apply Set_remove1.

unfold fsecmat in |- *; apply AddEq1.
auto.

intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec (o, NEWRW Sub o a)
        (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
  (Some (NEWRW Sub o a)).
unfold NEWRW in |- *; simpl in |- *; split; apply Set_remove1.

unfold fsecmat in |- *; apply AddEq1.
auto.

intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec (o, NEWRW Sub o a)
        (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
  (Some (NEWRW Sub o a)).
unfold NEWRW in |- *; simpl in |- *; split; apply Set_remove1.

unfold fsecmat in |- *; apply AddEq1.
auto.

tauto.

unfold fsecmat in |- *; apply DOMFuncRel4.

Qed.

Lemma Close_smCorr2 :
 forall (s : SFSstate) (Sub u0 : SUBJECT) (o : OBJECT),
 FuncPre5 s ->
 match fsecmat (secmat s) o with
 | Some y => set_In Sub (set_union SUBeq_dec (ActReaders y) (ActWriters y))
 | None => False
 end ->
 match fsecmat (close_sm s Sub o) o, fsecmat (secmat s) o with
 | _, None => False
 | None, Some z => True
 | Some y, Some z =>
     (set_In u0 (ActReaders y) -> set_In u0 (ActReaders z)) /\
     (set_In u0 (ActWriters y) -> set_In u0 (ActWriters z))
 end.
intros until o.
cut
 match fsecmat (secmat s) o with
 | Some y => set_In (o, y) (secmat s)
 | None => ~ set_In o (DOM OBJeq_dec (secmat s))
 end.
unfold close_sm in |- *.
elim (fsecmat (secmat s) o); intros.
elim (set_remove SUBeq_dec Sub (ActReaders a));
 elim (set_remove SUBeq_dec Sub (ActWriters a)).
replace (fsecmat (set_remove SECMATeq_dec (o, a) (secmat s)) o) with
 (None (A:=ReadersWriters)).
auto.

symmetry  in |- *; unfold fsecmat in |- *; unfold FuncPre5 in H; auto.

intros.
replace
 (fsecmat
    (set_add SECMATeq_dec (o, NEWRW Sub o a)
       (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
 (Some (NEWRW Sub o a)).
unfold NEWRW in |- *; simpl in |- *.
split;
 [ intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActReaders a) (x:=u0) (y:=Sub)); auto
 | intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActWriters a) (x:=u0) (y:=Sub)); auto ].

unfold fsecmat in |- *; apply AddEq1.
auto.

intros.
replace
 (fsecmat
    (set_add SECMATeq_dec (o, NEWRW Sub o a)
       (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
 (Some (NEWRW Sub o a)).
unfold NEWRW in |- *; simpl in |- *.
split;
 [ intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActReaders a) (x:=u0) (y:=Sub)); auto
 | intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActWriters a) (x:=u0) (y:=Sub)); auto ].

unfold fsecmat in |- *; apply AddEq1.
auto.

intros.
replace
 (fsecmat
    (set_add SECMATeq_dec (o, NEWRW Sub o a)
       (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
 (Some (NEWRW Sub o a)).
unfold NEWRW in |- *; simpl in |- *.
split;
 [ intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActReaders a) (x:=u0) (y:=Sub)); auto
 | intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActWriters a) (x:=u0) (y:=Sub)); auto ].

unfold fsecmat in |- *; apply AddEq1.
auto.

tauto.

unfold fsecmat in |- *; apply DOMFuncRel4.

Qed.

Lemma Eqfsecmat1 :
 forall (s : SFSstate) (o1 o2 : OBJECT) (u : SUBJECT),
 o1 <> o2 -> fsecmat (secmat s) o2 = fsecmat (close_sm s u o1) o2.
unfold close_sm, fsecmat in |- *; intros;
 elim (PARTFUNC OBJeq_dec (secmat s) o1).
intro; elim (set_remove SUBeq_dec u (ActReaders a));
 elim (set_remove SUBeq_dec u (ActWriters a)).
auto.

auto.

auto.

auto.

auto.

Qed.

Lemma Close_smCorr3 :
 forall (s : SFSstate) (Sub : SUBJECT) (o : OBJECT),
 fsecmat (secmat s) o = None -> fsecmat (close_sm s Sub o) o = None.
intros until o; unfold close_sm in |- *.
intro.
generalize H.
elim (fsecmat (secmat s) o).
intros y H0; discriminate H0.

auto.

Qed.

Lemma OwnerClose_smCorr2 :
 forall (s : SFSstate) (Sub u0 : SUBJECT) (o : OBJECT),
 FuncPre5 s ->
 match fsecmat (secmat s) o with
 | Some y => set_In Sub (set_union SUBeq_dec (ActReaders y) (ActWriters y))
 | None => False
 end ->
 match fsecmat (ownerclose_sm s Sub o) o, fsecmat (secmat s) o with
 | _, None => False
 | None, Some z => True
 | Some y, Some z =>
     (set_In u0 (ActReaders y) -> set_In u0 (ActReaders z)) /\
     (set_In u0 (ActWriters y) -> set_In u0 (ActWriters z))
 end.
intros until o.
cut
 match fsecmat (secmat s) o with
 | Some y => set_In (o, y) (secmat s)
 | None => ~ set_In o (DOM OBJeq_dec (secmat s))
 end.
unfold ownerclose_sm in |- *.
elim (fsecmat (secmat s) o); intros.
elim (set_remove SUBeq_dec Sub (ActReaders a));
 elim (set_remove SUBeq_dec Sub (ActWriters a)).
replace (fsecmat (set_remove SECMATeq_dec (o, a) (secmat s)) o) with
 (None (A:=ReadersWriters)).
auto.

symmetry  in |- *; unfold fsecmat in |- *; unfold FuncPre5 in H0; auto.

intros.
replace
 (fsecmat
    (set_add SECMATeq_dec (o, NEWRWOC Sub o a)
       (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
 (Some (NEWRWOC Sub o a)).
unfold NEWRWOC in |- *; simpl in |- *.
split;
 [ intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActReaders a) (x:=u0) (y:=Sub)); auto
 | intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActWriters a) (x:=u0) (y:=Sub)); auto ].

unfold fsecmat in |- *; apply AddEq1.
auto.

intros.
replace
 (fsecmat
    (set_add SECMATeq_dec (o, NEWRWOC Sub o a)
       (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
 (Some (NEWRWOC Sub o a)).
unfold NEWRWOC in |- *; simpl in |- *.
split;
 [ intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActReaders a) (x:=u0) (y:=Sub)); auto
 | intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActWriters a) (x:=u0) (y:=Sub)); auto ].

unfold fsecmat in |- *; apply AddEq1.
auto.

intros.
replace
 (fsecmat
    (set_add SECMATeq_dec (o, NEWRWOC Sub o a)
       (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
 (Some (NEWRWOC Sub o a)).
unfold NEWRWOC in |- *; simpl in |- *.
split;
 [ intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActReaders a) (x:=u0) (y:=Sub)); auto
 | intro;
    eapply
     (Set_remove2 (A:=SUBJECT) (Aeq_dec:=SUBeq_dec) (B:=
        ActWriters a) (x:=u0) (y:=Sub)); auto ].

unfold fsecmat in |- *; apply AddEq1.
auto.

tauto.

unfold fsecmat in |- *; apply DOMFuncRel4.

Qed.

Lemma Eqfsecmat2 :
 forall (s : SFSstate) (o1 o2 : OBJECT) (u : SUBJECT),
 o1 <> o2 -> fsecmat (secmat s) o2 = fsecmat (ownerclose_sm s u o1) o2.
unfold ownerclose_sm, fsecmat in |- *; intros;
 elim (PARTFUNC OBJeq_dec (secmat s) o1).
intro; elim (set_remove SUBeq_dec u (ActReaders a));
 elim (set_remove SUBeq_dec u (ActWriters a)).
auto.

auto.

auto.

auto.

auto.

Qed.

Lemma OwnerClose_smCorr3 :
 forall (s : SFSstate) (Sub : SUBJECT) (o : OBJECT),
 fsecmat (secmat s) o = None -> fsecmat (ownerclose_sm s Sub o) o = None.
intros until o; unfold ownerclose_sm in |- *.
intro.
generalize H.
elim (fsecmat (secmat s) o).
intros y H0; discriminate H0.

auto.

Qed.

Lemma Open_smCorr3 :
 forall (s : SFSstate) (Sub : SUBJECT) (o : OBJECT) (m : MODE),
 FuncPre5 s ->
 fsecmat (open_sm s Sub o m) o = None -> fsecmat (secmat s) o = None.
intros until m; intro; unfold open_sm in |- *.
cut
 match fsecmat (secmat s) o with
 | Some y => set_In (o, y) (secmat s)
 | None => ~ set_In o (DOM OBJeq_dec (secmat s))
 end.
elim m; elim (fsecmat (secmat s) o).
intro; intro;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o, mkRW (set_add SUBeq_dec Sub (ActReaders a)) (ActWriters a))
        (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
  (Some (mkRW (set_add SUBeq_dec Sub (ActReaders a)) (ActWriters a))).
intros H2; discriminate H2.

unfold fsecmat in |- *; apply AddEq1; auto.

intro;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o,
        mkRW (set_add SUBeq_dec Sub (empty_set SUBJECT)) (empty_set SUBJECT))
        (secmat s)) o) with
  (Some
     (mkRW (set_add SUBeq_dec Sub (empty_set SUBJECT)) (empty_set SUBJECT))).
intro H2; discriminate H2.

unfold fsecmat in |- *; apply AddEq1; auto.

intro; intro;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o, mkRW (ActReaders a) (set_add SUBeq_dec Sub (ActWriters a)))
        (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
  (Some (mkRW (ActReaders a) (set_add SUBeq_dec Sub (ActWriters a)))).
intro H2; discriminate H2.

unfold fsecmat in |- *; apply AddEq1; auto.
intro;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o,
        mkRW (empty_set SUBJECT) (set_add SUBeq_dec Sub (empty_set SUBJECT)))
        (secmat s)) o) with
  (Some
     (mkRW (empty_set SUBJECT) (set_add SUBeq_dec Sub (empty_set SUBJECT)))).
intro H2; discriminate H2.

unfold fsecmat in |- *; apply AddEq1; auto.

unfold fsecmat in |- *; apply DOMFuncRel4.

Qed.

Lemma Open_smCorr21 :
 forall (s : SFSstate) (Sub u0 : SUBJECT) (o : OBJECT) (m : MODE),
 Sub <> u0 ->
 FuncPre5 s ->
 match fsecmat (open_sm s Sub o READ) o, fsecmat (secmat s) o with
 | Some y, None =>
     ActReaders y = set_add SUBeq_dec Sub (empty_set SUBJECT) /\
     ActWriters y = empty_set SUBJECT
 | None, _ => False
 | Some y, Some z =>
     (set_In u0 (ActReaders y) -> set_In u0 (ActReaders z)) /\
     (set_In u0 (ActWriters y) -> set_In u0 (ActWriters z))
 end.
intros.
cut
 match fsecmat (secmat s) o with
 | Some y => set_In (o, y) (secmat s)
 | None => ~ set_In o (DOM OBJeq_dec (secmat s))
 end.
unfold open_sm in |- *.
elim (fsecmat (secmat s) o).
intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o, mkRW (set_add SUBeq_dec Sub (ActReaders a)) (ActWriters a))
        (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
  (Some (mkRW (set_add SUBeq_dec Sub (ActReaders a)) (ActWriters a))).
simpl in |- *.
split; (intros; eauto).

unfold fsecmat in |- *; apply AddEq1; auto.

intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o,
        mkRW (set_add SUBeq_dec Sub (empty_set SUBJECT)) (empty_set SUBJECT))
        (secmat s)) o) with
  (Some
     (mkRW (set_add SUBeq_dec Sub (empty_set SUBJECT)) (empty_set SUBJECT))).
auto.

unfold fsecmat in |- *; apply AddEq1; auto.

unfold fsecmat in |- *; apply DOMFuncRel4.

Qed.

Lemma Open_smCorr22 :
 forall (s : SFSstate) (Sub u0 : SUBJECT) (o : OBJECT) (m : MODE),
 Sub <> u0 ->
 FuncPre5 s ->
 match fsecmat (open_sm s Sub o WRITE) o, fsecmat (secmat s) o with
 | Some y, None =>
     ActWriters y = set_add SUBeq_dec Sub (empty_set SUBJECT) /\
     ActReaders y = empty_set SUBJECT
 | None, _ => False
 | Some y, Some z =>
     (set_In u0 (ActReaders y) -> set_In u0 (ActReaders z)) /\
     (set_In u0 (ActWriters y) -> set_In u0 (ActWriters z))
 end.
intros.
cut
 match fsecmat (secmat s) o with
 | Some y => set_In (o, y) (secmat s)
 | None => ~ set_In o (DOM OBJeq_dec (secmat s))
 end.
unfold open_sm in |- *.
elim (fsecmat (secmat s) o).
intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o, mkRW (ActReaders a) (set_add SUBeq_dec Sub (ActWriters a)))
        (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
  (Some (mkRW (ActReaders a) (set_add SUBeq_dec Sub (ActWriters a)))).
simpl in |- *.
split; (intro; eauto).

unfold fsecmat in |- *; apply AddEq1; auto.

intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o,
        mkRW (empty_set SUBJECT) (set_add SUBeq_dec Sub (empty_set SUBJECT)))
        (secmat s)) o) with
  (Some
     (mkRW (empty_set SUBJECT) (set_add SUBeq_dec Sub (empty_set SUBJECT)))).
auto.

unfold fsecmat in |- *; apply AddEq1; auto.

unfold fsecmat in |- *; apply DOMFuncRel4.

Qed.

Lemma Eqfsecmat3 :
 forall (s : SFSstate) (o1 o2 : OBJECT) (u : SUBJECT) (m : MODE),
 o1 <> o2 -> fsecmat (secmat s) o2 = fsecmat (open_sm s u o1 m) o2.
intros until m; unfold fsecmat, open_sm in |- *.
elim m; elim (fsecmat (secmat s) o1).
intros; apply AddRemEq; auto.

intros; apply AddEq; auto.

intros; apply AddRemEq; auto.

intros; apply AddEq; auto.

Qed.

Lemma Chobjsc_Corr :
 forall (s : SFSstate) (o : OBJECT) (sc : SecClass),
 FuncPre6 s ->
 (fOSC (objectSC s) o = None <-> fOSC (chobjsc_SC s o sc) o = None).
intros; unfold chobjsc_SC in |- *.
cut
 match fOSC (objectSC s) o with
 | Some y => set_In (o, y) (objectSC s)
 | None => ~ set_In o (DOM OBJeq_dec (objectSC s))
 end.
split.
intro H1; rewrite H1; auto.

generalize H0; elim (fOSC (objectSC s) o).
intro; intro;
 replace
  (fOSC
     (set_add OSCeq_dec (o, sc) (set_remove OSCeq_dec (o, a) (objectSC s))) o)
  with (Some sc).
intro H2; discriminate H2.

unfold fOSC in |- *; apply AddEq1.
auto.

auto.

unfold fOSC in |- *; apply DOMFuncRel4.

Qed.

Lemma Aux1 :
 forall y : SecClass, ~ (Some y = None <-> None = None :>option SecClass).
intro; unfold iff in |- *; intro H; elim H; intros.
absurd (Some y = None); auto.
intro D; discriminate D.

Qed.

Lemma Chsubsc_Corr :
 forall (s : SFSstate) (u : SUBJECT) (sc : SecClass),
 FuncPre7 s ->
 (fSSC (subjectSC s) u = None <-> fSSC (chsubsc_SC s u sc) u = None).
intros; unfold chsubsc_SC in |- *.
cut
 match fSSC (subjectSC s) u with
 | Some y => set_In (u, y) (subjectSC s)
 | None => ~ set_In u (DOM SUBeq_dec (subjectSC s))
 end.
split.
intro H1; rewrite H1; auto.

generalize H0; elim (fSSC (subjectSC s) u).
intro; intro;
 replace
  (fSSC
     (set_add SSCeq_dec (u, sc) (set_remove SSCeq_dec (u, a) (subjectSC s)))
     u) with (Some sc).
intro H2; discriminate H2.

unfold fSSC in |- *; apply AddEq1; auto.
auto.

auto.

unfold fSSC in |- *; apply DOMFuncRel4.

Qed.

Lemma Open_smCorr31 :
 forall (s : SFSstate) (Sub u0 : SUBJECT) (o : OBJECT) (m : MODE),
 FuncPre5 s ->
 match fsecmat (open_sm s Sub o READ) o, fsecmat (secmat s) o with
 | Some y, None =>
     ActReaders y = set_add SUBeq_dec Sub (empty_set SUBJECT) /\
     ActWriters y = empty_set SUBJECT
 | None, _ => False
 | Some y, Some z => set_In u0 (ActWriters y) -> set_In u0 (ActWriters z)
 end.
intros.
cut
 match fsecmat (secmat s) o with
 | Some y => set_In (o, y) (secmat s)
 | None => ~ set_In o (DOM OBJeq_dec (secmat s))
 end.
unfold open_sm in |- *.
elim (fsecmat (secmat s) o).
intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o, mkRW (set_add SUBeq_dec Sub (ActReaders a)) (ActWriters a))
        (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
  (Some (mkRW (set_add SUBeq_dec Sub (ActReaders a)) (ActWriters a))).
simpl in |- *; auto.

unfold fsecmat in |- *; apply AddEq1; auto.

intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o,
        mkRW (set_add SUBeq_dec Sub (empty_set SUBJECT)) (empty_set SUBJECT))
        (secmat s)) o) with
  (Some
     (mkRW (set_add SUBeq_dec Sub (empty_set SUBJECT)) (empty_set SUBJECT))).
simpl in |- *; auto.

unfold fsecmat in |- *; apply AddEq1; auto.

unfold fsecmat in |- *; apply DOMFuncRel4.

Qed.

Lemma Open_smCorr32 :
 forall (s : SFSstate) (Sub u0 : SUBJECT) (o : OBJECT) (m : MODE),
 FuncPre5 s ->
 match fsecmat (open_sm s Sub o WRITE) o, fsecmat (secmat s) o with
 | Some y, None =>
     ActWriters y = set_add SUBeq_dec Sub (empty_set SUBJECT) /\
     ActReaders y = empty_set SUBJECT
 | None, _ => False
 | Some y, Some z => set_In u0 (ActReaders y) -> set_In u0 (ActReaders z)
 end.
intros.
cut
 match fsecmat (secmat s) o with
 | Some y => set_In (o, y) (secmat s)
 | None => ~ set_In o (DOM OBJeq_dec (secmat s))
 end.
unfold open_sm in |- *.
elim (fsecmat (secmat s) o).
intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o, mkRW (ActReaders a) (set_add SUBeq_dec Sub (ActWriters a)))
        (set_remove SECMATeq_dec (o, a) (secmat s))) o) with
  (Some (mkRW (ActReaders a) (set_add SUBeq_dec Sub (ActWriters a)))).
simpl in |- *; auto.

unfold fsecmat in |- *; apply AddEq1; auto.

intros;
 replace
  (fsecmat
     (set_add SECMATeq_dec
        (o,
        mkRW (empty_set SUBJECT) (set_add SUBeq_dec Sub (empty_set SUBJECT)))
        (secmat s)) o) with
  (Some
     (mkRW (empty_set SUBJECT) (set_add SUBeq_dec Sub (empty_set SUBJECT)))).
simpl in |- *; auto.

unfold fsecmat in |- *; apply AddEq1; auto.

unfold fsecmat in |- *; apply DOMFuncRel4.

Qed.

Hint Resolve eq_scIMPLYle_sc eq_scSym Eqfsecmat1 Close_smCorr3 TwoImpLeft
  TwoImpRight EqfOSC1 ChsubscPSS1 Eqfsecmat2 NoMACObjChange NoDACChange
  NoMACSubChange EqfOSC6 Eqfacl1 Eqfacl2 Eqfacl3 EqfOSC1 EqfOSC2 EqfOSC3 Aux1
  NotInDOMIsUndef2 Eqfacl4 EqfOSC4 EqfOSC5 EqfSSC1 OwnerClose_smCorr3
  Open_smCorr3 Eqfsecmat3 Chobjsc_Corr NoMACObjChange2 NoDACChange2
  NoMACSubChange2 Chsubsc_Corr NotInDOMIsUndef3 Eqfacl5 EqfOSC7.


Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.
Require Import VST.floyd.fieldlist.
Require Import VST.floyd.type_induction.
Require Import VST.floyd.nested_pred_lemmas.
Open Scope Z.

Module Type ACR_DEC.

  Parameter align_compatible_rec_dec:
    forall {cs: compspecs},
      forall t z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.

End ACR_DEC.

Module align_compatible_rec_dec: ACR_DEC.

Section align_compatible_rec_dec.

Context {cs: compspecs}.

Definition dec_type := sigT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}).

Definition dec_by_value (ch: memory_chunk): dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => (Memdata.align_chunk ch | z)) (fun z => Zdivide_dec (Memdata.align_chunk ch) z (Memdata.align_chunk_pos _)).

Definition dec_False: dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => False) (fun z => right (fun H => H)).

Definition dec_True: dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => True) (fun z => left I).

Fixpoint cons_in_list {A} (a: A) (al' al: list A) (H: forall x, In x al' -> In x al) (bl: list {x:A| In x al'}) : list {x: A | In x al} :=
  match bl with
  | nil => nil
  | exist x i :: bl0 =>exist _ x (H x i)  :: cons_in_list a al' al H bl0
  end.

Fixpoint make_in_list {A} (al: list A) : list {x: A | In x al} :=
  match al as ax return (al = ax -> list {x : A | In x ax}) with
           | nil => fun _ => nil
           | a::al' => fun H: al = a::al' =>
                      exist _ a (or_introl eq_refl) ::
                         eq_rect al (fun l : list A => list {x : A | In x l})
                          (cons_in_list a al' al (fun (x : A) (H0 : In x al') =>
                                 eq_ind_r (fun al0 : list A => In x al0) (in_cons _ _ _ H0) H)
                               (make_in_list al'))
                        (a :: al') H
           end (eq_refl _).

Lemma in_make_in_list: forall {A} (a: A) (al: list A) H,
   In (exist (fun x => In x al) a H) (make_in_list al).
Proof.
induction al; intros.
inv H.
destruct H.
subst a0.
simpl.
left; auto.
unfold make_in_list; fold @make_in_list.
right.
specialize (IHal i).
unfold eq_rect.
forget (make_in_list al) as bl.
unfold eq_ind_r.
unfold eq_ind.
simpl.
induction bl.
inv IHal.
destruct IHal.
subst a1.
left.
apply exist_ext; auto.
specialize (IHbl H).
unfold cons_in_list; fold @cons_in_list.
destruct a1.
right. auto.
Qed.

Lemma field_type_in_members_strong:
 forall i t m, Ctypes.field_type i m = Errors.OK t ->
          In (i,t) m.
Proof.
induction m; intros.
inv H.
simpl in H.
destruct a. if_tac in H. subst. inv H. left; auto.
right. apply IHm; auto.
Qed.

Lemma align_compatible_dec_aux:
   forall n t, (rank_type cenv_cs t < n)%nat ->
    forall z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.
Proof.
induction n; intros; [ omega | ].
rename H into Hrank.
destruct t  as [ | [ | | | ] [ | ]| [ | ] | [ | ] | | | | | ] eqn:Ht; intros;
try solve [
clear IHn Hrank;
match goal with |- context [align_compatible_rec _ ?t _] =>
evar (ch: memory_chunk);
assert (access_mode t = By_value ch) by (subst ch; reflexivity);
(destruct (Zdivide_dec (Memdata.align_chunk ch) z (Memdata.align_chunk_pos _));
   [left; econstructor; try reflexivity; eassumption
   |right;  contradict n; inv n; inv H0; auto])
end];
try solve [right; intro H; inv H; inv H0].
* (* Tarray *)
specialize (IHn t0).
simpl in Hrank. spec IHn; [omega | ]. clear Hrank.
pose proof (Zrange_pred_dec (fun ofs => align_compatible_rec cenv_cs t0 (z + sizeof t0 * ofs))).
spec H.
intro; apply IHn.
specialize (H 0 z0).
destruct H as [H|H]; [left|right].
+
eapply align_compatible_rec_Tarray; intros.
apply H; auto.
+
contradict H.
intros.
eapply align_compatible_rec_Tarray_inv in H.
apply H.
split; try omega.
* (* Tstruct *)
destruct (cenv_cs ! i) eqn:?H;
 [ | right; intro H0; inv H0; [inv H1 | congruence]].
simpl in Hrank. rewrite H in Hrank.
pose (FO id := match Ctypes.field_offset cenv_cs id (co_members c) with
                      | Errors.OK z0 => z0 | _ => 0 end).
pose (D := fun x: {it: ident*type | In it (co_members c)} =>
                align_compatible_rec cenv_cs (snd (proj1_sig x)) (z + FO (fst (proj1_sig x)))).
assert (H1: forall x, {D x} + {~ D x}). {
 subst D. intros. destruct x as [[id t0] ?]. simpl.
 apply IHn.
 assert (H1:= rank_union_member cenv_cs _ a _ _ _ cenv_consistent H i0).
 simpl in H1. rewrite H in H1. omega.
}
destruct (Forall_dec D H1 (make_in_list (co_members c))) as [H2|H2]; clear H1; [left|right].
+
 eapply align_compatible_rec_Tstruct.
 eassumption.
 assert (H1 := proj1 (Forall_forall _ _) H2); clear H2.
 intros.
 specialize (H1 (exist _ (i0,t0) (field_type_in_members_strong _ _ _ H0))).
 specialize (H1 (in_make_in_list _ _ _)).
 subst D.
 simpl in H1.
 replace z0 with (FO i0).
 apply H1.
 unfold FO. rewrite H2. auto.
+
 contradict H2.
 apply Forall_forall.
 intros.
 subst D. simpl.
 destruct x as [[id t0] ?].
 eapply align_compatible_rec_Tstruct_inv in H2; try eassumption.
 instantiate (1:=id). simpl.
 pose proof (get_co_members_no_replicate i).
 unfold get_co in H1. rewrite H in H1. unfold members_no_replicate in H1.
 clear - i0 H1.
 induction (co_members c). inv i0. simpl. destruct a.
 if_tac. subst.
 simpl in H1. destruct (id_in_list i (map fst m)) eqn:?; try discriminate.
 destruct i0. inv H. auto.
 apply id_in_list_false in Heqb.
 elimtype False. apply Heqb. apply (in_map fst) in H. apply H.
 apply IHm.
 destruct i0. inv H0. contradiction. auto.
 simpl in H1. destruct (id_in_list i (map fst m)) eqn:?; try discriminate.
 auto.
 unfold FO; simpl.
 clear - i0.
 destruct (Ctypes.field_offset cenv_cs id (co_members c) ) eqn:?H; auto.
 elimtype False.
 unfold Ctypes.field_offset in H. forget 0 as z.
 revert z i0 H; induction (co_members c); intros. inv i0.
 simpl in H. destruct a. if_tac in H. inv H.
 destruct i0. inv H1. contradiction. apply IHm in H. auto. auto.
* (* Tunion *)
destruct (cenv_cs ! i) eqn:?H;
 [ | right; intro H0; inv H0; [inv H1 | congruence]].
simpl in Hrank. rewrite H in Hrank.
pose (D := fun x: {it: ident*type | In it (co_members c)} =>
                align_compatible_rec cenv_cs (snd (proj1_sig x)) z).
assert (H1: forall x, {D x} + {~ D x}). {
 subst D. intros. destruct x as [[id t0] ?]. simpl.
 apply IHn.
 assert (H1:= rank_union_member cenv_cs _ a _ _ _ cenv_consistent H i0).
 simpl in H1. rewrite H in H1. omega.
}
destruct (Forall_dec D H1 (make_in_list (co_members c))) as [H2|H2]; clear H1; [left|right].
+
 eapply align_compatible_rec_Tunion.
 eassumption.
 assert (H1 := proj1 (Forall_forall _ _) H2); clear H2.
 intros.
 specialize (H1 (exist _ (i0,t0) (field_type_in_members_strong _ _ _ H0))).
 specialize (H1 (in_make_in_list _ _ _)).
 apply H1.
+
 contradict H2.
 apply Forall_forall.
 intros.
 subst D. simpl.
 destruct x as [[id t0] ?].
 eapply align_compatible_rec_Tunion_inv in H2; try eassumption.
 instantiate (1:=id). simpl.
 pose proof (get_co_members_no_replicate i).
 unfold get_co in H1. rewrite H in H1. unfold members_no_replicate in H1.
 clear - i0 H1.
 induction (co_members c). inv i0. simpl. destruct a.
 if_tac. subst.
 simpl in H1. destruct (id_in_list i (map fst m)) eqn:?; try discriminate.
 destruct i0. inv H. auto.
 apply id_in_list_false in Heqb.
 elimtype False. apply Heqb. apply (in_map fst) in H. apply H.
 apply IHm.
 destruct i0. inv H0. contradiction. auto.
 simpl in H1. destruct (id_in_list i (map fst m)) eqn:?; try discriminate.
 auto.
Qed.

Lemma align_compatible_rec_dec: forall t z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.
Proof.
intros.
apply align_compatible_dec_aux with (S (rank_type cenv_cs t)).
omega.
Qed.

End align_compatible_rec_dec.

End align_compatible_rec_dec.

Lemma align_compatible_dec: forall {cs: compspecs} t p, {align_compatible t p} + {~ align_compatible t p}.
Proof.
  intros.
  destruct p; try solve [left; unfold align_compatible; simpl; tauto].
  simpl.
  apply align_compatible_rec_dec.align_compatible_rec_dec.
Qed.


Parameter T : Prop.
Parameter t : T.

Hint Extern 1 (T) => apply t.
Ltac diverge a := diverge a.
Hint Extern 2 (T) => diverge idtac.

Lemma test : T.
Proof.
  auto. (* executes the first hint, succeeds, and never executes
           the second hint. *)
Qed.

Lemma test2 : T.
Proof.
  eauto. (* executes the first and second hint;
            the latter of which results in a "stack overflow",
            and eauto does not solve the goal. *)
Abort.


Require Import CertiGraph.unionfind.env_unionfind_arr.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.UnionFind.
Require Import CertiGraph.msl_application.ArrayGraph.
Require Import CertiGraph.floyd_ext.share.
Require Import VST.floyd.library.
Require Import CertiGraph.unionfind.spatial_array_graph.

Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.
#[export] Existing Instances maGraph finGraph liGraph.

Local Open Scope Z_scope.

(*There is a full definition in the verified malloc, but it's impl-specific*)
(*Parameter malloc_token': share -> Z -> val -> mpred.*)

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH sh:share, n: Z(*, gv:globals*)
  PRE [tint]
     PROP (writable_share sh;
            4 <= n <= Int.max_unsigned
          )
     PARAMS (Vint (Int.repr n))
     GLOBALS ((*gv*))
     SEP (
          )
  POST [ tptr tvoid ]
     EX v: pointer_val,
     PROP (malloc_compatible n (pointer_val_val v))
     LOCAL (temp ret_temp (pointer_val_val v))
     SEP (
          memory_block sh n (pointer_val_val v)
         ).
(*
Definition mallocK_spec :=
 DECLARE _mallocK
  WITH gv: globals, sh: share, n: Z
  PRE [tint]
     PROP (writable_share sh;
           4 <= n <= Ptrofs.max_unsigned - 12 (*we don't want to malloc 0. The 12 is just some constant from the verified malloc*)
          )
     PARAMS (Vptrofs (Ptrofs.repr n))
     GLOBALS (gv)
     SEP (mem_mgr gv)
  POST [ tptr tvoid ]
     EX v: _,
     PROP (malloc_compatible n v)
     LOCAL (temp ret_temp v)
     SEP (mem_mgr gv; malloc_token' sh n v; memory_block sh n v).
*)
(*Basically collapses everything into the mpred defined by SAG_VST
takes in a lst of rank-parent pairs(from where? g?)
  which is converted into the Cdata structures
sh is the only parameter needed
data_at sh (tarray vertex_type (Z.of_nat (length lst)))
                               (map vgamma2cdata lst) (pointer_val_val x)
*)
Definition whole_graph sh g x :=
  (@full_graph_at mpred SAGA_VST pointer_val (SAG_VST sh) g x).

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH gv:globals, sh: share, V: Z
    PRE [tint]
      PROP (writable_share sh; readable_share sh;
            0 < V <= Int.max_signed / 8)
      PARAMS (Vint (Int.repr V))
      GLOBALS ()
      SEP ((*mem_mgr gv*))
    POST [tptr vertex_type]
      EX rt: pointer_val, (*creates a graph where*)
      PROP (forall i: Z, 0 <= i < V -> vvalid (makeSet_discrete_Graph (Z.to_nat V)) i) (*anything between 0 and V is a vertex*)
      LOCAL (temp ret_temp (pointer_val_val rt))
      SEP (
           (*mem_mgr gv; malloc_token' sh (V*4) (pointer_val_val rt);*)
           whole_graph sh (makeSet_discrete_Graph (Z.to_nat V)) rt). (*representation in heap...*)

Definition freeSet_spec :=
  DECLARE _freeSet
  WITH sh: share, p: pointer_val, g: ArrayGraph.UFGraph(*, gv: globals*)
    PRE [tptr vertex_type]
    PROP () PARAMS ((pointer_val_val p)) GLOBALS ((*gv*))
    SEP ((*mem_mgr gv;
          malloc_token' sh (Z.of_nat (numV' g)) (pointer_val_val p);*)
          whole_graph sh g p)
  POST [tvoid]
    PROP () LOCAL () SEP ((*mem_mgr gv*)).

Definition find_spec :=
  DECLARE _find
  WITH sh: share, g: UFGraph, subsets: pointer_val, i: Z
    PRE [tptr vertex_type, tint]
      PROP (writable_share sh; vvalid g i)
      PARAMS (pointer_val_val subsets; Vint (Int.repr i))
      GLOBALS ()
      SEP (whole_graph sh g subsets)
    POST [tint]
      EX g': UFGraph, EX rt: Z,
      PROP (uf_equiv g g' ; uf_root g' i rt)
      LOCAL (temp ret_temp (Vint (Int.repr rt)))
      SEP (whole_graph sh g' subsets).

Definition union_spec :=
 DECLARE _Union
  WITH sh: share, g: UFGraph, subsets: pointer_val, x: Z, y: Z
  PRE [tptr vertex_type, tint, tint]
          PROP  (writable_share sh; vvalid g x; vvalid g y)
          PARAMS (pointer_val_val subsets; Vint (Int.repr x); Vint (Int.repr y))
          GLOBALS ()
          SEP   (whole_graph sh g subsets)
  POST [ Tvoid ]
        EX g': UFGraph,
        PROP (uf_union g x y g')
        LOCAL ()
        SEP (whole_graph sh g' subsets).


(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

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

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

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

From mathcomp
Require Import ssreflect ssrbool seq ssrfun.
From LemmaOverloading
Require Import heaps rels hprop stmod stsep.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma bnd_is_try (A B : Type) (s1 : spec A) (s2 : A -> spec B) i r :
        verify (try_s s1 s2 (fun y => fr (throw_s B y))) i r ->
        verify (bind_s s1 s2) i r.
Proof.
move=>H; apply: frame0=>D.
case: {H D} (H D) (D)=>[[i1]][i2][->][[H1 [H2 H3]]] _ T D.
split=>[|y m].
- split=>[|x m]; first by apply: fr_pre H1.
  by case/(locality D H1)=>m1 [->][_]; move/H2; apply: fr_pre.
move=>{D} H; apply: T=>h1 h2 E.
rewrite {i1 i2 H1 H2 H3}E in H * => D1 [H1][H2] H3.
case: H=>[[x][h][]|[e][->]]; move/(locality D1 H1);
case=>[m1][->][D2] T1; move: (T1); [move/H2 | move/H3]=>H4.
- move=>T2; case/(locality D2 H4): (T2)=>m3 [->][D3].
  by exists m3; do !split=>//; left; exists x; exists m1.
exists m1; do !split=>//; right; exists e; exists m1; split=>//.
move=>j1 j2 E D _; rewrite {m1 D2}E in T1 D H4 *.
exists j1; do !split=>//; move=>k1 k2 -> D2 ->.
by exists empty; rewrite un0h; do !split=>//; apply: defUnr D2.
Qed.

Local Notation cont A := (ans A -> heap -> Prop).

Section EvalDo.
Variables (A B : Type).

Lemma val_do (s : spec A) i j (r : cont A) :
         s.1 i ->
         (forall x m, s.2 (Val x) i m -> def (m :+ j) -> r (Val x) (m :+ j)) ->
         (forall e m, s.2 (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
         verify s (i :+ j) r.
Proof.
move=>H1 H2 H3; apply: frame; apply: frame0; split=>//.
by case=>x m H4 D1 D2; [apply: H2 | apply: H3].
Qed.

Lemma try_do (s : spec A) s1 s2 i j (r : cont B) :
        s.1 i ->
        (forall x m, s.2 (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, s.2 (Exn e) i m -> verify (s2 e) (m :+ j) r) ->
        verify (try_s s s1 s2) (i :+ j) r.
Proof.
move=>H1 H2 H3; apply: frame0=>D; split=>[|y m].
- split; first by apply: fr_pre; exists i; exists empty; rewrite unh0.
  by split=>y m; case/(_ i j (erefl _) D H1)=>m1 [->][D2]; [case/H2 | case/H3].
by case=>[[x]|[e]][h][]; case/(_ i j (erefl _) D H1)=>m1 [->][D2];
   [case/H2 | case/H3]=>// _; apply.
Qed.

Lemma bnd_do (s : spec A) s2 i j (r : cont B) :
        s.1 i ->
        (forall x m, s.2 (Val x) i m -> verify (s2 x) (m :+ j) r) ->
        (forall e m, s.2 (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        verify (bind_s s s2) (i :+ j) r.
Proof.
move=>H1 H2 H3; apply: bnd_is_try.
apply: try_do=>// e m H4; apply: frame0; apply: frame1=>_.
by split=>// y m1 [->] -> _; rewrite un0h; apply: H3.
Qed.

End EvalDo.

Section EvalReturn.
Variables (A B : Type).

Lemma val_ret v i (r : cont A) :
       (def i -> r (Val v) i) -> verify (ret_s v) i r.
Proof.
by rewrite -[i]un0h=>H; apply: val_do=>// x m [->] // [->].
Qed.

Lemma try_ret s1 s2 (v : A) i (r : cont B) :
        verify (s1 v) i r -> verify (try_s (ret_s v) s1 s2) i r.
Proof.
by rewrite -[i]un0h=>H; apply: try_do=>// x m [->] // [->].
Qed.

Lemma bnd_ret s (v : A) i (r : cont B) :
        verify (s v) i r -> verify (bind_s (ret_s v) s) i r.
Proof. by move=>H; apply: bnd_is_try; apply: try_ret. Qed.

End EvalReturn.

Section EvalRead.
Variables (A B : Type).

Lemma val_read v x i (r : cont A) :
        (def (x :-> v :+ i) -> r (Val v) (x :-> v :+ i)) ->
        verify (read_s A x) (x :-> v :+ i) r.
Proof.
move=>*; apply: val_do; first by [exists v];
by move=>y m [<-]; move/(_ v (erefl _))=>// [->].
Qed.

Lemma try_read s1 s2 v x i (r : cont B) :
        verify (s1 v) (x :-> v :+ i) r ->
        verify (try_s (read_s A x) s1 s2) (x :-> v :+ i) r.
Proof.
move=>*; apply: try_do; first by [exists v];
by move=>y m [<-]; move/(_ v (erefl _))=>// [->].
Qed.

Lemma bnd_read s v x i (r : cont B) :
        verify (s v) (x :-> v :+ i) r ->
        verify (bind_s (read_s A x) s) (x :-> v :+ i) r.
Proof. by move=>*; apply: bnd_is_try; apply: try_read. Qed.

End EvalRead.

Section EvalWrite.
Variables (A B C : Type).

Lemma val_write (v : A) (w : B) x i (r : cont unit) :
        (def (x :-> v :+ i) -> r (Val tt) (x :-> v :+ i)) ->
        verify (write_s x v) (x :-> w :+ i) r.
Proof.
move=>*; apply: val_do; first by [exists B; exists w];
by move=>y m [// [->] ->].
Qed.

Lemma try_write s1 s2 (v: A) (w : C) x i (r : cont B) :
        verify (s1 tt) (x :-> v :+ i) r ->
        verify (try_s (write_s x v) s1 s2) (x :-> w :+ i) r.
Proof.
move=>*; apply: try_do; first by [exists C; exists w];
by move=>y m [// [->] ->].
Qed.

Lemma bnd_write s (v : A) (w : C) x i (r : cont B) :
        verify (s tt) (x :-> v :+ i) r ->
        verify (bind_s (write_s x v) s) (x :-> w :+ i) r.
Proof. by move=>*; apply: bnd_is_try; apply: try_write. Qed.

End EvalWrite.

Section EvalAlloc.
Variables (A B : Type).

Lemma val_alloc (v : A) i (r : cont ptr) :
        (forall x, def (x :-> v :+ i) -> r (Val x) (x :-> v :+ i)) ->
        verify (alloc_s v) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: val_do=>//;
by move=>y m [x][//][-> ->]; apply: H.
Qed.

Lemma try_alloc s1 s2 (v : A) i (r : cont B) :
        (forall x, verify (s1 x) (x :-> v :+ i) r) ->
        verify (try_s (alloc_s v) s1 s2) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: try_do=>//;
by move=>y m [x][//][-> ->]; apply: H.
Qed.

Lemma bnd_alloc s (v : A) i (r : cont B) :
        (forall x, verify (s x) (x :-> v :+ i) r) ->
        verify (bind_s (alloc_s v) s) i r.
Proof. by move=>*; apply: bnd_is_try; apply: try_alloc. Qed.

End EvalAlloc.

Section EvalBlockAlloc.
Variables (A B : Type).

Lemma val_allocb (v : A) n i (r : cont ptr) :
        (forall x, def (updi x (nseq n v) :+ i) ->
           r (Val x) (updi x (nseq n v) :+ i)) ->
        verify (allocb_s v n) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: val_do=>//;
by move=>y m [x][//][->]->; apply: H.
Qed.

Lemma try_allocb s1 s2 (v : A) n i (r : cont B) :
        (forall x, verify (s1 x) (updi x (nseq n v) :+ i) r) ->
        verify (try_s (allocb_s v n) s1 s2) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: try_do=>//;
by move=>y m [x][//][->]->; apply: H.
Qed.

Lemma bnd_allocb s (v : A) n i (r : cont B) :
        (forall x, verify (s x) (updi x (nseq n v) :+ i) r) ->
        verify (bind_s (allocb_s v n) s) i r.
Proof. by move=>*; apply: bnd_is_try; apply: try_allocb. Qed.

End EvalBlockAlloc.

Section EvalDealloc.
Variables (A B : Type).

Lemma val_dealloc (v : A) x i (r : cont unit) :
        (def i -> r (Val tt) i) ->
        verify (dealloc_s x) (x :-> v :+ i) r.
Proof.
move=>H; apply: val_do; first by [exists A; exists v];
by move=>y m [//][->] ->; rewrite un0h.
Qed.

Lemma try_dealloc s1 s2 (v : B) x i (r : cont A) :
        verify (s1 tt) i r ->
        verify (try_s (dealloc_s x) s1 s2) (x :-> v :+ i) r.
Proof.
move=>H; apply: try_do; first by [exists B; exists v];
by move=>y m [//][->] ->; rewrite un0h.
Qed.

Lemma bnd_dealloc s (v : B) x i (r : cont A) :
        verify (s tt) i r ->
        verify (bind_s (dealloc_s x) s) (x :-> v :+ i) r.
Proof. by move=>*; apply: bnd_is_try; apply: try_dealloc. Qed.

End EvalDealloc.

Section EvalThrow.
Variables (A B : Type).

Lemma val_throw e i (r : cont A) :
        (def i -> r (Exn e) i) -> verify (throw_s A e) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: val_do=>//;
by move=>y m [->] // [->]; rewrite un0h.
Qed.

Lemma try_throw s1 s2 e i (r : cont B) :
        verify (s2 e) i r ->
        verify (try_s (throw_s A e) s1 s2) i r.
Proof.
move=>H; rewrite -[i]un0h; apply: try_do=>//;
by move=>y m [->] // [->]; rewrite un0h.
Qed.

Lemma bnd_throw s e i (r : cont B) :
        (def i -> r (Exn e) i) ->
        verify (bind_s (throw_s A e) s) i r.
Proof.
move=>H; apply: bnd_is_try; apply: try_throw; apply: frame0.
by rewrite -[i]un0h; apply: val_do=>// y m [->] // [->]; rewrite un0h.
Qed.

End EvalThrow.

(* specialized versions of do lemmas, to handle ghost variables. *)

Section EvalGhost.
Variables (A B C : Type) (t : C) (p : C -> Pred heap) (q : C -> post A).
Variables (s1 : A -> spec B) (s2 : exn -> spec B) (i j : heap) (P : Pred heap).

Lemma val_gh (r : cont A) :
        let: s := (fun i => exists x, i \In p x,
                   fun y i m => forall x, i \In p x -> q x y i m) in
        (forall x m, q t (Val x) i m -> def (m :+ j) -> r (Val x) (m :+ j)) ->
        (forall e m, q t (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        i \In p t ->
        verify s (i :+ j) r.
Proof. by move=>*; apply: val_do=>/=; eauto. Qed.

Lemma val_gh1 (r : cont A) :
        let: Q := fun y i m => forall x, i \In p x -> q x y i m in
        (i \In p t -> P i) ->
        (forall x m, q t (Val x) i m -> def (m :+ j) -> r (Val x) (m :+ j)) ->
        (forall e m, q t (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        i \In p t ->
        verify (P, Q) (i :+ j) r.
Proof. by move=>*; apply: val_do=>/=; eauto. Qed.

Lemma try_gh (r : cont B) :
        let: s := (fun i => exists x, i \In p x,
                   fun y i m => forall x, i \In p x -> q x y i m) in
        (forall x m, q t (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, q t (Exn e) i m -> verify (s2 e) (m :+ j) r) ->
        i \In p t ->
        verify (try_s s s1 s2) (i :+ j) r.
Proof. by move=>*; apply: try_do=>/=; eauto. Qed.

Lemma try_gh1 (r : cont B) :
        let: Q := fun y i m => forall x, i \In p x -> q x y i m in
        (i \In p t -> P i) ->
        (forall x m, q t (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, q t (Exn e) i m -> verify (s2 e) (m :+ j) r) ->
        i \In p t ->
        verify (try_s (P, Q) s1 s2) (i :+ j) r.
Proof. by move=>*; apply: try_do=>/=; eauto. Qed.

Lemma bnd_gh (r : cont B) :
        let: s := (fun i => exists x, i \In p x,
                   fun y i m => forall x, i \In p x -> q x y i m) in
        (forall x m, q t (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, q t (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        i \In p t ->
        verify (bind_s s s1) (i :+ j) r.
Proof. by move=>*; apply: bnd_do=>/=; eauto. Qed.

Lemma bnd_gh1 (r : cont B) :
        let: Q := fun y i m => forall x, i \In p x -> q x y i m in
        (i \In p t -> P i) ->
        (forall x m, q t (Val x) i m -> verify (s1 x) (m :+ j) r) ->
        (forall e m, q t (Exn e) i m -> def (m :+ j) -> r (Exn e) (m :+ j)) ->
        i \In p t ->
        verify (bind_s (P, Q) s1) (i :+ j) r.
Proof. by move=>*; apply: bnd_do=>/=; eauto. Qed.

End EvalGhost.

(*****************************************************************************)
(* associativity lemmas should go here, but I don't want to bother right now *)
(*****************************************************************************)

(* packaging up the lemmas into a tactic that selects them appropriately *)

Definition pull (A : Type) x (v:A) := (unC (x :-> v), unCA (x :-> v)).
Definition push (A : Type) x (v:A) := (unCA (x :-> v), unC (x :-> v)).

Ltac hstep :=
  match goal with
    | |- verify ?h (ret_s _) _ =>
      apply: val_ret
    | |- verify ?h (try_s (ret_s _) _ _) _ =>
      apply: try_ret
    | |- verify ?h (bind_s (ret_s _) _) _ =>
      apply: bnd_ret

    | |- verify ?h (read_s _ ?l) _ =>
      rewrite -?(pull l); apply: val_read
    | |- verify ?h (try_s (read_s _ ?l) _ _) _ =>
      rewrite -?(pull l); apply: try_read
    | |- verify (?h) (bind_s (read_s _ ?l) _) _ =>
      rewrite -?(pull l); apply: bnd_read

    | |- verify (?h) (write_s ?l _) _ =>
      rewrite -?(pull l); apply: val_write
    | |- verify (?h) (try_s (write_s ?l _) _ _) _ =>
      rewrite -?(pull l); apply: try_write
    | |- verify (?h) (bind_s (write_s ?l _) _) _ =>
      rewrite -?(pull l); apply: bnd_write

    | |- verify ?h (alloc_s _) _ =>
      apply: val_alloc
    | |- verify ?h (try_s (alloc_s _) _ _) _ =>
      apply: try_alloc
    | |- verify ?h (bind_s (alloc_s _) _) _ =>
      apply: bnd_alloc

    | |- verify ?h (allocb_s _ _) _ =>
      apply: val_allocb
    | |- verify ?h (try_s (allocb_s _ _) _ _) _ =>
      apply: try_allocb
    | |- verify ?h (bind_s (allocb_s _ _) _) _ =>
      apply: bnd_allocb

    | |- verify ?h (dealloc_s ?l) _ =>
      rewrite -?(pull l); apply: val_dealloc
    | |- verify ?h (try_s (dealloc_s ?l) _ _) _ =>
      rewrite -?(pull l); apply: try_dealloc
    | |- verify ?h (bind_s (dealloc_s ?l) _) _ =>
      rewrite -?(pull l); apply: bnd_dealloc

    | |- verify ?h (throw_s _ _) _ =>
      apply: val_throw
    | |- verify ?h (try_s (throw_s _ _) _ _) _ =>
      apply: try_throw
    | |- verify ?h (bind_s (throw_s _ _) _) _ =>
      apply: bnd_throw
  end.

Lemma swp : forall (A : Type) (v : A) x h, h \In x :--> v <-> h = x :-> v.
Proof. by move=>A v x h; split; rewrite InE /pts /=; unlock. Qed.

Lemma opn : forall (A : Type) (v : A) x h, h \In x :--> v <-> x :-> v = h.
Proof. by move=>A v x h; split=>[|H]; rewrite InE /= /pts; unlock. Qed.

Prenex Implicits swp opn.

Lemma blah (A : Type) (p : ptr) (l : A) : def (p :-> l) -> (p :-> l) \In p :--> l.
Proof. by move=>H; apply/swp. Qed.

Hint Immediate blah : core.

Lemma blah2 (A : Type) (v1 v2 : A) q :
        def (q :-> v1) -> v1 = v2 -> q :-> v1 \In q :--> v2.
Proof. by move=>D E; apply/swp; rewrite E. Qed.

Hint Immediate blah2 : core.

Ltac hauto := (do ?econstructor=>//;
                try by [defcheck; auto |
                       eapply blah2; defcheck; auto])=>//.

Ltac hhauto := (do ?econstructor=>//; try by [heap_congr])=>//.
Ltac hdone := repeat progress hhauto=>//=.
Ltac heval := do ![hstep | by hhauto].


(* Distributed under the terms of the MIT license. *)
From Coq Require Import CRelationClasses ProofIrrelevance ssreflect ssrbool.
From MetaCoq.Template Require Import config Universes utils BasicAst.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction
     PCUICReflect PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICUnivSubstitutionConv
     PCUICUnivSubstitutionTyp
     PCUICCumulativity PCUICPosition PCUICEquality PCUICSigmaCalculus
     PCUICInversion PCUICCumulativity PCUICReduction
     PCUICConfluence PCUICConversion PCUICContextConversion
     PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICClosed PCUICClosedTyp PCUICSubstitution PCUICWfUniverses
     PCUICWeakeningConv PCUICWeakeningTyp PCUICGeneration PCUICUtils PCUICContexts
     PCUICWellScopedCumulativity PCUICConversion PCUICOnFreeVars.

Require Import Equations.Prop.DepElim.
Require Import Equations.Type.Relation_Properties.
From Equations Require Import Equations.

Implicit Types cf : checker_flags.

Notation isWAT := (isWfArity typing).

Lemma isType_Sort {cf:checker_flags} {Σ Γ s} :
  wf_universe Σ s ->
  wf_local Σ Γ ->
  isType Σ Γ (tSort s).
Proof.
  intros wfs wfΓ.
  eexists; econstructor; eauto.
Qed.
#[global] Hint Resolve isType_Sort : pcuic.

Definition wf_typing_spine {cf} {Σ Γ T args T'} :=
  isType Σ Γ T × typing_spine Σ Γ T args T'.

Lemma isArity_it_mkProd_or_LetIn Γ t : isArity t -> isArity (it_mkProd_or_LetIn Γ t).
Proof.
  intros isA. induction Γ using rev_ind; simpl; auto.
  rewrite it_mkProd_or_LetIn_app. simpl; auto.
  destruct x as [? [?|] ?]; simpl; auto.
Qed.

Inductive typing_spine {cf} Σ (Γ : context) : term -> list term -> term -> Type :=
| type_spine_nil ty ty' :
    isType Σ Γ ty ->
    isType Σ Γ ty' ->
    Σ ;;; Γ ⊢ ty ≤ ty' ->
    typing_spine Σ Γ ty [] ty'

| type_spine_cons ty hd tl na A B B' :
    isType Σ Γ ty ->
    isType Σ Γ (tProd na A B) ->
    Σ ;;; Γ ⊢ ty ≤ tProd na A B ->
    Σ ;;; Γ |- hd : A ->
    typing_spine Σ Γ (subst10 hd B) tl B' ->
    typing_spine Σ Γ ty (hd :: tl) B'.

Derive Signature NoConfusion for typing_spine.

Lemma typing_spine_isType_codom {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ T args U} :
  typing_spine Σ Γ T args U -> isType Σ Γ U.
Proof.
  induction 1; auto.
Qed.

Lemma subslet_inds_gen {cf} {Σ : global_env} {wfΣ : wf Σ} ind mdecl idecl :
  declared_inductive Σ ind mdecl idecl ->
  let u := abstract_instance (ind_universes mdecl) in
  subslet (Σ, ind_universes mdecl) [] (inds (inductive_mind ind) u (ind_bodies mdecl))
    (arities_context (ind_bodies mdecl)).
Proof.
  intros isdecl u.
  unfold inds.
  pose proof (proj1 isdecl) as declm'.
  apply on_declared_minductive in declm' as [oind oc]; auto.
  clear oc.
  assert (Alli (fun i x =>
  (Σ, ind_universes mdecl) ;;; [] |- tInd {| inductive_mind := inductive_mind ind; inductive_ind := i |} u : (ind_type x)) 0 (ind_bodies mdecl)).
  { apply forall_nth_error_Alli. intros.
    eapply Alli_nth_error in oind; eauto. simpl in oind.
    destruct oind. destruct onArity as [s Hs].
    eapply type_Cumul; eauto.
    econstructor; eauto. split; eauto with pcuic.
    eapply consistent_instance_ext_abstract_instance; eauto.
    eapply declared_inductive_wf_global_ext; eauto with pcuic.
    rewrite (subst_instance_ind_type_id Σ _ {| inductive_mind := inductive_mind ind; inductive_ind := i |}); eauto.
    destruct isdecl. split; eauto. reflexivity. }
  clear oind.
  revert X. clear onNpars.
  generalize (le_n #|ind_bodies mdecl|).
  generalize (ind_bodies mdecl) at 1 3 4 5.
  induction l using rev_ind; simpl; first constructor.
  rewrite /subst_instance /= /map_context.
  simpl. rewrite /arities_context rev_map_spec /=.
  rewrite map_app /= rev_app_distr /=.
  rewrite /= app_length /= Nat.add_1_r.
  constructor.
  - rewrite -rev_map_spec. apply IHl; try lia.
    eapply Alli_app in X; intuition auto.
  - eapply Alli_app in X as [oind Hx].
    depelim Hx. clear Hx.
    rewrite Nat.add_0_r in t.
    rewrite subst_closedn; auto.
    + eapply typecheck_closed in t as [? ?]; auto.
      destruct p as [? ?].
      now move/andb_and: i0=> [? ?].
Qed.

Section WfEnv.
  Context {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}.

  Lemma ws_cumul_ctx_pb_vass {Γ Γ' na na' A A'} le :
    eq_binder_annot na na' ->
    Σ ⊢ Γ ≤[le] Γ' ->
    Σ ;;; Γ ⊢ A ≤[le] A' ->
    Σ ⊢ Γ ,, vass na A ≤[le] Γ' ,, vass na' A'.
  Proof using Type.
    repeat (constructor; auto).
  Qed.

  Lemma ws_cumul_ctx_pb_app {le Γ Γ' Δ Δ'} :
    #|Δ| = #|Δ'| ->
    Σ ⊢ Γ ,,, Δ ≤[le] Γ' ,,, Δ' <~>
    Σ ⊢ Γ ≤[le] Γ' × ws_cumul_ctx_pb_rel le Σ Γ Δ Δ'.
  Proof using wfΣ.
    move => hlen; split.
    - move/All2_fold_app_inv. move/(_ hlen) => [] onΓ onΔ; split => //.
      split; eauto with fvs.
    - move=> [] onΓ [_ onΔ].
      apply All2_fold_app; auto.
  Qed.

  Lemma invert_cumul_arity_l (Γ : context) (C : term) T :
    Σ;;; Γ ⊢ C ≤ T ->
    match destArity [] C with
    | Some (ctx, s) =>
      ∑ T' ctx' s',
        [× Σ ;;; Γ ⊢ T ⇝ T', (destArity [] T' = Some (ctx', s')),
          Σ ⊢ Γ ,,, smash_context [] ctx = Γ ,,, ctx' &
          leq_universe (global_ext_constraints Σ) s s']
    | None => unit
    end.
  Proof using wfΣ.
    intros CT.
    generalize (destArity_spec [] C). destruct destArity as [[ctx p]|].
    simpl. intros ->. 2:intros _; exact tt.
    revert Γ T CT.
    generalize (@le_n #|ctx|).
    generalize (#|ctx|) at 2. intros n; revert ctx.
    induction n; intros ctx Hlen Γ T HT.
    - destruct ctx; simpl in Hlen; try lia.
      eapply ws_cumul_pb_Sort_l_inv in HT as [u' [redT leqT]].
      exists (tSort u'), [], u'; split; auto.
      cbn. eapply ws_cumul_ctx_pb_refl; eauto with fvs.
    - destruct ctx using rev_ind.
      * eapply ws_cumul_pb_Sort_l_inv in HT as [u' [redT leqT]].
        exists (tSort u'), [], u'; split; auto; cbn.
        apply ws_cumul_ctx_pb_refl; eauto with fvs.
      * rewrite it_mkProd_or_LetIn_app in HT; simpl in HT.
        destruct x as [na [b|] ty]; unfold mkProd_or_LetIn in HT; simpl in *.
        + eapply ws_cumul_pb_LetIn_l_inv in HT; auto.
          unfold subst1 in HT; rewrite subst_it_mkProd_or_LetIn in HT.
          rewrite app_length /= Nat.add_1_r in Hlen.
          simpl in HT. specialize (IHn (subst_context [b] 0 ctx) ltac:(rewrite
          subst_context_length; lia) Γ T HT).
          destruct IHn as [T' [ctx' [s' [redT destT convctx leq]]]].
          clear IHctx.
          exists T', ctx', s'. split; auto.
          rewrite smash_context_app. simpl.
          now rewrite -smash_context_subst_empty.
        + eapply ws_cumul_pb_Prod_l_inv in HT; auto.
          rewrite -> app_length in Hlen.
          rewrite Nat.add_1_r in Hlen.
          destruct HT as [na' [A' [B' [redT convT HT]]]].
          specialize (IHn ctx ltac:(lia) (Γ ,, vass na' A') B').
          forward IHn. eapply ws_cumul_pb_ws_cumul_ctx; eauto.
          { apply ws_cumul_ctx_pb_vass; eauto. now symmetry.
            eapply ws_cumul_ctx_pb_refl. eauto with fvs.
            now symmetry. }
          clear IHctx.
          destruct IHn as [T' [ctx' [s' [redT' destT convctx leq]]]].
          exists (tProd na' A' T'), (ctx' ++ [vass na' A']), s'. split; auto. 2:simpl.
          -- transitivity (tProd na' A' B'); auto.
            split.
            3:eapply red_prod; [reflexivity|apply redT'].
            all:eauto with fvs.
          -- now rewrite destArity_app destT.
          -- rewrite smash_context_app /= .
            rewrite !app_context_assoc.
            assert (#|smash_context [] ctx| = #|ctx'|).
            { apply All2_fold_length in convctx.
              autorewrite with len in convctx |- *.
              simpl in convctx. simpl. lia. }
            etransitivity; tea.
            apply ws_cumul_ctx_pb_app; auto.
            split. apply ws_cumul_ctx_pb_vass; auto.
            apply ws_cumul_ctx_pb_refl; eauto with fvs.
            eapply ws_cumul_ctx_pb_app; eauto.
            eapply ws_cumul_ctx_pb_refl; eauto with fvs.
            eapply ws_cumul_ctx_pb_closed_left in convctx.
            move: convctx.
            rewrite !on_free_vars_ctx_app. autorewrite with fvs.
            move/andP => [] /andP[] -> /=; cbn; rewrite andb_true_r => onA' ->.
            rewrite shiftnP0 andb_true_r; eauto with fvs.
  Qed.

  Lemma isType_tProd {Γ} {na A B} :
    isType Σ Γ (tProd na A B) <~> (isType Σ Γ A × isType Σ (Γ,, vass na A) B).
  Proof.
    split; intro HH.
    - destruct HH as [s H].
      apply inversion_Prod in H; tas. destruct H as [s1 [s2 [HA [HB Hs]]]].
      split.
      * eexists; tea.
      * eexists; tea.
    - destruct HH as [HA HB].
      destruct HA as [sA HA], HB as [sB HB].
      eexists. econstructor; eassumption.
  Defined.

  Lemma isType_subst {Γ Δ A} s :
    subslet Σ Γ s Δ ->
    isType Σ (Γ ,,, Δ) A ->
    isType Σ Γ (subst0 s A).
  Proof using wfΣ.
    intros sub HT.
    apply infer_typing_sort_impl with id HT; intros Hs.
    have wf := typing_wf_local Hs.
    now eapply (substitution (Δ := []) (T := tSort _)).
  Qed.

  Lemma isType_subst_gen {Γ Δ Δ'} {A} s :
    subslet Σ Γ s Δ ->
    isType Σ (Γ ,,, Δ ,,, Δ') A ->
    isType Σ (Γ ,,, subst_context s 0 Δ') (subst s #|Δ'| A).
  Proof using wfΣ.
    intros sub HT.
    apply infer_typing_sort_impl with id HT; intros Hs.
    now eapply (substitution (T:=tSort _)).
  Qed.

  Lemma type_ws_cumul_pb {pb Γ t} T {U} :
    Σ ;;; Γ |- t : T ->
    isType Σ Γ U ->
    Σ ;;; Γ ⊢ T ≤[pb] U ->
    Σ ;;; Γ |- t : U.
  Proof using Type.
    intros.
    eapply type_Cumul; tea. apply X0.π2.
    destruct pb.
    - eapply ws_cumul_pb_eq_le in X1.
      now eapply cumulAlgo_cumulSpec in X1.
    - now eapply cumulAlgo_cumulSpec.
  Qed.

  Lemma isType_tLetIn_red {Γ} (HΓ : wf_local Σ Γ) {na t A B}
    : isType Σ Γ (tLetIn na t A B) -> isType Σ Γ (B {0:=t}).
  Proof using wfΣ.
    intro HH.
    apply infer_typing_sort_impl with id HH; intros H.
    assert (Hs := typing_wf_universe _ H).
    apply inversion_LetIn in H; tas. destruct H as (s1 & A' & HA & Ht & HB & H).
    eapply (type_ws_cumul_pb (pb:=Cumul)) with (A' {0 := t}). eapply substitution_let in HB; eauto.
    * econstructor; eauto with pcuic. econstructor; eauto.
    * eapply ws_cumul_pb_Sort_r_inv in H as [s' [H H']].
      transitivity (tSort s'); eauto.
      eapply red_ws_cumul_pb.
      apply invert_red_letin in H as [H|H] => //.
      destruct H as (d' & ty' & b' & [reds ]).
      discriminate.
      repeat constructor; eauto with fvs.
  Qed.

  Lemma isType_tLetIn_dom {Γ} (HΓ : wf_local Σ Γ) {na t A B}
    : isType Σ Γ (tLetIn na t A B) -> Σ ;;; Γ |- t : A.
  Proof using wfΣ.
    intros (s & H).
    apply inversion_LetIn in H; tas. now destruct H as (s1 & A' & HA & Ht & HB & H).
  Qed.

  Lemma wf_local_ass {Γ na A} :
    wf_local Σ Γ ->
    isType Σ Γ A ->
    wf_local Σ (Γ ,, vass na A).
  Proof using Type.
    constructor; eauto with pcuic.
  Qed.

  Lemma wf_local_def {Γ na d ty} :
    wf_local Σ Γ ->
    isType Σ Γ ty ->
    Σ ;;; Γ |- d : ty ->
    wf_local Σ (Γ ,, vdef na d ty).
  Proof using Type.
    constructor; eauto with pcuic.
  Qed.

  Hint Resolve wf_local_ass wf_local_def : pcuic.
  Hint Transparent snoc : pcuic.

  Lemma isType_apply {Γ na A B t} :
    isType Σ Γ (tProd na A B) ->
    Σ ;;; Γ |- t : A ->
    isType Σ Γ (B {0 := t}).
  Proof using wfΣ.
    move/isType_tProd => [hA hB] ht.
    eapply (isType_subst (Δ:= [vass na A])); eauto with pcuic.
  Qed.

  Hint Resolve isType_wf_local : pcuic.

  Lemma typing_spine_letin_inv {Γ na b B T args S} :
    typing_spine Σ Γ (tLetIn na b B T) args S ->
    typing_spine Σ Γ (T {0 := b}) args S.
  Proof using wfΣ.
    intros Hsp.
    depelim Hsp.
    constructor; auto.
    eapply isType_tLetIn_red in i; eauto with pcuic.
    now eapply ws_cumul_pb_LetIn_l_inv in w.
    econstructor; eauto.
    eapply isType_tLetIn_red in i; eauto with pcuic.
    now eapply ws_cumul_pb_LetIn_l_inv in w.
  Qed.

  Lemma typing_spine_letin {Γ na b B T args S} :
    isType Σ Γ (tLetIn na b B T) ->
    typing_spine Σ Γ (T {0 := b}) args S ->
    typing_spine Σ Γ (tLetIn na b B T) args S.
  Proof using wfΣ.
    intros Hty Hsp.
    depelim Hsp.
    constructor; auto.
    - etransitivity; tea. eapply into_ws_cumul_pb.
      eapply red_cumul, red1_red, red_zeta. all:eauto with fvs.
    - econstructor; eauto.
      etransitivity; tea.
      eapply into_ws_cumul_pb.
      eapply red_cumul. eapply red1_red, red_zeta.
      all:eauto with fvs.
  Qed.

  Lemma typing_spine_weaken_concl {Γ T args S S'} :
    typing_spine Σ Γ T args S ->
    Σ ;;; Γ ⊢ S ≤ S' ->
    isType Σ Γ S' ->
    typing_spine Σ Γ T args S'.
  Proof using wfΣ.
    induction 1 in S' => cum.
    constructor; auto. transitivity ty'; auto.
    intros isType.
    econstructor; eauto.
  Qed.

  Lemma typing_spine_prod {Γ na b B T args S} :
    typing_spine Σ Γ (T {0 := b}) args S ->
    isType Σ Γ (tProd na B T) ->
    Σ ;;; Γ |- b : B ->
    typing_spine Σ Γ (tProd na B T) (b :: args) S.
  Proof using wfΣ.
    intros Hsp.
    depelim Hsp.
    econstructor; eauto with pcuic.
    - constructor; auto with pcuic.
    - intros Har.
      destruct (fst isType_tProd Har) as [? ?]; eauto using typing_wf_local.
      intros Hb.
      econstructor; eauto with pcuic.
      econstructor; revgoals; eauto with pcuic.
  Qed.

  Lemma typing_spine_WAT_concl {Γ T args S} :
    typing_spine Σ Γ T args S ->
    isType Σ Γ S.
  Proof using Type.
    induction 1; auto.
  Qed.

  Lemma typing_spine_isType_dom {Γ T args S} :
    typing_spine Σ Γ T args S ->
    isType Σ Γ T.
  Proof using Type.
    induction 1; auto.
  Qed.

  Lemma type_mkProd_or_LetIn {Γ} d {u t s} :
    Σ ;;; Γ |- decl_type d : tSort u ->
    Σ ;;; Γ ,, d |- t : tSort s ->
    match decl_body d return Type with
    | Some b => Σ ;;; Γ |- mkProd_or_LetIn d t : tSort s
    | None => Σ ;;; Γ |- mkProd_or_LetIn d t : tSort (Universe.sort_of_product u s)
    end.
  Proof using wfΣ.
    destruct d as [na [b|] dty] => [Hd Ht|Hd Ht]; rewrite /mkProd_or_LetIn /=.
    - have wf := typing_wf_local Ht.
      depelim wf. clear l.
      eapply type_Cumul. econstructor; eauto.
      econstructor; eauto. now eapply typing_wf_universe in Ht; pcuic.
      eapply convSpec_cumulSpec, red1_cumulSpec. constructor.
    - have wf := typing_wf_local Ht.
      depelim wf; clear l.
      eapply type_Prod; eauto.
  Qed.

  Lemma type_it_mkProd_or_LetIn {Γ Γ' u t s} :
    wf_universe Σ u ->
    type_local_ctx (lift_typing typing) Σ Γ Γ' u ->
    Σ ;;; Γ ,,, Γ' |- t : tSort s ->
    Σ ;;; Γ |- it_mkProd_or_LetIn Γ' t : tSort (Universe.sort_of_product u s).
  Proof using wfΣ.
    revert Γ u s t.
    induction Γ'; simpl; auto; move=> Γ u s t wfu equ Ht.
    - eapply type_Cumul; eauto.
      econstructor; eauto using typing_wf_local with pcuic.
      eapply typing_wf_universe in Ht; auto with pcuic.
      eapply cumul_Sort. eapply leq_universe_product.
    - specialize (IHΓ' Γ  u (Universe.sort_of_product u s)); auto.
      unfold app_context in Ht.
      eapply type_Cumul.
      eapply IHΓ'; auto.
      destruct a as [na [b|] ty]; intuition auto.
      destruct a as [na [b|] ty]; intuition auto.
      { apply typing_wf_local in Ht as XX. inversion XX; subst.
        eapply (type_mkProd_or_LetIn {| decl_body := Some b |}); auto.
        + simpl. exact X0.π2.
        + eapply type_Cumul; eauto.
          econstructor; eauto with pcuic.
          eapply cumul_Sort. eapply leq_universe_product. }
      eapply (type_mkProd_or_LetIn {| decl_body := None |}) => /=; eauto.
      econstructor; eauto with pcuic.
      eapply typing_wf_local in Ht.
      depelim Ht; eapply All_local_env_app_inv in Ht; intuition auto.
      now rewrite sort_of_product_twice.
  Qed.

  Fixpoint sort_of_products us s :=
    match us with
    | [] => s
    | u :: us => sort_of_products us (Universe.sort_of_product u s)
    end.

  Lemma leq_universe_sort_of_products_mon {u u' v v'} :
    Forall2 (leq_universe Σ) u u' ->
    leq_universe Σ v v' ->
    leq_universe Σ (sort_of_products u v) (sort_of_products u' v').
  Proof using Type.
    intros hu; induction hu in v, v' |- *; simpl; auto with pcuic.
    intros lev. eapply IHhu.
    eapply leq_universe_product_mon => //.
  Qed.

  Lemma type_it_mkProd_or_LetIn_sorts {Γ Γ' us t s} :
    sorts_local_ctx (lift_typing typing) Σ Γ Γ' us ->
    Σ ;;; Γ ,,, Γ' |- t : tSort s ->
    Σ ;;; Γ |- it_mkProd_or_LetIn Γ' t : tSort (sort_of_products us s).
  Proof using wfΣ.
    revert Γ us s t.
    induction Γ'; simpl; auto; move=> Γ us s t equ Ht.
    - destruct us => //.
    - destruct a as [na [b|] ty]; intuition auto.
      * destruct a0 as [s' Hs].
        eapply IHΓ'; eauto.
        eapply (type_mkProd_or_LetIn {| decl_body := Some b |}); auto.
        simpl. exact Hs.
      * destruct us => //. destruct equ.
        simpl.
        eapply IHΓ'; eauto.
        apply (type_mkProd_or_LetIn {| decl_body := None |}) => /=; eauto.
  Qed.

  Lemma isType_it_mkProd_or_LetIn {Γ Γ' us t} :
    sorts_local_ctx (lift_typing typing) Σ Γ Γ' us ->
    isType Σ (Γ ,,, Γ') t ->
    isType Σ Γ (it_mkProd_or_LetIn Γ' t).
  Proof using cf Σ wfΣ.
    move=> equs [s ttyp]; exists (sort_of_products us s).
    apply: type_it_mkProd_or_LetIn_sorts=> //.
  Qed.

  Lemma app_context_push Γ Δ Δ' d : (Γ ,,, Δ ,,, Δ') ,, d = (Γ ,,, Δ ,,, (Δ' ,, d)).
  Proof using Type.
    reflexivity.
  Qed.

  Hint Extern 4 (_ ;;; _ |- _ <= _) => reflexivity : pcuic.
  Ltac pcuic := eauto 5 with pcuic.

  Lemma subslet_app_closed {Γ s s' Δ Δ'} :
    subslet Σ Γ s Δ ->
    subslet Σ Γ s' Δ' ->
    closed_ctx Δ ->
    subslet Σ Γ (s ++ s') (Δ' ,,, Δ).
  Proof using Type.
    induction 1 in s', Δ'; simpl; auto; move=> sub' => /andb_and [clctx clt];
    try constructor; auto.
    - pose proof (subslet_length X). rewrite Nat.add_0_r in clt.
      rewrite /= -H in clt.
      rewrite subst_app_simpl /= (subst_closedn s') //.
    - pose proof (subslet_length X). rewrite Nat.add_0_r in clt.
      rewrite /= -H in clt. move/andb_and: clt => [clt clT].
      replace (subst0 s t) with (subst0 (s ++ s') t).
      + constructor; auto.
        rewrite !subst_app_simpl /= !(subst_closedn s') //.
      + rewrite !subst_app_simpl /= !(subst_closedn s') //.
  Qed.

  Hint Constructors subslet : core pcuic.

  Lemma subslet_app_inv {Γ Δ Δ' s} :
    subslet Σ Γ s (Δ ,,, Δ') ->
    subslet Σ Γ (skipn #|Δ'| s) Δ *
    subslet Σ Γ (firstn #|Δ'| s) (subst_context (skipn #|Δ'| s) 0 Δ').
  Proof using Type.
    intros sub. split.
    - induction Δ' in Δ, s, sub |- *; simpl; first by rewrite skipn_0.
      depelim sub; rewrite skipn_S; auto.
    - induction Δ' in Δ, s, sub |- *; simpl; first by constructor.
      destruct s; depelim sub.
      * rewrite subst_context_snoc. constructor; eauto.
        rewrite skipn_S Nat.add_0_r /=.
        assert(#|Δ'| = #|firstn #|Δ'| s|).
        { pose proof (subslet_length sub).
          rewrite app_context_length in H.
          rewrite firstn_length_le; lia. }
        rewrite {3}H.
        rewrite -subst_app_simpl.
        now rewrite firstn_skipn.
      * rewrite subst_context_snoc.
        rewrite skipn_S Nat.add_0_r /=.
        rewrite /subst_decl /map_decl /=.
        specialize (IHΔ' _ _ sub).
        epose proof (cons_let_def _ _ _ _ _ (subst (skipn #|Δ'| s0) #|Δ'| t0)
        (subst (skipn #|Δ'| s0) #|Δ'| T) IHΔ').
        assert(#|Δ'| = #|firstn #|Δ'| s0|).
        { pose proof (subslet_length sub).
          rewrite app_context_length in H.
          rewrite firstn_length_le; lia. }
        rewrite {3 6}H in X.
        rewrite - !subst_app_simpl in X.
        rewrite !firstn_skipn in X.
        specialize (X t1).
        rewrite {3}H in X.
        now rewrite - !subst_app_simpl firstn_skipn in X.
  Qed.

  Lemma subslet_inds {ind u mdecl idecl} :
    declared_inductive Σ.1 ind mdecl idecl ->
    consistent_instance_ext Σ (ind_universes mdecl) u ->
    subslet Σ [] (inds (inductive_mind ind) u (ind_bodies mdecl))
      (subst_instance u (arities_context (ind_bodies mdecl))).
  Proof using wfΣ.
    intros isdecl univs.
    unfold inds.
    pose proof (proj1 isdecl) as declm.
    apply on_declared_minductive in declm as [oind oc]; auto.
    clear oc.
    assert (Alli (fun i x =>
      Σ ;;; [] |- tInd {| inductive_mind := inductive_mind ind; inductive_ind := i |} u : subst_instance u (ind_type x)) 0 (ind_bodies mdecl)).
    { apply forall_nth_error_Alli.
      econstructor; eauto. split; eauto. simpl. eapply isdecl. }
    clear oind.
    revert X. clear onNpars.
    generalize (le_n #|ind_bodies mdecl|).
    generalize (ind_bodies mdecl) at 1 3 4 5.
    induction l using rev_ind; simpl; first constructor.
    rewrite /subst_instance /= /map_context.
    simpl. rewrite /arities_context rev_map_spec /=.
    rewrite map_app /= rev_app_distr /=.
    rewrite {1}/map_decl /= app_length /= Nat.add_1_r.
    constructor.
    - rewrite -rev_map_spec. apply IHl; try lia.
      eapply Alli_app in X; intuition auto.
    - eapply Alli_app in X as [oind Hx].
      depelim Hx. clear Hx.
      rewrite Nat.add_0_r in t.
      rewrite subst_closedn; auto.
      + now eapply type_closed in t.
  Qed.

  Lemma weaken_subslet {s Δ Γ} :
    wf_local Σ Γ ->
    subslet Σ [] s Δ -> subslet Σ Γ s Δ.
  Proof using wfΣ.
    intros wfΔ.
    induction 1; constructor; auto.
    + eapply (weaken_ctx (Γ:=[]) Γ); eauto.
    + eapply (weaken_ctx (Γ:=[]) Γ); eauto.
  Qed.

  Set Default Goal Selector "1".

  Lemma isType_substitution_it_mkProd_or_LetIn {Γ Δ T s} :
    subslet Σ Γ s Δ ->
    isType Σ Γ (it_mkProd_or_LetIn Δ T) ->
    isType Σ Γ (subst0 s T).
  Proof using wfΣ.
    intros sub HT.
    apply infer_typing_sort_impl with id HT; intros Hs.
    destruct HT as (s' & t); cbn in Hs |- *; clear t.
    revert Γ s sub Hs.
    generalize (le_n #|Δ|).
    generalize #|Δ| at 2.
    induction n in Δ, T |- *.
    - destruct Δ; simpl; intros; try (elimtype False; lia).
      depelim sub.
      rewrite subst_empty; auto.
    - destruct Δ using rev_ind; try clear IHΔ.
      + intros Hn Γ s sub; now depelim sub; rewrite subst_empty.
      + rewrite app_length Nat.add_1_r /= => Hn Γ s sub.
      pose proof (subslet_length sub). rewrite app_length /= Nat.add_1_r in H.
      have Hl : #|l| = #|firstn #|l| s|.
      { rewrite firstn_length_le; lia. }
      destruct x as [na [b|] ty] => /=;
      rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=.

      intros Hs.
      assert (wfs' := typing_wf_universe wfΣ Hs).
      eapply inversion_LetIn in Hs as (? & ? & ? & ? & ? & ?); auto.
      eapply substitution_let in t1; auto.
      eapply ws_cumul_pb_LetIn_l_inv in w; auto.
      pose proof (subslet_app_inv sub) as [subl subr].
      depelim subl. depelim subl. rewrite subst_empty in H0. rewrite H0 in subr.
      specialize (IHn (subst_context [b] 0 l) (subst [b] #|l| T) ltac:(rewrite subst_context_length; lia)).
      specialize (IHn _ _ subr).
      rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r in t1.
      rewrite !subst_empty in t3.
      forward IHn.
      eapply type_Cumul. eapply t1. econstructor; intuition eauto using typing_wf_local with pcuic.
      eapply (cumulAlgo_cumulSpec _ (pb:=Cumul)), w. rewrite {2}Hl in IHn.
      now rewrite -subst_app_simpl -H0 firstn_skipn in IHn.

      intros Hs.
      assert (wfs' := typing_wf_universe wfΣ Hs).
      eapply inversion_Prod in Hs as (? & ? & ? & ? & ?); auto.
      pose proof (subslet_app_inv sub) as [subl subr].
      depelim subl; depelim subl. rewrite subst_empty in t2. rewrite H0 in subr.
      epose proof (substitution0 t0 t2).
      specialize (IHn (subst_context [t1] 0 l) (subst [t1] #|l| T)).
      forward IHn. rewrite subst_context_length; lia.
      specialize (IHn _ _ subr).
      rewrite /subst1 subst_it_mkProd_or_LetIn Nat.add_0_r in X.
      forward IHn.
      eapply type_Cumul. simpl in X. eapply X.
      econstructor; eauto with pcuic.
      eapply ws_cumul_pb_Sort_inv in w. eapply cumul_Sort.
      transitivity (Universe.sort_of_product x x0).
      eapply leq_universe_product. auto.
      rewrite {2}Hl in IHn.
      now rewrite -subst_app_simpl -H0 firstn_skipn in IHn.
  Qed.

  Lemma on_minductive_wf_params {ind mdecl} {u} :
    declared_minductive Σ.1 ind mdecl ->
    consistent_instance_ext Σ (ind_universes mdecl) u ->
    wf_local Σ (subst_instance u (ind_params mdecl)).
  Proof using wfΣ.
    intros. eapply (wf_local_instantiate (decl := InductiveDecl mdecl)); eauto.
    eapply on_declared_minductive in H; auto.
    now apply onParams in H.
  Qed.

  Lemma it_mkProd_or_LetIn_wf_local {Γ Δ T U} :
    Σ ;;; Γ |- it_mkProd_or_LetIn Δ T : U -> wf_local Σ (Γ ,,, Δ).
  Proof using wfΣ.
    move: Γ T U.
    induction Δ using rev_ind => Γ T U.
    + simpl. intros. now eapply typing_wf_local in X.
    + rewrite it_mkProd_or_LetIn_app.
      destruct x as [na [b|] ty]; cbn; move=> H.
      * apply inversion_LetIn in H as (s1 & A & H0 & H1 & H2 & H3); auto.
        eapply All_local_env_app; split; pcuic.
        eapply All_local_env_app. split. repeat constructor. now exists s1.
        auto. apply IHΔ in H2.
        eapply All_local_env_app_inv in H2. intuition auto.
        eapply All_local_env_impl; eauto. simpl. intros.
        now rewrite app_context_assoc.
      * apply inversion_Prod in H as (s1 & A & H0 & H1 & H2); auto.
        eapply All_local_env_app; split; pcuic.
        eapply All_local_env_app. split. repeat constructor. now exists s1.
        apply IHΔ in H1.
        eapply All_local_env_app_inv in H1. intuition auto.
        eapply All_local_env_impl; eauto. simpl. intros.
        now rewrite app_context_assoc.
  Qed.

  Lemma isType_it_mkProd_or_LetIn_wf_local {Γ Δ T} :
    isType Σ Γ (it_mkProd_or_LetIn Δ T) -> wf_local Σ (Γ ,,, Δ).
  Proof using wfΣ.
    move=> [s Hs].
    now eapply it_mkProd_or_LetIn_wf_local in Hs.
  Qed.

  Lemma isType_weaken {Γ T} :
    wf_local Σ Γ ->
    isType Σ [] T ->
    isType Σ Γ T.
  Proof using wfΣ.
    intros wfΓ HT.
    apply infer_typing_sort_impl with id HT; intros hs.
    unshelve epose proof (subject_closed hs); eauto.
    eapply (weakening _ _ Γ) in hs => //.
    rewrite lift_closed in hs => //.
    now rewrite app_context_nil_l in hs.
    now rewrite app_context_nil_l.
  Qed.

  Lemma subst_telescope_subst_instance u s k Γ :
    subst_telescope (map (subst_instance u) s) k
      (subst_instance u Γ) =
    subst_instance u (subst_telescope s k Γ).
  Proof using Type.
    rewrite /subst_telescope /subst_instance /= /subst_instance_context /map_context.
    rewrite map_mapi mapi_map. apply mapi_ext.
    intros. rewrite !compose_map_decl; apply map_decl_ext => ?.
    now rewrite -subst_instance_subst.
  Qed.
End WfEnv.


Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.

Inductive insn :=
| Block (code : list insn)
| Arg
| Self
| Deref (off : nat)
| Call
| MkConstr (tag : nat) (nargs : nat)
| Switch (cases : list (list insn))
| MkClose (f : function_name) (nfree : nat)
| OpaqueOp (op : opaque_oper_name) (nargs : nat)
.

Definition env := list (list insn).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    stack : list value
}.

Definition push f v :=
    Frame (arg f) (self f) (v :: stack f).

Inductive state :=
| Run (i : list insn) (f : frame) (k : value -> state)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SBlock : forall code is f k,
        sstep E (Run (Block code :: is) f k)
                (Run code (Frame (arg f) (self f) []) (fun v => Run is (push f v) k))

| SArg : forall f k,
        stack f = [] ->
        sstep E (Run [Arg] f k) (k (arg f))
| SSelf : forall f k,
        stack f = [] ->
        sstep E (Run [Self] f k) (k (self f))

| SDerefinateConstr : forall off f k  tag args v,
        stack f = [Constr tag args] ->
        nth_error args off = Some v ->
        sstep E (Run [Deref off] f k) (k v)
| SDerefinateClose : forall off f k  fname free v,
        stack f = [Close fname free] ->
        nth_error free off = Some v ->
        sstep E (Run [Deref off] f k) (k v)

| SConstrDone : forall tag nargs f k,
        length (stack f) = nargs ->
        sstep E (Run [MkConstr tag nargs] f k)
                (k (Constr tag (rev (stack f))))
| SCloseDone : forall fname nfree f k,
        length (stack f) = nfree ->
        sstep E (Run [MkClose fname nfree] f k)
                (k (Close fname (rev (stack f))))
| SOpaqueOpDone : forall op nargs f k v,
        length (stack f) = nargs ->
        opaque_oper_denote_higher op (rev (stack f)) = Some v ->
        sstep E (Run [OpaqueOp op nargs] f k)
                (k v)

| SMakeCall : forall f k  fname free body argv,
        stack f = [argv; Close fname free] ->
        nth_error E fname = Some body ->
        sstep E (Run [Call] f k)
                (Run body (Frame argv (Close fname free) []) k)

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall cases f k  tag args case,
        stack f = [] ->
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run [Switch cases] f k)
                (Run case (Frame (arg f) (self f) []) k)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 Stop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition insn_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HBlock :   forall code, Pl code -> P (Block code))
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (i : insn) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        let fix go_list_list iss :=
            match iss as iss_ return Pll iss_ with
            | [] => Hnil2
            | is :: iss => Hcons2 is iss (go_list is) (go_list_list iss)
            end in
        match i as i_ return P i_ with
        | Block code => HBlock code (go_list code)
        | Arg => HArg
        | Self => HSelf
        | Deref off => HDeref off
        | Call => HCall
        | MkConstr tag nargs => HConstr tag nargs
        | Switch cases => HSwitch cases (go_list_list cases)
        | MkClose fname nfree => HClose fname nfree
        | OpaqueOp op nargs => HOpaqueOp op nargs
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition insn_ind' (P : insn -> Prop)
    (HBlock :   forall code, Forall P code -> P (Block code))
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Forall (Forall P) cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (i : insn) : P i :=
    ltac:(refine (@insn_rect_mut P (Forall P) (Forall (Forall P))
        HBlock HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp _ _ _ _ i); eauto).

Definition insn_list_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HBlock :   forall code, Pl code -> P (Block code))
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (is : list insn) : Pl is :=
    let go := insn_rect_mut P Pl Pll
            HBlock HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp
            Hnil Hcons Hnil2 Hcons2 in
    let fix go_list is :=
        match is as is_ return Pl is_ with
        | [] => Hnil
        | i :: is => Hcons i is (go i) (go_list is)
        end in go_list is.


From Mtac2 Require Import Mtac2.

Class Test := { val : nat }.

#[global] Instance Zero : Test := {| val := 0 |}.

Import M.notations.

Definition CouldntFindTC : Exception. exact exception. Qed.

Definition fail_solve_tc A :=
  M.solve_typeclass A >>= fun x=>
  match x with
  | mSome v => M.ret v
  | mNone => M.raise CouldntFindTC
  end.

Definition zero := ltac:(mrun (fail_solve_tc Test >>= fun x=>M.ret (@val x))).

Goal zero = 0.
MProof.
  T.reflexivity.
Qed.

Class TestFail := { valF : nat }.

Definition fail_but_caught := ltac: (mrun (
  mtry fail_solve_tc TestFail;; M.ret 1
  with CouldntFindTC => M.ret 0 end)).

Goal fail_but_caught = 0.
MProof.
  T.reflexivity.
Qed.