From Futhark Require Import FutharkExtract.
From Futhark Require Import FutharkPretty.
From ConCert.Extraction Require Import Common.
From ConCert.Extraction Require Import Utils.
From ConCert.Utils Require Import StringExtra.

From Coq Require Import Datatypes.
From Coq Require Import String.
From Coq Require Import ZArith.
From Coq Require Import List.
From Coq Require Import Arith.
From Coq Require Import Floats.

From MetaCoq.Template Require Import All.
From MetaCoq.Template Require Import monad_utils.

Import MonadNotation.
From stdpp Require  base.

Import ListNotations.

Open Scope string.
Open Scope pair_scope.

(** Extracts [program] to Futhark, adds a new definition [extracted_name]
    with the extracted program and also prints the program.
    The definition with the extracted program can be used later on
    to redirect to a file, for example. *)
Definition extract_and_print {A}
           (extracted_name : string)
           (prelude : string)
           (translate_constants : list (BasicAst.kername * string))
           (translate_ctors : list (string * string))
           (tests : option FutharkTest)
           (program : A) :=
  res <- futhark_extraction "" prelude translate_constants translate_ctors tests program;;
  match res with
  | inl s => tmDefinition extracted_name s;;
             tmMsg s
  | inr s => tmFail s
  end.

Definition float_zero := S754_zero false.

Definition nat_to_float : nat -> spec_float :=
    fun n => match n with
          | O => float_zero
          | S _ => S754_finite false (Pos.of_nat n) 0
          end.

(** We remap Coq's types to the corresponding Futhark types.
 All required operations should be remapped as well. *)
Definition TT :=
  [
   (* natural numbers *)
    remap <%% nat %%> "i64"
  ; remap <%% plus %%> "addI64"
  ; remap <%% mult %%> "multI64"

    (* integers *)
  ; remap <%% Z %%> "i64"
  ; remap <%% Z.add %%> "addI64"
  ; remap <%% Z.mul %%> "multI64"

   (* floats *)
  ; remap <%% spec_float %%> "f64"
  ; remap <%% float_zero %%> "0.0"
  ; remap <%% SF64add %%> "addF64"
  ; remap <%% SF64div %%> "divF64"
  ; remap <%% nat_to_float %%> "f64.i64"

  (* bools *)
  ; remap <%% bool %%> "bool"
    (* lists *)
  ; remap <%% list %%> "[]"
  ; remap <%% @List.length %%> "length"
  ; remap <%% List.fold_right %%> "reduce"

   (* subset types *)
  ; remap <%% sig %%> "sig_"
  ; remap <%% @proj1_sig %%> "id"
].

Definition TT_ctors :=
  [ ("O", "0i64")
  ; ("Z0", "0i64")
  ; ("true", "true")
  ; ("false", "false")].

Open Scope string.

Module PatternMatching.

  Inductive Dec :=
  | Yes (_ : Z)
  | No (_ : Z).

  Definition add_dec (d1 d2 : Dec) : Z :=
    match d1,d2 with
    | Yes i1, Yes i2
    | Yes i1, No i2
    | No i1, Yes i2
    | No i1, No i2  => i1 + i2
    end.

  MetaCoq Run (extract_and_print
                 "add_dec_futhark"
                 i64_ops
                 TT
                 TT_ctors
                 None
                 add_dec).
End PatternMatching.

Module TupleMatch.
  (** Example of how deconstructing tuples with match or let
      expressions work. *)

  Definition tmatch (x : Z * Z * Z * Z) :=
    match x with
    | (y, _, _, _) => y
    end.

  Definition tlet (x : Z * Z * Z * Z) :=
    let '(y, _, _, _) := x in y.

  Definition twiceFirst (x : Z * Z * Z * Z) := (tmatch x, tlet x).

  MetaCoq Run (extract_and_print "tuple_match_futhark" "" TT []
                                  None
                                  twiceFirst).

End TupleMatch.

Module Sum.

  (** A simple example of reduction *)

  Definition sum (xs: list nat) := fold_right plus 0 xs.

  Definition test_input := [4;3;2;1].
  Definition test_output := 10.

  Example sum_test : sum test_input = test_output. reflexivity. Qed.

  Definition futhark_sum_test :=
    {| FTname := "Sum test"
     ; FTinput := string_of_list (fun n => string_of_nat n ++ "i64") test_input
     ; FToutput := string_of_nat test_output ++ "i64" |}.

  MetaCoq Run (extract_and_print "sum_futhark" i64_ops TT TT_ctors
                                  (Some futhark_sum_test)
                                  sum).

End Sum.

Module Average.

  (** An example from the fronpage of https://futhark-lang.org/ *)

  (** We use the [spec_float] type, which is a specification of IEEE754 floating-point numbers in Coq.
   That allows for proving properties related to the precision of operations on floats.*)

  Open Scope float.

  Definition average (xs: list spec_float) : spec_float :=
    SF64div (fold_right SF64add float_zero xs) (nat_to_float (length xs)).

  Example average_test : average (map Prim2SF [10.5; 20.5]) = Prim2SF 15.5.
  Proof. reflexivity. Qed.

  Definition futhark_average_test :=
    {| FTname := "Average test"
     ; FTinput := "[10.5f64,20.5f64]" (* we can't print float literals currently *)
     ; FToutput := "15.5f64" |}.

  MetaCoq Run (extract_and_print "average_futhark" f64_ops TT TT_ctors
                                  (Some futhark_average_test)
                                  average).

End Average.

Module Monoid.
  (** In this example, we provide a "safe" parallel reduction operation.
   It is safe in the sense that it requires an operation and a neutral element of a carrier type to be a monoid *)

  Class IsMonoid (M : Type) (op : M -> M -> M) (e : M) : Prop:=
    { munit_left : forall m, op e m = m;
      munit_right : forall m, op m e = m;
      massoc : forall m1 m2 m3, op m1 (op m2 m3) = op (op m1 m2) m3
    }.

  Definition parallel_reduce {A : Type} (op : A -> A -> A) (e : A) `{IsMonoid A op e} (xs : list A) :=
    fold_right op e xs.

  (** We cannot define [sum], because Coq cannot find appropriate instance *)
  Fail Definition sum (xs : list Z) := parallel_reduce Z.add 0%Z.

  (** So, we define the required instance *)
  #[refine]
  Instance Z_add_monoid : IsMonoid Z Z.add 0%Z :=
    {| munit_left := fun m => _;
       munit_right := _;
       massoc := _
    |}.
  * reflexivity.
  * apply Z.add_0_r.
  * intros;apply Z.add_assoc.
  Defined.

  (** Now, it works as expected *)
  Definition sum (xs : list Z) := parallel_reduce Z.add 0%Z.

  (** We tell our extraction that our parallel reduce is Futhark's reduce *)
  Definition TT_extra :=
    [ remap <%% @parallel_reduce %%> "reduce"].

  (** The witness of the instance [Z_add_monoid] is erased, because it's a proposition.
   So, we are left with an ordinary Futhark function *)
  MetaCoq Run (extract_and_print "sum_futhark" i64_ops (TT ++ TT_extra) TT_ctors
                                  None
                                  sum).
  (* Geneterates the following function: *)
  (* let sum  = reduce addI32 0i32 *)
End Monoid.

Module DotProduct.

  Open Scope Z.

  Definition map2 {A B C : Type} (f : A -> B -> C) (xs : list A) (ys : list B)
             (p : length xs = length ys) : list C :=
    map (fun '(x,y) => f x y) (combine xs ys).

  Definition TT_extra :=
    [ remap <%% @map2 %%> "map2"
    ; remap <%% List.split %%> "unzip"].

  (** A function computing a dot product of two lists.
   It also takes a proof that the two lists have the same length.
   Eventually, we should be able to use vectors (sized lists) in such functions *)
  Definition dotprod (xs: list Z) (ys: list Z) (p : length xs = length ys):=
    fold_right Z.add 0%Z (map2 Z.mul xs ys p).

  (** The input is a list of pairs, which is basically N x 2 matrix.
   We take a dot product of the two vertical columns.
   We can prove that the sizes of the arguments to [dotprod] are of the same size *)
  Program Definition dotprod_list_of_pairs (xs : list (Z * Z)) :=
    let pair_of_lists := List.split xs in
    dotprod pair_of_lists.1 pair_of_lists.2 _.
  Next Obligation.
    intros. subst pair_of_lists.
    now rewrite split_length_l, split_length_r.
  Defined.

  Definition test_input :=
    [(1, 4)
    ;(2,-5)
    ;(3, 6)].

  Definition test_output := 12.

  Example dotprod_test : dotprod_list_of_pairs test_input = test_output. reflexivity. Qed.

  Definition futhark_dotprod_test :=
    {| FTname := "Dotproduct test"
     ; FTinput := string_of_list
                      (fun '(n,m) => parens false (string_of_Z n ++ "," ++ string_of_Z m)) test_input
     ; FToutput := string_of_Z test_output |}.

  (** Unfortunately, Futhark test syntax doesn't support tuples, so we don't generate the test *)
  MetaCoq Run (extract_and_print "dotprod_list_of_pairs_futhark" i64_ops (TT ++ TT_extra) TT_ctors
                                 None
                                 dotprod_list_of_pairs).

End DotProduct.

Notation "[| n |] A" := ({ xs : list A | #|xs| = n }) (at level 100).

Module RefinementTypes.

  Import Lia.

  Hint Resolve combine_length : core.

  Program Definition zip {A B n} (xs : [|n|]A) (ys : [|n|]B) : [|n|](A*B) :=
    combine xs ys.
  Next Obligation.
    intros;destruct xs,ys;cbn. rewrite combine_length;lia.
  Qed.

  Program Definition concat {A n m} (xs : [|n|]A) (ys : [|m|]A) : [|n+m|]A
    := (xs ++ ys)%list.
  Next Obligation.
    intros;destruct xs,ys;cbn;subst;apply app_length; lia.
  Qed.

  (** In this example we use commutativity of addition to type check the definition *)
  Program Definition zip_concat_swap {n m} (xs : [|n|]Z) (ys : [|m|]Z)
    : [| m+n |] (Z * Z) :=
    zip (concat xs ys) (concat ys xs).
  Next Obligation.
    cbn;intros. destruct xs,ys;cbn;subst. rewrite app_length; lia.
  Qed.
  Next Obligation.
    intros. destruct xs,ys;cbn;subst.
    rewrite combine_length; repeat rewrite app_length. lia.
  Qed.

  Program Definition zip_self {n} (xs : {l : list Z | length l = n}) : {l | length l = n } := zip xs xs.

  Definition TT_extra :=
    [ remap <%% @zip %%> "zip"
    ; remap <%% @concat %%> "concat"
    ].

  (** The statement below produces "almost compilable" code :)
     It requires some type coercions to be inserted in order to compile *)
  MetaCoq Run (extract_and_print "zip_concat_swap_futhark" sig_defs
                                 (TT ++ TT_extra)
                                 TT_ctors
                                 None
                                 zip_concat_swap).
End RefinementTypes.

Module Indexing.

  Import Lia.

  Program Definition safe_index {A} : forall (l : list A), {n : nat | n < List.length l} -> A :=
    fix go (l : list A) (n : nat | n < List.length l) : A :=
      match l with
      | nil => _
      | hd :: tl =>
        match n with
        | 0 => hd
        | S n => go tl n
        end
      end.
  Next Obligation.
  intros;subst;cbn in *. destruct n as [n Hn]. exfalso;inversion Hn.
  Defined.
  Next Obligation.
    intros. subst;simpl in *. destruct n0 as [n1 Hn1].
    subst filtered_var. cbn in *. subst. auto with arith.
  Defined.

  Fixpoint repl_iota_aux (i : nat) (xs : list nat) : list nat :=
    match xs with
    | [] => []
    | x :: xs' => repeat i x ++ repl_iota_aux (1+i) xs'
    end.

  Definition repl_iota := repl_iota_aux 0.

  Example repl_iota_1 : repl_iota [2;3;1] = [0;0;1;1;1;2].
  Proof. reflexivity. Qed.

  Example repl_iota_2 : repl_iota [1;2;3] = [0;1;1;2;2;2].
  Proof. reflexivity. Qed.

  Lemma repl_iota_aux_decompose n i a l :
    In i (repeat n a ++ repl_iota_aux (1+n) l) ->
    i = n \/ In i (repl_iota_aux (1+n) l).
  Proof.
    intros H.
    apply Erasure.In_app_inv in H.
    destruct H.
    - apply repeat_spec in H;auto.
    - auto.
  Qed.

  Lemma repl_iota_aux_lt {n i xs} :
    In i (repl_iota_aux n xs) ->
    i < n + #|xs|.
  Proof.
    revert dependent i.
    revert dependent n.
    induction xs;intros n i H.
    - inversion H.
    - cbn in *.
      apply repl_iota_aux_decompose in H.
      destruct H.
      * lia.
      * replace (n + S #|xs|) with (S n + #|xs|) by lia.
        apply IHxs;auto.
  Qed.

  Program Definition repl_iota_rt {n} (xs : [|n|]nat) :
    {l : list nat | forall i, In i l -> i < n } :=
    repl_iota xs.
  Next Obligation.
    cbn;intros n xs i H.
    destruct xs as [l Hsize];cbn in *. subst.
    apply @repl_iota_aux_lt with (n:=0);auto.
  Qed.

  (** The implementation is a bit tricky, because while we map through [idxs]
      we need to know that each element is actually coming from [idxs].
      If we use the standard [map], this information is lost.
      For that reason we use [map_In], which takes a function of two arguments:
      an element of a list and a proof that this element is in the list passed to [map_In] as an argument *)
  Program Definition segm_replicate {n} (reps : [|n|]nat) (vs : [|n|]nat)
    : list nat :=
    let idxs := repl_iota_rt reps in
    map_In idxs (fun i Hin => safe_index vs i).

  Next Obligation.
    intros. cbn.
    destruct idxs as [l Hl];cbn in *.
    destruct vs;cbn in *; subst;auto.
  Qed.

  Definition prelude_extra :=
     "import ""../lib/repl_iota""" ++ nl ++(* we treat [repl_iota] as a library function *)
      "" ++ nl ++
      "let unsafe_index 'a (xs : []a) (i: i64) : a = #[unsafe] xs[i]" ++ nl ++
        (* we also need a wrapper around our [map_In] function, since it's signature differs from the Futhark's [map] *)
      "let map_wrapper 'a 'b (xs : []a) (f : a -> () -> b) : []b = map (\x -> f x ()) xs".

  Definition TT_extra :=
    [ remap <%% @Utils.map_In %%> "map_wrapper"
    ; remap <%% @repl_iota_rt %%> "repl_iota"
    ; remap <%% @safe_index %%> "unsafe_index"
    ].

  (* NOTE: Clearly, using [segm_replicate] as a "library" function is not safe,
     because the invariant that the two arrays are of the same size is erased
     and curretnly we don't generate explicit sizes for the array types.
     However, it could be called from a wrapper that ensures the required
     preconditions hold. *)
  MetaCoq Run (extract_and_print "segm_replicate_futhark"
                                     (prelude_extra ++ nl ++ sig_defs)
                                     (TT ++ TT_extra)
                                     TT_ctors
                                     None
                                     segm_replicate).
End Indexing.

(** Here, we redirect the previuosly extracted programs to files *)
(** This part cannot be evaluated in the interactive mode, because one has to provide fixed paths. Therefore, we use path from the project's root, so it works when building the project using [makefile] *)

(* NOTE: we use [MetaCoq Run (tmMsg ...)] instead of [Print], because
   [Print] adds some extra stuff, which we don't need *)

Redirect "./extracted/auto-generated/pattern_matching.fut"
         MetaCoq Run (tmMsg PatternMatching.add_dec_futhark).

Redirect "./extracted/auto-generated/tuple_match.fut"
         MetaCoq Run (tmMsg TupleMatch.tuple_match_futhark).

Redirect "./extracted/auto-generated/average.fut"
         MetaCoq Run (tmMsg Average.average_futhark).

Redirect "./extracted/auto-generated/monoid.fut"
         MetaCoq Run (tmMsg Monoid.sum_futhark).

Redirect "./extracted/auto-generated/dot_product.fut"
         MetaCoq Run (tmMsg DotProduct.dotprod_list_of_pairs_futhark).

(* NOTE: this example is currently does not compile without some manual editing.
   It requres a type coercion, which we cannot insert automatically yet. *)
(* Redirect "./extracted/auto-generated/refinement_types.fut" *)
(*          MetaCoq Run (tmMsg RefinementTypes.zip_concat_swap_futhark). *)

Redirect "./extracted/auto-generated/segm_replicate.fut"
         MetaCoq Run (tmMsg Indexing.segm_replicate_futhark).


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Build a table for the next binop at a given level *)
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
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.


Require Import Coqlib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import Mem1.

Set Implicit Arguments.

Section PROOF.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG memRA Σ}.

  (* def new(): Ptr *)
  (*   Ptr stk = alloc(1); *)
  (*   return stk *)

  Definition newF: list val -> itree Es val :=
    fun args =>
      _ <- (pargs [] args)?;;
      `new_node: val  <- (ccallU "alloc" [Vint 1]);;
      assume(wf_val new_node);;;
      `_: val         <- (ccallU "store" [new_node; Vnullptr]);;
      Ret new_node
  .

  (* def pop(Ptr stk): Int64 *)
  (*   let hd := load(stk, 0); *)
  (*   if(ptrcmp(hd, NULL) != 0) { *)
  (*     let v    := load(hd, 0); *)
  (*     let next := load(hd, 1); *)
  (*     free(hd, 2); *)
  (*     store(stk, 0, next); *)
  (*     return v *)
  (*   } *)
  (*   return -1 *)

  Definition popF: list val -> itree Es val :=
    fun args =>
      `stk: mblock <- (pargs [Tblk] args)?;;
      `hd: val  <- (ccallU "load" [Vptr stk 0]);;
      assume(wf_val hd);;;
      `b: val   <- (ccallU "cmp"  [hd; Vnullptr]);;
      assume((wf_val b) /\ (match b with | Vint _ => True | _ => False end));;;
      if dec (Vint 0) b
      then (
          let addr_val    := hd in
          assume (match addr_val with | Vptr _ 0 => True | _ => False end);;;
          `addr_next: val <- (vadd hd (Vint 8))?;;
          `v: val         <- (ccallU "load"  [addr_val]);;
          `next: val      <- (ccallU "load"  [addr_next]);;
          `_: val         <- (ccallU "free"  [addr_val]);;
          `_: val         <- (ccallU "free"  [addr_next]);;
          `_: val         <- (ccallU "store" [Vptr stk 0; next]);;
          Ret v
        )
      else Ret (Vint (- 1))
  .

  (* def push(Ptr stk, Int64 n): Unit *)
  (*   let new_node := alloc(2); *)
  (*   store(new_node, 0, n); *)
  (*   let hd := load(stk, 0); *)
  (*   store(new_node, 1, hd); *)
  (*   store(stk, 0, new_node); *)
  (*   return () *)

  Definition pushF: list val -> itree Es val :=
    fun args =>
      '(stk, v)      <- (pargs [Tblk; Tuntyped] args)?;;
      `new_node: val <- (ccallU "alloc" [Vint 2]);;
      let addr_val   := new_node in
      assume(match addr_val with | Vptr _ 0 => True | _ => False end);;;
      addr_next      <- (vadd new_node (Vint 8))?;;
      `hd: val       <- (ccallU "load"  [Vptr stk 0]);;
      `_: val        <- (ccallU "store" [addr_val;   v]);;
      `_: val        <- (ccallU "store" [addr_next; hd]);;
      `_: val        <- (ccallU "store" [Vptr stk 0; new_node]);;
      Ret Vundef
  .

  Definition StackSem: ModSem.t := {|
    ModSem.fnsems := [("new", cfunU newF); ("pop", cfunU popF); ("push", cfunU pushF)];
    ModSem.mn := "Stack";
    ModSem.initial_st := tt↑;
  |}
  .

  Definition Stack: Mod.t := {|
    Mod.get_modsem := fun _ => StackSem;
    Mod.sk := [("new", Sk.Gfun); ("pop", Sk.Gfun); ("push", Sk.Gfun)];
  |}
  .
End PROOF.


Require Import Common.Definitions.
Require Import Common.Values.
Require Import Source.Language.
Require Import Intermediate.CS.
Require Import Intermediate.GlobalEnv.
Require Import S2I.Compiler.
Require Export Extraction.Definitions.

Definition compile_and_run (p: Source.program) (fuel: nat) :=
  match compile_program p with
  | None => print_error ocaml_int_0
  | Some compiled_p =>
    let G := prepare_global_env compiled_p in
    let st := CS.initial_machine_state compiled_p in
    match CS.execN fuel G st with
    | None => print_error ocaml_int_1
    | Some n => print_ocaml_int (z2int n)
    end
  end.


Require Export Util.

(*-----  Abstract Data Type  -----*)

(*  Heap Type  *)

Module Type HEAP.

Parameter name : Set.
Parameter rtype : Set.
Parameter ref : Set.
Parameter alloc : Set.
Parameter super_env : Type.
Parameter field_type : Type.
Parameter type_env : Type.

Parameter heap : Type.
Parameter empty_heap : heap.

Parameter get : ref -> name -> heap -> option ref.
Parameter update : ref -> name -> ref -> heap -> heap.
Parameter new : ref -> field_type -> heap -> heap.
Parameter remove : ref -> name -> heap -> heap.
Parameter pin : ref -> name -> ref -> heap -> Prop.

Parameter pdisjoint : heap -> heap -> Prop.
Parameter union : heap -> heap -> heap. (* the two heaps should be disjoint *)
Parameter beq : heap -> heap -> bool.
Parameter eq : heap -> heap -> Prop.
Parameter subheap : heap -> heap -> Prop.

Parameter well_formed : super_env -> type_env -> heap -> Prop.

Infix "|=|" := eq (at level 70) : heap_scope.
Infix "|+|" := union (at level 60, right associativity) : heap_scope.
Infix "|*|" := pdisjoint (at level 50) : heap_scope.
Infix "|<|" := subheap (at level 70) : heap_scope.
Notation "{}" := empty_heap : heap_scope.

Open Scope heap_scope.

Axiom beq_refl : forall x : heap, beq x x = true.
Axiom beq_sym : forall x y : heap, beq x y = true <-> beq y x = true.
Axiom beq_trans : forall x y z : heap, beq x y = true -> beq y z = true -> beq x z = true.

Axiom eq_refl : forall x : heap, x |=| x.
Axiom eq_sym : forall x y : heap, x |=| y -> y |=| x.
Axiom eq_trans : forall x y z : heap, x |=| y -> y |=| z -> x |=| z.

Axiom subheap_refl : forall h : heap, h |<| h.
Axiom subheap_asym : forall h1 h2 : heap, h1 |<| h2 -> h2 |<| h1 -> h1 |=| h2.
Axiom subheap_trans : forall h1 h2 h3 : heap, h1 |<| h2 -> h2 |<| h3 -> h1 |<| h3.
Axiom subheap_union : forall h1 h2 : heap, h1 |<| h2 |+| h1.

Axiom update_update : forall r1 n r2 r3 h,
    update r1 n r2 h = update r1 n r2 (update r1 n r3 h).

Axiom in_update_1 : forall r1 n r2 h, pin r1 n r2 (update r1 n r2 h).
Axiom in_update_2 : forall r1 r2 r3 r4 n1 n2 h,
    (r1 <> r2 \/ n1 <> n2) -> pin r1 n1 r3 h -> pin r1 n1 r3 (update r2 n2 r4 h).
Axiom in_update_3 : forall r1 r2 r3 r4 n1 n2 h,
    (r1 <> r2 \/ n1 <> n2) -> pin r1 n1 r3 (update r2 n2 r4 h) -> pin r1 n1 r3 h.
Axiom in_get : forall r1 r2 n h, pin r1 n r2 h <-> get r1 n h = Some r2.
Axiom not_in_get : forall r1 n h, (forall r2, ~ pin r1 n r2 h) <-> get r1 n h = None.

Axiom in_union_1 : forall r1 n r2 h1 h2,
    pin r1 n r2 (h1 |+| h2) <-> pin r1 n r2 h1 \/ pin r1 n r2 h2.
Axiom in_union_2 : forall r1 n r2 h1 h2,
    ~ pin r1 n r2 h1 -> (pin r1 n r2 h2 <-> pin r1 n r2 (h1 |+| h2)).
Axiom not_in_empty_1 : forall r1 n r2, ~ pin r1 n r2 {}.
Axiom in_equal : forall (r r1 r2 : ref) (n : name) (h : heap),
    pin r n r1 h -> pin r n r2 h -> r1 = r2.

Axiom pdisjoint_empty : forall x : heap, x |*| {}.
Axiom pdisjoint_sym : forall x y : heap, x |*| y -> y |*| x.
Axiom pdisjoint_union : forall h1 h2 h3 : heap,
    h1 |*| (h2 |+| h3) <-> h1 |*| h2 /\ h1 |*| h3.
Axiom pdisjoint_self : forall h : heap, h |*| h -> h |=| {}.

Axiom equal_1 : forall h1 h2 : heap, h1 |=| h2 -> beq h1 h2 = true.
Axiom equal_2 : forall h1 h2 : heap, beq h1 h2 = true -> h1 |=| h2.
Axiom equal_3 : forall h1 h2 : heap, h1 = h2 <-> h1 |=| h2.
Axiom union_emp : forall h : heap, {} |+| h |=| h.
Axiom union_comm : forall h1 h2 : heap, h1 |+| h2 |=| h2 |+| h1.
Axiom union_asso : forall h1 h2 h3 : heap,
    h1 |+| h2 |+| h3 |=| (h1 |+| h2) |+| h3.

Axiom not_in_remove_1 : forall r1 n r2 h, ~ pin r1 n r2 (remove r1 n h).
Axiom in_remove_2 : forall r1 r2 r3 n1 n2 h,
    (r1 <> r2 \/ n1 <> n2) -> pin r1 n1 r3 h -> pin r1 n1 r3 (remove r2 n2 h).
Axiom in_remove_3 : forall r1 r2 r3 n1 n2 h,
    pin r1 n1 r3 (remove r2 n2 h) -> pin r1 n1 r3 h.
Axiom disjoint_remove : forall r1 n r2 h,
    remove r1 n h |*| update r1 n r2 {}.

Close Scope heap_scope.

End HEAP.

(*-----  Data  -----*)

(*  Heap  *)

Module Heap <: HEAP.

Definition name := Name.name.
Definition rtype := RType.rtype.
Definition ref := Ref.ref.
Definition alloc := Ref.alloc.
Definition super_env := RType.super_env.
Definition field_type := RType.field_type.
Definition type_env := RType.type_env.

Definition obj := Smap.t ref.
Definition heap := Rmap.t obj.
Definition empty_heap := Rmap.empty obj.

Definition get (r : ref) (n : name) (h : heap) : option ref :=
    match Rmap.find r h with
        | None => None
        | Some o => Smap.find n o
    end.

Definition update (r : ref) (n : name) (r1 : ref) (h : heap) : heap :=
    match Rmap.find r h with
        | None => Rmap.add r (Smap.add n r1 (Smap.empty ref)) h
        | Some o => Rmap.add r (Smap.add n r1 o) h
    end.

Definition remove (r : ref) (n : name) (h : heap) : heap :=
    match Rmap.find r h with
        | None => h
        | Some o => Rmap.add r (Smap.remove n o) h
    end.

Definition pin (r : ref) (n : name) (r1 : ref) (h : heap) : Prop :=
    exists o, Rmap.MapsTo r o h /\ Smap.MapsTo n r1 o.

Definition new (r : ref) (f : field_type) (h : heap) : heap :=
    Rmap.add r (Smap.map (fun _ => Ref.rnull) f) h.

Definition pdisjoint (h1 h2 : heap) : Prop :=
    forall (r1 r2 r3 : ref) (n : name), ~ (pin r1 n r2 h1 /\ pin r1 n r3 h2).

Definition union1 (r : ref) (o : obj) (h : heap) : heap :=
    match Rmap.find r h with
        | None => Rmap.add r o h
        | Some o1 => Rmap.add r (Smap.fold (Smap.add (elt:=ref)) o1 o) h
    end.
Definition union (h1 h2 : heap) : heap :=
    Rmap.fold union1 h1 h2.

Definition beq (h1 h2 : heap) : bool :=
    Rmap.equal (Smap.equal Ref.beq) h1 h2.

(* 如果 h1 与 h2 相差一个空对象，eq h1 h2 仍成立 *)
Definition eq (h1 h2 : heap) : Prop :=
    forall (r1 r2 : ref) (n : name), pin r1 n r2 h1 <-> pin r1 n r2 h2.

Definition subheap (h1 h2 : heap) : Prop :=
    forall (r1 r2 : ref) (n : name), pin r1 n r2 h1 -> pin r1 n r2 h2.

Bind Scope heap_scope with heap.
Delimit Scope heap_scope with heap.

Infix "|=|" := eq (at level 70) : heap_scope.
Infix "|+|" := union (at level 60, right associativity) : heap_scope.
Infix "|*|" := pdisjoint (at level 50) : heap_scope.
Infix "|<|" := subheap (at level 70) : heap_scope.
Notation "{}" := empty_heap : heap_scope.

Open Scope heap_scope.

Definition check_attr (s : super_env) (f : field_type) (n : name) (r : ref) (p : Prop) : Prop :=
    match Smap.find n f with
        | None => False
        | Some t =>
            (RType.subtype (Ref.get_type r) t s) /\ p
    end.
Definition check_obj (s : super_env) (te : type_env) (r : ref) (o : obj) (p : Prop) : Prop :=
    match Smap.find (Ref.get_type r) te with
        | None => False
        | Some f =>
            (o <> Smap.empty ref \/ f = Smap.empty rtype) /\
            (Smap.fold (check_attr s f) o p)
    end.
Definition well_formed (s : super_env) (te : type_env) (h : heap) : Prop :=
    Rmap.fold (check_obj s te) h True.

Axiom equal_1 : forall h1 h2 : heap, h1 |=| h2 -> beq h1 h2 = true.
Lemma equal_2 : forall h1 h2 : heap, beq h1 h2 = true -> h1 |=| h2.
Proof.
  unfold beq; unfold eq. intros h1 h2 H r1 r2 n.
  apply Rmap.equal_2 in H.
  unfold Rmap.Equivb in H.
  unfold Rmap.Raw.Equivb in H.
  assert (forall r1 r2, Ref.beq r1 r2 = true <-> r1 = r2).
  intros r0 r3. apply lr_trans with (b := Ref.peq r0 r3).
  apply Ref.equal_1. apply Ref.equal_2.
  destruct H. unfold pin. split. intro H2.
  do 2 destruct H2. exists x. split.
  assert (Rmap.Raw.PX.In r1 (Rmap.this h1)).
  unfold Rmap.Raw.PX.In. exists x; apply H2.
  apply H in H4. unfold Rmap.Raw.PX.In in H4.
  destruct H4. apply H1 with (e' := x0) in H2.
  apply smap_equal with (m1 := x) (m2 := x0) in H0.
  apply H0 in H2. rewrite H2. assumption.
  assumption. assumption. intro H2.
  do 2 destruct H2. exists x. split.
  assert (Rmap.Raw.PX.In r1 (Rmap.this h2)).
  unfold Rmap.Raw.PX.In. exists x; apply H2.
  apply H in H4. unfold Rmap.Raw.PX.In in H4.
  destruct H4. assert (x0 = x).
  apply H1 with (e' := x) in H4.
  apply smap_equal with (m1 := x0) (m2 := x) in H0.
  apply H0; assumption. assumption.
  rewrite <- H5. assumption. assumption.
Qed.
Lemma equal_3 : forall h1 h2 : heap, h1 = h2 <-> h1 |=| h2.
Proof.
  unfold eq. intros h1 h2. split.
  intros H r1 r2 n. apply equal_2.
  apply rmap_equal. intros e1 e2.
  apply smap_equal. intros e0 e3.
  apply lr_trans with (b := Ref.peq e0 e3).
  apply Ref.equal_1. apply Ref.equal_2. assumption.
  intro H. apply equal_1 in H. unfold beq in H.
  assert (forall r1 r2, Ref.beq r1 r2 = true <-> r1 = r2).
  intros r1 r2. apply lr_trans with (b := Ref.peq r1 r2).
  apply Ref.equal_1. apply Ref.equal_2.
  assert (forall o1 o2, (Smap.equal Ref.beq) o1 o2 = true <-> o1 = o2).
  apply smap_equal. assumption.
  apply rmap_equal with (m1 := h1) (m2 := h2) in H1.
  apply H1; assumption.
Qed.

Lemma beq_refl : forall x : heap, beq x x = true.
Proof.
  intro x. unfold beq.
  apply rmap_refl_2. intro.
  apply smap_refl_2. intro.
  apply Ref.beq_refl.
Qed.
Lemma beq_sym : forall x y : heap, beq x y = true <-> beq y x = true.
Proof.
  intros x y. unfold beq. split.
  apply rmap_sym_2. intros.
  apply smap_sym_2. intros.
  apply Ref.beq_sym.
  assumption. assumption.
  apply rmap_sym_2. intros.
  apply smap_sym_2. intros.
  apply Ref.beq_sym.
  assumption. assumption.
Qed.
Lemma beq_trans : forall x y z : heap, beq x y = true -> beq y z = true -> beq x z = true.
Proof.
  unfold beq. intros x y z.
  apply rmap_trans_2 with (e2 := y). intros.
  apply smap_trans_2 with (e2 := t2). intros.
  apply Ref.beq_trans with (y := t4).
  assumption. assumption.
  assumption. assumption.
Qed.

Lemma eq_refl : forall x : heap, x |=| x.
Proof.
  unfold eq. intros. split.
  intro; assumption.
  intro; assumption.
Qed.

Lemma eq_sym : forall x y : heap, x |=| y -> y |=| x.
Proof.
  unfold eq. intros; split.
  apply H. apply H.
Qed.

Lemma eq_trans : forall x y z : heap, x |=| y -> y |=| z -> x |=| z.
Proof.
  unfold eq. intros. split.
  intro; apply H0; apply H; assumption.
  intro; apply H; apply H0; assumption.
Qed.

Lemma subheap_refl : forall h : heap, h |<| h.
Proof.
  unfold subheap.
  intros h r1 r2 n H.
  assumption.
Qed.

Lemma subheap_asym : forall h1 h2 : heap, h1 |<| h2 -> h2 |<| h1 -> h1 |=| h2.
Proof.
  unfold subheap. unfold eq.
  intros h1 h2 H H0 r1 r2 n.
  split. apply H. apply H0.
Qed.

Lemma subheap_trans : forall h1 h2 h3 : heap, h1 |<| h2 -> h2 |<| h3 -> h1 |<| h3.
Proof.
  unfold subheap.
  intros h1 h2 h3 H H0 r1 r2 n H1.
  apply H0. apply H. assumption.
Qed.

Lemma in_update_1 : forall r1 n r2 h, pin r1 n r2 (update r1 n r2 h).
Proof.
  intros r1 n r2 h. unfold update.
  case (Rmap.find r1 h).
  intro o. unfold pin.
  exists (Smap.add n r2 o). split.
  apply Rmap.add_1; reflexivity.
  apply Smap.add_1; reflexivity.
  unfold pin.
  exists (Smap.add n r2 (Smap.empty ref)).
  split.
  apply Rmap.add_1; reflexivity.
  apply Smap.add_1; reflexivity.
Qed.

Lemma in_update_2 : forall r1 r2 r3 r4 n1 n2 h,
    (r1 <> r2 \/ n1 <> n2) -> pin r1 n1 r3 h -> pin r1 n1 r3 (update r2 n2 r4 h).
Proof.
  intros r1 r2 r3 r4 n1 n2 h H H0.
  unfold update. unfold pin in H0.
  do 2 destruct H0.
  case Ref.eq_dec with (x := r1) (y := r2).
  intro H2.
  destruct H. elim H; assumption.
  rewrite <- H2. apply Rmap.find_1 in H0.
  rewrite H0. exists (Smap.add n2 r4 x).
  split. apply Rmap.add_1. reflexivity.
  apply Smap.add_2. auto.
  assumption. intro H2.
  unfold pin. exists x.
  split. case (Rmap.find r2 h).
  intro o. apply Rmap.add_2. auto.
  assumption. apply Rmap.add_2. auto.
  assumption. assumption.
Qed.

Lemma in_update_3 : forall r1 r2 r3 r4 n1 n2 h,
    (r1 <> r2 \/ n1 <> n2) -> pin r1 n1 r3 (update r2 n2 r4 h) -> pin r1 n1 r3 h.
Proof.
  intros r1 r2 r3 r4 n1 n2 h H H0.
  unfold update in H0; unfold pin in H0.
  do 2 destruct H0.
  case Ref.eq_dec with (x := r1) (y := r2).
  intro H2. destruct H. elim H; assumption.
  rewrite <- H2 in H0.
  inductS (Rmap.find r1 h); rewrite H3 in H0. unfold pin.
  assert (x = Smap.add n2 r4 x0).
  apply rmap_add in H0. assumption.
  exists x0. split.
  apply Rmap.find_2 in H3. assumption.
  rewrite H4 in H1.
  apply Smap.add_3 in H1. assumption. auto.
  assert (x = Smap.add n2 r4 (Smap.empty ref)).
  assert (Rmap.MapsTo r1 (Smap.add n2 r4 (Smap.empty ref))
    (Rmap.add r1 (Smap.add n2 r4 (Smap.empty ref)) h)).
  apply Rmap.add_1. reflexivity.
  apply rmap_inject with (k := r1)
    (m := (Rmap.add r1 (Smap.add n2 r4 (Smap.empty ref)) h));
  assumption. rewrite H4 in H1.
  apply Smap.add_3 in H1.
  apply Smap.empty_1 in H1. elim H1. auto.
  intro H2. inductS (Rmap.find r2 h); rewrite H3 in H0;
  apply Rmap.add_3 in H0; unfold pin;
  try (exists x; split; assumption); auto.
Qed.

Lemma in_get : forall r1 r2 n h, pin r1 n r2 h <-> get r1 n h = Some r2.
Proof.
  intros r1 r2 n h.
  split. intro H.
  unfold pin in H.
  do 2 destruct H.
  unfold get.
  apply Rmap.find_1 in H.
  rewrite H.
  apply Smap.find_1 in H0.
  rewrite H0; reflexivity.
  intro H. unfold get in H.
  unfold pin.
  inductS (Rmap.find r1 h); rewrite H0 in H.
  apply Smap.find_2 in H.
  apply Rmap.find_2 in H0.
  exists x; split; assumption.
  inversion H.
Qed.

Lemma not_in_get : forall r1 n h, (forall r2, ~ pin r1 n r2 h) <-> get r1 n h = None.
Proof.
  intros r1 n h. split. intro H.
  unfold pin in H. unfold get.
  inductS (Rmap.find r1 h).
  apply Rmap.find_2 in H0.
  assert (forall r2, ~ Smap.MapsTo n r2 x).
  intros r2 H1. elim H with (r2 := r2).
  exists x; split; assumption.
  inductS (Smap.find n x).
  apply Smap.find_2 in H2.
  elim H1 with (r2 := x0); assumption.
  reflexivity. reflexivity.
  intros H r2 H0. unfold get in H.
  inductS (Rmap.find r1 h); rewrite H1 in H.
  unfold pin in H0. do 2 destruct H0.
  apply Rmap.find_1 in H0. rewrite H1 in H0.
  inversion H0. rewrite <- H4 in H2.
  apply Smap.find_1 in H2. rewrite H2 in H; inversion H.
  do 2 destruct H0. apply Rmap.find_1 in H0.
  rewrite H1 in H0; inversion H0.
Qed.

Lemma in_union_1 : forall r1 n r2 h1 h2,
    pin r1 n r2 (h1 |+| h2) <-> pin r1 n r2 h1 \/ pin r1 n r2 h2.
Proof.
  unfold union.
  intros r1 n r2 h1 h2.
  split. intro H.
Admitted.

Lemma in_union_2 : forall r1 n r2 h1 h2, ~ pin r1 n r2 h1 ->
    (pin r1 n r2 h2 <-> pin r1 n r2 (h1 |+| h2)).
Proof.
  intros r1 n r2 h1 h2 H.
  split. intro H0.
  apply in_union_1.
  right. assumption.
  intro H0.
  apply in_union_1 in H0.
  case H0. intro H1.
  elim H. assumption.
  intro H1. assumption.
Qed.

(* rnull/rtrue/rfalse has no field. *)
Axiom not_in_null : forall n r h, ~ pin Ref.rnull n r h.
Axiom not_in_true : forall n r h, ~ pin Ref.rtrue n r h.
Axiom not_in_false : forall n r h, ~ pin Ref.rfalse n r h.

Lemma subheap_union : forall h1 h2 : heap, h1 |<| h2 |+| h1.
Proof.
  unfold subheap. intros h1 h2 r1 r2 n H.
  apply in_union_1. right; assumption.
Qed.

Lemma not_in_empty_1 : forall r1 n r2, ~ pin r1 n r2 {}.
Proof.
  intros r1 n r2 H.
  unfold pin in H.
  destruct H; destruct H.
  apply Rmap.empty_1 in H.
  assumption.
Qed.

Lemma not_in_empty_2 : forall k, ~ Rmap.In k {}.
Proof.
  intros k.
  unfold Rmap.In.
  unfold Rmap.Raw.PX.In.
  intro H.
  elim H.
  intros x H0.
  apply Rmap.empty_1 in H0.
  assumption.
Qed.

Lemma pdisjoint_empty : forall x : heap, x |*| {}.
Proof.
  unfold pdisjoint.
  intros x r1 r2 r3 n H.
  destruct H. unfold pin in H0.
  destruct H0. destruct H0.
  apply Rmap.empty_1 in H0.
  elim H0.
Qed.

Lemma pdisjoint_sym : forall x y : heap, x |*| y -> y |*| x.
Proof.
  unfold pdisjoint.
  intros x y H r1 r2 r3 n H0.
  elim H with (r1 := r1) (r2 := r3) (r3 := r2) (n := n).
  destruct H0. split.
  assumption. assumption.
Qed.

Lemma pdisjoint_union : forall h1 h2 h3 : heap,
    h1 |*| (h2 |+| h3) <-> h1 |*| h2 /\ h1 |*| h3.
Proof.
  unfold pdisjoint.
  intros h1 h2 h3.
  split. intro H.
  split. intros r1 r2 r3 n H0.
  destruct H0.
  elim H with (r1 := r1) (r2 := r2) (r3 := r3) (n := n).
  split. assumption.
  apply in_union_1.
  left; assumption.
  intros r1 r2 r3 n H0.
  destruct H0.
  elim H with (r1 := r1) (r2 := r2) (r3 := r3) (n := n).
  split. assumption.
  apply in_union_1.
  right; assumption.
  intros H r1 r2 r3 n H0.
  destruct H. destruct H0.
  apply in_union_1 in H2.
  destruct H2.
  elim H with (r1 := r1) (r2 := r2) (r3 := r3) (n := n).
  split. assumption. assumption.
  elim H1 with (r1 := r1) (r2 := r2) (r3 := r3) (n := n).
  split. assumption. assumption.
Qed.

Lemma pdisjoint_self : forall h : heap, h |*| h -> h |=| {}.
Proof.
  unfold eq; unfold pdisjoint.
  intros h H r1 r2 n. split.
  intro H0.
  elim H with (r1 := r1) (r2 := r2) (r3 := r2) (n := n).
  split. assumption. assumption.
  intro H0. apply not_in_empty_1 in H0.
  elim H0.
Qed.

Lemma exist_pdisjoint : forall h1 h2 : heap,
    h1 |<| h2 -> exists h3 : heap, h3 |*| h1 /\ h2 |=| h3 |+| h1.
Proof.
(*
  intros h1 h2 H. unfold subheap in H.
  exists (diff_heap h1 h2). unfold diff_heap. split.
  unfold pdisjoint. intros r1 r2 r3 n H0.
  destruct H0. unfold pin in H1. do 2 destruct H1.
  unfold pin in H0. do 2 destruct H0.
  rewrite Rmap.fold_1 in H1.
*)
Admitted.

Lemma in_equal : forall (r r1 r2 : ref) (n : name) (h : heap),
    pin r n r1 h -> pin r n r2 h -> r1 = r2.
Proof.
  unfold pin.
  intros r r1 r2 n h H H0.
  destruct H. destruct H0.
  destruct H. destruct H0.
  apply Rmap.find_1 in H.
  apply Rmap.find_1 in H0.
  rewrite H in H0.
  inversion H0.
  rewrite H4 in H1.
  apply Smap.find_1 in H1.
  apply Smap.find_1 in H2.
  rewrite H1 in H2.
  inversion H2.
  reflexivity.
Qed.

Lemma update_update : forall r1 n r2 r3 h,
    update r1 n r2 h = update r1 n r2 (update r1 n r3 h).
Proof.
  intros r1 n r2 r3 h.
  apply equal_3. unfold eq.
  intros r0 r4 n0.
  split. intro H.
  case Ref.eq_dec with (x := r0) (y := r1).
  case String.string_dec with (s1 := n0) (s2 := n).
  intros H0 H1. rewrite H0. rewrite H1.
  rewrite H0 in H. rewrite H1 in H.
  assert (pin r1 n r2 (update r1 n r2 h)).
  apply in_update_1.
  assert (r2 = r4).
  apply in_equal with (r := r1) (n := n) (h := update r1 n r2 h).
  assumption. assumption.
  rewrite H3. apply in_update_1.
  intros H0 H1. apply in_update_3 in H.
  apply in_update_2.
  right; assumption.
  apply in_update_2.
  right; assumption. assumption.
  right; assumption.
  intro H0. apply in_update_3 in H.
  apply in_update_2.
  left; assumption.
  apply in_update_2.
  left; assumption. assumption.
  left; assumption.
  intro H.
  case Ref.eq_dec with (x := r0) (y := r1).
  case String.string_dec with (s1 := n0) (s2 := n).
  intros H0 H1. rewrite H0. rewrite H1.
  rewrite H0 in H. rewrite H1 in H.
  assert (pin r1 n r2 (update r1 n r2 (update r1 n r3 h))).
  apply in_update_1.
  assert (r2 = r4).
  apply in_equal with (r := r1) (n := n) (h := update r1 n r2 (update r1 n r3 h)).
  assumption. assumption.
  rewrite H3. apply in_update_1.
  intros H0 H1. apply in_update_3 in H.
  apply in_update_2.
  right; assumption.
  apply in_update_3 in H. assumption.
  right; assumption.
  right; assumption.
  intro H0. apply in_update_3 in H.
  apply in_update_2.
  left; assumption.
  apply in_update_3 in H. assumption.
  left; assumption.
  left; assumption.
Qed.

Lemma union_emp : forall h : heap, {} |+| h |=| h.
Proof.
  unfold eq; unfold union.
  intros h r1 r2 n.
  split. intro H.
  apply in_union_1 in H.
  destruct H.
  assert (~ pin r1 n r2 empty_heap).
  apply not_in_empty_1 in H. elim H.
  elim H0. assumption.
  assumption.
  intro H.
  apply in_union_1.
  right. assumption.
Qed.

Lemma union_comm : forall h1 h2 : heap, h1 |+| h2 |=| h2 |+| h1.
Proof.
  unfold eq; unfold union.
  assert (forall (h1 h2 : heap) (r1 r2 : ref) (n : name),
    pin r1 n r2 (Rmap.fold union1 h1 h2) -> pin r1 n r2 (Rmap.fold union1 h2 h1)).
  intros h1 h2 r1 r2 n H.
  apply in_union_1 in H.
  apply in_union_1.
  destruct H.
  right; assumption.
  left; assumption.
  split. apply H. apply H.
Qed.

Lemma union_asso : forall h1 h2 h3 : heap,
    h1 |+| h2 |+| h3 |=| (h1 |+| h2) |+| h3.
Proof.
  unfold eq; unfold union.
  intros h1 h2 h3 r1 r2 n.
  split. intro H.
  apply in_union_1 in H.
  apply in_union_1.
  destruct H. left.
  apply in_union_1.
  left; assumption.
  apply in_union_1 in H.
  destruct H. left.
  apply in_union_1.
  right; assumption.
  right; assumption.
  intro H.
  apply in_union_1 in H.
  apply in_union_1.
  destruct H.
  apply in_union_1 in H.
  destruct H.
  left; assumption.
  right; apply in_union_1.
  left; assumption.
  right; apply in_union_1.
  right; assumption.
Qed.

Lemma not_in_remove_1 : forall r1 n r2 h, ~ pin r1 n r2 (remove r1 n h).
Proof.
  intros r1 n r2 h H.
  unfold remove in H.
  inductS (Rmap.find r1 h); rewrite H0 in H.
  unfold pin in H. do 2 destruct H.
  assert (x0 = Smap.remove n x).
  apply rmap_add in H. assumption.
  rewrite H2 in H1.
  assert (Smap.In n (Smap.remove n x)).
  exists r2. assumption.
  apply Smap.remove_1 in H3.
  elim H3. reflexivity.
  unfold pin in H. do 2 destruct H.
  apply Rmap.find_1 in H.
  rewrite H0 in H. inversion H.
Qed.

Lemma in_remove_2 : forall r1 r2 r3 n1 n2 h,
    (r1 <> r2 \/ n1 <> n2) -> pin r1 n1 r3 h -> pin r1 n1 r3 (remove r2 n2 h).
Proof.
  intros r1 r2 r3 n1 n2 h H H0.
  unfold remove.
  inductS (Rmap.find r2 h).
  do 2 destruct H0.
  destruct H. exists x0. split.
  apply Rmap.add_2. auto.
  assumption. assumption.
  case (Ref.eq_dec r1 r2).
  intro H3. rewrite <- H3.
  rewrite <- H3 in H1.
  apply Rmap.find_2 in H1.
  exists (Smap.remove (elt:=ref) n2 x).
  split. apply Rmap.add_1. reflexivity.
  apply Smap.remove_2. auto.
  assert (x0 = x).
  apply rmap_inject with (k := r1) (m := h).
  assumption. assumption.
  rewrite <- H4. assumption.
  intro H3. exists x0. split.
  apply Rmap.add_2. auto.
  assumption. assumption. assumption.
Qed.

Lemma in_remove_3 : forall r1 r2 r3 n1 n2 h,
    pin r1 n1 r3 (remove r2 n2 h) -> pin r1 n1 r3 h.
Proof.
  intros r1 r2 r3 n1 n2 h H.
  unfold remove in H.
  inductS (Rmap.find r2 h); rewrite H0 in H.
  do 2 destruct H.
  case (Ref.eq_dec r1 r2).
  intro H2. rewrite <- H2 in H.
  assert (x0 = Smap.remove n2 x).
  apply rmap_add in H. assumption.
  exists x. split. rewrite <- H2 in H0.
  apply Rmap.find_2 in H0. assumption.
  rewrite H3 in H1.
  apply Smap.remove_3 with (x := n2).
  assumption.
  intro H2. exists x0. split.
  apply Rmap.add_3 in H. assumption.
  auto. assumption. assumption.
Qed.

Lemma disjoint_remove : forall r1 n r2 h, remove r1 n h |*| update r1 n r2 {}.
Proof.
  unfold pdisjoint.
  intros r1 n r2 h r0 r3 r4 n0 H.
  destruct H.
  case Ref.eq_dec with (x := r0) (y := r1).
  intro H1. rewrite H1 in H.
  case String.string_dec with (s1 := n0) (s2 := n).
  intro H2. rewrite H2 in H.
  apply not_in_remove_1 in H. elim H.
  intro H2.
  apply in_update_3 in H0.
  apply not_in_empty_1 in H0.
  elim H0. right; assumption.
  intro H1.
  case String.string_dec with (s1 := n0) (s2 := n).
  intro H2. apply in_update_3 in H0.
  apply not_in_empty_1 in H0.
  elim H0. left; assumption.
  intro H2. apply in_update_3 in H0.
  apply not_in_empty_1 in H0.
  elim H0. left; assumption.
Qed.

Close Scope heap_scope.
End Heap.

Bind Scope heap_scope with Heap.heap.
Delimit Scope heap_scope with heap.

Infix "|=|" := Heap.eq (at level 70) : heap_scope.
Infix "|+|" := Heap.union (at level 60, right associativity) : heap_scope.
Infix "|*|" := Heap.pdisjoint (at level 50) : heap_scope.
Infix "|<|" := Heap.subheap (at level 70) : heap_scope.
Notation "{}" := Heap.empty_heap : heap_scope.


(* Copyright (c) 2017, the Dart project authors.  Please see the AUTHORS file
 * for details. All rights reserved. Use of this source code is governed by a
 * BSD-style license that can be found in the LICENSE file. *)

Require Import Utf8.
Require Import ClassTestTypes.
Require Import InvariantVoidnessPreservation.

Module MyVoidnessPreservation :=
  InvariantVoidnessPreservation.VoidnessPreservationBase
    Dynamics.StrictDynamics.
Import MyVoidnessPreservation.

(* -------------------- Examples from email threads -------------------- *)

(* A<Object> x = new A<void>(); // No *)
Goal ~(VoidnessPreserves dt_A_void dt_A_Object).
  intro H. inversion H; simpl in *.
  - inversion H2. inversion H5.
    + inversion H8. intuition H14.
    + inversion H8; subst.
      * inversion H14. inversion H4.
      * inversion H8. inversion H4. inversion H14. inversion H3. inversion H10.
Qed.

(* A<dynamic> x = new A<void>(); // No *)
Goal ~(VoidnessPreserves dt_A_void dt_A_dynamic).
  intro H. inversion H; simpl in *.
  - inversion H2. inversion H5.
    + inversion H8. intuition H14.
    + inversion H8.
      * inversion H14. inversion H20. exact H23.
      * inversion H13. inversion H17.
Qed.

(* A<Object> x = new A<dynamic>(); // Yes *)
Goal VoidnessPreserves dt_A_dynamic dt_A_Object.
  unfold dt_A_dynamic, dt_A_Object, ct_A_dynamic, ct_A_Object.
  apply vp_class. apply vctsp_cons.
  - apply vctp_some. apply vctps_first.
    + apply vpp_cons; auto.
    + apply vpp_cons; auto. apply vp_class_dynamic.
  - apply vctsp_cons; auto.
    apply vctp_some. apply vctps_rest. apply vctps_first; auto.
Qed.

(* A<void> x = new A<dynamic>(); // voidV = dynamicV, No *)
Goal ~(VoidnessPreserves dt_A_dynamic dt_A_void).
  intro H. inversion H; simpl in *.
  - inversion H2. inversion H5.
    + inversion H8. intuition H14.
    + inversion H8.
      * inversion H16. inversion H20. exact H23.
      * inversion H13. inversion H17.
Qed.

(* A<void> x = new A<Object>(); // voidV = objectV, No *)
Goal ~(VoidnessPreserves dt_A_Object dt_A_void).
  intro H. inversion H; simpl in *.
  - inversion H2. inversion H5.
    + inversion H8. intuition H14.
    + inversion H8.
      * inversion H16. inversion H20.
      * inversion H13. inversion H17.
Qed.

(* dynamic x = new A<void>(); // Yes *)
Goal VoidnessPreserves dt_A_void dt_dynamic.
  unfold dt_A_void, ct_A_void. auto.
Qed.

(* Object x = new A<void>(); // Yes *)
Goal VoidnessPreserves dt_A_void dt_Object.
  unfold dt_A_void, dt_Object, ct_A_void, ct_Object.
  apply vp_class. apply vctsp_cons; auto.
  apply vctp_gone. apply vctg_cons; auto. discriminate.
Qed.

(* Iterable<void> x = new List<void>(); // Yes *)
Goal VoidnessPreserves dt_List_void dt_Iterable_void.
  simpl.
  - apply vp_class. apply vctsp_cons.
    + apply vctp_gone; apply vctg_cons. discriminate.
      apply vctg_cons; auto. discriminate.
    + apply vctsp_cons.
      * apply vctp_some; auto. apply vctps_first; auto.
      * apply vctsp_cons; auto.
        apply vctp_some. apply vctps_rest. apply vctps_first; auto.
Qed.

(* List<void> x = new Iterable<void>(); // Yes *)
Goal VoidnessPreserves dt_Iterable_void dt_List_void.
  simpl.
  - apply vp_class. apply vctsp_cons.
    + apply vctp_some. apply vctps_rest. apply vctps_first.
      * apply vpp_cons. apply vp_any_void. auto.
      * apply vpp_cons. apply vp_any_void. auto.
    + apply vctsp_cons.
      * apply vctp_some. apply vctps_rest. apply vctps_rest.
        apply vctps_first. auto. auto.
      * apply vctsp_nil.
Qed.

(* Iterable<Object> x = new List<void>(); // No *)
Goal ~(VoidnessPreserves dt_List_void dt_Iterable_Object).
  intro H. inversion H.
  - inversion H2. inversion H7. inversion H10.
    + inversion H13. intuition H19.
    + inversion H13.
      * inversion H19. inversion H25.
      * inversion H18. inversion H22.
Qed.

(* List<Object> x = new Iterable<void>(); // No *)
Goal ~(VoidnessPreserves dt_Iterable_void dt_List_Object).
  intro H. inversion H.
  - inversion H2. inversion H5.
    + inversion H8. inversion H17. intuition H21.
    + inversion H8. inversion H13.
      * inversion H18. inversion H24.
      * inversion H17. inversion H21.
Qed.