Require Import Lia.

Inductive term :=
| var : nat -> term
| app : term -> term -> term
| lam : term -> term
| lft : term -> term
| rgt : term -> term
| cse : term -> term -> term -> term
.

Inductive lift :=
| ELID : lift
| ELSHFT : lift -> lift
| ELLFT : lift -> lift.

Fixpoint ELLFTn (n : nat) e := match n with
| 0 => e
| S n => ELLFT (ELLFTn n e)
end.

Fixpoint ELSHFTn (n : nat) e := match n with
| 0 => e
| S n => ELSHFT (ELSHFTn n e)
end.

Set Implicit Arguments.

Inductive subs (A : Type) :=
| ESID : subs A
| CONS : A -> subs A -> subs A
| SHFT : subs A -> subs A
| LIFT : subs A -> subs A
.

Unset Implicit Arguments.

Arguments ESID {_}.

Fixpoint LIFTn {A} (n : nat) (σ : subs A) := match n with
| 0 => σ
| S n => LIFT (LIFTn n σ)
end.

Fixpoint SHFTn {A} (n : nat) (σ : subs A) := match n with
| 0 => σ
| S n => SHFT (SHFTn n σ)
end.

Fixpoint reloc n el :=
match el with
| ELID => n
| ELSHFT el => S (reloc n el)
| ELLFT el =>
  match n with
  | 0 => 0
  | S n => S (reloc n el)
  end
end.

Fixpoint lift_term (el : lift) (t : term) :=
match t with
| var n => var (reloc n el)
| app t1 t2 => app (lift_term el t1) (lift_term el t2)
| lam t => lam (lift_term (ELLFT el) t)
| lft t => lft (lift_term el t)
| rgt t => rgt (lift_term el t)
| cse t u1 u2 => cse (lift_term el t) (lift_term (ELLFT el) u1) (lift_term (ELLFT el) u2)
end.

Fixpoint lift_compose (e1 e2 : lift) {struct e1} : lift :=
match e1 with
| ELID => e2
| ELSHFT e1 => ELSHFT (lift_compose e1 e2)
| ELLFT e1 =>
  match e2 with
  | ELID => ELLFT e1
  | ELSHFT e2 => ELSHFT (lift_compose e1 e2)
  | ELLFT e2 => ELLFT (lift_compose e1 e2)
  end
end.

Lemma lift_term_ELLFTn : forall t n, lift_term (ELLFTn n ELID) t = t.
Proof.
induction t; intros m; cbn; try (f_equal; intuition).
+ revert n; induction m as [|m IHm]; cbn in *; intros n.
  - reflexivity.
  - destruct n as [|n]; [reflexivity|].
    f_equal; apply IHm.
+ refine (IHt (S m)).
+ refine (IHt2 (S m)).
+ refine (IHt3 (S m)).
Qed.

Lemma lift_term_ELID : forall t, lift_term ELID t = t.
Proof.
intros.
apply (lift_term_ELLFTn t 0).
Qed.

Fixpoint expand {A} (s : subs A) (n : nat) : (A * nat) + nat :=
match s with
| ESID => inr n
| SHFT s =>
  match expand s n with
  | inl (v, k) => inl (v, S k)
  | inr n => inr (S n)
  end
| LIFT s =>
  match n with
  | 0 => inr 0
  | S n =>
    match expand s n with
    | inl (v, k) => inl (v, S k)
    | inr n => inr (S n)
    end
  end
| CONS v s =>
  match n with
  | 0 => inl (v, 0)
  | S n => expand s n
  end
end.

Definition expand_term s n :=
match expand s n with
| inl (t, k) => lift_term (ELSHFTn k ELID) t
| inr m => var m
end.

Lemma expand_term_ESID : forall n,
  expand_term ESID n = var n.
Proof.
reflexivity.
Qed.

Lemma expand_term_CONS : forall σ n x,
  expand_term (CONS x σ) n =
  match n with 0 => x | S n => expand_term σ n end.
Proof.
intros σ n x.
unfold expand_term; cbn.
destruct n as [|n]; [apply lift_term_ELID|reflexivity].
Qed.

Fixpoint subs_compose {A} (apply : subs A -> A -> A) (σ1 σ2 : subs A) {struct σ1} : subs A :=
match σ1 with
| ESID => σ2
| CONS x σ1 =>
  (fix subs_compose_CONS σ2 {struct σ2} :=
  match σ2 with
  | ESID => CONS x σ1
  | CONS y σ2 => CONS (apply (CONS x σ1) y) (subs_compose_CONS σ2)
  | SHFT σ2 => subs_compose apply σ1 σ2
  | LIFT σ2 => CONS x (subs_compose apply σ1 σ2)
  end) σ2
| SHFT σ1 => SHFT (subs_compose apply σ1 σ2)
| LIFT σ1 =>
  (fix subs_compose_LIFT σ2 {struct σ2} :=
  match σ2 with
  | ESID => LIFT σ1
  | CONS y σ2 => CONS (apply (LIFT σ1) y) (subs_compose_LIFT σ2)
  | SHFT σ2 => SHFT (subs_compose apply σ1 σ2)
  | LIFT σ2 => LIFT (subs_compose apply σ1 σ2)
  end) σ2
end.

Fixpoint subs_term (s : subs term) (t : term) : term :=
match t with
| var n => expand_term s n
| app t1 t2 => app (subs_term s t1) (subs_term s t2)
| lam t => lam (subs_term (LIFT s) t)
| lft t => lft (subs_term s t)
| rgt t => rgt (subs_term s t)
| cse t u1 u2 => cse (subs_term s t) (subs_term (LIFT s) u1) (subs_term (LIFT s) u2)
end.

Lemma subs_term_LIFTn : forall t n, subs_term (LIFTn n ESID) t = t.
Proof.
induction t; intros m; cbn.
+ revert n; induction m as [|m]; intros n; cbn.
  - reflexivity.
  - unfold expand_term; cbn; destruct n as [|n]; [reflexivity|].
    specialize (IHm n).
    unfold expand_term in IHm.
    destruct (expand (LIFTn m ESID) n) as [[v k]|p]; [|congruence].
    destruct v as [p| | | | | ]; cbn in *; congruence.
+ f_equal; intuition.
+ f_equal; apply (IHt (S m)).
+ f_equal; intuition.
+ f_equal; intuition.
+ f_equal; intuition.
  - apply (IHt2 (S m)).
  - apply (IHt3 (S m)).
Qed.

Lemma subs_term_ESID : forall t, subs_term ESID t = t.
Proof.
intros t; apply (subs_term_LIFTn t 0).
Qed.

Fixpoint subs_of_lift {A} el : subs A :=
match el with
| ELID => ESID
| ELLFT el => LIFT (subs_of_lift el)
| ELSHFT el => SHFT (subs_of_lift el)
end.

Lemma subs_term_lift : forall e t,
  subs_term (subs_of_lift e) t = lift_term e t.
Proof.
intros e t; revert e; induction t; intros e; cbn.
+ revert n; induction e; intros n; cbn.
  - reflexivity.
  - unfold expand_term; cbn.
    specialize (IHe n); unfold expand_term in IHe.
    destruct (expand (subs_of_lift e) n) as [[v k]|m]; [|congruence].
    destruct v; cbn in *; congruence.
  - destruct n as [|n]; cbn; [f_equal; apply plus_n_O|].
    unfold expand_term; cbn.
    specialize (IHe n); unfold expand_term in IHe.
    destruct (expand (subs_of_lift e) n) as [[v k]|m]; [|congruence].
    destruct v; cbn in *; congruence.
+ f_equal; intuition.
+ f_equal; apply (IHt (ELLFT e)).
+ f_equal; intuition.
+ f_equal; intuition.
+ f_equal; intuition.
  - apply (IHt2 (ELLFT e)).
  - apply (IHt3 (ELLFT e)).
Qed.

Lemma subs_lift_compose : forall e1 e2,
  subs_of_lift (lift_compose e1 e2) = subs_compose subs_term (subs_of_lift e1) (subs_of_lift e2).
Proof.
induction e1; intros e2; cbn.
+ reflexivity.
+ f_equal; intuition.
+ destruct e2; cbn; f_equal; intuition.
Qed.

Lemma lift_compose_ELID_r : forall e, lift_compose e ELID = e.
Proof.
induction e; cbn; try reflexivity.
f_equal; apply IHe.
Qed.

Lemma lift_term_compose : forall e1 e2 t,
  lift_term (lift_compose e1 e2) t =
    lift_term e1 (lift_term e2 t).
Proof.
intros e1 e2 t; revert e1 e2; induction t; intros e1 e2; cbn.
+ f_equal.
  revert n e2; induction e1; intros n e2; cbn.
  - reflexivity.
  - f_equal; apply IHe1.
  - destruct e2; cbn.
    * destruct n as [|n]; reflexivity.
    * f_equal; apply IHe1.
    * destruct n; [reflexivity|f_equal]; apply IHe1.
+ f_equal; intuition.
+ f_equal; rewrite <- IHt; reflexivity.
+ f_equal; intuition.
+ f_equal; intuition.
+ f_equal; intuition.
  - rewrite <- IHt2; reflexivity.
  - rewrite <- IHt3; reflexivity.
Qed.

Lemma expand_term_SHFT : forall σ n,
  expand_term (SHFT σ) n = lift_term (ELSHFT ELID) (expand_term σ n).
Proof.
intros; unfold expand_term; cbn.
destruct (expand σ n) as [[v k]|m]; cbn; [|reflexivity].
rewrite <- lift_term_compose; reflexivity.
Qed.

Lemma expand_term_LIFT : forall σ n,
  expand_term (LIFT σ) n =
  match n with 0 => var 0 | S n => lift_term (ELSHFT ELID) (expand_term σ n) end.
Proof.
intros; unfold expand_term; cbn; destruct n as [|n]; [reflexivity|].
destruct (expand σ n) as [[k v]|m]; cbn; [|reflexivity].
rewrite <- lift_term_compose; reflexivity.
Qed.

Lemma subs_term_CONS_SHFT_n : forall σ x t n,
  subs_term (LIFTn n (CONS x σ)) (lift_term (ELLFTn n (ELSHFT ELID)) t) = subs_term (LIFTn n σ) t.
Proof.
intros σ x t; revert σ x.
induction t; intros σ x m; cbn.
+ revert n; induction m as [|m]; intros n; cbn.
  - rewrite expand_term_CONS; reflexivity.
  - rewrite !expand_term_LIFT.
    destruct n as [|n]; [reflexivity|].
    f_equal; apply IHm.
+ f_equal; intuition.
+ f_equal.
  apply (IHt _ _ (S m)).
+ f_equal; intuition.
+ f_equal; intuition.
+ f_equal; intuition.
  - apply (IHt2 _ _ (S m)).
  - apply (IHt3 _ _ (S m)).
Qed.

Lemma subs_term_CONS_SHFT : forall σ x t,
  subs_term (CONS x σ) (lift_term (ELSHFT ELID) t) = subs_term σ t.
Proof.
intros; apply subs_term_CONS_SHFT_n with (n := 0).
Qed.

Lemma subs_term_SHFT_SHFT_n : forall σ t n,
  subs_term (LIFTn n (SHFT σ)) t = lift_term (ELLFTn n (ELSHFT ELID)) (subs_term (LIFTn n σ) t).
Proof.
intros σ t; revert σ; induction t; intros σ m; cbn.
+ revert σ n; induction m as [|m]; intros σ n; cbn.
  - rewrite expand_term_SHFT; reflexivity.
  - rewrite !expand_term_LIFT; destruct n as [|n]; [reflexivity|].
    rewrite IHm, <- !lift_term_compose; f_equal.
    clear; induction m as [|m]; cbn; congruence.
+ f_equal; intuition.
+ f_equal; apply (IHt _ (S m)).
+ f_equal; intuition.
+ f_equal; intuition.
+ f_equal; intuition.
  - apply (IHt2 _ (S m)).
  - apply (IHt3 _ (S m)).
Qed.

Lemma subs_term_SHFT_SHFT : forall σ t,
  subs_term (SHFT σ) t = lift_term (ELSHFT ELID) (subs_term σ t).
Proof.
intros; apply subs_term_SHFT_SHFT_n with (n := 0).
Qed.

Lemma subs_term_LIFT_SHFT_n : forall σ t n,
  subs_term (LIFTn n (LIFT σ)) (lift_term (ELLFTn n (ELSHFT ELID)) t) =
  lift_term (ELLFTn n (ELSHFT ELID)) (subs_term (LIFTn n σ) t).
Proof.
intros σ t; revert σ; induction t; intros σ m; cbn.
+ revert n σ; induction m as [|m]; intros n σ; cbn.
  - rewrite expand_term_LIFT; reflexivity.
  - rewrite !expand_term_LIFT; destruct n as [|n]; [reflexivity|].
    rewrite IHm.
    rewrite <- !lift_term_compose; cbn; do 2 f_equal.
    clear; induction m as [|m]; cbn; congruence.
+ f_equal; intuition.
+ f_equal; apply (IHt _ (S m)).
+ f_equal; intuition.
+ f_equal; intuition.
+ f_equal; intuition.
  - apply (IHt2 _ (S m)).
  - apply (IHt3 _ (S m)).
Qed.

Lemma subs_term_LIFT_SHFT : forall σ t,
  subs_term (LIFT σ) (lift_term (ELSHFT ELID) t) = lift_term (ELSHFT ELID) (subs_term σ t).
Proof.
intros σ t; apply subs_term_LIFT_SHFT_n with (n := 0).
Qed.

Lemma subs_term_compose : forall σ1 σ2 t,
  subs_term (subs_compose subs_term σ1 σ2) t =
    subs_term σ1 (subs_term σ2 t).
Proof.
intros σ1 σ2 t; revert σ1 σ2; induction t; intros σ1 σ2; cbn in *.
+ revert n σ2; induction σ1; intros n σ2; cbn.
  - rewrite subs_term_ESID; reflexivity.
  - revert n; induction σ2; intros n; cbn.
    * reflexivity.
    * rewrite !expand_term_CONS.
      destruct n as [|n]; [reflexivity|].
      apply IHσ2.
    * rewrite IHσ1, expand_term_SHFT, subs_term_CONS_SHFT; reflexivity.
    * rewrite !expand_term_CONS, expand_term_LIFT.
      destruct n as [|n]; cbn.
      { symmetry; apply lift_term_ELID. }
      { rewrite IHσ1, subs_term_CONS_SHFT; reflexivity. }
  - rewrite expand_term_SHFT, IHσ1; clear.
    rewrite subs_term_SHFT_SHFT; reflexivity.
  - revert n; induction σ2; intros n; cbn.
    * reflexivity.
    * rewrite !expand_term_CONS; destruct n as [|n]; [reflexivity|].
      apply IHσ2.
    * rewrite !expand_term_SHFT, IHσ1.
      rewrite subs_term_LIFT_SHFT; reflexivity.
    * rewrite !expand_term_LIFT; destruct n as [|n]; [reflexivity|].
      rewrite IHσ1.
      rewrite subs_term_LIFT_SHFT; reflexivity.
+ rewrite IHt1, IHt2; reflexivity.
+ f_equal.
  rewrite <- IHt; reflexivity.
+ f_equal; intuition.
+ f_equal; intuition.
+ rewrite <- IHt1, <- IHt2, <- IHt3; reflexivity.
Qed.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

From Coq Require Import Reals List ssreflect.

(** This file describes compactness results: finite covering of opens,
finite covering based on a gauge function, specific instances for 1D
and 2D spaces. *)

(* This enables a compatibility with Coq 8.4, which didn't have the right lemmas Rplus_lt_reg_l
   and Rplus_lt_reg_r.  So this Import should disappear in the future.  A better solution would
   be to have the fix in a specific compatibility file, rather than in Rcomplements.v. *)
Require Import Rcomplements.

Open Scope R_scope.

Lemma completeness_any :
  forall P : R -> Prop,
  ( forall x y, x <= y -> P y -> P x ) ->
  forall He : (exists x, P x),
  forall Hb : (bound P),
  forall x, x < proj1_sig (completeness _ Hb He) ->
  ~ ~ P x.
Proof.
intros P HP He Hb x.
case completeness => y [Hy1 Hy2] /= Hxy Px.
apply Rle_not_lt with (2 := Hxy).
apply Hy2 => t Pt.
apply Rnot_lt_le => Hxt.
apply Px.
apply: HP Pt.
now apply Rlt_le.
Qed.

Lemma false_not_not :
  forall P Q : Prop, (P -> ~Q) -> (~~P -> ~Q).
Proof.
intros P Q H HP HQ.
apply HP.
intros H'.
now apply H.
Qed.

Section Compactness.

Fixpoint Tn n T : Type :=
  match n with
  | O => unit
  | S n => (T * Tn n T)%type
  end.

Fixpoint bounded_n n : Tn n R -> Tn n R -> Tn n R -> Prop :=
  match n return Tn n R -> Tn n R -> Tn n R -> Prop with
  | O => fun a b x : Tn O R => True
  | S n => fun a b x : Tn (S n) R =>
    let '(a1,a2) := a in
    let '(b1,b2) := b in
    let '(x1,x2) := x in
    a1 <= x1 <= b1 /\ bounded_n n a2 b2 x2
  end.

Fixpoint close_n n d : Tn n R -> Tn n R -> Prop :=
  match n return Tn n R -> Tn n R -> Prop with
  | O => fun x t : Tn O R => True
  | S n => fun x t : Tn (S n) R =>
    let '(x1,x2) := x in
    let '(t1,t2) := t in
    Rabs (x1 - t1) < d /\ close_n n d x2 t2
  end.

(** * Compactness: there is a finite covering of opens *)

Lemma compactness_list :
  forall n a b (delta : Tn n R -> posreal),
  ~~ exists l, forall x, bounded_n n a b x -> exists t, In t l /\ bounded_n n a b t /\ close_n n (delta t) x t.
Proof.
induction n.
intros a b delta.
intros H.
apply H.
exists (tt :: nil).
intros x Hx.
exists tt.
repeat split.
now left.
simpl.
(* *)
intros (a,a') (b,b') delta.
destruct (Rlt_le_dec b a) as [Hab|Hab].
intros H.
apply H.
exists nil.
intros (x,x') (Hx,_).
elim (Rlt_irrefl a).
apply Rle_lt_trans with (2 := Hab).
now apply Rle_trans with x.
(* *)
set (P y := y <= b /\ ~~exists l, forall x, bounded_n (S n) (a,a') (y,b') x ->
  exists t, In t l /\ bounded_n (S n) (a,a') (b,b') t /\ close_n (S n) (delta t) x t).
(* . *)
assert (P1': P a).
split.
apply Hab.
simpl.
specialize (IHn a' b' (fun x' => delta (a,x'))).
contradict IHn.
contradict IHn.
destruct IHn as (l,Hl).
exists (fold_right (fun x' acc => (a,x')::acc) nil l).
intros (x,x') (Hx,Hx').
replace x with a by now apply Rle_antisym.
destruct (Hl x' Hx') as (t',(Ht1,Ht2)).
exists (a,t').
split.
clear -Ht1.
induction l.
easy.
simpl in Ht1 |- *.
destruct Ht1 as [Ht1|Ht1].
left.
now apply f_equal2.
right.
now apply IHl.
repeat split.
apply Rle_refl.
exact Hab.
apply Ht2.
rewrite /Rminus Rplus_opp_r Rabs_R0.
apply cond_pos.
apply Ht2.
(* . *)
assert (P2: bound P).
exists b => y Hy.
apply Hy.
(* . *)
assert (P3: forall x y, x <= y -> P y -> P x).
intros x y Hxy (Py1,Py2).
split.
now apply Rle_trans with y.
contradict Py2.
contradict Py2.
destruct Py2 as (l,Py2).
exists l => [[z z']] Hz.
apply Py2.
split.
split.
apply Hz.
now apply Rle_trans with (1 := proj2 (proj1 Hz)).
apply Hz.
assert (P1: exists x, P x).
now exists a.
(* . *)
set (y := proj1_sig (completeness _ P2 P1)).
assert (P4: ~~exists d : posreal, P (Rmin b (y + d))).
specialize (IHn a' b' (fun x' => delta (y,x'))).
contradict IHn.
contradict IHn.
destruct IHn as (l, Hl).
set (d := fold_right (fun t acc => mkposreal _ (Rmin_stable_in_posreal (delta (y,t)) acc)) (mkposreal _ Rlt_0_1) l).
assert (Hd: 0 < d/2).
apply Fourier_util.Rlt_mult_inv_pos.
apply cond_pos.
apply Rlt_R0_R2.
exists (mkposreal _ Hd).
split.
apply Rmin_l.
refine (_ (completeness_any _ P3 P1 P2 (y - d) _)).
intros Hy.
apply: false_not_not Hy => Hy.
destruct Hy as (Hy1,Hy2).
apply: false_not_not Hy2 => Hy2.
apply.
destruct Hy2 as (l',Hl').
exists (app (fold_right (fun x' acc => (y,x')::acc) nil l) l').
simpl.
intros (x,x') (Hx,Hx').
destruct (Rle_or_lt x (y - d)) as [Hxy|Hxy].
destruct (Hl' (x,x') (conj (conj (proj1 Hx) Hxy) Hx')) as (t,(Ht1,Ht2)).
exists t.
split.
apply in_or_app.
now right.
exact Ht2.
destruct (Hl x' Hx') as (t',(Ht1,Ht2)).
exists (y, t').
split.
apply in_or_app.
left.
clear -Ht1.
induction l.
easy.
simpl in Ht1 |- *.
destruct Ht1 as [Ht1|Ht1].
left.
now apply f_equal2.
right.
now apply IHl.
do 2 split.
unfold y.
case completeness => /= z [Hz1 Hz2].
split.
now apply Hz1.
apply Hz2.
intros w Hw.
apply Hw.
apply Ht2.
apply Rlt_le_trans with d.
apply Rabs_def1.
apply Rplus_lt_reg_r with y.
ring_simplify.
apply Rle_lt_trans with (y + d/2).
now apply Rle_trans with (2 := Rmin_r b _).
apply Rplus_lt_compat_l.
rewrite -(Rplus_0_r (d/2)).
rewrite {2}(double_var d).
now apply Rplus_lt_compat_l.
apply Rplus_lt_reg_l with y.
now ring_simplify (y + (x - y)).
clearbody y.
clear -Ht1.
induction l.
easy.
simpl in Ht1.
destruct Ht1 as [Ht1|Ht1].
rewrite -Ht1.
apply: Rmin_l.
unfold d.
simpl.
apply Rle_trans with (1 := Rmin_r _ _).
now apply IHl.
apply Ht2.
fold y.
rewrite -{2}(Rplus_0_r y) -Ropp_0.
apply Rplus_lt_compat_l.
apply Ropp_lt_contravar.
apply cond_pos.
(* . *)
apply: false_not_not P4 => P4.
destruct P4 as (d,P4).
destruct (Rle_or_lt b y) as [Hby|Hby].
rewrite Rmin_left in P4.
apply P4.
rewrite -(Rplus_0_r b).
apply Rplus_le_compat with (1 := Hby).
apply Rlt_le.
apply cond_pos.
elimtype False.
unfold y in *.
clear y.
revert P4 Hby.
case completeness => /= y [Hy1 Hy2] P4 Hby.
apply Rle_not_lt with (1 := Hy1 (Rmin b (y + d)) P4).
apply Rmin_case.
exact Hby.
rewrite -{1}(Rplus_0_r y).
apply Rplus_lt_compat_l.
apply cond_pos.
Qed.

(** * Compactness: there is a covering based on a gauge function *)

Lemma compactness_value :
  forall n a b (delta : Tn n R -> posreal),
  { d : posreal | forall x, bounded_n n a b x -> ~~ exists t, bounded_n n a b t /\ close_n n (delta t) x t /\ d <= delta t }.
Proof.
intros n a b delta.
set (P d := d <= 1 /\ forall x, bounded_n n a b x -> exists t, bounded_n n a b t /\ close_n n (delta t) x t /\ d <= delta t).
assert (P1 : exists d, P d).
exists 0.
split.
apply Rle_0_1.
intros x Hx.
exists x.
split.
exact Hx.
split.
clear.
induction n.
easy.
destruct x as (x,x').
split.
rewrite /Rminus Rplus_opp_r Rabs_R0.
apply cond_pos.
apply (IHn (fun x' => delta (x,x'))).
apply Rlt_le.
apply cond_pos.
assert (P2 : bound P).
exists 1.
now intros d (Hd,_).
set (d := completeness P P2 P1).
(* *)
assert (P3 : 0 < proj1_sig d).
revert d.
case completeness.
intros d (Hd1,Hd2).
simpl.
apply Rnot_le_lt.
intros Hd3.
apply (compactness_list n a b delta).
intros (l,Hl).
set (v := fold_right (fun t acc => mkposreal _ (Rmin_stable_in_posreal (delta t) acc)) (mkposreal _ Rlt_0_1) l).
apply (Rlt_not_le _ _ (cond_pos v)).
apply Rle_trans with (2 := Hd3).
apply Hd1.
split.
unfold v.
clear.
induction l.
apply Rle_refl.
simpl.
apply Rle_trans with (2 := IHl).
apply Rmin_r.
intros x Hx.
destruct (Hl x Hx) as (t,(Ht1,Ht2)).
exists t.
split.
apply Ht2.
split.
apply Ht2.
clear -Ht1.
induction l.
easy.
simpl in Ht1.
destruct Ht1 as [Ht1|Ht1].
simpl.
rewrite Ht1.
apply Rmin_l.
simpl.
eapply Rle_trans with (1 := Rmin_r _ _).
now apply IHl.
(* *)
exists (mkposreal _ (Fourier_util.Rlt_mult_inv_pos _ _ P3 Rlt_R0_R2)).
intros x Hx.
simpl.
refine (_ (completeness_any P _ P1 P2 (proj1_sig d / 2) _)).
intros HP.
contradict HP.
contradict HP.
destruct HP as (_,HP).
now apply HP.
intros u v Huv (Pv1,Pv2).
split.
now apply Rle_trans with v.
intros z Hz.
destruct (Pv2 z Hz) as (t,Ht).
exists t.
split.
apply Ht.
split.
apply Ht.
apply Rle_trans with (1 := Huv).
apply Ht.
fold d.
rewrite -(Rplus_0_r (proj1_sig d / 2)).
rewrite {2}(double_var (proj1_sig d)).
apply Rplus_lt_compat_l.
apply Fourier_util.Rlt_mult_inv_pos.
exact P3.
apply Rlt_R0_R2.
Qed.

End Compactness.

(** * Specific instances of compactness for 1D and 2D spaces *)

Lemma compactness_value_1d :
  forall a b (delta : R -> posreal),
  { d : posreal | forall x, a <= x <= b -> ~~ exists t, a <= t <= b /\ Rabs (x - t) < delta t /\ d <= delta t }.
Proof.
intros a b delta.
destruct (compactness_value 1 (a,tt) (b,tt) (fun t => let '(t,_) := t in delta t)) as (d, Hd).
exists d.
intros x Hx.
specialize (Hd (x,tt) (conj Hx I)).
do 2 contradict Hd.
destruct Hd as ((t,t'),Ht).
exists t.
repeat split ; apply Ht.
Qed.

Lemma compactness_value_2d :
  forall a b a' b' (delta : R -> R -> posreal),
  { d : posreal | forall x y, a <= x <= b -> a' <= y <= b' ->
    ~~ exists u, exists v, a <= u <= b /\ a' <= v <= b' /\ Rabs (x - u) < delta u v /\ Rabs (y - v) < delta u v /\ d <= delta u v }.
Proof.
intros a b a' b' delta.
destruct (compactness_value 2 (a,(a',tt)) (b,(b',tt)) (fun t => let '(u,(v,_)) := t in delta u v)) as (d, Hd).
exists d.
intros x y Hx Hy.
specialize (Hd (x,(y,tt)) (conj Hx (conj Hy I))).
do 2 contradict Hd.
destruct Hd as ((u,(v,w)),Ht).
exists u.
exists v.
simpl in Ht.
repeat split ; apply Ht.
Qed.


From isla Require Import opsem.

Definition aa0400 : isla_trace :=
  WriteReg "R0" [] (RegVal_Base (Val_Bits (BV 64%N 0x2a%Z))) Mk_annot :t:
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 47%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 47%Z)) Mk_annot :t:
  tnil
.


From stdpp Require Export set fin_maps.
From iris.algebra Require Export local_updates.
From iris.base_logic Require Export base_logic.
From iris_hashtable Require Export multiset.

Close Scope Z_scope.

Section cmra.
  Context {K V: Type} `{FinMap K M}.

  Inductive partial_table : Type :=
  | PTCar : (M (list V) * multiset K) -> partial_table
  | PTBot : partial_table
  | PTUnit : partial_table.

  Global Instance partial_table_empty : Empty partial_table := PTUnit.

  Global Instance partial_table_op : Op partial_table :=
    fun X Y => match X, Y with
               | PTCar (m1, d1), PTCar (m2, d2) =>
                if (decide (map_Forall (fun k _ => k ∈ d1) m1 /\
                            map_Forall (fun k _ => k ∈ d2) m2))
                then PTCar (union_with (fun _ _ => Some []) m1 m2, d1 ∪ d2)
                else PTBot
               | X, PTUnit => X
               | PTUnit, Y => Y
               | _, _ => PTBot
               end.

  Global Instance partial_table_core : PCore partial_table :=
    fun _ => Some PTUnit.

  Global Instance partial_table_valid : Valid partial_table :=
    fun X => match X with
             | PTCar (m, d) =>
               multiset_no_dup d /\
               forall k, (is_Some (m !! k) -> multiset_car d k = 1)
             | PTUnit => True
             | PTBot => False
             end.

  Global Instance partial_table_equiv : Equiv partial_table :=
    fun X Y => match X, Y with
               | PTCar (m1, d1), PTCar (m2, d2) =>
                 m1 = m2 /\ d1 ≡ d2
               | PTUnit, PTUnit => True
               | PTBot, PTBot => True
               | _, _ => False
               end.

  Global Instance partial_table_equiv_equivalence : Equivalence partial_table_equiv.
  Proof.
    split.
    - intros [[??]| |] ;split ; done.
    - intros [[??]| |] [[??]| |] ; try done. intros [??]. split ; done.
    - intros [[??]| |] [[??]| |] [[??]| |] ; try done. intros [??] [??] ; split ; congruence.
  Qed.

  Lemma partial_table_ra_mixin : RAMixin partial_table.
  Proof.
    apply ra_total_mixin ; try by eauto.
    - intros [[m1 d1]| |] [[m2 d2]| |] [[? ?]| |] ; try done.
      intros [<- Heq]. unfold op, partial_table_op. case_decide as Hforall.
      + rewrite decide_True. split. done. intro. simpl. f_equal. done.
        destruct Hforall as [? Hforall]. split. done.
        intros ???. rewrite /elem_of /multiset_elem_of -Heq. eapply Hforall. done.
      + rewrite decide_False //. apply not_and_l in Hforall. destruct Hforall as [Hforall|Hforall].
        intuition. intros [_ Hcon]. apply Hforall. intros ???. rewrite /elem_of /multiset_elem_of Heq.
        eapply Hcon. done.
    - intros [[??]| |] [[??]| |] ; try done.
      intros [<- Heq] [? ?]. split ; intro k ; rewrite -(Heq k) ; auto.
    - intros [[m1 d1]| |] [[m2 d2]| |] [[m3 d3]| |] ;
        unfold op, partial_table_op ; try solve [done| by case_decide].
      case_decide as Hin2_3. case_decide as Hin1_23.
      + rewrite 2?decide_True. split.
        apply map_eq. intro k. rewrite ?lookup_union_with.
        by destruct (m1 !! k), (m2 !! k), (m3 !! k).
        intro. simpl. apply plus_assoc.
        intuition. intros ?? Hlookup. apply lookup_union_with_Some in Hlookup.
        apply elem_of_union. decompose [and or ex] Hlookup ; eauto.
        intuition.
      + rewrite decide_False //. destruct Hin2_3 as [Hin2 Hin3]. apply not_and_l in Hin1_23.
        rewrite ->or_l in Hin1_23. intuition. intro Hnot. apply Hnot.
        intros ?? Hlookup.  apply lookup_union_with_Some in Hlookup.
        apply elem_of_union. decompose [and or ex] Hlookup ; eauto.
      + case_decide ; last done. rewrite decide_False //. intuition.
    - intros [[? ?]| |] [[? ?]| |] ; try done.
      unfold op, partial_table_op. case_decide ; [rewrite decide_True|rewrite decide_False] ; intuition.
      split. apply union_with_comm. done. intro. apply plus_comm.
    - intros [[??]| |] ; by vm_compute.
    - intros [[??]| |] [[??]| |] ? ; by exists PTUnit.
    - intros [[? ?]| |] [[? ?]| |] ; try done. unfold op, partial_table_op.
      case_decide as Hmem ; last done.
      intros [Hnd Hdom]. split.
      + intro k. specialize (Hdom k). specialize (Hnd k). unfold union, multiset_union in *. simpl in *. lia.
      + intros k [? Hlookup]. specialize (Hnd k). destruct Hmem as [Hmem ?]. specialize (Hmem _ _ Hlookup).
        unfold elem_of, multiset_elem_of in Hmem. rewrite /union /multiset_union /= in Hnd. lia.
  Qed.

  Canonical Structure partial_tableC : ofeT := discreteC partial_table.

  Canonical Structure partial_tableR : cmraT := discreteR partial_table partial_table_ra_mixin.

  Lemma partial_table_ucmra_mixin : UCMRAMixin partial_table.
  Proof. split ; try done. by intros [[??]| |]. Qed.

  Canonical Structure partial_tableUR : ucmraT := UCMRAT partial_table partial_table_ucmra_mixin.
  Global Instance partial_table_cmra_discrete : CMRADiscrete partial_tableR.
  Proof. apply discrete_cmra_discrete. Qed.

  Global Instance PTCar_proper : Proper (prod_relation (=) (≡) ==> (≡)) PTCar.
  Proof. intros [??] [??]. solve_proper. Qed.

  Lemma partial_table_valid_op_disjoint m1 m2 d1 d2:
    ✓(PTCar (m1, d1) ⋅ PTCar (m2, d2)) -> d1 ⊥ d2.
  Proof.
    unfold op, partial_table_op. case_decide as Hincl ; last done. intros [Hnd _].
    apply elem_of_disjoint. intros k. specialize (Hnd k). simpl in Hnd.
    unfold elem_of, multiset_elem_of. lia.
  Qed.

  Lemma partial_table_valid_op_map_disjoint m1 m2 d1 d2:
    ✓(PTCar (m1, d1) ⋅ PTCar (m2, d2)) -> m1 ⊥ₘ m2.
  Proof.
    intro Hval. pose proof (partial_table_valid_op_disjoint _ _ _ _ Hval) as Hdisj.
    unfold op, partial_table_op in Hval. case_decide as Hincl ; last done.
    apply map_disjoint_spec. intros k ?? Hlookup1 Hlookup2.
    destruct Hincl as [Hincl1 Hincl2].
    specialize (Hincl1 _ _ Hlookup1). specialize (Hincl2 _ _ Hlookup2).
    simpl in *. rewrite ->elem_of_disjoint in Hdisj. eauto.
  Qed.

  Definition cut_table (d : multiset K) (m : M (list V)) :=
    map_imap (fun k x => if decide (k ∈ d) then Some x else None) m.

  Lemma lookup_cut_table_elem_of m d k :
    k ∈ d -> cut_table d m !! k = m !! k.
  Proof.
    intro. rewrite lookup_imap. destruct (m !! k) ; by [rewrite /= decide_True|].
  Qed.

  Lemma lookup_cut_table_not_elem_of m d k:
    k ∉ d -> cut_table d m !! k = None.
  Proof.
    intro. rewrite lookup_imap. destruct (m !! k) ; by [rewrite /= decide_False|].
  Qed.

  Global Instance cut_table_proper : Proper ((≡) ==> (=) ==> (=)) cut_table.
  Proof.
    intros d1 d2 Heq ?? ->. apply map_eq. intro k.
    destruct (decide (k ∈ d1)).
    - rewrite 2?lookup_cut_table_elem_of -?Heq //.
    - rewrite 2?lookup_cut_table_not_elem_of -?Heq //.
  Qed.

  Lemma cut_table_insert_elem_of m d k l :
    k ∈ d -> cut_table d (<[k := l]>m) = <[k := l]>(cut_table d m).
  Proof.
    intro. apply map_eq. intro k'. destruct (decide (k = k')) as [->|].
    - rewrite lookup_cut_table_elem_of // 2!lookup_insert //.
    - rewrite lookup_insert_ne //. destruct (decide (k' ∈ d)).
      + rewrite 2?lookup_cut_table_elem_of ?lookup_insert_ne //.
      + rewrite 2?lookup_cut_table_not_elem_of //.
  Qed.

  Lemma cut_table_insert_not_elem_of m d k l :
    k ∉ d -> cut_table d (<[k := l]>m) = cut_table d m.
  Proof.
    intro. apply map_eq. intro k'. destruct (decide (k = k')) as [->|].
    - rewrite 2?lookup_cut_table_not_elem_of //.
    - destruct (decide (k' ∈ d)).
      + rewrite 2?lookup_cut_table_elem_of ?lookup_insert_ne //.
      + rewrite 2?lookup_cut_table_not_elem_of //.
  Qed.

  Lemma partial_table_update_partial_alter m d f k :
    k ∈ d -> PTCar (m, d) ~~> PTCar (partial_alter f k m, d).
  Proof.
    intros Hin. apply cmra_discrete_update.
    intros [[m' d']| |] ; rewrite /op /cmra_op /=.
    - case_decide as Hdomparts ; last done.
      intros [Hnd Hdom]. rewrite decide_True.
      + split. done.
        intros k' Hlookup. destruct (decide (k = k')) as [<-|].
        * specialize (Hnd k).
          unfold union, multiset_union in *. simpl in *.
          unfold elem_of, multiset_elem_of in Hin. lia.
        * apply Hdom. rewrite lookup_union_with.
          rewrite lookup_union_with lookup_partial_alter_ne // in Hlookup.
      + destruct Hdomparts as [Hdompart ?].
        split ; last done. intros k' ?. destruct (decide (k = k')) as [<-|].
        eauto. rewrite lookup_partial_alter_ne //. apply Hdompart.
    - done.
    - intros [Hnd Hdom]. split. done.
      intros k' Hlookup. destruct (decide (k = k')) as [<-|].
      + specialize (Hnd k).
        unfold union, multiset_union in *. simpl in *.
        unfold elem_of, multiset_elem_of in Hin. lia.
      + rewrite lookup_partial_alter_ne // in Hlookup. by apply Hdom.
  Qed.

  Lemma partial_table_update_insert m d k l :
    k ∈ d -> PTCar (m, d) ~~> PTCar (<[k := l]>m, d).
  Proof. apply partial_table_update_partial_alter. Qed.

  Lemma partial_table_update_delete m d k :
    k ∈ d -> PTCar (m, d) ~~> PTCar (delete k m, d).
  Proof. apply partial_table_update_partial_alter. Qed.

  Lemma partial_table_local_update_partial_alter m1 d1 m2 d2 f k :
    k ∈ d2 ->
    (PTCar (m1, d1), PTCar (m2, d2)) ~l~>
    (PTCar (partial_alter f k m1, d1), PTCar (partial_alter f k m2, d2)).
  Proof.
    intro Hin. rewrite local_update_unital_discrete.
    intros [[m3 d3]| |] ; rewrite /= /op /cmra_op /= /ucmra_op /=.
    - case_decide as Hdomparts ; last done.
      intros Hval [-> Heq]. split.
      + pose proof (partial_table_update_partial_alter
                      (union_with (λ _ _ : list V, Some []) m2 m3) d1 f k) as Hupd.
        rewrite ->cmra_discrete_update in Hupd.
        rewrite -(right_id _ (⋅) (PTCar (partial_alter f k (union_with (λ _ _ : list V, Some []) m2 m3), d1))).
        apply Hupd. rewrite /elem_of /multiset_elem_of Heq /union /multiset_union /=.
        unfold elem_of, multiset_elem_of in Hin. lia. done.
      + rewrite decide_True.
        * split ; last done.
          apply map_eq. intro k'. destruct (decide (k = k')) as [<-|].
          -- rewrite lookup_partial_alter ?lookup_union_with lookup_partial_alter.
             rewrite ->Heq in Hval. pose proof (partial_table_valid_op_disjoint m2 m3 d2 d3) as Hdisj.
             rewrite /op /cmra_op /= /ucmra_op /= decide_True // in Hdisj.
             apply Hdisj in Hval. rewrite ->elem_of_disjoint in Hval.
             destruct (decide (k ∈ d3)). exfalso. by eapply Hval.
             destruct Hdomparts as [? Hdom]. case_eq (m3 !! k).
             ++ intros ? Hlookup. specialize (Hdom _ _ Hlookup). exfalso. by eapply Hval.
             ++ destruct (m2 !! k) as [l|]; simpl. by destruct (f (Some l)). by destruct (f None).
          -- rewrite lookup_union_with 2?lookup_partial_alter_ne ?lookup_union_with //.
        * destruct Hdomparts as [Hdom ?]. split ; last done.
          intros k'. destruct (decide (k = k')) as [<-|]. done.
          rewrite lookup_partial_alter_ne //. apply Hdom.
    - done.
    - intros ? [<- Heq]. rewrite <-Heq in *. split.
      pose proof (partial_table_update_partial_alter m1 d1 f k) as Hupd.
      rewrite ->cmra_discrete_update in Hupd.
      rewrite -(right_id _ (⋅) (PTCar (partial_alter f k m1, d1))). eauto.
      reflexivity.
  Qed.

  Lemma partial_table_included_subseteq m1 m2 d1 d2:
    PTCar (m1, d1) ≼ PTCar (m2, d2) -> d1 ⊆ d2.
  Proof.
    intros [[[m3 d3]| |] Heq].
    - rewrite /op /= in Heq. case_decide ; last done.
      destruct Heq as [? ->]. apply union_subseteq_l.
    - done.
    - rewrite /op /= in Heq. by destruct Heq as [? ->].
  Qed.

  Lemma partial_table_included_cut_table m1 m2 d1 d2:
    ✓PTCar (m2, d2) ->
    PTCar (m1, d1) ≼ PTCar (m2, d2) ->
    m1 = cut_table d1 m2.
  Proof.
    intros [Hnd Hdom] [[[m3 d3]| |] Heq].
    - rewrite /op /= in Heq. case_decide as Hdomparts ; last done.
      destruct Heq as [-> Heq]. apply map_eq. intro k.
      destruct (decide (k ∈ d1)).
      + rewrite lookup_cut_table_elem_of //. rewrite ->Heq in Hnd.
        case_eq (m1 !! k).
        * intros ? Hlookup. symmetry. apply lookup_union_with_Some.
          left. split. done. eapply map_disjoint_Some_l.
          eapply partial_table_valid_op_map_disjoint.
          rewrite /op /= decide_True //. split. done. intro. rewrite -Heq. apply Hdom.
          done.
        * intro Hlookup. rewrite lookup_union_with Hlookup.
          case_eq (m3 !! k) ; last done.
          intros ? Hlookup'. destruct Hdomparts as [_ Hdom'].
          specialize (Hdom' _ _ Hlookup').
          apply multiset_union_no_dup_disjoint in Hnd. rewrite ->elem_of_disjoint in Hnd.
          exfalso. by eapply Hnd.
      + destruct Hdomparts as [Hdom1 Hdom3]. rewrite lookup_cut_table_not_elem_of //.
        case_eq (m1 !! k) ; last done.
        intros ? Hlookup. specialize (Hdom1 _ _ Hlookup). done.
    - done.
    - rewrite /op /= in Heq. destruct Heq as [<- <-]. apply map_eq.
      intro k. destruct (decide (k ∈ d2)) as [|Hnin].
      + symmetry. apply lookup_cut_table_elem_of. done.
      + rewrite lookup_cut_table_not_elem_of //.
        case_eq (m2 !! k) ; last done.
        intros ? Hlookup. specialize (Hdom _ (ex_intro _ _ Hlookup)).
        unfold elem_of, multiset_elem_of in Hnin. lia.
  Qed.

  Lemma partial_table_op_cut_table m d1 d2:
    ✓PTCar (m, d1) ->
    PTCar (m, d1) ≡ PTCar (cut_table d2 m, d1 ∩ d2) ⋅ PTCar (cut_table (d1 ∖ d2) m, d1 ∖ d2).
  Proof.
    intros [Hnd Hdom]. rewrite /op /= decide_True.
    - split. apply map_eq. intro k. rewrite lookup_union_with.
      destruct (decide (k ∈ d2)) as [Hin|Hnin].
      + rewrite lookup_cut_table_elem_of // lookup_cut_table_not_elem_of.
        destruct (m !! k) ; done. intro Hcontr. rewrite ->multiset_difference_no_dup_elem_of in Hcontr.
        intuition. done.
      + rewrite lookup_cut_table_not_elem_of //.
        destruct (decide (k ∈ d1)) as [Hin'|Hnin'].
        * rewrite lookup_cut_table_elem_of. by destruct (m !! k).
          apply multiset_difference_no_dup_elem_of ; done.
        * rewrite lookup_cut_table_not_elem_of. case_eq (m !! k).
          intros ? Hlookup. specialize (Hdom _ (ex_intro _ _ Hlookup)).
          unfold elem_of, multiset_elem_of in Hnin'. lia.
          done. intro Hcontr. rewrite ->multiset_difference_no_dup_elem_of in Hcontr.
          intuition. done.
      + intro. simpl. lia.
    - split.
      + intros k ? Hlookup. destruct (decide (k ∈ d2)).
        * rewrite ->lookup_cut_table_elem_of in Hlookup. specialize (Hdom _ (ex_intro _ _ Hlookup)).
          apply multiset_elem_of_intersection. split. unfold elem_of, multiset_elem_of. lia. done. done.
        * rewrite ->lookup_cut_table_not_elem_of in Hlookup ; done.
      + intros k ? Hlookup. destruct (decide (k ∈ d1 ∖ d2)). done.
        rewrite lookup_cut_table_not_elem_of // in Hlookup.
  Qed.

End cmra.
Arguments partial_table : clear implicits.
Arguments partial_tableC : clear implicits.
Arguments partial_tableR _ _ _ {_ _ _ _ _ _ _ _ _}.
Arguments partial_tableUR _ _ _ {_ _ _ _ _ _ _ _ _}.


Require MSets.
Require Import Omega.

Module Type FreshListS (Var : Orders.UsualOrderedType).
Parameter fresh : forall s : list Var.t, {v | ~ List.In v s}.
End FreshListS.

Module Type FreshS (Var : Orders.UsualOrderedType)(VSet : MSetInterface.SetsOn(Var)).
Parameter fresh : forall s : VSet.t, {v | ~ VSet.In v s}.
End FreshS.

Module Type VarS := Orders.UsualOrderedType <+ FreshListS.

Module Var : VarS.
Include Coq.Arith.PeanoNat.Nat.

Definition fresh : forall s : list Var.t, {v | ~ List.In v s}.
Proof.
intros l; pose (e := (List.fold_right Nat.max 0 l)).
assert (H : List.Forall (fun x => x <= e) l).
{ induction l; cbn in *; constructor; [apply Nat.le_max_l|].
  eapply List.Forall_impl; [|eassumption].
  cbn; intros; etransitivity; [eassumption|apply Nat.le_max_r]. }
exists (S e); intros He.
eapply List.Forall_forall in He; [|eassumption].
cbn in He; omega.
Qed.

End Var.

Module VSet : MSetInterface.SetsOn(Var) := MSetAVL.Make(Var).
Module Export Fresh : FreshS(Var)(VSet).

Definition fresh : forall s : VSet.t, {v | ~ VSet.In v s}.
Proof.
intros s; destruct (Var.fresh (VSet.elements s)) as [x Hx].
exists x; intros Hi.
apply VSet.elements_spec1 in Hi.
apply SetoidList.InA_alt in Hi; destruct Hi as [y [Hrw Hi]]; subst; intuition.
Qed.

End Fresh.

Module Export VSetFacts := MSetFacts.WFactsOn(Var)(VSet).

Ltac check_not_in l x :=
match l with
| nil => idtac
| cons ?y ?l => try (constr_eq x y; fail 2 x y) ; check_not_in l x
end.

Ltac get T l f :=
match goal with
| [ x : ?T' |- _ ] => unify T T'; check_not_in l x; get T (cons x l) f
| _ => f l
end.

Ltac fold_not_hyp H :=
  let t := type of H in
  match t with context [?P -> False] => fold (not P) in H end.

Ltac fold_not_goal :=
  match goal with |- context [?P -> False] => fold (not P) end.

Ltac simplify_vset_one_hyp H :=
match type of H with
| context [VSet.In ?x (VSet.union ?p ?q)] =>
  rewrite VSet.union_spec in H
| context [VSet.In ?x (VSet.add ?p ?q)] =>
  rewrite VSet.add_spec in H
| context [VSet.In ?x (VSet.singleton ?y)] =>
  rewrite VSetFacts.singleton_iff in H
| context [VSet.In ?x VSet.empty] =>
  rewrite VSetFacts.empty_iff in H
end.

Ltac simplify_vset_one_goal :=
match goal with
| |- context [VSet.In ?x (VSet.union ?p ?q)] =>
  rewrite VSet.union_spec
| |- context [VSet.In ?x (VSet.add ?p ?q)] =>
  rewrite VSet.add_spec
| |- context [VSet.In ?x (VSet.singleton ?y)] =>
  rewrite VSetFacts.singleton_iff
| |- context [VSet.In ?x VSet.empty] =>
  rewrite VSetFacts.empty_iff
end.

Ltac simplify_vset_hyp H :=
  repeat simplify_vset_one_hyp H;
  unfold not in H;
  repeat rewrite Decidable.not_or_iff in H;
  repeat (fold_not_hyp H).

Ltac simplify_vset_goal :=
  repeat simplify_vset_one_goal;
  unfold not;
  repeat rewrite Decidable.not_or_iff;
  repeat fold_not_goal.

Ltac simplify_vset_hyps :=
  repeat match goal with [ H : ?P |- _ ] => progress (simplify_vset_hyp H) end.

Ltac simplify_vset := simplify_vset_hyps; simplify_vset_goal.

Class Nominal (A : Type) (x : A) (s : VSet.t).
Definition vars {A s} (x : A) {_ : Nominal A x s} := s.

Instance Nominal_var : forall x, Nominal Var.t x (VSet.singleton x).
Instance Nominal_vset : forall s, Nominal VSet.t s s.

Notation "x ∈ y" := (VSet.In x (vars y)) (at level 70, no associativity).

Ltac get_nominal l f :=
match goal with
| [ x : ?T |- _ ] =>
  let v := constr:(vars x) in
  let v := match v with @vars _ ?s _ _ => s end in
  check_not_in l v;
  get_nominal (cons v l) f
| _ => f l
end.

Ltac gather_ f :=
  get_nominal (@nil VSet.t) ltac:(fun l =>
  let s := constr:(List.fold_left (fun accu x => VSet.union x accu) l VSet.empty) in
  f s).


Set Implicit Arguments.
Require Import Morphisms Lia List.
From Undecidability.HOU Require Import calculus.calculus.
Import ListNotations ArsInstances.

(* * Conservativity *)

Section Constants.

  (* ** Constant Operations *)
  Section ConstantsOfTerm.
    Context {X: Const}.
    Implicit Types (s t: exp X).

    Fixpoint consts s :=
      match s with
      | var x => nil
      | const c => [c]
      | lambda s => consts s
      | app s t => consts s ++ consts t
      end.
    Definition Consts S := (flat_map consts S).

    Lemma Consts_consts s S:
      s ∈ S -> consts s ⊆ Consts S.
    Proof.
      unfold Consts; eauto using flat_map_in_incl.
    Qed.

    Lemma Consts_montone S T:
      S ⊆ T -> Consts S ⊆ Consts T.
    Proof.
      unfold Consts; eauto using flat_map_incl.
    Qed.

    Lemma consts_ren delta s:
      consts (ren delta s) = consts s.
    Proof.
      induction s in delta |-*; cbn; intuition idtac; congruence.
    Qed.

    Lemma vars_subst_consts x s sigma:
      x ∈ vars s -> consts (sigma x) ⊆ consts (sigma • s).
    Proof.
      intros H % vars_varof; induction H in sigma |-*; cbn; [auto with listdb..|].
      rewrite <-IHvarof; cbn; unfold funcomp; now rewrite consts_ren.
    Qed.

    Lemma consts_subst_in x sigma s:
      x ∈ consts (sigma • s) -> x ∈ consts s \/
                           exists y, y ∈ vars s /\ x ∈ consts (sigma y).
    Proof.
      induction s in sigma |-*.
      - right; exists f; intuition.
      - cbn; intuition.
      - intros H % IHs; cbn -[vars]; intuition idtac.
        destruct H0 as [[]]; cbn -[vars] in *; intuition idtac.
        right. exists n. intuition eauto with listdb.
        unfold funcomp in H1; now rewrite consts_ren in H1.
      - cbn; simplify; intuition idtac.
        + specialize (IHs1 _ H0); intuition idtac.
          destruct H as [y]; right; exists y; intuition (auto with datatypes).
        + specialize (IHs2 _ H0); intuition idtac.
          destruct H as [y]; right; exists y; intuition (auto with datatypes).
    Qed.

    Lemma consts_subset_step s t:
      s > t -> consts t ⊆ consts s.
    Proof.
      induction 1; cbn; [|auto with listdb..].
      subst. unfold beta.
      intros x ? % consts_subst_in; simplify.
      destruct H; [tauto|].
      destruct H as [[|y] ?]; cbn in *; intuition.
    Qed.

    Lemma consts_subset_steps s t:
      s >* t -> consts t ⊆ consts s.
    Proof.
      induction 1; firstorder using consts_subset_step.
    Qed.

    Lemma consts_subst_vars sigma s:
      consts (sigma • s) ⊆ consts s ++ Consts (map sigma (vars s)).
    Proof.
      intros x [|[y]] % consts_subst_in; simplify; intuition idtac.
      right; eapply Consts_consts; eauto using in_map.
    Qed.

    Lemma consts_Lam k s:
      consts (Lambda k s) === consts s.
    Proof.
      induction k; cbn; intuition easy.
    Qed.

    Lemma consts_AppL S t:
      consts (AppL S t) === Consts S ++ consts t.
    Proof.
      induction S; cbn; [trivial with listdb|].
      rewrite IHS; now rewrite app_assoc.
    Qed.

    Lemma consts_AppR s T:
      consts (AppR s T) === consts s ++ Consts T.
    Proof.
      induction T; cbn; [auto with listdb|].
      rewrite IHT.
      split; intros c; simplify; intuition.
    Qed.

  End ConstantsOfTerm.

  Section ConstantSubstitution.

    Implicit Types (X Y Z : Const).

    Fixpoint subst_consts {X Y} (kappa: X -> exp Y) s :=
      match s with
      | var x => var x
      | const c => kappa c
      | lambda s => lambda (subst_consts (kappa >> ren shift) s)
      | app s t => (subst_consts kappa s) (subst_consts kappa t)
      end.

    Lemma ren_subst_consts_commute X Y (zeta: X -> exp Y) delta s:
      subst_consts (zeta >> ren delta) (ren delta s) = ren delta (subst_consts zeta s).
    Proof.
      induction s in delta, zeta |-*; cbn; trivial.
      - f_equal. rewrite <-IHs. f_equal.
        asimpl. reflexivity.
      - now rewrite IHs1, IHs2.
    Qed.

    Lemma subst_consts_comp X Y Z (zeta: X -> exp Y) (kappa: Y -> exp Z) s:
      subst_consts kappa (subst_consts zeta s) =
      subst_consts (zeta >> subst_consts kappa) s.
    Proof.
      induction s in zeta, kappa |-*; cbn; trivial.
      - f_equal. rewrite IHs. f_equal. fext.
        unfold funcomp at 4; unfold funcomp at 4.
        intros; rewrite <-ren_subst_consts_commute.
        reflexivity.
      - now rewrite IHs1, IHs2.
    Qed.

    Lemma subst_consts_ident Y zeta s:
      (forall x: Y, x ∈ consts s -> zeta x = const x) -> subst_consts zeta s = s.
    Proof.
      intros; induction s in zeta, H |-*; cbn; trivial.
      eapply H; cbn; tauto.
      rewrite IHs; trivial.
      unfold funcomp; now intros x -> % H.
      rewrite IHs1, IHs2; trivial.
      all: intros; apply H; cbn; simplify; intuition.
    Qed.

    Lemma subst_const_comm {X Y} (zeta: X -> exp Y) sigma delta s:
      (forall x, sigma (delta x) = var x) ->
      subst_consts zeta (sigma • s) = (sigma >> subst_consts zeta) • (subst_consts (zeta >> ren delta) s).
    Proof.
      induction s in zeta, sigma, delta |-*; intros H; cbn.
      - reflexivity.
      - unfold funcomp; asimpl.
        rewrite idSubst_exp; trivial.
        intros y; unfold funcomp; cbn.
        rewrite H; reflexivity.
      - f_equal. erewrite IHs with (delta := 0 .: delta >> shift).
        2: intros []; cbn; unfold funcomp; trivial; rewrite H; reflexivity.
        f_equal; [| now asimpl].
        fext; intros []; cbn; trivial.
        unfold funcomp at 2.
        now rewrite ren_subst_consts_commute.
      - erewrite IHs1, IHs2; eauto.
    Qed.

    #[export] Instance step_subst_consts X Y:
      Proper (Logic.eq ++> step ++> step) (@subst_consts X Y).
    Proof.
      intros ? zeta -> s t H; induction H in zeta |-*; cbn; [|eauto..].
      econstructor; subst; unfold beta.
      erewrite subst_const_comm with (delta := shift).
      f_equal. fext.
      all: intros []; cbn; eauto.
    Qed.

    #[export] Instance steps_subst_consts X Y:
      Proper (Logic.eq ++> star step ++> star step) (@subst_consts X Y).
    Proof.
      intros ? zeta -> s t H; induction H in zeta |-*; cbn; trivial; rewrite H; eauto.
    Qed.

    #[export] Instance equiv_subst_consts X Y:
      Proper (Logic.eq ++> equiv step ++> equiv step) (@subst_consts X Y).
    Proof.
      intros ? zeta -> s t [v [H1 H2]] % church_rosser; trivial;
        now rewrite H1, H2.
    Qed.

    Lemma subst_consts_consts X Y (zeta: X -> exp Y) (s: exp X):
      consts (subst_consts zeta s) === Consts (map zeta (consts s)).
    Proof.
      unfold Consts; induction s in zeta |-*; cbn; simplify; [eauto with listdb|eauto with listdb|..].
      - rewrite IHs.
        unfold funcomp; rewrite <-map_map, !flat_map_concat_map, map_map.
        erewrite map_ext with (g := consts); intuition eauto with listdb.
        now rewrite consts_ren.
      - rewrite IHs1, IHs2, !flat_map_concat_map; simplify.
        now rewrite concat_app.
    Qed.

    Lemma consts_in_subst_consts X Y (kappa: X -> exp Y) c s:
      c ∈ consts (subst_consts kappa s) -> exists d, d ∈ consts s /\ c ∈ consts (kappa d).
    Proof.
      rewrite subst_consts_consts.
      unfold Consts; rewrite in_flat_map; intros [e []]; mapinj.
      exists x; intuition.
    Qed.

    Lemma subst_consts_up Y Z (zeta: Y -> exp Z) (sigma: fin -> exp Y):
      up (sigma >> subst_consts zeta) = up sigma >> subst_consts (zeta >> ren shift).
    Proof.
      fext; intros []; cbn; trivial.
      unfold funcomp at 1 2.
      now rewrite <-ren_subst_consts_commute.
    Qed.

    Lemma subst_const_comm_id Y zeta sigma (s: exp Y):
      subst_consts zeta s = s ->
      (sigma >> subst_consts zeta) • s = subst_consts zeta (sigma • s).
    Proof.
      induction s in zeta, sigma |-*; cbn; [trivial|congruence|..].
      - injection 1 as H. f_equal.
        rewrite <-IHs; trivial.
        now rewrite subst_consts_up.
      - injection 1 as H. f_equal; eauto.
    Qed.

    Lemma typing_constants X n Gamma s A :
      Gamma ⊢(n) s : A -> forall c, c ∈ consts s -> ord (ctype X c) <= S n.
    Proof.
      induction 1; cbn;  intuition idtac; subst; trivial.
      simplify in H1; intuition.
    Qed.

    Lemma typing_Consts X c n Gamma S' L:
      Gamma ⊢₊(n) S' : L -> c ∈ Consts S' -> ord (ctype X c) <= S n.
    Proof.
      induction 1; cbn; simplify; intuition eauto using typing_constants.
    Qed.

    Lemma preservation_consts X Y Gamma s A (zeta: X -> exp Y):
      Gamma ⊢ s : A -> (forall x, x ∈ consts s -> Gamma ⊢ zeta x : ctype X x) ->
      Gamma ⊢ subst_consts zeta s : A.
    Proof.
      induction 1 in zeta |-*; cbn; [eauto|eauto|..].
      - intros H'. econstructor. eapply IHtyping.
        intros; eapply preservation_under_renaming; [eauto|].
        intros ?; cbn; eauto.
      - intros H'. econstructor.
        eapply IHtyping1; intros ??; eapply H'; simplify; intuition idtac.
        eapply IHtyping2; intros ??; eapply H'; simplify; intuition idtac.
    Qed.

    Lemma ordertyping_preservation_consts X Y n Gamma s A (zeta: X -> exp Y):
      Gamma ⊢(n) s : A -> (forall x, x ∈ consts s -> Gamma ⊢(n) zeta x : ctype X x) ->
      Gamma ⊢(n) subst_consts zeta s : A.
    Proof.
      induction 1 in zeta |-*; cbn; [eauto|eauto|..].
      - intros H'. econstructor. eapply IHordertyping.
        intros; eapply ordertyping_preservation_under_renaming; [eauto|].
        intros ?; cbn; eauto.
      - intros H'. econstructor.
        eapply IHordertyping1; intros ??; eapply H'; simplify; intuition idtac.
        eapply IHordertyping2; intros ??; eapply H'; simplify; intuition idtac.
    Qed.

    Lemma subst_consts_Lambda Y Z (zeta: Y -> exp Z) k s:
        subst_consts zeta (Lambda k s) = Lambda k (subst_consts (zeta >> ren (plus k)) s).
    Proof.
        induction k in zeta |-*; cbn; asimpl; trivial.
        f_equal. rewrite IHk. f_equal. f_equal.
        asimpl. fext; intros x; unfold funcomp; f_equal; fext; intros ?.
        unfold shift; simplify; f_equal; lia.
    Qed.

    Lemma subst_consts_AppL X Y (tau: X -> exp Y) S t:
        subst_consts tau (AppL S t) = AppL (map (subst_consts tau) S) (subst_consts tau t).
    Proof.
        induction S; cbn; congruence.
    Qed.

    Lemma subst_consts_AppR X Y (tau: X -> exp Y) s T:
        subst_consts tau (AppR s T) = AppR (subst_consts tau s) (map (subst_consts tau) T).
    Proof.
        induction T; cbn; congruence.
    Qed.

  End ConstantSubstitution.
End Constants.


(*string imports*)
Require Import Strings.String.
Require Import List.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.

(*some errors*)

Inductive ErrorNat :=
  | error_nat : ErrorNat
  | num : nat -> ErrorNat.

Inductive ErrorBool :=
  | error_bool : ErrorBool
  | boolean : bool -> ErrorBool.

Coercion num: nat >-> ErrorNat.
Coercion boolean: bool >-> ErrorBool.

(*Var Types*)
Inductive NNat :=
| nat_err : NNat
| nat_val : nat -> NNat.

Inductive BBool :=
| bool_err : BBool
| b_true : BBool
| b_false : BBool.

Inductive SString :=
|str_err : SString
|str_val : string -> SString.
(* A general type which includes all kind of types *)
Inductive Result :=
  | err_undecl : Result
  | err_assign : Result
  | default : Result
  | res_nat : ErrorNat -> Result
  | res_bool : ErrorBool -> Result
  | value_nat : NNat -> Result
  | value_bool : BBool -> Result
  | value_string : SString -> Result.

Scheme Equality for Result.

(* An environment which maps variable names (strings) to the Result type *)
Definition Env := string -> Result.

(* Initial environment *)
Definition env : Env := fun  x => err_undecl.
(*variables declared*)

(*arithmethic stuff*)
Inductive AExp :=
| avar : string -> AExp
| aint : NNat -> AExp
| anum : nat -> AExp
| aplus : AExp -> AExp -> AExp
| amin : AExp -> AExp -> AExp
| adiv : AExp -> AExp -> AExp
| amod : AExp -> AExp -> AExp
| amul : AExp -> AExp -> AExp.

Coercion anum : nat >-> AExp.

Notation "A +' B" := (aplus A B) (at level 60, right associativity).
Notation "A *' B" := (amul A B) (at level 58, left associativity).
Notation "A -' B" := (amin A B) (at level 60, right associativity).
Notation "a /' b" := (adiv a b) (at level 58, left associativity).
Notation "a %' b" := (amod a b) (at level 58, left associativity).

(*bool stuff*)
Inductive BExp :=
| bvar : Env -> BExp
| btrue : BExp
| bfalse : BExp
| bnot : BExp -> BExp
| band : BExp -> BExp -> BExp
| bor  : BExp -> BExp -> BExp
| blessthan : AExp -> AExp -> BExp
| bgreaterthan : AExp -> AExp -> BExp
| bdifferent : AExp -> AExp -> BExp
| bless_equal : AExp -> AExp -> BExp
| bgreater_equal : AExp -> AExp -> BExp
| bequal : AExp -> AExp -> BExp.

Notation "A <' B" := (blessthan A B) (at level 80).
Notation "A >' B" := (bgreaterthan A B) (at level 80).
Notation "A >=' B" := (bgreater_equal A B) (at level 80).
Notation "A <=' B" := (bless_equal A B) (at level 80).
Notation "A !=' B" := (bdifferent A B) (at level 80).
Notation "A =' B" := (bequal A B) (at level 80).
Infix "and'" := band (at level 82).
Infix "or'" := bor (at level 82).
Notation "!' A" := (bnot A) (at level 81).
(*string manipulations*)
Inductive STRexp :=
| s_var : Env -> STRexp
| s_str : SString -> STRexp
| s_concat: STRexp -> STRexp -> STRexp.

Notation "STR1 <--> STR2" := (s_concat STR1 STR2) (at level 53).

(**)
Inductive Exp :=
| e_Aexp : AExp -> Exp
| e_Bexp : BExp -> Exp
| e_STRexp : STRexp -> Exp.

(*pointer*)
Inductive Adress :=
| ad_var : Env -> Adress.

(*vector/pointers/types*)
Inductive Declaration :=
| decl_int_exp : string -> AExp -> Declaration
| decl_bool_exp : string -> BExp -> Declaration
| decl_string_exp : string -> STRexp -> Declaration
| decl_int : string -> Declaration
| decl_bool : string -> Declaration
| decl_string : string -> Declaration
| decl_struct: string -> list Declaration -> Declaration
| decl_vect_int : string -> nat -> Declaration
| decl_vect_bool : string -> nat -> Declaration
| decl_vect_string : string -> nat -> Declaration
| decl_vect_int_init : string -> nat -> list NNat -> Declaration
| decl_vect_bool_init : string -> nat -> list BBool -> Declaration
| decl_vect_string_init : string -> nat -> list SString -> Declaration
| decl_mat_int : string -> nat -> nat -> Declaration
| decl_mat_bool : string -> nat  -> nat -> Declaration
| decl_mat_string : string -> nat -> nat -> Declaration
| decl_mat_int_init : string -> nat -> nat -> list NNat -> list NNat -> Declaration
| decl_mat_bool_init : string -> nat -> nat -> list BBool -> list BBool -> Declaration
| decl_mat_string_init : string -> nat -> nat -> list SString -> list SString -> Declaration
| decl_pointer_int : string -> Declaration
| decl_pointer_bool : string -> Declaration
| decl_pointer_string : string -> Declaration
| decl_pointer_int_init : string -> Adress -> Declaration
| decl_pointer_bool_init : string -> Adress -> Declaration
| decl_pointer_string_init : string -> Adress -> Declaration.

Notation "'int' A " := (decl_int A)(at level 50).
Notation "'int' A --> V" := (decl_int_exp A  V)(at level 50).
Notation "'int*' A " := (decl_pointer_int A)(at level 50).
Notation "'int*' A --> AD" := (decl_pointer_int_init A AD) (at level 50).
Notation "'Bbool' B " := (decl_bool B)(at level 50).
Notation "'Bbool' B --> V" := (decl_bool_exp B  V)(at level 50).
Notation "'Bbool*' B --> AD" := (decl_pointer_bool_init B AD) (at level 50).
Notation "'Bbool*' B " := (decl_pointer_bool B)(at level 50).
Notation "'chars' S " := (decl_string S)(at level 50).
Notation "'chars' S --> V" := (decl_string_exp S  V)(at level 50).
Notation "'chars*' S --> AD" := (decl_pointer_string_init S AD) (at level 50).
Notation "'chars*' S |" := (decl_pointer_string S)(at level 50).
Notation "'struct'' S '{'' D1 ; D2 ; .. ; Dn '}''" := (decl_struct S (cons D1 ( cons D2 .. (cons Dn nil) .. ) ) )(at level 50).
Notation "'int' V [ Nr ]" := ( decl_vect_int V Nr) (at level 50).
Notation "'Bbool' V [ Nr ]" := ( decl_vect_bool V Nr) (at level 50).
Notation "'chars' V [ Nr ]" := ( decl_vect_string V Nr) (at level 50).
Notation "'int' V [ Nr ] --> '{' List '}'" := (decl_vect_int_init V Nr (List)) (at level 50).
Notation "'Bbool' V [ Nr ] --> '{'' List '}''" := (decl_vect_bool_init V Nr (List) ) (at level 50).
Notation "'chars' V [ Nr ] --> '{'' List '}''" := (decl_vect_string_init V Nr (List)) (at level 50).

Notation "'int' V [ Nr ][ Nr2 ] " := ( decl_mat_int V Nr Nr2) (at level 50).
Notation "'Bbool' V [ Nr ][ Nr2 ]" := ( decl_mat_bool V Nr Nr2) (at level 50).
Notation "'chars' V [ Nr ][ Nr2 ]" := ( decl_mat_string V Nr Nr2) (at level 50).
(*Notation "'int' V [ Nr1 ][ Nr2 ] --> '{' L1 ; L2 ; .. ; Ln '}'" := (decl_mat_int_init V (List L1 ..(List L2 .. (List Ln nil)..) ..) .. ) (at level 50)*)

(*writing stuff*)
Inductive Stmt :=
| assignment : Env -> AExp -> Stmt
| while : BExp -> Stmt -> Stmt
| ifelse : BExp -> Stmt -> Stmt ->Stmt
| seq : Stmt -> Stmt -> Stmt.

Notation "X ::= A" := (assignment X A) (at level 85).
Notation "S1 ;; S2" := (seq S1 S2) (at level 99).
Notation "WWhile( A ){ B }" := (while A B) (at level 85).
Notation "IF( A ){ B }ELSE{ C }" := (ifelse A B C) (at level 85).

(*functions*)
Inductive Fun :=
| decl_fun_int: Env -> list Declaration -> Stmt -> Fun
| decl_fun_bool: Env -> list Declaration -> Stmt -> Fun
| decl_fun_string: Env -> list Declaration -> Stmt -> Fun.

Notation "'chars A ( B1 , B2 , .. , Bn ){ C }" := (decl_fun_string A (cons B1 ( cons B2 .. (cons Bn nil) .. ) ) C) (at level 50).
Notation "'int' A ( B1 , B2 , .. , Bn ){ C }" := (decl_fun_int A (cons B1 ( cons B2 .. (cons Bn nil) .. ) ) C) (at level 50).
Notation "'Bbool' A ( B1 , B2 , .. , Bn ){ C }" := (decl_fun_bool A (cons B1 ( cons B2 .. (cons Bn nil) .. ) ) C) (at level 50).

(* Semantix *)

Definition get_nat (v : Result) : NNat :=
match v with
| value_nat n => n
| _ => nat_err
end.

Definition get_bool (v : Result) : BBool :=
match v with
| value_bool b => b
| _ => bool_err
end.

Definition get_str (v : Result) : SString :=
match v with
| value_string s => s
| _ => str_err
end.

Coercion value_nat: NNat >-> Result.
Coercion value_bool: BBool >-> Result.
Coercion value_string : SString >-> Result.

Definition EnvS := string -> Result.

Definition update_value (env : Env)
           (x : string) (v : Result) : Env :=
  fun y =>
    if (string_dec y x)
    then v
    else (env y).

Definition update (env : Env)
           (x : string) : Env := (update_value env x err_undecl).

Definition add_nat (x y : NNat) : NNat :=
match x, y with
| nat_err, _ => nat_err
| _ ,nat_err => nat_err
| nat_val x, nat_val y => nat_val (x + y)
end.

Definition mul_nat (x y : NNat) : NNat :=
match x, y with
| nat_err, _ => nat_err
| _ ,nat_err => nat_err
| nat_val x, nat_val y => nat_val (x * y)
end.

Coercion nat_val : nat >-> NNat.

Definition div_nat (x y : NNat) : NNat :=
match x, y with
| nat_err, _ => nat_err
| _ ,nat_err => nat_err
| nat_val x, nat_val y => Nat.div x y
end.

Definition mod_nat (x y : NNat) : NNat :=
match x, y with
| nat_err, _ => nat_err
| _ ,nat_err => nat_err
| nat_val x, nat_val y => Nat.modulo x y
end.

Fixpoint get_from_nat_vector (l : list NNat) (n : nat) : NNat :=
match n, l with
| O, x::l1 => x
| S m, nil => nat_err
| S m, x::l2 => (get_from_nat_vector l2 m)
| _, _ => nat_err
end.

Fixpoint get_from_bool_vector (l : list BBool) (n : nat) : BBool :=
match n, l with
| O, x::l1 => x
| S m, nil => bool_err
| S m, x::l2 => (get_from_bool_vector l2 m)
| _, _ => bool_err
end.

Fixpoint get_from_str_vector (l : list SString) (n : nat) : SString :=
match n, l with
| O, x::l1 => x
| S m, nil => str_err
| S m, x::l2 => (get_from_str_vector l2 m)
| _, _ => str_err
end.
Reserved Notation "A =[ S ]=> N" (at level 40).
(*Inductive aeval : AExp -> Env -> NNat -> Prop :=
| e_aconst : forall n sigma, aint n =[ sigma ]=> n
| e_avar : forall v sigma, avar v =[ sigma ]=> (get_nat (sigma v))
| e_add : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n =  add_nat i1 i2 ->
    a1 +' a2 =[sigma]=> n
| e_mul : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = mul_nat i1 i2 ->
    a1 *' a2 =[sigma]=> n
| e_sub : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n =  sub_nat i1 i2 ->
    a1 -' a2 =[sigma]=> n
| e_div : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n =  div_nat i1 i2 ->
    a1 /' a2 =[sigma]=> n
| e_mod : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n =  mod_nat i1 i2 ->
    a1 %' a2 =[sigma]=> n
| e_bool_to_nat : forall b sigma, a_bool_to_nat b =[ sigma ]=> conv_bool_nat b

| e_aget_vect_val : forall v1 v2 n sigma,
  v2 = (sigma v1) ->
  a_get_vect_val v1 n =[ sigma ]=> get_nat (get_element v2 n)

where "a =[ sigma ]=> n" := (aeval a sigma n).*)

Definition val_Bool (b : bool) : BBool :=
match b with
| true => b_true
| false => b_false
end.

Definition less_than(a1 a2 : NNat) : BBool :=
match a1, a2 with
| _, nat_err => bool_err
| nat_err, _ => bool_err
| nat_val n1, nat_val n2 => val_Bool (Nat.ltb n1 n2)
end.

Definition less_equal_than(a1 a2 : NNat) : BBool :=
match a1, a2 with
| _, nat_err => bool_err
| nat_err, _ => bool_err
| nat_val n1, nat_val n2 => val_Bool (Nat.leb n1 n2)
end.

Definition greater_than(a1 a2 : NNat) : BBool :=
match a1, a2 with
| _, nat_err => bool_err
| nat_err, _ => bool_err
| nat_val n1, nat_val n2 => val_Bool (Nat.leb n2 n1)
end.

Definition greater_equal_than(a1 a2 : NNat) : BBool :=
match a1, a2 with
| _, nat_err => bool_err
| nat_err, _ => bool_err
| nat_val n1, nat_val n2 => val_Bool (Nat.ltb n2 n1)
end.

Definition equality(a1 a2 : NNat) : BBool :=
match a1, a2 with
| _, nat_err => bool_err
| nat_err, _ => bool_err
| nat_val n1, nat_val n2 => val_Bool (Nat.eqb n1 n2)
end.

Definition different(a1 a2 : NNat) : BBool :=
match a1, a2 with
| _, nat_err => bool_err
| nat_err, _ => bool_err
| nat_val n1, nat_val n2 => val_Bool (negb (Nat.eqb n1 n2))
end.

Reserved Notation "B ={ S }=> B'" (at level 60).
(*
Inductive beval : BExp -> Env -> BBool -> Prop :=
| e_true : forall sigma, btrue ={ sigma }=> b_true
| e_false : forall sigma, bfalse ={ sigma }=> b_false

(*| e_b_var : forall v sigma, bvar v ={ sigma }=> get_bool (sigma v)*)

| e_lessthan : forall a1 a2 i1 i2 sigma b,
    a1 ={ sigma }=> i1 ->
    a2 ={ sigma }=> i2 ->
    b = less_than (get_nat i1) (get_nat i2) ->
    a1 <' a2 ={ sigma }=> b

| e_less_equal_than : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = less_equal_than (get_nat i1) (get_nat i2) ->
    a1 <=' a2 ={ sigma }=> b

| e_greaterthan : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = greater_than (get_nat i1) (get_nat i2) ->
    a1 <' a2 ={ sigma }=> b

| e_grater_equal_than : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = less_equal_than i1 i2->
    a1 <=' a2 ={ sigma }=> b

| e_nottrue : forall b sigma,
    b ={ sigma }=> b_true ->
    !' b ={ sigma }=> b_false

| e_andtrue : forall b1 b2 sigma t,
    b1 ={ sigma }=> b_true ->
    b2 ={ sigma }=> t ->
    b1 and' b2 ={ sigma }=> t
| e_andfalse : forall b1 b2 sigma,
    b1 ={ sigma }=> b_false ->
    b1 and' b2 ={ sigma }=> b_false

| e_ortrue : forall b1 b2 sigma,
    b1 ={ sigma }=> b_true ->
    b1 or' b2 ={ sigma }=> b_true

| e_orfalse : forall b1 b2 sigma t,
    b1 ={ sigma }=> b_false ->
    b2 ={ sigma }=> t ->
    b1 or' b2 ={ sigma }=> t

| e_equal : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = equality i1 i2 ->
    a1 =' a2 ={ sigma }=> b

| e_different : forall a1 a2 i1 i2 sigma b,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    b = different i1 i2 ->
    a1 =' a2 ={ sigma }=> b

| e_nat_to_bool : forall a sigma,  b_nat_to_bool a ={ sigma }=> conv_nat_bool a

| e_bget_vect_val : forall v1 v2 n sigma,
  v2 = (sigma v1) ->
  b_get_vect_val v1 n ={ sigma }=> get_bool (get_element v2 n)

where "B ={ S }=> B'" := (beval B S B').*)


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the static semantics of typing in the heap, pg 64.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.

Fixpoint gettype (u : Upsilon) (x : EVar) (p : P) (tau : Tau) (p' : P) : option Tau :=
  match u, x, p, tau, p' with
    | _, _, p, _, [] => Some tau
    | _, _, _, (etype aliases alpha k tau'), (u_pe :: p') =>
      match getU u x p with
          | None => None
          | Some tau'' =>
            match gettype u x (p ++ [u_pe]) (subst_Tau tau' tau'' alpha) p' with
                | None => None
                | Some tau => Some tau
            end
      end
    | _, _, _, (cross t0 t1), ((i_pe (i_i 0)) :: p') =>
      match gettype u x (p ++ [(i_pe (i_i 0))]) t0 p' with
          | None => None
          | Some tau  => Some tau
      end
    | _, _, _, (cross t0 t1), ((i_pe (i_i 1)) :: p') =>
      match gettype u x (p ++ [(i_pe (i_i 1))]) t1 p' with
          | None => None
          | Some tau  => Some tau
      end
    | _, _, _, _, _ => None
end.

Functional Scheme gettype_ind := Induction for gettype Sort Prop.


Require Import Typing.
Require Export ContextualCausality.
Require Import Tactics.
Require Import Utils.
Require Import Environments.
Require Import Causality.

Import ListNotations.

(* A type system with time-indexed types. This system subsumes both
the type system and the contextual causality system. *)

Open Scope Z.

(* Timed types *)

Inductive TiTy := TimedType (ty : Ty) (ti : TimeB).

Infix "@" := TimedType (at level 50).

(* Selector functions to extract the time and the type of a timed
type. *)

Definition time (t : TiTy)  := match t with TimedType _ ti => ti end.
Definition type (t : TiTy) := match t with TimedType ty _ => ty end.

(* Convenience function to add time to a timed type. *)

Definition add_time d (t : TiTy) := match t with TimedType ty ti => TimedType ty (tadd' d ti) end.
Definition sub_time d (t : TiTy) := match t with TimedType ty ti => TimedType ty (tsub' d ti) end.

(* A time timed time environment maps variables to timed types.  *)

Definition TiTyEnv := Env' TiTy.

Open Scope time.

(* Definition of the timed type inference rules for variables,
operators, expressions and contracts. *)

Inductive TiTyV : TiTyEnv -> TiTy -> Var -> Prop :=
| causal_V1 t t' g  : type t = type t' -> time t <= time t' -> TiTyV (t :: g) t' V1
| causal_VS g v t t' : TiTyV g t v -> TiTyV (t' :: g) t (VS v).

Definition TiTyOp (op : Op) (ts : list TiTy) (t:TiTy) : Prop
  := (all (fun t' => time t' = time t) ts) /\ TypeOp op (map type ts) (type t).

Lemma TiTyOp_TypeOp op ts t ty tys :
  TypeOp op tys ty ->
  (all (fun t' => time t' = time t) ts) ->
  tys = map type ts -> ty = type t ->
  TiTyOp op ts t.
Proof.
  intros. subst. firstorder.
Qed.

Inductive TiTyE : TiTyEnv -> TiTy -> Exp -> Prop:=
 | causal_op t ts ts' op args : TiTyOp op ts' t -> all2 (TiTyE ts) ts' args -> TiTyE ts t (OpE op args)
 | causal_obs l t' t ts : Time t' <= time t -> |-O l ∶ type t ->  TiTyE ts t (Obs l t')
 | causal_var t ts v : TiTyV ts t v -> TiTyE ts t (VarE v)
 | causal_acc t ts e1 e2 n : TiTyE (map (add_time n) ts) (add_time n t) e2
                             -> TiTyE (type t @ TimeBot :: ts) t e1
                             -> TiTyE ts t (Acc e1 n e2)
  .

Inductive TiTyC : TiTyEnv -> TimeB -> Contr -> Prop :=
| causal_zero ts t : TiTyC ts t Zero
| causal_translate ts t d c : TiTyC (map (sub_time d) ts) (tsub' d t) c
                                     -> TiTyC ts t (Translate d c)
| causal_let ts t t' e c : TiTyE ts t' e -> TiTyC (t' :: ts) t c -> TiTyC ts t (Let e c)
| causal_scale ts ti ti' e c : ti' <= ti -> TiTyE ts (REAL @ ti) e -> TiTyC ts ti c -> TiTyC ts ti' (Scale e c)
| causal_both ts t c1 c2 : TiTyC ts t c1 -> TiTyC ts t c2 -> TiTyC ts t (Both c1 c2)
| causal_transfer t ts p1 p2 a : t <= Time 0 -> TiTyC ts t (Transfer p1 p2 a)
| causal_if ts t d e c1 c2 : TiTyE ts (BOOL @ Time 0) e -> TiTyC ts t c1
                             -> TiTyC (map (sub_time d) ts) (tsub' d t) c2
                             -> TiTyC ts t (If e d c1 c2)
.

Hint Constructors TiTyV TiTyE TiTyC.

(* We now show that timed typing implies both well-typing and
contextual causality. *)

Lemma TiTyV_type ts t v : TiTyV ts t v -> map type ts |-X v ∶ type t.
Proof.
  intro T. induction T;simpl in *; try rewrite H; auto.
Qed.

Lemma type_add_time d t :  type (add_time d t) = type t.
Proof.
  destruct t. reflexivity.
Qed.
Lemma type_sub_time d t :  type (sub_time d t) = type t.
Proof.
  destruct t. reflexivity.
Qed.

(* Timed typing on expressions implies well-typing. *)

Lemma TiTyE_type ts t e : TiTyE ts t e -> map type ts |-E e ∶ type t.
Proof.
  intros T. generalize dependent ts. generalize dependent t.
  induction e using Exp_ind';intros;inversion T;simpl in T; subst.
  - unfold TiTyOp in *. destruct H4. econstructor;eauto. clear H1. clear T.
    generalize dependent t.
    induction H5;intros; simpl in *; constructor;inversion H;inversion H1;subst; auto.
    eapply IHall2;eauto.
  - auto.
  - constructor. apply TiTyV_type. assumption.
  - constructor.
    + apply IHe1 in H5. simpl in *. assumption.
    + apply IHe2 in H3. rewrite map_map in *. rewrite type_add_time in *.
      erewrite map_ext. eassumption. intros. simpl. rewrite type_add_time. reflexivity.
Qed.

Hint Resolve TiTyE_type.

(* Timed typing implies well-typing. *)

Theorem TiTyC_type ts t e : TiTyC ts t e -> map type ts |-C e.
Proof.
  intros T. induction T; econstructor;simpl in *;eauto.
  - rewrite map_map in IHT. erewrite map_ext. eassumption. intro. simpl.
    rewrite type_sub_time. reflexivity.
  - apply TiTyE_type in H0. simpl in H0. apply H0.
  - apply TiTyE_type in H. simpl in H. apply H.
  - rewrite map_map in IHT2. erewrite map_ext. eassumption. intro. simpl.
    rewrite type_sub_time. reflexivity.
Qed.

Lemma TiTyV_time ts t v : TiTyV ts t v -> CausalV (map time ts) (time t) v.
Proof.
  intro T. induction T;simpl in *; try rewrite H; auto.
Qed.

Lemma time_add_time d t :  time (add_time d t) = tadd' d (time t).
Proof.
  destruct t. reflexivity.
Qed.
Lemma time_sub_time d t :  time (sub_time d t) = tsub' d (time t).
Proof.
  destruct t. reflexivity.
Qed.

(* Timed typing on expressions implies contextual causality. *)

Lemma TiTyE_time ts t e : TiTyE ts t e -> CausalE (map time ts) (time t) e.
Proof.
  intros T. generalize dependent ts. generalize dependent t.
  induction e using Exp_ind';intros;inversion T;simpl in T; subst.
  - unfold TiTyOp in *. destruct H4. econstructor;eauto. clear H1. clear T.
    generalize dependent t.
    induction H5;intros; simpl in *; constructor;inversion H;inversion H1;subst; auto.
    rewrite <- H9. auto.
  - auto.
  - constructor. apply TiTyV_time. assumption.
  - econstructor.
    + apply IHe2 in H3. rewrite map_map in *. rewrite time_add_time in *.
      erewrite map_ext. eassumption. intros. simpl. rewrite time_add_time. reflexivity.
    + apply IHe1 in H5. simpl in *. eassumption.
Qed.

Hint Resolve TiTyE_type.

(* Timed typing implies contextual causality. *)

Theorem TiTyC_time ts t c : TiTyC ts t c -> CausalC (map time ts) t c.
Proof.
  intros T. induction T; econstructor;simpl in *;eauto.
  - rewrite map_map in *. erewrite map_ext. eassumption. intro. simpl.
    rewrite time_sub_time. reflexivity.
  - apply TiTyE_time in H. simpl in H. apply H.
  - apply TiTyE_time in H0. simpl in H0. apply H0.
  - apply TiTyE_time in H. simpl in H. apply H.
  - rewrite map_map in *. erewrite map_ext. eassumption. intro. simpl.
    rewrite time_sub_time. reflexivity.
Qed.

Corollary TiTyC_causal t c : TiTyC [] t c -> causal c.
Proof.
  intros T. apply TiTyC_time in T. simpl in *. eauto using CausalC_sound.
Qed.

(* Below we show that the conjunction of well typing and contextual
causality implies timed typing. *)

Infix "@@" := (zipWith TimedType) (at level 1).

Fixpoint repeat {A} (n : nat) (x : A) : list A :=
  match n with
    | O => nil
    | S m => x :: repeat m x
  end.

Lemma map_type tys tis : length tys = length tis -> map type tys @@ tis = tys.
Proof.
  generalize dependent tis. induction tys;intros. reflexivity.
  destruct tis;tryfalse. simpl. f_equal. auto.
Qed.

Lemma map_time tys tis : length tys = length tis -> map time tys @@ tis = tis.
Proof.
  generalize dependent tys. induction tis;intros. destruct tys; reflexivity.
  destruct tys;tryfalse. simpl. f_equal. auto.
Qed.

Lemma map_type_time ts : (map type ts) @@ (map time ts) = ts.
Proof.
  induction ts;simpl;f_equal;try destruct a;eauto.
Qed.

Lemma map_type_repeat tys t : map type tys @@ (repeat (length tys) t) = tys.
Proof.
  induction tys. reflexivity. simpl. f_equal. auto.
Qed.

Lemma map_add_time n tys tis : map (add_time n) tys @@ tis = tys @@ (map (tadd' n) tis).
Proof.
  generalize dependent tis. induction tys;intros. reflexivity.
  destruct tis. reflexivity.
  simpl. rewrite IHtys. reflexivity.
Qed.

Lemma map_sub_time n tys tis : map (sub_time n) tys @@ tis = tys @@ (map (tsub' n) tis).
Proof.
  generalize dependent tis. induction tys;intros. reflexivity.
  destruct tis. reflexivity.
  simpl. rewrite IHtys. reflexivity.
Qed.

Lemma type_TiTyE tis tys ti ty e : tys |-E e ∶ ty -> CausalE tis ti e -> TiTyE tys@@tis (ty@ti) e.
Proof.
  intros Ty Ti. generalize dependent tis. generalize dependent ti.
  induction Ty using TypeExp_ind';intros;inversion Ti;subst;clear Ti.
  - apply causal_op with (ts' := ts @@ (repeat (length ts) ti)). unfold TiTyOp. split.
    clear H. clear H0. clear H1. induction ts;simpl; constructor. reflexivity. apply IHts.
    rewrite map_type_repeat. simpl. assumption.
    clear H. induction H0;simpl;constructor;inversion H1;inversion H5;subst;auto.
  - eauto.
  - econstructor. generalize dependent tis. generalize dependent ti.
    induction H;intros;inversion H3; clear H3;subst;simpl; econstructor; eauto.
  - apply causal_acc. simpl. rewrite map_add_time. eauto.
    specialize (IHTy1 ti (TimeBot :: tis)). eauto.
Qed.

Theorem type_TiTyC tis tys ti  c : tys |-C c -> CausalC tis ti c -> TiTyC tys@@tis ti c.
Proof.
  intros Ty Ti. generalize dependent tis. generalize dependent ti.
  induction Ty;intros;inversion Ti;subst;clear Ti;eauto using type_TiTyE.
  - specialize (IHTy ti (t' :: tis)).  eauto using type_TiTyE.
  - econstructor. rewrite map_sub_time. eauto.
  - econstructor; eauto using type_TiTyE. rewrite map_sub_time. eauto.
Qed.

Theorem TiTyE_decompose ts t e : TiTyE ts t e <-> map type ts |-E e ∶ type t /\ CausalE (map time ts) (time t) e.
Proof.
  split; intros. split; eauto using TiTyE_type, TiTyE_time. destruct H.
  eapply type_TiTyE in H;eauto. rewrite map_type_time in H. destruct t;simpl in H. assumption.
Qed.

Theorem TiTyC_decompose ts ti c : TiTyC ts ti c <-> map type ts |-C c /\ CausalC (map time ts) ti c.
Proof.
  split; intros. split; eauto using TiTyC_type, TiTyC_time. destruct H.
  eapply type_TiTyC in H;eauto. rewrite map_type_time in H. assumption.
Qed.

Theorem TiTyC_decompose' tis tys ti c : length tys = length tis ->
                                       (TiTyC tys@@tis ti c <-> tys |-C c /\ CausalC tis ti c).
Proof.
  intro L. split; intros. split. apply TiTyC_type in H. rewrite map_type in H;auto.
  apply TiTyC_time in H. rewrite map_time in H; auto. destruct H. apply type_TiTyC;auto.
Qed.

Definition subtype (t1 t2 : TiTy) := type t1 = type t2 /\ time t1 <= time t2.

Infix "<|" := subtype (at level 1).

Hint Unfold subtype.

Lemma subtype_type t1 t2 : t1 <| t2 -> type t1 = type t2.
Proof.
  intros. unfold subtype in *. tauto.
Qed.
Lemma subtype_time t1 t2 : t1 <| t2 -> time t1 <= time t2.
Proof.
  intros. unfold subtype in *. tauto.
Qed.

Hint Resolve subtype_time subtype_type.

Lemma all_subtype_type ts1 ts2 : all2 subtype ts1 ts2 -> map type ts1 = map type ts2.
Proof.
  intro H. induction H; simpl; f_equal; eauto.
Qed.

Lemma all_subtype_time ts1 ts2 : all2 subtype ts1 ts2 -> all2 tle (map time ts1) (map time ts2).
Proof.
  intro H. induction H; simpl; f_equal; eauto.
Qed.

Hint Resolve all_subtype_time all_subtype_type.

Lemma TiTyE_open t t' ts ts' (e : Exp) : all2 subtype ts' ts -> t <| t' -> TiTyE ts t e -> TiTyE ts' t' e.
Proof.
  intros Ss S T. rewrite TiTyE_decompose in *. destruct T. destruct S as [S1 S2].
  split. rewrite <- S1. erewrite all_subtype_type by eassumption. assumption.
  eapply CausalE_open;eauto.
Qed.

Lemma TiTyC_open t t' ts ts' c : all2 subtype ts' ts -> t' <= t -> TiTyC ts t c -> TiTyC ts' t' c.
Proof.
  intros Ss S T. rewrite TiTyC_decompose in *. destruct T.
  split. erewrite all_subtype_type by eassumption. assumption.
  eapply CausalC_open;eauto.
Qed.

Lemma subtype_refl t : t <| t.
Proof. destruct t. auto. Qed.

Hint Immediate subtype_refl.

Lemma all_subtype_refl ts :  all2 subtype ts ts.
Proof.
  induction ts; eauto.
Qed.

(* Special case of [TiTyE_open] where the type environment stays the same. *)
Corollary TiTyE_open' t t' ts (e : Exp) : t <| t' -> TiTyE ts t e -> TiTyE ts t' e.
Proof. eauto using TiTyE_open, all_subtype_refl. Qed.

Lemma TiTyC_open' t t' ts c : t' <= t -> TiTyC ts t c -> TiTyC ts t' c.
Proof. eauto using TiTyC_open, all_subtype_refl. Qed.

Definition inferObs (l : ObsLabel) : Ty :=
  match l with
    | LabR _ => REAL
    | LabB _ => BOOL
  end.

Lemma inferObs_sound l : |-O l ∶ inferObs l.
Proof.
  destruct l; auto.
Qed.

Definition tyeqb (t1 t2 : Ty) : bool :=
  match t1, t2 with
    | REAL, REAL => true
    | BOOL, BOOL => true
    | _,_ => false
  end.

Lemma tyeqb_iff t1 t2 : tyeqb t1 t2 = true <-> t1 = t2.
Proof.
  destruct t1;destruct t2; split;intro;simpl in *; congruence.
Qed.

Definition inferOp (op : Op) (args : list Ty) : option Ty :=
  match op with
    | Add => match args with [REAL;REAL] => Some REAL | _ => None end
    | Sub => match args with [REAL;REAL] => Some REAL | _ => None end
    | Mult => match args with [REAL;REAL] => Some REAL | _ => None end
    | Div => match args with [REAL;REAL] => Some REAL | _ => None end
    | And => match args with [BOOL;BOOL] => Some BOOL | _ => None end
    | Or => match args with [BOOL;BOOL] => Some BOOL | _ => None end
    | Less => match args with [REAL;REAL] => Some BOOL | _ => None end
    | Leq => match args with [REAL;REAL] => Some BOOL | _ => None end
    | Equal => match args with [REAL;REAL] => Some BOOL | _ => None end
    | Not => match args with [BOOL] => Some BOOL | _ => None end
    | Neg => match args with [REAL] => Some REAL | _ => None end
    | BLit _ => match args with [] => Some BOOL | _ => None end
    | RLit _ => match args with [] => Some REAL | _ => None end
    | Cond => match args with [BOOL;t1;t2] => if tyeqb t1 t2 then Some t1 else None | _ => None end
  end.

Lemma inferOp_TypeOp op args ty : inferOp op args = Some ty <-> |-Op op ∶ args => ty.
Proof.
  destruct op; split; intro H; repeat (destruct args;try destruct t; simpl in *; try solve [inversion H;eauto]).
Qed.

Definition tmax (t1 t2 : TimeB) : TimeB :=
  match t1,t2 with
    | TimeBot, _ => t2
    | _, TimeBot => t1
    | Time t1', Time t2' => Time (Z.max t1' t2')
  end.

Lemma tmax_tle_iff t t1 t2 : t <= tmax t1 t2 <-> t <= t1 \/ t <= t2.
Proof.
  destruct t;split;firstorder; destruct t1, t2; inversion H; try rewrite -> Z.max_le_iff in H2; firstorder;
  constructor; rewrite -> Z.max_le_iff; tauto.
Qed.

Lemma tmax_lub_iff  t t1 t2 : tmax t1 t2 <= t <-> t1 <= t /\ t2 <= t.
Proof.
    destruct t;split;firstorder destruct t1, t2; simpl in H; inversion_clear H;
    try constructor; try rewrite -> Z.max_lub_iff in H0; firstorder.
    rewrite -> Z.max_lub_iff. inversion H0. tauto. inversion H0. tauto.
Qed.

(* Define as left fold instead (and then prove that it is equal to the right fold). *)
Definition tmaxs (ts : list TimeB) : TimeB :=fold_right tmax TimeBot ts.

Lemma tmaxs_cons x xs : tmaxs (x :: xs) = tmax x (tmaxs xs).
Proof.
  unfold tmaxs. fold ([x] ++ xs). rewrite fold_right_app. reflexivity.
Qed.

Fixpoint inferE (env : TiTyEnv) (e:Exp) : option TiTy :=
  match e with
    | OpE op args => sequence (map (inferE env) args) >>=
                              (fun args' => liftM (fun ty => ty @ tmaxs (map time args'))
                                                  (inferOp op (map type args')))
    | VarE v => lookupEnv v env
    | Obs l i => Some (inferObs l @ Time i)
    | Acc f d z => inferE (map (add_time d) env) z >>=
                  (fun t => inferE (type t @ TimeBot :: env) f >>=
                  (fun t' => if tyeqb (type t) (type t')
                             then Some (type t @ tmax (tsub' d (time t)) (time t'))
                             else None))
  end.

(* Time intervals *)
Open Scope Z.

Definition ole (lo hi : option Z) := forall l h, lo = Some l -> hi = Some h -> l <= h.

Hint Unfold ole.

(* Time intervals are always non-empty. *)
Inductive TimeI := Time' (t : TimeB) | TimeTop.

Definition iadd d t := match t with
                         | TimeTop => TimeTop
                         | Time' t' => Time' (tadd' d t')
                       end.

Definition tileb l t := match t with
                           | TimeTop => true
                           | Time' t' => tleb l t'
                       end.

Definition ileb t1 t2 := match t1,t2 with
                         | _,TimeTop => true
                         | Time' s1, Time' s2 => tleb s1 s2
                         | _, _ => false
                       end.

Definition imin t1 t2 := if ileb t1 t2 then t1 else t2.

Open Scope time.

Fixpoint inferC (env : TiTyEnv) (c:Contr) : option TimeI :=
  match c with
    | Zero => Some TimeTop
    | Transfer p1 p2 a => Some (Time' (Time 0))
    | Translate d c' => liftM (iadd d) (inferC (map (sub_time d) env) c')
    | Scale e c' => inferE env e >>= fun ty =>
                   inferC env c' >>= fun t => if tyeqb (type ty) REAL && tileb (time ty) t
                                              then Some t
                                              else None
    | Both c1 c2 => liftM2 imin (inferC env c1) (inferC env c2)
    | Let e c' => inferE env e >>= fun t => inferC (t :: env) c'
    | If e d c1 c2 => inferE env e >>= fun t =>
                      if tyeqb (type t) BOOL && tleb (time t) (Time 0)
                      then liftM2 imin (inferC env c1) (liftM (iadd d) (inferC (map (sub_time d) env) c2))
                      else None
  end.

Lemma all_type_tle args ts env m :
  all2 (TiTyE env) ts args
  -> tmaxs (map time ts) <= m
  -> all2 (TiTyE env) (map (fun t => type t @ m) ts) args.
Proof.
  intros T M. rewrite <- map_id. apply all2_map'. generalize dependent m. induction T;intros m M;constructor.
  - simpl. eapply TiTyE_open' with (t:=x);auto. constructor. reflexivity.
    simpl in *. rewrite tmax_lub_iff in M. tauto.
  - apply IHT. simpl in M. rewrite tmax_lub_iff in M. tauto.
Qed.

Corollary all_type_max args ts env :
  all2 (TiTyE env) ts args
  -> all2 (TiTyE env) (map (fun t => type t @ tmaxs (map time ts)) ts) args.
Proof.
  intros. apply all_type_tle;auto.
Qed.

Theorem inferE_sound env e t :
   inferE env e = Some t -> TiTyE env t e.
Proof.
  intros I. generalize dependent env. generalize dependent t.
  induction e using Exp_ind'; intros; simpl in *;option_inv_auto.
  - assert (all2 (TiTyE env) x args) as T
    by (clear H3; generalize dependent x; induction H; simpl in *;
        intros; option_inv_auto; eauto using TiTyE_open').
    apply all_type_max in T. remember (map (fun t => type t @ tmaxs (map time x)) x) as x'.
    rewrite inferOp_TypeOp in *. apply causal_op with (ts':= x').
    constructor. simpl. subst. apply all_map_forall. auto. simpl.
    assert (map type x = map type x') as Tx.
    subst. induction x;simpl;f_equal. rewrite map_map. simpl. reflexivity.
    rewrite <- Tx. assumption. assumption.
  - destruct l;eauto.
  - generalize dependent t. generalize dependent env.
    induction v;constructor; destruct env; simpl in I; inversion I; auto.
    apply IHv in I. inversion I. auto.
  - destruct x; destruct x0; simpl in H3. cases (tyeqb ty ty0) as E;tryfalse. apply tyeqb_iff in E.
    inversion_clear H3. subst. eapply IHe1 in H2. eapply IHe2 in H0.
    econstructor;simpl in *;
    [eapply TiTyE_open' with (t:=ty0 @ ti)|eapply TiTyE_open' with (t:=ty0 @ ti0)]; try assumption;
    constructor; try reflexivity; simpl; destruct ti,ti0;auto;
    simpl; autounfold;constructor; try omega.
    + rewrite <- Z.add_max_distr_r. rewrite Z.max_le_iff. left. omega.
    + rewrite Z.max_le_iff. right. omega.
Qed.

Lemma inferObs_complete l t : |-O l ∶ t -> inferObs l = t.
Proof.
  intros T. destruct T; reflexivity.
Qed.

Open Scope time.
Lemma tadd_tsub_tle d x y : x <= tadd d y ->  tsub d x <= y.
Proof.
  intros T.
  destruct x, y; simpl in *;eauto;inversion T; constructor. omega.
Qed.

Lemma tyeqb_refl x : tyeqb x x = true.
Proof. rewrite tyeqb_iff. reflexivity. Qed.

Lemma all_tmaxs ts' s :
  all (fun t' : TiTy => time t' = time s) ts' -> tmaxs (map time ts') <= time s.
Proof.
  intros A. induction A. constructor. simpl.
  rewrite tmax_lub_iff. rewrite H. auto using tle_refl.
Qed.

Theorem inferE_complete env e s :
   TiTyE env s e -> exists t, inferE env e = Some t /\ t <| s.
Proof.
  intros T. generalize dependent env. generalize dependent s.
  induction e using Exp_ind'; intros; inversion T;clear T;subst;simpl in *;option_inv_auto.
  - assert (exists ts,sequence (map (inferE env) args) = Some ts /\ map type ts = map type ts'
           /\ tmaxs (map time ts) <= tmaxs (map time ts')) as Q.
    clear H4. induction H5;simpl. eauto. inversion H. subst. eapply IHall2 in H4.
    decompose [ex and] H4. apply H3 in H0. decompose [ex and] H0. eexists. split.
    repeat rewr_assumption. simpl. autounfold. reflexivity. simpl. split.
    apply subtype_type in H9. repeat rewr_assumption. reflexivity.
    inversion H9. rewrite tmax_lub_iff. split.
    rewrite tmax_tle_iff. auto. rewrite tmax_tle_iff. auto.

    decompose [ex and] Q. inversion H4. rewrite <- inferOp_TypeOp in *.
    repeat (rewr_assumption; simpl). autounfold. eexists. split.
    reflexivity. split. reflexivity. simpl.
    assert (tmaxs (map time ts') <= time s). apply all_tmaxs. eauto.
    eauto using tle_trans.

  - eexists. split. erewrite inferObs_complete by eassumption. reflexivity. eauto.
  - induction H2;try decompose [ex and] IHTiTyV;eexists;split; simpl;eauto.
  - apply IHe1 in H5. apply IHe2 in H3. decompose [ex and] H5. decompose [ex and] H3.
    eexists. split.
    assert (type x0 = type s) as E by (inversion H4; rewrite type_add_time in *; assumption).
    repeat (rewr_assumption;simpl).
    assert (type x = type s) as E2 by auto using subtype_type.
    rewr_assumption. rewrite tyeqb_refl. reflexivity.
    constructor. reflexivity. simpl. inversion H4. inversion H1.
    destruct s, x, x0. simpl in *. rewrite tmax_lub_iff.
    unfold tadd', tsub'. split; auto using tadd_tsub_tle.
Qed.

Open Scope Z.

Inductive tile : TimeB -> TimeI -> Prop :=
| tile_top t : tile t TimeTop
| tile_time s t : tle s t -> tile s (Time' t).

Hint Constructors tile.

Lemma tileb_tile s t : tileb s t = true <-> tile s t.
Proof.
  split;intros A.
  - destruct t;auto. simpl in *. rewrite tleb_tle in A. auto.
  - destruct t; simpl;auto. inversion A. subst.
    rewrite <- tleb_tle in *. auto.
Qed.

Lemma tile_tsub_iadd t n x :  tile t (iadd n x) -> tile (tsub' n t) x.
Proof.
  intro L. destruct x. inversion L. subst. unfold tsub', tadd' in *.
  constructor. auto using tadd_tsub_tle. constructor.
Qed.

Lemma tile_imin_l t x y : tile t (imin x y) -> tile t x.
Proof.
  intro T. unfold imin in *.
  cases (ileb x y) as L. assumption. destruct x, y;simpl in *;eauto.
  rewrite tleb_tgt in L. inversion T. subst. constructor. eauto using tle_trans, tle_tlt.
  inversion L.
Qed.

Lemma tile_imin_r t x y : tile t (imin x y) -> tile t y.
Proof.
  intro T. unfold imin in *.
  cases (ileb x y) as L; try assumption. destruct x, y;simpl in *;eauto.
  rewrite tleb_tle in L. inversion T. subst. constructor. eauto using tle_trans.
  inversion L.
Qed.

Lemma tile_imin_iadd s t x n : tile t (imin x (iadd n s)) -> tile (tsub' n t) s.
Proof.
  intros T. eauto using tile_imin_r, tile_tsub_iadd.
Qed.

Theorem inferC_sound env c i : inferC env c = Some i -> forall t, tile t i -> TiTyC env t c.
Proof.
  generalize dependent env. generalize dependent i.
  induction c; intros i env I t E;simpl in *; option_inv_auto;
  try solve [eauto using inferE_sound |inversion E;auto].
  - cases (tyeqb (type x) REAL && tileb (time x) x0) as TE;tryfalse.
    rewrite Bool.andb_true_iff in TE.
    destruct TE as [TE1 TE2]. rewrite tyeqb_iff in TE1.
    rewrite tileb_tile in TE2.
    destruct x. simpl in *. subst. inversion H3. subst.
    apply inferE_sound in H0.
    cases (tleb t ti) as TL. rewrite tleb_tle in TL.
    eapply IHc in H2;try eassumption.
    econstructor;eauto.
    rewrite tleb_tgt in TL.
    eapply IHc in H2; try apply E.
    eapply causal_scale in H2. eassumption.
    apply tle_refl. apply TiTyE_open' with (t:=REAL@ti);eauto.
    constructor. reflexivity. simpl. auto using tle_tlt.
  - eapply IHc in H0;eauto using tile_tsub_iadd.
  - constructor; eauto using tile_imin_l, tile_imin_r.
  - cases (tyeqb (type x) BOOL && tleb (time x) (Time 0)) as B;tryfalse.
    rewrite Bool.andb_true_iff in B. destruct B as [B1 B2].
    rewrite tleb_tle, tyeqb_iff in *.
    option_inv_auto.
    constructor. eapply TiTyE_open' with (t:=x);eauto using inferE_sound.
    eapply IHc1; eauto using tile_imin_l.
    eapply IHc2; eauto using tile_imin_iadd.
Qed.

Lemma tile_iadd_tsub t n x :  tile (tsub' n t) x  -> tile t (iadd n x).
Proof.
  intro L. destruct x. inversion L. subst. unfold tsub', tadd' in *.
  constructor. unfold tadd'. auto using tsub_tadd_tle. constructor.
Qed.

Lemma tile_imin t x y : tile t x -> tile t y -> tile t (imin x y).
Proof.
  intros X Y. unfold imin. cases (ileb x y) as L;assumption.
Qed.

Lemma imin_top_l t : imin TimeTop t = t.
Proof. unfold imin. destruct t;reflexivity. Qed.

Lemma imin_top_r t : imin t TimeTop = t.
Proof. unfold imin. destruct t;reflexivity. Qed.

Theorem inferC_complete env c t : TiTyC env t c -> exists i, inferC env c = Some i /\ tile t i.
Proof.
  generalize dependent env. generalize dependent t.
  induction c; intros t env T;simpl in *; option_inv_auto;inversion T;subst;eauto.
  - apply inferE_complete in H3. decompose [ex and] H3. subst.
    eapply TiTyC_open in H4.
    apply IHc in H4. decompose [ex and] H4.
    eexists. split.
    repeat (rewr_assumption;simpl). reflexivity. eassumption.
    eauto using all_subtype_refl. apply tle_refl.
  - apply IHc in H5. decompose [ex and] H5.
    apply inferE_complete in H4. decompose [ex and] H4.
    repeat (rewr_assumption;simpl). inversion H6. simpl in *.
    rewrite H. rewrite tyeqb_refl.
    assert (tile (time x0) x) as E by (inversion H2;eauto).
    subst. rewrite <- tileb_tile in E. rewrite E.
    simpl. eexists. split. reflexivity.
    inversion H2;eauto.
  - apply IHc in H2. decompose [ex and] H2. rewr_assumption. simpl. autounfold.
    eexists. split. reflexivity. auto using tile_iadd_tsub.
  - apply IHc1 in H3. decompose [ex and] H3. apply IHc2 in H4. decompose [ex and] H4.
    repeat rewr_assumption. simpl. autounfold.
    eexists. split. reflexivity. auto using tile_imin.
  - apply IHc1 in H6. decompose [ex and] H6. apply IHc2 in H7. decompose [ex and] H7.
    apply inferE_complete in H4. decompose [ex and] H4.
    repeat rewr_assumption. simpl. autounfold.
    eexists. split. inversion H8. rewrite <- tleb_tle in H9. simpl in *.
    repeat rewr_assumption. rewrite tyeqb_refl. simpl. reflexivity.
    inversion H1; subst. rewrite imin_top_l. auto using tile_iadd_tsub.
    inversion H3; subst. simpl. rewrite imin_top_r. assumption.
    simpl. unfold imin. cases (ileb (Time' t0) (Time' (tadd' n t1))).
    assumption. simpl. constructor. unfold tadd', tsub' in *.
    auto using tsub_tadd_tle.
Qed.

Definition has_type (c : Contr) : bool :=
  match inferC nil c with
    | Some _ => true
    | None => false
  end.

Definition select_time t := match t with
                              | TimeTop => Time 0
                              | Time' t => t
                            end.

Lemma select_time_tile t : tile (select_time t) t.
Proof.
  destruct t; simpl; constructor. apply tle_refl.
Qed.

Corollary has_type_causal c : has_type c = true -> causal c.
Proof.
  unfold has_type. intros. cases (inferC [] c) as T;tryfalse.
  eauto using inferC_sound,select_time_tile, TiTyC_causal.
Qed.