Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Cryptol.Coqlib.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.AST.
Require Import Cryptol.Semantics.
Require Import Cryptol.Utils.
Require Import Cryptol.Builtins.
Require Import Cryptol.BuiltinSem.
Require Import Cryptol.BuiltinSyntax.
Require Import Cryptol.SimpleValues.
Require Import Cryptol.Bitstream.
Require Import Cryptol.Lib.
Require Import Cryptol.GetEachN.
Require Import Cryptol.EagerEvalInd.
Require Import Cryptol.GlobalExtends.

Require Import Cryptol.EvalTac.
Require Import Cryptol.Eager.

Import HaskellListNotations.
Open Scope string.

Require Import HMAC.HMAC.

(* Model of HMAC *)
(* Now we can use ext_val to characterize the inputs to HMAC *)
(* As well, we can simply write HMAC over ext_val *)

Fixpoint xor_const_list (idx : Z) (const : Z) (l : list ext_val) : list ext_val :=
  match l with
  | nil => nil
  | (ebit b) :: r =>
    let r' := xor_const_list (idx - 1) const r in
    let b' := Z.testbit const idx in
    (ebit (xorb b b')) :: r'
  | _ => nil
  end.

Definition xor_const (const : Z) (e : ext_val) : ext_val :=
  match e with
  | eseq l => eseq (xor_const_list ((Z.of_nat ((Datatypes.length l)) - 1)) const l)
  | _ => ebit false
  end.

(* Model of hmac, given model of hash *)
Definition hmac_model (hf : ext_val -> ext_val) (key msg : ext_val) :=
    match key, msg with
    | eseq keyl, eseq msgl =>
      match hf (eseq ((map (fun x => xor_const 54 x) keyl) ++ msgl)) with
      | eseq x3 =>
        Some (hf (eseq (map (xor_const 92) keyl ++ map eseq (get_each_n (Pos.to_nat 8) x3))))
      | _ => None
      end
    | _,_ => None
    end.

(* TODO: is this the right definition of a good hash? *)
(* *)
Definition good_hash (h : Expr) (ge : genv) (T : tenv) (SE : senv) (hf : ext_val -> ext_val) : Prop :=
  (exists id exp TE E,
      eager_eval_expr ge T SE h (sclose id exp TE E) /\ (* can evaluate the hash to a closure *)
      forall n v,
        has_type v (bytestream n) ->
        eager_eval_expr ge TE (extend E id (to_sval v)) exp (to_sval (hf v)) /\ exists n, has_type (hf v) (tseq n tbit)

  ) /\ (    forall x l,
      hf x = eseq l ->
      Nat.divide 8 (Datatypes.length l)).

(* TODO: massage into good_hash defn *)
Lemma good_hash_fully_padded :
  forall h GE TE SE hf,
    good_hash h GE TE SE hf ->
    forall x l,
      hf x = eseq l ->
      Nat.divide 8 (Datatypes.length l).
Proof.
  intros. unfold good_hash in H. destruct H. eauto.
Qed.

Lemma good_hash_eval :
  forall h GE T SE hf,
    good_hash h GE T SE hf ->
    exists id exp TE E,
      eager_eval_expr GE T SE h (sclose id exp TE E).
Proof.
  intros. unfold good_hash in *.
  do 6 destruct H.
  eauto.
Qed.

Lemma good_hash_complete_eval :
  forall h GE T SE hf,
    good_hash h GE T SE hf ->
    exists id exp TE E,
      eager_eval_expr GE T SE h (sclose id exp TE E) /\
      forall n v,
        has_type v (bytestream n) ->
        eager_eval_expr GE TE (extend E id (to_sval v)) exp (to_sval (hf v)) /\ exists n, has_type (hf v) (tseq n tbit).
Proof.
  intros. unfold good_hash in *.
  do 6 destruct H.
  do 4 eexists. split; eauto.
Qed.

Lemma good_hash_same_eval :
  forall h GE TE SE hf,
    good_hash h GE TE SE hf ->
    forall v,
      eager_eval_expr GE TE SE h v ->
      forall GE' TE' SE' h',
        global_extends GE GE' ->
        eager_eval_expr GE' TE' SE' h' v ->
        good_hash h' GE' TE' SE' hf.
Proof.
  intros. unfold good_hash in *.
  repeat match goal with
         | [ H : exists _, _ |- _ ] => destruct H
         | [ H : _ /\ _ |- _ ] => destruct H
         end.
  split.
  eapply eager_eval_expr_determ in H; try eapply H0. subst v.
  exists x. exists x0. exists x1. exists x2.
  split. auto.
  intros. eapply H4 in H; eauto.
  destruct H; split; eauto.
  repeat eexists; eauto.
  eapply global_extends_eager_eval; eauto.
  eassumption.
Qed.

(*
Lemma extend_other_name_irrel :
  forall {A} l id0 GE,
    Forall (fun id => GE id = None) l ->
    ~ In (fst id0) (map fst l) ->
    forall (v : A),
      Forall (fun id => extend GE id0 v id = None) l.
Proof.
  induction 1; intros.
  econstructor.
  destruct id0. unfold map in H1. fold (map fst l) in H1.
  destruct x. unfold fst in H1. fold (@fst Z string) in H1.
  erewrite not_in_cons in H1.
  destruct H1.
  econstructor; try eapply IHforall; eauto.

  unfold extend. destruct (ident_eq (z0,s0) (z,s)); try congruence.
  simpl in e. congruence.
Qed.
*)

Definition typenum (n : Z) : Expr := ETyp (TCon (TC (TCNum n)) []).

Lemma eager_eval_bind_senvs :
  forall l model GE TE exp SE id,
    (Forall (fun x => has_type x byte) l) ->
    (forall ev, has_type ev byte -> eager_eval_expr GE TE (extend SE id (to_sval ev)) exp (model ev)) ->
    Forall2 (fun se => eager_eval_expr GE TE se exp)
            (bind_senvs SE (map (fun sv => [(id,sv)]) (map to_sval l))) (map model l).
Proof.
  induction l; intros.
  econstructor; eauto.

  inversion H. subst.
  eapply IHl in H4.
  simpl. econstructor; [idtac | eassumption].
  eapply H0. eauto.
  intros. eapply H0. eauto.
Qed.

(*
Lemma strictval_from_bitv'_widen :
  forall a b n z,
    (a >= n)%nat ->
    (b >= n)%nat ->
    strictval_from_bitv' a n (@repr a z) = strictval_from_bitv' b n (@repr b z).
Proof.
  induction n; intros.
  simpl. reflexivity.

  simpl.
  f_equal. f_equal.
  assert (Z.of_nat (S n) > Z.of_nat n).
  simpl. rewrite Zpos_P_of_succ_nat. omega.
  erewrite testbit_widen.
  symmetry.
  erewrite testbit_widen.
  reflexivity.
  eassumption.
  assumption.
  eassumption.
  assumption.
  eapply IHn; eauto; omega.
Qed.

Lemma strictval_from_bitv_norm :
  forall x n z,
    (x >= n)%nat ->
    strictval_from_bitv' x n (@repr x z) = strictval_from_bitv' n n (@repr n z).
Proof.
  intros.
  erewrite strictval_from_bitv'_widen; eauto.
Qed.
*)

Lemma testbit_unsigned_repr :
  forall w z idx,
    Z.of_nat w > idx ->
    Z.testbit (@unsigned w (@repr w z)) idx = Z.testbit z idx.
Proof.
  induction w; intros;
    simpl.
  * assert (idx < 0) by (simpl in H; omega).
    destruct idx; simpl in H0; try omega.
    remember (Zgt_pos_0 p) as HH. omega.
    simpl. reflexivity.
  * rewrite Z_mod_modulus_eq; try omega.
    unfold modulus.
    rewrite two_power_nat_equiv.
    rewrite Z.mod_pow2_bits_low;
      try omega.
    reflexivity.
Qed.

Lemma xor_num :
  forall  l n z,
    has_type (eseq l) (tseq (Datatypes.length l) tbit) ->
    n = Datatypes.length l ->
    xor_sem (strict_list (map to_sval l)) (strict_list (from_bitlist strictval sbit n z)) = Some (to_sval (xor_const z (eseq l))).
Proof.
  induction l; intros.
  simpl in *.
  subst n. simpl. reflexivity.

  assert (has_type (eseq l) (tseq (Datatypes.length l) tbit)).
  {
    inversion H. econstructor; eauto. inversion H3. auto.

  }
  unfold xor_const.
  rewrite length_cons.
  unfold Z.of_nat.
  rewrite Zpos_P_of_succ_nat.
  simpl.
  simpl in H0. subst n.
  simpl. erewrite IHl; eauto.
  inversion H. inversion H3. subst. inversion H6. subst.
  simpl.
  replace (Z.succ (Z.of_nat (Datatypes.length l)) - 1) with (Z.of_nat (Datatypes.length l)) by omega.
  f_equal. f_equal.

  destruct b; simpl; auto.
  f_equal.
  destruct (Z.testbit z (Z.of_nat (Datatypes.length l))); auto.
Qed.

Lemma ext_val_list_of_strictval :
  forall ev n t,
    has_type ev (tseq n t) ->
    exists l,
      list_of_strictval (to_sval ev) = Some (map to_sval l).
Proof.
  intros.
  destruct ev; try solve [inversion H].
  simpl. rewrite list_of_strictval_of_strictlist.
  eauto.
Qed.

Lemma xor_const_list_length_pres :
  forall l z n,
    Forall (fun b => has_type b tbit) l ->
    Datatypes.length (xor_const_list z n l) = Datatypes.length l.
Proof.
  induction l; intros;
    simpl. reflexivity.
  destruct a; simpl. rewrite IHl; eauto.
  inversion H. eauto.
  inversion H. inversion H2.
  inversion H. inversion H2.
  inversion H. inversion H2.
Qed.

Lemma xor_const_byte :
  forall ev,
    has_type ev byte ->
    forall n,
      has_type (xor_const n ev) byte.
Proof.
  intros.
  inversion H.
  subst.
  do 9 (destruct l; simpl in H0; try omega).
  clear H0.
  repeat match goal with
         | [ H : Forall _ _ |- _ ] => inversion H; clear H; subst
         end.
  repeat match goal with
         | [ H : has_type _ tbit |- _ ] => inversion H; clear H
         end; subst.

  unfold xor_const.
  unfold byte.
  replace 8%nat with (Datatypes.length [ebit b6, ebit b5, ebit b4, ebit b3, ebit b2, ebit b1, ebit b0, ebit b]) by (simpl; auto).
  erewrite <- xor_const_list_length_pres.
  econstructor.
  simpl.
  repeat econstructor; eauto.
  repeat econstructor; eauto.
Qed.

Lemma strict_list_map_to_sval :
  forall l,
    strict_list (map to_sval l) = to_sval (eseq l).
Proof.
  induction l; intros; simpl; auto.
Qed.

Lemma map_strict_list_map_map_to_sval :
  forall l,
    map strict_list (map (map to_sval) l) = map to_sval (map eseq l).
Proof.
  induction l; intros; simpl; auto.
  f_equal. assumption.
Qed.

Lemma to_sval_list_pair_equiv :
  forall f,
    to_sval_list_pair f = combine (map fst f) (map to_sval (map snd f)).
Proof.
  induction f; intros; simpl; auto.
  destruct a. simpl. f_equal. auto.
Qed.

Lemma to_sval_injective :
  forall ev1 ev2,
    to_sval ev1 = to_sval ev2 ->
    ev1 = ev2.
Proof.
  induction ev1 using ext_val_ind_mut; intros; simpl in *;
    destruct ev2; simpl in *; try congruence;
      try solve [
            destruct l; simpl in *; try congruence].
  f_equal.
  eapply strict_list_injective in H0.
  eapply map_injective_function; eauto.
  destruct l0; simpl in H0; congruence.
  inversion H0. f_equal.
  eapply map_injective_function; eauto.
  fold to_sval_list_pair in *.
  inversion H0. clear H0.
  f_equal.
  repeat erewrite to_sval_list_pair_equiv in *.
  eapply combine_injective in H2; repeat rewrite list_length_map; auto.
  destruct H2.
  eapply map_injective_function in H1; eauto.
  eapply list_pair_parts_eq; eauto.
Qed.

Lemma list_of_strictval_to_sval :
  forall l' l,
    list_of_strictval (to_sval l) = Some (map to_sval l') ->
    l = eseq l'.
Proof.
  induction l'; intros; simpl in *; try congruence.
  * destruct l; simpl in H; try congruence.
    rewrite list_of_strictval_of_strictlist in H. inversion H.
    destruct l; simpl in H1; congruence.
  * destruct l; simpl in H; try congruence.
    rewrite list_of_strictval_of_strictlist in H. inversion H.
    f_equal.
    destruct l; simpl in *; try congruence.
    specialize (IHl' (eseq l)).
    simpl in IHl'.
    rewrite list_of_strictval_of_strictlist in IHl'.
    assert (eseq l = eseq l'). eapply IHl'. f_equal. inversion H1. eauto.
    inversion H0. f_equal.
    inversion H1.
    eapply to_sval_injective; eauto.
Qed.

Lemma has_type_seq_append :
  forall l l' t,
    (exists n, has_type (eseq l) (tseq n t)) ->
    (exists n, has_type (eseq l') (tseq n t)) ->
    (exists n, has_type (eseq (l ++ l')) (tseq n t)).
Proof.
  induction l; intros.
  simpl; auto.
  simpl. destruct H. destruct H0.
  inversion H. inversion H3.
  subst.
  inversion H0. subst.
  eexists. econstructor.
  econstructor; eauto.
  eapply Forall_app; eauto.
Qed.

Lemma eq_is_refl :
  forall width v,
    eq_sem
      (strict_list (SimpleValues.from_bitlist strictval sbit width v))
      (strict_list (SimpleValues.from_bitlist strictval sbit width v))
    = Some (sbit true).
Proof.
  induction width; intros; simpl; auto.
  rewrite IHwidth.
  destruct (Z.testbit v (Z.of_nat width)) eqn:?; auto.
Qed.

Lemma lt_not_refl :
  forall width v,
    lt_sem
      (strict_list (SimpleValues.from_bitlist strictval sbit width v))
      (strict_list (SimpleValues.from_bitlist strictval sbit width v))
    = Some (sbit false).
Proof.
  induction width; intros; simpl; auto.
  rewrite IHwidth.
  destruct (Z.testbit v (Z.of_nat width)) eqn:?; auto.
Qed.

Lemma gt_not_refl :
  forall width v,
    gt_sem
      (strict_list (SimpleValues.from_bitlist strictval sbit width v))
      (strict_list (SimpleValues.from_bitlist strictval sbit width v))
    = Some (sbit false).
Proof.
  intros.
  unfold gt_sem.

  erewrite lt_not_refl.
  erewrite eq_is_refl.
  reflexivity.
Qed.

Lemma has_type_cons :
  forall f l n t,
    has_type (eseq l) (tseq n t) ->
    has_type f t ->
    has_type (eseq (f :: l)) (tseq (S n) t).
Proof.
  intros. inversion H.
  econstructor; eauto.
Qed.

Lemma list_drop_all :
  forall {A} (l : list A),
    list_drop (Datatypes.length l) l = nil.
Proof.
  induction l; intros; simpl; auto.
Qed.

Lemma list_drop_exact_length :
  forall {A} (l : list A) n,
    (n <= Datatypes.length l)%nat ->
    (Datatypes.length (list_drop n l) = (Datatypes.length l) - n)%nat.
Proof.
  induction l; intros.
  destruct n; simpl in H; try omega. simpl. reflexivity.
  destruct n; simpl. reflexivity.
  eapply IHl. simpl in H. omega.
Qed.

Lemma Forall_firstn :
  forall {A} P (l : list A),
    Forall P l ->
    forall n,
      Forall P (firstn n l).
Proof.
  induction 1; intros.
  destruct n; econstructor.
  destruct n; simpl. econstructor.
  econstructor; eauto.
Qed.

Lemma Forall_list_drop :
  forall {A} P (l : list A),
    Forall P l ->
    forall n,
      Forall P (list_drop n l).
Proof.
  induction 1; intros.
  destruct n; econstructor.
  destruct n; simpl. econstructor; eauto.
  eauto.
Qed.

(* This'll be a fun one *)
(* if too hard, it's fine to existentially quantify the Nat.div number *)
(* and carry that through to type_stream_of_bytes *)
Lemma get_each_n'_type :
  forall fuel l n t,
    Forall (fun x => has_type x t) l ->
    Nat.divide n (Datatypes.length l) ->
    n <> O ->
    (fuel >= Datatypes.length l)%nat ->
    exists n',
      has_type (eseq (map eseq (get_each_n' fuel n l))) (tseq n' (tseq n t)).
Proof.
  induction fuel; intros.
  destruct l; simpl in *; try omega.
  eexists. econstructor; eauto.

  assert (fuel >= Datatypes.length l \/ S fuel = Datatypes.length l)%nat by omega.
  destruct H3.
  erewrite get_each_n'_extra_fuel; try apply H3; try omega.
  eapply IHfuel; eauto.

  destruct l; destruct n; try solve [simpl in *; try congruence; try omega].
  unfold get_each_n'. fold (@get_each_n' ext_val).
  clear H2.
  simpl in H3. inversion H3. subst fuel.
  clear H3. clear H1.
  simpl in H0.
  eexists. econstructor. simpl.
  econstructor.

  replace (S n) with (Datatypes.length (e :: firstn n l)).
  econstructor. inversion H. subst.
  econstructor; eauto.
  eapply Forall_firstn; eauto.
  simpl. f_equal.
  eapply Nat.divide_pos_le in H0; try omega.
  eapply firstn_length_le; omega.

  edestruct (IHfuel (list_drop n l)). instantiate (1 := t).
  inversion H.
  eapply Forall_list_drop; eauto.

  instantiate (1 := S n).

  replace (Datatypes.length (list_drop n l)) with ((S (Datatypes.length l)) - (S n))%nat.
  eapply Nat.divide_sub_r; eauto.
  eapply Nat.divide_refl.
  erewrite list_drop_exact_length. omega.
  eapply Nat.divide_pos_le in H0; eauto; try omega.

  congruence.
  remember (list_drop_length l n) as Hld; try omega.
  inversion H1. subst.  assumption.
Qed.

Lemma type_stream_of_bytes :
  forall n l t,
    Forall (fun x => has_type x t) l ->
    Nat.divide n (Datatypes.length l) ->
    n <> O ->
    exists n',
      has_type (eseq (map eseq (get_each_n n l))) (tseq n' (tseq n t)).
Proof.
  intros.
  unfold get_each_n.
  eapply get_each_n'_type; eauto.
Qed.


Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.lib.relation_list.
Require Import CertiGraph.lib.Equivalence_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.MathGraph.

Section BinGraph.

Context {V E: Type} {EV: EqDec V eq} {EE: EqDec E eq}.

Class BinGraph (pg: PreGraph V E) (left_out_edge right_out_edge: V -> E): Prop :=
{
  bin_consist: forall x, vvalid pg x -> left_out_edge x <> right_out_edge x;
  only_two_edges: forall x e, vvalid pg x -> (src pg e = x /\ evalid pg e <-> e = left_out_edge x \/ e = right_out_edge x)
}.

Context {left_out_edge right_out_edge: V -> E}.

Lemma left_valid (pg: PreGraph V E) {bi: BinGraph pg left_out_edge right_out_edge}: forall x, vvalid pg x -> evalid pg (left_out_edge x).
Proof.
  intros.
  pose proof only_two_edges x (left_out_edge x).
  tauto.
Qed.

Lemma right_valid (pg: PreGraph V E) {bi: BinGraph pg left_out_edge right_out_edge}: forall x, vvalid pg x -> evalid pg (right_out_edge x).
Proof.
  intros.
  pose proof only_two_edges x (right_out_edge x).
  tauto.
Qed.

Lemma left_sound (pg: PreGraph V E) {bi: BinGraph pg left_out_edge right_out_edge}: forall x, vvalid pg x -> src pg (left_out_edge x) = x.
Proof.
  intros.
  pose proof only_two_edges x (left_out_edge x).
  pose proof left_valid pg x.
  tauto.
Qed.

Lemma right_sound (pg: PreGraph V E) {bi: BinGraph pg left_out_edge right_out_edge}: forall x, vvalid pg x -> src pg (right_out_edge x) = x.
Proof.
  intros.
  pose proof only_two_edges x (right_out_edge x).
  pose proof right_valid pg x.
  tauto.
Qed.

Lemma left_or_right (pg: PreGraph V E) (bi: BinGraph pg left_out_edge right_out_edge): forall x e, vvalid pg x -> evalid pg e -> src pg e = x -> {e = left_out_edge x} + {e = right_out_edge x}.
Proof.
  intros.
  pose proof only_two_edges x e.
  destruct_eq_dec e (left_out_edge x); [left | right]; tauto.
Qed.

Lemma binGraph_out_edges (pg: PreGraph V E) (bi: BinGraph pg left_out_edge right_out_edge): forall x e, vvalid pg x -> (In e (left_out_edge x :: right_out_edge x :: nil) <-> out_edges pg x e).
Proof.
  intros.
  unfold out_edges.
  simpl.
  pose proof only_two_edges x e H.
  firstorder; subst; tauto.
Qed.

Definition binE (pg : PreGraph V E) {bi: BinGraph pg left_out_edge right_out_edge} (v: V) : V * V := (dst pg (left_out_edge v), dst pg (right_out_edge v)).

Lemma binE_only2 (pg : PreGraph V E) {bi: BinGraph pg left_out_edge right_out_edge} :
  forall v v1 v2 n, vvalid pg v -> binE pg v = (v1 ,v2) -> (step pg v n <-> n = v1 \/ n = v2).
Proof.
  intros; unfold binE in H.
  split; intros.
  + inversion H1; subst.
    inversion H0; subst.
    assert (e = left_out_edge (src pg e) \/ e = right_out_edge (src pg e)) by (rewrite <- only_two_edges; eauto).
    destruct H3; rewrite <- H3; auto.
  + rewrite step_spec; inversion H0; subst.
    destruct H1; [exists (left_out_edge v) | exists (right_out_edge v)]; subst.
    - split; [| split]; [eapply left_valid | rewrite left_sound |]; eauto.
    - split; [| split]; [eapply right_valid | rewrite right_sound |]; eauto.
Qed.

Lemma bin_graph_si: forall (g1 g2: PreGraph V E),
  g1 ~=~ g2 ->
  BinGraph g1 left_out_edge right_out_edge ->
  BinGraph g2 left_out_edge right_out_edge.
Proof.
  intros.
  constructor.
  + intros.
    apply (bin_consist).
    rewrite (proj1 H); auto.
  + destruct H as [? [? [? ?]]].
    intros.
    pose proof only_two_edges x e.
    rewrite <- H in H4.
    rewrite <- H1.
    rewrite <- H5 by auto.
    apply and_iff_compat_r_weak.
    intros.
    pose proof proj1 (H1 e) H6.
    rewrite H2 by auto.
    reflexivity.
Qed.

Lemma gen_dst_preserve_bin: forall (g: PreGraph V E) e t,
    BinGraph g left_out_edge right_out_edge -> BinGraph (pregraph_gen_dst g e t) left_out_edge right_out_edge.
Proof.
  intros. apply Build_BinGraph; intros.
  + apply bin_consist; auto.
  + simpl. apply (only_two_edges); auto.
Qed.

Context {is_null: DecidablePred V}.

Lemma bin_graph_join: forall (g: PreGraph V E) (PV1 PV2 PV: V -> Prop) (PE1 PE2 PE: E -> Prop),
  Prop_join PV1 PV2 PV ->
  Prop_join PE1 PE2 PE ->
  MathGraph (gpredicate_subgraph PV1 PE1 g) is_null ->
  MathGraph (gpredicate_subgraph PV2 PE2 g) is_null ->
  BinGraph (gpredicate_subgraph PV1 PE1 g) left_out_edge right_out_edge ->
  BinGraph (gpredicate_subgraph PV2 PE2 g) left_out_edge right_out_edge ->
  BinGraph (gpredicate_subgraph PV PE g) left_out_edge right_out_edge.
Proof.
  intros.
  constructor.
  + intros.
    simpl in H5.
    rewrite Intersection_spec in H5.
    destruct H5.
    destruct H as [? _].
    rewrite H in H6; destruct H6.
    - apply (@bin_consist _ _ _ H3).
      split; auto.
    - apply (@bin_consist _ _ _ H4).
      split; auto.
  + intros.
    simpl in H5.
    rewrite Intersection_spec in H5.
    destruct H5.
    destruct H as [HH HH0].
    rewrite HH in H6.
    destruct H6 as [H6 | H6]; [pose proof HH0 _ H6 | pose proof (fun H => HH0 _ H H6)].
    - pose proof @only_two_edges _ _ _ H3 x e.
      simpl in H7; rewrite !Intersection_spec in H7; specialize (H7 (conj H5 H6)).
      rewrite <- H7; simpl.
      rewrite Intersection_spec.
      apply and_iff_compat_l_weak; intros.
      apply and_iff_compat_l_weak; intros.
      destruct H0 as [HH1 HH2].
      rewrite HH1.
      assert (~ PE2 e); [intro | tauto].
      pose proof valid_graph (gpredicate_subgraph PV2 PE2 g) e.
      simpl in H10; rewrite !Intersection_spec in H10.
      specialize (H10 (conj H9 H0)).
      subst x.
      pose proof (fun H => HH2 _ H H0).
      tauto.
    - pose proof @only_two_edges _ _ _ H4 x e.
      simpl in H7; rewrite !Intersection_spec in H7; specialize (H7 (conj H5 H6)).
      rewrite <- H7; simpl.
      rewrite Intersection_spec.
      apply and_iff_compat_l_weak; intros.
      apply and_iff_compat_l_weak; intros.
      destruct H0 as [HH1 HH2].
      rewrite HH1.
      assert (~ PE1 e); [intro | tauto].
      pose proof valid_graph (gpredicate_subgraph PV1 PE1 g) e.
      simpl in H10; rewrite !Intersection_spec in H10.
      specialize (H10 (conj H9 H0)).
      subst x.
      pose proof (HH2 _ H0).
      tauto.
Qed.

Lemma bin_graph_join': forall (g: PreGraph V E) (PV1 PV2 PV: V -> Prop) (PE1 PE2 PE: E -> Prop),
  Prop_join PV1 PV2 PV ->
  Prop_join PE1 PE2 PE ->
  MathGraph' (gpredicate_subgraph PV1 PE1 g) is_null ->
  MathGraph' (gpredicate_subgraph PV2 PE2 g) is_null ->
  BinGraph (gpredicate_subgraph PV1 PE1 g) left_out_edge right_out_edge ->
  BinGraph (gpredicate_subgraph PV2 PE2 g) left_out_edge right_out_edge ->
  BinGraph (gpredicate_subgraph PV PE g) left_out_edge right_out_edge.
Proof.
  intros.
  constructor.
  + intros.
    simpl in H5.
    rewrite Intersection_spec in H5.
    destruct H5.
    destruct H as [? _].
    rewrite H in H6; destruct H6.
    - apply (@bin_consist _ _ _ H3).
      split; auto.
    - apply (@bin_consist _ _ _ H4).
      split; auto.
  + intros.
    simpl in H5.
    rewrite Intersection_spec in H5.
    destruct H5.
    destruct H as [HH HH0].
    rewrite HH in H6.
    destruct H6 as [H6 | H6]; [pose proof HH0 _ H6 | pose proof (fun H => HH0 _ H H6)].
    - pose proof @only_two_edges _ _ _ H3 x e.
      simpl in H7; rewrite !Intersection_spec in H7; specialize (H7 (conj H5 H6)).
      rewrite <- H7; simpl.
      rewrite Intersection_spec.
      apply and_iff_compat_l_weak; intros.
      apply and_iff_compat_l_weak; intros.
      destruct H0 as [HH1 HH2].
      rewrite HH1.
      assert (~ PE2 e); [intro | tauto].
      pose proof valid_graph' (gpredicate_subgraph PV2 PE2 g) e.
      simpl in H10; rewrite !Intersection_spec in H10.
      specialize (H10 (conj H9 H0)).
      subst x.
      pose proof (fun H => HH2 _ H H0).
      tauto.
    - pose proof @only_two_edges _ _ _ H4 x e.
      simpl in H7; rewrite !Intersection_spec in H7; specialize (H7 (conj H5 H6)).
      rewrite <- H7; simpl.
      rewrite Intersection_spec.
      apply and_iff_compat_l_weak; intros.
      apply and_iff_compat_l_weak; intros.
      destruct H0 as [HH1 HH2].
      rewrite HH1.
      assert (~ PE1 e); [intro | tauto].
      pose proof valid_graph' (gpredicate_subgraph PV1 PE1 g) e.
      simpl in H10; rewrite !Intersection_spec in H10.
      specialize (H10 (conj H9 H0)).
      subst x.
      pose proof (HH2 _ H0).
      tauto.
Qed.

End BinGraph.


From Undecidability.L Require Import L Tactics.LTactics LBool.
(*From Undecidability.L.Complexity Require Import Monotonic UpToC.*)

Class eqbClass X (eqb : X -> X -> bool): Type :=
  _eqb_spec : forall (x y:X), reflect (x=y) (eqb x y).

#[export] Hint Mode eqbClass + -: typeclass_instances. (* treat argument as input and force evar-freeness*)

Definition eqb X eqb `{H:eqbClass (X:=X) eqb} := eqb.

Arguments eqb {_ _ _}: simpl never.

Lemma eqb_spec {X} {f : X -> X -> bool} {_:eqbClass f}:
  forall (x y:X), reflect (x=y) (eqb x y).
Proof.
  intros. eapply _eqb_spec.
Qed.

Instance eqbBool_inst : eqbClass Bool.eqb.
Proof.
  intros ? ?. eapply iff_reflect. rewrite eqb_true_iff. reflexivity.
Qed.

Lemma dec_reflect_remove {P Y} (d:dec P) b (H:reflect P b) (y y' : Y):
  (if d then y else y') = (if b then y else y').
Proof.
  destruct H,d;easy.
Qed.

Lemma eqDec_remove {X Y eqb} {H:eqbClass (X:=X) eqb} x x' (d:dec (x=x')) (a b : Y):
  (if d then a else b) = (if eqb x x' then a else b).
Proof.
  apply dec_reflect_remove. eapply eqb_spec.
Qed.

Class eqbCompT X {R:registered X} eqb {H:eqbClass (X:=X) eqb} :=
  { c__eqbComp :nat;
    eqbTime x y:= min x y* c__eqbComp;
    comp_eqb : computableTime' eqb (fun x _ =>(5,fun y _ => (eqbTime (size (enc x)) (size (enc y)),tt)))
  }.
Arguments eqbCompT _ {_ _ _}.
Arguments c__eqbComp _ {_ _ _ _}.

#[export] Hint Mode eqbCompT + - - -: typeclass_instances.

Existing Instance comp_eqb.

Instance eqbComp_bool : eqbCompT bool.
Proof.
  evar (c:nat). exists c. unfold Bool.eqb.
  unfold enc;cbn.
  extract.
  solverec.
  [c]:exact 3.
  all:unfold c;try lia.
Qed.

Lemma eqbTime_le_l X {R : registered X} (eqb : X -> X -> bool) {H : eqbClass eqb}
      {H' : eqbCompT X} x n':
  eqbTime (X:=X) x n' <= x * c__eqbComp X.
Proof.
  unfold eqbTime. rewrite Nat.le_min_l. easy.
Qed.

Lemma eqbTime_le_r X (R : registered X) (eqb : X -> X -> bool) (H : eqbClass eqb)
      (eqbCompT : eqbCompT X) x n':
  eqbTime (X:=X) n' x <= x * c__eqbComp X.
Proof.
  unfold eqbTime. rewrite Nat.le_min_r. easy.
Qed.

(*
Lemma eqbTime_upToC X {R:registered X} eqb {H:eqbClass (X:=X) eqb} {_:eqbCompT X}:
  eqbTime (X:=X) <=c (fun (x y:nat) => min x y).
Proof.
  unfold eqbTime. hnf.
  exists (c__eqbComp X). unfold leHO;repeat intro; cbn;nia.
Qed.
*)


From Tealeaves.Classes Require Export
  Decorated.Functor
  Kleisli.Decorated.Functor.

Import Product.Notations.
Import Comonad.Notations.

#[local] Generalizable Variables T E A B C.

Section operations.

  Context
    (E : Type)
    (T : Type -> Type)
    `{Fmapd E T}.

  #[export] Instance Decorate_Fmapd: Decorate E T := fun A => fmapd T (@id ((E ×) A)).

End operations.

Import Kleisli.Decorated.Functor.ToFunctor.

Section properties.

  Context
    (E : Type)
    (T : Type -> Type)
    `{Kleisli.Decorated.Functor.DecoratedFunctor E T}.

  Lemma dec_dec : forall (A : Type),
      dec T ∘ dec T = fmap T (cojoin (E ×)) ∘ dec T (A := A).
  Proof.
    intros.
    (* Merge LHS *)
    unfold_ops @Decorate_Fmapd.
    rewrite (dfun_fmapd2 E T).
    (* Merge RHS *)
    unfold_ops @Fmap_Fmapd.
    rewrite (dfun_fmapd2 E T).
    reassociate ->. rewrite (extract_cobind (E ×)).
    fequal. now ext [e a].
  Qed.

  Lemma dec_extract : forall (A : Type),
      fmap T (extract (E ×)) ∘ dec T = @id (T A).
  Proof.
    intros.
    unfold_ops @Decorate_Fmapd.
    unfold_ops @Fmap_Fmapd.
    rewrite (dfun_fmapd2 E T).
    reassociate ->. rewrite (extract_cobind (E ×)).
    apply (dfun_fmapd1 E T).
  Qed.

  Lemma dec_natural : Natural (@dec E T _).
  Proof.
    constructor.
    - typeclasses eauto.
    - typeclasses eauto.
    - intros. unfold_ops @Fmap_compose.
      unfold_ops @Fmap_Fmapd.
      unfold_ops @Decorate_Fmapd.
      rewrite (dfun_fmapd2 E T).
      rewrite (dfun_fmapd2 E T).
      reassociate ->. rewrite (extract_cobind (E ×)).
      now rewrite <- (fmap_to_cobind (E ×)).
  Qed.

  #[export] Instance: Classes.Decorated.Functor.DecoratedFunctor E T :=
    {| dfun_dec_natural := dec_natural;
      dfun_dec_dec := dec_dec;
      dfun_dec_extract := dec_extract;
    |}.

End properties.

Import Kleisli.Decorated.Functor.ToFunctor.

Module Roundtrip1.

  Context
    `{fmapT : Fmap T}
    `{decT : Decorate E T}
    `{! Classes.Decorated.Functor.DecoratedFunctor E T}.

  #[local] Instance fmapd' : Fmapd E T := ToKleisli.Fmapd_dec E T.

  Definition fmap' : Fmap T := Fmap_Fmapd T.
  Definition dec' : Decorate E T := Decorate_Fmapd E T.

  Goal fmapT = fmap'.
  Proof.
    unfold fmap'. unfold_ops @Fmap_Fmapd.
    unfold fmapd, fmapd'.
    unfold_ops @ToKleisli.Fmapd_dec.
    ext A B f.
    rewrite <- (fun_fmap_fmap T).
    reassociate ->.
    rewrite (dfun_dec_extract E T).
    reflexivity.
  Qed.

  Goal decT = dec'.
  Proof.
    unfold dec'. unfold_ops @Decorate_Fmapd.
    unfold fmapd, fmapd'.
    unfold_ops @ToKleisli.Fmapd_dec.
    ext A.
    rewrite (fun_fmap_id T).
    reflexivity.
  Qed.

End Roundtrip1.

Module Roundtrip2.

  Context
    `{fmapdT : Fmapd E T}
    `{! Classes.Kleisli.Decorated.Functor.DecoratedFunctor E T}.

  #[local] Instance fmap' : Fmap T := Fmap_Fmapd T.
  #[local] Instance dec' : Decorate E T := Decorate_Fmapd E T.

  Definition fmapd' : Fmapd E T := ToKleisli.Fmapd_dec E T.

  Goal fmapdT = fmapd'.
  Proof.
    unfold fmapd'. unfold_ops @ToKleisli.Fmapd_dec.
    unfold fmap, fmap', dec, dec'.
    unfold_ops @Fmap_Fmapd.
    unfold_ops @Decorate_Fmapd.
    ext A B f.
    unfold_compose_in_compose.
    rewrite (dfun_fmapd2 E T).
    reassociate -> on right.
    rewrite (extract_cobind (E ×)).
    reflexivity.
  Qed.

End Roundtrip2.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Eqdep.

Require Export CatSem.PCF_order_comp.RPCF_rep_comp.
Require Export CatSem.PCF_order_comp.RPCF_rep_id.
Require Export CatSem.PCF_order_comp.RPCF_rep_eq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Obligation Tactic := idtac.

Program Instance REP_s :
     Cat_struct (obj := PCFPO_rep) (PCFPO_rep_Hom) := {
  mor_oid P R := eq_Rep_oid P R ;
  id R := PCFPO_id R ;
  comp a b c f g := Rep_comp f g
}.
Next Obligation.
Proof.
  intros a b c.
  unfold Proper; do 2 red.
  intros M N H.
  induction H.
  simpl in *.
  intros S T H'.
  induction H'.
  simpl in *.

  assert (He : (forall t, tcomp (Rep_comp c0 c1) t =
                          tcomp (Rep_comp a0 a1) t)).
    simpl.
    intro t.
    rewrite H;
    rewrite H1; auto.
  apply (eq_rep (H:=He)).

  destruct c1.
  destruct a1.
  destruct c0.
  destruct a0.

  simpl in *.
  intros V t y.
  assert (K1 : tcomp = tcomp0).
    apply functional_extensionality. auto.
  assert (K2 : tcomp1 = tcomp2).
    apply functional_extensionality. auto.

  generalize dependent He.
  subst.

  intro He.

  assert (Hl := rlift_transp_id).
  assert (Hl':= Hl _ _ _ c He).
  assert (Hll := Hl' _ _
  (RMon_car (f:=tcomp2) (f':=tcomp0)
          rep_Hom_monad2 rep_Hom_monad0 V t y)).

  simpl in *.
  rewrite Hll.
  simpl.

  assert (Hk := transp_id He).
  simpl in Hk.
  rewrite Hk.
  simpl.

  clear Hk Hll Hl' Hl.

  destruct y as [t y].
  simpl in *.
  apply f_equal.

  assert (H0spec := H0 _ _ (ctype _ y)).
  assert (H0r := rlift_transp_id (Q:=b) H
               (rep_Hom_monad2 V (tcomp2 t)
        (ctype (fun t : type_type a => tcomp2 t)
                (V:=a V) (t:=t) y))).
  simpl in *.

  rewrite H0r in H0spec. simpl in *.
  rewrite (UIP_refl _ _ (H t)) in H0spec.
  simpl in *.
  rewrite H0spec.
  simpl.

  clear H0r.
  clear H0spec.
  clear H0.

  assert (H2spec := H2 _ _
  ((ctype (fun t0 : type_type b => tcomp0 t0)
   (V:=b (retype (fun t0 : type_type a => tcomp2 t0) V))
          (t:=tcomp2 t)
     (rep_Hom_monad1 V (tcomp2 t)
        (ctype (fun t0 : type_type a => tcomp2 t0)
   (V:=a V) (t:=t) y))))).
   simpl.

  assert (H2r := rlift_transp_id (Q:=c) H1).
  simpl in H2r.
  rewrite H2r in H2spec.
  simpl in *.
  rewrite H2spec.

  apply f_equal.
  rewrite (UIP_refl _ _ (H1 (tcomp2 t))).
  simpl.
  auto.
Qed.

Next Obligation.
Proof.
  simpl.
  intros a b f.
  assert (H : forall t, tcomp f t =
    tcomp (Rep_comp f (PCFPO_id b)) t)
    by (simpl; auto).

  apply (eq_rep (H:=H)); simpl.

  intros V t y.
  destruct y as [t y].
  simpl.

  destruct f.
  simpl in *.

  rewrite (UIP_refl _ _ (H t)).
  simpl.

  assert (HH:=rlift_transp_id (Q:=b) H).
  simpl in *.
  rewrite HH.
  simpl.

  assert (Hl := rlift_rlift b).
  simpl in Hl.
  rewrite Hl.
  simpl.
  assert (He := rlift_eq_id b).
  simpl in He.
  apply He.

  clear t y.
  intros t y.
  destruct y as [t y];
  simpl; auto.
Qed.
Next Obligation.
  simpl.
  intros a b f.
  assert (H : forall t, tcomp f t =
    tcomp (Rep_comp (PCFPO_id a) f) t)
    by (simpl; auto).

  apply (eq_rep (H:=H)); simpl.

  intros V t y.
  destruct y as [t y].
  simpl.

  destruct f.
  simpl in *.

  rewrite (UIP_refl _ _ (H t)).
  simpl.

  assert (HH:=rlift_transp_id (Q:=b) H).
  simpl in *.
  rewrite HH.
  simpl.

  assert (H3:=gen_rh_rlift rep_Hom_monad).
  simpl in *.
  assert (H4 :=H3 _ _ (id_retype(V:=V))t y ).
  simpl in H4.
  rewrite <- H4.
  clear H4.

  assert (Hl := rlift_rlift b).
  simpl in Hl.
  rewrite Hl.
  simpl.
  assert (He := rlift_eq_id b).
  simpl in He.
  apply He.

  clear t y.
  intros t y.
  destruct y as [t y];
  simpl; auto.
Qed.
Next Obligation.
Proof.
  intros a b c c' f g h.
  assert (H : forall t,
    tcomp (Rep_comp f (Rep_comp g h)) t =
    tcomp (Rep_comp (Rep_comp f g) h) t) by
          (simpl; auto).
  apply (eq_rep (H:=H)).
  simpl.
  intros V t y.
  destruct h.
  destruct g.
  destruct f.
  simpl in *.

  assert (Hl:=rlift_transp_id (Q:=c') H).
  simpl in Hl.
  rewrite Hl.

  assert (Ht := transp_id H).
  simpl in Ht.
  rewrite Ht.

  destruct y as [t y].
  simpl in *.

  assert (Hc' := rlift_rlift c').
  simpl in Hc'.
  rewrite Hc'.

  assert (H3:=gen_rh_rlift rep_Hom_monad).
  rewrite <- (H3 _ _ (double_retype_1 (f:=tcomp1)
                             (f':=tcomp0)(V:= V))).

  rewrite Hc'.

  apply (rlift_eq c').
  simpl.

  clear t y.
  intros t y.
  destruct y as [t y].
  simpl.
  destruct y as [t y].
  simpl.
  destruct y as [t y].
  simpl;
  auto.
Qed.

Canonical Structure REP : Cat := Build_Cat REP_s.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Floating-point format with gradual underflow *)
Require Import Raux Defs Round_pred Generic_fmt Float_prop.
Require Import FLX FIX Ulp Round_NE.

Section RND_FLT.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.

Context { prec_gt_0_ : Prec_gt_0 prec }.

Inductive FLT_format (x : R) : Prop :=
  FLT_spec (f : float beta) :
    x = F2R f -> (Zabs (Fnum f) < Zpower beta prec)%Z ->
    (emin <= Fexp f)%Z -> FLT_format x.

Definition FLT_exp e := Zmax (e - prec) emin.

(** Properties of the FLT format *)
Global Instance FLT_exp_valid : Valid_exp FLT_exp.
Proof.
intros k.
unfold FLT_exp.
generalize (prec_gt_0 prec).
repeat split ;
  intros ; zify ; omega.
Qed.

Theorem generic_format_FLT :
  forall x, FLT_format x -> generic_format beta FLT_exp x.
Proof.
clear prec_gt_0_.
intros x [[mx ex] H1 H2 H3].
simpl in H2, H3.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold cexp, FLT_exp.
rewrite mag_F2R with (1 := Zmx).
apply Zmax_lub with (2 := H3).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply mag_le_Zpower.
Qed.

Theorem FLT_format_generic :
  forall x, generic_format beta FLT_exp x -> FLT_format x.
Proof.
intros x.
unfold generic_format.
set (ex := cexp beta FLT_exp x).
set (mx := Ztrunc (scaled_mantissa beta FLT_exp x)).
intros Hx.
rewrite Hx.
eexists ; repeat split ; simpl.
apply lt_IZR.
rewrite IZR_Zpower. 2: now apply Zlt_le_weak.
apply Rmult_lt_reg_r with (bpow ex).
apply bpow_gt_0.
rewrite <- bpow_plus.
change (F2R (Float beta (Zabs mx) ex) < bpow (prec + ex))%R.
rewrite F2R_Zabs.
rewrite <- Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
unfold cexp in ex.
destruct (mag beta x) as (ex', He).
simpl in ex.
specialize (He Hx0).
apply Rlt_le_trans with (1 := proj2 He).
apply bpow_le.
cut (ex' - prec <= ex)%Z. omega.
unfold ex, FLT_exp.
apply Zle_max_l.
apply Zle_max_r.
Qed.

Theorem FLT_format_bpow :
  forall e, (emin <= e)%Z -> generic_format beta FLT_exp (bpow e).
Proof.
intros e He.
apply generic_format_bpow; unfold FLT_exp.
apply Z.max_case; try assumption.
unfold Prec_gt_0 in prec_gt_0_; omega.
Qed.

Theorem FLT_format_satisfies_any :
  satisfies_any FLT_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLT_exp)).
intros x.
split.
apply FLT_format_generic.
apply generic_format_FLT.
Qed.

Theorem cexp_FLT_FLX :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  cexp beta FLT_exp x = cexp beta (FLX_exp prec) x.
Proof.
intros x Hx.
assert (Hx0: x <> 0%R).
intros H1; rewrite H1, Rabs_R0 in Hx.
contradict Hx; apply Rlt_not_le, bpow_gt_0.
unfold cexp.
apply Zmax_left.
destruct (mag beta x) as (ex, He).
unfold FLX_exp. simpl.
specialize (He Hx0).
cut (emin + prec - 1 < ex)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := Hx).
apply He.
Qed.

(** Links between FLT and FLX *)
Theorem generic_format_FLT_FLX :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  generic_format beta (FLX_exp prec) x ->
  generic_format beta FLT_exp x.
Proof.
intros x Hx H.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply generic_format_0.
unfold generic_format, scaled_mantissa.
now rewrite cexp_FLT_FLX.
Qed.

Theorem generic_format_FLX_FLT :
  forall x : R,
  generic_format beta FLT_exp x -> generic_format beta (FLX_exp prec) x.
Proof.
clear prec_gt_0_.
intros x Hx.
unfold generic_format in Hx; rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
unfold cexp, FLX_exp, FLT_exp.
apply Zle_max_l.
Qed.

Theorem round_FLT_FLX : forall rnd x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  round beta FLT_exp rnd x = round beta (FLX_exp prec) rnd x.
Proof.
intros rnd x Hx.
unfold round, scaled_mantissa.
rewrite cexp_FLT_FLX ; trivial.
Qed.

(** Links between FLT and FIX (underflow) *)
Theorem cexp_FLT_FIX :
  forall x, x <> 0%R ->
  (Rabs x < bpow (emin + prec))%R ->
  cexp beta FLT_exp x = cexp beta (FIX_exp emin) x.
Proof.
intros x Hx0 Hx.
unfold cexp.
apply Zmax_right.
unfold FIX_exp.
destruct (mag beta x) as (ex, Hex).
simpl.
cut (ex - 1 < emin + prec)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := Hx).
now apply Hex.
Qed.

Theorem generic_format_FIX_FLT :
  forall x : R,
  generic_format beta FLT_exp x ->
  generic_format beta (FIX_exp emin) x.
Proof.
clear prec_gt_0_.
intros x Hx.
rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
apply Zle_max_r.
Qed.

Theorem generic_format_FLT_FIX :
  forall x : R,
  (Rabs x <= bpow (emin + prec))%R ->
  generic_format beta (FIX_exp emin) x ->
  generic_format beta FLT_exp x.
Proof with auto with typeclass_instances.
apply generic_inclusion_le...
intros e He.
unfold FIX_exp.
apply Zmax_lub.
omega.
apply Zle_refl.
Qed.

Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R ->
    ulp beta FLT_exp x = bpow emin.
Proof with auto with typeclass_instances.
intros x Hx.
unfold ulp; case Req_bool_spec; intros Hx2.
(* x = 0 *)
case (negligible_exp_spec FLT_exp).
intros T; specialize (T (emin-1)%Z); contradict T.
apply Zle_not_lt; unfold FLT_exp.
apply Zle_trans with (2:=Z.le_max_r _ _); omega.
assert (V:FLT_exp emin = emin).
unfold FLT_exp; apply Z.max_r.
unfold Prec_gt_0 in prec_gt_0_; omega.
intros n H2; rewrite <-V.
apply f_equal, fexp_negligible_exp_eq...
omega.
(* x <> 0 *)
apply f_equal; unfold cexp, FLT_exp.
apply Z.max_r.
assert (mag beta x-1 < emin+prec)%Z;[idtac|omega].
destruct (mag beta x) as (e,He); simpl.
apply lt_bpow with beta.
apply Rle_lt_trans with (2:=Hx).
now apply He.
Qed.

Theorem ulp_FLT_le :
  forall x, (bpow (emin + prec - 1) <= Rabs x)%R ->
  (ulp beta FLT_exp x <= Rabs x * bpow (1 - prec))%R.
Proof.
intros x Hx.
assert (Zx : (x <> 0)%R).
  intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt.
  rewrite Z, Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0 with (1 := Zx).
unfold cexp, FLT_exp.
destruct (mag beta x) as (e,He).
apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R.
rewrite <- bpow_plus.
right; apply f_equal.
replace (e - 1 + (1 - prec))%Z with (e - prec)%Z by ring.
apply Z.max_l.
assert (emin+prec-1 < e)%Z; try omega.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=Hx).
now apply He.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply He.
Qed.

Theorem ulp_FLT_gt :
  forall x, (Rabs x * bpow (-prec) < ulp beta FLT_exp x)%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0.
rewrite Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLT_exp.
apply Rlt_le_trans with (bpow (mag beta x)*bpow (-prec))%R.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
now apply bpow_mag_gt.
rewrite <- bpow_plus.
apply bpow_le.
apply Z.le_max_l.
Qed.

(** FLT is a nice format: it has a monotone exponent... *)
Global Instance FLT_exp_monotone : Monotone_exp FLT_exp.
Proof.
intros ex ey.
unfold FLT_exp.
zify ; omega.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z.

Global Instance exists_NE_FLT : Exists_NE beta FLT_exp.
Proof.
destruct NE_prop as [H|H].
now left.
right.
intros e.
unfold FLT_exp.
destruct (Zmax_spec (e - prec) emin) as [(H1,H2)|(H1,H2)] ;
  rewrite H2 ; clear H2.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (e - prec + 1 - prec) emin).
omega.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (emin + 1 - prec) emin).
omega.
Qed.

End RND_FLT.


(* -*- coding: utf-8 -*- *)

Require Import Coq.Program.Basics.

Module Typeclasses.

Local Open Scope program_scope.

Reserved Notation "f <$> a" (at level 40).

Class Functor f := {
  fmap {A B} : (A -> B) -> f A -> f B where "f <$> a" := (fmap f a);
  functor_hom : forall {A B C} (g : B -> C) (h : A -> B) x,
    fmap (g ∘ h) x = (fmap g ∘ fmap h) x;
  functor_id : forall A x, @fmap A A id x = id x;
}.

Notation "f <$> a" := (fmap f a).

Reserved Notation "a <*> b" (at level 40).

Class Applicative f:= {
  applic_is_functor :> Functor f;
  pure : forall {A}, A -> f A;
  comb : forall {A B}, f (A -> B) -> f A -> f B where "a <*> b" := (comb a b);
  applic_id : forall {A} (x : f A), comb (pure id) x = x;
  applic_hom : forall {A B} (f : A -> B) x,
    pure f <*> pure x = pure (f x);
  applic_inter : forall {A B} (u : f (A -> B)) y,
    u <*> pure y = pure (fun f => f y) <*> u;
  applic_comp : forall {A B C} (u : f (B -> C)) (v : f (A -> B)) w,
    u <*> comb v w = pure compose <*> u <*> v <*> w;
}.

Notation "a <*> b" := (comb a b).

Notation "a <$ b" := ((comb ∘ pure ∘ const) a b) (at level 40).

Notation "a *> b" := ((id <$ a) <*> b) (at level 40).

Notation "a <* b" := (const <$> a <*> b) (at level 40).

Reserved Notation "a <+> b" (at level 30).

Class Monoid f := {
  mempty  : forall {A : Type}, f A;
  mappend : forall {A}, f A -> f A -> f A where "a <+> b" := (mappend a b);
  monoid_left_empty : forall {A} (x : f A),
    mempty <+> x = x;
  monoid_right_empty : forall {A} (x : f A),
    x <+> mempty = x;
  monoid_assoc : forall {A} (x y z : f A),
    (x <+> y) <+> z = x <+> (y <+> z);
}.

Notation "a <+> b" := (mappend a b).

Class Alternative f := {
  altern_is_applic :> Applicative f;
  altern_is_monoid :> Monoid f;
}.

Definition altern_or {f: Type -> Type} {falt: Alternative f}
  {A} (a b: f A) := mappend a b.

Notation "a <|> b" := (altern_or a b) (at level 30).

Instance option_Functor : Functor option := {
  fmap A B f m := match m with | None => None | Some m' => Some (f m') end;
}.
Proof.
  destruct x; auto...
  destruct x; auto...
Defined.

Instance option_Applicative : Applicative option := {
  pure A x := Some x;
  comb A B f x := match f with | None => None | Some f' => fmap f' x end;
}.
Proof.
  destruct x; auto...
  auto...
  auto...
  destruct w; destruct v; destruct u; auto...
Defined.

Instance option_Monoid : Monoid option := {
  mempty A := None;
  mappend A l r := match l with None => r | Some x => Some x end;
}.
Proof.
  auto...
  destruct x; auto...
  destruct x; auto...
Defined.

Instance option_Alternative : Alternative option := {}.

Local Close Scope program_scope.

End Typeclasses.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.
Require Import Coq.Program.Equality.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

Require Import FinProof.All.
Require Import FinProof.CommonInstances.

Require Import UMLang.ExecGenerator.
Require Import UMLang.ExecGen.GenFlags.
Require Import UMLang.ExecGen.ExecGenDefs.
Require Import UMLang.All.

Require Import UrsusStdLib.Solidity.All.

Require Import UrsusTVM.Solidity.All.

(* Require Import Blank.ClassTypesNotations. *)

(* Set Typeclasses Depth 100. *)

Import UrsusNotations.
Local Open Scope ursus_scope.
Local Open Scope usolidity_scope.
Local Open Scope struct_scope.
Local Open Scope N_scope.
Local Open Scope string_scope.
Local Open Scope xlist_scope.

(*

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.
 *)
Require Import Logic.FunctionalExtensionality.
From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Import CommonQCEnvironment.
Require Import STS.Props.
Require Import CommonForProps.

Require Import  SetcodeMultisig.

Definition STS_1_propb l
        (dest :  address)
        (value :  uint128)
        (bounce :  boolean)
        (flags :  uint8)
        (payload :  cell_)
        (mpk: uint256)
        (acc: bool)
        (bal: N)
        timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_balance := Build_XUBInteger (10 * bal) $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

STS_1 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState := l $$}
                            with Ledger_VMState := v4 $$})
       dest value bounce flags payload  ? .

(* OK *)
QuickCheck STS_1_propb.

Definition STS_2_propb l
        (dest :  address)
        (value :  uint128)
        (bounce :  boolean)
        (flags :  uint8)
        (payload :  cell_)
        (mpk: uint256)
        (acc: bool)
        (bal: N)
        timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_balance := Build_XUBInteger (10 * bal) $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in

STS_2 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState := l $$}
                            with Ledger_VMState := v4 $$})
       dest value bounce flags payload  ? .

(* OK *)
QuickCheck STS_2_propb.

Definition STS_3_1_propb l
            (dest :  address)
            (value :  uint128)
            (bounce :  boolean)
            (flags :  uint8)
            (payload :  cell_)
            (mpk: uint256)
            (acc: bool)
            (bal: N)
            timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_balance := Build_XUBInteger (10 * bal) $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in
let custodians := CommonInstances.wrap Map (Datatypes.cons (mpk, Build_XUBInteger 0) Datatypes.nil) in

STS_3_1 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState :=
                {$$ l with  _m_custodians := custodians $$}
         $$}with Ledger_VMState := v4 $$})
       dest value bounce flags payload  ? .

(* OK *)
QuickCheck STS_3_1_propb.

Definition STS_3_2_propb l
            (dest :  address)
            (value :  uint128)
            (bounce :  boolean)
            (flags :  uint8)
            (payload :  cell_)
            (mpk: uint256)
            (acc: bool)
            (bal: N)
            timestamp
        now: bool :=
let v0 := {$$ VMStateDefault with VMState_ι_msg_pubkey := mpk $$} in
let v1 := {$$ v0 with VMState_ι_accepted := acc $$} in
let v2 := {$$ v1 with VMState_ι_balance := Build_XUBInteger (10 * bal) $$} in
let v3 := {$$ v2 with VMState_ι_now := now $$} in
let v4 := {$$ v3 with VMState_ι_timestamp := timestamp $$} in
let custodians := CommonInstances.wrap Map (Datatypes.cons (mpk, Build_XUBInteger 0) Datatypes.nil) in

STS_3_2 (quickFixState {$$
        {$$ LedgerDefault with Ledger_MainState :=
                {$$ l with  _m_custodians := custodians $$}
         $$}with Ledger_VMState := v4 $$})
       dest value bounce flags payload  ? .

(* OK *)
QuickCheck STS_3_2_propb.


Require Import Events.
Require Import TraceModel.
Require Import Properties.
Require Import CommonST.
Require Import ClassicalExtras.
Require Import List.
Import ListNotations.

Axiom classicT : forall (P : Prop), {P} + {~ P}.
Axiom indefinite_description : forall (A : Type) (P : A->Prop),
   ex P -> sig P.

(** This file provides a abstract definition of small-step operational
    semantics.  Then, we show that under certain assumptions of
    *determinacy* of configurations, these semantics satisfy the
    particular property that we call "Safety-Like". This property,
    along with determinacy, can be used to prove that R2rSP => RTEP
    (file r2RSC_teq.v)
*)
Section SmallSteps.

Variable partial : Set.
Variable program : Set.
Variable context : Set.
Variable plug : partial -> context -> program.

Variable cfg : Set.
Variable init : program -> cfg.
Variable step : cfg -> event -> cfg -> Prop.

Definition stuck (c:cfg) : Prop :=  forall e c', ~step c e c'.
Variable es_of_cfg : forall (c : cfg), stuck c -> endstate.

Variable silent : event -> Prop.

CoInductive can_loop_silent : cfg -> Prop :=
| FSilent : forall c e c', step c e c' -> silent e -> can_loop_silent c' -> can_loop_silent c.
Hint Constructors can_loop_silent.

(** Reflexive Transitive Closure of the step relation *)
Inductive steps' : cfg -> list event -> cfg -> Prop :=
| SSTbd : forall c, steps' c nil c
| SSCons : forall c e c' m c'', step c e c' -> ~silent e -> steps' c' m c'' ->
                                                            steps' c (cons e m) c''
| SSSilent : forall c e c' c'' m, step c e c' -> silent e -> steps' c' m c'' -> steps' c m c''.
Hint Constructors steps'.

Lemma steps'_refl : forall c,
    steps' c [] c.
Proof.
  eauto.
Qed.
Hint Resolve steps'_refl.

Lemma steps'_trans : forall c1 c2 c3 m m',
    steps' c1 m c2 -> steps' c2 m' c3 -> steps' c1 (m ++ m') c3.
Proof.
  intros c1 c2 c3 m m' H H0. generalize dependent c3. generalize dependent m'.
  induction H; intros; simpl; eauto.
Qed.
Hint Resolve steps'_trans.

Lemma steps'_cons : forall c c' e m,
    steps' c (e :: m) c' -> exists c'', steps' c [e] c'' /\ steps' c'' m c'.
Proof.
  intros c c' e m H.
  remember (e :: m) as mm.
  induction H.
  - inversion Heqmm.
  - inversion Heqmm; subst.
    exists c'. split; eauto.
  - inversion Heqmm; subst.
    specialize (IHsteps' H2).
    destruct IHsteps' as [c0 [Hc01 Hc02]].
    exists c0; eauto.
Qed.
Hint Resolve steps'_cons.

Inductive steps : cfg -> finpref -> cfg -> Prop :=
| steps_ftbd : forall c m' c', steps' c m' c' -> steps c (ftbd m') c'
| steps_fstop : forall c m' c' (H : stuck c'), steps' c m' c' -> steps c (fstop m' (es_of_cfg c' H)) c'.

(* Definition steps (c:cfg) (m:finpref) (c':cfg) : Prop := *)
(*   match m with *)
(*   | ftbd m' => steps' c m' c' *)
(*   | fstop m' es => steps' c m' c' /\ stuck c' *)
(*   end. *)

Hint Constructors steps.

(* Keep that for later, maybe it will be useful *)
(* Inductive steps_silent : cfg -> cfg -> Prop := *)
(* | SilOne : forall (c c': cfg) (e : event), step c e c' -> silent e -> steps_silent c c' *)
(* | SilCons : forall (c c' c'' : cfg) (e : event), *)
(*     step c e c' -> silent e -> steps_silent c' c'' -> steps_silent c c''. *)
(* Hint Constructors steps_silent. *)

(* Lemma steps_silent_trans : forall c1 c2 c3, *)
(*     steps_silent c1 c2 -> steps_silent c2 c3 -> steps_silent c1 c3. *)
(* Proof. *)
(*   intros c1 c2 c3 H H0. generalize dependent c3. *)
(*   induction H; intros; simpl; eauto. *)
(* Qed. *)
(* Hint Resolve steps_silent_trans. *)

(* Lemma steps_silent_cons : forall c c', *)
(*     steps_silent c c' -> *)
(*     (exists e, step c e c' /\ silent e) \/ (exists c'', steps_silent c c'' /\ steps_silent c'' c'). *)
(* Proof. *)
(*   intros c c' H. *)
(*   induction H. *)
(*   - left; eexists; now eauto. *)
(*   - right; eexists; eauto. *)
(* Qed. *)
(* Hint Resolve steps_silent_cons. *)

(* must terminate or cause non-silent event ... TODO: but that's not
   what we can easily write, folowing definition may termination *)
Definition cannot_loop_silent (c:cfg) : Prop :=
  forall c', steps' c nil c' -> exists e c'', steps' c' (cons e nil) c''.

Definition does_event_or_goes_wrong' (c : cfg) :=
  exists m c', steps' c m c' /\ (stuck c' \/ m <> []).

Lemma not_can_loop_silent' :  forall c, ~(can_loop_silent c) -> does_event_or_goes_wrong' c.
Proof.
  intros c.
  rewrite contra. intros Hc. rewrite <- dne.
  generalize dependent c.
  cofix Hfix.
  - intros c Hc.
    unfold does_event_or_goes_wrong' in Hc.
    assert (~ stuck c).
    { rewrite not_ex_forall_not in Hc. specialize (Hc []).
      rewrite not_ex_forall_not in Hc. specialize (Hc c).
      rewrite de_morgan1 in Hc. destruct Hc.
      - exfalso. apply H. constructor.
      - rewrite de_morgan2 in H. destruct H. assumption.
    }
    unfold stuck in H.
    rewrite not_forall_ex_not in H.
    destruct H as [e Hn].
    rewrite not_forall_ex_not in Hn. destruct Hn as [c' H].
    rewrite <- dne in H.
    destruct (classic (silent e)).
    (* Hfix *)
    apply FSilent with (e := e) (c' := c'); try assumption.
    apply Hfix.
    unfold does_event_or_goes_wrong'.
    intros Hn. destruct Hn as [m [c'0 [H1 H2]]].
    rewrite (not_ex_forall_not) in Hc. specialize (Hc m).
    rewrite (not_ex_forall_not) in Hc. specialize (Hc c'0).
    apply Hc. split.
    econstructor; eassumption.
    assumption.
    rewrite (not_ex_forall_not) in Hc. specialize (Hc [e]).
    rewrite (not_ex_forall_not) in Hc. specialize (Hc c').
    rewrite de_morgan1 in Hc. destruct Hc.
    exfalso. apply H1. econstructor. apply H. apply H0. constructor.
    apply de_morgan2 in H1. destruct H1.
    exfalso. apply H2. intros Hn. inversion Hn.
Qed.

Definition does_event_or_goes_wrong (c:cfg) :=
  (* (exists e c', steps' c (cons e nil) c') \/ (exists c', steps' c nil c' /\ stuck c'). *)
  {exists e c', steps' c [e] c'} + {exists c', steps' c [] c' /\ stuck c'}.

Lemma not_can_loop_silent : forall c, ~(can_loop_silent c) -> does_event_or_goes_wrong c.
Proof.
  intros c Hc.
  unfold does_event_or_goes_wrong.
  apply not_can_loop_silent' in Hc. unfold does_event_or_goes_wrong' in Hc.
  apply indefinite_description in Hc. destruct Hc as [m Hc].
  apply indefinite_description in Hc. destruct Hc as [c' Hc].
  destruct Hc as [H1 H2].
  destruct m as [|e p].
  - assert (H3: stuck c') by (destruct H2; now auto).
    right. exists c'. now split.
  - left. apply steps'_cons in H1.
    destruct H1 as [c'0 [H11 H12]].
    exists e. exists c'0. assumption.
Qed.

(** Semantics: the semantics produce full traces, not finite prefixes. *)
(* A definition of the semantics, using a well-founded order
   and based on Compcert, module Smallstep *)
Variable A: Type.
Variable order: A -> A -> Prop.
Hypothesis an_A : A. (* A is not empty *)
Hypothesis order_wf: well_founded order.
Hypothesis order_inf: forall (a : A), exists a', order a a'. (* Example: natural numbers *)

CoInductive sem'_N : A -> cfg -> trace -> Prop :=
| SStopN : forall c a (H : stuck c), sem'_N a c (tstop nil (es_of_cfg c H))
| SSilentDivN : forall c a, can_loop_silent c -> sem'_N a c (tsilent nil)
| SAppNilN : forall c c' t a1 a2, steps' c [] c' -> order a2 a1 ->
                             sem'_N a2 c' t -> sem'_N a1 c t
| SAppN : forall c c' m t a1 a2, m <> [] -> steps' c m c' ->
                            sem'_N a2 c' t -> sem'_N a1 c (tapp (ftbd m) t).

Lemma tapp_ftbd_nil_id : forall t, t = tapp (ftbd []) t.
Proof.
  now destruct t.
Qed.
Hint Resolve tapp_ftbd_nil_id.

Lemma sem'_N_inv:
  forall a c t,
  sem'_N a c t ->
  exists m, exists c', exists a', exists t',
          steps' c m c' /\ sem'_N a' c' t' /\ t = tapp (ftbd m) t'.
Proof.
  intros a. pattern a. apply (well_founded_ind order_wf).
  intros a' Hi c t H.
  inversion H; subst; repeat eexists; eauto.
Qed.
Hint Resolve sem'_N_inv.

Inductive sem' : cfg -> trace -> Prop :=
| sem'_cons : forall a c t, sem'_N a c t -> sem' c t.
Hint Constructors sem'.

Lemma sem'_inv : forall c t,
    sem' c t -> exists m c' t', steps' c m c' /\ sem' c' t' /\ t = tapp (ftbd m) t'.
Proof.
  intros c t H.
  inversion H; subst. repeat eexists; eauto.
Qed.
Hint Resolve sem'_inv.

(* Another definition of the semantics, based on the reflexive transitive closrure of the step
   relation but without restrictions on appplying the silent event only finitely many times *)
CoInductive sem'' : cfg -> trace -> Prop :=
| SStop : forall c (H : stuck c), sem'' c (tstop nil (es_of_cfg c H))
| SSilentDiv : forall c, can_loop_silent c -> sem'' c (tsilent nil)
| SApp : forall c c' m t, steps' c m c' -> sem'' c' t -> sem'' c (tapp (ftbd m) t).

Lemma sem'_sem'':
  forall c t, sem' c t -> sem'' c t.
Proof.
  cofix Hfix; intros.
  destruct (sem'_inv c t H) as [m [c' [t' [H1 [H2 H3]]]]].
  rewrite H3.
  apply SApp with (c' := c'). assumption.
  apply Hfix. auto.
Qed.

(* Might be useful later? *)
(* CoInductive sem'_N : A -> cfg -> trace -> Prop := *)
(* | SStopN : forall c a, stuck c -> sem'_N a c tstop *)
(* | SConsN : forall c e c' t a1 a2, step c e c' -> ~silent e -> sem'_N a1 c' t -> sem'_N a2 c (tcons e t) *)
(* | SSilentN : forall c c' t a1 a2, steps_silent c c' -> order a1 a2 -> sem'_N a1 c' t -> sem'_N a2 c t *)
(*    (* Shouldn't be able to infinitely step with a silent event *) *)
(* | SSilentDivN : forall c a, can_loop_silent c -> sem'_N a c tsilent. *)

(* This lemma should accurately model one expectation from the small-step semantics:
   if a configuration can produce a whole trace with a least one single event, then
   in particular it can finitely produce this event. *)

Lemma sem'_N_tapp : forall a c e t,
    sem'_N a c (tapp (ftbd [e]) t) -> exists c' a', steps' c [e] c' /\ sem'_N a' c' t.
Proof.
  intros a. pattern a. apply (well_founded_ind order_wf).
  intros a' Hi c e t H.
  inversion H; subst.
  - destruct t; inversion H4.
  - destruct t; inversion H0.
  - specialize (Hi a2 H1 c' e t H2).
    destruct Hi as [c'0 [a'0 [H1' H2']]].
    repeat eexists; eauto.
    eapply steps'_trans with (m := []) (m' := [e]); eassumption.
  - destruct m; subst.
    + contradiction.
    + simpl in *.
      apply steps'_cons in H2.
      assert (Hee0 : e = e0) by (destruct t0, t; now inversion H0).
      rewrite <- Hee0 in *.
      destruct H2 as [c'' [H3 H4]]. (* clear H0. clear H1. *)
      destruct m.
      * exists c'. exists a2. split. eapply steps'_trans with (m := [e]) (m' := []); eauto.
        destruct t, t0; inversion H0; subst; assumption.
      * exists c''. exists a2. split. assumption.
        pose proof (SAppN c'' c' (e1 :: m) t0 a2 a2).
        assert (e1 :: m <> []) by now destruct m.
        specialize (H2 H6 H4 H5).
        destruct t, t0; inversion H0; subst; assumption.
Qed.
Hint Resolve sem'_N_tapp.

Lemma sem'_tapp : forall c e t,
    sem' c (tapp (ftbd [e]) t) -> exists c', steps' c [e] c' /\ sem' c' t.
Proof.
  intros c e t H.
  inversion H; subst.
  eapply sem'_N_tapp in H0.
  destruct H0 as [c' [a' [H1 H2]]]. eexists; eauto.
Qed.

Definition sem (p:program) : trace -> Prop := sem' (init p).

CoFixpoint dummy_stream : @stream event :=
  scons an_event dummy_stream.

Inductive can_get_stuck : cfg -> Prop :=
| stuck_now : forall c, stuck c -> can_get_stuck c
| stuck_later : forall c e c', step c e c' -> can_get_stuck c' -> can_get_stuck c.

Inductive can_ev_loop_silent : cfg -> Prop :=
| silent_now : forall c, can_loop_silent c -> can_ev_loop_silent c
| silent_later : forall c e c', step c e c' -> can_ev_loop_silent c' -> can_ev_loop_silent c.

Lemma not_can_get_stuck_not_stuck : forall c, ~ can_get_stuck c -> ~ stuck c.
Proof.
  intros c H. intros Hn. apply H. now constructor.
Qed.

Lemma can_get_stuck_steps' : forall c m c', steps' c m c' -> can_get_stuck c' -> can_get_stuck c.
Proof.
  intros c m c' H. induction H; intros.
  - eauto.
  - specialize (IHsteps' H2).
    apply stuck_later with (e := e) (c' := c'); eauto.
  - specialize (IHsteps' H2).
    apply stuck_later with (e := e) (c' := c'); eauto.
Qed.

Lemma not_can_get_stuck_steps' : forall c m c', steps' c m c' -> ~ can_get_stuck c -> ~ can_get_stuck c'.
  intros c m c' H.
  apply contra. rewrite <- dne. rewrite <- dne. eapply can_get_stuck_steps'; eassumption.
Qed.

Lemma not_can_ev_loop_silent : forall c, ~ can_ev_loop_silent c -> ~ can_loop_silent c.
Proof.
  intros c H. intros Hn. apply H. now constructor.
Qed.

Lemma can_ev_loop_silent_steps' : forall c m c', steps' c m c' -> can_ev_loop_silent c' ->
                                            can_ev_loop_silent c.
Proof.
  intros c m c' H. induction H; intros.
  - eauto.
  - specialize (IHsteps' H2).
    apply silent_later with (e := e) (c' := c'); eauto.
  - specialize (IHsteps' H2).
    apply silent_later with (e := e) (c' := c'); eauto.
Qed.

Lemma not_can_ev_loop_silent_steps' : forall c m c', steps' c m c' -> ~ can_ev_loop_silent c ->
                                                ~ can_ev_loop_silent c'.
  intros c m c' H.
  apply contra. rewrite <- dne. rewrite <- dne. eapply can_ev_loop_silent_steps'; eassumption.
Qed.

CoFixpoint stream_of (c : cfg) (H1 : ~ can_get_stuck c) (H2 : ~ can_ev_loop_silent c) : @stream event.
  assert (Hnstuck : ~ stuck c) by now apply not_can_get_stuck_not_stuck.
  do 2 setoid_rewrite not_forall_ex_not in Hnstuck.
  apply indefinite_description in Hnstuck. destruct Hnstuck as [e H].
  apply indefinite_description in H. destruct H as [c' H].
  apply NNPP in H.

  destruct (classicT (silent e)) as [He | He].
  - assert (Hnsilent : ~ can_loop_silent c) by now apply not_can_ev_loop_silent.
    apply not_can_loop_silent' in Hnsilent.
    unfold does_event_or_goes_wrong' in Hnsilent.
    apply indefinite_description in Hnsilent. destruct Hnsilent as [m Hnsilent].
    apply indefinite_description in Hnsilent. destruct Hnsilent as [c'' [Hc''1 Hc''2]].
    assert (Hm : exists e' p', m = e' :: p').
    { destruct m as [| e' p'].
      - destruct Hc''2. exfalso.
        apply H1. apply can_get_stuck_steps' with (m := []) (c' := c'').
        assumption. now constructor. congruence.
      - now (exists e', p'). }
    apply indefinite_description in Hm. destruct Hm as [e' Hm].
    apply indefinite_description in Hm. destruct Hm as [p' Heq]. subst.
    apply steps'_cons in Hc''1.
    apply indefinite_description in Hc''1. destruct Hc''1 as [c'0 Hc''1].
    destruct Hc''1 as [Hc''11 Hc''12].
    assert (H2' : ~ can_ev_loop_silent c'0)
      by now apply not_can_ev_loop_silent_steps' with (c := c) (m := [e']).
    assert (H1' : ~ can_get_stuck c'0)
      by now apply not_can_get_stuck_steps' with (c := c) (m := [e']).
    exact (app_list_stream [e'] (stream_of c'0 H1' H2')).
  - assert (H1' : ~ can_get_stuck c').
    apply not_can_get_stuck_steps' with (c := c) (m := [e]); eauto.
    assert (H2' : ~ can_ev_loop_silent c').
    apply not_can_ev_loop_silent_steps' with (c := c) (m := [e]); eauto.
    exact (app_list_stream [e] (stream_of c' H1' H2')).
Defined.

(* cf CPDT *)
Definition frob (s : @stream event) : stream :=
  match s with
  | scons e s' => scons e s'
  end.

Theorem frob_eq : forall s, s = frob s.
  destruct s; reflexivity.
Qed.

Lemma stream_of_eta : forall (c : cfg) (H1 : ~ can_get_stuck c) (H2 : ~ can_ev_loop_silent c),
    stream_of c H1 H2 = let Hnstuck : ~ stuck c := not_can_get_stuck_not_stuck c H1 in
  let Hnstuck0 :=
    indefinite_description event (fun n : event => exists n0 : cfg, ~ ~ step c n n0)
      (Morphisms.subrelation_proper Morphisms_Prop.ex_iff_morphism tt
         (Morphisms.subrelation_respectful
            (Morphisms.subrelation_refl (Morphisms.pointwise_relation event iff))
            Morphisms.iff_impl_subrelation) (fun n : event => ~ (forall c' : cfg, ~ step c n c'))
         (fun n : event => exists n0 : cfg, ~ (fun n1 : cfg => ~ step c n n1) n0)
         (fun n : event => not_forall_ex_not cfg (fun n0 : cfg => ~ step c n n0))
         (Morphisms.iff_impl_subrelation
            (~ (forall n : event, (fun n0 : event => forall c' : cfg, ~ step c n0 c') n))
            (exists n : event, ~ (fun n0 : event => forall c' : cfg, ~ step c n0 c') n)
            (not_forall_ex_not event (fun n : event => forall c' : cfg, ~ step c n c')) Hnstuck)) in
  let (e, H) := Hnstuck0 in
  let H0 := indefinite_description cfg (fun n : cfg => ~ ~ step c e n) H in
  let (c', H3) := H0 in
  let H4 : step c e c' := NNPP (step c e c') H3 in
  let s := classicT (silent e) in
  match s with
  | left _ =>
      let Hnsilent : ~ can_loop_silent c := not_can_ev_loop_silent c H2 in
      let Hnsilent0 : does_event_or_goes_wrong' c := not_can_loop_silent' c Hnsilent in
      let Hnsilent1 :=
        indefinite_description (list event)
          (fun m : list event => exists c'0 : cfg, steps' c m c'0 /\ (stuck c'0 \/ m <> [])) Hnsilent0
        in
      let (m, Hnsilent2) := Hnsilent1 in
      let Hnsilent3 :=
        indefinite_description cfg (fun c'0 : cfg => steps' c m c'0 /\ (stuck c'0 \/ m <> []))
          Hnsilent2 in
      let (c'', a) := Hnsilent3 in
      match a with
      | conj Hc''1 Hc''2 =>
          let Hm : exists (e' : event) (p' : list event), m = e' :: p' :=
            match
              m as l
              return
                (steps' c l c'' ->
                 stuck c'' \/ l <> [] -> exists (e' : event) (p' : list event), l = e' :: p')
            with
            | [] =>
                fun (Hc''3 : steps' c [] c'') (Hc''4 : stuck c'' \/ [] <> []) =>
                match Hc''4 with
                | or_introl H5 =>
                    False_ind (exists (e' : event) (p' : list event), [] = e' :: p')
                      (H1 (can_get_stuck_steps' c [] c'' Hc''3 (stuck_now c'' H5)))
                | or_intror H5 =>
                    let Heq : [] = [] := eq_refl in
                    False_ind (exists (e' : event) (p' : list event), [] = e' :: p') (H5 Heq)
                end
            | e' :: p' =>
                fun (_ : steps' c (e' :: p') c'') (_ : stuck c'' \/ e' :: p' <> []) =>
                ex_intro (fun e'0 : event => exists p'0 : list event, e' :: p' = e'0 :: p'0) e'
                  (ex_intro (fun p'0 : list event => e' :: p' = e' :: p'0) p' eq_refl)
            end Hc''1 Hc''2 in
          let Hm0 :=
            indefinite_description event (fun e' : event => exists p' : list event, m = e' :: p') Hm
            in
          let (e', Hm1) := Hm0 in
          let Hm2 := indefinite_description (list event) (fun p' : list event => m = e' :: p') Hm1 in
          let (p', Heq) := Hm2 in
          eq_rec_r (fun m0 : list event => steps' c m0 c'' -> stuck c'' \/ m0 <> [] -> stream)
            (fun (Hc''3 : steps' c (e' :: p') c'') (_ : stuck c'' \/ e' :: p' <> []) =>
             let Hc''5 : exists c''0 : cfg, steps' c [e'] c''0 /\ steps' c''0 p' c'' :=
               steps'_cons c c'' e' p' Hc''3 in
             let Hc''6 :=
               indefinite_description cfg (fun c''0 : cfg => steps' c [e'] c''0 /\ steps' c''0 p' c'')
                 Hc''5 in
             let (c'0, Hc''7) := Hc''6 in
             match Hc''7 with
             | conj Hc''11 _ =>
                 let H2' : ~ can_ev_loop_silent c'0 :=
                   not_can_ev_loop_silent_steps' c [e'] c'0 Hc''11 H2 in
                 let H1' : ~ can_get_stuck c'0 := not_can_get_stuck_steps' c [e'] c'0 Hc''11 H1 in
                 app_list_stream [e'] (stream_of c'0 H1' H2')
             end) Heq Hc''1 Hc''2
      end
  | right He =>
      let H1' : ~ can_get_stuck c' :=
        not_can_get_stuck_steps' c [e] c' (SSCons c e c' [] c' H4 He (steps'_refl c')) H1 in
      let H2' : ~ can_ev_loop_silent c' :=
        not_can_ev_loop_silent_steps' c [e] c' (SSCons c e c' [] c' H4 He (steps'_refl c')) H2 in
      app_list_stream [e] (stream_of c' H1' H2')
  end.
Proof.
  intros c H1 H2.
  rewrite (frob_eq (stream_of c H1 H2)).
  simpl.
  destruct (indefinite_description event (fun n : event => exists n0 : cfg, ~ ~ step c n n0)
         (Morphisms.subrelation_proper Morphisms_Prop.ex_iff_morphism tt
            (Morphisms.subrelation_respectful
               (Morphisms.subrelation_refl (Morphisms.pointwise_relation event iff))
               Morphisms.iff_impl_subrelation) (fun n : event => ~ (forall c' : cfg, ~ step c n c'))
            (fun n : event => exists n0 : cfg, ~ ~ step c n n0)
            (fun n : event => not_forall_ex_not cfg (fun n0 : cfg => ~ step c n n0))
            (Morphisms.iff_impl_subrelation (~ (forall (n : event) (c' : cfg), ~ step c n c'))
               (exists n : event, ~ (forall c' : cfg, ~ step c n c'))
               (not_forall_ex_not event (fun n : event => forall c' : cfg, ~ step c n c'))
               (not_can_get_stuck_not_stuck c H1)))).
  destruct (indefinite_description cfg (fun n : cfg => ~ ~ step c x n) e).
  destruct (classicT (silent x)).
  destruct (indefinite_description (list event)
         (fun m : list event => exists c'0 : cfg, steps' c m c'0 /\ (stuck c'0 \/ m <> []))
         (not_can_loop_silent' c (not_can_ev_loop_silent c H2))).
  destruct (indefinite_description cfg (fun c'0 : cfg => steps' c x1 c'0 /\ (stuck c'0 \/ x1 <> [])) e0).
  destruct a.
  destruct (indefinite_description event (fun e' : event => exists p' : list event, x1 = e' :: p')
         (match
            x1 as l
            return
              (steps' c l x2 ->
               stuck x2 \/ l <> [] -> exists (e' : event) (p' : list event), l = e' :: p')
          with
          | [] =>
              fun (Hc''3 : steps' c [] x2) (Hc''4 : stuck x2 \/ [] <> []) =>
              match Hc''4 with
              | or_introl H5 =>
                  False_ind (exists (e' : event) (p' : list event), [] = e' :: p')
                    (H1 (can_get_stuck_steps' c [] x2 Hc''3 (stuck_now x2 H5)))
              | or_intror H5 =>
                  False_ind (exists (e' : event) (p' : list event), [] = e' :: p') (H5 eq_refl)
              end
          | e' :: p' =>
              fun (_ : steps' c (e' :: p') x2) (_ : stuck x2 \/ e' :: p' <> []) =>
              ex_intro (fun e'0 : event => exists p'0 : list event, e' :: p' = e'0 :: p'0) e'
                (ex_intro (fun p'0 : list event => e' :: p' = e' :: p'0) p' eq_refl)
           end s0 o)).
  destruct (indefinite_description (list event) (fun p' : list event => x1 = x3 :: p') e1).
  unfold eq_rec_r. unfold eq_rec. unfold eq_rect. subst. simpl.
  destruct (indefinite_description cfg (fun c''0 : cfg => steps' c [x3] c''0 /\ steps' c''0 x4 x2)
                                   (steps'_cons c x2 x3 x4 s0)).
  destruct a.
  reflexivity. reflexivity.
Qed.

Lemma sem'_stream_of (c : cfg) (H1 : ~ can_get_stuck c) (H2 : ~ can_ev_loop_silent c) :
  sem' c (tstream (stream_of c H1 H2)).
Proof.
  (* This is probably a stupid way of doing this proof, but it is certainly quicker than
   taking the time to think about it *)
  destruct (order_inf an_A) as [a' Ha'].
  apply sem'_cons with (a := a').
  generalize dependent c. generalize dependent a'.
  cofix Hfix.
  intros a' Ha' c H1 H2.
  rewrite stream_of_eta. simpl.
  (* rewrite (frob_eq (stream_of c H1 H2)). simpl. *)
  destruct (indefinite_description event (fun n : event => exists n0 : cfg, ~ ~ step c n n0)
              (Morphisms.subrelation_proper Morphisms_Prop.ex_iff_morphism tt
                 (Morphisms.subrelation_respectful
                    (Morphisms.subrelation_refl (Morphisms.pointwise_relation event iff))
                    Morphisms.iff_impl_subrelation)
                 (fun n : event => ~ (forall c' : cfg, ~ step c n c'))
                 (fun n : event => exists n0 : cfg, ~ ~ step c n n0)
                 (fun n : event => not_forall_ex_not cfg (fun n0 : cfg => ~ step c n n0))
                 (Morphisms.iff_impl_subrelation (~ (forall (n : event) (c' : cfg), ~ step c n c'))
                    (exists n : event, ~ (forall c' : cfg, ~ step c n c'))
                    (not_forall_ex_not event (fun n : event => forall c' : cfg, ~ step c n c'))
                    (not_can_get_stuck_not_stuck c H1)))) as [e H].
  destruct (indefinite_description cfg (fun n : cfg => ~ ~ step c e n) H) as [c' H0].
  destruct (classicT (silent e)) as [He | He].
  destruct (indefinite_description (list event)
              (fun m : list event => exists c'0 : cfg, steps' c m c'0 /\ (stuck c'0 \/ m <> []))
              (not_can_loop_silent' c (not_can_ev_loop_silent c H2))) as [m Hnsilent].
  destruct (indefinite_description cfg (fun c'0 : cfg => steps' c m c'0 /\ (stuck c'0 \/ m <> []))
                                   Hnsilent) as [c'' [Hc''1 Hc''2]].
  destruct (indefinite_description event (fun e' : event => exists p' : list event, m = e' :: p')
              (match
                 m as l
                 return
                   (steps' c l c'' ->
                    stuck c'' \/ l <> [] -> exists (e' : event) (p' : list event), l = e' :: p')
               with
               | [] =>
                   fun (Hc''0 : steps' c [] c'') (Hc''3 : stuck c'' \/ [] <> []) =>
                   match Hc''3 with
                   | or_introl H3 =>
                       False_ind (exists (e' : event) (p' : list event), [] = e' :: p')
                         (H1 (can_get_stuck_steps' c [] c'' Hc''0 (stuck_now c'' H3)))
                   | or_intror H3 =>
                       False_ind (exists (e' : event) (p' : list event), [] = e' :: p') (H3 eq_refl)
                   end
               | e' :: p' =>
                   fun (_ : steps' c (e' :: p') c'') (_ : stuck c'' \/ e' :: p' <> []) =>
                   ex_intro (fun e'0 : event => exists p'0 : list event, e' :: p' = e'0 :: p'0) e'
                     (ex_intro (fun p'0 : list event => e' :: p' = e' :: p'0) p' eq_refl)
                end Hc''1 Hc''2)) as [e' Hm].
  destruct (indefinite_description (list event) (fun p' : list event => m = e' :: p') Hm) as [p' Heq].
  unfold eq_rec_r; unfold eq_rec; unfold eq_rect; subst; simpl in *.
  destruct (indefinite_description cfg (fun c''0 : cfg => steps' c [e'] c''0 /\ steps' c''0 p' c'')
                                   (steps'_cons c c'' e' p' Hc''1)) as [c'0 [Hc''11 Hc''12]].
  assert (Hre : forall s', tstream (scons e' s') = tapp (ftbd [e']) (tstream s')) by reflexivity.
  rewrite Hre.
  eapply SAppN. congruence. eassumption. apply Hfix. eassumption.
  assert (Hre : forall s', tstream (scons e s') = tapp (ftbd [e]) (tstream s')) by reflexivity.
  rewrite Hre.
  eapply SAppN. congruence. econstructor. apply NNPP in H0. apply H0. assumption.
  constructor. apply Hfix. eassumption.
Qed.

Definition trace_of (c : cfg) : exists (t : trace), sem' c t.
Proof.
  destruct (classicT (can_get_stuck c)) as [H | H].
  - induction H.
    + exists (tstop nil (es_of_cfg c H)).
      econstructor. econstructor.
    + destruct (classicT (silent e)); destruct IHcan_get_stuck as [t Ht].
      * exists t. inversion Ht; subst. destruct (order_inf a) as [a' Haa'].
        apply (sem'_cons a').
        apply SAppNilN with (a2 := a) (c' := c'); eauto.
      * exists (tapp (ftbd [e]) t). inversion Ht; subst.
        destruct (order_inf a) as [a' Haa'].
        apply (sem'_cons a').
        apply SAppN with (a2 := a) (c' := c'); eauto. congruence.
  - destruct (classicT (can_ev_loop_silent c)) as [Hc | Hc].
    + induction Hc.
      * exists (tsilent nil). econstructor; constructor; assumption.
      * assert (H': ~ can_get_stuck c') by (intros Hn; apply H; eapply stuck_later; eauto).
        destruct (IHHc H') as [t Ht].
        destruct (classicT (silent e)).
        -- inversion Ht; subst.
           destruct (order_inf a) as [a' Ha].
           exists t. econstructor. eapply SAppNilN with (c' := c').
           econstructor; eauto. apply Ha. assumption.
        -- inversion Ht; subst.
           exists (tapp (ftbd [e]) t).
           econstructor. eapply SAppN with (c' := c').
           congruence. eauto.  apply H1.
    + exists (tstream (stream_of c H Hc)).
      apply sem'_stream_of.
      Unshelve.
      exact an_A. exact an_A. exact an_A.
Qed.

Lemma non_empty_sem : forall W, exists t, sem W t.
Proof. intro W. apply (trace_of (init W)).
Qed.

(** Definition of the language *)
Definition lang : language := @Build_language partial
                                        program
                                        context
                                        plug
                                        sem
                                        non_empty_sem.

(** Build links between the semantics of the language and the
    step by step relation *)
Lemma steps'_sem'_single : forall c c' t,
    steps' c [] c' ->
    sem' c' t ->
    sem' c t.
Proof.
  intros c c' t H H0.
  inversion H0; subst; eauto.
  destruct (order_inf a) as [a' Ha'].
  apply sem'_cons with (a := a').
  econstructor; eauto.
Qed.
Hint Resolve steps'_sem'_single.

Lemma steps'_sem' : forall c e c' t,
  steps' c [e] c' ->
  sem' c' t ->
  sem' c (tapp (ftbd [e]) t).
Proof.
  intros c e c' t H H0.
  inversion H0; subst; eauto.
  destruct (order_inf a) as [a' Ha'].
  apply sem'_cons with (a := a').
  eapply SAppN with (m := [e]); eauto.
  intros Hn; inversion Hn.
Qed.
Hint Resolve steps'_sem'.

Lemma steps'_sem'_N : forall c e c' t a,
    steps' c [e] c' ->
    sem'_N a c' t ->
    sem'_N a c (tapp (ftbd [e]) t).
Proof.
  intros c e c' t a H H0.
  eapply SAppN with (m := [e]); eauto.
  intros Hn; inversion Hn.
Qed.

Lemma steps_sem'_app : forall c m c' t,
  steps c m c' ->
  sem' c' t ->
  sem' c (tapp m t).
Proof.
  intros c m c' t H H0.
  destruct m.
  - simpl in *.
    inversion H; subst; try now auto.
    induction H7; subst; try now eauto.
    + simpl in *. econstructor. now constructor.
    + specialize (IHsteps' H6).
      assert (steps c' (fstop m (es_of_cfg c'' H6)) c'').
      constructor. assumption.
      specialize (IHsteps' H4 H0 H6).
      inversion IHsteps'; subst; eauto.
      simpl in *. econstructor.
      assert (Hrewrite :
                (tstop (e :: m) (es_of_cfg c'' H6)) = tapp (ftbd [e]) (tstop m (es_of_cfg c'' H6))).
      { simpl. reflexivity. }
      rewrite Hrewrite.
      eapply SAppN with (m := [e]) (c' := c'); eauto.
      congruence.
  - inversion H0; subst; eauto.
    destruct (order_inf a) as [a' Ha'].
    apply sem'_cons with (a := a').
    destruct l as [| e' p'].
    inversion H; subst. econstructor; eauto. destruct t; eauto.
    eapply SAppN with (m := e' :: p'); eauto. congruence. inversion H; subst. assumption.
    Unshelve.
    assumption. exact an_A. exact an_A.
Qed.

Lemma steps_psem : forall P m c,
  steps (init P) m c ->
  @psem lang P m.
Proof.
  intros P m c Hsteps.
  unfold psem. simpl.
  destruct (trace_of c) as [t Ht].
  exists (tapp m t). split.
  - destruct m.
    + inversion Hsteps; subst.
      apply tapp_pref.
    + unfold sem.
      inversion Hsteps; subst.
      inversion H1; subst.
      ++ now destruct t.
      ++ apply tapp_pref.
      ++ apply tapp_pref.
  - unfold sem.
    eapply steps_sem'_app. eassumption.
    now apply Ht.
Qed.

Definition fstopped (m : finpref) :=
  match m with
  | fstop _ _ => true
  | _ => false
  end.

Lemma sem'_prefix : forall m c0 t,
  sem' c0 t ->
  prefix m t ->
  fstopped m = false ->
  exists c, steps c0 m c.
Proof.
  induction finpref m as e es p IHp; intros c0 t Hsem Hpref Hnstopped.
  - inversion Hnstopped.
  - inversion Hnstopped.
  - exists c0. constructor. apply SSTbd.
  - destruct t as [l es | l | s]; simpl in *.
    + destruct l as [| e' p']. inversion Hpref.
      destruct Hpref as [H Hpref]; subst.
      assert (Hre : tstop (e' :: p') es = tapp (ftbd [e']) (tstop p' es)) by reflexivity.
      rewrite Hre in Hsem.
      apply sem'_tapp in Hsem.
      destruct Hsem as [c' [H1 H2]].
      specialize (IHp c' (tstop p' es) H2 Hpref Hnstopped).
      destruct IHp as [c'' Hc''].
      exists c''. constructor.
      inversion Hc''; subst.
      apply steps'_trans with (m := [e']) (m' := p) (c2 := c'); eauto.
    + destruct l as [| e' p']. inversion Hpref.
      destruct Hpref as [H Hpref]; subst.
      assert (Hre : tsilent (e' :: p') = tapp (ftbd [e']) (tsilent p')) by reflexivity.
      rewrite Hre in Hsem.
      apply sem'_tapp in Hsem.
      destruct Hsem as [c' [H1 H2]].
      specialize (IHp c' (tsilent p') H2 Hpref Hnstopped).
      destruct IHp as [c'' Hc''].
      exists c''. constructor.
      inversion Hc''; subst.
      apply steps'_trans with (m := [e']) (m' := p) (c2 := c'); eauto.
    + destruct s as [ e' s']. destruct Hpref as [H Hpref]; subst.
      assert (Hre : tstream (scons e' s') = tapp (ftbd [e']) (tstream s')) by reflexivity.
      rewrite Hre in Hsem.
      apply sem'_tapp in Hsem.
      destruct Hsem as [c' [H1 H2]].
      specialize (IHp c' (tstream s') H2 Hpref Hnstopped).
      destruct IHp as [c'' Hc''].
      exists c''. constructor.
      inversion Hc''; subst.
      apply steps'_trans with (m := [e']) (m' := p) (c2 := c'); eauto.
Qed.

Lemma sem_prefix : forall m P t,
  sem P t ->
  prefix m t ->
  fstopped m = false ->
  exists c, steps (init P) m c.
(* /\ exists t', t_eq t (tapp m t') /\ sem' c t' *)
(* A better way to state this might be to avoid t_eq and use
   an operation to remove m from t -- for now removed that part since not needed *)
Proof. intros m P. now apply (sem'_prefix m (init P)). Qed.

Lemma psem_steps : forall m P,
  @psem lang P m ->
  fstopped m = false ->
  exists c, steps (init P) m c.
Proof. intros m P [t [H1 H2]] Hstopped. eapply sem_prefix; eassumption. Qed.

Definition semantics_safety_like_reverse : forall t P m,
  sem P t ->
  prefix m t ->
  @psem lang P m.
Proof.
  intros t P m H H0. unfold psem. exists t. split; assumption.
Qed.

Definition fsnoc (m : finpref) (e : event) : finpref :=
  match m with
  | fstop m' es => fstop (snoc m' e) es
  | ftbd m' => ftbd (snoc m' e)
  end.

Theorem finpref_ind_snoc :
  forall (P : finpref -> Prop),
    P (ftbd nil) ->
    (forall (m : list event) (es : endstate), P (fstop m es)) ->
    (forall (m : finpref) (e : event), P m -> P (fsnoc m e)) ->
    forall m, P m.
Proof.
  (* Proof similar to list_rev_ind in the Coq library *)
  intros P H H0 H1 m.
  destruct m; eauto.
  rewrite <- (@rev_involutive event l).
  induction (rev l).
  apply H.
  simpl.
  assert (forall l, l ++ [a] = snoc l a).
  { clear.
    induction l. now simpl.
    simpl in *. rewrite IHl. reflexivity. }
  specialize (H2 (rev l0)). rewrite H2.
  specialize (H1 (ftbd (rev l0)) a IHl0). assumption.
Qed.

(* Lemma not_diverges_cons : forall e t, ~ diverges (tcons e t) -> ~ diverges t. *)
(*   intros e t H Hn. *)
(*   apply H. now constructor. *)
(* Qed. *)

Definition configuration_determinacy := forall (c c1 c2 : cfg) (m : list event),
    steps' c m c1 -> steps' c m c2 -> steps' c1 [] c2 \/ steps' c2 [] c1.

Definition very_strong_determinacy := forall (c c1 c2 : cfg) (e1 e2 : event),
    steps' c [e1] c1 -> steps' c [e2] c2 -> ((e1 = e2 /\ c1 = c2) \/ (is_input e1 /\ is_input e2 /\ e1 <> e2)).

Definition strong_determinacy := forall (c c1 c2 : cfg) (e1 e2 : event),
    step c e1 c1 -> step c e2 c2 -> ((e1 = e2 /\ c1 = c2) \/ (is_input e1 /\ is_input e2 /\ e1 <> e2)).

Definition rel_cfg (c1 c2 : cfg) : Prop := forall (t : trace), sem' c1 t <-> sem' c2 t.

Lemma rel_cfg_reflexivity : forall (c : cfg), rel_cfg c c.
Proof.
  now unfold rel_cfg.
Qed.

Lemma rel_cfg_transitivity : forall (c1 c2 c3 : cfg), rel_cfg c1 c2 -> rel_cfg c2 c3 -> rel_cfg c1 c3.
Proof.
  unfold rel_cfg. firstorder.
Qed.

Lemma rel_cfg_symmetry : forall (c1 c2 : cfg), rel_cfg c1 c2 -> rel_cfg c2 c1.
Proof.
  now firstorder.
Qed.

Definition rel_cfg_pref (c1 c2 : cfg) : Prop := forall (m : list event),
    (exists c1', steps' c1 m c1') <-> (exists c2', steps' c2 m c2').

Lemma steps'_to_sem'_N_pref : forall c c' m,
    steps' c m c' ->
    exists t a, prefix (ftbd m) t /\ sem'_N a c t.
Proof.
  intros c c' m H.
  induction H.
  - pose proof (trace_of c).
    destruct H as [t Ht].
    inversion Ht; subst.
    exists t, a.
    split; simpl; destruct t; eauto.
  - destruct IHsteps' as [t' [a [H2 H3]]].
    exists (tapp (ftbd [e]) t'). exists a. split. simpl. destruct t'; eauto.
    eapply SAppN with (c' := c') (m := [e]); eauto. intros Hn; inversion Hn.
  - destruct IHsteps' as [t' [a [H2 H3]]].
    destruct (order_inf a) as [a' Ha'].
    exists t'. exists a'. split. now simpl.
    eapply SAppNilN with (c' := c'); eauto.
Qed.

Lemma steps'_to_sem'_pref : forall c c' m,
    steps' c m c' ->
    exists t, prefix (ftbd m) t /\ sem' c t.
Proof.
  intros c c' m H.
  apply steps'_to_sem'_N_pref in H.
  destruct H as [t [a [H1 H2]]]. eauto.
Qed.

Lemma sem'_N_pref_to_steps' : forall c m t a,
    prefix (ftbd m) t -> sem'_N a c t -> exists c', steps' c m c'.
Proof.
  intros c m.
  generalize dependent c.
  induction m; intros.
  - now eauto.
  - destruct t.
    + destruct l; inversion H; subst.
      assert (Hre: tstop (e0 :: l) e = tapp (ftbd [e0]) (tstop l e)) by reflexivity.
      rewrite Hre in H0.
      apply sem'_N_tapp in H0.
      destruct H0 as [c' [a' [H0 H1]]].
      specialize (IHm c' (tstop l e) a' H2 H1).
      destruct IHm as [c'0 H3].
      exists c'0; eapply steps'_trans with (m := [e0]) (m' := m); eassumption.
    + destruct l; inversion H; subst.
      assert (Hre: tsilent (e :: l) = tapp (ftbd [e]) (tsilent l )) by reflexivity.
      rewrite Hre in H0.
      apply sem'_N_tapp in H0.
      destruct H0 as [c' [a' [H0 H1]]].
      specialize (IHm c' (tsilent l) a' H2 H1).
      destruct IHm as [c'0 H3].
      exists c'0; eapply steps'_trans with (m := [e]) (m' := m); eassumption.
    + destruct s; inversion H; subst.
      assert (Hre: tstream (scons e s) = tapp (ftbd [e]) (tstream s)) by reflexivity.
      rewrite Hre in H0.
      apply sem'_N_tapp in H0.
      destruct H0 as [c' [a' [H0 H1]]].
      specialize (IHm c' (tstream s) a' H2 H1).
      destruct IHm as [c'0 H3].
      exists c'0; eapply steps'_trans with (m := [e]) (m' := m); eassumption.
Qed.

Lemma sem'_pref_to_steps' : forall c m t,
    prefix (ftbd m) t -> sem' c t -> exists c', steps' c m c'.
Proof.
  intros c m t H H0.
  inversion H0; subst.
  eauto using sem'_N_pref_to_steps'.
Qed.

Lemma rel_cfg_to_rel_cfg_pref : forall c1 c2, rel_cfg c1 c2 -> rel_cfg_pref c1 c2.
Proof.
  unfold rel_cfg, rel_cfg_pref.
  intros c1 c2 H m.
  split.
  - intros H'. destruct H' as [c1' H'].
    apply steps'_to_sem'_pref in H'.
    destruct H' as [t [H1 H2]].
    apply H in H2. inversion H2; subst; eauto.
    eapply sem'_N_pref_to_steps' with (t := t).
    assumption. eassumption.
  - intros H'. destruct H' as [c1' H'].
    apply steps'_to_sem'_pref in H'.
    destruct H' as [t [H1 H2]].
    apply sem'_pref_to_steps' with (t := t).
    assumption.
    now apply (H t).
Qed.

Definition weak_determinacy := forall (c1 c1' c2 c2' : cfg) (m : list event),
    rel_cfg c1 c1' -> steps' c1 m c2 -> steps' c1' m c2' -> rel_cfg c2 c2'.

(* Lemma steps'_cons_smaller : forall c1 c3 m e, *)
(*     steps' c1 (e :: m) c3 -> exists c2, steps' c1 [e] c2 /\ steps' c2 m c3. *)
(* Proof. *)
(*   intros c1 c3 m e H. *)
(*   remember (e :: m) as p. *)
(*   induction H. *)
(*   - inversion Heqp. *)
(*   - inversion Heqp; subst. clear Heqp. *)
(*     exists c'; split. apply SSCons with (c' := c'); auto. *)
(*     constructor. assumption. *)
(*   - inversion Heqp; subst. specialize (IHsteps' H2). *)
(*     destruct IHsteps' as [c2 [Hc2 Hc2']]. *)
(*     exists c2. split. *)
(*     apply SSSilent with (e := e0) (c' := c'); auto. *)
(*     assumption. *)
(* Qed. *)

Lemma steps'_not_silent : forall c c' e, steps' c [e] c' -> ~ silent e.
Proof.
  intros c c' e H.
  remember [e] as m.
  induction H; eauto; inversion Heqm; now subst.
Qed.

Definition stopped (t : trace) : Prop :=
  match t with
  | tstop _ _ => True
  | _ => False
  end.

Lemma ind_hyp (det : weak_determinacy) : forall t c,
    ~ diverges t -> ~ stopped t ->
    (forall m, prefix (ftbd m) t -> exists c', steps' c m c') ->
    sem' c t.
Proof.
  intros.
  apply sem'_cons with (a := an_A).
  generalize dependent an_A.
  generalize dependent t. generalize dependent c.
  cofix ind_hyp. intros c t Hndiv Hnstopped H a.
  destruct t as [| | [e s']].
  - apply False_ind. apply Hnstopped. now constructor.
  - apply False_ind. apply Hndiv. now constructor.
  - assert (Hsilent: ~silent e).
    { specialize (H [e]).
      assert (prefix (ftbd [e]) (tstream  (scons e s'))) by now simpl.
      specialize (H H0). destruct H as [c' Hc'].
      eapply steps'_not_silent; now eauto.
    }
    pose proof H as H'.
    assert (H1: prefix (ftbd [e]) (tstream (scons e s'))) by now split.
    specialize (H' [e] H1); clear H1. destruct H' as [c' Hc'].
    destruct (order_inf a) as [a1 Ha1].
    assert (Hre : tstream (scons e s') = tapp (ftbd [e]) (tstream s')) by reflexivity.
    rewrite Hre.
    apply SAppN with (c' := c') (m := [e]) (a2 := a1).
    congruence.
    (* apply steps'_sem'_N with (c' := c'). *)
    assumption.
    assert (Hndiv' : ~ diverges (tstream s')).
    { intros Hn; apply Hndiv; eauto. }
    assert (Hnstopped' : ~ stopped (tstream s')).
    { intros Hn; apply Hnstopped; eauto. }
    Guarded.
    apply ind_hyp; try now assumption.
    Guarded.
    intros m H0.
    assert (H': prefix (ftbd (e :: m)) (tstream (scons e s'))) by now split.
    specialize (H (e :: m) H'); clear H'.
    unfold weak_determinacy in det.
    destruct H as [c'' Hc''].
    apply steps'_cons in Hc''.
    destruct Hc'' as [cc [Hcc1 Hcc2]].
    specialize (det c c c' cc [e] (rel_cfg_reflexivity c) Hc' Hcc1).
    apply rel_cfg_to_rel_cfg_pref in det. unfold rel_cfg_pref in det.
    specialize (det m).
    destruct det as [_ det].
    assert (exists c2' : cfg, steps' cc m c2') by (now exists c'').
    specialize (det H).
    apply det.
Qed.

(* The original semantics_safety_like_right can only be obtained if we assume determinacy *)
Lemma semantics_safety_like_right (det : weak_determinacy): forall t P,
  ~ diverges t -> ~ stopped t ->
  (forall m, prefix m t -> @psem lang P m) -> sem P t.
Proof.
  intros t P Hndiv Hnstopped H.
  destruct t as [| | s].
  - assert (Ht: e = e /\ l = l) by (split; reflexivity).
    specialize (H (fstop l e) Ht). unfold psem in H.
    destruct H as [t [H1 H2]].
    destruct t; simpl in *; subst; now eauto.
  - exfalso. apply Hndiv. now constructor.
  - (* remember (tcons e0 t0) as t. *)
    apply ind_hyp.
    apply det.
    apply Hndiv.
    apply Hnstopped.
    intros m H'.
    specialize (H (ftbd m) H').
    apply psem_steps in H; [| reflexivity].
    destruct H as [c2 H].
    simpl in H.
    exists c2.
    now inversion H.
Qed.

Lemma tgt_sem (det : weak_determinacy) : semantics_safety_like lang.
  (* Basic idea: if t is not in sem P, there is a prefix of t, m (here
     signified with a dependent type for the sake of simplicity), that
     does not belong to psem P. The argument can be that if every prefix
     of t is in the semantics, then t itself must be, too.

     Consider now the initial bad prefix m. If m is empty, choose it as
     the minimal bad prefix and any event as the bad event: these two
     instantiate the existentials in the goal. If m = snoc m' e, there
     are two possible cases: if m' is in sem P, it is the minimal bad
     prefix and e the bad event, and we are done; if m' is still not in
     sem P, we continue reducing it. (Thus, an easy induction.) *)

Proof.
  unfold semantics_safety_like. simpl.
  intros t P Hsem Hinf Hndiv.
  destruct (classic (stopped t)) as [Hstopped | Hnstopped].
  (* t stopped *)
  assert (Hstopinf : stopped t -> fin t).
  { clear.
    intros H. now assumption. }
  specialize (Hinf (Hstopinf Hstopped)). now contradiction.
  pose proof (semantics_safety_like_right det t P Hndiv Hnstopped).
  rewrite -> contra in H.
  specialize (H Hsem). apply not_all_ex_not in H.
  destruct H as [m Hm]. rewrite not_imp in Hm. destruct Hm as [Hm1 Hm2].
  generalize dependent Hm2. generalize dependent Hm1.
  destruct m as [p | p].
  - (* fstop *)
    intros Hm1 Hm2.
    assert (forall t m es, prefix (fstop m es) t -> fin t).
    { clear. intros t m. generalize dependent t. induction m; intros t es H.
      - destruct t; try now auto.
      - destruct t; try now auto. }
    unfold inf in Hinf. exfalso; apply Hinf. now apply (H t p es Hm1).
  - (* ftbd *)
    induction p as [| p' e' IH] using list_ind_snoc; intros Hm1 Hm2.
    + (* p = nil *)
      assert (Hm2' : @psem lang P (ftbd nil)).
      { clear. unfold psem. pose proof non_empty_sem P. destruct H as [t Ht].
        exists t; split. now destruct t. assumption. }
      now contradiction.
    + (* p = snoc p' e' *)
      pose proof (classic (@psem lang P (ftbd p'))) as [H | H].
      ++ exists p', e'. subst. split; try split; assumption.
      ++ apply IH.
         assert (H0: forall (p : list event) e t, prefix (ftbd (snoc p e)) t -> prefix (ftbd p) t).
         { clear. induction p.
           - intros. now destruct t.
           - intros. simpl in *. destruct t; try now auto.
             destruct l; try now auto.
             destruct H as [H1 H2].
             split. assumption.
             now specialize (IHp e (tstop l e0) H2).
             destruct l; try now auto.
             destruct H as [H1 H2].
             split. assumption.
             now specialize (IHp e (tsilent l) H2).
             destruct s; try now auto.
             destruct H as [H1 H2].
             split. assumption.
             now specialize (IHp e (tstream s) H2).
         }
         apply H0 in Hm1. assumption.
         assumption.
Qed.

End SmallSteps.


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 P Q R S Pprime Qprime Rprime Sprime A B X Y Qprimeprime Sprimeprime : Universe, ((wd_ A B /\ (wd_ X Y /\ (wd_ P Q /\ (wd_ R S /\ (wd_ Pprime Qprime /\ (wd_ Rprime Sprime /\ (wd_ Qprime Qprimeprime /\ (wd_ Sprime Sprimeprime /\ (wd_ B Qprimeprime /\ (wd_ A Qprimeprime /\ (col_ A B Pprime /\ (col_ A B Qprime /\ (col_ A B Rprime /\ (col_ A B Sprime /\ (col_ Pprime Qprimeprime Qprime /\ col_ Pprime Qprime A))))))))))))))) -> col_ Pprime Qprime B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import LinkingC.
Require Import CoqlibC Maps Errors ASTC.
Require Import sflib.
Require Import RelationClasses.

Require Export Maps.

Set Implicit Arguments.

Local Open Scope o_monad_scope.

Fixpoint xfilter_map (A B : Type) (f : positive -> A -> option B) (m : PTree.t A) (i : positive)
         {struct m} : PTree.t B :=
  match m with
  | PTree.Leaf => PTree.Leaf
  | PTree.Node l o r => PTree.Node (xfilter_map f l (xO i))
                                  (match o with None => None | Some x => (f (PTree.prev i) x) end)
                                  (xfilter_map f r (xI i))
  end.

Lemma xfilter_map_get:
  forall (A B: Type) (f: positive -> A -> option B) (i j : positive) (m: PTree.t A),
    PTree.get i (xfilter_map f m j) = o_bind (PTree.get i m) (f (PTree.prev (PTree.prev_append i j))).
Proof. induction i; intros; destruct m; simpl; auto. des_ifs. Qed.

(* partial mapping *)
Definition PTree_filter_map A B (f: positive -> A -> option B) (m: PTree.t A): PTree.t B := xfilter_map f m 1.

About PTree.gmap.

Lemma PTree_filter_map_spec
      A B (f: positive -> A -> option B) i m:
      (PTree_filter_map f m) ! i = o_bind (m ! i) (f i).
Proof.
  unfold PTree_filter_map. rewrite xfilter_map_get. f_equal. rewrite PTree.prev_append_prev. ss.
Qed.

About PTree.filter1.
Definition PTree_filter_key A (f: positive -> bool) (m: PTree.t A): PTree.t A :=
  PTree_filter_map (fun k v => if f k then Some v else None) m.

Lemma PTree_filter_key_spec
      A (f: positive -> bool) i (m: PTree.t A):
      (PTree_filter_key f m) ! i = assertion (f i); m ! i.
Proof.
  unfold PTree_filter_key. rewrite PTree_filter_map_spec. uo. des_ifs.
Qed.

Lemma PTree_elements_map
      X Y (f: X -> Y) xm:
    map (update_snd f) (PTree.elements xm) = PTree.elements (PTree.map (fun _ => f) xm).
Proof.
  unfold PTree.elements. unfold PTree.map. generalize 1%positive.
  assert(LIST: [] = map (update_snd f) ([]: list (prod positive X))) by ss.
  revert LIST. generalize ([]: list (prod positive X)) as lx. generalize ([]: list (prod positive Y)) as ly.
  induction xm; ii; ss. cbn in *. destruct o; ss; erewrite IHxm1; ss; erewrite IHxm2; ss.
Qed.