Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.

Require Import Cava.Expr.
Require Import Cava.ExprProperties.
Require Import Cava.Invariant.
Require Import Cava.Primitives.
Require Import Cava.Semantics.
Require Import Cava.TLUL.
Require Import Cava.Types.
Require Import Cava.Util.BitArithmetic.
Require Import Cava.Util.List.
Require Import Cava.Util.Tactics.

Require Import coqutil.Tactics.Simp.
Require Import coqutil.Tactics.Tactics.

Import ListNotations.

Section Var.
  Import Expr.
  Import ExprNotations.
  Import PrimitiveNotations.

  Local Open Scope N.

  Context {var : tvar}.

  Definition incr_state := BitVec 2.
  Definition Idle       := Constant incr_state 0.
  Definition Busy1      := Constant incr_state 1.
  Definition Busy2      := Constant incr_state 2.
  Definition Done       := Constant incr_state 3.

  Definition inner
    : Circuit _ [Bit; BitVec 32] (Bit ** BitVec 32)
    := {{
      fun valid data =>
        let/delay '(istate; value) :=
           let istate' :=
               if istate == `Busy1` then `Busy2`
               else if istate == `Busy2` then `Done`
                    else if istate == `Done` then `Idle`
                         else (* istate == `Idle` *)
                           if valid then `Busy1`
                           else `Idle` in

           let value' :=
               if istate == `Busy2` then value + `K 1`
               else if istate == `Idle` then data
                    else value in

           (istate', value')
             initially default
           : denote_type (incr_state ** BitVec 32)
        in
        (istate == `Done`, value)
       }}.

  Definition incr
    : Circuit _ [tl_h2d_t] tl_d2h_t
    := {{
      fun tl_h2d =>
        (* Destruct and reassemble tl_h2d with a_address that matches the
           tlul_adapter_reg interface. *)
        let '(a_valid
              , a_opcode
              , a_param
              , a_size
              , a_source
              , a_address
              , a_mask
              , a_data
              , a_user
              ; d_ready) := tl_h2d in
        (* Bit #2 of the address determines which register is being accessed *)
        (*    (STATUS or VALUE). Zero out the other bits. *)
        let a_address := a_address & (`K 1` << 2) in
        let tl_h2d := (a_valid
                       , a_opcode
                       , a_param
                       , a_size
                       , a_source
                       , a_address
                       , a_mask
                       , a_data
                       , a_user
                       , d_ready) in

        let/delay '(busy, done, registers; tl_d2h) :=
           let '(tl_d2h'; req) := `tlul_adapter_reg` tl_h2d registers in
           let '(is_read, is_write, address, write_data; _write_mask) := req in

           let '(inner_res_valid; inner_res) := `inner` (!busy && !done && is_write) write_data in

           let busy' :=
               if busy then !inner_res_valid
               else !done && is_write in

           let done' :=
               if busy then inner_res_valid
               else if done then !(is_read && address == `K 0`)
                    else done in

           let registers' :=
               if inner_res_valid then `replace` registers `K (sz:=1) 0` inner_res
               else registers in

           let registers' :=
               if busy' then `replace` registers' `K (sz:=1) 1` `K 2`
               else if done' then `replace` registers' `K (sz:=1) 1` `K 4`
                    else `replace` registers' `K (sz:=1) 1` `K 1` in

           (busy', done', registers', tl_d2h') initially
           (false, (false, ([0; 1], set_a_ready true (default (t:=tl_d2h_t)))))
           : denote_type (Bit ** Bit ** Vec (BitVec 32) 2 ** tl_d2h_t)
        in

        tl_d2h
       }}.
End Var.

Definition sim {s i o} (c : Circuit s i o) (input : list (denote_type i))
  : list (denote_type s * denote_type i * denote_type o) :=
  fst (List.fold_left (fun '(acc, s) i =>
                         let '(s', o) := step c s i in
                         (acc ++ [(s, i, o)], s'))
                      input
                      ([], reset_state c)).

Example sample_trace :=
  Eval compute in
    let nop := set_d_ready true tl_h2d_default in
    let read_reg (r : N) :=
        set_a_valid true
        (set_a_opcode Get
        (set_a_size 2%N
        (set_a_address r
        (set_d_ready true tl_h2d_default)))) in
    let write_val (v : N) :=
        set_a_valid true
        (set_a_opcode PutFullData
        (set_a_size 2%N
        (set_a_address 0%N (* value-ref *)
        (set_a_data v
        (set_d_ready true tl_h2d_default))))) in

    sim incr
        [ (nop, tt)
          ; (read_reg 4, tt) (* status *)
          ; (nop, tt)
          ; (write_val 42, tt)
          ; (nop, tt)
          ; (nop, tt)
          ; (read_reg 4, tt) (* status *)
          ; (nop, tt)
          ; (read_reg 0, tt) (* value *)
          ; (nop, tt)
          ; (read_reg 4, tt) (* status *)
        ]%N.
(* Print sample_trace. *)

Section Spec.
  Local Open Scope N.

  Variant repr_state :=
  | ReprIdle
  | ReprBusy (data : N) (count : nat)
  | ReprDone (res : N).

  Notation inner_repr := repr_state.

  Global Instance inner_invariant : invariant_for inner inner_repr :=
    fun (state : denote_type (state_of inner)) repr =>
      let '(istate, value) := state in
      match repr with
      | ReprIdle => istate = 0
      | ReprBusy data c => (0 < c <= 2)%nat /\ istate = N.of_nat c /\ value = data
      | ReprDone res => istate = 3 /\ value = res
      end.

  Definition inner_spec_step (input : denote_type (input_of inner)) repr :=
    let '(valid, (data, tt)) := input in
    match repr with
    | ReprIdle => if valid then ReprBusy data 1 else ReprIdle
    | ReprBusy data 2 => ReprDone ((data + 1) mod 2^32)
    | ReprBusy data c => ReprBusy data (c + 1)
    | ReprDone _ => ReprIdle
    end.

  Instance inner_specification
    : specification_for inner inner_repr :=
    {| reset_repr := ReprIdle;

       update_repr :=
         fun (input : denote_type (input_of inner)) repr =>
           inner_spec_step input repr;

       precondition :=
         fun (input : denote_type (input_of inner)) repr => True;

       postcondition :=
         fun (input : denote_type (input_of inner)) repr
           (output : denote_type (output_of inner)) =>
           let repr' := inner_spec_step input repr in
           match repr' with
           | ReprDone res => output = (true, res)
           | _ => exists res, output = (false, res)
           end;
    |}.

  Lemma inner_invariant_at_reset : invariant_at_reset inner.
  Proof.
    simplify_invariant inner. reflexivity.
  Qed.

  Lemma inner_invariant_preserved : invariant_preserved inner.
  Proof.
    intros (valid, (data, t)) state repr. destruct t.
    cbn in * |-. destruct state as (istate, value).
    intros repr' ? Hinvar Hprec; subst.
    simplify_invariant inner.
    simplify_spec inner.
    cbv [inner inner_spec_step]. stepsimpl.
    repeat (destruct_pair_let; cbn [fst snd]).
    destruct repr as [|? iiscount|?]; logical_simplify; subst.
    - destruct valid; cbn; ssplit; lia.
    - destruct iiscount as [|[|[|iiscount]]]; cbn; ssplit; lia.
    - reflexivity.
  Qed.

  Lemma inner_output_correct : output_correct inner.
  Proof.
    intros (valid, (data, t)) state repr. destruct t.
    cbn in * |-. destruct state as (istate, value).
    remember (update_repr (c:=inner) (valid, (data, tt)) repr) as repr'.
    intros Hinvar Hprec.
    simplify_invariant inner.
    simplify_spec inner.
    cbv [inner inner_spec_step]. stepsimpl.
    repeat (destruct_pair_let; cbn [fst snd]).
    destruct repr as [|? iiscount|?]; logical_simplify; subst.
    - destruct valid; eexists; cbn; ssplit; reflexivity.
    - destruct iiscount as [|[|[|iiscount]]]; try lia; eexists; reflexivity.
    - eexists. reflexivity.
  Qed.

  Existing Instances inner_invariant_at_reset inner_invariant_preserved
           inner_output_correct.
  Global Instance inner_correctness : correctness_for inner.
  Proof. constructor; typeclasses eauto. Defined.

  Definition repr := (repr_state * list N * TLUL.repr_state * inner_repr)%type.

  Global Instance incr_invariant : invariant_for incr repr :=
    fun (state : denote_type (state_of incr)) repr =>
      let '((s_busy, (s_done, (s_regs, s_d2h))), (s_tlul, s_inner)) := state in
      let '(r_state, r_regs, r_tl, r_inner) := repr in
      tlul_invariant (reg_count:=2) s_tlul r_tl
      /\ match r_tl with
        | TLUL.Idle =>
          d_valid    s_d2h = false
          /\ d_error  s_d2h = false
          /\ a_ready  s_d2h = true
        | TLUL.OutstandingAccessAckData h2d regs =>
          d_valid    s_d2h = true
          /\ d_opcode s_d2h = AccessAckData
          /\ d_param  s_d2h = 0
          /\ d_size   s_d2h = (a_size h2d)
          /\ d_source s_d2h = (a_source h2d)
          /\ d_sink   s_d2h = 0
          /\ d_data   s_d2h = (List.nth (N.to_nat ((((a_address h2d) / 4) mod (2 ^ 30)))) regs 0%N)
          /\ d_user   s_d2h = 0
          /\ d_error  s_d2h = false
          /\ a_ready  s_d2h = false
        | TLUL.OutstandingAccessAck h2d  =>
          d_valid    s_d2h = true
          /\ d_opcode s_d2h = AccessAck
          /\ d_param  s_d2h = 0
          (* /\ d_size   s_d2h =  *)
          /\ d_source s_d2h = (a_source h2d)
          /\ d_sink   s_d2h = 0
          /\ d_user   s_d2h = 0
          /\ d_error  s_d2h = false
          /\ a_ready  s_d2h = false
        end
      /\ inner_invariant s_inner r_inner
      /\ match r_state with
        | ReprIdle => s_busy = false /\ s_done = false
                     /\ r_inner = ReprIdle
                     /\ nth 1 r_regs 0%N = 1
        | ReprBusy data count => s_busy = true /\ s_done = false
                                /\ r_inner = ReprBusy data count
                                /\ nth 1 r_regs 0%N = 2
        | ReprDone res => s_busy = false /\ s_done = true
                         /\ (r_inner = ReprDone res \/ r_inner = ReprIdle)
                         /\ nth 0 r_regs 0%N = res
                         /\ nth 1 r_regs 0%N = 4
        end
      /\ s_regs = r_regs
      /\ length r_regs = 2%nat.

  Existing Instance tl_specification.

  Instance incr_specification
    : specification_for incr repr :=
    {| reset_repr := (ReprIdle, [0; 1], TLUL.Idle, ReprIdle);

       update_repr :=
         fun (input : denote_type (input_of incr)) repr =>
           let '(i_h2d, tt) := input in
           let '(r_state, r_regs, r_tl, r_inner) := repr in

           let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in

           let r_tl' :=
               let tlul_input := (h2d, (r_regs, tt)) in
               update_repr (c:=tlul_adapter_reg (reg_count:=2))
                           tlul_input r_tl in

           (* compute (some) tlul output *)
           let '(is_read, is_write, address, write_data) :=
               match r_tl' with
               | TLUL.Idle => (false, false, 0, 0)
               | TLUL.OutstandingAccessAckData _ _ =>
                 match r_tl with
                   | TLUL.Idle => (a_valid h2d, false, a_address h2d, 0)
                   | _ => (false, false, 0, 0)
                 end
               | TLUL.OutstandingAccessAck _ =>
                 match r_tl with
                 | TLUL.Idle => (false, a_valid h2d, a_address h2d, a_data h2d)
                 | _ => (false, false, 0, 0)
                 end
               end in

           let r_inner' :=
               let inner_input := (match r_state with ReprIdle => is_write | _ => false end,
                                   (write_data, tt)) in
               update_repr (c:=inner) inner_input r_inner in

           let r_state' :=
               match r_state with
               | ReprDone _ =>
                   if (is_read && (address =? 0))%bool then ReprIdle
                   else r_state
               | _ =>
                 match r_inner' with
                 | ReprBusy data count => ReprBusy data count
                 | ReprDone res => ReprDone res
                 | _ => r_state
                 end
               end in

           let r_regs' :=
               match r_inner' with
               | ReprDone res => replace 0 res r_regs
               | _ => r_regs
               end in

           let r_regs' :=
               match r_state' with
               | ReprIdle => replace 1 1 r_regs'
               | ReprBusy _ _ => replace 1 2 r_regs'
               | ReprDone _ => replace 1 4 r_regs'
               end in

           (r_state', r_regs', r_tl', r_inner');

       precondition :=
         fun (input : denote_type (input_of incr)) repr =>
           let '(i_h2d, tt) := input in
           let '(r_state, r_regs, r_tl, r_inner) := repr in

           let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in

           let tlul_input := (h2d, (r_regs, tt)) in

           let prec_tlul :=
               precondition (tlul_adapter_reg (reg_count:=2))
                            tlul_input r_tl in

           let prec_inner :=
               forall d2h is_read is_write address write_data write_mask,
                 postcondition (tlul_adapter_reg (reg_count:=2))
                               tlul_input r_tl
                               (d2h, (is_read, (is_write, (address, (write_data, write_mask)))))
                 -> precondition inner (match r_state with ReprIdle => is_write | _ => false end,
                                       (write_data, tt)) r_inner in

           prec_tlul /\ prec_inner;

       postcondition :=
         fun (input : denote_type (input_of incr)) repr
           (output : denote_type (output_of incr)) =>
           let '(i_h2d, tt) := input in
           let '(r_state, r_regs, r_tl, r_inner) := repr in
           let h2d := set_a_address (N.land (a_address i_h2d) 4) i_h2d in

           (* let postc_tlul := *)
           (*     let tlul_input := (h2d, (r_regs, tt)) in *)
           (*     exists req, *)
           (*       postcondition (tlul_adapter_reg (reg_count:=2)) *)
           (*                     tlul_input r_tl *)
           (*                     (output, req) in *)
           (* postc_tlul; *)
           True;
    |}.

  Lemma incr_invariant_at_reset : invariant_at_reset incr.
  Proof.
    simplify_invariant incr.
    cbn. ssplit; [apply (tlul_adapter_reg_invariant_at_reset (reg_count:=2))
                 |reflexivity..].
  Qed.

  Existing Instance tlul_adapter_reg_correctness.

  Lemma incr_invariant_preserved : invariant_preserved incr.
  Proof.
    intros (h2d, t) state (((r_state, r_regs), r_tl), r_inner). destruct t.
    cbn in * |-. destruct state as ((busy, (done, (registers, d2h))), (tl_st, inner_st)).
    destruct_tl_h2d. destruct_tl_d2h.
    intros repr' ? Hinvar Hprec; subst.
    simplify_invariant incr. logical_simplify. subst.
    simplify_spec incr. logical_simplify. subst.
    (* destruct Hprec as [regs Hprec]. *)
    match goal with
    | |- context [step incr ?s ?i] =>
      remember (step incr s i) as step eqn:Estep;
        cbv -[Semantics.step inner tlul_adapter_reg] in Estep;
          subst
    end.
    stepsimpl.
    use_correctness.
    clear H5.
    rename H9 into Hpostc_tl.
    repeat (destruct_pair_let; cbn [fst snd]).
    ssplit.
    - eapply tlul_adapter_reg_invariant_preserved.
      2: apply H.
      + reflexivity.
      + assumption.
    - pose (r_tl_:=r_tl); destruct r_tl; logical_simplify; subst.
      + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst.
        pose (r_state_:=r_state); destruct r_state; cbn in *; logical_simplify; subst;
          pose (a_valid_:=a_valid); (destruct a_valid;
                                     [ match goal with
                                       | H: true = true -> _ |- _ =>
                                         destruct H; [auto|subst..]
                                       end|]); cbn in *; logical_simplify; subst;
            ssplit; auto.
      + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst.
        pose (r_state_:=r_state); destruct r_state; cbn in *; logical_simplify; subst;
          pose (d_ready_:=d_ready); destruct d_ready; cbn in *; logical_simplify; subst;
            ssplit; auto.
      + destruct_tl_h2d; destruct_tl_d2h; tlsimpl; subst.
        pose (r_state_:=r_state); destruct r_state; cbn in *; logical_simplify; subst;
          pose (d_ready_:=d_ready); destruct d_ready; cbn in *; logical_simplify; subst;
            ssplit; reflexivity.
    - eapply inner_invariant_preserved.
      2: eassumption.
      + simpl in *.
        destruct r_inner; try reflexivity.
        destruct r_tl eqn:Houts; logical_simplify; subst.
        * destruct a_valid eqn:Hvalid; logical_simplify; subst.
          -- match goal with
             | H: true = true -> _ |- _ =>
               destruct H; try reflexivity; subst
             end; logical_simplify; subst;
               boolsimpl; destruct r_state; logical_simplify; subst;
                 cbn in Hpostc_tl |- *; logical_simplify; subst; reflexivity.
          -- boolsimpl; destruct r_state; reflexivity.

        * destruct d_ready; logical_simplify; subst;
            boolsimpl; destruct r_state; reflexivity.
        * destruct d_ready; logical_simplify; subst;
            boolsimpl; destruct r_state; reflexivity.
      + simplify_spec inner. auto.
    - destruct r_tl; destruct r_inner; destruct r_state; destruct inner_st;
        logical_simplify; subst; simplify_invariant inner; try discriminate.
      all: simplify_spec (tlul_adapter_reg (reg_count:=2)); logical_simplify; tlsimpl; subst.
      all: destruct a_valid; [destruct H3; subst|]; cbn in Hpostc_tl; logical_simplify; subst; cbn.
      all: eauto.
      all: destruct_tl_d2h; tlsimpl; subst.
      all: try (destruct (N.land a_address 4 =? 0) eqn:Haddr;
               ssplit; eauto;
               destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity).
      all: try (destruct count as [|[|[|]]]; [lia|..|lia]; cbn;
             ssplit; eauto;
             destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity).
      all: try (destruct H6; discriminate).
      all: try (destruct d_ready; logical_simplify; subst; cbn;
                  ssplit; eauto;
                  destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity).
    - destruct r_tl; destruct r_inner; destruct r_state; destruct inner_st;
        logical_simplify; subst.
      all: simplify_invariant inner.
      all: try discriminate.
      all: simplify_spec (tlul_adapter_reg (reg_count:=2)); logical_simplify; tlsimpl; subst.
      all: destruct a_valid; [destruct H3; subst|]; cbn in Hpostc_tl; logical_simplify; subst; cbn.
      all: eauto.
      all: try (destruct (N.land a_address 4 =? 0) eqn:Haddr;
               ssplit; eauto;
               destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity).
      all: try (destruct count as [|[|[|]]]; [lia|..|lia]; cbn;
             ssplit; eauto;
             destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity).
      all: try (destruct H6; discriminate).
      all: try (destruct d_ready; logical_simplify; subst; cbn;
                  ssplit; eauto;
                  destruct x0 as [|? [|]]; cbn in *; try discriminate; reflexivity).
    - repeat destruct_one_match; rewrite ! length_replace; assumption.
  Qed.

  Lemma incr_output_correct : output_correct incr.
  Proof.
    intros ? **.
    simplify_spec incr. destruct input. destruct d0. destruct r as [[[? ?] ?] ?].
    apply I.
  Qed.

  Existing Instances incr_invariant_at_reset incr_invariant_preserved
           incr_output_correct.
  Global Instance incr_correctness : correctness_for incr.
  Proof. constructor; typeclasses eauto. Defined.
End Spec.


Require Import compcert.lib.Maps.
Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcert.common.Globalenvs.

Require Import VST.msl.ageable.

Require Import VST.sepcomp.extspec.
Require Import VST.sepcomp.step_lemmas.

Require Import VST.veric.compcert_rmaps.
Require Import VST.veric.juicy_mem.

Definition pures_sub (phi phi' : rmap) :=
  forall adr,
  match resource_at phi adr with
    | PURE k pp => resource_at phi' adr
                 = PURE k (preds_fmap (approx (level phi')) (approx (level phi')) pp)
    | _ => True
  end.

Lemma pures_sub_trans phi1 phi2 phi3 :
  (level phi3 <= level phi2)%nat ->
  pures_sub phi1 phi2 ->
  pures_sub phi2 phi3 ->
  pures_sub phi1 phi3.
Proof.
  intros lev S1 S2. intros l; specialize (S1 l); specialize (S2 l).
  destruct (phi1 @ l); auto.
  rewrite S1 in S2. rewrite S2.
  f_equal.
  rewrite (compose_rewr (preds_fmap _ _)).
  rewrite preds_fmap_comp.
  rewrite approx_oo_approx'; auto.
  rewrite approx'_oo_approx; auto.
Qed.

Lemma pures_sub_refl phi : pures_sub phi phi.
Proof.
  intros l.
  destruct (phi @ l) eqn:E; auto; f_equal.
  pose proof E as E_.
  rewrite <-resource_at_approx, E_ in E. simpl in E.
  congruence.
Qed.

Definition pures_eq (phi phi' : rmap) :=
  pures_sub phi phi' /\
  (forall adr,
   match resource_at phi' adr with
    | PURE k pp' => exists pp, resource_at phi adr = PURE k pp
    | _ => True
  end).

Lemma pures_eq_refl phi : pures_eq phi phi.
Proof.
  split. apply pures_sub_refl. intros l; destruct (phi @ l); eauto.
Qed.

Lemma pures_eq_trans phi1 phi2 phi3 :
  level phi3 <= level phi2 ->
  pures_eq phi1 phi2 ->
  pures_eq phi2 phi3 ->
  pures_eq phi1 phi3.
Proof.
  intros lev [S1 E1] [S2 E2]; split. apply pures_sub_trans with phi2; auto.
  intros l; specialize (E1 l); specialize (E2 l).
  destruct (phi3 @ l); auto. destruct E2 as (pp, E2). rewrite E2 in E1; auto.
Qed.


(*
 * © 2020 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     SyntacticallySafe
     AdversaryUniverse

     ModelCheck.Commutation
     ModelCheck.ModelCheck
     ModelCheck.ProtocolFunctions
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.InvariantSearch
     ModelCheck.UniverseInversionLemmas
.

From protocols Require Import
     ShareSecretProtocolSymmetricEnc
.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

From Frap Require Import Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Import SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module ShareSecretProtocolSecureSS <: AutomatedSafeProtocolSS.

  Import ShareSecretSymmetricEncProtocol.

  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b := tt.
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start.

  Import Gen Tacs.

  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start real_univ_start : core.

  Lemma finitelyRuns : exists n, runningTimeMeasure ru0 n.
  Proof.
    autounfold; simpl.
    eexists.
    econstructor; simpl; find_runtime.

    Unshelve.
    all: exact 0.
  Qed.

  Lemma typechecks : syntactically_safe_U ru0.
  Proof.
    unfold syntactically_safe_U; intros.
    autounfold
    ; subst
    ; simpl in *.

    unfold compute_ids; simpl.

    focus_user; simpl
    ; try solve [ do 2 eexists; split
                  ; [ unshelve (repeat typechecks1)
                      ; match goal with
                        | [ |- bool ] => exact true
                        | [ |- list safe_typ ] => exact []
                        end
                    | repeat verify_context_soundness ] ].

    Unshelve.
    all : exact TyDontCare.
  Qed.

  Lemma summarizable : exists summaries, summarize_univ ru0 summaries.
  Proof.
    autounfold; unfold summarize_univ; simpl; intros.
    unshelve (
        eexists; intros; focus_user; simpl
        ; (exists useless_summary; split; [ build_summary |]; eauto using useless_summary_summarizes)
      ) ; exact $0.
  Qed.

  Lemma lameness : @lameAdv t__adv b (RealWorld.adversary ru0).
  Proof.
    unfold lameAdv; autounfold; simpl; eauto.
  Qed.

  Set Ltac Profiling.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @stepSS t__hon t__adv  |}
      (@noresends_inv t__hon t__adv).
  Proof.
    unfold invariantFor
    ; unfold Initial, Step
    ; intros
    ; simpl in *
    ; split_ors
    ; try contradiction
    ; subst.

    autounfold in H0
    ; unfold fold_left, fst, snd in *.

    time (
        repeat transition_system_step
      ).

    Unshelve.
    all: exact 0 || auto.
  Qed.

  Show Ltac Profile.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - focus_user; auto.
    - econstructor.
    - unfold AdversarySafety.keys_honest; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
          rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
          eauto;
          simpl in *;
          solve_concrete_perm_merges;
          solve_concrete_maps;
          solve_simple_maps;
          eauto.
  Qed.

End ShareSecretProtocolSecureSS.


Set Implicit Arguments.
(*Set Maximal Implicit Insertion.*)
(*Set Contextual Implicit.*)
(*Unset Strict Implicit.*)

Inductive Both t := Two : t -> t -> Both t.

Inductive MStack a : Type -> Type :=
  M0 : MStack a a
| MS : forall b, a -> a -> MStack (Both a) b -> MStack a b.

Set Maximal Implicit Insertion.
Implicit Arguments M0 [a].
Implicit Arguments MS [a b].
Unset Maximal Implicit Insertion.

Inductive Buffer a :=
  B0
| B1: a -> Buffer a
| B2: a -> a -> Buffer a.

Inductive Stuck a b :=
  Stack :  Buffer a -> Buffer a -> MStack (Both a) b -> Stuck a b.

Inductive Nest f a : Type -> Type :=
  Empty : Nest f a a
| Full : forall b c, f a b -> Nest f b c -> Nest f a c.

Set Maximal Implicit Insertion.
Implicit Arguments Empty [f a].
Implicit Arguments Full [f a b c].
Unset Maximal Implicit Insertion.

Inductive SE f a c :=
  NE : forall b, f a b -> Nest f b c -> SE f a c.

Set Maximal Implicit Insertion.
Implicit Arguments NE [f a b c].
Unset Maximal Implicit Insertion.

Definition StackStack := SE Stuck.

Definition ThreeStack := Nest StackStack.

Inductive SM a :=
  None
| Some : a -> SM a.

Set Maximal Implicit Insertion.
Implicit Arguments None [a].
Unset Maximal Implicit Insertion.

Inductive Deq a :=
 Deque : forall b c, MStack a b -> ThreeStack b c -> SM c -> Deq a.

Inductive Size := Small | Medium | Large.

Definition bufSize t (x:Buffer t) :=
  match x with
    | B0 => Small
    | B1 _ => Medium
    | B2 _ _ => Large
  end.

Definition sameSize x y :=
  match x,y with
    | Small,Small => true
    | Large,Large => true
    | _,_ => false
  end.

Definition nextSize x y :=
  match y with
    | Medium => x
    | _ => y
  end.

Definition SameSize x y :=
  match x,y with
    | Small,Small => True
    | Large,Large => True
    | _,_ => False
  end.

(*
Inductive BufsAltStart (xs ys:Size)
  : forall a b, ThreeStack a b -> Prop :=
    Stop : forall a, BufsAltStart xs ys (Empty _ a)
  | Bit : forall t (x y:Buffer t) s u (r:ThreeStack s u) z,
    ~(SameSize xs (bufSize x)) ->
    ~(SameSize ys (bufSize y)) ->
    BufsAltStart (nextSize xs (bufSize x))
                 (nextSize ys (bufSize y))
                 r ->
    BufsAltStart xs ys (Full _ (NE _ (Stack x y z) (Empty _ _)) r)
  | Go : forall t (x y:Buffer t) za (q:MStack (Both t) za) zb (z:Stuck za zb) zc (zs:Nest Stuck zb zc) zd (r:ThreeStack zc zd),
    ~(SameSize xs (bufSize x)) ->
    ~(SameSize ys (bufSize y)) ->
    BufsAltStart (nextSize xs (bufSize x))
                 (nextSize ys (bufSize y))
                 (Full _ (@NE Stuck za zc zb z zs) r) ->
    BufsAltStart xs ys (Full _ (NE _ (Stack x y q) (Full za z zs)) r).
*)

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

Inductive Top := Prefix | Suffix | Twofix.

Ltac crush := subst; (*unfold not;*) intros;
  simpl in *; auto; subst; simpl in *; auto; subst;
    match goal with
      | [H:True |- _] => clear H; crush
      | [H:~ False |- _] => clear H; crush
      | [H:?x = ?x |- _] => clear H; crush
      | [F:False |- _] => inversion F
      | [H:?x = ?x -> False |- _]
        => pose (H (@eq_refl _ x)); crush
      | [H:?x <> ?x |- _]
        => pose (H (@eq_refl _ x)); crush
      | [H:Some _ = ?x
        |- context[
          match ?x with
            | None => _
            | Some _ => _
          end]]
        => rewrite <- H; crush
      | [H:true = ?x
        |- context[if ?x then _ else _]]
        => rewrite <- H; crush
      | [H:false = ?x
        |- context[if ?x then _ else _]]
        => rewrite <- H; crush
      | [H:false = true |- _] => inversion H
      | [H:true = false |- _] => inversion H
      | [H: _ /\ _ |- _] => destruct H; crush
      | [|- _ /\ _ ] => split; crush
      | [H: _ \/ _ |- _] => destruct H; crush
      | [H: None = Some _ |- _] => inversion H
      | [H: Some _ = None |- _] => inversion H
      | [H: Some ?x = Some ?y |- _]
        => assert (x = y); inversion H; clear H; crush
      | [H: Suffix = Prefix |- _] => inversion H
      | [H: Prefix = Suffix |- _] => inversion H
      | [H : None = ?x,
         I : Some _ = ?x |- _]
        => rewrite <- I in H; crush
      | [H : Some _ = ?x,
         I : Some _ = ?x |- _]
        => rewrite <- I in H; inversion H
      | [H: Small = Medium |- _] => inversion H
      | [H: Large = Medium |- _] => inversion H
      | [H: Medium = Small |- _] => inversion H
      | [H: Medium = Large |- _] => inversion H
      | [H: Large = Small |- _] => inversion H
      | [H: Small = Large |- _] => inversion H
      | [|- Small <> Medium] => discriminate
      | [|- Small <> Large] => discriminate
      | [|- Large <> Medium] => discriminate
      | [|- Medium <> Large] => discriminate
      | [|- Medium <> Small] => discriminate
      | [|- Large <> Small] => discriminate
      | [|- Some _ <> None] => discriminate
      | [|- None <> Some _] => discriminate
      | [|- Some _ <> Some _] => discriminate; crush
      | [|- Some _ = Some _] => f_equal; crush
      | [|- pair _ _ = pair _ _] => f_equal; crush
      | [H: ~ True |- _] =>
        let J := fresh
          in pose (H I) as J; inversion J
      | [H:(?x,?y) = (?p,?q) |- _] =>
        inversion_clear H; crush
      | _ => idtac
    end.

Fixpoint bufsAltStart2 a b (m:Stuck a b) c d (n:Nest Stuck c d) (*d e (r:ThreeStack d e) *) (xs ys:Size) :=
  match m with
    | Stack x y _ =>
      let xs' := bufSize x in
        let ys' := bufSize y in
          match sameSize xs xs', sameSize ys ys' with
            | false,false =>
              let xs2 := nextSize xs xs' in
                let ys2 := nextSize ys ys' in
                  match n with
                    | Empty => Some (xs2,ys2)
                    | Full _ _ z zs => bufsAltStart2 z zs xs2 ys2
                  end
            | _,_ => None
          end
  end.

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

Ltac crush1 :=
  crush;
  match goal with
    | [_:context[
      match topCheck ?x ?y with
        | None => _
        | Some _ => _
      end] |- _]
      => cutThis (topCheck x y); desall
    | [_:context[
      match bufSize ?x with
        | Small => _
        | Medium => _
        | Large => _
      end] |- _]
      => cutThis x; desall
    | [|- context[
      match topCheck ?x ?y with
        | None => _
        | Some _ => _
      end]]
      => cutThis (topCheck x y); desall
    | [_:context[if nextTop1 ?x ?y then _ else _] |- _]
      => cutThis (nextTop1 x y); desall
    | [|- context[if nextTop1 ?x ?y then _ else _]]
      => cutThis (nextTop1 x y); desall
    | [|- context[if sameSize ?x ?y then _ else _]]
      => cutThis (sameSize x y); desall
    | [_: context[if sameSize ?x ?y then _ else _] |- _]
      => cutThis (sameSize x y); desall
    | [_:context[
      match top2' ?x ?y with
        | None => _
        | Some _ => _
      end] |- _]
      => cutThis (top2' x y); desall
    | [_:context[
      match top3 ?x ?y with
        | None => _
        | Some _ => _
      end] |- _]
      => cutThis (top3 x y); desall
    | [|- context[
      match top3 ?x ?y with
        | None => _
        | Some _ => _
      end]]
      => cutThis (top3 x y); desall
    | [ H:_ |- context[
      match ?x with
        | None => _
        | Some _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x in MStack _ _ return _ with
        | M0 => _
        | MS _ _ _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x in Nest _ _ _ return _ with
        | Empty => _
        | Full _ _ _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x with
        | NE _ _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x with
        | Stack _ _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_,
        _:context[
      match ?x with
        | Stack _ _ _ => _
      end] |- _] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x with
        | B0 => _
        | B1 _ => _
        | B2 _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x with
        | Prefix => _
        | Suffix => _
        | Twofix => _
      end]] => equate H x; cutThis x; desall
    | [ H:_,
        _:context[
      match ?x with
        | Prefix => _
        | Suffix => _
        | Twofix => _
      end] |- _] => equate H x; cutThis x; desall
    | [ H:_,
        _:context[
      match ?x with
        | B0 => _
        | B1 _ => _
        | B2 _ _ => _
      end] |- _] => equate H x; cutThis x; desall
    | [|- context[
      match bufsAltStart2 ?p ?q ?r ?s with
        | None => _
        | Some _ => _
      end]]
      => cutThis (bufsAltStart2 p q r s); desall
    | _ => idtac
  end.

Lemma medPreNone :
  forall
    C D (y:Nest Stuck C D)
    A B (x:Stuck A B) q p,
    None = bufsAltStart2 x y Medium p ->
    None = bufsAltStart2 x y q p.
Proof.
  induction y; crush.

  Ltac crush1 :=
    crush;
    match goal with
      | [|- None = match x with
                     | Stack _ _ _ => _

  destruct x; crush.
  destruct p; destruct q; destruct b0; destruct b; crush.
  destruct x; crush.
  destruct p; destruct q; destruct b0; destruct b1; crush.
Qed.
Hint Resolve medPreNone.

Lemma medPreSomeExt :
  forall
    C D (y:Nest Stuck C D)
    A B (x:Stuck A B) p n q,
    q <> Medium ->
    Some (Medium,n) <> bufsAltStart2 x y q p.
Proof.
  induction y; crush.
  destruct x; crush.
  destruct q; destruct b; crush;
    destruct p; destruct b0; crush.
  destruct x; crush.
  destruct q; destruct b0; crush;
    destruct p; destruct b1; crush;
      try (eapply IHy; eauto); crush.
Qed.
Hint Resolve medPreSomeExt.

Lemma medPreSomeMed :
  forall
    C D (y:Nest Stuck C D)
    A B (x:Stuck A B) p n q,
    Some (Medium,n) = bufsAltStart2 x y Medium p ->
    Some (q,n) = bufsAltStart2 x y q p.
Proof.
  induction y; crush.
  destruct x; crush.
  destruct p; destruct q; destruct b0; destruct b; crush.
  destruct x; crush.

  Ltac extMed :=
    crush;
    match goal with
      | [ H:Some (Medium,_) = bufsAltStart2 _ _ Small _ |- _]
        => assert False; apply medPreSomeExt in H; extMed
      | [ H:Some (Medium,_) = bufsAltStart2 _ _ Large _ |- _]
        => assert False; apply medPreSomeExt in H; extMed
      | _ => crush
    end.

  destruct p; destruct q; destruct b0; destruct b1; extMed.
Qed.
Hint Resolve medPreSomeMed.

Definition topCheck t (x y:Buffer t) :=
  match x,y with
    | B1 _, B1 _ => None
    | B0, B1 _ => Some Prefix
    | B2 _ _, B1 _ => Some Prefix
    | B1 _, B0 => Some Suffix
    | B1 _, B2 _ _ => Some Suffix
    | _,_ => Some Twofix
  end.

Definition top1 a b (z:Stuck a b) :=
  match z with
    | Stack x y _ => topCheck x y
  end.

Definition nextTop1 x y :=
  match x,y with
    | Prefix,Prefix => true
    | Suffix,Suffix => true
    | _,_ => false
  end.

Fixpoint top2' a b (x:Stuck a b) c d (yys:Nest Stuck c d) {struct yys} :=
  match yys with
    | Empty => top1 x
    | (Full _ _ y ys) =>
      match top1 x, top2' y ys with
        | Some v, Some w =>
          if nextTop1 v w
            then Some v
            else None
        | _,_ => None
      end
  end.

Lemma medPreSomeOth :
  forall
    C D (y:Nest Stuck C D)
    A B (x:Stuck A B) p n r,
    r <> Medium ->
    Some (r,n) = bufsAltStart2 x y Medium p ->
    ((Some (r,n) = bufsAltStart2 x y Small p
      /\ None = bufsAltStart2 x y Large p)
    \/ (Some (r,n) = bufsAltStart2 x y Large p
      /\ None = bufsAltStart2 x y Small p)).
Proof.
  induction y; crush.
  destruct x; crush.
  destruct b; crush; destruct p; destruct b0; crush.
  destruct x; crush.
  destruct p; destruct b1; crush;
    destruct b0; crush.
Qed.
Hint Resolve medPreSomeOth.

Lemma extPreSomeSame :
  forall
    C D (y:Nest Stuck C D)
    A B (x:Stuck A B) q p n,

    Some (q,n) = bufsAltStart2 x y q p ->
    (Some (Medium,n) = bufsAltStart2 x y Medium p \/
     Some (q,n) = bufsAltStart2 x y Medium p).
Proof.
  induction y; crush.
  destruct x; crush.
  destruct q; destruct b; crush; destruct p; destruct b0; crush.
  destruct x; crush.
  destruct q; destruct b0; crush; destruct p; destruct b1; crush.
Qed.
Hint Resolve extPreSomeSame.

Lemma extPreSomeMed :
  forall
    C D (y:Nest Stuck C D)
    A B (x:Stuck A B) q p,
    None <> bufsAltStart2 x y q p ->
    None <> bufsAltStart2 x y Medium p.
Proof.
  induction y; crush.
  destruct x; crush.
  destruct q; destruct b; crush; destruct p; destruct b0; crush.
  destruct x; crush.
  destruct q; destruct b0; crush; destruct p; destruct b1; crush;
    try (eapply IHy in H; eauto); crush.
Qed.
Hint Resolve extPreSomeMed.

Lemma extPreSomeSame2 :
  forall
    C D (y:Nest Stuck C D)
    A B (x:Stuck A B) q p n,
    q <> Medium ->
    Some (q,n) = bufsAltStart2 x y q p ->
    ((forall z, Some (z,n) = bufsAltStart2 x y z p)
      \/ (Some (q,n) = bufsAltStart2 x y Medium p
        /\ forall r, r <> q -> r <> Medium ->
          None = bufsAltStart2 x y r p)).
Proof.
  induction y; crush.
  destruct x; crush.
  destruct q; destruct b; crush; destruct p; destruct b0; crush;
    left; crush; destruct z; crush.
  destruct x; crush.
  cutThis (bufsAltStart2 f y (nextSize Medium (bufSize b0))
    (nextSize p (bufSize b1))); crush.
  left.
  destruct z; crush;
    destruct q; destruct b0; crush;
      destruct b1; destruct p; crush;
        eapply IHy in H0; crush.
  destruct q; destruct b0; crush;
    destruct p; destruct b1; crush;
      try (eapply IHy in H0); crush;
        try (abstract (left; crush; destruct z; crush));
          try (abstract (right; crush; destruct r; crush)).
Qed.
Hint Resolve extPreSomeSame2.

Require Import caseTactic.

Lemma extPreSomeOpp :
  forall
    C D (y:Nest Stuck C D)
    A B (x:Stuck A B) q p n r,
    r <> q ->
    Some (r,n) = bufsAltStart2 x y q p ->
    (Some (r,n) = bufsAltStart2 x y Medium p /\
     None = bufsAltStart2 x y r p).
Proof.
  induction y; crush;
    destruct x; crush.
  destruct p; crush; destruct b0; crush;
    destruct q; crush; destruct b; crush.
  destruct p; crush; destruct b0; crush;
    destruct q; crush; destruct b; crush.
  destruct p; crush; destruct b0; crush;
    destruct q; crush; destruct b1; crush;
      eapply IHy in H0; crush.
  destruct p; crush; destruct b0; crush;
    destruct q; crush; destruct b1; crush;
      pose H0 as hcopy;
        eapply IHy in hcopy; crush;
          destruct r; crush.
Abort.

Fixpoint bufsAltStart a b (r:ThreeStack a b) (xs ys:Size) :=
  match r with
    | Empty => True
    | Full _ _ (NE _ p ps) qs =>
      match bufsAltStart2 p ps xs ys with
        | None => False
        | Some (xs',ys') => bufsAltStart qs xs' ys'
      end
  end.

Definition BufsAlternate t (x:Deq t) :=
  match x with
    | Deque _ _ _ y _ => bufsAltStart y Medium Medium
  end.

Definition NextTop1 x y :=
  match x,y with
    | Prefix,Prefix => True
    | Suffix,Suffix => True
    | _,_ => False
  end.

Definition top2 a b (x:StackStack a b) :=
  match x with
    | NE _ p q => top2' p q
  end.

Fixpoint top3 a b (x:StackStack a b) d e (yys:ThreeStack d e) {struct yys} :=
  match yys with
    | Empty => top2 x
    | Full _ _ y ys =>
      match top2 x, top3 y ys with
        | Some v, Some w =>
          if nextTop1 v w
            then None
            else Some v
        | _,_ => None
      end
  end.

Definition topShape a b (x:ThreeStack a b) :=
  match x with
    | Empty => True
    | Full _ _ y ys =>
      match top3 y ys with
        | None => False
        | _ => True
      end
  end.
Hint Unfold topShape.

Definition allShape a (x:Deq a) :=
  match x with
    | Deque _ _ _ b _ => topShape b
  end.

Fixpoint lastPair2 (ans:Prop) (cont:Size->Size->Prop) a b (x:Stuck a b) c d (xs:Nest Stuck c d) :=
  match xs with
    | Empty =>
      match x with
        | Stack p q rs =>
          match rs with
            | M0 => cont (bufSize p) (bufSize q)
            | _ => cont Medium Medium
          end
      end
    | Full _ _ y ys => lastPair2 ans cont y ys
  end.

Fixpoint LastPair (ans:Prop) (cont:Size->Size->Prop) a b (x:ThreeStack a b)  :=
  match x with
    | Empty => ans
    | Full _ _ y ys =>
      match ys with
        | Empty =>
          match y with
            | NE _ z zs => lastPair2 ans cont z zs
          end
        | _ => LastPair ans cont ys
      end
  end.

Definition BottomSome x y :=
  match x,y with
    | Small,Small => False
    | _,_ => True
  end.

Definition BottomNone x y :=
  match x,y with
    | Small,Small => False
    | Small,_ => False
    | _,Small => False
    | _,_ => True
  end.

Definition BottomOK a (x:Deq a) :=
  match x with
    | Deque _ _ _ b (Some _) => LastPair True BottomSome b
    | Deque _ _ _ b None => LastPair True BottomNone b
  end.

Definition invariants a (x:Deq a) := BottomOK x /\ allShape x /\ BufsAlternate x.

Definition cons13 a (x y:Buffer a) b (xs:MStack (Both a) b) c (t:ThreeStack b c) : ThreeStack a c :=
    match t with
      | Empty => Full (NE (Stack x y xs) Empty) Empty
      | Full _ _ (NE _ (Stack p q pq) r) s =>
        let t' := Full (NE (Stack p q pq) r) s in
          let default := Full (NE (Stack x y xs) Empty) t' in
        match topCheck x y, topCheck p q with
          | Some i, Some j =>
            if nextTop1 i j
              then Full (NE (Stack x y xs) (Full (Stack p q pq) r)) s
              else Full (NE (Stack x y xs) Empty) t'
          | _,_ => default
        end
    end.
Hint Unfold cons13.

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

Ltac desall :=
  crush;
  match goal with
    | [_:context[
      match topCheck ?x ?y with
        | None => _
        | Some _ => _
      end] |- _]
      => cutThis (topCheck x y); desall
    | [_:context[
      match bufSize ?x with
        | Small => _
        | Medium => _
        | Large => _
      end] |- _]
      => cutThis x; desall
    | [|- context[
      match topCheck ?x ?y with
        | None => _
        | Some _ => _
      end]]
      => cutThis (topCheck x y); desall
    | [_:context[if nextTop1 ?x ?y then _ else _] |- _]
      => cutThis (nextTop1 x y); desall
    | [|- context[if nextTop1 ?x ?y then _ else _]]
      => cutThis (nextTop1 x y); desall
    | [|- context[if sameSize ?x ?y then _ else _]]
      => cutThis (sameSize x y); desall
    | [_: context[if sameSize ?x ?y then _ else _] |- _]
      => cutThis (sameSize x y); desall
    | [_:context[
      match top2' ?x ?y with
        | None => _
        | Some _ => _
      end] |- _]
      => cutThis (top2' x y); desall
    | [_:context[
      match top3 ?x ?y with
        | None => _
        | Some _ => _
      end] |- _]
      => cutThis (top3 x y); desall
    | [|- context[
      match top3 ?x ?y with
        | None => _
        | Some _ => _
      end]]
      => cutThis (top3 x y); desall
    | [ H:_ |- context[
      match ?x with
        | None => _
        | Some _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x in MStack _ _ return _ with
        | M0 => _
        | MS _ _ _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x in Nest _ _ _ return _ with
        | Empty => _
        | Full _ _ _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x with
        | NE _ _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x with
        | Stack _ _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_,
        _:context[
      match ?x with
        | Stack _ _ _ => _
      end] |- _] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x with
        | B0 => _
        | B1 _ => _
        | B2 _ _ => _
      end]] => equate H x; cutThis x; desall
    | [ H:_ |- context[
      match ?x with
        | Prefix => _
        | Suffix => _
        | Twofix => _
      end]] => equate H x; cutThis x; desall
    | [ H:_,
        _:context[
      match ?x with
        | Prefix => _
        | Suffix => _
        | Twofix => _
      end] |- _] => equate H x; cutThis x; desall
    | [ H:_,
        _:context[
      match ?x with
        | B0 => _
        | B1 _ => _
        | B2 _ _ => _
      end] |- _] => equate H x; cutThis x; desall
    | [|- context[
      match bufsAltStart2 ?p ?q ?r ?s with
        | None => _
        | Some _ => _
      end]]
      => cutThis (bufsAltStart2 p q r s); desall
    | _ => idtac
  end.

Lemma cons13shape :
  forall a (x y:Buffer a)
    b (xs:MStack (Both a) b)
    c (t:ThreeStack b c)
    i,
    Some i = topCheck x y ->
    topShape t ->
    topShape (cons13 x y xs t).
Proof.
  Ltac ifneq x y t :=
    assert (x = y); [reflexivity|auto] || t.
  Ltac here3 := unfold cons13 in *; desall;
    match goal with
      | [_ : Some _ = top3 (NE (Stack ?a ?b _) ?f) ?e,
         _ : None = topCheck ?a ?b
         |- _] => destruct e; desall; destruct f; desall; here3
      | [_ : None = top3 (NE _ (Full (Stack ?a ?b _) ?f)) ?e,
         _ : Some _ = topCheck ?a ?b
         |- _] => destruct e; desall; destruct f; desall; here3
      | [_ : _ = nextTop1 ?a ?b
         |- _] => destruct a; destruct b; desall; here3
      | [_ : Some ?d = top3 (NE (Stack ?a ?b _) ?f) ?e,
         _ : Some ?c = topCheck ?a ?b
         |- _] =>
      let thisone := destruct e; desall; destruct f; desall; here3
        in ifneq c d thisone
      | _ => desall
    end.
  here3.
Qed.

Definition empty {a} := Deque M0 Empty (@None a).

Definition prepose' a b (x:ThreeStack a b) :=
  let default := Medium in
    match x with
      | Empty => Medium
      | Full _ _ (NE _ (Stack B0 _ _) _) _ => Small
      | Full _ _ (NE _ (Stack (B2 _ _) _ _) _) _ => Large
      | _ => default
    end.

Definition prepose a (x:Deq a) :=
  match x with
    | Deque _ _ _ (Full _ _ (NE _ (Stack (B1 _) _ _) _) x) _ => prepose' x
    | Deque _ _ _ x _ => prepose' x
  end.

(*
Definition npushHelp a (x:a) (xx:Deq a) : Deq a.
intros.
destruct xx.
destruct m. destruct t. destruct s.
eapply Deque. apply M0. apply Empty. apply Some. exact x.
eapply Deque. apply MS. exact x. exact a0. apply M0. apply Empty. apply None.
apply empty.
apply empty.
Defined.

Print npushHelp.
*)

Ltac sizeSplit t :=
  here3; eauto;
    match goal with
      | [_ : _ = sameSize ?a _,
        b : Size |- _]
        => equate a b; destruct a; sizeSplit t
      | [_ : _ = sameSize _ (bufSize ?a),
        b : Buffer _ |- _]
        => equate a b; destruct a; sizeSplit t
      | [|- Some _ <> None] => discriminate
      | [|- Some _ <> Some _] => discriminate
      | _ => let foo := eapply t; here3 in try (abstract foo)
    end.

Ltac nextSize t :=
  sizeSplit t;
  match goal with
    | [|- Some _ = Some _] => f_equal; nextSize t
    | [_: _ = nextSize Medium (bufSize ?b) |- _]
        => destruct b; nextSize t
    | [H : Some (Medium,_) = bufsAltStart2 _ _ Small _ |- _]
        => eapply medPreSomeExt in H; nextSize t
    | [H : Some (Medium,_) = bufsAltStart2 _ _ Large _ |- _]
        => eapply medPreSomeExt in H; nextSize t
    | _ => auto
  end.

  Ltac topFix' t :=
    nextSize t;
    match goal with
      | [_:Some Suffix = top2' (Stack (B2 _ _) _ _) ?a ,
         A:_ |- _]
        => equate A a; assert False; destruct a; topFix' t
      | [_:Some Suffix = top2' (Stack (@B0 _) _ _) ?a ,
         A:_ |- _]
        => equate A a; assert False; destruct a; topFix' t
      | _ => nextSize t
    end.
  Ltac topFix t :=
    topFix' t;
    match goal with
      | _ => let foo := eapply t; eauto; topFix' t in try (abstract foo)
    end.

(*
Lemma startExt :
  forall A B C D (f:Stuck A B) (N:Nest Stuck C D)
    p w,
    p <> Medium ->
    forall z,
      Some (Medium,z) <> bufsAltStart2 f N p w.
Proof.

  intros A B C D f N.

  generalize dependent A;
    generalize dependent B.

  induction N; sizeSplit IHN.
Qed.
Hint Resolve startExt.
*)

(*
Lemma bufsAlt2PreExtNone :
  forall
    B C (N:Nest Stuck B C)
    A (M:Stuck A B) w,
    None = bufsAltStart2 M N Medium w ->
    forall p, None = bufsAltStart2 M N p w.
Proof.
  induction N; sizeSplit IHN.
Qed.
Hint Resolve bufsAlt2PreExtNone.

Lemma bufsAlt2PreExtSoMed :
  forall
    B C (N:Nest Stuck B C)
    A (M:Stuck A B) w,
    forall d, Some (Medium,d) = bufsAltStart2 M N Medium w ->
    forall p, Some (p,d) = bufsAltStart2 M N p w.
Proof.
  Print nextSize.

  induction N; nextSize IHN.
Qed.
Hint Resolve bufsAlt2PreExtSoMed.
*)

Lemma bufsAlt2PreExtSoExt :
  forall
    B C (N:Nest Stuck B C)
    A (M:Stuck A B) w,
    forall c,
      c <> Medium ->
      forall d,
        Some (c,d) = bufsAltStart2 M N Medium w ->
        Medium = prepose' (Full (NE M N) Empty) ->
        topShape (Full (NE M N) Empty) ->
        False.
Proof.
  induction N; topFix IHN.
Qed.
Hint Resolve bufsAlt2PreExtSoExt.

Ltac ese t :=
    topFix t;
    match goal with
      | [_:?c <> Medium,
         _:Some (?c,_) = bufsAltStart2 _ _ Medium _ |- False]
        => eapply bufsAlt2PreExtSoExt; eauto; ese t
      | _ => let foo := eapply t; eauto; topFix t in try (abstract foo)
    end.

Lemma bufsAlt2PreExtSoExtExt :
  forall
    B C (N:Nest Stuck B C)
    A (M:Stuck A B) w,
    forall c,
      c <> Medium ->
      forall d,
        Some (c,d) = bufsAltStart2 M N Medium w ->
        match prepose' (Full (NE M N) Empty) with
          | Medium => topShape (Full (NE M N) Empty) -> False
          | Small => Some (c,d) = bufsAltStart2 M N Large w
          | Large => Some (c,d) = bufsAltStart2 M N Small w
        end.
Proof.

  induction N; ese IHN.
Qed.
Hint Resolve bufsAlt2PreExtSoExtExt.

Lemma bufsAlt2PreExtSoMedMed :
  forall
    B C (N:Nest Stuck B C)
    A (M:Stuck A B) w,
    forall c,
      c <> Medium ->
      forall d,
        Some (c,d) = bufsAltStart2 M N Medium w ->
        Medium = prepose' (Full (NE M N) Empty) ->
        topShape (Full (NE M N) Empty) -> False.
Proof.
  eauto.
Qed.
Hint Resolve bufsAlt2PreExtSoMedMed.

Lemma bufsAlt2PreExtSoMedBig :
  forall
    B C (N:Nest Stuck B C)
    A (M:Stuck A B) w,
    forall c,
      c <> Medium ->
      forall d,
        Some (c,d) = bufsAltStart2 M N Medium w ->
        Small = prepose' (Full (NE M N) Empty) ->
        Some (c,d) = bufsAltStart2 M N Large w.
Proof.
  intros.
  eapply bufsAlt2PreExtSoExtExt in H0; eauto.
  rewrite <- H1 in H0. auto.
Qed.
Hint Resolve bufsAlt2PreExtSoMedBig.

Lemma bufsAlt2PreExtSoMedSml :
  forall
    B C (N:Nest Stuck B C)
    A (M:Stuck A B) w,
    forall c,
      c <> Medium ->
      forall d,
        Some (c,d) = bufsAltStart2 M N Medium w ->
        Large = prepose' (Full (NE M N) Empty) ->
        Some (c,d) = bufsAltStart2 M N Small w.
Proof.
  intros.
  eapply bufsAlt2PreExtSoExtExt in H0; eauto.
  rewrite <- H1 in H0. auto.
Qed.
Hint Resolve bufsAlt2PreExtSoMedSml.

(*
Lemma bufsAltPreExt :
  forall a b (t:ThreeStack a b) p q,
    topShape t ->
    prepose' t <> p ->
    bufsAltStart t Medium q ->
    bufsAltStart t p q.
Proof.

  Ltac badMatch t :=
    ese t;
    match goal with
      | [_:Some _ = top3 (NE ?a ?b) _,
         _:None = bufsAltStart2 ?a ?b _ _,
         B:_ |- _]
        => equate B b; destruct b; badMatch t
      | [J:match ?a with
             | None => False
             | Some _ => _
           end,
         I:None = ?a |- _]
        => rewrite <- I in J; assert False; badMatch t
      | [J:match ?a with
             | None => _
             | Some _ => _
           end,
         I:Some _ = ?a |- _]
        => rewrite <- I in J; badMatch t
      | [|- let 'pair _ _ := ?b in _] => destruct b; badMatch t
      | [_:Some _ = top3 (NE (Stack (B1 _) (B1 _) _) (Full ?a ?b)) ?c,
        _:None = bufsAltStart2 ?a ?b _ _,
        A:_,
        B:_,
        C:_
        |- False]
        => equate A a; equate B b; equate C c;
        destruct a; destruct b; destruct c; badMatch t
      | _ => let foo := eapply t; eauto; ese t in try (abstract foo)
    end.
  induction t; badMatch IHt.

  Focus 3.
  cutThis (bufsAltStart2 s n Medium Large); desall.
  destruct p; desall.
  erewrite <- bufsAlt2PreExtSoMedBig in HeqH.
  Focus 4. destruct s; destruct n; destruct t; desall.

rewrite

  destruct t0.
  destruct t; desall.
  destruct t; desall. Print bufsAltStart2.
  destruct s; desall. Print bufsAltStart2.
  destruct n; desall.

  Focus 2.

  Focus 3.
  destruct n; destruct s; destruct t; badMatch IHt.
  destruct s0; destruct n; badMatch IHt.
  cutThis (bufsAltStart2 s n Medium Large); badMatch IHt.
  destruct p. destruct s0; badMatch IHt.
  erewrite <- bufsAlt2PreExtSoMedBig in HeqH.
  Focus 3. eauto. Focus 4. badMatch IHt.
  Focus 4. destruct s; destruct n; badMatch IHt.
  destruct s; destruct n; badMatch IHt.

  Focus 2.

  destruct n; destruct s; destruct t; badMatch IHt.

  destruct s0; destruct n; badMatch IHt.

Unfocus.

  Lemma matchLetPair :
    forall (t:Type) (x:prod t t),
      let (a,b) := x in a = b.
  Proof.
  Ltac noMatch :=
    match goal with
      | [|- let (_,_) := ?p in _]
        => destruct p
      | [|- match ?p with
              | pair _ _ => _
            end]
        => destruct p
    end.

  noMatch.

  Ltac uh :=
    match goal with
      | [|- let (pair ?xs' ?ys') := ?p0 in bufsAltStart ?t ?xs' ?ys']
        => destruct p0
    end.
  Locate "(_,_)".
  Print pair.

  destruct p0.
  destruct p; desall.
  badMatch t.
  eapply IHt.
  desall.

; topFix IHt.

ese IHt.
  destruct n; badMatch IHt.

  destruct p0.
  destruct t; simpl in *; auto.
  destruct s1; simpl in *.

eapply IHt.
  destruct n;  badMatch IHt.

  destruct t; destruct n; badMatch IHt.

  destruct p; ese IHt.

  desall.
  intros; simpl in *.
  destruct f; simpl in *.
  cutThis (bufsAltStart2 s n Medium q); simpl in *.
  desall.
  destruct p0; simpl in *.
  destruct s0; simpl in *.

  apply bufsAlt2PreExtSoExtExt in HeqH2.
  desall. destruct t; desall.
  destruct p0; desall. eapply IHt; desall.
  destruct t; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct p0; desall. eapply IHt; desall.
  destruct t; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct p0; desall. eapply IHt; desall.
  destruct t; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall;
    destruct p; desall;
      destruct q; desall.
  destruct p0; desall. eapply IHt; desall.
  destruct t; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall;
    destruct p; desall;
      destruct q; desall.
  destruct p0; desall. eapply IHt; desall.
  destruct t; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct p0; desall. eapply IHt; desall.
  destruct t; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct p0; desall. eapply IHt; desall.
  destruct t; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct p0; desall. eapply IHt; desall.
  destruct t; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct p0; desall. eapply IHt; desall.
  destruct t; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.
  destruct t; destruct n; desall.

  cutThis (prepose' (Full (NE s n) Empty)).

  Focus 2.
  eapply bufsAlt2PreExtSoMed in HeqH2.
  rewrite <- HeqH2.
  eapply IHt; auto.
  destruct t; desall.
  desall; destruct t; desall.
  destruct s; simpl in *.
  destruct t; simpl in *.
  destruct n; destruct b1; simpl in *;
    destruct b2; simpl in *;
      destruct p; simpl in *; desall.
  destruct q; desall.

  Focus 2.

  destruct t; desall.
  destruct t; desall.
  destruct n

  induction t; desall.
  cutThis (bufsAltStart2 (Stack (B0 a) b2 m) n Medium q); desall; eauto.

  cutThis (bufsAltStart2 s n p q); desall;
    cutThis (bufsAltStart2 s n Medium q); desall.
  Focus 2.
  destruct p0. destruct p1.
  destruct s; simpl in *.
  fold (bufSize b1) in *.

  assert (
    bufSize b1 <> p ->
    match top3 (NE (Stack b1 b2 m) n) t with
      | None => True
      | Some _ =>
        bufsAltStart t s2 s3 ->
        bufsAltStart t s0 s1

  destruct s; destruct p; desall.
  cutThis (bufsAltStart2 (Stack (B1 a0) b2 m) n Medium q); desall.

  Ltac crr :=
    match goal with
      | [H:(?x = ?x) -> False |- _]
        => pose (H (@eq_refl _ x))
    end.
  crr.

Lemma bufsAlt2PreExt :
  forall (f:Size -> Size -> Prop)
    A B (M:Stuck A B)
    C (N:Nest Stuck B C)
    E (R:ThreeStack C E) p w,
    (forall q z, (*prepose' R <> q*) (*q = p ->*) f Medium z -> f q z) ->
    topShape R ->
    topShape (Full (NE M N) R) ->
    prepose' (Full (NE M N) R) <> p ->
    bufsAltStart2 f M N R Medium w ->
    bufsAltStart2 f M N R p w.
Proof.
  intros f A B M C N.
  generalize dependent f; generalize dependent A.
  induction N; intros; desall;
    repeat split; desall;
      destruct p; desall.
  eapply IHN; desall.
  destruct R; desall;
    destruct f; desall.
  destruct f; desall;
    destruct R; desall;
      destruct N; desall.
  eapply IHN; desall.
  destruct R; desall;
    destruct N; desall.
  destruct f; desall;
    destruct R; desall;
      destruct N; desall.
Qed.

Lemma bufsAltPreExt :
  forall a b (t:ThreeStack a b) p q,
    topShape t ->
    prepose' t <> p ->
    bufsAltStart t Medium q ->
    bufsAltStart t p q.
Proof.
  induction t; intros; desall.
  destruct p; desall.
  eapply bufsAlt2PreExt; desall.
  eapply IHt; desall.
  destruct t; desall.
  destruct s; desall.
  destruct t; desall.
      destruct n; desall.

  destruct s; destruct p; desall; eapply IHt; desall;
    destruct t; desall.
  destruct s; desall.
  destruct s; desall.
  destruct n; desall.
  destruct
  des
  destruct s; desall.
*)

(*
Lemma bufsAlt2PreExt :
  forall (f:Size -> Size -> Prop)
    A B (M:Stuck A B)
    C (N:Nest Stuck B C)
    E (R:ThreeStack C E) p w,
    (forall q z, (*prepose' R <> q -> *) f Medium z -> f q z) ->
    topShape R ->
    topShape (Full (NE M N) R) ->
    prepose' (Full (NE M N) R) <> p ->
    bufsAltStart2 f M N R Medium w ->
    bufsAltStart2 f M N R p w.
Proof.
  intros f A B M C N.
  generalize dependent f; generalize dependent A.
  induction N; intros; desall;
    repeat split; desall;
      destruct p; desall.
  eapply IHN; desall.
  destruct R; desall.
  destruct f; desall.
  destruct R; desall.
  destruct N; desall.
  destruct N; desall.
  destruct N; desall.
  destruct N; desall.
  destruct N; desall.
  destruct N; desall.
  destruct R; desall.
  destruct N; desall.
  destruct N; desall.
  destruct N; desall.
  destruct N; desall.
  destruct N; desall.
  destruct N; desall.
  destruct p; desall.
Qed.
*)

(*
  destruct b1; desall.
  destruct R; desall;
    destruct N; desall;
      destruct f; desall.

  destruct p; desall.
  destruct p; desall.
  destruct p; desall.

  eapply H; desall.
  destruct R; desall.
  destruct s; desall.
  destruct s; desall.
  destruct R; desall.
  destruct n; desall.

  destruct p; desall.
  cutThis (prepose' R); desall.
  destruct R; desall.
  destruct w; destruct s; desall.
  destruct s; destruct R; desall.
  destruct n; desall.
  eapply H; desall.
  destruct p; desall.
  destruct p; desall.
  destruct p; desall.
  eapply IHN; desall.
  destruct f; desall.
  destruct p; desall.
  destruct p; desall.
  apply H; desall.
  destruct w; destruct p; destruct b0; desall.
  destruct p; desall.
  destruct w; destruct p; destruct b1; desall.
  destruct w; destruct p; destruct b1; desall.
  eapply IHN; desall.
  Focus 2.
  destruct w; destruct b1; desall.
  Unfocus.
  destruct w; destruct b1; desall.
  destruct f; destruct N; desall.

  destruct w; destruct p; destruct b1; desall.

  Print bufsAltStart2.
  destruct p; desall;
    destruct w; desall;
      destruct R; desall;
        destruct N; desall;
          repeat split; desall.
  apply H; crush.
  pose (H3 I). inversion f0.
  inversion H3.
  simpl in *.
  unfold not in *. crush.
  crush.
  unfold bufSize in *. desall. eapply H; auto.
  eapply H; eauto; desall. destruct b0; desall.

          destruct M; desall.

  assert (forall A B (C:ThreeStack A B),
    prepose' C <> Large ->
    forall z,
      z <> Medium ->
      bufsAltStart C Medium z ->
      bufsAltStart C Large z) as ans.

Lemma bufsAlt2PreMed :
  forall
    A B (M:Stuck A B)
    C (N:Nest Stuck B C) p w
    X Y (t : ThreeStack X Y),
    (forall q r, bufsAltStart t q r -> bufsAltStart t Medium r) ->
    let ext := bufsAltStart2 M N p w in
      let med := bufsAltStart2 M N Medium w in
        match ext with
          | Some (a,b) =>
            match med with
              | None => False
              | Some (c,d) =>

                  bufsAltStart t a b ->
                  bufsAltStart t c d
            end
          | _ => True
        end.
Proof.
  intros. generalize dependent w. generalize dependent A.
  generalize dependent p.
  induction N; desall.
  destruct w; destruct b; destruct b0; desall; eauto.
  destruct p0.
  destruct b0; desall.
  pose (IHN p _ f (nextSize w (bufSize b1))) as ans.
  rewrite <- HeqH2 in *.
  rewrite <- HeqH3 in *; desall.
  destruct p0; destruct p1; desall.
  destruct b0; desall; crush.
  pose (IHN p _ f (nextSize w (bufSize b1))) as ans.
  rewrite <- HeqH2 in *.
  rewrite <- HeqH3 in *; desall.
Qed.

Lemma bufsAltPreMedium :
  forall a b (t:ThreeStack a b) p q,
    bufsAltStart t p q ->
    bufsAltStart t Medium q.
Proof.
  induction t; desall.
  cutThis (bufsAltStart2 s n p q); desall.
  pose (bufsAlt2PreMed s n p q) as C.
  desall.
  rewrite <- HeqH0 in C.
  destruct p0; desall.
  rewrite <- HeqH1 in C. desall.
  eapply C; desall.
  eapply IHt. eauto.
  destruct p0.
  cutThis (bufsAltStart2 s n p q).
  pose (bufsAlt2PreMed s n p q) as C.
  desall.
  destruct p0.
  pose (bufsAlt2PreMed s n p q) as C. desall.
  rewrite <- HeqH0 in C.
  rewrite <- HeqH1 in C. desall.
Qed.
Hint Resolve bufsAltPreMedium.
*)

(*
npush :: a -> Deque a -> Deque a
npush x (Deque M0 Empty None) = Deque M0 Empty (Some x)
npush x (Deque M0 Empty (Some y)) = Deque (MS x y M0) Empty None
npush x (Deque M0 (Full (NE (Stack B0 (B1 z) zs) Empty) xs) q) = Deque (MS x z zs) xs q
npush x (Deque M0 (Full (NE (Stack B0 (B1 z) zs) (Full y ys)) xs) q) = Deque (MS x z zs) (Full (NE y ys) xs) q
npush x (Deque M0 (Full (NE (Stack B0 z zs) Empty) xs) q) = Deque M0 (cons13 (B1 x) z zs xs) q
*)
(*
npush x (Deque M0 (Full (NE (Stack (B1 y) z zs) Empty) xs) q) = Deque M0 (Full (NE (Stack (B2 x y) z zs) Empty) xs) q
npush x (Deque M0 (Full (NE (Stack (B1 y) z zs) (Full r rs)) xs) q) = Deque M0 (Full (NE (Stack (B2 x y) z zs) Empty) (Full (NE r rs) xs)) q
npush x (Deque (MS y z zs) rs q) = Deque M0 (cons13 (B2 x y) (B1 z) zs rs) q
*)

Definition npush a (x:a) (xx:Deq a) : Deq a :=
  let default := xx in
  match xx with
    | Deque _ _ b c d =>
      match b in MStack _ B return ThreeStack B _ -> Deq a with
        | M0 => fun cc =>
          match cc in Nest _ _ C return SM C -> Deq a with
            | Empty =>
              fun dd =>
              match dd with
                | None => Deque M0 Empty (Some x)
                | Some y => Deque (MS x y M0) Empty None
              end
            | Full _ _ e xs => fun dd =>
              match e with
                | NE _ f g =>
                  match f  with
                    | Stack B0 (B1 z) zs =>
                      match g in Nest _ _ G return Nest _ G _ -> Deq a with
                        | Empty => fun xsxs => Deque (MS x z zs) xsxs dd
                        | Full _ _ y ys => fun xsxs => Deque (MS x z zs) (Full (NE y ys) xsxs) dd
                      end xs
                    | Stack B0 z zs =>
                      match g in Nest _ _ G return Nest _ G _ -> Deq a with
                        | Empty => fun xsxs => Deque M0 (cons13 (B1 x) z zs xsxs) dd
                        | _ => fun _ => default
                      end xs
                    | Stack (B1 y) z zs =>
                      match g in Nest _ _ G return Nest _ G _ -> Deq a with
                        | Empty => fun xsxs => Deque M0 (Full (NE (Stack (B2 x y) z zs) Empty) xsxs) dd
                        | Full _ _ r rs => fun xsxs => Deque M0 (Full (NE (Stack (B2 x y) z zs) Empty) (Full (NE r rs) xsxs)) dd
                      end xs

                    | _ => default
                  end
              end
          end d
        | _ => fun _ => default
      end c
  end.

Lemma npushBottom :
  forall a (x:a) xs,
    BottomOK xs ->
    BottomOK (npush x xs).
Proof.
  intros; destruct xs.
  ese H.

  Ltac badMatch t :=
    ese t;
    match goal with
      | [_:Some _ = top3 (NE ?a ?b) _,
         _:None = bufsAltStart2 ?a ?b _ _,
         B:_ |- _]
        => equate B b; destruct b; badMatch t
      | [J:match ?a with
             | None => False
             | Some _ => _
           end,
         I:None = ?a |- _]
        => rewrite <- I in J; assert False; badMatch t
      | [J:match ?a with
             | None => _
             | Some _ => _
           end,
         I:Some _ = ?a |- _]
        => rewrite <- I in J; badMatch t
      | [|- let 'pair _ _ := ?b in _] => destruct b; badMatch t
      | [_:Some _ = top3 (NE (Stack (B1 _) (B1 _) _) (Full ?a ?b)) ?c,
        _:None = bufsAltStart2 ?a ?b _ _,
        A:_,
        B:_,
        C:_
        |- False]
        => equate A a; equate B b; equate C c;
        destruct a; destruct b; destruct c; badMatch t
      | [_:match ?x with
             | Empty => _
             | Full _ _ _ _ => _
           end,
         X:_ |- _]
         => equate x X; destruct x; badMatch t
      | _ => let foo := eapply t; eauto; ese t in try (abstract foo)
    end.
  badMatch H.
  badMatch H.
Qed.

Lemma npushShape :
  forall a (x:a) xs,
    allShape xs ->
    allShape (npush x xs).
Proof.

  Ltac shapDes t :=
    badMatch t;
    match goal with
      | [_:Some _ = top3 _ ?x,
         X:_ |- topShape ?x]
         => equate X x; destruct x; shapDes t
      | [_:Some _ = top3 _ ?x,
         _:None = top3 _ ?x,
         X:_ |- False]
         => equate X x; destruct x; shapDes t
      | [_:Some ?a = top3 _ ?x,
         _:Some ?b = top3 _ ?x,
         X:_ |- False]
         => equate X x;
         let t1 := destruct x; shapDes t
           in ifneq a b t1
      | _ => let foo := eapply t; eauto; badMatch t in try (abstract foo)
    end.

  destruct xs;
  shapDes H.
Qed.

Lemma npushSmallHelp :
  forall A B (y:Nest Stuck A B) C (x:Stuck C A) p,
    match bufsAltStart2 x y Small p with
      | None => False
      | Some (pair _ _) => True
    end ->
    None = bufsAltStart2 x y Medium p ->
    Some Suffix = top2' x y ->
    False.
Proof.
  induction y; badMatch IHy.
Qed.
Hint Resolve npushSmallHelp.

Lemma npushSmallOth :
  forall E A (n0:Nest Stuck E A)
    B F (s1 : Stuck F B) C D (H0 : Nest StackStack C D)  p,
    match bufsAltStart2 s1 n0 Small p with
      | None => False
      | Some (pair xs' ys') => bufsAltStart H0 xs' ys'
    end ->
    None = bufsAltStart2 s1 n0 Medium p ->
    False.
Proof.
  induction n0; badMatch IHn0.
Qed.
Hint Resolve npushSmallOth.

Lemma npushSmallThd :
  forall
    B A (n0:Nest Stuck B A)
     F (s1 : Stuck F B)
     C D (H0 : Nest StackStack C D)
     s0 s2,
    Some Prefix = top3 (NE s1 n0) H0 ->
    match bufsAltStart2 s1 n0 Small Large with
      | None => False
      | Some (pair xs' ys') => bufsAltStart H0 xs' ys'
    end ->
    Some (s0, s2) = bufsAltStart2 s1 n0 Medium Large ->
    bufsAltStart H0 s0 s2.
Proof.
  induction n0; badMatch IHn0;
    induction H0; badMatch IHH0.
Qed.
Hint Resolve npushSmallThd.

Lemma npushSmall4 :
  forall
    B A (n0:Nest Stuck B A)
     F (s1 : Stuck F B)
     C D (H0 : Nest StackStack C D)
     s0 s2,
    Some Twofix = top3 (NE s1 n0) H0 ->
    match bufsAltStart2 s1 n0 Small Large with
      | None => False
      | Some (pair xs' ys') => bufsAltStart H0 xs' ys'
    end ->
    Some (s0, s2) = bufsAltStart2 s1 n0 Medium Large ->
    bufsAltStart H0 s0 s2.
Proof.
  induction n0; badMatch IHn0;
    induction H0; badMatch IHH0.
Qed.
Hint Resolve npushSmall4.

(*
Lemma npushSmall5 :
  forall
     C D (H0 : Nest StackStack C D)
     B A (n0:Nest Stuck B A)
     G H (n : Nest Stuck G H)
     F (s1 : Stuck F B)
     I (s0 : Stuck I G) p q,
     Some Prefix = top3 (NE s1 n0) H0 ->
     q <> Medium ->
     match bufsAltStart2 s0 n Small q with
       | None => False
       | Some (pair xs' ys') =>
         match bufsAltStart2 s1 n0 xs' ys' with
           | None => False
           | Some (pair xs'0 ys'0) => bufsAltStart H0 xs'0 ys'0
         end
     end ->
     Some p = bufsAltStart2 s0 n Medium q ->
     Some Suffix = top2' s0 n ->
     let (xs',ys') := p in
       let (xs', ys') := p in
         match bufsAltStart2 s1 n0 xs' ys' with
           | None => False
           | Some (pair xs'0 ys'0) => bufsAltStart H0 xs'0 ys'0
         end.
Proof.

  intros.
  destruct p.
  cutThis (bufsAltStart2 s0 n Small q).
  induction n; badMatch IHn.
  destruct p.
  cutThis (bufsAltStart2 s1 n0 s3 s4).
  assert False; crush.
  destruct p.
  induction n0; desall.
  destruct b; destruct b0; destruct s3; destruct s4;
    destruct H0; desall.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.
  badMatch m.

 badMatch IHn0.

  cutThis q.

  induction H0; badMatch IHH0.
  induction n0; badMatch IHn0.
  eapply IHn. eauto. Focus 2. eauto. badMatch IHn. eauto. eauto.
  eapply IHn. eauto. Focus 2. eauto. crush. eauto. auto.
Qed.
(*Hint Resolve npushSmall5.*)

(*  let (xs', ys') := p in
   match bufsAltStart2 s1 n0 xs' ys' with
   | None => False
   | Some (pair xs'0 ys'0) => bufsAltStart H0 xs'0 ys'0
   end
*)
*)

Lemma npushBufs :
  forall a (x:a) xs,
    prepose xs <> Large ->
    allShape xs ->
    BufsAlternate xs ->
    BufsAlternate (npush x xs).
Proof.
  intros.
  unfold BufsAlternate in *.
  destruct xs; simpl in *.
  destruct t; simpl in *.
  desall.

  desall.
  unfold cons13; desall.
  cutThis (bufsAltStart2 (Stack b2 b3 m0) n Small Small); crush.
  eapply medPreNone in HeqH1. rewrite <- HeqH1 in HeqH3; crush.
  destruct p.

  cutThis (bufsAltStart2 (Stack b2 b3 m0) n Small Small); crush.
  destruct p; crush.

  destruct s2; desall.
  pose HeqH3 as hh.
  eapply extPreSomeSame2 in hh. desall.
  pose HeqH1 as hh.
  rewrite <- H2 in hh. desall.
  destruct H0; desall.
  eapply medPreNone in HeqH0.
  rewrite <- HeqH0 in H1; crush.
  destruct p; desall.

  cutThis (bufsAltStart2 s1 n0 Small s3); crush.
  destruct p; crush.
  destruct s0; desall.
  pose HeqH7 as hh.
  eapply extPreSomeSame2 in hh. desall.
  pose HeqH0 as hh.
  rewrite <- H3 in hh. desall. crush. crush.
  Check medPreNone.
  destruct H0; desall.
  cutThis (bufsAltStart2 s1 n0 Small s3); crush.
  destruct p; crush.

  rewrite <- HeqH0 in Heq

  assert
    (forall E F (z:ThreeStack E F)
      s t r u A B (x:Stuck A B) C D (y:Nest Stuck C D) v
      m n w,
      Some (s,t) = bufsAltStart2 x y m v ->
      bufsAltStart z s t ->
      Some (r,u) = bufsAltStart2 x y n w ->
      bufsAltStart z r u) as ans.
  clear.
  induction z; desall.
  cutThis (bufsAltStart2 s0 n0 s t); crush.
  destruct p; desall. Focus 2.
  cutThis (bufsAltStart2 s0 n0 s t); crush.
  destruct p; desall. destruct p0; desall.
  eapply IHz. Focus 2. eapply H0.
  Focus 2. eapply HeqH0.
  Focus 2. eauto.
  pose (IHz _ _ _ _ _ _ _ _ _ _ _ _ _ _ HeqH0 H0 H1).

  destruct r; desall.
  eapply IHz in HeqH0. Focus 3.

  destruct t; desall.

  clear HeqH1 HeqH0 H s m.

  destruct p.

  assert
    (forall E F (z:ThreeStack E F)
      s t A B (x:Stuck A B) C D (y:Nest Stuck C D) v,
      Some (s,t) = bufsAltStart2 x y Small v ->
      bufsAltStart z s t ->
      None = bufsAltStart2 x y Medium v ->
      False) as ans.
  clear.
  induction z; desall.
  eapply medPreNone in H1. rewrite <- H1 in H. crush.
  eapply medPreNone in H1. rewrite <- H1 in H. crush.

  eapply ans; eauto.
  destruct p.

  destruct f.
  cutThis (bufsAltStart2 s0 n s t). crush. destruct p.
  eapply IHz. eapply HeqH2.
  destruct

  eapply medPreNone in HeqH2. rewrite <- HeqH2 in H1. crush.
  destruct p; desall. destruct s0; desall.
  eapply medPreSomeOth in HeqH2; desall.
  rewrite <- H0 in H1.
  destruct t; desall. rewrite <- H2 in H1. crush.
  eapply medPreSomeMed in HeqH2. rewrite <- HeqH2 in H1.
  destruct t; desall.
  eapply medPreNone in HeqH0. rewrite <- HeqH0 in H1. crush.
  destruct p; desall. destruct s0; desall.
  eapply medPreSomeOth in HeqH0; desall.
  rewrite <- H0 in H1.
  destruct t; desall. rewrite <- H2 in H1. crush.
  eapply medPreSomeMed in HeqH0. rewrite <- HeqH0 in H1.
  destruct t; desall.
  eapply medPreNone in HeqH0. rewrite <- HeqH0 in H1. crush.
  destruct p; desall. destruct s0; desall.

  Check medPreSomeOth.
  Check medPreSomeExt.
  destruct m; desall. destruct t; desall.
  Focus 5.

  destruct s0; simpl in *.
  cutThis (bufsAltStart2 s0 n Medium Medium).
  inversion H1.
  destruct p.
  destruct s1.
  eapply medPreSomeOth in HeqH2; desall.

  destruct s0; simpl in *.
  destruct b2; simpl in *.
  destruct m; desall.
  destruct t; desall.
  Print cons13.
  crush.
  Print SM.

  intros.
  destruct xs; ese H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  eapply npushSmallHelp; eauto;  badMatch H1.
  eapply npushSmallHelp; eauto;  badMatch H1.
  try (eapply npushSmallHelp; eauto);  badMatch H1.
  try (eapply npushSmallHelp; eauto);  badMatch H1.
  try (eapply npushSmallHelp; eauto);  badMatch H1.

  eapply npushSmall5 with (s0 := s0) (n := n) (q := Large).
  Focus 3.
  cutThis (bufsAltStart2 s0 n Small Large). auto.
  destruct p0.
 simpl in *.
  eapply H1.

eauto.
  try (eapply npushSmallHelp; eauto);  badMatch H1.
  try (eapply npushSmallHelp; eauto);  badMatch H1.

  destruct p. (* bookmark *)
  induction n0; badMatch IHn0.

  assert False.
  eapply npushSmallHelp; eauto.

  badMatch H1;
    try (eapply npushSmallHelp; eauto);
      try (eapply npushSmallOth; eauto);
        badMatch H1.

  clear s m H.
  clear HeqH4.
  induction n0; badMatch IHn0.

  try (eapply npushSmallHelp; eauto);  badMatch H1.
  try (eapply npushSmallHelp; eauto);  badMatch H1.
  try (eapply npushSmallHelp; eauto);  badMatch H1.
  try (eapply npushSmallHelp; eauto);  badMatch H1.

  eapply npushSmallHelp; eauto;  badMatch H1.
  eapply npushSmallHelp; eauto;  badMatch H1.
  eapply npushSmallHelp; eauto;  badMatch H1.
  eapply npushSmallHelp; eauto;  badMatch H1.
  eapply npushSmallHelp; eauto;  badMatch H1.
  eapply npushSmallHelp; eauto;  badMatch H1.

(*bookmark*)
  clear H m0 m s.
  assert (forall A B (y:Nest Stuck A B) C (x:Stuck C A) p,
    match bufsAltStart2 x y Small p with
      | None => False
      | Some (pair _ _) => True
    end ->
    None = bufsAltStart2 x y Medium p ->
    Some Suffix = top2' x y ->
    False) as ans.
  clear.
  induction y; badMatch IHy.
  badMatch ans.

  eapply IHn.
  induction n; badMatch IHn0.
  destruct
  eapply IHn0.

  destruct s0; destruct n; badMatch H.
  destruct s0; destruct n; badMatch H.

  shapDes H.

  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.
  badMatch H.

Lemma npushBufs :
  forall a (x:a) xs,
    prepose xs <> Large ->
    allShape xs ->
    BufsAlternate xs ->
    BufsAlternate (npush x xs).
Proof.
  intros.
  destruct xs; desall.
  destruct m; desall; destruct H2; desall;
    repeat split; desall; eauto.
  eauto.
  destruct m; desall; destruct H2; desall;
    repeat split; desall; eauto.
  repeat split; desall; eauto.
  Focus 2.
  eauto. Focus 2.
  repeat split; desall; eauto.
  Unfocus. Print nextSize. Print top3.
  assert (forall A B (C:ThreeStack A B),
    prepose' C <> Large ->
    forall z,
      z <> Medium ->
      bufsAltStart C Medium z ->
      bufsAltStart C Large z) as ans.
  clear.
  Print bufsAltStart.
  Print bufsAltStart2.
  destruct C. Focus 2.
  simpl. destruct s; desall.
  unfold bufsAltStart.
  forall A B
  assert (fora

  induction C.
  intros.
  destruct z; desall.
  intros.
  destruct f; desall.
  desall s; desall; destruct n; desall
  destruct C; desall.
  destruct s0; desall; destruct n; desall;
    repeat split; desall.
  destruct b2

  cutThis (prepose' C); desall.
  destruct C; desall.
  destruct s0; desall; destruct n; desall; destruct C; desall;
    repeat split; desall.
  destruct C; desall.
  destruct s0; desall; destruct n; desall; destruct C; desall;
    repeat split; desall.
  destruct b2; desall; destruct s0; desall; destruct n; desall; destruct C; desall.
  destruct b2; desall; destruct b3; desall; destruct s0; desall; destruct n; desall; destruct C; desall.

    repeat split; desall.

  destruct z; desall;
  destruct s0; desall; destruct n; desall; destruct C; desall;
    repeat split; desall.
  destruct s0; desall; destruct n; desall; destruct C; desall;
    repeat split; desall.
  destruct b2; destruct z; desall.

  cutThis (prepose' H2); desall.
  destruct H2; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; destruct m; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H. auto.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; desall; destruct s1; desall; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.

  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.
  destruct H2; destruct s1; destruct n; desall.

  destruct H2; desall. destruct H2; desall. destruct n; desall.
  repeat split; desall; eauto.
  eauto.
Qed.

npush :: a -> Deque a -> Deque a
npush x (Deque M0 Empty None) = Deque M0 Empty (Some x)
npush x (Deque M0 Empty (Some y)) = Deque (MS x y M0) Empty None
npush x (Deque M0 (Full (NE (Stack B0 (B1 z) zs) Empty) xs) q) = Deque (MS x z zs) xs q
npush x (Deque M0 (Full (NE (Stack B0 (B1 z) zs) (Full y ys)) xs) q) = Deque (MS x z zs) (Full (NE y ys) xs) q
npush x (Deque M0 (Full (NE (Stack B0 z zs) Empty) xs) q) = Deque M0 (cons13 (B1 x) z zs xs) q
npush x (Deque M0 (Full (NE (Stack (B1 y) z zs) Empty) xs) q) = Deque M0 (Full (NE (Stack (B2 x y) z zs) Empty) xs) q
npush x (Deque M0 (Full (NE (Stack (B1 y) z zs) (Full r rs)) xs) q) = Deque M0 (Full (NE (Stack (B2 x y) z zs) Empty) (Full (NE r rs) xs)) q
npush x (Deque (MS y z zs) rs q) = Deque M0 (cons13 (B2 x y) (B1 z) zs rs) q

ninject :: Deque a -> a -> Deque a
ninject (Deque M0 Empty None) x = Deque M0 Empty (Some x)
ninject (Deque M0 Empty (Some y)) x = Deque (MS y x M0) Empty None
ninject (Deque M0 (Full (NE (Stack (B1 z) B0 zs) Empty) xs) q) x = Deque (MS z x zs) xs q
ninject (Deque M0 (Full (NE (Stack (B1 z) B0 zs) (Full y ys)) xs) q) x = Deque (MS z x zs) (Full (NE y ys) xs) q
ninject (Deque M0 (Full (NE (Stack z B0 zs) Empty) xs) q) x = Deque M0 (cons13 z (B1 x) zs xs) q
ninject (Deque M0 (Full (NE (Stack z (B1 y) zs) Empty) xs) q) x = Deque M0 (Full (NE (Stack z (B2 y x) zs) Empty) xs) q
ninject (Deque M0 (Full (NE (Stack z (B1 y) zs) (Full r rs)) xs) q) x = Deque M0 (Full (NE (Stack z (B2 y x) zs) Empty) (Full (NE r rs) xs)) q
ninject (Deque (MS z y zs) rs q) x = Deque M0 (cons13 (B1 z) (B2 y x) zs rs) q

npop :: Deque a -> Maybe (a,Deque a)
npop (Deque M0 Empty None) = Nothing
npop (Deque M0 Empty (Some y)) =  Just (y,empty)
npop (Deque M0 (Full (NE (Stack (B2 y x) (B1 z) zs) Empty) xs) q) = Just (y,Deque (MS x z zs) xs q)
npop (Deque M0 (Full (NE (Stack (B2 y x) (B1 z) zs) (Full r rs)) xs) q) = Just (y,Deque (MS x z zs) (Full (NE r rs) xs) q)
npop (Deque M0 (Full (NE (Stack (B2 y x) z zs) Empty) xs) q) = Just (y,Deque M0 (cons13 (B1 x) z zs xs) q)
npop (Deque M0 (Full (NE (Stack (B1 y) (B2 x z) M0) Empty) Empty) None) = Just (y,Deque (MS x z M0) Empty None)
npop (Deque M0 (Full (NE (Stack (B1 y) B0 M0) Empty) Empty) (Some (Both x z))) = Just (y,Deque (MS x z M0) Empty None)
npop (Deque M0 (Full (NE (Stack (B1 y) z zs) Empty) xs) q) = Just (y,Deque M0 (Full (NE (Stack B0 z zs) Empty) xs) q)
npop (Deque M0 (Full (NE (Stack (B1 y) z zs) (Full r rs)) xs) q) = Just (y,Deque M0 (Full (NE (Stack B0 z zs) Empty) (Full (NE r rs) xs)) q)
npop (Deque (MS y z M0) Empty None) = Just (y,Deque M0 Empty (Some z))
npop (Deque (MS y z zs) rs q) = Just (y,Deque M0 (cons13 B0 (B1 z) zs rs) q)

neject :: Deque a -> Maybe (Deque a,a)
neject (Deque M0 Empty None) = Nothing
neject (Deque M0 Empty (Some y)) = Just (empty,y)
neject (Deque M0 (Full (NE (Stack (B1 x) (B2 z y) zs) Empty) xs) q) = Just (Deque (MS x z zs) xs q,y)
neject (Deque M0 (Full (NE (Stack (B1 x) (B2 z y) zs) (Full r rs)) xs) q) = Just (Deque (MS x z zs) (Full (NE r rs) xs) q, y)
neject (Deque M0 (Full (NE (Stack z (B2 x y) zs) Empty) xs) q) = Just (Deque M0 (cons13 z (B1 x) zs xs) q, y)
neject (Deque M0 (Full (NE (Stack (B2 x z) (B1 y) M0) Empty) Empty) None) = Just (Deque (MS x z M0) Empty None, y)
neject (Deque M0 (Full (NE (Stack B0 (B1 y) M0) Empty) Empty) (Some (Both x z))) = Just (Deque (MS x z M0) Empty None, y)
neject (Deque M0 (Full (NE (Stack z (B1 y) zs) Empty) xs) q) = Just (Deque M0 (Full (NE (Stack z B0 zs) Empty) xs) q, y)
neject (Deque M0 (Full (NE (Stack z (B1 y) zs) (Full r rs)) xs) q) = Just (Deque M0 (Full (NE (Stack z B0 zs) Empty) (Full (NE r rs) xs)) q, y)
neject (Deque (MS z y M0) Empty None) = Just (Deque M0 Empty (Some z), y)
neject (Deque (MS z y zs) rs q) = Just (Deque M0 (cons13 (B1 z) B0 zs rs) q, y)

Inductive Back a where
    Back :: !(ThreeStack a b) -> !(SM b) -> Back a

prefix0' :: ThreeStack a b -> SM b -> Back a
prefix0' (Full (NE (Stack (B2 x y) z zs) Empty) xs) q =
    case npush (Both x y) (Deque zs xs q) of
      Deque a c q' -> Back (cons13 B0 z a c) q'
prefix0' (Full (NE (Stack (B2 x y) z zs) (Full r rs)) xs) q =
    case npush (Both x y) (Deque zs (Full (NE r rs) xs) q) of
      Deque a c q' -> Back (cons13 B0 z a c) q'

prefix0 :: ThreeStack a b -> SM b -> Back a
prefix0 (Full (NE (Stack (B1 x) z zs) rs) xs) q =
    case prefix0' xs q of
      Back c q' -> Back (Full (NE (Stack (B1 x) z zs) rs) c) q'
prefix0 x y = prefix0' x y

suffix0' :: ThreeStack a b -> SM b -> Back a
suffix0' (Full (NE (Stack z (B2 x y) zs) Empty) xs) q =
    case ninject (Deque zs xs q) (Both x y) of
       Deque a c q' -> Back (cons13 z B0 a c) q'
suffix0' (Full (NE (Stack z (B2 x y) zs) (Full r rs)) xs) q =
    case ninject (Deque zs (Full (NE r rs) xs) q) (Both x y) of
       Deque a c q' -> Back (cons13 z B0 a c) q'

suffix0 :: ThreeStack a b -> SM b -> Back a
suffix0 (Full (NE (Stack z (B1 x) zs) rs) xs) q =
    case suffix0' xs q of
      Back c q' -> Back (Full (NE (Stack z (B1 x) zs) rs) c) q'
suffix0 x y = suffix0' x y

prefix2' :: ThreeStack a b -> SM b -> Back a
prefix2' (Full (NE (Stack B0 z zs) Empty) xs) q =
    case npop (Deque zs xs q) of
      Just (Both x y,Deque a c q') ->
          Back (cons13 (B2 x y) z a c) q'
prefix2' (Full (NE (Stack B0 z zs) (Full r rs)) xs) q =
    case npop (Deque zs (Full (NE r rs) xs) q) of
      Just (Both x y,Deque a c q') ->
          Back (cons13 (B2 x y) z a c) q'

prefix2 (Full (NE (Stack (B1 x) z zs) rs) xs) q =
    case prefix2' xs q of
      Back c q' ->
          Back (Full (NE (Stack (B1 x) z zs) rs) c) q'
prefix2 x y = prefix2' x y

suffix2' :: ThreeStack a b -> SM b -> Back a
suffix2' (Full (NE (Stack z B0 zs) Empty) xs) q =
    case neject (Deque zs xs q) of
      Just (Deque a c q',Both x y) ->
          Back (cons13 z (B2 x y) a c) q'
suffix2' (Full (NE (Stack z B0 zs) (Full r rs)) xs) q =
    case neject (Deque zs (Full (NE r rs) xs) q) of
      Just (Deque a c q',Both x y) ->
          Back (cons13 z (B2 x y) a c) q'

suffix2 (Full (NE (Stack z (B1 x) zs) rs) xs) q =
    case suffix2' xs q of
      Back c q' ->
          Back (Full (NE (Stack z (B1 x) zs) rs) c) q'
suffix2 x y = suffix2' x y

fixHelp :: (forall a b . ThreeStack a b -> SM b -> Back a) -> Deque t -> Deque t
fixHelp f (Deque b c d) =
    case f c d of
      Back c' d' -> Deque b c' d'

sufpose' :: ThreeStack a b -> Size
sufpose' Empty = Medium
sufpose' (Full (NE (Stack _ B0{} _) _) _) = Small
sufpose' (Full (NE (Stack _ B2{} _) _) _) = Large

sufpose (Deque _ (Full (NE (Stack _ B1{} _) _) x) _) = sufpose' x
sufpose (Deque _ x _) = sufpose' x

push x xs =
    case prepose xs of
      Large -> npush x (fixHelp prefix0 xs)
      _  -> npush x xs

inject xs x =
    case sufpose xs of
      Large -> ninject (fixHelp suffix0 xs) x
      _  -> ninject xs x

pop xs =
    case prepose xs of
      Small -> npop (fixHelp prefix2 xs)
      _ -> npop xs

eject xs =
    case sufpose xs of
      Small -> neject (fixHelp suffix2 xs)
      _ -> neject xs

*)


From iris_ni.program_logic Require Export dwp.
From iris.proofmode Require Import proofmode.
Set Default Proof Using "Type".

Section lifting.
Context `{!irisDG Λ Σ, !invGS Σ}.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → val Λ → iProp Σ.

Lemma dwp_lift_pure_step `{Inhabited (state Λ)} E1 E1' Φ e1 e2 :
  (∀ σ1, reducible e1 σ1) →
  (∀ κ σ1 e1' σ1' efs1, prim_step e1 σ1 κ e1' σ1' efs1 → κ = [] ∧ σ1' = σ1) →
  (∀ σ2, reducible e2 σ2) →
  (∀ κ σ2 e2' σ2' efs2, prim_step e2 σ2 κ e2' σ2' efs2 → κ = [] ∧ σ2' = σ2) →
  (|={E1}[E1']▷=> ∀ κ1 κ2 e1' σ1 efs1 e2' σ2 efs2,
    ⌜prim_step e1 σ1 κ1 e1' σ1 efs1⌝ →
    ⌜prim_step e2 σ2 κ2 e2' σ2 efs2⌝ →
    dwp E1 e1' e2' Φ ∗
    [∗ list] ef1;ef2 ∈ efs1;efs2, dwp ⊤ ef1 ef2 (λ _ _, True ))
  ⊢ dwp E1 e1 e2 Φ.
Proof.
  iIntros (Hsafe1 Hdet1 Hsafe2 Hdet2) "H".
  rewrite (dwp_unfold _ e1 e2) /dwp_pre.
  assert (language.to_val e1 = None) as ->.
  { destruct (Hsafe1 inhabitant) as (?&?&?&?&?).
    eapply val_stuck; eauto. }
  assert (language.to_val e2 = None) as ->.
  { destruct (Hsafe2 inhabitant) as (?&?&?&?&?).
    eapply val_stuck; eauto. }
  iIntros (σ1 σ2 κ1 κs1 κ2 κs2) "Hrel".
  iMod "H" as "H".
  iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver.
  iSplit; first iPureIntro.
  { destruct (Hsafe1 σ1) as (xxx&?&?&?&Hst).
    assert (xxx = []) as ->. { by eapply Hdet1. }
    do 3 eexists. eauto. }
  iSplit; first iPureIntro.
  { destruct (Hsafe2 σ2) as (xxx&?&?&?&Hst).
    assert (xxx = []) as ->. { by eapply Hdet2. }
    do 3 eexists. eauto. }
  iIntros (e1' σ1' efs1 e2' σ2' efs2 Hstep1 Hstep2).
  iModIntro. iNext. iMod "Hclose" as "_".
  iMod "H" as "H".
  assert (σ1' = σ1) as ->.
  { eapply Hdet1. eauto. }
  assert (σ2' = σ2) as ->.
  { eapply Hdet2. eauto. }
  iSpecialize ("H" $! [] [] with "[//] [//]").
  iModIntro. iFrame.
Qed.

Lemma dwp_lift_pure_det_step `{!Inhabited (state Λ)} {E1 E1' Φ}
      e1 e1' e2 e2' efs1 efs2 :
  (∀ σ1, reducible e1 σ1) →
  (∀ κ σ1 e1'' σ1' efs1', prim_step e1 σ1 κ e1'' σ1' efs1' → κ = [] ∧ σ1' = σ1 ∧ e1'' = e1' ∧ efs1' = efs1) →
  (∀ σ2, reducible e2 σ2) →
  (∀ κ σ2 e2'' σ2' efs2', prim_step e2 σ2 κ e2'' σ2' efs2' → κ = [] ∧ σ2' = σ2 ∧ e2'' = e2' ∧ efs2' = efs2) →
  (|={E1}[E1']▷=> dwp E1 e1' e2' Φ ∗
    [∗ list] ef1;ef2 ∈ efs1;efs2, dwp ⊤ ef1 ef2 (λ _ _, True ))
  ⊢ dwp E1 e1 e2 Φ.
Proof.
  iIntros (? Hpuredet1 ? Hpuredet2) "H".
  iApply dwp_lift_pure_step; try done.
  { intros. split; by eapply Hpuredet1. }
  { intros. split; by eapply Hpuredet2. }
  iApply (step_fupd_wand with "H"); iIntros "H".
  iIntros (? ? ? ? ? ? ? ?).
  iIntros ((->&_&->&->)%Hpuredet1 (->&_&->&->)%Hpuredet2).
  iApply "H".
Qed.

Lemma dwp_pure_step_fupd `{!Inhabited (state Λ)} E1 E1' n
      e1 e1' e2 e2' φ1 φ2 Φ :
  PureExec φ1 n e1 e1' →
  PureExec φ2 n e2 e2' →
  φ1 →
  φ2 →
  Nat.iter n (λ P, |={E1}[E1']▷=> P) (dwp E1 e1' e2' Φ)
  ⊢ dwp E1 e1 e2 Φ.
Proof.
  iIntros (Hexec1 Hexec2 Hφ1 Hφ2) "H".
  specialize (Hexec1 Hφ1).
  specialize (Hexec2 Hφ2).
  iInduction Hexec1 as [e1|n e1 e1' e1'' [Hsafe1 ?]] "IH"
     forall (e2 e2' Hexec2); simpl; simpl in Hexec2.
  - by inversion Hexec2.
  - inversion Hexec2 as [|m t2 t2' e2'' [Hsafe2 ?]]. simplify_eq/=.
    iApply dwp_lift_pure_det_step.
    + eauto using reducible_no_obs_reducible.
    + intros σ1 κ e1_ σ1' efs1' Hstep.
      specialize (pure_step_det _ _ _ _ _ Hstep).
      naive_solver.
    + eauto using reducible_no_obs_reducible.
    + intros σ1 κ e1_ σ1' efs1' Hstep.
      specialize (pure_step_det0 _ _ _ _ _ Hstep).
      naive_solver.
    + iApply (step_fupd_wand with "H").
      rewrite big_sepL2_nil. iIntros "H". iSplitL; last done.
      by iApply "IH".
Qed.

Lemma dwp_pure_step_later `{!Inhabited (state Λ)} E1
      e1 e1' e2 e2' n φ1 φ2 Φ :
  PureExec φ1 n e1 e1' →
  PureExec φ2 n e2 e2' →
  φ1 →
  φ2 →
  ▷^n (dwp E1 e1' e2' Φ)
  ⊢ dwp E1 e1 e2 Φ.
Proof.
  intros Hexec1 Hexec2 ??.
  rewrite -(dwp_pure_step_fupd E1 E1) //. clear Hexec1 Hexec2.
  induction n=>// /=.
  by rewrite -(step_fupd_intro E1 E1)// IHn.
Qed.

End lifting.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Cava.Arrow.ArrowExport.

Require Import Coq.Strings.String.
Local Open Scope string_scope.

Require Import Coq.Lists.List Coq.NArith.NArith.
Import ListNotations.

Section notation.
  Import KappaNotation.
  Local Open Scope category_scope.
  Local Open Scope kind_scope.

  Definition halfAdder
  : << Bit, Bit, Unit >> ~> <<Bit, Bit>> :=
    (* The bracket pairing `<[` `]>` opens a circuit expression scope,
    see readme.md for more information *)
  <[ \ a b =>
    let part_sum = xor a b in
    let carry = and a b in
    (part_sum, carry)
  ]>.

  Definition fullAdder
  : << Bit, << Bit, Bit >>, Unit >> ~> <<Bit, Bit>> :=
  <[ \ cin ab =>
    let '(a,b) = ab in
    (* Since 'halfAdder' is in the larger Coq scope, and is not a local variable,
    they must be escaped with ! See the readme.md in this file for more explanation*)
    let '(abl, abh) = !halfAdder a b in
    let '(abcl, abch) = !halfAdder abl cin in
    let cout = xor abh abch in
    (abcl, cout)
  ]>.

  (* Combinators *)
  Definition below {A B C D E F G: Kind}
    (r: << A, B, Unit >> ~> << G, D >>)
    (s: << G, C, Unit >> ~> << F, E >>)
    : << A, <<B, C>>, Unit >> ~> << F, <<D, E>> >> :=
  <[ \ a bc =>
    let '(b, c) = bc in
    let '(g, d) = !r a b in
    let '(f, e) = !s g c in
    (f, (d, e))
  ]>.

  (* Replicate is a type created by replicating a type n times,
  and connecting them by a right imbalanced tuple structure.

  Since the above formulation of 'below' pairs the inputs and outputs
  as a tuple (rather requiring the types are equal and appending as a vector),
  'replicate' allows us to refer to type arrising from multiple
  applications of 'below'.
  *)
  Fixpoint replicate A n : Kind :=
    match n with
    | O => Unit
    | S O => A
    | S n => <<A, replicate A n>>
    end.

  Fixpoint col {A B C: Kind} n
    (circuit: << A, B, Unit >> ~> <<A, C>>)
    {struct n}:
      << A, replicate B (S n), Unit >> ~>
      << A, replicate C (S n)>> :=
    match n with
    | O => <[ \a b => !circuit a b ]>
    | S n' =>
      let column_above := (col n' circuit) in
      below circuit column_above
    end.

  Lemma col_cons: forall {A B C}
    (circuit: << A, B, Unit >> ~> <<A, C>>),
    forall n, col (S n) circuit = below circuit (col n circuit).
  Proof.
    intros.
    auto.
  Qed.

  Fixpoint interleave n
    : << Vector Bit (S n), Vector Bit (S n), Unit >> ~>
      << replicate <<Bit, Bit>> (S n) >> :=
  match n with
  (* Since for n = 0 -> Vector 1 Bit, we have to index into the variables to retrieve their values.
  This is done with familiar 'x[_]' syntax, although numeric constants require prepending with '#'.
  The index can be any expression. See readme.md for more information.
  *)
  | 0 => <[\ x y => (x[#0], y[#0]) ]>
  | S n =>
      <[\ xs ys =>
      let '(x, xs') = uncons xs in
      let '(y, ys') = uncons ys in
      ((x, y), (!(interleave n) xs' ys'))
    ]>
  end.

  (* As noted above, we use 'replicate' to allow us to refer to a tuple structure of a single type of kind.
  It would be convenient to interact with this variable as a vector, and so we can write a conversion
  function : *)
  Fixpoint productToVec n
    : << replicate Bit (S n), Unit >> ~>
      << Vector Bit (S n) >> :=
  match n with
  | 0 => <[\ x => x :: [] ]>
  | S n =>
      <[\ xs =>
      let '(x, xs') = xs in
      x :: !(productToVec n) xs'
    ]>
  end.

  Definition rippleCarryAdder' (width: nat)
    : << Bit, replicate <<Bit, Bit>> (S width), Unit >> ~>
      << Bit, replicate Bit (S width) >> :=
  <[ !(col width fullAdder) ]>.

  Definition rippleCarryAdder (width: nat)
    : << Bit, <<Vector Bit (S width), Vector Bit (S width)>>, Unit >> ~>
      << Bit, Vector Bit (S width) >> :=
  <[ \b xy =>
    let '(x,y) = xy in
    let merged = !(interleave _) x y in
    let '(carry, result) = !(rippleCarryAdder' _) b merged in
    (carry, !(productToVec _) result)
    ]>.

End notation.

Lemma fullAdder_is_combinational: is_combinational (closure_conversion fullAdder).
Proof. simply_combinational. Qed.

Require Import Cava.Netlist.

Definition fullAdderInterface
  := combinationalInterface "fullAdder"
     [mkPort "cin" Signal.Bit; mkPort "a" Signal.Bit; mkPort "b" Signal.Bit]
     [mkPort "sum" Signal.Bit; mkPort "cout" Signal.Bit]
     [].

Definition fullAdder_tb_inputs :=
  [(false, (false, false));
   (false, (true, false));
   (false, (false, true));
   (false, (true, true));
   (true, (false, false));
   (true, (true, false));
   (true, (false, true));
   (true, (true, true))
].

Definition fullAdder_netlist :=
  build_netlist (closure_conversion fullAdder) "fullAdder" ("cin", ("a", "b")) ("sum", "cout").

Definition fullAdder_tb_expected_outputs  : list (bool * bool)
  := (List.map (fun i => combinational_evaluation (closure_conversion fullAdder) i) fullAdder_tb_inputs) .

Definition fullAdder_tb :=
  testBench "fullAdder_tb" fullAdderInterface
            (map (fun '(a,(b,c)) => (a,b,c)) fullAdder_tb_inputs) fullAdder_tb_expected_outputs.