From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
From Categories Require Import Functor.Functor_Extender.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations
        Ext_Cons.Prod_Cat.Nat_Facts.
From Categories Require Import Adjunction.Adjunction.
From Categories Require Import KanExt.Local.
From Categories Require Import Basic_Cons.Terminal.

Local Open Scope functor_scope.

(** This module contains conversion from local kan extensions defined through
    hom functor to local kan extensions defined through cones. *)
Section Hom_Local_Right_KanExt_to_Local_Right_KanExt.
  Context {C C' : Category} {p : C –≻ C'}
          {D : Category} {F : C –≻ D}
          (hlrke : Hom_Local_Right_KanExt p F).

  (** The cone that is the kan extension. *)
  Definition Hom_Local_Right_KanExt_to_Local_Right_KanExt_Terminal_Cone :
    LoKan_Cone p F :=
    {|
      cone_apex := hlrke;
      cone_edge :=
        Trans (inverse_morphism (HLRKE_Iso hlrke)) hlrke (NatTrans_id hlrke)
    |}.

  (** The cone we just constructed is (as we will prove) the local kan
      extension and thus the terminal cone. So we abbreviate it as TCONE. *)
  Local Notation TCONE :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt_Terminal_Cone (only parsing).

  (** Given a cone Cn, we construct a cone morph from Cn to the cone that is the
local kan extension. *)
  Section Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone.
    Context (Cn : LoKan_Cone p F).

    Program Definition
            Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone :
      LoKan_Cone_Morph Cn TCONE :=
      {|
        cone_morph := Trans (iso_morphism (HLRKE_Iso hlrke)) Cn Cn
      |}.

    Next Obligation.
    Proof.
      set (W :=
             f_equal (
                 fun w :
                       (((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ F (Hom_Func _))
                             ∘ (Left_Functor_Extender p D)^op)
                         –≻ ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ F (Hom_Func _))
                            ∘ (Left_Functor_Extender p D)^op
                         ))%nattrans =>
                   Trans w Cn
               ) (left_inverse (HLRKE_Iso hlrke))).
      cbn in W.
      match goal with
        [|- ?A = ?B] =>
        match type of W with
          ?X = _ =>
          cut (X A = X B); simpl;
            [rewrite (equal_f W A); rewrite (equal_f W B); trivial|clear W]
        end
      end.
      apply f_equal.
      set (M :=
             equal_f
               (@Trans_com _ _ _ _
                           (iso_morphism (HLRKE_Iso hlrke))
                           hlrke
                           Cn
                           (Trans (iso_morphism (HLRKE_Iso hlrke)) Cn Cn)
               )
               (Trans (inverse_morphism (HLRKE_Iso hlrke))
                      hlrke (NatTrans_id hlrke))).
      cbn in M.
      repeat rewrite NatTrans_id_unit_left in M.
      rewrite M; clear M.
      apply NatTrans_eq_simplify; extensionality x; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ hlrke (Hom_Func _))
                      –≻ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ hlrke (Hom_Func _))
                   )%nattrans
             => Trans w hlrke (NatTrans_id _)
            )
            (right_inverse (HLRKE_Iso hlrke))
        ).
      cbn; auto.
    Qed.

  End Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone.

  (** We show that any two cone morphs to TCONE (see above) are equal. *)
  Section
    Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone_unique.
    Context {Cn : LoKan_Cone p F} (h h' : LoKan_Cone_Morph Cn TCONE).

    Theorem
      Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone_unique
      : h = h' :> (_ –≻ _)%nattrans.
    Proof.
      set (Mh :=
             equal_f
               (@Trans_com _ _ _ _ (iso_morphism (HLRKE_Iso hlrke)) hlrke Cn h)
               (Trans (inverse_morphism (HLRKE_Iso hlrke))
                      hlrke (NatTrans_id hlrke))
          ).
      set (Mh' :=
             equal_f
               (@Trans_com _ _ _ _ (iso_morphism (HLRKE_Iso hlrke)) hlrke Cn h')
               (Trans (inverse_morphism
                         (HLRKE_Iso hlrke)) hlrke (NatTrans_id hlrke))
          ).
      cbn in Mh, Mh'.
      cbn_rewrite ((f_equal
                      (fun w :
                           ((@Fix_Bi_Func_2
                               _ (Func_Cat _ _) _ hlrke (Hom_Func _))
                              –≻ (@Fix_Bi_Func_2
                                    _ (Func_Cat _ _) _ hlrke (Hom_Func _))
                           )%nattrans
                       => Trans w hlrke (NatTrans_id _))
                      (right_inverse (HLRKE_Iso hlrke)))) in Mh Mh'.
      repeat rewrite NatTrans_id_unit_left in Mh, Mh'.
      destruct Mh; destruct Mh'.
      apply f_equal.
      etransitivity;
        [symmetry; apply (cone_morph_com h) | apply (cone_morph_com h')].
    Qed.

  End
    Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone_unique.

  (** Conversion from Hom_Local_Right_KanExt to Local_Right_KanExt. *)
  Definition Hom_Local_Right_KanExt_to_Local_Right_KanExt :
    Local_Right_KanExt p F :=
    {|
      LRKE := TCONE;
      LRKE_morph_ex :=
        Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone;
      LRKE_morph_unique :=
        @Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone_unique
    |}.

End Hom_Local_Right_KanExt_to_Local_Right_KanExt.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Tactics.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_not ===== *)

Definition bit_blast_not1 (g: generator) (l:literal) : generator * cnf * literal :=
  let (g', r):= gen g in
  let cs := [::
        [:: r; l]; [:: neg_lit r; neg_lit l]
            ] in (g', cs , r).

Fixpoint bit_blast_not g ls : generator * cnf * word :=
  match ls with
  | [::] => (g, [::], [::])
  | hd :: tl =>
    let '(g_hd, cs_hd, lrs_hd) := bit_blast_not1 g hd in
    let '(g_tl, cs_tl, lrs_tl) := bit_blast_not g_hd tl in
    (g_tl, catrev cs_hd cs_tl, lrs_hd :: lrs_tl)
  end.

Definition mk_env_not1 E g l : env * generator * cnf * literal :=
  let (g', r) := gen g in
  let E' := env_upd E (var_of_lit r) (~~ (interp_lit E l)) in
  let cs := [:: [:: r; l]; [:: neg_lit r; neg_lit l]] in
  (E', g', cs, r).

Fixpoint mk_env_not E g ls : env * generator * cnf * word :=
  match ls with
  | [::] => (E, g, [::], [::])
  | hd :: tl =>
    let '(E_hd, g_hd, cs_hd, lrs_hd) := mk_env_not1 E g hd in
    let '(E_tl, g_tl, cs_tl, lrs_tl) := mk_env_not E_hd g_hd tl in
    (E_tl, g_tl, catrev cs_hd cs_tl, lrs_hd :: lrs_tl)
  end.

Lemma bit_blast_not_size_ss :
  forall ls g g' (cs: cnf) (lrs: seq literal),
    bit_blast_not g ls = (g', cs, lrs) ->
    size ls = size lrs.
Proof.
  move => ls.
  elim : ls=> [| ls_hd ls_tl IH] g g' cs lrs.
  - by case => _ _ <-.
  - rewrite /=. case Hbbnot : (bit_blast_not (g + 1)%positive ls_tl) => [[gnot csnot] lrsnot].
    case => _ _ <-. move : (IH _ _ _ _ Hbbnot) => Hszeq.
    by rewrite Hszeq /=.
Qed.

Lemma bit_blast_not1_correct g b br E l g' cs lr :
    bit_blast_not1 g l = (g', cs, lr) ->
    enc_bit E l b ->
    interp_cnf E (add_prelude cs) ->
    br = ~~ b ->
    enc_bit E lr br.
Proof.
  rewrite /bit_blast_not1 /enc_bit. case=> _ <- <- /=.
  rewrite add_prelude_expand /= interp_lit_neg_lit /=. move/eqP ->.
  move/andP => [Htt Hcs] ->; t_clear.
  move: Hcs. by case (E g); case b.
Qed.

Lemma bit_blast_not_correct g bs E ls g' cs lrs:
    bit_blast_not g ls = (g', cs, lrs) ->
    enc_bits E ls bs ->
    interp_cnf E (add_prelude cs) ->
    enc_bits E lrs (invB bs).
Proof.
  elim: ls g bs E g' cs lrs.
  - move=> g bs E g' cs lr /=. case=> _ <- <- /=.
    rewrite enc_bits_nil_l. move/eqP ->. done.
  - move=> ls_hd ls_tl IH g bs E g' cs lrs.
    rewrite /bit_blast_not -/bit_blast_not.
    case Hbb_hd : (bit_blast_not1 g ls_hd) => [[g_hd cs_hd] lrs_hd].
    case Hbb_tl : (bit_blast_not g_hd ls_tl) => [[g_tl cs_tl] lrs_tl].
    case=> _ <- <-. case: bs => [| bs_hd bs_tl] //=.
    rewrite !enc_bits_cons add_prelude_catrev.
    move => /andP [Henc_hd Henc_tl] /andP [Hi_hd Hi_tl].
    rewrite (bit_blast_not1_correct Hbb_hd Henc_hd Hi_hd) /=; try done.
    exact: (IH _ _ _ _ _ _ Hbb_tl Henc_tl Hi_tl).
Qed.

Lemma mk_env_not1_is_bit_blast_not1 E g l E' g' cs lr:
    mk_env_not1 E g l = (E', g', cs, lr) ->
    bit_blast_not1 g l = (g', cs, lr).
Proof.
  rewrite /mk_env_not1 /bit_blast_not1; intros;
    dite_hyps; dcase_hyps; subst; reflexivity.
Qed.

Lemma mk_env_not_is_bit_blast_not E g ls E' g' cs lrs:
    mk_env_not E g ls = (E', g', cs, lrs) ->
    bit_blast_not g ls = (g', cs, lrs).
Proof.
  elim: ls E g E' g' cs lrs => [| ls_hd ls_tl IH] E g E' g' cs lrs.
  - by case=> _ <- <- <-.
  - rewrite /bit_blast_not -/bit_blast_not /mk_env_not -/mk_env_not.
    case Hmk_hd : (mk_env_not1 E g ls_hd) => [[[E_hd g_hd] cs_hd] lrs_hd].
    case Hmk_tl : (mk_env_not E_hd g_hd ls_tl) => [[[E_tl g_tl] cs_tl] lrs_tl].
    rewrite (mk_env_not1_is_bit_blast_not1 Hmk_hd).
    rewrite (IH _ _ _ _ _ _ Hmk_tl).
    by case=> _ <- <- <-.
Qed.

Lemma mk_env_not1_newer_gen E g l E' g' cs lr:
    mk_env_not1 E g l = (E', g', cs, lr) ->
    (g <=? g')%positive.
Proof.
  rewrite /mk_env_not1 /=. case=> _ <- _ _.
  by t_auto_newer.
Qed.

Lemma mk_env_not_newer_gen E g ls E' g' cs lrs:
    mk_env_not E g ls = (E', g', cs, lrs) ->
    (g <=? g')%positive.
Proof.
  elim: ls E g E' g' cs lrs => [| ls_hd ls_tl IH] E g E' g' cs lrs.
  - case=> _ <- _ _; by t_auto_newer.
  - rewrite /mk_env_not -/mk_env_not.
    case Hmk_hd : (mk_env_not1 E g ls_hd) => [[[E_hd g_hd] cs_hd] lrs_hd].
    case Hmk_tl : (mk_env_not E_hd g_hd ls_tl) => [[[E_tl g_tl] cs_tl] lrs_tl].
    case=> _ <- _ _.
    move: (mk_env_not1_newer_gen Hmk_hd) => Hggh.
    move: (IH _ _ _ _ _ _ Hmk_tl) => Hghgt.
    by apply: (pos_leb_trans Hggh Hghgt).
Qed.

Lemma mk_env_not1_newer_res E g l E' g' cs lr:
    mk_env_not1 E g l = (E', g', cs, lr) ->
    newer_than_lit g l ->
    newer_than_lit g' lr.
Proof.
  rewrite /mk_env_not1 /=. case=> _ <- _ <-.
  by t_auto_newer.
Qed.

Lemma mk_env_not_newer_res E g ls E' g' cs lrs:
    mk_env_not E g ls = (E', g', cs, lrs) ->
    newer_than_lits g ls ->
    newer_than_lits g' lrs.
Proof.
  elim: ls E g E' g' cs lrs => [| ls_hd ls_tl IH] E g E' g' cs lrs.
  - case=> _ <- _ <-; by t_auto_newer.
  - rewrite /mk_env_not -/mk_env_not.
    case Hmk_hd : (mk_env_not1 E g ls_hd) => [[[E_hd g_hd] cs_hd] lrs_hd].
    case Hmk_tl : (mk_env_not E_hd g_hd ls_tl) => [[[E_tl g_tl] cs_tl] lrs_tl].
    case=> _ <- _ <- /=.
    move/andP => [Hglh Hglt].
    move: (mk_env_not1_newer_gen Hmk_hd) => Hggh.
    move: (mk_env_not_newer_gen Hmk_tl) => Hghgt.
    move: (mk_env_not1_newer_res Hmk_hd Hglh) => Hghlrh.
    apply/andP; split.
    + by apply (newer_than_lit_le_newer Hghlrh).
    + move: (newer_than_lits_le_newer Hglt Hggh) => Hghlt.
      exact: (IH _ _ _ _ _ _ Hmk_tl Hghlt).
Qed.

Lemma mk_env_not1_newer_cnf E g l E' g' cs lr:
    mk_env_not1 E g l = (E', g', cs, lr) ->
    newer_than_lit g l ->
    newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_not1 /=. case=> _ <- <- _.
  by t_auto_newer.
Qed.

Lemma mk_env_not_newer_cnf E g ls E' g' cs lrs:
    mk_env_not E g ls = (E', g', cs, lrs) ->
    newer_than_lits g ls ->
    newer_than_cnf g' cs.
Proof.
  elim: ls E g E' g' cs lrs => [| ls_hd ls_tl IH] E g E' g' cs lrs.
  - case=> _ <- <- _; by t_auto_newer.
  - rewrite /mk_env_not -/mk_env_not.
    case Hmk_hd : (mk_env_not1 E g ls_hd) => [[[E_hd g_hd] cs_hd] lrs_hd].
    case Hmk_tl : (mk_env_not E_hd g_hd ls_tl) => [[[E_tl g_tl] cs_tl] lrs_tl].
    case=> _ <- <- _ /=. move/andP => [Hglh Hglt].
    rewrite newer_than_cnf_catrev.
    move: (mk_env_not_newer_gen Hmk_tl) => Hghgt.
    apply/andP; split.
    + move: (mk_env_not1_newer_cnf Hmk_hd Hglh) => Hghch.
      by apply (newer_than_cnf_le_newer Hghch).
    + move: (mk_env_not1_newer_gen Hmk_hd) => Hggh.
      move: (newer_than_lits_le_newer Hglt Hggh) => Hghlt.
      exact: (IH _ _ _ _ _ _ Hmk_tl Hghlt).
Qed.

Lemma mk_env_not1_preserve E g l E' g' cs lr:
    mk_env_not1 E g l = (E', g', cs, lr) ->
    env_preserve E E' g.
Proof.
  rewrite /mk_env_not1 /=. case=> <- _ _ _.
  by t_auto_preserve.
Qed.

Lemma mk_env_not_preserve E g ls E' g' cs lrs:
    mk_env_not E g ls = (E', g', cs, lrs) ->
    env_preserve E E' g.
Proof.
  elim: ls E g E' g' cs lrs => [| ls_hd ls_tl IH] E g E' g' cs lrs.
  - case=> <- _ _ _; by t_auto_preserve.
  - rewrite /mk_env_not -/mk_env_not.
    case Hmk_hd : (mk_env_not1 E g ls_hd) => [[[E_hd g_hd] cs_hd] lrs_hd].
    case Hmk_tl : (mk_env_not E_hd g_hd ls_tl) => [[[E_tl g_tl] cs_tl] lrs_tl].
    case=> <- _ _ _ /=.
    move: (mk_env_not1_preserve Hmk_hd) => HEEhg.
    move: (IH _ _ _ _ _ _ Hmk_tl) => HEhEtgh.
    move: (mk_env_not1_newer_gen Hmk_hd) => Hggh.
    apply (env_preserve_trans HEEhg).
    exact: (env_preserve_le HEhEtgh Hggh).
Qed.

Lemma mk_env_not1_sat E g l E' g' cs lr:
    mk_env_not1 E g l = (E', g', cs, lr) ->
    newer_than_lit g l ->
    interp_cnf E' cs.
Proof.
  rewrite /mk_env_not1 /=. case=> <- _ <- _ Hgl.
  move: (newer_than_lit_neq Hgl) => Hngl /=.
  rewrite !env_upd_eq !interp_lit_neg_lit.
  rewrite (interp_lit_env_upd_neq _ _ Hngl).
  by case (interp_lit E l).
Qed.

Lemma mk_env_not_sat E g ls E' g' cs lrs:
    mk_env_not E g ls = (E', g', cs, lrs) ->
    newer_than_lits g ls ->
    interp_cnf E' cs.
Proof.
  elim: ls E g E' g' cs lrs => [| ls_hd ls_tl IH] E g E' g' cs lrs.
  - by case=> <- _ <- _.
  - rewrite /mk_env_not -/mk_env_not.
    case Hmk_hd : (mk_env_not1 E g ls_hd) => [[[E_hd g_hd] cs_hd] lrs_hd].
    case Hmk_tl : (mk_env_not E_hd g_hd ls_tl) => [[[E_tl g_tl] cs_tl] lrs_tl].
    case=> <- _ <- _ /=. move/andP => [Hglh Hglt].
    rewrite interp_cnf_catrev; apply/andP; split.
    + move: (mk_env_not_preserve Hmk_tl) => HpEhEtgh.
      move: (mk_env_not1_newer_cnf Hmk_hd Hglh) => Hghch.
      rewrite (env_preserve_cnf HpEhEtgh Hghch).
      exact: (mk_env_not1_sat Hmk_hd Hglh).
    + apply: (IH _ _ _ _ _ _ Hmk_tl).
      move: (mk_env_not1_newer_gen Hmk_hd).
      by apply: newer_than_lits_le_newer.
Qed.

Lemma mk_env_not_env_equal E1 E2 g ls E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_not E1 g ls = (E1', g1', cs1, lrs1) ->
  mk_env_not E2 g ls = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  elim: ls E1 E2 g E1' E2' g1' g2' cs1 cs2 lrs1 lrs2
  => [| l ls IH] //= E1 E2 g E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 Heq.
  - case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
  - dcase (mk_env_not (env_upd E1 g (~~ interp_lit E1 l)) (g + 1)%positive ls)
    => [[[[Etl1 gtl1] cstl1] lrstl1] Htl1].
    dcase (mk_env_not (env_upd E2 g (~~ interp_lit E2 l)) (g + 1)%positive ls)
    => [[[[Etl2 gtl2] cstl2] lrstl2] Htl2].
    case=> ? ? ? ?; case=> ? ? ? ?; subst.
    have Heq': env_equal (env_upd E1 g (~~ interp_lit E1 l))
                         (env_upd E2 g (~~ interp_lit E2 l)).
    { rewrite (env_equal_interp_lit l Heq). apply: env_equal_upd. assumption. }
    move: (IH _ _ _ _ _ _ _ _ _ _ _ Heq' Htl1 Htl2) => [H1 [H2 [H3 H4]]]; subst.
    done.
Qed.


(* Copyright (c) 2008, Harvard University
 * All rights reserved.
 *
 * Author: Ryan Wisnesky
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

Module BinaryTree.

 (* The modelling type is a binary tree. *)
 Fixpoint btree (A : Set) (n: nat) : Set :=
   match n with
     | 0 => A
     | S n' => prod (btree A n') (btree A n')
   end.

End BinaryTree.

Module Type BINOMIAL_TREE.

 Module BT := BinaryTree.
 Import BT.

 Require Export Ynot.
 Open Scope hprop_scope.
 Open Scope stsepi_scope.

 Parameter A   : Set.

 Parameter t   : Set.
 Parameter rep : forall n, btree A n -> t -> hprop.

 Parameter new : forall (a: A), STsep __ (rep O a).

 Parameter free: forall p,
   STsep (Exists a :@ A, rep O a p) (fun _:unit => __).

 Parameter asbtree: forall n (bt: [btree A n]) p,
   STsep (bt ~~ rep n bt p) (fun r => bt ~~ rep n bt p * [r = bt]).

 Parameter merge: forall p1 p2 n (bt1 bt2: [btree A n]),
   STsep (bt1 ~~ bt2 ~~ rep n bt1 p1 * rep n bt2 p2)
         (fun r:unit => bt1 ~~ bt2 ~~ rep (S n) (bt1, bt2) p2).

 Parameter split: forall n (bt: [btree A (S n)]) p,
  STsep (bt ~~ rep (S n) bt p)
        (fun r => bt ~~ rep n (snd bt) p * rep n (fst bt) r).

End BINOMIAL_TREE.

Module BinomialTree : BINOMIAL_TREE.
 Module BT := BinaryTree.
 Import BT.
 Require Export Ynot.

 Parameter A: Set.

 Open Scope hprop_scope.
 Open Scope stsepi_scope.

 (* Representation *)

 Definition t := ptr.

(*  A binomial tree is defined recursively:
     - a tree of order 0 is a single node
     - a tree of order k has a root node whose children are
       roots of binomial trees of orders k-1, k-2... 1, 0,
       in this order. *)

 Fixpoint bltree (n: nat) : Set :=
   match n with
     | 0 => A
     | S n' => prod ptr (bltree n')
   end.

  Notation "'kids'" := snd.
  Notation "'head'" := fst.

  Fixpoint rep' n :      btree A n -> bltree n -> hprop :=
   match n   as n return btree A n -> bltree n -> hprop with
    | O    => fun a a' => [a = a']
    | S n' => fun bt bl => rep' n' (kids bt) (kids bl) *
                Exists bl' :@ bltree n', head bl --> bl' * rep' n' (head bt) bl'
   end.

  Definition rep (n: nat) (bt: btree A n) (p: ptr) : hprop :=
    Exists bl :@ bltree n, p --> bl * rep' n bt bl.

 (* Reasoning *)

  Ltac simplr := unfold rep; unfold rep'; try match goal with
                                     | [ h : (?a, ?b) = (?c, ?d) |- _ ] =>
                                       let y := fresh "y" in
                                       let z := fresh "z" in
                                         assert (a = c); try congruence; subst;
                                         assert (b = d); try congruence; subst; clear h
                                   end; simpl in *.
 Ltac t := solve [ repeat (simplr; sep fail auto) | match goal with [n: nat |- _ ] => destruct n; repeat (simplr; sep fail auto) end].
 Ltac f := fold rep'; fold rep.

(* Implementation *)

 Definition new : forall hd, STsep __ (rep O hd).
  intros. refine ( {{ New hd }} ). sep fail auto. t. Qed.

 Definition free p : STsep (Exists a :@ A, rep O a p) (fun _:unit => __).
  intros. refine ( Assert (Exists a :@ A, p --> a) ;;
                   {{ Free p }}); t. Qed.

(* Merging is attaching one tree as the leftmost child of the other.
   This spec, which updates in place, requires strong update, because the type
   of the node changes (it increases by one level) *)
Definition merge : forall p1 p2 n (bt1 bt2: [btree A n]),
 STsep (bt1 ~~ bt2 ~~ rep n bt1 p1 * rep n bt2 p2)
       (fun r:unit => bt1 ~~ bt2 ~~ rep (S n) (bt1, bt2) p2).
 intros p1 p2. refine (fun n bt1 bt2 =>
   oldp2node <- ! p2 ;
   Assert (bt1 ~~ bt2 ~~ rep n bt1 p1 * p2 --> oldp2node * rep' n bt2 oldp2node) ;;
   {{ p2 ::= (p1, oldp2node) }} ); t. Qed.

(* had to use SepRead here *)
Definition split: forall n (bt: [btree A (S n)]) p,
  STsep (bt ~~ rep (S n) bt p)
        (fun r => bt ~~ rep n (snd bt) p * rep n (fst bt) r).
 refine (fun n bt p => bl <- (p !! (fun bl => bt ~~ rep' (S n) bt bl))%stsep  ;
                       p ::= kids bl ;;
                       {{ Return (head bl) }}); t. Qed.

(* n is not computationally irrelevent *)

(* had to use SepRead here *)
Definition asbtree' : forall n (bt: [btree A n]) (bl: bltree n),
  STsep (bt ~~ rep' n bt bl) (fun r => bt ~~ rep' n bt bl * [r = bt]).
refine (fix F (n: nat) {struct n} : forall bt bl, STsep (bt ~~ rep' n bt bl) (fun r => bt ~~ rep' n bt bl * [r = bt]) :=
          match n as n return       forall (bt: [btree A n]) (bl: bltree n), STsep (bt ~~ rep' n bt bl) (fun r => bt ~~ rep' n bt bl * [r = bt])  with
              | O    => fun bt bl => {{ SepReturn bl <@> _  }}
              | S n' => fun bt bl => x   <- ((head bl) !! (fun (x:bltree n') => bt ~~ rep' n' (kids bt) (kids bl)* rep' n' (head bt) x))%stsep ;
                                     bth <- F n' (bt ~~~ head bt) x         <@> (bt ~~ head bl --> x * rep' n' (kids bt) (kids bl))   ;
                                     btk <- F n' (bt ~~~ kids bt) (kids bl) <@> (bt ~~ head bl --> x * rep' n' (head bt) x * [bth = head bt])  ;
                                     {{ SepReturn (bth, btk) <@> _ }}

            end); t. Qed.

Definition asbtree n (bt: [btree A n]) (p: ptr) :
  STsep (bt ~~ rep n bt p) (fun r: btree A n => bt ~~ rep n bt p * [r = bt]).
 intros. refine ( x <- ! p;
                  {{ asbtree' n bt x <@> p --> x }} ); t. Qed.

End BinomialTree.


(***************************************************************************
* Safety for Lambda Mu Mutilde (CBV) - Infrastructure                      *
* Étienne Miquey, June 2015                                                *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.
Require Import  L_Core_Definitions
        L_Core_Infrastructure
        L_Core_Soundness.

 Open Scope list_scope.

(* List Notations *)
Notation  "[ a ]" := (a::nil).
Notation  "[ ]" := (@nil _).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(*Print typ.
Implicit Types x : var.

(** Grammar of types. *)

Inductive typ : Set :=
| typ_var   : var -> typ
| typ_arrow : typ -> typ -> typ
| typ_mu :  typ.

(* Inductive cotyp : Set :=
 | neg : typ -> cotyp.
 *)

 Inductive ltyp : Set :=
 | pos: typ -> ltyp
 | neg: typ -> ltyp.
(*
| cotyp_var : var -> cotyp
| cotyp_arrow : typ -> cotyp -> cotyp
| cotyp_mut : cotyp.
*)
*)
(** Grammar of pre-terms. *)

Inductive sprf : Type :=
| sprf_bvar : nat -> sprf (* bound variable in de Bruijn style *)
| sprf_fvar : var -> sprf (* free variable in named style *)
| sprf_abs  : sprf -> sprf
| sprf_mu  :  sclos-> sprf
with scont:Type :=
| sco_bvar: nat -> scont
| sco_fvar: var -> scont
| sco_stack : sprf -> scont -> scont
| sco_mut : sclos -> scont
with store:Type :=
| st : LibEnv.env sprf -> store
with sclos:Type :=
| scl : sprf -> scont -> store -> sclos.

(** Opening up abstractions / mutilde *)

Fixpoint open_rec_sprf_sprf (k : nat) (p : sprf) (q : sprf) {struct p} : sprf :=
  match p with
    | sprf_bvar i    => If k = i then q else (sprf_bvar i)
    | sprf_fvar a    => sprf_fvar a
    | sprf_abs p1    => sprf_abs (open_rec_sprf_sprf (S k) p1 q)
    | sprf_mu c  => sprf_mu (open_rec_sclos_sprf k c q)
end
with open_rec_scont_sprf (k:nat) (e:scont) (q:sprf) {struct e} : scont :=
   match e with
     | sco_stack p e => sco_stack (open_rec_sprf_sprf k p q) (open_rec_scont_sprf k e q)
     | sco_mut c => sco_mut (open_rec_sclos_sprf (S k) c q)
     | sco_bvar i=> sco_bvar i
     | sco_fvar a=> sco_fvar a
   end
with open_rec_store_sprf (k:nat) (tau:store) (q:sprf) {struct tau}: store :=
   match tau with
     | st l => st (List.map (fun (t:var*sprf) => let (a,p):= t in (a,open_rec_sprf_sprf k p q)) l)
   end
with open_rec_sclos_sprf (k:nat) (c:sclos) (q:sprf) {struct c} : sclos :=
   match c with
     | scl p e tau => scl (open_rec_sprf_sprf k p q) (open_rec_scont_sprf k e q) (open_rec_store_sprf k tau q)
   end.

Definition open_sprf_sprf p q := open_rec_sprf_sprf 0 p q.
Definition open_scont_sprf e q := open_rec_scont_sprf 0 e q.
Definition open_sclos_sprf c q := open_rec_sclos_sprf 0 c q.
Definition open_store_sprf tau q := open_rec_store_sprf 0 tau q.
Definition open_sprf_sprf_var p x := open_rec_sprf_sprf 0 p (sprf_fvar x).
Definition open_scont_sprf_var e x := open_rec_scont_sprf 0 e (sprf_fvar x).
Definition open_sclos_sprf_var c x := open_rec_sclos_sprf 0 c (sprf_fvar x).
Definition open_store_sprf_var tau x := open_rec_store_sprf 0 tau (sprf_fvar x).

Notation "{ k ~+> q }+ p" := (open_rec_sprf_sprf k p q) (at level 67).
Notation "{ k ~+> q }- e" := (open_rec_scont_sprf k e q) (at level 67).
Notation "{ k ~+> q }* c" := (open_rec_sclos_sprf k c q) (at level 67).
Notation "{ k ~+> q } tau" := (open_rec_store_sprf k tau q) (at level 67).
Notation "p +^^+ q" := (open_sprf_sprf p q) (at level 67).
Notation "e -^^+ q" := (open_scont_sprf e q) (at level 67).
Notation "c *^^+ q" := (open_sclos_sprf c q) (at level 67).
Notation "tau ^^+ q" := (open_store_sprf tau q) (at level 67).
Notation "p +^+ a" := (open_sprf_sprf p (sprf_fvar a)) (at level 67).
Notation "e -^+ a" := (open_scont_sprf e (sprf_fvar a)) (at level 67).
Notation "c *^+ a" := (open_sclos_sprf c (sprf_fvar a)) (at level 67).
Notation "tau ^+ a" := (open_store_sprf tau (sprf_fvar a)) (at level 67).

Lemma open_sprf_sprf_def p q: p +^^+q = {0 ~+> q}+ p.
Proof. unfolds* open_sprf_sprf. Qed.
Lemma open_scont_sprf_def e q: e -^^+q = {0 ~+> q}- e.
Proof. unfolds* open_scont_sprf. Qed.
Lemma open_sclos_sprf_def c q: c *^^+q= {0 ~+> q}* c.
Proof. unfolds* open_sclos_sprf. Qed.
Lemma open_store_sprf_def tau q: tau ^^+q= {0 ~+> q} tau.
Proof. unfolds* open_store_sprf. Qed.
Lemma open_sprf_sprf_var_def p y: p +^+y = {0 ~+> sprf_fvar y}+ p.
Proof. unfolds* open_sprf_sprf. Qed.
Lemma open_scont_sprf_var_def e y: e -^+y = {0 ~+> sprf_fvar y}- e.
Proof. unfolds* open_scont_sprf. Qed.
Lemma open_sclos_sprf_var_def c y: c *^+y = {0 ~+> sprf_fvar y}* c.
Proof. unfolds* open_sclos_sprf. Qed.
Lemma open_store_sprf_var_def tau y: tau ^+y = {0 ~+> sprf_fvar y} tau.
Proof. unfolds* open_store_sprf. Qed.

(** Opening up mu *)

Fixpoint open_rec_sprf_scont (k : nat) (p : sprf) (e : scont) {struct p} : sprf :=
  match p with
    | sprf_bvar i    => sprf_bvar i
    | sprf_fvar a    => sprf_fvar a
    | sprf_abs p1    => sprf_abs (open_rec_sprf_scont (k) p1 e)
    | sprf_mu c  => sprf_mu (open_rec_sclos_scont (S k) c e)
end
with open_rec_scont_scont (k:nat) (e:scont) (f:scont) {struct e} : scont :=
  match e with
     | sco_bvar i=> If i=k then f else (sco_bvar i)
     | sco_fvar a=> sco_fvar a
     | sco_stack p e' => sco_stack (open_rec_sprf_scont k p f) (open_rec_scont_scont k e' f)
     | sco_mut c => sco_mut (open_rec_sclos_scont k c f)
end
with open_rec_store_scont (k:nat) (tau:store) (f:scont) {struct tau}: store :=
   match tau with
     | st l => st (List.map (fun (t:var*sprf) => let (a,p):=t in (a,open_rec_sprf_scont k p f)) l)
   end
with open_rec_sclos_scont (k:nat) (c:sclos) (f:scont) {struct c} : sclos :=
   match c with
     | scl p e tau=> scl (open_rec_sprf_scont k p f) (open_rec_scont_scont k e f) (open_rec_store_scont k tau f)
   end.

Definition open_sprf_scont p f := open_rec_sprf_scont 0 p f.
Definition open_scont_scont e f := open_rec_scont_scont 0 e f.
Definition open_sclos_scont c f := open_rec_sclos_scont 0 c f.
Definition open_store_scont tau f := open_rec_store_scont 0 tau f.

Notation "{ k ~-> f }+ p" := (open_rec_sprf_scont k p f) (at level 67).
Notation "{ k ~-> f }- e" := (open_rec_scont_scont k e f) (at level 67).
Notation "{ k ~-> f }* c" := (open_rec_sclos_scont k c f) (at level 67).
Notation "{ k ~-> f } tau" := (open_rec_store_scont k tau f) (at level 67).
Notation "p +^^- f" := (open_sprf_scont p f) (at level 67).
Notation "e -^^- f" := (open_scont_scont e f) (at level 67).
Notation "c *^^- f" := (open_sclos_scont c f) (at level 67).
Notation "tau ^^- f" := (open_store_scont tau f) (at level 67).
Notation "p +^- a" := (open_sprf_scont p (sco_fvar a)) (at level 67).
Notation "e -^- a" := (open_scont_scont e (sco_fvar a)) (at level 67).
Notation "c *^- a" := (open_sclos_scont c (sco_fvar a)) (at level 67).
Notation "tau ^- a" := (open_store_scont tau (sco_fvar a)) (at level 67).

Lemma open_sprf_scont_def p f: p +^^-f = {0 ~-> f}+ p.
Proof. unfolds* open_sprf_scont. Qed.
Lemma open_scont_scont_def e f: e -^^-f = {0 ~-> f}- e.
Proof. unfolds* open_scont_scont. Qed.
Lemma open_sclos_scont_def c f: c *^^-f = {0 ~-> f}* c.
Proof. unfolds* open_sclos_scont. Qed.
Lemma open_store_scont_def tau f: tau ^^-f = {0 ~-> f} tau.
Proof. unfolds* open_store_scont. Qed.
Lemma open_sprf_scont_var_def p y: p +^-y = {0 ~-> sco_fvar y}+ p.
Proof. unfolds* open_sprf_scont. Qed.
Lemma open_scont_scont_var_def e y: e -^-y = {0 ~-> sco_fvar y}- e.
Proof. unfolds* open_scont_scont. Qed.
Lemma open_sclos_scont_var_def c y: c *^-y = {0 ~-> sco_fvar y}* c.
Proof. unfolds* open_sclos_scont. Qed.
Lemma open_store_scont_var_def tau y: tau ^-y = {0 ~-> sco_fvar y} tau.
Proof. unfolds* open_store_scont. Qed.

(** Substitution for names *)

(* substitute z in p by q *)

(*Definition subst_prf_store (a:var) (p:sprf)

Fixpoint subst_store (c:sclos) {struct c} : clos :=
  match c with
    |scl p e (st l) =>
     match l with
         | nil  => cl (prf_abs (prf_bvar 0)) (co_bvar 0)
         | h::q => cl (prf_abs (prf_bvar 0)) (co_mut (subst_store (scl p e (st q))))
     end
  end
.
*)

Fixpoint subst_sprf_sprf (z : var) (p: sprf) (q : sprf) {struct p} : sprf :=
  match p with
  | sprf_bvar i    => sprf_bvar i
  | sprf_fvar x    => If x = z then q else (sprf_fvar x)
  | sprf_abs p1    => sprf_abs (subst_sprf_sprf z p1 q)
  | sprf_mu c => sprf_mu (subst_sclos_sprf z c q)
end
with subst_scont_sprf (z : var) (e:scont) (q:sprf) {struct e}:scont :=
  match e with
    | sco_bvar i => sco_bvar i
    | sco_fvar x => sco_fvar x
    | sco_stack p f => sco_stack (subst_sprf_sprf z p q) (subst_scont_sprf z f q)
    | sco_mut c => sco_mut (subst_sclos_sprf z c q)
  end
with subst_store_sprf (z:var) (tau:store) (q:sprf) {struct tau} : store :=
  match tau with
    | st l  => st (List.map (fun (t:var*sprf) =>let (a,p):=t in (a,(subst_sprf_sprf z p q))) l)
  end
with subst_sclos_sprf (z:var) (c:sclos) (q:sprf) {struct c} : sclos :=
  match c with
    | scl p e tau =>  scl (subst_sprf_sprf z p q)  (subst_scont_sprf z e q) (subst_store_sprf z tau q)
  end.

Fixpoint subst_sprf_scont (z : var) (p: sprf) (f:scont) {struct p} : sprf :=
  match p with
  | sprf_bvar i    => sprf_bvar i
  | sprf_fvar x    => sprf_fvar x
  | sprf_abs p1    => sprf_abs (subst_sprf_scont z p1 f)
  | sprf_mu c => sprf_mu (subst_sclos_scont z c f)
end
with subst_scont_scont (z : var) (e:scont) (f:scont) {struct e}:scont :=
  match e with
    | sco_bvar i => sco_bvar i
    | sco_fvar x => If x = z then f else sco_fvar x
    | sco_stack p e' => sco_stack (subst_sprf_scont z p f) (subst_scont_scont z e' f)
    | sco_mut c => sco_mut (subst_sclos_scont z c f)
  end
with subst_store_scont (z:var) (tau:store) (f:scont) {struct tau} : store :=
  match tau with
    | st l  => st (List.map (fun (t:var*sprf) =>let (a,p):=t in (a,(subst_sprf_scont z p f))) l)
  end
with subst_sclos_scont (z:var) (c:sclos) (f:scont) {struct c} : sclos :=
  match c with
    | scl p e tau =>  scl (subst_sprf_scont z p f)  (subst_scont_scont z e f) (subst_store_scont z tau f)
  end.

Notation "[ z ~+> q ]+ p" := (subst_sprf_sprf z p q) (at level 68).
Notation "[ z ~+> q ]- e" := (subst_scont_sprf z e q) (at level 68).
Notation "[ z ~+> q ]* c" := (subst_sclos_sprf z c q) (at level 68).
Notation "[ z ~+> q ] tau":= (subst_store_sprf z tau q) (at level 68).
Notation "[ z ~-> f ]+ p" := (subst_sprf_scont z p f) (at level 68).
Notation "[ z ~-> f ]- e" := (subst_scont_scont z e f) (at level 68).
Notation "[ z ~-> f ]* c" := (subst_sclos_scont z c f) (at level 68).
Notation "[ z ~-> f ] tau":= (subst_store_scont z tau f) (at level 68).

Fixpoint subst_list_in_sprf (p:sprf) (l:list (var*sprf)) {struct l}: sprf:=
  match l with
    |nil => p
    |cons (a,q) t => subst_list_in_sprf (subst_sprf_sprf a p q) t
  end.

Definition subst_store_in_sprf (p:sprf) (tau:store):sprf :=
  match tau with
    |st l => subst_list_in_sprf p l
  end.

Fixpoint subst_list_in_scont (e:scont) (l:list (var*sprf)) {struct l}: scont:=
  match l with
    |nil => e
    |cons (a,q) t => subst_list_in_scont (subst_scont_sprf a e q) t
  end.

Definition subst_store_in_scont (e:scont) (tau:store):scont :=
  match tau with
    |st l => subst_list_in_scont e l
  end.

(** Terms are locally-closed pre-terms *)

Inductive in_list {A:Type}: A -> list A-> Prop :=
|in_member : forall a l, in_list a (a::l)
|in_cons : forall a l, (forall b, in_list a l -> in_list a (b::l)).

Inductive sproof : sprf -> Prop :=
  | proof_var : forall a,
                  sproof (sprf_fvar a)
  | proof_abs : forall L p,
                  (forall a, a\notin L -> sproof (p +^+ a)) ->
                  sproof (sprf_abs p)
  | proof_mu : forall L c ,
                 (forall a,a\notin L -> sclosure (c *^- a)) ->
                 sproof (sprf_mu c)
with scontext : scont -> Prop :=
     | scontext_var : forall a, scontext (sco_fvar a)
     | scontext_stack : forall p e, sproof p -> scontext e -> scontext (sco_stack p e)
     | scontext_mut : forall L c, (forall a, a\notin L -> sclosure (c *^+ a)) ->
                                 scontext (sco_mut c)
with store_ok : store -> Prop :=
     | store_st : forall l, (forall a p, (in_list (a,p) l) -> sproof p) -> store_ok (st l)
with sclosure : sclos -> Prop :=
     | sclosure_cl : (forall p e tau, sproof p -> scontext e -> store_ok tau -> sclosure (scl p e tau))
.

(** Environment is an associative list mapping variables to types. *)

Definition env := LibEnv.env ltyp.

(********************)
(** Typing relation *)
(********************)

(* Reserved Notation "E|tau |= p :+ T" (at level 69).
Reserved Notation "E|tau |= e :- T" (at level 69).
Reserved Notation "c|tau :* E" (at level 69).
 *)

Definition concat_env tau tau' :=
  match (tau,tau') with
    |(st l,st l') => st (concat l l')
  end.

Notation "tau @@ tau'" := (concat_env tau tau') (at level 67).

Definition cons_env a p tau :=
  match tau with
    |st l => st (cons (a,p) l )
  end.

Inductive typing_sprf : env -> store -> sprf -> typ -> Prop :=
  | typing_sprf_var : forall E tau a T,
      ok E ->
      binds a (pos T) E ->
      typing_sprf E tau (sprf_fvar a)  T
  |typing_store_var : forall E tau a T,
                        (exists (q:sprf) l, tau=st l /\ binds a q l /\ typing_sprf E (st l) q T)->
                        typing_sprf E tau (sprf_fvar a) T
  | typing_abs : forall L E tau U T p1,
      (forall a, (a \notin L) ->
        typing_sprf (E & a ~pos U) tau (p1 +^+ a)  T) ->
     typing_sprf E tau (sprf_abs p1) (typ_arrow U T)

  | typing_mu : forall L E tau T c,
      (forall a, a \notin L ->
                 typing_sclos (E & a ~ neg T) tau (c*^-a))  ->
      typing_sprf  E tau (sprf_mu c) T
with typing_scont : env -> store -> scont -> typ -> Prop :=
  | typing_cont_var : forall E tau a T,
      ok E ->
      binds a (neg T) E ->
      typing_scont E tau (sco_fvar a) (T)
  | typing_mut : forall L E tau T c,
      (forall a, a \notin L ->
        typing_sclos (E & a ~ pos T) tau (c*^+a)) ->
      typing_scont E tau  (sco_mut c)  T
  | typing_stack : forall  E tau U T q e,
     (typing_sprf E tau q T) ->
     (typing_scont E tau e U) ->
      typing_scont E tau (sco_stack q e) (typ_arrow T U)
with typing_sclos : env -> store -> sclos -> Prop :=
  | typing_sclosure : forall E tau tau' T p e,
     (typing_sprf E (tau'@@tau) p T ->
      typing_scont E (tau'@@tau) e T ->
      typing_sclos E tau (scl p e tau')).

Notation "E ; tau |= p :+ T" := (typing_prf E tau p T) (at level 68).
Notation "E ; tau |= e :- T" := (typing_scont E tau e T) (at level 68).
Notation "c :* E ; tau " := (typing_sclos E tau c ) (at level 68).

(*** NOTATIONS ??? ****)

Require Import Coq.Program.Equality.
Scheme typing_sprf_ind1 := Induction for typing_sprf Sort Prop
with typing_scont_ind1 := Induction for typing_scont Sort Prop
with typing_sclos_ind1 := Induction for typing_sclos Sort Prop.
(* About typing_sclos_ind1. *)

Combined Scheme typing_store_mut_ind from typing_sprf_ind1,typing_scont_ind1,typing_sclos_ind1.

(** Definition of values (only abstractions are values) *)

(* FIX ? Rajouter variables ? *)

Inductive value : sprf -> Prop :=
  | value_abs : forall p,
      sproof (sprf_abs p) -> value (sprf_abs p).

(** Reduction relation - one step in call-by-value *)

Definition sclos_concat_store (c:sclos) (tau:store): sclos :=
  match c with
    | scl p e tau' => scl p e (concat_env tau tau')
  end.

Definition sclos_append_store (c:sclos) (tau:store): sclos :=
  match c with
    | scl p e tau' => scl p e (concat_env tau' tau)
  end.

Definition void:store := st nil.

Inductive sred : sclos -> sclos -> Prop :=
  | sred_mut : forall p c tau,
      scontext (sco_mut c) ->
      value p -> forall L a, (a \notin L ->
      sred (scl p (sco_mut c) tau) (sclos_append_store (c*^+ a) (cons_env a p tau)))
  | sred_abs : forall p q e tau,
      sproof (sprf_abs p) -> sproof q ->
      scontext e ->
      sred (scl (sprf_abs p) (sco_stack q e) tau) (scl q (sco_mut (scl p e void)) tau)
  | sred_mu : forall e c tau,
      sproof (sprf_mu c) -> scontext e ->
      sred (scl (sprf_mu c) e tau) (sclos_append_store (c *^^- e) tau).

Notation "c -s-> c'" := (sred c c') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E c c',
  typing_sclos E void c ->
  c -s-> c' ->
  typing_sclos E void c'.

Definition progress := forall p T,
  typing_sprf empty void p T ->
  value p
  \/ (exists L, forall a,(a\notin L -> exists c, sred (scl p (sco_fvar a) void) c)).


From stdpp Require Import numbers.
From SepLogic Require Import SepSet.
From Examples Require Import example2 example3.
From FreeMonad Require Import FreeMonad.

Section PHOAS.

  Context {var : Type -> Type}.

  Inductive VAL : Type -> Type :=
  | Var : forall {X}, var X -> VAL X
  | Const : N -> VAL N
  | Add : VAL N -> VAL N -> VAL N
  | Sub : VAL N -> VAL N -> VAL N
  | Le : VAL N -> VAL N -> VAL bool
  | Lt : VAL N -> VAL N -> VAL bool
  | Len : VAL span -> VAL N
  | Pair : forall {X Y}, VAL X -> VAL Y -> VAL (X * Y)
  | Fst : forall {X Y}, VAL (X * Y) -> VAL X
  | Snd : forall {X Y}, VAL (X * Y) -> VAL Y
  | ToU32 : VAL octet -> VAL octet -> VAL octet -> VAL octet -> VAL N.

  Inductive Expr : Type -> Type :=
  | Val : forall {X}, VAL X -> Expr X
  | LetIn : forall {X}, Expr X -> forall {Y}, (var X -> Expr Y) -> Expr Y
  | IfThenElse: VAL bool -> forall {X}, Expr X -> Expr X -> Expr X
  | Take : VAL N -> Expr span
  | Read : VAL span -> VAL N -> Expr octet
  | Length : Expr N
  | Fail : forall {X}, Expr X.

End PHOAS.

Notation "'let%' v ':=' e 'in' k" := (LetIn e (fun v => k))(at level 50).
Notation "'If' b 'Then' et 'Else' ef" := (IfThenElse b et ef)(at level 50).
Notation "b0 '<!' b1" := (Lt b0 b1)(at level 30).
Notation "b0 '<=!' b1" := (Le b0 b1)(at level 30).
Notation "n0 '+!' n1" := (Add n0 n1)(at level 25, left associativity).
Notation "n0 '-!' n1" := (Sub n0 n1)(at level 25, left associativity).
Notation "'(!' a ',' b ')'" := (Pair a b)(at level 25, left associativity).

Section sem_PHOAS.

  Inductive var : Type -> Type :=
  | VNat : N -> var N
  | VSpan : span -> var span
  | VBool : bool -> var bool
  | VPair : forall {X Y}, var X -> var Y -> var (X * Y).

  Fixpoint sem_val {X} (v : var X) : X :=
  match v with
  | VSpan v | VBool v | VNat v => v
  | VPair va vb => (sem_val va, sem_val vb)
  end.

  Inductive sem_VAL : forall {X}, @VAL var X -> var X -> Prop :=
  | sem_Const : forall n, sem_VAL (Const n) (VNat n)
  | sem_Add : forall vm m m' vn n n',
      sem_val m = m' ->
      sem_VAL vm m ->
      sem_val n = n' ->
      sem_VAL vn n ->
      sem_VAL (Add vm vn) (VNat (m' + n'))
  | sem_Sub : forall vm m m' vn n n',
      sem_val m = m' ->
      sem_VAL vm m ->
      sem_val n = n' ->
      sem_VAL vn n ->
      sem_VAL (Sub vm vn) (VNat (m' - n'))
  | sem_Le : forall vm vn m m' n n',
      sem_VAL vm m ->
      sem_val m = m' ->
      sem_VAL vn n ->
      sem_val n = n' ->
      sem_VAL (Le vm vn) (VBool (m' <=? n'))
  | sem_Lt : forall vm vn m n,
      sem_VAL vm m ->
      sem_VAL vn n ->
      sem_VAL (Lt vm vn) (VBool (sem_val m <? sem_val n))
  | sem_Len : forall vs s,
      sem_VAL vs s ->
      sem_VAL (Len vs) (VNat (len (sem_val s)))
  | sem_Pair : forall X Y va (a : var X) vb (b : var Y),
      sem_VAL va a ->
      sem_VAL vb b ->
      sem_VAL (Pair va vb) (VPair a b)
  | sem_Fst : forall X Y v (a : var X) (b : var Y),
      sem_VAL v (VPair a b) ->
      sem_VAL (Fst v) a
  | sem_Snd : forall X Y v (a : var X) (b : var Y),
      sem_VAL v (VPair a b) ->
      sem_VAL (Snd v) b
  | sem_ToU32 : forall va vb vc vd a b c d,
      sem_VAL va a ->
      sem_VAL vb b ->
      sem_VAL vc c ->
      sem_VAL vd d ->
      sem_VAL (ToU32 va vb vc vd) (VNat (to_u32 (sem_val a) (sem_val b) (sem_val c) (sem_val d)))
  | sem_Var : forall X (v : var X), sem_VAL (Var v) v.

  Inductive sem_Expr {data : list N} :
    span -> forall {X}, @Expr var X -> option (var X * span) -> Prop :=
  | sem_Val : forall s X (v :VAL X) res,
      sem_VAL v res ->
      sem_Expr s (Val v) (Some (res, s))
  | sem_LetInF : forall X ex Y (k : var X -> Expr Y) s,
      sem_Expr s ex None ->
      sem_Expr s (LetIn ex k) None
  | sem_LetInS : forall X ex Y (k : var X -> Expr Y) s v sv res,
      sem_Expr s ex (Some (v, sv)) ->
      sem_Expr sv (k v) res ->
      sem_Expr s (LetIn ex k) res
  | sem_IfThenElseT : forall vb X (et ee : Expr X) res s,
      sem_VAL vb (VBool true) ->
      sem_Expr s et res ->
      sem_Expr s (IfThenElse vb et ee) res
  | sem_IfThenElseF : forall vb X (et ee : Expr X) res s,
      sem_VAL vb (VBool false) ->
      sem_Expr s ee res ->
      sem_Expr s (IfThenElse vb et ee) res
  | sem_Take : forall s vn n,
    sem_VAL vn (VNat n) ->
    sem_Expr s (Take vn) (Some (VSpan (mk_span (pos s) n), mk_span (pos s + n) (len s - n)))
  | sem_Read : forall s vrange range vn n v default,
      sem_VAL vrange (VSpan range) ->
      sem_VAL vn (VNat n) ->
      nth (N.to_nat (pos range + n)) data default = v ->
      sem_Expr s (Read vrange vn) (Some (VNat v, s))
  | sem_Length : forall s, sem_Expr s Length (Some (VNat (len s), s))
  | sem_Fail : forall X s, sem_Expr s (Fail : Expr X) None.

End sem_PHOAS.

Definition span_data_wf (data : list N) (s : span) :=
    pos s + len s < length data.

Definition adequate {X Y} (R : X -> Y -> Prop) (d : Decodeur X) (e : Expr Y) (data : list N) :=
  forall s res,
    span_data_wf data s ->
    @sem_Expr data s Y e res ->
    match res with
    | None => eval d data s = None
    | Some (v, t) => ∃ r, eval d data s = Some (r, t) /\ R r (sem_val v)
    end.

Axiom adequacy_pure : forall X e (Q : X -> Prop),
    {{ emp }} e {{ v; ⌜Q v⌝ }} ->
    forall data (v : X) s' s,
      eval e data s = Some (v, s') ->
      Q v.

Lemma adequacy_pure_PHOAS :
  forall X Q (e : Decodeur X) (h : Expr X),
    {{ emp }} e {{ v; ⌜Q v⌝ }} ->
    forall data,
      adequate eq e h data ->
      forall vv s sres,
        @sem_Expr data s X h (Some (vv, sres)) ->
        span_data_wf data s ->
        Q (sem_val vv).
Proof.
  intros X Q e h TRIPLE data ADE vv s sres SEM WF.
  eapply ADE in SEM as [r [EVAL EQ]]; eauto. subst.
  eapply adequacy_pure; eauto.
Qed.

Ltac simpl_existT :=
  repeat match goal with
         | H : existT _ _ = existT _ _ |- _ =>
             repeat eapply Eqdep.EqdepTheory.inj_pair2 in H
    end.

Ltac next_step H := inversion H; subst; simpl_existT; subst; clear H.

Ltac head t :=
  match t with
  | ?t' _ => head t'
  | _ => t
  end.

Ltac head_constructor t :=
  let t' := head t in is_constructor t'.

Lemma sem_VAL_inj : forall X (v : VAL X) a b,
    sem_VAL v a ->
    sem_VAL v b ->
    a = b.
Proof.
  Ltac ind_inj IH :=
    match goal with
    | H : sem_VAL ?t _ |- _ =>
        head_constructor t; next_step H
    | H0 : sem_VAL ?t _, H1 : sem_VAL ?t _ |- _ =>
        injection (IH _ t _ _ H0 H1); clear H0; clear H1
    | H0 : sem_VAL ?t _, H1 : sem_VAL ?t _ |- _ =>
        eapply (IH _ t _ _ H0) in H1
    end.
  fix IH 2.
  destruct v; intros; repeat ind_inj IH; intros; simpl_existT; subst; reflexivity.
Qed.

Ltac sem_VAL_unif :=
  match goal with
  | H : sem_VAL ?t _, H0 : sem_VAL ?t _ |- _ => eapply (sem_VAL_inj _ t _ _ H) in H0
  end.

Ltac inj_val :=
  match goal with
  | H : VNat _ = VNat _ |- _ => injection H; intros; clear H
  | H : VSpan _ = VSpan _ |- _ => injection H; intros; clear H
  | H : VBool _ = VBool _ |- _ => injection H; intros; clear H
  | H : VPair _ _ = VPair _ _ |- _ => injection H; intros; clear H
  end.

Ltac VAL_unif := repeat sem_VAL_unif; repeat inj_val.

Open Scope free_monad_scope.

Axiom run_bind_fail : forall s data X Y e (k : X -> Decodeur Y),
    eval e data s = None ->
    eval (let! v := e in k v) data s = None.

Lemma bind_adequate :
  forall data (X X0 Y Y0 : Type) R R0 (e : Decodeur X) (ke : X -> Decodeur Y)
    (h : Expr X0) (kh : var X0 -> Expr Y0),
    adequate R0 e h data ->
    (forall res vres, R0 res (sem_val vres) -> adequate R (ke res) (kh vres) data) ->
    adequate R (let! v := e in ke v) (let% v := h in kh v) data.
Proof.
  unfold adequate.
  intros data X X0 Y Y0 R R0 e ke h kh SEME SEMK s res WF SEM.
  next_step SEM.
  - eapply SEME in H2 as P1; auto.
    eapply run_bind_fail. auto.
  - eapply SEME in H3 as [r [P0 R0r]]; auto.
    eapply SEMK in H6. destruct res.
    + destruct p. destruct H6 as [r0 [EVAL Rr0]]. exists r0. split; auto.
      admit.
    + admit.
    + eauto.
    + admit.
Admitted.

Lemma ret_adequate :
  forall Y (va : VAL Y) (X : Type) (R : X -> Y -> Prop) a (v : X) data,
    sem_VAL va a ->
    R v (sem_val a) ->
    adequate R (ret v) (Val va) data.
Proof.
  unfold adequate.
  intros Y va X R a v data SEMA RA s res WF SEM.
  next_step SEM. VAL_unif. subst. exists v. split; auto.
Qed.

Definition span_eq_take data n (s0 s1 : span) : Prop :=
  s0 = s1 /\ span_data_wf data s1 /\ len s1 = n.

Lemma take_adequate : forall (hn : VAL N) data (n : N) vn,
    sem_VAL hn vn ->
    sem_val vn = n ->
    adequate (span_eq_take data n) (take n)
      (let% len := Length in
       IfThenElse (Le hn (Var len))
         (Take hn)
         Fail) data.
Proof.
  intros data n hn vn VALN EQ s res WF SEM.
  next_step SEM.
  - next_step H2.
  - next_step H6.
    + next_step H3. next_step H8. next_step H4. next_step H6.
      simpl in *. repeat VAL_unif. subst.
      simpl. unfold example2.bind. unfold takeM.
      eexists. rewrite H1. split. reflexivity.
      repeat split. unfold span_data_wf in *. simpl.
      eapply N.leb_le in H1. simpl in *. lia.
    + next_step H8. next_step H4. next_step H3. next_step H6.
      repeat VAL_unif. subst.
      simpl. unfold example2.bind. unfold takeM.
      rewrite H1. reflexivity.
Qed.

Lemma lookup_lt : forall pos (data : data),
    pos < length data ->
    exists v, lookup pos data = Some v.
Proof.
  induction pos using N.peano_ind; simpl; intros data LT.
  - destruct data; simpl in *; intros.
    + exfalso. eapply N.nlt_0_r. eexact LT.
    + rewrite lookup_equation_2. exists o. reflexivity.
  - destruct data; simpl in *.
    + exfalso. eapply N.nlt_0_r. eexact LT.
    + rewrite length_equation_2 in LT. eapply N.succ_lt_mono in LT.
      eapply IHpos in LT. destruct LT. rewrite <- N.succ_pos_spec.
      rewrite lookup_equation_3. rewrite N.succ_pos_spec. rewrite N.pred_succ.
      exists x. auto.
Qed.

Lemma lookup_nth : forall pos (data : data) default,
    pos < length data ->
    lookup pos data = Some (nth (N.to_nat pos) data default).
Proof.
  induction pos using N.peano_ind; simpl; intros data default LT.
  - destruct data; simpl in *; intros.
    + exfalso. eapply N.nlt_0_r. eexact LT.
    + rewrite lookup_equation_2. reflexivity.
  - destruct data; simpl in *.
    + exfalso. eapply N.nlt_0_r. eexact LT.
    + rewrite length_equation_2 in LT. eapply N.succ_lt_mono in LT.
      eapply IHpos in LT. rewrite <- N.succ_pos_spec.
      rewrite lookup_equation_3. rewrite N.succ_pos_spec. rewrite N.pred_succ.
      erewrite LT. f_equal. rewrite N2Nat.inj_succ. reflexivity.
Qed.

Lemma read_adequate : forall hs hn data vn (n n0 : N) vs s,
    span_eq_take data n0 s (sem_val vs) ->
    sem_VAL hs vs ->
    sem_VAL hn vn ->
    sem_val vn = n ->
    adequate eq (read s n) (IfThenElse (Lt hn (Len hs)) (Read hs hn) Fail) data.
Proof.
  intros hs hn data vn n n0 vs s RS ADES ADEN VALn s0 res WF SEM.
  next_step SEM.
  - next_step H3. next_step H4. next_step H6. repeat VAL_unif. subst. simpl in *.
    destruct RS as [P0 [P1 P2]]. subst.
    unfold example2.bind, readM. rewrite H1. eapply N.ltb_lt in H1.
    rewrite (lookup_nth (pos range + n) data default).
    eexists. split; auto. unfold span_data_wf in P1. lia.
  - next_step H6. next_step H3. next_step H4. repeat VAL_unif. subst. simpl in *.
    destruct RS as [P0 [P1 P2]]. subst.
    unfold example2.bind, readM. rewrite H1. reflexivity.
Qed.

Lemma read2_adequate : forall hs hn data vn (n n0 : N) vs s,
    span_eq_take data n0 s (sem_val vs) ->
    sem_VAL hs vs ->
    sem_VAL hn vn ->
    sem_val vn = n ->
    n < n0 ->
    adequate eq (read s n) (Read hs hn) data.
Proof.
  intros hs hn data vn n n0 vs s RS ADES ADEN VALn LT s0 res WF SEM.
  next_step SEM.
  repeat VAL_unif. subst. simpl. unfold example2.bind, readM. eapply N.ltb_lt in LT.
  destruct RS as [P0 [P1 P2]]. subst.
  unfold span_data_wf in *. simpl in *. rewrite LT. eapply N.ltb_lt in LT.
  rewrite (lookup_nth (pos range + n1) data default).
  eexists. split; auto. lia.
Qed.

Lemma ite_adequate : forall hb data X Y R vb (b : bool) (et : Decodeur X) (ht : Expr Y) ef hf,
    sem_VAL hb vb ->
    sem_val vb = b ->
    (b = true -> adequate R et ht data) ->
    (b = false -> adequate R ef hf data) ->
    adequate R (if b then et else ef) (IfThenElse hb ht hf) data.
Proof.
  intros hb data X Y R vb b et ht ef hf VALb EQ ADET ADEF s res WF SEM.
  subst. next_step SEM.
  - repeat VAL_unif. subst. simpl. eapply ADET; auto.
  - repeat VAL_unif. subst. simpl. eapply ADEF; auto.
Qed.

Lemma fail_adequate : forall data X Y R,
    adequate R (fail : Decodeur X) (Fail : Expr Y) data.
Proof. intros data X Y R s res WF SEM. next_step SEM. reflexivity. Qed.

Ltac Pos_is_literal p :=
  match p with
  | xO ?p  => Pos_is_literal p
  | xI ?p => Pos_is_literal p
  | xH => idtac
  end.

Ltac N_is_literal n :=
  match n with
  | N0 => idtac
  | Npos ?p => Pos_is_literal p
  end.

Ltac what_is e k :=
  match e with
  | ?e => N_is_literal e; k (@Const var e)
  (* | H : ?e = sem_val ?v |- ?e => is_var e; k (@Var var v) *)
  (* | H : sem_val ?v = ?e |- ?e => is_var e; k (@Var var v) *)
  (* | ?e => is_var e; k (@Var _ var e) *)
  | sem_val ?e => is_var e; k (@Var var _ e)
  | ?l <=? ?r => what_is l ltac:(fun l => what_is r ltac:(fun r => k (@Le var l r)))
  | ?l <? ?r => what_is l ltac:(fun l => what_is r ltac:(fun r => k (@Lt var l r)))
  | ?l + ?r => what_is l ltac:(fun l => what_is r ltac:(fun r => k (@Add var l r)))
  | ?l - ?r => what_is l ltac:(fun l => what_is r ltac:(fun r => k (@Sub var l r)))
  | to_u32 ?a ?b ?c ?d =>
      what_is a ltac:(fun a =>
       what_is b ltac:(fun b =>
        what_is c ltac:(fun c =>
         what_is d ltac:(fun d => k (@ToU32 var a b c d)))))
  end.

Ltac clean_up :=
  match goal with
  | H : span_eq_take _ _ _ _ |- _ =>
      let P0 := fresh "P" in
      let P1 := fresh "P" in
      let P2 := fresh "P" in
      destruct H as [P0 [P1 P2]]
  end.

Ltac step := repeat clean_up; subst;
  match goal with
  | |- adequate _ (let! _ := _ in _) _ _ =>
        eapply bind_adequate; [ idtac | intros (* intros; repeat clean_up; subst *) ]
  | |- adequate _ (take ?e) _ _ =>
      what_is e ltac:(fun v => eapply (take_adequate v)); repeat econstructor
  | |- adequate _ (read ?s ?n) _ _ =>
      what_is s ltac:(fun s => what_is n ltac:(fun n => eapply (read2_adequate s n)));
      [repeat split; eauto | repeat econstructor | repeat econstructor | eauto | lia]
  | |- adequate _ (read ?s ?n) _ _ =>
      what_is s ltac:(fun s => what_is n ltac:(fun n => eapply (read_adequate s n)));
      [repeat split; eauto | repeat econstructor | repeat econstructor | eauto]
  | |- adequate _ (if ?b then ?et else ?ef) _ _ =>
      what_is b ltac:(fun s => eapply (ite_adequate s));
      repeat econstructor; eauto; intros
  | |- adequate _ fail _ _ => eapply fail_adequate
  | |- adequate _ (ret ?v) _ _ =>
      what_is v ltac:(fun v => eapply (ret_adequate _ v)); repeat econstructor; eauto
  end.

Ltac StartDF :=
  eapply exist; intros;
  match goal with
  | |- adequate _ ?f _ _ =>
      let v := head f in
      unfold f
  end.

Local Hint Extern 3 (adequate _ _ _ _) => (* repeat  *)step : core.

Definition decode_next_DF_example :
  {code | forall data, adequate eq decode_next code data}.
Proof.
  what_is 1 ltac:(fun v => pose (H := v)).
  eapply exist. intro. unfold decode_next.
  eapply bind_adequate.
  - eapply (take_adequate (Const 1)); constructor.
  - intros res vres [P0 [P1 P2]].
    eapply (read_adequate (Var vres) (Const 0)); constructor; auto.
Defined.

Definition decode_next_DF :
  {code | forall data, adequate eq decode_next code data}.
Proof. StartDF; auto. Defined.

Lemma decode_first_eq : proj1_sig decode_next_DF_example = proj1_sig decode_next_DF.
Fail reflexivity. Abort.

Compute (proj1_sig decode_next_DF).

Lemma decode_next_adequate :
  forall data, adequate eq decode_next (`decode_next_DF) data.
Proof. intros. destruct (decode_next_DF) as [x P]. eapply P. Qed.

Ltac FMfirst :=
  match goal with
  | |- adequate _ decode_next _ _ => eapply decode_next_adequate
  | |- _ => step
  end.

Local Hint Extern 3 (adequate _ decode_next _ _) => eapply decode_next_adequate : core.

Definition decode_u32_DF :
  { code | forall data, adequate eq decode_u32 code data}.
Proof. StartDF; auto. Defined.

Compute (proj1_sig decode_u32_DF).

Lemma decode_u32_adequate :
  forall data, adequate eq decode_u32 (`decode_u32_DF) data.
Proof. intros. destruct (decode_u32_DF) as [x P]. eapply P. Qed.

Ltac FMU32 :=
  match goal with
  | |- adequate _ decode_u32 _ _ => eapply decode_u32_adequate
  | |- _ => FMfirst
  end.

Local Hint Extern 3 (adequate _ decode_u32 _ _) => eapply decode_u32_adequate : core.

Definition RpacketSSH (s : packet_SSH) (v : (N * N) * (span * span)) :=
  v.1.1 = packet_length s /\
  v.1.2 = padding_length s /\
  v.2.1 = payload s /\
  v.2.2 = mac s.

Definition decode_packet_SSH_sig :
  { code | forall data, adequate RpacketSSH decode_packet_SSH code data}.
Proof.
  StartDF. repeat FMU32. repeat clean_up. subst.
  eapply (ret_adequate _ (Pair (Pair (Var vres) (Var vres0)) (Pair (Var vres1) (Var vres3)))).
  repeat econstructor.
  repeat split; eauto.
Defined.

Compute (proj1_sig decode_packet_SSH_sig).


(** * Build a table for the next binop at a given level *)
Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.
Require Import Fiat.Common.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.SetoidInstances.
Require Import Fiat.Parsers.Reachable.ParenBalanced.Core.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.StringLike.FirstChar.
Require Import Fiat.Parsers.Refinement.BinOpBrackets.ParenBalanced.

Set Implicit Arguments.

Section make_table.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.

  (** We build a version of paren-balanced-hiding to compute each cell
      of the table. *)
  (**
<<
pb' ch n "" = (n == 0)
pb' ch n (ch :: s) = n > 0 && pb' ch n s
pb' ch n ('(' :: s) = pb' ch (n + 1) s
pb' ch n (')' :: s) = n > 0 && pb' ch (n - 1) s
pb' ch n (_ :: s) = pb' ch n s

pb = pb' '+' 0
>>
*)

  Definition compute_next_bin_op'_step
    := (fun ch next level
        => if is_bin_op ch
           then if Compare_dec.gt_dec level 0
                then option_map S (next level)
                else Some 0
           else if is_open ch
                then option_map S (next (S level))
                else if is_close ch
                     then if Compare_dec.gt_dec level 0
                          then option_map S (next (pred level))
                          else None
                     else option_map S (next level)).

  Definition compute_next_bin_op' (str : String) (level : nat)
  : option nat
    := fold
         compute_next_bin_op'_step
         (fun _ => None)
         str
         level.

  Lemma compute_next_bin_op'_nil (str : String) (H : length str = 0)
  : compute_next_bin_op' str = fun _ => None.
  Proof.
    apply fold_nil; assumption.
  Qed.

  Lemma compute_next_bin_op'_recr {HSLP : StringLikeProperties Char} (str : String)
  : compute_next_bin_op' str
    = match get 0 str with
        | Some ch => compute_next_bin_op'_step ch (compute_next_bin_op' (drop 1 str))
        | None => fun _ => None
      end.
  Proof.
    apply fold_recr.
  Qed.

  Global Instance compute_next_bin_op'_step_Proper {HSLP : StringLikeProperties Char}
  : Proper (eq ==> (eq ==> eq) ==> eq ==> eq) compute_next_bin_op'_step.
  Proof.
    repeat intro; subst.
    unfold compute_next_bin_op'_step.
    unfold respectful in *.
    match goal with
      | [ H : _ |- _ ] => erewrite !H by reflexivity
    end.
    reflexivity.
  Qed.

  Global Instance compute_next_bin_op'_Proper {HSLP : StringLikeProperties Char}
  : Proper (beq ==> eq) compute_next_bin_op'.
  Proof.
    apply fold_Proper.
  Qed.

  Global Instance compute_next_bin_op'_Proper' {HSLP : StringLikeProperties Char}
  : Proper (beq ==> eq ==> eq) compute_next_bin_op'.
  Proof.
    repeat intro; subst.
    refine (f_equal (fun f => f _) _).
    setoid_subst_rel beq.
    reflexivity.
  Qed.

  Typeclasses Opaque compute_next_bin_op'.
  Opaque compute_next_bin_op'.

  (** We build a table to tell us where to split.
      For each character, we store an [option nat], and keep a
      transient [list nat].

      We store where the next '+' at the current level of
      parenthetization is.  The transient list stores where the
      next '+' is for higher levels. *)

  Definition list_of_next_bin_ops'_step'
    := (fun ch table_higher_ops =>
          let next_ops := map (option_map S) (nth 0 table_higher_ops nil) in
          let '(cur_mark, new_higher_ops) := (nth 0 next_ops None, tl next_ops) in
          ((if is_bin_op ch
            then Some 0 :: new_higher_ops
            else if is_open ch
                 then new_higher_ops
                 else if is_close ch
                      then None :: next_ops
                      else next_ops))).

  Definition list_of_next_bin_ops'_step
    := (fun ch table_higher_ops =>
          list_of_next_bin_ops'_step' ch table_higher_ops :: table_higher_ops).

  Definition list_of_next_bin_ops' (str : String)
  : list (list (option nat))
    := fold
         list_of_next_bin_ops'_step
         nil
         str.

  Definition list_of_next_bin_ops (str : String)
    := map (fun ls => nth 0 ls None) (list_of_next_bin_ops' str).

  Lemma list_of_next_bin_ops'_nil (str : String) (H : length str = 0)
  : list_of_next_bin_ops' str = nil.
  Proof.
    apply fold_nil; assumption.
  Qed.

  Lemma list_of_next_bin_ops'_recr {HSLP : StringLikeProperties Char} (str : String)
  : list_of_next_bin_ops' str
    = match get 0 str with
        | Some ch => list_of_next_bin_ops'_step ch (list_of_next_bin_ops' (drop 1 str))
        | None => nil
      end.
  Proof.
    apply fold_recr.
  Qed.

  Global Instance list_of_next_bin_ops'_Proper {HSLP : StringLikeProperties Char}
  : Proper (beq ==> eq) list_of_next_bin_ops'.
  Proof.
    apply fold_Proper.
  Qed.

  Typeclasses Opaque list_of_next_bin_ops'.
  Opaque list_of_next_bin_ops'.

  Lemma list_of_next_bin_ops'_length' {HSLP : StringLikeProperties Char} str
  : List.length (list_of_next_bin_ops' str) = length str.
  Proof.
    set (len := length str).
    generalize (eq_refl : length str = len).
    clearbody len.
    revert str.
    induction len; simpl; intros str H'.
    { rewrite list_of_next_bin_ops'_nil by assumption; reflexivity. }
    { specialize (IHlen (drop 1 str)).
      rewrite drop_length, H' in IHlen.
      simpl in IHlen.
      specialize (IHlen (NPeano.Nat.sub_0_r _)).
      rewrite list_of_next_bin_ops'_recr.
      destruct (singleton_exists (take 1 str)) as [ch H''].
      { rewrite take_length, H'; reflexivity. }
      { erewrite (fun s H => proj1 (get_0 s H)) by eassumption.
        unfold list_of_next_bin_ops'_step.
        repeat match goal with
                 | _ => reflexivity
                 | _ => rewrite IHlen
                 | _ => progress simpl
                 | [ |- context[if ?f ch then _ else _] ] => destruct (f ch)
               end. } }
  Qed.

  Lemma list_of_next_bin_ops'_drop {HSLP : StringLikeProperties Char} str n
  : List.drop n (list_of_next_bin_ops' str) = list_of_next_bin_ops' (drop n str).
  Proof.
    revert str.
    induction n as [|n]; simpl; intros.
    { rewrite drop_0; reflexivity. }
    { replace (S n) with (n + 1) by omega.
      rewrite <- drop_drop, <- IHn; clear IHn.
      set (len := length str).
      generalize (eq_refl : length str = len).
      clearbody len.
      revert str n.
      induction len; simpl; intros str n H'.
      { rewrite !list_of_next_bin_ops'_nil by (rewrite ?drop_length; omega).
        destruct n; reflexivity. }
      { specialize (IHlen (drop 1 str)).
        rewrite drop_length, H' in IHlen.
        simpl in IHlen.
        rewrite NPeano.Nat.sub_0_r in IHlen.
        specialize (IHlen (pred n) eq_refl).
        rewrite list_of_next_bin_ops'_recr.
        destruct (singleton_exists (take 1 str)) as [ch H''].
        { rewrite take_length, H'; reflexivity. }
        { rewrite (proj1 (get_0 _ _) H'').
          reflexivity. } } }
  Qed.

  Definition index_points_to_binop (offset index : nat) (str : String)
    := for_first_char (drop (offset + index) str) is_bin_op.

  Lemma index_points_to_binop_spec {HSLP : StringLikeProperties Char} offset index str ch
        (H : (take 1 (drop (offset + index) str) ~= [ ch ])%string_like)
  : index_points_to_binop offset index str <-> is_bin_op ch.
  Proof.
    unfold index_points_to_binop.
    rewrite (for_first_char__take 0).
    rewrite <- for_first_char_singleton; [ reflexivity | assumption ].
  Qed.

  Lemma index_points_to_binop_S1 {HSLP : StringLikeProperties Char} offset index str
  : index_points_to_binop (S offset) index str <-> index_points_to_binop offset index (drop 1 str).
  Proof.
    unfold index_points_to_binop.
    rewrite ?drop_drop, !NPeano.Nat.add_1_r; simpl.
    reflexivity.
  Qed.

  Lemma index_points_to_binop_S2 {HSLP : StringLikeProperties Char} offset index str
  : index_points_to_binop offset (S index) str <-> index_points_to_binop offset index (drop 1 str).
  Proof.
    rewrite <- index_points_to_binop_S1.
    unfold index_points_to_binop.
    replace (offset + S index) with (S offset + index) by omega.
    reflexivity.
  Qed.

  Lemma index_points_to_binop_nil {HSLP : StringLikeProperties Char}
        (offset index : nat) (str : String) (H : length str <= offset + index)
  : index_points_to_binop offset index str.
  Proof.
    unfold index_points_to_binop.
    apply for_first_char_nil.
    rewrite drop_length; omega.
  Qed.

  Definition index_not_points_to_binop (offset index : nat) (str : String)
    := for_first_char (drop (offset + index) str) (fun ch => is_bin_op ch = false).

  Lemma index_not_points_to_binop_spec {HSLP : StringLikeProperties Char} offset index str ch
        (H : (take 1 (drop (offset + index) str) ~= [ ch ])%string_like)
  : index_not_points_to_binop offset index str <-> is_bin_op ch = false.
  Proof.
    unfold index_not_points_to_binop.
    rewrite (for_first_char__take 0).
    rewrite <- for_first_char_singleton; [ reflexivity | assumption ].
  Qed.

  Lemma index_not_points_to_binop_S1 {HSLP : StringLikeProperties Char} offset index str
  : index_not_points_to_binop (S offset) index str <-> index_not_points_to_binop offset index (drop 1 str).
  Proof.
    unfold index_not_points_to_binop.
    rewrite ?drop_drop, !NPeano.Nat.add_1_r; simpl.
    reflexivity.
  Qed.

  Lemma index_not_points_to_binop_S2 {HSLP : StringLikeProperties Char} offset index str
  : index_not_points_to_binop offset (S index) str <-> index_not_points_to_binop offset index (drop 1 str).
  Proof.
    rewrite <- index_not_points_to_binop_S1.
    unfold index_not_points_to_binop.
    replace (offset + S index) with (S offset + index) by omega.
    reflexivity.
  Qed.

  Lemma index_not_points_to_binop_nil {HSLP : StringLikeProperties Char}
        (offset index : nat) (str : String) (H : length str <= offset + index)
  : index_not_points_to_binop offset index str.
  Proof.
    unfold index_not_points_to_binop.
    apply for_first_char_nil.
    rewrite drop_length; omega.
  Qed.

  Definition cell_of_next_bin_ops_spec'' (level : nat) (cell : option nat) (str : String) offset idx
    := (cell = Some idx
        -> index_points_to_binop offset idx str
           /\ paren_balanced_hiding' (take idx (drop offset str)) level)
       /\ (cell = None
           -> paren_balanced' (take idx (drop offset str)) level
           -> index_not_points_to_binop offset idx str).

  Definition list_of_next_bin_ops_spec'' (level : nat) (table : list (option nat)) (str : String) offset idx
    := cell_of_next_bin_ops_spec'' level (nth offset table None) str offset idx.

  Definition list_of_next_bin_ops_spec' (level : nat) (table : list (option nat)) (str : String)
    := forall offset idx, list_of_next_bin_ops_spec'' level table str offset idx.

  Definition list_of_next_bin_ops_spec
    := list_of_next_bin_ops_spec' 0.

  Global Instance cell_of_next_bin_ops_spec''_Proper {HSLP : StringLikeProperties Char}
  : Proper (eq ==> eq ==> beq ==> eq ==> eq ==> iff) cell_of_next_bin_ops_spec''.
  Proof.
    repeat intro; subst.
    unfold cell_of_next_bin_ops_spec''.
    repeat (split || intros || split_and);
    specialize_by assumption;
    unfold index_points_to_binop in *;
    unfold index_not_points_to_binop in *;
    try match goal with
          | [ H : (_ =s _) |- _ ] => rewrite <- H; assumption
          | [ H : (_ =s _) |- _ ] => rewrite H; assumption
        end.
    repeat match goal with
             | [ H : (_ =s _) |- _ ] => rewrite <- H
             | [ H : (_ =s ?x), H' : context[?x] |- _ ] => rewrite <- H in H'
             | _ => progress specialize_by assumption
             | _ => assumption
           end.
    repeat match goal with
             | [ H : (_ =s _) |- _ ] => rewrite H
             | [ H : (?x =s _), H' : context[?x] |- _ ] => rewrite H in H'
             | _ => progress specialize_by assumption
             | _ => assumption
           end.
  Qed.

  Definition cell_of_next_bin_op_spec''_S_offset {HSLP : StringLikeProperties Char} {level cell str offset idx}
             (H : cell_of_next_bin_ops_spec'' level cell (drop 1 str) offset idx)
  : cell_of_next_bin_ops_spec'' level cell str (S offset) idx.
  Proof.
    unfold cell_of_next_bin_ops_spec'' in *; simpl in *.
    rewrite !index_points_to_binop_S1.
    rewrite !index_not_points_to_binop_S1.
    rewrite drop_drop, NPeano.Nat.add_1_r in H.
    assumption.
  Qed.

  Definition list_of_next_bin_ops_spec''_S_offset {HSLP : StringLikeProperties Char} {level table str offset t' idx}
             (H : list_of_next_bin_ops_spec'' level table (drop 1 str) offset idx)
  : list_of_next_bin_ops_spec'' level (t'::table) str (S offset) idx.
  Proof.
    unfold list_of_next_bin_ops_spec''; simpl.
    apply cell_of_next_bin_op_spec''_S_offset.
    assumption.
  Qed.

  Local Ltac t_eq :=
    repeat match goal with
             | _ => assumption
             | _ => progress simpl in *
             | _ => progress subst
             | [ |- is_true true ] => reflexivity
             | [ H : None = Some _ |- _ ] => solve [ inversion H ]
             | [ H : Some _ = None |- _ ] => solve [ inversion H ]
             | [ H : 0 = S _ |- _ ] => solve [ inversion H ]
             | [ H : S _ = 0 |- _ ] => solve [ inversion H ]
             | [ H : is_true false |- _ ] => solve [ inversion H ]
             | [ H : false = true |- _ ] => solve [ inversion H ]
             | [ H : true = false |- _ ] => solve [ inversion H ]
             | [ H : ?x = ?x |- _ ] => clear H
             | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
             | [ H : option_map _ ?x = Some _ |- _ ] => destruct x eqn:?; simpl in H
             | [ H : option_map _ ?x = None |- _ ] => destruct x eqn:?; simpl in H
             | _ => progress split_and
             | [ H : is_true (?str ~= [ ?ch ])%string_like, H' : is_true (?str ~= [ ?ch' ])%string_like |- _ ]
               => assert (ch = ch') by (eapply singleton_unique; eassumption);
                 clear H'
             | [ H : ?x = true |- context[?x] ] => rewrite H
             | [ H : ?x = false |- context[?x] ] => rewrite H
             | [ H : is_true ?x |- context[?x] ] => rewrite H
             | [ H : ?x = true, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : ?x = false, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : is_true ?x, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : ?x = S _, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : ?x = Some _, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : ?x = None, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : option_map _ ?x = Some _ |- _ ] => destruct x eqn:?; simpl in H
             | [ H : option_map _ ?x = None |- _ ] => destruct x eqn:?; simpl in H
             | [ H : forall x, _ = _ -> @?T x |- _ ] => specialize (H _ eq_refl)
             | [ H : _ = _ -> ?T |- _ ] => specialize (H eq_refl)
             | [ H : context[_ - 0] |- _ ] => rewrite NPeano.Nat.sub_0_r in H
             | [ |- context[_ - 0] ] => rewrite NPeano.Nat.sub_0_r
             | [ H : context[(_ + 1)%nat] |- _ ] => rewrite NPeano.Nat.add_1_r in H || setoid_rewrite NPeano.Nat.add_1_r in H
             | [ H : ?x > 0 |- _ ] => is_var x; destruct x; [ exfalso; clear -H; omega | clear dependent H ]
             | [ H : ~ ?x > 0 |- _ ] => is_var x; destruct x; [ clear dependent H | exfalso; clear -H; omega ]
             | [ H : 0 > 0 |- _ ] => exfalso; clear -H; omega
             | [ |- and _ _ ] => split
             | _ => progress intros
           end.

  Local Ltac t' :=
    idtac;
    match goal with
      | _ => progress t_eq
      | [ |- index_points_to_binop 0 0 _ ] => eapply index_points_to_binop_spec; [ simpl; rewrite ?drop_0; eassumption | ]
      | _ => rewrite paren_balanced_hiding'_nil by (rewrite take_length; reflexivity)
      | [ H : _ |- _ ] => progress rewrite ?nth_tl in H
      | _ => progress rewrite ?drop_0, ?nth_tl
      | [ |- context[drop _ (take _ _)] ] => rewrite drop_take
      | [ H : context[drop _ (take _ _)] |- _ ] => rewrite drop_take in H
      | [ |- context[get 0 (take _ _)] ] => rewrite get_take_lt by omega
      | [ |- context[nth ?n (map ?f ?ls) _] ] => simpl rewrite (map_nth f ls None n)
      | [ |- context[nth ?n (map ?f ?ls) _] ] => simpl rewrite (map_nth f ls nil n)
      | [ H : context[nth ?n (map ?f ?ls) _] |- _ ] => revert H; simpl rewrite (map_nth f ls None n)
      | [ H : context[nth ?n (map ?f ?ls) _] |- _ ] => revert H; simpl rewrite (map_nth f ls nil n)
      | [ |- index_points_to_binop _ (S _) _ ] => rewrite index_points_to_binop_S2
      | [ H : context[length (take _ _)] |- _ ] => rewrite take_length in H
      | [ H : context[length (drop _ _)] |- _ ] => rewrite drop_length in H
      | [ H : context[drop 0 _] |- _ ] => rewrite drop_0 in H || setoid_rewrite drop_0 in H
      | [ H : context[drop _ (drop _ _)] |- _ ] => rewrite drop_drop in H || setoid_rewrite drop_drop in H
      | [ H : context[take _ (take _ _)] |- _ ] => rewrite take_take in H || setoid_rewrite take_take in H
      | [ H : context[get 0 ?str] |- _ ] => erewrite (proj1 (get_0 str _)) in H by eassumption
      | [ H : context[get 0 (take 0 _)] |- _ ]
        => rewrite has_first_char_nonempty in H by (rewrite take_length; reflexivity)
      | [ |- context[get 0 ?str] ] => erewrite (proj1 (get_0 str _)) by eassumption
      | [ |- context[get 0 (take 0 _)] ]
        => rewrite has_first_char_nonempty by (rewrite take_length; reflexivity)
      | [ H : get 0 _ = Some _ |- _ ] => apply get_0 in H
      | [ H : get 0 _ = None |- _ ] => apply no_first_char_empty in H
      | [ H : context[(take ?n ?str ~= [ _ ])%string_like] |- _ ]
        => pose proof (length_singleton _ _ H);
          progress apply take_n_1_singleton in H
      | [ |- index_not_points_to_binop 0 0 _ ] => eapply index_not_points_to_binop_spec; [ simpl; rewrite ?drop_0; eassumption | ]
      | [ |- index_points_to_binop 0 0 _ ] => eapply index_points_to_binop_spec; [ simpl; rewrite ?drop_0; eassumption | ]
      | [ |- index_points_to_binop (S _) _ _ ] => rewrite index_points_to_binop_S1
      | [ |- index_not_points_to_binop (S _) _ _ ] => rewrite index_not_points_to_binop_S1
      | [ |- index_points_to_binop _ (S _) _ ] => rewrite index_points_to_binop_S2
      | [ |- index_not_points_to_binop _ (S _) _ ] => rewrite index_not_points_to_binop_S2
      | _ => solve [ eauto with nocore ]
    end.

  Local Ltac t := repeat t'.

  Lemma tables_agree {HSLP : StringLikeProperties Char}
        {level str offset}
  : nth offset (map (fun ls => nth level ls None) (list_of_next_bin_ops' str)) None
    = compute_next_bin_op' (drop offset str) level.
  Proof.
    revert level offset.
    set (len := length str).
    generalize (eq_refl : length str = len).
    clearbody len.
    revert str.
    induction len; simpl; intros str Hlen level offset.
    { hnf.
      rewrite compute_next_bin_op'_nil, list_of_next_bin_ops'_nil by (rewrite ?drop_length; omega).
      destruct offset; reflexivity. }
    { specialize (IHlen (drop 1 str)).
      specialize_by (rewrite drop_length; omega).
      setoid_rewrite drop_drop in IHlen.
      t_eq.
      rewrite list_of_next_bin_ops'_recr.
      destruct (get 0 str) eqn:H'; [ | solve [ t ] ].
      destruct offset as [|offset].
      { rewrite compute_next_bin_op'_recr.
        rewrite drop_0, H'.
        unfold list_of_next_bin_ops'_step; simpl.
        rewrite drop_0.
        unfold compute_next_bin_op'_step, list_of_next_bin_ops'_step'.
        rewrite <- !IHlen; clear IHlen.
        repeat match goal with
                 | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
                 | _ => progress t
                 | _ => reflexivity
               end;
          match goal with
            | [ |- context[nth ?n (map ?f ?ls) _] ] => simpl rewrite <- (map_nth f ls nil n)
          end;
          destruct level; reflexivity. }
      { rewrite <- IHlen; clear IHlen.
        reflexivity. } }
  Qed.

  Definition list_of_next_bin_ops_spec''_0_0_bin_op {HSLP : StringLikeProperties Char} {table str idx ch}
             (H_ch : (take 1 str ~= [ch])%string_like)
             (H : is_bin_op ch)
  : list_of_next_bin_ops_spec'' 0 (Some 0 :: table) str 0 idx.
  Proof.
    hnf; t.
  Qed.

  Lemma cell_of_next_bin_ops_spec''_compute_next_bin_op' {HSLP : StringLikeProperties Char}
        {level str offset idx}
  : cell_of_next_bin_ops_spec'' level (compute_next_bin_op' (drop offset str) level) str offset idx.
  Proof.
    revert level offset idx.
    set (len := length str).
    generalize (eq_refl : length str = len).
    clearbody len.
    revert str.
    induction len; simpl; intros str Hlen level offset idx.
    { hnf.
      rewrite compute_next_bin_op'_nil by (rewrite drop_length; omega).
      repeat split; intros.
      { apply index_points_to_binop_nil; omega. }
      { congruence. }
      { apply index_not_points_to_binop_nil; omega. } }
    { specialize (IHlen (drop 1 str)).
      specialize_by (rewrite drop_length; omega).
      setoid_rewrite drop_drop in IHlen; t_eq.
      destruct offset as [|offset];
        [
        | solve [ eauto using cell_of_next_bin_op_spec''_S_offset with nocore ] ].
      rewrite drop_0.
      specialize (fun level => IHlen level 0).
      split.
      { specialize (fun level => IHlen level (pred idx)).
        destruct idx as [|idx].
        { clear IHlen.
          rewrite compute_next_bin_op'_recr.
          unfold compute_next_bin_op'_step.
          repeat match goal with
                   | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
                 end;
          t. }
        { rewrite compute_next_bin_op'_recr.
          repeat match goal with
                   | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
                 end;
            [ | solve [ t ] ].
          rewrite paren_balanced_hiding'_recr.
          repeat match goal with
                   | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
                 end;
            [ | solve [ t ] ].
          unfold compute_next_bin_op'_step, paren_balanced_hiding'_step, paren_balanced'_step, cell_of_next_bin_ops_spec'' in *.
          repeat match goal with
                   | _ => progress t
                   | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
                   | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
                 end. } }
      { specialize (fun level => IHlen level (pred idx)).
        destruct idx as [|idx].
        { clear IHlen.
          rewrite compute_next_bin_op'_recr, paren_balanced'_recr.
          unfold compute_next_bin_op'_step, paren_balanced'_step.
          repeat match goal with
                   | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
                 end;
          t. }
        { simpl in *.
          rewrite compute_next_bin_op'_recr.
          repeat match goal with
                   | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
                 end;
            [ | solve [ t ] ].
          rewrite paren_balanced'_recr.
          repeat match goal with
                   | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
                 end;
            [ | solve [ t ] ].
          unfold compute_next_bin_op'_step, paren_balanced'_step, cell_of_next_bin_ops_spec'' in *.
          repeat match goal with
                   | _ => progress t
                   | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
                   | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
                 end. } } }
  Qed.

  Lemma list_of_next_bin_ops'_satisfies_spec {HSLP : StringLikeProperties Char} (str : String)
  : forall n,
      list_of_next_bin_ops_spec' n (map (fun ls => nth n ls None) (list_of_next_bin_ops' str)) str.
  Proof.
    unfold list_of_next_bin_ops_spec'.
    intros n offset idx.
    unfold list_of_next_bin_ops_spec''.
    rewrite tables_agree.
    apply cell_of_next_bin_ops_spec''_compute_next_bin_op'.
  Qed.

  Lemma list_of_next_bin_ops_satisfies_spec {HSLP : StringLikeProperties Char} (str : String)
  : list_of_next_bin_ops_spec (list_of_next_bin_ops str) str.
  Proof.
    apply list_of_next_bin_ops'_satisfies_spec.
  Qed.
End make_table.

Section for_string.
  Context {HSLM : StringLikeMin Ascii.ascii} {HSL : StringLike Ascii.ascii} {HSLP : StringLikeProperties Ascii.ascii}.
  Context {pdata : paren_balanced_hiding_dataT Ascii.ascii}.

  Definition list_of_next_bin_ops'_step'_opt
    := (fun ch (table_higher_ops : option (list (option nat)) * list (option nat)) =>
          let next_ops := map (option_map S) (match fst table_higher_ops with
                                                | None => nil
                                                | Some ls => ls
                                              end) in
          let '(cur_mark, new_higher_ops) := (nth 0 next_ops None, tl next_ops) in
          (Some (if is_bin_op ch
                 then Some 0 :: new_higher_ops
                 else if is_open ch
                      then new_higher_ops
                      else if is_close ch
                           then None :: next_ops
                           else next_ops))).

  Definition list_of_next_bin_ops'_step_opt
    := (fun ch table_higher_ops =>
          (list_of_next_bin_ops'_step'_opt ch table_higher_ops,
           (match fst table_higher_ops with
              | Some ls => nth 0 ls None :: snd table_higher_ops
              | None => snd table_higher_ops
            end))).

  Definition list_of_next_bin_ops'_opt0 (str : String)
  : option (list (option nat)) * list (option nat)
    := fold
         list_of_next_bin_ops'_step_opt
         (None, nil)
         str.

  Section no_fold.
    Local Arguments fold / _ _ _ _ _ _ _.
    Local Arguments fold' / _ _ _ _ _ _ _ _.
    Local Arguments list_of_next_bin_ops'_opt0 / _.
    Local Arguments list_of_next_bin_ops'_step_opt / _ _.
    Local Arguments list_of_next_bin_ops'_step'_opt / _ _.
    Definition list_of_next_bin_ops'_opt (str : String)
    : option (list (option nat)) * list (option nat)
      := Eval simpl in list_of_next_bin_ops'_opt0 str.
  End no_fold.

  Definition list_of_next_bin_ops_opt (str : String)
    := let ls' := list_of_next_bin_ops'_opt str in
       match fst ls' with
         | Some ls'' => nth 0 ls'' None :: snd ls'
         | None => snd ls'
       end.

  Lemma list_of_next_bin_ops'_opt_correct (str : String)
  : list_of_next_bin_ops'_opt str
    = (nth 0 (map Some (list_of_next_bin_ops' str)) None,
       tl (map (fun ls => nth 0 ls None) (list_of_next_bin_ops' str))).
  Proof.
    change list_of_next_bin_ops'_opt with list_of_next_bin_ops'_opt0.
    unfold list_of_next_bin_ops', list_of_next_bin_ops'_opt0.
    set (len := length str).
    generalize (eq_refl : length str = len).
    clearbody len.
    revert str.
    induction len; intros str H'.
    { rewrite !fold_nil by assumption; reflexivity. }
    { specialize (IHlen (drop 1 str)).
      specialize_by (rewrite drop_length; omega).
      rewrite !(fold_recr _ _ str).
      destruct (get 0 str) eqn:H''.
      { unfold list_of_next_bin_ops'_step_opt at 1.
        rewrite !IHlen; clear IHlen.
        unfold list_of_next_bin_ops'_step'_opt.
        generalize (fold list_of_next_bin_ops'_step [] (drop 1 str)).
        intros ls'.
        unfold list_of_next_bin_ops'_step.
        unfold list_of_next_bin_ops'_step'.
        repeat match goal with
                 | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
                 | _ => progress cbv beta
                 | [ |- context[fst (?x, ?y)] ] =>
                   change (fst (x, y)) with x
                 | [ |- context[snd (?x, ?y)] ] =>
                   change (snd (x, y)) with y
                 | [ |- context[nth 0 (?x::?xs) ?v] ]
                   => change (nth 0 (x::xs) v) with x
                 | [ |- (_, _) = (_, _) ] => apply f_equal2
                 | [ |- context[map ?f (?x::?xs)] ]
                   => change (map f (x::xs)) with (f x :: map f xs)
                 | [ |- Some _ = Some _ ] => apply f_equal
                 | [ |- _::_ = _::_ ] => apply f_equal2
                 | _ => reflexivity
                 | [ |- context[nth 0 (map Some ?ls) None] ]
                   => is_var ls; destruct ls
               end. }
      { reflexivity. } }
  Qed.

  Lemma list_of_next_bin_ops_opt_correct (str : String)
  : list_of_next_bin_ops_opt str = list_of_next_bin_ops str.
  Proof.
    unfold list_of_next_bin_ops_opt, list_of_next_bin_ops.
    rewrite !list_of_next_bin_ops'_opt_correct.
    simpl.
    generalize (list_of_next_bin_ops' str).
    intro ls'.
    destruct ls'; simpl; reflexivity.
  Qed.

  Lemma list_of_next_bin_ops_opt_satisfies_spec (str : String)
  : list_of_next_bin_ops_spec (list_of_next_bin_ops_opt str) str.
  Proof.
    rewrite list_of_next_bin_ops_opt_correct.
    apply list_of_next_bin_ops_satisfies_spec.
  Qed.
End for_string.

Section no_records.
  Section specialized.
    Context {String : Type}.

    Class list_of_next_bin_ops_opt_data :=
      { is_open : Ascii.ascii -> bool;
        is_close : Ascii.ascii -> bool;
        is_bin_op : Ascii.ascii -> bool;
        length : String -> nat;
        get : nat -> String -> option Ascii.ascii;
        unsafe_get : nat -> String -> Ascii.ascii }.
    Context {ldata : list_of_next_bin_ops_opt_data}.

    Section exploded.
      Context (char_at_matches : nat -> String -> (Ascii.ascii -> bool) -> bool)
              (is_char : String -> Ascii.ascii -> bool)
              (take : nat -> String -> String)
              (drop : nat -> String -> String)
              (bool_eq : String -> String -> bool).

      Local Instance temp_pbh : paren_balanced_hiding_dataT Ascii.ascii
        := { is_open := is_open;
             is_close := is_close;
             is_bin_op := is_bin_op }.

      Local Instance temp_hslm : StringLikeMin Ascii.ascii
        := { length := length;
             unsafe_get := unsafe_get;
             char_at_matches := char_at_matches }.

      Local Instance temp_hsl : StringLike Ascii.ascii
        := { is_char := is_char;
             drop := drop;
             take := take;
             get := get;
             bool_eq := bool_eq }.

      Local Arguments list_of_next_bin_ops'_opt / _ _ _ _.
      Definition list_of_next_bin_ops'_opt_nor' (str : String)
      : option (list (option nat)) * list (option nat)
        := Eval simpl in list_of_next_bin_ops'_opt (str : @StringLike.String _ temp_hslm).
    End exploded.

    Definition list_of_next_bin_ops'_opt_nor (str : String)
    : option (list (option nat)) * list (option nat)
      := Eval unfold list_of_next_bin_ops'_opt_nor' in list_of_next_bin_ops'_opt_nor' str.

    Definition list_of_next_bin_ops_opt_nor (str : String)
      := let ls' := list_of_next_bin_ops'_opt_nor str in
         match fst ls' with
           | Some ls'' => nth 0 ls'' None :: snd ls'
           | None => snd ls'
         end.
  End specialized.

  Section correct.
    Context {HSLM : StringLikeMin Ascii.ascii} {HSL : StringLike Ascii.ascii} {HSLP : StringLikeProperties Ascii.ascii}.
    Context {pdata : paren_balanced_hiding_dataT Ascii.ascii}.

    Global Instance default_list_of_next_bin_ops_opt_data : list_of_next_bin_ops_opt_data
      := { is_open := ParenBalanced.Core.is_open;
           is_close := ParenBalanced.Core.is_close;
           is_bin_op := ParenBalanced.Core.is_bin_op;
           length := StringLike.length;
           get := StringLike.get;
           unsafe_get := StringLike.unsafe_get }.

    Lemma list_of_next_bin_ops'_opt_nor_correct (str : String)
    : list_of_next_bin_ops'_opt_nor str
      = (nth 0 (map Some (list_of_next_bin_ops' str)) None,
         tl (map (fun ls => nth 0 ls None) (list_of_next_bin_ops' str))).
    Proof.
      exact (list_of_next_bin_ops'_opt_correct str).
    Qed.

    Lemma list_of_next_bin_ops_opt_nor_correct (str : String)
    : list_of_next_bin_ops_opt_nor str = list_of_next_bin_ops str.
    Proof.
      exact (list_of_next_bin_ops_opt_correct str).
    Qed.

    Lemma list_of_next_bin_ops_opt_nor_satisfies_spec (str : String)
    : list_of_next_bin_ops_spec (list_of_next_bin_ops_opt_nor str) str.
    Proof.
      exact (list_of_next_bin_ops_opt_satisfies_spec str).
    Qed.
  End correct.
End no_records.


Load "preamble2D.v".

(* dans la couche 0 *)
Lemma LABCD : forall A B C D ,
rk(A :: C ::  nil) = 2 -> rk(A :: B :: D ::  nil) = 3 -> rk(C :: D ::  nil) = 2 ->
rk(A :: C :: D ::  nil) = 2 -> rk(A :: B :: C :: D ::  nil) = 3.
Proof.

intros A B C D
HACeq HABDeq HCDeq HACDeq .

(* dans constructProofaux(), preuve de 2 <= rg <= 3 pour ABCD requis par la preuve de (?)ABCD pour la règle 5  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 3 pour ABCD requis par la preuve de (?)ABCD pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HABCDm2 : rk(A :: B :: C :: D :: nil) >= 2).
{
	assert(HACmtmp : rk(A :: C :: nil) >= 2) by (solve_hyps_min HACeq HACm2).
	assert(Hcomp : 2 <= 2) by (repeat constructor).
	assert(Hincl : incl (A :: C :: nil) (A :: B :: C :: D :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (A :: C :: nil) (A :: B :: C :: D :: nil) 2 2 HACmtmp Hcomp Hincl);apply HT.
}

(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HABCDm3 : rk(A :: B :: C :: D :: nil) >= 3).
{
	assert(HABDmtmp : rk(A :: B :: D :: nil) >= 3) by (solve_hyps_min HABDeq HABDm3).
	assert(Hcomp : 3 <= 3) by (repeat constructor).
	assert(Hincl : incl (A :: B :: D :: nil) (A :: B :: C :: D :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (A :: B :: D :: nil) (A :: B :: C :: D :: nil) 3 3 HABDmtmp Hcomp Hincl);apply HT.
}

assert(HABCDM : rk(A :: B :: C :: D ::  nil) <= 3) by (solve_hyps_max HABCDeq HABCDM3).
assert(HABCDm : rk(A :: B :: C :: D ::  nil) >= 1) by (solve_hyps_min HABCDeq HABCDm1).
intuition.
Qed.

(* dans la couche 0 *)
Lemma LABC : forall A B C D ,
rk(A :: C ::  nil) = 2 -> rk(A :: B :: D ::  nil) = 3 -> rk(C :: D ::  nil) = 2 ->
rk(A :: C :: D ::  nil) = 2 -> rk(A :: B :: C ::  nil) = 3.
Proof.

intros A B C D
HACeq HABDeq HCDeq HACDeq .

(* dans constructProofaux(), preuve de 2 <= rg <= 3 pour ABC requis par la preuve de (?)ABC pour la règle 2  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 3 pour ABC requis par la preuve de (?)ABC pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HABCm2 : rk(A :: B :: C :: nil) >= 2).
{
	assert(HACmtmp : rk(A :: C :: nil) >= 2) by (solve_hyps_min HACeq HACm2).
	assert(Hcomp : 2 <= 2) by (repeat constructor).
	assert(Hincl : incl (A :: C :: nil) (A :: B :: C :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (A :: C :: nil) (A :: B :: C :: nil) 2 2 HACmtmp Hcomp Hincl);apply HT.
}

(* Application de la règle 2 code (7 ou 8 dans la thèse) conclusion A*)
(* marque des antécédents AUB AiB B: 4 -4 et -4*)
assert(HABCm3 : rk(A :: B :: C :: nil) >= 3).
{
	assert(HACDMtmp : rk(A :: C :: D :: nil) <= 2) by (solve_hyps_max HACDeq HACDM2).
	assert(HABCDeq : rk(A :: B :: C :: D :: nil) = 3) by (apply LABCD with (A := A) (B := B) (C := C) (D := D) ; assumption).
	assert(HABCDmtmp : rk(A :: B :: C :: D :: nil) >= 3) by (solve_hyps_min HABCDeq HABCDm3).
	assert(HACmtmp : rk(A :: C :: nil) >= 2) by (solve_hyps_min HACeq HACm2).
	assert(Hincl : incl (A :: C :: nil) (list_inter (A :: B :: C :: nil) (A :: C :: D :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (A :: B :: C :: D :: nil) (A :: B :: C :: A :: C :: D :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (A :: B :: C :: A :: C :: D :: nil) ((A :: B :: C :: nil) ++ (A :: C :: D :: nil))) by (clear_all_rk;my_inO).
	try rewrite HT1 in HABCDmtmp;try rewrite HT2 in HABCDmtmp.
	assert(HT := rule_2 (A :: B :: C :: nil) (A :: C :: D :: nil) (A :: C :: nil) 3 2 2 HABCDmtmp HACmtmp HACDMtmp Hincl);apply HT.
}

assert(HABCM : rk(A :: B :: C ::  nil) <= 3) by (solve_hyps_max HABCeq HABCM3).
assert(HABCm : rk(A :: B :: C ::  nil) >= 1) by (solve_hyps_min HABCeq HABCm1).
intuition.
Qed.

(* dans la couche 0 *)
Theorem essai_Conclusion : forall A B C D ,
rk(A :: C ::  nil) = 2 -> rk(A :: B :: D ::  nil) = 3 -> rk(C :: D ::  nil) = 2 ->
rk(A :: C :: D ::  nil) = 2 ->
	 rk(A :: B :: C ::  nil) = 3  .
Proof.

intros A B C D
HACeq HABDeq HCDeq HACDeq .
repeat split.

	apply LABC with (A := A) (B := B) (C := C) (D := D) ; assumption.
Qed .