Require Import Coq.Strings.String Coq.Numbers.Natural.Peano.NPeano Coq.NArith.BinNat Coq.omega.Omega Coq.Setoids.Setoid Coq.Classes.RelationPairs Coq.Lists.SetoidList.
Require Export PrefixSerializableDefinitions.
Require Import Common.

Set Implicit Arguments.

Local Open Scope list_scope.
Local Open Scope bool_scope.
Local Open Scope string_scope.

Lemma from_to_string_append_1 {A R} `{PrefixSerializable A R} x s : option_lift_relation R (fst (from_string (to_string x ++ s))) (Some x).
Proof.
  apply prefix_closed_1.
  apply from_to_string_1.
Qed.

Lemma from_to_string_append_2 {A R} `{PrefixSerializable A R} x s : snd (from_string (to_string x ++ s)) = s.
Proof.
  erewrite prefix_closed_2 by apply from_to_string_1.
  rewrite from_to_string_2; reflexivity.
Qed.

Lemma from_to_string_append_1_eq {A} `{PrefixSerializable A eq} x s
: fst (from_string (to_string x ++ s)) = Some x.
Proof.
  apply prefix_closed_1_eq.
  apply from_to_string_1_eq.
Qed.

Local Arguments Ascii.ascii_dec !_ !_ / .

Instance Serializable_bool : Serializable bool
  := {| to_string b := if b : bool then "1" else "0" |}.
Instance Deserializable_bool : Deserializable bool
  := {| from_string x := match x with
                           | "" => (None, "")
                           | String a s' => if Ascii.ascii_dec a "1"
                                            then (Some true, s')
                                            else if Ascii.ascii_dec a "0"
                                                 then (Some false, s')
                                                 else (None, x)
                         end |}.

Instance PrefixSerializable_bool {R} `{Reflexive bool R}
: PrefixSerializable bool R
  := {| serialize := _; deserialize := _ |}.
Proof.
  intros []; split; reflexivity.
  abstract (
      intro s1; induction s1; intros;
      repeat match goal with
               | _ => progress cleanup
               | [ b : bool |- _ ] => destruct b
               | _ => progress simpl in *
               | _ => progress unfold from_string, to_string in *
               | [ |- appcontext[prefix _ ?s] ] => (atomic s; destruct s)
               | [ H : appcontext[prefix _ ?s] |- _ ] => (atomic s; destruct s)
               | [ |- appcontext[Ascii.ascii_dec ?a ?b] ] => destruct (Ascii.ascii_dec a b)
               | [ H : appcontext[Ascii.ascii_dec ?a ?b] |- _ ] => destruct (Ascii.ascii_dec a b)
             end
    ).
Defined.

Local Opaque Serializable_bool.
Local Opaque Deserializable_bool.

Fixpoint string_of_Npositive (n : positive) : string :=
  match n with
    | xH => "1"
    | xI n' => string_of_Npositive n' ++ "1"
    | xO n' => string_of_Npositive n' ++ "0"
  end.

Definition string_of_N (n : N) : string :=
  match n with
    | N0 => "0 "
    | Npos n' => string_of_Npositive n' ++ " "
  end.

Fixpoint N_of_string_helper (s : string) (so_far : N) (acc : string) : option N * string :=
  match s with
    | "" => (None, acc)
    | String a s' => if Ascii.ascii_dec a " "
                     then (Some so_far, s')
                     else if Ascii.ascii_dec a "0"
                          then N_of_string_helper s' (2 * so_far) (acc ++ String a "")
                          else if Ascii.ascii_dec a "1"
                               then N_of_string_helper s' (1 + 2 * so_far) (acc ++ String a "")
                               else (None, acc ++ String a s')
  end.

Definition N_of_string (s : string) : option N * string := N_of_string_helper s 0 "".

Arguments string_of_N !n / .
Arguments N_of_string !s / .
Arguments N_of_string_helper !s so_far acc / .

Lemma string_append_assoc (s1 s2 s3 : string) : (s1 ++ s2) ++ s3 = s1 ++ (s2 ++ s3).
Proof.
  revert s2 s3.
  induction s1; simpl; trivial.
  intros; f_equal; eauto.
Qed.

Local Ltac N_str_append_t IH :=
  repeat match goal with
           | _ => progress simpl in *
           | _ => progress cleanup
           | _ => progress subst
           | _ => intro
           | [ |- appcontext[Ascii.ascii_dec ?a ?b] ] => destruct (Ascii.ascii_dec a b)
           | [ H : appcontext[Ascii.ascii_dec ?a ?b] |- _ ] => destruct (Ascii.ascii_dec a b)
           | [ H : _ |- _ ] => rewrite H by assumption
           | [ |- appcontext[match ?E with _ => _ end] ] => atomic E; destruct E
           | _ => rewrite !string_append_assoc
           | _ => rewrite IH; clear IH
         end.

Lemma N_of_string_append0 (s1 : string) (n1 : N) so_far acc
      (H1 : N_of_string_helper (s1 ++ " ") so_far acc = (Some n1, ""))
      (H1' : N_of_string_helper s1 so_far acc = (None, acc ++ s1))
: N_of_string_helper (s1 ++ "0 ") so_far acc = (Some (2 * n1)%N, "").
Proof.
  generalize dependent so_far; generalize dependent acc.
  induction s1; simpl in *;
  N_str_append_t IHs1.
Qed.

Lemma N_of_string_append1 (s1 : string) (n1 : N) so_far acc
      (H1 : N_of_string_helper (s1 ++ " ") so_far acc = (Some n1, ""))
      (H1' : N_of_string_helper s1 so_far acc = (None, acc ++ s1))
: N_of_string_helper (s1 ++ "1 ") so_far acc = (Some (1 + 2 * n1)%N, "").
Proof.
  generalize dependent so_far; generalize acc;
  induction s1; simpl in *;
  N_str_append_t IHs1.
Qed.

Delimit Scope char_scope with char.
Bind Scope char_scope with Ascii.ascii.

Fixpoint string_contains_ascii (s : string) (a : Ascii.ascii) : bool :=
  match s with
    | "" => false
    | String a' s' => if Ascii.ascii_dec a a'
                      then true
                      else string_contains_ascii s' a
  end.

Lemma string_contains_ascii_append s1 s2 a
: string_contains_ascii (s1 ++ s2) a = string_contains_ascii s1 a || string_contains_ascii s2 a.
Proof.
  induction s1; simpl; trivial.
  rewrite IHs1; clear IHs1.
  edestruct Ascii.ascii_dec; trivial.
Qed.

Lemma string_append_empty s : s ++ "" = s.
Proof.
  induction s; eauto; simpl.
  rewrite IHs; trivial.
Qed.

Lemma N_of_string_of_string_of_N_None s so_far acc
: string_contains_ascii s " " = false
  -> N_of_string_helper s so_far acc = (None, acc ++ s).
Proof.
  revert so_far acc.
  induction s; simpl; trivial; intros;
  repeat match goal with
           | _ => progress cleanup
           | _ => progress simpl in *
           | [ |- appcontext[Ascii.ascii_dec ?a ?b] ] => destruct (Ascii.ascii_dec a b)
           | [ H : appcontext[Ascii.ascii_dec ?a ?b] |- _ ] => destruct (Ascii.ascii_dec a b)
           | _ => rewrite !string_append_assoc
           | _ => rewrite !string_append_empty
           | _ => rewrite IHs; clear IHs
           | _ => solve [ auto ]
         end.
Qed.

Lemma N_of_string_helper_string_of_Npositive n so_far acc
: N_of_string_helper (string_of_Npositive n) so_far acc = (None, acc ++ string_of_Npositive n).
Proof.
  apply N_of_string_of_string_of_N_None.
  induction n; simpl; rewrite ?string_contains_ascii_append; try rewrite IHn; reflexivity.
Qed.

Lemma N_of_string_of_string_of_N_helper n acc
: N_of_string_helper (string_of_N n) 0 acc = (Some n, "").
Proof.
  revert n.
  repeat match goal with
           | _ => progress simpl in *
           | _ => reflexivity
           | [ |- forall s : string, _ ] => intro
           | [ |- forall n : N, _ ] => intros []
           | [ |- forall p : positive, _ ] => let p := fresh in intro p; induction p
           | _ => rewrite string_append_assoc; progress simpl
           | _ => erewrite N_of_string_append1 by first [ eassumption | apply N_of_string_helper_string_of_Npositive ]
           | _ => erewrite N_of_string_append0 by first [ eassumption | apply N_of_string_helper_string_of_Npositive ]
         end.
Qed.

Lemma N_of_string_of_string_of_N n
: N_of_string (string_of_N n) = (Some n, "").
Proof.
  apply N_of_string_of_string_of_N_helper.
Qed.

Lemma N_of_string_of_string_of_N'' n acc
: N_of_string_helper (string_of_Npositive n ++ " ") 0 acc = (Some (N.pos n), "").
Proof.
  apply (N_of_string_of_string_of_N_helper (N.pos n)).
Qed.

Lemma N_of_string_of_string_of_N' n
: N_of_string (string_of_Npositive n ++ " ") = (Some (N.pos n), "").
Proof.
  apply (N_of_string_of_string_of_N_helper (N.pos n)).
Qed.

Instance Serializable_N : Serializable N
  := {| to_string := string_of_N |}.
Instance Deserializable_N : Deserializable N
  := {| from_string := N_of_string |}.

Instance PrefixSerializable_N {R} `{Reflexive N R} : PrefixSerializable N R
  := {| serialize := _; deserialize := _ |}.
Proof.
  abstract (intros; simpl; rewrite N_of_string_of_string_of_N; split; reflexivity).
  abstract (
      unfold to_string, from_string; simpl; unfold N_of_string;
      intro s1; set (so_far := 0%N); set (acc := ""); generalize so_far; generalize acc; clear; induction s1;
      repeat match goal with
               | _ => progress simpl in *
               | _ => intro
               | _ => progress cleanup
               | [ |- appcontext[Ascii.ascii_dec ?a ?b] ] => destruct (Ascii.ascii_dec a b)
               | [ H : appcontext[Ascii.ascii_dec ?a ?b] |- _ ] => destruct (Ascii.ascii_dec a b)
               | _ => solve [ eauto ]
             end
    ).
Defined.

Local Opaque Serializable_N.
Local Opaque Deserializable_N.

Existing Instance eq_Reflexive. (* we want this, not [N.divide_reflexive] *)

Definition prod_map {A A' B B'} (f : A -> A') (g : B -> B') : A * B -> A' * B'
  := fun xy => (f (fst xy), g (snd xy)).

Arguments prod_map / .

Instance Serializable_nat : Serializable nat
  := {| to_string x := to_string (N.of_nat x) |}.
Instance Deserializable_nat : Deserializable nat
  := {| from_string x := prod_map (option_map N.to_nat) (fun x => x) (from_string x) |}.

Instance PrefixSerializable_nat {R} `{Reflexive nat R} : PrefixSerializable nat R
  := {| serialize := _; deserialize := _ |}.
Proof.
  abstract (
      intro;
      simpl rewrite (@from_to_string_1_eq N _);
      simpl rewrite (@from_to_string_2 N _ _);
      simpl; rewrite Nnat.Nat2N.id;
      split; reflexivity
    ).
  abstract (
      set (R' := fun a b => R (N.to_nat a) (N.to_nat b));
      assert (Reflexive R') by (repeat intro; hnf; reflexivity);
      simpl; intros s1 s2 x H1;
      pose proof (prefix_closed_1 (R := R') s1 s2 (N.of_nat x)) as H';
      pose proof (prefix_closed_2 (R := R') s1 s2 (N.of_nat x)) as H'';
      repeat match goal with
               | _ => progress simpl in *
               | _ => progress cleanup
               | _ => progress unfold R', option_lift_relation, option_map in *
               | [ H : _ |- _ ] => rewrite !Nnat.Nat2N.id in H
               | [ H : appcontext[match fst (from_string (A := ?A) ?s1) with _ => _ end] |- _ ]
                 => revert H; case_eq (fst (from_string (A := A) s1)); intros
             end
    ).
Defined.

Local Opaque Serializable_nat.
Local Opaque Deserializable_nat.

Lemma leb_xx x : x <=? x = true.
Proof.
  induction x; trivial.
Qed.

Lemma substring_length x : substring 0 (String.length x) x = x.
Proof.
  induction x; trivial; simpl.
  rewrite IHx; trivial.
Qed.

Lemma substring_length' x n : substring (String.length x) n x = "".
Proof.
  induction x; trivial; simpl.
  destruct n; trivial.
Qed.

Lemma string_length_append s1 s2 : String.length (s1 ++ s2) = String.length s1 + String.length s2.
Proof.
  revert s2.
  induction s1; simpl; trivial; eauto.
Qed.

Lemma substring_length_append s1 s2 : substring 0 (String.length s1) (s1 ++ s2) = s1.
Proof.
  induction s1; simpl.
  { destruct s2; trivial. }
  { f_equal; eauto. }
Qed.

Fixpoint string_drop n (s : string) : string :=
  match n, s with
    | 0, s => s
    | S n', String _ s' => string_drop n' s'
    | _, "" => ""
  end.

Lemma string_drop_le_append n s1 s2 (H : n <= String.length s1)
: string_drop n (s1 ++ s2) = string_drop n s1 ++ s2.
Proof.
  revert n s2 H.
  induction s1; intros; simpl; trivial.
  { destruct n; simpl; trivial; inversion H. }
  { destruct n; simpl in *; trivial.
    apply le_S_n in H.
    apply IHs1; auto. }
Qed.

Lemma substring_le s s' a b (H : a + b <= String.length s) : substring a b (s ++ s') = substring a b s.
Proof.
  revert a b s' H; induction s; intros; simpl in *.
  { destruct a, b, s'; simpl in *; trivial;
    omega. }
  { repeat match goal with
             | [ |- appcontext[match ?E with _ => _ end] ] => atomic E; destruct E
             | _ => reflexivity
             | _ => progress simpl in *
             | [ H : S _ <= S _ |- _ ] => apply le_S_n in H
           end;
    try (rewrite IHs; clear IHs);
    simpl; trivial. }
Qed.

Instance Serializable_string : Serializable string
  := {| to_string x := to_string (String.length x) ++ x |}.
Instance Deserializable_string : Deserializable string
  := {| from_string x := let nx := from_string (A := nat) x in
                         match fst nx with
                           | Some n => if (n <=? String.length (snd nx))
                                       then (Some (substring 0 n (snd nx)), string_drop n (snd nx))
                                       else (None, x)
                           | None => (None, (snd nx))
                         end |}.

Instance PrefixSerializable_string {R} `{Reflexive string R} : PrefixSerializable string R
  := {| serialize := _; deserialize := _ |}.
Proof.
  abstract (
      intro x; induction x; trivial;
      repeat match goal with
               | [ H : _ |- _ ] => progress rewrite ?substring_length in H |- *
               | [ H : _ |- _ ] => progress rewrite ?substring_length' in H |- *
               | [ H : _ |- _ ] => progress rewrite ?leb_xx in H |- *
               | [ H : _ |- _ ] => simpl rewrite from_to_string_append_1_eq in H
               | [ H : _ |- _ ] => simpl rewrite from_to_string_append_2 in H
               | _ => simpl rewrite from_to_string_append_1_eq
               | _ => simpl rewrite from_to_string_append_2
               | _ => progress simpl in *
               | _ => progress cleanup
             end
    ).
  abstract (
      cbv zeta; intros;
      repeat match goal with
               | [ H : appcontext[match ?E with None => _ | _ => _ end] |- _ ]
                 => (let H' := fresh in
                     case_eq E;
                     [ intros ? H'; rewrite H' in H
                     | intro H'; rewrite H' in H ])
               | _ => (simpl rewrite (@prefix_closed_1_eq _ _ _ _ _); [ | eassumption ])
               | _ => (simpl rewrite (@prefix_closed_2_refl _ _ _ _ _ _ _); [ | eassumption ])
               | _ => progress cleanup
               | _ => rewrite string_length_append
               | _ => progress simpl in *
               | _ => intro
               | [ H : (_ <=? _) = true |- _ ] => apply leb_le in H
               | [ H : appcontext[if ?E then _ else _] |- _ ] => (revert H; case_eq E)
               | [ H : _ <= _ |- _ ] => rewrite (proj2 (@leb_le _ _) (Plus.le_plus_trans _ _ _ H))
               | _ => rewrite substring_le by assumption
               | _ => rewrite string_drop_le_append by assumption
             end
    ).
Defined.

Local Opaque Serializable_string.
Local Opaque Deserializable_string.

Instance Serializable_unit : Serializable unit
  := {| to_string x := "" |}.
Instance Deserializable_unit : Deserializable unit
  := {| from_string s := (Some tt, s) |}.
Instance PrefixSerializable_unit {R} `{Reflexive unit R}
: PrefixSerializable unit R
  := {| serialize := _; deserialize := _ |}.
Proof.
  intros []; split; reflexivity.
  intros ? ? []; split; reflexivity.
Defined.

Instance Serializable_True : Serializable True
  := {| to_string x := "" |}.
Instance Deserializable_True : Deserializable True
  := {| from_string s := (Some I, s) |}.
Instance PrefixSerializable_True {R} `{Reflexive True R}
: PrefixSerializable True R
  := {| serialize := _; deserialize := _ |}.
Proof.
  intros []; split; reflexivity.
  intros ? ? []; split; reflexivity.
Defined.

Instance Serializable_Empty_set : Serializable Empty_set
  := {| to_string x := "" |}.
Instance Deserializable_Empty_set : Deserializable Empty_set
  := {| from_string s := (None, s) |}.
Instance PrefixSerializable_Empty_set {R}
: PrefixSerializable Empty_set R
  := {| serialize := _; deserialize := _ |}.
Proof.
  intros [].
  intros ? ? [].
Defined.

Instance Serializable_False : Serializable False
  := {| to_string x := "" |}.
Instance Deserializable_False : Deserializable False
  := {| from_string s := (None, s) |}.
Instance PrefixSerializable_False {R}
: PrefixSerializable False R
  := {| serialize := _; deserialize := _ |}.
Proof.
  intros [].
  intros ? ? [].
Defined.

Definition Serializable_sum {A B} `{Serializable A, Serializable B} : Serializable (A + B)
  := {| to_string x := match x with
                         | inl x' => "L" ++ to_string x'
                         | inr x' => "R" ++ to_string x'
                       end |}.

Definition Deserializable_sum {A B} `{Deserializable A, Deserializable B} : Deserializable (A + B)
  := {| from_string s := match s with
                           | "" => (None, "")
                           | String a s' => if Ascii.ascii_dec a "L"
                                            then prod_map (option_map (@inl _ _)) id (from_string s')
                                            else if Ascii.ascii_dec a "R"
                                                 then prod_map (option_map (@inr _ _)) id (from_string s')
                                                 else (None, String a s')
                         end |}.

Hint Extern 2 (Deserializable (sum _ _)) => apply Deserializable_sum : typeclass_instances.
Hint Extern 2 (Serializable (sum _ _)) => apply Serializable_sum : typeclass_instances.

Section RelSum.
  Context {A B}
          (RA : relation A) (RB : relation B).

  Definition RelSum : relation (A + B)
    := fun x y => match x, y with
                    | inl x', inl y' => RA x' y'
                    | inr x', inr y' => RB x' y'
                    | _, _ => False
                  end.

  Global Instance RelSum_Reflexive `{Reflexive A RA, Reflexive B RB}
  : Reflexive RelSum.
  Proof. lazy; intros [|]; reflexivity. Qed.

  Global Instance RelSum_Symmetry `{Symmetric A RA, Symmetric B RB}
  : Symmetric RelSum.
  Proof. lazy; intros [|] [|]; auto. Qed.

  Global Instance RelSum_Transitive `{Transitive A RA, Transitive B RB}
  : Transitive RelSum.
  Proof. lazy; intros [|] [|] [|]; eauto; tauto. Qed.
End RelSum.

Definition PrefixSerializable_sum {A B RA RB} `{Reflexive A RA, Reflexive B RB}
           `{PrefixSerializable A RA, PrefixSerializable B RB}
: PrefixSerializable (A + B) (RelSum RA RB).
Proof.
  refine {| serialize := _; deserialize := _ |}.
  abstract (
      intros [x|x]; simpl; rewrite from_to_string_2;
      repeat match goal with
               | _ => progress unfold option_map
               | _ => intro
               | [ R : relation ?A |- appcontext[match fst (from_string (A := ?A) (to_string ?x)) with _ => _ end] ]
                 => (generalize (@from_to_string_1 A R _ x);
                     case_eq (fst (from_string (A := A) (to_string x))))
               | _ => progress simpl in *
               | _ => progress cleanup
             end
    ).
  abstract (
      intros [|a s1] ? [x|x]; simpl; intros;
      repeat match goal with
               | _ => progress cleanup
               | _ => progress simpl in *
               | [ |- appcontext[Ascii.ascii_dec ?a ?b] ] => destruct (Ascii.ascii_dec a b)
               | [ H : appcontext[Ascii.ascii_dec ?a ?b] |- _ ] => destruct (Ascii.ascii_dec a b)
               | _ => progress unfold option_map in *
               | [ H : appcontext[match ?E with None => _ | _ => _ end] |- _ ]
                 => (revert H; case_eq E; intros)
               | [ |- appcontext[match ?E with None => _ | _ => _ end] ]
                 => (case_eq E; intros)
               | _ => (simpl rewrite (@prefix_closed_1 _ _ _ _ _ _); [ | eassumption ])
               | _ => erewrite prefix_closed_2_refl by eassumption
               | [ H : appcontext[from_string (A := ?A) (?s1 ++ ?s2)] |- _ ]
                 => (let H' := fresh in
                     assert (H' := @prefix_closed_1 A _ _ s1 s2);
                     unfold option_lift_relation in H';
                     cleanup;
                     solve [ eauto ])
             end
    ).
Defined.

Hint Extern 2 (PrefixSerializable (sum _ _) _) => apply PrefixSerializable_sum : typeclass_instances.

Local Opaque Serializable_sum.
Local Opaque Deserializable_sum.

Definition Serializable_option {A} `{Serializable A} : Serializable (option A)
  := {| to_string x := to_string (match x return A + unit with
                                    | Some x' => inl x'
                                    | None => inr tt
                                  end) |}.

Definition Deserializable_option {A} `{Deserializable A} : Deserializable (option A)
  := {| from_string x := let fs := from_string x in
                         (match fst fs with
                            | Some (inl s) => Some (Some s)
                            | Some (inr tt) => Some None
                            | None => None
                          end,
                          snd fs) |}.

Hint Extern 1 (Deserializable (option _)) => apply Deserializable_option : typeclass_instances.
Hint Extern 1 (Serializable (option _)) => apply Serializable_option : typeclass_instances.

Definition PrefixSerializable_option {A RA} `{Reflexive A RA}
           `{PrefixSerializable A RA}
: PrefixSerializable (option A) (option_lift_relation RA).
Proof.
  refine {| serialize := _; deserialize := _ |}.
  abstract (
      intros [x|]; simpl; simpl rewrite (@from_to_string_2 (A + unit) _ _);
      repeat match goal with
               | _ => progress unfold option_lift_relation
               | _ => intro
               | [ |- appcontext[match fst (from_string (A := ?A) (to_string ?x)) with _ => _ end] ]
                 => (generalize (@from_to_string_1 A _ _ x);
                     case_eq (fst (from_string (A := A) (to_string x))))
               | _ => progress destruct_head sum
               | _ => progress simpl in *
               | _ => progress cleanup
             end
    ).
  abstract (
      repeat match goal with
               | _ => intro
               | _ => progress cleanup
               | _ => progress simpl in *
               | _ => progress destruct_head option
               | _ => progress destruct_head sum
               | [ |- appcontext[match fst (from_string (A := ?A) ?s) with _ => _ end] ]
                 => case_eq (fst (from_string (A := A) s))
               | [ H : appcontext[match fst (from_string (A := ?A) ?s) with _ => _ end] |- _ ]
                 => case_eq (fst (from_string (A := A) s))
               | [ |- appcontext[from_string (A := ?A) _] ]
                 => (simpl rewrite (@prefix_closed_2_refl A _ _ _ _ _ _); [ | eassumption ])
               | _ => erewrite prefix_closed_2_refl by eassumption
               | [ H : appcontext[from_string (A := ?A) (?s1 ++ ?s2)] |- _ ]
                 => (let H' := fresh in
                     assert (H' := fun x => @prefix_closed_1 A _ _ s1 s2 (inl x));
                     let H'' := fresh in
                     assert (H'' := fun x => @prefix_closed_1 A _ _ s1 s2 (inr x));
                     unfold option_lift_relation, RelSum in H', H'';
                     simpl in *;
                       cleanup;
                     solve [ eauto ])
             end
    ).
Defined.

Hint Extern 1 (PrefixSerializable (option _) _) => apply PrefixSerializable_option : typeclass_instances.

Local Opaque Serializable_option.
Local Opaque Deserializable_option.

Definition Serializable_prod {A B} `{Serializable A, Serializable B}
: Serializable (A * B)
  := {| to_string x := to_string (fst x) ++ to_string (snd x) |}.

Definition Deserializable_prod {A B} `{Deserializable A, Deserializable B}
: Deserializable (A * B)
  := {| from_string x := let fs := from_string x in
                         let fs' := from_string (snd fs) in
                         match fst fs, fst fs' with
                           | Some a, Some b => (Some (a, b), snd fs')
                           | _, _ => (None, x)
                         end |}.

Hint Extern 2 (Deserializable (prod _ _)) => apply Deserializable_prod : typeclass_instances.
Hint Extern 2 (Serializable (prod _ _)) => apply Serializable_prod : typeclass_instances.

Definition PrefixSerializable_prod {A B RA RB}
           `{Reflexive A RA, Reflexive B RB}
           `{PrefixSerializable A RA, PrefixSerializable B RB}
: PrefixSerializable (A * B) (RelProd RA RB).
Proof.
  refine {| serialize := _; deserialize := _ |}.
  abstract (
      repeat match goal with
               | _ => progress unfold option_lift_relation
               | _ => intro
               | _ => progress destruct_head prod
               | _ => progress unfold RelProd, relation_conjunction, predicate_intersection in *
               | _ => progress simpl in *
               | _ => progress cleanup
               | _ => rewrite from_to_string_append_2
               | _ => rewrite from_to_string_2
               | [ |- appcontext[match fst (from_string (A := ?A) (to_string ?x ++ ?y)) with _ => _ end] ]
                 => (generalize (@from_to_string_append_1 A _ _ x y);
                     case_eq (fst (from_string (A := A) (to_string x ++ y))))
               | [ |- appcontext[match fst (from_string (A := ?A) (to_string ?x)) with _ => _ end] ]
                 => (generalize (@from_to_string_1 A _ _ x);
                     case_eq (fst (from_string (A := A) (to_string x))))

             end
    ).
  abstract (
      simpl; intros s1 s2;
      repeat match goal with
               | _ => intro
               | _ => progress cleanup
               | _ => progress simpl in *
               | _ => progress unfold RelProd, RelCompFun, relation_conjunction, predicate_intersection, option_lift_relation in *
               | _ => erewrite prefix_closed_2_refl by eassumption
               | [ H : _ |- _ ] => erewrite prefix_closed_2_refl in H by eassumption
               | [ |- appcontext[match fst (from_string (A := ?A) ?s) with _ => _ end] ]
                 => (case_eq (fst (from_string (A := A) s)))
               | [ H : appcontext[match fst (from_string (A := ?A) ?s) with _ => _ end] |- _ ]
                 => (revert H; case_eq (fst (from_string (A := A) s)))
               | [ H : appcontext[from_string (A := ?A) (?s1 ++ ?s2)] |- _ ]
                 => (let H' := fresh in
                     assert (H' := @prefix_closed_1 A _ _ s1 s2);
                     unfold option_lift_relation in H';
                     simpl in *;
                       cleanup;
                     solve [ eauto
                           | exfalso; eauto ])
             end).
Defined.

Hint Extern 2 (PrefixSerializable (prod _ _) _) => apply PrefixSerializable_prod : typeclass_instances.

Local Opaque Serializable_prod.
Local Opaque Deserializable_prod.

Fixpoint list_to_string_helper {A} `{Serializable A} (ls : list A) : string :=
  match ls with
    | nil => ""
    | x::xs => to_string x ++ list_to_string_helper xs
  end.

Definition list_to_string {A} `{Serializable A} (ls : list A) : string :=
  to_string (List.length ls) ++ list_to_string_helper ls.

Fixpoint list_from_string_helper {A} `{Deserializable A} n (s : string) : option (list A) * string :=
  match n with
    | 0 => (Some nil, s)
    | S n' => let fs := from_string s in
              let fs' := list_from_string_helper n' (snd fs) in
              match fst fs, fst fs' with
                | Some x, Some xs => (Some (x::xs), snd fs')
                | _, _ => (None, s)
              end
  end.

Lemma list_from_string_helper_append_1 {A R} `{Reflexive A R}
      `{PrefixSerializable A R} n (s1 s2 : string) x
: option_lift_relation (eqlistA R) (fst (list_from_string_helper n s1)) (Some x)
  -> option_lift_relation (eqlistA R) (fst (list_from_string_helper n (s1 ++ s2))) (Some x).
Proof.
  revert s1 s2 x.
  induction n;
    intro s1;
    case_eq (fst (from_string (A := A) s1));
    repeat match goal with
             | _ => intro
             | _ => progress cleanup
             | _ => progress simpl in *
             | _ => erewrite prefix_closed_2_refl by eassumption
             | [ |- appcontext[fst (list_from_string_helper _ (?s1 ++ ?s2))] ]
               => specialize (IHn s1 s2)
             | _ => progress unfold option_lift_relation in *
             | _ => erewrite prefix_closed by eassumption
             | [ H : appcontext[match ?E with None => _ | _ => _ end] |- _ ]
               => (revert H; case_eq E)
             | [ |- appcontext[match ?E with None => _ | _ => _ end] ]
               => case_eq E
             | _ => erewrite IHn by eassumption
             | [ H : fst (from_string (A := ?A) (?s1 ++ ?s2)) = _ |- _ ]
               => (pose proof (@prefix_closed_1 A _ _ s1 s2);
                   simpl in *; cleanup;
                   simpl in *;
                     solve [ eauto ])
           end.
Qed.

Instance eqlistA_Reflexive {A R} `{Reflexive A R} : Reflexive (eqlistA R).
Proof.
  intro ls; induction ls; constructor; auto.
Qed.

Instance eqlistA_Symmetric {A R} `{Symmetric A R} : Symmetric (eqlistA R).
Proof.
  intro ls; induction ls; intros ls' H'; inversion H'; subst; constructor;
  eauto.
Qed.

Instance eqlistA_Transitive {A R} `{Transitive A R} : Transitive (eqlistA R).
Proof.
  intro ls; induction ls; intros ls' ls'' H' H'';
  inversion H'; subst; inversion H'';
  subst; try constructor;
  eauto;
  try congruence.
Qed.

Lemma list_from_string_helper_append_2 {A R} `{Reflexive A R}
      `{PrefixSerializable A R} n (s1 s2 : string) x
: option_lift_relation (eqlistA R) (fst (list_from_string_helper n s1)) (Some x)
  -> snd (list_from_string_helper (A := A) n (s1 ++ s2)) = snd (list_from_string_helper (A := A) n s1) ++ s2.
Proof.
  revert s1 s2 x; induction n;
  repeat match goal with
           | _ => intro
           | _ => progress cleanup
           | _ => progress simpl in *
           | [ H : _ |- _ ] => erewrite prefix_closed_2_refl in H by eassumption
           | _ => erewrite prefix_closed_2_refl by eassumption
           | [ H : appcontext[match ?E with None => _ | _ => _ end] |- _ ]
             => (revert H; case_eq E)
           | [ |- appcontext[match ?E with None => _ | _ => _ end] ]
             => case_eq E
           | _ => erewrite IHn
           | [ H : fst (from_string (A := ?A) (?s1 ++ ?s2)) = _ |- _ ]
             => (pose proof (@prefix_closed_1 A _ _ s1 s2);
                 simpl in *; cleanup;
                 simpl in *;
                   solve [ eauto ])
           | [ H : fst (list_from_string_helper (A := ?A) ?n (?s1 ++ ?s2)) = None |- _ ]
             => (pose proof (@list_from_string_helper_append_1 A _ _ _ n s1 s2);
                 simpl in *; cleanup;
                 simpl in *; cleanup;
                 solve [ exfalso; eauto ])
           | [ H : fst (from_string (A := ?A) (?s1 ++ ?s2)) = None |- _ ]
             => (pose proof (@prefix_closed_1 A _ _ s1 s2);
                 simpl in *; cleanup;
                 simpl in *; cleanup;
                 solve [ exfalso; eauto ])
           | [ H : _ |- _ ] => rewrite H; reflexivity
         end.
Qed.

Definition list_from_string {A} `{Deserializable A} (s : string) : option (list A) * string :=
  let fs := from_string (A := nat) s in
  match fst fs with
    | Some n => list_from_string_helper n (snd fs)
    | None => (None, s)
  end.

Arguments list_from_string / .
Arguments list_to_string / .

Definition Serializable_list {A} `{Serializable A} : Serializable (list A)
  := {| to_string x := list_to_string x |}.

Definition Deserializable_list {A} `{Deserializable A} : Deserializable (list A)
  := {| from_string x := list_from_string x |}.

Hint Extern 1 (Deserializable (list _)) => apply Deserializable_list : typeclass_instances.
Hint Extern 1 (Serializable (list _)) => apply Serializable_list : typeclass_instances.

Definition PrefixSerializable_list {A R} `{Reflexive A R}
           `{PrefixSerializable A R}
: PrefixSerializable (list A) (eqlistA R).
Proof.
  refine {| serialize := _ |}.
  unfold to_string, from_string; simpl; unfold list_from_string, list_to_string.
  abstract (
      intro x; induction x; trivial;
      repeat match goal with
               | _ => intro
               | _ => progress cleanup
               | [ H : _ |- _ ] => simpl rewrite (@from_to_string_append_1_eq nat _) in H
               | [ H : _ |- _ ] => simpl rewrite (@from_to_string_append_2 nat _ _) in H
               | _ => progress simpl in *
               | _ => progress unfold option_lift_relation in *
               | [ H : _ |- _ ] => (rewrite H; reflexivity)
               | [ |- appcontext[match fst (from_string (A := ?A) (to_string ?x ++ ?y)) with _ => _ end] ]
                 => (generalize (@from_to_string_append_1 A _ _ x y);
                     case_eq (fst (from_string (A := A) (to_string x ++ y))))
               | [ |- appcontext[match fst (from_string (A := ?A) (to_string ?x)) with _ => _ end] ]
                 => (generalize (@from_to_string_1 A _ _ x);
                     case_eq (fst (from_string (A := A) (to_string x))))
               | [ |- appcontext[snd (from_string (A := ?A) (to_string ?x ++ ?y))] ]
                 => simpl rewrite (@from_to_string_append_2 A _ _)
               | [ H : appcontext[match ?E with None => _ | _ => _ end] |- _ ]
                 => (revert H; case_eq E)
               | _ => solve [ eauto ]
             end
    ).
  unfold to_string, from_string; simpl; unfold list_from_string, list_to_string.
  abstract (
      intro s1;
      case_eq (fst (from_string (A := nat) s1));
      repeat match goal with
               | _ => intro
               | _ => progress cleanup
               | _ => progress simpl in *
               | [ H : appcontext[from_string (A := ?A) _] |- _ ]
                 => (simpl rewrite (@prefix_closed_2_refl A _ _ _ _ _ _) in H; [ | eassumption ])
               | [ H : _ |- _ ] => erewrite prefix_closed_2_refl in H by eassumption
               | [ H : _ |- _ ] => simpl rewrite (@prefix_closed_1_eq nat _ _ _ _) in H; [ | eassumption ]
               | _ => erewrite prefix_closed_2_refl by eassumption
               | _ => simpl rewrite (@prefix_closed_2_refl nat _ _ _ _ _ _); [ | eassumption ]
               | _ => apply list_from_string_helper_append
               | _ => progress unfold option_lift_relation in *
               | [ H : appcontext[match ?E with None => _ | _ => _ end] |- _ ]
                 => (revert H; case_eq E)
               | [ |- appcontext[match ?E with None => _ | _ => _ end] ]
                 => (revert H; case_eq E)
               | [ H : fst (list_from_string_helper (A := ?A) ?n (?s0 ++ ?s1)) = _ |- _ ]
                 => (pose proof (@list_from_string_helper_append_1 A _ _ _ n s0 s1);
                     simpl in *; cleanup;
                     simpl in *; solve [ eauto ])
               | [ |- _ ] => eapply list_from_string_helper_append_2
               | [ H : _ |- _ ] => rewrite H; reflexivity
             end
    ).
Defined.

Hint Extern 1 (PrefixSerializable (list _) _) => apply PrefixSerializable_list : typeclass_instances.

Local Opaque Serializable_list.
Local Opaque Deserializable_list.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export list.
Require Export per_props.
Require Export continuity_defs.
Require Export stronger_continuity_defs0.
Require Export cequiv_props.
Require Export terms_pi.

Lemma fresh_in_product {o} :
  forall lib v (t1 t2 : @CVTerm o [v]) A x B,
    equality lib (mkc_fresh v (mkcv_pi1 [v] t1)) (mkc_fresh v (mkcv_pi2 [v] t2)) A
    -> equality
         lib
         (mkc_fresh v (mkcv_pi2 [v] t1))
         (mkc_fresh v (mkcv_pi2 [v] t2))
         (substc (mkc_fresh v (mkcv_pi1 [v] t1)) x B)
    -> (forall a1 a2,
          equality lib a1 a2 A
          -> tequality lib (substc a1 x B) (substc a2 x B))
    -> equality lib (mkc_fresh v t1) (mkc_fresh v t2) (mkc_product A x B).
Proof.
  introv ea eb tb.
  apply equality_in_product.
  dands; auto.
  { eapply inhabited_implies_tequality; eauto. }

  Check computes_to_pair_eta_c.

Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Reals.
Require Import trajectory_const.
Require Import rrho.
Require Import constants.
Require Import Omega.

(* Verifiable in MuPAD *)
Axiom
  Math_prop_alarm_1 :
    forall (a l : R) (T : TimeT),
    (MinDistance T <= l)%R ->
    (l <= MaxDistance T)%R ->
    (0 <= a)%R ->
    (a <= MinBeta)%R ->
    (Rsqr (l * cos a - v V * T) + Rsqr (l * sin a) <= Rsqr AlertRange)%R.

(* Verifiable in MuPAD *)
Axiom
  Math_prop_no_conflict_1 :
    forall (a l x y : R) (T : TimeT),
    (MinDistance T <= l)%R ->
    (l <= MaxDistance T)%R ->
    (MinBeta <= a)%R ->
    (a <= PI / 2)%R ->
    (l * sin a + r_V * (cos (rho_V * T) - 1) <= y)%R ->
    (r_V * sin (rho_V * T) - l * cos a <= x)%R ->
    (Rsqr ConflictRange < Rsqr x + Rsqr y)%R.

(**********)
Lemma MinBeta_pos : (0 < MinBeta)%R.
unfold MinBeta in |- *; unfold Rdiv in |- *.
apply Rmult_lt_0_compat; [ prove_sup | apply Rinv_0_lt_compat; prove_sup ].
Qed.

(**********)
Lemma Math_prop_y_a_PI2 :
 forall (a l : R) (T : TimeT),
 (MinBeta <= a)%R ->
 (a <= PI / 2)%R ->
 (0 <= l)%R ->
 (l * sin MinBeta + r_V * (cos (rho_V * T) - 1) <=
  l * sin a + r_V * (cos (rho_V * T) - 1))%R.
intros; apply Rplus_le_compat_r; apply Rmult_le_compat_l;
 [ assumption
 | apply sin_incr_1;
    [ left; apply Rlt_trans with 0%R;
       [ apply _PI2_RLT_0 | apply MinBeta_pos ]
    | apply Rle_trans with a; assumption
    | left; apply Rlt_trans with 0%R;
       [ apply _PI2_RLT_0
       | apply Rlt_le_trans with MinBeta; [ apply MinBeta_pos | assumption ] ]
    | assumption
    | assumption ] ].
Qed.

(**********)
Lemma Math_prop_approx_y_a_PI2 :
 forall (a l1 l2 : R) (T : TimeT),
 (0 <= a)%R ->
 (a <= PI / 2)%R ->
 (0 <= l1)%R ->
 (l1 <= l2)%R ->
 (l1 * sin_lb a + r_ub V * (cos_lb (rho_ub V * MaxT) - 1) <=
  l2 * sin a + r_V * (cos (rho_V * T) - 1))%R.
intros; apply Rplus_le_compat.
apply Rle_trans with (l1 * sin a)%R.
apply Rmult_le_compat_l.
assumption.
generalize (SIN a H (Rlt_le a PI (Rle_lt_trans a (PI / 2) PI H0 PI2_Rlt_PI)));
 intro; elim H3; intros; assumption.
apply Rmult_le_compat_r.
apply (sin_ge_0 a H (Rlt_le a PI (Rle_lt_trans a (PI / 2) PI H0 PI2_Rlt_PI))).
assumption.
rewrite <- (Ropp_involutive (r_ub V * (cos_lb (rho_ub V * MaxT) - 1)));
 rewrite <- (Ropp_involutive (r_V * (cos (rho_V * T) - 1)));
 apply Ropp_ge_le_contravar; apply Rle_ge;
 replace (- (r_V * (cos (rho_V * T) - 1)))%R with
  (r_V * (1 - cos (rho_V * T)))%R.
replace (- (r_ub V * (cos_lb (rho_ub V * MaxT) - 1)))%R with
 (r_ub V * (1 - cos_lb (rho_ub V * MaxT)))%R.
apply Rmult_le_compat.
left; apply r_V_is_pos.
apply Rplus_le_reg_l with (cos (rho_V * T)); rewrite Rplus_0_r;
 rewrite Rplus_comm; unfold Rminus in |- *; repeat rewrite Rplus_assoc;
 rewrite Rplus_opp_l; rewrite Rplus_0_r; generalize (COS_bound (rho_V * T));
 intro; elim H3; intros; assumption.
unfold r_V in |- *; left; apply r_ub_0.
apply Rplus_le_reg_l with (Ropp 1); unfold Rminus in |- *;
 repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l;
 repeat rewrite Rplus_0_l; apply Ropp_ge_le_contravar;
 apply Rle_ge; apply Rle_trans with (cos (rho_ub V * MaxT)).
cut (- PI / 2 <= rho_ub V * MaxT <= PI / 2)%R.
intro; elim H3; intros; generalize (COS (rho_ub V * MaxT) H4 H5); intro;
 elim H6; intros; assumption.
split.
left; apply Rlt_le_trans with 0%R.
replace (- PI / 2)%R with (- (PI / 2))%R.
apply _PI2_RLT_0.
unfold Rdiv in |- *; symmetry  in |- *; apply Ropp_mult_distr_l_reverse.
apply Rmult_le_pos.
left; apply rho_ub_pos.
left; unfold MaxT in |- *.
prove_sup.
cut (MaxT <= MaxT)%R.
intro; left; apply (rho_ub_t_PI2 V (mkTimeT MaxT MinT_MaxT H3)).
right; reflexivity.
apply cos_decr_1.
left; apply Rmult_lt_0_compat.
apply rho_V_is_pos.
apply Rlt_le_trans with MinT.
apply MinT_is_pos.
apply (cond_1 T).
left; apply Rlt_trans with (PI / 2)%R.
apply (rho_t_PI2 T).
apply PI2_Rlt_PI.
left; apply Rmult_lt_0_compat.
apply rho_ub_pos.
unfold MaxT in |- *; prove_sup.
left; apply Rlt_trans with (PI / 2)%R.
cut (MaxT <= MaxT)%R.
intro; apply (rho_ub_t_PI2 V (mkTimeT MaxT MinT_MaxT H3)).
right; reflexivity.
apply PI2_Rlt_PI.
apply Rmult_le_compat.
left; apply rho_V_is_pos.
left; apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 T) ].
left; unfold rho_V in |- *; apply rho_ub_0.
apply (cond_2 T).
ring.
ring.
Qed.

(**********)
Lemma Math_prop_x_a_PI2 :
 forall (a l : R) (T : TimeT),
 (MinBeta <= a)%R ->
 (a <= PI / 2)%R ->
 (0 <= l)%R ->
 (r_V * sin (rho_V * T) - l * cos MinBeta <=
  r_V * sin (rho_V * T) - l * cos a)%R.
intros; unfold Rminus in |- *; apply Rplus_le_compat_l;
 apply Ropp_ge_le_contravar; apply Rle_ge; apply Rmult_le_compat_l;
 [ assumption
 | apply cos_decr_1;
    [ left; apply MinBeta_pos
    | apply Rle_trans with a;
       [ assumption
       | left; apply Rle_lt_trans with (PI / 2)%R;
          [ assumption | apply PI2_Rlt_PI ] ]
    | left; apply Rlt_le_trans with MinBeta;
       [ apply MinBeta_pos | assumption ]
    | left; apply Rle_lt_trans with (PI / 2)%R;
       [ assumption | apply PI2_Rlt_PI ]
    | assumption ] ].
Qed.

(**********)
Lemma Math_prop_approx_x_a_PI2 :
 forall (a l1 l2 : R) (T : TimeT),
 (0 <= a)%R ->
 (a <= PI / 2)%R ->
 (0 <= l1)%R ->
 (l1 <= l2)%R ->
 (r_lb V * sin_lb (rho_lb V * MinT) - l2 * cos_ub a <=
  r_V * sin (rho_V * T) - l1 * cos a)%R.
intros; unfold Rminus in |- *; apply Rplus_le_compat.
apply Rmult_le_compat.
left; unfold r_lb in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
 [ apply TypeSpeed_pos | apply Rinv_0_lt_compat; apply rho_ub_pos ].
apply sin_lb_ge_0.
left; apply Rmult_lt_0_compat; [ apply rho_lb_pos | apply MinT_is_pos ].
apply Rle_trans with (rho_V * MinT)%R.
apply Rmult_le_compat_r.
left; apply MinT_is_pos.
unfold rho_V in |- *; left; apply rho_lb_0.
cut (MinT <= MinT)%R.
intro; left; apply (rho_t_PI2 (mkTimeT MinT H3 MinT_MaxT)).
right; reflexivity.
unfold r_V in |- *; left; apply r_lb_0.
apply Rle_trans with (sin (rho_lb V * MinT)).
cut (0 <= rho_lb V * MinT <= PI)%R.
intro; elim H3; intros.
generalize (SIN (rho_lb V * MinT) H4 H5); intro; elim H6; intros; assumption.
split.
left; apply Rmult_lt_0_compat.
apply rho_lb_pos.
apply MinT_is_pos.
left; apply Rle_lt_trans with (PI / 2)%R.
apply Rle_trans with (rho_V * MinT)%R.
apply Rmult_le_compat_r.
left; apply MinT_is_pos.
unfold rho_V in |- *; left; apply rho_lb_0.
cut (MinT <= MinT)%R.
intro; left; apply (rho_t_PI2 (mkTimeT MinT H3 MinT_MaxT)).
right; reflexivity.
apply PI2_Rlt_PI.
apply sin_incr_1.
left; apply Rlt_trans with 0%R.
apply _PI2_RLT_0.
apply Rmult_lt_0_compat.
apply rho_lb_pos.
apply MinT_is_pos.
apply Rle_trans with (rho_V * MinT)%R.
apply Rmult_le_compat_r.
left; apply MinT_is_pos.
unfold rho_V in |- *; left; apply rho_lb_0.
cut (MinT <= MinT)%R.
intro; left; apply (rho_t_PI2 (mkTimeT MinT H3 MinT_MaxT)).
right; reflexivity.
left; apply Rlt_trans with 0%R.
apply _PI2_RLT_0.
apply Rmult_lt_0_compat.
apply rho_V_is_pos.
apply Rlt_le_trans with MinT.
apply MinT_is_pos.
apply (cond_1 T).
left; apply (rho_t_PI2 T).
apply Rmult_le_compat.
left; apply rho_lb_pos.
left; apply MinT_is_pos.
left; unfold rho_V in |- *; apply rho_lb_0.
apply (cond_1 T).
apply Ropp_ge_le_contravar; apply Rle_ge.
apply Rmult_le_compat.
assumption.
apply cos_ge_0.
left; apply Rlt_le_trans with 0%R.
apply _PI2_RLT_0.
assumption.
assumption.
assumption.
cut (- PI / 2 <= a)%R.
intro; generalize (COS a H3 H0); intro; elim H4; intros; assumption.
left; apply Rlt_le_trans with 0%R.
replace (- PI / 2)%R with (- (PI / 2))%R.
apply _PI2_RLT_0.
unfold Rdiv in |- *; symmetry  in |- *; apply Ropp_mult_distr_l_reverse.
assumption.
Qed.

(**********)
Lemma Math_prop_no_conflict_2 :
 forall (a l x y : R) (T : TimeT),
 (MinDistance T <= l)%R ->
 (l <= MaxDistance T)%R ->
 (3 * (PI / 2) <= a)%R ->
 (a <= 2 * PI - MinBeta)%R ->
 (y <= l * sin a - r_V * (cos (rho_V * T) - 1))%R ->
 (r_V * sin (rho_V * T) - l * cos a <= x)%R ->
 (Rsqr ConflictRange < Rsqr x + Rsqr y)%R.
intros.
cut (MinBeta <= 2 * PI - a)%R.
cut (2 * PI - a <= PI / 2)%R.
cut (l * sin (2 * PI - a) + r_V * (cos (rho_V * T) - 1) <= - y)%R.
intros; rewrite (Rsqr_neg y);
 apply (Math_prop_no_conflict_1 (2 * PI - a) l x (- y) T H H0 H7 H6 H5).
replace (2 * PI - a)%R with (- a + 2 * INR 1 * PI)%R;
 [ rewrite (cos_period (- a) 1); rewrite cos_neg; assumption | simpl; ring ].
replace (2 * PI - a)%R with (- a + 2 * INR 1 * PI)%R;
 [ rewrite (sin_period (- a) 1); rewrite sin_neg;
    replace (l * - sin a + r_V * (cos (rho_V * T) - 1))%R with
     (- (l * sin a - r_V * (cos (rho_V * T) - 1)))%R;
    [ apply Ropp_ge_le_contravar; apply Rle_ge; assumption | simpl; ring ]
 | simpl; ring ].
generalize (Rplus_le_compat_l (PI / 2 - a) (3 * (PI / 2)) a H1);
 replace (PI / 2 - a + 3 * (PI / 2))%R with (2 * PI - a)%R.
replace (PI / 2 - a + a)%R with (PI / 2)%R.
intro; assumption.
unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
 rewrite Rplus_0_r; reflexivity.
rewrite double.
pattern PI at 1 2 in |- *; rewrite double_var.
ring.
generalize (Rplus_le_compat_l (MinBeta - a) a (2 * PI - MinBeta) H2);
 replace (MinBeta - a + (2 * PI - MinBeta))%R with (2 * PI - a)%R;
 [ replace (MinBeta - a + a)%R with MinBeta; [ intro; assumption | ring ]
 | ring ].
Qed.

(**********)
Lemma Math_prop_alarm_2 :
 forall (a l : R) (T : TimeT),
 (MinDistance T <= l)%R ->
 (l <= MaxDistance T)%R ->
 (2 * PI - MinBeta <= a)%R ->
 (a <= 2 * PI)%R ->
 (Rsqr (l * cos a - v V * T) + Rsqr (l * sin a) <= Rsqr AlertRange)%R.
intros.
cut (0 <= 2 * PI - a)%R.
cut (2 * PI - a <= MinBeta)%R.
cut (cos (2 * PI - a) = cos a).
cut (sin (2 * PI - a) = (- sin a)%R).
intros; rewrite Rsqr_mult; rewrite (Rsqr_neg (sin a)); rewrite <- H3;
 rewrite <- H4; rewrite <- Rsqr_mult;
 apply (Math_prop_alarm_1 (2 * PI - a) l T H H0 H6 H5).
replace (2 * PI - a)%R with (- a + 2 * INR 1 * PI)%R;
 [ rewrite (sin_period (- a) 1); apply sin_neg | simpl; ring ].
replace (2 * PI - a)%R with (- a + 2 * INR 1 * PI)%R;
 [ rewrite (cos_period (- a) 1); apply cos_neg | simpl; ring ].
generalize (Rplus_le_compat_l (MinBeta - a) (2 * PI - MinBeta) a H1);
 replace (MinBeta - a + (2 * PI - MinBeta))%R with (2 * PI - a)%R;
 [ replace (MinBeta - a + a)%R with MinBeta; [ intro; assumption | ring ]
 | ring ].
generalize (Rplus_le_compat_r (- a) a (2 * PI) H2); rewrite Rplus_opp_r;
 intro; assumption.
Qed.


Require Import Classical List Relations Peano_dec.
Require Import Hahn.

Require Import Basic.

Set Implicit Arguments.
Remove Hints plus_n_O.

Lemma step_dom A (r: relation A) d e
  (E: r ⊆ (⦗d⦘ ∪ ⦗e⦘) ⨾ r ⨾ (⦗d⦘ ∪ ⦗e⦘))
  dd (DD: dd = ⦗d⦘ ⨾ r ⨾ ⦗d⦘)
  de (DE: de = ⦗d⦘ ⨾ r ⨾ ⦗e⦘)
  ed (ED: ed = ⦗e⦘ ⨾ r ⨾ ⦗d⦘)
  ee (EE: ee = ⦗e⦘ ⨾ r ⨾ ⦗e⦘) :
  r ⊆ dd ∪ de ∪ ed ∪ ee.
Proof.
rewrite E; subst; basic_solver 8.
Qed.

Lemma path_dom A (r: relation A) d e
  (E1: r ⊆ (⦗d⦘ ∪ ⦗e⦘) ⨾ r ⨾ (⦗d⦘ ∪ ⦗e⦘))
  (E2: ⦗d⦘ ⨾ ⦗e⦘ ⊆ ∅₂)
  dd (DD: dd = ⦗d⦘ ⨾ r ⨾ ⦗d⦘)
  de (DE: de = ⦗d⦘ ⨾ r ⨾ ⦗e⦘)
  ed (ED: ed = ⦗e⦘ ⨾ r ⨾ ⦗d⦘)
  ee (EE: ee = ⦗e⦘ ⨾ r ⨾ ⦗e⦘) :
   r⁺ ⊆ (dd⁺ ∪ (dd^* ⨾ de ⨾ ee^* ⨾ ed)⁺ ⨾ dd^* ) ∪
  (ee⁺ ∪ (ee^* ⨾ ed ⨾ dd^* ⨾ de)⁺ ⨾ ee^* ) ∪
  (ee^* ⨾ ed ⨾ dd^* ⨾ de)^* ⨾ ee^* ⨾ ed ⨾ dd^* ∪
  (dd^* ⨾ de ⨾ ee^* ⨾ ed)^* ⨾ dd^* ⨾ de ⨾ ee^*.
Proof.
  apply inclusion_t_ind_right.
- rewrite step_dom with (r:=r) (d:=d) (e:=e) at 1; try eassumption.
repeat apply inclusion_union_l; rewrite ?seqA.
1,4: sin_rewrite !ct_end.
all: try (repeat (apply inclusion_union_r; constructor); basic_solver 14).
- rewrite step_dom with (r:=r) (d:=d) (e:=e) at 1; try eassumption.
relsf.
assert (E2': ⦗e⦘ ⨾ ⦗d⦘ ⊆ (fun _ _ : A => False)).
  by rewrite seq_eqvC in E2.

assert (X17: ed ⨾ ed ⊆ ∅₂).
  by rewrite ?DD, ?ED, ?DE, ?EE; generalize E2; basic_solver.
assert (X18: ed ⨾ ee ⊆ ∅₂).
  by rewrite ?DD, ?ED, ?DE, ?EE; generalize E2; basic_solver.
assert (X19: de ⨾ dd ⊆ ∅₂).
  by rewrite ?DD, ?ED, ?DE, ?EE; generalize E2; basic_solver.
assert (X20: de ⨾ de ⊆ ∅₂).
  by rewrite ?DD, ?ED, ?DE, ?EE; generalize E2; basic_solver.
assert (X1: dd ^* ⨾ ed ⊆ ed).
  by rewrite ?rtE; relsf; rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X2: dd ^* ⨾ dd ⊆ dd^* ).
  by rewrite rt_end at 2; relsf.
assert (X3: dd ^* ⨾ ee ⊆ ee).
  by rewrite ?rtE; relsf; rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X4: ee ^* ⨾ de ⊆ de).
  by rewrite ?rtE; relsf; rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X5: ee ^* ⨾ ee ⊆ ee^* ).
  by rewrite rt_end at 2; relsf.
assert (X6: ee ^* ⨾ dd ⊆ dd).
  by rewrite ?rtE; relsf; rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X7: dd ⁺ ⨾ dd ⊆ dd⁺).
  by rewrite ct_end at 2; rewrite inclusion_t_rt.
assert (X8: dd ⁺ ⨾ ed ⊆ ∅₂).
  by rewrite ?rtE; relsf; rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X9: dd ⁺ ⨾ ee ⊆ ∅₂).
  by rewrite ?rtE; relsf; rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X10: (dd ^* ⨾ de ⨾ ee ^* ⨾ ed) ⁺ ⨾ ed ⊆ ∅₂).
  by rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X11: (dd ^* ⨾ de ⨾ ee ^* ⨾ ed) ⁺ ⨾ ee ⊆ ∅₂).
   by rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X12: ee ⁺ ⨾ dd ⊆ ∅₂).
  by rewrite ?rtE; relsf; rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X13: ee ⁺ ⨾ de ⊆ ∅₂).
  by rewrite ?rtE; relsf; rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X14: ee ⁺ ⨾ ee ⊆ ee⁺).
  by rewrite ct_end at 2; rewrite inclusion_t_rt.
assert (X15: (ee ^* ⨾ ed ⨾ dd ^* ⨾ de) ⁺ ⨾ dd ⊆ ∅₂).
  by rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.
assert (X16: (ee ^* ⨾ ed ⨾ dd ^* ⨾ de) ⁺ ⨾ de ⊆ ∅₂).
  by rewrite ct_end, ?seqA, ?DD, ?ED, ?DE, ?EE, ?seqA;
    try sin_rewrite E2; try sin_rewrite E2'; relsf.

repeat apply inclusion_union_l; rewrite ?seqA.
all: rewrite ?X1, ?X2, ?X3, ?X4, ?X5, ?X6, ?X7, ?X8, ?X9, ?X10,
     ?X11, ?X12, ?X13, ?X14, ?X15, ?X16, ?X17, ?X18, ?X19, ?X20.
all: rels.
all: try (repeat (apply inclusion_union_r; constructor); basic_solver 5).
all: try (repeat (apply inclusion_union_r; constructor); basic_solver 20).
Qed.

Lemma path_dom_same A (r: relation A) d e
  (E1: r ⊆ (⦗d⦘ ∪ ⦗e⦘) ⨾ r ⨾ (⦗d⦘ ∪ ⦗e⦘))
  (E2: ⦗d⦘ ⨾ ⦗e⦘ ⊆ ∅₂)
  dd (DD: dd = ⦗d⦘ ⨾ r ⨾ ⦗d⦘)
  de (DE: de = ⦗d⦘ ⨾ r ⨾ ⦗e⦘)
  ed (ED: ed = ⦗e⦘ ⨾ r ⨾ ⦗d⦘)
  ee (EE: ee = ⦗e⦘ ⨾ r ⨾ ⦗e⦘) :
  ⦗d⦘ ⨾ r⁺ ⨾ ⦗d⦘ ⊆ dd⁺ ∪ (dd^* ⨾ de ⨾ ee^* ⨾ ed)⁺ ⨾ dd^*.
Proof.
rewrite path_dom; try edone.
relsf; repeat apply inclusion_union_l; rewrite ?seqA.
all: try by rewrite inclusion_seq_eqv_l, inclusion_seq_eqv_r; relsf.
- by rewrite ct_begin, EE, ?seqA; sin_rewrite E2; relsf.
- rewrite ct_begin at 1; rewrite EE at 1; rewrite ED at 1;
  rewrite rtE at 1; relsf.
  rewrite ?seqA.
  repeat apply inclusion_union_l; rewrite ?seqA.
  by sin_rewrite E2; relsf.
  by rewrite ct_begin, EE, ?seqA; sin_rewrite E2; relsf.
- rewrite rtE at 1; relsf.
  rewrite rtE at 1; relsf.
  repeat apply inclusion_union_l; rewrite ?seqA.
  by rewrite ED, ?seqA; sin_rewrite E2; relsf.
  by rewrite ct_begin, EE, ?seqA; sin_rewrite E2; relsf.
  rewrite ct_begin at 1; rewrite ?seqA.
  rewrite rtE at 1; relsf.
  rewrite ED, ?seqA; sin_rewrite E2; relsf.
  by rewrite ct_begin, EE, ?seqA; sin_rewrite E2; relsf.
- rewrite ?seqA.
  arewrite (⦗d⦘ ⨾ (dd ^* ⨾ de ⨾ ee ^* ⨾ ed) ^* ⨾ dd ^* ⊆ fun _ _ => True).
  rewrite rtE at 1; relsf.
  rewrite DE, ?seqA.
  arewrite (⦗e⦘ ⨾ ⦗d⦘ ⊆ (fun _ _ : A => False)).
    by rewrite seq_eqvC in E2.
  relsf.
  rewrite ct_end at 1; rewrite ?seqA.
  rewrite EE, ?seqA.
  arewrite (⦗e⦘ ⨾ ⦗d⦘ ⊆ (fun _ _ : A => False)).
    by rewrite seq_eqvC in E2.
  by relsf.
Qed.

Lemma irr_dom A (r: relation A) d e
  (E1: r ⊆ (⦗d⦘ ∪ ⦗e⦘) ⨾ r ⨾ (⦗d⦘ ∪ ⦗e⦘))
  (E2: ⦗d⦘ ⨾ ⦗e⦘ ⊆ ∅₂)
  (IRRd: irreflexive (⦗d⦘ ⨾ r ⨾ ⦗d⦘))
  (IRRe: irreflexive (⦗e⦘ ⨾ r ⨾ ⦗e⦘)) :
  irreflexive r.
Proof.
  rewrite step_dom; try edone.
  repeat rewrite irreflexive_union; splits; try done;
  generalize E2; basic_solver 8.
Qed.

Lemma acyc_dom A (r: relation A) d e
  (E1: r ⊆ (⦗d⦘ ∪ ⦗e⦘) ⨾ r ⨾ (⦗d⦘ ∪ ⦗e⦘))
  (E2: ⦗d⦘ ⨾ ⦗e⦘ ⊆ ∅₂)
  dd (DD: dd = ⦗d⦘ ⨾ r ⨾ ⦗d⦘)
  de (DE: de = ⦗d⦘ ⨾ r ⨾ ⦗e⦘)
  ed (ED: ed = ⦗e⦘ ⨾ r ⨾ ⦗d⦘)
  ee (EE: ee = ⦗e⦘ ⨾ r ⨾ ⦗e⦘)
  (ACYCd: acyclic dd)
  (ACYCe: acyclic ee)
  (ACYCed: acyclic (ed ⨾ dd^* ⨾ de ⨾ ee^*)) :
  acyclic r.
Proof.
red.
eapply irr_dom; try edone.
- arewrite (⦗d⦘ ∪ ⦗e⦘ ≡ ⦗fun x => d x \/ e x⦘).
    by basic_solver.
  apply domab_helper; split.
  apply ct_doma; eapply domab_helper with (d':= fun x => d x \/ e x).
  rewrite E1 at 1; basic_solver.
  apply ct_domb; eapply domab_helper with (d := fun x => d x \/ e x).
  rewrite E1 at 1; basic_solver.
- sin_rewrite path_dom_same; try edone.
  repeat rewrite irreflexive_union; splits; try done.
  rewrite irreflexive_seqC.
  arewrite( dd^* ⨾ (dd ^* ⨾ de ⨾ ee ^* ⨾ ed) ⁺ ⊆ (dd ^* ⨾ de ⨾ ee ^* ⨾ ed) ⁺).
    by rewrite ct_begin; rewrite !seqA; rels.
  assert (acyclic (dd ^* ⨾ de ⨾ ee ^* ⨾ ed)); try done. (*?*)
  rewrite acyclic_seqC; rewrite !seqA.
  rewrite acyclic_seqC; rewrite !seqA.
  rewrite acyclic_seqC; rewrite !seqA.
  done.
- rewrite unionC in E1.
  sin_rewrite path_dom_same; try edone; try by rewrite seq_eqvC.
  repeat rewrite irreflexive_union; splits; try done.
  rewrite irreflexive_seqC.
  arewrite( ee^* ⨾ (ee ^* ⨾ ed ⨾ dd ^* ⨾ de) ⁺  ⊆ (ee ^* ⨾ ed ⨾ dd ^* ⨾ de) ⁺).
    by rewrite ct_begin; rewrite !seqA; rels.
  assert (acyclic(ee ^* ⨾ ed ⨾ dd ^* ⨾ de)); try done. (*?*)
  rewrite acyclic_seqC; rewrite !seqA.
  done.
Qed.


Require Import Coq.Lists.List Coq.Arith.Arith Coq.Bool.Bool.
Require Import Bedrock.Expr Bedrock.Env.
Require Import Coq.Classes.EquivDec Bedrock.EqdepClass.
Require Import Bedrock.DepList.
Require Import Bedrock.Word Bedrock.Prover.
Require Import Bedrock.provers.ReflexivityProver Bedrock.sep.Locals.

Set Implicit Arguments.
Set Strict Implicit.

(** * The Word Prover **)

Require Import Coq.Arith.Arith Bedrock.ILEnv Bedrock.Memory.

Section LocalsProver.
  Variable types' : list type.
  Definition types := Locals.types types'.
  Variable funcs' : functions types.
  Definition funcs := Locals.funcs funcs'.

  Definition localsSimplify (e : expr types) : expr types :=
    match e with
      | Func 11 (vs :: Const t nm :: nil) =>
        match t return tvarD types t -> _ with
          | tvType 6 => fun nm => sym_sel vs nm
          | _ => fun _ => e
        end nm
      | _ => e
    end.

  Definition localsProve (_ : unit) (goal : expr types) :=
    match goal with
      | Equal _ x y => expr_seq_dec (localsSimplify x) (localsSimplify y)
      | _ => false
    end.

  Lemma localsSimplify_correct : forall uvars vars (e : expr types) t v,
    exprD funcs uvars vars e t = Some v
    -> exprD funcs uvars vars (localsSimplify e) t = Some v.
    destruct e; simpl; intuition idtac.
    do 12 (destruct f; try assumption).
    do 2 (destruct l; try assumption).
    destruct e0; try assumption.
    destruct l; try assumption.
    destruct t0; try assumption.
    do 7 (destruct n; try assumption).
    simpl in *.
    destruct (equiv_dec (tvType 0) t); try discriminate.
    hnf in e0; subst.
    generalize (sym_sel_correct funcs' uvars vars t1 e).
    unfold funcs in *.
    match type of H with
      | match ?E with Some _ => _ | _ => _ end _ _ = _ => destruct E; try discriminate
    end.
    injection H; clear H; intros; subst.
    auto.
  Qed.

  Theorem localsProveCorrect : ProverCorrect funcs reflexivityValid localsProve.
    unfold localsProve; hnf; simpl; intros.

    destruct goal; try discriminate.
    destruct H1.
    apply expr_seq_dec_correct in H0.
    hnf.
    simpl in *.
    generalize (localsSimplify_correct uvars vars goal1 t).
    generalize (localsSimplify_correct uvars vars goal2 t).
    destruct (exprD funcs uvars vars goal1 t); try discriminate.
    destruct (exprD funcs uvars vars goal2 t); try discriminate.
    intros.
    specialize (H2 _ (refl_equal _)).
    specialize (H3 _ (refl_equal _)).
    congruence.
  Qed.

  Definition localsProver : ProverT types :=
    {| Facts := unit
      ; Summarize := reflexivitySummarize
      ; Learn := reflexivityLearn
      ; Prove := localsProve |}.

  Definition localsProver_correct : ProverT_correct localsProver funcs.
    eapply Build_ProverT_correct with (Valid := reflexivityValid : _ -> _ -> Facts localsProver -> Prop); unfold reflexivityValid; eauto.
    apply localsProveCorrect.
  Qed.

End LocalsProver.

Definition LocalsProver : ProverPackage :=
{| ProverTypes := Locals.types_r
 ; ProverFuncs := Locals.funcs_r
 ; Prover_correct := localsProver_correct
|}.


Require Import ProofIrrelevance.
Require Import FunctionalExtensionality.
Require Import List.

Require Import ProofAutomation.
Require Import Ordering.
Require Import Helpers.ListStuff.
Require Import Helpers.Maps.
Require Import Helpers.Instances.
Require Import Spec.ConcurExec.
Require Import Spec.Equiv.
Require Import Spec.Patterns.
Require Import Spec.Abstraction.
Require Import Spec.Movers.
Require Import Spec.Compile.
Require Import Spec.CompileLoop.
Require Import Spec.Protocol.

Require Import Coq.Program.Equality.

Import ListNotations.

Global Set Implicit Arguments.
Global Generalizable All Variables.

Section HorizontalComposition.

  Variable indexT : Type.
  Context {cmp : Ordering indexT}.
  Variable indexValid : indexT -> Prop.

  Variable sliceOpT : Type -> Type.
  Variable sliceState : Type.
  Variable sliceStep : OpSemantics sliceOpT sliceState.
  Variable initP : sliceState -> Prop.

  Definition validIndexT := { i : indexT | indexValid i }.

  Inductive CheckResult :=
  | Missing
  | Present : validIndexT -> CheckResult
  .

  Inductive horizOpT : Type -> Type :=
  | Slice : forall (i : validIndexT) T (op : sliceOpT T), horizOpT T
  | CheckSlice : forall (i : indexT), horizOpT CheckResult
  .

  Record horizState := mk_horizState {
    HSMap : FMap.t indexT sliceState;
    HSValid : forall i, indexValid i -> FMap.In i HSMap;
  }.

  Definition hget (S : horizState) (i : validIndexT) : sliceState.
    destruct S.
    destruct i.
    eapply HSValid0 in i.
    eapply FMap.in_mapsto_get in i.
    destruct i.
    exact x0.
  Defined.

  Definition hadd (i : validIndexT) (s : sliceState) (S : horizState) : horizState.
    destruct S.
    destruct i.
    refine (mk_horizState (FMap.add x s HSMap0) _).
    intros.
    eapply FMap.add_incr; eauto.
  Defined.

  Theorem hget_mapsto :
    forall i m,
      FMap.MapsTo (proj1_sig i) (hget m i) (HSMap m).
  Proof.
    destruct m.
    destruct i.
    simpl in *.
    destruct (FMap.in_mapsto_get x HSMap0 (HSValid0 x i)).
    eauto.
  Qed.

  Theorem hget_mapsto' :
    forall i m P,
      FMap.MapsTo i (hget m (exist _ i P)) (HSMap m).
  Proof.
    destruct m; simpl; intros.
    destruct (FMap.in_mapsto_get i HSMap0 (HSValid0 i P)).
    eauto.
  Qed.

  Opaque FMap.add.

  Theorem hget_hadd_eq : forall S s i H0 H1,
    hget (hadd (exist _ i H0) s S) (exist _ i H1) = s.
  Proof.
    destruct S; simpl; intros.
    match goal with
    | |- context[FMap.in_mapsto_get ?a ?b ?c] => destruct (FMap.in_mapsto_get a b c)
    end.
    eapply FMap.mapsto_add in m; eauto.
  Qed.

  Local Theorem hget_hadd_eq_general : forall i s s',
      hget (hadd i s s') i = s.
  Proof.
    destruct i; intros.
    apply hget_hadd_eq.
  Qed.

  Local Theorem hget_hadd_ne : forall S s i i' H0 H1,
    i <> i' ->
    hget (hadd (exist _ i H0) s S) (exist _ i' H1) = hget S (exist _ i' H1).
  Proof.
    destruct S; simpl; intros.
    repeat match goal with
    | |- context[FMap.in_mapsto_get ?a ?b ?c] => destruct (FMap.in_mapsto_get a b c)
    end.
    eapply FMap.mapsto_add_ne in m; eauto.
    FMap.mapsto_unique; auto.
  Qed.

  Local Theorem hget_hadd_ne_general : forall i i' s S,
      i <> i' ->
      hget (hadd i s S) i' = hget S i'.
  Proof.
    intros.
    destruct i, i'.
    destruct (x == x0); subst.
    exfalso.
    apply H.
    f_equal; auto using proof_irrelevance.
    apply hget_hadd_ne; auto.
  Qed.

  Theorem hadd_hget_eq : forall S i H0 H1,
    hadd (exist _ i H0) (hget S (exist _ i H1)) S = S.
  Proof.
    destruct S; simpl; intros.
    repeat match goal with
    | |- context[FMap.in_mapsto_get ?a ?b ?c] => destruct (FMap.in_mapsto_get a b c)
    end.
    match goal with
    | |- {| HSMap := ?m ; HSValid := ?v |} = _ =>
      generalize v; remember m
    end.
    rewrite FMap.mapsto_add_nilpotent in Heqt; eauto.
    subst; intros.
    f_equal.
    apply proof_irrelevance.
  Qed.

  Local Theorem hadd_hadd_eq : forall S s s' i H0 H1,
    hadd (exist _ i H0) s (hadd (exist _ i H1) s' S) = hadd (exist _ i H0) s S.
  Proof.
    destruct S; simpl; intros.
    match goal with
    | |- {| HSMap := ?m ; HSValid := ?v |} = _ =>
      generalize v; remember m
    end.
    rewrite FMap.add_add in Heqt.
    subst; intros.
    f_equal.
    apply proof_irrelevance.
  Qed.

  Local Theorem hadd_hadd_ne : forall S s s' i i' H0 H1,
    i <> i' ->
    hadd (exist _ i H0) s (hadd (exist _ i' H1) s' S) =
    hadd (exist _ i' H1) s' (hadd (exist _ i H0) s S).
  Proof.
    destruct S; simpl; intros.
    match goal with
    | |- {| HSMap := ?m ; HSValid := ?v |} = _ =>
      generalize v; remember m
    end.
    rewrite FMap.add_add_ne in Heqt; eauto.
    subst; intros.
    f_equal.
    apply proof_irrelevance.
  Qed.

  Inductive sameSlice : CheckResult -> indexT -> Prop :=
  | SameSliceMissing : forall i,
    sameSlice Missing i
  | SameSlicePresent : forall i P,
    sameSlice (Present (exist _ i P)) i
  .

  Inductive horizStep :
      forall T, horizOpT T -> nat -> horizState -> T -> horizState -> list event -> Prop :=
  | StepSlice :
    forall tid idx (S : horizState) `(op : sliceOpT T) r s' evs,
      sliceStep op tid (hget S idx) r s' evs ->
      horizStep (Slice idx op) tid S r (hadd idx s' S) evs
  | StepCheckSlice :
    forall tid idx (S : horizState) r,
      sameSlice r idx ->
      horizStep (CheckSlice idx) tid S r S nil
  .

  Definition horizInitP (S : horizState) :=
    forall i,
      indexValid i ->
      exists s,
        FMap.MapsTo i s (HSMap S) /\
        initP s.

  Definition SliceProc (i : validIndexT) `(p : proc sliceOpT T) : proc horizOpT T :=
    Compile.compile (fun T (op : sliceOpT T) => Call (Slice i op)) p.

  Theorem SliceProc_eq : forall i T (p p': proc _ T),
      SliceProc i p = SliceProc i p' ->
      p = p'.
  Proof.
    induction p; intros;
      try solve [ destruct p'; simpl in *; try congruence; invert H; auto ].
    - destruct p'; simpl in *; try congruence.
      invert H0; eauto.
      f_equal; eauto.
      extensionality r.
      invert H0.
      apply equal_f with r in H5.
      eauto.
    - destruct p'; simpl in *; try congruence.
      invert H0.
      f_equal.
      extensionality x.
      apply equal_f with x in H3.
      eauto.
    - destruct p'; simpl in *; try congruence.
      invert H.
      f_equal.
      eauto.
    - dependent destruction p'; simpl in *; try congruence.
      invert H.
      erewrite IHp; eauto.
  Qed.

End HorizontalComposition.

Arguments horizState indexT {cmp} indexValid sliceState.
Arguments horizStep indexT {cmp} indexValid {sliceOpT sliceState} sliceStep.
Arguments Slice {indexT indexValid sliceOpT} i {T}.
Arguments CheckSlice {indexT indexValid sliceOpT} i.
Arguments Missing {indexT indexValid}.

Ltac destruct_horizState :=
  match goal with
  | x : horizState _ _ _ |- _ => destruct x; simpl in *
  end.

Ltac destruct_validIndex :=
  match goal with
  | x : validIndexT _ |- _ => destruct x; simpl in *
  end.

Section HorizontalCompositionAbs.

  Variable indexT : Type.
  Context {cmp : Ordering indexT}.
  Variable indexValid : indexT -> Prop.

  Variable sliceOpT : Type -> Type.

  Variable sliceState1 : Type.
  Variable sliceStep1 : OpSemantics sliceOpT sliceState1.

  Variable sliceState2 : Type.
  Variable sliceStep2 : OpSemantics sliceOpT sliceState2.

  Variable absR : sliceState1 -> sliceState2 -> Prop.

  Definition horizAbsR (S1 : horizState indexT indexValid sliceState1)
                       (S2 : horizState indexT indexValid sliceState2) : Prop :=
    forall (i : indexT),
      indexValid i ->
      ( forall s1,
          FMap.MapsTo i s1 (HSMap S1) ->
            exists s2, FMap.MapsTo i s2 (HSMap S2) /\ absR s1 s2 ) /\
      ( forall s2,
          FMap.MapsTo i s2 (HSMap S2) ->
            exists s1, FMap.MapsTo i s1 (HSMap S1) /\ absR s1 s2 ).

  Hint Resolve FMap.add_mapsto.
  Hint Resolve FMap.mapsto_add_ne'.
  Hint Resolve FMap.mapsto_in.

  Theorem horizAbsR_ok :
    op_abs absR sliceStep1 sliceStep2 ->
    op_abs horizAbsR (horizStep indexT indexValid sliceStep1) (horizStep indexT indexValid sliceStep2).
  Proof.
    unfold op_abs, horizAbsR; intros.
    inversion H1; clear H1; subst; repeat sigT_eq.
    {
      eapply H in H7; repeat deex.
      {
        eexists; split; [ | econstructor; eauto ].
        intros.
        repeat destruct_horizState.
        repeat destruct_validIndex.
        destruct (i == x); subst.
        - split; intros.
          + eapply FMap.mapsto_add_eq in H4; subst; eauto.
          + eapply FMap.mapsto_add_eq in H4; subst; eauto.
        - specialize (H0 i); intuition idtac.
          + eapply FMap.mapsto_add_ne in H4; eauto.
            specialize (H0 _ H4); propositional; eauto.
          + eapply FMap.mapsto_add_ne in H4; eauto.
            specialize (H5 _ H4); propositional; eauto.
      }
      {
        pose proof (@hget_mapsto _ _ _ _ idx s1).
        pose proof (@hget_mapsto _ _ _ _ idx s2).
        specialize (H0 (proj1_sig idx) (proj2_sig idx)).
        eapply H0 in H1; deex.
        FMap.mapsto_unique; eauto.
      }
    }
    {
      eexists.
      split.
      eassumption.
      constructor.
      intuition idtac.
    }
  Qed.

  Variable initP1 : sliceState1 -> Prop.
  Variable initP2 : sliceState2 -> Prop.

  (* this is like the normal absInitP but strengthens it to provide an explicit
  function for the witness - this is needed to construct the horizontal abstract
  state *)
  Variable initP_map : sliceState1 -> sliceState2.
  Variable initP_ok :
    forall s1,
      initP1 s1 ->
      absR s1 (initP_map s1) /\
      initP2 (initP_map s1).

  Hint Resolve FMap.mapsto_in.
  Hint Resolve FMap.map_values_MapsTo.

  Theorem horizAbsR_initP_ok :
    forall s1,
      horizInitP initP1 s1 ->
      exists s2, horizAbsR s1 s2 /\
            horizInitP initP2 s2.
  Proof.
    unfold horizInitP; intros.

    unshelve eexists {| HSMap := FMap.map_values initP_map s1.(HSMap) |};
      simpl;
      intuition idtac.
    - intros.
      specialize (H i); propositional.
      rewrite <- FMap.map_values_in; eauto.
    - unfold horizAbsR; simpl; intros.
      specialize (H _ H0); propositional.
      eapply initP_ok in H1; propositional.
      split; intros.
      + FMap.mapsto_unique; eauto.
      + eapply FMap.map_values_MapsTo_general in H3; propositional.
        FMap.mapsto_unique; eauto.
    - specialize (H i); propositional.
      apply initP_ok in H1; propositional.
      eauto.
  Qed.

End HorizontalCompositionAbs.

Arguments horizAbsR indexT {cmp indexValid sliceState1 sliceState2} absR.

Section HorizontalCompositionMovers.

  Variable indexT : Type.
  Context {cmp : Ordering indexT}.
  Variable indexValid : indexT -> Prop.

  Variable sliceOpT : Type -> Type.
  Variable sliceState : Type.
  Variable sliceStep : OpSemantics sliceOpT sliceState.

  Hint Resolve FMap.add_mapsto.
  Hint Resolve FMap.mapsto_add_ne'.
  Hint Resolve FMap.mapsto_in.
  Hint Resolve FMap.add_in_in.
  Hint Resolve FMap.add_incr.
  Hint Constructors horizStep.
  Hint Extern 1 (horizStep _ _ _ _ _ _ _ _ _) => econstructor.

  Opaque hget.
  Opaque hadd.

  Local Theorem horiz_right_mover_ok :
    forall `(op : sliceOpT T),
      right_mover sliceStep op ->
      forall i,
        right_mover (horizStep indexT indexValid sliceStep) (Slice i op).
  Proof.
    intros.
    unfold right_mover; intros.
    inversion H0; clear H0; subst; repeat sigT_eq.
    eapply H in H9 as H'; intuition subst.
    inversion H3; clear H3; subst; repeat sigT_eq.
    {
      repeat destruct_horizState.
      repeat destruct_validIndex.
      destruct (x == x0); subst.
      - rewrite hget_hadd_eq in *.
        eapply H1 in H8; eauto; deex.
        eexists; split.
        + econstructor; eauto.
          replace i0 with i by apply proof_irrelevance; eauto.
        + rewrite hadd_hadd_eq.
          erewrite <- hadd_hadd_eq with (s := s'0).
          replace i0 with i by apply proof_irrelevance; eauto.
          econstructor; eauto.
          rewrite hget_hadd_eq; eauto.
      - rewrite hget_hadd_ne in * by eauto.
        eexists; split.
        + econstructor; eauto.
        + rewrite hadd_hadd_ne by eauto.
          econstructor; eauto.
          rewrite hget_hadd_ne by eauto.
          eauto.
    }
    {
      eexists; split; eauto.
    }
  Qed.

  Theorem horiz_enabled_stable :
    forall `(op : sliceOpT T),
      enabled_stable sliceStep T op ->
      forall i,
        enabled_stable (horizStep indexT indexValid sliceStep) T (Slice i op).
  Proof.
    intros.
    unfold enabled_stable; intros.
    unfold enabled_in in *; repeat deex.
    inversion H1; clear H1; subst; repeat sigT_eq.
    inversion H2; clear H2; subst; repeat sigT_eq; eauto.
    repeat destruct_validIndex.
    destruct (x == x0); subst.
    - edestruct H.
      eassumption.
      unfold enabled_in; eauto.
      replace i0 with i in * by apply proof_irrelevance; eauto.
      repeat deex.
      do 3 eexists. econstructor; eauto.
      rewrite hget_hadd_eq; eauto.
    - do 3 eexists. econstructor; eauto.
      rewrite hget_hadd_ne; eauto.
  Qed.

  Local Theorem horiz_left_mover_ok :
    forall `(op : sliceOpT T),
      left_mover sliceStep op ->
      forall i,
        left_mover (horizStep indexT indexValid sliceStep) (Slice i op).
  Proof.
    intros.
    split; intros.
    - eapply horiz_enabled_stable.
      destruct H; eauto.
    - inversion H0; clear H0; subst; repeat sigT_eq.
      eapply H in H9 as H'; intuition subst.
      inversion H3; clear H3; subst; repeat sigT_eq.
      {
        repeat destruct_validIndex.
        destruct (x == x0); subst.
        * rewrite hget_hadd_eq in *.
          replace i0 with i in * by apply proof_irrelevance; eauto.
          eapply H1 in H8; eauto; deex.
          eexists; split.
          + econstructor; eauto.
          + rewrite hadd_hadd_eq.
            erewrite <- hadd_hadd_eq with (s := s').
            econstructor; eauto.
            rewrite hget_hadd_eq; eauto.
        * rewrite hget_hadd_ne in * by eauto.
          eexists; split.
          + econstructor; eauto.
          + rewrite hadd_hadd_ne by eauto.
            econstructor; eauto.
            rewrite hget_hadd_ne by eauto.
            eauto.
      }
      {
        eexists; split; eauto.
      }
  Qed.

  Local Theorem horiz_left_mover_pred_ok :
    forall `(op : sliceOpT T) P,
      left_mover_pred sliceStep op P ->
      forall i,
        left_mover_pred (horizStep indexT indexValid sliceStep) (Slice i op)
          (fun tid S => P tid (hget S i)).
  Proof.
    intros.
    split; intros.
    - eapply horiz_enabled_stable.
      destruct H; eauto.
    - inversion H0; clear H0; subst; repeat sigT_eq.
      eapply H in H9 as H'; intuition subst.
      inversion H4; clear H4; subst; repeat sigT_eq.
      {
        repeat destruct_validIndex.
        destruct (x == x0); subst.
        * rewrite hget_hadd_eq in *.
          replace i0 with i in * by apply proof_irrelevance; eauto.
          eapply H1 in H10; eauto; deex.
          eexists; split.
          + econstructor; eauto.
          + rewrite hadd_hadd_eq.
            erewrite <- hadd_hadd_eq with (s := s').
            econstructor; eauto.
            rewrite hget_hadd_eq; eauto.
        * rewrite hget_hadd_ne in * by eauto.
          eexists; split.
          + econstructor; eauto.
          + rewrite hadd_hadd_ne by eauto.
            econstructor; eauto.
            rewrite hget_hadd_ne by eauto.
            eauto.
      }
      {
        eexists; split; eauto.
      }
  Qed.

  Hint Resolve horiz_right_mover_ok.
  Hint Resolve horiz_left_mover_ok.
  Hint Resolve horiz_left_mover_pred_ok.

  Lemma atomic_exec_horizStep : forall `(p0 : proc _ T) i tid S v S' evs,
    atomic_exec (horizStep indexT indexValid sliceStep) p0 tid S v S' evs ->
      forall p,
        p0 = SliceProc i p ->
        exists s',
          atomic_exec sliceStep p tid (hget S i) v s' evs /\
          S' = hadd i s' S.
  Proof.
    induction 1; simpl; intros.
    - destruct p; simpl in *; try congruence.
      inversion H; clear H; subst; repeat sigT_eq.
      eexists; split; eauto.
      destruct_validIndex.
      rewrite hadd_hget_eq; eauto.
    - destruct p; simpl in *; try congruence.
      inversion H1; clear H1; subst; repeat sigT_eq.
      edestruct IHatomic_exec1; eauto.
      edestruct IHatomic_exec2; eauto.
      intuition subst.
      destruct_validIndex.
      rewrite hget_hadd_eq in *.
      eexists; split; eauto.
      rewrite hadd_hadd_eq; eauto.
    - destruct p; simpl in *; try congruence.
      inversion H0; clear H0; subst; repeat sigT_eq.
      inversion H; clear H; subst; repeat sigT_eq.
      eauto.
    - destruct p0; simpl in *; try congruence.
      inversion H0; clear H0; subst; repeat sigT_eq.
      edestruct IHatomic_exec.
      + unfold until1.
        instantiate (1 := Bind (p0 v0) (fun x => if (c0 x) then Ret x else Until c0 (fun x0 => p0 x0) (Some x))).
        simpl; f_equal.
        eapply functional_extensionality; intros.
        destruct (c0 x); reflexivity.
      + intuition subst.
        eexists; split; eauto.
  Qed.

  Local Lemma hadd_hget_eq' : forall (i: validIndexT indexValid) (s: horizState _ _ sliceState),
      s = hadd i (hget s i) s.
  Proof.
    intros.
    destruct_validIndex.
    rewrite hadd_hget_eq; auto.
  Qed.

  Hint Resolve hadd_hget_eq'.

  Local Lemma exec_tid_slice :
    forall S1 S2 tid `(p : proc _ T) r spawned evs,
      exec_tid (horizStep indexT indexValid sliceStep) tid S1 p S2 r spawned evs ->
      forall `(p' : proc _ T) i,
        p = SliceProc i p' ->
        exists spawned' s' r',
        spawned = match spawned' with
                  | Proc p => Proc (SliceProc i p)
                  | NoProc => NoProc
                  end /\
          exec_tid sliceStep tid (hget S1 i) p' s' r' spawned' evs /\
          S2 = hadd i s' S1 /\
          match r with
          | inl v => r' = inl v
          | inr rx => exists rx', r' = inr rx' /\ rx = SliceProc i rx'
          end.
  Proof.
    induction 1; intros; subst.
    - exists NoProc; simpl.
      destruct p'; simpl in *; try congruence.
      invert H.
      descend; simpl; intuition eauto.
    - exists NoProc; simpl.
      destruct p'; simpl in *; try congruence.
      invert H0.
      invert H.
      eauto 10.
    - exists NoProc; simpl.
      destruct p'; simpl in *; try congruence.
      inversion H0; clear H0; subst; repeat sigT_eq.
      eapply atomic_exec_horizStep in H; eauto; deex.
      eauto 10.
    - destruct p'; simpl in *; try congruence.
      inversion H0; clear H0; subst; repeat sigT_eq.
      edestruct IHexec_tid; eauto; repeat deex.
      descend; intuition eauto.
      destruct result; subst; eauto.
      deex; eauto.
    - exists NoProc; simpl.
      destruct p'; simpl in *; try congruence.
      invert H.
      descend; intuition eauto.
      descend; intuition eauto.
      unfold until1; simpl.
      f_equal.
      extensionality x.
      destruct matches.
    - dependent destruction p'; simpl in *; try congruence.
      invert H.
      eexists (Proc _).
      descend; intuition eauto.
  Qed.

  Local Lemma exec_any_slice :
    forall S1 S2 tid `(p : proc _ T) r,
      exec_any (horizStep indexT indexValid sliceStep) tid S1 p r S2 ->
      forall `(p' : proc _ T) i,
        p = SliceProc i p' ->
        exec_any sliceStep tid (hget S1 i) p' r (hget S2 i).
  Proof.
    induction 1; intros; subst.
    - inversion H0; clear H0; subst; repeat sigT_eq; eauto.
      repeat destruct_validIndex.
      destruct (x == x0); subst; eauto.
      + replace i0 with i in * by apply proof_irrelevance.
        eapply ExecAnyOther.
        eassumption.
        2: eauto.
        rewrite hget_hadd_eq in *.
        eauto.
      + specialize (IHexec_any _ _ eq_refl).
        rewrite hget_hadd_ne in * by eauto.
        eauto.
    - eapply exec_tid_slice in H; eauto; repeat deex.
      destruct_validIndex.
      rewrite hget_hadd_eq; eauto.
    - eapply exec_tid_slice in H; eauto; repeat deex.
      eapply ExecAnyThisMore; eauto.
      specialize (IHexec_any _ _ eq_refl).
      destruct_validIndex.
      rewrite hget_hadd_eq in *.
      eapply IHexec_any.
  Qed.

  Local Lemma exec_others_slice :
    forall S1 S2 tid,
      exec_others (horizStep indexT indexValid sliceStep) tid S1 S2 ->
      forall i,
        exec_others sliceStep tid (hget S1 i) (hget S2 i).
  Proof.
    induction 1; intros; eauto.
    repeat deex.
    inversion H1; clear H1; subst; repeat sigT_eq; eauto.
    repeat destruct_validIndex.
    destruct (x0 == x1); subst; eauto.
    * replace i0 with i in * by apply proof_irrelevance.
      econstructor; [ | apply IHclos_refl_trans_1n ].
      do 5 eexists; split; eauto.
      rewrite hget_hadd_eq; eauto.
    * specialize (IHclos_refl_trans_1n (exist _ x0 i)).
      rewrite hget_hadd_ne in * by eauto.
      eauto.
  Unshelve.
    all: try exact (Ret tt).
  Qed.

  Hint Resolve exec_any_slice.
  Hint Resolve exec_others_slice.

  Local Lemma horiz_left_movers :
    forall `(p : proc _ T) P,
      left_movers sliceStep P p ->
      forall i,
        left_movers (horizStep indexT indexValid sliceStep)
          (fun tid S => P tid (hget S i))
          (SliceProc i p).
  Proof.
    induction 1; simpl; intros; eauto.
    econstructor; intros.
    - eauto.
    - eapply H0 in H3.
      edestruct H3; repeat deex.
      do 3 eexists.
      constructor.
      eauto.
    - eapply left_movers_impl; eauto.
      simpl; intros; repeat deex.

      do 2 eexists.
      intuition eauto.
  Qed.

  Local Theorem horiz_ysa_movers :
    forall `(p : proc _ T),
      ysa_movers sliceStep p ->
      forall i,
        ysa_movers (horizStep indexT indexValid sliceStep) (SliceProc i p).
  Proof.
    unfold ysa_movers; intros.
    eapply right_movers_impl with
      (P1 := fun tid S => any tid (hget S i));
      [ | firstorder ].
    generalize dependent H.
    generalize (@any sliceState).
    intros.
    induction H.
    {
      simpl.
      econstructor; eauto; intros.
      eapply right_movers_impl; eauto.
      simpl; intros; repeat deex.

      do 2 eexists.
      intuition eauto.
    }

    eapply RightMoversDone.
    inversion H; clear H; subst; repeat sigT_eq.
    {
      eapply ZeroNonMovers.
      eapply horiz_left_movers; eauto.
    }

    simpl.
    eapply OneNonMover.
    {
      intros.
      eapply left_movers_impl.
      eapply horiz_left_movers; eauto.
      simpl; intros; repeat deex.

      do 2 eexists.
      intuition eauto.
    }

    eapply OneFinalNonMover.
  Qed.

End HorizontalCompositionMovers.

(** Module structures for horizontal composition *)

Module Type HIndex.
  Axiom indexT : Type.
  Axiom indexValid : indexT -> Prop.
  Axiom indexCmp : Ordering indexT.
End HIndex.

Module HOps (o : Ops) (i : HIndex) <: Ops.
  Definition Op := horizOpT i.indexValid o.Op.
End HOps.

Module HState (s : State) (i : HIndex) <: State.
  Definition State := @horizState i.indexT i.indexCmp i.indexValid s.State.
End HState.

Module HLayer (o : Ops) (s : State) (l : Layer o s) (i : HIndex).
  Definition step := @horizStep i.indexT i.indexCmp i.indexValid _ _ l.step.
  Definition initP : @horizState i.indexT i.indexCmp i.indexValid s.State -> Prop :=
    horizInitP l.initP.
End HLayer.

Module HProtocol (o : Ops) (s : State) (p : Protocol o s) (i : HIndex).
  Module ho := HOps o i.
  Module hs := HState s i.
  Definition step_allow T (hop : ho.Op T) (tid : nat) (S : hs.State) : Prop :=
    match hop with
    | Slice i op =>
      p.step_allow op tid (hget S i)
    | CheckSlice i =>
      True
    end.
End HProtocol.

Module Type HLayerImplAbsT
       (o:Ops)
       (s1: State) (l1: Layer o s1)
       (s2: State) (l2: Layer o s2).
  Parameter absR : s1.State -> s2.State -> Prop.
  Parameter absR_ok : op_abs absR l1.step l2.step.

  Parameter initP_map: forall (s1:s1.State), {s2:s2.State | l1.initP s1 -> absR s1 s2 /\ l2.initP s2}.

End HLayerImplAbsT.

Module LayerImplAbsT_from_H
       (o:Ops)
       (s1:State) (l1:Layer o s1)
       (s2:State) (l2:Layer o s2)
       (a: HLayerImplAbsT o s1 l1 s2 l2) <: LayerImplAbsT o s1 l1 s2 l2.
  Include a.

  Theorem absInitP : forall s1,
      l1.initP s1 ->
      exists s2, absR s1 s2 /\
            l2.initP s2.
  Proof.
    intros.
    destruct (initP_map s1); eauto.
  Qed.

End LayerImplAbsT_from_H.

Module HLayerImplAbs
       (o:Ops)
       (s1:State) (l1:Layer o s1)
       (s2:State) (l2:Layer o s2)
       (a: HLayerImplAbsT o s1 l1 s2 l2).
  Module a' := LayerImplAbsT_from_H o s1 l1 s2 l2 a.
  Include (LayerImplAbs o s1 l1 s2 l2 a').
End HLayerImplAbs.

Module LayerImplAbsHT
  (o : Ops)
  (s1 : State) (l1 : Layer o s1)
  (s2 : State) (l2 : Layer o s2)
  (a : HLayerImplAbsT o s1 l1 s2 l2)
  (i : HIndex).

  Module ho := HOps o i.
  Module hs1 := HState s1 i.
  Module hs2 := HState s2 i.
  Module hl1 := HLayer o s1 l1 i.
  Module hl2 := HLayer o s2 l2 i.

  Definition absR :=
    @horizAbsR i.indexT i.indexCmp i.indexValid _ _ a.absR.

  Theorem absInitP :
    forall s1,
      hl1.initP s1 ->
      exists s2, absR s1 s2 /\
      hl2.initP s2.
  Proof.
    intros.
    eapply horizAbsR_initP_ok
      with (initP_map := fun s1 => proj1_sig (a.initP_map s1)) in H;
      propositional; eauto.
    pose proof (proj2_sig (a.initP_map s0));
      simpl in *; propositional; eauto.
  Qed.

  Theorem absR_ok :
    op_abs absR hl1.step hl2.step.
  Proof.
    eapply horizAbsR_ok.
    apply a.absR_ok.
  Qed.

End LayerImplAbsHT.

Module LayerImplMoversProtocolHT
  (s : State)
  (o1 : Ops) (l1raw : Layer o1 s) (l1 : Layer o1 s)
  (o2 : Ops) (l2 : Layer o2 s)
  (p : Protocol o1 s)
  (a : LayerImplMoversProtocolT s o1 l1raw l1 o2 l2 p)
  (i : HIndex).

  Module hs := HState s i.
  Module ho1 := HOps o1 i.
  Module ho2 := HOps o2 i.
  Module hl1raw := HLayer o1 s l1raw i.
  Module hl1 := HLayer o1 s l1 i.
  Module hl2 := HLayer o2 s l2 i.
  Module hp := HProtocol o1 s p i.

  Definition compile_op T (op : ho2.Op T) : proc ho1.Op T :=
    match op with
    | Slice i op => SliceProc i (a.compile_op op)
    | CheckSlice i => Call (CheckSlice i)
    end.

  Theorem compile_op_no_atomics : forall T (op : ho2.Op T),
    no_atomics (compile_op op).
  Proof.
    destruct op; simpl; eauto.
    pose proof (a.compile_op_no_atomics op).
    generalize dependent H.
    generalize (a.compile_op op).
    clear.
    induction 1; simpl; eauto.
  Qed.

  Theorem ysa_movers : forall T (op : ho2.Op T),
    ysa_movers hl1.step (compile_op op).
  Proof.
    destruct op; simpl; eauto.
    eapply horiz_ysa_movers.
    eapply a.ysa_movers.
  Qed.

  Theorem compile_correct :
    compile_correct compile_op hl1.step hl2.step.
  Proof.
    intro; intros.
    destruct op; simpl in *.
    - eapply atomic_exec_horizStep in H; eauto; deex.
      eapply a.compile_correct in H.
      econstructor; eauto.
    - repeat atomic_exec_inv.
      inversion H5; clear H5; subst; repeat sigT_eq.
      econstructor; eauto.
  Qed.

  Existing Instance i.indexCmp.

  Hint Rewrite hget_hadd_eq_general : h.
  Hint Rewrite hget_hadd_ne_general using solve [ auto ] : h.

  Lemma step_high_to_step_low :
    forall s s' (i: validIndexT i.indexValid) T (op: hp.ho.Op T) tid r evs,
      restricted_step hl1raw.step hp.step_allow op tid s r s' evs ->
      (exists (op': o1.Op T) r' evs',
          restricted_step l1raw.step p.step_allow op' tid (hget s i) r' (hget s' i) evs') \/
      hget s i = hget s' i.
  Proof.
    intros.
    unfold restricted_step in *; propositional.
    unfold hp.step_allow, hl1raw.step in *.
    invert H0; clear H0.
    - destruct (i == idx); subst;
        autorewrite with h;
        eauto 10.
    - eauto.
  Qed.

  Lemma exec_ops_high : forall s s' (i: validIndexT i.indexValid),
      exec_ops (restricted_step hl1raw.step hp.step_allow) s s' ->
      exec_ops (restricted_step l1raw.step p.step_allow) (hget s i) (hget s' i).
  Proof.
    unfold exec_ops; intros.
    induction H; propositional.
    reflexivity.

    transitivity (hget y i); auto.
    eapply step_high_to_step_low with (i:=i) in H;
      (intuition propositional);
      eauto.
    - econstructor; [ | reflexivity ].
      descend; eauto.
    - replace (hget y i).
      reflexivity.
  Qed.

  Theorem op_follows_protocol : forall tid s `(op : ho2.Op T),
    follows_protocol_proc hl1raw.step hp.step_allow tid s (compile_op op).
  Proof.
    destruct op; simpl.
    - pose proof (a.op_follows_protocol tid (hget s i) op).
      generalize dependent (a.compile_op op); intros; clear dependent op.
      remember (hget s i).
      generalize dependent s.
      generalize dependent i.
      induction H; intros; subst; simpl.
      + constructor. eauto.
      + constructor. eauto.
        intros.
        eapply H1; eauto.
        eapply exec_any_slice; eauto.
        eapply exec_any_impl; try eassumption.

        clear.
        unfold restricted_step; intuition idtac.
        inversion H1; clear H1; subst; repeat sigT_eq; simpl in *.
        * econstructor; eauto.
        * econstructor; eauto.
      + constructor; intros.
        eapply H0; eauto.
      + constructor.
      + constructor; intros.
        assert (forall tid', tid <> tid' ->
                        follows_protocol_proc hl1raw.step hp.step_allow
                                              tid' s0 (SliceProc i p)).
        eauto.
        rename H into Hspawn.
        unfold spawn_follows_protocol; intros.
        specialize (H1 tid' ltac:(auto)).
        specialize (H0 tid' ltac:(auto)).
        specialize (Hspawn tid' ltac:(auto)).

        assert (exec_ops (restricted_step l1raw.step p.step_allow)
                         (hget s0 i) (hget s' i)).
        eapply exec_ops_high; eauto.
        eauto.
    - constructor; constructor.
  Qed.

  Theorem allowed_stable :
    forall `(op : ho1.Op T) `(op' : ho1.Op T') tid tid' s s' r evs,
      tid <> tid' ->
      hp.step_allow op tid s ->
      hl1.step op' tid' s r s' evs ->
      hp.step_allow op tid s'.
  Proof.
    destruct op, op'; eauto.
    {
      intros.
      simpl in *.
      inversion H1; clear H1; subst; repeat sigT_eq.
      pose (i.indexCmp).
      repeat destruct_validIndex.
      destruct (x == x0); subst.
      - replace i0 with i in * by apply proof_irrelevance.
        rewrite hget_hadd_eq.
        eapply a.allowed_stable; eauto.
      - rewrite hget_hadd_ne in * by eauto.
        eauto.
    }
    {
      intros.
      inversion H1; subst; eauto.
    }
  Qed.

  Theorem raw_step_ok :
    forall `(op : ho1.Op T) tid s r s' evs,
      restricted_step hl1raw.step hp.step_allow op tid s r s' evs ->
      hl1.step op tid s r s' evs.
  Proof.
    destruct op.
    - unfold restricted_step; intuition idtac.
      inversion H1; clear H1; subst; repeat sigT_eq.
      econstructor; eauto.
      eapply a.raw_step_ok.
      constructor; eauto.
    - unfold restricted_step; intuition idtac.
      inversion H1; clear H1; subst; repeat sigT_eq.
      econstructor; eauto.
  Qed.

  Theorem initP_compat : forall s, hl1.initP s -> hl2.initP s.
  Proof.
    unfold hl1.initP, hl2.initP, horizInitP; intros.
    specialize (H i); propositional.
    eauto using a.initP_compat.
  Qed.

  Theorem raw_initP_compat : forall s, hl1raw.initP s -> hl1.initP s.
  Proof.
    unfold hl1raw.initP, hl1.initP, horizInitP; intros.
    specialize (H i); propositional.
    eauto using a.raw_initP_compat.
  Qed.

End LayerImplMoversProtocolHT.

Module LayerImplMoversHT
  (s : State)
  (o1 : Ops) (l1 : Layer o1 s)
  (o2 : Ops) (l2 : Layer o2 s)
  (a : LayerImplMoversT s o1 l1 o2 l2)
  (i : HIndex).

  Module hs := HState s i.
  Module ho1 := HOps o1 i.
  Module ho2 := HOps o2 i.
  Module hl1 := HLayer o1 s l1 i.
  Module hl2 := HLayer o2 s l2 i.

  Definition compile_op T (op : ho2.Op T) : proc ho1.Op T :=
    match op with
    | Slice i op => SliceProc i (a.compile_op op)
    | CheckSlice i => Call (CheckSlice i)
    end.

  Theorem compile_op_no_atomics : forall T (op : ho2.Op T),
    no_atomics (compile_op op).
  Proof.
    destruct op; simpl; eauto.
    pose proof (a.compile_op_no_atomics op).
    generalize dependent H.
    generalize (a.compile_op op).
    clear.
    induction 1; simpl; eauto.
  Qed.

  Theorem ysa_movers : forall T (op : ho2.Op T),
    ysa_movers hl1.step (compile_op op).
  Proof.
    destruct op; simpl; eauto.
    eapply horiz_ysa_movers.
    eapply a.ysa_movers.
  Qed.

  Theorem compile_correct :
    compile_correct compile_op hl1.step hl2.step.
  Proof.
    intro; intros.
    destruct op; simpl in *.
    - eapply atomic_exec_horizStep in H; eauto; deex.
      eapply a.compile_correct in H.
      econstructor; eauto.
    - repeat atomic_exec_inv.
      inversion H5; clear H5; subst; repeat sigT_eq.
      econstructor; eauto.
  Qed.

  Theorem initP_compat :
    forall s, hl1.initP s -> hl2.initP s.
  Proof.
    unfold hl1.initP, hl2.initP.
    unfold horizInitP; intros.
    specialize (H i); propositional.
    eauto using a.initP_compat.
  Qed.

End LayerImplMoversHT.

Module LayerImplLoopHT
  (s : State)
  (o1 : Ops) (l1 : Layer o1 s)
  (o2 : Ops) (l2 : Layer o2 s)
  (a : LayerImplLoopT s o1 l1 o2 l2)
  (i : HIndex).

  Module hs := HState s i.
  Module ho1 := HOps o1 i.
  Module ho2 := HOps o2 i.
  Module hl1 := HLayer o1 s l1 i.
  Module hl2 := HLayer o2 s l2 i.

  Definition compile_op T (op : ho2.Op T) :
    (option T -> ho1.Op T) * (T -> bool) * option T :=
    match op with
    | Slice idx op' =>
      let '(p, cond, i) := a.compile_op op' in
        ((fun x => Slice idx (p x)), cond, i)
    | CheckSlice idx =>
      ((fun x => CheckSlice idx),
        fun _ => true,
        None)
    end.

  Theorem noop_or_success :
    noop_or_success compile_op hl1.step hl2.step.
  Proof.
    intro; intros.
    destruct opM; simpl in *.
    {
      destruct (a.compile_op op) eqn:He.
      destruct p.
      inversion H; clear H; subst.
      inversion H0; clear H0; subst; repeat sigT_eq.
      edestruct a.noop_or_success; eauto.
      - left. intuition idtac.
        subst.
        destruct_validIndex.
        rewrite hadd_hget_eq; eauto.
      - right. intuition idtac.
        econstructor; eauto.
    }
    {
      inversion H; clear H; subst.
      inversion H0; clear H0; subst; repeat sigT_eq.
      right; intuition eauto.
      econstructor; eauto.
    }
  Qed.

  Theorem initP_compat :
    forall s, hl1.initP s -> hl2.initP s.
  Proof.
    unfold hl1.initP, hl2.initP.
    unfold horizInitP; intros.
    specialize (H i); propositional.
    eauto using a.initP_compat.
  Qed.

End LayerImplLoopHT.


(** A completely interactive command with variable amount of obligations **)

Require Import MetaCoq.Template.All.

Require Import List String.
Import ListNotations MonadNotation Nat.

Fixpoint printer (n:nat) :=
match n with
| O => tmMsg "All Done";;
       tmReturn 0
| S m =>
  name <- tmFreshName "tmp";;
  a <- tmLemma name nat;;
  ssum <- (printer m);;
  tmReturn (ssum + a)
end.

MetaCoq Run (n <- tmLemma "t1" nat;;
n' <- tmEval all n;;
sum <- printer n';;
sumR <- tmEval all sum;;
tmPrint sumR).
Next Obligation.
  exact 2.
Defined.
Next Obligation.
  exact 3.
Defined.
Next Obligation.
  exact 4.
Defined.