(*
This project is an attempt at formalising the proof of DRF-SC for the repaired
C11 memory model presented in the article (Repairing Sequential Consistency in
C/C++11; Lahav, Vafeiadis, Kang et al., PLDI 2017)

Author: Quentin Ladeveze, Inria Paris, France
*)

From RelationAlgebra Require Import
  lattice prop monoid rel kat_tac normalisation kleene kat rewriting.
Require Import Ensembles.
Require Import Lia.
Require Import Classical_Prop.
From RC11 Require Import util.
From RC11 Require Import exec.
From RC11 Require Import proprel_classic.
From RC11 Require Import prefix.
From RC11 Require Import rc11.
From RC11 Require Import conflict.

(** This file defines the notion of numbering on the events of an execution. *)

(** ** Definition *)

(** A valid numbering on an execution assigns to each event of the execution a
distinct number such that, if two events are related by the transitive closure
of the union of the sequenced-before and read-from relations of the execution,
then the numbering of the first event is smaller than the numbering of the
second event *)

Definition numbering event : nat :=
  match event with
  | Read eid _ _ _ => eid
  | Write eid _ _ _ => eid
  | Fence eid _ => eid
  end.

(** Two different events can't have the same numbering *)

Definition numbering_injective (ex: Execution) := forall x y,
  x <> y <-> numbering x <> numbering y.

(** Two identical events have the same numbering *)

Lemma numbering_injective_eq (ex: Execution) (x y: Event):
  numbering_injective ex ->
  x = y <-> numbering x = numbering y.
Proof.
  intros Hinj.
  split; intros H.
  - rewrite H; auto.
  - destruct (classic (x = y)) as [Hxy | Hxy].
    + auto.
    + rewrite (Hinj _ _) in Hxy.
      destruct (Hxy H).
Qed.

(** If an event is equal to a read whose numbering is the numbering of a second
event, the two events are equal *)

Lemma eq_num_read {ex: Execution} {x y: Event} {m: Mode} {l: Loc} {v: Val}:
  numbering_injective ex ->
  Read (numbering y) m l v = x ->
  x = y.
Proof.
  intros Hnuminj Heq.
  eapply numbering_injective_eq. eauto.
  rewrite <-Heq. auto.
Qed.

Lemma eq_num_read2 {ex: Execution} {x y: Event} {m: Mode} {l: Loc} {v: Val}:
  numbering_injective ex ->
  x = Read (numbering y) m l v ->
  x = y.
Proof.
  intros Hnuminj Heq.
  eapply numbering_injective_eq. eauto.
  rewrite Heq. auto.
Qed.

(** If a numbering of the events of an execution is injective, the numbering of
the events of its prefixes is also injective *)

Lemma numbering_injective_pre (ex pre: Execution):
  numbering_injective ex ->
  prefix pre ex ->
  numbering_injective pre.
Proof.
  intros Hnuminj Hpre. destruct_prefix Hpre.
  intros x y. apply Hnuminj; apply Hevts; auto.
Qed.

(** If an first event is related to a second event by the union of the sequenced
before relation and reads-from relation, the numbering of the first event is
strictly inferior to the numbering of the second event *)

Definition numbering_coherent ex :=
  forall x y, ((sb ex) ⊔ (rf ex)) x y ->
              numbering x < numbering y.

(** If a first event is related to a second event by the reflexive transitive
closure of the union of the sequenced-before relation and reads-from relation,
the numbering of the second event is greater or equal to the numbering of the
first event *)

Lemma numbering_coherent_rtc (ex: Execution) (x y: Event):
  numbering_coherent ex ->
  ((sb ex) ⊔ (rf ex))^* x y ->
  numbering y >= numbering x.
Proof.
  intros Hnumco.
  generalize dependent y.
  generalize dependent x.
  apply rtc_ind.
  - intros z1 z2 Hstep.
    apply Hnumco in Hstep. lia.
  - intuition auto.
  - intros z1 z2 z3 _ IH1 _ IH2.
    lia.
Qed.

(** If a first event is related to a second event by the transitive closure of
the union of the sequenced-before relation and reads-from relation, the
numbering of the second event is greater than the numbering of the first
event *)

Lemma numbering_coherent_tc (ex: Execution) (x y: Event):
  numbering_coherent ex ->
  ((sb ex) ⊔ (rf ex))^+ x y ->
  numbering y > numbering x.
Proof.
  intros Hnumco [z Hstep Hrtc].
  apply Hnumco in Hstep.
  apply (numbering_coherent_rtc _ _ _ Hnumco) in Hrtc.
  lia.
Qed.

(** If a first event is related by the sequenced-before relation to a second
event, the numbering of the second event is strictly greater than the numbering
of the first event *)

Lemma sb_num_ord (ex: Execution) (x y: Event):
  numbering_coherent ex ->
  sb ex x y ->
  (numbering y) > (numbering x).
Proof.
  intros Hnumco Hsb.
  eapply numbering_coherent_tc, tc_incl_itself. eauto.
  left; auto.
Qed.

(** If a first event is related by the read-modify-write relation to a second
event, the numbering of the second event is strictly greater than the numbering
of the first event *)

Lemma rmw_num_ord (ex: Execution) (x y: Event):
  valid_exec ex ->
  numbering_coherent ex ->
  rmw ex x y ->
  (numbering y) > (numbering x).
Proof.
  intros Hval Hnumco Hrmw.
  eapply (rmw_incl_sb _ Hval) in Hrmw.
  eapply sb_num_ord; eauto.
Qed.

(** If a first event is related by the reads-from relation to a second event,
the numbering of the second event is strictly greater than the numbering of the
first event *)

Lemma rf_num_ord (ex: Execution) (x y: Event):
  numbering_coherent ex ->
  rf ex x y ->
  (numbering y) > (numbering x).
Proof.
  intros Hnumco Hsb.
  eapply numbering_coherent_tc, tc_incl_itself; eauto.
  right; auto.
Qed.

(** If the numbering of the events of an execution is coherent, the numbering of
the events of its prefixes is also coherent *)

Lemma numbering_coherent_pre (ex pre: Execution):
  numbering_coherent ex ->
  prefix pre ex ->
  numbering_coherent pre.
Proof.
  intros Hnumco Hpre. destruct_prefix Hpre.
  intros x y Hsbrf.
  apply Hnumco.
  apply (incl_rel_thm Hsbrf). rewrite Hsb, Hrf. kat.
Qed.

(** In every execution, there is a last event whose numbering is greater than
the one of all the other events *)

Axiom numbering_bounded:
  exists e, forall e', numbering e >= numbering e'.

(** Tests if the numbering of an event is Less or Equal to a bound *)

Definition NLE (b: nat) : prop_set Event :=
  fun e => b >= (numbering e).

(** Being in the set of events whose numbering is less or equal to a bound is
equivalent to satisfying the NLE test with this bound *)

Lemma NLE_I_evts (bound: nat):
  [I (fun x => bound >= numbering x)] = [NLE bound].
Proof. unfold NLE. kat_eq. Qed.

(** If an event's numbering is less or equal to a bound minus one, it is less
or equal to the bound *)

Lemma NLE_bound_min_one (bound: nat):
  [NLE (bound-1)] ≦ [NLE bound].
Proof.
  intros x y [H1 H2].
  split; auto.
  unfold NLE in *. lia.
Qed.

(** If we test that an event's numbering is less or equal to two bounds, one of
which is strictly inferior to the other, we can replace these two tests by the
test of the event's numbering being less or equal to the smaller bound *)

Lemma nle_double (k1 k2: nat):
  k1 < k2 ->
  [NLE k1]⋅[NLE k2] = [NLE k1].
Proof.
  intros Hord. apply ext_rel, antisym.
  - intros x y [z [Heq1 Hr1] [Heq2 Hr2]].
    rewrite Heq2 in Heq1, Hr2. split; auto.
  - intros x y [Heq Hr].
    exists x; split; auto.
    unfold NLE in Hr. unfold NLE. lia.
Qed.

(** An bounded execution is a restriction of the events and relations of an
execution to the events whose numbering is less or equal to a given bound. *)

Definition bounded_exec (ex: Execution) (n: nat) : Execution :=
  {|
    exec.evts := Intersection _ (evts ex) (fun x => n >= numbering x);
    exec.sb := [NLE n] ⋅ (sb ex) ⋅ [NLE n];
    exec.rmw := [NLE n] ⋅ (rmw ex) ⋅ [NLE n];
    exec.rf := [NLE n] ⋅ (rf ex) ⋅ [NLE n];
    exec.mo := [NLE n] ⋅  (mo ex) ⋅ [NLE n];
  |}.

(** Simplifications of the different getters applied over bounded executions *)

Lemma simpl_evts_be (ex: Execution) (n:nat):
  evts (bounded_exec ex n) = Intersection _ (evts ex) (fun x => n >= numbering x).
Proof. compute; auto. Qed.

Lemma simpl_sb_be (ex: Execution) (n:nat):
  sb (bounded_exec ex n) = [NLE n] ⋅ (sb ex) ⋅ [NLE n].
Proof. compute; auto. Qed.

Lemma simpl_rmw_be (ex: Execution) (n:nat):
  rmw (bounded_exec ex n) = [NLE n] ⋅ (rmw ex) ⋅ [NLE n].
Proof. compute; auto. Qed.

Lemma simpl_rf_be (ex: Execution) (n:nat):
  rf (bounded_exec ex n) = [NLE n] ⋅ (rf ex) ⋅ [NLE n].
Proof. compute; auto. Qed.

Lemma simpl_mo_be (ex: Execution) (n:nat):
  mo (bounded_exec ex n) = [NLE n] ⋅ (mo ex) ⋅ [NLE n].
Proof. compute; auto. Qed.

Lemma simpl_rb_be (ex: Execution) (n:nat):
  rb (bounded_exec ex n) ≦ [NLE n] ⋅ (rb ex) ⋅ [NLE n].
Proof.
  unfold rb. rewrite simpl_mo_be, simpl_rf_be.
  rewrite 2dot_cnv, injcnv.
  kat.
Qed.

Create HintDb bounded_exec_db.

Hint Rewrite simpl_sb_be simpl_rmw_be simpl_rf_be simpl_mo_be : bounded_exec_db.

Tactic Notation "rew" "bounded" := autorewrite with bounded_exec_db.
Tactic Notation "rew" "bounded" "in" hyp(H) := autorewrite with bounded_exec_db in H.

(** Extract the information about the numbering of events from relations in
bounded executions *)

Lemma bounded_sb_l (ex: Execution) (n: nat) (x y: Event):
  sb (bounded_exec ex n) x y ->
  numbering x <= n.
Proof.
  intros H. rew bounded in H.
  apply simpl_trt_hyp in H as [H1 [_ H2]].
  unfold NLE in *. lia.
Qed.

Lemma bounded_sb_r (ex: Execution) (n: nat) (x y: Event):
  sb (bounded_exec ex n) x y ->
  numbering y <= n.
Proof.
  intros H. rew bounded in H.
  apply simpl_trt_hyp in H as [H1 [_ H2]].
  unfold NLE in *. lia.
Qed.

Lemma bounded_rf_l (ex: Execution) (n: nat) (x y: Event):
  rf (bounded_exec ex n) x y ->
  numbering x <= n.
Proof.
  intros H. rew bounded in H.
  apply simpl_trt_hyp in H as [H1 [_ H2]].
  unfold NLE in *. lia.
Qed.

Lemma bounded_rf_r (ex: Execution) (n: nat) (x y: Event):
  rf (bounded_exec ex n) x y ->
  numbering y <= n.
Proof.
  intros H. rew bounded in H.
  apply simpl_trt_hyp in H as [H1 [_ H2]].
  unfold NLE in *. lia.
Qed.

Lemma bounded_mo_l (ex: Execution) (n: nat) (x y: Event):
  mo (bounded_exec ex n) x y ->
  numbering x <= n.
Proof.
  intros H. rew bounded in H.
  apply simpl_trt_hyp in H as [H1 [_ H2]].
  unfold NLE in *. lia.
Qed.

Lemma bounded_mo_r (ex: Execution) (n: nat) (x y: Event):
  mo (bounded_exec ex n) x y ->
  numbering y <= n.
Proof.
  intros H. rew bounded in H.
  apply simpl_trt_hyp in H as [H1 [_ H2]].
  unfold NLE in *. lia.
Qed.

Lemma bounded_rb_l (ex: Execution) (n: nat) (x y: Event):
  rb (bounded_exec ex n) x y ->
  numbering x <= n.
Proof.
  intros H. unfold rb in H. destruct H as [z H _].
  rewrite <-cnv_rev in H.
  rew bounded in H.
  apply simpl_trt_hyp in H as [H1 [_ H2]].
  unfold NLE in *. lia.
Qed.

Lemma bounded_rb_r (ex: Execution) (n: nat) (x y: Event):
  rb (bounded_exec ex n) x y ->
  numbering y <= n.
Proof.
  intros H. unfold rb in H. destruct H as [z _ H].
  rew bounded in H.
  apply simpl_trt_hyp in H as [H1 [_ H2]].
  unfold NLE in *. lia.
Qed.

(** An event belonging to the events of a bounded executions belong to the events
of the execution *)

Lemma bounding_evts_in (ex: Execution) (x: Event) (bound: nat):
  In _ (evts (bounded_exec ex bound)) x ->
  In _ (evts ex) x.
Proof.
  intros [y Hin _]. auto.
Qed.

(** Bounding two executions by the same bound maintains the prefix relationship
between them *)

Lemma bounding_of_prefix (pre ex: Execution) (bound: nat):
  prefix pre ex ->
  prefix (bounded_exec pre bound) (bounded_exec ex bound).
Proof.
  intros Hpre.
  inverse_prefix Hpre.
  repeat (apply conj).
  - rewrite simpl_evts_be. intros x H.
    apply in_intersection in H as [H1 H2].
    split.
    + apply Hevts in H1. auto.
    + unfold In in *. auto.
  - intros a b Hsbrf Hinb. specialize (Hclosed a b).
    split.
    + apply Hclosed.
      * destruct Hsbrf as [Hsbrf|Hsbrf];
        rew bounded in Hsbrf;
        apply simpl_trt_rel in Hsbrf; [left|right]; auto.
      * rewrite simpl_evts_be in Hinb. apply in_intersection in Hinb as [Hinb _].
        auto.
    + unfold In.
      destruct Hsbrf as [Hsbrf|Hsbrf];
      apply simpl_trt_hyp in Hsbrf as [Hsbrf _];
      unfold NLE in Hsbrf; auto.
  - rew bounded. rewrite simpl_evts_be.
    rewrite I_inter. rewrite NLE_I_evts.
    rewrite Hsb. kat_eq.
  - rew bounded. rewrite simpl_evts_be.
    rewrite I_inter. rewrite NLE_I_evts.
    rewrite Hrf. kat_eq.
  - rew bounded. rewrite simpl_evts_be.
    rewrite I_inter. rewrite NLE_I_evts.
    rewrite Hmo. kat_eq.
  - rew bounded. rewrite simpl_evts_be.
    rewrite I_inter. rewrite NLE_I_evts.
    rewrite Hrmw. kat_eq.
Qed.

(** The union of all the relations of an execution bounded by [n] is included in
the union of all the relations of the execution bounded by [n] restricted to the
events whose numbering is less or equal to [n] *)

Lemma sc_cycle_be_incl_be_sc_cycle (ex: Execution) (n: nat):
  sb (bounded_exec ex n) ⊔
  rf (bounded_exec ex n) ⊔
  mo (bounded_exec ex n) ⊔
  rb (bounded_exec ex n) ≦
  [NLE n] ⋅
  (sb (bounded_exec ex n) ⊔
   rf (bounded_exec ex n) ⊔
   mo (bounded_exec ex n) ⊔
   rb (bounded_exec ex n) ) ⋅ [NLE n].
Proof.
  unfold rb.
  rew bounded.
  rewrite 2dot_cnv, injcnv.
  kat.
Qed.

(** The union of all the relations of a bounded execution is included in the
union of all the relations of the execution *)

Lemma cycle_be_incl_cycle_ex (ex: Execution) (bound:nat):
  sb (bounded_exec ex bound) ⊔ rf (bounded_exec ex bound) ⊔
  mo (bounded_exec ex bound) ⊔ rb (bounded_exec ex bound) ≦
  sb ex ⊔ rf ex ⊔ mo ex ⊔ rb ex.
Proof.
  unfold rb. rew bounded. rewrite 2dot_cnv, injcnv. kat.
Qed.

(** In a valid execution, if two events are related by [sb ex ⊔ rf ex], they
belong to the events of [ex] *)

Lemma sbrf_in_events (ex: Execution) (x y : Event) :
  valid_exec ex ->
  ((sb ex) ⊔ (rf ex)) x y ->
  In _ (evts ex) x /\ In _ (evts ex) y.
Proof.
  intros Hval [Hsb | Hrf]; split;
  eauto using sb_orig_evts, sb_dest_evts, rf_orig_evts, rf_dest_evts.
Qed.

(** If an event belongs to the events of an execution bounded by [n], its
numbering is less or equal to [n] and it belongs to the events of the execution *)

Lemma I_evts_bounded_le_bnd (ex: Execution) (n: nat):
  [I (evts (bounded_exec ex n))] = [NLE n] ⋅ [I (evts ex)].
Proof.
  apply ext_rel, antisym.
  - intros x y [Heq Hinter]. destruct Hinter.
    exists x; split; auto.
  - intros x y [z [Heq Hr] [Heq1 Hr1]].
    rewrite <- Heq in Hr1. rewrite Heq1 in Heq.
    split; [|split]; auto.
Qed.

(** Any bounding of a valid execution is a prefix of this execution *)

Lemma bounded_exec_is_prefix (ex: Execution) (n: nat):
  valid_exec ex ->
  numbering_coherent ex ->
  prefix (bounded_exec ex n) ex.
Proof.
  intros Hval Hnumco.
  split; [|split].
  - apply intersection_included_itself.
  - intros x y Hnum.
    generalize (sbrf_in_events _ _ _ Hval Hnum); intros [Hx Hy].
    apply (Hnumco _ _) in Hnum.
    intros H. destruct H as [y Hevts Hbound]; split.
    + auto.
    + unfold_in; lia.
  - rew bounded.
    repeat (apply conj);
    destruct_val_exec Hval.
    + destruct_sb_v Hsb_v.
      destruct Hsb_lso as [Hsb_in_e _].
      rewrite Hsb_in_e, I_evts_bounded_le_bnd. kat_eq.
    + destruct_rf_v Hrf_v. rewrite Hrf_in_e, I_evts_bounded_le_bnd. kat_eq.
    + destruct_mo_v Hmo_v. destruct Hmopo as [Hmo_in_e _].
      rewrite Hmo_in_e, I_evts_bounded_le_bnd. kat_eq.
    + destruct_rmw_v Hrmw_v. rewrite Hrmw_in_e, I_evts_bounded_le_bnd. kat_eq.
Qed.

(** If an execution is valid, any of its boundings is valid *)

Lemma bounded_is_valid (ex: Execution) (bound: nat):
  valid_exec ex ->
  numbering_coherent ex ->
  valid_exec (bounded_exec ex bound).
Proof.
  intros Hval Hnumco.
  eapply prefix_valid.
  eauto.
  eapply bounded_exec_is_prefix;
  eauto.
Qed.

(** If an execution is complete, any of its boundings is complete *)

Lemma bounded_is_complete (ex: Execution) (bound: nat):
  complete_exec ex ->
  numbering_coherent ex ->
  complete_exec (bounded_exec ex bound).
Proof.
  intros Hcomp Hnumco.
  eapply prefix_complete.
  eauto.
  eapply bounded_exec_is_prefix; auto.
  destruct Hcomp as [Hval _]. auto.
Qed.

(** If an execution is consistent in the RC11 model, any of its boundings is
consistent in the RC11 model *)

Lemma bounded_is_rc11 (ex: Execution) (bound: nat):
  valid_exec ex ->
  numbering_coherent ex ->
  rc11_consistent ex ->
  rc11_consistent (bounded_exec ex bound).
Proof.
  intros Hval Hnumco Hrc11.
  eapply prefix_rc11_consistent.
  eauto.
  eapply bounded_exec_is_prefix;
  eauto.
Qed.

(** If we have two boundings of an execution, the bounding bounded by the
smallest bound is a prefix of the bounding bounded by the biggest bound *)

Lemma two_ord_bounds_pre (ex: Execution) (k1 k2: nat):
  valid_exec ex ->
  numbering_coherent ex ->
  k1 < k2 ->
  prefix (bounded_exec ex k1) (bounded_exec ex k2).
Proof.
  intros Hval Hnumco Hord.
  inverse_val_exec Hval.
  repeat (apply conj).
  - destruct ex. apply inter_incl. intros x.
    unfold In. intros H. lia.
  - intros a b [Hsb|Hrf] Hin;
    apply in_intersection in Hin as [Hevts Hbord]; unfold_in.
    + rew bounded in Hsb. apply simpl_trt_hyp in Hsb as [_ [Hr _]].
      apply sb_num_ord in Hr as Habord; auto. split.
      * eapply sb_orig_evts; eauto.
      * unfold_in; lia.
    + rew bounded in Hrf. apply simpl_trt_hyp in Hrf as [_ [Hr _]].
      apply rf_num_ord in Hr as Habord; auto. split.
      * eapply rf_orig_evts; eauto.
      * unfold_in; lia.
  - rew bounded. rewrite I_evts_bounded_le_bnd.
    rewrite <- (nle_double _ _ Hord) at 1.
    rewrite <- (nle_double _ _ Hord) at 2.
    destruct_sb_v Hsb_v.
    destruct Hsb_lso as [Hsb_in_e _].
    rewrite Hsb_in_e. kat_eq.
  - rew bounded. rewrite I_evts_bounded_le_bnd.
    rewrite <- (nle_double _ _ Hord) at 1.
    rewrite <- (nle_double _ _ Hord) at 2.
    destruct_rf_v Hrf_v. rewrite Hrf_in_e. kat_eq.
  - rew bounded. rewrite I_evts_bounded_le_bnd.
    rewrite <- (nle_double _ _ Hord) at 1.
    rewrite <- (nle_double _ _ Hord) at 2.
    destruct_mo_v Hmo_v. destruct Hmopo as [Hmo_in_e _].
    rewrite Hmo_in_e. kat_eq.
  - rew bounded. rewrite I_evts_bounded_le_bnd.
    rewrite <- (nle_double _ _ Hord) at 1.
    rewrite <- (nle_double _ _ Hord) at 2.
    destruct_rmw_v Hrmw_v. rewrite Hrmw_in_e. kat_eq.
Qed.

(** There is a bound high enough so that the bounding of the execution is equal
to the execution *)

Lemma bounded_execution_itself_exists (ex: Execution):
  valid_exec ex ->
  exists k, ex = (bounded_exec ex k).
Proof.
  destruct (numbering_bounded) as [k Hsup].
  intros Hval.
  exists (numbering k).
  apply tautology_makes_fullset in Hsup. destruct ex.
  unfold bounded_exec. rew bounded.
  unfold NLE. rewrite Hsup. f_equal.
  - simpl. erewrite inter_fullset. auto.
  - unfold exec.sb. rewrite fullset_one. kat_eq.
  - unfold exec.rmw. rewrite fullset_one. kat_eq.
  - unfold exec.rf. rewrite fullset_one. kat_eq.
  - unfold exec.mo. rewrite fullset_one. kat_eq.
Qed.

(** ** Smallest conflicting prefix *)

(** A bound encodes the smallest possible conflicting prefix if all the other
conflicting boundings are bounded by a bigger bound *)

Definition smallest_conflicting_bounding (ex: Execution) (bound: nat) :=
  expi (bounded_exec ex bound) /\
  (forall n, expi (bounded_exec ex n) ->
             n >= bound).

Axiom smallest_conflicting_bounding_exists:
  forall ex, expi ex ->
             (exists bound, smallest_conflicting_bounding ex bound).

(** The boundings smaller than the smallest conflicting bounding are not
conflicting *)

Lemma smaller_than_smallest_not_conflicting (ex: Execution) (bound: nat):
  (smallest_conflicting_bounding ex bound) ->
  forall smaller, smaller < bound ->
                  ~(expi (bounded_exec ex smaller)).
Proof.
  intros [_ Hsmallest] smaller Hsmaller Hnot.
  apply Hsmallest in Hnot.
  lia.
Qed.

Theorem smaller_than_smallest_sc (ex: Execution) (bound: nat):
  valid_exec ex ->
  numbering_coherent ex ->
  rc11_consistent ex ->
  (smallest_conflicting_bounding ex bound) ->
  forall smaller, smaller < bound ->
                  sc_consistent (bounded_exec ex smaller).
Proof.
  intros Hval Hnumco Hrc11 Hscb smaller Hsmaller.
  eapply no_conflict_prefix_sc; eauto.
  - eauto using bounded_exec_is_prefix.
  - eapply smaller_than_smallest_not_conflicting; eauto.
Qed.

(** ** Minimal conflicting pair *)

(** If an execution contains conflicts, there is a unique pair of events that
are in conflict and belong to the smallest conflicting prefix of the execution *)

Definition minimal_conflicting_pair (ex: Execution) (bound: nat) (j k: Event) :=
  (smallest_conflicting_bounding ex bound) /\
  (pi (bounded_exec ex bound) j k).

(** Two events forming a minimal conflicting pair can be equal *)

Lemma mcp_irr (ex: Execution) (bound: nat) (k: Event):
  ~(minimal_conflicting_pair ex bound k k).
Proof.
  intros Hnot.
  destruct Hnot as [_ Hnot].
  apply pi_diff in Hnot.
  intuition auto.
Qed.

(** The minimal conflicting pair of given execution and bound is a symmetric
relation *)

Lemma mcp_is_sym (ex: Execution) (bound: nat) (j k: Event):
  (minimal_conflicting_pair ex bound j k) <->
  (minimal_conflicting_pair ex bound k j).
Proof. compute; intuition eauto. Qed.

(** The two events and the bound forming the minimal conflicting pair of an
execution are such that the two events are pi-conflicting in the bounding of
the execution by the bound *)

Lemma mcp_is_pi (ex: Execution) (bound:nat) (j k: Event):
  minimal_conflicting_pair ex bound j k ->
  pi (bounded_exec ex bound) j k.
Proof. intros [_ ?]. auto. Qed.

(** The two events and the bound forming the minimal conflicting pair of an
execution are such that the two events belong to the events of the bounding of
the execution by the bound *)

Lemma mcp_in_evts_left (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  In _ (evts (bounded_exec ex bound)) x.
Proof. intros. eauto using pi_in_evts_left, mcp_is_pi. Qed.

Lemma mcp_in_evts_right (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  In _ (evts (bounded_exec ex bound)) y.
Proof. intros. eauto using pi_in_evts_right, mcp_is_pi. Qed.

Lemma mcp_in_evts_left2 (ex: Execution) (x y: Event) (bound: nat):
  minimal_conflicting_pair ex bound x y ->
  In _ (evts ex) x.
Proof.
  intros Hmcp. apply mcp_in_evts_left in Hmcp.
  destruct Hmcp; auto.
Qed.

Lemma mcp_in_evts_right2 (ex: Execution) (x y: Event) (bound: nat):
  minimal_conflicting_pair ex bound x y ->
  In _ (evts ex) y.
Proof.
  intros Hmcp. apply mcp_in_evts_right in Hmcp.
  destruct Hmcp; auto.
Qed.
(** One of the two events forming a minimal conflicting pair must be a write
event *)

Lemma mcp_one_is_write (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  is_write x \/ is_write y.
Proof. intros. eauto using pi_one_is_write, mcp_is_pi. Qed.

(** Two events forming a minimal conflicting pair are different *)

Lemma mcp_diff (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  x <> y.
Proof. intros. eauto using pi_diff, mcp_is_pi. Qed.

(** Two events forming a minimal conflicting pair affect the same location *)

Lemma mcp_same_loc (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  get_loc x = get_loc y.
Proof. intros. eauto using pi_same_loc, mcp_is_pi. Qed.

(** At least one of the two events forming a conflicting pair must be a SC
event *)

Lemma mcp_at_least_one_not_sc (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  at_least_one_not_sc x y.
Proof. intros. eauto using pi_at_least_one_not_sc, mcp_is_pi. Qed.

(** Two events forming a minimal conflicting pair must each be either a read or
a write *)

Lemma mcp_readwrite_l (ex: Execution) (x y: Event) (bound: nat):
  minimal_conflicting_pair ex bound x y ->
  (is_write x) \/ (is_read x).
Proof. intros. eauto using pi_readwrite_l, mcp_is_pi. Qed.

Lemma mcp_readwrite_r (ex: Execution) (x y: Event) (bound: nat):
  minimal_conflicting_pair ex bound x y ->
  (is_write y) \/ (is_read y).
Proof. intros. eauto using pi_readwrite_r, mcp_is_pi. Qed.

(** Two events forming a minimal conflicting pair are not ordered by the
transitive closure of the union of the sequenced-before relation and of the
restriction of the reads-from relation to SC events, in the execution bounded
by the minimal bound in either direction *)

Lemma mcp_not_sbrfsc (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  ~((sb (bounded_exec ex bound) ⊔ (res_mode Sc (rf (bounded_exec ex bound))))^+ x y).
Proof. intros. eauto using pi_not_sbrfsc, mcp_is_pi. Qed.

Lemma mcp_not_cnv_sbrfsc (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  ~((sb (bounded_exec ex bound) ⊔ (res_mode Sc (rf (bounded_exec ex bound))))^+ y x).
Proof. intros. eauto using pi_not_cnv_sbrfsc, mcp_is_pi. Qed.

(** The events forming a minimal conflicting pair have a numbering less or equal
to the minimal bound *)

Lemma mcp_left_le_bound (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  (numbering x) <= bound.
Proof.
  intros Hmcp. eapply mcp_in_evts_left in Hmcp.
  destruct Hmcp as [? _ Hxord]. unfold In in Hxord.
  auto.
Qed.

Lemma mcp_right_le_bound (ex: Execution) (x y: Event) (bound:nat):
  minimal_conflicting_pair ex bound x y ->
  (numbering y) <= bound.
Proof.
  intros Hmcp. eapply mcp_in_evts_right in Hmcp.
  destruct Hmcp as [? _ Hxord]. unfold In in Hxord.
  auto.
Qed.

(** The numbering of one of the two events forming a minimal conflicting pair
is equal to the minimal bound and the numbering of the other event is strictly
inferior to the minmal bound *)

Lemma mcp_left_eq_lt_bound (ex: Execution) (bound: nat) (x y: Event):
  minimal_conflicting_pair ex bound x y ->
  (numbering x) = bound \/ (numbering x) < bound.
Proof.
  intros Hmcp.
  destruct (Compare_dec.lt_eq_lt_dec (numbering x) bound) as [[Hord|Hord]|Hord];
  [right;auto|left;auto|].
  apply mcp_left_le_bound in Hmcp. lia.
Qed.

Lemma mcp_right_eq_lt_bound (ex: Execution) (bound: nat) (x y: Event):
  minimal_conflicting_pair ex bound x y ->
  (numbering y) = bound \/ (numbering y) < bound.
Proof.
  intros Hmcp.
  destruct (Compare_dec.lt_eq_lt_dec (numbering y) bound) as [[Hord|Hord]|Hord];
  [right;auto|left;auto|].
  apply mcp_right_le_bound in Hmcp. lia.
Qed.

(** Every execution containing pi-conflicting events has a minimal conflicting
pair *)

Lemma mcp_exists (ex: Execution):
  expi ex ->
  (exists bound j k, minimal_conflicting_pair ex bound j k).
Proof.
  intros Hconf.
  destruct (smallest_conflicting_bounding_exists _ Hconf) as [bound Hsmallest].
  exists bound.
  destruct Hsmallest as [[j [k Hpreconf]] Hsmallest].
  exists j, k. split; [split|]; auto.
  exists j, k. auto.
Qed.

(** Every execution containing pi-conflicting events has a minimal conflicting
pair with one of the events having the biggest numbering *)

Lemma mcp_exists_ord (ex: Execution):
  expi ex ->
  numbering_injective ex ->
  (exists bound j k, minimal_conflicting_pair ex bound j k /\
                     (numbering j) < (numbering k)).
Proof.
  intros Hexpi Hnuminj.
  destruct (mcp_exists _ Hexpi) as [b [j [k Hmcp]]].
  destruct (Compare_dec.lt_eq_lt_dec (numbering j) (numbering k)) as
  [[Hcomp|Hcomp]|Hcomp].
  - exists b, j, k. intuition auto.
  - exfalso. eapply mcp_irr.
    eapply numbering_injective_eq in Hcomp; eauto.
    rewrite Hcomp in Hmcp. eauto.
  - exists b, k, j. intuition auto.
    eapply mcp_is_sym. auto.
Qed.

(** In a minimal conflicting pair, at least one of the two events is not SC *)

Lemma mcp_not_sc (ex: Execution) (bound: nat) (j k: Event):
  (minimal_conflicting_pair ex bound j k) ->
  ~((get_mode j) = Sc /\ (get_mode k) = Sc).
Proof.
  intros [_ [[_ H] _]].
  auto.
Qed.

(** In a minimal conflicting pair, the two conflicting events cannot be related
by sb *)

Lemma mcp_not_sb_jk (ex: Execution) (bound: nat) (j k: Event):
  minimal_conflicting_pair ex bound j k ->
  ~(sb ex j k).
Proof.
  intros Hmcp Hsb.
  inversion Hmcp as [_ [_ Hnot]].
  apply Hnot. left. apply tc_incl_itself. left.
  rew bounded. simpl_trt.
  - eapply mcp_left_le_bound. eauto.
  - auto.
  - eapply mcp_right_le_bound. eauto.
Qed.

(*
(** In a valid execution, the set of events whose numbering in an execution
bounded by [n] is less or equal to a bound, is the same as the set of events
whose numbering in the execution is less or equal to the same bound *)

Lemma NLE_set_in_bound_ex_rew (ex: Execution) (b1 b2: nat):
  valid_exec ex ->
  (fun x => b2 >= (numbering x)) =
  (fun x => b2 >= (numbering x)).
Proof.
  intuition auto.
  intros Hval.
  pose proof (bounded_exec_is_prefix _ b1 Hval) as Hpre.
  pose proof (numbering_pre_stable _ _ Hpre) as Hnumeq.
  apply ext_set. split; intros H.
  - rewrite Hnumeq in H. auto.
  - rewrite Hnumeq. auto.
Qed.

Lemma NLE_in_bound_ex_rew (ex: Execution) (b1 b2: nat):
  valid_exec ex ->
  [NLE (bounded_exec ex b1) b2] = [NLE ex b2].
Proof.
  intros Hval.
  pose proof (bounded_exec_is_prefix _ b1 Hval) as Hpre.
  pose proof (numbering_pre_stable _ _ Hpre) as Hnumeq.
  apply ext_rel, antisym; intros x y H;
  destruct H as [Heq Hord];
  split; auto; unfold NLE in *.
  - rewrite Hnumeq in Hord; auto.
  - rewrite Hnumeq; auto.
Qed.
*)

(** Bounding an execution already bounded by a smaller bound has no effect *)

Lemma double_bounding_rew (ex: Execution) (b1 b2: nat):
  valid_exec ex ->
  b1 < b2 ->
  bounded_exec (bounded_exec ex b1) b2 = bounded_exec ex b1.
Proof.
  intros Hval Hord.
  unfold bounded_exec at 1.
  (*
  rewrite (NLE_in_bound_ex_rew _ b1 b2 Hval).
  rewrite (NLE_set_in_bound_ex_rew _ b1 b2 Hval).
  *)
  rew bounded. unfold bounded_exec at 2.
  f_equal.
  - apply ext_set. intros x; split; intros H.
    + destruct H as [y Hevtsb1 Hordb2].
      unfold bounded_exec in Hevtsb1.
      simpl in Hevtsb1. unfold In in Hevtsb1. auto.
    + split.
      * unfold bounded_exec. simpl. unfold In. auto.
      * destruct H as [y _ Hb1]. unfold_in. lia.
  - rewrite <- (nle_double _ _ Hord) at 4.
    rewrite <- (nle_double _ _ Hord) at 3.
    kat_eq.
  - rewrite <- (nle_double _ _ Hord) at 4.
    rewrite <- (nle_double _ _ Hord) at 3.
    kat_eq.
  - rewrite <- (nle_double _ _ Hord) at 4.
    rewrite <- (nle_double _ _ Hord) at 3.
    kat_eq.
  - rewrite <- (nle_double _ _ Hord) at 4.
    rewrite <- (nle_double _ _ Hord) at 3.
    kat_eq.
Qed.

(** Bounding an execution already bounded with a greater bound is the same as
directly bounding the execution with the smaller bound *)

Lemma double_bounding_rew' (ex: Execution) (b1 b2: nat):
  valid_exec ex ->
  b1 < b2 ->
  bounded_exec (bounded_exec ex b2) b1 = bounded_exec ex b1.
Proof.
  intros Hval Hord.
  unfold bounded_exec at 1.
  (*
  rewrite (NLE_in_bound_ex_rew _ b2 b1 Hval).
  rewrite (NLE_set_in_bound_ex_rew _ b2 b1 Hval).
  *)
  rew bounded. unfold bounded_exec at 2.
  f_equal.
  - apply ext_set. intros x; split; intros H.
    + destruct H as [y Hevtsb2 Hb1].
      split; auto.
      destruct Hevtsb2; auto.
    + destruct H as [y Hevts Hb1].
      split; auto.
      split; auto.
      unfold_in; lia.
  - rewrite <- (nle_double _ _ Hord) at 4.
    rewrite <- (nle_double _ _ Hord) at 3.
    kat_eq.
  - rewrite <- (nle_double _ _ Hord) at 4.
    rewrite <- (nle_double _ _ Hord) at 3.
    kat_eq.
  - rewrite <- (nle_double _ _ Hord) at 4.
    rewrite <- (nle_double _ _ Hord) at 3.
    kat_eq.
  - rewrite <- (nle_double _ _ Hord) at 4.
    rewrite <- (nle_double _ _ Hord) at 3.
    kat_eq.
Qed.

(** Bouding an execution twice with the same bound is the same as bounding it
once *)

Lemma double_same_bounding_rew (ex: Execution) (b: nat):
  valid_exec ex ->
  bounded_exec (bounded_exec ex b) b = bounded_exec ex b.
Proof.
  intros Hval.
  unfold bounded_exec at 3.
  unfold bounded_exec at 1.
  f_equal.
  - unfold bounded_exec at 1.
    unfold evts at 1.
    apply ext_set. intros x; split.
    + intros [y [H1 H2] H3]. split; unfold_in; auto.
    + intros [y H1 H2]. split; [split|]; unfold_in; auto.
  - rew bounded. kat_eq.
  - rew bounded. kat_eq.
  - rew bounded. kat_eq.
  - rew bounded. kat_eq.
Qed.

(** If a bound is the smallest conflicting bounding of an execution, it is the
smallest conflicting bounding of the execution bounded by the bound *)

Lemma scp_bounded (ex: Execution) (bound: nat):
  valid_exec ex ->
  smallest_conflicting_bounding ex bound ->
  smallest_conflicting_bounding (bounded_exec ex bound) bound.
Proof.
  intros Hval [Hexpi Hsmaller].
  split.
  - rewrite (double_same_bounding_rew ex bound Hval). auto.
  - intros n Hexpidbound.
    destruct (classic (n < bound)) as [Hord|Hord].
    + apply Hsmaller. erewrite double_bounding_rew' in Hexpidbound; auto.
    + apply Compare_dec.not_lt in Hord. auto.
Qed.

(** If two events and a bound are the minimal conflicting pair of an execution,
they are the minimal conflicting pair of the execution bounded by the bound *)

Lemma mcp_bounded (ex: Execution) (bound: nat) (x y: Event):
  valid_exec ex ->
  minimal_conflicting_pair ex bound x y ->
  minimal_conflicting_pair (bounded_exec ex bound) bound x y.
Proof.
  intros Hval [Hscb Hpi]; split.
  - apply scp_bounded; auto.
  - rewrite (double_same_bounding_rew ex bound Hval). auto.
Qed.

(** If two events are conflicting in a bounded execution, they are also
conflicting in the execution bounded by the greatest of the numberings of the
two events *)

Lemma bound_to_c_events (ex: Execution) (b:nat) (j k: Event):
  valid_exec ex ->
  numbering_coherent ex ->
  numbering j <= numbering k ->
  numbering k < b ->
  pi (bounded_exec ex b) j k ->
  pi (bounded_exec ex (numbering k)) j k.
Proof.
  intros Hval Hnumco Hord Hord' [[[Hinj [Hink [Hw [Hdiff Hloc]]]] Hsc] Hbidir].
  repeat (apply conj); auto.
  - destruct ex. simpl. destruct Hinj as [z Hjevts Hinj]. split.
    + simpl in Hjevts. auto.
    + unfold In. lia.
  - destruct ex. simpl. destruct Hink as [z Hkevts Hink]. split.
    + simpl in Hkevts. auto.
    + unfold In. lia.
  (*
  - destruct (not_or_and _ _ Hbidir) as [Hjk Hkj].
    apply and_not_or. split; auto.
  *)
  - destruct (not_or_and _ _ Hbidir) as [Hjk Hkj].
    intros Hnot. destruct Hnot as [Hnot|Hnot].
    + apply Hjk.
      eapply sbrfsc_pre_inc.
      * eapply two_ord_bounds_pre; eauto.
      * auto.
    + apply Hkj.
      eapply sbrfsc_pre_inc.
      * eapply two_ord_bounds_pre; eauto.
      * auto.
Qed.

(** If two events are conflicting and if their numbering is strictly inferior to
a bound, this bound cannot be the smallest conflicting bounding *)

Lemma smallest_conflicting_bounding_conflict (ex: Execution) (j k: Event) (b: nat):
  valid_exec ex ->
  numbering_coherent ex ->
  numbering k < b ->
  numbering j < b ->
  smallest_conflicting_bounding ex b ->
  pi (bounded_exec ex b) j k ->
  False.
Proof.
  intros Hval Hnumco Hord1 Hord2 Hscb Hconf.
  destruct (Compare_dec.lt_eq_lt_dec (numbering j) (numbering k)) as [[Hjlt|Hjeq]|Hjgt].
  - destruct Hscb as [_ Hsmallest].
    assert (numbering k >= b).
    * apply Hsmallest. exists j, k.
      apply bound_to_c_events with b; auto. lia.
    * lia.
  - destruct Hscb as [_ Hsmallest].
    assert (numbering k >= b).
    * apply Hsmallest. exists j, k.
      apply bound_to_c_events with b; auto. lia.
    * lia.
  - destruct Hscb as [_ Hsmallest].
    assert (numbering j >= b).
    * apply Hsmallest. exists j, k.
      rewrite pi_sym. rewrite pi_sym in Hconf.
      apply bound_to_c_events with b; auto. lia.
    * lia.
Qed.

(** In a minimal conflicting pair, the bound is the numbering of one of the two
conflicting events *)

Theorem mcp_num_snd_evt (ex: Execution) (bound: nat) (j k: Event):
  valid_exec ex ->
  numbering_coherent ex ->
  (minimal_conflicting_pair ex bound j k) ->
  (max (numbering k) (numbering j) = bound).
Proof.
  intros Hval Hnumco [Hscb Hconf].
  destruct (Compare_dec.lt_eq_lt_dec bound (numbering k)) as [[Hklt|Hkeq]|Hkgt].
  - destruct Hconf as [[[_ [? _]] _] _]. destruct ex. simpl in H.
    destruct H as [? ?]. unfold In in *. lia.
  - destruct (Compare_dec.lt_eq_lt_dec (numbering j) (numbering k)) as [[Hjlt|Hjeq]|Hjgt].
    + rewrite (max_rewrite _ _ Hjlt). auto.
    + rewrite Hjeq, PeanoNat.Nat.max_id. auto.
    + destruct Hconf as [[[? _] _] _].
      destruct ex. simpl in H. destruct H as [? ?]. unfold In in *. lia.
  - destruct (Compare_dec.lt_eq_lt_dec (numbering j) (numbering k)) as [[Hjlt|Hjeq]|Hjgt].
    + exfalso.
      apply (smallest_conflicting_bounding_conflict ex j k bound); auto.
      lia.
    + exfalso.
      apply (smallest_conflicting_bounding_conflict ex j k bound); auto.
      lia.
    + rewrite (max_rewrite' _ _ Hjgt).
      destruct (Compare_dec.lt_eq_lt_dec (numbering j) bound) as [[Hblt|Hbeq]|Hbgt].
      * exfalso.
        apply (smallest_conflicting_bounding_conflict ex j k bound); auto.
      * auto.
      * destruct Hconf as [[[? _] _] _]. destruct ex. simpl in H.
        destruct H as [? ?]. unfold In in *. lia.
Qed.

Lemma mcp_num_snd_evt_ord (ex: Execution) (bound: nat) (j k: Event):
  valid_exec ex ->
  numbering_coherent ex ->
  (minimal_conflicting_pair ex bound j k) ->
  (numbering k) > (numbering j) ->
  numbering k = bound.
Proof.
  intros Hval Hnumco Hmcp Hord.
  pose proof (mcp_num_snd_evt _ _ _ _ Hval Hnumco Hmcp) as Hmax.
  rewrite (max_rewrite _ _ Hord) in Hmax. auto.
Qed.

(** All the events of a minimal conflicting pair that are not the second event
of the pair have a numbering smaller than the second event *)

Lemma mcp_all_smaller_snd_evt (ex: Execution) (bound: nat) (x j k: Event):
  valid_exec ex ->
  numbering_coherent ex ->
  numbering_injective ex ->
  (minimal_conflicting_pair ex bound j k) ->
  (numbering k) > (numbering j) ->
  In _ (evts (bounded_exec ex bound)) x ->
  x <> k ->
  numbering x < numbering k.
Proof.
  intros Hval Hnumco Hnuminj Hmcp Hord Hxevts Hdiff.
  pose proof (mcp_num_snd_evt_ord _ _ _ _ Hval Hnumco Hmcp Hord) as Heq.
  apply in_intersection in Hxevts as [_ Hxbound].
  unfold In in Hxbound. rewrite Heq.
  destruct (Compare_dec.lt_eq_lt_dec (numbering x) bound) as [[H|H]|H].
  - lia.
  - rewrite <-H in Heq. apply (numbering_injective_eq _ _ _ Hnuminj) in Heq.
    congruence.
  - lia.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal50.

From lfind Require Import LFind.
Require Import Arith.
Lemma lfind_state  (x:natural) (n:natural) (y:lst) (IHy:@eq natural (count (sort y) x) (count y x)) (E:@eq bool (eqb x n) false):@eq natural (count (insort (sort y) n) x) (count y x).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal50_theorem0_199_count_insort_diff/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (n:natural) (y:lst) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"n:" ++ "(" ++ show n ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  n y.
QuickChick collect_data.
Success.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e448m2e224m1_10limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(** Pervasives functions using [nat] instead of [int]

    [nat] are unary numbers, so this highly inefficient!
    These operations are unsafe when numbers exceed [max_int] in OCaml.
  *)

(* begin hide *)
From Coq.extraction Require Import
     ExtrOcamlIntConv.

From SimpleIO Require Import
     IO_Monad
     IO_Pervasives.

Import IO.Notations.

Set Warnings "-extraction-opaque-accessed,-extraction".
(* end hide *)

Definition print_nat : nat -> IO unit :=
  fun n => print_int (int_of_nat n).

Definition prerr_nat : nat -> IO unit :=
  fun n => prerr_int (int_of_nat n).

Definition read_nat : IO nat :=
  IO.map nat_of_int read_int.

Definition read_nat_opt : IO (option nat) :=
  IO.map (option_map nat_of_int) read_int_opt.

Definition output_nat : out_channel -> nat -> IO unit :=
  fun h n => output_string h (ostring_of_int (int_of_nat n)).

Definition output_byte_nat : out_channel -> nat -> IO unit :=
  fun h n => output_byte h (int_of_nat n).

Definition input_byte_nat : in_channel -> IO nat :=
  fun h => IO.map nat_of_int (input_byte h).

Definition incr_ref_nat : ref nat -> IO unit :=
  fun r =>
    n <- read_ref r;;
    write_ref r (Nat.succ n).

(** N.B.: 0 decreases to 0. *)
Definition decr_ref_nat : ref nat -> IO unit :=
  fun r =>
    n <- read_ref r;;
    write_ref r (Nat.pred n).

Definition exit_nat {a} : nat -> IO a :=
  fun n => exit (int_of_nat n).


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Trivial.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.ExtensionTactic.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Section ContextProperties.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: Derivable L}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimumSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {cpSC: ClassicalPropositionalSequentCalculus L Gamma}.

Lemma classical_derivable_spec: forall (Phi: context) (x: expr),
  Phi |-- x <-> ~ consistent (Union _ Phi (Singleton _ (~~ x))).
Proof.
  intros.
  unfold consistent.
  AddAxiomatization.
  fold (@consistent L Gamma (Phi;; ~~ x)).
  rewrite <- (double_negp x) at 1.
  unfold negp at 1.
  rewrite <- deduction_theorem.
  rewrite consistent_spec.
  tauto.
Qed.

Lemma MCS_nonelement_inconsistent: forall (Phi: context),
  maximal consistent Phi ->
  (forall x: expr, ~ Phi x <-> Phi |-- x --> FF).
Proof.
  intros.
  split; intros.
  + destruct H.
    specialize (H1 (Union _ Phi (Singleton _ x))).
    rewrite consistent_spec in H1.
    rewrite deduction_theorem in H1.
    assert (Included expr Phi (Union expr Phi (Singleton expr x))) by (intros ? ?; left; auto).
    assert (~ Included expr (Union expr Phi (Singleton expr x)) Phi) by (intros HH; specialize (HH x); apply H0, HH; right; constructor).
    tauto.
  + intro.
    pose proof derivable_assum Phi x H1.
    pose proof deduction_modus_ponens _ _ _ H2 H0.
    destruct H as [? _].
    rewrite consistent_spec in H; auto.
Qed.

Lemma maximal_consistent_orp_witnessed: forall (Phi: context),
  maximal consistent Phi -> orp_witnessed Phi.
Proof.
  intros.
  hnf; intros.
  rewrite MCS_element_derivable in H0 by auto.
  apply NNPP; intro.
  apply not_or_and in H1.
  destruct H1.
  rewrite MCS_nonelement_inconsistent in H1, H2 by eauto.
  destruct H as [? _]; rewrite consistent_spec in H.
  apply H.
  eapply deduction_modus_ponens; [exact H0 |].
  apply deduction_orp_elim'; auto.
Qed.

Lemma MCS_andp_iff: forall (Phi: context),
  maximal consistent Phi ->
  (forall x y: expr, Phi (x && y) <-> (Phi x /\ Phi y)).
Proof.
  intros.
  apply maximal_consistent_derivable_closed in H.
  apply DCS_andp_iff; auto.
Qed.

Lemma MCS_orp_iff: forall (Phi: context),
  maximal consistent Phi ->
  (forall x y: expr, Phi (x || y) <-> (Phi x \/ Phi y)).
Proof.
  intros.
  apply DCS_orp_iff; auto.
  + apply maximal_consistent_derivable_closed; auto.
  + apply maximal_consistent_orp_witnessed; auto.
Qed.

Lemma MCS_impp_iff: forall (Phi: context),
  maximal consistent Phi ->
  (forall x y: expr, Phi (x --> y) <-> (Phi x -> Phi y)).
Proof.
  intros.
  split; intros.
  + rewrite MCS_element_derivable in H0, H1 |- * by auto.
    apply (deduction_modus_ponens _ x y); auto.
  + pose proof derivable_excluded_middle Phi y.
    rewrite <- MCS_element_derivable in H1 by auto.
    rewrite MCS_orp_iff in H1 by auto.
    pose proof derivable_excluded_middle Phi x.
    rewrite <- MCS_element_derivable in H2 by auto.
    rewrite MCS_orp_iff in H2 by auto.
    destruct H1; [| destruct H2].
    - rewrite MCS_element_derivable in H1 |- * by auto.
      apply deduction_left_impp_intros; auto.
    - exfalso.
      apply H0 in H2.
      rewrite MCS_element_derivable in H1, H2 by auto.
      pose proof deduction_modus_ponens _ _ _ H2 H1.
      destruct H as [? _].
      rewrite consistent_spec in H; auto.
    - rewrite MCS_element_derivable in H2 |- * by auto.
      unfold negp in H2.
      rewrite <- deduction_theorem in H2 |- *.
      pose proof deduction_falsep_elim _ y H2.
      auto.
Qed.

Lemma MCS_negp_iff: forall (Phi: context),
  maximal consistent Phi ->
  (forall x: expr, Phi (~~ x) <-> ~ Phi x).
Proof.
  intros.
  unfold negp.
  rewrite MCS_impp_iff by auto.
  assert (~ Phi FF); [| tauto].
  pose proof proj1 H.
  rewrite consistent_spec, <- MCS_element_derivable in H0 by auto.
  auto.
Qed.

Lemma DDCS_MCS: forall (Phi: context),
  derivable_closed Phi ->
  orp_witnessed Phi ->
  consistent Phi ->
  maximal consistent Phi.
Proof.
  intros.
  split; auto.
  intros.
  unfold Included, Ensembles.In; intros.
  pose proof derivable_excluded_middle Phi x.
  apply H in H5.
  apply H0 in H5.
  destruct H5; auto.
  exfalso.
  apply H3 in H5; unfold Ensembles.In in H5.
  rewrite consistent_spec in H2.
  apply H2; clear H2.
  apply derivable_assum in H4.
  apply derivable_assum in H5.
  eapply deduction_modus_ponens.
  - apply H4.
  - apply H5.
Qed.

End ContextProperties.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D G E F I : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ B D /\ (wd_ B D /\ (wd_ D G /\ (wd_ B G /\ (wd_ A D /\ (wd_ C D /\ (wd_ G E /\ (wd_ E C /\ (wd_ G C /\ (wd_ G F /\ (wd_ F A /\ (wd_ G A /\ (wd_ C F /\ (wd_ G I /\ (wd_ I E /\ (wd_ G E /\ (col_ A B C /\ (col_ B D G /\ (col_ G E C /\ (col_ G F A /\ (col_ G I E /\ col_ G E F)))))))))))))))))))))))) -> col_ A G E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import FcEtt.sigs.

Require Import FcEtt.fc_dec_fuel.
Require Import FcEtt.fc_dec_fun.
Require Import FcEtt.fc_dec_aux.

Require Import FcEtt.imports.
(* Require Export FcEtt.ett_inf_cs. *)
Require Import FcEtt.ett_ind.
Require Export FcEtt.fc_invert.

Require Import Coq.Init.Specif.
Require Import Coq.micromega.Lia.

Module fc_dec (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig) (unique: fc_unique_sig).

Module invert := fc_invert wf weak subst.
Module fuel := fc_dec_fuel wf weak subst unique.
Module tc_fun := fc_dec_fun wf weak subst unique.
Module aux := fc_dec_aux wf weak subst unique.

Import tc_fun fuel aux unique wf subst invert.

Definition fuel_at n : Type :=
    (∀ a, size_tm a <= n ->  fuel_tpg a) *
    (∀ phi, size_constraint phi <= n -> fuel_pwf phi) *
    (∀ gamma, size_co gamma <= n -> fuel_iso gamma) *
    (∀ gamma, size_co gamma <= n -> fuel_deq gamma).

Ltac wfind :=
  match goal with
    | [ Hind: ∀ z : nat, z < ?x → fuel_at z |- fuel_tpg ?a ] => eapply (Hind (size_tm a))
    | [ Hind: ∀ z : nat, z < ?x → fuel_at z |- fuel_deq ?g ] => eapply (Hind (size_co g))
    | [ Hind: ∀ z : nat, z < ?x → fuel_at z |- fuel_iso ?g ] => eapply (Hind (size_co g))
    | [ Hind: ∀ z : nat, z < ?x → fuel_at z |- fuel_pwf ?g ] => eapply (Hind (size_constraint g))
  end.

Lemma fuel_all : ∀ n, fuel_at n.
Proof.
  intro n. eapply (well_founded_induction_type lt_wf). clear n. intros.
  repeat split.
  + intros a sz.
    destruct a; auto; unfold size_tm in sz; fold size_tm in sz; fold size_co in sz; fold size_constraint in sz.

    all: try econstructor; intros.
    all: try wfind.
    all: try rewrite size_tm_open_tm_wrt_tm_var; try rewrite size_tm_open_tm_wrt_co_var.
    all: try lia.

  + intros phi sz.
    destruct phi; auto; unfold size_constraint in sz; fold size_tm in sz; fold size_co in sz; fold size_constraint in sz.
    econstructor; intros.
    all: wfind.
    all: try lia.

  + intros g sz.
    destruct g; auto; unfold size_co in sz; unfold size_tm in sz; fold size_tm in sz; fold size_co in sz; fold size_constraint in sz.
(*
    Focus 5.
    apply FD_Left.
*)

    all: try econstructor; intros.
    all: try wfind.
    all: try rewrite size_tm_open_tm_wrt_tm_var; try rewrite size_tm_open_tm_wrt_co_var.
    all: try lia.

  + intros g sz.
    destruct g; auto; unfold size_co in sz; unfold size_tm in sz; fold size_tm in sz; fold size_co in sz; fold size_constraint in sz.
    all: econstructor; intros.
    all: try wfind.
    all: try
      solve [ lia
            | rewrite size_co_open_co_wrt_co_var; lia
            | rewrite size_tm_open_tm_wrt_co_var; lia
            | rewrite size_co_open_co_wrt_tm_var; lia
            | rewrite size_tm_open_tm_wrt_tm_var; lia].
Qed.

Definition gaspump : ∀ t : tm, fuel_tpg t.
Proof.
  move => t.
  move: (fuel_all (size_tm t)) => f.
  do 3 move: f => [f _].
  apply f.
  done.
Qed.

(* TODO: as added bonus, make the function that generates context fuel and write the general function (the one accepting an arbitrary context) *)
Definition FC_typechecker : ∀ t : tm, {T : tm | AnnTyping nil t T } + {(forall T, ¬ AnnTyping nil t T)} :=
  fun t => AnnTyping_dec nil t (gaspump t) An_Empty.

Theorem FC_typechecking_decidable : ∀ t : tm, (exists T : tm, AnnTyping nil t T) \/ (∀ T, ¬ AnnTyping nil t T).
Proof.
  intros t.
  case: (FC_typechecker t).
  - intros [T p]. left. exists T. exact p.
  - intros n. right. intros T. apply n.
Qed.

End fc_dec.


(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

(** * Term algebra defined as functor from a Module Signature and a Module Variable.*)

Require Import Recdef.
Require Import List.
Require Import closure.
Require Import more_list.
Require Import list_permut.
Require Import list_set.
Require Import Arith.
Require Import decidable_set.
Require Import Setoid.

Set Implicit Arguments.

(** The arity of a symbol contains the information about built-in theories as in CiME *)
Inductive arity_type : Set :=
  | AC : arity_type
  | C : arity_type
  | Free : nat -> arity_type.

(** * Module Type Signature.
 There are almost no assumptions, except a decidable equality
and an arity function. *)

Module Type Signature.
Declare Module Export Symb : decidable_set.S.
Parameter arity : Symb.A -> arity_type.
End Signature.

(** * Module Type Term built from a signature and a set of variables. *)
Module Type Term.

Declare Module Import F : Signature.
Declare Module Import X : decidable_set.S.

Notation symbol := Symb.A.
Notation eq_symb_bool := Symb.eq_bool.
Notation eq_symb_bool_ok := Symb.eq_bool_ok.
Parameter eq_symb_bool_refl : forall x, eq_symb_bool x x = true.

Notation variable := X.A.
Notation eq_var_bool := X.eq_bool.
Notation eq_var_bool_ok := X.eq_bool_ok.
Parameter eq_var_bool_refl : forall x, eq_var_bool x x = true.

Declare Module VSet :
   list_set.S with Definition EDS.A := X.A
                 with Definition EDS.eq_A := @eq X.A.

(* Declare Module VSet : list_set.S with Definition DS.A := variable. *)

Ltac destruct_arity f n Af :=
generalize (refl_equal (arity f)); pattern f at 1; destruct (arity f) as [ |  | n]; intro Af.

(** Definition of terms.
Arity is not taken into account, and terms may be ill-formed. *)
Inductive term : Set :=
  | Var : variable -> term
  | Term : symbol -> list term -> term.

(** Definition and a few properties of the size of a term.*)
Fixpoint size (t:term) : nat :=
  match t with
  | Var v => 1
  | Term _ l =>
       let size_list :=
         (fix size_list (l : list term) {struct l} : nat :=
            match l with
            | nil => 0
            | t :: lt => size t + size_list lt
            end) in
        1 + size_list l
   end.

Parameter size_unfold :
 forall t, size t = match t with
                             | Var _ => 1
                             | Term f l => 1 + list_size size l
                           end.

Parameter size_ge_one : forall t, 1 <= size t.

Function var_in_term_list (x : variable) (l : list term)
{ measure (list_size size) l } : bool :=
  match l with
    | nil => false
    | (Var y) :: l => orb (eq_var_bool x y) (var_in_term_list x l)
    | (Term _ ll) :: l => orb (var_in_term_list x ll) (var_in_term_list x l)
end.
Proof.
intros _ l t l' y H1 H2;  simpl; auto with arith.
intros _ l t l' f ll H1 H2; simpl; auto with arith.
intros _ l t l' f ll H1 H2; simpl; apply Nat.lt_le_trans with (size (Term f ll)).
rewrite size_unfold; simpl; auto with arith.
simpl; auto with arith.
Defined.

Definition var_in_term (v : variable) (t : term) : bool :=
	match t with
	| Var x =>  eq_var_bool x v
        | Term _ l => var_in_term_list v l
        end.

Fixpoint var_list (t : term) : list variable :=
  match t with
  | Var x => (x :: nil)
  | Term _ l =>
       let var_list_list :=
         (fix var_list_list (l : list term) {struct l} : list variable :=
            match l with
            | nil => @nil _
            | t :: lt => var_list t ++ var_list_list lt
            end) in
        var_list_list l
   end.

Fixpoint var_list_list (l : list term) {struct l} : list variable :=
            match l with
            | nil => nil
            | t :: lt => var_list t ++ var_list_list lt
            end.

Parameter var_list_list_app : forall l1 l2, var_list_list (l1 ++ l2) = (var_list_list l1) ++ var_list_list l2.

Parameter in_var_list_list : forall l v, In v (var_list_list l) -> exists t, In t l /\ In v (var_list t).

Parameter mem_var_list_list : forall l v, mem (@eq _) v (var_list_list l) -> exists t, In t l /\ mem (@eq _) v (var_list t).

Parameter var_list_unfold :
 forall t,
 var_list t = match t with
          | Var x => (x :: nil)
          | Term _ l => var_list_list l
          end.

Parameter var_in_term_is_sound : forall x t, var_in_term x t = true <-> In x (var_list t).

Definition direct_subterm t1 t2 : Prop :=
  match t2 with
  | Var _ => False
  | Term _ l => In t1 l
  end.

Parameter size_direct_subterm :
 forall t1 t2, direct_subterm t1 t2 -> size t1 < size t2.

Fixpoint symb_in_term (f : symbol) (t:term) : bool :=
  match t with
  | Var _ => false
  | Term g l =>
       let symb_in_term_list :=
         (fix symb_in_term_list f (l : list term) {struct l} : bool :=
            match l with
            | nil => false
            | t :: lt => orb (symb_in_term f t) (symb_in_term_list f lt)
            end) in
                 orb (eq_symb_bool f g) (symb_in_term_list f l)
   end.

Fixpoint symb_in_term_list f (l : list term) {struct l} : bool :=
            match l with
            | nil => false
            | t :: lt => orb (symb_in_term f t) (symb_in_term_list f lt)
            end.

Fixpoint symb_list (t : term) : list symbol :=
  match t with
  | Var x => nil
  | Term f l =>
       let symb_list_list :=
         (fix symb_list_list (l : list term) {struct l} : list symbol :=
            match l with
            | nil => nil
            | t :: lt => symb_list t ++ symb_list_list lt
            end) in
        f :: (symb_list_list l)
   end.

Function symb_list_list (l : list term) {struct l} : list symbol :=
            match l with
            | nil => nil
            | t :: lt => symb_list t ++ symb_list_list lt
            end.

Parameter symb_list_list_app : forall l1 l2, symb_list_list (l1 ++ l2) = (symb_list_list l1) ++ symb_list_list l2.

Parameter in_symb_list_list : forall l f, In f (symb_list_list l) -> exists t, In t l /\ In f (symb_list t).

Parameter symb_in_term_unfold :
 forall f t,  symb_in_term f t = match t with
                             | Var _ => false
                             | Term g l =>  orb (eq_symb_bool f g) (symb_in_term_list f l)
                           end.

Parameter symb_in_term_list_app :
  forall f l1 l2, symb_in_term_list f (l1 ++ l2) =
                     orb (symb_in_term_list f l1) (symb_in_term_list f l2).

Parameter symb_in_direct_subterm :
  forall f l t g, In t l -> symb_in_term g t = true ->
         symb_in_term g (Term f l) = true.

(** ** Recursion on terms. *)
Section Recursion.
Variable P : term -> Type.
Variable Pl : list term -> Type.

Parameter term_rec2 : (forall n t, size t <= n -> P t) -> forall t, P t.
Parameter term_rec3 :
  (forall v, P (Var v)) -> (forall f l, (forall t, In t l -> P t) -> P (Term f l)) -> forall t, P t.
Parameter term_rec4 :
  (forall v, P (Var v)) -> (forall f l, Pl l -> P (Term f l)) ->
  (forall l, (forall t, In t l -> P t) -> Pl l) -> forall t, P t.
End Recursion.

(** ** Double recursion on terms. *)
Section DoubleRecursion.
Variable P2 : term -> term -> Type.
Variable Pl2 : list term -> list term -> Type.

Parameter term_rec7 :
  (forall v1 t2, P2 (Var v1) t2) ->
               (forall t1 v2, P2 t1 (Var v2)) ->
               (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
               (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
               forall t1 t2, P2 t1 t2.

Parameter term_rec8 :
  (forall v1 t2, P2 (Var v1) t2) ->
               (forall t1 v2, P2 t1 (Var v2)) ->
               (forall f1 f2 l1 l2, Pl2 l1 l2 -> P2 (Term f1 l1) (Term f2 l2)) ->
               (forall l1 l2, (forall t1 t2, In t1 l1 -> In t2 l2 -> P2 t1 t2) -> Pl2 l1 l2) ->
               forall l1 l2, Pl2 l1 l2.
End DoubleRecursion.

(** ** Equality on terms is decidable. *)
Fixpoint eq_bool (t1 t2 :term) : bool :=
  match t1, t2 with
  | Var v1, Var v2 => eq_var_bool v1 v2
  | Var _, Term _ _ => false
  | Term _ _, Var _ => false
  | Term f1 l1, Term f2 l2 =>
       if eq_symb_bool f1 f2
       then
       let eq_bool_list :=
         (fix eq_bool_list (l1 l2: list term) {struct l1} : bool :=
            match l1, l2 with
            | nil, nil => true
            | nil, (_ :: _) => false
            | (_::_), nil => false
            | t1 :: k1, t2 :: k2 => andb (eq_bool t1 t2) (eq_bool_list k1 k2)
            end) in
        eq_bool_list l1 l2
        else false
   end.

Parameter eq_bool_ok : forall t1 t2, match eq_bool t1 t2 with true => t1 = t2 | false => t1<> t2 end.

Parameter term_term_dec : forall x y:term*term, {x=y}+{~x=y}.

Parameter rel_dec :
  forall (P : relation term) Plist, (forall u v, P v u <-> In (u,v) Plist) ->
  forall r l, {P r l}+{~P r l}.

Declare Module Term_eq_dec : decidable_set.S with Definition A:= term
                                                             with Definition eq_bool := eq_bool
                                                             with Definition eq_bool_ok := eq_bool_ok.

(** ** Well-formedness of terms, according to the arity. *)
Fixpoint well_formed_bool (t:term) : bool :=
  match t with
  | Var _ => true
  | Term f l =>
     let well_formed_list :=
       (fix well_formed_list (l:list term) : bool :=
       match l with
       | nil => true
       | h :: tl => andb (well_formed_bool h)  (well_formed_list tl)
       end) in
       andb (well_formed_list l)
     (match arity f with
     | Free n => Nat.eqb (length l) n
     | _ => Nat.eqb (length l) 2
     end)
  end.

Definition well_formed t := well_formed_bool t = true.

Parameter well_formed_unfold :
 forall t, well_formed t ->
 match t with
 | Var _ => True
 | Term f l =>
    (forall u, In u l -> well_formed u) /\
    (match arity f with
    | Free n => length l = n
    | _ => length l = 2
    end)
 end.

Parameter well_formed_fold :
 forall t,
 match t with
 | Var _ => True
 | Term f l =>
    (forall u, In u l -> well_formed u) /\
    (match arity f with
    | Free n => length l = n
    | _ => length l = 2
    end)
 end -> well_formed t.

(** ** Substitutions. *)
Definition substitution := list (variable * term).

Fixpoint apply_subst (sigma : substitution) (t : term) {struct t} : term :=
  match t with
  | Var v =>
    match find eq_var_bool v sigma with
    | None => t
    | Some v_sigma => v_sigma
    end
  | Term f l => Term f (map (apply_subst sigma) l)
    end.

Parameter empty_subst_is_id : forall t, apply_subst nil t = t.
Parameter empty_subst_is_id_list : forall l, map (apply_subst nil) l = l.

(** Composition of substitutions. *)
Definition map_subst (f : variable -> term -> term) sigma :=
  map (fun x =>
            match (x : variable * term) with
            | (v, v_sigma) => (v, f v v_sigma)
            end)
            sigma.

Definition subst_comp sigma1 sigma2 :=
  (map_subst (fun _ t => apply_subst sigma1 t) sigma2)
  ++
  (map_subst (fun v t =>
                        match find eq_var_bool v sigma2 with
                        | None => t
                        | Some v_sigma2 => apply_subst sigma1 v_sigma2
                        end)
                      sigma1).

Parameter subst_comp_is_subst_comp_aux1 :
  forall v sigma f,
  find eq_var_bool v (map_subst f sigma) =
   match find eq_var_bool v sigma with
   | None => None
   | Some t => Some (f v t)
  end.

Parameter subst_comp_is_subst_comp :
  forall sigma1 sigma2 t,
   apply_subst (subst_comp sigma1 sigma2) t =
   apply_subst sigma1 (apply_subst sigma2 t).

Parameter instantiated_subterm :
  forall u u' sigma, trans_clos direct_subterm u u' ->
                             trans_clos direct_subterm (apply_subst sigma u) (apply_subst sigma u').

(** Well-formed substitutions. *)
Definition well_formed_subst sigma :=
  forall v, match find eq_var_bool v sigma with
            | None => True
            | Some t => well_formed t
            end.

Parameter well_formed_apply_subst :
  forall sigma, well_formed_subst sigma ->
  forall t, well_formed t -> well_formed (apply_subst sigma t).

Parameter well_formed_apply_subst_strong :
  forall sigma t, (forall x, var_in_term x t = true -> well_formed (apply_subst sigma (Var x))) ->
  well_formed t -> well_formed (apply_subst sigma t).

Parameter well_formed_remove_subst :
  forall sigma t, well_formed (apply_subst sigma t) -> well_formed t.

Parameter well_formed_remove_term :
  forall sigma t, well_formed (apply_subst sigma t) ->
  forall x, var_in_term x t = true -> well_formed (apply_subst sigma (Var x)).

(** ** Positions in a term.*)
Fixpoint is_a_pos (t : term) (p : list nat) {struct p}: bool :=
  match p with
  | nil => true
  | i :: q =>
    match t with
    | Var _ => false
    | Term _ l =>
         match nth_error l i with
          | Some ti => is_a_pos ti q
          | None => false
          end
     end
  end.

Fixpoint subterm_at_pos (t : term) (p : list nat) {struct p}: option term :=
  match p with
  | nil => Some t
  | i :: q =>
    match t with
    | Var _ => None
    | Term _ l =>
         match nth_error l i with
          | Some ti => subterm_at_pos ti q
          | None => None
          end
    end
  end.

Fixpoint is_subterm (s t : term) : bool  :=
 match t with
 | Var x => match s with Var y => eq_var_bool x y | _ => false end
 | Term f l =>
      let fix is_subterm_list (l : list term) : bool :=
         match l with
         | nil => false
         | t :: l => orb (is_subterm s t) (is_subterm_list l)
         end in
         orb (eq_bool t s) (is_subterm_list l)
 end.

Parameter is_subterm_ok_true :
  forall s t, is_subterm s t = true -> {p : list nat | subterm_at_pos t p = Some s}.

Parameter is_subterm_ok_false :
  forall s t, is_subterm s t = false -> forall p, subterm_at_pos t p <> Some s.

Parameter subterm_at_pos_dec :
  forall t s, {p : list nat | subterm_at_pos t p = Some s}+{forall p, subterm_at_pos t p <> Some s}.

Parameter subterm_at_pos_dec_alt :
  forall t s, {p : list nat | subterm_at_pos t p = Some s}+ {~exists p, subterm_at_pos t p = Some s}.

Parameter subterm_subterm :
	forall t p s, subterm_at_pos t p = Some s -> (t=s) \/ (trans_clos direct_subterm s t).

Parameter size_subterm_at_pos :
  forall t i p, match subterm_at_pos t (i :: p) with
	           | Some u => size u < size t
	           | None => True
	           end.

Parameter size_strict_subterm : forall s t, trans_clos direct_subterm s t -> size s < size t.

Parameter var_in_subterm :
  forall v s t p, subterm_at_pos t p = Some s -> In v (var_list s)  -> In v (var_list t).

Parameter var_in_subterm2 :
  forall v t, mem (@eq _) v (var_list t) -> {p : list nat | subterm_at_pos t p = Some (Var v)}.

Parameter symb_in_subterm :
  forall f s t p, subterm_at_pos t p = Some s -> symb_in_term f s = true -> symb_in_term f t = true.

Parameter symb_list_ok : forall f t, In f (symb_list t) <-> symb_in_term f t = true.

Parameter symb_list_list_ok : forall f l, In f (symb_list_list l) <-> symb_in_term_list f l = true.

Parameter is_a_pos_exists_subterm :
  forall t p, is_a_pos t p = true <-> exists u, subterm_at_pos t p = Some u.

Parameter well_formed_subterm :
  forall t p s, well_formed t -> subterm_at_pos t p = Some s -> well_formed s.

Fixpoint replace_at_pos (t u : term) (p : list nat) {struct p} : term :=
  match p with
  | nil => u
  | i :: q =>
     match t with
     | Var _ => t
     | Term f l =>
        let replace_at_pos_list :=
         (fix replace_at_pos_list j (l : list term) {struct l}: list term :=
            match l with
            | nil => nil
            | h :: tl =>
                 match j with
                 | O => (replace_at_pos h u q) :: tl
                 | S k => h :: (replace_at_pos_list k tl)
                 end
            end) in
    Term f (replace_at_pos_list i l)
    end
  end.

Fixpoint replace_at_pos_list (l : list term) (u : term) (i : nat) (p : list nat)
 {struct l}: list term :=
  match l with
  | nil => nil
  | h :: tl =>
     match i with
     | O => (replace_at_pos h u p) :: tl
     | S j => h :: (replace_at_pos_list tl  u j p)
     end
  end.

Parameter replace_at_pos_unfold :
  forall f l u i q,
   replace_at_pos (Term f l) u (i :: q) = Term f (replace_at_pos_list l u i q).

Parameter replace_at_pos_is_replace_at_pos1 :
  forall t u p, is_a_pos t p = true ->
  subterm_at_pos (replace_at_pos t u p) p = Some u.

Parameter replace_at_pos_is_replace_at_pos2 :
  forall t p u, subterm_at_pos t p = Some u -> replace_at_pos t u p = t.

Parameter subterm_at_pos_apply_subst_apply_subst_subterm_at_pos :
  forall t p sigma,
  match subterm_at_pos t p with
  | Some u =>
        subterm_at_pos (apply_subst sigma t) p = Some (apply_subst sigma u)
  | None => True
end.

Parameter replace_at_pos_list_replace_at_pos_in_subterm :
forall l1 ui l2 u i p, length l1 = i ->
 replace_at_pos_list (l1 ++ ui :: l2) u i p =
 l1 ++ (replace_at_pos ui u p) :: l2.

Parameter well_formed_replace_at_pos :
   forall p t u, well_formed t -> well_formed u -> well_formed (replace_at_pos t u p).

Parameter subst_replace_at_pos :
	forall t u p sigma, is_a_pos t p = true -> apply_subst sigma (replace_at_pos t u p) =
	replace_at_pos (apply_subst sigma t) (apply_subst sigma u) p.

Parameter subterm_in_instantiated_term :
  forall p s t sigma, subterm_at_pos (apply_subst sigma t) p = Some s ->
                    match subterm_at_pos t p with
		    | Some u' => s = apply_subst sigma u'
	            | None => exists v, exists q, exists q', p = q ++ q' /\
                                          In v (var_list t)  /\
                                         subterm_at_pos t q = Some (Var v) /\
	                                 subterm_at_pos (apply_subst sigma (Var v)) q' = Some s
	            end.

Parameter subterm_in_subterm :
  forall p q s t u, subterm_at_pos t p = Some s -> subterm_at_pos s q = Some u ->
                          subterm_at_pos t (p ++ q) = Some u.

Parameter subterm_in_subterm2 :
  forall p q s t, subterm_at_pos t (p ++ q) = Some s ->
                      exists u, subterm_at_pos t p = Some u /\ subterm_at_pos u q = Some s.

Parameter subterm_subterm_alt :
	forall t s, (refl_trans_clos direct_subterm s t) -> {p : list nat | subterm_at_pos t p = Some s}.

Parameter var_in_replace_at_pos :
  forall s p u x, In x (var_list (replace_at_pos s u p)) -> In x (var_list s) \/ In x (var_list u).

Parameter remove_garbage_subst :
  forall sigma : substitution ,
     {sigma' : substitution | (forall x, find eq_var_bool x sigma = find eq_var_bool x sigma') /\
	                                 (forall x val, In (x,val) sigma' -> find eq_var_bool x sigma' = Some val) /\
                                         (forall x y val val' (tau tau' tau'' : substitution),
                                                 sigma' = tau ++ (x,val) :: tau' ++ (y,val') :: tau'' ->
                                                 x <> y)}.

Parameter subst_eq_vars :
  forall t sigma sigma', (forall v, In v (var_list t) -> apply_subst sigma (Var v) = apply_subst sigma' (Var v))
                                    <-> apply_subst sigma t = apply_subst sigma' t.

Fixpoint subst_rest vars sigma : substitution :=
match sigma with
| nil => nil
| (x,u) :: sigma =>
          if mem_bool eq_var_bool x vars
          then (x,u) :: (subst_rest vars sigma)
          else subst_rest vars sigma
end.

Parameter subst_rest_ok :
  forall vars sigma v, In v vars -> apply_subst (subst_rest vars sigma) (Var v) = apply_subst sigma (Var v).

Parameter subst_rest_rest :
  forall vars sigma v t, In (v,t) (subst_rest vars sigma) -> In v vars.

Parameter subst_rest_subst :
  forall vars sigma v t, In (v,t) (subst_rest vars sigma) -> In (v,t) sigma.

Parameter subst_rest_subst_rest :
  forall vars sigma v t, In v vars -> In (v,t) sigma -> In (v,t) (subst_rest vars sigma).

Definition extend_with_id vars sigma :=
  (map (fun x => (x,Var x))
                                 (filter (fun x =>
                                 negb (mem_bool X.eq_bool x (map (@fst _ _) sigma))) vars))
  ++ sigma.

Parameter subst_trivial_ext :
forall vars sigma t, apply_subst (extend_with_id vars sigma) t = apply_subst sigma t.

(** *** Definition of matching. *)
Parameter matching : list (term * term) -> option substitution.

Parameter matching_unfold2 : forall pb,
  matching pb =
  match pb with
   | nil => Some nil
   | (patt, subj) :: pb =>
        match patt with
        | Var x =>
               match matching pb with
               | Some subst => merge eq_var_bool eq_bool ((x,subj) :: nil) subst
               | None => None
               end
         | Term f l =>
             match subj with
               | Var _ => None
               | Term g m =>
                   if eq_symb_bool f g
                  then
                      match l with
                      | nil =>
                          match m with
                          | nil => matching pb
                          | sub1 :: lsub => None
                          end
                      | pat1 :: lpat =>
                           match m with
                           | nil => None
                           | sub1 :: lsub =>
                             match (matching ((pat1, sub1) :: nil)) with
                              | Some subst1 =>
                                  match  (matching ((Term f lpat, Term g lsub) :: pb)) with
                                  | Some subst => merge eq_var_bool eq_bool subst1 subst
                                  | None => None
                                  end
                              | None => None
                              end
                           end
                      end
                  else None
               end
         end
    end.

Parameter matching_correct :
  forall pb sigma, matching pb = Some sigma ->
            ((forall v p s, In v (var_list p) -> In (p,s) pb -> find eq_var_bool v sigma <> None) /\
           (forall v, find eq_var_bool v sigma <> None ->
                                 exists p, exists s, In (p,s) pb /\ In v (var_list p)) /\
            (forall p s, In (p,s) pb -> apply_subst sigma p = s)).

Parameter matching_complete :
  forall pb sigma, (forall p s, In (p,s) pb -> apply_subst sigma p = s) ->
  match matching pb with
  | Some tau => forall v p s, In v (var_list p) -> In (p,s) pb ->
                                    apply_subst tau (Var v) = apply_subst sigma (Var v)
  | None => False
  end.

End Term.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop -emacs -I . -I ../basis -I ../term_orderings -I ../list_extensions -I ../term_algebra" ***
*** coq-prog-args: nil ***
*** End: ***
 *)


Require Import VST.progs.io.
Require Import VST.progs.io_specs.
Require Import VST.floyd.proofauto.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition putchar_spec := DECLARE _putchar putchar_spec.
Definition getchar_spec := DECLARE _getchar getchar_spec.

Definition getchar_blocking_spec :=
 DECLARE _getchar_blocking
  WITH k : byte -> IO_itree
  PRE [ ]
    PROP ()
    PARAMS ()
    GLOBALS ()
    SEP (ITREE (r <- read stdin;; k r))
  POST [ tint ]
   EX i : byte,
    PROP ()
    LOCAL (temp ret_temp (Vubyte i))
    SEP (ITREE (k i)).

Definition putchar_blocking_spec :=
 DECLARE _putchar_blocking
  WITH c : byte, k : IO_itree
  PRE [ tint ]
    PROP ()
    PARAMS (Vubyte c)
    GLOBALS ()
    SEP (ITREE (r <- write stdout c ;; k))
  POST [ tint ]
    PROP ()
    LOCAL (temp ret_temp (Vubyte c))
    SEP (ITREE k).

Lemma div_10_dec : forall n, 0 < n ->
  (Z.to_nat (n / 10) < Z.to_nat n)%nat.
Proof.
  intros.
  change 10 with (Z.of_nat 10).
  rewrite <- (Z2Nat.id n) by lia.
  rewrite <- div_Zdiv by discriminate.
  rewrite !Nat2Z.id.
  apply Nat2Z.inj_lt.
  rewrite div_Zdiv, Z2Nat.id by lia; simpl.
  apply Z.div_lt; auto; lia.
Qed.

Program Fixpoint chars_of_Z (n : Z) { measure (Z.to_nat n) } : list byte :=
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Next Obligation.
Proof.
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous.
  eapply Z.lt_le_trans, Z_mult_div_ge with (b := 10); lia.
Defined.

(* The function computed by print_intr *)
Program Fixpoint intr n { measure (Z.to_nat n) } : list byte :=
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Next Obligation.
Proof.
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous; lia.
Defined.

Definition print_intr_spec :=
 DECLARE _print_intr
  WITH i : Z, tr : IO_itree
  PRE [ tuint ]
    PROP (0 <= i <= Int.max_unsigned)
    PARAMS (Vint (Int.repr i))
    GLOBALS ()
    SEP (ITREE (write_list stdout (intr i) ;; tr))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (ITREE tr).

Definition print_int_spec :=
 DECLARE _print_int
  WITH i : Z, tr : IO_itree
  PRE [ tuint ]
    PROP (0 <= i <= Int.max_unsigned)
    PARAMS (Vint (Int.repr i))
    GLOBALS ()
    SEP (ITREE (write_list stdout (chars_of_Z i) ;; tr))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (ITREE tr).

Definition read_sum n d : IO_itree :=
   ITree.iter (fun '(n, d) =>
       if zlt n 1000 then if zlt d 10 then
         write_list stdout (chars_of_Z (n + d));; write stdout (Byte.repr newline);;
              c <- read stdin;;
              Ret (inl (n + d, Byte.unsigned c - char0)) (* loop again with these parameters *)
       else Ret (inr tt) else Ret (inr tt)) (* inr to end the loop *)
     (n, d).

Definition main_itree := c <- read stdin;; read_sum 0 (Byte.unsigned c - char0).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog main_itree gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs := ltac:(with_library prog [putchar_spec; getchar_spec;
  print_intr_spec; print_int_spec; getchar_blocking_spec; putchar_blocking_spec; main_spec]).

Lemma divu_repr : forall x y,
  0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned ->
  Int.divu (Int.repr x) (Int.repr y) = Int.repr (x / y).
Proof.
  intros; unfold Int.divu.
  rewrite !Int.unsigned_repr; auto.
Qed.

Opaque Nat.div Nat.modulo.

Lemma intr_eq : forall n, intr n =
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Proof.
  intros.
  unfold intr at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold intr.
  destruct n; reflexivity.
Qed.

Lemma body_getchar_blocking: semax_body Vprog Gprog f_getchar_blocking getchar_blocking_spec.
Proof.
  start_function.
  forward.
  forward_while (EX i : int, PROP (-1 <= Int.signed i <= two_p 8 - 1) LOCAL (temp _r (Vint i))
    SEP (ITREE (if eq_dec (Int.signed i) (-1) then (r <- read stdin;; k r) else k (Byte.repr (Int.signed i))))).
  - Exists (Int.neg (Int.repr 1)); entailer!.
    { simpl; lia. }
    rewrite if_true; auto.
  - entailer!.
  - subst; rewrite Int.signed_repr by rep_lia.
    rewrite if_true by auto.
    forward_call k.
    Intros i.
    forward.
    Exists i; entailer!.
  - assert (Int.signed i <> -1).
    { intro X.
      apply f_equal with (f := Int.repr) in X.
      rewrite Int.repr_signed in X; auto. }
    rewrite if_false by auto.
    forward.
    Exists (Byte.repr (Int.signed i)); entailer!.
    unfold Vubyte; rewrite Byte.unsigned_repr, Int.repr_signed; auto.
    split; try lia.
    etransitivity; [apply H|].
    simpl; rep_lia.
Qed.

Lemma body_putchar_blocking: semax_body Vprog Gprog f_putchar_blocking putchar_blocking_spec.
Proof.
  start_function.
  forward.
  forward_while (EX i : int, PROP (Int.signed i = -1 \/ Int.signed i = Byte.unsigned c) LOCAL (temp _r (Vint i); temp _c (Vubyte c))
    SEP (ITREE (if eq_dec (Int.signed i) (-1) then (r <- write stdout c;; k) else k))).
  - Exists (Int.neg (Int.repr 1)); entailer!.
    rewrite if_true; auto.
  - entailer!.
  - subst; rewrite Int.signed_repr by rep_lia.
    rewrite if_true by auto.
    forward_call (c, k).
    Intros i.
    forward.
    Exists i; entailer!.
  - assert (Int.signed i <> -1).
    { intro X.
      apply f_equal with (f := Int.repr) in X.
      rewrite Int.repr_signed in X; auto. }
    rewrite if_false by auto.
    destruct H; [contradiction | subst].
    forward.
    entailer!.
    unfold Vubyte.
    rewrite <- H, Int.repr_signed; auto.
Qed.

Lemma body_print_intr: semax_body Vprog Gprog f_print_intr print_intr_spec.
Proof.
  start_function.
  forward_if (PROP () LOCAL () SEP (ITREE tr)).
  - forward.
    forward.
    rewrite modu_repr, divu_repr by (lia || computable).
    rewrite intr_eq.
    destruct (Z.leb_spec i 0); try lia.
    rewrite write_list_app, bind_bind.
    forward_call (i / 10, write_list stdout [Byte.repr (i mod 10 + char0)];; tr).
    { split; [apply Z.div_pos; lia | apply Z.div_le_upper_bound; lia]. }
    simpl write_list.
    forward_call (Byte.repr (i mod 10 + char0), tr).
    { entailer!.
      unfold Vubyte; rewrite Byte.unsigned_repr; auto.
      pose proof (Z_mod_lt i 10); unfold char0; rep_lia. }
    { rewrite <- sepcon_emp at 1; apply sepcon_derives; [|cancel].
      rewrite bind_ret'; auto. }
    entailer!.
  - forward.
    subst; entailer!.
    simpl.
    rewrite bind_ret_l; auto.
Qed.

Lemma chars_of_Z_eq : forall n, chars_of_Z n =
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Proof.
  intros.
  unfold chars_of_Z at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold chars_of_Z.
  destruct (_ <=? _); reflexivity.
Qed.

Lemma chars_of_Z_intr : forall n, 0 < n ->
  chars_of_Z n = intr n.
Proof.
  induction n using (well_founded_induction (Zwf.Zwf_well_founded 0)); intro.
  rewrite chars_of_Z_eq, intr_eq.
  destruct (n <=? 0) eqn: Hn; [apply Zle_bool_imp_le in Hn; lia|].
  simpl.
  destruct (n / 10 <=? 0) eqn: Hdiv.
  - apply Zle_bool_imp_le in Hdiv.
    assert (0 <= n / 10).
    { apply Z.div_pos; lia. }
    assert (n / 10 = 0) as Hz by lia.
    rewrite Hz; simpl.
    apply Z.div_small_iff in Hz as [|]; try lia.
    rewrite Zmod_small; auto.
  - apply Z.leb_nle in Hdiv.
    rewrite H; auto; try lia.
    split; try lia.
    apply Z.div_lt; auto; lia.
Qed.

Lemma body_print_int: semax_body Vprog Gprog f_print_int print_int_spec.
Proof.
  start_function.
  forward_if (PROP () LOCAL () SEP (ITREE tr)).
  - subst.
    forward_call (Byte.repr char0, tr).
    { rewrite chars_of_Z_eq; simpl.
      erewrite <- sepcon_emp at 1; apply sepcon_derives; [|cancel].
      rewrite bind_ret'; apply derives_refl. }
    entailer!.
  - forward_call (i, tr).
    { rewrite chars_of_Z_intr by lia; cancel. }
    entailer!.
Qed.

Lemma read_sum_eq : forall n d, read_sum n d ≈
  (if zlt n 1000 then if zlt d 10 then
     write_list stdout (chars_of_Z (n + d));; write stdout (Byte.repr newline);;
     c <- read stdin;; read_sum (n + d) (Byte.unsigned c - char0)
   else Ret tt else Ret tt).
Proof.
  intros.
  unfold read_sum; rewrite unfold_iter.
  unfold ITree.iter.
  if_tac; [|rewrite bind_ret_l; reflexivity].
  if_tac; [|rewrite bind_ret_l; reflexivity].
  repeat setoid_rewrite bind_bind.
  setoid_rewrite bind_ret_l.
  setoid_rewrite tau_eutt.
  reflexivity.
Qed.

Lemma signed_char_unsigned : forall c, Byte.unsigned c <= two_p 8 - 1.
Proof.
  intros.
  pose proof (Byte.unsigned_range c).
  unfold Byte.modulus, two_power_nat in H; simpl in *; lia.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  unfold main_pre.
  sep_apply (has_ext_ITREE(E := @IO_event nat)).
  forward.
  unfold main_itree.
  rewrite <- !seq_assoc. (* Without this, forward_call gives a type error! *)
  forward_call (fun c => read_sum 0 (Byte.unsigned c - char0)).
  Intros c.
  forward.
  rewrite zero_ext_inrange by (pose proof (signed_char_unsigned c); rewrite Int.unsigned_repr; rep_lia).
  set (Inv := EX n : Z, EX c : byte,
    PROP (0 <= n < 1009)
    LOCAL (temp _c (Vubyte c); temp _n (Vint (Int.repr n)))
    SEP (ITREE (read_sum n (Byte.unsigned c - char0)))).
  unfold Swhile; forward_loop Inv break: Inv.
  { Exists 0 c; entailer!. }
  subst Inv.
  clear dependent c; Intros n c.
  forward_if.
  forward.
  forward_if.
  { forward.
    Exists n c; entailer!. }
  forward.
  destruct (zlt (Byte.unsigned c) char0).
  { rewrite Int.unsigned_repr_eq in H1.
    rewrite <- Z_mod_plus_full with (b := 1), Zmod_small in H1; unfold char0 in *; rep_lia. }
  rewrite Int.unsigned_repr in H1 by (unfold char0 in *; rep_lia).
  rewrite read_sum_eq.
  rewrite if_true by auto.
  destruct (zlt _ _); [|unfold char0 in *; lia].
  forward_call (n + (Byte.unsigned c - char0),
    write stdout (Byte.repr newline);; c' <- read stdin;; read_sum (n + (Byte.unsigned c - char0)) (Byte.unsigned c' - char0)).
  forward_call (Byte.repr newline, c' <- read stdin;; read_sum (n + (Byte.unsigned c - char0)) (Byte.unsigned c' - char0)).
  forward_call (fun c' => read_sum (n + (Byte.unsigned c - char0)) (Byte.unsigned c' - char0)).
  Intros c'.
  forward.
  rewrite zero_ext_inrange by (pose proof (signed_char_unsigned c'); rewrite Int.unsigned_repr; rep_lia).
  Exists (n + (Byte.unsigned c - char0)) c'; entailer!.
  { forward.
    Exists n c; entailer!. }
  subst Inv.
  Intros n c'.
  forward.
Qed.

Definition ext_link := ext_link_prog prog.

Instance Espec : OracleKind := IO_Espec ext_link.

Lemma prog_correct:
  semax_prog prog main_itree Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons_ext.
{ simpl; Intro i.
  apply typecheck_return_value with (t := Tint16signed); auto. }
semax_func_cons_ext.
{ simpl; Intro i'.
  apply typecheck_return_value with (t := Tint16signed); auto. }
semax_func_cons body_getchar_blocking.
semax_func_cons body_putchar_blocking.
semax_func_cons body_print_intr.
semax_func_cons body_print_int.
semax_func_cons body_main.
Qed.

Require Import VST.veric.SequentialClight.
Require Import VST.progs.io_dry.

Lemma init_mem_exists : { m | Genv.init_mem prog = Some m }.
Proof.
  unfold Genv.init_mem; simpl.
Ltac alloc_block m n := match n with
  | O => idtac
  | S ?n' => let m' := fresh "m" in let Hm' := fresh "Hm" in
    destruct (dry_mem_lemmas.drop_alloc m) as [m' Hm']; alloc_block m' n'
  end.
  alloc_block Mem.empty 59%nat.
  eexists; repeat match goal with H : ?a = _ |- match ?a with Some m' => _ | None => None end = _ => rewrite H end.
  reflexivity.
Qed.

Definition init_mem := proj1_sig init_mem_exists.

Definition main_block_exists : {b | Genv.find_symbol (Genv.globalenv prog) (AST.prog_main prog) = Some b}.
Proof.
  eexists; simpl.
  unfold Genv.find_symbol; simpl; reflexivity.
Qed.

Definition main_block := proj1_sig main_block_exists.

Theorem prog_ext_correct : exists q,
  semantics.initial_core (Clight_core.cl_core_sem (globalenv prog)) 0 init_mem q init_mem (Vptr main_block Ptrofs.zero) [] /\
  forall n, @step_lemmas.dry_safeN _ _ _ _ semax.genv_symb_injective (Clight_core.cl_core_sem (globalenv prog))
             (io_dry_spec ext_link) {| genv_genv := Genv.globalenv prog; genv_cenv := prog_comp_env prog |} n
            main_itree q init_mem.
Proof.
  edestruct whole_program_sequential_safety_ext with (V := Vprog) as (b & q & Hb & Hq & Hsafe).
  - repeat intro; hnf.
    apply I.
  - apply juicy_dry_specs.
  - apply dry_spec_mem.
  - apply CSHL_Sound.semax_prog_sound, prog_correct.
  - apply (proj2_sig init_mem_exists).
  - exists q.
    rewrite (proj2_sig main_block_exists) in Hb; inv Hb.
    split; auto.
Qed.

Require Import VST.progs.os_combine.
Require Import VST.progs.io_combine.
Require Import VST.progs.io_os_specs.
Require Import VST.progs.io_os_connection.

(* correctness down to OS traces, with relationship between syscall events and actual external reads/writes *)
Theorem prog_OS_correct : forall {H : io_os_specs.ThreadsConfigurationOps},
  exists q,
  semantics.initial_core (Clight_core.cl_core_sem (globalenv prog)) 0 init_mem q init_mem (Vptr main_block Ptrofs.zero) [] /\
     forall n s0, s0.(io_log) = [] -> s0.(console) = {| cons_buf := []; rpos := 0 |} ->
    exists traces, OS_safeN_trace prog n Traces.TEnd traces main_itree s0 q init_mem /\
     forall t s, Ensembles.In _ traces (t, s) -> exists z', consume_trace main_itree z' t /\ t = trace_of_ostrace s.(io_log) /\
      valid_trace_user s.(io_log).
Proof.
  intros.
  edestruct IO_OS_ext with (V := Vprog) as (b & q & Hb & Hq & Hsafe).
  - apply prog_correct.
  - apply (proj2_sig init_mem_exists).
  - exists q.
    rewrite (proj2_sig main_block_exists) in Hb; inv Hb.
    auto.
Qed.


Require Export D.

Fixpoint remove_all (v:nat) (s:natlist) : natlist :=
  FILL_IN_HERE.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Require Import riscv.Utility.Monads.

Module free.
  Section WithInterface.
    Context {action : Type} {result : action -> Type}.
    Inductive free {T : Type} : Type :=
    | act (a : action) (_ : result a -> free)
    | ret (x : T).
    Arguments free : clear implicits.

    Fixpoint bind {A B} (mx : free A) (fy : A -> free B) : free B :=
      match mx with
      | act a k => act a (fun x => bind (k x) fy)
      | ret x => fy x
      end.

    (** Monad laws *)
    Definition bind_ret_l {A B} a b : @bind A B (ret a) b = b a := eq_refl.
    Lemma bind_assoc {A B C} (a : free A) (b : A -> free B) (c : B -> free C) :
      bind (bind a b) c = bind a (fun x => bind (b x) c).
    Proof. revert c; revert C; revert b; revert B; induction a;
        cbn [bind]; eauto using f_equal, functional_extensionality. Qed.
    Lemma bind_ret_r {A} (a : free A) : bind a ret = a.
    Proof. induction a;
        cbn [bind]; eauto using f_equal, functional_extensionality. Qed.
    Global Instance Monad_free : Monad free.
    Proof. esplit; eauto using bind_ret_l, bind_assoc, bind_ret_r. Defined.

    Section WithState.
      Context {state}
      (interp_action : forall a : action, state -> (result a -> state -> Prop) -> Prop).
      Section WithOutput.
        Context {output} (post : output -> state -> Prop).
        Definition interp_body interp (a : free output) (s : state) : Prop :=
          match a with
          | ret x => post x s
          | act a k => interp_action a s (fun r => interp (k r))
          end.
        Fixpoint interp_fix a := interp_body interp_fix a.
      End WithOutput.

      Definition interp {output} a s post := @interp_fix output post a s.

      Lemma interp_ret {T} (x : T) m P : interp (ret x) m P = P x m.
      Proof. exact eq_refl. Qed.
      Lemma interp_act {T} a (k : _ -> free T) s post
        : interp (act a k) s post
        = interp_action a s (fun r s => interp (k r) s post).
      Proof. exact eq_refl. Qed.

      Context (interp_action_weaken_post :
        forall a (post1 post2:_->_->Prop), (forall r s, post1 r s -> post2 r s) -> forall s, interp_action a s post1 -> interp_action a s post2).

      Lemma interp_weaken_post {T} (p : free T) s
        (post1 post2:_->_->Prop) (Hpost : forall r s, post1 r s -> post2 r s)
        (Hinterp : interp p s post1) : interp p s post2.
      Proof. revert dependent s; induction p; cbn; firstorder eauto. Qed.

      Lemma interp_bind {A B} s post (a : free A) (b : A -> free B) :
        interp (bind a b) s post <-> interp a s (fun x s => interp (b x) s post).
      Proof.
        revert post; revert b; revert B; revert s; induction a.
        2: { intros. cbn. reflexivity. }
        split; eapply interp_action_weaken_post; intros; eapply H; eauto.
      Qed.

      Lemma interp_bind_ex_mid {A B} m0 post (a : free A) (b : A -> free B) :
        interp (bind a b) m0 post <->
        (exists mid, interp a m0 mid /\ forall x m1, mid x m1 -> interp (b x) m1 post).
      Proof.
        rewrite interp_bind.
        split; [intros ? | intros (?&?&?)].
        { exists (fun x m1 => interp (b x) m1 post); split; eauto. }
        { eauto using interp_weaken_post. }
      Qed.
    End WithState.

    Section WithStateAndAbort.
      Context {state : Type}.
      Context (interpret_action : forall a : action,
                  state ->                       (* initial state *)
                  (result a -> state -> Prop) -> (* postcondition if finished *)
                  (state -> Prop) ->             (* postcondition if aborted *)
                  Prop).
      Section WithOutput.
        Context {output} (postF : output -> state -> Prop) (postA : state -> Prop).
        Definition interpret_body rec (a : free output) (s : state) : Prop :=
          match a with
          | ret x => postF x s
          | act a k => interpret_action a s (fun r => rec (k r)) postA
          end.
        Fixpoint interpret_fix a := interpret_body interpret_fix a.
      End WithOutput.

      Definition interpret {output} a s postF postA := @interpret_fix output postF postA a s.

      Lemma interpret_ret {T} (x : T) m postF postA : interpret (ret x) m postF postA = postF x m.
      Proof. exact eq_refl. Qed.
      Lemma interpret_act {T} a (k : _ -> free T) s postF postA
        : interpret (act a k) s postF postA
        = interpret_action a s (fun r s => interpret (k r) s postF postA) postA.
      Proof. exact eq_refl. Qed.

      Context (interpret_action_weaken_post :
        forall a (postF1 postF2 : _ -> _ -> Prop) (postA1 postA2 : _ -> Prop),
        (forall r s, postF1 r s -> postF2 r s) ->
        (forall s, postA1 s -> postA2 s) ->
        forall s, interpret_action a s postF1 postA1 -> interpret_action a s postF2 postA2).

      Lemma interpret_weaken_post {T} (p : free T) s
            (postF1 postF2 : _ -> _ -> Prop) (postA1 postA2 : _ -> Prop):
        (forall r s, postF1 r s -> postF2 r s) ->
        (forall s, postA1 s -> postA2 s) ->
        interpret p s postF1 postA1 -> interpret p s postF2 postA2.
      Proof.
        revert dependent s; induction p. 2: firstorder eauto.
        cbn. intros. eapply interpret_action_weaken_post.
        - intros. eapply H; try eassumption. exact H3.
        - eassumption.
        - eassumption.
      Qed.

      Lemma interpret_bind {A B} s postF postA (a : free A) (b : A -> free B) :
        interpret (bind a b) s postF postA <->
        interpret a s (fun x s => interpret (b x) s postF postA) postA.
      Proof.
        revert postF; revert postA; revert b; revert B; revert s; induction a.
        2: { intros. cbn. reflexivity. }
        split; intros; eapply interpret_action_weaken_post; intros.
        - eapply H. exact H1.
        - exact H1.
        - eauto.
        - eapply H. exact H1.
        - exact H1.
        - eauto.
      Qed.

      Lemma interpret_bind_ex_mid {A B} m0 postF postA (a : free A) (b : A -> free B) :
        interpret (bind a b) m0 postF postA <->
        (exists mid, interpret a m0 mid postA /\ forall x m1, mid x m1 -> interpret (b x) m1 postF postA).
      Proof.
        rewrite interpret_bind.
        split; [intros ? | intros (?&?&?)].
        { exists (fun x m1 => interpret (b x) m1 postF postA); split; eauto. }
        { eauto using interpret_weaken_post. }
      Qed.
    End WithStateAndAbort.
  End WithInterface.
  Global Arguments free : clear implicits.
End free. Notation free := free.free.