Require Import GeoCoq.Tarski_dev.Ch08_orthogonality.

Section Coplanar.

Context `{Tn:Tarski_neutral_dimensionless}.

Lemma coplanar_perm_1 : forall A B C D,
  Coplanar A B C D -> Coplanar A B D C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_2 : forall A B C D,
  Coplanar A B C D -> Coplanar A C B D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_3 : forall A B C D,
  Coplanar A B C D -> Coplanar A C D B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_4 : forall A B C D,
  Coplanar A B C D -> Coplanar A D B C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_5 : forall A B C D,
  Coplanar A B C D -> Coplanar A D C B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_6 : forall A B C D,
  Coplanar A B C D -> Coplanar B A C D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_7 : forall A B C D,
  Coplanar A B C D -> Coplanar B A D C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_8 : forall A B C D,
  Coplanar A B C D -> Coplanar B C A D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_9 : forall A B C D,
  Coplanar A B C D -> Coplanar B C D A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_10 : forall A B C D,
  Coplanar A B C D -> Coplanar B D A C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_11 : forall A B C D,
  Coplanar A B C D -> Coplanar B D C A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_12 : forall A B C D,
  Coplanar A B C D -> Coplanar C A B D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_13 : forall A B C D,
  Coplanar A B C D -> Coplanar C A D B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_14 : forall A B C D,
  Coplanar A B C D -> Coplanar C B A D.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_15 : forall A B C D,
  Coplanar A B C D -> Coplanar C B D A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_16 : forall A B C D,
  Coplanar A B C D -> Coplanar C D A B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_17 : forall A B C D,
  Coplanar A B C D -> Coplanar C D B A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_18 : forall A B C D,
  Coplanar A B C D -> Coplanar D A B C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_19 : forall A B C D,
  Coplanar A B C D -> Coplanar D A C B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_20 : forall A B C D,
  Coplanar A B C D -> Coplanar D B A C.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_21 : forall A B C D,
  Coplanar A B C D -> Coplanar D B C A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_22 : forall A B C D,
  Coplanar A B C D -> Coplanar D C A B.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma coplanar_perm_23 : forall A B C D,
  Coplanar A B C D -> Coplanar D C B A.
Proof.
intros A B C D HCop.
destruct HCop as [X H]; exists X.
induction H; try (induction H); spliter; Col5.
Qed.

Lemma ncoplanar_perm_1 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A B D C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_1, HCop.
Qed.

Lemma ncoplanar_perm_2 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A C B D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_2, HCop.
Qed.

Lemma ncoplanar_perm_3 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A C D B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_4, HCop.
Qed.

Lemma ncoplanar_perm_4 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A D B C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_3, HCop.
Qed.

Lemma ncoplanar_perm_5 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar A D C B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_5, HCop.
Qed.

Lemma ncoplanar_perm_6 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B A C D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_6, HCop.
Qed.

Lemma ncoplanar_perm_7 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B A D C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_7, HCop.
Qed.

Lemma ncoplanar_perm_8 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B C A D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_12, HCop.
Qed.

Lemma ncoplanar_perm_9 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B C D A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_18, HCop.
Qed.

Lemma ncoplanar_perm_10 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B D A C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_13, HCop.
Qed.

Lemma ncoplanar_perm_11 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar B D C A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_19, HCop.
Qed.

Lemma ncoplanar_perm_12 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C A B D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_8, HCop.
Qed.

Lemma ncoplanar_perm_13 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C A D B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_10, HCop.
Qed.

Lemma ncoplanar_perm_14 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C B A D.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_14, HCop.
Qed.

Lemma ncoplanar_perm_15 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C B D A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_20, HCop.
Qed.

Lemma ncoplanar_perm_16 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C D A B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_16, HCop.
Qed.

Lemma ncoplanar_perm_17 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar C D B A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_22, HCop.
Qed.

Lemma ncoplanar_perm_18 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D A B C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_9, HCop.
Qed.

Lemma ncoplanar_perm_19 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D A C B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_11, HCop.
Qed.

Lemma ncoplanar_perm_20 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D B A C.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_15, HCop.
Qed.

Lemma ncoplanar_perm_21 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D B C A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_21, HCop.
Qed.

Lemma ncoplanar_perm_22 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D C A B.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_17, HCop.
Qed.

Lemma ncoplanar_perm_23 : forall A B C D,
  ~ Coplanar A B C D -> ~ Coplanar D C B A.
Proof.
intros A B C D HNCop HCop; apply HNCop.
apply coplanar_perm_23, HCop.
Qed.

Lemma coplanar_trivial : forall A B C, Coplanar A A B C.
Proof.
intros.
exists B; Col5.
Qed.

Lemma col__coplanar : forall A B C D,
  Col A B C -> Coplanar A B C D.
Proof.
intros.
exists C; Col5.
Qed.

Lemma ncop__ncol : forall A B C D,
  ~ Coplanar A B C D -> ~ Col A B C.
Proof.
intros.
intro.
apply H, col__coplanar, H0.
Qed.

Lemma ncop__ncols : forall A B C D,
  ~ Coplanar A B C D -> ~ Col A B C /\ ~ Col A B D /\ ~ Col A C D /\ ~ Col B C D.
Proof.
intros; repeat split.
apply ncop__ncol with D, H.
apply ncop__ncol with C, ncoplanar_perm_1, H.
apply ncop__ncol with B, ncoplanar_perm_3, H.
apply ncop__ncol with A, ncoplanar_perm_9, H.
Qed.

Lemma bet__coplanar : forall A B C D,
  Bet A B C -> Coplanar A B C D.
Proof.
intros.
apply col__coplanar; Col.
Qed.

Lemma out__coplanar : forall A B C D,
  Out A B C -> Coplanar A B C D.
Proof.
intros.
apply col__coplanar; Col.
Qed.

Lemma midpoint__coplanar : forall A B C D,
  Midpoint A B C -> Coplanar A B C D.
Proof.
intros A B C D [].
apply col__coplanar; Col.
Qed.

Lemma perp__coplanar : forall A B C D,
  Perp A B C D -> Coplanar A B C D.
Proof.
intros A B C D [P HP].
unfold Perp_at in HP; spliter.
exists P; left; Col.
Qed.

Lemma ts__coplanar : forall A B C D,
  TS A B C D -> Coplanar A B C D.
Proof.
intros A B C D [_ [_ [X []]]].
exists X; left; split; Col.
Qed.

Lemma reflectl__coplanar : forall A B C D,
  ReflectL A B C D -> Coplanar A B C D.
Proof.
intros A B C D [[X [[] HCol]] _].
exists X.
left; split; Col.
Qed.

Lemma reflect__coplanar : forall A B C D,
  Reflect A B C D -> Coplanar A B C D.
Proof.
intros A B C D [[_ HR]|[Heq]].
  apply reflectl__coplanar, HR.
subst; apply coplanar_perm_16, coplanar_trivial.
Qed.

Lemma inangle__coplanar : forall A B C D,
  InAngle A B C D -> Coplanar A B C D.
Proof.
intros A B C D H.
unfold InAngle in H; spliter.
destruct H2 as [X [HBet Dij]].
exists X; right; left.
split; Col.
induction Dij; [subst|]; Col.
Qed.

Lemma pars__coplanar : forall A B C D,
  Par_strict A B C D -> Coplanar A B C D.
Proof.
  unfold Par_strict; intros; spliter; assumption.
Qed.

Lemma par__coplanar : forall A B C D,
  Par A B C D -> Coplanar A B C D.
Proof.
  intros A B C D H.
  destruct H.
    apply pars__coplanar; assumption.
  spliter; exists A; left; Col.
Qed.

Lemma plg__coplanar : forall A B C D,
  Plg A B C D -> Coplanar A B C D.
Proof.
  intros A B C D [H [M [[H1 _] [H2 _]]]].
  exists M; right; left; split; Col.
Qed.

Lemma plgs__coplanar : forall A B C D,
  Parallelogram_strict A B C D -> Coplanar A B C D.
Proof.
  intros A B C D [_ [HPar _]].
  apply par__coplanar, HPar.
Qed.

Lemma plgf__coplanar : forall A B C D,
  Parallelogram_flat A B C D -> Coplanar A B C D.
Proof.
  intros A B C D [HCol _].
  apply col__coplanar, HCol.
Qed.

Lemma parallelogram__coplanar : forall A B C D,
  Parallelogram A B C D -> Coplanar A B C D.
Proof.
  intros A B C D [Hs|Hf].
    apply plgs__coplanar, Hs.
    apply plgf__coplanar, Hf.
Qed.

Lemma rhombus__coplanar : forall A B C D,
  Rhombus A B C D -> Coplanar A B C D.
Proof.
  unfold Rhombus.
  intros; spliter; apply plg__coplanar; assumption.
Qed.

Lemma rectangle__coplanar : forall A B C D,
  Rectangle A B C D -> Coplanar A B C D.
Proof.
  unfold Rectangle.
  intros; spliter; apply plg__coplanar; assumption.
Qed.

Lemma square__coplanar : forall A B C D,
  Square A B C D -> Coplanar A B C D.
Proof.
  unfold Square.
  intros; spliter; apply rectangle__coplanar; assumption.
Qed.

Lemma lambert__coplanar : forall A B C D,
  Lambert A B C D -> Coplanar A B C D.
Proof.
  unfold Lambert.
  intros; spliter; assumption.
Qed.

End Coplanar.

#[global]
Hint Resolve coplanar_perm_1 coplanar_perm_2 coplanar_perm_3 coplanar_perm_4 coplanar_perm_5
coplanar_perm_6 coplanar_perm_7 coplanar_perm_8 coplanar_perm_9 coplanar_perm_10 coplanar_perm_11
coplanar_perm_12 coplanar_perm_13 coplanar_perm_14 coplanar_perm_15 coplanar_perm_16 coplanar_perm_17
coplanar_perm_18 coplanar_perm_19 coplanar_perm_20 coplanar_perm_21 coplanar_perm_22 coplanar_perm_23
ncoplanar_perm_1 ncoplanar_perm_2 ncoplanar_perm_3 ncoplanar_perm_4 ncoplanar_perm_5 ncoplanar_perm_6
ncoplanar_perm_7 ncoplanar_perm_8 ncoplanar_perm_9 ncoplanar_perm_10 ncoplanar_perm_11
ncoplanar_perm_12 ncoplanar_perm_13 ncoplanar_perm_14 ncoplanar_perm_15 ncoplanar_perm_16
ncoplanar_perm_17 ncoplanar_perm_18 ncoplanar_perm_19 ncoplanar_perm_20 ncoplanar_perm_21
ncoplanar_perm_22 ncoplanar_perm_23 : cop_perm.

#[global]
Hint Resolve coplanar_trivial col__coplanar bet__coplanar out__coplanar midpoint__coplanar
perp__coplanar ts__coplanar reflectl__coplanar reflect__coplanar inangle__coplanar pars__coplanar
par__coplanar plg__coplanar plgs__coplanar plgf__coplanar parallelogram__coplanar rhombus__coplanar
rectangle__coplanar square__coplanar lambert__coplanar : cop.

Ltac not_exist_hyp_perm_cop_aux A B C D :=
  not_exist_hyp (Coplanar A B C D); not_exist_hyp (Coplanar A B D C); not_exist_hyp (Coplanar A C B D);
  not_exist_hyp (Coplanar A C D B); not_exist_hyp (Coplanar A D B C); not_exist_hyp (Coplanar A D C B).

Ltac not_exist_hyp_perm_cop A B C D := not_exist_hyp_perm_cop_aux A B C D;
                                       not_exist_hyp_perm_cop_aux B A C D;
                                       not_exist_hyp_perm_cop_aux C A B D;
                                       not_exist_hyp_perm_cop_aux D A B C.

Ltac assert_cops :=
 repeat match goal with
      | H:Perp ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply perp__coplanar, H)
      | H:TS ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply ts__coplanar, H)
      | H:ReflectL ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply reflectl__coplanar, H)
      | H:Reflect ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply reflect__coplanar, H)
      | H:InAngle ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply inangle__coplanar, H)
      | H:Par_strict ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply pars__coplanar, H)
      | H:Par ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply par__coplanar, H)
      | H:Plg ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply plg__coplanar, H)
      | H:Parallelogram_strict ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply plgs__coplanar, H)
      | H:Parallelogram_flat ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply plgf__coplanar, H)
      | H:Parallelogram ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply parallelogram__coplanar, H)
      | H:Rhombus ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply rhombus__coplanar, H)
      | H:Rectangle ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply rectangle__coplanar, H)
      | H:Square ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply square__coplanar, H)
      | H:Lambert ?X1 ?X2 ?X3 ?X4 |- _ =>
     not_exist_hyp_perm_cop X1 X2 X3 X4; assert (Coplanar X1 X2 X3 X4) by (apply lambert__coplanar, H)
 end.

Ltac exist_hyp_perm_cop_aux A B C D := first
  [exist_hyp (Coplanar A B C D)|exist_hyp (Coplanar A B D C)|exist_hyp (Coplanar A C B D)
  |exist_hyp (Coplanar A C D B)|exist_hyp (Coplanar A D B C)|exist_hyp (Coplanar A D C B)].

Ltac exist_hyp_perm_cop A B C D := first
  [exist_hyp_perm_cop_aux A B C D|exist_hyp_perm_cop_aux B A C D
  |exist_hyp_perm_cop_aux C A B D|exist_hyp_perm_cop_aux D A B C].

Ltac exist_hyp_perm_ncop_aux A B C D := first
  [exist_hyp (~ Coplanar A B C D)|exist_hyp (~ Coplanar A B D C)|exist_hyp (~ Coplanar A C B D)
  |exist_hyp (~ Coplanar A C D B)|exist_hyp (~ Coplanar A D B C)|exist_hyp (~ Coplanar A D C B)].

Ltac exist_hyp_perm_ncop A B C D := first
  [exist_hyp_perm_ncop_aux A B C D|exist_hyp_perm_ncop_aux B A C D
  |exist_hyp_perm_ncop_aux C A B D|exist_hyp_perm_ncop_aux D A B C].

Ltac Cop := auto; try (intros; solve [apply col__coplanar; Col
     |apply coplanar_perm_1, col__coplanar; Col|apply coplanar_perm_4, col__coplanar; Col
     |apply coplanar_perm_18, col__coplanar; Col
     |assert_cops; auto 2 with cop_perm]).


(** A first attempt to make a typed assembly language. Only calls to inlined
   functions and conditional jumps to following intructions. Termination of the
   evaluation is trivial. *)
Set Implicit Arguments.

Module Asm.
  (** [S] is the memory, [L] is the logical state. *)
  Inductive t (S : Set) (L : S -> Type) : Type :=
  | op :
    forall (f : S -> S), (forall s, L s -> L (f s)) ->
    t L -> t L
  | jcc :
    (S -> bool) -> (forall s, L s -> L s) ->
    t L -> t L -> t L
  | call :
    forall (fx : S -> S), (forall s, L s -> L (fx s)) ->
    forall (fy : S -> S), (forall s, L s -> L (fy s)) ->
    t L -> t L -> t L
  | ret :
    t L.

  Fixpoint eval (S : Set) (L : S -> Type) (a : t L) (s : S) (l : L s) {struct a} : {s : S & L s}.
    destruct a as [fs fl n | c fl nnc n | xs xl ys yl f n | ].
      exact (
        let l := fl s l in
        let s := fs s in
        eval _ _ n s l).

      exact (
        let l := fl s l in
        if c s then
          eval _ _ n s l
        else
          let (s, l) := eval _ _ nnc s l in
          eval _ _ n s l).

      exact (
        let l := xl s l in
        let s := xs s in
        let (s, l) := eval _ _ f s l in
        let l := yl s l in
        let s := ys s in
        eval _ _ n s l).

      exact (existT _ s l).
  Defined.
End Asm.

Import Asm.
Require Import Arith.Compare_dec.

(** A program where the state is a single natural number, and the logical world
    a proof that it is greater or equal to three. *)
Definition test1 : t (fun n => 3 <= n).
  refine (
    op (fun _ => 12) _ (
    op (fun n => n + 1) _ (
    ret _)));
  auto with *.
Defined.

Compute eval test1 3 (leb_complete 3 3 eq_refl).


From Coq Require Import List.
From mathcomp Require Import ssreflect.
From ssrlib Require Import Tactics.

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

Inductive nonempty_list A : Type :=
| NonemptyList : forall (hd : A) (tl : list A), nonempty_list A.

Definition nonempty_list_to_list A (l : nonempty_list A) : list A :=
  match l with
  | NonemptyList hd tl => hd::tl
  end.

Coercion nonempty_list_to_list : nonempty_list >-> list.

Definition nonempty_hd A (l : nonempty_list A) : A :=
  match l with
  | NonemptyList hd tl => hd
  end.

From Coq Require Import SetoidList.
From mathcomp Require Import eqtype ssrbool seq.

Section INA.

  Variable S : eqType.

  Lemma in_inA (x : S) (l : seq S) :
    (x \in l) -> (SetoidList.InA (fun x y => x == y) x l).
  Proof.
    elim: l x => /=.
    - move=> x Hin.
      rewrite in_nil in Hin.
      discriminate.
    - move=> hd tl IH x Hin.
      case Hx: (x == hd).
      + apply: InA_cons_hd.
        assumption.
      + rewrite in_cons Hx /= in Hin.
        apply: InA_cons_tl.
        exact: (IH _ Hin).
  Qed.

  Lemma inA_in (x : S) (l : seq S) :
    (SetoidList.InA (fun x y => x == y) x l) -> (x \in l).
  Proof.
    elim: l x => /=.
    - move=> x Hin; by inversion_clear Hin.
    - move=> hd tl IH x Hin.
      rewrite in_cons.
      inversion_clear Hin.
      + by rewrite H.
      + apply/orP; right; apply: IH.
        assumption.
  Qed.

  Lemma InAP (x : S) (l : seq S) : reflect (SetoidList.InA (fun x y => x == y) x l) (x \in l).
  Proof.
    case Hin: (x \in l).
    - apply: ReflectT.
      exact: (in_inA Hin).
    - apply: ReflectF.
      move=> HinA.
      move/negP: Hin; apply.
      exact: (inA_in HinA).
  Qed.

End INA.

Section ListLemmas.

  Variable A : Type.

  Variable B : Type.

  Lemma split_cons :
    forall (hd : A * B) (tl : list (A * B)),
      split (hd::tl) = ((fst hd)::(fst (split tl)), (snd hd)::(snd (split tl))).
  Proof.
    move=> [hd1 hd2] tl /=. dcase (split tl). move=> [ls1 ls2] Hspl /=.
    reflexivity.
  Qed.

  Lemma split_append :
    forall (ls1 ls2 : list (A * B)),
      split (ls1 ++ ls2) = ((fst (split ls1)) ++ (fst (split ls2)), (snd (split ls1)) ++ (snd (split ls2))).
  Proof.
    elim.
    - move=> ls2 /=. exact: surjective_pairing.
    - move=> [l1_hd1 l1_hd2] l1_tl IH ls2 /=. rewrite IH.
      dcase (split l1_tl). move=> [l1_tl1 l1_tl2] Hspl1. reflexivity.
  Qed.

  Lemma existsb_rcons (f : A -> bool) s x :
    existsb f (rcons s x) = existsb f s || f x.
  Proof.
    elim: s x => [| a s IH] x /=.
    - by rewrite orbF.
    - rewrite IH orbA. reflexivity.
  Qed.

  Section InA.

    Variable eqA eqB : A -> A -> Prop.

    Definition is_eq (eqA : A -> A -> Prop) : Prop :=
      forall x y, eqA x y -> x = y.

    Variable eqA_is_eq : is_eq eqA.

    Lemma InA_eqB x s :
      (forall x y, eqA x y -> eqB x y) ->
      InA eqA x s -> InA eqB x s.
    Proof.
      move=> H. elim: s x => [| a s IH] x Hin //=.
      - by inversion_clear Hin.
      - case/InA_cons : Hin => Hin.
        + left. exact: (H _ _ Hin).
        + right. exact: (IH _ Hin).
    Qed.

    Lemma InA_eq_In x (s : seq A) : InA Logic.eq x s -> In x s.
    Proof.
      elim: s x => [| a s IH] x Hin //=.
      - by inversion_clear Hin.
      - case/InA_cons : Hin => Hin.
        + rewrite Hin; by left.
        + right; exact: (IH _ Hin).
    Qed.

    Lemma InA_In x (s : seq A) : InA eqA x s -> In x s.
    Proof.
      elim: s x => [| a s IH] x Hin //=.
      - by inversion_clear Hin.
      - case/InA_cons : Hin => Hin.
        + rewrite (eqA_is_eq Hin); by left.
        + right; exact: (IH _ Hin).
    Qed.

  End InA.

  Lemma List_rev_rev (s : seq A) : List.rev s = rev s.
  Proof. elim: s => [| x s IH] //=. rewrite rev_cons -cats1. by rewrite IH. Qed.

  Lemma List_rev_rcons (s : seq A) (a : A) :
    List.rev (rcons s a) = a::(List.rev s).
  Proof.
    elim: s a => [| x s IH] a //=. rewrite IH.
    rewrite -cat_cons. reflexivity.
  Qed.

  Lemma List_rev_cat (s1 s2 : seq A) :
    List.rev (s1 ++ s2) = List.rev s2 ++ List.rev s1.
  Proof.
    elim: s1 s2 => [| x1 s1 IH1] s2 //=.
    - rewrite cats0. reflexivity.
    - rewrite IH1. rewrite catA. reflexivity.
  Qed.

  Lemma Exists_rcons (P : A -> Prop) (s : seq A) (a : A) :
    Exists P (rcons s a) <-> Exists P s \/ P a.
  Proof.
    elim: s => [| x s IH] //=.
    - split => H.
      + by case/Exists_cons: H => H; tauto.
      + case: H => H.
        * by inversion H.
        * exact: Exists_cons_hd.
    - move: IH => [IH1 IH2]. split => H.
      + case/Exists_cons: H => H.
        * left; exact: Exists_cons_hd.
        * case: (IH1 H) => {}H.
          -- left; exact: Exists_cons_tl.
          -- by right.
      + have H': P x \/ Exists P s \/ P a.
        { case: H; [ move=> H | tauto ]. move/Exists_cons: H => {}H; by tauto. }
        case: H' => H'.
        * exact: Exists_cons_hd.
        * apply: Exists_cons_tl. exact: IH2.
  Qed.

  Lemma Forall_rcons_iff (P : A -> Prop) (s : seq A) (a : A) :
    Forall P (rcons s a) <-> Forall P s /\ P a.
  Proof.
    elim: s => [| x s IH] //=.
    - split => H.
      + move/Forall_cons_iff: H => [H1 H2]; tauto.
      + apply: Forall_cons; tauto.
    - move: IH => [IH1 IH2]. split => H.
      + move/Forall_cons_iff: H => [H1 H2].
        split; [ apply: Forall_cons |]; tauto.
      + move: H => [H1 H2]. move/Forall_cons_iff: H1 => [H1 H3].
        apply: Forall_cons; tauto.
  Qed.

  Lemma Forall_rcons (P : A -> Prop) (s : seq A) (a : A) :
    Forall P s -> P a -> Forall P (rcons s a).
  Proof. move=> ? ?; apply/Forall_rcons_iff; done. Qed.

  Lemma Forall_rcons_hd (P : A -> Prop) (s : seq A) (a : A) :
    Forall P (rcons s a) -> Forall P s.
  Proof. by move/Forall_rcons_iff => [H1 H2]. Qed.

  Lemma Forall_rcons_tl (P : A -> Prop) (s : seq A) (a : A) :
    Forall P (rcons s a) -> P a.
  Proof. by move/Forall_rcons_iff => [H1 H2]. Qed.

  Lemma Exists_cat (P : A -> Prop) (s1 s2 : seq A) :
    Exists P (s1 ++ s2) <-> Exists P s1 \/ Exists P s2.
  Proof.
    elim: s1 s2 => [| x1 s1 IH1] s2 //=.
    - split => H; first tauto. case: H; last tauto. by inversion 1.
    - split => H.
      + case/Exists_cons: H => H.
        * by left; apply: Exists_cons_hd.
        * case/(IH1 _): H => H.
          -- by left; apply: Exists_cons_tl.
          -- by right.
      + have H': P x1 \/ Exists P s1 \/ Exists P s2.
        { case: H; [ move=> H | tauto ]. move/Exists_cons: H => {}H; by tauto. }
        case: H' => H'.
        * by apply: Exists_cons_hd.
        * apply: Exists_cons_tl. apply/IH1. assumption.
  Qed.

  Lemma Forall_cat_iff (P : A -> Prop) (s1 s2 : seq A) :
    Forall P (s1 ++ s2) <-> Forall P s1 /\ Forall P s2.
  Proof. exact: Forall_app. Qed.

  Lemma Forall_cat_l (P : A -> Prop) (s1 s2 : seq A) :
    Forall P (s1 ++ s2) -> Forall P s1.
  Proof. by move/Forall_cat_iff => [H1 H2]. Qed.

  Lemma Forall_cat_r (P : A -> Prop) (s1 s2 : seq A) :
    Forall P (s1 ++ s2) -> Forall P s2.
  Proof. by move/Forall_cat_iff => [H1 H2]. Qed.

  Lemma Forall_cat (P : A -> Prop) (s1 s2 : seq A) :
    Forall P s1 -> Forall P s2 -> Forall P (s1 ++ s2).
  Proof. by move=> H1 H2; apply/Forall_cat_iff. Qed.

  Lemma Exists_rev (P : A -> Prop) (s : seq A) :
    List.Exists P (rev s) <-> List.Exists P s.
  Proof.
    elim: s => [| x s IH] //=. move: IH => [IH1 IH2].
    rewrite rev_cons. split.
    - move/Exists_rcons => [] H.
      + apply: Exists_cons_tl. exact: IH1.
      + apply: Exists_cons_hd; assumption.
    - move=> H. apply/Exists_rcons. case/Exists_cons: H => H.
      + by right.
      + by left; apply: IH2.
  Qed.

  Lemma Forall_rev (P : A -> Prop) (s : seq A) :
    List.Forall P (rev s) <-> List.Forall P s.
  Proof.
    split => H.
    - move: (Forall_rev H). rewrite List_rev_rev revK. by apply.
    - move: (Forall_rev H). rewrite List_rev_rev. by apply.
  Qed.

End ListLemmas.


(** Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
 *  Jean-Baptiste Tristan, and Edward Gan.
 *
 *  This file is part of RockSalt.
 *
 *  This file 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 2 of
 *  the License, or (at your option) any later version.
 *)

Require Import Tacs.
Require Import List.
Require Import ZArith.
Require Export Psatz.
Require Coqlib.
Require Import Bits.
Export Word.

Local Open Scope Z_scope.

(** Data structures *)
Require Coq.Sets.Ensembles.
Definition Int32Ensemble := Ensembles.Ensemble int32.
Definition w32add := @Word.add 31.
Definition w32sub := @Word.sub 31.
Definition w32neg := @Word.neg 31.
Notation w32modulus := (modulus 31).

(** Abbreviations *)
Infix "+32" := w32add (at level 50, left associativity).
Notation "i +32_z z" := (i +32 (repr z))
  (at level 50, left associativity).
Notation "i +32_p p" := (i +32 (repr (Zpos p)))
  (at level 50, left associativity).
Notation "i +32_n n" := (i +32 (repr (Z_of_nat n)))
  (at level 50, left associativity).

Infix "-32" := w32sub (at level 50, left associativity).
Notation "i -32_z z" := (i -32 (repr z))
  (at level 50, left associativity).
Notation "i -32_p p" := (i -32 (repr (Zpos p)))
  (at level 50, left associativity).
Notation "i -32_n n" := (i -32 (repr (Z_of_nat n)))
  (at level 50, left associativity).

Notation "-32" := w32neg (at level 35, right associativity).

Notation int32_zero := (@Word.zero 31).
(*Notation int32_max := (@repr 31 (Word.max_unsigned 31))*)
Notation int32_max := (@Word.mone 31).
Notation int32_of_nat n := (@repr 31 (Z_of_nat n)).

Definition int32_ltu_bool := @Word.ltu 31.
Definition int32_eq_bool := @Word.eq 31.
Definition int32_lequ_bool := @Word.lequ 31.
Definition int32_gtu_bool i1 i2 := (int32_ltu_bool i2 i1).
Definition int32_gequ_bool i1 i2 := (int32_lequ_bool i2 i1).

Notation "i1 =32 i2" := (int32_eq_bool i1 i2 = true) (at level 70).
Notation "i1 <>32 i2" := (int32_eq_bool i1 i2 = false) (at level 70).
Notation "i1 <32 i2" := (int32_ltu_bool i1 i2 = true) (at level 70).
Notation "i1 <=32 i2" := (int32_lequ_bool i1 i2 = true) (at level 70).
Notation "i1 >32 i2" := (int32_gtu_bool i1 i2 = true) (at level 70).
Notation "i1 >=32 i2" := (int32_gequ_bool i1 i2 = true) (at level 70).

(** Basic lemmas *)

Lemma add32_zero_r : forall i, i +32_n 0 = i.
Proof. simpl. apply add_zero. Qed.

Lemma int32_modulus_constant:
  w32modulus = 4294967296.
Proof. unfold modulus. unfold Word.wordsize.
  trivial.
Qed.

Lemma int32_eq_rewrite :
  forall i1 i2, i1 = i2 -> i1 =32 i2.
Proof. apply int_eq_true_iff2. Qed.

Lemma int32_neq_rewrite :
  forall i1 i2, i1 <> i2 -> i1 <>32 i2.
Proof. apply int_eq_false_iff2. Qed.

Lemma int32_minus_rewrite : forall x y,
  unsigned x >= unsigned y -> unsigned (x -32 y) = unsigned x - unsigned y.
Proof. intros. unfold w32sub, sub. rewrite unsigned_repr2. trivial.
  generalize (unsigned_range x), (unsigned_range y). omega.
Qed.

Remark Zmod_plus_eq_self : forall a b c, (a + b) mod c = a mod c -> b mod c = 0.
Proof. intros.
  assert (b = (a+b-a)) as H2 by ring.
  rewrite H2. rewrite Zminus_mod. rewrite H. rewrite Zminus_diag.
  apply Zmod_0_l.
Qed.

Lemma int32_plus_eq_zero : forall x y, x = x +32 y -> y = int32_zero.
Proof. intros x y Hc.
  destruct x as [xv Hx]. destruct y as [yv Hy].
  unfold Word.add, repr in Hc. simpl in Hc.
  injection Hc. intro H4.
  apply mkint_eq.
  assert (xv = xv mod w32modulus) as H6.
    apply eq_sym. apply Zmod_small. assumption.
  rewrite H6 in H4 at 1.
  apply eq_sym in H4. apply Zmod_plus_eq_self in H4.
  rewrite Zmod_small in H4 by assumption. rewrite H4.
  rewrite Zmod_0_l. trivial.
Qed.

(** Tactics for int32 *)

(** Convert operations on int32 to operations on Z *)

(* converting x=y to unsigned x = unsigned y, when x and y are of type int32 *)
Ltac elim_int32_eq :=
  repeat match goal with
    | [H: ?X = ?Y |- _] =>
      match type of X with
        | wint 31 => assert (unsigned X = unsigned Y) by congruence; clear H
        | _ => idtac
      end
  end.

Ltac int32_to_Z_tac :=
  unfold int32_gtu_bool, int32_gequ_bool,
    int32_lequ_bool, int32_ltu_bool, int32_eq_bool in *;
  autorewrite with int_to_Z in *;
  elim_int32_eq.

(** convert nat to Z *)
Hint Rewrite inj_plus inj_mult : nat_to_Z.
Hint Rewrite inj_minus1 using omega : nat_to_Z.
Hint Rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P : nat_to_Z.

Lemma Z_of_nat_0 : Z_of_nat 0%nat = 0. trivial. Qed.
Lemma Z_of_nat_1 : Z_of_nat 1%nat = 1. trivial. Qed.
Hint Rewrite Z_of_nat_0 Z_of_nat_1 : nat_to_Z.

Lemma inj_S2 : forall n, (Z_of_nat (S n) = Z_of_nat n + 1).
Proof. intros. apply inj_S. Qed.
Hint Rewrite inj_S2 : nat_to_Z.

Hint Rewrite inj_Zabs_nat : nat_to_Z.
Hint Rewrite Zabs_eq using omega: nat_to_Z.

(** Converting hypothesis about nats to Z:
 *    * n1 = n2 ===> Z_of_nat n1 = Z_of_nat n2
 *    * n1 > n2 ===> Z_of_nat n1 > Z_of_nat n2
 *    * ...
 *  This would not be necessary if we used omega instead of lia.
 *  Since lia cannot mix facts of Z and nat, we have to
 *  convert every equality and inquality between nat to Z;
 *  we also have to add hypothesis (Z_of_nat n >=0) for every
 *  nat n.
 *)
Ltac nat_hyp_to_Z_tac :=
  repeat match goal with
           | [H : ?X = ?Y |- _] =>
             match type of X with
               | nat => apply inj_eq in H
               | _ => fail 1
             end
           | [H: le ?X ?Y |- _] =>  apply inj_le in H
           | [H: Peano.gt ?X ?Y |- _] =>  apply inj_gt in H
           | [H: ge ?X ?Y |- _] =>  apply inj_ge in H
           | [H: Peano.lt ?X ?Y |- _] =>  apply inj_lt in H
           | [n: nat |- _] => extend (Zle_0_nat n)
         end.

(** need to repeat autorewrite below because rewritng rules such as inj_minus1 might
 *  depend on the results of other rewriting rules so that omega will succeed *)
Ltac nat_to_Z_tac :=  nat_hyp_to_Z_tac; repeat autorewrite with nat_to_Z in *.
Ltac nat_to_Z_in_goal :=  autorewrite with nat_to_Z.
Ltac nat_to_Z_in H :=  autorewrite with nat_to_Z in H.

(** convert Z to nat *)
Hint Rewrite <- inj_plus inj_mult: Z_to_nat.
Hint Rewrite <- inj_minus1 using omega : Z_to_nat.
Hint Rewrite <- Z_of_nat_0 Z_of_nat_1 : Z_to_nat.

Ltac Z_to_nat_in_goal := autorewrite with Z_to_nat.
Ltac Z_to_nat_in H := autorewrite with Z_to_nat in H.

(** Definition and properties of noOverflow *)
Definition addZ_list (l:list int32) : Z :=
  List.fold_right (fun (a:int32) (z:Z) => unsigned a + z) 0 l.

(** A semantic definition that adding a list of int32s does not overflow *)
Definition noOverflow (l:list int32) : Prop := addZ_list l < w32modulus.

Ltac noOverflow_simpl :=
  unfold noOverflow; cbv [addZ_list List.fold_right].
Ltac noOverflow_simpl_in H :=
  unfold noOverflow in H; cbv [addZ_list List.fold_right] in H.

(** Check a +32 b does not overflow; it is equivalent to a + b < 2^32
 *  and also equivalent to a +32 b = a + b; this formulation is easy to
 *  convert to checks in real programs. *)
Definition checkNoOverflow (a b:int32) : bool :=
  int32_lequ_bool a (a +32 b).

(** Properties of noOverflow *)
Lemma checkNoOverflow_equiv_noOverflow : forall a b,
  checkNoOverflow a b = true <-> noOverflow (a :: b :: nil).
Proof. intros; generalize (unsigned_range a), (unsigned_range b);
  intros Ha Hb; unfold checkNoOverflow, noOverflow; split.
  intros. int32_to_Z_tac. simpl. rewrite Zplus_0_r.
    apply Znot_ge_lt; intro Hc.
    unfold "+32", repr in H. simpl in H.
    assert ((unsigned a + unsigned b) mod w32modulus =
              unsigned a + unsigned b - w32modulus) as H5.
      apply Coqlib.Zmod_unique with (a:=1) ; omega.
    rewrite H5 in H. omega.
  intros. simpl in H. rewrite Zplus_0_r in H.
    int32_to_Z_tac. unfold "+32", repr. simpl.
    assert (0 <= unsigned a + unsigned b < w32modulus) by omega.
    rewrite (Zmod_small _ _ H0). omega.
Qed.

Lemma noOverflow_2_iff : forall a b,
  noOverflow (a::b::nil) <-> unsigned (a +32 b) = unsigned a + unsigned b.
Proof. intros; generalize (unsigned_range a), (unsigned_range b);
  intros Ha Hb; unfold noOverflow; split; unfold "+32", repr; simpl.
  intros. apply Zmod_small. simpl in H.
    omega.
  intros.
    assert (0 <= unsigned a + unsigned b < w32modulus).
      rewrite <- H; apply Z_mod_lt. apply Word.modulus_pos.
    omega.
Qed.

Lemma int32_add_rewrite : forall (a b:int32),
  unsigned a + unsigned b < w32modulus
    -> unsigned (a +32 b) = unsigned a + unsigned b.
Proof. intros. unfold "+32", repr. simpl.
  generalize (unsigned_range a) (unsigned_range b); intros.
  rewrite Zmod_small by omega. trivial.
Qed.

(** Tactics for noOverflow *)

(** Eliminate checkNoOverflow *)
Ltac checkNoOverflow_elim :=
  repeat match goal with
           | [H: checkNoOverflow _ _ = true |- _] =>
             apply checkNoOverflow_equiv_noOverflow in H
           | [ |- checkNoOverflow _ _ = true] =>
             apply checkNoOverflow_equiv_noOverflow
         end.

(** For any occurence of "unsigned x" in the context, add the
 *  assumption (0 <= unsigned x < 2^32)*)
Ltac add_unsigned_rng_tac :=
  repeat match goal with
           | [H:context[unsigned ?X] |- _] =>
             extend (unsigned_range X)
         end.

(* converting everything to Z so that lia can be used. *)

Require RTL.

Ltac pos_to_Z_tac := autorewrite with pos_to_Z_db in *.

Hint Rewrite Zpos_plus_distr : pos_to_Z_db.

Ltac all_to_Z_tac :=
  unfold noOverflow in *; cbv [addZ_list List.fold_right] in *;
  int32_to_Z_tac; add_unsigned_rng_tac; nat_to_Z_tac; pos_to_Z_tac;
  unfold RTL.size32 in *.

Ltac int32_simplify := all_to_Z_tac; repeat autorewrite with int32_simpl_db in *.
Ltac int32_prover := int32_simplify; omega.

Ltac int32_simplify_in_goal :=
  nat_to_Z_in_goal; autorewrite with int32_simpl_db.
Ltac int32_simplify_in H :=
  nat_to_Z_in H; autorewrite with int32_simpl_db in H.

(** A rewrite tactic that
 *  (1) rewrites to (unsigned a + unsigned b) when
 *      (unsigned a + unsigned b < 2^32 holds
 *  (3) rewrites unsigned (repr z) to z when 0 <= z < 2^32 *)
Hint Rewrite int32_add_rewrite using (omega || (int32_simplify_in_goal; omega))
  : int32_simpl_db.
Hint Rewrite int32_minus_rewrite using omega : int32_simpl_db.
Hint Rewrite Word.unsigned_repr2 using omega : int32_simpl_db.

(** More lemmas about noOverflow *)
Lemma checkNoOverflow_3_sound : forall (a b c:int32),
  checkNoOverflow a b = true -> checkNoOverflow (a +32 b) c = true
    -> noOverflow (a::b::c::nil).
Proof. intros. checkNoOverflow_elim. int32_prover. Qed.

(** addrRegion *)

Definition addrRegion (start limit:int32):Int32Ensemble :=
  fun x:int32 => exists i:int32, x = start +32 i /\ i <=32 limit.

Lemma addrRegion_start_in : forall start limit,
  Ensembles.In _ (addrRegion start limit) start.
Proof. autounfold with sets. intros.
  unfold addrRegion.
  exists int32_zero.
  split. rewrite add32_zero_r. trivial.
  apply Word.int_lequ_zero.
Qed.

(** disjointRegions *)

(** Check region [start1, start1+limit1] is disjoint from
 *  [start2, start2+limit2]; For simplicity, neither region can wrap
 *  around the 32-bit address space. *)
Definition disjointRegions (start1 limit1 start2 limit2:int32) : bool :=
  (int32_ltu_bool (start1 +32 limit1) start2 ||
   int32_ltu_bool (start2 +32 limit2) start1)%bool.

Lemma disjointRegions_sound :
  forall (s1 l1 s2 l2:int32),
    checkNoOverflow s1 l1 = true
      -> checkNoOverflow s2 l2 = true
      -> disjointRegions s1 l1 s2 l2 = true
      -> Ensembles.Disjoint _ (addrRegion s1 l1) (addrRegion s2 l2).
Proof. intros. split; intros. autounfold with sets. intro Hc.
  destruct Hc as [x [i1 [H10 H11]] [i2 [H12 H13]]].
  unfold disjointRegions in H1.
  checkNoOverflow_elim.
  rewrite H10 in H12; clear H10.
  bool_elim_tac; int32_prover.
Qed.

(** Some properties about ensembles *)
(*  not sure where to put these lemmas *)
Lemma included_disjoint : forall A r1 r2 r3,
  Ensembles.Included A r1 r2 -> Ensembles.Disjoint A r2 r3
    -> Ensembles.Disjoint A r1 r3.
Proof. intros. destruct H0. split.
  autounfold with sets in *. intros. intro Hc.
  apply (H0 x).
  destruct Hc. split; auto with sets.
Qed.

Lemma included_trans : forall A r1 r2 r3,
  Ensembles.Included A r1 r2 -> Ensembles.Included A r2 r3
    -> Ensembles.Included A r1 r3.
Proof. auto with sets. Qed.


Require Import
        Coq.ZArith.ZArith
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.DecideableEnsembles
        Fiat.Computation
        Fiat.Narcissus.Common.Specs.

Section ComposeFormat.

  Context {S : Type}. (* Source Type *)
  Context {T : Type}. (* Target Type *)
  Context {cache : Cache}. (* State Type *)
  Context {S' : Type}. (* Transformed Type *)

  Definition Compose_Format
    (format : FormatM S' T)
      (f : S -> S' -> Prop) (* Transformation Relation *)
    : FormatM S T :=
    fun s env benv' =>
      exists s', format s' env ∋ benv' /\ f s s'.

  Definition Compose_Decode {S' : Type}
             (decode : DecodeM S' T)
             (g : S' -> S) (* Transformation Function *)
    : DecodeM S T  :=
    fun b env => `(s, env') <- decode b env; Ok (g s, env').

  Definition Compose_Decode' {S' : Type}
             (decode : DecodeM S' T)
             (g : S' -> Hopefully S) (* Transformation Function *)
    : DecodeM S T  :=
    fun b env => `(s', env') <- decode b env; match g s' with Ok s => Ok (s, env') | Error e => Error e end.

  Definition Compose_Encode
             {S' : Type}
             (encode : EncodeM S' T)
             (f' : S -> Hopefully S')
    : EncodeM S T :=
    fun s c => HBind f' s as s' With encode s' c.

  Lemma CorrectEncoder_Compose
        (format : FormatM S' T)
        (encode : EncodeM S' T)
        (f : S -> S' -> Prop)
        (f' : S -> Hopefully S')
        (f'_refines_f_1 :
           forall s s',
             f' s = Ok s' ->
             f s s')
        (f'_refines_f_2 :
           forall s,
             is_error (f' s) ->
             forall s', ~ f s s')
        (f'_sound_choice :
           forall s s',
             f' s = Ok s' ->
             forall x env benv,
               format x env ∋ benv
               -> f s x
               -> format s' env ∋ benv)
    : CorrectEncoder format encode
      -> CorrectEncoder (Compose_Format format f) (Compose_Encode encode f').
  Proof.
    unfold CorrectEncoder, Compose_Encode, Compose_Format in *; split; intros.
    - apply unfold_computes.
      destruct (f' a) eqn: ?; simpl in *; try discriminate.
      eapply H in H0; eexists; intuition eauto.
    - rewrite unfold_computes; intro;  destruct_ex; split_and.
      destruct (f' a) eqn: ?; simpl in *.
      + eapply H4; eauto.
      + eapply f'_refines_f_2; eauto.
       rewrite Heqh; constructor.
  Qed.

End ComposeFormat.

Section ComposeSpecializations.

  Context {S : Type}. (* Source Type *)
  Context {T : Type}. (* Target Type *)
  Context {cache : Cache}. (* State Type *)
  Context {S' : Type}. (* Transformed Type *)

  Definition Restrict_Format
             (P : S -> Prop)
             (format : FormatM S T)
    : FormatM S T
    := Compose_Format format (fun s s' => s = s' /\ P s').

  Corollary CorrectEncoder_Restrict_Format
            (format : FormatM S T)
            (encode : EncodeM S T)
            (P : S -> Prop)
            (decideable_P : DecideableEnsemble P)
    : CorrectEncoder format encode
      -> CorrectEncoder
           (Restrict_Format P format)
           (fun s => if (DecideableEnsembles.dec s) then encode s else fun _ => Error DecideableEnsembles).
  Proof.
    intros; replace
              (fun s : S => if DecideableEnsembles.dec s then encode s else fun _ : CacheFormat => Error DecideableEnsembles)
              with (Compose_Encode encode (fun s => if DecideableEnsembles.dec s then Ok s else Error DecideableEnsembles)).
    eapply CorrectEncoder_Compose; intros;
      try (destruct (DecideableEnsembles.dec s) eqn: ?; first [discriminate | injections]);
      intuition eauto.
    - eapply dec_decides_P; eauto.
    - eapply Decides_false; subst; eauto.
    - subst; eauto.
    - apply functional_extensionality; intros; unfold Compose_Encode;
        find_if_inside; reflexivity.
  Qed.

  Definition Projection_Format
             (format : FormatM S' T)
             (f : S -> S')
    : FormatM S T :=
    Compose_Format format (fun s s' => f s = s').

  Lemma EquivFormat_Projection_Format
        (format : FormatM S' T)
        (f : S -> S')
    : EquivFormat (Projection_Format format f)
                  (fun s => format (f s)).
  Proof.
    unfold EquivFormat, Projection_Format, Compose_Format; split; intros ? ?.
    apply unfold_computes.
    eexists; eauto.
    rewrite unfold_computes in H; destruct_ex; intuition; subst; eauto.
  Qed.

  Corollary CorrectEncoder_Projection_Format
            (format : FormatM S' T)
            (encode : EncodeM S' T)
            (g : S -> S')
    : CorrectEncoder format encode
      -> CorrectEncoder (Projection_Format format g) (compose encode g).
  Proof.
    intros; replace
              (compose encode g)
              with (Compose_Encode encode (fun s => Ok (g s))).
    eapply CorrectEncoder_Compose; intros;
      try (destruct (DecideableEnsembles.dec s') eqn: ?; first [discriminate | injections]);
      intuition eauto.
    apply functional_extensionality; intros; reflexivity.
  Qed.

End ComposeSpecializations.

Lemma Projection_format_compose
      {S S' S'' T}
      {monoid : Monoid T}
      {cache : Cache}
  : forall (f : S -> S')
           (f' : S' -> S'')
           (formatS'' : FormatM S'' T)
           (formatS : FormatM S T),
    EquivFormat (Projection_Format (Projection_Format formatS'' f') f)
                (Projection_Format formatS'' (f' ∘ f)).
Proof.
  unfold EquivFormat, refineEquiv; intros.
  unfold Projection_Format, Compose_Format; split;
    intros ? ?.
  - apply unfold_computes.
    apply (proj1 (unfold_computes _ _)) in H; simpl in *.
    destruct_ex; eexists; intuition eauto.
    apply unfold_computes.
    eexists; intuition eauto.
  -  apply (proj2 (unfold_computes _ _)); simpl in *.
     apply (proj1 (unfold_computes _ _)) in H; simpl in *.
     destruct_ex; intuition.
     apply (proj1 (unfold_computes _ _)) in H0; simpl in *.
     destruct_ex; intuition eauto.
     eexists.
     split; eauto.
     unfold Basics.compose; congruence.
Qed.

Lemma Compose_decode_correct {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (view : S -> V -> Prop)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (format : FormatM V T)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate eq format decode_V P
                                    view_format)
      (View_Predicate_OK : forall s v, view s v -> Source_Predicate s -> View_Predicate v)
  : CorrectDecoder monoid Source_Predicate View_Predicate view
                   (Compose_Format format view) decode_V P view_format.
Proof.
  unfold CorrectDecoder, Projection_Format, Compose_Format; split; intros.
  { rewrite @unfold_computes in H1; destruct_ex; intuition.
    apply proj1 in decode_V_OK; eapply decode_V_OK with (ext := ext) in H2; eauto.
    destruct_ex; intuition; subst; eauto.
    eexists _, _; intuition eauto. }
  { apply proj2 in decode_V_OK; eapply decode_V_OK in H1;
      clear decode_V_OK; eauto. }
Qed.

Lemma projection_decode_correct {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (project : S -> V)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (format : FormatM V T)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate eq format decode_V P view_format)
      (View_Predicate_OK : forall (s : S), Source_Predicate s -> View_Predicate (project s))
  : CorrectDecoder monoid Source_Predicate View_Predicate (fun s v => project s = v)
                   (Projection_Format format project) decode_V P view_format.
Proof.
  eapply Compose_decode_correct; intros; eauto.
  subst; eauto.
Qed.

Lemma constant_decode_correct {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (view : S -> V -> Prop)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (format : FormatM V T)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (const_v : V)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate eq format decode_V P
                                    view_format)
      (const_v_OK : View_Predicate const_v)
  : CorrectDecoder monoid Source_Predicate View_Predicate (fun _ v' => const_v = v')
                   (Projection_Format format (constant const_v)) decode_V P view_format.
Proof.
  eapply projection_decode_correct; eauto.
Qed.

Lemma refine_Projection_Format
      {cache : Cache}
      {S S' T : Type}
      (f : S -> S')
      (format : FormatM S' T)
  : forall s env,
    refineEquiv (Projection_Format format f s env)
                (format (f s) env).
Proof.
  unfold Projection_Format, Compose_Format; intros; split.
  - intros v Comp_v.
    apply unfold_computes; eexists; intuition eauto.
  - intros v Comp_v.
    rewrite unfold_computes in Comp_v; destruct_ex; intuition eauto.
    subst; eauto.
Qed.

Lemma injection_decode_correct' {S V V' T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (inj : V -> Hopefully V')
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (View'_Predicate : V' -> Prop)
      (format : FormatM S T)
      (view : S -> V -> Prop)
      (view' : S -> V' -> Prop)
      (view_format : FormatM V T)
      (view'_format : FormatM V' T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid Source_Predicate View_Predicate
                                    view format decode_V P view_format)
      (view'_OK : forall s v, Source_Predicate s -> view s v -> exists v', inj v = Ok v' /\ view' s v')
      (View'_Predicate_OK : forall v, View_Predicate v
                                 -> forall v', inj v = Ok v' -> View'_Predicate v')
      (view'_format_OK : forall v env t,
          computes_to (view_format v env) t
          -> forall v', inj v = Ok v' -> computes_to (view'_format v' env) t)
  : CorrectDecoder monoid Source_Predicate View'_Predicate
                   view'
                   format (Compose_Decode' decode_V (fun s => match inj (fst s) with
                                                           | Ok s' => Ok (s', snd s)
                                                           | Error e => Error e
                                                           end))
                   P view'_format.
Proof.
  unfold CorrectDecoder, Projection_Format, Compose_Decode'; split; intros.
  { apply proj1 in decode_V_OK; eapply decode_V_OK with (ext := ext) in H1; eauto.
    destruct_ex; intuition; subst; eauto.
    destruct (view'_OK s x); eauto. intuition.
    eexists _, _; intuition eauto; rewrite H2; simpl; eauto.
    rewrite H7; auto.
  }
  { destruct (decode_V t env') as [ [ [? ?] ?] |] eqn: ? ;
      simpl in *; try discriminate; destruct inj eqn:?; try discriminate; injections.
    apply proj2 in decode_V_OK;
      eapply decode_V_OK in Heqh; eauto.
    intuition; destruct_ex; split_and; eexists _, _; intuition eauto.
  }
Qed.

Lemma injection_decode_correct {S V V' T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (inj : V -> V')
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (View'_Predicate : V' -> Prop)
      (format : FormatM S T)
      (view : S -> V -> Prop)
      (view' : S -> V' -> Prop)
      (view_format : FormatM V T)
      (view'_format : FormatM V' T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid Source_Predicate View_Predicate
                                    view format decode_V P view_format)
      (view'_OK : forall s v, Source_Predicate s -> view s v -> view' s (inj v))
      (View'_Predicate_OK : forall v, View_Predicate v
                                      -> View'_Predicate (inj v))
      (view'_format_OK : forall v env t,
          computes_to (view_format v env) t
          -> computes_to (view'_format (inj v) env) t)
  : CorrectDecoder monoid Source_Predicate View'_Predicate
                   view'
                   format (Compose_Decode decode_V (fun s => (inj (fst s), snd s)))
                   P view'_format.
Proof.
  eapply (injection_decode_correct' (fun v => Ok (inj v)));
    intuition eauto; injections; intuition eauto.
Qed.

Lemma bijection_decode_correct' {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (proj : S -> V)
      (inj : V -> Hopefully S)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate
                                    eq view_format decode_V P view_format)
      (view_OK : forall s, Source_Predicate s -> inj (proj s) = Ok s)
      (view_OK' : forall v s, inj v = Ok s -> proj s = v)
      (View_Predicate_OK : forall s, Source_Predicate s -> View_Predicate (proj s))
      (View_Predicate_OK' : forall v s, View_Predicate v -> inj v = Ok s -> Source_Predicate s)
  : CorrectDecoder monoid Source_Predicate Source_Predicate
                   eq
                   (Projection_Format view_format proj)
                   (Compose_Decode' decode_V (fun s => match inj (fst s) with
                                                    | Ok s' => Ok (s', snd s)
                                                    | Error e => Error e
                                                    end))
                   P
                   (Projection_Format view_format proj).
Proof.
  eapply injection_decode_correct'.
  - apply projection_decode_correct; eauto.
  - simpl; intros. subst. eexists. intuition eauto.
  - eauto.
  - intros. apply (EquivFormat_sym (EquivFormat_Projection_Format _ _)).
    erewrite view_OK'; eauto.
Qed.

Lemma bijection_decode_correct {S V T}
      {cache : Cache}
      {P : CacheDecode -> Prop}
      {monoid : Monoid T}
      (proj : S -> V)
      (inj : V -> S)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (view_format : FormatM V T)
      (decode_V : DecodeM (V * T) T)
      (decode_V_OK : CorrectDecoder monoid View_Predicate View_Predicate
                                    eq view_format decode_V P view_format)
      (view_OK : forall s, Source_Predicate s -> inj (proj s) = s)
      (view_OK' : forall v, proj (inj v) = v)
      (View_Predicate_OK : forall s, Source_Predicate s -> View_Predicate (proj s))
      (View_Predicate_OK' : forall v, View_Predicate v -> Source_Predicate (inj v))
  : CorrectDecoder monoid Source_Predicate Source_Predicate
                   eq
                   (Projection_Format view_format proj)
                   (Compose_Decode decode_V (fun s => (inj (fst s), snd s)))
                   P
                   (Projection_Format view_format proj).
Proof.
  eapply (bijection_decode_correct' _ (fun v => Ok (inj v)));
    intuition eauto; injections; f_equal; intuition eauto.
Qed.

(* Do we have something similar already? *)
Ltac derive_decoder_equiv :=
  unfold flip, pointwise_relation,
  Compose_Decode, Compose_Decode', DecodeBindOpt2, DecodeBindOpt, BindOpt;
  intros; try reflexivity;
  let tac x := (destruct x eqn:?; cbn; destruct_pairs; intuition eauto) in
  repeat match goal with
         | |- context[If_Opt_Then_Else ?x _ _] => tac x
         | |- context[If_Then_Else ?x _ _] => tac x
         | |- context[if ?x then _ else _] => tac x
         | |- context[hbind ?x _] => tac x
         end.

Ltac _apply_bijection_rule tac :=
    match goal with
    | |- CorrectDecoder _ _ _ _ ?f ?d _ ?f =>
      try unfold f; try unfold d
    end;
    match goal with
    | |- CorrectDecoder _ _ _ _ ?f _ _ ?f =>
      match f with
      | Projection_Format _ _ => idtac
      | _ => eapply format_decode_correct_EquivFormatAndView;
            [solve [apply EquivFormat_sym; apply EquivFormat_Projection_Format] |]
      end;
        tac ||
            (eapply format_decode_correct_EquivDecoder;
             [| tac]; cycle 1)
    end.

Ltac apply_bijection_rule :=
  _apply_bijection_rule ltac:(eapply bijection_decode_correct).

Tactic Notation "apply_bijection_rule" "with" uconstr(t) :=
  _apply_bijection_rule ltac:(eapply bijection_decode_correct with (inj:=t)).

Ltac apply_bijection_rule' :=
  _apply_bijection_rule ltac:(eapply bijection_decode_correct').

Tactic Notation "apply_bijection_rule'" "with" uconstr(t) :=
  _apply_bijection_rule ltac:(eapply bijection_decode_correct' with (inj:=t)).

Notation "format ◦ f" := (Projection_Format format f) (at level 55) : format_scope.
Notation "P ∩ format" := (Restrict_Format P format) (at level 55) : format_scope.


Add LoadPath "~/Desktop/classdiagram/src".

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Sorting.Mergesort.
Require Export classdiagram.
Require Import String.
Require Import CpdtTactics.
Open Scope string_scope.

(** example **)
Definition Customer : class := "Customer".
Definition Order : class := "Order".
Definition Payment : class := "Payment".
Definition Cash : class := "Cash".
Definition Check_ : class := "Check_".
Definition Credit : class := "Credit".
Definition OrderDetail : class := "OrderDetail".
Definition Item : class := "Item".

Definition order_class :=
  [Customer;Order;Payment;Cash;Check_;Credit;OrderDetail;Item].

Definition firstname :=
  BAttribute "firstname" Customer TString.
Definition lastname :=
  BAttribute "lastname" Customer TString.
Definition email :=
  BAttribute "email" Customer TString.
Definition address :=
  BAttribute "address" Customer TString.
Definition date :=
  BAttribute "date" Order TString.
Definition status :=
  BAttribute "status" Order TString.
Definition amount :=
  BAttribute "amount" Payment TInteger.
Definition cashTendered :=
  BAttribute "cashTendered" Cash TInteger.
Definition name :=
  BAttribute "name" Check_ TString.
Definition bankID :=
  BAttribute "bankID" Cash TInteger.
Definition number :=
  BAttribute "number" Credit TString.
Definition credittype :=
  BAttribute "type" Credit TString.
Definition expDate :=
  BAttribute "expDate" Credit TString.
Definition quanity :=
  BAttribute "quanity" OrderDetail TInteger.
Definition tax :=
  BAttribute "tax" OrderDetail TInteger.
Definition shippingWeight :=
  BAttribute "shippingWeight" Item TInteger.
Definition description :=
  BAttribute "description" OrderDetail TString.

Definition order_attibute :=
  [firstname;lastname;email;address;date;status;amount;cashTendered;
   name;bankID;number;credittype;expDate;quanity;tax;shippingWeight;description].

Definition calcTax :=
  BOperation "calcTax" Order [TInteger].
Definition calcTotal :=
  BOperation "calcTotal" Order [TInteger].
Definition calcTotalWeight :=
  BOperation "calcTotalWeight" Order [TInteger].

Definition order_operation :=
  [calcTax;calcTotal;calcTotalWeight].

(** example **)
Definition Generate : assoc := "Generate".
Definition Pay : assoc := "Pay".
Definition Has : assoc := "Has".
Definition Contain : assoc := "Contain".

Definition order_assoc :=
  [Generate;Pay;Has;Contain].

Definition a1 :=
  BAssoc Generate [Customer;Order] bidirect.
Definition a2 :=
  BAssoc Pay [Payment;Order] bidirect.
Definition a3 :=
  BAssoc Has [Order;OrderDetail] composite.
Definition a4 :=
  BAssoc Contain [OrderDetail;Item] direct.

Definition order_associates :=
  [a1;a2;a3;a4].

(** example **)
Definition r1 :=
  BRole Generate ["customer";"order"].
Definition r2 :=
  BRole Pay ["payment";"order"].
Definition r3 :=
  BRole Has ["order";"orderDetail"].
Definition r4 :=
  BRole Contain ["orderDetail";"item"].

Definition order_roles :=
  [r1;r2;r3;r4].

(* example *)
Definition m1 :=
  BMulti Generate [(Nat 1, Nat 1);(Nat 0, Star)].
Definition m2 :=
  BMulti Pay [(Nat 1, Star);(Nat 1, Nat 1)].
Definition m3 :=
  BMulti Has [(Nat 1, Nat 1);(Nat 1, Star)].
Definition m4 :=
  BMulti Contain [(Nat 0, Star);(Nat 1, Nat 1)].

Definition order_multiplicity :=
  [m1;m2;m3;m4].

(** example **)
Definition g1 := BGen Cash Payment.
Definition g2 := BGen Check_ Payment.
Definition g3 := BGen Credit Payment.

Definition order_generalization := [g1; g2; g3].

Definition order_model := mkSimpleUML
  order_class order_attibute order_operation order_assoc order_associates
  order_roles order_multiplicity order_generalization.

Compute (participating Order order_associates).

Compute (navends Order a1 order_roles).
Compute (navends Order a2 order_roles).
Compute (navends Order a3 order_roles).

Compute (navs Order order_associates order_roles).

Compute (parents order_generalization Cash).
Compute (parents order_generalization Payment).

Compute (get_children order_generalization Payment).

(** Proof **)
Example wlf_rule1:
  unique_class order_model.
Proof.
  unfold order_model, order_class, unique_class; crush.
  repeat constructor; crush; try inversion H0; try inversion H.
Qed.

Example wlf_rule2:
  nsc_attribute_unique order_model.
Proof.
  unfold order_model, order_attibute, nsc_attribute_unique; crush;
  repeat constructor; crush.
Qed.

Example wlf_rule3:
  nsc_nselfgen order_model.
Proof.
  unfold order_model, nsc_nselfgen; crush; inversion H.
Qed.

Example wlf_rule4:
  nsc_role order_model.
Proof.
  unfold order_model, nsc_role; crush.
Qed.

Example wlf_rule4:
  nsc_assoc order_model.
Proof.
  unfold order_model, nsc_assoc; crush.
Qed.

Require Import objectdiagram.

(* object diagrams *)
Definition b1 := BObject Branch "b1".
Definition e1 := BObject Employee "e1".
Definition e2 := BObject Employee "e2".

Definition car_objects := [b1;e1;e2].

Definition v1 := BAttrval location b1 (AString "Berlin").
Definition v2 := BAttrval firstname e1 (AString "John").
Definition v3 := BAttrval lastname e1 (AString "Clark").
Definition v4 := BAttrval age e1 (AInteger 47).
Definition v5 := BAttrval isMarried e1 (ABoolean true).
Definition v6 := BAttrval salary e1 (AInteger 72).
Definition v7 := BAttrval firstname e2 (AString "Frank").
Definition v8 := BAttrval lastname e2 (AString "Barnes").
Definition v9 := BAttrval age e2 (AInteger 23).
Definition v10 := BAttrval isMarried e2 (ABoolean false).
Definition v11 := BAttrval salary e2 (AInteger 38).

Definition car_attrivals := [v1;v2;v3;v4;v5;v6;v7;v8;v9;v10;v11].

Definition l1 := BLink Management [b1;e1].
Definition l2 := BLink Employment [b1;e1].
Definition l3 := BLink Employment [b1;e2].

Definition car_links := [l1;l2;l3].

Definition car_rental_state :=
  mkState car_objects car_attrivals car_links.

Example sat_rule1:
  sat_object_class car_rental car_rental_state.
Proof.
  unfold car_rental, car_rental_state, sat_object_class; crush.
  + exists Branch; crush.
  + exists Employee; crush.
  + exists Employee; crush.
Qed.

Example sat_rule2:
  sat_domain car_rental car_rental_state.
Proof.
  unfold car_rental, car_rental_state, sat_domain; crush.
Qed.

Example sat_rule3:
  sat_abstract_class_domain car_rental car_rental_state.
Proof.
  unfold car_rental, car_rental_state, sat_abstract_class_domain; crush.
  + unfold car_generalization, car_objects, domain; simpl.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Qpositive.

Fixpoint Qpositive_le_bool (w w' : Qpositive) {struct w'} : bool :=
  match w with
  | One => match w' with
           | dL y => false
           | _ => true
           end
  | dL y => match w' with
            | dL y' => Qpositive_le_bool y y'
            | _ => true
            end
  | nR y => match w' with
            | nR y' => Qpositive_le_bool y y'
            | _ => false
            end
  end.

Definition Qpositive_le (w w' : Qpositive) := Qpositive_le_bool w w' = true.

Definition Qpositive_le' (w w' : Qpositive) :=
  match Qpositive_i w, Qpositive_i w' with
  | (p, q), (p', q') => p * q' <= p' * q
  end.

Theorem Qpositive_le_to_Qpositive_le' :
 forall w w' : Qpositive, Qpositive_le w w' -> Qpositive_le' w w'.
intros w w'; generalize w; elim w'; clear w w'.

intros w'1 Hrec w; case w.
(* 1 *)
unfold Qpositive_le in |- *; simpl in |- *.
intros w1 H; generalize (Hrec w1 H).
unfold Qpositive_le' in |- *.
simpl in |- *.
case (Qpositive_i w1); case (Qpositive_i w'1).
intros p' q' p q Hle; repeat rewrite mult_plus_distr_r.
rewrite (mult_comm q').
apply plus_le_compat_r.
auto.
(* 1 *)

(* 2 *)
intros w1; unfold Qpositive_le in |- *.
simpl in |- *.
unfold Qpositive_le' in |- *; simpl in |- *; intros H; case (Qpositive_i w1);
 case (Qpositive_i w'1); intros p' q' p q.
rewrite mult_plus_distr_r.
repeat rewrite <- (mult_comm (p + q)).
repeat rewrite mult_plus_distr_r.
rewrite (plus_comm (p * p' + q * p')).
repeat rewrite <- plus_assoc.
auto with arith.
(* 2 *)

(* Focus 3 *)
unfold Qpositive_le, Qpositive_le' in |- *.
simpl in |- *.
case (Qpositive_i w'1).
intros; omega.
(* 3 *)

intros w'1 Hrec w; case w; clear w; unfold Qpositive_le in |- *;
 simpl in |- *.

(* 1 *)
intros q H; discriminate H.
(* 2 *)
intros w1 H; generalize (Hrec w1 H); unfold Qpositive_le' in |- *.
simpl in |- *; case (Qpositive_i w1); case (Qpositive_i w'1);
 intros p' q' p q.
repeat rewrite (mult_comm p); repeat rewrite (mult_comm p');
 repeat rewrite mult_plus_distr_r.
intros H1.
rewrite (mult_comm p').
apply plus_le_compat_l.
auto.
(* 3 *)
intros H; discriminate H.

unfold Qpositive_le, Qpositive_le' in |- *.
intros w; case w.
3: simpl in |- *; auto.
intros w1; simpl in |- *.
intros Heq; discriminate Heq.
 intros w'; simpl in |- *.
 case (Qpositive_i w').
 intros; omega.

Qed.

Theorem Qpositive_le'_to_Qpositive_le :
 forall w w' : Qpositive, Qpositive_le' w w' -> Qpositive_le w w'.
intros w w'; generalize w; elim w'; clear w w'.

(* Focus 1 *)
intros w'1 Hrec w; case w; clear w.

(* 1.1 *)
intros w; unfold Qpositive_le', Qpositive_le in |- *; simpl in |- *.
generalize (Hrec w); clear Hrec; unfold Qpositive_le, Qpositive_le' in |- *;
 simpl in |- *.
elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq; clear Hex;
 rewrite Heq.
elim (interp_non_zero w'1); intros p' Hex; elim Hex; intros q' Heq1;
 clear Hex; rewrite Heq1.
intros H H1; (lapply H; [ intros H0; try exact H0 | idtac ]).
apply (fun p n m : nat => plus_le_reg_l n m p) with (S q * S q').
replace (S q * S q' + S p * S q') with ((S p + S q) * S q').
replace (S q * S q' + S p' * S q) with ((S p' + S q') * S q).
auto.
ring.
ring.
(* 1.2 *)
unfold Qpositive_le in |- *; simpl in |- *; auto.
(* 1.3 *)
unfold Qpositive_le in |- *; simpl in |- *.
auto.

(* Focus 2 *)
intros w'1 Hrec w; case w; clear w; unfold Qpositive_le in |- *;
 simpl in |- *; auto.
(* 2.1 *)
intros w1; unfold Qpositive_le' in |- *; simpl in |- *.
elim (interp_non_zero w1); intros p Hex; elim Hex; intros q Heq; clear Hex;
 rewrite Heq.
elim (interp_non_zero w'1); intros p' Hex; elim Hex; intros q' Heq1;
 clear Hex; rewrite Heq1.
rewrite mult_plus_distr_r.
repeat rewrite <- (mult_comm (S p' + S q')).
repeat rewrite mult_plus_distr_r.
repeat rewrite <- (plus_comm (S p' * S q)) || rewrite plus_assoc;
 repeat rewrite <- plus_assoc.
pattern (S p' * S q) at 2 in |- *; rewrite plus_n_O.
intros H; generalize (plus_le_reg_l _ _ _ H); simpl in |- *; intros H1;
 inversion H1.
(* 2.2 *)
intros w; unfold Qpositive_le', Qpositive_le in |- *; simpl in |- *.
generalize (Hrec w); clear Hrec; unfold Qpositive_le, Qpositive_le' in |- *;
 simpl in |- *.
elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq; clear Hex;
 rewrite Heq.
elim (interp_non_zero w'1); intros p' Hex; elim Hex; intros q' Heq1;
 clear Hex; rewrite Heq1.
intros H H1; (lapply H; [ intros H0; try exact H0 | idtac ]).
apply (fun p n m : nat => plus_le_reg_l n m p) with (S p * S p').
replace (S p * S p' + S p * S q') with (S p * (S p' + S q')).
replace (S p * S p' + S p' * S q) with (S p' * (S p + S q)).
auto.
ring.
ring.
(* 2.3 *)
unfold Qpositive_le' in |- *; simpl in |- *.
elim (interp_non_zero w'1); intros p' Hex; elim Hex; intros q' Heq1;
 clear Hex; rewrite Heq1.
rewrite <- plus_n_O; rewrite <- (mult_comm 1); simpl in |- *; intros H;
 generalize (plus_le_reg_l _ _ _ (le_S_n _ _ H)).
intros H1; inversion H1.

(* Focus 3 *)

intros w; case w; clear w; unfold Qpositive_le', Qpositive_le in |- *;
 simpl in |- *.
(* 3.1 *)
intros w; elim (interp_non_zero w).
intros p Hex; elim Hex; intros q Heq; rewrite Heq.
rewrite mult_1_r.
rewrite (plus_comm (S p)).
intros H; generalize (plus_le_reg_l _ _ _ H); intros H1; inversion H1.
(* 3.2 *)
auto.
(* 3.3 *)
auto.

Qed.

Theorem Qpositive_le_trans :
 forall w w' w'' : Qpositive,
 Qpositive_le w w' -> Qpositive_le w' w'' -> Qpositive_le w w''.
intros w w'; generalize w; elim w'; unfold Qpositive_le in |- *;
 simpl in |- *; clear w w'.

(* Focus 1 *)
intros w' Hrec w; case w.
(* 1.3 *)
3: intros w''; case w''; simpl in |- *; auto.
(* 1.1 *)
intros w0 w''; case w''; simpl in |- *; auto.
(* 1.2 *)
intros w0 w''; case w''; simpl in |- *; auto.
intros w''0 H H1; discriminate H1.

(* Focus 2 *)
intros w' Hrec w; case w.
(* 2.3 *)
3: intros w'' H; discriminate H.
(* 2.1 *)
intros w0 w'' H; discriminate H.
(* 2.2 *)
intros w0 w''; case w''; simpl in |- *; auto.

(* Focus 3 *)
intros w; case w; clear w; simpl in |- *.
(* 3.3 *)
3: auto.
(* 3.1 *)
intros w w'' H; discriminate H.
(* 3.2 *)
intros w w''; case w''; simpl in |- *; auto.
intros w''0 H H1; discriminate H1.

Qed.

Theorem Qpositive_le_antisym :
 forall w w' : Qpositive, Qpositive_le w w' -> Qpositive_le w' w -> w = w'.
intros w; elim w; unfold Qpositive_le in |- *; simpl in |- *.
intros w0 Hrec w'; case w'; simpl in |- *.
3: intros H; discriminate H.
intros; apply f_equal with (f := nR); auto.
intros w'0 H; discriminate H.
intros w0 Hrec w'; case w'; simpl in |- *.
3: intros H H1; discriminate H1.
intros w'1 H H1; discriminate H1.
intros; apply f_equal with (f := dL); auto.

intros w'; case w'; auto with *.
intros w'0 H H1; discriminate H1.
intros w'0 H; discriminate H.

Qed.

Theorem Qpositive_le_refl : forall w : Qpositive, Qpositive_le w w.
intros w; unfold Qpositive_le in |- *; elim w; simpl in |- *; auto.
Qed.

Theorem Qpositive_le_total :
 forall w w' : Qpositive, Qpositive_le w w' \/ Qpositive_le w' w.
intros w w'; cut (Qpositive_le' w w' \/ Qpositive_le' w' w).
intros H; elim H; intros H1;
 generalize (Qpositive_le'_to_Qpositive_le _ _ H1);
 auto.
unfold Qpositive_le' in |- *.
case (Qpositive_i w'); case (Qpositive_i w); intros p q p' q'.
elim (le_or_lt (p * q') (p' * q)); auto with arith.
Qed.

Theorem not_Qpositive_le_not_eq :
 forall n m : Qpositive, ~ Qpositive_le n m -> n <> m.
intros n m H; red in |- *; intros H1; elim H; rewrite H1;
 apply Qpositive_le_refl.
Qed.

Theorem not_Qpositive_le_Qpositive_le' :
 forall n m : Qpositive, ~ Qpositive_le n m -> Qpositive_le m n.
intros n m Hle; elim (Qpositive_le_total n m); auto.
intros H; elim Hle; auto.
Qed.

Lemma Qpositive_le_noneq_explicit: forall qp qp', Qpositive_le qp qp' -> ~ qp=qp' ->
  let (p, q) := Qpositive_i qp in
    let (p', q') := Qpositive_i qp' in (p * q' < p' * q)%nat.
Proof.
 intros qp qp' H_le H_neq; generalize (Qpositive_le_to_Qpositive_le' qp qp' H_le); unfold Qpositive_le';
 destruct (interp_non_zero qp) as [p [q H]];
 destruct (interp_non_zero qp') as [p' [q' H']];
 rewrite H; rewrite H'; intros H_le_unfold; destruct (le_lt_eq_dec _ _ H_le_unfold) as [H1|H1]; trivial;
 apply False_ind; apply H_neq;
 rewrite <- (construct_correct qp (S p) (S q) (S p+S q)%nat H); auto with arith;
 rewrite <- (construct_correct qp' (S p') (S q') (S p'+S q')%nat H'); auto with arith;
 apply construct_correct4'; auto with arith.
Qed.


From SimplyRatt Require Export Heaps ClosedTerms.

From SimplyRatt Require Import Tactics.

From Coq Require Import Omega Program.Equality.

(* Definition of heaps *)
Inductive store : Type :=
| store_bot  : store
| store_lock : option heap -> heap -> store.

Bind Scope heap_scope with heap.
Open Scope heap_scope.

Definition gc (s : store) :=
  match s with
  | store_bot => store_bot
  | store_lock _ h => store_lock None h
  end.

Definition store_tick (s : store) (h : heap) : store :=
  match s with
  | store_bot => store_bot
  | store_lock _ h' => store_lock (Some h') h
  end.

Inductive store_mapsto : loc -> term -> store -> Prop :=
| store_mapsto_heap l t h h' : heap_mapsto l t h -> store_mapsto l t (store_lock h' h).

Hint Constructors store_mapsto.

(* freshness for heaps *)

(* orders on heaps and stores *)

Definition heap_le (h1 h2 : heap) : Prop := forall x e, heap_mapsto x e h1 -> heap_mapsto x e h2
.
Inductive store_le : store -> store -> Prop :=
| store_le_bot : store_le store_bot store_bot
| store_le_lock h h' : heap_le h h' -> store_le (store_lock None h) (store_lock None h')
| store_le_tick h1 h1' h2 h2' : heap_le h1 h1' -> heap_le h2 h2' ->
                                store_le (store_lock (Some h1) h2) (store_lock (Some h1') h2').

Inductive tick_le : store -> store -> Prop :=
| tick_le_store s s' : store_le s s' -> tick_le s s'
| tick_le_tick h1 h2 h2' : heap_le h2 h2' ->
                           tick_le (store_lock None h2) (store_lock (Some h1) h2').

Hint Constructors store_le tick_le.

Definition heaps := heap -> Prop.

Definition heaps_le (H H' : heaps) : Prop :=
  forall h', H' h' -> exists h, H h /\ heap_le h h'.

Definition heapseq := list heaps.

Notation heapseq_le := (Forall2 heaps_le).

Inductive suffix (Hs : heapseq) :  heapseq -> Prop :=
| suffix_drop H Hs' : suffix Hs Hs' -> suffix Hs (H :: Hs')
| suffix_refl : suffix Hs Hs.

Inductive wsuffix : heapseq -> heapseq -> Prop :=
  wsuffix_split Hs1 Hs2 Hs3 : heapseq_le Hs2 Hs1 -> suffix Hs2 Hs3 -> wsuffix Hs1 Hs3.

Hint Constructors suffix wsuffix.

(* reflexivity and transitivity of the above orders *)

Lemma suffix_trans Hs1 Hs2 Hs3 : suffix Hs1 Hs2 -> suffix Hs2 Hs3 -> suffix Hs1 Hs3.
Proof.
  intros S1 S2. induction S2;eauto.
Qed.

Lemma heap_le_refl h : heap_le h h.
Proof.
  unfold heap_le. intros. auto.
Qed.

Lemma heaps_le_refl H : heaps_le H H.
Proof.
  unfold heaps_le. intros. exists h'. eauto using heap_le_refl.
Qed.

Lemma heapseq_le_refl Hs : heapseq_le Hs Hs.
Proof.
  induction Hs; constructor; eauto using heaps_le_refl.
Qed.

Lemma store_le_refl s : store_le s s.
Proof.
  destruct s;try destruct o;eauto using heap_le_refl.
Qed.

Lemma tick_le_refl s : tick_le s s.
Proof.
  destruct s;eauto using store_le_refl.
Qed.

Lemma heap_le_trans s1 s2 s3 : heap_le s1 s2 -> heap_le s2 s3 -> heap_le s1 s3.
Proof.
  unfold heap_le. intros. eauto.
Qed.

Lemma store_le_trans s1 s2 s3 : store_le s1 s2 -> store_le s2 s3 -> store_le s1 s3.
Proof.
  intros T1 T2. destruct T1; inversion T2;eauto using heap_le_trans.
Qed.

Lemma tick_le_trans s1 s2 s3 : tick_le s1 s2 -> tick_le s2 s3 -> tick_le s1 s3.
Proof.
  intros T1 T2. destruct T1;inversion T2;subst;eauto using store_le_trans.
  -  inversion H. subst. apply tick_le_tick. eauto using heap_le_trans.
  - inversion H0. subst. apply tick_le_tick. eauto using heap_le_trans.
Qed .

Lemma heaps_le_trans H1 H2 H3 : heaps_le H1 H2 -> heaps_le H2 H3 -> heaps_le H1 H3.
Proof.
  unfold heaps_le. intros.
  remember (H0 h' H4) as As. clear HeqAs H0.
  destruct As. destruct H0.
  remember (H x H0) as As2. clear HeqAs2 H.
  destruct As2. destruct H. eauto using heap_le_trans.
Qed.

Lemma heapseq_le_trans Hs1 Hs2 Hs3 : heapseq_le Hs1 Hs2 -> heapseq_le Hs2 Hs3 -> heapseq_le Hs1 Hs3.
Proof.
  intros S1 S2. generalize dependent Hs3.
  induction S1;intros;inversion S2;subst;eauto using heaps_le_trans.
Qed.

Lemma tick_le_lock hn hl s : tick_le (store_lock hn hl) s ->
                             exists hn' hl', s = store_lock hn' hl'.
Proof.
  intros L. dependent destruction L.
  - dependent destruction H; eauto.
  - eauto.
Qed.

Lemma suffix_cons1 H Hs Hs' :
  suffix (H :: Hs) Hs' -> exists H' Hs'', Hs' = H' :: Hs''.
Proof.
  intros Su. inversion Su; subst. eauto. eexists. eexists. reflexivity.
Qed.

Lemma heapseq_le_cons1 H Hs Hs' :
  heapseq_le (H :: Hs) Hs' -> exists H' Hs'', Hs' = H' :: Hs''.
Proof.
  intros L. inversion L. subst. eauto.
Qed.

Lemma heapseq_le_cons2 H Hs Hs' :
  heapseq_le  Hs' (H :: Hs) -> exists H' Hs'', Hs' = H' :: Hs''.
Proof.
  intros L. inversion L. subst. eauto.
Qed.

Lemma tick_le_none hl hl' hn :
  heap_le hl hl' -> tick_le (store_lock None hl) (store_lock hn hl').
Proof.
  intros. destruct hn;eauto.
Qed.

Lemma suffix_cons H Hs Hs' : suffix (H :: Hs) Hs' -> suffix Hs Hs'.
Proof.
  intros Su. induction Su; eauto.
Qed.

Lemma skipn_skipn A n n' (l : list A) : skipn n (skipn n' l) = skipn (n' + n) l.
Proof.
  generalize dependent l. induction n'; intros; simpl; eauto. destruct l.
  + destruct n;reflexivity.
  + eauto.
Qed.

Lemma heapseq_le_length Hs Hs' : heapseq_le Hs Hs' -> length Hs = length Hs'.
Proof.
  intros L. induction L;simpl;eauto.
Qed.

(* Other properties of the orderings *)

Lemma heap_le_dom h h' l : heap_le h h' -> heap_dom l h -> heap_dom l h'.
Proof.
  intros L D. destruct D as (t & D). apply L in D. eexists. eauto.
Qed.

Lemma heapseq_le_len Hs Hs' : heapseq_le Hs Hs' -> length Hs = length Hs'.
Proof.
  intros. induction H.
  - reflexivity.
  - simpl. rewrite IHForall2. reflexivity.
Qed.

Lemma suffix_nil Hs : suffix Hs nil -> Hs = nil.
Proof.
  intros S. inversion S. reflexivity.
Qed.

Lemma suffix_nil' Hs : suffix nil Hs.
Proof.
  induction Hs; eauto.
Qed.

Lemma suffix_length Hs1 Hs2 : suffix Hs1 Hs2 -> length Hs1 <= length Hs2.
Proof.
  intros Su. induction Su. simpl. omega. omega.
Qed.

Lemma suffix_length_skip Hs1 Hs2 : suffix Hs1 Hs2 -> skipn (length Hs2 - length Hs1) Hs2 = Hs1.
Proof.
  intros Su. induction Su. assert (length (H :: Hs') = S (length Hs')) as L1 by reflexivity.
  rewrite L1. rewrite <- minus_Sn_m by auto using suffix_length. auto.
  rewrite Nat.sub_diag. auto.
Qed.

Lemma skip_suffix n Hs : suffix (skipn n Hs) Hs.
Proof.
  generalize dependent Hs. induction n;intros.
  + auto.
  + destruct Hs.
    * auto.
    * simpl. constructor. apply IHn.
Qed.

Lemma store_le_mapsto l t s s' : store_le s s' -> store_mapsto l t s -> store_mapsto l t s'.
Proof.
  intros SL SM. destruct SL;inversion SM; autodest.
Qed.

Lemma tick_le_mapsto l t s s' : tick_le s s' -> store_mapsto l t s -> store_mapsto l t s'.
Proof.
  intros SL SM; destruct SL.
  - eauto using store_le_mapsto.
  - inversion SM; autodest.
Qed.

Lemma heap_cons_mono l h x: heap_fresh l h -> heap_le h (heap_cons h l x).
Proof.
  unfold heap_le, heap_fresh. intros.
  pose (Nat.eq_decidable l x0) as EQ. destruct EQ. subst.
  assert (exists e,heap_mapsto x0 e h) by eauto. contradiction.
  apply heap_cons_mapsto_neq;eauto.
Qed.

Lemma mapsto_heap_cons l t h : heap_mapsto l t (heap_cons h l t).
Proof.
  rewrite heap_cons_mapsto_eq. auto.
Qed.

Lemma store_mapsto_cons l t h h' : store_mapsto l t (store_lock h' (heap_cons h l t)).
Proof.
  eauto using mapsto_heap_cons.
Qed.

Lemma tick_le_store_tick s s' h h' : tick_le s s' -> heap_le h h' -> tick_le (store_tick s h) (store_tick s' h').
Proof.
  intros. destruct s.
  - inversion H. subst. inversion H1. subst. auto.
  - inversion H; subst. inversion H1; subst; simpl; eauto.
    simpl. eauto.
Qed.

Lemma tick_le_gc s s' : tick_le s s' -> store_le (gc s) (gc s').
Proof.
  intros. destruct H.
  - destruct H;simpl;eauto.
  - simpl. eauto.
Qed.

Definition suffix_le Hs1 Hs3 := exists Hs2, suffix Hs1 Hs2 /\ heapseq_le Hs2 Hs3.

Lemma suffix_skipn Hs1 Hs2 : suffix Hs1 Hs2 -> exists n, Hs1 = skipn n Hs2.
Proof.
  intros. induction H.
  - destruct IHsuffix. exists (S x). simpl. assumption.
  - exists 0. simpl. auto.
Qed.

Lemma heapseq_le_skipn n : forall Hs1 Hs2,  heapseq_le Hs1 Hs2 -> heapseq_le (skipn n Hs1) (skipn n Hs2).
Proof.
  induction n.
  - simpl. auto.
  - intros. destruct Hs1; inversion H;subst;eauto.
Qed.

Lemma heapseq_le_suffix Hs1 Hs2 Hs3 :
  heapseq_le Hs1 Hs2 -> suffix Hs3 Hs2 -> exists Hs4, suffix Hs4 Hs1 /\ heapseq_le Hs4 Hs3.
Proof.
  intros. apply suffix_skipn in H0. destruct H0.
  exists (skipn x Hs1). split. apply skip_suffix. subst. eauto using heapseq_le_skipn.
Qed.

Lemma heapseq_le_concat  Hs1 Hs2 Hs3 Hs4 :
  heapseq_le Hs1 Hs2 -> heapseq_le Hs3 Hs4 -> heapseq_le (Hs1 ++ Hs3) (Hs2 ++ Hs4).
Proof. intros. eauto using Forall2_app. Qed.

Lemma suffix_concat Hs1 Hs2 : suffix Hs2 (Hs1 ++ Hs2).
Proof.
  induction Hs1;simpl; eauto.
Qed.

Lemma heapseq_le_suffix' Hs1 Hs2 Hs3 :
  heapseq_le Hs1 Hs3 -> suffix Hs1 Hs2 ->
  exists Hs4, heapseq_le Hs2 Hs4  /\suffix Hs3 Hs4.
Proof.
  intros HS Su.
  apply suffix_skipn in Su. autodest.
  exists (firstn x Hs2 ++ Hs3). split.
  assert (firstn x Hs2 ++ skipn x Hs2 = Hs2) as SK by eauto using firstn_skipn.
  rewrite <- SK at 1. apply heapseq_le_concat. apply heapseq_le_refl. assumption.
  eauto using suffix_concat.
Qed.

Lemma tick_le_bot s s' : tick_le s s' -> s = store_bot <-> s' = store_bot.
Proof.
  intro T. split; intros S;subst;inversion T;subst; inversion H; auto.
Qed.

Lemma tick_le_bot' s s' : tick_le s s' -> s <> store_bot <-> s' <> store_bot.
Proof.
  intro T. split;intros S C;subst;inversion T;subst; inversion H; auto.
Qed.

Hint Resolve tick_le_refl store_le_refl heap_le_refl heaps_le_refl heapseq_le_refl .

Lemma tick_le_gc': forall s : store, tick_le (gc s) s.
Proof.
  intros. destruct s;simpl;eauto. destruct o; eauto.
Qed.

Lemma tick_le_tick' s hn hl  : tick_le (store_lock (Some hn) hl) s ->
                              exists hn' hl', s = store_lock (Some hn') hl' /\
                                              heap_le hn hn' /\ heap_le hl hl'.
Proof.
  intros T. inversion T. subst. inversion H. subst. eauto.
Qed.

Lemma heap_le_empty h : heap_le heap_empty h.
Proof.
  intros l t M. assert (exists t, heap_mapsto l t heap_empty) as C by eauto.
  apply heap_empty_fresh in C. contradiction.
Qed.

Hint Resolve heap_le_empty.

Lemma tick_le_empty h h' : tick_le (store_lock None heap_empty) (store_lock h h').
Proof.
  destruct h; eauto.
Qed.

Lemma tick_le_cons hn hl l t :
  heap_fresh l hl ->
  tick_le (store_lock hn hl) (store_lock hn (heap_cons hl l t)).
Proof.
  intro. constructor. destruct hn ;econstructor; eauto using heap_cons_mono.
Qed.

Lemma wsuffix_trans Hs1 Hs2 Hs3 : wsuffix Hs1 Hs2 -> wsuffix Hs2 Hs3 -> wsuffix Hs1 Hs3.
Proof.
  intros W1 W2. dependent destruction W1. dependent destruction W2.
  apply suffix_skipn in H2. destruct H2 as (n & S1). subst.
  apply suffix_skipn in H0. destruct H0 as (n' & S2). subst.
  apply heapseq_le_skipn with (n:=n') in H1.
  rewrite skipn_skipn in H1. rewrite Nat.add_comm in H1.
  rewrite <- skipn_skipn in H1.
  pose (heapseq_le_trans _ _ _ H1 H) as HL.
  rewrite skipn_skipn in HL.
  econstructor. eassumption. apply skip_suffix.
Qed.

Lemma suffix_wsuffix Hs Hs' : suffix Hs Hs' -> wsuffix Hs Hs'.
Proof.
  intros Su. econstructor;eauto.
Qed.
Lemma heapseq_le_wsuffix Hs Hs' : heapseq_le Hs' Hs -> wsuffix Hs Hs'.
Proof.
  intros Su. econstructor;eauto.
Qed.

Lemma heapseq_le_suffix_trans Hs1 Hs2 Hs3 : wsuffix Hs1 Hs2 -> heapseq_le Hs1 Hs3 -> wsuffix Hs3 Hs2.
Proof.
  intros. eauto using wsuffix_trans, heapseq_le_wsuffix.
Qed.

Lemma heapseq_le_cons_wsuffix H Hs  Hs' : heapseq_le Hs (H :: Hs') -> wsuffix Hs' Hs.
Proof.
  intros L.
  inversion L. subst.
  econstructor;eauto.
Qed.

(* Other properties of heaps and stores *)

Lemma heap_dom_cons' l h t : heap_dom l (heap_cons h l t).
Proof.
  exists t. apply heap_cons_mapsto_eq. auto.
Qed.

Lemma heap_dom_cons l l' h t : heap_dom l h -> heap_dom l (heap_cons h l' t).
  unfold heap_dom. intro H. destruct H as (u & H).
  pose (Nat.eq_decidable l l') as D. destruct D.
  - subst. apply heap_dom_cons'.
  - exists u. rewrite heap_cons_mapsto_neq; auto.
Qed.

Lemma heap_dom_alloc_fresh l h : heap_dom l h -> l <> alloc_fresh h.
Proof.
  intros D.
  pose (heap_fresh_alloc h).
  destruct (Nat.eq_decidable l (alloc_fresh h)). subst. contradiction. assumption.
Qed.

Lemma store_mapsto_gc l t s : store_mapsto l t s -> store_mapsto l t (gc s).
Proof.
  intros. destruct H; simpl; autodest.
Qed.

Lemma store_tick_gc s h : store_tick (gc s) h = store_tick s h.
Proof.
  destruct s; auto.
Qed.

Lemma gc_idem s : gc (gc s) = gc s.
Proof.
  destruct s;auto.
Qed.

Lemma store_bot_gc s : s <> store_bot <-> gc s <> store_bot.
Proof.
  split; intros; destruct s; intro C;subst;simpl in *; try contradiction; inversion C.
Qed.

Lemma length_skipn n A  : forall (Hs : list A), n <= length Hs -> length (skipn n Hs) = length Hs - n.
Proof.
  induction n;intros.
  - unfold skipn. simpl. zify;omega.
  - destruct Hs. inversion H. simpl in *. apply IHn. omega.
Qed.

Definition heaps_single (h : heap) : heaps := (fun h' => h' = h).

Lemma heaps_single_le h1 h2 : heap_le h1 h2 -> heaps_le (heaps_single h1) (heaps_single h2).
Proof.
  intros L h HS. inversion HS. subst. eauto. exists h1. split. constructor. assumption.
Qed.

Lemma heaps_single_refl h : heaps_single h h.
Proof. constructor. Qed.

Hint Resolve heaps_single_refl.

(* Closed heaps *)

Definition closed_heap (h : heap) := forall l t, heap_mapsto l t h -> closed_term t.

Inductive closed_store : store -> Prop :=
| closed_store_bot : closed_store store_bot
| closed_store_lock h : closed_heap h -> closed_store (store_lock None h)
| closed_store_tick h h' : closed_heap h -> closed_heap h' -> closed_store (store_lock (Some h) h').

Definition closed_heaps (H : heaps) := forall h, H h -> closed_heap h.

Notation closed_heapseq := (Forall closed_heaps).

Lemma closed_heap_cons_rev u h l t : closed_term u -> heap_mapsto l u h -> closed_heap (heap_cons h l t) -> closed_heap h.
Proof.
  intros CT M CH.
  intros l' t' M'.
  destruct (Nat.eq_decidable l l').
  - subst. eapply heap_mapsto_determ in M;eauto. subst. auto.
  - eapply CH. rewrite heap_cons_mapsto_neq; eauto.
Qed.

Hint Constructors closed_store.

Lemma suffix_closed Hs Hs' : closed_heapseq Hs -> suffix Hs' Hs -> closed_heapseq Hs'.
Proof.
  intros C Su. induction Su. inversion C. subst. eauto. auto.
Qed.

Lemma append_closed Hs Hs' : closed_heapseq Hs -> closed_heapseq Hs' -> closed_heapseq (Hs ++ Hs').
Proof.
  intros C1 C2. induction Hs;simpl;eauto. inversion C1. subst. eauto.
Qed.

Lemma firstn_closed Hs n : closed_heapseq Hs -> closed_heapseq (firstn n Hs).
Proof.
  intros C. generalize dependent Hs. induction n;intros;simpl.
  constructor. destruct Hs. constructor. inversion C. subst. constructor;eauto.
Qed.

Lemma heapseq_le_suffix'' Hs1 Hs2 Hs3 :
  heapseq_le Hs1 Hs3 -> suffix Hs1 Hs2 -> closed_heapseq Hs2 -> closed_heapseq Hs3 ->
  exists Hs4, heapseq_le Hs2 Hs4  /\suffix Hs3 Hs4 /\ closed_heapseq Hs4.
Proof.
  intros HS Su.
  apply suffix_skipn in Su. autodest.
  exists (firstn x Hs2 ++ Hs3). split.
  assert (firstn x Hs2 ++ skipn x Hs2 = Hs2) as SK by eauto using firstn_skipn.
  rewrite <- SK at 1. apply heapseq_le_concat. apply heapseq_le_refl. assumption.
  split. eauto using suffix_concat.
  eauto using append_closed, firstn_closed.
Qed.

Lemma closed_store_gc s: closed_store s -> closed_store (gc s).
Proof.
  intros CS. destruct CS;simpl;eauto.
Qed.

Lemma closed_heap_empty : closed_heap heap_empty.
Proof.
    intros l t M. assert (exists t, heap_mapsto l t heap_empty) as C by eauto.
  apply heap_empty_fresh in C. contradiction.
Qed.