Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition doppler1_bmap_list := [Build_varinfo Tdouble 1%positive (-100) (100);Build_varinfo Tdouble 2%positive (20) (2e4);Build_varinfo Tdouble 3%positive (-30) (50)].

Definition doppler1_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list doppler1_bmap_list) in exact z).

Definition doppler1 (u : ftype Tdouble) (v : ftype Tdouble) (t : ftype Tdouble) :=
  let t1 := ((3314e-1)%F64 + ((6e-1)%F64 * t)%F64)%F64 in
  (((-t1) * v)%F64 / ((t1 + u)%F64 * (t1 + u)%F64)%F64)%F64.

Definition doppler1_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) doppler1 in exact e').

Derive doppler1_b
SuchThat (forall vmap, prove_roundoff_bound doppler1_bmap vmap doppler1_expr doppler1_b)
As doppler1_bound.
Proof.
idtac "Starting doppler1".
time "doppler1" (
(subst doppler1_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try (prove_roundoff_bound2; error_rewrites;
((prune_terms (cutoff 30);
try match goal with |- (Rabs ?e <= ?a - 0)%R =>
  rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*)
end;
try match goal with |- (Rabs ?e <= ?a - ?b)%R =>
                      let G := fresh "G" in
                      interval_intro (Rabs e) as G ;
                      eapply Rle_trans;
                      [apply G | apply Rminus_plus_le_minus; apply Rle_refl] end)));
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (i_bisect v,
 i_depth 17) as H'; apply H'; apply Rle_refl
end;
try match goal with |- Rabs ?a <= _ =>
interval_intro (Rabs a) with (i_bisect vxH,
i_bisect v0, i_depth 17) as H'; apply H'; apply Rle_refl
end).
Qed.

Lemma check_doppler1_bound: ltac:(CheckBound doppler1_b 4.5e-13%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Require Import Coq.Classes.EquivDec.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Utils.
Require Import Coq.Logic.Classical.
Require Import List.
Require Import Nat.
Require Import Bool.Bool.
Require Import Coq.Logic.Eqdep_dec.

Require Export Tagged LastCommon.

Section eval.

  Context `{C : redCFG}.

  Notation "p --> q" := (edge p q = true) (at level 55,right associativity).

  Parameter Var : Type.
  Parameter Var_dec : EqDec Var eq.
  Parameter is_def : Var -> Lab -> Lab -> bool.

  Parameter def_edge :
    forall p q x, is_def x p q = true -> p --> q.

  Definition is_def_lab x p := exists q, is_def x q p = true.

(*  Lemma Lab_var_dec :
    forall (x y : (Lab * Var)), { x = y } + { x <> y }.
  Proof.
    intros.
    destruct x as [xa xb], y as [ya yb].

    decide ((xa, xb) = (ya, yb)); firstorder.
  Qed.
  Program Instance lab_var_eq_eqdec : EqDec (Lab * Var) eq := Lab_var_dec.*)

  Parameter Val : Type.

  Definition State := Var -> Val.

  Parameter Val_dec : EqDec Val eq.
  Parameter Tag_dec : EqDec Tag eq.
  Parameter State_dec : EqDec State eq.

  Global Existing Instance Val_dec.
  Global Existing Instance Tag_dec.
  Global Existing Instance State_dec.

  Parameter S : list State.

  Definition Conf := ((@Coord Lab)* State)%type.

  Hint Unfold Conf Coord : core.

  Definition lab_of (k : Conf) :=
    match k with
      ((p, i), s) => p
    end.

  (** * Effect function **)

  Parameter eff' : Lab * State -> option (Lab * State).

  Definition eff (k : Conf) : option Conf
    := match k with
       | (p, i, s) => match eff' (p,s) with
                     | None => None
                     | Some (q, r) => match eff_tag p q i with
                                     | Some j => Some (q, j, r)
                                     | None => None
                                     end
                     end
       end.

  Ltac eff_unf :=
    lazymatch goal with
    | H : context [eff (?q,?j,?r)] |- _
      => unfold eff, eff_tag in H;
        destruct (eff' (q,r));
        [match type of H with
         | context[let (_,_) := ?x in _ ]
           => let x1 := fresh "x" in
             let x2 := fresh "x" in
             destruct x as [x1 x2];
             decide (edge__P q x1);[|try congruence; try contradiction]
         end
        |try congruence; try contradiction]
    | H : context [eff ?x] |- _
      => destruct x as [[? ?] ?]; eff_unf
    end.

  Ltac some_match_subst :=
    lazymatch goal with
    | H: match _ with
         | Some _ => Some (?x, _, _)
         | None => _
         end = Some (?y, _, _) |- _
      => let Q := fresh "Q" in
        assert (x = y) as Q;[
          destruct (match edge_Edge _ with
                    | Enormal _ => _
                    | Eback _ => _
                    | Eentry _ => _
                    | Eexit _ => _
                    end);[
            inversion H;subst;eauto
           |congruence]
         |subst]
    end.

  Program Instance conf_eq_eqdec : EqDec Conf eq.
  Next Obligation.
    intros.
    destruct x as [[p i] s], y as [[q j] r].

    destruct ((p, i, s) == (q, j, r)); firstorder.
  Qed.
  Definition Conf_dec := conf_eq_eqdec.

  Definition is_effect_on (p q : Lab) :=
    exists i i' s s', eff ((p, i), s) = Some ((q, i'), s').
  Parameter zero : State.

  Parameter edge_spec :
    forall p q, is_effect_on p q -> p --> q.

  Lemma step_conf_implies_edge :
    forall p q i j s r, eff (p, i, s) = Some (q, j, r) -> (p --> q).
  Proof.
    intros.
    eapply edge_spec.
    unfold is_effect_on. eauto.
  Qed.

  Lemma eff_eff_tag q j r p i s :
    eff (q,j,r) = Some (p,i,s)
    -> eff_tag q p j = Some i.
  Proof.
    intros Heff.
    eff_unf. some_match_subst. unfold eff_tag.
    decide (edge__P q p);[|contradiction].
    unfold eff_tag.
    rewrite Edge_eq with (Q:=e).
    destruct (edge_Edge e);inversion Heff;subst;eauto.
    1,2: destruct j;inversion Heff;subst;eauto.
  Qed.

  (** * Edge on the Trace-Graph **)

  Definition eval_edge := (fun k k' : Conf
                           => match eff k with
                             | Some k => k = k'
                             | None => False
                             end).

  Parameter def_spec :
    forall p q x, (exists i j s r, eff (p, i, s) = Some (q, j, r) /\ r x <> s x) ->
             is_def x p q = true.

  Definition option_chain (A B : Type) (f : A -> option B) (a : option A) : option B
    := match a with
       | Some a' => f a'
       | _ => None
       end.

  Definition sem_step l k := option_chain eff (hd_error l) = Some k.

  (** * Traces **)

  Inductive Tr : list Conf -> Prop :=
  | Init : forall s, s ∈ S -> Tr [(root, start_tag, s)]
  | Step : forall l (k : Conf), Tr l -> sem_step l k -> Tr (k :: l).

  Definition EPath := Path eval_edge.

  Hint Unfold Conf Coord : core.

  (** ** Lemmas **)

  Lemma EPath_Tr s0 p i s π :
    s0 ∈ S -> EPath (root,start_tag,s0) (p,i,s) π -> Tr π.
  Proof.
    intros Hel H. remember (root, start_tag, s0) as start_c.
    remember (p,i,s) as pis_c. revert p i s Heqpis_c.
    induction H; intros p i s Heqpis_c; [rewrite Heqstart_c|];econstructor.
    2,3: destruct b as [[b1 b2] b3].
    - eauto.
    - eapply IHPath; eauto.
    - subst c. destruct π;[inversion H|].
      unfold sem_step;cbn.
      path_simpl' H.
      unfold eval_edge in H0. clear - H0.
      unfold Coord in *.
      destruct (eff (b1,b2,b3)).
      + subst. reflexivity.
      + contradiction.
  Qed.

  Lemma Tr_EPath p i s π :
    Tr π ->  hd_error π = Some (p,i,s) -> exists s0, EPath (root,start_tag,s0) (p,i,s) π.
  Proof.
    intros HTr Hfront.
    revert p i s Hfront. dependent induction HTr; cbn; intros p i s' Hfront.
    - inversion Hfront. subst p i s'. eexists;econstructor.
    - inversion Hfront. subst k.
      remember (hd_error l) as c.
      destruct c.
      + destruct c as [[q j] r].
        specialize (IHHTr q j r). exploit IHHTr.
        destructH. eexists;econstructor;eauto.
        unfold eval_edge.
        unfold sem_step in H.
        destruct l;cbn in H;[congruence|]. unfold EPath in IHHTr. path_simpl' IHHTr.
        destruct (eff (q,j,r)).
        * inversion H;eauto.
        * congruence.
      + unfold sem_step in H. destruct l;cbn in *;congruence.
  Qed.

  Lemma eval_edge_tcfg_edge p q i j s r
        (Heval : eval_edge (q,j,r) (p,i,s))
    : tcfg_edge (q,j) (p,i).
  Proof.
    unfold eval_edge in Heval.
    split.
    - destruct (eff (q,j,r)) eqn:E;[|contradiction].
      eapply step_conf_implies_edge. subst c;eauto.
    - destruct (eff (q,j,r)) eqn:E;[subst c|contradiction].
      eff_unf. unfold eff_tag. some_match_subst. decide (edge__P q p);[|contradiction].
      rewrite (Edge_eq) with (Q:=e).
      destruct (edge_Edge e).
      all: inversion E;eauto.
      1,2: destruct j;[congruence|]; inversion E;eauto.
  Qed.

  Lemma EPath_TPath k k' π :
    EPath k k' π -> TPath (fst k) (fst k') (map fst π).
  Proof.
    intros H. dependent induction H; [|destruct c]; econstructor.
    - apply IHPath.
    - cbn. destruct b. cbn. destruct c0, c. eapply eval_edge_tcfg_edge;eauto.
  Qed.

  Lemma Tr_tag_depth p i s t
        (Htr : Tr ((p,i,s) :: t))
    : |i| = depth p.
  Proof.
    eapply Tr_EPath in Htr;cbn;eauto. destructH.
    eapply EPath_TPath in Htr.
    cbn in Htr.
    eapply tag_depth';eauto.
  Qed.

  Definition proj_Tr_TPath (π : list Conf)
    := map fst π.

  Definition proj_Tr_TPath_list (T : list (list Conf))
    := map (map fst) T.

  Lemma EPath_TPath' k k' c c' π ϕ :
    EPath k k' π -> c = fst k -> c' = fst k' -> ϕ = map fst π -> TPath c c' ϕ.
  Proof.
    intros. eapply EPath_TPath in H;subst; eauto.
  Qed.

  Ltac inv_dep H Dec := inversion H; subst;
                        repeat match goal with
                               | [ H0: @existT _ _ _ _ = @existT _ _ _ _  |- _ ]
                                 => apply inj_pair2_eq_dec in H0; try (apply Dec); subst
                               end.

  Ltac inv_tr H := inversion H; subst;
                   repeat match goal with
                          | [ H0: @existT Conf _ _ _ = @existT _ _ _ _  |- _ ]
                            => apply inj_pair2_eq_dec in H0; try (apply Conf_dec); subst
                          end.

  Definition trace := {l : list Conf | Tr l}.

  Open Scope prg.

  Definition Traces := trace -> Prop.
  Definition Hyper := Traces -> Prop.

  (** * Concrete transformer **)

  (** ** Concrete transformer for sets of traces *)
  Definition sem_trace (ts : Traces) : Traces :=
    fun tr' => exists tr k', ts tr /\ `tr' = (k' :: `tr).

  (** ** Hypertrace transformer **)
  (* Essentially, it lifts the trace set transformers to set of trace sets *)
  Definition sem_hyper (T : Hyper) : Hyper :=
    fun ts' => exists ts, T ts /\ ts' = sem_trace ts.

  (** ** Lemmas **)

  Lemma Tr_eff_Some c k t
        (Htr : Tr (c :: k :: t))
    : eff k = Some c.
  Proof.
    inversion Htr.
    unfold sem_step in H2. cbn in H2. eauto.
  Qed.

  Lemma in_pred_exists p i s k t :
    (p,i,s) ∈ (k :: t) ->
    p <> root ->
    Tr (k :: t) ->
    exists q j r, (q, j, r) ∈ t /\ eff (q, j, r) = Some (p, i, s).
  Proof.
    revert k.
    dependent induction t; intros k Hin Hneq Htr; inversion Htr.
    - exfalso.
      destruct Hin;[|contradiction].
      subst k. inversion H. eapply Hneq. rewrite H2. reflexivity.
    - inversion H1.
    - subst.
      destruct Hin.
      + subst k.
        destruct a as [[q j] r].
        exists q, j, r. split;[left;auto|].
        eapply Tr_eff_Some;eauto.
      + specialize (IHt a).
        exploit IHt.
        destructH. do 3 eexists;eauto.
  Qed.

  Lemma ivec_fresh : forall p i s (t : trace),
      sem_step (`t) (p, i, s) -> forall j r, In (p, j, r) (`t) -> j <> i.
  Proof.
    intros.
    destruct t; cbn in *.
    remember (hd_error x) as c. destruct c.
    - destruct c,c. eapply eff_tag_fresh;cycle 2.
      + eapply in_map with (f:=fst) in H0. eauto.
      + eapply Tr_EPath in t;eauto. destruct t as [s1 t].
        eapply EPath_TPath in t; eauto.
      + destruct x;cbn in Heqc;[congruence|].
        inversion Heqc. subst c.
        unfold sem_step in H.
        unfold hd_error in H. unfold option_chain in H.
        split.
        { eapply step_conf_implies_edge;eauto. }
        cbn in H.
        destruct (eff' (e,s0)).
        * destruct p0. unfold eff_tag in *.
          decide (edge__P e e0). 2:congruence.
          some_match_subst.
          decide (edge__P e p);[|congruence].
          rewrite (Edge_eq _ e1).
          destruct (edge_Edge e1);inversion H;eauto.
          1,2: destruct t0; inversion H;eauto.
        * congruence.
    - destruct x.
      + inversion t.
      + cbn in Heqc. congruence.
  Qed.

  Lemma ivec_det : forall q j r r' p i i' s s',
      eff (q, j, r) = Some (p, i, s) ->
      eff (q, j, r') = Some (p, i', s') ->
      i = i'.
  Proof.
    intros. eff_unf. eff_unf. some_match_subst. some_match_subst. auto.
    assert (x1 = p).
    { clear H0. some_match_subst. auto. }
    subst x1.
    rewrite (Edge_eq _ e0) in H0.
    destruct (edge_Edge e0);try congruence.
    1,2: destruct j;congruence.
  Qed.

  Definition Precedes' (l : list Conf) (k k' : Conf) : Prop :=
    exists l', Prefix (k' :: l') l /\ Precedes lab_of (k' :: l') k.

  (*
  Lemma start_no_tgt :
    forall i' s' k, eff k = Some (root, i', s') -> False.
  Proof.
    intros.
    destruct k as [[p i] s].
    unfold start_coord in H.
    cut (is_effect_on p root); intros.
    apply edge_spec in H0.
    eapply root_no_pred. eassumption.
    unfold is_effect_on.
    exists i, i', s, s'.
    assumption.
  Qed.
   *)

  Lemma precedes_cons (k k' : Conf) l : Precedes' l k' k' -> Precedes' (k :: l) k' k'.
  Proof.
    intro H. destruct H as [l' [H1 H2]].
    unfold Precedes'.
    exists l'. split; econstructor. eauto.
  Qed.

  Lemma precedes_self c t :
    In c t -> Precedes' t c c.
  Proof.
    intros H.
    destruct c as [[p i] s].
    induction t.
    + inv_tr H.
    + destruct a as [[q j] r].
      inv_tr H; eauto using Precedes.
      * rewrite H0. exists t. split; econstructor.
      * eapply precedes_cons; eauto.
  Qed.

  Lemma precedes_step_inv :
    forall k t p s, Precedes' (k :: t) p s ->
               Tr (k :: t) ->
               lab_of p <> lab_of s ->
               In p t.
  Proof.
    intros.
    destruct H as [l [Hpre Hprec]].
    inv_tr Hprec.
    - firstorder.
    - eapply precedes_in in H5.
      eapply prefix_cons_cons in Hpre.
      eapply in_prefix_in; eauto.
  Qed.

  Lemma in_exists_pred p i s k (t : trace) :
    In (p, i, s) (k :: `t) ->
    sem_step (`t) k ->
    p <> root ->
    exists q j r, In (q, j, r) (`t) /\ eff (q, j, r) = Some (p, i, s).
  Proof.
    intros H Heff Hneq.
    destruct t as [l tr]; cbn in H, Heff. unfold "`".
    destruct H; [subst k| revert dependent k];
      dependent induction l; inversion tr; subst; intros.
    - exists root, start_tag, s0. split; [ constructor | eauto ]; eauto.
    - cbn in Heff, H2. destruct a as [[q j] r]. exists q,j,r. firstorder.
    - exfalso. inversion H; inversion H0. subst p; contradiction.
    - destruct H.
      + subst a. remember (hd_error l) as qjr. destruct qjr as [qjr|].
        2: destruct l; unfold sem_step in H3;cbn in *;congruence.
        destruct qjr as [[q j] r].
        exists q,j,r. split; [econstructor 2 | eauto].
        * destruct l;[inversion H2|]. cbn in Heqqjr. inversion Heqqjr.
          setoid_rewrite H0. left. auto.
        * unfold sem_step in H3.
          destruct l;[inversion H2|].
          cbn in H3. cbn in Heqqjr. inversion Heqqjr. subst c. eauto.
      + eapply IHl in H2; eauto. destruct H2 as [q [j [r [Hin Hstep]]]].
        exists q, j, r. split; eauto.
  Qed.

  Lemma root_prefix (t : trace) : exists s, Prefix ((root, start_tag, s) :: nil) (`t).
  Proof.
    destruct t as [l tr].
    induction l; inversion tr; subst; cbn in *.
    - exists s. econstructor.
    - destruct IHl as [s IHl']; eauto. exists s. econstructor; eauto.
  Qed.

  Lemma root_start_tag s i (t : trace) : In (root, i, s) (`t) -> i = start_tag.
  Proof.
    intros Hin.
    revert dependent i.
    destruct t as [l tr]. induction l; inversion tr; subst; cbn in *; intros i Hin.
    - destruct Hin as [Hin|Hin]; [inversion Hin; eauto|contradiction].
    - destruct Hin.
      + exfalso. destruct l;[inversion H1|]. destruct c as [[q j] r].
        eapply root_no_pred. subst a.
        apply edge_spec. unfold is_effect_on. exists j,i,r,s.
        eapply Tr_eff_Some;eauto.
      + eapply IHl; eauto.
  Qed.

  Lemma trace_destr_in_in k k' (t : trace) :
    In k (`t) -> In k' (`t)
    -> exists (t': trace), hd_error (`t') = Some k' /\ In k (`t') \/ hd_error (`t') = Some k /\ In k' (`t').
  Proof.
    intros Hin Hin'.
    destruct t as [t tr]. cbn in *.
    induction t; inversion tr; cbn in *.
    - subst t. destruct Hin; [|contradiction]; destruct Hin'; [|contradiction].
      subst a k.
      exists (exist _ [k'] tr). cbn. tauto.
    - destruct Hin, Hin'; [| | |eapply IHt; eauto]; subst.
      + exists (exist _ (k' :: t) tr ). cbn. tauto.
      + exists (exist _ (k :: t) tr). cbn. tauto.
      + exists (exist _ (k' :: t) tr). cbn. tauto.
  Qed.

  Ltac trace_proj t :=
    lazymatch goal with
    | [ H : Tr t |- _ ] =>
      replace t with ( ` (exist Tr t H)) in * by (cbn; reflexivity)
    end.

  Lemma tag_inj p i s r (t : trace) : In (p,i,s) (`t) -> In (p,i,r) (`t) -> s = r.
  Proof.
    intros His Hir. eapply trace_destr_in_in in His; eauto.
    destruct His as [[t' tr'] [[Hf Hin]|[Hf Hin]]]; cbn in *.
    - induction t'; inversion tr'.
      + cbn in Hin,Hf. subst t'. destruct Hin; [|contradiction]. subst a. inversion Hf. reflexivity.
      + subst. cbn in *. destruct a as [[q j] r']. inversion Hf. subst.
        destruct Hin;  [inversion H; reflexivity|].
        trace_proj t'.
        eapply ivec_fresh in H2; eauto. contradiction.
    - induction t'; inversion tr'.
      + cbn in Hin,Hf. subst t'. destruct Hin; [|contradiction]. subst a. inversion Hf. reflexivity.
      + cbn in *. subst. destruct a as [[q j] r']. inversion Hf. subst.
        destruct Hin; [inversion H; reflexivity|].
        trace_proj t'. eapply ivec_fresh in H2; eauto. contradiction.
  Qed.

  Lemma prefix_trace (l l' : list Conf) c :
    Prefix (c :: l) l' -> Tr l' -> Tr (c :: l).
  Proof.
    intros Hpr Htr. induction Htr;cbn in *.
    - inversion Hpr;[econstructor|]. 1:eauto. inversion H2.
    - inversion Hpr.
      + subst. econstructor;eauto.
      + eapply IHHtr;eauto.
  Qed.

  Lemma eval_det c0 c c' : eval_edge c0 c -> eval_edge c0 c' -> c = c'.
  Proof.
    intros Hcc Hcc'. unfold eval_edge in *. destruct (eff c0); subst;auto. contradiction.
  Qed.

(*  Lemma tr_succ_eq (l : list Conf) (k k' : Conf) :
    ne_back (k :: l) = ne_back (k' :: l) -> Tr (k :: l) -> Tr (k' :: l) -> k = k'.
  Proof.
    intros Hback Htr Htr'.
    inversion Htr; inversion Htr'; subst.
    1,2: destruct l;cbn in H0,H1;[|congruence].
    3: destruct l;cbn in H3;[|congruence].
    all: cbn in Hback;eauto.
    eapply necons_nlcons_inv in H2 as [H21 H22];eapply necons_nlcons_inv in H as [H01 H02].
    subst k0 k1. destruct l;[exfalso;eapply ne_to_list_not_nil;eauto|].
    rewrite nlcons_to_list in H22. rewrite nlcons_to_list in H02.
    apply ne_to_list_inj in H22. apply ne_to_list_inj in H02. rewrite H22 in H4. rewrite H02 in H1.
    simpl_nl' H1. simpl_nl' H4.
    eapply eval_det; unfold eval_edge; [rewrite H1|rewrite H4]; conv_bool; reflexivity.
  Qed.*)

  Lemma prefix_eff_cons_cons k k' l l' :
    (*    eff (ne_front l) = Some k
    -> l' = ne_to_list l''
    -> Tr (k' :<: l'')
    -> Prefix l l'
    -> Prefix (k :: l) (k' :: l').
     *)
    l <> nil
    -> Tr (k :: l)
    -> Tr (k' :: l')
    -> Prefix l l'
    -> Prefix (k :: l) (k' :: l').
  Proof.
    intros Hemp Htr Htr' Hpre.
    revert dependent k'.
    induction Hpre; intros k' Htr'.
    - enough (k = k').
      + subst k'. econstructor.
      + destruct k as [[q j] r]. destruct k' as [[q' j'] r'].
        eapply Tr_EPath in Htr. 2: cbn;reflexivity.
        eapply Tr_EPath in Htr'. 2: cbn;reflexivity.
        do 2 destructH.
        inversion Htr. 1: symmetry in H4;contradiction.
        inversion Htr'. 1: symmetry in H9;contradiction.
        subst. destruct l. 1: inversion H0.
        path_simpl' H0. path_simpl' H5.
        eapply eval_det;eauto.
    - econstructor. eapply IHHpre; eauto. inversion Htr'; eauto.
  Qed.

  Lemma precedes_succ (t : trace) q j r q' j' r' p i s k' :
    Precedes' (`t) (q', j', r') (q, j, r) ->
    eff (q, j, r) = Some (p, i, s) ->
    p <> q' ->
    Tr (k' :: (`t)) ->
    Precedes' (k' :: (`t)) (q', j', r') (p, i, s).
  Proof.
    intros Hprec Heff Hneq Htr.
    destruct Hprec as [t' [Hpre Hprec]].
    exists ((q,j,r) :: t').
    split.
    - clear Hprec Hneq.
      unfold Conf in Hpre. unfold Coord in Hpre.
      set (t2 := (q,j,r) :: t') in *.
      destruct t as [t tr]. unfold "`" in *. cbn. subst t2.
      eapply prefix_eff_cons_cons; eauto;[congruence| eauto].
      cbn. econstructor.
      + eapply prefix_trace.
        * eauto.
        * inversion Htr; eauto. subst t. inversion Hpre.
      + eauto.
    - econstructor; cbn; eauto.
  Qed.

  (* possibly unused
  Lemma precedes_step l q j r p i s :
    forall k, (q, j, r) ∈ l ->
         p <> q ->
         eff (q, j, r) = Some (p, i, s) ->
         Tr (k :: l) ->
         Precedes' (k :: l) (q, j, r) (p, i, s).
  Proof.
    intros k Hin Hneq Heff Htr.
    assert ((p,i,s) ∈ (k :: l)) as Hin'.
    {
      revert dependent k.
      induction l; intros k Htr; cbn in Htr; inversion Htr; inversion Hin; cbn; subst.
      - left. rewrite H2 in Heff. inversion Heff. reflexivity.
      - right. cbn in IHl. eauto.
    }
    exists (prefix_nincl (p,i,s) (k :: l)). split.
    - eapply prefix_nincl_prefix; eauto.
    - revert dependent k. induction l; intros k Htr Hin'; inversion Hin; inversion Hin'; subst.
      + cbn. destruct ((p,i,s) == (p,i,s)); [destruct e|exfalso; eapply c; reflexivity].
        econstructor; [cbn; eauto|]. destruct l; cbn; econstructor.
      + exfalso.
        inversion Htr; subst.
        assert (k = (p,i,s)) as Hk.
        { eapply Tr_eff_Some in Htr. rewrite Htr in Heff. inversion Heff. auto. }
        subst k.
        eapply ivec_fresh.
        * instantiate (4:=exist _ _ H2). unfold "`". eapply H3.
        * cbn. eauto.
        * reflexivity.
      + exfalso.
        inversion Htr; subst.
        destruct a as [[q' j'] r'].
        eapply ivec_fresh.
        * instantiate (4:=exist _ _ H2). unfold "`". eauto.
        * cbn. give_up.
        * reflexivity.
      + cbn. destruct ((p,i,s) == k).
        * destruct e. exfalso.
          inversion Htr; subst.
          eapply ivec_fresh.
          -- instantiate (4:=exist _ _ Htr). unfold "`". eauto. give_up.
          -- cbn. eauto.
          -- reflexivity.
        * eapply IHl; eauto. cbn in Htr. inversion Htr; subst; eauto.
  Qed.
  *)

  Lemma no_def_untouched :
    forall p q x, is_def x q p = false -> forall i j s r, eff (q, j, r) = Some (p, i, s) -> r x = s x.
  Proof.
    intros.
    specialize (@def_spec q p x).
    cut (forall (a b : Prop), (a -> b) -> (~ b -> ~ a)); intros Hrev; [| eauto].
    assert (Hds := def_spec).
    eapply Hrev in Hds.
    - cut (forall x y : Val, ~ (x <> y) -> x = y).
      * intros.
        apply H1; clear H1.
        intro. apply Hds.
        exists j; exists i; exists r; exists s; eauto.
      * intros y z. destruct (equiv_dec y z); intros; auto.
        exfalso. apply H1. auto.
    - intro.
      rewrite H in H1.
      inversion H1.
  Qed.

  Definition lift (tr : Traces) : Hyper :=
    fun ts => ts = tr.

  Definition red_prod (h h' : Hyper) : Hyper :=
    fun ts => h ts /\ h' ts.

  (* not used:
  Lemma postfix_rcons_trace_eff l k k' l' :
    Tr l'
    -> Postfix ((l :r: k) :r: k') l'
    -> eff k' = Some k.
   *)

  Lemma Tr_CPath l :
    Tr l -> CPath root (fst (fst (hd (root,start_tag,zero) l))) (map fst (map fst l)).
  Proof.
    intro H. destruct l;[inversion H|].
    eapply Tr_EPath in H;[| repeat rewrite <-surjective_pairing; reflexivity].
    destruct H as [s0 H]. cbn.
    eapply EPath_TPath in H. cbn in H. eapply TPath_CPath in H. eauto.
  Qed.

  Definition Tr' (l : list Conf) :=
    exists l', Tr l' /\ Postfix l l'.

  Lemma tr_lc_lt p i s1 s2 l1 l2 q1 q2 j1 j2 r1 r2
        (Htr1 : Tr ((p, i, s1) :: (q1,j1,r1) :: l1))
        (Htr2 : Tr ((p, i, s2) :: (q2,j2,r2) :: l2))
    : exists brk,
      last_common ((q1,j1) :: map fst l1) ((q2,j2) :: map fst l2) (brk).
  Proof.
    inversion Htr1. subst k l.
    inversion Htr2. subst k l.
    eapply Tr_EPath in H1. 2:cbn;eauto.
    eapply Tr_EPath in H3. 2:cbn;eauto.
    do 2 destructH.
    setoid_rewrite cons_rcons' in H1.
    setoid_rewrite cons_rcons' in H3.
    pose (l1' := (rev (tl (rev ((q1, j1, r1) :: l1))))).
    pose (l2' := (rev (tl (rev ((q2, j2, r2) :: l2))))).
    eapply path_back in H1 as Hback1. rewrite <-Hback1 in *.
    eapply path_back in H3 as Hback2. rewrite <-Hback2 in *.
    specialize (ne_last_common (map fst l1') (map fst l2') (root,start_tag)) as Hlc.
    destructH.
    exists s.
    enough ((q2,j2) :: map fst l2 = map fst l2' :r: (root,start_tag)).
    enough ((q1,j1) :: map fst l1 = map fst l1' :r: (root,start_tag)).
    * rewrite H. rewrite H0. eauto.
    * clear - Hback1. subst l1'.
      fold (fst (root,start_tag,s3)).
      rewrite <-map_rcons.
      rewrite Hback1.
      rewrite <-cons_rcons'. cbn. eauto.
    * clear - Hback2. subst l2'.
      fold (fst (root,start_tag,s0)).
      rewrite <-map_rcons.
      rewrite Hback2.
      rewrite <-cons_rcons'. cbn. eauto.
  Qed.

  Lemma tr_tpath_cons2 p i s q j r l
        (Htr : Tr ((p,i,s) :: (q,j,r) :: l))
    : TPath (root,start_tag) (p,i) ((p, i) :: (q, j) :: map fst l).
  Proof.
    eapply Tr_EPath in Htr as Htr; cbn;eauto. destruct Htr as [s01 Htr].
    eapply EPath_TPath in Htr.
    cbn in *. auto.
  Qed.

  Lemma Tr_NoDup l
        (Htr : Tr l)
    : NoDup (map fst l).
  Proof.
    destruct l;[inversion Htr|].
    destruct c as [[q j] r]. cbn.
    eapply Tr_EPath in Htr;[|cbn;reflexivity].
    destructH.
    eapply EPath_TPath in Htr. cbn in Htr.
    eapply tpath_NoDup;eauto.
  Qed.

  Lemma tr_lift_succ l q q' j j'
        (Hpath : Tr l)
        (Hsucc : (q',j') ≻ (q,j) | map fst l)
    : exists r r', (q',j',r') ≻ (q,j,r) | l.
  Proof.
    unfold succ_in in Hsucc. destructH.
    revert dependent l1. revert dependent l.
    induction l2;intros;cbn in Hsucc.
    - revert dependent l1. revert q q' j j'. induction l;intros.
      + cbn in *. congruence.
      + cbn in *. inversion Hpath;subst.
        1:cbn in Hsucc; congruence.
        exploit' IHl. destruct l1.
        * destruct a. inversion H1;subst;cbn in Hsucc; inversion Hsucc;[subst q j|].
          -- cbn in *.
             exists s0, s, nil, nil. cbn. reflexivity.
          -- exfalso. destruct l0; cbn in H6;[inversion H|congruence].
        * destruct a. cbn in *. destruct c.
          specialize (IHl e q t j l1). inversion Hsucc;subst. exploit IHl. destructH.
          exists r', s, ((e,t,r) :: (tl (tl l))), nil. cbn.
          unfold succ_in in IHl. destructH.
          destruct l2;cycle 1.
          {
            exfalso.
            eapply Tr_NoDup in H1.
            enough (fst c = (q,j)).
            - rewrite IHl in H1. cbn in H1. rewrite H in H1.
              rewrite map_app in H1. clear - H1.
              inversion H1. eapply H2.
              eapply in_or_app. right. auto.
            - clear - IHl Hsucc.
              inversion Hsucc. rewrite IHl in H0. cbn in H0.
              inversion H0. reflexivity.
          }
          assert (l1 = map fst l0).
          {
            cbn in IHl. clear - IHl H3.
            rewrite IHl in H3. cbn in H3. inversion H3. reflexivity.
          }
          rewrite H in H3. cbn in IHl.
          f_equal.
          inversion H1.
          -- exfalso. cbn in *. congruence.
          -- cbn in Hsucc,H2,H3. destruct k. cbn in Hsucc,H3.
             rewrite <-H5 in IHl.
             inversion H0.
             ++ cbn. destruct c. inversion IHl. subst. congruence.
             ++ cbn. destruct c. inversion IHl. subst. f_equal. f_equal. inversion H13. auto.
    - destruct l; cbn.
      + exfalso. destruct l2;cbn in Hsucc; inversion Hsucc.
      + cbn in Hsucc. inversion Hsucc.
        destruct l. 1: cbn in H1;congruence'.
        inversion Hpath;subst.
        eapply IHl2 in H1;eauto.
        destructH. do 2 eexists. eapply succ_cons. eauto.
  Qed.

  Lemma tr_succ_eff' p q q' br i j k s r r' r0 l
        (Htr : Tr ((p, i, s) :: l))
        (Hsucc : (q, j, r) ≻ (br, k, r0) | (p, i, s) :: l)
        (Heff : eff' (br,r0) = Some (q',r'))
    : q = q'.
  Proof.
    unfold succ_in in Hsucc. destructH.
    revert dependent l1. revert dependent l. revert p i s.
    induction l2;intros.
    - cbn in Hsucc.
      destruct l. 1: cbn in *; congruence.
      inversion Hsucc. subst.
      eapply Tr_eff_Some in Htr.
      eff_unf. some_match_subst. destruct (edge_Edge e); congruence.
    - cbn in Hsucc.
      destruct l. 1: cbn in *; destruct l2; cbn in Hsucc;congruence.
      destruct p0. destruct p0.
      eapply IHl2.
      + cbn in Htr. inversion Htr. eapply H1.
      + cbn in Hsucc. inversion Hsucc;subst. eauto.
  Qed.

  Lemma succ_in_rcons2 {A : Type} (a b : A) l
    : a ≻ b | l :r: a :r: b.
  Proof.
    exists nil, l. rewrite <-app_assoc. rewrite <-app_comm_cons. cbn. reflexivity.
  Qed.

  Lemma succ_in_cons_eq (A : Type) (a b c : A) l
        (Hsucc : a ≻ b | a :: c :: l)
        (Hnd : NoDup (a :: c :: l))
    : b = c.
  Proof.
    inversion Hnd. subst.
(*    destruct (b == c);[auto|].*)
    unfold succ_in in Hsucc. destructH.
    destruct l2.
    - cbn in *. inversion Hsucc. auto.
    - exfalso.
      eapply H1. cbn in Hsucc. inversion Hsucc;subst.
      clear - H3. destruct l2;intros;inversion H3;subst;cbn in *;eauto.
  Qed.

  Lemma succ_in_cons_neq (A : Type) (a b c d : A) l
        (Hsucc : a ≻ b | d :: c :: l)
        (Hnd : NoDup (c :: l))
        (Hneq : a <> d)
    : a ≻ b | c :: l.
  Proof.
    unfold succ_in in Hsucc. destructH.
    destruct l2.
    - cbn in Hsucc. inversion Hsucc. subst. contradiction.
    - cbn in Hsucc. inversion Hsucc. subst. eexists;eexists. eauto.
  Qed.

  Lemma eff_tcfg p q i j s r
        (Heff : eff (p,i,s) = Some (q,j,r))
    : tcfg_edge (p,i) (q,j).
  Proof.
    eapply eff_eff_tag in Heff as Heff'. unfold tcfg_edge.
    eapply step_conf_implies_edge in Heff. conv_bool; firstorder.
  Qed.

  (* possibly unused
  Lemma tr_tpath_cons1 (l : list Conf) c
        (Htr : Tr (c :: l))
    : TPath (root,start_tag) (fst c) ((fst c) :: map fst l).
  Proof.
    revert dependent c.
    induction l; intros c Htr; inversion Htr; cbn; [econstructor|]. unfold TPath'. cbn.
    econstructor. eapply IHl;eauto.

    simpl_nl' H2. destruct a as [[p i] s]. destruct c as [[q j] r]. cbn. simpl_nl.
    eapply eff_tcfg;eauto.
  Qed.
   *)

  Lemma prec_lab_prec_fst p i s l
        (Hprec : Precedes lab_of l (p,i,s))
    : Precedes fst (map fst l) (p,i).
  Proof.
    induction l; inversion Hprec;subst;cbn in *.
    - econstructor.
    - econstructor;eauto.
      destruct a as [[a1 a2] a]; cbn in *;eauto.
  Qed.

End eval.

(** * spot_path tactic **)

Ltac spot_path_e :=
  let H := fresh "H" in
  let Q := fresh "Q" in
  let p := fresh "p" in
  let i := fresh "i" in
  let s := fresh "s" in
  lazymatch goal with
  | [ H : Tr ((?p,?i,?s) :: ?t) |- _ ] => eapply Tr_EPath in H;[|cbn;reflexivity]; destructH' H; cbn in H
  | [ H : Tr ?t |- _ ] => destruct (hd_error t) as [[[p i] s]|N] eqn:Q;
                        [eapply Tr_EPath in H;[clear Q|apply Q]; destructH' H; cbn in H
                        |inversion H]
  end.

Ltac spot_path_t :=
  try spot_path_e;
  lazymatch goal with
  | [ H : EPath _ _ _ |- _ ] => eapply EPath_TPath in H; cbn in H
  end.

Ltac spot_path_c :=
  try spot_path_t;
  lazymatch goal with
    [ H : TPath _ _ _ |- _ ] => eapply TPath_CPath in H; cbn in H
  end.

Ltac spot_path :=
  lazymatch goal with
  | [ |- CPath _ _ _ ] => repeat (spot_path_c;eauto)
  | [ |- TPath _ _ _ ] => repeat (spot_path_t;eauto)
  | [ |- EPath _ _ _ ] => repeat (spot_path_e;eauto)
  end.


Require Import list_examples.

Definition inf_code :=
  Push 1::While (Dup 0::nil)
    (Plus1)
    ::Ret::nil.

Definition inf_cfg stk rstk heap funs mark n :=
  {|
    code := While (Dup 0 :: nil) Plus1 :: Ret :: nil;
    stack := n :: stk;
    rstack := rstk;
    heap := heap;
    functions := funs;
    alloc_next := mark
  |}.

Inductive inf_spec : Spec cfg :=
  inf_claim : forall H l, fun_claim inf_spec
  "inf" inf_code
    1 (fun p => asP H (rep_list l p))
    1 (fun n => constraint False)
  |inf_loop_claim : forall stk rstk heap funs mark n,
      n > 0 -> inf_spec (inf_cfg stk rstk heap funs mark n) (fun c => False).

Lemma inf_proof : sound stack_step inf_spec.
Proof. list_solver; contradiction. Qed.


(** Model construction (entailing consistency) for ECC based on
    ZF + infinitely many Grothendieck universes.
*)

Require Import List Bool Models TypModels.
Require Import ZF ZFsum ZFnats ZFrelations ZFord ZFfix ZFgrothendieck ZFcoc ZFecc.
Require Import ModelCC.

Import BuildModel.
Import T J R.

Lemma sub_typ_covariant e U1 U2 V1 V2 :
  U1 <> kind ->
  eq_typ e U1 U2 ->
  sub_typ (U1::e) V1 V2 ->
  sub_typ e (Prod U1 V1) (Prod U2 V2).
red; intros.
revert H3; apply cc_prod_covariant.
 do 2 red; intros.
 rewrite H4; reflexivity.

 apply H0; trivial.

 red; intros.
 revert H4; apply H1.
 apply vcons_add_var; trivial.
Qed.

(** Universes: version where type 0 is a universe of hereditarily
    finite sets (HF). Hence it does not contain nat. It is a model
    of ECC.
 *)

Module Type ECC := ECC_Rules BuildModel.

Module WithFinitistUniverse <: ECC.

Definition type (n:nat) := cst (ecc n).

Lemma typ_Prop : forall e, typ e prop (type 0).
red; intros; simpl.
apply (ecc_in1 0).
Qed.

Lemma typ_Type : forall e n, typ e (type n) (type (S n)).
red; intros; simpl.
apply (ecc_in2 n).
Qed.

Lemma cumul_Type : forall e n, sub_typ e (type n) (type (S n)).
red; simpl; intros.
red; intros.
apply ecc_incl; trivial.
Qed.

Lemma cumul_Prop : forall e, sub_typ e prop (type 0).
red; simpl; intros.
red; intros.
apply G_trans with props; trivial.
 apply (ecc_grot 0).

 apply (ecc_in1 0).
Qed.

Lemma typ_prod2 : forall e n T U,
  typ e T (type n) ->
  typ (T :: e) U (type n) ->
  typ e (Prod T U) (type n).
Proof.
unfold typ, Prod; simpl; red; intros e n T U ty_T ty_U i is_val.
apply G_cc_prod.
 apply ecc_grot.

 red; red; intros.
 rewrite H0; auto with *.

 apply ty_T; trivial.

 intros.
 apply ty_U.
 apply vcons_add_var; auto.
Qed.

Definition sub_typ_covariant := sub_typ_covariant.

End WithFinitistUniverse.

(** Universes: version where type 0 contains an infinite set,
    hence nat can be in type 0.
 *)

Module WithoutFinitistUniverse <: ECC.

Definition type (n:nat) := cst (ecc (S n)).

Lemma typ_Prop : forall e, typ e prop (type 0).
red; intros; simpl.
apply G_trans with (grot_succ (ZFcoc.props)); auto.
 apply (ecc_grot 1).

 apply (ecc_in1 0).

 apply (ecc_in2 0).
Qed.

Lemma typ_Type : forall e n, typ e (type n) (type (S n)).
red; intros; simpl.
apply (ecc_in2 (S n)).
Qed.

Lemma cumul_Type : forall e n, sub_typ e (type n) (type (S n)).
red; simpl; intros.
red; intros.
apply ecc_incl with (n:=S n); trivial.
Qed.

Lemma cumul_Prop : forall e, sub_typ e prop (type 0).
red; simpl; intros.
red; intros.
apply G_trans with ZFcoc.props; trivial.
 apply (ecc_grot 1).
apply G_trans with (grot_succ ZFcoc.props); trivial.
 apply (ecc_grot 1).

 apply (ecc_in1 0).

 apply (ecc_in2 0).
Qed.

Lemma typ_prod2 : forall e n T U,
  typ e T (type n) ->
  typ (T :: e) U (type n) ->
  typ e (Prod T U) (type n).
Proof.
red; intros e n T U ty_T ty_U i is_val.
apply G_cc_prod.
 apply ecc_grot.

 red; red; intros.
 rewrite H0; auto with *.

 apply ty_T; trivial.

 intros.
 red in ty_U.
 change (int (type n) i) with (int (type n) (V.cons x i)).
 apply in_int_not_kind.
 2:discriminate.
 apply ty_U.
 apply vcons_add_var; auto.
Qed.

Definition sub_typ_covariant := sub_typ_covariant.

End WithoutFinitistUniverse.

(** By default we take the second version (without universe of HF) *)
Export WithoutFinitistUniverse.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B X Y P Q R Pprime : Universe, ((wd_ A B /\ (wd_ X Y /\ (wd_ P Pprime /\ (wd_ P Q /\ (wd_ R Q /\ (wd_ Pprime Q /\ (wd_ B P /\ (wd_ A P /\ (wd_ P R /\ (col_ A B Pprime /\ (col_ A B Q /\ (col_ A B R /\ (col_ Pprime Q R /\ col_ P Q R))))))))))))) -> col_ A Q R)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj27synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus (mult lv0 (plus lv1 Zero)) (plus lv1 lv0))) (plus lv2 lv3)).
Admitted.
QuickChick conj27synthconj3.


Require Import Hask.Prelude.
Require Import Hask.Control.Monad.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(******************************************************************************
 * The State Monad
 *)

Definition State (s a : Type) := s -> (a * s).

Definition get  {s : Type}     : State s s := fun i => (i, i).
Definition gets {s a : Type} f : State s a := fun s => (f s, s).
Definition put  {s : Type} x   : State s unit := fun _ => (tt, x).

Definition modify {s : Type} (f : s -> s) : State s unit := fun i => (tt, f i).

#[export]
Program Instance State_Functor {s : Type} : Functor (State s) := {
  fmap := fun A B f (x : State s A) => fun st => match x st with
    | (a,st') => (f a, st')
    end
}.

#[export]
Program Instance State_Applicative {s : Type} : Applicative (State s) := {
  pure := fun _ x => fun st => (x, st);

  ap := fun _ _ f x => fun st => match f st with
    | (f', st') =>
        match x st' with
        | (x', st'') => (f' x', st'')
        end
    end
}.

#[export]
Program Instance State_Monad {s : Type} : Monad (State s) := {
  join := fun _ x => fun st => match x st with
    | (y, st') => match y st' with
      | (a, st'') => (a, st'')
      end
    end
}.

Require Import FunctionalExtensionality.

Module StateLaws.

Include MonadLaws.

#[export]
Program Instance State_FunctorLaws {s : Type} : FunctorLaws (State s).
Obligation 1.
  extensionality x.
  extensionality st.
  unfold id.
  destruct (x st); auto.
Qed.
Obligation 2.
  extensionality x.
  extensionality st.
  unfold comp.
  destruct (x st); auto.
Qed.

#[export]
Program Instance State_Applicative {s : Type} : ApplicativeLaws (State s).
Obligation 1.
  extensionality x.
  extensionality st.
  unfold id.
  destruct (x st); auto.
Qed.
Obligation 2.
  extensionality st.
  destruct (u st) as [f' st'].
  destruct (v st') as [f'' st''].
  destruct (w st''); auto.
Qed.

#[export]
Program Instance State_Monad {s : Type} : MonadLaws (State s).
Obligation 1.
  extensionality f.
  extensionality st.
  unfold comp; simpl.
  destruct (f st) as [f' st'].
  destruct (f' st') as [f'' st''].
  destruct (f'' st'') as [f''' st''']; auto.
Qed.
Obligation 2.
  extensionality f.
  extensionality st.
  unfold comp, id; simpl.
  destruct (f st) as [f' st']; auto.
Qed.
Obligation 3.
  extensionality f.
  extensionality st.
  unfold comp, id; simpl.
  destruct (f st) as [f' st']; auto.
Qed.
Obligation 4.
  extensionality x.
  extensionality st.
  unfold comp; simpl.
  destruct (x st) as [f' st'].
  destruct (f' st') as [f'' st'']; auto.
Qed.

End StateLaws.


Require Import Coq.Program.Basics.
Require Import Clight.pow2.
Require Import VST.floyd.proofauto.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Open Scope program_scope.

Definition pow2_spec : ident * funspec :=
  DECLARE _pow2
    WITH n : Z
    PRE [_n OF tuint]
      PROP(0 <= n <= Int.max_unsigned;
           0 <= two_p n <= Int.max_unsigned)
      LOCAL(temp _n ((Vint ∘ Int.repr) n))
      SEP()
    POST [tuint]
      PROP()
      LOCAL(temp ret_temp ((Vint ∘ Int.repr) (two_p n)))
      SEP().

Definition Gprog := ltac:(with_library prog [pow2_spec]).

Lemma body_max: semax_body Vprog Gprog f_pow2 pow2_spec.
Proof.
  start_function.
  unfold compose in *; simpl.
  forward.
  forward_while (
      EX i : Z,
        PROP(0 <= i; i <= n; 0 <= two_p n <= Int.max_unsigned)
        LOCAL(temp _n (Vint (Int.repr (n - i)));
              temp _res (Vint (Int.repr (two_p i))))
        SEP()).
  entailer!.
  Exists 0.
  entailer!.
  now (replace (n - 0) with n by Lia.lia).
  entailer!.
  forward.
  autorewrite with norm.
  forward.
  autorewrite with norm.
  entailer!.
  Exists (i + 1).
  entailer!.
  rewrite Z.sub_add_distr.
  replace (two_p (i + 1)) with ((two_p i) + (two_p i)).
  easy.
  rewrite two_p_is_exp.
  replace (two_p 1) with 2 by reflexivity.
  rewrite Z.mul_comm; rewrite <-Z.add_diag.
  reflexivity.
  assumption.
  Lia.lia.
  forward.
  entailer!.
  assert (n - i = 0).
  {
    replace (n - i) with (Int.unsigned (Int.repr (n - i))).
    replace (0) with (Int.unsigned Int.zero).
    f_equal.
    assumption.
    reflexivity.
    rewrite Int.unsigned_repr.
    reflexivity.
    Lia.lia.
  }
  apply Zminus_eq in H4.
  rewrite  H4.
  reflexivity.
Qed.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(* begin hide *)

Require Export CoRN.ftc.COrdLemmas.
Require Export CoRN.ftc.Partitions.
From Coq Require Import Lia.

Section Refining_Separated.

Variables a b : IR.
Hypothesis Hab : a[<=]b.
Let I := compact a b Hab.

Variable F : PartIR.
Hypothesis contF : Continuous_I Hab F.
Hypothesis incF : included (compact a b Hab) (Dom F).

Variables m n : nat.
Variable P : Partition Hab n.
Variable R : Partition Hab m.

Hypothesis HPR : Separated P R.

Lemma RSR_HP : _Separated P.
Proof.
 elim HPR; intros; assumption.
Qed.

Lemma RSR_HP' : a[=]b -> 0 = n.
Proof.
 intro.
 apply _Separated_imp_length_zero with (P := P).
  exact RSR_HP.
 assumption.
Qed.

Lemma RSR_HR : _Separated R.
Proof.
 elim HPR; intros.
 elim b0; intros; assumption.
Qed.

Lemma RSR_HR' : a[=]b -> 0 = m.
Proof.
 intro.
 apply _Separated_imp_length_zero with (P := R).
  exact RSR_HR.
 assumption.
Qed.

Lemma RSR_mn0 : 0 = m -> 0 = n.
Proof.
 intro; apply RSR_HP'; apply partition_length_zero with Hab.
 rewrite H; apply R.
Qed.

Lemma RSR_nm0 : 0 = n -> 0 = m.
Proof.
 intro; apply RSR_HR'; apply partition_length_zero with Hab.
 rewrite H; apply P.
Qed.

Lemma RSR_H' :
  forall i j : nat,
  0 < i ->
  0 < j ->
  i < n -> j < m -> forall (Hi : i <= n) (Hj : j <= m), P i Hi[#]R j Hj.
Proof.
 elim HPR; do 2 intro.
 elim b0; do 2 intro; assumption.
Qed.

Let f' (i : nat) (H : i < pred n) := P _ (lt_8 _ _ H).
Let g' (j : nat) (H : j < pred m) := R _ (lt_8 _ _ H).

Lemma RSR_f'_nlnf : nat_less_n_fun f'.
Proof.
 red in |- *; intros; unfold f' in |- *; apply prf1; auto.
Qed.

Lemma RSR_g'_nlnf : nat_less_n_fun g'.
Proof.
 red in |- *; intros; unfold g' in |- *; apply prf1; auto.
Qed.

Lemma RSR_f'_mon : forall (i i' : nat) Hi Hi', i < i' -> f' i Hi[<]f' i' Hi'.
Proof.
 intros.
 apply local_mon_imp_mon_lt with (n := pred n).
  intros; unfold f' in |- *; apply RSR_HP.
 assumption.
Qed.

Lemma RSR_g'_mon : forall (j j' : nat) Hj Hj', j < j' -> g' j Hj[<]g' j' Hj'.
Proof.
 intros.
 apply local_mon_imp_mon_lt with (n := pred m).
  intros; unfold g' in |- *; apply RSR_HR.
 assumption.
Qed.

Lemma RSR_f'_ap_g' : forall (i j : nat) Hi Hj, f' i Hi[#]g' j Hj.
Proof.
 intros.
 unfold f', g' in |- *; apply RSR_H'.
    apply lt_O_Sn.
   apply lt_O_Sn.
  apply pred_lt; assumption.
 apply pred_lt; assumption.
Qed.

Let h := om_fun _ _ _ _ _ RSR_f'_ap_g'.

Lemma RSR_h_nlnf : nat_less_n_fun h.
Proof.
 unfold h in |- *; apply om_fun_1.
  exact RSR_f'_nlnf.
 exact RSR_g'_nlnf.
Qed.

Lemma RSR_h_mon : forall (i i' : nat) Hi Hi', i < i' -> h i Hi[<]h i' Hi'.
Proof.
 unfold h in |- *; apply om_fun_2; auto.
    exact RSR_f'_nlnf.
   exact RSR_g'_nlnf.
  exact RSR_f'_mon.
 exact RSR_g'_mon.
Qed.

Lemma RSR_h_mon' : forall (i i' : nat) Hi Hi', i <= i' -> h i Hi[<=]h i' Hi'.
Proof.
 intros; apply mon_imp_mon'_lt with (n := pred m + pred n).
   apply RSR_h_nlnf.
  apply RSR_h_mon.
 assumption.
Qed.

Lemma RSR_h_f' : forall (i : nat) Hi, {j : nat | {Hj : _ < _ | f' i Hi[=]h j Hj}}.
Proof.
 unfold h in |- *; apply om_fun_3a; auto.
  exact RSR_f'_nlnf.
 exact RSR_g'_nlnf.
Qed.

Lemma RSR_h_g' : forall (j : nat) Hj, {i : nat | {Hi : _ < _ | g' j Hj[=]h i Hi}}.
Proof.
 unfold h in |- *; apply om_fun_3b; auto.
  exact RSR_f'_nlnf.
 exact RSR_g'_nlnf.
Qed.

Lemma RSR_h_PropAll :
  forall P : IR -> Prop,
  pred_wd' IR P ->
  (forall (i : nat) Hi, P (f' i Hi)) ->
  (forall (j : nat) Hj, P (g' j Hj)) -> forall (k : nat) Hk, P (h k Hk).
Proof.
 unfold h in |- *; apply om_fun_4b.
Qed.

Lemma RSR_h_PropEx :
  forall P : IR -> Prop,
  pred_wd' IR P ->
  {i : nat | {Hi : _ < _ | P (f' i Hi)}}
  or {j : nat | {Hj : _ < _ | P (g' j Hj)}} ->
  {k : nat | {Hk : _ < _ | P (h k Hk)}}.
Proof.
 unfold h in |- *; intros; apply om_fun_4d; auto.
  exact RSR_f'_nlnf.
 exact RSR_g'_nlnf.
Qed.

Definition Separated_Refinement_fun : forall i : nat, i <= pred (m + n) -> IR.
Proof.
 intros.
 elim (le_lt_eq_dec _ _ H); intro.
  elim (le_lt_dec i 0); intro.
   apply a.
  apply (h (pred i) (lt_10 _ _ _ b0 a0)).
 apply b.
Defined.

Lemma Separated_Refinement_lemma1 :
 forall i j : nat,
 i = j ->
 forall (Hi : i <= pred (m + n)) (Hj : j <= pred (m + n)),
 Separated_Refinement_fun i Hi[=]Separated_Refinement_fun j Hj.
Proof.
 do 3 intro.
 rewrite <- H; intros; unfold Separated_Refinement_fun in |- *; simpl in |- *.
 elim (le_lt_eq_dec _ _ Hi); elim (le_lt_eq_dec _ _ Hj); elim (le_lt_dec i 0); intros; simpl in |- *.
        algebra.
       apply RSR_h_nlnf; reflexivity.
      exfalso; rewrite <- b0 in a1; apply (lt_irrefl _ a1).
     exfalso; rewrite <- b1 in a0; apply (lt_irrefl _ a0).
    exfalso; rewrite <- b0 in a1; apply (lt_irrefl _ a1).
   exfalso; rewrite <- b1 in a0; apply (lt_irrefl _ a0).
  algebra.
 algebra.
Qed.

Lemma Separated_Refinement_lemma3 :
 forall H : 0 <= pred (m + n), Separated_Refinement_fun 0 H[=]a.
Proof.
 intros; unfold Separated_Refinement_fun in |- *; simpl in |- *.
 elim (le_lt_eq_dec _ _ H); elim (le_lt_dec 0 0); intros; simpl in |- *.
    algebra.
   exfalso; inversion b0.
  apply eq_symmetric_unfolded; apply partition_length_zero with Hab.
  cut (m + n <= 1); [ intro | lia ].
  elim (plus_eq_one_imp_eq_zero _ _ H0); intro.
   rewrite <- a1; apply R.
  rewrite <- b1; apply P.
 exfalso; inversion b0.
Qed.

Lemma Separated_Refinement_lemma4 :
 forall H : pred (m + n) <= pred (m + n),
 Separated_Refinement_fun (pred (m + n)) H[=]b.
Proof.
 intros; unfold Separated_Refinement_fun in |- *; simpl in |- *.
 elim (le_lt_eq_dec _ _ H); elim (le_lt_dec 0 0); intros; simpl in |- *.
    algebra.
    exfalso; apply (lt_irrefl _ a1).
   exfalso; apply (lt_irrefl _ a0).
  algebra.
 algebra.
Qed.

Lemma Separated_Refinement_lemma2 :
 forall (i : nat) (H : i <= pred (m + n)) (H' : S i <= pred (m + n)),
 Separated_Refinement_fun i H[<=]Separated_Refinement_fun (S i) H'.
Proof.
 intros; unfold Separated_Refinement_fun in |- *; simpl in |- *.
 elim (le_lt_eq_dec _ _ H); elim (le_lt_eq_dec _ _ H'); intros; simpl in |- *.
    elim (le_lt_dec i 0); elim (le_lt_dec (S i) 0); intros; simpl in |- *.
       exfalso; inversion a2.
      apply RSR_h_PropAll with (P := fun x : IR => a[<=]x).
        red in |- *; intros.
        apply leEq_wdr with x; assumption.
       intros; unfold f' in |- *.
       astepl (P 0 (le_O_n _)).
       apply Partition_mon; apply le_O_n.
      intros; unfold g' in |- *.
      astepl (R 0 (le_O_n _)).
      apply Partition_mon; apply le_O_n.
     exfalso; inversion a2.
    apply less_leEq; apply RSR_h_mon; auto with arith.
   elim (le_lt_dec i 0); elim (le_lt_dec (S i) 0); intros; simpl in |- *.
      exfalso; inversion a1.
     assumption.
    exfalso; inversion a1.
   apply RSR_h_PropAll with (P := fun x : IR => x[<=]b).
     red in |- *; intros.
     apply leEq_wdl with x; assumption.
    intros; unfold f' in |- *.
    apply leEq_wdr with (P _ (le_n _)).
     apply Partition_mon; apply le_trans with (pred n); auto with arith.
    apply finish.
   intros; unfold g' in |- *.
   apply leEq_wdr with (R _ (le_n _)).
    apply Partition_mon; apply le_trans with (pred m); auto with arith.
   apply finish.
  exfalso; rewrite <- b0 in H'; apply (le_Sn_n _ H').
 apply leEq_reflexive.
Qed.

Definition Separated_Refinement : Partition Hab (pred (m + n)).
Proof.
 apply Build_Partition with Separated_Refinement_fun.
    exact Separated_Refinement_lemma1.
   exact Separated_Refinement_lemma2.
  exact Separated_Refinement_lemma3.
 exact Separated_Refinement_lemma4.
Defined.

Definition RSR_auxP : nat -> nat.
Proof.
 intro i.
 elim (le_lt_dec i 0); intro.
  apply 0.
 elim (le_lt_dec n i); intro.
  apply (pred (m + n) + (i - n)).
 apply (S (ProjT1 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b1)))).
Defined.

Definition RSR_auxR : nat -> nat.
Proof.
 intro i.
 elim (le_lt_dec i 0); intro.
  apply 0.
 elim (le_lt_dec m i); intro.
  apply (pred (m + n) + (i - m)).
 apply (S (ProjT1 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b1)))).
Defined.

Lemma RSR_auxP_lemma0 : RSR_auxP 0 = 0.
Proof.
 unfold RSR_auxP in |- *.
 elim (le_lt_dec 0 0); intro; simpl in |- *.
  reflexivity.
 exfalso; inversion b0.
Qed.

Lemma RSR_h_inj : forall (i j : nat) Hi Hj, h i Hi[=]h j Hj -> i = j.
Proof.
 intros.
 eapply mon_imp_inj_lt with (f := h).
  exact RSR_h_mon.
 apply H.
Qed.

Lemma RSR_auxP_lemmai :
  forall (i : nat) (Hi : 0 < i) (Hi' : i < n),
  RSR_auxP i = S (ProjT1 (RSR_h_f' (pred i) (lt_pred' _ _ Hi Hi'))).
Proof.
 intros.
 unfold RSR_auxP in |- *.
 elim (le_lt_dec n i); intro; simpl in |- *.
  exfalso; apply le_not_lt with n i; auto.
 elim (le_lt_dec i 0); intro; simpl in |- *.
  exfalso; apply lt_irrefl with 0; apply lt_le_trans with i; auto.
 set (x := ProjT1 (RSR_h_f' _ (lt_pred' _ _ b1 b0))) in *.
 set (y := ProjT1 (RSR_h_f' _ (lt_pred' _ _ Hi Hi'))) in *.
 cut (x = y).
  intro; auto with arith.
 assert (H := ProjT2 (RSR_h_f' _ (lt_pred' _ _ b1 b0))).
 assert (H0 := ProjT2 (RSR_h_f' _ (lt_pred' _ _ Hi Hi'))).
 elim H; clear H; intros Hx Hx'.
 elim H0; clear H0; intros Hy Hy'.
 apply RSR_h_inj with Hx Hy.
 eapply eq_transitive_unfolded.
  2: apply Hy'.
 eapply eq_transitive_unfolded.
  apply eq_symmetric_unfolded; apply Hx'.
 apply RSR_f'_nlnf; reflexivity.
Qed.

Lemma RSR_auxP_lemman : RSR_auxP n = pred (m + n).
Proof.
 unfold RSR_auxP in |- *.
 elim (le_lt_dec n 0); intro; simpl in |- *.
  cut (n = 0); [ intro | auto with arith ].
  transitivity (pred m).
   2: rewrite H; auto.
  cut (0 = m); [ intro; rewrite <- H0; auto | apply RSR_HR' ].
  apply partition_length_zero with Hab; rewrite <- H; apply P.
 elim (le_lt_dec n n); intro; simpl in |- *.
  rewrite <- minus_n_n; auto.
 exfalso; apply lt_irrefl with n; auto.
Qed.

Lemma RSR_auxP_lemma1 : forall i j : nat, i < j -> RSR_auxP i < RSR_auxP j.
Proof.
 intros; unfold RSR_auxP in |- *.
 assert (X:=not_not_lt); assert (X':=plus_pred_pred_plus).
 assert (X'':=RSR_mn0); assert (X''':=RSR_nm0).
 elim (le_lt_dec i 0); intro.
  elim (le_lt_dec j 0); intros; simpl in |- *.
   apply lt_le_trans with j; try apply le_lt_trans with i; auto with arith.
  elim (le_lt_dec n j); intros; simpl in |- *.
   lia.
  apply lt_O_Sn.
 elim (le_lt_dec n i); elim (le_lt_dec j 0); intros; simpl in |- *.
    elim (lt_irrefl 0); apply lt_le_trans with j; try apply le_lt_trans with i; auto with arith.
   elim (le_lt_dec n j); intro; simpl in |- *.
    apply plus_lt_compat_l.
    apply plus_lt_reg_l with n.
    repeat rewrite <- le_plus_minus; auto.
   elim (le_not_lt n i); auto; apply lt_trans with j; auto.
  elim (lt_irrefl 0); apply lt_trans with i; auto; apply lt_le_trans with j; auto.
 elim (le_lt_dec n j); intro; simpl in |- *.
  apply lt_le_trans with (S (pred m + pred n)).
   apply lt_n_S.
   apply (ProjT1 (ProjT2 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2)))).
  rewrite plus_n_Sm.
  rewrite <- S_pred with n 0.
   2: apply lt_trans with i; auto.
  replace (pred m + n) with (pred (m + n)).
   auto with arith.
  cut (S (pred (m + n)) = S (pred m + n)); auto.
  rewrite <- plus_Sn_m.
  rewrite (S_pred m 0); auto with arith.
  apply neq_O_lt.
  intro.
  apply lt_irrefl with 0.
  apply lt_trans with i; auto.
  rewrite RSR_mn0; auto.
 apply lt_n_S.
 cut (~ ~ ProjT1 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2)) <
   ProjT1 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3))); intro.
  apply not_not_lt; assumption.
 cut (ProjT1 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3)) <=
   ProjT1 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2))); intros.
  2: apply not_lt; assumption.
 cut (h _ (ProjT1 (ProjT2 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3))))[<=]
   h _ (ProjT1 (ProjT2 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2))))).
  intro.
  2: apply RSR_h_mon'; assumption.
 cut (f' (pred j) (lt_pred' _ _ b1 b3)[<=]f' (pred i) (lt_pred' _ _ b0 b2)).
  2: apply leEq_wdl with (h _ (ProjT1 (ProjT2 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3))))).
   2: apply leEq_wdr with (h _ (ProjT1 (ProjT2 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2))))).
    2: assumption.
   3: apply eq_symmetric_unfolded; exact (ProjT2 (ProjT2 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3)))).
  2: apply eq_symmetric_unfolded; exact (ProjT2 (ProjT2 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2)))).
 clear H2 H1; intro.
 cut (f' _ (lt_pred' _ _ b0 b2)[<]f' _ (lt_pred' _ _ b1 b3)).
  2: apply RSR_f'_mon.
  2: apply lt_pred'; assumption.
 intro.
 exfalso.
 apply less_irreflexive_unfolded with (x := f' _ (lt_pred' _ _ b1 b3)).
 eapply leEq_less_trans; [ apply H1 | apply X0 ].
Qed.

Lemma RSR_auxP_lemma2 :
  forall (i : nat) (H : i <= n),
  {H' : RSR_auxP i <= _ | P i H[=]Separated_Refinement _ H'}.
Proof.
 intros.
 unfold Separated_Refinement in |- *; simpl in |- *.
 unfold Separated_Refinement_fun in |- *; simpl in |- *.
 elim (le_lt_dec i 0); intro; simpl in |- *.
  cut (i = 0); [ intro | auto with arith ].
  generalize H; clear a0 H; rewrite H0.
  rewrite RSR_auxP_lemma0.
  clear H0; intros.
  exists (le_O_n (pred (m + n))).
  elim le_lt_eq_dec; intro; simpl in |- *.
   elim (le_lt_dec 0 0); intro; simpl in |- *.
    apply start.
   exfalso; inversion b0.
  apply eq_transitive_unfolded with a.
   apply start.
  apply partition_length_zero with Hab.
  cut (m + n <= 1).
   intro.
   elim (plus_eq_one_imp_eq_zero _ _ H0); intro.
    rewrite <- a0; apply R.
   rewrite <- b1; apply P.
  generalize b0; clear b0.
  case (m + n).
   auto.
  intros.
  simpl in b0; rewrite <- b0; auto.
 elim (le_lt_eq_dec _ _ H); intro.
  cut (pred i < pred n); [ intro | apply lt_pred; rewrite <- S_pred with i 0; auto ].
  cut (RSR_auxP i <= pred (m + n)).
   intro; exists H1.
   elim le_lt_eq_dec; intro; simpl in |- *.
    elim (le_lt_dec (RSR_auxP i) 0); intro; simpl in |- *.
     cut (RSR_auxP i = 0); [ intro | auto with arith ].
     rewrite <- RSR_auxP_lemma0 in H2.
     cut (RSR_auxP 0 < RSR_auxP i); [ intro | apply RSR_auxP_lemma1; assumption ].
     exfalso; rewrite H2 in H3; apply (lt_irrefl _ H3).
    generalize b1 a1; clear b1 a1.
    rewrite (RSR_auxP_lemmai i b0 a0); intros.
    simpl in |- *.
    elim (ProjT2 (RSR_h_f' _ (lt_pred' i n b0 a0))); intros.
    eapply eq_transitive_unfolded.
     2: eapply eq_transitive_unfolded.
      2: apply p.
     unfold f' in |- *.
     apply prf1; apply S_pred with 0; auto.
    apply RSR_h_nlnf; reflexivity.
   rewrite <- RSR_auxP_lemman in b1.
   cut (i = n).
    intro; exfalso; rewrite H2 in a0; apply (lt_irrefl _ a0).
   apply nat_mon_imp_inj with (h := RSR_auxP).
    apply RSR_auxP_lemma1.
   assumption.
  unfold RSR_auxP in |- *.
  elim (le_lt_dec i 0); intro; simpl in |- *.
   apply le_O_n.
  elim (le_lt_dec n i); intro; simpl in |- *.
   elim (lt_irrefl n); apply le_lt_trans with i; auto.
  apply plus_pred_pred_plus.
  elim (ProjT2 (RSR_h_f' _ (lt_pred' i n b1 b2))); intros.
  assumption.
 generalize H; clear H; rewrite b1; intro.
 rewrite RSR_auxP_lemman.
 exists (le_n (pred (m + n))).
 elim le_lt_eq_dec; intro; simpl in |- *.
  exfalso; apply (lt_irrefl _ a0).
 apply finish.
Qed.

Lemma Separated_Refinement_lft : Refinement P Separated_Refinement.
Proof.
 exists RSR_auxP; repeat split.
   exact RSR_auxP_lemman.
  intros; apply RSR_auxP_lemma1; assumption.
 exact RSR_auxP_lemma2.
Qed.

Lemma RSR_auxR_lemma0 : RSR_auxR 0 = 0.
Proof.
 unfold RSR_auxR in |- *.
 elim (le_lt_dec 0 0); intro; simpl in |- *.
  reflexivity.
 exfalso; inversion b0.
Qed.

Lemma RSR_auxR_lemmai :
  forall (i : nat) (Hi : 0 < i) (Hi' : i < m),
  RSR_auxR i = S (ProjT1 (RSR_h_g' (pred i) (lt_pred' _ _ Hi Hi'))).
Proof.
 intros.
 unfold RSR_auxR in |- *.
 elim (le_lt_dec m i); intro; simpl in |- *.
  exfalso; apply le_not_lt with m i; auto.
 elim (le_lt_dec i 0); intro; simpl in |- *.
  exfalso; apply lt_irrefl with 0; apply lt_le_trans with i; auto.
 set (x := ProjT1 (RSR_h_g' _ (lt_pred' _ _ b1 b0))) in *.
 set (y := ProjT1 (RSR_h_g' _ (lt_pred' _ _ Hi Hi'))) in *.
 cut (x = y).
  intro; auto with arith.
 assert (H := ProjT2 (RSR_h_g' _ (lt_pred' _ _ b1 b0))).
 assert (H0 := ProjT2 (RSR_h_g' _ (lt_pred' _ _ Hi Hi'))).
 elim H; clear H; intros Hx Hx'.
 elim H0; clear H0; intros Hy Hy'.
 apply RSR_h_inj with Hx Hy.
 eapply eq_transitive_unfolded.
  2: apply Hy'.
 eapply eq_transitive_unfolded.
  apply eq_symmetric_unfolded; apply Hx'.
 apply RSR_g'_nlnf; reflexivity.
Qed.

Lemma RSR_auxR_lemmam : RSR_auxR m = pred (m + n).
Proof.
 unfold RSR_auxR in |- *.
 elim (le_lt_dec m 0); intro; simpl in |- *.
  cut (m = 0); [ intro | auto with arith ].
  transitivity (pred m).
   rewrite H; auto.
  cut (0 = n); [ intro; rewrite <- H0; auto | apply RSR_HP' ].
  apply partition_length_zero with Hab; rewrite <- H; apply R.
 elim (le_lt_dec m m); intro; simpl in |- *.
  rewrite <- minus_n_n; auto.
 elim (lt_irrefl _ b1).
Qed.

Lemma RSR_auxR_lemma1 : forall i j : nat, i < j -> RSR_auxR i < RSR_auxR j.
Proof.
 intros; unfold RSR_auxR in |- *.
 assert (X:=not_not_lt); assert (X':=plus_pred_pred_plus).
 assert (X'':=RSR_mn0); assert (X''':=RSR_nm0).
 elim (le_lt_dec i 0); intro.
  elim (le_lt_dec j 0); intros; simpl in |- *.
   apply le_lt_trans with i; try apply lt_le_trans with j; auto with arith.
  elim (le_lt_dec m j); intros; simpl in |- *.
   lia.
  apply lt_O_Sn.
 elim (le_lt_dec m i); elim (le_lt_dec j 0); intros; simpl in |- *.
    elim (lt_irrefl 0); apply le_lt_trans with i; try apply lt_le_trans with j; auto with arith.
   elim (le_lt_dec m j); intro; simpl in |- *.
    apply plus_lt_compat_l.
    apply plus_lt_reg_l with m.
    repeat rewrite <- le_plus_minus; auto.
   elim (le_not_lt m i); auto; apply lt_trans with j; auto.
  elim (lt_irrefl 0); apply lt_trans with i; auto; apply lt_le_trans with j; auto.
 elim (le_lt_dec m j); intro; simpl in |- *.
  set (H0 := RSR_nm0) in *; set (H1 := RSR_mn0) in *; apply lt_le_trans with (S (pred m + pred n)).
   apply lt_n_S.
   apply (ProjT1 (ProjT2 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2)))).
  rewrite <- plus_Sn_m.
  rewrite <- S_pred with m 0.
   2: apply lt_trans with i; auto.
  replace (m + pred n) with (pred (m + n)).
   auto with arith.
  cut (S (pred (m + n)) = S (m + pred n)); auto.
  rewrite plus_n_Sm.
  rewrite <- S_pred with n 0; auto with arith.
   symmetry  in |- *; apply S_pred with 0.
   apply lt_le_trans with m; auto with arith.
   apply lt_trans with i; auto.
  apply neq_O_lt.
  intro.
  apply lt_irrefl with 0.
  apply lt_trans with i; auto.
  rewrite RSR_nm0; auto.
 apply lt_n_S.
 cut (~ ~ ProjT1 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2)) <
   ProjT1 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3))); intro.
  apply not_not_lt; assumption.
 cut (ProjT1 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3)) <=
   ProjT1 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2))); intros.
  2: apply not_lt; assumption.
 cut (h _ (ProjT1 (ProjT2 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3))))[<=]
   h _ (ProjT1 (ProjT2 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2))))).
  intro.
  2: apply RSR_h_mon'; assumption.
 cut (g' (pred j) (lt_pred' _ _ b1 b3)[<=]g' (pred i) (lt_pred' _ _ b0 b2)).
  2: apply leEq_wdl with (h _ (ProjT1 (ProjT2 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3))))).
   2: apply leEq_wdr with (h _ (ProjT1 (ProjT2 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2))))).
    2: assumption.
   3: apply eq_symmetric_unfolded; exact (ProjT2 (ProjT2 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3)))).
  2: apply eq_symmetric_unfolded; exact (ProjT2 (ProjT2 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2)))).
 clear H2 H1; intro.
 cut (g' _ (lt_pred' _ _ b0 b2)[<]g' _ (lt_pred' _ _ b1 b3)).
  2: apply RSR_g'_mon.
  2: apply lt_pred'; assumption.
 intro.
 exfalso.
 apply less_irreflexive_unfolded with (x := g' _ (lt_pred' _ _ b1 b3)).
 eapply leEq_less_trans; [ apply H1 | apply X0 ].
Qed.

Lemma RSR_auxR_lemma2 :
  forall (j : nat) (H : j <= m),
  {H' : RSR_auxR j <= _ | R j H[=]Separated_Refinement _ H'}.
Proof.
 intros.
 unfold Separated_Refinement in |- *; simpl in |- *.
 unfold Separated_Refinement_fun in |- *; simpl in |- *.
 elim (le_lt_dec j 0); intro; simpl in |- *.
  cut (j = 0); [ intro | auto with arith ].
  generalize H; clear a0 H; rewrite H0.
  rewrite RSR_auxR_lemma0.
  clear H0; intros.
  exists (le_O_n (pred (m + n))).
  elim le_lt_eq_dec; intro; simpl in |- *.
   elim (le_lt_dec 0 0); intro; simpl in |- *.
    apply start.
   exfalso; inversion b0.
  apply eq_transitive_unfolded with a.
   apply start.
  apply partition_length_zero with Hab.
  cut (m + n <= 1).
   intros.
   elim (plus_eq_one_imp_eq_zero _ _ H0); intro.
    rewrite <- a0; apply R.
   rewrite <- b1; apply P.
  generalize b0; clear b0.
  case (m + n).
   auto.
  intros.
  simpl in b0; rewrite <- b0; auto.
 elim (le_lt_eq_dec _ _ H); intro.
  cut (pred j < pred m); [ intro | red in |- *; rewrite <- S_pred with j 0; auto; apply le_2; auto ].
  cut (RSR_auxR j <= pred (m + n)).
   intro; exists H1.
   elim le_lt_eq_dec; intro; simpl in |- *.
    elim (le_lt_dec (RSR_auxR j) 0); intro; simpl in |- *.
     cut (RSR_auxR j = 0); [ intro | auto with arith ].
     rewrite <- RSR_auxR_lemma0 in H2.
     cut (RSR_auxR 0 < RSR_auxR j); [ intro | apply RSR_auxR_lemma1; assumption ].
     exfalso; rewrite H2 in H3; apply (lt_irrefl _ H3).
    generalize b1 a1; clear b1 a1.
    rewrite (RSR_auxR_lemmai j b0 a0); intros.
    simpl in |- *.
    elim (ProjT2 (RSR_h_g' _ (lt_pred' _ _ b0 a0))); intros.
    eapply eq_transitive_unfolded.
     2: eapply eq_transitive_unfolded.
      2: apply p.
     unfold g' in |- *.
     apply prf1; apply S_pred with 0; auto.
    apply RSR_h_nlnf; reflexivity.
   rewrite <- RSR_auxR_lemmam in b1.
   cut (j = m).
    intro; exfalso; rewrite H2 in a0; apply (lt_irrefl _ a0).
   apply nat_mon_imp_inj with (h := RSR_auxR).
    apply RSR_auxR_lemma1.
   assumption.
  unfold RSR_auxR in |- *.
  elim (le_lt_dec j 0); intro; simpl in |- *.
   apply le_O_n.
  elim (le_lt_dec m j); intro; simpl in |- *.
   rewrite not_le_minus_0.
    rewrite <- plus_n_O; auto with arith.
   apply lt_not_le; auto.
  apply plus_pred_pred_plus.
  elim (ProjT2 (RSR_h_g' _ (lt_pred' _ _ b1 b2))); intros.
  assumption.
 generalize H; clear H; rewrite b1; intro.
 rewrite RSR_auxR_lemmam.
 exists (le_n (pred (m + n))).
 elim le_lt_eq_dec; intro; simpl in |- *.
  exfalso; apply (lt_irrefl _ a0).
 apply finish.
Qed.

Lemma Separated_Refinement_rht : Refinement R Separated_Refinement.
Proof.
 exists RSR_auxR; repeat split.
   exact RSR_auxR_lemmam.
  intros; apply RSR_auxR_lemma1; assumption.
 exact RSR_auxR_lemma2.
Qed.

End Refining_Separated.
(* end hide *)


Require Import String.
Require Import List.
Require Import Nat.
Require Import Bool.
Require Import Arith.
Require Import FunctionalExtensionality.

Open Scope string_scope.
Open Scope list_scope.
Open Scope core_scope.

Import ListNotations.

Require Import Maps.
Require Import LibTactics.
Require Import AST.
Require Import TypeInferencer.
Require Import TypeChecker.

(* misc *)
Lemma in_app_iff_prop :
  forall {T : Type } (l l' : list T) (P : T -> Prop),
    (forall i, In i (l ++ l') -> P i) <->
    (forall i, In i l -> P i) /\ (forall i, In i l' -> P i).
Proof.
  introv. split.
  - introv Hll'. split.
    * introv Hl.
      assert (Hll'': In i (l ++ l')).
        { apply in_app_iff. left. assumption. }
      apply (Hll' i Hll'').
    * introv Hl'.
      assert (Hll'': In i (l ++ l')).
        { apply in_app_iff. right. assumption. }
      apply (Hll' i Hll'').
  - introv Hll'. inverts Hll' as Hl Hl'.
    introv Hi. apply in_app_iff in Hi. destruct Hi as [Hil|Hil'].
    * apply (Hl i Hil).
    * apply (Hl' i Hil').
Qed.

Lemma app_non_nil :
  forall {T : Type} (l l' : list T),
    l <> [] -> (l ++ l') <> [].
Proof.
  introv Hl. intro.
  apply app_eq_nil in H.
  destruct H as [Hnl Hnl'].
  apply Hl. assumption.
Qed.

Lemma lt_n_n_1 :
  forall n, n < n + 1.
Proof.
  introv.
  assert (H: n + 0 < n + 1).
    { apply (plus_lt_compat_l 0 1 n).
      apply (Nat.lt_succ_diag_r 0). }
  rewrite <- (plus_n_O n) in H.
  assumption.
Qed.

Lemma lt_n_n :
  forall n, ~(n < n).
Proof.
  unfold not.
  introv H.
  apply (le_not_lt n n (le_n n)).
  assumption.
Qed.

Lemma and_factor :
  forall P Q R,
     P /\ (Q \/ R) <-> (P /\ Q) \/ (P /\ R).
Proof.
  introv. split.
  - introv H. destruct H as [HP HQR]. destruct HQR as [HQ|HR].
    * left. split; assumption.
    * right. split; assumption.
  - introv H. destruct H as [HPQ|HPR].
    * destruct HPQ as [HP HQ]. split.
      + assumption.
      + left. assumption.
    * destruct HPR as [HP HR]. split.
      + assumption.
      + right. assumption.
Qed.

(* app_sub_to_type *)
Example app_sub_to_type_ex1 : app_sub_to_type (update empty_substs (Id 1) TNum) (TFun (TVar (Id 1)) TNum) = TFun TNum TNum.
Proof. reflexivity. Qed.

Example app_sub_to_type_ex2 : app_sub_to_type (update (update empty_substs (Id 1) TNum) (Id 2) TBool) (TFun (TVar (Id 1)) (TVar (Id 2))) = TFun TNum TBool.
Proof. reflexivity. Qed.

Lemma app_sub_to_concrete_type :
  forall s T, concrete_type T -> app_sub_to_type s T = T.
Proof.
  introv Hvt.
  induction T.
  - reflexivity.
  - reflexivity.
  - inverts Hvt. simpl.
    apply IHT1 in H1.
    apply IHT2 in H2.
    rewrite H1, H2.
    reflexivity.
  - inverts Hvt. simpl.
    apply IHT in H0.
    rewrite H0.
    reflexivity.
  - inverts Hvt.
Qed.

(* satisfy *)
Example satisfy_ex1 :
  satisfy
    (update (update (update empty_substs (Id 1) TNum) (Id 2) TNum) (Id 3) TNum)
    [(TList (TVar (Id 1)), TList TNum); (TList (TVar (Id 3)), TList TNum); (TVar (Id 2), TNum)].
Proof.
  apply SAT_NotEmpty.
  - reflexivity.
  - apply SAT_NotEmpty.
    * reflexivity.
    * apply SAT_NotEmpty.
      + reflexivity.
      + apply SAT_Empty.
Qed.

Lemma satisfy_constr_concat :
  forall s C1 C2, satisfy s C1 /\ satisfy s C2 <-> satisfy s (C1 ++ C2).
Proof.
  introv. split.
  - introv [HC1 HC2]. induction C1 as [|hd1 tl1].
    * simpl. assumption.
    * simpl. inverts HC1.
      apply SAT_NotEmpty.
      + assumption.
      + apply (IHtl1 H3).
  - introv H. induction C1 as [|hd1 tl1]; simpl in H.
    * split.
      + apply SAT_Empty.
      + assumption.
    * inverts H. apply IHtl1 in H4. inverts H4. split.
      + apply SAT_NotEmpty.
        { assumption. }
        { assumption. }
      + assumption.
Qed.

(* app_sub_to_env *)
Lemma app_sub_to_update_env :
  forall sub env i t,
    app_sub_to_env sub (update env i t) = update (app_sub_to_env sub env) i (app_sub_to_type sub t).
Proof.
  intros.
  unfold app_sub_to_env.
  unfold update.
  unfold t_update.
  apply functional_extensionality_dep.
  intro x'.
  destruct (beq_id i x').
  - reflexivity.
  - reflexivity.
Qed.

(* max_typevar *)
Lemma max_typevar_larger_fv :
  forall t fv,
    fv < max_typevar t fv + 1.
Proof.
  induction t;
  introv;
  simpl;
  try (apply (lt_n_n_1 fv)); unfold max_typevar; simpl.
  - rewrite (map_app (fun i : id => match i with | Id n => n end) (typevars t1) (typevars t2)).
    rewrite (fold_left_app (fun mx n : nat => max mx n)
              (map (fun i : id => match i with | Id n => n end) (typevars t1))
              (map (fun i : id => match i with | Id n => n end) (typevars t2))
              fv).
    fold (max_typevar t1 fv).
    fold (max_typevar t2 (max_typevar t1 fv)).
    assert (Hlt_fv_t1: fv < max_typevar t1 fv + 1).
      { apply (IHt1 fv). }
    rewrite Nat.add_1_r in Hlt_fv_t1. apply lt_n_Sm_le in Hlt_fv_t1.
    assert (Hlt_t1_t2: max_typevar t1 fv < max_typevar t2 (max_typevar t1 fv) + 1).
      { apply (IHt2 (max_typevar t1 fv)). }
    apply (Nat.le_lt_trans fv (max_typevar t1 fv) (max_typevar t2 (max_typevar t1 fv) + 1) Hlt_fv_t1 Hlt_t1_t2).
  - apply (IHt fv).
  - destruct i. destruct (Max.max_dec fv n) eqn:He.
    * rewrite e. apply (lt_n_n_1 fv).
    * assert (Hle_fv_n: fv <= Nat.max fv n).
        { apply (Max.le_max_l fv n). }
      rewrite e in Hle_fv_n.
      rewrite e.
      apply (Nat.le_lt_trans fv n (n + 1) Hle_fv_n (lt_n_n_1 n)).
Qed.

Lemma max_typevar_larger_typevar :
  forall t fv,
    (forall n, In (Id n) (typevars t) -> n <  max_typevar t fv + 1).
Proof.
  induction t;
  unfold max_typevar;
  simpl;
  introv Hin;
  simpl in Hin;
  try (inverts Hin as H').
  - rewrite (map_app (fun i : id => match i with | Id n0 => n0 end) (typevars t1) (typevars t2)).
    rewrite (fold_left_app (fun mx n : nat => max mx n)
              (map (fun i : id => match i with | Id n0 => n0 end) (typevars t1))
              (map (fun i : id => match i with | Id n0 => n0 end) (typevars t2))
              fv).
    fold (max_typevar t1 fv).
    fold (max_typevar t2 (max_typevar t1 fv)).
    apply in_app_or in Hin. destruct Hin as [Hint1|Hint2].
    * assert (Hlt_n_t1: n < max_typevar t1 fv + 1).
        { apply (IHt1 fv n Hint1). }
      rewrite Nat.add_1_r in Hlt_n_t1. apply lt_n_Sm_le in Hlt_n_t1.
      assert (Hlt_t1_t2: max_typevar t1 fv < max_typevar t2 (max_typevar t1 fv) + 1).
        { apply (max_typevar_larger_fv t2 (max_typevar t1 fv)). }
      apply (Nat.le_lt_trans n (max_typevar t1 fv) (max_typevar t2 (max_typevar t1 fv) + 1) Hlt_n_t1 Hlt_t1_t2).
    * apply (IHt2 (max_typevar t1 fv) n Hint2).
  - fold (max_typevar t fv). apply (IHt fv n Hin).
  - destruct (Max.max_dec fv n) eqn:He.
    * assert (Hle_n_fv: n <= Nat.max fv n).
        { apply (Max.le_max_r fv n). }
      rewrite e in Hle_n_fv.
      rewrite e.
      apply (Nat.le_lt_trans n fv (fv + 1) Hle_n_fv (lt_n_n_1 fv)).
    * rewrite e. apply (lt_n_n_1 n).
  - inverts H'.
Qed.

(* typevars *)
Example typevars_ex1 :
  typevars (TFun (TVar (Id 1)) (TList (TVar (Id 2)))) = [Id 1; Id 2].
Proof. reflexivity. Qed.

Example typevars_ex2 :
  typevars_from_constr
    [(TList (TVar (Id 1)), TList TNum); (TList (TVar (Id 3)), TList TNum); (TVar (Id 2), TNum)] =
    [Id 1; Id 3; Id 2].
Proof. reflexivity. Qed.

(* typeinf *)
Lemma typeinf_larger_fv :
  forall e t_env fv1 fv2 S C X,
    typeinf t_env fv1 e (fv2, S, C, X) -> fv1 < fv2.
Proof.
  induction e;
  introv Hti;
  inverts Hti as Htie1 Htie2 Htie3;
  try (apply (lt_n_n_1 fv1));
  sort.
  - apply (max_typevar_larger_fv S fv1).
  - assert (Hlt_fv1_c_fv: fv1 < c_fv).
      { apply (IHe1 t_env fv1 c_fv c_T c_C c_X Htie1). }
    assert (Hlt_c_fv_e1_fv: c_fv < e1_fv).
      { apply (IHe2 t_env c_fv e1_fv S e1_C e1_X Htie2). }
    assert (Hlt_e1_fv_fv2: e1_fv < fv2).
      { apply (IHe3 t_env e1_fv fv2 e2_T e2_C e2_X Htie3). }
    assert (Hlt_c_fv_fv2: c_fv < fv2).
      { apply (lt_trans c_fv e1_fv fv2 Hlt_c_fv_e1_fv Hlt_e1_fv_fv2). }
    apply (lt_trans fv1 c_fv fv2 Hlt_fv1_c_fv Hlt_c_fv_fv2).
  - assert (Hlt_fv1_t: fv1 < max_typevar t fv1 + 1).
      { apply (max_typevar_larger_fv t fv1). }
    assert (Hlt_t_fv2: max_typevar t fv1 + 1< fv2).
      { apply (IHe (update t_env i t) (max_typevar t fv1 + 1) fv2 e_T C X Htie1). }
    apply (lt_trans fv1 (max_typevar t fv1 + 1) fv2 Hlt_fv1_t Hlt_t_fv2).
  - assert (Hlt_fv1_f_fv: fv1 < f_fv).
      { apply (IHe1 t_env fv1 f_fv f_T f_C f_X Htie1). }
    assert (Hlt_f_fv_e_fv: f_fv < e_fv).
      { apply (IHe2 t_env f_fv e_fv e_T e_C e_X Htie2). }
    assert (Hlt_fv1_e_fv: fv1 < e_fv).
      { apply (lt_trans fv1 f_fv e_fv Hlt_fv1_f_fv Hlt_f_fv_e_fv). }
    apply (lt_trans fv1 e_fv (e_fv + 1) Hlt_fv1_e_fv (lt_n_n_1 e_fv)).
  - assert (Hlt_fv1_e1_fv: fv1 < e1_fv).
      { apply (IHe1 t_env fv1 e1_fv e1_T e1_C e1_X Htie1). }
    assert (Hlt_e1_fv_fv2: e1_fv < fv2).
      { apply (IHe2 t_env e1_fv fv2 e2_T e2_C e2_X Htie2). }
    apply (lt_trans fv1 e1_fv fv2 Hlt_fv1_e1_fv Hlt_e1_fv_fv2).
  - assert (Hlt_fv1_e1_fv: fv1 < e1_fv).
      { apply (IHe1 t_env fv1 e1_fv e1_T e1_C e1_X Htie1). }
    assert (Hlt_e1_fv_fv2: e1_fv < fv2).
      { apply (IHe2 t_env e1_fv fv2 e2_T e2_C e2_X Htie2). }
    apply (lt_trans fv1 e1_fv fv2 Hlt_fv1_e1_fv Hlt_e1_fv_fv2).
  - assert (Hlt_fv1_e1_fv: fv1 < e1_fv).
      { apply (IHe1 t_env fv1 e1_fv e1_T e1_C e1_X Htie1). }
    assert (Hlt_e1_fv_fv2: e1_fv < fv2).
      { apply (IHe2 t_env e1_fv fv2 e2_T e2_C e2_X Htie2). }
    apply (lt_trans fv1 e1_fv fv2 Hlt_fv1_e1_fv Hlt_e1_fv_fv2).
  - assert (Hlt_fv1_hd_fv: fv1 < hd_fv).
      { apply (IHe1 t_env fv1 hd_fv hd_T hd_C hd_X Htie1). }
    assert (Hlt_hd_fv_fv2: hd_fv < fv2).
      { apply (IHe2 t_env hd_fv fv2 tl_T tl_C tl_X Htie2). }
    apply (lt_trans fv1 hd_fv fv2 Hlt_fv1_hd_fv Hlt_hd_fv_fv2).
  - apply (max_typevar_larger_fv t fv1).
Qed.

Lemma typeinf_X_between_fvs :
  forall e t_env fv1 fv2 S C X,
    typeinf t_env fv1 e (fv2, S, C, X) ->
    (forall n, In (Id n) X -> fv1 < n /\ n < fv2).
Proof.
  induction e;
  introv Hti;
  inverts Hti as Htie1 Htie2 Htie3;
  introv Hin;
  try (inverts Hin);
  sort.

  (* EIf *)
  - apply in_app_or in Hin. destruct Hin as [Hine2X|Hine1cX].
    * assert (Hlt_e1_fv_n_fv2: e1_fv < n < fv2).
        { apply ((IHe3 t_env e1_fv fv2 e2_T e2_C e2_X Htie3) n Hine2X). }
      destruct Hlt_e1_fv_n_fv2 as [Hlt_e1_fv_n Hlt_n_fv2].
      assert (Hlt_fv1_c_fv: fv1 < c_fv).
        { apply (typeinf_larger_fv e1 t_env fv1 c_fv c_T c_C c_X Htie1). }
      assert (Hlt_c_fv_e1_fv: c_fv < e1_fv).
        { apply (typeinf_larger_fv e2 t_env c_fv e1_fv S e1_C e1_X Htie2). }
      assert (Hlt_fv1_e1_fv: fv1 < e1_fv).
        { apply (lt_trans fv1 c_fv e1_fv Hlt_fv1_c_fv Hlt_c_fv_e1_fv). }
      assert (Hlt_fv1_n: fv1 < n).
        { apply (lt_trans fv1 e1_fv n Hlt_fv1_e1_fv Hlt_e1_fv_n). }
      split; assumption.
    * apply in_app_or in Hine1cX. destruct Hine1cX as [Hine1X|HincX].
      + assert (Hlt_c_fv_n_e1_fv: c_fv < n < e1_fv).
          { apply ((IHe2 t_env c_fv e1_fv S e1_C e1_X Htie2) n Hine1X). }
        destruct Hlt_c_fv_n_e1_fv as [Hlt_c_fv_n Hlt_n_e1_fv].
        assert (Hlt_fv1_c_fv: fv1 < c_fv).
          { apply (typeinf_larger_fv e1 t_env fv1 c_fv c_T c_C c_X Htie1). }
        assert (Hlt_e1_fv_fv2: e1_fv < fv2).
          { apply (typeinf_larger_fv e3 t_env e1_fv fv2 e2_T e2_C e2_X Htie3). }
        assert (Hlt_fv1_n: fv1 < n).
          { apply (lt_trans fv1 c_fv n Hlt_fv1_c_fv Hlt_c_fv_n). }
        assert (Hlt_n_fv2: n < fv2).
          { apply (lt_trans n e1_fv fv2 Hlt_n_e1_fv Hlt_e1_fv_fv2). }
        split; assumption.
      + assert (Hlt_fv1_n_c_fv: fv1 < n < c_fv).
          { apply ((IHe1 t_env fv1 c_fv c_T c_C c_X Htie1) n HincX). }
        destruct Hlt_fv1_n_c_fv as [Hlt_fv1_n Hlt_n_c_fv].
        assert (Hlt_c_fv_e1_fv: c_fv < e1_fv).
          { apply (typeinf_larger_fv e2 t_env c_fv e1_fv S e1_C e1_X Htie2). }
        assert (Hlt_e1_fv_fv2: e1_fv < fv2).
          { apply (typeinf_larger_fv e3 t_env e1_fv fv2 e2_T e2_C e2_X Htie3). }
        assert (Hlt_c_fv_fv2: c_fv < fv2).
          { apply (lt_trans c_fv e1_fv fv2 Hlt_c_fv_e1_fv Hlt_e1_fv_fv2). }
        assert (Hlt_n_fv2: n < fv2).
          { apply (lt_trans n c_fv fv2 Hlt_n_c_fv Hlt_c_fv_fv2). }
        split; assumption.

  (* EFun *)
  - assert (Hlt_t_fv2: (max_typevar t fv1 + 1) < n < fv2).
      { apply ((IHe (update t_env i t) (max_typevar t fv1 + 1) fv2 e_T C X Htie1) n Hin). }
    destruct Hlt_t_fv2 as [Hlt_t_n Hlt_n_fv2].
    assert (Hlt_fv1_t: fv1 < max_typevar t fv1 + 1).
      { apply (max_typevar_larger_fv t fv1). }
    assert (Hlt_fv1_n: fv1 < n).
      { apply (lt_trans fv1 (max_typevar t fv1 + 1) n Hlt_fv1_t Hlt_t_n). }
    split; assumption.

  (* ECall *)
  - apply in_app_or in Hin. destruct Hin as [HineX|HinfXefv].
    * assert (Hlt_f_fv_n_e_fv: f_fv < n < e_fv).
        { apply ((IHe2 t_env f_fv e_fv e_T e_C e_X Htie2) n HineX). }
      destruct Hlt_f_fv_n_e_fv as [Hlt_f_fv_n Hlt_n_e_fv].
      assert (Hlt_fv1_f_fv: fv1 < f_fv).
        { apply (typeinf_larger_fv e1 t_env fv1 f_fv f_T f_C f_X Htie1). }
      assert (Hlt_fv1_n: fv1 < n).
        { apply (lt_trans fv1 f_fv n Hlt_fv1_f_fv Hlt_f_fv_n). }
      assert (Hlt_n_e_fv_1: n < e_fv + 1).
        { apply (lt_trans n e_fv (e_fv + 1) Hlt_n_e_fv (lt_n_n_1 e_fv)). }
      split; assumption.
    * apply in_app_or in HinfXefv. destruct HinfXefv as [HinfX|Hinefv].
      + assert (Hlt_fv1_n_f_fv: fv1 < n < f_fv).
          { apply ((IHe1 t_env fv1 f_fv f_T f_C f_X Htie1) n HinfX). }
        destruct Hlt_fv1_n_f_fv as [Hlt_fv1_n Hlt_n_f_fv].
        assert (Hlt_f_fv_e_fv: f_fv < e_fv).
          { apply (typeinf_larger_fv e2 t_env f_fv e_fv e_T e_C e_X Htie2). }
        assert (Hlt_n_e_fv: n < e_fv).
          { apply (lt_trans n f_fv e_fv Hlt_n_f_fv Hlt_f_fv_e_fv). }
        assert (Hlt_n_e_fv_1: n < e_fv + 1).
          { apply (lt_trans n e_fv (e_fv + 1) Hlt_n_e_fv (lt_n_n_1 e_fv)). }
        split; assumption.
      + simpl in Hinefv. destruct Hinefv as [Hefvn|Hfalse].
        { assert (Hlt_fv1_f_fv: fv1 < f_fv).
            { apply (typeinf_larger_fv e1 t_env fv1 f_fv f_T f_C f_X Htie1). }
          assert (Hlt_f_fv_e_fv: f_fv < e_fv).
            { apply (typeinf_larger_fv e2 t_env f_fv e_fv e_T e_C e_X Htie2). }
          inverts Hefvn.
          assert (Hlt_fv1_n: fv1 < n).
            { apply (lt_trans fv1 f_fv n Hlt_fv1_f_fv Hlt_f_fv_e_fv). }
          assert (Hlt_n_n_1: n < n + 1).
            { apply (lt_n_n_1 n). }
          split; assumption. }
        { inverts Hfalse. }

  (* EBinop *)
  - apply in_app_or in Hin. destruct Hin as [Hine2X|Hine1X].
    * assert (Hlt_e1_fv_n_fv2: e1_fv < n < fv2).
        { apply ((IHe2 t_env e1_fv fv2 e2_T e2_C e2_X Htie2) n Hine2X). }
      destruct Hlt_e1_fv_n_fv2 as [Hlt_e1_fv_n Hlt_n_fv2].
      assert (Hlt_fv1_e1_fv: fv1 < e1_fv).
        { apply (typeinf_larger_fv e1 t_env fv1 e1_fv e1_T e1_C e1_X Htie1). }
      assert (Hlt_fv1_n: fv1 < n).
        { apply (lt_trans fv1 e1_fv n Hlt_fv1_e1_fv Hlt_e1_fv_n). }
      split; assumption.
    * assert (Hlt_fv1_n_e1_fv: fv1 < n < e1_fv).
        { apply ((IHe1 t_env fv1 e1_fv e1_T e1_C e1_X Htie1) n Hine1X). }
      destruct Hlt_fv1_n_e1_fv as [Hlt_fv1_n Hlt_n_e1_fv].
      assert (Hlt_e1_fv_fv2: e1_fv < fv2).
        { apply (typeinf_larger_fv e2 t_env e1_fv fv2 e2_T e2_C e2_X Htie2). }
      assert (Hlt_n_fv2: n < fv2).
        { apply (lt_trans n e1_fv fv2 Hlt_n_e1_fv Hlt_e1_fv_fv2). }
      split; assumption.

  - apply in_app_or in Hin. destruct Hin as [Hine2X|Hine1X].
    * assert (Hlt_e1_fv_n_fv2: e1_fv < n < fv2).
        { apply ((IHe2 t_env e1_fv fv2 e2_T e2_C e2_X Htie2) n Hine2X). }
      destruct Hlt_e1_fv_n_fv2 as [Hlt_e1_fv_n Hlt_n_fv2].
      assert (Hlt_fv1_e1_fv: fv1 < e1_fv).
        { apply (typeinf_larger_fv e1 t_env fv1 e1_fv e1_T e1_C e1_X Htie1). }
      assert (Hlt_fv1_n: fv1 < n).
        { apply (lt_trans fv1 e1_fv n Hlt_fv1_e1_fv Hlt_e1_fv_n). }
      split; assumption.
    * assert (Hlt_fv1_n_e1_fv: fv1 < n < e1_fv).
        { apply ((IHe1 t_env fv1 e1_fv e1_T e1_C e1_X Htie1) n Hine1X). }
      destruct Hlt_fv1_n_e1_fv as [Hlt_fv1_n Hlt_n_e1_fv].
      assert (Hlt_e1_fv_fv2: e1_fv < fv2).
        { apply (typeinf_larger_fv e2 t_env e1_fv fv2 e2_T e2_C e2_X Htie2). }
      assert (Hlt_n_fv2: n < fv2).
        { apply (lt_trans n e1_fv fv2 Hlt_n_e1_fv Hlt_e1_fv_fv2). }
      split; assumption.

  - apply in_app_or in Hin. destruct Hin as [Hine2X|Hine1X].
    * assert (Hlt_e1_fv_n_fv2: e1_fv < n < fv2).
        { apply ((IHe2 t_env e1_fv fv2 e2_T e2_C e2_X Htie2) n Hine2X). }
      destruct Hlt_e1_fv_n_fv2 as [Hlt_e1_fv_n Hlt_n_fv2].
      assert (Hlt_fv1_e1_fv: fv1 < e1_fv).
        { apply (typeinf_larger_fv e1 t_env fv1 e1_fv e1_T e1_C e1_X Htie1). }
      assert (Hlt_fv1_n: fv1 < n).
        { apply (lt_trans fv1 e1_fv n Hlt_fv1_e1_fv Hlt_e1_fv_n). }
      split; assumption.
    * assert (Hlt_fv1_n_e1_fv: fv1 < n < e1_fv).
        { apply ((IHe1 t_env fv1 e1_fv e1_T e1_C e1_X Htie1) n Hine1X). }
      destruct Hlt_fv1_n_e1_fv as [Hlt_fv1_n Hlt_n_e1_fv].
      assert (Hlt_e1_fv_fv2: e1_fv < fv2).
        { apply (typeinf_larger_fv e2 t_env e1_fv fv2 e2_T e2_C e2_X Htie2). }
      assert (Hlt_n_fv2: n < fv2).
        { apply (lt_trans n e1_fv fv2 Hlt_n_e1_fv Hlt_e1_fv_fv2). }
      split; assumption.

  (* ECons *)
  - apply in_app_or in Hin. destruct Hin as [HintlX|HinhdX].
    * assert (Hlt_hd_fv_n_fv2: hd_fv < n < fv2).
        { apply ((IHe2 t_env hd_fv fv2 tl_T tl_C tl_X Htie2) n HintlX). }
      destruct Hlt_hd_fv_n_fv2 as [Hlt_hd_fv_n Hlt_n_fv2].
      assert (Hlt_fv1_hd_fv: fv1 < hd_fv).
        { apply (typeinf_larger_fv e1 t_env fv1 hd_fv hd_T hd_C hd_X Htie1). }
      assert (Hlt_fv1_n: fv1 < n).
        { apply (lt_trans fv1 hd_fv n Hlt_fv1_hd_fv Hlt_hd_fv_n). }
      split; assumption.
    * assert (Hlt_fv1_n_hd_fv: fv1 < n < hd_fv).
        { apply ((IHe1 t_env fv1 hd_fv hd_T hd_C hd_X Htie1) n HinhdX). }
      destruct Hlt_fv1_n_hd_fv as [Hlt_fv1_n Hlt_n_hd_fv].
      assert (Hlt_hd_fv_fv2: hd_fv < fv2).
        { apply (typeinf_larger_fv e2 t_env hd_fv fv2 tl_T tl_C tl_X Htie2). }
      assert (Hlt_n_fv2: n < fv2).
        { apply (lt_trans n hd_fv fv2 Hlt_n_hd_fv Hlt_hd_fv_fv2). }
      split; assumption.
Qed.

Lemma typeinf_disjoint_Xs :
  forall
    t_env1 e1 S1 C1 X1
    t_env2 e2 S2 C2 X2
    fv1 fv2 fv3,
  typeinf t_env1 fv1 e1 (fv2, S1, C1, X1) ->
  typeinf t_env2 fv2 e2 (fv3, S2, C2, X2) ->
  (forall x, ~ (In x X1 /\ In x X2)).
Proof.
  introv Htie1 Htie2.
  introv.
  introv Hand.
  destruct Hand as [HxX1 HxX2].
  destruct x.
  assert (Hlt_fv1_n_fv2: fv1 < n < fv2).
    { apply ((typeinf_X_between_fvs e1 t_env1 fv1 fv2 S1 C1 X1 Htie1) n HxX1). }
  assert (Hlt_fv2_n_fv3: fv2 < n < fv3).
    { apply ((typeinf_X_between_fvs e2 t_env2 fv2 fv3 S2 C2 X2 Htie2) n HxX2). }
  destruct Hlt_fv1_n_fv2 as [Hlt_fv1_n Hlt_n_fv2].
  destruct Hlt_fv2_n_fv3 as [Hlt_fv2_n Hlt_n_fv3].
  apply (lt_n_n n (lt_trans n fv2 n Hlt_n_fv2 Hlt_fv2_n)).
Qed.

Lemma app_sub_type_omit_disjoint_list :
  forall T sub l,
    (forall i, ~(In i (typevars T) /\ In i l)) ->
    app_sub_to_type (omit sub l) T = app_sub_to_type sub T.
Proof.
  induction T;
  introv Hnin;
  simpl in Hnin;
  simpl;
  unfold not in Hnin;
  try reflexivity.
  - assert (HT1: forall i : id, ~ (In i (typevars T1) /\ In i l)).
      { introv. unfold not.
        introv Hini. destruct Hini.
        apply (Hnin i). split.
        - apply in_or_app. left. assumption.
        - assumption. }
    assert (HT2: forall i : id, ~ (In i (typevars T2) /\ In i l)).
      { introv. unfold not.
        introv Hini. destruct Hini.
        apply (Hnin i). split.
        - apply in_or_app. right. assumption.
        - assumption. }
    rewrite (IHT1 sub l HT1).
    rewrite (IHT2 sub l HT2).
    reflexivity.
  - rewrite (IHT sub l Hnin).
    reflexivity.
  - assert (Hini: ~ (In i l)).
    { unfold not. introv Hin.
      apply (Hnin i). split.
      - left. reflexivity.
      - assumption. }
    rewrite (omit_not_in_list t_type l i sub Hini).
    reflexivity.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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 2.1 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 GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Arith.
Require Import Compare.
Open Scope nat_scope.

(** * Additional properties on [le] *)

(** elimination of [le] with [plus] *)
Lemma Nle_plus : forall n k, k <= n -> exists p, n = k + p.
intros n k.
intro.
induction H.
exists 0. auto with arith.
destruct IHle.
rewrite H0.
exists (S x).
auto with arith.
Qed.