From Coq Require Export List.
Import ListNotations.
Local Open Scope list_scope.
Require Import Nat.
Require Import Psatz.
Require Import ZArith.

Require Import Common.
Require Import Basic.
Require Import Lt.
Require Import Plus.

Definition siglist := {x : bilist | ltb (length x) 6 = true}.

Program Definition foo (a: {x: nat | ltb x 6 = true}) :  {x: nat | ltb x 7 = true} := S a.

Lemma lt_sum : forall (a b c d : bilist),
    binary_lt a b -> binary_lt c d -> binary_lt (plus a c) (plus a d).
Proof.
    intros.
    induction a.
    simpl.
    assumption.
    simpl.
    destruct a.
    remember (length (plus a0 c) - length a0).
    remember (plus a0 c).
    remember (length (plus a0 d) - length a0).
    remember (plus a0 d).
    destruct n.
    simpl.
    destruct n0.
    simpl.
    constructor 3.
    apply IHa.
    apply binary_lt_trans with (b := E1 :: a0).
    constructor.
    auto.
    assumption.
    simpl.
    destruct b1.
    simpl.
    simpl in Heqn0.
    lia.
    simpl.
    destruct b1.
    remember (length (incr1 (firstn n0 b2)) =? length (firstn n0 b2)).
    destruct b1.
    simpl.
    constructor.
    simpl.
    symmetry in Heqb2.

Lemma plus_help : forall (b b1 : bilist),
    Forall (eq E2) (plus b b1) -> length b1 < length b -> length (plus b b1) = length b.
Proof.
    induction b using list_ind_length.
    intros.
    simpl.
    inversion H0.
    intros.
    destruct b.
    inversion H1.
    rewrite plus_plus'.
    destruct b.
    simpl.
    unfold plus'.
    remember (plus b b1).
    destruct b0.
    simpl.
    destruct b.
    simpl.
    auto.
    simpl in Heqb0.
    destruct b.
    assert (incr1 (firstn (length (plus b0 b1) - length b0) (plus b0 b1)) <> []).
    apply neq_in.
    remember (incr1 (firstn (length (plus b0 b1) - length b0) (plus b0 b1))).
    destruct b.
    contradiction.
    inversion Heqb0.
    rewrite <- incr2_incr1 in Heqb0.
    remember (incr1 (incr1 (firstn (length (plus b0 b1) - length b0) (plus b0 b1)))).
    destruct b.
    assert (incr1 (incr1 (firstn (length (plus b0 b1) - length b0) (plus b0 b1))) <> []).
    apply neq_in.
    rewrite Heqb in H1.
    contradiction.
    inversion Heqb0.
    destruct b0.

Program Definition sigmaplus (n : nat) (b b1: {x: bilist | ltb (length x) n = true}) :  {x: bilist | ltb (length x) (1 + n) = true} := plus b b1.

Next Obligation.
    rewrite plus_plus'.
    induction b using bilist_incr_ind.
    simpl.
    rewrite Nat.ltb_lt.
    rewrite Nat.ltb_lt in H.
    lia.
    rewrite <- plus_plus'.
    rewrite plus_incr1_left.
    rewrite plus_plus'.
    remember (plus' b b1).
    destruct b0.
    simpl.
    rewrite Nat.ltb_lt.
    rewrite Nat.ltb_lt in H0.
    assert (0 < length (incr1 b)).
    induction b.
    simpl.
    auto.
    destruct a; simpl; destruct (length (incr1 b) =? length b); simpl; lia.
    lia.
    destruct b0;
    simpl; remember (length (incr1 b2) =? length b2); destruct b0; simpl.
    enough ((length b <? n) = true ).
    apply IHb in H1.
    simpl in *.
    rewrite Nat.ltb_lt in *.
    destruct b2.
    simpl in *.
    inversion Heqb1.
    Search (_ =? _ = true).
    symmetry in Heqb1.
    rewrite Nat.eqb_eq in Heqb1.
    rewrite Heqb1.
    apply H1.
    rewrite Nat.ltb_lt in *.
    assert (length b <= length (incr1 b)).
    apply incr1_length.
    lia.
    rewrite tl_S.
    symmetry in Heqb1.
    apply length_eq_incr_S in Heqb1.
    rewrite Heqb1.
    assert (length b <= length (incr1 b)).
    apply incr1_length.
    rewrite Nat.ltb_lt in *.
    enough (length b < n).
    apply IHb in H2.
    rewrite Nat.ltb_lt in *.
    simpl in *.
    lia.
    lia.
    symmetry in Heqb1.
    rewrite Nat.eqb_eq in Heqb1.
    rewrite Heqb1.
    rewrite Nat.ltb_lt in *.
    enough (length b < n).
    apply IHb in H1.
    rewrite Nat.ltb_lt in *.
    simpl in *.
    lia.
    assert (length b <= length (incr1 b)).
    apply incr1_length.
    lia.
    symmetry in Heqb1.
    apply length_eq_incr_S in Heqb1.
    rewrite Heqb1.
    assert (length b <= length (incr1 b)).
    apply incr1_length.
    rewrite Nat.ltb_lt in *.
    assert (length b < n).
    lia.
    apply IHb in H2.
    rewrite Nat.ltb_lt in *.
    simpl in *.

assert (length b <= length (incr1 b)).
apply incr1_length.
lia.
assert (length b <= length (incr1 b)).
apply incr1_length.
lia.
rewrite tl_S.
symmetry in Heqb1.
apply length_eq_incr_S in Heqb1.
rewrite Heqb1.
assert (length b <= length (incr1 b)).
apply incr1_length.
rewrite Nat.ltb_lt in *.
enough (length b < n).
apply IHb in H2.
rewrite Nat.ltb_lt in *.
simpl in *.
lia.
lia.

rewrite app_length.
rewrite skipn_length.
replace (length (plus b b1) - (length (plus b b1) - length b)) with (length b).
remember (firstn (length (plus b b1) - length b) (plus b b1)).
destruct l.
simpl.
rewrite Nat.ltb_lt.
rewrite Nat.ltb_lt in H0.
simpl in H0.
lia.
simpl in H0.
destruct b0.
simpl.
remember (length (incr1 l) =? length l).
destruct b0.
simpl.
destruct l.
simpl.
rewrite Nat.ltb_lt.
rewrite Nat.ltb_lt in H0.
lia.
simpl.
destruct b0.

apply IHb.

Admitted.
Fail Next Obligation.


Set Automatic Coercions Import.

Require interval_abstraction square_flow_conditions concrete EquivDec.
Require Import List util list_util c_util geometry monotonic_flow stability.
Require Import Morphisms.

Set Implicit Arguments.

Open Scope CR_scope.

Section contents.

  Inductive Reset :=
    | Reset_id
    | Reset_const (c: CR)
    | Reset_map (m: sigT increasing).
  (* we distinguish between const and map because
  for a const reset function with value c, a range with an infinite
  bound [a, inf) should be mapped to [c, c], not to [c, inf).
  we distinguish between id and map because it lets us
  avoid senseless discrete transitions between adjacent regions. *)

  Definition apply_Reset (r: Reset) (v: CR): CR :=
    match r with
    | Reset_id => v
    | Reset_const c => c
    | Reset_map m => proj1_sigT _ _ m v
    end.

  (* If one has a concrete hybrid system.. *)

  Variable chs: concrete.System.

  (* .. and points in that system basically correspond to points in the plane.. *)

  Variables px py:
    morpher (@st_eq (concrete.Point chs) ==> @st_eq CRasCSetoid)%signature.

  Hypothesis xyp: geometry.Point -> concrete.Point chs.
  Definition pxy (p: concrete.Point chs): geometry.Point := (px p, py p).

  Hypotheses
    (xyp_pxy: forall p, xyp (pxy p) = p)
    (px_xyp: forall p, px (xyp p) = fst p)
    (py_xyp: forall p, py (xyp p) = snd p).

  (* .. and flow in that system is separable over the two axes.. *)

  Variables
    (xflow yflow: concrete.Location chs -> Flow CRasCSetoid)
    (xflow_invr yflow_invr: concrete.Location chs -> OpenRange -> OpenRange -> OpenRange)
    (xflow_invr_correct: forall l, range_flow_inv_spec (xflow l) (xflow_invr l))
    (yflow_invr_correct: forall l, range_flow_inv_spec (yflow l) (yflow_invr l)).

  Hypothesis flow_separable: forall l p t,
    concrete.flow chs l p t = xyp (product_flow (xflow l) (yflow l) (pxy p) t).

  (* .. and on both axes, abstraction parameters can be formed based on
   OpenRange regions.. *)

  Context
    {Xinterval Yinterval: Set}
    {Xinterval_eq_dec: EquivDec.EqDec Xinterval eq}
    {Yinterval_eq_dec: EquivDec.EqDec Yinterval eq}
    {Xintervals: ExhaustiveList Xinterval}
    {Yintervals: ExhaustiveList Yinterval}.

  Variables
    (NoDup_Xintervals: NoDup Xintervals)
    (NoDup_Yintervals: NoDup Yintervals)
    (Xinterval_range: Xinterval -> OpenQRange)
    (Yinterval_range: Yinterval -> OpenQRange)
    (absXinterval: forall (l: concrete.Location chs) (p: concrete.Point chs), concrete.invariant (l, p) ->
      DN (sig (fun i: Xinterval => in_orange (Xinterval_range i) (px p))))
    (absYinterval: forall (l: concrete.Location chs) (p: concrete.Point chs), concrete.invariant (l, p) ->
      DN (sig (fun i: Yinterval => in_orange (Yinterval_range i) (py p)))).
        (* No need for LazyProp, because these are not used in computation anyway. *)

  Definition ap: abstract.Space chs :=
    abstract.prod_space
      (interval_abstraction.space chs px NoDup_Xintervals Xinterval_range absXinterval)
      (interval_abstraction.space chs py NoDup_Yintervals Yinterval_range absYinterval).

  Definition square: abstract.Region ap -> OpenQSquare :=
    prod_map Xinterval_range Yinterval_range.

  (*  .. then we can define useful things.

  For instance, we can easily make an invariant overestimator (if one's
  invariant can be overestimated by a list of open squares): *)

  Program Definition make_invariant_overestimator
    (invariant_squares: forall l: concrete.Location chs, sig (fun s: OpenSquare =>
      forall p, concrete.invariant (l, p) -> in_osquare (pxy p) s)) eps:
        overestimator (@abstract.invariant _ ap) :=
    fun li => overestimate_osquares_overlap eps (invariant_squares (fst li)) (square (snd li)).
  Next Obligation. Proof with auto.
    intros inv_squares eps li H [p [A B]].
    apply (overestimation_false _ H). clear H.
    destruct inv_squares. simpl proj1_sig.

    destruct p.
    destruct B. simpl in H.
    subst.
    apply osquares_share_point with (pxy s)...
  Qed.

  (* Similarly, if one's initial condition can be overestimated by
   an open square, we can make an initial_dec thingy. *)

  Section make_initial_overestimator.

    Variables
      (initial_location: concrete.Location chs)
      (initial_square: OpenSquare)
      (initial_representative: forall s, concrete.initial s ->
        fst s = initial_location /\ in_osquare (pxy (snd s)) initial_square).

    Program Definition make_initial_overestimator (eps: Qpos): overestimator
      (@abstract.Initial _ ap) := fun s =>
        (overestimate_conj (overestimate_osquares_overlap eps (initial_square) (square (snd s)))
          (decision_overestimation (concrete.Location_eq_dec chs (fst s) initial_location))).

    Next Obligation. Proof with auto.
      intros eps [l i] H [p [A B]].
      apply (overestimation_false _ H).
      destruct (initial_representative _ A).
      destruct B.
      split...
        apply osquares_share_point with (pxy (snd p))...
      rewrite <- H0.
      symmetry...
    Qed.

  End make_initial_overestimator.

  (* And similarly, if one's guard conditions can be overestimated by
  open squares, we can make a guard_dec thingy. *)

  Obligation Tactic := idtac.

  Definition GuardSquare l l' := sig
    (fun s: option OpenSquare => forall p, concrete.guard chs (l, p) l' ->
      match s with
      | None => False
      | Some v => in_osquare (pxy p) v
      end).

  Program Definition guard_dec (guard_square: forall l l', GuardSquare l l') eps:
    overestimator (@abstract.guard _ ap) := fun l r l' =>
      match guard_square l l' with
      | Some s => overestimate_osquares_overlap eps s (square r)
      | None => false
      end.

  Next Obligation. Proof with auto.
    intros gs eps l r l' fv s e H [x [A B]].
    apply (overestimation_false _ H).
    unfold abstract.guard in B.
    apply osquares_share_point with (pxy x)...
    destruct gs.
    simpl in fv.
    subst. subst...
  Qed.

  Next Obligation.
    intros gs eps l r l' fv s e [p [B C]].
    subst.
    destruct gs.
    simpl in s. subst. eauto.
  Qed.

  (* If the safety condition can be overestimated by a list of unsafe
   osquares, then we can select the unsafe abstract states automatically: *)

  Section square_safety.

    Variables
      (unsafe_concrete: concrete.State chs -> Prop)
      (unsafe_squares: concrete.Location chs -> list OpenSquare)
      (unsafe_squares_correct: forall s, unsafe_concrete s -> exists q,
        In q (unsafe_squares (fst s)) /\ in_osquare (pxy (snd s)) q)
      (eps: Qpos).

    Program Definition unsafe_abstract: abstract.CompleteCoverList ap unsafe_concrete
      := flat_map (fun l => map (pair l) (flat_map (fun q =>
        filter (fun s => overestimate_osquares_overlap eps q (square s)) exhaustive_list
        ) (unsafe_squares l))) (concrete.locations chs).

    Next Obligation. Proof with auto.
      intros _ s H r H0.
      apply <- in_flat_map.
      destruct H0.
      destruct s.
      exists l.
      split...
      destruct r.
      simpl in H0.
      subst.
      apply (in_map (pair l0)).
      destruct (unsafe_squares_correct H) as [x [H0 H2]].
      apply <- in_flat_map.
      eauto 10 using overestimation_true, osquares_share_point, in_filter.
    Qed.

  End square_safety.

  (* Everything above is pretty simplistic. We now prepare for more complex
   transition overestimators, for which we will require some more stuff: *)

  Variables
    (invariant_overestimator: overestimator (@abstract.invariant _ ap))
    (guard_decider: overestimator (@abstract.guard _ ap))
    (reset_x reset_y: concrete.Location chs -> concrete.Location chs -> Reset)
    (reset_components: forall p l l', pxy (concrete.reset chs l l' p) =
      (apply_Reset (reset_x l l') (px p), apply_Reset (reset_y l l') (py p))).

Lemma increasing_const x: increasing (const x).
  unfold increasing.
  intros.
  simpl.
  apply CRle_refl.
Defined.

Definition increasing_const' (x: CR): sigT increasing.
  exists (@const CR CR x).
  apply increasing_const.
Defined.

  Section disc_trans_regions.

    Variables (eps: Qpos) (l l': concrete.Location chs) (r: abstract.Region ap).

    Definition map_orange' (f: sigT increasing): OpenRange -> OpenRange
      := let (_, y) := f in map_orange y.

    Definition x_regions :=
      match reset_x l l' with
      | Reset_const c => filter (fun r' => overestimate_oranges_overlap eps
        (* (map_orange' (increasing_const' c) (Xinterval_range (fst r))) (Xinterval_range r')) Xintervals *)
        (unit_range c: OpenRange) (Xinterval_range r')) Xintervals
      | Reset_map f => filter (fun r' => overestimate_oranges_overlap eps
        (map_orange' f (Xinterval_range (fst r))) (Xinterval_range r')) Xintervals
      | Reset_id => [fst r] (* x reset is id, so we can only remain in this x range *)
      end.

    Definition y_regions :=
      match reset_y l l' with
      | Reset_const c => filter (fun r' => overestimate_oranges_overlap eps
        (unit_range c: OpenRange) (Yinterval_range r')) Yintervals
      | Reset_map f => filter (fun r' => overestimate_oranges_overlap eps
        (map_orange' f (Yinterval_range (snd r))) (Yinterval_range r')) Yintervals
      | Reset_id => [snd r] (* x reset is id, so we can only remain in this x range *)
      end.

    Definition disc_trans_regions: list (abstract.Region ap)
      :=
      if overestimation_bool (guard_decider l r l') &&
          overestimation_bool (invariant_overestimator (l, r)) then
       filter (fun s => overestimation_bool (invariant_overestimator (l', s))) (cart x_regions y_regions)
     else [].

  End disc_trans_regions.

  Definition raw_disc_trans (eps: Qpos) (s: abstract.State ap): list (abstract.State ap) :=
    let (l, r) := s in
    flat_map (fun l' => map (pair l') (disc_trans_regions eps l l' r)) (concrete.locations chs).

  Lemma NoDup_disc_trans eps s: NoDup (raw_disc_trans eps s).
  Proof with auto.
    intros.
    unfold raw_disc_trans.
    destruct s.
    apply NoDup_flat_map...
        intros.
        apply in_map_iff in H1.
        apply in_map_iff in H2.
        destruct H1. destruct H2.
        intuition.
        subst.
        inversion_clear H1...
      intros.
      apply NoDup_map.
        intros.
        inversion_clear H2...
      unfold disc_trans_regions.
      destruct andb...
      apply NoDup_filter.
      simpl.
      apply NoDup_cart.
        unfold x_regions.
        destruct (reset_x l x)...
      unfold y_regions.
      destruct (reset_y l x)...
    apply concrete.NoDup_locations.
  Qed.

  Hint Resolve in_map_orange.

  Definition is_id_reset (r: Reset): bool :=
    match r with
    | Reset_id => true
    | _ => false
    end.

  Hint Unfold abstract.invariant abstract.guard.

  Lemma respects_disc (eps: Qpos) (s1 s2 : concrete.State chs):
    concrete.disc_trans s1 s2 -> forall i1, abstract.in_region ap (snd s1) i1 ->
    DN (exists i2, abstract.in_region ap (snd s2) i2 /\
    In (fst s2, i2) (raw_disc_trans eps (fst s1, i1))).
  Proof with simpl; auto.
    destruct s1.
    destruct s2.
    intros [g [e [inv_src inv_dst]]] r H0.
    simpl in e.
    subst s0.
    rewrite <- (xyp_pxy (concrete.reset chs l l0 s)) in inv_dst.
    rewrite reset_components in inv_dst.
    apply (DN_bind (@absXinterval l0 (xyp (apply_Reset (reset_x l l0) (px s), apply_Reset (reset_y l l0) (py s))) inv_dst)). intros [xi xin].
    apply (DN_bind (@absYinterval l0 (xyp (apply_Reset (reset_x l l0) (px s), apply_Reset (reset_y l l0) (py s))) inv_dst)). intros [yi yin].
    apply DN_return.
    rewrite px_xyp in xin. rewrite py_xyp in yin.
    simpl @fst in xin. simpl @snd in yin.
    exists ( if is_id_reset (reset_x l l0) then fst r else xi,
      if is_id_reset (reset_y l l0) then snd r else yi).
    split.
      split.
        unfold abstract.in_region.
        simpl in *.
        unfold interval_abstraction.in_region.
        rewrite <- (xyp_pxy (concrete.reset chs l l0 s)).
        rewrite reset_components.
        rewrite px_xyp.
        destruct reset_x...
        intuition.
      unfold abstract.in_region.
      simpl in *.
      unfold interval_abstraction.in_region.
      rewrite <- (xyp_pxy (concrete.reset chs l l0 s)).
      rewrite reset_components.
      rewrite py_xyp.
      destruct reset_y...
      intuition.
    unfold raw_disc_trans.
    apply <- in_flat_map.
    exists l0.
    split...
    apply in_map.
    unfold disc_trans_regions.
    rewrite (overestimation_true (guard_decider l r l0)); [| eauto 20].
    rewrite (overestimation_true (invariant_overestimator (l, r))); [| eauto 20].
      simpl andb.
      cbv iota.
      apply in_filter.
        simpl.
        apply in_cart.
          simpl @fst.
          unfold x_regions.
          destruct reset_x; auto.
            apply in_filter; auto.
            apply overestimation_true.
            apply oranges_share_point with c...
            split...
(*
            destruct (Xinterval_range (@fst Xinterval Yinterval r)).
            unfold map_orange.
            simpl.
            unfold orange_left.
            simpl proj1_sig.
            simpl @fst.
            unfold option_map.
            unfold const.
            destruct x.
            destruct o0...
            unfold flip...
          destruct (Xinterval_range (@fst Xinterval Yinterval r)).
          unfold opt_prop. unfold orange_right. unfold map_orange.
          simpl. unfold option_map. destruct x. simpl.
          destruct o1...
*)

            unfold flip...
          apply in_filter; auto.
          apply overestimation_true.
          apply oranges_share_point with (apply_Reset (Reset_map m) (px s))...
          destruct m.
          simpl.
          simpl in i.
          apply in_map_orange.
          destruct H0...
        simpl @snd.
        unfold y_regions.
        destruct reset_y; auto.
          apply in_filter; auto.
          apply overestimation_true.
          apply oranges_share_point with c...
          split... unfold flip...
        apply in_filter; auto.
        apply overestimation_true.
        apply oranges_share_point with (apply_Reset (Reset_map m) (py s))...
        destruct m.
        simpl.
        simpl in i.
        apply in_map_orange.
        destruct H0...
      apply overestimation_true...
      unfold abstract.invariant.
      simpl.
      exists (l0, xyp (apply_Reset (reset_x l l0) (px s), apply_Reset (reset_y l l0) (py s))).
      split...
      split...
      unfold containers.In.
      unfold interval_abstraction.in_region.
      destruct H0.
      unfold containers.In.
      unfold abstract.abs.
      simpl.
      rewrite px_xyp, py_xyp.
      split; simpl.
        destruct (reset_x l l0)...
      destruct (reset_y l l0)...
    unfold abstract.invariant.
    exists (l, s).
    split...
    split...
  Qed.

  Program Definition disc_trans: Qpos ->
    abstract.sharing_transition_overestimator ap (@concrete.disc_trans chs) := raw_disc_trans.

  Next Obligation. Proof with auto.
    split.
      apply NoDup_disc_trans.
    unfold abstract.SharedCover.
    intros s [H0 [x1 [[H1 H3] H2]]].
    apply (DN_fmap (@respects_disc x x1 s H2 _ H3)).
    intros [x2 [H4 H5]].
    exists (fst s, x2).
    split. split...
    destruct x0.
    simpl in H1. subst...
  Qed.

  Obligation Tactic := idtac.

  Program Definition cont_trans_cond_dec eps l r r':
    overestimation (abstract.cont_trans ap l r r') :=
      square_flow_conditions.decide_practical
        (xflow_invr l) (yflow_invr l) (square r) (square r') eps &&
      invariant_overestimator (l, r) &&
      invariant_overestimator (l, r').

  Next Obligation. Proof with auto.
    intros eps l r r' cond.
    intros [p [q [pi [qi [[t tn] [ctc cteq]]]]]].
    simpl proj1_sig in ctc. simpl proj1_sig in cteq.
    destruct (andb_false_elim _ _ cond); clear cond.
      destruct (andb_false_elim _ _ e); clear e.
        apply (overestimation_false _ e0). clear e0.
        apply square_flow_conditions.ideal_implies_practical_decideable with (xflow l) (yflow l)...
            intros. apply xflow_invr_correct with x...
          intros. apply yflow_invr_correct with y...
        unfold square_flow_conditions.ideal.
        exists (pxy p). split...
        exists t. split.
          apply (CRnonNeg_le_zero t)...
        unfold square_flow_conditions.f.
        simpl @fst. simpl @snd.
        rewrite <- cteq in qi.
        rewrite flow_separable in qi.
        simpl in qi.
        unfold interval_abstraction.in_region in qi.
        unfold containers.In in qi.
        rewrite px_xyp in qi.
        rewrite py_xyp in qi.
        simpl in qi.
        destruct qi.
        split...
      apply (overestimation_false _ e0).
      unfold abstract.invariant.
      exists (l, p).
      split...
      unfold containers.In.
      unfold containers.predicate_container.
      rewrite (curry_eq concrete.invariant).
      rewrite <- (flow_zero (concrete.flow chs l) p).
      simpl. apply ctc... apply (CRnonNeg_le_zero t)...
      split...
    apply (overestimation_false _ e).
    exists (l, q).
    split...
    unfold containers.In, containers.predicate_container.
    rewrite (curry_eq concrete.invariant).
    rewrite <- cteq.
    simpl. apply ctc... apply (CRnonNeg_le_zero t)...
    split...
  Qed.

End contents.


Require Import JMeq FunctionalExtensionality.
Require Export SpecializedCategory Functor.
Require Import Common Notations FunctorAttributes.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Infix "==" := JMeq.

Local Ltac faithful_t :=
  repeat (unfold Object in *; simpl in *;
          match goal with
            | _ => intro
            | _ => progress trivial
            | [ |- _ = _ ] => (apply functional_extensionality_dep; intro)
            | _ => progress simpl_eq
            | [ H : _ = _ |- _ ] => fg_equal_in H
          end).

Section sig_obj_mor.
  Context `(A : @SpecializedCategory objA).
  Variable Pobj : objA -> Prop.
  Variable Pmor : forall s d : sig Pobj, A.(Morphism) (proj1_sig s) (proj1_sig d) -> Prop.
  Variable Pidentity : forall x, @Pmor x x (Identity (C := A) _).
  Variable Pcompose : forall s d d', forall m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (Compose (C := A) m1 m2).

  Definition SpecializedCategory_sig : @SpecializedCategory (sig Pobj).
    match goal with
      | [ |- @SpecializedCategory ?obj ] =>
        refine (@Build_SpecializedCategory obj
          (fun s d => sig (@Pmor s d))
          (fun x => exist _ _ (Pidentity x))
          (fun s d d' m1 m2 => exist _ _ (Pcompose (proj2_sig m1) (proj2_sig m2)))
          _
          _
          _
        )
    end;
    abstract (intros; simpl_eq; auto with category).
  Defined.

  Definition proj1_sig_functor : SpecializedFunctor SpecializedCategory_sig A
    := Build_SpecializedFunctor SpecializedCategory_sig A
                                (@proj1_sig _ _)
                                (fun s d => @proj1_sig _ _)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Lemma proj1_sig_functor_faithful : FunctorFaithful proj1_sig_functor.
    faithful_t.
  Qed.
End sig_obj_mor.

Arguments proj1_sig_functor {objA A Pobj Pmor Pidentity Pcompose}.

Section sig_obj.
  Context `(A : @SpecializedCategory objA).
  Variable Pobj : objA -> Prop.

  Definition SpecializedCategory_sig_obj : @SpecializedCategory (sig Pobj).
    match goal with
      | [ |- @SpecializedCategory ?obj ] =>
        refine (@Build_SpecializedCategory obj
          (fun s d => A.(Morphism) (proj1_sig s) (proj1_sig d))
          (fun x => Identity (C := A) (proj1_sig x))
          (fun s d d' m1 m2 => Compose (C := A) m1 m2)
          _
          _
          _
        )
    end;
    abstract (intros; destruct_sig; simpl; auto with category).
  Defined.

  Definition proj1_sig_obj_functor : SpecializedFunctor SpecializedCategory_sig_obj A
    := Build_SpecializedFunctor SpecializedCategory_sig_obj A
                                (@proj1_sig _ _)
                                (fun s d m => m)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Definition SpecializedCategory_sig_obj_as_sig : @SpecializedCategory (sig Pobj)
    := @SpecializedCategory_sig _ A Pobj (fun _ _ _ => True) (fun _ => I) (fun _ _ _ _ _ _ _ => I).

  Definition sig_functor_obj : SpecializedFunctor SpecializedCategory_sig_obj_as_sig SpecializedCategory_sig_obj
    := Build_SpecializedFunctor SpecializedCategory_sig_obj_as_sig SpecializedCategory_sig_obj
                                (fun x => x)
                                (fun _ _ => @proj1_sig _ _)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Definition sig_functor_obj_inv : SpecializedFunctor SpecializedCategory_sig_obj SpecializedCategory_sig_obj_as_sig
    := Build_SpecializedFunctor SpecializedCategory_sig_obj SpecializedCategory_sig_obj_as_sig
                                (fun x => x)
                                (fun _ _ m => exist _ m I)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Lemma sig_obj_eq : ComposeFunctors sig_functor_obj sig_functor_obj_inv = IdentityFunctor _ /\ ComposeFunctors sig_functor_obj_inv sig_functor_obj = IdentityFunctor _.
    split; functor_eq; destruct_sig; destruct_head True; reflexivity.
  Qed.

  Lemma sig_obj_compat : ComposeFunctors proj1_sig_obj_functor sig_functor_obj = proj1_sig_functor.
    functor_eq.
  Qed.

  Lemma proj1_sig_obj_functor_faithful : FunctorFaithful proj1_sig_obj_functor.
    faithful_t.
  Qed.
End sig_obj.

Arguments proj1_sig_obj_functor {objA A Pobj}.

Section sig_mor.
  Context `(A : @SpecializedCategory objA).
  Variable Pmor : forall s d, A.(Morphism) s d -> Prop.

  Variable Pidentity : forall x, @Pmor x x (Identity (C := A) _).
  Variable Pcompose : forall s d d', forall m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (Compose (C := A) m1 m2).

  Definition SpecializedCategory_sig_mor : @SpecializedCategory objA.
    match goal with
      | [ |- @SpecializedCategory ?obj ] =>
        refine (@Build_SpecializedCategory obj
          (fun s d => sig (@Pmor s d))
          (fun x => exist _ (Identity (C := A) x) (Pidentity x))
          (fun s d d' m1 m2 => exist _ (Compose (proj1_sig m1) (proj1_sig m2)) (Pcompose (proj2_sig m1) (proj2_sig m2)))
          _
          _
          _
        )
    end;
    abstract (intros; simpl_eq; auto with category).
  Defined.

  Definition proj1_sig_mor_functor : SpecializedFunctor SpecializedCategory_sig_mor A
    := Build_SpecializedFunctor SpecializedCategory_sig_mor A
                                (fun x => x)
                                (fun s d => @proj1_sig _ _)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Definition SpecializedCategory_sig_mor_as_sig : @SpecializedCategory (sig (fun _ : objA => True))
    := @SpecializedCategory_sig _ A _ (fun s d => @Pmor (proj1_sig s) (proj1_sig d)) (fun _ => Pidentity _) (fun _ _ _ _ _ m1 m2 => Pcompose m1 m2).

  Definition sig_functor_mor : SpecializedFunctor SpecializedCategory_sig_mor_as_sig SpecializedCategory_sig_mor
    := Build_SpecializedFunctor SpecializedCategory_sig_mor_as_sig SpecializedCategory_sig_mor
                                (@proj1_sig _ _)
                                (fun _ _ m => m)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Definition sig_functor_mor_inv : SpecializedFunctor SpecializedCategory_sig_mor SpecializedCategory_sig_mor_as_sig
    := Build_SpecializedFunctor SpecializedCategory_sig_mor SpecializedCategory_sig_mor_as_sig
                                (fun x => exist _ x I)
                                (fun _ _ m => m)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Lemma sig_mor_eq : ComposeFunctors sig_functor_mor sig_functor_mor_inv = IdentityFunctor _ /\ ComposeFunctors sig_functor_mor_inv sig_functor_mor = IdentityFunctor _.
    split; functor_eq; destruct_sig; destruct_head True; reflexivity.
  Qed.

  Lemma sig_mor_compat : ComposeFunctors proj1_sig_mor_functor sig_functor_mor = proj1_sig_functor.
    functor_eq.
  Qed.

  Lemma proj1_sig_mor_functor_faithful : FunctorFaithful proj1_sig_mor_functor.
    faithful_t.
  Qed.
End sig_mor.

Arguments proj1_sig_mor_functor {objA A Pmor Pidentity Pcompose}.


From Tealeaves Require Export
     Classes.ListableMonad
     Classes.SetlikeModule.

Import Sets.Notations.
#[local] Open Scope tealeaves_scope.

(** * Listable modules *)
(******************************************************************************)
Section ListableModule.

  Context
    (F T : Type -> Type)
    `{Fmap T} `{Return T} `{Join T} `{Tolist T}
    `{Fmap F} `{Tolist F} `{RightAction F T}.

    Class ListableModule :=
    { lrmod_module :> RightModule F T;
      lrmod_functor :> ListableFunctor F;
      lrmod_monad :> ListableMonad T;
      lrmod_action :
        `(tolist F ∘ right_action F =
          join list ∘ tolist F ∘ fmap F (tolist T (A:=A)));
    }.

End ListableModule.

(** ** Listable monads form listable modules *)
(******************************************************************************)
Section ListableModule_monad.

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

  Existing Instance RightAction_Join.
  Existing Instance RightModule_Monad.

  Instance ListableModule_Monad : ListableModule T T :=
    {| lrmod_action := lmon_join T; |}.

End ListableModule_monad.

(** ** Listable modules compose with functors *)
(******************************************************************************)
Section ListableModule_composition.

  Context
    `{ListableFunctor F}
    `{ListableModule G T}.

  Existing Instance RightModule_compose.

  Instance ListableModule_compose : ListableModule (F ∘ G) T.
  Proof.
    constructor; try typeclasses eauto.
    intros A. unfold_ops @RightAction_compose @Tolist_compose.
    #[local] Set Keyed Unification.
    rewrite <- (compose_assoc (f := join list ∘ tolist F)
                             (g := fmap F (tolist G))
                             (h := fmap F (right_action (T:=T) G))).
    #[local] Unset Keyed Unification.
    rewrite (fun_fmap_fmap F).
    rewrite (lrmod_action G T).
    rewrite <- (fun_fmap_fmap F).
    rewrite <- (fun_fmap_fmap F).
    repeat reassociate <-.
    reassociate -> near (fmap F (join list)).
    rewrite <- natural.
    reassociate <-.
    now rewrite <- (mon_join_join list).
  Qed.

End ListableModule_composition.

(** ** Basic properties *)
(******************************************************************************)
Section ListableModule_theory.

  Context
    (F : Type -> Type)
    `{ListableModule F T}.

  Corollary tolist_right_action_1 A (t : F (T A)) :
    tolist F (right_action F t) =
    join list (tolist F (fmap F (tolist T) t)).
  Proof.
    intros. compose near t on left.
    now rewrite (lrmod_action F T).
  Qed.

  Theorem tolist_right_action_2 A : forall (t : F (T A)),
    tolist F (right_action F (A:=A) t) =
    bind list (tolist T) (tolist F t).
  Proof.
    intros. compose near t.
    rewrite (lrmod_action F T).
    reassociate -> on left.
    unfold_compose_in_compose.
    now rewrite <- natural.
  Qed.

  Theorem tolist_sub `{f : A -> T B} :
    tolist F ∘ sub F f = bind list (tolist T ∘ f) ∘ tolist F.
  Proof.
    intros. unfold sub, Sub_RightAction.
    reassociate <- on left. rewrite (lrmod_action F T).
    reassociate -> on left. unfold_compose_in_compose.
    rewrite (fun_fmap_fmap F).
    reassociate -> on left.
    now rewrite <- natural.
  Qed.

End ListableModule_theory.

(** * Listable right modules are set-like *)
(******************************************************************************)
Section ListableModule_setlike.

  Context
    `{ListableModule F T}.

  Theorem toset_right_action_Listable :
    `(toset F ∘ right_action F = join set ∘ toset F ∘ fmap F (toset T (A:=A))).
  Proof.
    intros. unfold toset, Toset_Tolist.
    rewrite <- (fun_fmap_fmap F).
    reassociate -> on right.
    change_right (join (A:=A) set ∘ toset list ∘ (tolist F
                       ∘ fmap F (toset list)) ∘ fmap F (tolist T)).
    rewrite <- natural.
    reassociate <- on right.
    rewrite <- toset_join_list.
    reassociate -> on left.
    now rewrite (lrmod_action F T).
  Qed.

  #[export] Instance SetlikeModule_Listable : SetlikeModule F T :=
    {| xrmod_action := toset_right_action_Listable;
    |}.

End ListableModule_setlike.

(** * Respectfulness conditions for listable modules *)
(******************************************************************************)
Section tolist_respectfulness_module_definitions.

  Context
    (F T : Type -> Type)
    `{Tolist F} `{Tolist F}
    `{Fmap F} `{Fmap T}
    `{RightAction F T}.

  Definition tolist_sub_injective := forall A B (t1 t2 : F A) (f g : A -> T B),
      shape F t1 = shape F t2 ->
      sub F f t1 = sub F g t2 ->
      fmap list f (tolist F t1) = fmap list g (tolist F t2).

  Definition tolist_sub_respectful := forall A B (t1 t2 : F A) (f g : A -> T B),
      shape F t1 = shape F t2 ->
      fmap list f (tolist F t1) = fmap list g (tolist F t2) ->
      sub F f t1 = sub F g t2.

  Definition tolist_sub_respectful_iff := forall A B (t1 t2 : F A) (f g : A -> T B),
      shape F t1 = shape F t2 ->
      fmap list f (tolist F t1) = fmap list g (tolist F t2) <->
      sub F f t1 = sub F g t2.

End tolist_respectfulness_module_definitions.

Ltac unfold_list_properness :=
  unfold shapeliness,
  tolist_fmap_respectful,
  tolist_fmap_respectful_iff,
  tolist_sub_injective,
  tolist_sub_respectful,
  tolist_sub_respectful_iff in *.

(** ** Containments *)
(******************************************************************************)
Section tolist_respectful_module_characterizations.

  Context
    `{ListableModule F T}.

  Lemma shapeliness_equiv_4: tolist_fmap_respectful F -> tolist_sub_respectful F T.
  Proof.
    unfold_list_properness.
    intros. unfold transparent tcs.
    unfold compose. replace (fmap F g t2) with (fmap F f t1); auto.
  Qed.

  Lemma shapeliness_equiv_5 : tolist_sub_respectful F T -> tolist_fmap_respectful F.
  Proof.
    unfold_list_properness. introv hyp ? ?.
    rewrite 2(RightModule.fmap_to_sub F T). apply hyp.
    - auto.
    - rewrite <- 2(fun_fmap_fmap list). unfold compose. fequal. auto.
  Qed.

End tolist_respectful_module_characterizations.

(** * Non-collapse of right actions *)
(******************************************************************************)
Section action_shape_theory.

  Context
    (F : Type -> Type)
    `{ListableModule F T}
    `{! ShapelyFunctor F}
    `{! ShapelyFunctor T}.

  Definition noncollapse := forall A (t1 t2 : F (T A)),
      shape F t1 = shape F t2 ->
      shape F (right_action F t1) = shape F (right_action F t2) ->
      shape (F ∘ T) t1 = shape (F ∘ T) t2.

  Hypothesis
    (noncollapse_proof : noncollapse).

  Lemma action_inj1 : forall A (t1 t2 : F (T A)),
      right_action F t1 = right_action F t2 ->
      bind list (tolist T) (tolist F t1) = bind list (tolist T) (tolist F t2).
  Proof.
    introv heq. assert (lemma : tolist F (right_action F t1) = tolist F (right_action F t2)).
    now rewrite heq.
    rewrite 2(tolist_right_action_1 F) in lemma.
    compose near t1. compose near t2.
    unfold_ops @Bind_Join.
    reassociate ->.
    unfold_compose_in_compose.
    rewrite (natural (ϕ := @tolist F _) (G := list)).
    assumption.
  Qed.

  Lemma action_inj2 : forall A (t1 t2 : F (T A)),
      shape F t1 = shape F t2 ->
      right_action F t1 = right_action F t2 ->
      tolist F t1 = tolist F t2.
  Proof.
    introv t_shape_eq action_eq.
    apply noncollapse_proof in t_shape_eq.
    rewrite action_eq in t_shape_eq. specialize (t_shape_eq eq_refl).
    apply (shape_compose_2 (F := F)) in t_shape_eq.
    apply shapeliness_compose_1; auto using action_inj1.
  Qed.

  Theorem action_inj : forall A (t1 t2 : F (T A)),
      shape F t1 = shape F t2 ->
      right_action F t1 = right_action F t2 ->
      t1 = t2.
  Proof.
    intros. eapply (lfun_shapeliness F); eauto.
    split; auto using action_inj2.
  Qed.

  Corollary sub_inj1 : forall A B (t1 t2 : F A) (f g : A -> T B),
      shape F t1 = shape F t2 ->
      sub F f t1 = sub F g t2 ->
      fmap list f (tolist F t1) = fmap list g (tolist F t2).
  Proof.
    introv hshape. unfold_ops @Sub_RightAction; unfold compose.
    introv heq. apply action_inj in heq.
    2:(now rewrite 2(shape_fmap)).
    compose near t1; compose near t2.
    rewrite 2(natural). unfold compose. now rewrite heq.
  Qed.

End action_shape_theory.


Require Import Verdi.Verdi.

Section Linearizability.
  Variable K : Type.
  Variable K_eq_dec : forall x y : K, {x = y} + {x <> y}.

  Inductive op : Type :=
  | I : K -> op
  | O : K -> op.

  Definition op_eq_dec :
    forall x y : op, {x = y} + {x <> y}.
  Proof using K_eq_dec.
    decide equality.
  Qed.

  Inductive IR : Type :=
  | IRI : K -> IR
  | IRO : K -> IR
  | IRU : K -> IR.

  Definition IR_eq_dec :
    forall x y : IR, {x = y} + {x <> y}.
  Proof using K_eq_dec.
    decide equality.
  Qed.

  (* Hypothesis trace_NoDup : NoDup trace. *)
  (* also maybe: no Us *)
  (* alse maybe: every O has corresponding I before it *)

  Definition acknowledged_op (k : K) (trace : list op) :=
    In (O k) trace.

  Definition acknowledged_op_dec (k : K) (tr : list op) : {acknowledged_op k tr} + {~acknowledged_op k tr} :=
    in_dec op_eq_dec (O k) tr.

  Inductive acknowledge_all_ops : list op ->  list IR -> Prop :=
  | AAO_nil : acknowledge_all_ops [] []
  | AAO_IU : forall k tr out,
               ~ acknowledged_op k tr ->
               acknowledge_all_ops tr out ->
               acknowledge_all_ops (I k :: tr) (IRI k :: IRU k :: out)
  | AAO_I_dorp : forall k tr out,
                   ~ acknowledged_op k tr ->
                   acknowledge_all_ops tr out ->
                   acknowledge_all_ops (I k :: tr) out
  | AAO_IO : forall k tr out,
               acknowledged_op k tr ->
               acknowledge_all_ops tr out ->
               acknowledge_all_ops (I k :: tr) (IRI k :: out)
  | AAO_O : forall k tr out,
              acknowledge_all_ops tr out ->
              acknowledge_all_ops (O k :: tr) (IRO k :: out).

  Lemma acknowledge_all_ops_was_in :
    forall l ir,
      acknowledge_all_ops l ir ->
      forall k,
        In (IRI k) ir ->
        In (I k) l.
  Proof using.
    induction 1; intros; simpl in *; intuition (auto; congruence).
  Qed.

  Fixpoint acknowledge_all_ops_func (l : list op) (target : list IR) : list IR :=
    match l with
      | [] => []
      | x :: xs => match x with
                     | I k => if acknowledged_op_dec k xs
                              then IRI k :: acknowledge_all_ops_func xs target
                              else if in_dec IR_eq_dec (IRU k) target
                                   then IRI k :: IRU k :: acknowledge_all_ops_func xs target
                                   else acknowledge_all_ops_func xs target
                     | O k => IRO k :: acknowledge_all_ops_func xs target
                   end
    end.

  Hint Constructors acknowledge_all_ops : core.

  Lemma acknowledge_all_ops_func_defn :
    forall x l target,
      acknowledge_all_ops_func (x :: l) target =
      match x with
        | I k => if acknowledged_op_dec k l
                 then IRI k :: acknowledge_all_ops_func l target
                 else if in_dec IR_eq_dec (IRU k) target
                      then IRI k :: IRU k :: acknowledge_all_ops_func l target
                      else acknowledge_all_ops_func l target
        | O k => IRO k :: acknowledge_all_ops_func l target
      end.
  Proof using.
    intros.
    unfold acknowledge_all_ops_func. repeat break_match; auto.
  Qed.

  Lemma acknowledge_all_ops_func_correct :
    forall l target,
      acknowledge_all_ops l (acknowledge_all_ops_func l target).
  Proof using.
    induction l; intros; simpl; repeat break_match; subst; eauto.
  Qed.

  Lemma acknowledge_all_ops_func_target_ext :
    forall l t t',
      (forall k, In (IRU k) t -> In (IRU k) t') ->
      (forall k, In (IRU k) t' -> In (IRU k) t) ->
      acknowledge_all_ops_func l t = acknowledge_all_ops_func l t'.
  Proof using.
    induction l; simpl in *; repeat break_match; subst; intuition eauto using f_equal.
    repeat break_match; eauto using f_equal; solve [exfalso; eauto].
  Qed.

  Definition good_move (x y : IR) : Prop :=
    (forall k k', ~ (x = IRO k /\ y = IRI k')) /\
    (forall k, ~ (x = IRI k /\ y = IRO k)) /\
    (forall k, ~ (x = IRI k /\ y = IRU k)).

  Inductive IR_equivalent : list IR -> list IR -> Prop :=
  | IR_equiv_nil : IR_equivalent [] []
  | IR_equiv_cons : forall x xs ys,
                   IR_equivalent xs ys ->
                   IR_equivalent (x :: xs) (x :: ys)
  | IR_equiv_move : forall x y xs ys,
                   IR_equivalent xs ys ->
                   good_move x y ->
                   IR_equivalent (x :: y :: xs) (y :: x :: ys)
  | IR_equiv_trans : forall l1 l2 l3,
                    IR_equivalent l1 l2 ->
                    IR_equivalent l2 l3 ->
                    IR_equivalent l1 l3.
  Hint Constructors IR_equivalent : core.

  Lemma IR_equivalent_refl :
    forall l,
      IR_equivalent l l.
  Proof using.
    induction l; eauto.
  Qed.

  Lemma IR_equiv_in_l_r :
    forall ir1 ir2,
      IR_equivalent ir1 ir2 ->
      forall o,
        In o ir1 -> In o ir2.
  Proof using.
    induction 1; intros; simpl in *; intuition.
  Qed.

  Lemma IR_equiv_in_r_l :
    forall ir1 ir2,
      IR_equivalent ir1 ir2 ->
      forall o,
        In o ir2 -> In o ir1.
  Proof using.
    induction 1; intros; simpl in *; intuition.
  Qed.

  Hint Constructors Permutation : core.
  Lemma IR_equiv_Permutation :
    forall ir1 ir2,
      IR_equivalent ir1 ir2 ->
      Permutation ir1 ir2.
  Proof using.
    induction 1; eauto.
  Qed.

  Lemma IR_equiv_app_head :
    forall l xs ys,
      IR_equivalent xs ys ->
      IR_equivalent (l ++ xs) (l ++ ys).
  Proof using.
    induction l; intros; simpl; auto.
  Qed.

  Lemma IR_equiv_snoc :
    forall xs ys x,
      IR_equivalent xs ys ->
      IR_equivalent (xs ++ [x]) (ys ++ [x]).
  Proof using.
    induction 1; simpl; eauto.
  Qed.

  Lemma IR_equiv_app_tail :
    forall l xs ys,
      IR_equivalent xs ys ->
      IR_equivalent (xs ++ l) (ys ++ l).
  Proof using.
    induction 1; intros; simpl in *; eauto using IR_equivalent_refl.
  Qed.

  Section Examples.
    Example IR_equiv_eg1 :
      forall k k',
        k <> k' ->
        IR_equivalent [IRI k; IRI k'; IRO k; IRO k'] [IRI k; IRO k; IRI k'; IRO k'].
    Proof using.
      intros.
      constructor.
      econstructor; auto.
      red.
      intuition (auto; congruence).
    Qed.

    Example IR_equiv_eg2 :
      forall k k',
        k <> k' ->
        IR_equivalent [IRI k; IRI k'; IRO k; IRO k'] [IRI k'; IRO k'; IRI k; IRO k].
    Proof using.
      intros.
      eapply IR_equiv_trans with (l2 := [IRI k; IRI k'; IRO k'; IRO k]).
      - repeat constructor; unfold good_move; intuition (try congruence).
      - eapply IR_equiv_trans with (l2 := [IRI k'; IRI k; IRO k'; IRO k]).
        + apply IR_equiv_move; auto using IR_equivalent_refl.
          red. intuition congruence.
        + constructor. apply IR_equiv_move; auto.
          red. intuition congruence.
    Qed.

    Example IR_equiv_eg3 :
      forall k k',
        k <> k' ->
        IR_equivalent [IRI k; IRI k'; IRO k'; IRO k] [IRI k'; IRO k'; IRI k; IRO k].
    Proof using.
      intros.
      eapply IR_equiv_trans with (l2 := [IRI k'; IRI k; IRO k'; IRO k]).
      - constructor.
        + apply IR_equivalent_refl.
        + red. intuition congruence.
      - constructor. constructor.
        + apply IR_equivalent_refl.
        + red. intuition congruence.
    Qed.

    Example IR_equiv_eg4 :
      forall k k',
        k <> k' ->
        IR_equivalent [IRI k; IRI k'; IRO k'; IRO k] [IRI k; IRO k; IRI k'; IRO k'].
    Proof using.
      intros.
      constructor.
      eapply IR_equiv_trans with (l2 := [IRI k'; IRO k; IRO k']).
      - repeat constructor; unfold good_move; intuition congruence.
      - eapply IR_equiv_move; auto.
        red. intuition congruence.
    Qed.
  End Examples.

  Fixpoint good_trace (l : list IR) : Prop :=
    match l with
      | [] => True
      | IRI k :: IRO k' :: l' => k = k' /\ good_trace l'
      | IRI k :: IRU k' :: l' => k = k' /\ good_trace l'
      | _ => False
    end.

  Definition equivalent (l : list op) (ir : list IR) : Prop :=
    good_trace ir /\
    exists ir',
      acknowledge_all_ops l ir' /\
      IR_equivalent ir' ir.

  Lemma acknowledge_all_ops_func_IRU_In :
    forall l ir k,
      In (IRU k) (acknowledge_all_ops_func l ir) ->
      In (I k) l.
  Proof using.
    induction l; intros; simpl in *; repeat break_match; subst; simpl in *;
    intuition (eauto; congruence).
  Qed.

  Definition get_op_input_keys (l : list op) : list K :=
    filterMap (fun x => match x with
                          | I k => Some k
                          | _ => None
                        end) l.

  Lemma get_op_input_keys_defn :
    forall x l,
      get_op_input_keys (x :: l) = match x with
                               | I k => k :: get_op_input_keys l
                               | _ => get_op_input_keys l
                                   end.
  Proof using.
    unfold get_op_input_keys.
    intros.
    simpl. repeat break_match; congruence.
  Qed.

  Definition get_IR_input_keys (l : list IR) : list K :=
    filterMap (fun x => match x with
                          | IRI k => Some k
                          | _ => None
                        end) l.

  Lemma get_IR_input_keys_defn :
    forall x l,
      get_IR_input_keys (x :: l) = match x with
                               | IRI k => k :: get_IR_input_keys l
                               | _ => get_IR_input_keys l
                             end.
  Proof using.
    unfold get_IR_input_keys.
    intros.
    simpl. repeat break_match; congruence.
  Qed.

  Definition get_op_output_keys (l : list op) : list K :=
    filterMap (fun x => match x with
                          | O k => Some k
                          | _ => None
                        end) l.

  Lemma get_op_output_keys_defn :
    forall x l,
      get_op_output_keys (x :: l) = match x with
                                      | O k => k :: get_op_output_keys l
                                      | _ => get_op_output_keys l
                                    end.
  Proof using.
    unfold get_op_output_keys.
    intros.
    simpl.
    repeat break_match; congruence.
  Qed.

  Definition get_IR_output_keys (l : list IR) : list K :=
    filterMap (fun x => match x with
                          | IRO k => Some k
                          | IRU k => Some k
                          | _ => None
                        end) l.

  Lemma get_IR_output_keys_defn :
    forall x l,
      get_IR_output_keys (x :: l) = match x with
                                      | IRO k => k :: get_IR_output_keys l
                                      | IRU k => k :: get_IR_output_keys l
                                      | _ => get_IR_output_keys l
                                    end.
  Proof using.
    unfold get_IR_output_keys.
    intros. simpl. repeat break_match; congruence.
  Qed.

  (* this is cleaner than the auto-generated functional induction scheme *)
  Fixpoint good_trace_ind'
    (P : list IR -> Prop -> Prop)
    (l : list IR) :
      P [] True ->
      (forall k, P [IRI k] False) ->
      (forall k k' l, P (IRI k :: IRI k' :: l) False) ->
      (forall k k' l, P l (good_trace l) -> P (IRI k :: IRO k' :: l) (k = k' /\ good_trace l)) ->
      (forall k k' l, P l (good_trace l) -> P (IRI k :: IRU k' :: l) (k = k' /\ good_trace l)) ->
      (forall k l, P (IRO k :: l) False) ->
      (forall k l, P (IRU k :: l) False) ->
      P l (good_trace l).
  Proof using.
    intros.
    destruct l; simpl; repeat break_match; auto; subst.
    - match goal with
        | [ H : context [IRI _ :: IRO _ :: _ ] |- _ ] => apply H
      end.
      apply good_trace_ind'; auto.
    - match goal with
        | [ H : context [IRI _ :: IRU _ :: _ ] |- _ ] => apply H
      end.
      apply good_trace_ind'; auto.
  Qed.

  Lemma good_trace_ind :
    forall P : list IR -> Prop -> Prop,
      P [] True ->
      (forall k, P [IRI k] False) ->
      (forall k k' ir, P (IRI k :: IRI k' :: ir) False) ->
      (forall k k' ir, P ir (good_trace ir) -> P (IRI k :: IRO k' :: ir) (k = k' /\ good_trace ir)) ->
      (forall k k' ir, P ir (good_trace ir) -> P (IRI k :: IRU k' :: ir) (k = k' /\ good_trace ir)) ->
      (forall k ir, P (IRO k :: ir) False) ->
      (forall k ir, P (IRU k :: ir) False) ->
      forall ir, P ir (good_trace ir).
  Proof using.
    intros.
    apply good_trace_ind'; auto.
  Qed.

  Lemma good_trace_IRI_in :
    forall ir,
      good_trace ir ->
      forall k,
        In (IRI k) ir ->
        In (IRO k) ir \/ In (IRU k) ir.
  Proof using.
    intros ir.
    induction ir, good_trace using good_trace_ind; intros; simpl in *; intuition (auto; try congruence).
    - subst. find_apply_hyp_hyp. intuition.
    - subst. find_apply_hyp_hyp. intuition.
  Qed.

  Lemma acknowledge_all_ops_func_target_nil :
    forall l,
      (forall k, ~ In (O k) l) ->
      acknowledge_all_ops_func l [] = [].
  Proof using.
    induction l; intros; simpl in *.
    - auto.
    - repeat break_match; subst; unfold acknowledged_op in *;
      (exfalso + idtac); solve [intuition eauto].
  Qed.

  Lemma before_head_op :
    forall l h ir,
      (forall k1 k2,
         In (I k2) l ->
         before (O k1) (I k2) l ->
         before (IRO k1) (IRI k2) (IRI h :: ir)) ->
      forall x,
        In (I h) l ->
        before x (I h) l ->
        exists k,
          x = I k.
  Proof using.
    intros. destruct x. eauto.
    eapply_prop_hyp In In; eauto.
    simpl in *. intuition congruence.
  Qed.

  Lemma good_move_II :
    forall k k',
      good_move (IRI k) (IRI k').
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma good_move_OO :
    forall k k',
      good_move (IRO k) (IRO k').
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma IR_equivalent_all_Is_I :
    forall l k,
      (forall x, In x l -> exists k, x = IRI k) ->
      IR_equivalent (l ++ [IRI k]) (IRI k :: l).
  Proof using.
    induction l; intros; simpl in *; intuition.
    apply IR_equiv_trans with (l2 := (a :: IRI k :: l)).
    - auto.
    - specialize (H a). concludes. break_exists. subst.
      auto using IR_equivalent_refl, good_move_II.
  Qed.

  Definition good_op_move (x y : op) : Prop :=
    (forall k k', ~ (x = O k /\ y = I k')) /\
    (forall k, ~ (x = I k /\ y = O k)).

  Inductive op_equivalent : list op -> list op -> Prop :=
  | op_equiv_nil : op_equivalent [] []
  | op_equiv_cons : forall x xs ys, op_equivalent xs ys -> op_equivalent (x :: xs) (x :: ys)
  | op_equiv_move : forall x y xs ys, good_op_move x y ->
                                      op_equivalent xs ys -> op_equivalent (x :: y :: xs) (y :: x :: ys)
  | op_equiv_trans : forall l1 l2 l3, op_equivalent l1 l2 -> op_equivalent l2 l3 -> op_equivalent l1 l3.

  Lemma op_equiv_Permutation :
    forall xs ys,
      op_equivalent xs ys ->
      Permutation xs ys.
  Proof using.
    induction 1; eauto.
  Qed.

  Lemma op_equiv_ack_op_lr :
    forall xs ys,
      op_equivalent xs ys ->
      forall k,
        acknowledged_op k xs ->
        acknowledged_op k ys.
  Proof using.
    unfold acknowledged_op.
    intros.
    eauto using Permutation_in, op_equiv_Permutation.
  Qed.

  Lemma op_equiv_ack_op_rl :
    forall xs ys,
      op_equivalent xs ys ->
      forall k,
        acknowledged_op k ys ->
        acknowledged_op k xs.
  Proof using.
    unfold acknowledged_op.
    intros.
    eauto using Permutation_sym, Permutation_in, op_equiv_Permutation.
  Qed.

  Lemma acknowledged_op_defn :
    forall k xs,
      acknowledged_op k xs ->
      In (O k) xs.
  Proof using.
    auto.
  Qed.

  Lemma good_move_U_l :
    forall k x,
      good_move (IRU k) x.
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma good_move_IU_neq :
    forall k k',
      k <> k' ->
      good_move (IRI k) (IRU k').
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma good_move_IO_neq :
    forall k k',
      k <> k' ->
      good_move (IRI k) (IRO k').
  Proof using.
    red. intuition congruence.
  Qed.

  Hint Resolve IR_equivalent_refl : core.
  Hint Resolve good_move_II : core.
  Hint Resolve good_move_U_l : core.

  Lemma not_good_op_move_IO :
    forall k,
      good_op_move (I k) (O k) -> False.
  Proof using.
    unfold good_op_move.
    intuition eauto.
  Qed.

  Lemma not_good_op_move_OI :
    forall k k',
      good_op_move (O k) (I k') -> False.
  Proof using.
    unfold good_op_move.
    intuition eauto.
  Qed.

  Lemma good_op_move_good_move_IO :
    forall k k',
      good_op_move (I k) (O k') ->
      good_move (IRI k) (IRO k').
  Proof using.
    unfold good_op_move, good_move.
    intuition (try congruence). repeat find_inversion. eauto.
  Qed.

  Lemma good_op_move_cases :
    forall x y,
      good_op_move x y ->
      exists k k',
        (x = I k /\ y = I k') \/
        (x = O k /\ y = O k') \/
        (k <> k' /\ x = I k /\ y = O k').
  Proof using.
    unfold good_op_move. intros.
    destruct x as [k|k], y as [k'|k']; exists k, k'; intuition.
    - right. right. intuition. subst. eauto.
    - exfalso. eauto.
  Qed.

  Lemma acknowledged_op_I_cons_reduce :
    forall k k' l,
      acknowledged_op k (I k' :: l) ->
      acknowledged_op k l.
  Proof using.
    unfold acknowledged_op.
    simpl. intuition congruence.
  Qed.

  Lemma acknowledged_op_I_cons_expand :
    forall k k' l,
      acknowledged_op k l ->
      acknowledged_op k (I k' :: l).
  Proof using.
    unfold acknowledged_op.
    simpl. intuition congruence.
  Qed.

  Hint Constructors op_equivalent : core.

  Lemma IR_equiv_AAOF_I :
    forall k xs ys target,
      op_equivalent xs ys ->
      IR_equivalent (acknowledge_all_ops_func xs target)
                    (acknowledge_all_ops_func ys target) ->
      IR_equivalent (acknowledge_all_ops_func (I k :: xs) target)
                    (acknowledge_all_ops_func (I k :: ys) target).
  Proof using.
    intros.
    simpl.
    repeat break_match; auto;
    exfalso; eauto using op_equiv_ack_op_lr, op_equiv_ack_op_rl.
  Qed.

  Lemma IR_equiv_AAOF_II_neq :
    forall xs ys target k k',
      k <> k' ->
      op_equivalent xs ys ->
      IR_equivalent (acknowledge_all_ops_func xs target)
                    (acknowledge_all_ops_func ys target) ->
      IR_equivalent (acknowledge_all_ops_func (I k :: I k' :: xs) target)
                    (acknowledge_all_ops_func (I k' :: I k :: ys) target).
  Proof using.
    intros.
    rewrite acknowledge_all_ops_func_defn.
    break_if.
    - rewrite acknowledge_all_ops_func_defn.
      break_if; rewrite acknowledge_all_ops_func_defn with (l := _ :: _).
      + rewrite if_decider_true by
                  eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                              acknowledged_op_I_cons_reduce.
        rewrite acknowledge_all_ops_func_defn.
        rewrite if_decider_true by
            eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                        acknowledged_op_I_cons_reduce.
        auto.
      + rewrite if_decider_false with (dec := acknowledged_op_dec _) by
        intuition eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                              acknowledged_op_I_cons_reduce.
        rewrite acknowledge_all_ops_func_defn.
        rewrite if_decider_true with (dec := acknowledged_op_dec _) by
            eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                              acknowledged_op_I_cons_reduce.
        break_if.
        * eauto 6 using good_move_IU_neq.
        * auto.
    - break_if; rewrite acknowledge_all_ops_func_defn.
      + break_if; rewrite acknowledge_all_ops_func_defn.
        * rewrite if_decider_true by
              eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                            acknowledged_op_I_cons_reduce.
          rewrite acknowledge_all_ops_func_defn.
          rewrite if_decider_false by
              intuition eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                            acknowledged_op_I_cons_reduce.
          rewrite if_decider_true by auto.
          eauto.
        * rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
              acknowledged_op_I_cons_reduce.
          rewrite acknowledge_all_ops_func_defn.
          rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
              acknowledged_op_I_cons_reduce.
          rewrite if_decider_true with (dec := in_dec _ (IRU k)) by auto.
          { break_if.
            - eapply IR_equiv_trans; [apply IR_equiv_cons; apply IR_equiv_move; auto|].
              eapply IR_equiv_trans; [apply IR_equiv_move; auto|]. constructor.
              eapply IR_equiv_trans; [apply IR_equiv_cons; apply IR_equiv_move; auto|].
              auto using good_move_IU_neq.
            - auto.
          }
      + break_if; rewrite acknowledge_all_ops_func_defn.
        * rewrite if_decider_true with (dec := acknowledged_op_dec _) by
              eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                  acknowledged_op_I_cons_reduce.
          rewrite acknowledge_all_ops_func_defn.
          rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                  acknowledged_op_I_cons_reduce.
          rewrite if_decider_false by auto.
          auto.
        * rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                  acknowledged_op_I_cons_reduce.
           rewrite acknowledge_all_ops_func_defn.
           rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                  acknowledged_op_I_cons_reduce.
           rewrite if_decider_false with (dec := in_dec _ (IRU k)) by auto.
           break_if; auto.
  Qed.

  Lemma op_equiv_AAOF_IR_equiv :
    forall xs ys,
      op_equivalent xs ys ->
      forall l,
        IR_equivalent (acknowledge_all_ops_func xs l) (acknowledge_all_ops_func ys l).
  Proof using.
    induction 1; intros.
    - auto.
    - simpl.
      repeat break_match; subst; auto;
      exfalso; eauto using op_equiv_ack_op_lr, op_equiv_ack_op_rl.
    - find_copy_apply_lem_hyp good_op_move_cases. break_exists. intuition; subst.
      + destruct (K_eq_dec x0 x1).
        * subst. auto using IR_equiv_AAOF_I.
        * auto using IR_equiv_AAOF_II_neq.
      + simpl. eauto using good_move_OO.
      + simpl. repeat break_match; intuition; try congruence.
        * eauto using good_move_IO_neq.
        * exfalso. eauto using op_equiv_ack_op_lr.
        * exfalso. eauto using op_equiv_ack_op_lr.
        * exfalso; eauto using Permutation_in, op_equiv_Permutation, acknowledged_op_defn, Permutation_sym.
        * eapply IR_equiv_trans; [apply IR_equiv_cons; apply IR_equiv_move; auto|].
          eapply IR_equiv_trans; [apply IR_equiv_move; auto|]. apply good_move_IO_neq. congruence.
          auto.
        * exfalso.
          match goal with
            | [ H : In (O _) _ -> False |- _ ] => apply H
          end.
          eapply Permutation_in; [apply Permutation_sym; eapply op_equiv_Permutation; eauto|].
          auto using acknowledged_op_defn.
    - eauto.
  Qed.

  Lemma op_equivalent_refl :
    forall xs,
      op_equivalent xs xs.
  Proof using.
    induction xs; auto.
  Qed.

  Lemma good_op_move_II :
    forall k k',
      good_op_move (I k) (I k').
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma op_equivalent_all_Is_I :
    forall l k,
      (forall x, In x l -> exists k, x = I k) ->
      op_equivalent (l ++ [I k]) (I k :: l).
  Proof using.
    induction l; intros; simpl in *; intuition.
    apply op_equiv_trans with (l2 := (a :: I k :: l)).
    - auto.
    - specialize (H a). concludes. break_exists. subst.
      auto using op_equivalent_refl, good_op_move_II.
  Qed.

  Lemma good_op_move_neq_IO :
    forall k k',
      k <> k' ->
      good_op_move (I k) (O k').
  Proof using.
    unfold good_op_move.
    intuition congruence.
  Qed.

  Lemma good_op_move_OO :
    forall k k',
      good_op_move (O k) (O k').
  Proof using.
    unfold good_op_move.
    intuition congruence.
  Qed.

  Lemma op_equivalent_all_Is_O :
    forall l k,
      (forall k', In (I k') l -> k <> k') ->
      op_equivalent (l ++ [O k]) (O k :: l).
  Proof using.
    induction l; intros; simpl in *; intuition.
    apply op_equiv_trans with (l2 := (a :: O k :: l)).
    - eauto 10.
    - destruct a.
      + eauto 6 using good_op_move_neq_IO, op_equivalent_refl.
      + eauto 6 using good_op_move_OO, op_equivalent_refl.
  Qed.

  Lemma op_equiv_app_tail :
    forall l xs ys,
      op_equivalent xs ys ->
      op_equivalent (xs ++ l) (ys ++ l).
  Proof using.
    induction 1; intros; simpl in *; intuition.
    - auto using op_equivalent_refl.
    - eauto.
  Qed.

  Lemma op_equivalent_all_Is_I_middle :
    forall xs ys k,
      (forall x, In x xs -> exists k, x = I k) ->
      op_equivalent (xs ++ I k :: ys) (I k :: xs ++ ys).
  Proof using.
    intros.
    rewrite app_comm_cons.
    replace (xs ++ I k :: ys) with ((xs ++ [I k]) ++ ys) by now rewrite app_ass.
    auto using op_equiv_app_tail, op_equivalent_all_Is_I.
  Qed.

  Lemma get_op_input_keys_app :
    forall xs ys,
      get_op_input_keys (xs ++ ys) = get_op_input_keys xs ++ get_op_input_keys ys.
  Proof using.
    intros.
    apply filterMap_app.
  Qed.

  Lemma get_op_output_keys_app :
    forall xs ys,
      get_op_output_keys (xs ++ ys) = get_op_output_keys xs ++ get_op_output_keys ys.
  Proof using.
    intros.
    apply filterMap_app.
  Qed.

  Lemma get_op_input_keys_complete :
    forall xs k,
      In (I k) xs ->
      In k (get_op_input_keys xs).
  Proof using.
    unfold get_op_input_keys.
    intros.
    eapply filterMap_In; eauto.
    auto.
  Qed.

  Lemma get_op_input_keys_sound :
    forall k l,
      In k (get_op_input_keys l) ->
      In (I k) l.
  Proof using.
    induction l; intros.
    - auto.
    - simpl in *. rewrite get_op_input_keys_defn in *. break_match; simpl in *.
      + subst. intuition congruence.
      + intuition.
  Qed.

  Lemma get_op_output_keys_sound :
    forall k l,
      In k (get_op_output_keys l) ->
      In (O k) l.
  Proof using.
    induction l; intros.
    - auto.
    - simpl in *. rewrite get_op_output_keys_defn in *. break_match; simpl in *.
      + subst. auto.
      + intuition congruence.
  Qed.

  Lemma get_op_input_keys_on_Os_nil :
    forall l,
      (forall o, In o l -> exists k, o = O k) ->
      get_op_input_keys l = [].
  Proof using.
    induction l; intros; simpl in *; intuition.
    rewrite get_op_input_keys_defn.
    pose proof H a. concludes. break_exists. subst.
    auto.
  Qed.

  Lemma get_op_input_keys_preserves_NoDup :
    forall l,
      NoDup l ->
      NoDup (get_op_input_keys l).
  Proof using.
    intros.
    unfold get_op_input_keys.
    apply filterMap_NoDup_inj; auto.
    intros.
    repeat break_match; try discriminate.
    subst. congruence.
  Qed.

  Lemma get_op_output_keys_preserves_NoDup :
    forall l,
      NoDup l ->
      NoDup (get_op_output_keys l).
  Proof using.
    intros.
    unfold get_op_output_keys.
    apply filterMap_NoDup_inj; auto.
    intros.
    repeat break_match; try discriminate.
    subst. congruence.
  Qed.

  Lemma get_op_output_keys_complete :
    forall xs k,
      In (O k) xs ->
      In k (get_op_output_keys xs).
  Proof using.
    unfold get_op_input_keys.
    intros.
    eapply filterMap_In; eauto.
    auto.
  Qed.

  Lemma get_IR_output_keys_complete_U :
    forall xs k,
      In (IRU k) xs ->
      In k (get_IR_output_keys xs).
  Proof using.
    unfold get_IR_output_keys.
    intros.
    eapply filterMap_In; eauto. auto.
  Qed.

  Lemma get_IR_output_keys_complete_O :
    forall xs k,
      In (IRO k) xs ->
      In k (get_IR_output_keys xs).
  Proof using.
    unfold get_IR_output_keys.
    intros.
    eapply filterMap_In; eauto. auto.
  Qed.

  Lemma get_IR_input_keys_complete :
    forall xs k,
      In (IRI k) xs ->
      In k (get_IR_input_keys xs).
  Proof using.
    unfold get_IR_input_keys.
    intros.
    eapply filterMap_In; eauto. auto.
  Qed.

  Lemma op_equivalent_all_Is_O_middle :
    forall xs ys k,
      (forall k', In (I k') xs -> k <> k') ->
      op_equivalent (xs ++ O k :: ys) (O k :: xs ++ ys).
  Proof using.
    intros.
    rewrite app_comm_cons.
    replace (xs ++ O k :: ys) with ((xs ++ [O k]) ++ ys) by now rewrite app_ass.
    auto using op_equiv_app_tail, op_equivalent_all_Is_O.
  Qed.

  Lemma NoDup_get_op_output_keys_In_O :
    forall xs ys k,
      NoDup (get_op_output_keys (xs ++ O k :: ys)) ->
      In (O k) (xs ++ ys) ->
      False.
  Proof using.
    intros.
    rewrite get_op_output_keys_app in *.
    rewrite get_op_output_keys_defn in *.
    do_in_app.
    intuition; eapply NoDup_remove_2; eauto using get_op_output_keys_complete, in_or_app.
  Qed.

  Lemma NoDup_get_op_output_keys_In_2_3 :
    forall xs ys zs k,
      NoDup (get_op_output_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      In (O k) (xs ++ ys ++ zs) ->
      False.
  Proof using.
    intros.
    rewrite get_op_output_keys_app in *.
    rewrite get_op_output_keys_defn in *.
    rewrite get_op_output_keys_app in *.
    rewrite get_op_output_keys_defn in *.
    repeat
      (do_in_app; intuition
                    eauto using NoDup_app3_not_in_1, NoDup_app3_not_in_2,
                  NoDup_app3_not_in_3, get_op_output_keys_complete).
  Qed.

  Lemma NoDup_get_op_input_keys_In_2_3 :
    forall xs ys zs k,
      NoDup (get_op_input_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      In (I k) (xs ++ ys ++ zs) ->
      False.
  Proof using.
    intros.
    rewrite get_op_input_keys_app in *.
    rewrite get_op_input_keys_defn in *.
    rewrite get_op_input_keys_app in *.
    rewrite get_op_input_keys_defn in *.
    match goal with
      | [ H : NoDup _ |- _ ] =>
        apply NoDup_remove_2 in H
    end.
    repeat (do_in_app; intuition); eauto 10 using get_op_input_keys_complete with *.
  Qed.

  Lemma O_IRO_preserved_IU :
    forall xs ys k' ir,

      (forall k, In (O k) (xs ++ I k' :: ys) ->
                 In (IRO k) (IRI k' :: IRU k' :: ir)) ->
      forall k, In (O k) (xs ++ ys) ->
                In (IRO k) ir.
  Proof using.
    intros.
    eapply In_cons_neq.
    - eapply In_cons_neq.
      + eauto.
      + discriminate.
    - discriminate.
  Qed.

  Lemma O_IRO_preserved :
    forall xs ys zs k' ir,
      NoDup (get_op_output_keys (xs ++ I k' :: ys ++ O k' :: zs)) ->
      (forall k, In (O k) (xs ++ I k' :: ys ++ O k' :: zs) ->
                 In (IRO k) (IRI k' :: IRO k' :: ir)) ->
      forall k, In (O k) (xs ++ ys ++ zs) ->
                In (IRO k) ir.
  Proof using.
    intros.
    eapply In_cons_neq.
    - eapply In_cons_neq.
      + eauto using In_cons_2_3.
      + discriminate.
    - intro. find_inversion. eauto using NoDup_get_op_output_keys_In_2_3.
  Qed.

  Lemma no_Ik_in_first2 :
    forall xs ys zs k,
      NoDup (get_op_input_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      forall k',
        In (I k') (xs ++ ys) -> k <> k'.
  Proof using.
    intros.
    rewrite get_op_input_keys_app in *. rewrite get_op_input_keys_defn in *.
    match goal with
      | [ H : NoDup (_ ++ _ :: _) |- _ ] =>
        apply NoDup_remove_2 in H
    end.
    rewrite get_op_input_keys_app in *.
    intro. subst.

    repeat do_in_app; intuition auto 10 using get_op_input_keys_complete, in_or_app.
  Qed.

  Lemma IRO_O_preserved_IU :
    forall xs ys k' ir,
      (forall k, In (IRO k) (IRI k' :: IRU k' :: ir) ->
                 In (O k) (xs ++ I k' :: ys)) ->
      forall k, In (IRO k) ir ->
                In (O k) (xs ++ ys).
  Proof using.
    intros.
    apply in_middle_reduce with (y := I k'); intuition (auto with *; congruence).
  Qed.

  Lemma IRO_O_preserved :
    forall xs ys zs k' ir,
      (~ In k' (get_IR_output_keys ir)) ->
      (forall k, In (IRO k) (IRI k' :: IRO k' :: ir) ->
                 In (O k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k, In (IRO k) ir ->
                In (O k) (xs ++ ys ++ zs).
  Proof using.
    intros.

    eapply In_cons_2_3_neq; eauto using in_cons; try congruence.
    intro. find_inversion. eauto using get_IR_output_keys_complete_O.
  Qed.

  Lemma IRU_I_preserved_IU :
    forall xs ys k' ir,
      (~ In k' (get_IR_output_keys ir)) ->
      (forall k, In (IRU k) (IRI k' :: IRU k' :: ir) ->
                 In (I k) (xs ++ I k' :: ys)) ->
      forall k, In (IRU k) ir ->
                In (I k) (xs ++ ys).
  Proof using.
    intros.
    apply in_middle_reduce with (y := I k'); intuition.
    find_inversion.
    auto using get_IR_output_keys_complete_U.
  Qed.

  Lemma IRU_I_preserved :
    forall xs ys zs k' ir,
      (~ In k' (get_IR_output_keys ir)) ->
      (forall k, In (IRU k) (IRI k' :: IRO k' :: ir) ->
                 In (I k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k, In (IRU k) ir ->
                In (I k) (xs ++ ys ++ zs).
  Proof using.
    intros.
    eapply In_cons_2_3_neq; eauto using in_cons; try congruence.
    intro. find_inversion. eauto using get_IR_output_keys_complete_U.
  Qed.

  Lemma NoDup_get_op_input_keys_In_I :
    forall xs ys k,
      NoDup (get_op_input_keys (xs ++ I k :: ys)) ->
      In (I k) (xs ++ ys) -> False.
  Proof using.
    intros.
    rewrite get_op_input_keys_app in *.
    rewrite get_op_input_keys_defn in *.
    do_in_app.
    intuition; eapply NoDup_remove_2; eauto using get_op_input_keys_complete, in_or_app.
  Qed.

  Lemma in_before_before_preserved_IU :
    forall xs ys k ir,
      NoDup (get_op_input_keys (xs ++ I k :: ys)) ->
      (forall k1 k2,
         In (I k2) (xs ++ I k :: ys) ->
         before (O k1) (I k2) (xs ++ I k :: ys) ->
         before (IRO k1) (IRI k2) (IRI k :: IRU k :: ir)) ->
      forall k1 k2,
        In (I k2) (xs ++ ys) ->
        before (O k1) (I k2) (xs ++ ys) ->
        before (IRO k1) (IRI k2) ir.
  Proof using.
    intros.
    simpl in *.
    find_eapply_lem_hyp before_middle_insert.
    - find_eapply_lem_hyp in_middle_insert.
      eapply_prop_hyp In (O k1); eauto.
      intuition; try congruence.
    - intro. find_inversion. eauto using NoDup_get_op_input_keys_In_I.
  Qed.

  Lemma in_before_before_preserved :
    forall xs ys zs k ir,
      NoDup (get_op_input_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      NoDup (get_op_output_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      (forall k1 k2,
         In (I k2) (xs ++ I k :: ys ++ O k :: zs) ->
         before (O k1) (I k2) (xs ++ I k :: ys ++ O k :: zs) ->
         before (IRO k1) (IRI k2) (IRI k :: IRO k :: ir)) ->
      forall k1 k2,
        In (I k2) (xs ++ ys ++ zs) ->
        before (O k1) (I k2) (xs ++ ys ++ zs) ->
        before (IRO k1) (IRI k2) ir.
  Proof using.
    intros.
    simpl in *.
    find_copy_eapply_lem_hyp before_2_3_insert.
    - find_eapply_lem_hyp In_cons_2_3.
      eapply_prop_hyp In (O k1); eauto.
      intuition; try congruence.
      find_inversion.
      find_copy_eapply_lem_hyp before_In.
      exfalso.
      eauto using NoDup_get_op_output_keys_In_2_3.
    - intro. find_inversion. eauto using NoDup_get_op_input_keys_In_2_3.
    - discriminate.
  Qed.

  Lemma in_before_preserved_IU :
    forall xs ys k',
      ~ acknowledged_op k' (xs ++ ys) ->
      (forall k, In (O k) (xs ++ I k' :: ys) ->
                 before (I k) (O k) (xs ++ I k' :: ys)) ->
      forall k, In (O k) (xs ++ ys) ->
                before (I k) (O k) (xs ++ ys).
  Proof using.
    intros.
    eapply before_middle_reduce.
    - eauto using in_middle_insert.
    - intro. find_inversion. intuition eauto using acknowledged_op_defn.
  Qed.

  Lemma in_before_preserved :
    forall xs ys zs k',
      NoDup (get_op_output_keys (xs ++ I k' :: ys ++ O k' :: zs)) ->
      (forall k, In (O k) (xs ++ I k' :: ys ++ O k' :: zs) ->
                 before (I k) (O k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k, In (O k) (xs ++ ys ++ zs) ->
                before (I k) (O k) (xs ++ ys ++ zs).
  Proof using.
    intros.
    eapply before_2_3_reduce.
    - eauto using In_cons_2_3.
    - intro. find_inversion. eauto using NoDup_get_op_output_keys_In_2_3.
    - discriminate.
  Qed.

  Lemma IRI_I_preserved_IU :
    forall xs ys k' ir,
      (~ In k' (get_IR_input_keys ir)) ->
      (forall k, In (IRI k) (IRI k' :: IRU k' :: ir) -> In (I k) (xs ++ I k' :: ys)) ->
      forall k, In (IRI k) ir -> In (I k) (xs ++ ys).
  Proof using.
    intros.
    eapply in_middle_reduce.
    - auto with *.
    - intro. find_inversion.  eauto using get_IR_input_keys_complete.
  Qed.

  Lemma IRI_I_preserved :
    forall xs ys zs k' ir,
      (~ In k' (get_IR_input_keys ir)) ->
      (forall k, In (IRI k) (IRI k' :: IRO k' :: ir) -> In (I k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k, In (IRI k) ir -> In (I k) (xs ++ ys ++ zs).
  Proof using.
    intros.
    eapply In_cons_2_3_neq.
    - auto with *.
    - intro. find_inversion. eauto using get_IR_input_keys_complete.
    - discriminate.
  Qed.

  Lemma subseq_get_op_input_keys :
    forall xs ys,
      subseq xs ys ->
      subseq (get_op_input_keys xs) (get_op_input_keys ys).
  Proof using.
    eauto using subseq_filterMap.
  Qed.

  Lemma subseq_get_op_output_keys :
    forall xs ys,
      subseq xs ys ->
      subseq (get_op_output_keys xs) (get_op_output_keys ys).
  Proof using.
    eauto using subseq_filterMap.
  Qed.

  Ltac start :=
    match goal with
      | [ H : good_trace (_ :: _) |- _ ] => simpl in H
    end;
    break_and; subst;
    match goal with
      | [ H : context [In (?c _) (_ :: ?c ?k' :: _) -> In _ ?l] |- _ ] =>
        assert (In (O k') l) by firstorder;
          assert (before (I k') (O k') l) by auto;
          repeat rewrite get_IR_input_keys_defn in *;
          repeat rewrite get_IR_output_keys_defn in *;
          repeat match goal with
                   | [ H : NoDup (_ :: _) |- _ ] => invc H
                 end;
          assert (In (I k') l) by eauto using before_In;
          assert (forall x, before x (I k') l -> exists k, x = I k) by eauto using before_head_op;
          find_copy_apply_lem_hyp before_split; auto; try congruence; break_exists; subst
    end;
    repeat match goal with
             | [ H : In ?x (_ ++ ?x :: _) |- _ ] => clear H
             | [ H : In ?x (_ ++ _ :: _ ++ ?x :: _) |- _ ] => clear H
           end.

  Lemma acknowledge_all_ops_func_target_ext_strong :
    forall (l : list op) (t t' : list IR),
      (forall k : K, In (I k) l -> In (IRU k) t -> In (IRU k) t') ->
      (forall k : K, In (I k) l -> In (IRU k) t' -> In (IRU k) t) ->
      acknowledge_all_ops_func l t = acknowledge_all_ops_func l t'.
  Proof using.
    induction l; intros.
    - auto.
    - simpl. repeat break_match; subst; simpl in *; intuition auto 10 using f_equal with *.
      + exfalso. eauto.
      + exfalso. eauto.
  Qed.

  Lemma IRU_not_O_preserved_IU :
    forall xs ys k' ir,
      (forall k,
         In (IRU k) (IRI k' :: IRU k' :: ir) ->
         ~ In (O k) (xs ++ I k' :: ys)) ->
      forall k,
        In (IRU k) (ir) ->
        ~ In (O k) (xs ++ ys).
  Proof using.
    intuition.
    eapply H.
    - apply in_cons. apply in_cons. eauto.
    - auto using in_middle_insert.
  Qed.

  Lemma IRU_not_O_preserved :
    forall xs ys zs k' ir,
      (forall k,
         In (IRU k) (IRI k' :: IRO k' :: ir) ->
         ~ In (O k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k,
        In (IRU k) (ir) ->
        ~ In (O k) (xs ++ ys ++ zs).
  Proof using.
    intuition.
    eapply H.
    - eauto with *.
    - auto using In_cons_2_3.
  Qed.

  Lemma IR_equivalent_acknowledge_all_ops_func :
    forall ir,
      good_trace ir ->
      forall l,
        (forall k, In (O k) l -> In (IRO k) ir) ->
        (forall k, In (IRO k) ir -> In (O k) l) ->
        (forall k, In (IRU k) ir -> In (I k) l) ->
        (forall k, In (IRU k) ir -> ~ In (O k) l) ->
        (forall k k', In (I k') l ->
                      before (O k) (I k') l ->
                      before (IRO k) (IRI k') ir) ->
        (forall k, In (O k) l -> before (I k) (O k) l) ->
        (forall k, In (IRI k) ir -> In (I k) l) ->
        NoDup (get_op_input_keys l) ->
        NoDup (get_IR_input_keys ir) ->
        NoDup (get_op_output_keys l) ->
        NoDup (get_IR_output_keys ir) ->
        IR_equivalent (acknowledge_all_ops_func l ir) ir.
  Proof using.
    intros ir.
    induction ir, good_trace using good_trace_ind; intros; try solve [simpl in *; intuition].
    - rewrite acknowledge_all_ops_func_target_nil; auto.
    - start.
      eapply IR_equiv_trans.
      + apply op_equiv_AAOF_IR_equiv.
        apply op_equivalent_all_Is_I_middle.
        intros.
        match goal with
          | [ H : context [before] |- _ ] => apply H
        end.
        apply In_app_before; auto using op_eq_dec.
        find_rewrite_lem get_op_input_keys_app. rewrite get_op_input_keys_defn in *.
        intro. eapply NoDup_remove_2; eauto using in_or_app, get_op_input_keys_complete.
      + repeat rewrite app_ass.
        rewrite acknowledge_all_ops_func_defn.
        break_if.
        * constructor.
          { eapply IR_equiv_trans.
            - apply op_equiv_AAOF_IR_equiv.
              rewrite <- app_ass.
              eauto using op_equivalent_all_Is_O_middle, no_Ik_in_first2.
            - simpl. constructor.
              rewrite acknowledge_all_ops_func_target_ext with (t' := ir).
              + rewrite app_ass.
                apply IHP; auto.
                * eauto using O_IRO_preserved.
                * eauto using IRO_O_preserved.
                * eauto using IRU_I_preserved.
                * eauto using IRU_not_O_preserved.
                * eauto using in_before_before_preserved.
                * eauto using in_before_preserved.
                * eauto using IRI_I_preserved.
                * eauto using subseq_NoDup, subseq_get_op_input_keys, subseq_2_3.
                * eauto using subseq_NoDup, subseq_get_op_output_keys, subseq_2_3.
              + simpl. intuition congruence.
              + intuition.
          }
        * { break_if.
            - simpl in *. intuition (try congruence).
              exfalso. eauto using get_IR_output_keys_complete_U.
            - exfalso. apply n. red. intuition.
          }
    - (* IRU case. *)
      match goal with
        | [ H : good_trace (_ :: _) |- _ ] => simpl in H
      end.
      break_and; subst.
      match goal with
        | [ H : context [In (?c _) (_ :: ?c ?k' :: _) -> In _ ?l] |- _ ] =>
          assert (In (I k') l) by firstorder;
            assert (forall x, before x (I k') l -> exists k, x = I k) by eauto using before_head_op
      end;
        repeat rewrite get_IR_input_keys_defn in *;
        repeat rewrite get_IR_output_keys_defn in *;
        repeat match goal with
                 | [ H : NoDup (_ :: _) |- _ ] => invc H
               end.
      find_copy_apply_lem_hyp in_split.
      break_exists. subst.
      eapply IR_equiv_trans.
      + apply op_equiv_AAOF_IR_equiv.
        apply op_equivalent_all_Is_I_middle.
        intros.
        match goal with
          | [ H : context [before] |- _ ] => apply H
        end.
        apply In_app_before; auto using op_eq_dec.
        find_rewrite_lem get_op_input_keys_app. rewrite get_op_input_keys_defn in *.
        intro. eapply NoDup_remove_2; eauto using in_or_app, get_op_input_keys_complete.
      + rewrite acknowledge_all_ops_func_defn.
        break_if.
        * exfalso.
          intuition eauto using in_middle_insert, in_cons, in_eq, acknowledged_op_defn.
        * rewrite if_decider_true by intuition.
          { constructor. constructor.
            rewrite acknowledge_all_ops_func_target_ext_strong with (t' := ir).
            - apply IHP; auto.
              + eauto using O_IRO_preserved_IU.
              + eauto using IRO_O_preserved_IU.
              + eauto using IRU_I_preserved_IU.
              + eauto using IRU_not_O_preserved_IU.
              + eauto using in_before_before_preserved_IU.
              + eauto using in_before_preserved_IU.
              + eauto using IRI_I_preserved_IU.
              + eauto using subseq_NoDup, subseq_get_op_input_keys, subseq_middle.
              + eauto using subseq_NoDup, subseq_get_op_output_keys, subseq_middle.
            - simpl. intuition (try congruence ). find_inversion.
              rewrite get_op_input_keys_app in *. rewrite get_op_input_keys_defn in *.
              exfalso.
              repeat match goal with
                       | [ H : In ?x (_ ++ ?x :: _) |- _ ] => clear H
                       | [ H : In ?x (_ ++ _ :: _ ++ ?x :: _) |- _ ] => clear H
                     end.
              do_in_app.
              eapply NoDup_remove_2; intuition eauto using in_or_app, get_op_input_keys_complete.
            - intros. simpl. intuition.
          }
  Qed.

  Theorem equivalent_intro :
    forall l ir,
      good_trace ir ->
      (forall k, In (O k) l -> In (IRO k) ir) ->
      (forall k, In (IRO k) ir -> In (O k) l) ->
      (forall k, In (IRU k) ir -> In (I k) l) ->
      (forall k k', In (I k') l ->
                    before (O k) (I k') l ->
                    before (IRO k) (IRI k') ir) ->
      (forall k, In (O k) l -> before (I k) (O k) l) ->
      (forall k, In (IRU k) ir -> ~ In (O k) l) ->
      NoDup (get_op_input_keys l) ->
      NoDup (get_IR_input_keys ir) ->
      NoDup (get_op_output_keys l) ->
      NoDup (get_IR_output_keys ir) ->
      equivalent l ir.
  Proof using K_eq_dec.
    intros.
    red.
    intuition.
    exists (acknowledge_all_ops_func l ir).
    intuition.
    - apply acknowledge_all_ops_func_correct.
    - apply IR_equivalent_acknowledge_all_ops_func; auto.
      intros.
      find_apply_lem_hyp good_trace_IRI_in; auto.
      intuition eauto using before_In.
  Qed.

End Linearizability.
Arguments I {_} _.
Arguments O {_} _.

Arguments IRI {_} _.
Arguments IRO {_} _.
Arguments IRU {_} _.


Require Import List.
Import ListNotations.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import ZArith.

Require Import QuickChick.Show.

(* Proof that Show for string round-trips. *)

Lemma not_digit_when (c : ascii) (x : nat) :
  (nat_of_ascii c < 48) \/ (57 < nat_of_ascii c) ->
  unit_digit x <> c.
Proof.
  assert (mod_fact : x mod 10 < 10).
  { apply Nat.mod_upper_bound; auto. }
  intros H e.
  unfold unit_digit in e.
  apply (f_equal nat_of_ascii) in e.
  rewrite nat_ascii_embedding in e.
  intuition.
  intuition.
Qed.

Lemma unit_digit_ascii :
  forall n, digit_of_ascii (unit_digit n) = Some (n mod 10).
Proof.
  intro.
  assert (mod_fact : n mod 10 < 10).
  { apply Nat.mod_upper_bound; auto. }
  unfold unit_digit.
  unfold digit_of_ascii.
  rewrite nat_ascii_embedding.
  replace (48 <=? n mod 10 + 48) with true.
  replace (n mod 10 + 48 <=? 57) with true.
  rewrite Nat.add_sub.
  auto.
  { symmetry. apply leb_correct. intuition. }
  { symmetry. apply leb_correct. intuition. }
  { intuition. }
Qed.

Lemma decimal_thousand : forall n,
    n < 256 ->
    (n / 100) mod 10 * 100 + (n / 10) mod 10 * 10 + n mod 10 = n.
Admitted.

Lemma ascii_256 : forall c, nat_of_ascii c < 256.
Admitted.

Lemma unthree_three_digit (c : ascii) :
  let n := nat_of_ascii c in
  unthree_digit
    (unit_digit (n / 100)) (unit_digit (n / 10)) (unit_digit n)
  = Some (ascii_of_nat n).
Proof.
  unfold unthree_digit.
  do 3 rewrite unit_digit_ascii.
  rewrite decimal_thousand.
  auto.
  apply ascii_256.
Qed.

Lemma read_show_quoted_string : forall (s : string),
    read_quoted_string (show_quoted_string s) = Some s.
Proof.
  induction 0.
  - auto.
  - unfold show_quoted_string.
    destruct (ascii_dec a "009") as [is_tab | isn_tab].
    { fold show_quoted_string.
      simpl.
      rewrite IHs.
      rewrite is_tab; auto.
    }
    destruct (ascii_dec a "010") as [is_nl | isn_nl].
    { fold show_quoted_string.
      simpl; rewrite IHs.
      rewrite is_nl; auto.
    }
    destruct (ascii_dec a "013") as [is_cr | isn_cr].
    { fold show_quoted_string.
      simpl; rewrite IHs.
      rewrite is_cr; auto.
    }
    destruct (ascii_dec a """") as [is_dq | isn_dq].
    { fold show_quoted_string.
      simpl; rewrite IHs.
      rewrite is_dq; auto.
    }
    destruct (ascii_dec a "\") as [is_bs | isn_bs].
    { fold show_quoted_string.
      simpl; rewrite IHs.
      rewrite is_bs; auto.
    }
    destruct ((nat_of_ascii a <? 32) || (126 <? nat_of_ascii a))%bool.
    { fold show_quoted_string.
      simpl.
      destruct (ascii_dec _ "n") as [is_n2 | isn_n2].
      { apply not_digit_when in is_n2. contradict is_n2.
        compute. right. intuition.
      }
      destruct (ascii_dec _ "r") as [is_r2 | isn_r2].
      { apply not_digit_when in is_r2. contradict is_r2.
        compute. right. intuition.
      }
      destruct (ascii_dec _ "t") as [is_t2 | isn_t2].
      { apply not_digit_when in is_t2. contradict is_t2.
        compute. right. intuition.
      }
      destruct (ascii_dec _ "\") as [is_bs2 | isn_bs2].
      { apply not_digit_when in is_bs2. contradict is_bs2.
        compute. right; intuition.
      }
      destruct (ascii_dec _ """") as [is_dq2 | isn_dq2].
      { apply not_digit_when in is_dq2. contradict is_dq2.
        compute. left; intuition.
      }
      fold (Nat.div (nat_of_ascii a) 100).
      fold (Nat.div (nat_of_ascii a) 10).
      rewrite unthree_three_digit.
      rewrite IHs.
      rewrite ascii_nat_embedding.
      auto.
    }
    { fold show_quoted_string.
      simpl.
      destruct (ascii_dec a """"); [contradiction |].
      destruct (ascii_dec a "\"); [contradiction |].
      rewrite IHs.
      auto.
    }
Qed.

Lemma read_show_string : forall (s : string),
    read_string (show s) = Some s.
Proof.
  intro.
  simpl.
  apply read_show_quoted_string.
Qed.