Set Implicit Arguments.

Require Export List.
Require Export Arith.

Section Carrier.

Variable N:Type.
Variable zero : N.
Variable succ : N -> N.
Variable comp : N -> N -> comparison.

Fixpoint fromNat (x:nat) : N :=
  match x with
    | 0 => zero
    | S y => succ (fromNat y)
  end.

Variable size : forall t, list t -> N.
Variable sizeNat : forall t (x:list t), fromNat (length x) = size x.

(*
Definition Buffer t := list t.

Definition bufferSize t (b:list t) := @length _ b < 6.
*)

Inductive Buffer t :=
  Zero
| One : t -> Buffer t
| Two : t -> t -> Buffer t
| Three : t -> t -> t -> Buffer t
| Four : t -> t -> t -> t -> Buffer t
| Five : t -> t -> t -> t -> t -> Buffer t.

Set Maximal Implicit Insertion.
Implicit Arguments Zero [t].
Unset Maximal Implicit Insertion.

(*
Inductive SimpleDeque t :=
  Empty : SimpleDeque t
| Full : Buffer t ->
         SimpleDeque (prod t t) ->
         Buffer t ->
         SimpleDeque t.
*)

(*
Inductive LeafTree t :=
  One : t -> LeafTree t
| More : LeafTree (prod t t) -> LeafTree t.

Definition Elem := LeafTree A.
*)

Inductive SubStack s : Type -> Type :=
  Single : Buffer s -> Buffer s -> SubStack s s
| Multiple : forall t,
             Buffer s -> Buffer s ->
             SubStack (prod s s) t ->
             SubStack s t.

Inductive Deque s :=
  Empty : Deque s
| Full : forall t,
         SubStack s t ->
         Deque (prod t t) ->
         Deque s.

Set Maximal Implicit Insertion.
Implicit Arguments Empty [s].
Unset Maximal Implicit Insertion.

Definition toListBufferC t (x:Buffer t) r :=
  match x with
    | Zero => r
    | One a => a::r
    | Two a b => a::b::r
    | Three a b c => a::b::c::r
    | Four a b c d => a::b::c::d::r
    | Five a b c d e => a::b::c::d::e::r
  end.
Hint Unfold toListBufferC.
(*
Definition toListPairBufferC t (x:Buffer (prod t t)) r :=
  match x with
    | Zero => r
    | One (a,b) => a::b::r
    | Two (a,b) (c,d) => a::b::c::d::r
    | Three (a,b) (c,d) (e,f) => a::b::c::d::e::f::r
    | Four (a,b) (c,d) (e,f) (g,h) => a::b::c::d::e::f::g::h::r
    | Five (a,b) (c,d) (e,f) (g,h) (i,j) => a::b::c::d::e::f::g::h::i::j::r
  end.
*)

Fixpoint unzipMix t (x:list (prod t t)) r :=
  match x with
    | nil => r
    | (a,b)::tyl => a::b::(unzipMix tyl r)
  end.

(*
Require Import Program.
Require Import Coq.Logic.JMeq.
*)
(* Error: Library Coq.Logic.JMeq has to be required first. *)
(*
Program Fixpoint toListSubStack t s (x:SubStack t s) (r:list s -> list s) : list t :=
  match x with
    | Single a b => toListBufferC a (r (toListBufferC b nil))
    | Multiple _ a b tyl =>
      toListBufferC a
      (unzipMix (toListSubStack tyl r)
        (toListBufferC b nil))
  end.
*)

Fixpoint toListSubStack t s (x:SubStack t s) :
  (list s -> list s) -> list t :=
  match x with
    | Single a b => fun r => toListBufferC a (r (toListBufferC b nil))
    | Multiple _ a b tyl => fun r =>
      toListBufferC a
      (unzipMix (toListSubStack tyl r)
        (toListBufferC b nil))
  end.

Fixpoint toListDeque t (x:Deque t) : list t :=
  match x with
    | Empty => nil
    | Full u hed tyl =>
      toListSubStack hed (unzipMix (toListDeque tyl))
  end.

Inductive Color :=
  Red
| Yellow
| Green.

Definition bufferColor t (b:Buffer t) :=
  match b with
    | Two _ _ => Green
    | Three _ _ _ => Green
    | One _ => Yellow
    | Four _ _ _ _ => Yellow
    | _ => Red
  end.
Hint Unfold bufferColor.
Hint Unfold length.

Definition minColor a b :=
  match a with
    | Red => Red
    | Yellow =>
      match b with
        | Red => Red
        | _ => Yellow
      end
    | _ => b
  end.

Definition bottomSubStackColor s t (x:SubStack s t) :=
  match x with
    | Single pre suf =>
      match pre with
        | Zero => bufferColor suf
        | _ =>
          match suf with
            | Zero => bufferColor pre
            | _ => minColor (bufferColor pre) (bufferColor suf)
          end
      end
    | Multiple _ pre suf _ => minColor (bufferColor pre) (bufferColor suf)
  end.

Definition topSubStackColor s t (x:SubStack s t) :=
  match x with
    | Single pre suf =>
        minColor (bufferColor pre) (bufferColor suf)
    | Multiple _ pre suf _ =>
        minColor (bufferColor pre) (bufferColor suf)
  end.

Definition dequeColor t (d:Deque t) :=
  match d with
    | Empty => None
    | Full _ hed tyl => Some (
      match tyl with
        | Empty => bottomSubStackColor hed
        | _ => topSubStackColor hed
      end)
  end.

Fixpoint allSubStackYellow (f:forall s t, SubStack s t -> Color)
  s t (x:SubStack s t) :=
  f _ _ x = Yellow /\
  match x with
    | Single _ _ => True
    | Multiple _ _ _ r => allSubStackYellow f r
  end.

Definition tailStackColor (f: forall s t, SubStack s t -> Color)
  s t (x:SubStack s t) :=
  match x with
    | Single _ _ => None
    | Multiple _ _ _ r => Some (f _ _ r)
  end.

Definition yellowOrNothing x :=
  match x with
    | None => True
    | Some c =>
      match c with
        | Yellow => True
        | _ => False
      end
  end.

Definition tailStackProp (f: forall s t, SubStack s t -> Prop)
  s t (x:SubStack s t) :=
  match x with
    | Single _ _ => True
    | Multiple _ _ _ r => f _ _ r
  end.

Fixpoint restWellStacked s (x:Deque s) :=
  match x with
    | Empty => True
    | Full _ hed tyl =>
      match tyl with
        | Empty =>
          bottomSubStackColor hed <> Yellow
          /\
          tailStackProp (allSubStackYellow bottomSubStackColor) hed
        | _ =>
          topSubStackColor hed <> Yellow
          /\
          tailStackProp (allSubStackYellow topSubStackColor) hed
          /\
          restWellStacked tyl
      end
  end.

Definition wellStacked s (x:Deque s) :=
  match x with
    | Empty => True
    | Full _ hed tyl =>
      match tyl with
        | Empty => tailStackProp (allSubStackYellow bottomSubStackColor) hed
        | _ =>
          tailStackProp (allSubStackYellow topSubStackColor) hed
          /\
          restWellStacked tyl
      end
  end.

Fixpoint topDequeColors s (x:Deque s) :=
  match x with
    | Empty => nil
    | Full _ hed tyl =>
      match tyl with
        | Empty => (bottomSubStackColor hed) :: nil
        | _ => (topSubStackColor hed) :: (topDequeColors tyl)
      end
  end.

Fixpoint semiRegularColorListGreenBeforeRed x :=
  match x with
    | nil => True
    | y::ys =>
      match y with
        | Red => False
        | Green => semiRegularColorList ys
        | Yellow => semiRegularColorListGreenBeforeRed ys
      end
  end
with semiRegularColorList x :=
  match x with
    | nil => True
    | y::ys =>
      match y with
        | Red => semiRegularColorListGreenBeforeRed ys
        | _ => semiRegularColorList ys
      end
  end.

Fixpoint nonEmptySubStack t s (x:SubStack t s) :=
  match x with
    | Single pre suf =>
      match pre, suf with
        | Zero,Zero => False
        | _,_ => True
      end
    | Multiple _ pre suf tyl =>
        (match pre, suf with
           | Zero,Zero => False
           | _,_ => True
         end)
        /\
        nonEmptySubStack tyl
  end.

(* Full deques are not empty *)
Fixpoint fullDequeIs t (d:Deque t) :=
  match d with
    | Empty => True
    | Full _ hed tyl =>
      match tyl with
        | Empty => nonEmptySubStack hed
        | _ =>
          nonEmptySubStack hed
          /\
          fullDequeIs tyl
      end
  end.

Fixpoint eachBufferSubStack (f: forall a, Buffer a -> Prop)
  s t (x:SubStack s t) :=
  match x with
    | Single pre suf => f _ pre /\ f _ suf
    | Multiple _ pre suf tyl => f _ pre /\ f _ suf /\ eachBufferSubStack f tyl
  end.

Fixpoint eachSubStackDeque (f:forall s t, SubStack s t -> Prop)
  s (x:Deque s) :=
  match x with
    | Empty => True
    | Full _ hed tyl =>
      f _ _ hed /\ eachSubStackDeque f tyl
  end.

Definition semiRegular s (x:Deque s) :=
  wellStacked x
  /\
  fullDequeIs x
  /\
(*  eachSubStackDeque (eachBufferSubStack bufferSize) x
  /\*)
  semiRegularColorList (topDequeColors x).
Hint Unfold semiRegular.

Fixpoint topNonYellowIsGreen x :=
  match x with
    | nil => True
    | y::ys =>
      match y with
        | Red => False
        | Yellow => topNonYellowIsGreen ys
        | Green => True
      end
  end.

(*
Fixpoint regularColorList x :=
  topNonYellowIsGreen x
  /\
  semiRegularColorList x.
*)

Definition regular s (x:Deque s) :=
  semiRegular x
  /\
  topNonYellowIsGreen (topDequeColors x).
Hint Unfold regular.

Definition restoreBottom t (pre suf:Buffer t) : Deque t :=
  match pre,suf with
    | Zero,Five a b c d e =>
      Full (Single (Two a b) (Three c d e)) Empty
    | One a,Five b c d e f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Two a b,Five c d e f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Three a b c,Five d e f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Four a b c d,Five e f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty
    | Five a b c d e,Five f g h i j =>
      Full (Multiple (Three a b c) (Three h i j)
        (Single (One (d,e)) (One (f,g)))) Empty

    | Five a b c d e, Zero =>
      Full (Single (Two a b) (Three c d e)) Empty
    | Five a b c d e, One f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Five a b c d e, Two f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Five a b c d e, Three f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Five a b c d e, Four f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty

    | _,_ => Full (Single pre suf) Empty
  end.

Ltac cutThis x :=
  let xx := fresh
    in remember x as xx; destruct xx.

Ltac equate x y :=
  let H := fresh "H" in
    assert (H : x = y); [ reflexivity | clear H ].

Ltac pisp t n := auto;
      try subst;
        unfold bufferColor in *;
          unfold toListBufferC in *; (*
            try (unfold bottomSubStackColor);
              try (unfold topSubStackColor); *)
                unfold regular in *;
                  unfold semiRegular in *;
    unfold not; intros;
          simpl in *; auto; t; auto;
   match goal with
     | [H : ?a <> ?a |- _] =>
       let fname := fresh
         in abstract (unfold not in H;
           pose (H (eq_refl _)) as fname;
             inversion fname)
     | [H:Red=Yellow |- _] => abstract (inversion H)
     | [H:Red=Green |- _] => abstract (inversion H)
     | [H:Yellow=Green |- _] => abstract (inversion H)
     | [H:Yellow=Red |- _] => abstract (inversion H)
     | [H:Green=Red |- _] => abstract (inversion H)
     | [H:Green=Yellow |- _] => abstract (inversion H)
     | [ H : true = false |- _] => abstract (inversion H)
     | [ H : None = Some ?a |- _] => abstract (inversion H)
     | [ H : Some ?a = None |- _] => abstract (inversion H)
     | [ H : False |- _] => abstract (inversion H)
(*
   | [ H : True |- _] => clear H; pisp t
   | [ H : ?a = ?a |- _] => clear H;  pisp t
   *)
     | [ H : Some ?a = Some ?b |- _] => inversion_clear H; subst;  pisp t n

(*
     | [ |- regular (Full _ _) ] => unfold regular;  pisp t
     | [ H : regular (Full _ _) |- _] => unfold regular in H;  pisp t
     | [ H : semiRegular (Full _ _) |- _] => unfold semiRegular in H;  pisp t
     | [ |- semiRegular (Full _ _) ] => unfold semiRegular;  pisp t
*)
(*
     | [ |- context[regular (Full _ _)] ] => unfold regular;  pisp t
     | [ H : context[regular (Full _ _)] |- _] => unfold regular in H;  pisp t
     | [ H : context[semiRegular (Full _ _)] |- _] => unfold semiRegular in H;  pisp t
     | [ |- context[semiRegular (Full _ _)] ] => unfold semiRegular;  pisp t
*)

(*     | [H : ?A \/ ?B |- _] => destruct H;  pisp t *)
     | [ H : _ /\ _ |- _ ] => destruct H;  pisp t n
     | [ |- _ /\ _ ] => split;  pisp t n
     | [ H : prod _ _ |- _] => cutThis H; pisp t n

     | [ H : _ = Red |- _] => rewrite H in *; pisp t n
     | [ H : _ = Yellow |- _] => rewrite H in *; pisp t n
     | [ H : _ = Green |- _] => rewrite H in *; pisp t n
     | [ H : Red = _ |- _] => rewrite <- H in *; pisp t n
     | [ H : Yellow = _ |- _] => rewrite <- H in *; pisp t n
     | [ H : Green = _ |- _] => rewrite <- H in *; pisp t n

(*     | [ H :*)
     | _ =>
       match n with
         | S ?m =>
           match goal with
             | [ |- context
               [match ?x with
                  | Red => _
                  | Yellow => _
                  | Green => _
                end]] => cutThis x; abstract (pisp t m)
             | [ |- context
               [match ?x with
                  | Zero => _
                  | One _ => _
                  | Two _ _ => _
                  | Three _ _ _ => _
                  | Four _ _ _ _ => _
                  | Five _ _ _ _ _ => _
                end]] => cutThis x; abstract (pisp t m)
             | [ |- context[
               match ?x with
                 | Single _ _ => _
                 | Multiple _ _ _ _ => _
               end]] => cutThis x; abstract (pisp t m)
             | [ |- context[
               match ?x in SubStack _ _ return _ with
                 | Single _ _ => _
                 | Multiple _ _ _ _ => _
               end]] => cutThis x; abstract (pisp t m)
             | [ |- context
               [match ?x with
                  | Empty => _
                  | Full _ _ _ => _
                end]] => cutThis x; abstract (pisp t m)

             | [ _: context
               [match ?x with
                  | Red => _
                  | Yellow => _
                  | Green => _
                end]|-_] => cutThis x; abstract (pisp t m)
             | [ _: context
               [match ?x with
                  | Zero => _
                  | One _ => _
                  | Two _ _ => _
                  | Three _ _ _ => _
                  | Four _ _ _ _ => _
                  | Five _ _ _ _ _ => _
                end]|-_] => cutThis x; abstract (pisp t m)
             | [ _:context[
               match ?x with
                 | Single _ _ => _
                 | Multiple _ _ _ _ => _
               end]|-_] => cutThis x; abstract (pisp t m)
             | [ _:context[
               match ?x in SubStack _ _ return _ with
                 | Single _ _ => _
                 | Multiple _ _ _ _ => _
               end]|-_] => cutThis x; abstract (pisp t m)
             | [ _:context
               [match ?x with
                  | Empty => _
                  | Full _ _ _ => _
                end]|-_] => cutThis x; abstract (pisp t m)
           end
(*         | _ => auto *)
       end
     | _ => auto
   end.

Ltac nisp n := pisp auto n.

Ltac dasp n := abstract (nisp n) || dasp (S n).
Ltac asp := dasp 0.
Ltac sisp := pisp auto 1.

Lemma restoreBottomDoes :
  forall t (pre suf:Buffer t),
    semiRegular (Full (Single pre suf) Empty) ->
    regular (restoreBottom pre suf).
Proof.
  intros.
  destruct pre; nisp 1.
Qed.
Hint Resolve restoreBottomDoes.

Lemma restoreBottomPreserves :
  forall t (pre suf:Buffer t),
    let x := (Full (Single pre suf) Empty) in
      semiRegular x ->
      toListDeque (restoreBottom pre suf) = toListDeque x.
Proof.
  intros.
  destruct pre; nisp 1.
Qed.
Hint Resolve restoreBottomPreserves.

Definition lShiftBuffer T (buf: Buffer T) (x:T) : prod T (Buffer T) :=
  match buf with
    | Zero => (x,Zero)
    | One a => (a,One x)
    | Two a b => (a,Two b x)
    | Three a b c => (a,Three b c x)
    | Four a b c d => (a,Four b c d x)
    | Five a b c d e => (a,Five b c d e x)
  end.

Definition lShiftBottom T (pre suf:Buffer T) (x:T)
  :=
  let (a,b) := lShiftBuffer suf x in
    let (c,d) := lShiftBuffer pre a in
      (c,d,b).

Lemma unzipMixApp :
  forall T (x:list (prod T T)) (y:list T) (z:list T),
    (unzipMix x y) ++ z = unzipMix x (y ++ z).
Proof.
  clear; intros.
  induction x; nisp 0.
  rewrite IHx. auto.
Qed.
Hint Rewrite unzipMixApp : anydb.

Require Import caseTactic.

Ltac bufferCase c x :=
  let xx := fresh
    in remember x as xx;
      destruct xx;
        [c "Zero"
          |c "One"
          |c "Two"
          |c "Three"
          |c "Four"
          |c "Five"].

Ltac dequeCase c x :=
  let xx := fresh
    in remember x as xx;
      destruct xx;
        [c "Empty"
          |c "Full"].

Ltac subStackCase c x :=
  let xx := fresh
    in remember x as xx;
      destruct xx;
        [c "Single"
          |c "Multiple"].

Definition injectSemi T (x:Deque T) (z:T) : Deque T :=
  match x with
    | Empty => Full (Single (One z) Zero) Empty
(*    | Full _ (Single Zero (Five a b c d e)) Empty =>
      Full (Single (Three a b c) (Three d e z)) Empty
*)    | Full _ ss r =>
      match ss in SubStack _ V return Deque (prod V V) -> Deque T with
        | Single p s =>
          fun (v:Deque (prod T T)) =>
            match s with
              | Zero => Full (Single p (One z)) v
              | One a => Full (Single p (Two a z)) v
              | Two a b => Full (Single p (Three a b z)) v
              | Three a b c => Full (Single p (Four a b c z)) v
              | Four a b c d => Full (Single p (Five a b c d z)) v
              | Five a b c d e => x (*
                match p,v with
                  | Zero,Empty => Full (Single (Three a b c) (Three d e z)) Empty
                  | _,_ => x
                end*)
            end
        | Multiple t0 p s r1 =>
          fun (v:Deque (prod t0 t0)) =>
            match s with
              | Zero => x (*Full (Multiple p (One z) r1) v*)
              | One a => Full (Multiple p (Two a z) r1) v
              | Two a b => Full (Multiple p (Three a b z) r1) v
              | Three a b c => Full (Multiple p (Four a b c z) r1) v
              | Four a b c d => Full (Multiple p (Five a b c d z) r1) v
              | _ => x
            end
      end r
  end.

Lemma injectSemiDoes :
  forall T (x:Deque T) (z:T),
    regular x ->
    (app (toListDeque x) (z :: nil)) = toListDeque (injectSemi x z).
Proof.
  clear. intros.
  Ltac eqlr := autorewrite with anydb.
  destruct x.
  nisp 0.
  pisp eqlr 3.
  nisp 1.
  nisp 1. nisp 2.
  rewrite unzipMixApp.

  simpl. destruct s; simpl.
  destruct b; simpl. eqlr. destruct b0; simpl; auto. nisp 1.
  simpl. destruct b0; simpl; eqlr; auto; nisp 1.
simpl. destruct b0; simpl; eqlr; auto; nisp 1.
simpl. destruct b0; simpl; eqlr; auto; nisp 1.
simpl. destruct b0; simpl; eqlr; auto; nisp 1.
simpl. destruct b0; simpl; eqlr; auto; nisp 1.
simpl. nisp 0.

destruct b0; simpl; eqlr; auto; nisp 2.

simpl. destruct b0; simpl; eqlr; auto; nisp 1.simpl. destruct b0; simpl; eqlr; auto; nisp 1.simpl. destruct b0; simpl; eqlr; auto; nisp 1.
  pisp eqlr 1.
  simpl in H. unfold regular in H.
  simpl in H. nisp 1.
  nisp 0.

  rewrite unzipMixApp.  simpl. reflexivity.
  nisp 0.

  nisp 1.

; pisp eqlr 2.
Qed.

Lemma injectSemiIsSemi :
  forall T (x:Deque T) (z:T),
    regular x ->
    semiRegular (injectSemi x z).
Proof.
  clear. intros.
  destruct x; asp.
Qed.

Definition popSemi T U (ss:SubStack T U)
  : Deque (prod U U) -> option (prod T (Deque T)) :=
  match ss in SubStack _ V return Deque (prod V V) -> option (prod T (Deque T)) with
    | Single p s =>
      fun (v:Deque (prod T T)) =>
        match p with
          | Zero => (* v is Empty *)
            match s with
              | One a => Some (a,Empty)
              | Two a b => Some (a,Full (Single (One b) Zero) Empty)
              | Three a b c => Some (a,Full (Single (Two b c) Zero) Empty)
              | Four a b c d => Some (a,Full (Single (Three b c d) Zero) Empty)
              | Five a b c d e => Some (a,Full (Single (Four b c d e) Zero) Empty)
              | _ => None
            end
          | One a =>
            match s with
              | Zero => Some (a,Empty)
              | _ => Some (a,Full (Single Zero s) v)
            end
          | Two a b => Some (a,Full (Single (One b) s) v)
          | Three a b c => Some (a,Full (Single (Two b c) s) v)
          | Four a b c d => Some (a,Full (Single (Three b c d) s) v)
          | Five a b c d e => None
                  (*Some (a,Full (Single (Four b c d e) s) v) *)
        end
    | Multiple t0 p s r1 =>
      fun (v:Deque (prod t0 t0)) =>
        match p with
          | One a => Some (a,Full (Multiple Zero s r1) v)
          | Two a b => Some (a,Full (Multiple (One b) s r1) v)
          | Three a b c => Some (a,Full (Multiple (Two b c) s r1) v)
          | Four a b c d => Some (a,Full (Multiple (Three b c d) s r1) v)
          | _ => None
        end
  end.

Lemma popSemiTotal :
  forall T U (ss:SubStack T U) (v:Deque (prod U U)),
    let x := Full ss v in
      regular x ->
      None = popSemi ss v ->
      False.
Proof.
  clear. intros. unfold x in *. clear x.
  destruct ss; asp.
Qed.

Lemma popSemiDoes :
  forall T U (ss:SubStack T U) (v:Deque (prod U U)),
    let x := Full ss v in
      regular x ->
      match popSemi ss v with
        | None => False
        | Some (hed,tyl) => hed :: toListDeque tyl = toListDeque x
      end.
Proof.
  clear. intros. unfold x in *. clear x.
  cutThis (popSemi ss v).
  destruct ss; asp.
  eapply popSemiTotal; eauto.
Qed.

Lemma semiRegEmpty : forall s, semiRegular (@Empty s).
Proof.
  intros.
  unfold semiRegular.
  unfold topDequeColors; asp.
Qed.
Hint Resolve semiRegEmpty.

Lemma regEmpty : forall s, regular (@Empty s).
Proof.
  intros.
  unfold regular. sisp.
Qed.
Hint Resolve regEmpty.

Lemma popSemiIsSemi :
  forall T U (ss:SubStack T U) (v:Deque (prod U U)),
    let x := Full ss v in
      regular x ->
      match popSemi ss v with
        | None => False
        | Some (_,tyl) => semiRegular tyl
      end.
Proof.
  clear. intros. unfold x in *. clear x.
  cutThis (popSemi ss v).
  destruct ss; sisp; sisp; sisp; sisp.
  sisp.
  sisp; sisp.
  sisp.
  sisp; sisp.
  sisp.
  sisp; sisp.
  sisp.
  destruct s; sisp; sisp; sisp.
  sisp; sisp.
  sisp; sisp.
  sisp.
  sisp; sisp.
  sisp.
  sisp; sisp; sisp; sisp; sisp; sisp; sisp; sisp.
  sisp.
  destruct s; sisp; sisp; sisp.
  sisp; sisp; sisp; sisp; sisp.
  sisp.
  sisp; sisp.
  sisp.
  sisp; sisp.

  destruct ss; sisp; sisp; sisp; sisp;
    destruct s; sisp; sisp; sisp.
  eapply popSemiTotal; eauto.
Qed.

Definition bufferDequeWrap T (pre suf:Buffer T) (xs:Deque (prod T T)) :=
  match xs with
    | Empty => Full (Single pre suf) Empty
    | Full _ ss r =>
      match r with
        | Empty =>
          match bottomSubStackColor ss with
            | Yellow => Full (Multiple pre suf ss) Empty
            | _ => Full (Single pre suf) (Full ss Empty)
          end
        | _ =>
          match topSubStackColor ss with
            | Yellow => Full (Multiple pre suf ss) r
            | _ => Full (Single pre suf) (Full ss r)
          end
      end
  end.
Hint Unfold bufferDequeWrap.

Lemma wrapSemi :
  forall T (xs:Deque (T*T)),
    semiRegular xs ->
    forall pre suf,
      topSubStackColor (Single pre suf) <> Red ->
      semiRegular (bufferDequeWrap pre suf xs).
Proof.
  clear; intros.
  destruct xs; sisp; sisp; sisp.
  unfold bottomSubStackColor in *.
  destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp.
  destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp.
  destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp.
  destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp.
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  Unfocus.
Qed.
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).
  abstract (destruct s; simpl in *;
  destruct b; simpl in *;
  destruct b0; simpl in *; sisp).

 sisp. sisp. sisp. sisp. sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
  cutThis (bottomSubStackColor s); sisp. destruct s; sisp.
  cutThis (topSubStackColor s); sisp. destruct s; sisp. destruct s; sisp.
Qed.

Definition restoreOneYellowBottom
  T (p1 s1:Buffer T) (p2 s2:Buffer (prod T T)) : option (Deque T) :=
  match p1,s1 with
    | Zero,Five a b c d e =>
      Some (
        match lShiftBottom p2 s2 (a,b) with
          | ((p,q),r,s) =>
            Full
            (Multiple (Two p q) (Three c d e)
              (Single r s))
            Empty
        end)
    | One a,Five b c d e f =>
      Some (
        match lShiftBottom p2 s2 (b,c) with
          | ((p,q),r,s) =>
            Full
            (Multiple (Three a p q) (Three d e f)
              (Single r s))
            Empty
        end)
    | Two a b,Five c d e f g =>
      Some (
        match lShiftBottom p2 s2 (c,d) with
          | ((p,q),r,s) =>
            Full
            (Multiple (Four a b p q) (Three e f g)
              (Single r s))
            Empty
        end)
    | Three a b c,Five d e f g h =>
      Some (
        bufferDequeWrap (Three a b c) (Three f g h)
        (injectSemi (Full (Single p2 s2) Empty) (d,e)))
    | _,_ => None
  end.

(*
      Full (Single (Two a b) (Three c d e)) Empty
    | One a,Five b c d e f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Two a b,Five c d e f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Three a b c,Five d e f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Four a b c d,Five e f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty
    | Five a b c d e,Five f g h i j =>
      Full (Multiple (Three a b c) (Three h i j)
        (Single (One (d,e)) (One (f,g)))) Empty

    | Five a b c d e, Zero =>
      Full (Single (Two a b) (Three c d e)) Empty
    | Five a b c d e, One f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Five a b c d e, Two f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Five a b c d e, Three f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Five a b c d e, Four f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty

    | Zero,Zero,One (a,b),Five c d e f g =>
      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
    | Zero,Zero,Four (a,b) cd ef gh,Five i j k l m =>
      Some (Full
      (Single (Two a b) (Three k l m))
        (Full (Single (Two cd ef) (Two gh (i,j))) Empty))

    | Zero,One (a,b),Zero,Five c d e f g =>
      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
    | Zero,One (a,b),One (c,d), Five e f g h i =>
      Some (
        Full (Multiple (Four a b c d) (Three g h i)
          (Single Zero (One (e,f)))) Empty)
    | Zero,One (a,b),Two (c,d) (e,f), Five g h i j k =>
      Some (
        Full (Multiple (Four a b c d) (Three i j k)
          (Single (One (e,f)) (One (g,h)))) Empty)
    | Zero,One (a,b),Three (c,d) (e,f) (g,h), Five i j k l m =>
      Some (
        Full (Multiple (Four a b c d) (Three k l m)
          (Single (One (e,f)) (Two (g,h) (i,j)))) Empty)
    | Zero,One (a,b),Four (c,d) (e,f) (g,h) (i,j), Five k l m n o=>
      Some (
        Full (Multiple (Four a b c d) (Three m n o)
          (Single (One (e,f)) (Three (g,h) (i,j) (k,l)))) Empty)

    | Zero,Two (a,b) (c,d), One (e,f), Five g h i j k =>
      Some (
        Full (Multiple (Four a b c d) (Three i j k)
          (Single (One (e,f)) (One (g,h)))) Empty)
    | Zero,Two (a,b) (c,d),Four (e,f) (g,h) (i,j) (k,l), Five m n o p q=>
      Some (
        Full (Multiple (Four a b c d) (Three o p q)
          (Single (One (e,f)) (Four (g,h) (i,j) (k,l) (m,n)))) Empty)

    | Zero,Three (a,b) (c,d) (e,f), One (g,h), Five i j k l m=>
      Some (
        Full (Multiple (Four a b c d) (Three k l m)
          (Single (One (e,f)) (Two (g,h) (i,j)))) Empty)
    | Zero,Three (a,b) (c,d) (e,f), Four (g,h) (i,j) (k,l) (m,n), Five o p q r s =>
      Some (
        Full (Multiple (Four a b c d) (Three q r s)
          (Single (Two (e,f) (g,h)) (Four (i,j) (k,l) (m,n) (o,p)))) Empty)

    |_,_,_,_ => None
  end.
*)

Lemma restoreOneYellowBottomDoes :
  forall t (p1 s1:Buffer t) p2 s2,
    semiRegular (Full (Multiple p1 s1 (Single p2 s2)) Empty) ->
    match restoreOneYellowBottom p1 s1 p2 s2 with
      | None => True
      | Some v => regular v
    end.
Proof.
  intros.
  destruct p1; destruct s1; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  unfold regular.
  split. apply wrapSemi.
  fold (injectSemi (Full (Single p2 s2) Empty) (t3,t4)).
  apply injectSemiIsSemi. sisp.
  sisp.
  destruct s2; sisp;
    destruct p2; sisp.
Qed.

Lemma restoreOneYellowBottomPreserves :
  forall t (p1 s1:Buffer t) p2 s2,
    let x := (Full (Multiple p1 s1 (Single p2 s2)) Empty) in
    semiRegular x ->
    match restoreOneYellowBottom p1 s1 p2 s2 with
      | None => True
      | Some v => toListDeque x = toListDeque v
    end.
Proof.
  intros.
  destruct p1; destruct s1; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  destruct p2; destruct s2; sisp.
  unfold regular.
  split. apply wrapSemi.
  fold (injectSemi (Full (Single p2 s2) Empty) (t3,t4)).
  apply injectSemiIsSemi. sisp.
  sisp.
  destruct s2; sisp;
    destruct p2; sisp.
  intros.
  destruct p1; destruct s1; asp;
    destruct p2; destruct s2; asp.
Qed.
*)

Definition restore s (x:Deque s) : option (Deque s) :=
  match x with
    | Empty => Some Empty
    | Full _ y ys =>
      match ys with
        | Empty =>
          match y with
            | Single pre suf =>
              Some (restoreBottom pre suf)
            | Multiple _ pre suf tyl =>
              match tyl with
                | Single p2 s2 => None
                | Multiple _ p2 s2 _ => None
              end
          end
        | _ => None
      end
  end.

Lemma regEmpty : forall s, regular (@Empty s).
Proof.
  intros.
  unfold regular.
  unfold semiRegular; unfold topNonYellowIsGreen; unfold topDequeColors;
    asp.
Qed.
Hint Resolve regEmpty.

Lemma restoreDoes :
  forall s (x:Deque s), semiRegular x ->
    match restore x with
      | None => True
      | Some v => regular v
    end.
Proof.
  intros.
  destruct x; simpl in *; auto.
  destruct x; simpl in *; auto.
  destruct s0; auto.
  destruct s0; auto.
Qed.
Lemma restorePreserves :
  forall s (x:Deque s), semiRegular x ->
    match restore x with
      | None => True
      | Some v => toListDeque v = toListDeque x
    end.
Proof.
  intros.
  destruct x; simpl in *; auto.
  destruct x; simpl in *; auto.
  destruct s0; auto.
  apply restoreBottomPreserves; auto.
  destruct s0; auto.
Qed.

Lemma restoreBottomPreserves :
  forall t (pre suf:Buffer t),
    let x := (Full (Single pre suf) Empty) in
      semiRegular x ->
      toListDeque (restoreBottom pre suf) = toListDeque x.
Proof.
  intros.
  destruct pre; asp.
Qed.
Hint Resolve restoreBottomPreserves.

(Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty
    | Zero,One a,Zero,Five b c d e f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Zero,One a,One b,Five c d e f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Zero,One a,One b,Five c d e f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty

    | One a,Five b c d e f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Two a b,Five c d e f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Three a b c,Five d e f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Four a b c d,Five e f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty
    | Five a b c d e,Five f g h i j =>
      Full (Multiple (Three a b c) (Three h i j)
        (Single (One (d,e)) (One (f,g)))) Empty

    | Five a b c d e, Zero =>
      Full (Single (Two a b) (Three c d e)) Empty
    | Five a b c d e, One f =>
      Full (Single (Three a b c) (Three d e f)) Empty
    | Five a b c d e, Two f g =>
      Full (Single (Three a b c) (Four d e f g)) Empty
    | Five a b c d e, Three f g h =>
      Full (Single (Four a b c d) (Four e f g h)) Empty
    | Five a b c d e, Four f g h i =>
      Full (Multiple (Four a b c d) (Three g h i)
        (Single Zero (One (e,f)))) Empty

    | _,_ => Full (Single pre suf) Empty
end

Definition restore s (x:Deque s) : option (Deque s) :=
  match x with
    | Empty => Some Empty
    | Full _ y ys =>
      match ys with
        | Empty =>
          match bottomSubStackColor y with
            | Green => Some x
            | Yellow => Some x
            | Red =>
              match y with
                | Single pre suf =>
                  match pre,suf with

                    | Zero,Five a b c d e =>
                      Some (Full (Single (Two a b) (Three c d e)) Empty)
                    | One a,Five b c d e f =>
                      Some (Full (Single (Three a b c) (Three d e f)) Empty)
                    | Two a b,Five c d e f g =>
                      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
                    | Three a b c,Five d e f g h =>
                      Some (Full (Single (Four a b c d) (Four e f g h)) Empty)
                    | Four a b c d,Five e f g h i =>
                      Some (Full (Multiple (Four a b c d) (Three g h i)
                        (Single Zero (One (e,f)))) Empty)
                    | Five a b c d e,Five f g h i j =>
                      Some (Full (Multiple (Three a b c) (Three h i j)
                        (Single (One (d,e)) (One (f,g)))) Empty)

                    | Five a b c d e, Zero =>
                      Some (Full (Single (Two a b) (Three c d e)) Empty)
                    | Five a b c d e, One f =>
                      Some (Full (Single (Three a b c) (Three d e f)) Empty)
                    | Five a b c d e, Two f g =>
                      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
                    | Five a b c d e, Three f g h =>
                      Some (Full (Single (Four a b c d) (Four e f g h)) Empty)
                    | Five a b c d e, Four f g h i =>
                      Some (Full (Multiple (Four a b c d) (Three g h i)
                        (Single Zero (One (e,f)))) Empty)

                    | _,_ => Some x
                  end
                | Multiple _ pre suf tyl =>
                  match pre,suf with
                    | Zero,Five a b c d e =>
                      match tyl with
                        | Single p2 s2 =>
                          match s2 with
                            | Zero =>
                              Some (Full (Multiple Zero (Three c d e) (Single p2 (One (a,b)))) Empty)
                            | _ => None
                          end
                        | _ => None
                      end
                    | _,_ => None
                  end
(*
                    | One a,Five b c d e f =>
                      Some (Full (Single (Three a b c) (Three d e f)) Empty)
                    | Two a b,Five c d e f g =>
                      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
                    | Three a b c,Five d e f g h =>
                      Some (Full (Single (Four a b c d) (Four e f g h)) Empty)
                    | Four a b c d,Five e f g h i =>
                      Some (Full (Multiple (Four a b c d) (Three g h i)
                        (Single Zero (One (e,f)))) Empty)
                    | Five a b c d e,Five f g h i j =>
                      Some (Full (Multiple (Three a b c) (Three h i j)
                        (Single (One (d,e)) (One (f,g)))) Empty)

                    | Five a b c d e, Zero =>
                      Some (Full (Single (Two a b) (Three c d e)) Empty)
                    | Five a b c d e, One f =>
                      Some (Full (Single (Three a b c) (Three d e f)) Empty)
                    | Five a b c d e, Two f g =>
                      Some (Full (Single (Three a b c) (Four d e f g)) Empty)
                    | Five a b c d e, Three f g h =>
                      Some (Full (Single (Four a b c d) (Four e f g h)) Empty)
                    | Five a b c d e, Four f g h i =>
                      Some (Full (Multiple (Four a b c d) (Three g h i)
                        (Single Zero (One (e,f)))) Empty)

                    | _,_ => Some x

                  match tyl with
                    | Single pre1 suf1 =>
                      match pre1 with
                        | Zero =>
                          match suf1 with
                            | Zero => Some x
                            | _ => None
                          end
                        | _ => None
                      end
                    | _ => None
                  end*)
              end
          end
        | _ => None
      end
  end.

(*
      match topSubStackColor y with
        | Green => x
        | Yellow => restoreRest ys
        | Red =>
*)

Ltac cutThis x :=
  let xx := fresh
    in remember x as xx; destruct xx.

Ltac pisp t := try subst;
  unfold bufferColor in *; simpl in *; auto; t;
  match goal with
    | [H:Red=Yellow |- _] => inversion H;  pisp t
    | [H:Red=Green |- _] => inversion H;  pisp t
    | [H:Yellow=Green |- _] => inversion H;  pisp t
    | [H:Yellow=Red |- _] => inversion H;  pisp t
    | [H:Green=Red |- _] => inversion H;  pisp t
    | [H:Green=Yellow |- _] => inversion H;  pisp t
    | [ H : true = false |- _] => inversion H;  pisp t
    | [ H : None = Some ?a |- _] => inversion H;  pisp t
    | [ H : Some ?a = None |- _] => inversion H;  pisp t
    | [ H : False |- _] => inversion H;  pisp t

    | [ H : True |- _] => clear H; pisp t
    | [ H : ?a = ?a |- _] => clear H;  pisp t

    | [ H : Some ?a = Some ?b |- _] => inversion_clear H; subst;  pisp t
    | [ |- regular (Full _ _) ] => unfold regular;  pisp t
    | [ H : semiRegular (Full _ _) |- _] => unfold semiRegular in H;  pisp t
    | [ |- semiRegular (Full _ _) ] => unfold semiRegular;  pisp t
(*
    | [ _ : context[length ?a] |- _] => destruct a; pisp t
*)
    | [H : ?A \/ ?B |- _] => destruct H;  pisp t
    | [ H : _ /\ _ |- _ ] => destruct H;  pisp t
    | [ |- _ /\ _ ] => split;  pisp t

(*
    | [ _ : _ =
      match ?x with
         | Single _ _ => _
         | Multiple _ _ _ _ => _
       end |- _] => cutThis x; pisp t
*)
    | [ |- context[
      match ?x with
         | Single _ _ => _
         | Multiple _ _ _ _ => _
       end]] => destruct x; pisp t
    | [ |- context
      [match ?x with
         | Zero => _
         | One _ => _
         | Two _ _ => _
         | Three _ _ _ => _
         | Four _ _ _ _ => _
         | Five _ _ _ _ _ => _
       end]] => destruct x; pisp t

(*
    | [ _ : context[bufferColor (?a :: ?b :: ?c :: ?d :: ?e)] |- _]
      => destruct e; pisp t
    | [ _ : context[bufferColor (?a :: ?b :: ?c :: ?e)] |- _]
      => destruct e; pisp t
    | [ _ : context[bufferColor (?a :: ?b :: ?e)] |- _]
      => destruct e; pisp t
(*    | [ _ : context[bufferColor (?a :: ?e)] |- _]
      => destruct e; pisp t*)
*)
    | _ => auto
  end.

Ltac asp := progress pisp auto.

Lemma regEmpty : forall s, regular (@Empty s).
Proof.
  intros.
  unfold regular.
  unfold semiRegular; unfold topNonYellowIsGreen; unfold topDequeColors;
    asp.
Qed.
Hint Resolve regEmpty.

Lemma restoreDoes :
  forall s (x:Deque s), semiRegular x ->
    match restore x with
      | None => True
      | Some v => regular v
    end.
Proof.
  intros.
  destruct x.
  Focus 2.
  simpl.
  destruct x; simpl.
  destruct s0; simpl.
  Focus 2.
  destruct s0.
  destruct b2.
  destruct b0.
  Focus 6.
  destruct b.
  simpl in *.
  unfold regular in *.
  unfold semiRegular in *.
  destruct H. destruct H0.
  split. split.
  simpl in *. asp.
  asp.
  simpl.
  asp.
  split.
  asp.
  destruct x; asp;
    destruct x; asp.
  Focus 2.
  destruct b1; asp.
Qed.

Lemma restorePreserves :
  forall s (x:Deque s), semiRegular x ->
    match restore x with
      | None => True
      | Some v => toListDeque v = toListDeque x
    end.
Proof.
  intros.
  destruct x; asp;
    destruct x; asp.
Qed.

End Carrier.

Extraction Language Haskell.
Recursive Extraction dequeColor.

Lemma help :
  forall t (p q:t), proj1 (conj p q) = p.
Proof.
  Print proj1.
  unfold proj1.
  simpl.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Transitivity.

Lemma wf_env_map_free: forall E1 E2 X C B,
    wf_env (E1 ++ X~B++ E2) ->
    WF (X ~ B ++ E2) C ->
    wf_env ((map (subst_tb X C) E1)++ X~B++E2).
Proof with auto.
  induction E1;intros...
  destruct a.
  rewrite_env ((a, b) :: E1 ++ X~B++ E2) in H.
  simpl...
  rewrite_env  ((a, subst_tb X C b) :: (map (subst_tb X C) E1 ++ (X,B)::E2)).
  destruct b;simpl...
  -
    dependent destruction H.
    constructor...
    apply IHE1...
    rewrite_env (map (subst_tb X C) E1 ++ [(X, B)] ++ E2).
    apply subst_tb_wf2 with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1...
    rewrite_env (map (subst_tb X C) E1 ++ [(X, B)] ++ E2).
    apply subst_tb_wf2 with (Q:=B)...
Qed.

Lemma wf_env_map_free2: forall E1 E2 X C B,
    wf_env (E1 ++ X~B++ E2) ->
    WF  E2 C ->
    wf_env ((map (subst_tb X C) E1)++ E2).
Proof with auto.
  induction E1;intros;simpl...
  dependent destruction H...
  destruct a.
  rewrite_env ((a, b) :: E1 ++ X~B++ E2) in H.
  simpl...
  rewrite_env  ((a, subst_tb X C b) :: (map (subst_tb X C) E1 ++ E2)).
  destruct b;simpl...
  -
    dependent destruction H.
    constructor...
    apply IHE1 with (B:=B)...
    apply subst_tb_wf with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1 with (B:=B)...
    apply subst_tb_wf with (Q:=B)...
Qed.

Lemma binds_map_free_env: forall E1 E2 X Y U T S,
    Y \notin {{X}}  ->
    wf_env (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub U) (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub (subst_tt Y S U)) (map (subst_tb Y S) E1 ++ (Y, bind_sub T) :: E2).
Proof with auto.
  intros.
  unfold binds in *.
  apply binds_map_free with (Y:=Y) (P:=S) in H1...
  apply notin_from_wf_env in H0.
  rewrite_env (map (subst_tb Y S) E1 ++ map (subst_tb Y S) [(Y, bind_sub T)] ++ map (subst_tb Y S) E2) in H1.
  simpl in H1...
  assert (map (subst_tb Y S) E2 = E2).
  rewrite maps_subst_tb_free ...
  rewrite H2 in H1...
  assert (subst_tt Y S T = T).
  rewrite <- subst_tt_fresh...
  rewrite H3 in H1...
Qed.

Lemma equiv_subst_refl: forall E A,
    WF E A -> forall C D X,
    equiv E C D ->
    equiv E (subst_tt X C A) (subst_tt X D A).
Proof with auto.
  intros E A H.
  unfold equiv.
  assert (type A).
  get_type...
  apply type_to_rec in H0.
  generalize dependent E.
  dependent induction H0;intros;simpl;try solve [destruct_hypos;get_well_form;split;auto]...
  -
    destruct_hypos.
    split.
    +
      destruct (X==X0);subst...
      get_well_form.
      constructor...
    +
      destruct (X==X0);subst...
      get_well_form.
      constructor...
  -
    dependent destruction H.
    destruct_hypos.
    split.
    +
      constructor...
      apply IHtype4rec1...
      apply IHtype4rec2...
    +
      constructor...
      apply IHtype4rec1...
      apply IHtype4rec2...
  -
    dependent destruction H3.
    destruct_hypos.
    split.
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E);intros...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite <- subst_tt_open_tt_twice...
        rewrite <- subst_tt_open_tt_twice...
        apply H0...
        split.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E);intros...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite <- subst_tt_open_tt_twice...
        rewrite <- subst_tt_open_tt_twice...
        apply H0...
        split.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
  -
    dependent destruction H2.
    destruct_hypos.
    split.
    +
      apply sa_all with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ E).
        apply WF_narrowing with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
    +
      apply sa_all with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X C T1) ++ E).
        apply WF_narrowing with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
  -
    dependent destruction H.
    destruct_hypos.
    split.
    +
      constructor...
      apply IHtype4rec...
    +
      constructor...
      apply IHtype4rec...
  -
    destruct_hypos. get_well_form.
    split;apply Reflexivity...
  -
    dependent destruction H0.
    specialize (IHtype4rec1 _ H0_1 _ _ X H2).
    specialize (IHtype4rec2 _ H0_2 _ _ X H2).
    destruct_hypos.
    split.
    +
      apply sa_rcd...
      * get_well_form...
      * simpl. intro x. intros.
        apply union_iff in H8. destruct H8...
        apply subst_tt_collect3 with (E:=E) in H8 ...
        apply union_iff. right.
        apply subst_tt_collect2 with (E:=E)...
      * get_well_form. constructor...
        { apply subst_tt_rt_type with(E:=E)... }
        { apply subst_tt_collect with (E:=E)... }
      * get_well_form. constructor...
        { apply subst_tt_rt_type with(E:=E)... }
        { apply subst_tt_collect with (E:=E)... }
      * intros. simpl in *.
        destruct (i == i0).
        { subst. inversion H8. inversion H9. subst... }
        { apply rcd_inversion with (A:=subst_tt X C T2) (B:=subst_tt X D T2) (i:=i0)...
          apply subst_tt_rt_type with (E:=E)... get_well_form...
          apply subst_tt_rt_type with (E:=E)... get_well_form...
        }
    +
      apply sa_rcd...
      * get_well_form...
      * simpl. intro x. intros.
        apply union_iff in H8. destruct H8...
        apply subst_tt_collect3 with (E:=E) in H8 ...
        apply union_iff. right.
        apply subst_tt_collect2 with (E:=E)...
      * get_well_form. constructor...
        { apply subst_tt_rt_type with(E:=E)... }
        { apply subst_tt_collect with (E:=E)... }
      * get_well_form. constructor...
        { apply subst_tt_rt_type with(E:=E)... }
        { apply subst_tt_collect with (E:=E)... }
      * intros. simpl in *.
        destruct (i == i0).
        { subst. inversion H8. inversion H9. subst... }
        { apply rcd_inversion with (A:=subst_tt X D T2) (B:=subst_tt X C T2) (i:=i0)...
          apply subst_tt_rt_type with (E:=E)... get_well_form...
          apply subst_tt_rt_type with (E:=E)... get_well_form...
        }
Qed.

Lemma WF_narrowing_env_subst: forall E1 E2 X T S,
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) T ->
    wf_env (E1 ++ X ~ bind_sub typ_top ++ E2) ->
    WF (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2) T.
Proof with auto.
  intros.
  assert (type T).
  get_type...
  apply type_to_rec in H1.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent X.
  induction H1;intros;try solve [dependent destruction H;auto]...
  -
    dependent destruction H.
    analyze_binds_uniq H.
    apply uniq_from_wf_env...
    +
      apply WF_var with (U:=subst_tt X0 S U).
      apply binds_map_free_env...
    +
      apply WF_var with (U:=typ_top)...
    +
      apply WF_var with (U:=U)...
  -
    dependent destruction H3...
    apply WF_rec with (L:=L \u L0 \u dom E1 \u dom E2 \u {{X}});intros...
    +
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub typ_top ++ E2).
      apply H2...
      apply H3...
      constructor...
    +
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub typ_top ++ E2).
      apply H0...
      apply H4...
      constructor...
  -
    dependent destruction H2...
    apply WF_all with (L:=L \u L0 \u dom E1 \u dom E2 \u {{X}});intros...
    rewrite_env (nil ++ X0 ~ bind_sub T1 ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
    apply WF_narrowing with (V:=subst_tt X S T1).
    rewrite_env (map (subst_tb X S) (X0 ~ bind_sub T1 ++ E1) ++ X ~ bind_sub typ_top ++ E2).
    apply H0...
    apply H3...
    constructor...
  -
    dependent destruction H0...
Qed.

Lemma equiv_sub_subst_refl: forall A X E1 E2 C D S,
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) A ->
    wf_env (E1 ++ X ~ bind_sub typ_top ++ E2) ->
    equiv (X ~ bind_sub typ_top ++ E2) C D ->
    equiv (X ~ bind_sub typ_top ++ E2) C S ->
    equiv (X ~ bind_sub typ_top ++ E2) S D ->
    sub (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2) (subst_tt X C A) (subst_tt X D A).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  assert (type A) as Hq.
  get_type...
  apply type_to_rec in Hq.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent X.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction Hq;intros;simpl...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    destruct (X==X0);subst...
    +
      rewrite_env (nil ++ map (subst_tb X0 S) E1 ++ (X0, bind_sub typ_top) :: E2).
      apply Sub_weakening...
      apply wf_env_map_free...
      get_well_form...
    +
      constructor...
      apply wf_env_map_free...
      get_well_form...
      dependent destruction H.
      analyze_binds H...
      apply WF_var with (U:=subst_tt X0 S U)...
      unfold binds in *.
      apply In_lemmaL.
      apply binds_map_free...
      apply WF_var with (U:= U)...
  -
    dependent destruction H.
    constructor...
    apply IHHq1...
    apply IHHq2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H9.
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2 \u L0);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply subst_tt_wf...
      rewrite_env (nil ++ map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
      apply WF_weakening...
      get_well_form...
      apply WF_narrowing_env_subst...
      apply H9...
      constructor...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply subst_tt_wf...
      rewrite_env (nil ++ map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
      apply WF_weakening...
      get_well_form...
      apply WF_narrowing_env_subst...
      apply H9...
      constructor...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H0...
      apply H10...
      constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      apply IHHq...
    +
      apply IHHq...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2);
        split;apply Sub_weakening...
        apply wf_env_map_free...
        get_well_form...
        apply wf_env_map_free...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub T1 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H0...
        apply H8...
        constructor...
  -
    dependent destruction H.
    constructor...
    apply IHHq...
  -
    dependent destruction H...
    apply Reflexivity...
    apply wf_env_map_free...
    get_well_form...
  -
    inversion H0;subst.
    rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
    apply sa_rcd...
    * apply wf_env_map_free... get_well_form...
    * simpl. intro x. intros.
      apply union_iff in H8. destruct H8...
      apply subst_tt_collect3 with (E:=(E1 ++ X ~ bind_sub typ_top ++ E2)) in H8 ...
      apply union_iff. right.
      apply subst_tt_collect2 with (E:=(E1 ++ X ~ bind_sub typ_top ++ E2))...
    * get_well_form. constructor...
      { apply subst_tt_wf...
        - apply WF_narrowing_env_subst... add_nil.
          apply WF_weakening...
        - apply WF_narrowing_env_subst...
      }
      { apply subst_tt_wf...
        - apply WF_narrowing_env_subst... add_nil.
          apply WF_weakening...
        - apply WF_narrowing_env_subst...
      }
      { apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
        add_nil. apply WF_weakening... }
      { apply subst_tt_collect with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)... }
    * get_well_form. constructor...
      { apply subst_tt_wf...
        - apply WF_narrowing_env_subst... add_nil.
          apply WF_weakening...
        - apply WF_narrowing_env_subst...
      }
      { apply subst_tt_wf...
        - apply WF_narrowing_env_subst... add_nil.
          apply WF_weakening...
        - apply WF_narrowing_env_subst...
      }
      { apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
        add_nil. apply WF_weakening... }
      { apply subst_tt_collect with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)... }
    * intros. simpl in *.
      destruct (i == i0).
      { subst. inversion H8. inversion H9. subst... }
      { apply rcd_inversion with (A:=subst_tt X C T2) (B:=subst_tt X D T2) (i:=i0)...
        + apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
          add_nil. apply WF_weakening...
          get_well_form...
        + apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
          add_nil. apply WF_weakening...
          get_well_form...
      }
Qed.

Lemma equiv_sub_subst_refl_no_var: forall A X E1 E2 C D S,
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) A ->
    wf_env (E1 ++ X ~ bind_sub typ_top ++ E2) ->
    equiv E2 C D ->
    equiv E2 C S ->
    equiv E2 S D ->
    sub (map (subst_tb X S) E1 ++  E2) (subst_tt X C A) (subst_tt X D A).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  assert (type A) as Hq.
  get_type...
  apply type_to_rec in Hq.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent X.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction Hq;intros;simpl...
  -
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    get_well_form...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
  -
    destruct (X==X0);subst...
    +
      rewrite_env (nil ++ map (subst_tb X0 S) E1 ++ E2).
      apply Sub_weakening...
      apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
    +
      constructor...
      apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
      dependent destruction H.
      analyze_binds H...
      apply WF_var with (U:=subst_tt X0 S U)...
      unfold binds in *.
      apply In_lemmaL.
      apply binds_map_free...
      apply WF_var with (U:= U)...
  -
    dependent destruction H.
    constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H9.
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2 \u L0);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++  E2).
      apply subst_tb_wf3...
      apply WF_narrowing with (V:=typ_top)...
      apply H9...
      get_well_form...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++  E2).
      apply subst_tb_wf3...
      apply WF_narrowing with (V:=typ_top)...
      apply H9...
      get_well_form...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ E2).
      apply H0...
      apply H10...
      constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top) ++ E2);
          split;apply Sub_weakening...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub T1 ++ E1) ++  E2).
        apply H0...
        apply H8...
        constructor...
  -
    dependent destruction H.
    constructor...
  -
    apply Reflexivity... apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    get_well_form...
  -
    inversion H0;subst.
    apply sa_rcd...
    * apply wf_env_map_free2 with (B:=bind_sub typ_top)... get_well_form...
    * simpl. intro x. intros.
      apply union_iff in H8. destruct H8...
      apply subst_tt_collect3 with (E:=(E1 ++ X ~ bind_sub typ_top ++ E2)) in H8 ...
      apply union_iff. right.
      apply subst_tt_collect2 with (E:=(E1 ++ X ~ bind_sub typ_top ++ E2))...
    * get_well_form. constructor...
      { apply subst_tb_wf3... apply WF_narrowing with (V:=typ_top)... }
      { apply subst_tb_wf3... apply WF_narrowing with (V:=typ_top)... }
      { apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
        apply WF_weakening... add_nil. apply WF_weakening... }
      { apply subst_tt_collect with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)... }
    * get_well_form. constructor...
      { apply subst_tb_wf3... apply WF_narrowing with (V:=typ_top)... }
      { apply subst_tb_wf3... apply WF_narrowing with (V:=typ_top)... }
      { apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
        apply WF_weakening... add_nil. apply WF_weakening... }
      { apply subst_tt_collect with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)... }
    * intros. simpl in *.
      destruct (i == i0).
      { subst. inversion H8. inversion H9. subst... }
      { apply rcd_inversion with (A:=subst_tt X C T2) (B:=subst_tt X D T2) (i:=i0)...
        + apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
          apply WF_weakening. add_nil. apply WF_weakening.
          get_well_form...
        + apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
          apply WF_weakening. add_nil. apply WF_weakening.
          get_well_form...
      }
Qed.

Lemma equiv_sub_subst_not_var: forall A B X E1 E2 C D S,
    sub (E1 ++ X ~ bind_sub typ_top ++ E2) A B ->
    equiv E2 C D ->
    equiv E2 C S ->
    equiv E2 S D ->
    sub (map (subst_tb X S) E1 ++ E2) (subst_tt X C A) (subst_tt X D B).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction H;intros;simpl...
  -
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    get_well_form...
  -
    destruct (X0==X);subst...
    +
      rewrite_env (nil ++ map (subst_tb X S) E1 ++ E2).
      apply Sub_weakening...
      apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
    +
      constructor...
      *
        apply wf_env_map_free2 with (B:=bind_sub typ_top)...
        get_well_form...
      *
        dependent destruction H0.
        analyze_binds H0...
        apply WF_var with (U:=subst_tt X S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free...
        apply WF_var with (U:= U)...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    apply subst_tb_wf3...
    apply WF_narrowing with (V:=typ_top)...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...
      dependent destruction BindsTacVal.
      dependent destruction H0.
      * simpl...
        constructor...
        apply wf_env_map_free2 with (B:=bind_sub typ_top)...
        get_well_form...
        get_well_form.
        rewrite_env (nil ++ map (subst_tb X S) E1 ++  E2).
        apply WF_weakening...
      * inversion H0.
    +
      apply sa_trans_tvar with (U:=subst_tt X S U)...
      *
        apply binds_map_free_sub with (Q:=typ_top)...
        get_well_form...
      *
        apply IHsub...
        get_well_form.
        apply Reflexivity...
        get_well_form.
        apply Reflexivity...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_all with (L:=L \u {{X}});intros...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl_no_var;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub S2 ++ E1) ++ E2).
        apply H2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ E2).
      apply subst_tb_wf3...
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub S ++ E2).
      apply WF_narrowing with (V:=typ_top)...
      apply H...
      get_well_form...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ E2).
      apply subst_tb_wf3...
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub S ++ E2).
      apply WF_narrowing with (V:=typ_top)...
      apply H0...
      get_well_form...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++  E2).
      apply H2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_rcd...
    + apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
    + apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
      apply WF_weakening. add_nil. apply WF_weakening. get_well_form...
    + apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
      apply WF_weakening. add_nil. apply WF_weakening. get_well_form...
    + simpl. intro x. intros.
      apply subst_tt_collect3 with (E:=(E1 ++ X ~ bind_sub typ_top ++ E2)) in H15...
      apply subst_tt_collect2 with (E:=(E1 ++ X ~ bind_sub typ_top ++ E2))...
    + apply subst_tb_wf3... apply WF_narrowing with (V:=typ_top)...
      get_well_form...
    + apply subst_tb_wf3... apply WF_narrowing with (V:=typ_top)...
      get_well_form...
    + intros.
      apply Tlookup_subst with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)in H15...
      apply Tlookup_subst with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)in H16...
      destruct H15 as [t1'], H16 as [t2']. destruct_hypos.
      subst t1 t2.
      apply H6 with (i:=i)...
Qed.
(* different proof for rcd from above *)

Lemma equiv_sub_subst: forall A B X E1 E2 C D S,
    sub (E1 ++ X ~ bind_sub typ_top ++ E2) A B ->
    equiv (X ~ bind_sub typ_top ++ E2) C D ->
    equiv (X ~ bind_sub typ_top ++ E2) C S ->
    equiv (X ~ bind_sub typ_top ++ E2) S D ->
    sub (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2) (subst_tt X C A) (subst_tt X D B).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction H;intros;simpl...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    destruct (X0==X);subst...
    +
      rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply Sub_weakening...
      apply wf_env_map_free...
      get_well_form...
    +
      constructor...
      *
        apply wf_env_map_free...
        get_well_form...
      *
        dependent destruction H0.
        analyze_binds H0...
        apply WF_var with (U:=subst_tt X S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free...
        apply WF_var with (U:= U)...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free...
    apply subst_tt_wf...
    rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
    apply WF_weakening...
    apply WF_narrowing_env_subst...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...
      inversion BindsTacVal.
      subst.
      dependent destruction H0.
      * simpl...
        constructor...
        apply wf_env_map_free...
        get_well_form...
        get_well_form.
        rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
        apply WF_weakening...
      * inversion H0.
    +
      apply sa_trans_tvar with (U:=subst_tt X S U)...
      *
        apply binds_map_free_env...
        get_well_form...
      *
        apply IHsub...
        get_well_form.
        apply Reflexivity...
        get_well_form.
        apply Reflexivity...
  -
    constructor...
    apply IHsub1...
    apply IHsub2...
  -
    apply sa_all with (L:=L \u {{X}});intros...
    +
      apply IHsub1...
    +
      apply IHsub2...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub S2 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wf...
      rewrite_env (nil ++ (X0 ~ bind_sub typ_top ++ map (subst_tb X S) E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_weakening...
      get_well_form...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_narrowing_env_subst...
      apply H...
      specialize_x_and_L X0 L.
      get_well_form...
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wf...
      rewrite_env (nil ++ (X0 ~ bind_sub typ_top ++ map (subst_tb X S) E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_weakening...
      get_well_form...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_narrowing_env_subst...
      apply H0...
      specialize_x_and_L X0 L.
      get_well_form...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++ (X, bind_sub typ_top) :: E2).
      apply H2...
  -
    constructor...
    apply IHsub...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    rewrite_env  (map (subst_tb X S) E1 ++ (X ~ bind_sub typ_top) ++ E2).
    apply sa_rcd...
    + apply wf_env_map_free with (B:=bind_sub typ_top)...
      get_well_form...
    + apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
      add_nil. apply WF_weakening. get_well_form...
    + apply subst_tt_rt_type with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)...
      add_nil. apply WF_weakening. get_well_form...
    + simpl. intro x. intros.
      apply subst_tt_collect3 with (E:=(E1 ++ X ~ bind_sub typ_top ++ E2)) in H15...
      apply subst_tt_collect2 with (E:=(E1 ++ X ~ bind_sub typ_top ++ E2))...
    + apply subst_tt_wf...
      { apply WF_narrowing_env_subst... add_nil.
        apply WF_weakening. get_well_form... }
      { apply WF_narrowing_env_subst... }
    + apply subst_tt_wf...
      { apply WF_narrowing_env_subst... add_nil.
        apply WF_weakening. get_well_form... }
      { apply WF_narrowing_env_subst... }
    + intros.
      apply Tlookup_subst with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)in H15...
      apply Tlookup_subst with (E:=E1 ++ X ~ bind_sub typ_top ++ E2)in H16...
      destruct H15 as [t1'], H16 as [t2']. destruct_hypos.
      subst t1 t2.
      apply H6 with (i:=i)...
Qed.

Lemma equiv_unfolding: forall E C D X,
    equiv E (typ_mu C) (typ_mu D) ->
    X \notin fv_tt C \u fv_tt D \u dom E ->
    equiv (X~bind_sub typ_top ++ E) (typ_label X (open_tt C X)) (typ_label X (open_tt D X)).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  dependent destruction H.
  -
    dependent destruction H2.
    +
      split.
      constructor...
      pick fresh Y.
      apply sub_replacing_var with (X:=Y)...
      apply sub_nominal_inversion...
      constructor...
      specialize_x_and_L Y L.
      get_well_form...
      dependent destruction H1...
      constructor...
      pick fresh Y.
      apply sub_replacing_var with (X:=Y)...
      apply sub_nominal_inversion...
      constructor...
      specialize_x_and_L Y L.
      get_well_form...
      dependent destruction H1...
    + inversion H3.
  - inversion H0.
Qed.

Lemma equiv_reflexivity: forall E C,
    wf_env E ->
    WF E C ->
    equiv E C C.
Proof with auto.
  intros.
  unfold equiv;split;apply Reflexivity...
Qed.

Lemma equiv_sub_unfolding: forall C D Y E,
      sub (Y ~ bind_sub typ_top ++ E) (open_tt C Y) (open_tt D Y) ->
      sub (Y ~ bind_sub typ_top ++ E) (open_tt D Y) (open_tt C Y) ->
      Y \notin fv_tt C \u fv_tt D \u fl_tt C \u fl_tt D \u dom E \u fl_env E->
      sub E (typ_mu C) (typ_mu D).
Proof with auto.
  intros.
  apply sa_rec with (L:=dom E \u {{Y}} \u fv_tt C \u fv_tt D \u fl_tt C \u fl_tt D);intros.
  -
    get_well_form.
    apply WF_replacing_var with (X:=Y)...
  -
    get_well_form.
    apply WF_replacing_var with (X:=Y)...
  -
    apply sub_renaming_unfolding with (X:=Y)...
    +
      rewrite subst_tt_intro with (X:=Y)...
      remember (subst_tt Y (typ_label Y (open_tt C Y)) (open_tt C Y)).
      rewrite subst_tt_intro with (X:=Y)...
      rewrite_env (map (subst_tb Y (typ_label Y (open_tt C Y))) nil ++ Y ~ bind_sub typ_top ++ E).
      subst.
      apply equiv_sub_subst...
      unfold equiv;split...
      get_well_form.
      unfold equiv;split;apply Reflexivity...
      unfold equiv;split...
    +
      constructor...
      get_well_form...
      dependent destruction H...
Qed.


Require Import Raft.
Require Import RaftRefinementInterface.

Section LeaderLogsPreserved.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition leaderLogs_preserved (net : network) : Prop :=
    forall h ll t' h' ll' e e',
      In (eTerm e, ll) (leaderLogs (fst (nwState net h))) ->
      In (t', ll') (leaderLogs (fst (nwState net h'))) ->
      In e ll' ->
      In e' ll ->
      In e' ll'.

  Class leaderLogs_preserved_interface : Prop :=
    {
      leaderLogs_preserved_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          leaderLogs_preserved net
    }.
End LeaderLogsPreserved.


Require Import Relations.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Structures.Proper.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Structures.FunctorRelations.
Require Import ExtLib.Structures.MonadLaws.

Set Implicit Arguments.
Set Strict Implicit.

Section stuff.

  Variable m : Type -> Type.
  Variable Monad_m : Monad m.
  Variable mleq : forall T, (T -> T -> Prop) -> m T -> m T -> Prop.
  Variable mproper : forall T (rT : relation T), Proper rT -> Proper (mleq rT).
  Variable FunctorOrder_mleq : FunctorOrder m mleq mproper.
  Variable MonadLaws_mleq : MonadLaws Monad_m mleq mproper.

  Definition compose (A B C : Type) (f : A -> B) (g : B -> C) : A -> C :=
    fun x => g (f x).

  Definition pure (T : Type) : T -> m T := @ret _ _ _.
  Definition fapply (T U : Type) (f : m (T -> U)) (x : m T) : m U :=
    bind f (fun f => bind x (fun x => ret (f x))).

  Existing Instance fun_trans.
  Existing Instance fun_refl.

  Variables A B C : Type.
  Context (rA : relation A) (rB : relation B) (rC : relation C)
          (pA : Proper rA) (pB : Proper rB) (pC : Proper rC).
  Context (Ra : PReflexive rA) (Rb : PReflexive rB) (Rc : PReflexive rC).
  Context (Ta : PTransitive rA) (Tb : PTransitive rB) (Tc : PTransitive rC).

  Instance fun_app_proper (A B : Type) (rA : relation A) (rB : relation B) (pA : Proper rA) (pB : Proper rB) (f : A -> B) x :
    proper f -> proper x ->
    proper (f x).
  Proof.
    intros. apply H. auto.
  Qed.

  Instance fun_abs (A B : Type) (rA : relation A) (rB : relation B) (pA : Proper rA) (pB : Proper rB) (f : A -> B) :
    (forall x, proper x -> proper (f x)) ->
    (forall x y, proper x -> proper y -> rA x y -> rB (f x) (f y)) ->
    proper (fun x => f x).
  Proof.
    intros. split; auto; eapply H.
  Qed.

  Ltac prove_proper x k :=
    match x with
      | _ => match goal with
               | [ H : proper x |- _ ] => k H
             end
      | bind ?A ?B =>
        prove_proper A ltac:(fun a => prove_proper B ltac:(fun b =>
          let H := fresh in
            assert (H : proper x); [ eapply bind_proper; eauto with typeclass_instances | k H ]))
      | ret ?A =>
        prove_proper A ltac:(fun a =>
          let H := fresh in
            assert (H : proper x); [ eapply ret_proper; eauto with typeclass_instances | k H ])
      | (fun x => _) =>
        let H := fresh in
        assert (H : proper x); [ eapply fun_abs; intros; [ propers | repeat red; intros; prove_mleq ] | k H ]
      | _ =>
        let H := fresh in
          assert (H : proper x); [ eauto with typeclass_instances | k H ]
    end
  with prove_mleq :=
    try match goal with
          | |- proper (fun x => _) =>
            eapply fun_abs; intros; [ propers | repeat red; intros; prove_mleq ]
          | [ R : _ , H' : pfun_ext ?R _ ?F ?G |- ?R (?F _) (?G _) ] =>
            eapply H'; [ propers | propers | prove_mleq ]
          | [ H' : proper ?F |- ?R (?F _) (?F _) ] =>
            eapply H'; [ propers | propers | try assumption; prove_mleq ]
          | [ |- mleq _ (bind _ _) (bind _ _) ] =>
            eapply bind_respectful_leq; [ eauto with typeclass_instances | eauto with typeclass_instances | prove_mleq | intros; prove_mleq ]
          | [ |- mleq _ (ret _) (ret _) ] =>
            eapply ret_respectful_leq; [ eauto with typeclass_instances | eauto with typeclass_instances | prove_mleq ]
          | [ H : proper ?f |- pfun_ext _ _ ?f ?f ] => apply H
          | [ H : proper ?f |- pfun_ext _ _ (fun x => _) (fun y => _) ] => red; intros; prove_mleq
          | _ => eassumption
        end
  with propers :=
    match goal with
      | |- proper ?X => prove_proper X ltac:(fun x => eapply x)
      | |- mleq _ ?X ?Y =>
        prove_proper X ltac:(fun x => prove_proper Y ltac:(fun x => idtac))
    end.

  Instance PReflexive_stuff : PReflexive
     (pfun_ext (pfun_ext (pfun_ext rC pA) (Proper_pfun pB pC))
        (Proper_pfun pA pB)).
  Proof. intuition. Qed.

  Theorem bind_law : forall (f : A -> B) (g : B -> C),
    proper f -> proper g ->
    mleq (pfun_ext rC pA)
         (fapply (fapply (pure (@compose A B C)) (pure f)) (pure g))
         (pure (compose f g)).
  Proof.
    unfold fapply, pure, compose; simpl; intros.
    propers.
    (eapply ptransitive; [ | | | | eapply (@bind_associativity _ _ _ _ MonadLaws_mleq) | ]); eauto with typeclass_instances; propers.
    (eapply ptransitive; [ | | | | eapply (@bind_of_return _ _ _ _ MonadLaws_mleq) | ]); eauto with typeclass_instances; propers.
    (eapply ptransitive; [ | | | | eapply (@bind_associativity _ _ _ _ MonadLaws_mleq) | ]); eauto with typeclass_instances; propers.
    (eapply ptransitive; [ | | | | eapply (@bind_of_return _ _ _ _ MonadLaws_mleq) | ]); eauto with typeclass_instances; propers.
    (eapply ptransitive; [ | | | | eapply (@bind_of_return _ _ _ _ MonadLaws_mleq) | ]); eauto with typeclass_instances; propers.
    (eapply ptransitive; [ | | | | eapply (@bind_of_return _ _ _ _ MonadLaws_mleq) | ]); eauto with typeclass_instances; propers.
    eapply preflexive; eauto with typeclass_instances.
  Qed.

End stuff.

Print Assumptions bind_law.