(** * The Null type constructor *)

Require Import Spreadable.

(** ** A leveled empty type *)
Inductive False : Prop := . (* Already in the Standard Library *)

(** ** The Null type constructor *)
Definition Null : TT := fun _ => False.

(** ** Null is spread-able *)
Definition SnullMap : Map Null := fun A B _ (H :False) => H.

Lemma SnullCngMap : MapCongruence SnullMap.
Proof. unfold MapCongruence. reflexivity. Defined.

Print SnullCngMap.

Lemma SnullCmpMap : MapComposition SnullMap.
Proof. unfold MapComposition, SnullMap. tauto. Defined.

Print SnullCmpMap.

Lemma SnullFold : Fold Null.
Proof. unfold Fold. tauto. Defined.

Print SnullFold.

Lemma SnullAny : TransPred Null.
Proof. unfold TransPred, Null. tauto. Defined.

Print SnullAny.

Lemma SnullDecAny : TransDec SnullAny.
Proof. unfold TransDec, Null, SnullAny, Dec. tauto. Defined.

Print SnullDecAny.

Lemma SnullDecEq : DecEq Null.
Proof. unfold DecEq, Null, Decidable. tauto. Defined.

Print SnullDecEq.

Definition SnullIn
:= fun A x => SnullAny A (fun y => x = y ) .

Lemma SnullIn_map : forall (A B : Type) (f : A -> B) l (x : A),
SnullIn _ x l -> SnullIn _ (f x) (SnullMap _ _ f l).
Proof.  simpl; compute; intros.  tauto. Defined.

Definition null_spreadable : SpreadAble Null :=
  mkSpread Null
    (mkFold Null SnullFold SnullFold)
    (mkMap Null SnullMap SnullCngMap SnullCmpMap)
    (mkAnyAll Null SnullAny SnullDecAny
              SnullAny SnullDecAny)
    (mkEq Null SnullDecEq). (* SnullIn_map. *)

Definition null_map         := map        _ (map_able _ null_spreadable).
Definition null_cng_map     := map_congru _ (map_able _ null_spreadable).
Definition null_cmp_map     := map_compo  _ (map_able _ null_spreadable).
Definition null_foldr       := foldr      _ (fold_able _ null_spreadable).
Definition null_foldl       := foldl      _ (fold_able _ null_spreadable).
(** ** A size of Null can be defined, but can never be called
       However, it is useful in the definition of Maybe *)
Definition null_size        := size        _ (fold_able _ null_spreadable).
Definition null_flatten     := flatten     _ (fold_able _ null_spreadable).
(* Definition null_show        := show        _ (fold_able _ null_spreadable). *)
Definition null_any         := any         _ (any_all_able _ null_spreadable).
Definition null_dec_any     := dec_any     _ (any_all_able _ null_spreadable).
Definition null_all         := all         _ (any_all_able _ null_spreadable).
Definition null_dec_all     := dec_all     _ (any_all_able _ null_spreadable).
Definition null_in_prop     := in_prop     _ (any_all_able _ null_spreadable).
Definition null_empty       := empty       _ (any_all_able _ null_spreadable).
Definition null_dec_in_prop := dec_in_prop _ (any_all_able _ null_spreadable).
Definition null_dec_eq      := dec_eq      _ (eq_able _ null_spreadable).


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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv0 lv1)).
Admitted.
QuickChick conj14eqsynthconj5.


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.