(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

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

  DdlCoq 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 DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export static_sem.
Require Export dynamic_semantics.
Require Export terms_util2.
Require Export list_util.

(**

 This file implements some additional lemmas which we used in order
 to prove static semantic lemmas.

 *)

Lemma equal_states_upto_prop1 :
  forall v s1 s2 vs,
    equal_states_except s1 s2 vs
    -> not (List.In v vs)
    -> s1 v = s2 v.
Proof.
  introv h1 h2; auto.
Qed.

Lemma ex_derive_all_n_id : ex_derive_all_n (fun x => x).
Proof.
  introv.
  apply ex_derive_n_id.
Qed.

Definition unary2vec (f : R -> R) : Vector.t R 1%nat -> R :=
  fun v : Vector.t R 1%nat =>
    match v with
    | Vector.cons x 0 Vector.nil => f x
    | _ => R0
    end.

Definition id_vec : Vector.t R 1%nat -> R :=
  unary2vec (fun x => x).

Lemma ex_partial_derive_st_func_id_vec : ex_partial_derive_st_func id_vec.
Proof.
  introv d; introv.
  unfold id_vec, unary2vec.
  apply (Vector.caseS' ts).
  introv; simpl.

  clear ts.

  apply (@Vector.case0
                T
                (fun t =>
                   (forall t0 : T, Vector.In t0 (Vector.cons T h 0 t) -> ex_all_partial_derive_st (fun s : state => G s t0)) ->
                   ex_all_partial_derive_st
                     (fun s : state =>
                        match Vector.map (G s) t return R with
                        | @Vector.nil _ => G s h
                        | @Vector.cons _ _ _ _ => R0
                        end))).
  simpl.
  clear t.
  introv ih.

  pose proof (ih h) as q; clear ih.
  autodimp q hyp.
  repeat constructor.
Qed.

Lemma ex_partial_derive_st_func_sub_id_vec : smooth_fun_T id_vec.
Proof.
  introv d; introv.
  unfold id_vec, unary2vec.
  apply (Vector.caseS' ts).
  introv; simpl.

  clear ts.

  apply (@Vector.case0
                T
                (fun t =>
                   (forall t0 w l',
                       Vector.In t0 (Vector.cons T h 0 t)
                       -> sublist (w :: l') (v :: l)
                       -> ex_partial_derive (fun s : state => G s t0) w l') ->
                   ex_partial_derive
                     (fun s : state =>
                        match Vector.map (G s) t return R with
                        | @Vector.nil _ => G s h
                        | @Vector.cons _ _ _ _ => R0
                        end) v l)).
  simpl.
  clear t.
  introv ih; introv; simpl in *.

  apply ih; auto; try (apply sublist_refl).
  repeat constructor.
Qed.

Definition interp_fun_id : interpretation_function 1%nat :=
  MkInterpFun 1%nat id_vec ex_partial_derive_st_func_sub_id_vec.

Lemma interpQuantExt_false : interpQuantExt (fun _ => FalseFormulaSem).
Proof.
  introv h; tcsp.
Qed.

Definition interp_quant_false : interpretation_quantifier :=
  MkInterpQuant (fun _ => FalseFormulaSem) interpQuantExt_false.

(** states s1 and s2 are equal for variables in vars *)
Definition equal_states_on (s1 s2 : state) (vs : list KAssignable) : Prop :=
  forall x,
    List.In x vs
    -> s1 x = s2 x.

(** iff states s1 and s2 are equal for all variables,
then they are equal on the variable at the head of that list,
as well as on the variables which are in tale at that list *)
Lemma equal_states_on_cons :
  forall s1 s2 v vs,
    equal_states_on s1 s2 (v :: vs)
    <-> (s1 v = s2 v /\ equal_states_on s1 s2 vs).
Proof.
  introv; split; intro h; repnd; dands; auto.
  { apply (h v); simpl; tcsp. }
  { introv i; apply (h x); simpl; tcsp. }
  { introv i; simpl in i; repndors; subst; auto. }
Qed.

(** iff states s1 and s2 are equal on append of two lists,
then they are equal on both of those lists *)
Lemma equal_states_on_app :
  forall s1 s2 vs1 vs2,
    equal_states_on s1 s2 (vs1 ++ vs2)
    <-> (equal_states_on s1 s2 vs1 /\ equal_states_on s1 s2 vs2).
Proof.
  introv; split; intro h; repnd; dands; auto.
  { introv i.
    apply (h x).
    apply in_app_iff; auto. }
  { introv i.
    apply (h x).
    apply in_app_iff; auto. }
  { introv i.
    apply in_app_iff in i; repndors.
    - apply (h0 x); auto.
    - apply (h x); auto.
  }
Qed.

(** states s1 and s2 are equal for variables in vars *)
Definition equal_states_on_ea (s1 s2 : state) (e : EAssignables) : Prop :=
  forall x : KAssignable,
    in_eassignables x e = true
    -> s1 x = s2 x.

(*
Lemma equal_states_on_ea_cons :
  forall s1 s2 v vs,
    equal_states_on_ea s1 s2 (EA_assignable v :: vs)
    <-> (s1 v = s2 v /\ equal_states_on_ea s1 s2 vs).
Proof.
  introv; split; intro h; repnd; dands; auto.
  { apply (h v); simpl; tcsp.
    dest_cases w; dest_cases w. }
  { introv i; apply (h x); simpl; tcsp.
    dest_cases w. }
  { introv i; simpl in i; repndors; subst; auto.
    dest_cases w; dest_cases w. }
Qed.
*)

(* we need this lemma in order to work with empty set *)
(** iff states s1 and s2 are equal on IF_infinite l,
states s1 and s2 are equal only for variables which are not in l *)
Lemma equal_states_on_ea_all :
  forall s1 s2 l,
    equal_states_on_ea s1 s2 (FCS_infinite l)
    <-> forall v, ~ List.In v l -> s1 v = s2 v.
Proof.
  introv; split; intro h; repnd; dands; auto.
  { introv i; apply (h v); simpl; tcsp; dest_cases w. }
  { introv i; apply h; simpl in *; dest_cases w. }
Qed.

(* we need this lemma in order to work with all variables *)
(** iff states s1 and s2 are equal on FCS_infinite [] (for all variables),
then they are equal for all variables *)
Lemma equal_states_on_ea_all_nil :
  forall s1 s2,
    equal_states_on_ea s1 s2 (FCS_infinite [])
    <-> forall v, s1 v = s2 v.
Proof.
  introv.
  rewrite equal_states_on_ea_all; split; introv h; introv; tcsp.
Qed.

(** iff states s1 and s2 are equal on append of two EAssignables,
then they are equal for both EAssignables *)
Lemma equal_states_on_ea_app :
  forall s1 s2 e1 e2,
    equal_states_on_ea s1 s2 (EAssignables_app e1 e2)
    <-> (equal_states_on_ea s1 s2 e1 /\ equal_states_on_ea s1 s2 e2).
Proof.
  introv; split; intro h; repnd; dands; auto.
  { introv i.
    apply (h x).
    apply in_eassignables_app_true_iff; auto. }
  { introv i.
    apply (h x).
    apply in_eassignables_app_true_iff; auto. }
  { introv i.
    apply in_eassignables_app_true_iff in i; repndors.
    - apply (h0 x); auto.
    - apply (h x); auto.
  }
Qed.

(** extensionallity of big sum in case f and g are extensionally equal *)
Lemma big_sum_ext :
  forall {T} (vs : list T) f g,
    (forall v, List.In v vs -> f v = g v)
    -> big_sum vs f = big_sum vs g.
Proof.
  induction vs; introv imp; simpl in *; auto.
  rewrite (IHvs f g); auto.
  rewrite imp; auto.
Qed.

(** all term variables are subset of free variables of that term *)
Lemma term_variables_subset_free_vars_term :
  forall v t,
    List.In v (term_variables t)
    -> List.In (KAssignVar v) (free_vars_term t).
Proof.
  term_ind t Case; introv i; simpl in *; auto.

  { Case "KTfuncOf".
    allrw in_vec_flatten; exrepnd.
    allrw in_vec_map; exrepnd; subst.
    pose proof (IHargs a i1 i0) as q; clear IHargs.
    exists (free_vars_term a).
    dands; auto.
    apply in_vec_map.
    exists a; dands; auto.
  }

  { Case "KTread".
    destruct var as [z|d]; simpl in *; repndors; subst; auto.
  }

  { Case "KTplus".
    apply in_app_iff in i; apply in_app_iff; repndors;
      [left;apply IHt1|right;apply IHt2];auto.
  }

  { Case "KTminus".
    apply in_app_iff in i; apply in_app_iff; repndors;
      [left;apply IHt1|right;apply IHt2];auto.
  }

  { Case "KTtimes".
    apply in_app_iff in i; apply in_app_iff; repndors;
      [left;apply IHt1|right;apply IHt2];auto.
  }

  { Case "KTdifferential".
    apply in_app_iff; auto.
  }
Qed.

(** term variables have have no duplicates *)
Lemma term_variables_nodup_eqset :
  forall t, eqset (term_variables_nodup t) (term_variables t).
Proof.
  introv; unfold term_variables_nodup.
  apply remove_duplicates_eqset.
Qed.

(** term variables without duplicates are subset of free variables of terms *)
Lemma term_variables_nodup_subset_free_vars_term :
  forall v t,
    List.In v (term_variables_nodup t)
    -> List.In (KAssignVar v) (free_vars_term t).
Proof.
  introv i.
  apply term_variables_subset_free_vars_term.
  apply term_variables_nodup_eqset in i; auto.
Qed.

Lemma implies_in_map_prime_kassignable :
  forall v l,
    List.In (KAssignVar v) l
    -> List.In (DVar v) (map KD l).
Proof.
  introv i.
  apply in_map_iff.
  eexists;dands;[|eauto].
  simpl; auto.
Qed.

(** if states v and w are equal on EA_assignables l,
they are equal on list l *)
Lemma equal_states_on_ea_assigns2ext :
  forall v w l,
    equal_states_on_ea v w (EA_assignables l)
    <-> equal_states_on v w l.
Proof.
  introv; split; introv h i; apply h; apply in_eassignables_assignables; auto.
Qed.

(** reflexivity for equal_states for EA_assignables *)
Lemma equal_states_on_ea_refl :
  forall s l, equal_states_on_ea s s l.
Proof.
  introv h; auto.
Qed.
Hint Resolve equal_states_on_ea_refl : core.

Fixpoint var_sub_find (s : var_sub) (v : KVariable) : option R :=
  match s with
  | [] => None
  | (w,r) :: s =>
    if KVariable_dec v w then Some r
    else var_sub_find s v
  end.

Lemma var_sub_find_some_implies_upd_list_state :
  forall st vs v r,
    var_sub_find vs v = Some r
    -> upd_list_state st vs (KAssignVar v) = r.
Proof.
  induction vs; simpl; introv h; ginv.
  destruct a; dest_cases w; ginv; autorewrite with core; auto.
  rewrite upd_state_diff;[|intro xx; inversion xx; tcsp];[].
  apply IHvs; auto.
Qed.

Lemma upd_list_state_decomp :
  forall st vs a,
    upd_list_state st vs a
    = match a with
      | KAssignVar v =>
        match var_sub_find vs v with
        | Some r => r
        | None => st a
        end
      | _ => st a
      end.
Proof.
  induction vs; introv; simpl; destruct a; auto.
  destruct a0; auto.

  - dest_cases w; subst; auto; autorewrite with core; auto.
    unfold upd_state; dest_cases w.
    rewrite IHvs; auto.

  - unfold upd_state; dest_cases w.
    rewrite IHvs; auto.
Qed.

Lemma var_sub_find_combine_none :
  forall vs rs v,
    length vs = length rs
    -> (var_sub_find (combine vs rs) v = None <-> not (List.In v vs)).
Proof.
  induction vs; destruct rs; introv h; simpl in *; ginv;
    split; introv q; tcsp;
    dest_cases w; subst.

  { apply IHvs in q; tcsp. }

  { destruct q; auto. }

  { apply IHvs; auto. }
Qed.

Lemma implies_var_in_eassignables_remove_vars_true :
  forall v e l,
    in_eassignables (KAssignVar v) e = true
    -> ~ List.In v l
    -> in_eassignables (KAssignVar v) (remove_vars e l) = true.
Proof.
  destruct e; simpl; introv; repeat (dest_cases w); introv h1 h2; GC;
    allrw in_KAssignables_minus.
  { destruct n; dands; auto.
    rewrite in_map_iff; intro q; destruct h2; exrepnd; ginv; auto. }
  { allrw in_app_iff; repndors; tcsp.
    allrw in_map_iff; exrepnd; ginv; tcsp. }
Qed.

(** if v' is in e then v' is in list form which e is removed *)
Lemma implies_diff_in_eassignables_remove_vars_true :
  forall v e l,
    in_eassignables (KAssignDiff v) e = true
    -> in_eassignables (KAssignDiff v) (remove_vars e l) = true.
Proof.
  destruct e; simpl; introv; repeat (dest_cases w); introv h; GC;
    allrw in_KAssignables_minus.
  { destruct n; dands; auto.
    rewrite in_map_iff; intro q; exrepnd; ginv. }
  { allrw in_app_iff; repndors; tcsp.
    allrw in_map_iff; exrepnd; ginv; tcsp. }
Qed.

Lemma equal_states_on_ea_remove_all_implies_upd_list_state :
  forall v w vars rs e,
    length vars = length rs
    -> equal_states_on_ea v w (remove_vars e vars)
    -> equal_states_on_ea
         (upd_list_state v (combine vars rs))
         (upd_list_state w (combine vars rs))
         e.
Proof.
  introv len h i.
  repeat (rewrite upd_list_state_decomp).
  destruct x as [z|d].

  {
    remember (var_sub_find (combine vars rs) z) as fs; symmetry in Heqfs; destruct fs; auto.
    apply h.
    apply var_sub_find_combine_none in Heqfs; auto.
    apply implies_var_in_eassignables_remove_vars_true; auto.
  }

  { apply h.
    apply implies_diff_in_eassignables_remove_vars_true; auto. }
Qed.

(** symmetry for equality of EAssignables on states *)
Lemma equal_states_on_ea_sym :
  forall v w e,
    equal_states_on_ea w v e
    -> equal_states_on_ea v w e.
Proof.
  introv eqs i; symmetry; apply eqs; auto.
Qed.

(** symmetry for equality of KAssignables on states *)
Lemma equal_states_on_sym :
  forall v w e,
    equal_states_on w v e
    -> equal_states_on v w e.
Proof.
  introv eqs i; symmetry; apply eqs; auto.
Qed.

(** reflexivity for equality on states *)
Lemma equal_states_on_refl :
  forall s e, equal_states_on s s e.
Proof.
  introv i; tcsp.
Qed.
Hint Resolve equal_states_on_refl : core.

(** if EAssignables e1 is subset of EAssignables e2 and
states v and w are equal on e2, then v and w are equal on e2 *)
Lemma equal_states_on_ea_eassignables_subset :
  forall v w e1 e2,
    eassignables_subset e1 e2 = true
    -> equal_states_on_ea v w e2
    -> equal_states_on_ea v w e1.
Proof.
  destruct e1, e2; simpl; introv ss es i; apply es; clear es;
    simpl in *; repeat (dest_cases w); GC;
    allrw @disj_dec_prop;
    allrw @included_dec_prop;
    allrw KAssignables_disj_prop;
    allrw KAssignables_included_prop; tcsp.
  apply ss in i0; sp.
Qed.

Lemma differ_state_except_iff_upd :
  forall v w x r,
    differ_state_except v w x r
    <-> w = upd_state v x r.
Proof.
  introv; unfold differ_state_except, upd_state; split; introv h;
    repnd; dands; subst.

  - apply functional_extensionality; introv; dest_cases w.
    symmetry; apply h0; auto.

  - introv i; dest_cases w.

  - dest_cases w.
Qed.

(** box implies not diamond *)
Lemma dynamic_semantics_formula_box_implies_not_diamond :
  forall P F I v,
    dynamic_semantics_formula I (KFbox P F) v
    -> dynamic_semantics_formula I (KFnot (KFdiamond P (KFnot F))) v.
Proof.
  simpl; introv h q; exrepnd.
  apply h in q0; tcsp.
Qed.

(** MBV of program is subset of VB of that program *)
Lemma must_bound_vars_program_subset_bound_vars_program :
  forall P,
    eassignables_subset (must_bound_vars_program P) (bound_vars_program P) = true.
Proof.
  prog_ind P Case; simpl; auto.

  { Case "KPassign".
    dest_cases w. }

  { Case "KPassignAny".
    dest_cases w. }

  { Case "KPchoice".
    apply implies_eassignables_subset_inter_l_true.
    left.
    apply implies_eassignables_subset_app_r_true.
    left; auto. }

  { Case "KPcompose".
    rewrite eassignables_subset_app_l_true_iff; dands;
      apply implies_eassignables_subset_app_r_true;[left|right]; auto. }

  { Case "KPloop".
    remember (bound_vars_program P) as e; destruct e; auto. }
Qed.

(** if states s1 and s2 are equal on EAssignables e1 and e2,
then they are equal in intersection of these EAssignables *)
Lemma implies_equal_states_on_ea_inter :
  forall (s1 s2 : state) (e1 e2 : EAssignables),
    (equal_states_on_ea s1 s2 e1 \/ equal_states_on_ea s1 s2 e2)
    -> equal_states_on_ea s1 s2 (EAssignables_inter e1 e2).
Proof.
  introv h i.
  apply in_eassignables_inter_iff in i; repnd.
  repndors;[apply h in i0|apply h in i]; auto.
Qed.

(** if EAassignables e1 and e2 are equal,
and all states s1 and s2 are equal on e1,
then all states s1 and s2 are equal on e2 *)
Lemma equal_states_on_ea_eassignables_eq :
  forall s1 s2 e1 e2,
    eassignables_eq e1 e2
    -> equal_states_on_ea s1 s2 e1
    -> equal_states_on_ea s1 s2 e2.
Proof.
  introv eqe eqs i.
  apply eqs.
  apply eqe; auto.
Qed.

(** two states equal on complement of EAssignables *)
Definition equal_states_on_complement
           (v w : state)
           (e : EAssignables) : Prop :=
  forall a : KAssignable,
    in_eassignables a e = false
    -> v a = w a.

Lemma in_ode_footprint_implies_in_bound_vars :
  forall a I ode,
    In a (ode_footprint I ode)
    -> in_eassignables a (bound_vars_ode ode) = true.
Proof.
  induction ode; introv i; simpl in *; tcsp.

  { destruct child; simpl in *; auto.
    dest_cases w. }

  { apply eqset_ode_footprint_prod in i.
    apply in_app_iff in i.
    apply in_eassignables_app_true_iff; tcsp. }
Qed.

(*
Lemma dynamic_semantics_ode_implies_eq_initial_state :
  forall ode I r phi x a,
    dynamic_semantics_ode I ode r phi
    -> in_eassignables a (bound_vars_ode ode) = false
    -> ~ In x (ode_footprint I ode)
    -> v x = phi 0%R x.
Proof.
  induction ode; introv d ia i; simpl in *.

  { destruct child; simpl in *; ginv.
    dest_cases w; GC.
    repeat (apply not_or in n; repnd).
    repeat (apply not_or in i; repnd).
    GC.
    apply d0; simpl; tcsp.
    intro xx; repndors; subst; tcsp.
    destruct xp; simpl in *; auto.
  }

  { rewrite (eqset_ode_footprint_prod I ode1 ode2 x) in i.
    rewrite in_app_iff in i.
    apply not_or in i; repnd.
    apply in_eassignables_app_false_implies in ia; repnd.
    eapply IHode1; eauto. }
Qed.
 *)

Lemma ode_footprint_diff_subset_ode_footprint :
  forall I ode,
    subset
      (ode_footprint_diff I ode)
      (ode_footprint I ode).
Proof.
  introv i.
  apply in_app_iff; auto.
Qed.

Lemma ode_footprint_vars_subset_ode_footprint :
  forall I ode,
    subset
      (ode_footprint_vars I ode)
      (ode_footprint I ode).
Proof.
  introv i.
  apply in_app_iff; auto.
Qed.

Lemma equal_states_on_vec_flatten_map :
  forall v w {n} (args : Vector.t Term n ) a,
    equal_states_on v w (vec_flatten (Vector.map free_vars_term args))
    -> Vector.In a args
    -> equal_states_on v w (free_vars_term a).
Proof.
  introv equ i j.
  apply equ.
  apply in_vec_flatten.
  exists (free_vars_term a); dands; auto.
  apply in_vec_map.
  exists a; dands; auto.
Qed.
Hint Resolve equal_states_on_vec_flatten_map : core.

Lemma subset_vec_flatten_map_lr :
  forall {A B} a {n} (v1 v2 : Vector.t A n) (F G : A -> list B),
    (forall m, m < n -> subset (F (vec_nth v1 m a)) (G (vec_nth v2 m a)))
    -> subset (vec_flatten (Vector.map F v1)) (vec_flatten (Vector.map G v2)).
Proof.
  induction n; introv.

  { apply Vector.case0 with (v := v1); simpl; clear v1; auto. }

  { apply (Vector.caseS' v1); introv; clear v1.
    apply (Vector.caseS' v2); introv; clear v2.
    simpl.
    intro hyp.
    apply implies_subset_app_lr.
    { apply (hyp 0); omega. }
    apply IHn; introv ltmn.
    apply (hyp (S m)); omega. }
Qed.

Lemma term_assignables_nodup_subset_free_vars_term :
  forall t,
    subset (term_assignables_nodup t) (free_vars_term t).
Proof.
  introv.
  unfold term_assignables_nodup.
  eapply subset_eqset_l;
    [|apply eqset_sym;apply remove_duplicates_eqset].
  apply subset_refl.
Qed.

Lemma implies_KD_in_map_prime_kassignable :
  forall a l,
    List.In a l
    -> List.In (KD a) (map KD l).
Proof.
  introv i.
  apply in_map_iff.
  eexists;dands;[|eauto]; auto.
Qed.

(******************************************************************************)

(* we needed this definition in order to prove Coincidence of formulas and programs *)
Definition KPtrue : Program := KPtest KFtrue.

(* we needed this definition in order to prove Coincidence of formulas and programs *)
Fixpoint KPcomposeN (P : Program) (n : nat) :=
  match n with
  | 0 => KPtrue
  | S n => KPcompose (KPcomposeN P n) P
  end.

(* we needed this lemma in order to prove Coincidence of formulas and programs *)
Lemma program_close_implies_all :
  forall P v w I,
    program_close (dynamic_semantics_program I P) v w
    <-> exists n, dynamic_semantics_program I (KPcomposeN P n) v w.
Proof.
  introv; split; introv h.

  {
    induction h.

    { exists 0%nat; simpl; dands; tcsp. }

    { exrepnd.
      exists (S n); simpl.
      exists s; dands; auto. }
  }

  {
    exrepnd.
    revert dependent w.
    induction n; simpl in *; introv h; repnd; subst.

    { apply program_close_refl. }

    { exrepnd.
      apply IHn in h1.
      eapply program_close_trans; eauto. }
  }
Qed.

Inductive ODEcontainsConst : ODE -> Prop :=
| ODEconstPrim :
    forall c,
      ODEcontainsConst (ODEconst c)
| ODEconstProdL :
    forall L R,
      ODEcontainsConst L
      -> ODEcontainsConst (ODEprod L R)
| ODEconstProdR :
    forall L R,
      ODEcontainsConst R
      -> ODEcontainsConst (ODEprod L R).
Hint Constructors ODEcontainsConst.

Lemma in_bound_vars_ode_prop1 :
  forall x I ode,
    in_eassignables x (bound_vars_ode ode) = true
    -> ~ In x (ode_footprint I ode)
    -> ODEcontainsConst ode.
Proof.
  induction ode; introv i ni; simpl in *; auto; tcsp.

  { destruct child; simpl in *; auto.
    dest_cases w; GC.
    repeat (apply not_or in ni; repnd; GC).
    repndors; subst; tcsp. }

  { rewrite (eqset_ode_footprint_prod I ode1 ode2 x) in ni.
    rewrite in_app_iff in ni.
    apply not_or in ni; repnd.
    apply in_eassignables_app_true_iff in i; repndors.

    { apply ODEconstProdL.
      apply IHode1; auto. }

    { apply ODEconstProdR.
      apply IHode2; auto. }
  }
Qed.

Lemma contains_const_implies_free_vars_ode_all :
  forall ode,
    ODEcontainsConst ode
    -> free_vars_ode ode = EA_all [].
Proof.
  induction ode; introv h; simpl in *; tcsp; try (complete (inversion h)).

  { destruct child; simpl in *; auto.
    inversion h. }

  { inversion h; subst.

    { autodimp IHode1 hyp.
      rewrite IHode1.
      apply EAssignables_app_all_left. }

    { autodimp IHode2 hyp.
      rewrite IHode2.
      apply EAssignables_app_all_right. }
  }
Qed.

Lemma eqset_ode_footprint_vars_prod :
  forall I ode1 ode2,
    eqset (ode_footprint_vars I (ODEprod ode1 ode2))
          (ode_footprint_vars I ode1 ++ ode_footprint_vars I ode2).
Proof.
  repeat introv.
  unfold ode_footprint_vars; simpl.
  allrw map_app.
  allrw in_app_iff.
  split; intro h; tcsp.
Qed.

Lemma subset_ode_footprint_vars_free_vars_ode :
  forall I ode,
    eassignables_subset
      (EA_assignables (ode_footprint_vars I ode))
      (free_vars_ode ode) = true.
Proof.
  induction ode; tcsp.

  { destruct child; simpl; auto.

    { apply disj_dec_prop.
      apply disjoint_sym; auto. }

    { dest_cases w. }
  }

  { rewrite eassignables_subset_iff in *; introv i; simpl in *.
    dest_cases w; ginv.
    apply eqset_ode_footprint_vars_prod in i0.
    apply in_eassignables_app_true_iff.
    apply in_app_iff in i0; repndors.

    { left.
      apply IHode1; dest_cases w. }

    { right.
      apply IHode2; dest_cases w. }
  }
Qed.

Definition upd_solution_at_list
           (phi : R -> state)
           (v   : state)
           (e   : EAssignables)
           (l   : list KAssignable): R -> state :=
  fun (r : R) (a : KAssignable) =>
    if in_dec KAssignable_dec a l
    then phi r a
    else
      if in_eassignables a e (* and (not?) (r = 0)? *)
      then phi r a
      else v a.

Lemma equal_states_on_ea_upd_solution_at_list :
  forall phi r v e d,
    equal_states_on_ea (phi r) (upd_solution_at_list phi v e d r) e.
Proof.
  introv i.
  unfold upd_solution_at_list; repeat (dest_cases w).
Qed.

(** returns all variables in Formula *)
Definition all_vars_formula (f : Formula) : EAssignables :=
  EAssignables_app (free_vars_formula f) (bound_vars_formula f).

(** returns all variables in Program *)
Definition all_vars_program (p : Program) : EAssignables :=
  EAssignables_app (free_vars_program p) (bound_vars_program p).

Lemma free_vars_program_eassignables_subset_all_vars_program :
  forall p, eassignables_subset (free_vars_program p) (all_vars_program p) = true.
Proof.
  introv; unfold all_vars_program.
  apply implies_eassignables_subset_app_r_true; left; eauto 2 with core.
Qed.
Hint Resolve free_vars_program_eassignables_subset_all_vars_program : core.


Require Import SyntaxProp.
Require Import StaticProp.
Require Import DynamicProp.
Require Import WellFormednessProp.

Lemma actor_progress :
  forall H n l L Q e id,
    wf_cfg (H, n) ->
    wf_actor H (l, L, Q, e) ->
    id < length H ->
    (exists H' n' e', id / (H, n) ; e ==> (H', n') ; e') \/ is_val e.
Proof with eauto using is_val, step_actor, is_econtext.
  introv wfCfg wfActor wfId.
  assert (exists t, empty |- e \in t) as [t hasType].
    inv wfActor...
  remember empty as Gamma.
  hasType_cases(induction hasType) Case; subst...
  + Case "T_Var".
    inv Hlookup.
  + Case "T_NewPassive".
    left. find_actor id...
  + Case "T_Mutate".
    apply wf_actor_ctx in wfActor...
    crush.
    - left. repeat constructors...
    - inv H0; inv hasType...
  + Case "T_Bestow".
    apply wf_actor_ctx in wfActor...
    crush.
    - left. repeat constructors...
    - inv H0; inv hasType...
  + Case "T_Apply".
    assert (wf_actor H (l, L, Q, e1)) as wfActor'.
    apply wf_actor_ctx with (ctx := ctx_appl e2)...
    crush.
    - left. apply EvalContext with (ctx := ctx_appl e2) in H0...
    - apply wf_actor_ctx
       with (ctx := ctx_appr e1)
         in wfActor as wfActor''...
      crush.
      * left. apply EvalContext with (ctx := ctx_appr e1) in H1...
      * inv H0; try solve[inv hasType1]...
        constructors...
  + Case "T_Send".
    eapply wf_actor_ctx
      with (ctx := ctx_send x TPas e')
        in wfActor as wfActor'...
    crush.
    - left. apply EvalContext with (ctx := ctx_send x TPas e') in H1...
    - unfold is_active in Hactive.
      destruct a; inv Hactive.
      * SCase "ActorSend".
        left. inv H1; try solve[inv hasType1]...
        inv wfActor'. simpls.
        assert (id0 < length H) as Hlt...
        find_actor id0...
      * SCase "BestowedSend".
        left. inv H1; try solve[inv hasType1]...
        inverts wfActor' as Hthis wfQueue Hex Hloc HId HBId.
        simpls.
        specializes HBId l0 id0 ___.
        inv HBId as (Hlt & Hloc')...
        find_actor id0...
Qed.

Theorem progress :
  forall H n id,
    wf_cfg (H, n) ->
    id < length H ->
    (exists cfg', step id (H, n) cfg') \/ actor_done (H, n) id.
Proof with eauto using step_preserves_this.
  introv wfCfg Hlt.
  find_actor id.
  assert (wf_actor H (l, L, Q, e)) as wfActor.
    inverts wfCfg as wfH. inverts wfH as [_ wfActors]...
  eapply actor_progress in wfCfg...
  inv wfCfg as [Hex | Hdone].
  + Case "e steps".
    left.
    inv Hex as [H' [n' [e' Hstep]]].
    assert (exists L' Q' e'', heapLookup H' id = Some (l, L', Q', e'')) as Hlookup'...
    destruct Hlookup' as [? [? [? ?]]].
    eapply EvalActorRun in Hstep...
  + Case "is_val e".
    destruct Q.
    - SCase "Q empty".
      right.
      unfolds. rewrite Hlookup.
      constructors...
    - SCase "Q non-empty".
      left.
      exists (heapUpdate H id (l, L, Q, EApp e0 (ELoc l)), n).
      constructors...
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A U P Aprime V : Universe, ((wd_ U A /\ (wd_ U Aprime /\ (wd_ U V /\ (wd_ Aprime V /\ (wd_ A V /\ (col_ U P Aprime /\ col_ Aprime U V)))))) -> col_ U V P)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import FOL Peano Tarski Deduction NumberTheory Synthetic Enumerability DecidabilityFacts Formulas Tennenbaum_diagonal Tennenbaum_insep Makholm McCarty Church Coding.

Notation "⊨ phi" := (forall rho, rho ⊨ phi) (at level 21).

(** * Variants of Tennenbaum's theorem *)

(*  Statements are formatted rougly as follows:

    Lemma Name (Parameters) :
      Logical Assumptions ->
      Assumptions about the Model ->
      other Assumptions ->
      Conclusion.
    Proof. [...] Qed.
 *)

Module T.
Section Variants.
Instance ff : falsity_flag := falsity_on.
Context {Δ1 : Delta1}.

Variable D : Type.
Variable I : interp D.
Variable axioms : forall ax, PA ax -> ⊨ ax.

Hypothesis ct : CT_Q.
Hypothesis delta1_definite : forall phi, delta1 phi -> Q ⊢I phi ∨ ¬ phi.
Definition obj_Insep := exists α β, def_obj_Insep α β.

Definition div e d := exists k : D, e i⊗ k = d.
Definition div_num n (d : D) := exists e, inu n i⊗ e = d.
Definition Div_nat (d : D) := fun n => div_num n d.
Definition div_pi ψ n a :=  (inu n .: (fun _ => a)) ⊨ (∃ (ψ ∧ ∃ $1 ⊗ $0 == $3)).
Definition prime_form ψ := bounded 2 ψ /\ (forall x, Q ⊢I ∀ ψ[up (num x)..] <--> $0 == num (Irred x) ).

(** CT_Q yields a formula for prime numbers. *)
Lemma Irred_repr :
  exists ψ, prime_form ψ.
Proof.
  destruct (ct Irred) as [phi Hphi].
  exists (∃ phi). split.
  - now constructor.
  - apply Hphi.
Qed.

Fact ψ_equiv n a ψ :
  prime_form ψ -> div_pi ψ n a <-> div_num (Irred n) a.
Proof.
  intros Hψ. unfold div_pi. cbn. split.
  - intros [d [->%ψ_repr H]]; auto.
  - intros. exists (inu (Irred n)). rewrite ψ_repr; auto.
Qed.

Fact MP_Discrete_stable_std :
  MP -> Discrete D -> Stable std.
Proof.
  intros mp [eq]%Discrete_sum e. unfold Stable.
  refine (MP_Dec_stable mp _ _).
  constructor. intros ?; apply eq.
Qed.

Fact stable_Std :
  Stable std -> stable (forall e, std e).
Proof.
  intros H h ?. apply H.
  now apply (DN_chaining h), DN.
Qed.

Lemma Dec_Div_nat_std ψ :
  prime_form ψ -> forall e, std e -> Dec (Div_nat e).
Proof.
  intros Hψ e [n <-].
  constructor; intros x.
  destruct n.
  - left. exists (inu 0).
    now rewrite mult_zero_r.
  - destruct (dec_eq_nat (Mod x (S n)) 0) as [h|nh].
    + left. apply Mod_divides in h.
      destruct h as [k ->].
      exists (inu k). now rewrite inu_mult_hom, mult_comm.
    + right. intros [K HK]. apply nh.
      enough (exists k, inu k = K) as [k <-].
      * apply Mod_divides. exists k.
        rewrite mult_comm, <-inu_mult_hom in HK; auto.
        now apply inu_inj in HK; auto.
      * eapply std_mult'; eauto.
Qed.

Lemma Dec_div_reduction d ψ :
  prime_form ψ -> Dec (Div_nat d) -> Dec (fun n => div_pi ψ n d).
Proof.
  intros Hψ [H].
  constructor. intros n.
  destruct (H (Irred n)) as [h|nh].
  + left. apply ψ_equiv; auto.
  + right. intros [k ]%ψ_equiv; auto. apply nh.
    now exists k.
Qed.

Fact Std_is_Enumerable :
  (forall e, std e) -> Enumerable D.
Proof.
  intros H.
  exists (fun n => Some (inu n)).
  intros d. destruct (H d) as [n <-]; eauto.
Qed.

(* ** Variants of Tennenbaum's Theorem *)

(** ** Tennenbaum via diagonal proof *)
Theorem Tennenbaum1 :
  MP ->
  Discrete D ->
  Enumerable D <-> forall e, std e.
Proof.
  intros mp eq.
  destruct Irred_repr as [ψ ]; auto.
  split.
  - intros ?.
    assert (~~ forall e, std e) as He.
    { eapply Tennenbaum_diagonal with (ψ0:=ψ); eauto. }
    intros e. apply MP_Discrete_stable_std; auto.
  - intros ?. now apply Std_is_Enumerable.
Qed.

(** ** Tennenbaum via inseparable formulas *)
Corollary Tennenbaum_insep :
  MP ->
  Discrete D ->
  (forall d, ~~Dec (Div_nat d)) -> (forall e, ~~std e).
Proof.
  intros mp eq DecDiv e He.
  destruct Irred_repr as [ψ ]; auto.
  eapply nonDecDiv; eauto.
  - apply CT_Inseparable; auto.
    + apply surj_form_.
    + apply enumerable_Q_prv.
  - now apply MP_Discrete_stable_std.
  - now exists e.
  - intros [d Hd]. apply (DecDiv d).
    intros h. apply Hd.
    now apply Dec_div_reduction.
Qed.

Theorem Tennenbaum2 :
  MP ->
  Discrete D ->
  (forall d, ~~Dec (Div_nat d)) <-> (forall e, std e).
Proof.
  destruct Irred_repr as [ψ ].
  intros mp eq. split.
  - intros ??. apply MP_Discrete_stable_std; auto.
    eapply Tennenbaum_insep; eauto.
  - intros ??. eapply DN, Dec_Div_nat_std; eauto.
Qed.

(** ** Makholm's Variant *)
Theorem Makholm :
  (exists ψ, prime_form ψ /\ (obj_Coding ψ)) -> obj_Insep ->
  nonStd D <-> exists d, ~ Dec (Div_nat d).
Proof.
  intros [ψ [H1 H2]] ?. split.
  - eapply Makholm; eauto.
  - intros [d Hd]. exists d.
  now intros ?%(Dec_Div_nat_std _ H1).
Qed.

Corollary Makholm' :
  (exists ψ, prime_form ψ /\ (obj_Coding ψ)) -> obj_Insep ->
  (forall e, ~~std e) <-> (forall d, ~~ Dec (Div_nat d)).
Proof.
  intros H1 H2.
  specialize (Makholm H1 H2) as [m1 m2].
  split.
  - intros H d nH. destruct m2 as [e He%H]; [now exists d | auto].
  - intros H d nH. destruct m1 as [e He%H]; [now exists d | auto].
Qed.

Lemma Tennenbaum3 :
  (exists ψ, prime_form ψ /\ (obj_Coding ψ)) -> obj_Insep ->
  (UC nat bool) -> ~ nonStd D.
Proof.
  intros ??? H.
  assert (nonStd D) as [e He]%Makholm by assumption; auto.
  refine (DN_Div_nat _ _ _ _ _ e _); auto.
Qed.

Lemma UC_Discrete :
  (forall X, UC X bool) -> Discrete D.
Proof.
  intros uc. unfold Discrete.
  apply UC_Def_Dec. apply uc.
  intros [x y]. destruct (@Peano.eq_dec D I axioms x y); now (left + right).
Qed.

(** ** McCarty's proof for the categoricity of HA. *)
Theorem McCarty :
  MP -> (forall X, UC X bool) ->
  (exists ψ, prime_form ψ /\ (obj_Coding ψ)) -> obj_Insep ->
  (forall e, std e).
Proof.
  intros ???? e.
  apply MP_Discrete_stable_std; auto.
  { now apply UC_Discrete. }
  intros He. apply Tennenbaum3; auto.
  now exists e.
Qed.

End Variants.
End T.

(*  Below, we list all major results again in a way that makes
    all their assumptions explicit.
 *)

Definition PA_model D I := forall ax, PA ax -> forall rho, @sat _ _ D I _ rho ax.

Theorem Tennenbaum2 {Δ1 : Delta1} D (I : interp D) :
 CT_Q -> MP ->
 PA_model D I -> Discrete D ->
 (forall d, ~~Dec(T.Div_nat D I d)) <-> (forall e, std e).
Proof.
  intros; now apply T.Tennenbaum2.
Qed.

Theorem Makholm  {Δ1 : Delta1} D (I : interp D) ψ :
  T.obj_Insep ->
  PA_model D I ->
  T.prime_form ψ /\ obj_Coding ψ ->
  nonStd D -> exists d, ~ Dec (T.Div_nat D I d).
Proof.
  intros; eapply T.Makholm; eauto.
Qed.

Theorem Makholm' {Δ1 : Delta1} D (I : interp D) ψ :
  T.obj_Insep ->
  PA_model D I ->
  T.prime_form ψ /\ obj_Coding ψ ->
  (forall e, ~~std e) <-> (forall d, ~~Dec (T.Div_nat D I d)).
Proof.
  intros; eapply T.Makholm'; eauto.
Qed.

Lemma Tennenbaum3 {Δ1 : Delta1} D (I : interp D) ψ :
  (UC nat bool) -> T.obj_Insep ->
  PA_model D I ->
  T.prime_form ψ /\ (obj_Coding ψ) ->
  ~ nonStd D.
Proof.
  intros; eapply T.Tennenbaum3; eauto.
Qed.

Theorem McCarty {Δ1 : Delta1} D (I : interp D) ψ :
  MP -> (forall X, UC X bool) ->
  PA_model D I ->
  T.prime_form ψ /\ obj_Coding ψ -> T.obj_Insep ->
  forall e, std e.
Proof.
  intros; eapply T.McCarty; eauto.
Qed.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import ZArith Reals.
From Flocq Require Import Raux.

Require Import Xreal.
Require Import Basic.
Require Import Interval.Interval.  (* for le_upper/lower, TODO PR: move them? *)

Variant fclass := Freal | Fnan | Fminfty | Fpinfty.  (* TODO PR: move? *)

Module Type FloatOps.

Parameter sensible_format : bool.

Parameter radix : radix.
Parameter type : Type.
Parameter toF : type -> float radix.

Definition toX x := FtoX (toF x).
Definition toR x := proj_val (toX x).

Parameter precision : Type.
Parameter sfactor : Type.
Parameter prec : precision -> positive.
Parameter PtoP : positive -> precision.
Parameter ZtoS : Z -> sfactor.
Parameter StoZ : sfactor -> Z.

Parameter incr_prec : precision -> positive -> precision.

Parameter zero : type.
Parameter one : type.
Parameter nan : type.

Parameter fromZ : Z -> type.
Parameter fromZ_DN : precision -> Z -> type.
Parameter fromZ_UP : precision -> Z -> type.

Parameter fromF : float radix -> type.
Parameter classify : type -> fclass.
Parameter real : type -> bool.
Parameter is_nan : type -> bool.
Parameter mag : type -> sfactor.
Parameter valid_ub : type -> bool.  (* valid upper bound (typically, not -oo) *)
Parameter valid_lb : type -> bool.  (* valid lower bound (typically, not +oo) *)

Parameter cmp : type -> type -> Xcomparison.
Parameter min : type -> type -> type.
Parameter max : type -> type -> type.
Parameter neg : type -> type.
Parameter abs : type -> type.
Parameter scale : type -> sfactor -> type.
Parameter div2 : type -> type.
Parameter add_UP : precision -> type -> type -> type.
Parameter add_DN : precision -> type -> type -> type.
Parameter sub_UP : precision -> type -> type -> type.
Parameter sub_DN : precision -> type -> type -> type.
Parameter mul_UP : precision -> type -> type -> type.
Parameter mul_DN : precision -> type -> type -> type.
Parameter div_UP : precision -> type -> type -> type.
Parameter div_DN : precision -> type -> type -> type.
Parameter sqrt_UP : precision -> type -> type.
Parameter sqrt_DN : precision -> type -> type.
Parameter nearbyint_UP : rounding_mode -> type -> type.
Parameter nearbyint_DN : rounding_mode -> type -> type.
Parameter midpoint : type -> type -> type.

Parameter zero_correct : toX zero = Xreal 0.
Parameter one_correct : toX one = Xreal 1.
Parameter nan_correct : classify nan = Fnan.

Parameter fromZ_correct :
  forall n,
  (Z.abs n <= 256)%Z ->
  toX (fromZ n) = Xreal (IZR n).

Parameter fromZ_DN_correct :
  forall p n,
  valid_lb (fromZ_DN p n) = true /\ le_lower (toX (fromZ_DN p n)) (Xreal (IZR n)).

Parameter fromZ_UP_correct :
  forall p n,
  valid_ub (fromZ_UP p n) = true /\ le_upper (Xreal (IZR n)) (toX (fromZ_UP p n)).

Parameter classify_correct :
  forall f, real f = match classify f with Freal => true | _ => false end.

Parameter real_correct :
  forall f, real f = match toX f with Xnan => false | _ => true end.

Parameter is_nan_correct :
  forall f, is_nan f = match classify f with Fnan => true | _ => false end.

Parameter valid_lb_correct :
  forall f, valid_lb f = match classify f with Fpinfty => false | _ => true end.

Parameter valid_ub_correct :
  forall f, valid_ub f = match classify f with Fminfty => false | _ => true end.

Parameter cmp_correct :
  forall x y,
  cmp x y =
  match classify x, classify y with
  | Fnan, _ | _, Fnan => Xund
  | Fminfty, Fminfty => Xeq
  | Fminfty, _ => Xlt
  | _, Fminfty => Xgt
  | Fpinfty, Fpinfty => Xeq
  | _, Fpinfty => Xlt
  | Fpinfty, _ => Xgt
  | Freal, Freal => Xcmp (toX x) (toX y)
  end.

Parameter min_correct :
  forall x y,
  match classify x, classify y with
  | Fnan, _ | _, Fnan => classify (min x y) = Fnan
  | Fminfty, _ | _, Fminfty => classify (min x y) = Fminfty
  | Fpinfty, _ => min x y = y
  | _, Fpinfty => min x y = x
  | Freal, Freal => toX (min x y) = Xmin (toX x) (toX y)
  end.

Parameter max_correct :
  forall x y,
  match classify x, classify y with
  | Fnan, _ | _, Fnan => classify (max x y) = Fnan
  | Fpinfty, _ | _, Fpinfty => classify (max x y) = Fpinfty
  | Fminfty, _ => max x y = y
  | _, Fminfty => max x y = x
  | Freal, Freal => toX (max x y) = Xmax (toX x) (toX y)
  end.

Parameter neg_correct :
  forall x,
  match classify x with
  | Freal => toX (neg x) = Xneg (toX x)
  | Fnan => classify (neg x) = Fnan
  | Fminfty => classify (neg x) = Fpinfty
  | Fpinfty => classify (neg x) = Fminfty
  end.

Parameter abs_correct :
  forall x, toX (abs x) = Xabs (toX x) /\ (valid_ub (abs x) = true).

Parameter div2_correct :
  forall x, sensible_format = true ->
  (1 / 256 <= Rabs (toR x))%R ->
  toX (div2 x) = Xdiv (toX x) (Xreal 2).

Parameter add_UP_correct :
  forall p x y, valid_ub x = true -> valid_ub y = true
    -> (valid_ub (add_UP p x y) = true
       /\ le_upper (Xadd (toX x) (toX y)) (toX (add_UP p x y))).

Parameter add_DN_correct :
  forall p x y, valid_lb x = true -> valid_lb y = true
    -> (valid_lb (add_DN p x y) = true
       /\ le_lower (toX (add_DN p x y)) (Xadd (toX x) (toX y))).

Parameter sub_UP_correct :
  forall p x y, valid_ub x = true -> valid_lb y = true
    -> (valid_ub (sub_UP p x y) = true
       /\ le_upper (Xsub (toX x) (toX y)) (toX (sub_UP p x y))).

Parameter sub_DN_correct :
  forall p x y, valid_lb x = true -> valid_ub y = true
    -> (valid_lb (sub_DN p x y) = true
       /\ le_lower (toX (sub_DN p x y)) (Xsub (toX x) (toX y))).

Definition is_non_neg x :=
  valid_ub x = true
  /\ match toX x with Xnan => True | Xreal r => (0 <= r)%R end.

Definition is_pos x :=
  valid_ub x = true
  /\ match toX x with Xnan => True | Xreal r => (0 < r)%R end.

Definition is_non_pos x :=
  valid_lb x = true
  /\ match toX x with Xnan => True | Xreal r => (r <= 0)%R end.

Definition is_neg x :=
  valid_lb x = true
  /\ match toX x with Xnan => True | Xreal r => (r < 0)%R end.

Definition is_non_neg_real x :=
  match toX x with Xnan => False | Xreal r => (0 <= r)%R end.

Definition is_pos_real x :=
  match toX x with Xnan => False | Xreal r => (0 < r)%R end.

Definition is_non_pos_real x :=
  match toX x with Xnan => False | Xreal r => (r <= 0)%R end.

Definition is_neg_real x :=
  match toX x with Xnan => False | Xreal r => (r < 0)%R end.

Parameter mul_UP_correct :
  forall p x y,
    ((is_non_neg x /\ is_non_neg y)
     \/ (is_non_pos x /\ is_non_pos y)
     \/ (is_non_pos_real x /\ is_non_neg_real y)
     \/ (is_non_neg_real x /\ is_non_pos_real y))
    -> (valid_ub (mul_UP p x y) = true
        /\ le_upper (Xmul (toX x) (toX y)) (toX (mul_UP p x y))).

Parameter mul_DN_correct :
  forall p x y,
    ((is_non_neg_real x /\ is_non_neg_real y)
     \/ (is_non_pos_real x /\ is_non_pos_real y)
     \/ (is_non_neg x /\ is_non_pos y)
     \/ (is_non_pos x /\ is_non_neg y))
    -> (valid_lb (mul_DN p x y) = true
        /\ le_lower (toX (mul_DN p x y)) (Xmul (toX x) (toX y))).

Parameter div_UP_correct :
  forall p x y,
    ((is_non_neg x /\ is_pos_real y)
     \/ (is_non_pos x /\ is_neg_real y)
     \/ (is_non_neg_real x /\ is_neg_real y)
     \/ (is_non_pos_real x /\ is_pos_real y))
    -> (valid_ub (div_UP p x y) = true
        /\ le_upper (Xdiv (toX x) (toX y)) (toX (div_UP p x y))).

Parameter div_DN_correct :
  forall p x y,
    ((is_non_neg x /\ is_neg_real y)
     \/ (is_non_pos x /\ is_pos_real y)
     \/ (is_non_neg_real x /\ is_pos_real y)
     \/ (is_non_pos_real x /\ is_neg_real y))
    -> (valid_lb (div_DN p x y) = true
        /\ le_lower (toX (div_DN p x y)) (Xdiv (toX x) (toX y))).

Parameter sqrt_UP_correct :
  forall p x,
  valid_ub (sqrt_UP p x) = true
  /\ le_upper (Xsqrt (toX x)) (toX (sqrt_UP p x)).

Parameter sqrt_DN_correct :
  forall p x,
    valid_lb x = true
    -> (valid_lb (sqrt_DN p x) = true
        /\ le_lower (toX (sqrt_DN p x)) (Xsqrt (toX x))).

Parameter nearbyint_UP_correct :
  forall mode x,
  valid_ub (nearbyint_UP mode x) = true
  /\ le_upper (Xnearbyint mode (toX x)) (toX (nearbyint_UP mode x)).

Parameter nearbyint_DN_correct :
  forall mode x,
  valid_lb (nearbyint_DN mode x) = true
  /\ le_lower (toX (nearbyint_DN mode x)) (Xnearbyint mode (toX x)).

Parameter midpoint_correct :
  forall x y,
  sensible_format = true ->
  real x = true -> real y = true -> (toR x <= toR y)%R
  -> real (midpoint x y) = true /\ (toR x <= toR (midpoint x y) <= toR y)%R.

End FloatOps.

Module FloatExt (F : FloatOps).

Lemma valid_lb_real f : F.real f = true -> F.valid_lb f = true.
Proof.
generalize (F.valid_lb_correct f).
generalize (F.classify_correct f).
now case F.classify; try easy; intro H; rewrite H.
Qed.

Lemma valid_ub_real f : F.real f = true -> F.valid_ub f = true.
Proof.
generalize (F.valid_ub_correct f).
generalize (F.classify_correct f).
now case F.classify; try easy; intro H; rewrite H.
Qed.

Lemma valid_lb_nan : F.valid_lb F.nan = true.
Proof.
generalize F.nan_correct.
generalize (F.valid_lb_correct F.nan).
now case F.classify.
Qed.

Lemma valid_ub_nan : F.valid_ub F.nan = true.
Proof.
generalize F.nan_correct.
generalize (F.valid_ub_correct F.nan).
now case F.classify.
Qed.

Lemma valid_lb_zero : F.valid_lb F.zero = true.
Proof.
generalize (F.valid_lb_correct F.zero).
generalize (F.classify_correct F.zero).
rewrite F.real_correct, F.zero_correct.
now case F.classify.
Qed.

Lemma valid_ub_zero : F.valid_ub F.zero = true.
Proof.
generalize (F.valid_ub_correct F.zero).
generalize (F.classify_correct F.zero).
rewrite F.real_correct, F.zero_correct.
now case F.classify.
Qed.

Lemma valid_lb_one : F.valid_lb F.one = true.
Proof.
generalize (F.classify_correct F.one).
rewrite F.valid_lb_correct, F.real_correct, F.one_correct.
now case F.classify.
Qed.

Lemma valid_ub_one : F.valid_ub F.one = true.
Proof.
generalize (F.classify_correct F.one).
rewrite F.valid_ub_correct, F.real_correct, F.one_correct.
now case F.classify.
Qed.

Lemma nan_correct : F.toX F.nan = Xnan.
Proof.
generalize (F.classify_correct F.nan).
generalize F.nan_correct.
case F.classify; [easy|intros _|easy..].
generalize (F.real_correct F.nan).
now case F.toX; [|intros r H; rewrite H].
Qed.

Lemma is_nan_nan : F.is_nan F.nan = true.
Proof. now rewrite F.is_nan_correct, F.nan_correct. Qed.

Lemma neg_correct x : F.toX (F.neg x) = Xneg (F.toX x).
Proof.
generalize (F.real_correct x).
generalize (F.real_correct (F.neg x)).
generalize (F.neg_correct x).
rewrite !F.classify_correct.
case F.classify; intro Hx; rewrite Hx; [|now case F.toX, F.toX..].
now case F.toX; [easy|]; intros rx; simpl; case F.classify.
Qed.

Lemma valid_lb_neg x : F.valid_lb (F.neg x) = F.valid_ub x.
Proof.
generalize (F.real_correct x).
generalize (F.real_correct (F.neg x)).
generalize (F.neg_correct x).
rewrite !F.classify_correct, !F.valid_lb_correct, !F.valid_ub_correct.
case F.classify; intro Hx; rewrite Hx; [|now case F.toX, F.toX..].
now case F.toX; [easy|]; intros rx; simpl; case F.classify.
Qed.

Lemma valid_ub_neg x : F.valid_ub (F.neg x) = F.valid_lb x.
Proof.
generalize (F.real_correct x).
generalize (F.real_correct (F.neg x)).
generalize (F.neg_correct x).
rewrite !F.classify_correct, !F.valid_lb_correct, !F.valid_ub_correct.
case F.classify; intro Hx; rewrite Hx; [|now case F.toX, F.toX..].
now case F.toX; [easy|]; intros rx; simpl; case F.classify.
Qed.

Lemma real_neg x : F.real (F.neg x) = F.real x.
Proof. now rewrite !F.real_correct, neg_correct; case F.toX. Qed.

Lemma is_nan_neg x : F.is_nan (F.neg x) = F.is_nan x.
Proof.
rewrite !F.is_nan_correct.
generalize (F.neg_correct x).
case_eq (F.classify x); [|now intros _ H; rewrite H..].
intro Hx.
generalize (F.classify_correct x); rewrite Hx, F.real_correct.
case F.toX; [easy|]; intros rx _.
generalize (F.classify_correct (F.neg x)).
rewrite F.real_correct.
case F.toX; [easy|]; intros rnx.
now case F.classify.
Qed.

Definition cmp x y:=
  if F.real x then
    if F.real y then
      F.cmp x y
    else Xund
  else Xund.

Lemma cmp_correct :
  forall x y,
  cmp x y = Xcmp (F.toX x) (F.toX y).
Proof.
intros x y.
unfold cmp.
rewrite !F.classify_correct, F.cmp_correct.
generalize (F.classify_correct x).
generalize (F.classify_correct y).
rewrite !F.real_correct.
now case (F.classify x), (F.classify y), (F.toX x), (F.toX y).
Qed.

Definition le' x y :=
  match cmp x y with
  | Xlt | Xeq => true
  | Xgt | Xund => false
  end.

Lemma le'_correct :
  forall x y,
  le' x y = true ->
  match F.toX x, F.toX y with
  | Xreal xr, Xreal yr => (xr <= yr)%R
  | _, _ => False
  end.
Proof.
intros x y.
unfold le'.
rewrite cmp_correct.
destruct F.toX as [|xr]. easy.
destruct F.toX as [|yr]. easy.
simpl.
now case Raux.Rcompare_spec ; auto with real.
Qed.

Definition lt' x y :=
  match cmp x y with
  | Xlt  => true
  | _ => false
  end.

Lemma lt'_correct :
  forall x y,
  lt' x y = true ->
  match F.toX x, F.toX y with
  | Xreal xr, Xreal yr => (xr < yr)%R
  | _, _ => False
  end.
Proof.
intros x y.
unfold lt'.
rewrite cmp_correct.
destruct F.toX as [|xr]. easy.
destruct F.toX as [|yr]. easy.
simpl.
now case Raux.Rcompare_spec.
Qed.

Definition le x y :=
  match F.cmp x y with
  | Xgt => false
  | _ => true
  end.

Lemma le_correct :
  forall x y,
  F.toX x = Xreal (F.toR x) ->
  F.toX y = Xreal (F.toR y) ->
  le x y = Rle_bool (F.toR x) (F.toR y).
Proof.
intros x y Rx Ry.
unfold le.
rewrite F.cmp_correct.
generalize (F.classify_correct x).
generalize (F.classify_correct y).
rewrite !F.real_correct, Rx, Ry.
do 2 (case F.classify; [|easy..]; intros _).
simpl.
unfold Rle_bool.
now case Rcompare.
Qed.

Definition lt x y :=
  match F.cmp x y with
  | Xlt  => true
  | _ => false
  end.

Lemma lt_correct :
  forall x y,
  F.toX x = Xreal (F.toR x) ->
  F.toX y = Xreal (F.toR y) ->
  lt x y = Rlt_bool (F.toR x) (F.toR y).
Proof.
intros x y Rx Ry.
unfold lt.
rewrite F.cmp_correct.
generalize (F.classify_correct x).
generalize (F.classify_correct y).
rewrite !F.real_correct, Rx, Ry.
do 2 (case F.classify; [|easy..]; intros _).
simpl.
unfold Rlt_bool.
now case Rcompare.
Qed.

Lemma real_correct :
  forall x,
  F.real x = true ->
  F.toX x = Xreal (F.toR x).
Proof.
intros x Rx.
rewrite F.real_correct in Rx.
unfold F.toR.
now destruct F.toX as [|rx].
Qed.

Inductive toX_prop (x : F.type) : ExtendedR -> Prop :=
  | toX_Xnan : toX_prop x Xnan
  | toX_Xreal : F.toX x = Xreal (F.toR x) -> toX_prop x (Xreal (F.toR x)).

Lemma toX_spec :
  forall x, toX_prop x (F.toX x).
Proof.
intros x.
case_eq (F.toX x).
intros _.
apply toX_Xnan.
intros r H.
change r with (proj_val (Xreal r)).
rewrite <- H.
apply toX_Xreal.
unfold F.toR.
now rewrite H at 2.
Qed.

Lemma classify_zero : F.classify F.zero = Freal.
Proof.
generalize (F.classify_correct F.zero).
rewrite F.real_correct, F.zero_correct.
now case F.classify.
Qed.

Lemma min_valid_lb x y :
  F.valid_lb x = true -> F.valid_lb y = true ->
  (F.valid_lb (F.min x y) = true
   /\ F.toX (F.min x y) = Xmin (F.toX x) (F.toX y)).
Proof.
rewrite !F.valid_lb_correct.
generalize (F.min_correct x y).
generalize (F.classify_correct x) ; rewrite F.real_correct ;
case_eq (F.classify x); intro Cx ; [..|easy] ;
  [case_eq (F.toX x); [easy|] ; intros rx Hx _
  |case_eq (F.toX x); [|easy] ; intros Hx _..] ;
  ( generalize (F.classify_correct y) ; rewrite F.real_correct ;
    case_eq (F.classify y); intro Cy ; [..|easy] ;
      [case_eq (F.toX y); [easy|] ; intros ry Hy _
      |case_eq (F.toX y); [|easy] ; intros Hy _..] ) ;
  intros Hmin _ _ ;
  generalize (F.classify_correct (F.min x y)) ; rewrite F.real_correct ;
  rewrite Hmin ;
  simpl ;
  rewrite ?Cx, ?Cy ;
  rewrite ?Hx, ?Hy ;
  [case F.classify ; easy|..] ;
  now case F.toX.
Qed.

Lemma max_valid_ub x y :
  F.valid_ub x = true -> F.valid_ub y = true ->
  (F.valid_ub (F.max x y) = true
   /\ F.toX (F.max x y) = Xmax (F.toX x) (F.toX y)).
Proof.
rewrite !F.valid_ub_correct.
generalize (F.max_correct x y).
generalize (F.classify_correct x) ; rewrite F.real_correct ;
case_eq (F.classify x); intro Cx ; [..|easy|] ;
  [case_eq (F.toX x); [easy|] ; intros rx Hx _
  |case_eq (F.toX x); [|easy] ; intros Hx _..] ;
  ( generalize (F.classify_correct y) ; rewrite F.real_correct ;
    case_eq (F.classify y); intro Cy ; [..|easy|] ;
      [case_eq (F.toX y); [easy|] ; intros ry Hy _
      |case_eq (F.toX y); [|easy] ; intros Hy _..] ) ;
  intros Hmax _ _ ;
  generalize (F.classify_correct (F.max x y)) ; rewrite F.real_correct ;
  rewrite Hmax ;
  simpl ;
  rewrite ?Cx, ?Cy ;
  rewrite ?Hx, ?Hy ;
  [case F.classify ; easy|..] ;
  now case F.toX.
Qed.

End FloatExt.


Require Import
        Essentials.Types.
Require Import Metrics.Mappings.
Require Import Metrics.Complete_UltraMetric.
Require Import Metrics.CBULt.Product.
Require Import Categories.Category.Main.

Section MCat.
  Context {L : MLattice}.

  (** An M-category is a category where each hom-set forms a complete
ultra metric space and composition function is non-expansive (where the
domain of composition is the product of complete ultra metric spaces).

In addition, an M-category must have a terminal object.
 *)
  Record MCat : Type :=
    {
      MC_Obj : Type;
      MC_Hom : MC_Obj → MC_Obj → (Complete_UltraMetric L);
      MC_compose :
        ∀ {a b c : MC_Obj},
          NonExpansive
            (product_CUM (MC_Hom a b) (MC_Hom b c))
            (MC_Hom a c)
      where "g ∘ f" := (MC_compose (f, g));
      MC_assoc :
        ∀ (a b c d : MC_Obj)
          (f : MC_Hom a b)
          (g : MC_Hom b c)
          (h : MC_Hom c d),
          (h ∘ g) ∘ f = h ∘ (g ∘ f);
      MC_assoc_sym :
        ∀ (a b c d : MC_Obj)
          (f : MC_Hom a b)
          (g : MC_Hom b c)
          (h : MC_Hom c d),
          h ∘ (g ∘ f) = (h ∘ g) ∘ f;
      MC_id : ∀ {a : MC_Obj}, MC_Hom a a;
      MC_id_unit_left :
        ∀ (a b : MC_Obj)
          (h : MC_Hom a b),
          MC_id ∘ h = h;
      MC_id_unit_right :
        ∀ (a b : MC_Obj)
          (h : MC_Hom a b),
          h ∘ MC_id = h;
      MC_Cat :> Category :=
        {|
          Obj := MC_Obj;
          Hom := MC_Hom;
          compose := fun _ _ _ x y => MC_compose (x, y);
          assoc := MC_assoc;
          assoc_sym := MC_assoc_sym;
          id := @MC_id;
          id_unit_left := MC_id_unit_left;
          id_unit_right := MC_id_unit_right
        |}
    }.

End MCat.

Arguments MCat _ : clear implicits.

Section NonExpansive_Compose_left.
  Context {L : MLattice} (M : MCat L) {a b c : M} (f : MC_Hom M a b).

  Program Definition NonExpansive_Compose_left :
    NonExpansive (MC_Hom M b c) (MC_Hom M a c)
    :=
    {|
      NE_fun := fun u : MC_Hom M b c => MC_compose M (f, u)
    |}.

  Next Obligation.
  Proof.
    eapply PO_Trans; [apply NE_non_expansive|].
    cbn.
    rewrite UM_eq_zero_dist.
    rewrite lub_sym.
    rewrite lub_bot.
    trivial.
  Qed.

End NonExpansive_Compose_left.

Section NonExpansive_Compose_right.
  Context {L : MLattice} (M : MCat L) {a b c : M} (g : MC_Hom M b c).

  Program Definition NonExpansive_Compose_right :
    NonExpansive (MC_Hom M a b) (MC_Hom M a c)
    :=
    {|
      NE_fun := fun u : MC_Hom M a b => MC_compose M (u, g)
    |}.

  Next Obligation.
  Proof.
    eapply PO_Trans; [apply NE_non_expansive|].
    cbn.
    rewrite UM_eq_zero_dist.
    rewrite lub_bot.
    trivial.
  Qed.

End NonExpansive_Compose_right.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                               liveness.v                                 *)
(****************************************************************************)

Section liveness.

Require Export card_facts.
Require Export parameters_card.
Require Export safe_card.
Require Export fairstr.
Require Export notacc_white_nogrey.
Require Export notacc_black_nogrey.
Require Export notacc_init.
Require Export notacc_white_ancestor.
Require Export until_zero.
Require Export LTL.

Notation Trace := (trace (fun (a : label) (s t : state) => transition s t a))
  (only parsing).
Notation Stream_formula := (stream_formula state) (only parsing).
Notation Stream := (stream state) (only parsing).
Notation Strong_fairstr :=
  (strong_fairstr (fun (a : label) (s t : state) => transition s t a) fair)
  (only parsing).
Notation Run :=
  (run init_state (fun (a : label) (s t : state) => transition s t a))
  (only parsing).
Notation Safe :=
  (safe init_state (fun (a : label) (s t : state) => transition s t a))
  (only parsing).

Definition and_inv : stream_formula state :=
  and (state2stream_formula (fun s : state => sweep_no_greys s))
    (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s)).

Lemma safe_inv_and_gwb :
 safe init_state (fun (a : label) (s t : state) => transition s t a)
   (and and_inv g_w_b).

unfold safe in |- *; intros str H_run.
apply and_always; eauto.
unfold and_inv in |- *; apply and_always; eauto.
Qed.

Hint Resolve safe_inv_and_gwb.

Lemma safe_inv_gwb_mesure :
 safe init_state (fun (a : label) (s t : state) => transition s t a)
   (and (and and_inv g_w_b)
      (state2stream_formula
         (fun s : state => exists nb : nat, mesure (mk s) nb))).

unfold safe in |- *; intros str H_run.
apply and_always; eauto.
Qed.

Hint Resolve safe_inv_gwb_mesure.

Lemma always_and_inv_g_w_b :
 forall str : stream state,
 always
   (and (and and_inv g_w_b)
      (state2stream_formula
         (fun s : state => exists nb : nat, mesure (mk s) nb))) str ->
 always (state2stream_formula (fun s : state => sweep_no_greys s)) str /\
 always (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s))
   str /\
 always
   (state2stream_formula
      (fun s : state => exists w : nat, card_color white (mk s) w)) str /\
 always
   (state2stream_formula
      (fun s : state => exists g : nat, card_color grey (mk s) g)) str /\
 always
   (state2stream_formula (fun s : state => exists nb : nat, mesure (mk s) nb))
   str.

unfold and_inv in |- *; unfold g_w_b in |- *;
 intros str H_always_inv_gwb_mesure.
cut
 (always
    (and
       (and (state2stream_formula (fun s : state => sweep_no_greys s))
          (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s)))
       (and
          (state2stream_formula
             (fun s : state => exists g : nat, card_color grey (mk s) g))
          (and
             (state2stream_formula
                (fun s : state => exists b : nat, card_color black (mk s) b))
             (state2stream_formula
                (fun s : state => exists w : nat, card_color white (mk s) w)))))
    str).
intro H_always; split.
cut
 (always
    (and (state2stream_formula (fun s : state => sweep_no_greys s))
       (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s)))
    str).
intro H_always_inv.
apply
 always_and
  with
    (Q := state2stream_formula (fun s : state => nogrey_accn_imp_blackn s));
 assumption.
apply
 always_and
  with
    (Q := and
            (state2stream_formula
               (fun s : state => exists g : nat, card_color grey (mk s) g))
            (and
               (state2stream_formula
                  (fun s : state => exists b : nat, card_color black (mk s) b))
               (state2stream_formula
                  (fun s : state => exists w : nat, card_color white (mk s) w))));
 assumption.
split.
cut
 (always
    (and (state2stream_formula (fun s : state => sweep_no_greys s))
       (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s)))
    str).
intro H_always_inv.
apply
 always_and_bis
  with (P := state2stream_formula (fun s : state => sweep_no_greys s));
 assumption.
apply
 always_and
  with
    (Q := and
            (state2stream_formula
               (fun s : state => exists g : nat, card_color grey (mk s) g))
            (and
               (state2stream_formula
                  (fun s : state => exists b : nat, card_color black (mk s) b))
               (state2stream_formula
                  (fun s : state => exists w : nat, card_color white (mk s) w))));
 assumption.
split;
 cut
  (always
     (and
        (state2stream_formula
           (fun s : state => exists g : nat, card_color grey (mk s) g))
        (and
           (state2stream_formula
              (fun s : state => exists b : nat, card_color black (mk s) b))
           (state2stream_formula
              (fun s : state => exists w : nat, card_color white (mk s) w))))
     str).
intro H_always_gwb.
cut
 (always
    (and
       (state2stream_formula
          (fun s : state => exists b : nat, card_color black (mk s) b))
       (state2stream_formula
          (fun s : state => exists w : nat, card_color white (mk s) w))) str).
intro H_always_and.
apply
 always_and_bis
  with
    (P := state2stream_formula
            (fun s : state => exists b : nat, card_color black (mk s) b));
 assumption.
apply
 always_and_bis
  with
    (P := state2stream_formula
            (fun s : state => exists g : nat, card_color grey (mk s) g));
 assumption.
apply
 always_and_bis
  with
    (P := and (state2stream_formula (fun s : state => sweep_no_greys s))
            (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s)));
 assumption.
intro H_always_and.
split.
apply
 always_and
  with
    (Q := and
            (state2stream_formula
               (fun s : state => exists b : nat, card_color black (mk s) b))
            (state2stream_formula
               (fun s : state => exists w : nat, card_color white (mk s) w)));
 assumption.
apply
 always_and_bis
  with
    (P := and
            (and (state2stream_formula (fun s : state => sweep_no_greys s))
               (state2stream_formula
                  (fun s : state => nogrey_accn_imp_blackn s)))
            (and
               (state2stream_formula
                  (fun s : state => exists g : nat, card_color grey (mk s) g))
               (and
                  (state2stream_formula
                     (fun s : state =>
                      exists b : nat, card_color black (mk s) b))
                  (state2stream_formula
                     (fun s : state =>
                      exists w : nat, card_color white (mk s) w)))));
 assumption.
apply
 always_and_bis
  with
    (P := and (state2stream_formula (fun s : state => sweep_no_greys s))
            (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s)));
 assumption.
apply
 always_and
  with
    (Q := state2stream_formula
            (fun s : state => exists nb : nat, mesure (mk s) nb));
 assumption.
Qed.

Hint Resolve always_and_inv_g_w_b.

Lemma run_fairstr_always :
 forall P : stream_formula state,
 (forall str : stream state,
  trace (fun (a : label) (s t : state) => transition s t a) str ->
  strong_fairstr (fun (a : label) (s t : state) => transition s t a) fair str ->
  always
    (and (and and_inv g_w_b)
       (state2stream_formula
          (fun s : state => exists nb : nat, mesure (mk s) nb))) str ->
  P str) ->
 forall str : stream state,
 run init_state (fun (a : label) (s t : state) => transition s t a) str ->
 strong_fairstr (fun (a : label) (s t : state) => transition s t a) fair str ->
 always P str.

unfold strong_fairstr in |- *; unfold infinitely_often in |- *; intros P H.
intros str H_run H_always.
apply
 always_on_run
  with
    (label := label)
    (init_state := init_state)
    (transition := fun (a : label) (s t : state) => transition s t a)
    (F := Eventually
            (fun str' : stream state =>
             fair_step (fun (a : label) (s t : state) => transition s t a)
               fair (head_str str') (head_str (tl_str str'))))
    (I := and (and and_inv g_w_b)
            (state2stream_formula
               (fun s : state => exists nb : nat, mesure (mk s) nb)));
 eauto.
Qed.

Lemma card_grey_rt :
 forall s : state,
 (forall n : node, n <> rt -> mk s n = white \/ mk s n = free) ->
 mk s rt = grey -> card_color grey (mk s) 1.

intros s H_col mksrt; elim (exist_updated node color black (mk s) rt).
intros mk' mark; elim mark; clear mark.
intros mark' mk'rt.
unfold card_color in |- *; apply card_S with (M1 := mk') (a0 := rt); auto.
constructor; intro n; elim (eq_dec_node n rt).
intro neqrt; rewrite neqrt; rewrite mk'rt; discriminate.
intro ndifrt; rewrite <- (mark' n ndifrt).
elim (H_col n ndifrt); intro mksn; rewrite mksn; discriminate.
symmetry  in |- *; apply mark'; auto.
rewrite mk'rt; discriminate.
Qed.

Lemma def_equiv :
 forall (n : node) (str : stream state),
 notacc_white_init_formula n str -> notacc_white_exgrey_reach_formula n str.

intros n str H; elim H; clear H.
intros notacc_n H; elim H; clear H.
intros mkhn H; elim H; clear H.
intros mkhrt H_n; split; auto.
split; auto.
split.
exists 1; split; auto.
apply card_grey_rt; auto.
intros m H_reach; apply H_n.
intro meqrt; absurd (accessible node (hp (head_str str)) rt n); auto.
replace (accessible node (hp (head_str str)) rt n) with
 (reachable node (hp (head_str str)) rt n); auto.
rewrite <- meqrt; assumption.
Qed.

Hint Resolve def_equiv.

Lemma liveness :
 forall str : stream state,
 run init_state (fun (a : label) (s t : state) => transition s t a) str ->
 strong_fairstr (fun (a : label) (s t : state) => transition s t a) fair str ->
 forall n : node,
 is_always_followed
   (state2stream_formula (fun s : state => ~ accessible node (hp s) rt n))
   (state2stream_formula (fun s : state => mk s n = free)) str.

unfold is_always_followed in |- *; intros str H_run H_fairstr n.
apply run_fairstr_always; try assumption.
clear H_run H_fairstr str; intros str H_trace H_fairstr always_inv_gwb.
unfold is_followed in |- *.
cut
 (always (state2stream_formula (fun s : state => sweep_no_greys s)) str /\
  always (state2stream_formula (fun s : state => nogrey_accn_imp_blackn s))
    str /\
  always
    (state2stream_formula
       (fun s : state => exists w : nat, card_color white (mk s) w)) str /\
  always
    (state2stream_formula
       (fun s : state => exists g : nat, card_color grey (mk s) g)) str /\
  always
    (state2stream_formula
       (fun s : state => exists nb : nat, mesure (mk s) nb)) str);
 eauto.
intro H; elim H; clear H.
intros H_always_sweep H; elim H; clear H.
intros H_always_inv H; elim H; clear H.
intros H_always_white H; elim H; clear H.
intros H_always_grey H_always_mesure.
cut
 (always
    (Eventually
       (state2stream_formula (fun s : state => card_color white (mk s) 0)))
    str);
 [ intro H_alw_ev_white
 | apply always_eventually_white_until_zero_trace; auto ].
cut
 (always
    (Eventually
       (state2stream_formula (fun s : state => card_color grey (mk s) 0)))
    str);
 [ intro H_alw_ev_grey
 | apply always_eventually_grey_until_zero_trace; auto ].
2: apply strong_fairstr_implies_fairstr; assumption.
2: apply strong_fairstr_implies_fairstr; assumption.
intro notacc_n;
 cut
  (until
     (state2stream_formula (fun s : state => ~ accessible node (hp s) rt n))
     (free_or_notfree_notacc_nogrey n) str).

(*  (A n str)U(B n str)-> (D n str)*)
intro H_until.
generalize H_alw_ev_grey H_alw_ev_white H_always_mesure H_always_grey
 H_always_white H_always_inv H_always_sweep H_fairstr H_trace.
clear H_alw_ev_grey H_alw_ev_white H_always_mesure H_always_grey
 H_always_white H_always_inv H_always_sweep H_fairstr H_trace always_inv_gwb
 notacc_n.
elim H_until; clear H_until str.

(* BASE CASE 1*)

intros str H_n H_alw_ev_grey H_alw_ev_white H_always_mesure H_always_grey
 H_always_white H_always_inv H_always_sweep H_fairstr H_trace.

(*  H_n: (B n str)*)
elim H_n; clear H_n.

(* 1st case : n is free  *)

intro mkhdn; constructor 1; assumption.

(* 2nd case: n is not free, non acc, g=0 *)

intro H; elim H; clear H.
intros H H_card; elim H; clear H.
intros mkhdn notacc_n.

(* n is white or not white *)
elim (eq_dec_color (mk (head_str str) n) white); intro mkhn.

(* n is white *)
apply white_notacc_nogrey_until_eventually_free; auto.
inversion H_alw_ev_white; auto.
split; auto.

(* m is not white*)

(* (F n)U(G n) str)*)
cut
 (until (fun str => notacc_black_nogrey_formula n str)
    (fun str => notacc_black_nomeasure_formula n str) str).

intro H_until.
generalize H_alw_ev_grey H_alw_ev_white H_always_mesure H_always_grey
 H_always_white H_always_inv H_always_sweep H_fairstr H_trace.
clear H_alw_ev_grey H_alw_ev_white H_always_mesure H_always_grey
 H_always_white H_always_inv H_always_sweep H_fairstr H_trace.
elim H_until; clear H_until mkhn notacc_n mkhdn H_card str.

(*BASE CASE 2*)
intros str H_n H_alw_ev_grey H_alw_ev_white H_always_mesure H_always_grey
 H_always_white H_always_inv H_always_sweep H_fairstr H_trace.
(* H_n:(G n str)*)

(* (G n)U(H n) *)
cut
 (until (fun str => notacc_black_nomeasure_formula n str)
    (fun str => notacc_white_init_formula n str) str).
2: apply until_no_measure_init; auto.
intro H_until.
generalize H_alw_ev_grey H_alw_ev_white H_always_mesure H_always_grey
 H_always_white H_always_inv H_always_sweep H_fairstr H_trace.
clear H_alw_ev_grey H_alw_ev_white H_always_mesure H_always_grey
 H_always_white H_always_inv H_always_sweep H_fairstr H_trace.
elim H_until; clear H_until H_n str.

(*BASE CASE 3*)
intros str H_n H_alw_ev_grey H_alw_ev_white H_always_mesure H_always_grey
 H_always_white H_always_inv H_always_sweep H_fairstr H_trace.

(* H_n:(H n str) *)

(* (K n s)*)
cut (notacc_white_exgrey_reach_formula n str); eauto.
intro H.
apply notacc_white_nogrey_eventually_free; auto.
inversion H_alw_ev_grey; auto.
intros s str H_n H_until H_ind H_alw_ev_grey H_alw_ev_white H_always_mesure
 H_always_grey H_always_white H_always_inv H_always_sweep H_fairstr H_trace.
inversion H_alw_ev_grey; inversion H_alw_ev_white; inversion H_always_mesure;
 inversion H_always_grey; inversion H_always_white;
 inversion H_always_inv; inversion H_always_sweep;
 inversion H_fairstr; inversion H_trace.
constructor 2; apply H_ind; assumption.
intros s str H_n H_until H_ind H_alw_ev_grey H_alw_ev_white H_always_mesure
 H_always_grey H_always_white H_always_inv H_always_sweep H_fairstr H_trace;
 inversion H_alw_ev_grey; inversion H_alw_ev_white;
 inversion H_always_mesure; inversion H_always_grey;
 inversion H_always_white; inversion H_always_inv;
 inversion H_always_sweep; inversion H_fairstr; inversion H_trace.
constructor 2; apply H_ind; assumption.
apply until_no_measure; auto.
inversion H_alw_ev_white; auto.
split; auto.
split; auto.
generalize (refl_equal (mk (head_str str) n));
 pattern (mk (head_str str) n) at -1 in |- *; case (mk (head_str str) n);
 intro mk_h_n; trivial.
absurd (mk (head_str str) n = white); assumption.
inversion_clear H_card; absurd (mk (head_str str) n = grey); auto.
absurd (mk (head_str str) n = free); assumption.
intros s str H_n H_until H_ind H_alw_ev_grey H_alw_ev_white H_always_mesure
 H_always_grey H_always_white H_always_inv H_always_sweep H_fairstr H_trace.
inversion H_alw_ev_grey; inversion H_alw_ev_white; inversion H_always_mesure;
 inversion H_always_grey; inversion H_always_white;
 inversion H_always_inv; inversion H_always_sweep;
 inversion H_fairstr; inversion H_trace.
constructor 2.
apply H_ind; assumption.
apply until_free_or_nogrey; auto.
inversion H_alw_ev_grey; auto.
Qed.

End liveness.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 14: Concurrent Separation Logic
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Map CSLSets Setoid Classes.Morphisms.
Require Import Decidable Coq.Logic.Eqdep Coq.Logic.EqdepFacts Peano_dec Coq.omega.Omega.

Require Import ho_proof_until_gen.
Require Import until_all_ok.

Set Implicit Arguments.

(* Let's combine the subjects of the last two lectures, to let us prove
 * correctness of concurrent programs that do dynamic management of shared
 * memory. *)

(** * Shared notations and definitions; main material starts afterward. *)

Notation heap := (fmap nat nat).
Notation locks := (set nat).

(* Hint Extern 1 (_ <= _) => linear_arithmetic. *)
(* Hint Extern 1 (@eq nat _ _) => linear_arithmetic. *)

(* Ltac simp := repeat (simplify; subst; propositional; *)
(*                      try match goal with *)
(*                          | [ H : ex _ |- _ ] => invert H *)
(*                         end); try linear_arithmetic. *)

(** * A shared-memory concurrent language with loops *)

(* Let's work with a variant of the shared-memory concurrent language from last
 * time.  We add back in result types, loops, and dynamic memory allocation. *)

Inductive loop_outcome acc :=
| Done (a : acc)
| Again (a : acc).

Definition valueOf {A} (o : loop_outcome A) :=
  match o with
  | Done v => v
  | Again v => v
  end.

Inductive cmd : Set -> Type :=
| Return {result : Set} (r : result) : cmd result
| Fail {result} : cmd result
| Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
| Loop {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) : cmd acc

| Read (a : nat) : cmd nat
| Write (a v : nat) : cmd unit
| Lock (a : nat) : cmd unit
| Unlock (a : nat) : cmd unit
| Alloc (numWords : nat) : cmd nat
| Free (base numWords : nat) : cmd unit

| Par (c1 c2 : cmd unit) : cmd unit.

(* The next span of definitions is copied from SeparationLogic.v.  Skip ahead to
 * the word "Finally" to see what's new. *)

Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).
Infix "||" := Par.

Fixpoint initialize (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => initialize h base numWords' $+ (base + numWords', 0)
  end.

Fixpoint deallocate (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => deallocate (h $- base) (base+1) numWords'
  end.

Inductive cfg (A : Set) : Type :=
  Cfg {hp:heap
      ;lcks:locks
      ;command:cmd A}.

Inductive cslstep : forall A, cfg A -> cfg A -> Prop :=
| StepBindRecur : forall result result' (c1 c1' : cmd result') (c2 : result' -> cmd result) h l h' l',
  cslstep (Cfg h l c1) (Cfg h' l' c1')
  -> cslstep (Cfg h l (Bind c1 c2)) (Cfg h' l' (Bind c1' c2))
| StepBindProceed : forall (result result' : Set) (v : result') (c2 : result' -> cmd result) h l,
  cslstep (Cfg h l (Bind (Return v) c2)) (Cfg h l (c2 v))

| StepLoop : forall (acc : Set) (init : acc) (body : acc -> cmd (loop_outcome acc)) h l,
  cslstep (Cfg h l (Loop init body)) (Cfg h l (o <- body init; match o with
                                                     | Done a => Return a
                                                     | Again a => Loop a body
                                                     end))

| StepRead : forall h l a v,
  h $? a = Some v
  -> cslstep (Cfg h l (Read a)) (Cfg h l (Return v))
| StepWrite : forall h l a v v',
  h $? a = Some v
  -> cslstep (Cfg h l (Write a v')) (Cfg (h $+ (a, v')) l (Return tt))
| StepAlloc : forall h l numWords a,
  a <> 0
  -> (forall i, i < numWords -> h $? (a + i) = None)
  -> cslstep (Cfg h l (Alloc numWords)) (Cfg (initialize h a numWords) l (Return a))
| StepFree : forall h l a numWords,
  cslstep (Cfg h l (Free a numWords)) (Cfg (deallocate h a numWords) l (Return tt))

| StepLock : forall h l a,
  ~a \in l
  -> cslstep (Cfg h l (Lock a)) (Cfg h (l \cup {a}) (Return tt))
| StepUnlock : forall h l a,
  a \in l
  -> cslstep (Cfg h l (Unlock a)) (Cfg h (l \setminus {a}) (Return tt))

| StepPar1 : forall h l c1 c2 h' l' c1',
  cslstep (Cfg h l c1) (Cfg h' l' c1')
  -> cslstep (Cfg h l (Par c1 c2)) (Cfg h' l' (Par c1' c2))
| StepPar2 : forall h l c1 c2 h' l' c2',
  cslstep (Cfg h l c2) (Cfg h' l' c2')
  -> cslstep (Cfg h l (Par c1 c2)) (Cfg h' l' (Par c1 c2')).

Infix "==n" := eq_nat_dec (no associativity, at level 50).

Example incrementer :=
for i := tt loop
  _ <- Lock 0;
  n <- Read 0;
  _ <- Write 0 (n);
  _ <- Unlock 0;
  if n ==n 0 then
    Fail
  else
    Return (Again tt)
done.

Example incrementer_par := incrementer || incrementer.

Definition hprop := heap -> Prop.
(* We add the locks to the mix. *)

Definition himp (p q : hprop) := forall h, p h -> q h.
Definition heq (p q : hprop) := forall h, p h <-> q h.

(* Lifting a pure proposition: it must hold, and the heap must be empty. *)
Definition lift (P : Prop) : hprop :=
  fun h => P /\ h = $0.

(* Separating conjunction, one of the two big ideas of separation logic.
 * When does [star p q] apply to [h]?  When [h] can be partitioned into two
 * subheaps [h1] and [h2], respectively compatible with [p] and [q].  See book
 * module [Map] for definitions of [split] and [disjoint]. *)
Definition star (p q : hprop) : hprop :=
  fun h => exists h1 h2, split h h1 h2 /\ disjoint h1 h2 /\ p h1 /\ q h2.

(* Existential quantification *)
Definition exis A (p : A -> hprop) : hprop :=
  fun h => exists x, p x h.

(* Convenient notations *)
Notation "[| P |]" := (lift P) : sep_scope.
Infix "*" := star : sep_scope.
Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
Delimit Scope sep_scope with sep.
Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).

(* And now we prove some key algebraic properties, whose details aren't so
 * important.  The library automation uses these properties. *)

Lemma iff_two : forall A (P Q : A -> Prop),
  (forall x, P x <-> Q x)
  -> (forall x, P x -> Q x) /\ (forall x, Q x -> P x).
Proof.
  firstorder.
Qed.

Definition ptsto (a v : nat) : heap -> Prop := fun h => h = $0 $+ (a, v).

(* Recall that each lock has an associated invariant.  This program only uses
 * lock 0, and here's its invariant: memory cell 0 holds a positive number. *)
Definition incrementer_inv :=
  (exists n, ptsto 0 n * [| n > 0 |])%sep.

Definition incrementer_inv' :=
  (exis (fun n => ptsto 0 n * [| n > 0 |]))%sep.

Definition inc_inv A : cfg A -> Prop :=
  fun cfg => forall h l c,
      cfg = (Cfg h l c) ->
      exists (x : nat) (h1 h2 : heap),
        split h h1 h2 /\ disjoint h1 h2 /\ ptsto 0 x h1 /\ [|x > 0|]%sep h2.

(* Inductive ho_spec_old (B : Spec (cfg unit)) : Spec (cfg unit) := *)
(* | claim1_old : forall h P n, *)
(*     h = $0 $+ (0, n) -> n > 0 ->  *)
(*     B (Cfg h {} (P || incrementer)) (fun _ c => inc_inv c) (fun _ => False) -> *)

(*     (forall x x' x'' l l' l'' Z Q, *)
(*       B (Cfg x l (Z || Q)) (fun _ c => inc_inv c) (fun _ => False) <-> *)
(*       (forall Z', cslstep (Cfg x l (Z || Q)) (Cfg x' l' (Z' || Q)) -> *)
(*                   B (Cfg x' l' (Z' || Q)) (fun _ c => inc_inv c) (fun _ => False) *)
(*                   /\ inc_inv (Cfg x' l' (Z' || Q))) /\ *)
(*       (forall Q', cslstep (Cfg x l (Z || Q)) (Cfg x'' l'' (Z || Q')) -> *)
(*                   inc_inv (Cfg x'' l'' (Z || Q')) -> *)
(*                   B (Cfg x'' l'' (Z || Q')) (fun _ c => inc_inv c) (fun _ => False))) *)

(*     -> ho_spec_old B (Cfg (h $+ (0 ,n)) {} (P || incrementer)) *)
(*                (fun _ c => inc_inv c) (fun _ => False). *)

Inductive ho_spec (B : Spec (cfg unit)) : Spec (cfg unit) :=
| claim1 : forall h P n,
    h = $0 $+ (0, n) -> n > 0 ->
    B (Cfg h {} (P || incrementer)) (fun _ c => inc_inv c) (fun _ => False) ->
    (forall x x' l l' Z Q,
        (forall Z', cslstep (Cfg x l (Z || Q)) (Cfg x' l' (Z' || Q)) ->
                    B (Cfg x' l' (Z' || Q)) (fun _ c => inc_inv c) (fun _ => False)
                    /\ inc_inv (Cfg x' l' (Z' || Q))))
    -> ho_spec B (Cfg (h $+ (0 ,n)) {} (P || incrementer))
               (fun _ c => inc_inv c) (fun _ => False).

Inductive nonho_spec : Spec (cfg unit) :=
| nonho_claim : forall h n,
    h = $0 $+ (0, n) -> n > 0 ->
    nonho_spec (Cfg (h $+ (0, n)) {} (incrementer || incrementer))
               (fun _ c => inc_inv c) (fun _ => False).

Lemma ho_spec_mono : mono ho_spec.
Proof.
  destruct 2. econstructor; try eassumption. apply H. eassumption.
  intros. split; try apply H; eapply H3; eassumption.
Qed.

Lemma ho_gfp : subspec nonho_spec (ho_spec nonho_spec).
Proof.
  destruct 1. econstructor; try eassumption. assert (h = (h $+ (0,n))).
  subst. maps_equal. rewrite H1. econstructor; try eassumption.
  intros. split. admit. admit.
Qed.

Ltac injpair1 H H1 := inversion H;
                      (try repeat apply inj_pair2 in H1; subst).
Ltac injpair3 H H1 H2 H3 := inversion H;
                            (try repeat apply inj_pair2 in H1;
                             try repeat apply inj_pair2 in H2;
                             try repeat apply inj_pair2 in H3; subst).
Ltac injpair4 H H1 H2 H3 H4 := inversion H;
                               (try repeat apply inj_pair2 in H1;
                                try repeat apply inj_pair2 in H2;
                                try repeat apply inj_pair2 in H3;
                                try repeat apply inj_pair2 in H4; subst).

Lemma heap_eq : forall h n,
    h = $0 $+ (0, n) -> n > 0 ->
    exists (x : nat) (h1 h2 : heap),
      split (h $+ (0, n)) h1 h2 /\ disjoint h1 h2 /\ ptsto 0 x h1 /\ [|x > 0|]%sep h2.
Proof.
  intros.
  exists n. exists ($0 $+ (0,n)). exists (h $- 0).
  split. unfold split. subst.
  maps_equal. rewrite lookup_join1.
  rewrite lookup_add_eq. rewrite lookup_add_eq. trivial. trivial. trivial.
  eapply lookup_Some_dom. apply lookup_add_eq. trivial.

  rewrite lookup_add_ne. rewrite lookup_join2.
  rewrite lookup_remove_ne. trivial. omega.
  apply lookup_None_dom. rewrite lookup_add_ne. apply lookup_empty. omega. omega.

  split. unfold disjoint. intros. apply H1.
  destruct (($0 $+ (0, n)) $? a) eqn:H'.
  destruct ((h $- 0) $? a) eqn:H''.
  exfalso. apply lookup_split in H'. inversion H'. inversion H3.
  rewrite lookup_empty in H5. inversion H5. inversion H3; subst. inversion H3.
  apply lookup_remove_eq with (m := $0 $+ (0, n)) in H. rewrite H'' in H. inversion H.
  exfalso. apply H2. trivial. trivial.

  split. unfold ptsto. trivial. unfold lift. split. assumption.
  subst. maps_equal. destruct k. rewrite lookup_remove_eq. rewrite lookup_empty.
  trivial. trivial.
  rewrite lookup_remove_ne. rewrite lookup_add_ne. trivial. omega. omega.
Qed.

Ltac get_next1 := apply tstep; apply ho_spec_mono; econstructor; apply StepPar2;
                  econstructor; econstructor; econstructor.

Ltac get_next2 := apply tstep; apply ho_spec_mono; econstructor; apply StepPar2;
                 constructor; apply StepBindProceed.

Ltac incsolve H := unfold inc_inv; intros;
                  inversion H; subst;
                   apply heap_eq; auto.

Ltac lstep H := edestruct H; try eassumption; split; try eassumption;
                apply trule; try apply ho_spec_mono; assumption.

Lemma map_get : forall n (v : nat), ($0 $+ (0, n) $+ (0, n)) $? 0 = Some v -> n = v.
Proof.
  intros.
  assert (($0 $+ (0, n) $+ (0, n)) $? 0 = Some n).
  apply lookup_add_eq. trivial. rewrite H in H0. inversion H0. trivial.
Qed.

Lemma ho_ok_all : sound (@cslstep unit) nonho_spec.
Proof.
  unfold sound. eapply ok with ho_spec. apply ho_spec_mono.
  intros.
  destruct 1. apply sstep. econstructor.
  apply StepPar2. constructor.

  intros.
  injpair1 H3 H9.
  assert ($0 $+ (0,n) = $0 $+ (0,n) $+ (0,n)) by maps_equal.
  lstep H2.

  injpair3 H6 H8 H9 H12.
  split. incsolve H. clear H3.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. constructor. constructor. sets idtac.

  intros. injpair1 H H9.
  lstep H2. clear H.

  injpair4 H5 H9 H10 H10 H13.
  injpair4 H4 H10 H11 H11 H14.
  injpair1 H7 H12.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. apply StepBindProceed.

  intros. injpair1 H H13.
  lstep H2. clear H.

  injpair4 H10 H13 H14 H14 H17.
  injpair4 H9 H14 H15 H15 H18.
  inversion H11. do 2 (apply inj_pair2 in H16). apply inj_pair2 in H19; subst.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. constructor. constructor. eapply lookup_add_eq. trivial.

  intros. injpair1 H H16.
  lstep H2. clear H.

  injpair4 H12 H16 H17 H17 H20.
  injpair4 H11 H17 H18 H18 H21.
  injpair1 H13 H19.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. apply StepBindProceed.

  intros. injpair1 H H20.
  lstep H2. clear H.

  injpair4 H17 H20 H21 H21 H24.
  injpair4 H16 H21 H22 H22 H25.
  inversion H18. do 2 (apply inj_pair2 in H23). apply inj_pair2 in H26; subst.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. constructor. econstructor. eapply lookup_add_eq. trivial.

  intros. injpair1 H H23.
  lstep H2. clear H. (* clear H8. clear H14. clear H15. *)

  apply map_get in H15; subst.
  injpair4 H19 H22 H23 H23 H26.
  injpair4 H15 H23 H24 H24 H27.
  injpair1 H18 H26.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. apply StepBindProceed.

  intros. injpair1 H H26.
  lstep H2. clear H.

  injpair4 H23 H26 H27 H27 H30.
  injpair4 H22 H27 H28 H28 H31.
  inversion H24. do 2 (apply inj_pair2 in H29). apply inj_pair2 in H32; subst.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. constructor. constructor. sets idtac. right. unfold List.In.
  left. trivial.

  intros. injpair1 H H29.
  lstep H2. clear H.

  injpair4 H25 H29 H30 H30 H33.
  injpair4 H24 H30 H31 H31 H34.
  injpair1 H26 H32.
  split. incsolve H.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  constructor. apply StepBindProceed.

  intros. injpair1 H H33.
  lstep H2. clear H.

  injpair4 H30 H33 H34 H34 H37.
  injpair4 H29 H34 H35 H35 H38.
  inversion H31. do 2 (apply inj_pair2 in H36). apply inj_pair2 in H39; subst.
  split. incsolve H.

  destruct (v ==n 0). apply tdone. apply ho_spec_mono. omega.

  apply tstep. apply ho_spec_mono. econstructor. apply StepPar2.
  apply StepBindProceed.

  intros. injpair1 H H36.
  lstep H2. clear H.

  injpair4 H32 H36 H37 H37 H40.
  inversion H31. do 2 (apply inj_pair2 in H38). apply inj_pair2 in H41; subst.
  split. incsolve H.

  eapply ttrans. eapply ho_spec_mono.
  assert (T (step (@cslstep unit)) ho_spec A
            {| hp := $0 $+ (0, v); lcks := {}; command := P || incrementer |}
            (fun _ c : cfg unit => inc_inv c) (fun _ : cfg unit => False)).
  apply Tf_id. assumption.
  assert ($0 $+ (0, v) = $0 $+ (0, v) $+ (0, v) $+ (0, v)) by maps_equal.
  assert (({} \cup {0}) \setminus {0} = {}) by sets idtac.
  rewrite <- H3. rewrite H31. apply H.

  intros. inversion H.
  apply ho_gfp.

Qed.

Print Assumptions ho_ok_all.


Require Import String Basics.
Require Import List.
Require Import Ast Notations EvalE PCUICtoTemplate PCUICTranslate.

From MetaCoq.Template Require Ast.
(* From MetaCoq.Template Require Import TemplateMonad. *)
(* From MetaCoq.Template Require Import monad_utils. *)

Definition expr_to_tc Σ := compose trans (expr_to_term Σ).
Definition type_to_tc := compose trans type_to_term.
Definition global_to_tc := compose trans_minductive_entry trans_global_dec.

Import ListNotations.
Module TC := Template.BasicAst.

(* Import MonadNotation. *)
Import BaseTypes.
Import StdLib.

Module MC:=MetaCoq.Template.Ast.
Import BasicAst.

(** ** MetaCoq demo *)

(** Quote *)
Quote Definition id_nat_syn := (fun x : nat => x).
Print id_nat_syn.
(* Ast.tLambda (nNamed "x")
   (Ast.tInd {| TC.inductive_mind := "nat"; TC.inductive_ind := 0 |}
      []) (Ast.tRel 0) : Ast.term *)

(** Unquote *)
Make Definition plus_one :=
  (MC.tLambda (nNamed "x") (MC.tInd (mkInd "nat"  0 ) nil)
              (MC.tApp (MC.tConstruct (mkInd "nat" 0) 1 nil)
                       (MC.tRel 0 :: nil))).

Print plus_one.
(* fun x : nat => S x : nat -> nat *)

Definition x := "x".
Definition y := "y".
Definition z := "z".

(** Negation function syntax *)
Definition my_negb_syn :=
  [| \x : Bool => case x : Bool return Bool of
                   | True -> False
                   | False -> True  |].

Unset Printing Notations.

Print my_negb_syn.

Set Printing Notations.

(* Execute the program using the interpreter *)
Compute (expr_eval_n Σ 3 nil [|{my_negb_syn} True |]).

Compute (expr_eval_i Σ 3 nil (indexify nil negb_app_true)).

(* Make a Coq function from the AST of the program *)
Make Definition coq_negb_app_true :=
  (expr_to_tc Σ (indexify nil negb_app_true)).

Print coq_negb_app_true.

Make Definition my_negb :=
  (expr_to_tc Σ (indexify nil my_negb_syn)).

Lemma my_negb_coq_negb b :
  my_negb b = negb b.
Proof. reflexivity. Qed.

Compute (expr_eval_n Σ 3 nil my_negb_syn).