Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import BoolMap.
Require Import Promises.
Require Import Global.
(* Require Import MemoryFacts. *)
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import Cover.
(* Require Import MemorySplit. *)
(* Require Import MemoryMerge. *)
(* Require Import FulfillStep. *)
Require Import MemoryProps.

Require Import LowerMemory.

Set Implicit Arguments.

Variant max_readable (gl: Global.t) (prom: BoolMap.t) (loc: Loc.t) (ts: Time.t) (val: Const.t) (released: option View.t): Prop :=
  | max_readable_intro
      from na
      (GET: Memory.get loc ts gl.(Global.memory) = Some (from, Message.message val released na))
      (NONE: implb (gl.(Global.promises) loc) (prom loc))
      (MAX: forall ts' from' msg
                   (TS: Time.lt ts ts')
                   (GET: Memory.get loc ts' gl.(Global.memory) = Some (from', msg))
                   (MSG: msg <> Message.reserve),
          False)
.

Lemma max_readable_inj gl prom loc ts0 ts1 val0 val1 released0 released1
      (MAX0: max_readable gl prom loc ts0 val0 released0)
      (MAX1: max_readable gl prom loc ts1 val1 released1)
  :
    (<<TS: ts0 = ts1>>) /\ (<<VAL: val0 = val1>>) /\ (<<RELEASED: released0 = released1>>).
Proof.
  inv MAX0. inv MAX1.
  assert (ts0 = ts1).
  { apply TimeFacts.antisym.
    { destruct (Time.le_lt_dec ts0 ts1); auto.
      hexploit MAX0; eauto; ss.
    }
    { destruct (Time.le_lt_dec ts1 ts0); auto.
      hexploit MAX; eauto; ss.
    }
  }
  subst. split; auto. clarify.
Qed.

Lemma read_tview_max tvw loc released
      (WF: TView.wf tvw)
  :
    TView.read_tview tvw loc (View.pln (TView.cur tvw) loc) released Ordering.na = tvw.
Proof.
  unfold TView.read_tview. des_ifs. ss.
  rewrite ! View.le_join_l.
  { destruct tvw; auto. }
  { apply View.singleton_rw_spec.
    { apply WF. }
    { transitivity (View.rlx (TView.cur tvw) loc).
      { apply WF. }
      { apply WF. }
    }
  }
  { apply View.bot_spec. }
  { apply View.singleton_rw_spec.
    { apply WF. }
    { apply WF. }
  }
  { apply View.bot_spec. }
Qed.

Lemma max_readable_view_mon gl prom rsv tvw0 tvw1 loc ts val released
      (MAX: max_readable gl prom loc ts val released)
      (TS: tvw0.(TView.cur).(View.pln) loc = ts)
      (TVIEW: TView.le tvw0 tvw1)
      (WF: Local.wf (Local.mk tvw1 prom rsv) gl)
  :
    max_readable gl prom loc (tvw1.(TView.cur).(View.pln) loc) val released.
Proof.
  subst. replace (tvw1.(TView.cur).(View.pln) loc) with (tvw0.(TView.cur).(View.pln) loc); auto.
  apply TimeFacts.antisym.
  { apply TVIEW. }
  destruct (Time.le_lt_dec (tvw1.(TView.cur).(View.pln) loc) (tvw0.(TView.cur).(View.pln) loc)); auto.
  inv MAX. inv WF.
  inv TVIEW_CLOSED. inv CUR. specialize (PLN loc). des.
  exploit MAX0; eauto; ss.
Qed.

Lemma non_max_readable_future gl0 gl1 prom rsv tvw loc ts
      (MAX: forall val released, ~ max_readable gl0 prom loc ts val released)
      (TS: tvw.(TView.cur).(View.pln) loc = ts)
      (FUTURE: Global.strong_le gl0 gl1)
      (WF: Local.wf (Local.mk tvw prom rsv) gl0)
  :
    forall val released, ~ max_readable gl1 prom loc ts val released.
Proof.
  subst. ii. inv H.
  inv WF. inv TVIEW_CLOSED. inv CUR. specialize (PLN loc). des. ss.
  inv FUTURE. inv LE. exploit MEMORY; eauto; ss. i.
  eapply MAX; eauto. econs; eauto.
  { inv ADDNA. specialize (ADDNA0 loc). des.
    { destruct (gl0.(Global.promises) loc), (gl1.(Global.promises) loc), (prom loc); ss. }
    { exfalso. inv LATEST. des. eapply MAX0; eauto. ss. }
  }
  { i. destruct msg; ss. exploit MEMORY; eauto. }
Qed.

Lemma max_readable_read_only_aux gl prom tvw rsv loc ts val released ord
      ts' val' released' lc
      (MAX: max_readable gl prom loc ts val released)
      (TS: tvw.(TView.cur).(View.pln) loc = ts)
      (READ: Local.read_step (Local.mk tvw prom rsv) gl loc ts' val' released' ord lc)
  :
    (<<TS: ts' = ts>>) /\ (<<VAL: Const.le val' val>>) /\ (<<RELEASED: released' = released>>).
Proof.
  assert (ts' = ts).
  { dup READ. inv READ.
    apply TimeFacts.antisym.
    { destruct (Time.le_lt_dec ts' (tvw.(TView.cur).(View.pln) loc)); auto.
      inv MAX. hexploit MAX0; eauto; ss.
    }
    { inv READABLE. auto. }
  }
  subst. inv MAX. inv READ. clarify.
Qed.

Lemma max_readable_read_only gl prom tvw rsv loc ts val released
      ts' val' released' lc
      (MAX: max_readable gl prom loc ts val released)
      (TS: tvw.(TView.cur).(View.pln) loc = ts)
      (READ: Local.read_step (Local.mk tvw prom rsv) gl loc ts' val' released' Ordering.na lc)
      (WF: Local.wf (Local.mk tvw prom rsv) gl)
  :
    (<<TS: ts' = ts>>) /\ (<<VAL: Const.le val' val>>) /\ (<<RELEASED: released' = released>>) /\ (<<LOCAL: lc = Local.mk tvw prom rsv>>).
Proof.
  hexploit max_readable_read_only_aux; eauto.
  i. des. splits; auto.
  inv READ. ss. f_equal.
  unfold TView.read_tview.
  change (Ordering.le Ordering.relaxed Ordering.na) with false. ss.
  change (Ordering.le Ordering.acqrel Ordering.na) with false. ss.
  rewrite ! View.join_bot_r.
  rewrite View.le_join_l; cycle 1.
  { eapply View.singleton_rw_spec; [eapply WF|eapply WF].  }
  rewrite View.le_join_l; cycle 1.
  { eapply View.singleton_rw_spec; [eapply WF|].
    transitivity (View.rlx (TView.cur tvw) loc); [eapply WF|eapply WF].
  }
  destruct tvw; auto.
Qed.

Lemma max_readable_not_racy gl prom rsv tvw loc to ts val released ord
      (MAX: max_readable gl prom loc ts val released)
      (TS: tvw.(TView.cur).(View.pln) loc = ts)
      (RACE: Local.is_racy (Local.mk tvw prom rsv) gl loc to ord)
      (WF: Local.wf (Local.mk tvw prom rsv) gl)
  :
    False.
Proof.
  inv RACE.
  { inv MAX. ss. rewrite GET in NONE. rewrite GETP in NONE. ss. }
  { inv MAX. ss. exploit MAX0; eauto. ss. }
Qed.

Lemma max_readable_not_read_race gl prom rsv tvw loc to ts val released
      val' ord
      (MAX: max_readable gl prom loc ts val released)
      (TS: tvw.(TView.cur).(View.pln) loc = ts)
      (READ: Local.racy_read_step (Local.mk tvw prom rsv) gl loc to val' ord)
      (WF: Local.wf (Local.mk tvw prom rsv) gl)
  :
    False.
Proof.
  inv READ. eapply max_readable_not_racy; eauto.
Qed.

Lemma max_readable_not_write_race gl prom rsv tvw loc to ts val released ord
      (MAX: max_readable gl prom loc ts val released)
      (TS: tvw.(TView.cur).(View.pln) loc = ts)
      (WRITE: Local.racy_write_step (Local.mk tvw prom rsv) gl loc to ord)
      (WF: Local.wf (Local.mk tvw prom rsv) gl)
  :
    False.
Proof.
  inv WRITE. eapply max_readable_not_racy; eauto.
Qed.

Lemma max_readable_read gl prom rsv tvw loc ts val0 val1 released
      (MAX: max_readable gl prom loc ts val1 released)
      (TS: tvw.(TView.cur).(View.pln) loc = ts)
      (WF: Local.wf (Local.mk tvw prom rsv) gl)
      (VAL: Const.le val0 val1)
  :
    exists released,
      (<<READ: Local.read_step (Local.mk tvw prom rsv) gl loc ts val0 released Ordering.na (Local.mk tvw prom rsv)>>).
Proof.
  inv MAX. esplits. econs; eauto.
  { econs; ss. refl. }
  ss. f_equal. rewrite read_tview_max; auto. apply WF.
Qed.

Variant fulfilled_memory (loc: Loc.t) (mem0 mem1: Memory.t): Prop :=
| fulfilled_memory_intro
    (OTHER: forall loc' (NEQ: loc' <> loc) to,
        Memory.get loc' to mem1 = Memory.get loc' to mem0)
    (GET: forall to from msg
                 (GET: Memory.get loc to mem1 = Some (from, msg)),
        Memory.get loc to mem0 = Some (from, msg))
.

Global Program Instance fulfilled_memory_PreOrder loc: PreOrder (fulfilled_memory loc).
Next Obligation.
Proof.
  ii. econs; eauto.
Qed.
Next Obligation.
Proof.
  ii. inv H. inv H0. econs.
  { i. transitivity (Memory.get loc' to y); eauto. }
  { i. exploit GET0; eauto. }
Qed.

Lemma fulfilled_memory_cancel loc from to msg mem0 mem1
      (CANCEL: Memory.remove mem0 loc from to msg mem1)
  :
    fulfilled_memory loc mem0 mem1.
Proof.
  econs.
  { i. erewrite (@Memory.remove_o mem1); eauto. des_ifs. des; clarify. }
  { i. erewrite (@Memory.remove_o mem1) in GET; eauto. des_ifs. }
Qed.

Lemma fulfilled_memory_max_ts loc mem0 mem1
      (INHABITED: Memory.inhabited mem1)
      (FULFILLED: fulfilled_memory loc mem0 mem1)
  :
    Time.le (Memory.max_ts loc mem1) (Memory.max_ts loc mem0).
Proof.
  specialize (INHABITED loc).
  apply Memory.max_ts_spec in INHABITED. des.
  apply FULFILLED in GET.
  apply Memory.max_ts_spec in GET. des. auto.
Qed.

Lemma fulfilled_memory_get0 loc mem0 mem1
      (FULFILLED: fulfilled_memory loc mem0 mem1)
      l to from msg
      (GET: Memory.get l to mem1 = Some (from, msg))
  :
    Memory.get l to mem0 = Some (from, msg).
Proof.
  destruct (Loc.eq_dec l loc).
  { subst. eapply FULFILLED in GET. des. eauto. }
  { inv FULFILLED. rewrite OTHER in GET; auto. }
Qed.

Variant unchanged_loc_memory (loc: Loc.t) (mem0 mem1: Memory.t): Prop :=
| unchanged_loc_memory_intro
    (UNCH: forall to, Memory.get loc to mem1 = Memory.get loc to mem0)
.

Definition unchanged_loc_promises (loc: Loc.t) (prom0 prom1: BoolMap.t): Prop :=
  prom1 loc = prom0 loc.

Global Program Instance unchanged_loc_memory_Equivalence loc:
  Equivalence (unchanged_loc_memory loc).
Next Obligation.
Proof.
  ii. econs. auto.
Qed.
Next Obligation.
Proof.
  ii. inv H. econs; eauto.
Qed.
Next Obligation.
Proof.
  ii. inv H. inv H0. econs. i. etrans; eauto.
Qed.

Global Program Instance unchanged_loc_promises_Equivalence loc:
  Equivalence (unchanged_loc_promises loc).
Next Obligation. ii. rr. refl. Qed.
Next Obligation. ii. rr. symmetry. auto. Qed.
Next Obligation. ii. rr. etrans; eauto. Qed.

Variant unchanged_loc_global (loc: Loc.t) (gl0 gl1: Global.t): Prop :=
| unchanged_loc_global_intro
    (MEMORY: unchanged_loc_memory loc gl0.(Global.memory) gl1.(Global.memory))
    (PROMISES: unchanged_loc_promises loc gl0.(Global.promises) gl1.(Global.promises))
.

Global Program Instance unchanged_loc_global_Equivalence loc:
  Equivalence (unchanged_loc_global loc).
Next Obligation.
Proof.
  ii. econs; refl.
Qed.
Next Obligation.
Proof.
  ii. inv H. econs; symmetry; auto.
Qed.
Next Obligation.
Proof.
  ii. inv H. inv H0. econs; etrans; eauto.
Qed.

Lemma unchanged_loc_max_readable prom0 gl0 prom1 gl1 loc
      (MEM: unchanged_loc_global loc gl0 gl1)
      (PROM: unchanged_loc_promises loc prom0 prom1)
  :
    forall ts val released,
      max_readable gl0 prom0 loc ts val released
      <->
      max_readable gl1 prom1 loc ts val released.
Proof.
  inv MEM. inv MEMORY.
  i. split; i.
  { inv H. econs.
    { rewrite UNCH. eauto. }
    { rewrite PROM. rewrite PROMISES. auto. }
    { i. eapply MAX; eauto. rewrite <- UNCH. eauto. }
  }
  { inv H. econs.
    { rewrite <- UNCH. eauto. }
    { rewrite <- PROM. rewrite <- PROMISES. auto. }
    { i. eapply MAX; eauto. rewrite UNCH. eauto. }
  }
Qed.

Lemma add_unchanged_loc mem0 mem1 loc from to msg loc0
      (ADD: Memory.add mem0 loc from to msg mem1)
      (NEQ: loc0 <> loc)
  :
    unchanged_loc_memory loc0 mem0 mem1.
Proof.
  econs. i. erewrite (@Memory.add_o mem1 mem0); eauto.
  des_ifs. ss. des; clarify.
Qed.

Lemma promises_add_unchanged_loc prm0 prm1 loc loc0
      (ADD: BoolMap.add prm0 loc prm1)
      (NEQ: loc0 <> loc)
  :
    unchanged_loc_promises loc0 prm0 prm1.
Proof.
  rr. inv ADD. setoid_rewrite LocFun.add_spec. des_ifs.
Qed.

Lemma promises_remove_unchanged_loc prm0 prm1 loc loc0
      (REMOVE: BoolMap.remove prm0 loc prm1)
      (NEQ: loc0 <> loc)
  :
    unchanged_loc_promises loc0 prm0 prm1.
Proof.
  rr. inv REMOVE. setoid_rewrite LocFun.add_spec. des_ifs.
Qed.

Lemma promises_fulfill_unchanged_loc prm0 gprm0 loc ord prm1 gprm1 loc0
      (FULFILL: Promises.fulfill prm0 gprm0 loc ord prm1 gprm1)
      (NEQ: loc0 <> loc)
  :
  (<<PROM: unchanged_loc_promises loc0 prm0 prm1>>) /\
    (<<GPROM: unchanged_loc_promises loc0 gprm0 gprm1>>).
Proof.
  inv FULFILL.
  { split; refl. }
  { split; eapply promises_remove_unchanged_loc; eauto. }
Qed.

Lemma promises_promise_unchanged_loc prm0 gprm0 loc prm1 gprm1 loc0
      (PROMISE: Promises.promise prm0 gprm0 loc prm1 gprm1)
      (NEQ: loc0 <> loc)
  :
  (<<PROM: unchanged_loc_promises loc0 prm0 prm1>>) /\
    (<<GPROM: unchanged_loc_promises loc0 gprm0 gprm1>>).
Proof.
  inv PROMISE.
  split; eapply promises_add_unchanged_loc; eauto.
Qed.

Lemma remove_unchanged_loc mem0 mem1 loc from to msg loc0
      (REMOVE: Memory.remove mem0 loc from to msg mem1)
      (NEQ: loc0 <> loc)
  :
    unchanged_loc_memory loc0 mem0 mem1.
Proof.
  econs. i. erewrite (@Memory.remove_o mem1 mem0); eauto.
  des_ifs; ss; des; clarify.
Qed.

Lemma reserve_unchanged_loc rsv0 mem0 loc from to rsv1 mem1 loc0
      (RESERVE: Memory.reserve rsv0 mem0 loc from to rsv1 mem1)
      (NEQ: loc0 <> loc)
  :
  (<<RSV: unchanged_loc_memory loc0 rsv0 rsv1>>) /\
    (<<MEM: unchanged_loc_memory loc0 mem0 mem1>>).
Proof.
  inv RESERVE. split; eapply add_unchanged_loc; eauto.
Qed.

Lemma cancel_unchanged_loc rsv0 mem0 loc from to rsv1 mem1 loc0
      (CANCEL: Memory.cancel rsv0 mem0 loc from to rsv1 mem1)
      (NEQ: loc0 <> loc)
  :
  (<<RSV: unchanged_loc_memory loc0 rsv0 rsv1>>) /\
    (<<MEM: unchanged_loc_memory loc0 mem0 mem1>>).
Proof.
  inv CANCEL. split; eapply remove_unchanged_loc; eauto.
Qed.

Lemma remove_reserves_loc prom0 mem0 loc
      (MLE: Memory.le prom0 mem0)
      (FIN: Memory.finite prom0)
      (INHABITED: Memory.inhabited mem0)
  :
    exists prom1 mem1,
      (<<RESERVE: cancel_future_memory loc prom0 mem0 prom1 mem1>>) /\
      (<<MEM: fulfilled_memory loc mem0 mem1>>) /\
      (<<RESERVE: forall to from msg
                         (GET: Memory.get loc to prom1 = Some (from, msg)),
          msg <> Message.reserve>>) /\
      (<<PROMISES: forall loc' to,
          Memory.get loc' to prom1 =
          if Loc.eq_dec loc' loc
          then match (Memory.get loc' to prom0) with
               | Some (from, Message.reserve) => None
               | x => x
               end
          else Memory.get loc' to prom0>>) /\
      (<<INHABITED: Memory.inhabited mem1>>).
Proof.
  hexploit (wf_cell_msgs_exists (prom0 loc)). i. des. clear WFMSGS.
  hexploit (@list_filter_exists _ (fun '(_, _, msg) => msg = Message.reserve) l).
  i. des.
  assert (exists rs,
             forall from to (GET: Memory.get loc to prom0 = Some (from, Message.reserve)),
               List.In to rs).
  { exists (List.map (snd <*> fst) l').  i.
    hexploit (proj1 (COMPLETE0 (from, to, Message.reserve))).
    { split; auto. apply COMPLETE. auto. }
    i. eapply List.in_map with (f:=(snd <*> fst)) in H. auto.
  }
  clear l l' COMPLETE COMPLETE0. des. ginduction rs.
  { i. exists prom0, mem0. splits.
    { econs. }
    { refl. }
    { ii. subst. eapply H in GET; eauto. }
    { i. des_ifs. hexploit H; eauto. ss. }
    { auto. }
  }
  { i. destruct (classic (exists from, Memory.get loc a prom0 = Some (from, Message.reserve))).
    { des.
      hexploit (@Memory.remove_exists prom0 loc from a Message.reserve); auto.
      i. des.
      hexploit Memory.remove_exists.
      { eapply MLE. eapply Memory.remove_get0; eauto. } i. des.
      assert (REMOVE: Memory.cancel prom0 mem0 loc from a mem2 mem1).
      { econs; eauto. }
      hexploit (IHrs mem2 mem1 loc); auto.
      { eapply cancel_memory_le; eauto. }
      { eapply Memory.remove_finite; eauto. }
      { apply Memory.cancel_inhabited in REMOVE; auto. }
      { i. erewrite Memory.remove_o in GET; eauto. des_ifs.
        ss. des; clarify. apply H in GET. des; clarify. }
      { i. des. exists prom1, mem3. splits.
        { econs; eauto. }
        { etrans; eauto. eapply fulfilled_memory_cancel; eauto. }
        { auto. }
        { i. rewrite PROMISES.
          erewrite (@Memory.remove_o mem2); eauto.
          des_ifs; ss; des; clarify.
        }
        { auto. }
      }
    }
    { eapply (IHrs prom0 mem0 loc); eauto. i.
      hexploit H; eauto. i. ss. des; clarify.
      exfalso. eapply H0. eauto.
    }
  }
Qed.

(* Lemma ts_le_memory_write_na *)
(*       ts0 prom0 mem0 loc from to val prom1 mem1 msgs kinds kind ts1 *)
(*       (WRITE: Memory.write_na ts1 prom0 mem0 loc from to val prom1 mem1 msgs kinds kind) *)
(*       (TS: Time.le ts0 ts1) *)
(*   : *)
(*     Memory.write_na ts0 prom0 mem0 loc from to val prom1 mem1 msgs kinds kind. *)
(* Proof. *)
(*   revert ts0 TS. induction WRITE; i. *)
(*   { econs 1; eauto. eapply TimeFacts.le_lt_lt; eauto. } *)
(*   { econs 2; eauto. eapply TimeFacts.le_lt_lt; eauto. } *)
(* Qed. *)

(* Lemma write_na_ts_lt ts prom0 mem0 loc from to val prom1 mem1 msgs kinds kind *)
(*       (WRITE: Memory.write_na ts prom0 mem0 loc from to val prom1 mem1 msgs kinds kind) *)
(*   : *)
(*     Time.lt ts to. *)
(* Proof. *)
(*   induction WRITE; auto. etrans; eauto. *)
(* Qed. *)

Lemma add_max_ts mem0 loc from to msg mem1
      (ADD: Memory.add mem0 loc from to msg mem1)
      (CLOSED: Memory.closed mem0)
  :
  Memory.max_ts loc mem1 = if (Time.le_lt_dec to (Memory.max_ts loc mem0)) then (Memory.max_ts loc mem0) else to.
Proof.
  inv CLOSED. specialize (INHABITED loc).
  eapply Memory.max_ts_spec in INHABITED. des.
  eapply Memory.add_get1 in GET; eauto.
  eapply Memory.max_ts_spec in GET. des; eauto.
  hexploit Memory.add_get0; eauto. i. des.
  hexploit Memory.max_ts_spec; eauto. i. des.
  erewrite Memory.add_o in GET2; eauto. des_ifs.
  { ss. des; clarify. eapply TimeFacts.antisym; auto. }
  { ss. des; clarify. eapply TimeFacts.antisym; auto.
    eapply Memory.max_ts_spec in GET2. des; eauto. }
  { ss. des; clarify. }
  { ss. des; clarify. eapply TimeFacts.antisym; auto.
    eapply Memory.max_ts_spec in GET2. des; eauto.
    left. eapply TimeFacts.le_lt_lt; eauto.
  }
Qed.

Lemma le_add_max_ts mem0 loc from to msg mem1
      (ADD: Memory.add mem0 loc from to msg mem1)
      (TO: Time.le (Memory.max_ts loc mem0) to)
  :
    Memory.max_ts loc mem1 = to.
Proof.
  hexploit Memory.add_get0; eauto. i. des.
  eapply Memory.max_ts_spec in GET0. des.
  erewrite Memory.add_o in GET1; eauto. des_ifs.
  { ss. des; clarify. }
  { ss. des; clarify.
    apply Memory.max_ts_spec in GET1. des.
    apply TimeFacts.antisym; auto. etrans; eauto.
  }
Qed.

Lemma timemap_singleton_neq loc ts loc0
      (NEQ: loc0 <> loc)
  :
    TimeMap.singleton loc ts loc0 = Time.bot.
Proof.
  unfold TimeMap.singleton. setoid_rewrite LocFun.add_spec_neq; auto.
Qed.

Lemma timemap_singleton_eq loc ts
  :
    TimeMap.singleton loc ts loc = ts.
Proof.
  unfold TimeMap.singleton. setoid_rewrite LocFun.add_spec_eq; auto.
Qed.

Lemma local_write_step_timestamp_pln
      lc0 gl0 loc from to val releasedm released ord lc1 gl1
      (WRITE: Local.write_step lc0 gl0 loc from to val releasedm released ord lc1 gl1)
      (WF: TView.wf lc0.(Local.tview))
  :
    lc1.(Local.tview).(TView.cur).(View.pln) loc = to.
Proof.
  inv WRITE. ss. unfold TimeMap.join.
  rewrite timemap_singleton_eq. apply TimeFacts.le_join_r.
  inv WRITABLE. left. eapply TimeFacts.le_lt_lt; eauto.
  eapply WF.
Qed.

Lemma local_write_step_timestamp_rlx
      lc0 gl0 loc from to val releasedm released ord lc1 gl1
      (WRITE: Local.write_step lc0 gl0 loc from to val releasedm released ord lc1 gl1)
      (WF: TView.wf lc0.(Local.tview))
  :
    lc1.(Local.tview).(TView.cur).(View.rlx) loc = to.
Proof.
  inv WRITE. ss. unfold TimeMap.join.
  rewrite timemap_singleton_eq. apply TimeFacts.le_join_r.
  inv WRITABLE. left. eauto.
Qed.

Lemma max_readable_na_write_step gl0 rsv0 prom0 tvw0 loc ts from to val0 val1 released
      (MAX: max_readable gl0 prom0 loc ts val0 released)
      (TS: tvw0.(TView.cur).(View.pln) loc = ts)
      (WF: Local.wf (Local.mk tvw0 prom0 rsv0) gl0)
      (CLOSED: Global.wf gl0)
      (FROM: Time.le (Memory.max_ts loc gl0.(Global.memory)) from)
      (TO: Time.lt from to)
  :
  exists mem1 mem2 rsv1 tvw1,
    (<<RESERVE: cancel_future_memory loc rsv0 gl0.(Global.memory) rsv1 mem1>>) /\
      (<<ADD0: Memory.add mem1 loc from to (Message.message val1 None true) mem2>>) /\
      (<<RESERVES: forall loc' ts',
          Memory.get loc' ts' rsv1 =
            if Loc.eq_dec loc' loc
            then None
            else Memory.get loc' ts' rsv0>>) /\
      (<<WRITE: Local.write_step (Local.mk tvw0 prom0 rsv1) (Global.mk gl0.(Global.sc) gl0.(Global.promises) mem1) loc from to val1 None None Ordering.na (Local.mk tvw1 (fun loc' => if Loc.eq_dec loc' loc then false else prom0 loc') rsv1) (Global.mk gl0.(Global.sc) (fun loc' => if Loc.eq_dec loc' loc then false else gl0.(Global.promises) loc') mem2)>>) /\
      (<<VIEW: tvw1.(TView.cur).(View.pln) loc = to>>) /\
      (<<MAXTS: Memory.max_ts loc mem2 = to>>) /\
      (<<MAX: max_readable (Global.mk gl0.(Global.sc) (fun loc' => if Loc.eq_dec loc' loc then false else gl0.(Global.promises) loc') mem2) (fun loc' => if Loc.eq_dec loc' loc then false else prom0 loc') loc to val1 None>>)
.
Proof.
  hexploit (@remove_reserves_loc rsv0 gl0.(Global.memory) loc).
  { apply WF. }
  { apply WF. }
  { eapply CLOSED. }
  i. des.
  hexploit (@Memory.add_exists mem1 loc from to (Message.message val1 None true)); auto.
  { ii. eapply Memory.max_ts_spec in GET2. des.
    inv LHS. inv RHS. ss.
    eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt; [apply FROM0|].
    etrans; eauto. etrans; eauto. etrans; [|eapply FROM].
    eapply fulfilled_memory_max_ts; eauto.
  }
  i. des.
  assert (WRITE: Local.write_step (Local.mk tvw0 prom0 prom1) (Global.mk gl0.(Global.sc) gl0.(Global.promises) mem1) loc from to val1 None None Ordering.na (Local.mk (TView.write_tview tvw0 loc to Ordering.na) (fun loc' => if Loc.eq_dec loc' loc then false else prom0 loc') prom1) (Global.mk gl0.(Global.sc) (fun loc' => if Loc.eq_dec loc' loc then false else gl0.(Global.promises) loc') mem2)).
  { econs; ss.
    { econs. inv WF. inv TVIEW_CLOSED. inv CUR. specialize (RLX loc). des.
      ss. eapply Memory.max_ts_spec in RLX. des.
      eapply TimeFacts.le_lt_lt; [eapply MAX0|].
      eapply TimeFacts.le_lt_lt; eauto.
    }
    { destruct (prom0 loc) eqn:EQ.
      { econs 2; ss. econs; ss. eapply WF. ss. }
      { econs 1.
        { extensionality l. des_ifs. }
        { extensionality l. des_ifs. inv MAX.
          rewrite EQ in NONE. destruct (gl0.(Global.promises) loc); ss.
        }
      }
    }
    { ss. }
  }
  assert (MAXTS: Memory.max_ts loc mem2 = to).
  { eapply le_add_max_ts; eauto. etrans.
    { eapply fulfilled_memory_max_ts; eauto. }
    etrans; eauto. left. auto.
  }
  eexists mem1, mem2, prom1,  _. splits; eauto.
  { i. rewrite PROMISES. des_ifs.
    inv WF. eapply RESERVES_ONLY in Heq. ss.
  }
  { hexploit local_write_step_timestamp_pln; eauto. eapply WF. }
  { econs.
    { eapply Memory.add_get0; eauto. }
    { ss. des_ifs. }
    { i. ss. eapply Memory.max_ts_spec in GET. des.
      subst. eapply Time.lt_strorder.
      eapply TimeFacts.le_lt_lt; [apply MAX0|apply TS0].
    }
  }
Qed.

Lemma write_max_readable
      lc0 gl0 loc from to val releasedm released ord lc1 gl1
      val0 released0
      (WRITE: Local.write_step lc0 gl0 loc from to val releasedm released ord lc1 gl1)
      (WF: Local.wf lc0 gl0)
      (MAX: max_readable gl1 lc1.(Local.promises) loc (lc1.(Local.tview).(TView.cur).(View.pln) loc) val0 released0)
  :
    (<<VAL: val0 = val>>) /\ (<<RELEASED: released0 = released>>).
Proof.
  hexploit local_write_step_timestamp_pln; eauto.
  { apply WF. }
  i. rewrite H in MAX. inv MAX. inv WRITE.
  eapply Memory.add_get0 in WRITE0. des. ss. clarify.
Qed.

Lemma max_readable_write gl0 rsv0 prom0 tvw0 loc ts from to val1 lprm1 gprm1 ord releasedm
      (TS: tvw0.(TView.cur).(View.pln) loc = ts)
      (WF: Local.wf (Local.mk tvw0 prom0 rsv0) gl0)
      (CLOSED: Global.wf gl0)
      (FROM: Time.le (Memory.max_ts loc gl0.(Global.memory)) from)
      (TO: Time.lt from to)
      (FULFILL: Promises.fulfill prom0 gl0.(Global.promises) loc ord lprm1 gprm1)
      (RELEASEDM: View.opt_wf releasedm)
      (NORACE: gl0.(Global.promises) loc = true -> prom0 loc = true)
  :
  exists tvw1 mem1,
    (<<WRITE: Local.write_step (Local.mk tvw0 prom0 rsv0) gl0 loc from to val1 releasedm (TView.write_released tvw0 loc to releasedm ord) ord (Local.mk tvw1 lprm1 rsv0) (Global.mk gl0.(Global.sc) gprm1 mem1)>>) /\
      (<<ADD0: Memory.add gl0.(Global.memory) loc from to (Message.message val1 (TView.write_released tvw0 loc to releasedm ord) (Ordering.le ord Ordering.na)) mem1>>) /\
      (<<VIEWPLN: tvw1.(TView.cur).(View.pln) loc = to>>) /\
      (<<VIEWRLX: tvw1.(TView.cur).(View.rlx) loc = to>>) /\
      (<<MAXTS: Memory.max_ts loc mem1 = to>>) /\
      (<<MAX: max_readable (Global.mk gl0.(Global.sc) gprm1 mem1) lprm1 loc to val1 (TView.write_released tvw0 loc to releasedm ord)>>)
.
Proof.
  hexploit (@Memory.add_exists gl0.(Global.memory) loc from to (Message.message val1 (TView.write_released tvw0 loc to releasedm ord) (Ordering.le ord Ordering.na))); auto.
  { ii. eapply Memory.max_ts_spec in GET2. des.
    inv LHS. inv RHS. ss.
    eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt; [apply FROM0|].
    etrans; eauto.
  }
  { econs; eauto. eapply TViewFacts.write_future0; eauto. eapply WF. }
  i. des.
  assert (MAXTS: Memory.max_ts loc mem2 = to).
  { eapply le_add_max_ts; eauto. etrans; eauto. left. auto. }
  assert (WRITE: Local.write_step
                   (Local.mk tvw0 prom0 rsv0)
                   gl0
                   loc from to val1 releasedm (TView.write_released tvw0 loc to releasedm ord) ord
                   (Local.mk (TView.write_tview tvw0 loc to ord) lprm1 rsv0)
                   (Global.mk gl0.(Global.sc) gprm1 mem2)).
  { econs; ss; eauto.
    { econs. inv WF. inv TVIEW_CLOSED. inv CUR. specialize (RLX loc). des.
      ss. eapply Memory.max_ts_spec in RLX. des.
      eapply TimeFacts.le_lt_lt; [eapply MAX|].
      eapply TimeFacts.le_lt_lt; eauto.
    }
  }
  esplits; eauto.
  { eapply local_write_step_timestamp_pln in WRITE; eauto. eapply WF. }
  { eapply local_write_step_timestamp_rlx in WRITE; eauto. eapply WF. }
  { econs.
    { eapply Memory.add_get0; eauto. }
    { ss. inv FULFILL.
      { unfold implb. des_ifs. eapply NORACE; auto. }
      { inv REMOVE. inv GREMOVE. setoid_rewrite LocFun.add_spec_eq. auto. }
    }
    { i. ss. eapply Memory.max_ts_spec in GET. des.
      subst. eapply Time.lt_strorder.
      eapply TimeFacts.le_lt_lt; [apply MAX|apply TS0].
    }
  }
Qed.

Lemma non_max_readable_race gl prom tvw rsv loc
      (MAX: forall val released, ~ max_readable gl prom loc (tvw.(TView.cur).(View.pln) loc) val released)
      (WF: Local.wf (Local.mk tvw prom rsv) gl)
  :
    exists to, Local.is_racy (Local.mk tvw prom rsv) gl loc to Ordering.na.
Proof.
  inv WF. inv TVIEW_CLOSED. inv CUR. ss.
  specialize (PLN loc). des.
  apply NNPP. ii. eapply MAX. econs; eauto.
  { destruct (prom loc) eqn:LCPROM, (Global.promises gl loc) eqn:GLPROM; ss.
    exfalso. eapply H. exists None. econs; ss.
  }
  { destruct msg; ss. i. eapply H.
    eexists (Some ts'). econs; eauto.
  }
Qed.

Lemma non_max_readable_read gl prom rsv tvw loc ts val'
      (MAX: forall val released, ~ max_readable gl prom loc ts val released)
      (TS: tvw.(TView.cur).(View.pln) loc = ts)
      (WF: Local.wf (Local.mk tvw prom rsv) gl)
  :
    exists to, Local.racy_read_step (Local.mk tvw prom rsv) gl loc to val' Ordering.na.
Proof.
  subst. hexploit non_max_readable_race; eauto. i. des. eauto.
Qed.

Lemma non_max_readable_write gl prom rsv tvw loc ts
      (MAX: forall val released, ~ max_readable gl prom loc ts val released)
      (TS: tvw.(TView.cur).(View.pln) loc = ts)
      (WF: Local.wf (Local.mk tvw prom rsv) gl)
  :
    exists to, Local.racy_write_step (Local.mk tvw prom rsv) gl loc to Ordering.na.
Proof.
  subst. hexploit non_max_readable_race; eauto. i. des. eauto.
Qed.

Variant added_memory loc msgs mem0 mem1: Prop :=
| added_memory_intro
    (MLE: Memory.le mem0 mem1)
    (OTHER: forall loc' (NEQ: loc' <> loc) to, Memory.get loc' to mem1 = Memory.get loc' to mem0)
    (COMPLETE: forall from to msg
                      (IN: List.In (from, to, msg) msgs),
        Memory.get loc to mem1 = Some (from, msg))
    (SOUND: forall from to msg
                   (GET: Memory.get loc to mem1 = Some (from, msg)),
        (<<GET: Memory.get loc to mem0 = Some (from, msg)>>) \/
        (<<IN: List.In (from, to, msg) msgs>>))
.

Lemma added_memory_nil loc mem
  :
    added_memory loc [] mem mem.
Proof.
  econs; eauto.
  { refl. }
  { i. ss. }
Qed.

Lemma added_memory_cons loc from to msg msgs mem0 mem1 mem2
      (ADD: Memory.add mem0 loc from to msg mem1)
      (ADDED: added_memory loc msgs mem1 mem2)
  :
    added_memory loc ((from, to, msg)::msgs) mem0 mem2.
Proof.
  inv ADDED. econs; eauto.
  { etrans; eauto. ii. eapply Memory.add_get1 in LHS; eauto. }
  { i. rewrite OTHER; auto.
    erewrite (@Memory.add_o mem1); eauto. des_ifs.
    ss. des; clarify.
  }
  { i. ss. des; clarify.
    { eapply MLE. eapply Memory.add_get0; eauto. }
    { apply COMPLETE; auto. }
  }
  { i. apply SOUND in GET. des; ss; auto.
    erewrite Memory.add_o in GET0; eauto. des_ifs; auto.
    ss. des; clarify. auto.
  }
Qed.

Lemma added_memory_unchanged_loc loc msgs mem0 mem1 loc0
      (ADDED: added_memory loc msgs mem0 mem1)
      (NEQ: loc0 <> loc)
  :
    unchanged_loc_memory loc0 mem0 mem1.
Proof.
  induction ADDED. econs. i.
  rewrite OTHER; eauto.
Qed.

Lemma add_promises_latest lang (st: lang.(Language.state)) prm gprm tvw sc loc msgs:
  forall mem0 rsv0
         (WFMSGS: wf_cell_msgs msgs)
         (MLE: Memory.le rsv0 mem0)
         (MEM: Memory.closed mem0)
         (FORALL: List.Forall
                    (fun '(from, to, msg) => (__guard__((<<RESERVE: msg = Message.reserve>>) /\ (<<DISJOINT: forall to2 from2 msg2 (GET: Memory.get loc to2 mem0 = Some (from2, msg2)), Interval.disjoint (from, to) (from2, to2)>>))) /\ (<<TS: Time.lt from to>>)) msgs),
  exists rsv1 mem1,
    (<<STEPS: rtc (@Thread.internal_step _) (Thread.mk _ st (Local.mk tvw prm rsv0) (Global.mk sc gprm mem0)) (Thread.mk _ st (Local.mk tvw prm rsv1) (Global.mk sc gprm mem1))>>) /\
    (<<MEM: added_memory loc msgs mem0 mem1>>) /\
    (<<PROMISES: added_memory loc msgs rsv0 rsv1>>).
Proof.
  induction msgs; i.
  { esplits; eauto.
    { eapply added_memory_nil. }
    { eapply added_memory_nil. }
  }
  { inv FORALL. destruct a as [[from to] msg]. des.
    red in WFMSGS. des. inv DISJOINT. inv MSGSWF. guardH H3.
    rr in H1. des; subst.
    hexploit (@Memory.add_exists mem0 loc from to Message.reserve); eauto.
    i. des. hexploit Memory.add_exists_le; eauto. i. des.
    assert (ADD: Memory.reserve rsv0 mem0 loc from to mem2' mem2).
    { econs; eauto. }
    hexploit (IHmsgs mem2 mem2').
    { red. splits; auto. }
    { ii. erewrite (@Memory.add_o _ rsv0) in LHS; eauto.
      erewrite (@Memory.add_o _ mem0); eauto. des_ifs. eapply MLE; auto.
    }
    { eapply Memory.add_closed; eauto. }
    { eapply List.Forall_forall.
      intros [[from0 to0] msgs0]. i.
      eapply List.Forall_forall in H2; eauto.
      eapply List.Forall_forall in H4; eauto.
      eapply List.Forall_forall in HD; eauto. ss. des; subst.
      { timetac. }
      splits; auto.
      { rr in H2. des. rr. splits; auto. i.
        erewrite Memory.add_o in GET; eauto. des_ifs.
        { ss. des; clarify.
          symmetry. eapply interval_le_disjoint. auto.
        }
        { eapply DISJOINT0; eauto. }
      }
    }
    i. des. esplits.
    { econs 2; [|eauto]. econs. econs 2; eauto. }
    { eapply added_memory_cons; eauto. }
    { eapply added_memory_cons; eauto. }
  }
Qed.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                                                                                *)
(************************************************************************************)

Set Implicit Arguments.

Require Import Bool List Arith NArith.

Require Import BasicFacts ListFacts ListPermut ListSort OrderedSet
        FiniteSet FiniteBag FiniteCollection Formula Partition DExpressions Data FlatData Tree SqlCommon.

Section Sec.

Hypothesis T : Tuple.Rcd.

Hypothesis relname : Type.
Hypothesis ORN : Oset.Rcd relname.

Hypothesis predicate : Type.
Hypothesis symb : Type.
Hypothesis aggregate : Type.
Hypothesis OPredicate : Oset.Rcd predicate.
Hypothesis OSymb : Oset.Rcd symb.
Hypothesis OAggregate : Oset.Rcd aggregate.
Hypothesis interp_predicate : predicate -> list (Tuple.value T) -> bool.
Hypothesis interp_symb : symb -> list (Tuple.value T) -> Tuple.value T.
Hypothesis interp_aggregate : aggregate -> list (Tuple.value T) -> Tuple.value T.

Arguments Select_Star {T} {symb} {aggregate} {OSymb} {OAggregate}.
Arguments Group_Fine {T} {symb} {aggregate} {OSymb} {OAggregate}.

Import Tuple.

Notation setA := (Fset.set (A T)).
Notation BTupleT := (Fecol.CBag (CTuple T)).
Notation bagT := (Febag.bag BTupleT).
Notation funterm := (funterm (E T OSymb OAggregate)).
Notation aggterm := (aggterm (E T OSymb OAggregate)).
Notation select := (select T OSymb OAggregate).

Inductive query : Type :=
  | Q_Empty_Tuple : query
  | Q_Table : relname -> query
  | Q_Set : set_op -> query -> query -> query
  | Q_Join : query -> query -> query
  | Q_Pi : list select -> query -> query
  | Q_Sigma : formula -> query -> query
  | Q_Gamma : list funterm -> formula -> list select -> query -> query

with formula : Type :=
  | Q_Conj : Formula.and_or -> formula -> formula -> formula
  | Q_Not : formula -> formula
  | Q_Atom : q_atom -> formula

with q_atom : Type :=
  | Q_True
  | Q_Pred : predicate -> list aggterm -> q_atom
  | Q_Quant : Formula.quantifier -> predicate -> list aggterm -> query -> q_atom
  | Q_In : list select -> query -> q_atom
  | Q_Exists : query -> q_atom.

Hypothesis basesort : relname -> Fset.set (Tuple.A T).
Hypothesis instance : relname -> bagT.

Fixpoint sort (q : query) : setA :=
  match q with
    | Q_Empty_Tuple => Fset.empty _
    | Q_Table t => basesort t
    | Q_Set _ q1 _ => sort q1
    | Q_Join q1 q2 => Fset.union _ (sort q1) (sort q2)
    | Q_Sigma _ q => sort q
    | Q_Pi l _
    | Q_Gamma _ _ l _ =>
      Fset.mk_set _ (map (fun x => match x with Select_As _ a => a end) l)
  end.

Lemma sort_unfold :
  forall q, sort q =
  match q with
    | Q_Empty_Tuple => Fset.empty _
    | Q_Table t => basesort t
    | Q_Set _ q1 _ => sort q1
    | Q_Join q1 q2 => Fset.union _ (sort q1) (sort q2)
    | Q_Sigma _ q => sort q
    | Q_Pi l _
    | Q_Gamma _ _ l _ =>
      Fset.mk_set _ (map (fun x => match x with Select_As _ a => a end) l)
  end.
Proof.
intro q; case q; intros; apply refl_equal.
Qed.

Notation env_t := (env_t (T := T) (OSymb := OSymb) (OAggregate := OAggregate)).
Notation env_g := (env_g (T := T) (OSymb := OSymb) (OAggregate := OAggregate)).
Notation projection_ := (projection (OSymb := OSymb) (OAggregate := OAggregate) interp_symb interp_aggregate).
Notation interp_funterm_ := (interp_funterm_ (OSymb := OSymb) (OAggregate := OAggregate) interp_symb).
Notation interp_aggterm_ :=
  (interp_aggterm_ (OSymb := OSymb) (OAggregate := OAggregate) interp_symb interp_aggregate).
Notation make_groups_ := (fun env b => make_groups (T := T) (OSymb := OSymb) (OAggregate := OAggregate) interp_symb env (Febag.elements (Fecol.CBag (CTuple T)) b)).
Notation natural_join_bag b1 b2 :=
  (Febag.mk_bag (Fecol.CBag (CTuple T)) (Data.natural_join_list
     _ _ (build_data T)
     (Febag.elements (Fecol.CBag (CTuple T)) b1) (Febag.elements(Fecol.CBag (CTuple T)) b2))).
Notation N_product_bag ll := (Data.N_product_bag _ _ (build_data T) (Fecol.CBag (CTuple T)) ll).

Fixpoint eval_query env q {struct q} : bagT :=
  match q with
  | Q_Empty_Tuple => Febag.singleton _ (empty_tuple T)
  | Q_Table r => instance r
  | Q_Set o q1 q2 =>
    if sort q1 =S?= sort q2
    then Febag.interp_set_op _ o (eval_query env q1) (eval_query env q2)
    else Febag.empty _
  | Q_Join q1 q2 => natural_join_bag (eval_query env q1) (eval_query env q2)
  | Q_Pi s q =>
    Febag.map _  _ (fun t => projection_ (env_t env t) (Select_List s) base.nullval) (eval_query env q)
  | Q_Sigma f q => Febag.filter _ (fun t => eval_formula (env_t env t) f) (eval_query env q)
  | Q_Gamma lf f s q =>
    Febag.mk_bag
      _ (map (fun l => projection_ (env_g env (Group_By lf) l) (Select_List s) base.nullval)
             (filter (fun l => eval_formula (env_g env (Group_By lf) l) f)
                     (make_groups_ env (eval_query env q) (Group_By lf))))
  end

with eval_formula env f :=
  match f with
    | Q_Conj Formula.And_F f1 f2 => (eval_formula env f1) && (eval_formula env f2)
    | Q_Conj Formula.Or_F f1 f2 => (eval_formula env f1) || (eval_formula env f2)
    | Q_Not f => negb (eval_formula env f)
    | Q_Atom a => eval_q_atom env a
  end

with eval_q_atom env atm :=
  match atm with
  | Q_True => true
  | Q_Pred p l => interp_predicate p (map (interp_aggterm_ env) l)
  | Q_Quant qtf p l sq =>
      let lt := map (interp_aggterm_ env) l in
      Formula.interp_quant qtf
        (fun x : tuple T =>
         let la := {{{support T x}}} in
         interp_predicate p (lt ++ map (dot T x) la))
        (Febag.elements (Fecol.CBag (CTuple T)) (eval_query env sq))
  | Q_In s q => projection_ env (Select_List s) base.nullval inBE? eval_query env q
  | Q_Exists q => negb (Febag.is_empty (Fecol.CBag (CTuple T)) (eval_query env q))
  end.

Lemma eval_query_unfold :
  forall env q, eval_query env q =
  match q with
  | Q_Empty_Tuple => Febag.singleton _ (empty_tuple T)
  | Q_Table r => instance r
  | Q_Set o q1 q2 =>
    if sort q1 =S?= sort q2
    then Febag.interp_set_op _ o (eval_query env q1) (eval_query env q2)
    else Febag.empty _
  | Q_Join q1 q2 => natural_join_bag (eval_query env q1) (eval_query env q2)
  | Q_Pi s q =>
    Febag.map _  _ (fun t => projection_ (env_t env t) (Select_List s) base.nullval) (eval_query env q)
  | Q_Sigma f q => Febag.filter _ (fun t => eval_formula (env_t env t) f) (eval_query env q)
  | Q_Gamma lf f s q =>
    Febag.mk_bag
      _ (map (fun l => projection_ (env_g env (Group_By lf) l) (Select_List s) base.nullval)
             (filter (fun l => eval_formula (env_g env (Group_By lf) l) f)
                     (make_groups_ env (eval_query env q) (Group_By lf))))
  end.
Proof.
intros env q; case q; intros; apply refl_equal.
Qed.

Lemma eval_formula_unfold :
  forall env f, eval_formula env f =
  match f with
    | Q_Conj Formula.And_F f1 f2 => (eval_formula env f1) && (eval_formula env f2)
    | Q_Conj Formula.Or_F f1 f2 => (eval_formula env f1) || (eval_formula env f2)
    | Q_Not f => negb (eval_formula env f)
    | Q_Atom a => eval_q_atom env a
  end.
Proof.
intros env f; case f; intros; apply refl_equal.
Qed.

Lemma eval_q_atom_unfold :
  forall env atm, eval_q_atom env atm =
  match atm with
  | Q_True => true
  | Q_Pred p l => interp_predicate p (map (interp_aggterm_ env) l)
  | Q_Quant qtf p l sq =>
      let lt := map (interp_aggterm_ env) l in
      Formula.interp_quant qtf
        (fun x : tuple T =>
         let la := {{{support T x}}} in
         interp_predicate p (lt ++ map (dot T x) la))
        (Febag.elements (Fecol.CBag (CTuple T)) (eval_query env sq))
  | Q_In s q => projection_ env (Select_List s) base.nullval inBE? eval_query env q
  | Q_Exists q => negb (Febag.is_empty (Fecol.CBag (CTuple T)) (eval_query env q))
  end.
Proof.
intros env atm; case atm; intros; apply refl_equal.
Qed.

Fixpoint N_Q_Join l :=
  match l with
    | nil => Q_Empty_Tuple
    | q :: nil => q
    | q1 :: l => Q_Join q1 (N_Q_Join l)
  end.

Lemma N_Q_Join_unfold :
  forall l, N_Q_Join l =
  match l with
    | nil => Q_Empty_Tuple
    | q :: nil => q
    | q1 :: l => Q_Join q1 (N_Q_Join l)
  end.
Proof.
intros [ | x1 [ | x2 l]]; apply refl_equal.
Qed.

Lemma sort_N_Q_Join :
  forall l, sort (N_Q_Join l) =S= Fset.Union _ (map sort l).
Proof.
intro l; induction l as [ | x1 [ | x2 l]].
- apply Fset.equal_refl.
- simpl; rewrite Fset.equal_spec; intro a.
  rewrite Fset.mem_union, Fset.empty_spec, Bool.orb_false_r.
  apply refl_equal.
- rewrite map_unfold, Fset.Union_unfold, N_Q_Join_unfold, sort_unfold.
  apply Fset.union_eq_2; apply IHl.
Qed.

(** * Syntactic comparison of queries *)

Section Compare.

Inductive All : Type :=
  | All_relname : relname  -> All
  | All_attribute : attribute T -> All
  | All_predicate : predicate -> All
  | All_funterm : funterm -> All
  | All_aggterm : aggterm -> All.

Definition tree_of_attribute (a : attribute T) : tree All := Leaf (All_attribute a).

Definition tree_of_select s : tree All :=
  match s with
    | Select_As e a => Node 0 (Leaf (All_aggterm e) :: tree_of_attribute a :: nil)
  end.

Definition tree_of_select_item s : tree All := Node 2 (map tree_of_select s).

Fixpoint tree_of_query (q : query) : tree All :=
  match q with
(*    | Q_Empty sa => Node 3 (map tree_of_attribute sa) *)
    | Q_Empty_Tuple => Node 4 nil
    | Q_Table r => Node 5 (Leaf (All_relname r) :: nil)
    | Q_Set o q1 q2 =>
      Node
        (match o with
           | Union => 6
           | Inter => 7
           | Diff => 8
           | UnionMax => 9 end)
        (tree_of_query q1 :: tree_of_query q2 :: nil)
    | Q_Join q1 q2 => Node 10 (tree_of_query q1 :: tree_of_query q2 :: nil)
    | Q_Pi s q => Node 11 (tree_of_select_item s :: tree_of_query q :: nil)
    | Q_Sigma f q => Node 12 (tree_of_formula f ::  tree_of_query q :: nil)
    | Q_Gamma lf f s q =>
      Node 13 (tree_of_formula f
               :: tree_of_select_item s
               :: tree_of_query q
               :: (map (fun x => Leaf (All_funterm x)) lf))
  end

with tree_of_formula f :=
  match f with
    | Q_Conj a f1 f2 =>
        Node (match a with Formula.And_F => 14 | Or_F => 15 end)
             (tree_of_formula f1 :: tree_of_formula f2 :: nil)
    | Q_Not f => Node 16 (tree_of_formula f :: nil)
    | Q_Atom a => tree_of_q_atom a
  end

with tree_of_q_atom a :=
  match a with
    | Q_True => Node 17 nil
    | Q_Pred p l => Node 18 (Leaf (All_predicate p) :: map (fun x => Leaf (All_aggterm x)) l)
    | Q_Quant qtf p l q =>
      Node
        (match qtf with
           | Formula.Forall_F => 19
           | Exists_F => 20
         end)
        (Leaf (All_predicate p)
              :: tree_of_query q
              :: (map (fun x => Leaf (All_aggterm x)) l))
    | Q_In s q => Node 21 ( tree_of_query q :: map tree_of_select s)
    | Q_Exists q => Node 22 (tree_of_query q :: nil)
  end.

Lemma tree_of_select_item_unfold :
  forall s, tree_of_select_item s = Node 2 (map tree_of_select s).
Proof.
intros; apply refl_equal.
Qed.

Lemma tree_of_query_unfold :
  forall q, tree_of_query q =
  match q with
(*    | Q_Empty sa => Node 3 (map tree_of_attribute sa) *)
    | Q_Empty_Tuple => Node 4 nil
    | Q_Table r => Node 5 (Leaf (All_relname r) :: nil)
    | Q_Set o q1 q2 =>
      Node
        (match o with
           | Union => 6
           | Inter => 7
           | Diff => 8
           | UnionMax => 9 end)
        (tree_of_query q1 :: tree_of_query q2 :: nil)
    | Q_Join q1 q2 => Node 10 (tree_of_query q1 :: tree_of_query q2 :: nil)
    | Q_Pi s q => Node 11 (tree_of_select_item s :: tree_of_query q :: nil)
    | Q_Sigma f q => Node 12 (tree_of_formula f ::  tree_of_query q :: nil)
    | Q_Gamma lf f s q =>
      Node 13 (tree_of_formula f
               :: tree_of_select_item s
               :: tree_of_query q
               :: (map (fun x => Leaf (All_funterm x)) lf))
  end.
Proof.
intro q; case q; intros; apply refl_equal.
Qed.

Lemma tree_of_formula_unfold :
  forall f, tree_of_formula f =
  match f with
    | Q_Conj a f1 f2 =>
        Node (match a with Formula.And_F => 14 | Or_F => 15 end)
             (tree_of_formula f1 :: tree_of_formula f2 :: nil)
    | Q_Not f => Node 16 (tree_of_formula f :: nil)
    | Q_Atom a => tree_of_q_atom a
  end.
Proof.
intro f; case f; intros; apply refl_equal.
Qed.

Lemma tree_of_q_atom_unfold :
  forall a, tree_of_q_atom a =
  match a with
    | Q_True => Node 17 nil
    | Q_Pred p l => Node 18 (Leaf (All_predicate p) :: map (fun x => Leaf (All_aggterm x)) l)
    | Q_Quant qtf p l q =>
      Node
        (match qtf with
           | Formula.Forall_F => 19
           | Exists_F => 20
         end)
        (Leaf (All_predicate p)
              :: tree_of_query q
              :: (map (fun x => Leaf (All_aggterm x)) l))
    | Q_In s q => Node 21 ( tree_of_query q :: map tree_of_select s)
    | Q_Exists q => Node 22 (tree_of_query q :: nil)
  end.
Proof.
intro a; case a; intros; apply refl_equal.
Qed.

Open Scope N_scope.

Definition N_of_All (a : All) : N :=
  match a with
  | All_relname _ => 0
  | All_attribute _ => 1
  | All_predicate _ => 2
  | All_funterm _ => 3
  | All_aggterm _ => 4
  end.

Close Scope N_scope.

Definition all_compare a1 a2 :=
   match Ncompare (N_of_All a1) (N_of_All a2) with
   | Lt => Lt
   | Gt => Gt
   | Eq =>
       match a1, a2 with
       | All_relname r1, All_relname r2 => Oset.compare ORN r1 r2
       | All_attribute a1, All_attribute a2 => Oset.compare (OAtt T) a1 a2
       | All_predicate p1, All_predicate p2 => Oset.compare OPredicate p1 p2
       | All_funterm f1, All_funterm f2 => Oset.compare (OFun (E T OSymb OAggregate)) f1 f2
       | All_aggterm a1, All_aggterm a2 => Oset.compare (OAgg (E T OSymb OAggregate)) a1 a2
       | _, _ => Eq
       end
   end.

Definition OAll : Oset.Rcd All.
split with all_compare; unfold all_compare.
(* 1/3 *)
- intros a1 a2.
  case a1; clear a1;
  (intro x1; case a2; clear a2; intro x2; simpl; try discriminate);
  try oset_compare_tac.
  + generalize (funterm_compare_eq_bool_ok x1 x2).
    case (funterm_compare x1 x2).
    * apply f_equal.
    * intros H K; apply H.
      injection K; exact (fun h => h).
    * intros H K; apply H.
      injection K; exact (fun h => h).
  + generalize (aggterm_compare_eq_bool_ok x1 x2).
    case (aggterm_compare x1 x2).
    * apply f_equal.
    * intros H K; apply H.
      injection K; exact (fun h => h).
    * intros H K; apply H.
      injection K; exact (fun h => h).
- intros a1 a2 a3.
  case a1; clear a1;
  (intro x1; case a2; clear a2; try discriminate;
   (intro x2; case a3; clear a3; intro x3; simpl;
    try (discriminate || intros; apply refl_equal)));
  try oset_compare_tac.
  + apply (Oset.compare_lt_trans (OFun (E T OSymb OAggregate))).
  + apply (Oset.compare_lt_trans (OAgg (E T OSymb OAggregate))).
- (* 1/1 *)
  intros a1 a2.
  case a1; clear a1;
  (intro x1; case a2; clear a2; intro x2; simpl;
   try (discriminate || intros; apply refl_equal));
  try oset_compare_tac.
  + apply (Oset.compare_lt_gt (OFun (E T OSymb OAggregate))).
  + apply (Oset.compare_lt_gt (OAgg (E T OSymb OAggregate))).
Defined.

End Compare.

Notation equiv_env_slice := (equiv_env_slice (T := T) (OSymb := OSymb) (OAggregate := OAggregate)).
Notation equiv_env := (equiv_env (T := T) (OSymb := OSymb) (OAggregate := OAggregate)).

Ltac env_tac :=
  match goal with
    | |- equiv_env ?e ?e => apply equiv_abstract_env_refl

(* env_g *)
    | Hx : ?x1 =t= ?x2
      |- equiv_env (env_g ?e Group_Fine (?x1 :: nil))
                   (env_g ?e Group_Fine (?x2 :: nil)) =>
      constructor 2; [ | apply equiv_env_refl];
      simpl; repeat split; [ | apply compare_list_t; simpl; rewrite Hx; apply refl_equal];
      rewrite tuple_eq in Hx; apply (proj1 Hx)

    | Hx : Oeset.compare (OLTuple T) ?x1 ?x2 = Eq
      |- equiv_env (env_g ?e ?g ?x1) (env_g ?e ?g ?x2) =>
      unfold SqlCommon.env_g; constructor 2; [ | apply equiv_env_refl];
      simpl; repeat split;
      [apply env_slice_eq_1 | rewrite compare_list_t]; assumption

    | He : equiv_env ?e1 ?e2
      |- equiv_env (env_g ?e1 ?g ?x) (env_g ?e2 ?g ?x) =>
      unfold SqlCommon.env_g; constructor 2; [ | apply He];
      simpl; repeat split; trivial;
      [apply Fset.equal_refl |
       rewrite compare_list_t; apply Oeset.compare_eq_refl]

    | He : equiv_env ?e1 ?e2,
      Hx : Oeset.compare (OLTuple T) ?x1 ?x2 = Eq
      |- equiv_env (env_g ?e1 ?g ?x1) (env_g ?e2 ?g ?x2) =>
      unfold SqlCommon.env_g; constructor 2; [ | apply He];
      simpl; repeat split;
      [apply env_slice_eq_1 | rewrite compare_list_t]; assumption

(* env_t *)
    | Hx : ?x1 =t= ?x2
      |- equiv_env (env_t ?env ?x1) (env_t ?env ?x2) =>
      unfold SqlCommon.env_t; constructor 2; [ | apply equiv_env_refl];
      simpl; repeat split; [ | apply compare_list_t; simpl; rewrite Hx; trivial];
      rewrite tuple_eq in Hx; apply (proj1 Hx)

    | He : equiv_env ?e1 ?e2
      |- equiv_env (env_t ?e1 ?x) (env_t ?e2 ?x) =>
      unfold SqlCommon.env_t; constructor 2; [ | assumption];
      simpl; repeat split; [ | apply permut_refl];
      apply Fset.equal_refl

    | He : equiv_env ?env1 ?env2, Hx : ?x1 =t= ?x2
      |- equiv_env (env_t ?env1 ?x1) (env_t ?env2 ?x2) =>
      unfold SqlCommon.env_t; constructor 2; [ | assumption];
      simpl; repeat split; [ | apply compare_list_t; simpl; rewrite Hx; trivial];
      rewrite tuple_eq in Hx; apply (proj1 Hx)

(* env_t, env_g *)
    | |- equiv_env (env_t ?e ?x) (env_g ?e Group_Fine  (?x :: nil)) =>
      unfold SqlCommon.env_t, SqlCommon.env_g; constructor 2; [ | apply equiv_env_refl];
      simpl; repeat split; [ | apply permut_refl];
      apply Fset.equal_refl

    | Hx : ?x1 =t= ?x2
      |- equiv_env (env_t ?e ?x1) (env_g ?e Group_Fine (?x2 :: nil)) =>
      unfold SqlCommon.env_t, SqlCommon.env_g; constructor 2; [ | apply equiv_env_refl];
      simpl; repeat split; [ | rewrite compare_list_t; simpl; rewrite Hx; trivial];
      rewrite tuple_eq in Hx; apply (proj1 Hx)

    | He : equiv_env ?e1 ?e2, Hx : ?x1 =t= ?x2
      |- equiv_env (env_t ?e1 ?x1) (env_g ?e2 Group_Fine (?x2 :: nil)) =>
      unfold SqlCommon.env_t, SqlCommon.env_g; constructor 2; [ | apply He];
      simpl; repeat split; [ | rewrite compare_list_t; simpl; rewrite Hx; trivial];
      rewrite tuple_eq in Hx; apply (proj1 Hx)

(* env *)
    | He : equiv_env ?e1 ?e2
      |- equiv_env ((?sa1, ?g, ?x) :: ?e1) ((?sa1, ?g, ?x) :: ?e2) =>
      constructor 2; [ | assumption];
      simpl; repeat split; trivial;
      [apply Fset.equal_refl |
       rewrite compare_list_t; apply Oeset.compare_eq_refl]

    |  Hx : Oeset.compare (OLTuple T) ?x1 ?x2 = Eq
      |- equiv_env ((?sa1, ?g, ?x1) :: ?e1) ((?sa1, ?g, ?x2) :: ?e1) =>
       constructor 2; [ | apply equiv_env_refl];
       simpl; repeat split; [apply Fset.equal_refl | rewrite compare_list_t; assumption]

    |  Hx : Oeset.compare (OTuple T) ?x1 ?x2 = Eq
      |- equiv_env ((?sa, ?g, ?x1 :: nil) :: ?e) ((?sa, ?g, ?x2 :: ?nil) :: ?e) =>
       constructor 2; [ | apply equiv_env_refl];
       simpl; repeat split;
       [apply Fset.equal_refl | rewrite compare_list_t; simpl; rewrite Hx; trivial]

    | He : equiv_env ?e1 ?e2,
           Hx : Oeset.compare (OLTuple T) ?x1 ?x2 = Eq
      |- equiv_env ((?sa1, ?g, ?x1) :: ?e1) ((?sa1, ?g, ?x2) :: ?e2) =>
      constructor 2; [ | apply He];
      simpl; repeat split;
      [apply Fset.equal_refl | rewrite compare_list_t; assumption]

    | He : equiv_env ?e1 ?e2,
           Hx : Oeset.compare (OTuple T) ?x1 ?x2 = Eq
      |- equiv_env ((?sa, ?g, ?x1 :: nil) :: ?e1) ((?sa, ?g, ?x2 :: ?nil) :: ?e2) =>
      constructor 2; [ | apply He];
      simpl; repeat split;
      [apply Fset.equal_refl
      | rewrite compare_list_t; simpl; rewrite Hx; trivial]

    | He : equiv_env ?e1 ?e2,
           Hx : Oeset.compare (OLTuple T) ?x1 ?x2 = Eq
      |- equiv_env ((?sa, ?g, ?x1) :: ?e1) (((?sa unionS (emptysetS)), ?g, ?x2) :: ?e2) =>
      constructor 2; [ | apply He];
      simpl; repeat split;
      [ rewrite Fset.equal_spec; intro a;
        rewrite Fset.mem_union, Fset.empty_spec, Bool.orb_false_r; apply refl_equal
      | apply compare_list_t; trivial]

    | _ => fail
  end.

Lemma eval_query_eq_etc :
  forall n,
    (forall q,
       tree_size (tree_of_query q) <= n ->
       forall env1 env2, equiv_env env1 env2 ->
                         eval_query env1 q =BE= eval_query env2 q) /\

    (forall f,
       tree_size (tree_of_formula f) <= n ->
       forall env1 env2, equiv_env env1 env2 ->
                         eval_formula env1 f = eval_formula env2 f).
Proof.
intro n; induction n as [ | n]; repeat split.
- intros q Hn; destruct q; inversion Hn.
- intros f Hn; destruct f; inversion Hn.
  destruct q; inversion Hn.
- intros q Hn env1 env2 He; destruct q as [(*sa |*) | r | o q1 q2 | q1 q2 | s q | f q | g f s q];
  rewrite Febag.nb_occ_equal; intro t.
(*  + apply refl_equal. *)
  + apply refl_equal.
  + apply refl_equal.
  + rewrite 2 (eval_query_unfold _ (Q_Set _ _ _)).
    assert (IH1 : eval_query env1 q1 =BE= eval_query env2 q1).
    {
      apply (proj1 IHn); [ | assumption].
      rewrite tree_of_query_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      apply le_plus_l.
    }
    assert (IH2 : eval_query env1 q2 =BE= eval_query env2 q2).
    {
      apply (proj1 IHn); [ | assumption].
      rewrite tree_of_query_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      refine (le_trans _ _ _ _ (le_plus_r _ _)).
      apply le_plus_l.
    }
    rewrite Febag.nb_occ_equal in IH1, IH2.
    case (sort q1 =S?= sort q2); [ | apply refl_equal].
    destruct o; simpl.
    * rewrite 2 Febag.nb_occ_union, IH1, IH2; apply refl_equal.
    * rewrite 2 Febag.nb_occ_union_max, IH1, IH2; apply refl_equal.
    * rewrite 2 Febag.nb_occ_inter, IH1, IH2; apply refl_equal.
    * rewrite 2 Febag.nb_occ_diff, IH1, IH2; apply refl_equal.
  + rewrite 2 (eval_query_unfold _ (Q_Join _ _)).
    assert (IH1 : eval_query env1 q1 =BE= eval_query env2 q1).
    {
      apply (proj1 IHn); [ | assumption].
      rewrite tree_of_query_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      apply le_plus_l.
    }
    assert (IH2 : eval_query env1 q2 =BE= eval_query env2 q2).
    {
      apply (proj1 IHn); [ | assumption].
      rewrite tree_of_query_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      refine (le_trans _ _ _ _ (le_plus_r _ _)).
      apply le_plus_l.
    }
    rewrite Febag.nb_occ_equal in IH1, IH2.
    rewrite 2 Febag.nb_occ_mk_bag; unfold Data.natural_join_list.
    rewrite 2 Data.nb_occ_theta_join_list; simpl Data.projection; simpl Data.combine; simpl Data.compatible.
    apply f_equal; apply _permut_size with (fun x y => x =t= y).
    * intros a1 a2 Ha1 Ha2 Ha.
      do 2 (rewrite (Oeset.compare_eq_2 _ _ _ _ (mk_tuple_id T _ _ _ (Fset.equal_refl _ _))),
              Oeset.compare_eq_refl, Nat.mul_1_l).
      {
        apply _permut_size with (fun x y => x =t= y).
        - intros b1 b2 Hb1 Hb2 Hb.
          rewrite <- (join_compatible_tuple_eq _ _ _ _ _ Ha Hb).
          rewrite <- (Oeset.compare_eq_1 _ _ _ _ (join_tuple_eq _ base.nullval base.nullval _ _ _ _ Ha Hb)).
          apply refl_equal.
        - apply permut_refl_alt; apply Febag.elements_spec1; rewrite Febag.nb_occ_equal.
          apply IH2.
      }
    * apply permut_refl_alt; apply Febag.elements_spec1; rewrite Febag.nb_occ_equal.
      apply IH1.
  + rewrite 2 (eval_query_unfold _ (Q_Pi _ _)).
    assert (IH : eval_query env1 q =BE= eval_query env2 q).
    {
      apply (proj1 IHn); [ | assumption].
      rewrite tree_of_query_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      apply le_S.
      refine (le_trans _ _ _ _ (le_plus_r _ _)).
      apply le_plus_l.
    }
    unfold Febag.map; rewrite 2 Febag.nb_occ_mk_bag.
    apply (Oeset.nb_occ_map_eq_2_3 (OTuple T)).
    * intros x1 x2 Hx; apply projection_eq; env_tac.
    * intro x; apply permut_nb_occ.
      apply permut_refl_alt; apply Febag.elements_spec1; apply IH.
  + rewrite 2 (eval_query_unfold _ (Q_Sigma _ _)).
    assert (IHq : eval_query env1 q =BE= eval_query env2 q).
    {
      apply (proj1 IHn); [ | assumption].
      rewrite tree_of_query_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      refine (le_trans _ _ _ _ (le_plus_r _ _)).
      apply le_plus_l.
    }
    assert (IHf : forall env1 env2, equiv_env env1 env2 ->
                                    eval_formula env1 f = eval_formula env2 f).
    {
      apply (proj2 IHn).
      rewrite tree_of_query_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      apply le_plus_l.
    }
    rewrite 2 Febag.nb_occ_filter.
    * {
        apply f_equal2.
        - rewrite Febag.nb_occ_equal in IHq; apply IHq.
        - apply if_eq; [ | intros; apply refl_equal | intros; apply refl_equal].
          apply IHf; env_tac.
      }
    * intros u1 u2 _ Hu; apply IHf; env_tac.
    * intros u1 u2 _ Hu; apply IHf; env_tac.
  + rewrite 2 (eval_query_unfold _ (Q_Gamma _ _ _ _)).
    rewrite 2 Febag.nb_occ_mk_bag.
    apply (Oeset.nb_occ_map_eq_2_3 (OLTuple T)).
    * intros l1 l2 Hl; apply projection_eq; env_tac.
    * {
        intro l; rewrite 2 Oeset.nb_occ_filter.
        - apply if_eq.
          + apply (proj2 IHn).
            * rewrite tree_of_query_unfold in Hn; simpl in Hn.
              refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
              apply le_plus_l.
            * env_tac.
          + intro Hl; unfold make_groups.
            apply permut_nb_occ; apply permut_refl_alt; apply partition_list_expr_eq_alt.
            * clear Hn Hl.
              induction g as [ | x1 g]; [constructor 1 | constructor 2; [ | apply IHg]].
              intros y1 y2 Hy; apply interp_funterm_eq; env_tac.
            * apply permut_refl_alt; apply Febag.elements_spec1.
              apply (proj1 IHn); [ | assumption].
              rewrite tree_of_query_unfold in Hn; simpl in Hn.
              refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
              refine (le_trans _ _ _ _ (le_plus_r _ _)).
              apply le_S.
              refine (le_trans _ _ _ _ (le_plus_r _ _)).
              apply le_plus_l.
          + intros; apply refl_equal.
        - intros x1 x2 _ Hx; apply (proj2 IHn).
          + rewrite tree_of_query_unfold in Hn; simpl in Hn.
            refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
            apply le_plus_l.
          + env_tac.
        - intros x1 x2 _ Hx; apply (proj2 IHn).
          + rewrite tree_of_query_unfold in Hn; simpl in Hn.
            refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
            apply le_plus_l.
          + env_tac.
      }
- intros f Hn env1 env2 He.
  destruct f as [a f1 f2 | f | [ | p l | qtf p l q | s q | q]].
  + assert (IHf1 : forall env1 env2, equiv_env env1 env2 ->
                                    eval_formula env1 f1 = eval_formula env2 f1).
    {
      apply (proj2 IHn).
      rewrite tree_of_formula_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      apply le_plus_l.
    }
    assert (IHf2 : forall env1 env2, equiv_env env1 env2 ->
                                    eval_formula env1 f2 = eval_formula env2 f2).
    {
      apply (proj2 IHn).
      rewrite tree_of_formula_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      refine (le_trans _ _ _ _ (le_plus_r _ _)).
      apply le_plus_l.
    }
    rewrite 2 (eval_formula_unfold _ (Q_Conj _ _ _)).
    destruct a; (apply f_equal2; [apply IHf1 | apply IHf2]; assumption).
  + rewrite 2 (eval_formula_unfold _ (Q_Not _)); apply f_equal.
    apply (proj2 IHn); [ | assumption].
    rewrite tree_of_formula_unfold in Hn; simpl in Hn.
    refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
    apply le_plus_l.
  + apply refl_equal.
  + rewrite 2 (eval_formula_unfold _ (Q_Atom _)), 2 eval_q_atom_unfold.
    apply f_equal; rewrite <- map_eq.
    intros; apply interp_aggterm_eq; assumption.
  + rewrite 2 (eval_formula_unfold _ (Q_Atom _)), 2 eval_q_atom_unfold.
    apply (Formula.interp_quant_eq (OTuple T)).
    * intro a; rewrite <- 2 Febag.mem_unfold.
      apply Febag.mem_eq_2.
      apply (proj1 IHn); [ | assumption].
      rewrite tree_of_formula_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      apply le_S; apply le_plus_l.
    * intros x1 x2 Hx1 Hx; apply f_equal.
      {
        apply f_equal2.
        - rewrite <- map_eq.
          intros a Ha; apply interp_aggterm_eq; assumption.
        - rewrite tuple_eq in Hx.
          rewrite <- (Fset.elements_spec1 _ _ _ (proj1 Hx)), <- map_eq.
          intros; apply (proj2 Hx).
      }
  + rewrite 2 (eval_formula_unfold _ (Q_Atom _)), 2 eval_q_atom_unfold.
    apply Febag.mem_eq.
    * apply (proj1 IHn); [ | assumption].
      rewrite tree_of_formula_unfold in Hn; simpl in Hn.
      refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
      apply le_plus_l.
    * apply projection_eq; assumption.
  + rewrite 2 (eval_formula_unfold _ (Q_Atom _)), 2 eval_q_atom_unfold.
    apply f_equal.
    rewrite 2 Febag.is_empty_spec.
    apply Febag.equal_eq_1.
    apply (proj1 IHn); [ | assumption].
    rewrite tree_of_formula_unfold in Hn; simpl in Hn.
    refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
    apply le_plus_l.
Qed.

Lemma eval_query_eq :
  forall q env1 env2, equiv_env env1 env2 -> eval_query env1 q =BE= eval_query env2 q.
Proof.
intros q env1 env2 He.
apply (proj1 (eval_query_eq_etc _) _ (le_n _) _ _ He).
Qed.

Lemma eval_formula_eq :
  forall f env1 env2, equiv_env env1 env2 -> eval_formula env1 f = eval_formula env2 f.
Proof.
intros f env1 env2 He.
apply (proj2 (eval_query_eq_etc _) _ (le_n _) _ _ He).
Qed.

Require Import HighLevelSpec.
Notation "b '=R=' l" :=
  (forall t, Febag.nb_occ BTupleT t b = Oeset.nb_occ (OTuple T) t l) (at level 70, no associativity).

Lemma Q_Sigma_is_a_filter_op :
  forall env f,
    is_a_filter_op
      (OTuple T)
      (fun q => Febag.elements BTupleT (eval_query env q))
      (fun q => Febag.elements BTupleT (eval_query env q))
      (fun t => eval_formula (env_t env t) f)
      (fun q => Q_Sigma f q).
Proof.
intros env f q t.
rewrite <- 2 Febag.nb_occ_elements, eval_query_unfold, Febag.nb_occ_filter.
- apply refl_equal.
- intros; apply eval_formula_eq; env_tac.
Qed.

Lemma Q_Sigma_is_computable_by_any_filter_op :
  forall (bagA bagA' : Type)
         (elementsA : bagA -> list (tuple T)) (elementsA' : bagA' -> list (tuple T))
         flt env f q,
    let eval_f := fun t => eval_formula (env_t env t) f in
    is_a_filter_op (OTuple T) elementsA elementsA' eval_f flt ->
    forall q', eval_query env q =R= elementsA q' ->
      eval_query env (Q_Sigma f q) =R= elementsA' (flt q').
Proof.
intros bagA bagA' elementsA elementsA' flt env f q eval_f HH cursor_q Hq' t.
unfold is_a_filter_op in HH.
rewrite eval_query_unfold, Febag.nb_occ_filter, Hq', HH.
- unfold eval_f; apply refl_equal.
- intros u1 u2 _ Hu; apply eval_formula_eq; env_tac.
Qed.

Lemma Q_Pi_is_a_map_op :
  forall env s,
    let eval_s t := projection_ (env_t env t) (Select_List s) base.nullval in
    let Q_Pi_s q := Q_Pi s q in
    is_a_map_op
      (OTuple T)
      (fun q => Febag.elements BTupleT (eval_query env q))
      (fun q => Febag.elements BTupleT (eval_query env q))
      eval_s Q_Pi_s.
Proof.
intros env s eval_s Q_Pi_s.
unfold Q_Pi_s, eval_s.
intros q t.
rewrite <- Febag.nb_occ_elements, eval_query_unfold.
unfold Febag.map; rewrite Febag.nb_occ_mk_bag. apply refl_equal.
Qed.

Lemma Q_Join_is_a_join_op :
  forall env s1 s2,
    let Q_Join q1 q2 := Q_Join q1 q2 in
    is_a_join_op
      (OTuple T) (OTuple T) (OTuple T)
      (fun q => Febag.elements BTupleT (eval_query env q))
      (fun q => Febag.elements BTupleT (eval_query env q))
      (fun q => Febag.elements BTupleT (eval_query env q))
      (A T)
      (support T)
      (support T)
      (support T)
      (fun t => mk_tuple T s1 (dot T t) base.nullval)
      (fun t => mk_tuple T s2 (dot T t) base.nullval) s1 s2 Q_Join.
Proof.
intros env s1 s2 Q_Join.
rewrite is_a_join_op_is_a_join_op_alt.
unfold is_a_join_op_alt, Q_Join; intros q1 q2 Hq1 Hq2.
rewrite eval_query_unfold; intro t.
rewrite <- Febag.nb_occ_elements, Febag.nb_occ_mk_bag.
rewrite (Data.nb_occ_natural_join_list _ _ (build_data T)
           (Febag.elements BTupleT (eval_query env q1))
           (Febag.elements BTupleT (eval_query env q2)) s1 s2).
- apply refl_equal.
- intros t1 Ht1; simpl.
  apply Hq1.
  rewrite <- Oeset.nb_occ_diff_0_pos.
  apply Oeset.mem_nb_occ.
  rewrite <- Febag.mem_unfold; apply Febag.in_elements_mem; assumption.
- intros t12 Ht2; simpl.
  apply Hq2.
  rewrite <- Oeset.nb_occ_diff_0_pos.
  apply Oeset.mem_nb_occ.
  rewrite <- Febag.mem_unfold; apply Febag.in_elements_mem; assumption.
Qed.

Lemma Q_Join_is_computable_by_any_join_op :
  forall (bagA1 bagA2 bagA : Type)
         (elementsA1 : bagA1 -> list (tuple T))
         (elementsA2 : bagA2 -> list (tuple T))
         (elementsA : bagA -> list (tuple T))
         j env q1 q2,
    is_a_join_op
      (OTuple T) (OTuple T) (OTuple T)
      elementsA1 elementsA2 elementsA _
      (support T)
      (support T)
      (support T)
      (fun t => mk_tuple T (sort q1) (dot T t) base.nullval)
      (fun t => mk_tuple T (sort q2) (dot T t) base.nullval) (sort q1) (sort q2) j ->
    let eval_q1 := eval_query env q1 in
    let eval_q2 := eval_query env q2 in
    (forall t1, t1 inBE eval_q1 -> support T t1 =S= sort q1) ->
    (forall t2, t2 inBE eval_q2 -> support T t2 =S= sort q2) ->
    forall q1', eval_query env q1 =R= elementsA1 q1' ->
    forall q2', eval_query env q2 =R= elementsA2 q2' ->
    eval_query env (Q_Join q1 q2) =R= elementsA (j q1' q2').
Proof.
intros bagA1 bagA2 bagA elementsA1 elementsA2 elementsA
       j env q1 q2 H eval_q1 eval_q2 H1 H2 q1' Hq1 q2' Hq2.
rewrite is_a_join_op_is_a_join_op_alt in H.
unfold is_a_join_op_alt in H.
rewrite eval_query_unfold; intro t.
rewrite Febag.nb_occ_mk_bag.
rewrite (Data.nb_occ_natural_join_list _ _ (build_data T)
           (Febag.elements BTupleT (eval_query env q1))
           (Febag.elements BTupleT (eval_query env q2)) (sort q1) (sort q2)).
- rewrite <- 2 Febag.nb_occ_elements, Hq1, Hq2, H.
  + apply refl_equal.
  + intros t1 Ht1; apply H1.
    apply Febag.nb_occ_mem; rewrite Hq1.
    rewrite Oeset.nb_occ_diff_0_pos; assumption.
  + intros t2 Ht2; apply H2; apply Febag.nb_occ_mem; rewrite Hq2.
    rewrite Oeset.nb_occ_diff_0_pos; assumption.
- intros t1 Ht1; apply H1; apply Febag.in_elements_mem; assumption.
- intros t2 Ht2; apply H2; apply Febag.in_elements_mem; assumption.
Qed.

Lemma Q_Sigma_Join_is_computable_by_any_filter_join_op :
  forall (bagA1 bagA2 bagA : Type)
         (elementsA1 : bagA1 -> list (tuple T))
         (elementsA2 : bagA2 -> list (tuple T))
         (elementsA : bagA -> list (tuple T))
         j env f q1 q2,

    let eval_f := fun t => eval_formula (env_t env t) f in
    is_a_filter_join_op
      (OTuple T) (OTuple T) (OTuple T)
      elementsA1 elementsA2 elementsA _
      (support T)
      (support T)
      (support T)
      (fun t => mk_tuple T (sort q1) (dot T t) base.nullval)
      (fun t => mk_tuple T (sort q2) (dot T t) base.nullval) eval_f (sort q1) (sort q2) j ->
    let eval_q1 := eval_query env q1 in
    let eval_q2 := eval_query env q2 in
    (forall t1, t1 inBE eval_q1 -> support T t1 =S= sort q1) ->
    (forall t2, t2 inBE eval_q2 -> support T t2 =S= sort q2) ->
    forall q1', eval_query env q1 =R= elementsA1 q1' ->
    forall q2', eval_query env q2 =R= elementsA2 q2' ->
    eval_query env (Q_Sigma f (Q_Join q1 q2)) =R= elementsA (j q1' q2').
Proof.
intros bagA1 bagA2 bagA elementsA1 elementsA2 elementsA
       j env f q1 q2 eval_f H eval_q1 eval_q2 H1 H2 q1' Hq1 q2' Hq2.
unfold is_a_filter_join_op in H.
assert (H' :  (forall t : tuple T,
       0 < Oeset.nb_occ (OTuple T) t (elementsA (j q1' q2')) ->
       support T t =S= (sort q1 unionS sort q2)) /\
      (forall t : tuple T,
       support T t =S= (sort q1 unionS sort q2) ->
       Oeset.nb_occ (OTuple T) t (elementsA (j q1' q2')) =
       Oeset.nb_occ (OTuple T) (mk_tuple T (sort q1) (dot T t) base.nullval) (elementsA1 q1') *
       Oeset.nb_occ (OTuple T) (mk_tuple T (sort q2) (dot T t) base.nullval) (elementsA2 q2') *
       (if eval_f t then 1 else 0))).
{
  apply H.
  - intros t Ht; apply H1.
    apply Febag.nb_occ_mem; rewrite Hq1.
    rewrite Oeset.nb_occ_diff_0_pos; assumption.
  - intros t Ht; apply H2.
    apply Febag.nb_occ_mem; rewrite Hq2.
    rewrite Oeset.nb_occ_diff_0_pos; assumption.
}
rewrite eval_query_unfold; intro t.
rewrite Febag.nb_occ_filter; [ | intros; apply eval_formula_eq; env_tac].
case_eq (support T t =S?= (sort q1 unionS sort q2)); intro Ht.
- rewrite (proj2 H' _ Ht), eval_query_unfold.
  rewrite Febag.nb_occ_mk_bag.
  rewrite (Data.nb_occ_natural_join_list _ _ (build_data T)
             (Febag.elements BTupleT (eval_query env q1))
             (Febag.elements BTupleT (eval_query env q2)) (sort q1) (sort q2)).
  + simpl Data.projection; simpl Data.support; simpl Data.att; simpl Data.OAtt; simpl Data.FAtt.
    rewrite Ht, N.mul_1_r.
    apply f_equal2; [ | apply refl_equal].
    rewrite <- 2 Febag.nb_occ_elements, Hq1, Hq2; apply refl_equal.
  + intros t1 Ht1; apply H1.
    rewrite Febag.mem_unfold; apply Oeset.in_mem_bool; apply Ht1.
  + intros t2 Ht2; apply H2.
    rewrite Febag.mem_unfold; apply Oeset.in_mem_bool; apply Ht2.
- assert (Kt : Oeset.nb_occ (OTuple T) t (elementsA (j q1' q2')) = 0).
  {
    case_eq (Oeset.nb_occ (OTuple T) t (elementsA (j q1' q2'))); [trivial | ].
    intros p Hp; rewrite (proj1 H') in Ht; [discriminate Ht | ].
    rewrite Hp; unfold N.lt; apply refl_equal.
  }
  rewrite Kt.
  case_eq (Febag.nb_occ BTupleT t (eval_query env (Q_Join q1 q2))).
  + intros; rewrite N.mul_0_l; trivial.
  + intros p Hp.
    assert (Jt : t inBE (eval_query env (Q_Join q1 q2))).
    {
     rewrite Febag.mem_unfold.
     apply Oeset.nb_occ_mem; rewrite <- Febag.nb_occ_elements, Hp.
     discriminate.
    }
    rewrite eval_query_unfold, Data.natural_join_list_unfold in Jt.
    rewrite Febag.mem_mk_bag, Oeset.mem_bool_true_iff in Jt.
    destruct Jt as [t' [Jt Ht']]; rewrite Data.theta_join_list_unfold in Ht'.
    rewrite in_flat_map in Ht'.
    destruct Ht' as [t1 [Ht1 Ht']]; unfold Data.d_join_list in Ht'.
    rewrite in_map_iff in Ht'.
    destruct Ht' as [t2 [Ht' Ht2]].
    rewrite filter_In in Ht2.
    destruct Ht2 as [Ht2 H12].
    rewrite tuple_eq in Jt; rewrite (Fset.equal_eq_1 _ _ _ _ (proj1 Jt)) in Ht.
    subst t'; unfold join_tuple in Ht; simpl in Ht; unfold join_tuple in Ht.
    rewrite (Fset.equal_eq_1 _ _ _ _ (support_mk_tuple _ _ _ _)) in Ht.
    assert (Abs : (support T t1 unionS support T t2) =S= (sort q1 unionS sort q2)).
    {
      apply Fset.union_eq.
      - apply H1; apply Febag.in_elements_mem; assumption.
      - apply H2; apply Febag.in_elements_mem; assumption.
    }
    rewrite Abs in Ht; discriminate Ht.
Qed.

Lemma Q_Gamma_is_a_grouping_op :
  forall env g f s ,
    let eval_s l := projection_ (env_g env (Group_By g) l) (Select_List s) base.nullval in
    let eval_f l := eval_formula (env_g env (Group_By g) l) f in
    let mk_grp g q :=
        partition_list_expr
          (FVal T) (Febag.elements _ (eval_query env q))
          (map (fun f t => SqlCommon.interp_funterm_ interp_symb (SqlCommon.env_t env t) f) g) in
    let Q_Gamma g f s q := eval_query env (Q_Gamma g f s q) in
    is_a_grouping_op
      (OTuple T)
      (Febag.elements BTupleT) mk_grp g eval_f eval_s (Q_Gamma g f s).
Proof.
intros env g f s eval_s eval_f mk_grp Q_Gamma q t.
unfold Q_Gamma; rewrite eval_query_unfold, <- Febag.nb_occ_elements, Febag.nb_occ_mk_bag.
unfold eval_s, eval_f, mk_grp, make_groups.
apply refl_equal.
Qed.

Lemma Q_Gamma_is_computable_by_any_group_op :
  forall (bagA bagA': Type)
         (elementsA : bagA -> list (tuple T))
         (elementsA' : bagA' -> list (tuple T))
         grp env g f s q,
    let eval_f l := eval_formula (env_g env (Group_By g) l) f in
    let eval_s l := projection_ (env_g env (Group_By g) l) (Select_List s) base.nullval in
    let mk_grp g l := make_groups interp_symb env (elementsA l) (Group_By g) in
    is_a_grouping_op (OTuple T) elementsA' mk_grp g eval_f eval_s grp ->
    forall q', eval_query env q =R= elementsA q' ->
               eval_query env (Q_Gamma g f s q) =R= elementsA' (grp q').
Proof.
intros bagA bagA' elementsA elementsA' grp env g f s q eval_f eval_s mk_grp H q' Hq t.
rewrite eval_query_unfold, H, Febag.nb_occ_mk_bag.
unfold eval_s, eval_f, mk_grp.
apply (Oeset.nb_occ_map_eq_2_3 (OLTuple T)).
- intros l1 l2 Hl; apply projection_eq; env_tac.
- intro l; rewrite 2 Oeset.nb_occ_filter.
  + apply if_eq; trivial.
    intros _.
    apply permut_nb_occ; apply permut_refl_alt; apply partition_list_expr_eq_alt.
    * clear eval_f eval_s mk_grp H.
      induction g as [ | fe g]; simpl; [constructor 1 | constructor 2; [ | apply IHg]].
      intros x y _H.
      apply interp_funterm_eq; env_tac.
    * apply nb_occ_permut; intro x.
      rewrite <- Hq, Febag.nb_occ_elements; apply refl_equal.
  + intros; apply eval_formula_eq; env_tac.
  + intros; apply eval_formula_eq; env_tac.
Qed.

Lemma eval_f_eq :
  forall env f,
    let eval_f := fun t => eval_formula (env_t env t) f in
    forall t1 t2, t1 =t= t2 -> eval_f t1 = eval_f t2.
Proof.
intros env f eval_f t1 t2 Ht; unfold eval_f.
apply eval_formula_eq; env_tac.
Qed.

End Sec.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype path.
From fcsl
Require Import ordtype unionmap.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(************************************************************)
(******************* <parameters> ***************************)
(************************************************************)
Module Type Types.
Parameter Timestamp : Set.
Parameter Hash : Set.
Parameter VProof : Set.
Parameter Transaction : Set.

(* These need to be types that can be coerced into ordType *)
Axiom Hash_eqMixin : Equality.mixin_of Hash.
Canonical Hash_eqType := Eval hnf in EqType Hash Hash_eqMixin.
Axiom Hash_ordMixin : Ordered.mixin_of Hash_eqType.
Canonical Hash_ordType := Eval hnf in OrdType Hash Hash_ordMixin.

Axiom VProof_eqMixin : Equality.mixin_of VProof.
Canonical VProof_eqType := Eval hnf in EqType VProof VProof_eqMixin.
Axiom VProof_ordMixin : Ordered.mixin_of VProof_eqType.
Canonical VProof_ordType := Eval hnf in OrdType VProof VProof_ordMixin.

Axiom Transaction_eqMixin : Equality.mixin_of Transaction.
Canonical Transaction_eqType := Eval hnf in EqType Transaction Transaction_eqMixin.
Axiom Transaction_ordMixin : Ordered.mixin_of Transaction_eqType.
Canonical Transaction_ordType := Eval hnf in OrdType Transaction Transaction_ordMixin.

Record Block  :=
  mkB {
    prevBlockHash : Hash;
    txs : seq Transaction;
    proof : VProof;
  }.

Definition eq_block b b':=
  match b, b' with
  | mkB p t pf, mkB p' t' pf' =>
    [&& p == p', t == t' & pf == pf']
  end.

Lemma eq_blockP : Equality.axiom eq_block.
Proof.
case=> p t pf; case=> p' t' pf'; rewrite /eq_block/=.
case H2: (p == p'); [move/eqP: H2=>?; subst p'| constructor 2];
  last by case=>?; subst p';rewrite eqxx in H2.
case H3: (t == t'); [move/eqP: H3=>?; subst t'| constructor 2];
  last by case=>?; subst t';rewrite eqxx in H3.
case H4: (pf == pf'); [move/eqP: H4=>?; subst pf'| constructor 2];
  last by case=>?; subst pf';rewrite eqxx in H4.
by constructor 1.
Qed.

Canonical Block_eqMixin := Eval hnf in EqMixin eq_blockP.
Canonical Block_eqType := Eval hnf in EqType Block Block_eqMixin.

Definition block := Block.
Definition Blockchain := seq block.

Definition TxPool := seq Transaction.
Definition BlockTree := union_map [ordType of Hash] block.
End Types.


Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Strings.String.
Require Import Coq.ZArith.BinInt.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.StringOperations.
Require Import Fiat.Common.StringFacts.
Require Import Fiat.Common.
Require Import Fiat.Parsers.ExtrOcamlPrimitives.
Require Import Fiat.Parsers.StringLike.Core.

Import Fiat.Parsers.ExtrOcamlPrimitives.Ocaml.

Local Ltac t' :=
  idtac;
  match goal with
    | _ => intro
    | _ => congruence
    | [ |- _ = _ ] => reflexivity
    | [ |- is_true true ] => reflexivity
    | [ |- is_true false ] => exfalso
    | _ => progress autorewrite with ocaml in *
    | [ s : Ocaml.string |- _ ] => generalize dependent (Ocaml.explode s); clear s
    | [ |- Coq.Strings.String.get _ (string_of_list _) = List.nth_error _ _ ]
      => apply get_string_of_list
    | _ => progress simpl in *
    | _ => progress subst
    | [ H : context[string_eq_dec ?x ?y] |- _ ] => destruct (string_eq_dec x y)
    | [ H : context[ascii_eq_dec ?x ?y] |- _ ] => destruct (ascii_eq_dec x y)
    | [ H : Coq.Strings.String.String _ _ = Coq.Strings.String.String _ _ |- _ ] => inversion H; clear H
    | [ H : is_true false |- _ ] => exfalso; clear -H; hnf in H; discriminate
    | _ => progress unfold beq in *
    | _ => rewrite string_dec_refl
    | [ |- RelationClasses.Equivalence _ ] => split
    | [ H : Coq.Strings.String.length ?s = 0 |- _ ] => atomic s; destruct s
    | _ => exfalso; congruence
    | _ => rewrite substring_length
    | _ => rewrite <- plus_n_O
    | _ => rewrite <- Minus.minus_n_O
    | _ => rewrite Min.min_l by omega
    | _ => rewrite Min.min_r by omega
    | _ => rewrite substring_correct3 by assumption
    | _ => rewrite substring_substring
    | _ => rewrite substring_correct3'
    | _ => rewrite substring_correct0
    | _ => rewrite Nat.sub_min_distr_l
    | _ => rewrite Nat.add_sub
    | _ => rewrite Min.min_0_r
    | _ => rewrite Min.min_0_l
    | _ => rewrite Nat.add_1_r
    | _ => rewrite <- Min.min_assoc
    | [ |- String.get _ _ = _ ] => apply StringProperties.get_correct
    | _ => progress rewrite ?string_beq_correct, ?ascii_beq_correct
    | [ H : _ |- _ ] => progress rewrite ?string_beq_correct, ?ascii_beq_correct in H
    | [ |- context[min ?m (?m - ?n)] ]
      => replace (min m (m - n)) with (m - max 0 n)
        by (rewrite <- Nat.sub_min_distr_l; apply f_equal2; omega)
    | [ |- context[min (?m + ?n) ?m] ]
      => replace (min (m + n) m) with (m + min n 0)
        by (rewrite <- Min.plus_min_distr_l; apply f_equal2; omega)
    | _ => rewrite Min.min_comm; reflexivity
    | [ |- context[string_eq_dec ?x ?y] ] => destruct (string_eq_dec x y)
    | [ H : _ <> _ |- False ] => apply H; clear H
    | _ => apply Max.max_case_strong; intro; apply substring_correct4; omega
    | [ H : Coq.Strings.String.length ?s = 1 |- _ ] => is_var s; destruct s
    | [ H : S (Coq.Strings.String.length ?s) = 1 |- _ ] => is_var s; destruct s
    | _ => eexists; rewrite (ascii_lb eq_refl); reflexivity
    | [ |- _ <-> _ ] => split
    | [ H : Coq.Strings.String.get 0 ?s = _ |- _ ] => is_var s; destruct s
    | [ |- Coq.Strings.String.get 0 ?s = _ ] => is_var s; destruct s
    | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
    | [ |- context[Coq.Strings.String.get ?p (Coq.Strings.String.substring _ ?m _)] ]
      => destruct (Compare_dec.lt_dec p m);
        [ rewrite substring_correct1 by omega
        | rewrite substring_correct2 by omega ]
    | _ => rewrite <- substring_correct3'; apply substring_correct2; omega
    | [ H : forall n, Coq.Strings.String.get n _ = Coq.Strings.String.get n _ |- _ ] => apply get_correct in H
    | [ H : EqNat.beq_nat _ _ = true |- _ ] => apply EqNat.beq_nat_true in H
    | [ H : EqNat.beq_nat _ _ = false |- _ ] => apply EqNat.beq_nat_false in H
    | [ H : context[EqNat.beq_nat ?x ?y] |- _ ] => destruct (EqNat.beq_nat x y) eqn:?
    | [ H : context[option_beq ascii_beq _ _] |- _ ] => rewrite (option_beq_correct (@ascii_bl) (@ascii_lb)) in H
    | [ H : context[option_eq_dec ?beq ?bl ?lb ?x ?y] |- _ ] => destruct (option_eq_dec beq bl lb x y)
    | _ => progress change (andb true) with (fun x : bool => x) in *
    | _ => progress cbv beta in *
    | _ => progress simpl in *
    | [ H : ?x = 1 |- context[?x] ] => rewrite H
    | _ => progress unfold beq in *
    | [ |- context[option_beq ?beq ?x (Some _)] ] => destruct x eqn:?
    | _ => progress unfold is_true in *
    | [ |- context[ascii_eq_dec ?x ?y] ] => destruct (ascii_eq_dec x y)
    | [ |- Zbool.Zeq_bool _ _ = _ ] => apply Zbool.Zeq_is_eq_bool
    | [ H : Zbool.Zeq_bool _ _ = _ |- _ ] => apply Zbool.Zeq_is_eq_bool in H
    | [ |- ?x = ?y :> Ocaml.string ]
      => cut (Ocaml.implode (Ocaml.explode x) = Ocaml.implode (Ocaml.explode y));
        [ autorewrite with ocaml; exact (fun z => z)
        | apply f_equal ]
    | [ H : context[String.get ?s ?n], H' : Strings.String.get ?n (Ocaml.explode ?s) = Some _ |- _ ]
      => rewrite (proj2 (@StringProperties.get_correct s n _) H') in H
    | [ H' : Strings.String.get ?n (Ocaml.explode ?s) = Some _ |- context[String.get ?s ?n] ]
      => rewrite (proj2 (@StringProperties.get_correct s n _) H')
    | [ H : forall n, String.safe_get ?str n = String.safe_get ?str' n |- _ ]
      => assert (forall n, Coq.Strings.String.get n (Ocaml.explode str) = Coq.Strings.String.get n (Ocaml.explode str'))
        by (intro n; specialize (H n); autorewrite with ocaml in H; exact H);
        clear H
    | [ |- String.substring ?n ?m ?s = String.substring ?n ?m' ?s ]
      => not constr_eq m m'; replace m with m' by omega
    | [ |- String.substring ?n ?m ?s = String.substring ?n ?m' ?s ]
      => not constr_eq m m'; replace m with m' by (repeat apply Min.min_case_strong; intros; omega)
  end.

Local Ltac t := repeat t'.

Module Export Ocaml.
  Global Instance string_stringlikemin : StringLikeMin Ascii.ascii
    := { String := Ocaml.string;
         length := String.length;
         unsafe_get n s := String.get s n;
         char_at_matches n str P := P (String.get str n) }.

  Global Instance string_stringlike : StringLike Ascii.ascii
    := { get n s := String.safe_get s n;
         take n s := String.sub s 0 n;
         drop n s := String.sub s n (String.length s - n);
         is_char s ch := ((EqNat.beq_nat (String.length s) 1)
                            && (option_beq ascii_beq (String.safe_get s 0) (Some ch)))%bool;
         bool_eq s1 s2 := Zbool.Zeq_bool (z_of_int (Ocaml.String.compare s1 s2)) 0%Z }.

  Global Instance string_stringiso : StringIso Ascii.ascii
    := { of_string s := Ocaml.implode (string_of_list s) }.

  Global Instance string_stringlike_properties : StringLikeProperties Ascii.ascii.
  Proof.
    split; try abstract t.
  Qed.

  Global Instance string_stringiso_properties : StringIsoProperties Ascii.ascii.
  Proof.
    split; simpl; t.
  Qed.

  Global Instance string_stringeq_properties : StringEqProperties Ascii.ascii.
  Proof.
    split; simpl; t.
  Qed.
End Ocaml.