(* Additional lemmas / proof rules about VST stack *)

Require Import VST.floyd.proofauto.
Require Export sha.general_lemmas.
Require Import sha.common_lemmas.
Local Open Scope logic.

Lemma force_lengthn_long {A}: forall n (l:list A) d, (n <= length l)%nat -> force_lengthn n l d = firstn n l.
Proof. induction n; simpl; intros. trivial.
  destruct l; simpl in H. omega.
  rewrite IHn; trivial. omega.
Qed.

Lemma data_at_triv {cs} sh t v v': v=v' -> @data_at cs sh t v |-- @data_at cs sh t v'.
Proof. intros; subst. cancel. Qed.

Lemma sizeof_Tarray {cs: composite_env} k: Z.max 0 k = k -> sizeof (Tarray tuchar k noattr) = k.
Proof. intros K; simpl; rewrite K. destruct k; trivial. Qed.

(*Require Import replace_refill_reptype_lemmas.*)
(*
Lemma data_at_Tarray_split3a {cs}: forall sh t n a i v,
  0 <= i <= n ->
  @data_at cs sh (Tarray t n a) v =
  @data_at cs sh (Tarray t n a) (upd_Znth i v (Znth i v (default_val _))) v.
    @data_at cs sh (Tarray t n a) (force_lengthn (nat_of_Z i) v (default_val _) ++
      (Znth i v (default_val _)) :: skipn (nat_of_Z (i + 1)) v).
Proof.
  intros.
  apply data_at_Tarray_ext.
  intros j ?H.
  unfold Znth.
  if_tac; [omega |].
  if_tac; [omega |].
  unfold nat_of_Z.
  destruct (Z_dec i j) as [[? | ?] | ?].
  + assert ((Z.to_nat i < Z.to_nat j)%nat) by (apply Z2Nat.inj_lt in l; omega).
    rewrite app_nth2 by (rewrite force_lengthn_length_n; omega).
    rewrite force_lengthn_length_n.
    simpl.
    destruct ((Z.to_nat j - Z.to_nat i)%nat) eqn:?H; [omega |].
    rewrite nth_skipn.
    f_equal.
    f_equal.
    change (i + 1) with (Z.succ i).
    rewrite Z2Nat.inj_succ by omega.
    omega.
  + assert ((Z.to_nat j < Z.to_nat i)%nat) by (apply Z2Nat.inj_lt; omega).
    rewrite app_nth1 by (rewrite force_lengthn_length_n; omega).
    rewrite nth_force_lengthn by omega.
    reflexivity.
  + subst.
    rewrite app_nth2 by (rewrite force_lengthn_length_n; omega).
    rewrite force_lengthn_length_n.
    rewrite minus_diag.
    simpl.
    reflexivity.
Qed.
*)
Lemma skipn_force_lengthn_app {A} n (l m:list A) a:
        skipn n (force_lengthn n l a ++ m) = m.
  intros. rewrite skipn_app1.
  specialize (skipn_exact_length (force_lengthn n l a)).
           rewrite force_lengthn_length_n. intros X; rewrite X; trivial.
  rewrite force_lengthn_length_n; omega.
Qed.

Lemma sepcon_fold: forall Frame P rho,
Frame = cons `(P) nil ->
P |-- fold_right
      (fun (P Q : environ -> mpred) (rho0 : environ) => P rho0 * Q rho0)
      `emp Frame rho.
Proof. intros. subst. simpl. entailer. Qed.

Lemma nth_mapVint: forall i (l:list Z) (Hi: (0 <= i < length l)%nat),
  exists n, nth i (map Vint (map Int.repr l)) Vundef = Vint n.
Proof. intros i.
  induction i; simpl; intros.
    destruct l; simpl in *. omega. eexists; reflexivity.
    destruct l; simpl in *. omega.
      destruct (IHi l). omega. rewrite H. eexists; reflexivity.
Qed.

Lemma nth_mapVint' {z}: forall i (l:list Z)
  (Hi: (0 <= i < length l)%nat),
  nth i (map Vint (map Int.repr l)) Vundef =
  Vint (Int.repr (nth i l z)).
Proof. intros i.
  induction i; simpl; intros.
    destruct l; simpl in *. omega. trivial.
    destruct l; simpl in *. omega.
      rewrite (IHi l). trivial. omega.
Qed.

Lemma nth_mapVintZ: forall i (l:list Z) (Hi: 0 <= i < Zlength l),
  exists n, nth (Z.to_nat i) (map Vint (map Int.repr l)) Vundef = Vint n.
Proof. intros.
  eapply nth_mapVint. rewrite Zlength_correct in Hi.
  destruct Hi; split.   omega.
unfold Z.of_nat in H0. unfold Z.to_nat.
destruct l; simpl in *. omega.
destruct i; try omega.
rewrite <- SuccNat2Pos.id_succ.
apply Pos2Nat.inj_lt.
apply H0.
Qed.

(*Same proof as semax_loadstore_array*)(*
Lemma NEWsemax_loadstore_array:
  forall {Espec: OracleKind},
 forall n k vi lo hi t1 (contents: Z -> reptype t1) v1 v2 (Delta: tycontext) e1 ei e2 sh P Q R,
  (*H0*) reptype t1 = val ->
  (*H1*) type_is_by_value t1 ->
  (*H2*) legal_alignas_type t1 = true ->
  (*H3*) typeof e1 = tarray t1 k->
  (*H4*) typeof ei = tint ->
  (*H8*) PROPx P (LOCALx Q (SEPx R)) |--  rel_expr e1 v1 && rel_expr ei (Vint (Int.repr vi))
           && rel_expr (Ecast e2 t1) v2 ->
  (*H7*) nth_error R n = Some (`(array_at t1 sh contents lo hi v1)) ->
  (*H *) writable_share sh ->
  (*H5*) tc_val t1 v2 ->
  (*H6*) in_range lo hi vi ->
   @semax Espec Delta (|> PROPx P (LOCALx Q (SEPx R))) (Sassign (Ederef (Ebinop Oadd e1 ei (tptr t1)) t1) e2)
          (normal_ret_assert
           (PROPx P (LOCALx Q (SEPx
            (replace_nth n R `(array_at t1 sh (upd contents vi (valinject _ v2)) lo hi v1)))))).
Proof.
intros until R.
intros H0 H1 H2 H3 H4 H8 H7 H H5 H6.
eapply semax_post_flipped'.
apply semax_loadstore_array'; eauto.
apply derives_trans with (!! isptr v1 && PROPx P (LOCALx Q (SEPx R))).
rewrite (SEP_nth_isolate _ _ _ H7).
repeat rewrite <- insert_SEP.
rewrite array_at_isptr. normalize.
normalize.
destruct v1; try contradiction.
instantiate (2:=v1).
simpl eval_binop. rewrite mul_repr.
apply andp_right; auto.
eapply derives_trans; [ apply H8 |].
intro rho. simpl.
repeat apply andp_right.
apply rel_lvalue_deref.
eapply rel_expr_binop.
repeat apply andp_left1. apply derives_refl.
apply andp_left1. apply andp_left2. apply derives_refl.
intro; rewrite H4; simpl. rewrite H3; simpl.
  unfold Cop.sem_add; simpl. rewrite mul_repr. auto.
 apply andp_left2. auto.
rewrite (SEP_nth_isolate _ _ _ H7).
repeat rewrite <- insert_SEP.
apply derives_refl.
rewrite (SEP_replace_nth_isolate _ _ _ `(array_at t1 sh (upd contents vi (valinject t1 v2)) lo hi v1) H7).
rewrite insert_SEP.
auto.
Qed.*)
(*
Lemma array_at_local_facts':
  forall (t : type) (sh : Share.t) (f : Z -> reptype t) (lo hi : Z) (v : val),
  array_at t sh f lo hi v |-- array_at t sh f lo hi v && !!isptr v && !!offset_in_range (sizeof t * lo) v &&
!!offset_in_range (sizeof t * hi) v && !!align_compatible t v.
Proof. intros. unfold array_at. entailer. Qed.
*)
(*
Lemma split_offset_array_at_: forall (ty : type) (sh : Share.t)
         (z lo hi : Z) (v : val),
       z <= lo <= hi ->
       sizeof ty > 0 ->
       legal_alignas_type ty = true ->
       array_at_ ty sh z hi v =
       !! offset_in_range (sizeof ty * z) v &&
       !! offset_in_range (sizeof ty * hi) v &&
       array_at_ ty sh z lo v *
       array_at_ ty sh 0 (hi - lo)
       (offset_val (Int.repr (sizeof ty * lo)) v).
Proof.
  intros. unfold array_at_.
  rewrite <- split_offset_array_at; trivial.
Qed.
*)
(*
Lemma offset_val_array_at0:
 forall t sh f lo hi v,
  sizeof t > 0 -> hi >= 0 ->
  legal_alignas_type t = true ->
  array_at t sh (fun i => f (i-lo)%Z) lo (lo + hi) v
  |--
  array_at t sh f 0 hi (offset_val (Int.repr (sizeof t * lo)) v).
Proof.
  intros.
  rewrite (split_offset_array_at t _ _ lo lo); trivial.
  rewrite array_at_emp.
  entailer. rewrite Zplus_comm. rewrite Z.add_simpl_r.
  apply array_lemmas.array_at_ext'. intros. rewrite Z.add_simpl_r. trivial.
  omega.
Qed.

Lemma offset_val_array_at1:
 forall t sh f g k lo hi ofs v,
    sizeof t > 0 -> hi >= 0 ->
    legal_alignas_type t = true ->
    k = lo + hi ->
    g = (fun i => f (i-lo)%Z) ->
    ofs = Int.repr (sizeof t * lo) ->
  array_at t sh g lo k v |--
  array_at t sh f 0 hi ((offset_val ofs) v).
Proof.
  intros. subst. apply offset_val_array_at0; trivial.
Qed.
*)
(*
Lemma split_memory_block p hi v sh:
      0 <= p <= hi -> isptr v ->
      memory_block sh (Int.repr hi) v =
      !!offset_in_range (sizeof tuchar * 0) v &&
      !!offset_in_range (sizeof tuchar * hi) v &&
      memory_block sh (Int.repr p) v * memory_block sh (Int.repr (hi-p)) (offset_val (Int.repr p) v).
Proof. intros.
rewrite memory_block_array_tuchar'; try omega; trivial.
rewrite memory_block_array_tuchar'; try omega; trivial.
rewrite memory_block_array_tuchar'; try omega.
rewrite (split_offset_array_at_ _ _ _ p).
   assert (K: (sizeof tuchar * p = p)%Z).
      assert (sizeof tuchar =1 ). reflexivity.
  rewrite H1. omega.
  rewrite K; trivial.
 assumption. simpl; omega. reflexivity. apply isptr_offset_val'; trivial.
Qed.
*)
Lemma isptrD v: isptr v -> exists b ofs, v = Vptr b ofs.
Proof. intros. destruct v; try contradiction. exists b, i; trivial. Qed.

(*
Lemma mysemax_frame_PQR:
  forall R2 Espec Delta R1 P Q P' Q' R1' c,
     closed_wrt_modvars c (LOCALx nil (SEPx R2)) ->
     @semax Espec Delta (PROPx P (LOCALx Q (SEPx R1))) c
                     (normal_ret_assert (PROPx P' (LOCALx Q' (SEPx R1')))) ->
     @semax Espec Delta (PROPx P (LOCALx (Q) (SEPx (R1++R2)))) c
                     (normal_ret_assert (PROPx P' (LOCALx (Q') (SEPx (R1'++R2))))).
Proof.
intros. specialize (semax_frame_PQR nil R2 Espec Delta R1 P Q P' Q' R1' c).
repeat rewrite app_nil_r. intros. apply H1; trivial. Qed.

Ltac frame_SEP'' L :=
 grab_indexes_SEP L;
 match goal with
 | |- @semax _ _ (PROPx _ (LOCALx _ (SEPx ?R))) _ _ =>
  rewrite <- (firstn_skipn (length L) R);
    simpl length; unfold firstn, skipn;
    eapply (mysemax_frame_PQR);
      [ unfold closed_wrt_modvars;  auto 50 with closed
     | ]
 | |- (PROPx _ (LOCALx _ (SEPx ?R))) |-- _ =>
  rewrite <- (firstn_skipn (length L) R);
    simpl length; unfold firstn, skipn;
    apply derives_frame_PQR
end.
*)

Ltac myframe_SEP'' L :=  (* this should be generalized to permit framing on LOCAL part too *)
 grab_indexes_SEP L;
 match goal with
 | |- @semax _ _ (PROPx _ (LOCALx ?Q (SEPx ?R))) _ _ =>
  rewrite <- (firstn_skipn (length L) R);
  rewrite <- (firstn_skipn (length Q) Q);
    simpl length; unfold firstn, skipn;
    eapply (semax_frame_PQR nil);
      [ unfold closed_wrt_modvars;  auto 50 with closed
     | ]
 | |- (PROPx _ (LOCALx _ (SEPx ?R))) |-- _ =>
  rewrite <- (firstn_skipn (length L) R);
    simpl length; unfold firstn, skipn;
    apply derives_frame_PQR
end.


Require Export Asn.
Require Export Sem.

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

(*  Specification Type  *)

Module Type SPEC.

Parameter heap : Type.
Parameter stack : Type.
Definition name := Name.name.
Definition method := Method.method.
Definition rtype := RType.rtype.
Definition ref := Ref.ref.
Definition bexpr := BExpr.bexpr.
Definition expr := Expr.expr.
Definition cmd := Lang.cmd.
Definition hprop := HProp.hprop.
Definition state := State.state.

Definition spec := (hprop * hprop)%type.
Parameter program_spec : Type.
Parameter init_program_spec : program_spec.

Parameter pred_env : Type.
Parameter init_pred_env : pred_env.

Parameter update_pred : name -> rtype -> hprop -> pred_env -> pred_env.
Parameter get_pred : name -> rtype -> pred_env -> option hprop.
Parameter pred_in : name -> rtype -> hprop -> pred_env -> Prop.
Parameter evalP : rtype -> pred_env -> hprop -> hprop.
(* bind the predicate families in specifications to the entries of the class *)

Parameter cmd_satisfy : state -> rtype -> cmd -> pred_env -> spec -> Prop.
Parameter bs : state -> rtype -> method -> program_spec -> Prop.
Parameter method_satisfy : state -> rtype -> method -> pred_env -> program_spec -> Prop.
Parameter program_satisfy : state -> pred_env -> program_spec -> Prop.

Parameter spec_in : rtype -> method -> spec -> program_spec -> Prop.
Parameter add_spec : rtype -> method -> spec -> program_spec -> program_spec.
Parameter get_spec : rtype -> method -> program_spec -> option spec.

Parameter refine : spec -> spec -> Prop.

Axiom pred_update_1 : forall n t p e, pred_in n t p (update_pred n t p e).
Axiom pred_update_2 : forall n1 n2 t1 t2 p1 p2 e,
    (t1 <> t2 \/ n1 <> n2) -> pred_in n1 t1 p1 e ->
        pred_in n1 t1 p1 (update_pred n2 t2 p2 e).
Axiom pred_update_3 : forall n1 n2 t1 t2 p1 p2 e,
    (t1 <> t2 \/ n1 <> n2) -> pred_in n1 t1 p1 (update_pred n2 t2 p2 e) ->
        pred_in n1 t1 p1 e.
Axiom pred_get : forall n t p e, pred_in n t p e <-> get_pred n t e = Some p.
Axiom pred_not_get : forall n t e,
    (forall p, ~ pred_in n t p e) <-> get_pred n t e = None.

Axiom spec_add_1 : forall t m s ps, spec_in t m s (add_spec t m s ps).
Axiom spec_add_2 : forall t1 t2 m1 m2 s1 s2 ps,
    (t1 <> t2 \/ m1 <> m2) -> spec_in t1 m1 s1 ps ->
        spec_in t1 m1 s1 (add_spec t2 m2 s2 ps).
Axiom spec_add_3 : forall t1 t2 m1 m2 s1 s2 ps,
    (t1 <> t2 \/ m1 <> m2) -> spec_in t1 m1 s1 (add_spec t2 m2 s2 ps) ->
        spec_in t1 m1 s1 ps.
Axiom spec_get : forall t m s ps, spec_in t m s ps <-> get_spec t m ps = Some s.
Axiom spec_not_get : forall t m ps,
    (forall s, ~ spec_in t m s ps) <-> get_spec t m ps = None.

Axiom spec_get_add_1 : forall t m s ps, get_spec t m (add_spec t m s ps) = Some s.
Axiom spec_get_add_2 : forall t1 t2 m1 m2 s ps, (t1 <> t2 \/ m1 <> m2) ->
    get_spec t1 m1 (add_spec t2 m2 s ps) = get_spec t1 m1 ps.

Notation "S + e , t |- sp # c" := (cmd_satisfy S t c e sp) (at level 30) : spec_scope.
Notation "S + e |> ps # t , m" := (method_satisfy S t m e ps) (at level 30) : spec_scope.
Notation "S + e |= ps" := (program_satisfy S e ps) (at level 30) : spec_scope.
Infix "<<=" := refine (at level 70) : spec_scope.

Open Scope spec_scope.
Open Scope hprop_scope.
Open Scope string_scope.

Axiom prog_satis_init : forall (S : state) (e : pred_env), S + e |= init_program_spec.

Axiom refine_refl : forall sp : spec, sp <<= sp.
Axiom refine_trans : forall sp1 sp2 sp3 : spec,
    sp1 <<= sp2 -> sp2 <<= sp3 -> sp1 <<= sp3.
Axiom refine_cons1 : forall p1 p2 p3 : hprop, p3 ==> p2 -> (p1, p2) <<= (p1, p3).
Axiom refine_cons2 : forall p1 p2 p3 : hprop, p1 ==> p3 -> (p1, p2) <<= (p3, p2).

(* verification rules *)
(* {P} skip {P} *)
Axiom h_skip : forall (p : hprop) (S : state) (t : rtype) (e : pred_env),
    S + e, t |- (p, p) # Lang.skip.
(* {P[e/n]} n := e {P} *)
Axiom h_asn : forall (p1 p2 : hprop) (n : name) (e : expr) (S : state)
                     (t : rtype) (pe : pred_env),
    p1 ==> HProp.subst_name_1 n e p2 ->
    S + pe,t |- (p1, p2) # Lang.assign n e.
(* {P[b/n]} n := b {P} *)
Axiom h_asnb : forall (p1 p2 : hprop) (n : name) (b : bexpr) (S : state)
                      (t : rtype) (e : pred_env),
               p1 ==> HProp.subst_name_2 n b p2 ->
               S + e, t |- (p1, p2) # Lang.assignb n b.

(* {v = r1 /\ r1.a |-> - /\ e = r2} v.a := e {v = r1 /\ r1.a |-> r2 /\ e = r2} *)
Axiom h_mut : forall (v a : name) (e : expr) (S : state) (r1 r2 r3: ref)
                     (t : rtype) (pe : pred_env),
    S + pe, t |- (v +-> r1 /.\ r1`a |-> r3 /.\ e |=> r2,
                 v +-> r1 /.\ r1`a |-> r2 /.\ e |=> r2) # Lang.fwrite v a e.
(* x <> v -> {v = r1 /\ r1.a |-> r2} x := v.a {v = r1 /\ r1.a |-> r2 /\ x = r2} *)
Axiom h_lkp : forall (x v a: name) (S : state) (r1 r2: ref) (t : rtype) (e : pred_env),
    x <> v ->
    S + e, t |- (v +-> r1 /.\ r1`a |-> r2,
                 v +-> r1 /.\ r1`a |-> r2 /.\ x +-> r2) # Lang.fread x v a.
(* {v = r1 /\ r1.a |-> r2} x := x.a {x = r2 /\ r1.a |-> r2} *)
Axiom h_lkp' : forall (x a: name) (S : state) (r1 r2: ref) (t : rtype) (e : pred_env),
    S + e, t |- (x +-> r1 /.\ r1`a |-> r2,
                 x +-> r2 /.\ r1`a |-> r2) # Lang.fread x x a.

(* {v = r /\ r <: C} x := (C)v {x = r} *)
Axiom h_cast : forall (x v: name) (C : rtype) (S : state) (r: ref)
                      (t : rtype) (e : pred_env),
    S + e, t |- (v +-> r /.\ r <: C, x +-> r) # Lang.cast x C v.

(* {P[e/"res"]} return e {P} *)
Axiom h_res : forall (p1 p2 : hprop) (e : expr) (S : state) (t : rtype) (pe : pred_env),
    p1 ==> HProp.subst_name_1 "res" e p2 ->
    S + pe, t |- (p1, p2) # (Lang.creturn e).

(* {P} c1 {Q} -> {Q} c2 {R} -> {P} c1; c2 {R} *)
Axiom h_seq : forall (p q r: hprop) (c1 c2 : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    S + e, t |- (p, q) # c1 -> S + e, t |- (q, r) # c2 ->
    S + e, t |- (p, r) # (Lang.cseq c1 c2).

Parameter subst_args1 : hprop -> name -> name -> list name -> list expr -> hprop.
Parameter subst_args2 : hprop -> list name -> list expr -> hprop.

(* {P} C.m(args) {Q} -> v : C ->
   {P[v/this][le/args]} x := v.m(le) {Q[x/res][v/this][le/args]}*)
Axiom h_dinv : forall S e v t t' m p1 p2 mb ps x le,
    get_spec t m ps = Some (p1, p2) ->
    MEnv.find_mbody (State.get_mbody_env S) t m = Some mb ->
    DType.get_dtype v (State.get_dtype S) = Some t ->
    S + e, t' |- (subst_args1 p1 x v (MEnv.get_args mb) le,
                  subst_args1 p2 x v (MEnv.get_args mb) le) # Lang.dcall x v m le.

(* {P} C.m(args) {Q} ->
   {P[v/this][le/args]} x := v.C::m(le) {Q[x/res][v/this][le/args]}*)
Axiom h_sinv : forall S e v t t' m p1 p2 mb ps x le,
    get_spec t m ps = Some (p1, p2) ->
    MEnv.find_mbody (State.get_mbody_env S) t m = Some mb ->
    S + e, t' |- (subst_args1 p1 x v (MEnv.get_args mb) le,
                  subst_args1 p2 x v (MEnv.get_args mb) le) # Lang.scall x v t m le.

(* {P} C(args) {Q} ->
   {P[le/args]} x := new C(le) {Q[x/this][le/args]}*)
Axiom h_new : forall S e p1 p2 mb ps x t t' le,
    get_spec t t ps = Some (p1, p2) ->
    MEnv.find_mbody (State.get_mbody_env S) t t = Some mb ->
    S + e, t' |- (subst_args2 p1 (MEnv.get_args mb) le,
                  HProp.subst_name_3 "this" x
                    (subst_args2 p2 (MEnv.get_args mb) le)) # Lang.calloc x t le.

(* (l1 = l2 -> {P} c {Q}) -> {P /\ l1 = l2} c {Q} *)
Axiom list_eq_ext : forall S e t c (l1 l2 : list ref) (hp1 hp2 : hprop),
    (l1 = l2 -> S + e, t |- (hp1, hp2) # c) ->
     S + e, t |- (hp1 /.\ HProp.list_eq l1 l2, hp2) # c.

(* "the variables c modifies" is disjoint with "the free variables in R"
   -> {P} c {Q} -> {P * R} c {Q * R} *)
Axiom h_frame : forall (p q r: hprop) (c : cmd) (S : state) (t : rtype) (e : pred_env),
    sset_dsj (Lang.md c) (HProp.fv r) ->
    S + e, t |- (p, q) # c -> S + e, t |- (p * r, q * r) # c.
(* "the variables c modifies" is disjoint with "the free variables in R"
   -> "R is an assertion independent of the heap"
   -> {P} c {Q} -> {P /\ R} c {Q /\ R} *)
Axiom h_frame' : forall (p q r: hprop) (c : cmd) (S : state)
                        (t : rtype) (e : pred_env),
    sset_dsj (Lang.md c) (HProp.fv r) -> HProp.stack_hprop r ->
        S + e, t |- (p, q) # c -> S + e, t |- (p /.\ r, q /.\ r) # c.

(* {P} c {Q /\ R} <-> {P} c {Q} /\ {P} c {R} *)
Axiom h_div1 : forall (p q r: hprop) (c : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    S + e, t |- (p, q /.\ r) # c <->
    S + e, t |- (p, q) # c /\ S + e, t |- (p, r) # c.
(* {P \/ R} c {Q} <-> {P} c {Q} /\ {R} c {Q} *)
Axiom h_div2 : forall (p q r: hprop) (c : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    S + e, t |- (p \./ r, q) # c <->
    S + e, t |- (p, q) # c /\ S + e, t |- (r, q) # c.

(* {P /\ b} c1 {Q} -> {P /\ ~b} c2 {Q} ->
   {P} if b then c1 else c2 {Q} *)
Axiom h_cond : forall (p q : hprop) (b : BExpr.bexpr) (c1 c2 : cmd) (S : state)
                      (t : rtype) (e : pred_env),
              S + e, t |- (p /.\ 'b, q) # c1
           -> S + e, t |- (p /.\ ~` 'b, q) # c2
           -> S + e, t |- (p, q) # Lang.cif b c1 c2.
(* (P -> b) -> {P} c1 {Q} -> {P} if b then c1 else c2 {Q} *)
Axiom h_cond1 : forall (p q : hprop) (b : BExpr.bexpr) (c1 c2 : cmd) (S : state)
                      (t : rtype) (e : pred_env),
    p ==> 'b -> S + e, t |- (p, q) # c1
    -> S + e, t |- (p, q) # Lang.cif b c1 c2.
(* (P -> ~b) -> {P} c2 {Q} -> {P} if b then c1 else c2 {Q} *)
Axiom h_cond2 : forall (p q : hprop) (b : BExpr.bexpr) (c1 c2 : cmd) (S : state)
                      (t : rtype) (e : pred_env),
    p ==> ~` 'b -> S + e, t |- (p, q) # c2
    -> S + e, t |- (p, q) # Lang.cif b c1 c2.

(* {P /\ b} c {P} -> {P} while b c {P /\ ~b} *)
Axiom h_iter : forall (p : hprop) (b : BExpr.bexpr) (c : cmd) (S : state)
                      (t : rtype) (e : pred_env),
    S + e, t |- (p /.\ 'b, p) # c ->
    S + e, t |- (p, p /.\ ~` 'b) # (Lang.cwhile b c).
Proof.

(* (P2 -> P3) -> {P1} c {P2} -> {P1} c {P3} *)
Axiom h_cons_1 : forall (p1 p2 p3 : hprop) (c : cmd) (S : state)
                        (t : rtype) (e : pred_env),
    p2 ==> p3 -> S + e, t |- (p1, p2) # c -> S + e, t |- (p1, p3) # c.
(* (P3 -> P1) -> {P1} c {P2} -> {P3} c {P2} *)
Axiom h_cons_2 : forall (p1 p2 p3 : hprop) (c : cmd) (S : state)
                        (t : rtype) (e : pred_env),
    p3 ==> p1 -> S + e, t |- (p1, p2) # c -> S + e, t |- (p3, p2) # c.

(* (forall r, {P r} c {Q r}) -> {exists r, P r} c {exists r, Q r} *)
Axiom h_ex : forall (p q: ref -> hprop) (c : cmd) (S : state)
                    (t : rtype) (e : pred_env),
    (forall r : ref, S + e, t |- (p r, q r) # c) -> S + e, t |- (=| p, =| q) # c.
(* (forall r, {P r} c {Q}) -> {exists r, P r} c {Q} *)
Axiom h_ex1 : forall (p : ref -> hprop) (q : hprop) (c : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    (forall r : ref, S + e, t |- (p r, q) # c) -> S + e, t |- (=| p, q) # c.
(* {P} c {Q r} -> {P} c {exists r, Q r} *)
Axiom h_ex2 : forall (p : hprop) (q : ref -> hprop) (r : ref) (c : cmd)
                     (S : state) (t : rtype) (e : pred_env),
    S + e, t |- (p, q r) # c -> S + e, t |- (p, =| q) # c.
(* (forall l, {P l} c {Q}) -> {exists l, P l} c {Q} *)
Axiom h_ex3 : forall (p : list ref -> hprop) (q : hprop) (c : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    (forall l, S + e, t |- (p l, q) # c) -> S + e, t |- (E| p, q) # c.
(* {P} c {Q l} -> {P} c {exists l, Q l} *)
Axiom h_ex4 : forall (p : hprop) (q : list ref -> hprop) (l : list ref)
                     (c : cmd) (S : state) (t : rtype) (e : pred_env),
    S + e, t |- (p, q l) # c -> S + e, t |- (p, E| q) # c.

(* {False} c {P} *)
Axiom h_contrad : forall (p : hprop) (c : cmd) (S : state) (t : rtype) (e : pred_env),
    S + e, t |- (HProp.hfalse, p) # c.
(* "R has no free variable" -> {P} {Q} refines {P * R} {Q * R} *)
Axiom refine_frame : forall p q r : hprop,
    HProp.fv r = Sset.empty -> (p * r, q * r) <<= (p, q).
(* (forall r, {P2} {Q2} refines {P1 r} {Q1 r}) ->
   {P2} {Q2} refines {exists r, P1 r} {exists r, Q1 r} *)
Axiom refine_exist : forall (p1 q1 : ref -> hprop) (p2 q2 : hprop) (r : ref),
    (forall r, (p1 r, q1 r) <<= (p2, q2)) -> (=|p1, =|q1) <<= (p2, q2).

Close Scope string_scope.
Close Scope hprop_scope.
Close Scope spec_scope.

End SPEC.

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

(*  Specification  *)

Module Spec <: SPEC.

Definition name := Name.name.
Definition rtype := RType.rtype.
Definition ref := Ref.ref.
Definition expr := Expr.expr.
Definition bexpr := BExpr.bexpr.
Definition heap := Heap.heap.
Definition stack := Stack.stack.
Definition cmd := Lang.cmd.
Definition method := Method.method.
Definition hprop := HProp.hprop.
Definition state := State.state.
Definition conf := Sem.conf.

Open Scope string_scope.

Definition spec := (hprop * hprop)%type.
Definition program_spec := Smap.t (Smap.t spec).
Definition no_spec := Smap.empty spec.
Definition init_program_spec := Smap.empty (Smap.t spec).

Definition pred_env := Smap.t (Smap.t hprop).
Definition init_pred_env := Smap.empty (Smap.t hprop).
Definition no_pred := Smap.empty hprop.

Definition update_pred (n : name) (t : rtype) (p : hprop) (e : pred_env) :=
    match Smap.find n e with
    | Some o => Smap.add n (Smap.add t p o) e
    | None => Smap.add n (Smap.add t p no_pred) e
    end.

Definition get_pred (n : name) (t : rtype) (e : pred_env) : option hprop :=
    match Smap.find n e with
    | Some o => Smap.find t o
    | None => None
    end.

Definition pred_in (n : name) (t : rtype) (p : hprop) (e : pred_env) :=
    exists o, Smap.MapsTo n o e /\ Smap.MapsTo t p o.

Open Scope hprop_scope.

Fixpoint evalP (t : rtype) (e : pred_env) (hp : hprop) : hprop :=
    match hp with
    | ~` hp' => ~` (evalP t e hp')
    | hp1 /.\ hp2 => (evalP t e hp1) /.\ (evalP t e hp2)
    | hp1 \./ hp2 => (evalP t e hp1) \./ (evalP t e hp2)
    | hp1 --> hp2 => (evalP t e hp1) --> (evalP t e hp2)
    | hp1 * hp2 => (evalP t e hp1) * (evalP t e hp2)
    | hp1 *-> hp2 => (evalP t e hp1) *-> (evalP t e hp2)
    | =| hp' => =| (fun r => evalP t e (hp' r))
    | \-/ hp' => \-/ (fun r => evalP t e (hp' r))
    | .\ hp' => .\ (fun r => evalP t e (hp' r))
    | hp' & r => (evalP t e hp') & r
    | hp' &^ n => (evalP t e hp') &^ n
    | |P| n @ a => if Name.beq a "this" then
                       match get_pred n t e with
                       | Some hp' => hp' &^ "this"
                       | None => HProp.hfalse
                       end
                   else hp
    | ,\ hp' => ,\ (fun l => evalP t e (hp' l))
    | hp' &` l => (evalP t e hp') &` l
    | _ => hp
    end.

(* A command $c$ in class $t$ satisfies the specification $sp$ *)
Definition cmd_satisfy (S : state) (t : rtype) (c : cmd) (e : pred_env)
                       (sp : spec) : Prop :=
    forall (h : heap) (s : stack) (S' : state),
    let S0 := State.update_heap h (State.update_stack s S) in
    let h' := State.get_heap S' in
    let s' := State.get_stack S' in
    let se := State.get_super_env S in
    match sp with (hp1, hp2) =>
        Sem.sem S0 c S' -> HProp.eval hp1 h s se -> HProp.eval hp2 h' s' se
    end.

Notation "S + e , t |- sp # c" := (cmd_satisfy S t c e sp) (at level 30) : spec_scope.
Open Scope spec_scope.

Definition add_spec (t : rtype) (m : method) (s : spec) (ps : program_spec) : program_spec :=
    match Smap.find t ps with
    | None => Smap.add t (Smap.add m s no_spec) ps
    | Some cs => Smap.add t (Smap.add m s cs) ps
    end.

Definition get_spec (t : rtype) (m : method) (ps : program_spec) : option spec :=
    match Smap.find t ps with
    | None => None
    | Some cs => Smap.find m cs
    end.

(* s2 refines s1 *)
Definition refine (s1 s2 : spec) : Prop :=
    forall S t c e, S + e, t |- s2 # c -> S + e, t |- s1 # c.

Infix "<<=" := refine (at level 70) : spec_scope.

Fixpoint bs2 (t : rtype) (l : list rtype) (m : method) (ps : program_spec) : Prop :=
    match l with
    | nil => True
    | cons s l' =>
        match get_spec t m ps, get_spec s m ps with
        | Some sp, Some sp' => sp' <<= sp /\ bs2 t l' m ps
        | None, Some sp' => sp' <<= (HProp.htrue, HProp.htrue) /\ bs2 t l' m ps
        | _, None => bs2 t l' m ps
        end
    end.

(* behavioral subtyping *)
Definition bs (S : state) (t : rtype) (m : method) (ps : program_spec) : Prop :=
    match RType.get_super t (State.get_super_env S) with
    | None => True
    | Some l => bs2 t l m ps
    end.

Fixpoint add_args (args : list name) (hp : hprop) : hprop :=
    match args with
    | nil => hp
    | cons a b => add_args b (=| (fun r => a +-> r /.\ hp))
    end.

Definition mbody_satisfy S t e (mb : MEnv.method_body) (sp : spec) :=
  match mb with
  | (a, l, Some c) =>
    match sp with (hp1, hp2) =>
      S + e, t |- (add_args a hp1, hp2) # c
    end
  | _ => True
  end.

Definition raw2 (r : ref) (n : name) (t : rtype) (p : hprop) : hprop :=
  if RType.beq t "Bool"
    then p * (r`n |-> Ref.rfalse)
    else p * (r`n |-> Ref.rnull).

Definition raw (t : rtype) (fe : TEnv.fields_env) : hprop :=
  match TEnv.get_fields t fe with
  | None => HProp.emp
  | Some f => =| (fun r => "this" +-> r /.\ r =: t /.\
                  Smap.fold (raw2 r) f HProp.emp)
  end.

Definition constructor_satisfy S t e (mb : MEnv.method_body) (sp : spec) :=
  match mb with
  | (a, l, Some c) =>
    match sp with (hp1, hp2) =>
      S + e, t |- (add_args a (hp1 * (raw t (State.get_fields_env S))), hp2) # c
    end
  | _ => True
  end.

Definition method_satisfy (S : state) (t : rtype) (m : method) (e : pred_env)
                          (ps : program_spec) : Prop :=
  if RType.beq t m then
    match get_spec t t ps with
    | Some sp =>
        match MEnv.find_mbody (State.get_mbody_env S) t t with
        | None => False
        | Some mb => constructor_satisfy S t e mb sp
        end
    | None => True
    end
  else
    match get_spec t m ps with
    | Some sp =>
        match MEnv.find_mbody (State.get_mbody_env S) t m with
        | None => False
        | Some mb => mbody_satisfy S t e mb sp /\ bs S t m ps
        end
    | None => bs S t m ps
    end.

Notation "S + e |> ps # t , m" := (method_satisfy S t m e ps) (at level 30) : spec_scope.

Definition spec_in (t : rtype) (m : method) (s : spec) (ps : program_spec) :=
    exists o, Smap.MapsTo t o ps /\ Smap.MapsTo m s o.

Definition program_satisfy (S : state) (e : pred_env) (ps : program_spec) : Prop :=
    forall t m, MEnv.In t m (State.get_mbody_env S) -> S + e |> ps # t,m.

Notation "S + e |= ps" := (program_satisfy S e ps) (at level 30) : spec_scope.

Lemma pred_update_1 : forall n t p e, pred_in n t p (update_pred n t p e).
Proof.
  intros n t p e. unfold update_pred.
  case (Smap.find n e).
  intro o. unfold pred_in.
  exists (Smap.add t p o). split.
  apply Smap.add_1; reflexivity.
  apply Smap.add_1; reflexivity.
  unfold pred_in.
  exists (Smap.add t p no_pred).
  split.
  apply Smap.add_1; reflexivity.
  apply Smap.add_1; reflexivity.
Qed.

Lemma pred_update_2 : forall n1 n2 t1 t2 p1 p2 e,
    (t1 <> t2 \/ n1 <> n2) -> pred_in n1 t1 p1 e ->
        pred_in n1 t1 p1 (update_pred n2 t2 p2 e).
Proof.
  intros n1 n2 t1 t2 p1 p2 e H H0.
  unfold update_pred. unfold pred_in in H0.
  do 2 destruct H0. case (Name.eq_dec n1 n2).
  intro H2. destruct H.
  rewrite <- H2. apply Smap.find_1 in H0.
  rewrite H0. exists (Smap.add t2 p2 x).
  split. apply Smap.add_1. reflexivity.
  apply Smap.add_2. auto.
  assumption. elim H; assumption. intro H2.
  unfold pred_in. exists x.
  split. case (Smap.find n2 e).
  intro o. apply Smap.add_2. auto.
  assumption. apply Smap.add_2. auto.
  assumption. assumption.
Qed.

Lemma pred_update_3 : forall n1 n2 t1 t2 p1 p2 e,
    (t1 <> t2 \/ n1 <> n2) -> pred_in n1 t1 p1 (update_pred n2 t2 p2 e) ->
        pred_in n1 t1 p1 e.
Proof.
  intros n1 n2 t1 t2 p1 p2 e H H0.
  unfold update_pred in H0; unfold pred_in in H0.
  do 2 destruct H0. case (Name.eq_dec n1 n2).
  intro H2. destruct H. rewrite <- H2 in H0.
  inductS (Smap.find n1 e); rewrite H3 in H0.
  assert (x = Smap.add t2 p2 x0).
  apply smap_add in H0. assumption.
  exists x0. split.
  apply Smap.find_2 in H3. assumption.
  rewrite H4 in H1.
  apply Smap.add_3 in H1. assumption. auto.
  assert (x = Smap.add t2 p2 no_pred).
  assert (Smap.MapsTo n1 (Smap.add t2 p2 no_pred)
    (Smap.add n1 (Smap.add t2 p2 no_pred) e)).
  apply Smap.add_1. reflexivity.
  apply smap_inject with (k := n1)
    (m := (Smap.add n1 (Smap.add t2 p2 no_pred) e)).
  assumption. assumption.
  rewrite H4 in H1.
  apply Smap.add_3 in H1.
  apply Smap.empty_1 in H1. elim H1. auto.
  elim H; assumption. intro H2.
  inductS (Smap.find n2 e); rewrite H3 in H0;
  apply Smap.add_3 in H0; unfold pred_in;
  try (exists x; split; assumption); auto.
Qed.

Lemma pred_get : forall n t p e, pred_in n t p e <-> get_pred n t e = Some p.
Proof.
  intros n t p e. split. intro H.
  unfold pred_in in H.
  do 2 destruct H.
  unfold get_pred.
  apply Smap.find_1 in H.
  rewrite H.
  apply Smap.find_1 in H0.
  rewrite H0; reflexivity.
  intro H. unfold get_pred in H.
  unfold pred_in.
  inductS (Smap.find n e); rewrite H0 in H.
  apply Smap.find_2 in H.
  apply Smap.find_2 in H0.
  exists x; split; assumption.
  inversion H.
Qed.

Lemma pred_not_get : forall n t e,
    (forall p, ~ pred_in n t p e) <-> get_pred n t e = None.
Proof.
  intros n t e. split. intro H.
  unfold pred_in in H. unfold get_pred.
  inductS (Smap.find n e).
  apply Smap.find_2 in H0.
  assert (forall p, ~ Smap.MapsTo t p x).
  intros p H1. elim H with (p := p).
  exists x; split. assumption. assumption.
  inductS (Smap.find t x).
  apply Smap.find_2 in H2.
  elim H1 with (p := x0). assumption.
  reflexivity. reflexivity.
  intros H p H0. unfold get_pred in H.
  do 2 destruct H0.
  inductS (Smap.find n e); rewrite H2 in H.
  apply Smap.find_1 in H0. rewrite H2 in H0.
  inversion H0. rewrite <- H4 in H1.
  apply Smap.find_1 in H1. rewrite H1 in H.
  inversion H. apply Smap.find_1 in H0.
  rewrite H2 in H0. inversion H0.
Qed.

Axiom unf_pred : forall S t c e p1 p2,
    cmd_satisfy S t c e (p1, p2) <-> cmd_satisfy S t c e (evalP t e p1, evalP t e p2).

Lemma spec_add_1 : forall t m s ps, spec_in t m s (add_spec t m s ps).
Proof.
  intros t m s ps. unfold add_spec.
  case (Smap.find t ps).
  intro o. unfold spec_in.
  exists (Smap.add m s o). split.
  apply Smap.add_1; reflexivity.
  apply Smap.add_1; reflexivity.
  unfold spec_in.
  exists (Smap.add m s no_spec).
  split.
  apply Smap.add_1; reflexivity.
  apply Smap.add_1; reflexivity.
Qed.

Lemma spec_add_2 : forall t1 t2 m1 m2 s1 s2 ps,
    (t1 <> t2 \/ m1 <> m2) -> spec_in t1 m1 s1 ps ->
        spec_in t1 m1 s1 (add_spec t2 m2 s2 ps).
Proof.
  intros t1 t2 m1 m2 s1 s2 ps H H0.
  unfold add_spec. unfold spec_in in H0.
  do 2 destruct H0.
  case RType.eq_dec with (s1 := t1) (s2 := t2).
  intro H2.
  destruct H. elim H; assumption.
  rewrite <- H2. apply Smap.find_1 in H0.
  rewrite H0. exists (Smap.add m2 s2 x).
  split. apply Smap.add_1. reflexivity.
  apply Smap.add_2. auto.
  assumption. intro H2.
  unfold spec_in. exists x.
  split. case (Smap.find t2 ps).
  intro o. apply Smap.add_2. auto.
  assumption. apply Smap.add_2. auto.
  assumption. assumption.
Qed.

Lemma spec_add_3 : forall t1 t2 m1 m2 s1 s2 ps,
    (t1 <> t2 \/ m1 <> m2) -> spec_in t1 m1 s1 (add_spec t2 m2 s2 ps) ->
        spec_in t1 m1 s1 ps.
Proof.
  intros t1 t2 m1 m2 s1 s2 ps H H0.
  unfold add_spec in H0; unfold spec_in in H0.
  do 2 destruct H0.
  case RType.eq_dec with (s1 := t1) (s2 := t2).
  intro H2. destruct H. elim H; assumption.
  rewrite <- H2 in H0.
  inductS (Smap.find t1 ps); rewrite H3 in H0.
  assert (x = Smap.add m2 s2 x0).
  apply smap_add in H0. assumption.
  exists x0. split.
  apply Smap.find_2 in H3. assumption.
  rewrite H4 in H1.
  apply Smap.add_3 in H1. assumption. auto.
  assert (x = Smap.add m2 s2 no_spec).
  assert (Smap.MapsTo t1 (Smap.add m2 s2 no_spec)
    (Smap.add t1 (Smap.add m2 s2 no_spec) ps)).
  apply Smap.add_1. reflexivity.
  apply smap_inject with (k := t1)
    (m := (Smap.add t1 (Smap.add m2 s2 no_spec) ps)).
  assumption. assumption.
  rewrite H4 in H1.
  apply Smap.add_3 in H1.
  apply Smap.empty_1 in H1. elim H1. auto.
  intro H2. inductS (Smap.find t2 ps);
  rewrite H3 in H0; apply Smap.add_3 in H0;
  try (exists x; split; assumption); auto.
Qed.

Lemma spec_get : forall t m s ps, spec_in t m s ps <-> get_spec t m ps = Some s.
Proof.
  intros t m s ps. split. intro H.
  unfold spec_in in H.
  do 2 destruct H.
  unfold get_spec.
  apply Smap.find_1 in H.
  rewrite H.
  apply Smap.find_1 in H0.
  rewrite H0; reflexivity.
  intro H. unfold get_spec in H.
  unfold spec_in.
  inductS (Smap.find t ps); rewrite H0 in H.
  apply Smap.find_2 in H.
  apply Smap.find_2 in H0.
  exists x; split; assumption.
  inversion H.
Qed.

Lemma spec_not_get : forall t m ps,
    (forall s, ~ spec_in t m s ps) <-> get_spec t m ps = None.
Proof.
  intros t m ps. split. intro H.
  unfold spec_in in H. unfold get_spec.
  inductS (Smap.find t ps).
  apply Smap.find_2 in H0.
  assert (forall s, ~ Smap.MapsTo m s x).
  intros s H1. elim H with (s := s).
  exists x; split; assumption.
  inductS (Smap.find m x).
  apply Smap.find_2 in H2.
  elim H1 with (s := x0). assumption.
  reflexivity. reflexivity.
  intros H s H0. unfold get_spec in H.
  do 2 destruct H0.
  inductS (Smap.find t ps); rewrite H2 in H.
  apply Smap.find_1 in H0. rewrite H2 in H0.
  inversion H0. rewrite <- H4 in H1.
  apply Smap.find_1 in H1. rewrite H1 in H.
  inversion H. apply Smap.find_1 in H0.
  rewrite H2 in H0; inversion H0.
Qed.

Lemma spec_get_add_1 : forall t m s ps, get_spec t m (add_spec t m s ps) = Some s.
Proof.
  intros t m s ps. apply spec_get.
  apply spec_add_1.
Qed.

Lemma spec_get_add_2 : forall t1 t2 m1 m2 s ps, (t1 <> t2 \/ m1 <> m2) ->
    get_spec t1 m1 (add_spec t2 m2 s ps) = get_spec t1 m1 ps.
Proof.
  intros t1 t2 m1 m2 s ps H.
  inductS (get_spec t1 m1 ps).
  apply spec_get.
  apply spec_add_2. assumption.
  apply spec_get. assumption.
  apply spec_not_get.
  intros s0 H1. apply spec_add_3 in H1.
  apply spec_get in H1. rewrite H1 in H0.
  discriminate. assumption.
Qed.

Lemma spec_init : forall t m, get_spec t m init_program_spec = None.
Proof.
  intros t m. unfold get_spec.
  inductS (Smap.find t init_program_spec).
  apply Smap.find_2 in H.
  apply Smap.empty_1 in H. elim H.
  reflexivity.
Qed.

Lemma prog_satis_init : forall (S : state) (e : pred_env), S + e |= init_program_spec.
Proof.
  intros S e. unfold program_satisfy.
  unfold init_program_spec.
  intros t m H. unfold method_satisfy.
  assert (forall t m, get_spec t m (Smap.empty (Smap.t spec)) = None).
  intros t0 m0. apply spec_not_get. intros s H0.
  apply spec_get in H0. unfold get_spec in H0.
  inductS (Smap.find t0 (Smap.empty (Smap.t spec))).
  apply Smap.find_2 in H1.
  apply Smap.empty_1 in H1. elim H1.
  rewrite H1 in H0. discriminate.
  do 2 rewrite H0. unfold bs.
  case (RType.beq t m); [reflexivity|].
  induction (RType.get_super t (State.get_super_env S)).
  induction a. unfold bs2. reflexivity.
  unfold bs2. rewrite H0. rewrite H0. apply IHa.
  reflexivity.
Qed.

Open Scope heap_scope.
Open Scope lang_scope.
Open Scope state_scope.

Lemma refine_refl : forall sp : spec, sp <<= sp.
Proof.
  unfold refine. intros; assumption.
Qed.

Lemma refine_trans : forall sp1 sp2 sp3 : spec, sp1 <<= sp2 -> sp2 <<= sp3 -> sp1 <<= sp3.
Proof.
  unfold refine. intros.
  apply H. apply H0.
  assumption.
Qed.

Lemma refine_cons1 : forall p1 p2 p3 : hprop, p3 ==> p2 -> (p1, p2) <<= (p1, p3).
Proof.
  intros p1 p2 p3 H.
  unfold refine. unfold cmd_satisfy.
  intros. apply H. apply H0 with (h := h) (s := s);
  assumption.
Qed.

Lemma refine_cons2 : forall p1 p2 p3 : hprop, p1 ==> p3 -> (p1, p2) <<= (p3, p2).
Proof.
  intros p1 p2 p3 H.
  unfold refine. unfold cmd_satisfy.
  intros. apply H0 with (h := h) (s := s);
  [ | apply H]; assumption.
Qed.

Lemma refine_inh : forall t1 t2 S e m ps,
    S + e |> ps # t2,m ->
    match get_spec t1 m ps, get_spec t2 m ps with
    | Some (hp1, hp2), Some (hp3, hp4) =>
        match MEnv.find_mbody (State.get_mbody_env S) t1 m,
              MEnv.find_mbody (State.get_mbody_env S) t2 m with
        | Some mb1, Some mb2 =>
            (hp1, hp2) = (hp3, hp4) /\ mb1 = mb2 /\
            (add_args (MEnv.get_args mb1) (evalP t1 e hp1), evalP t1 e hp2)
        <<= (add_args (MEnv.get_args mb2) (evalP t2 e hp3), evalP t2 e hp4)

        | _, _ => False
        end
    | _, _ => False
    end -> S + e |> ps # t1,m.
Proof.
  intros. inductS (get_spec t1 m ps); rewrite H1 in H0.
  induction x.
(* induction a.
  induction (get_spec t2 m ps) in H0. induction a0.
  induction (MEnv.find_mbody (State.get_mbody_env S) t1 m) in H0.
  induction (MEnv.find_mbody (State.get_mbody_env S) t2 m) in H0.
  do 2 destruct H0.
  apply H0. assumption.*)
Admitted.

Lemma h_skip : forall (p : hprop) (S : state) (t : rtype) (e : pred_env),
    S + e, t |- (p, p) # Lang.skip.
Proof.
  intros p S t e. unfold cmd_satisfy.
  intros h s S' H0 H1. inversion H0.
  rewrite State.get_after_update_00.
  rewrite State.update_comm_01.
  rewrite State.get_after_update_11.
  assumption.
Qed.

Lemma h_asn : forall (p1 p2 : hprop) (n : name) (e : expr) (S : state)
                     (t : rtype) (pe : pred_env),
    p1 ==> HProp.subst_name_1 n e p2 ->
    S + pe,t |- (p1, p2) # Lang.assign n e.
Proof.
  intros p1 p2 n e S t pe H.
  apply refine_cons2 with (p2 := p2) in H.
  apply H. unfold cmd_satisfy.
  intros h s S' H0 H1. inversion H0.
  rewrite State.update_comm_01.
  rewrite State.get_after_update_11.
  rewrite State.get_after_map_01.
  rewrite <- State.update_comm_01.
  rewrite State.get_after_update_00.
  rewrite State.get_after_map_11.
  rewrite State.update_comm_01.
  rewrite State.get_after_update_11.
  rewrite HProp.lemma3_23 in H1.
  assumption.
Qed.

Lemma h_asnb : forall (p1 p2 : hprop) (n : name) (b : bexpr) (S : state)
                      (t : rtype) (e : pred_env),
               p1 ==> HProp.subst_name_2 n b p2 ->
               S + e, t |- (p1, p2) # Lang.assignb n b.
Proof.
  intros p1 p2 n b S t e H.
  apply refine_cons2 with (p2 := p2) in H.
  apply H. unfold cmd_satisfy.
  intros h s S' H0 H1. inversion H0.
  rewrite State.update_comm_01.
  rewrite State.get_after_update_11.
  rewrite State.get_after_map_01.
  rewrite <- State.update_comm_01.
  rewrite State.get_after_update_00.
  rewrite State.get_after_map_11.
  rewrite State.update_comm_01.
  rewrite State.get_after_update_11.
  rewrite HProp.lemma3_23' in H1.
  assumption.
Qed.

Lemma h_mut : forall (v a : name) (e : expr) (S : state) (r1 r2 r3: ref)
                     (t : rtype) (pe : pred_env),
    S + pe, t |- (v +-> r1 /.\ r1`a |-> r3 /.\ e |=> r2,
                 v +-> r1 /.\ r1`a |-> r2 /.\ e |=> r2) # Lang.fwrite v a e.
Proof.
  intros v a e S r1 r2 r3 t pe.
  unfold cmd_satisfy. intros h s S' H H0.
  inversion H.
  rewrite State.get_after_map_00.
  rewrite State.get_after_update_10.
  rewrite State.get_after_update_11.
  rewrite State.get_after_update_00.
  rewrite State.get_after_map_10.
  rewrite State.get_after_update_10.
  rewrite State.get_after_update_11.
  unfold HProp.eval in H0. destruct H0. destruct H8.
  unfold HProp.eval; split. assumption.
  split. apply Heap.equal_3 in H8; rewrite H8.
  rewrite State.get_after_update_10 in H6.
  rewrite State.get_after_update_11 in H6.
  rewrite H0 in H6. inversion H6.
  rewrite <- Heap.update_update.
  induction e; unfold Expr.eval; rewrite H9; apply Heap.eq_refl.
  assumption.
Qed.

Lemma h_lkp : forall (x v a: name) (S : state) (r1 r2: ref) (t : rtype) (e : pred_env),
    x <> v ->
    S + e, t |- (v +-> r1 /.\ r1`a |-> r2,
                 v +-> r1 /.\ r1`a |-> r2 /.\ x +-> r2) # Lang.fread x v a.
Proof.
  intros x v a S r1 r2 t e H.
  unfold cmd_satisfy. simpl.
  intros. destruct H1. inversion H0.
  rewrite State.get_after_map_11.
  rewrite State.get_after_update_10.
  rewrite State.get_after_update_11.
  rewrite State.get_after_map_01.
  rewrite State.get_after_update_00.
  split. apply Stack.in_get. apply Stack.in_update_2.
  auto. apply Stack.in_get in H1; assumption.
  split. assumption.
  rewrite State.get_after_update_10 in H8.
  rewrite State.get_after_update_11 in H8.
  rewrite H1 in H8. inversion H8.
  rewrite State.get_after_update_00 in H9.
  apply Heap.equal_3 in H2; rewrite H2 in H9.
  rewrite H11 in H9. apply Heap.in_get in H9. assert (r' = r2).
  apply Heap.in_equal with (r := r) (n := a) (h := Heap.update r a r2 {}).
  assumption. apply Heap.in_update_1.
  rewrite H10. apply Stack.in_get.
  apply Stack.in_update_1.
Qed.

Lemma h_lkp' : forall (x a: name) (S : state) (r1 r2: ref) (t : rtype) (e : pred_env),
    S + e, t |- (x +-> r1 /.\ r1`a |-> r2,
                 x +-> r2 /.\ r1`a |-> r2) # Lang.fread x x a.
Proof.
  intros x a S r1 r2 t e.
  unfold cmd_satisfy. simpl.
  intros h s S' H [H0 H1]. inversion H.
  rewrite State.get_after_map_11.
  rewrite State.get_after_update_10.
  rewrite State.get_after_update_11.
  rewrite State.get_after_map_01.
  rewrite State.get_after_update_00.
  split. apply Stack.in_get.
  rewrite State.get_after_update_00 in H8.
  apply Heap.equal_3 in H1; rewrite H1 in H8.
  rewrite State.get_after_update_10 in H7.
  rewrite State.get_after_update_11 in H7.
  rewrite H7 in H0; inversion H0. rewrite H10 in H8.
  assert (r' = r2). apply Heap.in_equal with (r := r1) (n := a)
    (h := Heap.update r1 a r2 {}). apply Heap.in_get in H8.
  assumption. apply Heap.in_update_1.
  rewrite H9. apply Stack.in_update_1.
  assumption.
Qed.

Lemma h_cast : forall (x v: name) (C : rtype) (S : state) (r: ref)
                      (t : rtype) (e : pred_env),
    S + e, t |- (v +-> r /.\ r <: C, x +-> r) # Lang.cast x C v.
Proof.
  intros x v C S r t e.
  unfold cmd_satisfy. simpl.
  intros h s S' H [H0 H1].
  inversion H.
  rewrite State.get_after_map_11.
  rewrite State.get_after_update_10.
  rewrite State.get_after_update_11.
  rewrite State.get_after_update_10 in H7.
  rewrite State.get_after_update_11 in H7.
  rewrite H7 in H0; inversion H0.
  apply Stack.in_get; apply Stack.in_update_1.
Qed.

Lemma h_res : forall (p1 p2 : hprop) (e : expr) (S : state) (t : rtype) (pe : pred_env),
    p1 ==> HProp.subst_name_1 "res" e p2 ->
    S + pe, t |- (p1, p2) # (Lang.creturn e).
Proof.
  intros p1 p2 e S t pe H.
  apply refine_cons2 with (p2 := p2) in H.
  apply H. unfold cmd_satisfy.
  intros h s S' H0 H1. inversion H0.
  rewrite State.update_comm_01.
  rewrite State.get_after_update_11.
  rewrite State.get_after_map_01.
  rewrite <- State.update_comm_01.
  rewrite State.get_after_update_00.
  rewrite State.get_after_map_11.
  rewrite State.update_comm_01.
  rewrite State.get_after_update_11.
  rewrite HProp.lemma3_23 in H1.
  assumption.
Qed.

Lemma h_seq : forall (p q r: hprop) (c1 c2 : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    S + e, t |- (p, q) # c1 -> S + e, t |- (q, r) # c2 ->
    S + e, t |- (p, r) # (c1; c2).
Proof.
  unfold cmd_satisfy; intros. inversion H1.
  apply H0 with (h := State.get_heap s2) (s := State.get_stack s2).
  apply Sem.sem_seq in H6.
  apply State.seq_update_heap in H6.
  apply State.seq_update_stack in H6.
  apply State.seq_subst in H6.
  rewrite H6. assumption.
  apply H with (h := h) (s := s); assumption.
Qed.

(* For method invocation *)
Fixpoint subst_args1 (p : hprop) (x v : name) (arg : list name) (le : list expr) : hprop :=
    match arg, le with
    | nil, nil => HProp.subst_name_3 "res" x (HProp.subst_name_3 "this" v p)
    | cons a0 a, cons e0 e => subst_args1 (HProp.subst_name_1 a0 e0 p) x v a e
    | _, _ => p (* Error: argument number mismatch *)
    end.

(* For creating new objects *)
Fixpoint subst_args2 (p : hprop) (arg : list name) (le : list expr) : hprop :=
    match arg, le with
    | nil, nil => p
    | cons a0 a, cons e0 e => subst_args2 (HProp.subst_name_1 a0 e0 p) a e
    | _, _ => p (* Error: argument number mismatch *)
    end.

(* spec of "x := v.m(le)" *)
Axiom h_dinv : forall S e v t t' m p1 p2 mb ps x le,
    get_spec t m ps = Some (p1, p2) ->
    MEnv.find_mbody (State.get_mbody_env S) t m = Some mb ->
    DType.get_dtype v (State.get_dtype S) = Some t ->
    S + e, t' |- (subst_args1 p1 x v (MEnv.get_args mb) le,
                  subst_args1 p2 x v (MEnv.get_args mb) le) # Lang.dcall x v m le.

(* spec of "x := v.t::m(le)" *)
Axiom h_sinv : forall S e v t t' m p1 p2 mb ps x le,
    get_spec t m ps = Some (p1, p2) ->
    MEnv.find_mbody (State.get_mbody_env S) t m = Some mb ->
    S + e, t' |- (subst_args1 p1 x v (MEnv.get_args mb) le,
                  subst_args1 p2 x v (MEnv.get_args mb) le) # Lang.scall x v t m le.

(* spec of "x := new t(le)" *)
Axiom h_new : forall S e p1 p2 mb ps x t t' le,
    get_spec t t ps = Some (p1, p2) ->
    MEnv.find_mbody (State.get_mbody_env S) t t = Some mb ->
    S + e, t' |- (subst_args2 p1 (MEnv.get_args mb) le,
                  HProp.subst_name_3 "this" x
                    (subst_args2 p2 (MEnv.get_args mb) le)) # Lang.calloc x t le.

Lemma list_eq_ext : forall S e t c (l1 l2 : list ref) (hp1 hp2 : hprop),
    (l1 = l2 -> S + e, t |- (hp1, hp2) # c) ->
     S + e, t |- (hp1 /.\ HProp.list_eq l1 l2, hp2) # c.
Proof.
  intros S e t c l1 l2 hp1 hp2 H.
  unfold cmd_satisfy; simpl.
  intros h s se H0 [H1 H2].
  apply HProp.list_equal_1 in H2.
  apply H in H2; unfold cmd_satisfy in H2;
  apply (H2 h s); assumption.
Qed.

(* "the variables $c$ modifies" is disjoint with "the free variables in $r$"
   -> {p} c {q} -> {p * r} c {q * r} *)
Axiom h_frame : forall (p q r: hprop) (c : cmd) (S : state) (t : rtype) (e : pred_env),
    sset_dsj (Lang.md c) (HProp.fv r) ->
    S + e, t |- (p, q) # c -> S + e, t |- (p * r, q * r) # c.
(*Proof.
  unfold cmd_satisfy. induction c.
  unfold HProp.eval; fold HProp.eval.
  intros S t pe H H0 h s S' H1 H2.
  unfold evalP; fold evalP.
  do 3 destruct H2. destruct H3. destruct H4.
  unfold Sem.sem in H1. unfold Sem.peq in H1. apply State.equal_3 in H1.
  (*assert (exists h3, h3 |*| x0 /\ State.get_heap S' |=| h3 |+| x0).
  apply Heap.exist_pdisjoint. rewrite <- H1.
  rewrite State.get_after_map_01.
  rewrite State.get_after_update_00.
  rewrite H3. apply Heap.subheap_union.*)
  exists x. exists x0. assert (State.get_heap S' = x |+| x0).
  rewrite <- H1.
  rewrite State.get_after_map_01.
  rewrite State.get_after_update_00.
  assumption. split. assumption.
  split. assumption. split.
  rewrite <- State.get_after_update_00 with (s := S') (h := x).
  rewrite <- State.get_after_update_10 with (s := S') (h := x).
  apply H0 with (h := x)(s := s).
  unfold Sem.sem; unfold Sem.peq; apply State.equal_3.
  induction S'. do 8 induction a. inversion H1.
  apply State.equal_3. induction S. do 8 induction a0.
  unfold State.peq. split. apply Heap.eq_refl.
  split. rewrite State.get_after_update_10.
  rewrite State.get_after_update_11.
  rewrite State.get_after_update_10.
  rewrite State.get_after_update_11.
  apply Stack.eq_refl.
  split. apply Ref.alloc_eq_refl.
  split. apply DType.eq_refl.
  split. apply TEnv.fields_eq_refl.
  split. apply TEnv.super_eq_refl.
  split. apply TEnv.cnames_eq_refl.
  split. apply TEnv.methods_eq_refl.
  split. apply TEnv.locvars_eq_refl.
  apply MEnv.eq_refl. assumption.
  rewrite <- H1.
  rewrite State.get_after_map_11.
  rewrite State.get_after_update_10.
  rewrite State.get_after_update_11.
Admitted.*)

(* "the variables $c$ modifies" is disjoint with "the free variables in $r$"
   -> "$r$ is an assertion independent of the heap"
   -> {p} c {q} -> {p /\ r} c {q /\ r} *)
Axiom h_frame' : forall (p q r: hprop) (c : cmd) (S : state)
                        (t : rtype) (e : pred_env),
    sset_dsj (Lang.md c) (HProp.fv r) -> HProp.stack_hprop r ->
        S + e, t |- (p, q) # c -> S + e, t |- (p /.\ r, q /.\ r) # c.

Lemma h_div1 : forall (p q r: hprop) (c : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    S + e, t |- (p, q /.\ r) # c <->
    S + e, t |- (p, q) # c /\ S + e, t |- (p, r) # c.
Proof.
  intros p q r c S t e.
  split. intro H. split;
  generalize H; apply refine_cons1;
  [|rewrite HProp.conj_comm]; apply HProp.conj_impl.
  unfold cmd_satisfy; intros [H H0]; simpl.
  intros; split; [apply (H h s)|apply (H0 h s)]; assumption.
Qed.

Lemma h_div2 : forall (p q r: hprop) (c : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    S + e, t |- (p \./ r, q) # c <->
    S + e, t |- (p, q) # c /\ S + e, t |- (r, q) # c.
Proof.
  intros p q r c S t e.
  split. intro H. split;
  generalize H; apply refine_cons2;
  [|rewrite HProp.disj_comm]; apply HProp.disj_impl.
  unfold cmd_satisfy; intros [H H0]; simpl.
  intros h s S' H1 [H2|H3];
  [apply (H h s)|apply (H0 h s)]; assumption.
Qed.

Lemma h_cond : forall (p q : hprop) (b : BExpr.bexpr) (c1 c2 : cmd) (S : state)
                      (t : rtype) (e : pred_env),
              S + e, t |- (p /.\ 'b, q) # c1
           -> S + e, t |- (p /.\ ~` 'b, q) # c2
           -> S + e, t |- (p, q) # Lang.cif b c1 c2.
Proof.
  unfold cmd_satisfy. simpl. intros.
  inversion H1; [apply H in H9 | apply H0 in H9];
  try split; try rewrite State.get_after_update_10 in H8;
  try rewrite State.get_after_update_11 in H8;
  try assumption. rewrite H8; discriminate.
Qed.

Lemma h_cond1 : forall (p q : hprop) (b : BExpr.bexpr) (c1 c2 : cmd) (S : state)
                      (t : rtype) (e : pred_env),
    p ==> 'b -> S + e, t |- (p, q) # c1
    -> S + e, t |- (p, q) # Lang.cif b c1 c2.
Proof.
  unfold cmd_satisfy; intros.
  inversion H1. apply H0 in H9; assumption.
  apply H in H2. unfold HProp.eval in H2.
  rewrite State.get_after_update_10 in H8.
  rewrite State.get_after_update_11 in H8.
  rewrite H2 in H8; discriminate.
Qed.

Lemma h_cond2 : forall (p q : hprop) (b : BExpr.bexpr) (c1 c2 : cmd) (S : state)
                      (t : rtype) (e : pred_env),
    p ==> ~` 'b -> S + e, t |- (p, q) # c2
    -> S + e, t |- (p, q) # Lang.cif b c1 c2.
Proof.
  unfold cmd_satisfy; intros.
  inversion H1. apply H in H2. unfold HProp.eval in H2.
  rewrite State.get_after_update_10 in H8.
  rewrite State.get_after_update_11 in H8.
  elim H2; assumption.
  apply H0 with (S' := S') in H2; assumption.
Qed.

Lemma h_iter : forall (p : hprop) (b : BExpr.bexpr) (c : cmd) (S : state)
                      (t : rtype) (e : pred_env),
    S + e, t |- (p /.\ 'b, p) # c ->
    S + e, t |- (p, p /.\ ~` 'b) # (Lang.cwhile b c).
Proof.
  unfold cmd_satisfy. simpl. intros p b c S t e H h s S'.
  cut (forall c0, Sem.sem (State.update_heap h (State.update_stack s S)) c0 S' ->
    c0 = Lang.cwhile b c -> HProp.eval p h s (State.get_super_env S) ->
  HProp.eval p (State.get_heap S') (State.get_stack S') (State.get_super_env S) /\
  BExpr.eval b (State.get_stack S') <> true); eauto.
  assert (exists S0, S0 = State.update_heap h (State.update_stack s S)).
  exists (State.update_heap h (State.update_stack s S)); reflexivity.
  destruct H0. rewrite <- H0.
  assert (h = State.get_heap x).
  rewrite H0; rewrite State.get_after_update_00; reflexivity.
  assert (s = State.get_stack x).
  rewrite H0; rewrite State.get_after_update_10;
  rewrite State.get_after_update_11; reflexivity.
  assert (State.get_super_env S = State.get_super_env x).
  rewrite H0; rewrite State.get_after_update_50;
  rewrite State.get_after_update_51; reflexivity.
  rewrite H1; rewrite H2; rewrite H3.
  intros c0 Hsem; elim Hsem; try (intros; discriminate).
  intros. inversion H9.
  assert (State.get_super_env s1 = State.get_super_env s2).
  apply Sem.sem_seq in H5. apply State.seq_subst in H5.
  induction s1; do 8 induction a;
  induction s2; do 8 induction a0; repeat destruct H5 as [?HQ H5];
  unfold State.get_super_env; reflexivity. rewrite H11.
  apply H8; try assumption.

  Focus 2. intros; split; try assumption.
  inversion H5. rewrite <- H8; rewrite H4; discriminate.
Admitted.

Lemma h_cons_1 : forall (p1 p2 p3 : hprop) (c : cmd) (S : state)
                        (t : rtype) (e : pred_env),
    p2 ==> p3 -> S + e, t |- (p1, p2) # c -> S + e, t |- (p1, p3) # c.
Proof.
  intros p1 p2 p3 c S t e H.
  apply refine_cons1; assumption.
Qed.

Lemma h_cons_2 : forall (p1 p2 p3 : hprop) (c : cmd) (S : state)
                        (t : rtype) (e : pred_env),
    p3 ==> p1 -> S + e, t |- (p1, p2) # c -> S + e, t |- (p3, p2) # c.
Proof.
  intros p1 p2 p3 c S t e H.
  apply refine_cons2; assumption.
Qed.

Lemma h_ex : forall (p q: ref -> hprop) (c : cmd) (S : state)
                    (t : rtype) (e : pred_env),
    (forall r : ref, S + e, t |- (p r, q r) # c) -> S + e, t |- (=| p, =| q) # c.
Proof.
  unfold cmd_satisfy. simpl.
  intros. destruct H1.
  exists x. apply H with (h := h) (s := s); assumption.
Qed.

Lemma h_ex1 : forall (p : ref -> hprop) (q : hprop) (c : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    (forall r : ref, S + e, t |- (p r, q) # c) -> S + e, t |- (=| p, q) # c.
Proof.
  unfold cmd_satisfy. simpl.
  intros. destruct H1.
  apply H with (r := x) (h := h) (s := s); assumption.
Qed.

Lemma h_ex2 : forall (p : hprop) (q : ref -> hprop) (r : ref) (c : cmd)
                     (S : state) (t : rtype) (e : pred_env),
    S + e, t |- (p, q r) # c -> S + e, t |- (p, =| q) # c.
Proof.
  intros p q r c S t e. apply h_cons_1.
  apply HProp.impl_exist.
Qed.

Lemma h_ex3 : forall (p : list ref -> hprop) (q : hprop) (c : cmd) (S : state)
                     (t : rtype) (e : pred_env),
    (forall l, S + e, t |- (p l, q) # c) -> S + e, t |- (E| p, q) # c.
Proof.
  unfold cmd_satisfy. simpl.
  intros. destruct H1.
  apply H with (l := x) (h := h) (s := s); assumption.
Qed.

Lemma h_ex4 : forall (p : hprop) (q : list ref -> hprop) (l : list ref)
                     (c : cmd) (S : state) (t : rtype) (e : pred_env),
    S + e, t |- (p, q l) # c -> S + e, t |- (p, E| q) # c.
Proof.
  intros p q l c S t e. apply h_cons_1.
  unfold HProp.eimpl; simpl; intros.
  exists l; assumption.
Qed.

Lemma h_contrad : forall (p : hprop) (c : cmd) (S : state) (t : rtype) (e : pred_env),
    S + e, t |- (HProp.hfalse, p) # c.
Proof.
  unfold cmd_satisfy; intros.
  unfold HProp.eval in H0; elim H0.
Qed.

Lemma refine_frame : forall p q r : hprop,
    HProp.fv r = Sset.empty -> (p * r, q * r) <<= (p, q).
Proof.
  intros p q r H; unfold refine.
  intros S t c e. apply h_frame.
  rewrite H; apply sset_dsj_empty.
Qed.

Lemma refine_exist : forall (p1 q1 : ref -> hprop) (p2 q2 : hprop) (r : ref),
    (forall r, (p1 r, q1 r) <<= (p2, q2)) -> (=|p1, =|q1) <<= (p2, q2).
Proof.
  unfold refine; unfold cmd_satisfy.
  simpl; intros. destruct H2. exists x.
  apply H with (c := c) (h := h) (s := s); try assumption.
Qed.

Close Scope state_scope.
Close Scope lang_scope.
Close Scope heap_scope.
Close Scope hprop_scope.
Close Scope spec_scope.
Close Scope string_scope.

End Spec.

Bind Scope spec_scope with Spec.spec.
Delimit Scope spec_scope with spec.

Notation "S + e , t |- sp # c" := (Spec.cmd_satisfy S t c e sp) (at level 30) : spec_scope.
Notation "S + e |> ps # t , m" := (Spec.method_satisfy S t m e ps) (at level 30) : spec_scope.
Notation "S + e |= ps" := (Spec.program_satisfy S e ps) (at level 30) : spec_scope.
Infix "<<=" := Spec.refine (at level 70) : spec_scope.

Ltac trivBS  := repeat (reflexivity || (split; [apply Spec.refine_refl|]) ||
                        (split; [|trivBS; fail])).
Ltac bs      := unfold Spec.bs; simpl; trivBS.
Ltac exc     := repeat (rewrite HProp.exist_conj || rewrite HProp.exist_conj'
                || rewrite HProp.existl_conj || rewrite HProp.existl_conj'
                || rewrite HProp.exist_sep_conj || rewrite HProp.exist_sep_conj').
Ltac exconj  := exc; try (apply Spec.h_ex; intro).
Ltac exconj1 := exc; try (apply Spec.h_ex1; intro).
Ltac exconj2 v := exc; apply Spec.h_ex2 with (r := v).
Ltac exconj3 := exc; try (apply Spec.h_ex3; intro).
Ltac exconj4 v := exc; apply Spec.h_ex4 with (l := v).
Ltac eximpl1 := exc; try (apply HProp.forall_exist_impl; intro).
Ltac eximpl2 v := exc; apply HProp.exist_exist_impl; exists v.
Ltac eximpl3 := exc; try (apply HProp.forall_exist_impl2; intro).
Ltac eximpl4 v := exc; apply HProp.exist_exist_impl2; exists v.
Ltac impConj := repeat (apply HProp.impl_conj1 || apply HProp.impl_conj2 ||
                        apply HProp.impl_sep_conj1 || apply HProp.impl_sep_conj2);
                try (apply HProp.conj_impl || apply HProp.eimpl_refl ||
                     rewrite HProp.conj_comm; apply HProp.conj_impl).
Ltac param   := (rewrite HProp.param_arg || rewrite HProp.param_arg2 ||
                 rewrite HProp.param_arg3).
Ltac param2  := repeat param;
                repeat (rewrite HProp.param_ext || rewrite HProp.param_ext2);
                repeat param; exconj.
Ltac Simpl   := unfold Spec.method_satisfy; simpl;
                try rewrite Spec.unf_pred; param2;
                repeat rewrite HProp.sep_conj_emp2; simpl; try split.
Ltac unfEval := unfold HProp.eval; fold HProp.eval;
                unfold BExpr.eval; unfold Expr.beeq.
Ltac mbody   := try (rewrite State.find_mbody_comm1 ||
                     rewrite State.find_mbody_comm2);
                try (discriminate || left; discriminate || right; discriminate).
Ltac commC   := rewrite HProp.conj_comm.
Ltac commC1 x := rewrite HProp.conj_comm with (hp1 := x).
Ltac commC2 x := rewrite HProp.conj_comm with (hp2 := x).
Ltac assoC   := rewrite HProp.conj_asso.
Ltac assoC'  := rewrite <- HProp.conj_asso.
Ltac commSC  := rewrite HProp.sep_conj_comm.
Ltac commSC1 x := rewrite HProp.sep_conj_comm with (hp1 := x).
Ltac commSC2 x := rewrite HProp.sep_conj_comm with (hp2 := x).
Ltac assoSC  := rewrite HProp.sep_conj_asso.
Ltac assoSC' := rewrite <- HProp.sep_conj_asso.
Ltac sprop   := repeat (apply HProp.stack_hprop_conj; split);
                try apply HProp.stack_hprop_neg;
                try (apply HProp.stack_hprop_1 || apply HProp.stack_hprop_2 ||
                     apply HProp.stack_hprop_3 || apply HProp.stack_hprop_4 ||
                     apply HProp.stack_hprop_5 || apply HProp.stack_hprop_6 ||
                     apply HProp.stack_hprop_7).
Ltac sepconj := repeat try (rewrite HProp.stack_sep_conj1 ||
                            rewrite HProp.stack_sep_conj2 ||
                            rewrite HProp.stack_sep_conj3); sprop.
Ltac sepsep  := repeat rewrite <- HProp.stack_sep_conj1; sprop.
Ltac freevar := try (unfold HProp.fv; apply sset_dsj_empty ||
                     apply sset_dsj_sym; apply sset_dsj_empty).
Ltac frame   := sepconj; apply Spec.h_frame; freevar.
Ltac frame'  := apply Spec.h_frame'; try apply sset_dsj_card; eauto; sprop.
Ltac lkp     := apply Spec.h_lkp; discriminate.
Ltac mut x   := rewrite <- HProp.var_exp with (n := x); apply Spec.h_mut.
Ltac mlist   := let t := fresh "t" in
                let m := fresh "m" in
                let H := fresh "H" in
                intros t m H;
                repeat (rewrite <- State.in_mbody_env_1 in H ||
                        rewrite State.in_mbody_env_2 in H ||
                        rewrite State.in_mbody_env_3 in H ||
                        rewrite State.in_mbody_env_4 in H ||
                        rewrite State.in_mbody_env_init in H);
                unfold List.hd in H; propSimp H.
Ltac mtdSpec L :=
    let H := fresh "H" in
    let H0 := fresh "H" in
    match goal with
    | [id : _ /\ _ \/ _ |- _] => destruct id; [destruct id as [H H0];
                                   rewrite H; rewrite H0; apply L|]
    | [id : _ /\ _ |- _] => destruct id as [H H0]; rewrite H;
                              rewrite H0; apply L
    end.


(*********************************************************************************************************************************)
(* General: general data structures                                                                                *)
(*********************************************************************************************************************************)

Require Import Coq.Unicode.Utf8.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Strings.String.
Require Setoid.
Require Import Coq.Lists.List.
Require Import Preamble.
Generalizable All Variables.
Require Import Omega.

Definition EqDecider T := forall (n1 n2:T),  sumbool (n1=n2) (not (n1=n2)).
Class EqDecidable (T:Type) :=
{ eqd_type           := T
; eqd_dec            :  forall v1 v2:T, sumbool (v1=v2) (not (v1=v2))
}.
Coercion eqd_type : EqDecidable >-> Sortclass.

Instance EqDecidableOption (T:Type)(EQDT:EqDecidable T) : EqDecidable ??T.
  apply Build_EqDecidable.
  intros.
  destruct v1;
  destruct v2.
  destruct (eqd_dec t t0).
  subst.
  left; auto.
  right.
  unfold not; intros.
  inversion H.
  subst.
  apply n.
  auto.
  right; unfold not; intro; inversion H.
  right; unfold not; intro; inversion H.
  left; auto.
  Defined.

Class ToString (T:Type) := { toString : T -> string }.
Instance StringToString : ToString string := { toString := fun x => x }.

Class Concatenable {T:Type} :=
 { concatenate : T -> T -> T }.
 Implicit Arguments Concatenable [ ].
Open Scope string_scope.
Open Scope type_scope.
Close Scope list_scope.
Notation "a +++ b" := (@concatenate _ _ a b) (at level 99).
Instance ConcatenableString : Concatenable string := { concatenate := append }.

(*******************************************************************************)
(* Trees                                                                       *)

Inductive Tree (a:Type) : Type :=
  | T_Leaf   : a -> Tree a
  | T_Branch : Tree a -> Tree a -> Tree a.
Implicit Arguments T_Leaf   [ a ].
Implicit Arguments T_Branch [ a ].

Notation "a ,, b"   := (@T_Branch _ a b)                        : tree_scope.

(* tree-of-option-of-X comes up a lot, so we give it special notations *)
Notation "[ q ]"    := (@T_Leaf (option _) (Some q))            : tree_scope.
Notation "[ ]"      := (@T_Leaf (option _) None)                : tree_scope.
Notation "[]"       := (@T_Leaf (option _) None)                : tree_scope.

Fixpoint InT {A} (a:A) (t:Tree ??A) {struct t} : Prop :=
  match t with
    | T_Leaf None     => False
    | T_Leaf (Some x) => x = a
    | T_Branch b1 b2  => InT a b1 \/ InT a b2
  end.

Open Scope tree_scope.

Fixpoint mapTree {a b:Type}(f:a->b)(t:@Tree a) : @Tree b :=
  match t with
    | T_Leaf x     => T_Leaf (f x)
    | T_Branch l r => T_Branch (mapTree f l) (mapTree f r)
  end.
Fixpoint mapOptionTree {a b:Type}(f:a->b)(t:@Tree ??a) : @Tree ??b :=
  match t with
    | T_Leaf None     => T_Leaf None
    | T_Leaf (Some x) => T_Leaf (Some (f x))
    | T_Branch l r    => T_Branch (mapOptionTree f l) (mapOptionTree f r)
  end.
Fixpoint mapTreeAndFlatten {a b:Type}(f:a->@Tree b)(t:@Tree a) : @Tree b :=
  match t with
    | T_Leaf x        => f x
    | T_Branch l r    => T_Branch (mapTreeAndFlatten f l) (mapTreeAndFlatten f r)
  end.
Fixpoint mapOptionTreeAndFlatten {a b:Type}(f:a->@Tree ??b)(t:@Tree ??a) : @Tree ??b :=
  match t with
    | T_Leaf None     => []
    | T_Leaf (Some x) => f x
    | T_Branch l r    => T_Branch (mapOptionTreeAndFlatten f l) (mapOptionTreeAndFlatten f r)
  end.
Fixpoint treeReduce {T:Type}{R:Type}(mapLeaf:T->R)(mergeBranches:R->R->R) (t:Tree T) :=
  match t with
  | T_Leaf x => mapLeaf x
  | T_Branch y z => mergeBranches (treeReduce mapLeaf mergeBranches y) (treeReduce mapLeaf mergeBranches z)
  end.
Definition treeDecomposition {D T:Type} (mapLeaf:T->D) (mergeBranches:D->D->D) :=
  forall d:D, { tt:Tree T & d = treeReduce mapLeaf mergeBranches tt }.
Lemma mapOptionTree_distributes
  : forall T R (a b:Tree ??T) (f:T->R),
    mapOptionTree f (a,,b) = (mapOptionTree f a),,(mapOptionTree f b).
  reflexivity.
  Qed.

Fixpoint reduceTree {T}(unit:T)(merge:T -> T -> T)(tt:Tree ??T) : T :=
  match tt with
    | T_Leaf None     => unit
    | T_Leaf (Some x) => x
    | T_Branch b1 b2  => merge (reduceTree unit merge b1) (reduceTree unit merge b2)
  end.

Lemma tree_dec_eq :
   forall {Q}(t1 t2:Tree ??Q),
     (forall q1 q2:Q, sumbool (q1=q2) (not (q1=q2))) ->
     sumbool (t1=t2) (not (t1=t2)).
  intro Q.
  intro t1.
  induction t1; intros.

  destruct a; destruct t2.
  destruct o.
  set (X q q0) as X'.
  inversion X'; subst.
  left; auto.
  right; unfold not; intro; apply H. inversion H0; subst. auto.
  right. unfold not; intro; inversion H.
  right. unfold not; intro; inversion H.
  destruct o.
  right. unfold not; intro; inversion H.
  left; auto.
  right. unfold not; intro; inversion H.

  destruct t2.
  right. unfold not; intro; inversion H.
  set (IHt1_1 t2_1 X) as X1.
  set (IHt1_2 t2_2 X) as X2.
  destruct X1; destruct X2; subst.
  left; auto.

  right.
  unfold not; intro H.
  apply n.
  inversion H; auto.

  right.
  unfold not; intro H.
  apply n.
  inversion H; auto.

  right.
  unfold not; intro H.
  apply n.
  inversion H; auto.
  Defined.

Lemma mapOptionTree_compose : forall A B C (f:A->B)(g:B->C)(l:Tree ??A),
  (mapOptionTree (g ○ f) l) = (mapOptionTree g (mapOptionTree f l)).
  induction l.
    destruct a.
    reflexivity.
    reflexivity.
    simpl.
    rewrite IHl1.
    rewrite IHl2.
    reflexivity.
    Qed.

Lemma mapOptionTree_extensional {A}{B}(f g:A->B) : (forall a, f a = g a) -> (forall t, mapOptionTree f t = mapOptionTree g t).
  intros.
  induction t.
  destruct a; auto.
  simpl; rewrite H; auto.
  simpl; rewrite IHt1; rewrite IHt2; auto.
  Qed.

Fixpoint treeToString {T}{TT:ToString T}(t:Tree ??T) : string :=
match t with
  | T_Leaf None => "[]"
  | T_Leaf (Some s) => "["+++toString s+++"]"
  | T_Branch b1 b2 => treeToString b1 +++ ",," +++ treeToString b2
end.
Instance TreeToString {T}{TT:ToString T} : ToString (Tree ??T) := { toString := treeToString }.

(*******************************************************************************)
(* Lists                                                                       *)

Notation "a :: b"         := (cons a b)                               : list_scope.
Open Scope list_scope.
Fixpoint leaves {a:Type}(t:Tree (option a)) : list a :=
  match t with
    | (T_Leaf l)     => match l with
                          | None   => nil
                          | Some x => x::nil
                        end
    | (T_Branch l r) => app (leaves l) (leaves r)
  end.
(* weak inverse of "leaves" *)
Fixpoint unleaves {A:Type}(l:list A) : Tree (option A) :=
  match l with
    | nil    => []
    | (a::b) => [a],,(unleaves b)
  end.

(* a map over a list and the conjunction of the results *)
Fixpoint mapProp {A:Type} (f:A->Prop) (l:list A) : Prop :=
  match l with
    | nil => True
    | (a::al) => f a /\ mapProp f al
  end.

(* delete the n^th element of a list *)
Definition list_del : forall {T:Type} (l:list T) (n:nat)(pf:lt n (length l)), list T.
  refine (fix list_del {T:Type} (l:list T) (n:nat) : lt n (length l) -> list T :=
    match l as L return lt n (length L) -> list T with
      | nil  => _
      | a::b => match n with
                  | O    => fun _ => b
                  | S n' => fun pf => (fun list_del' => _) (list_del _ b n')
                end
    end).
    intro pf.
    simpl in pf.
    assert False.
    inversion pf.
    inversion H.

    simpl in *.
    apply list_del'.
    omega.
    Defined.

Definition list_get : forall {T:Type} (l:list T) (n:nat), lt n (length l) -> T.
  refine (fix list_get {T:Type} (l:list T) (n:nat) : lt n (length l) -> T :=
    match l as L return lt n (length L) -> T with
      | nil => _
      | a::b => match n with
                  | O    => fun _ => a
                  | S n' => fun pf => (fun list_get' => _) (list_get _ b n')
                end
    end).
  intro pf.
  assert False.
  inversion pf.
  inversion H.

  simpl in *.
  apply list_get'.
  omega.
  Defined.

Fixpoint list_ins (n:nat) {T:Type} (t:T) (l:list T) : list T :=
  match n with
    | O    => t::l
    | S n' => match l with
                | nil  => t::nil
                | a::b => a::(list_ins n' t b)
              end
  end.

Lemma list_ins_nil : forall T n x, @list_ins n T x nil = x::nil.
  intros.
  destruct n; auto.
  Qed.

Fixpoint list_take {T:Type}(l:list T)(n:nat) :=
  match n with
    | O    => nil
    | S n' => match l with
                | nil  => nil
                | a::b => a::(list_take b n')
              end
  end.

Fixpoint list_drop {T:Type}(l:list T)(n:nat) :=
  match n with
    | O    => l
    | S n' => match l with
                | nil  => nil
                | a::b => list_drop b n'
              end
  end.

Lemma list_ins_app T n κ : forall Γ, @list_ins n T κ Γ = app (list_take Γ n) (κ::(list_drop Γ n)).
  induction n.
  simpl.
  intros.
  destruct Γ; auto.
  intro Γ.
  destruct Γ.
  reflexivity.
  simpl.
  rewrite <- IHn.
  reflexivity.
  Qed.

Lemma list_take_drop T l : forall n, app (@list_take T l n) (list_drop l n) = l.
  induction l; auto.
  simpl.
  destruct n; auto.
  simpl.
  destruct n.
  reflexivity.
  simpl.
  rewrite IHl.
  reflexivity.
  Qed.

Lemma map_id : forall A (l:list A), (map (fun x:A => x) l) = l.
  induction l.
  auto.
  simpl.
  rewrite IHl.
  auto.
  Defined.
Lemma map_app : forall `(f:A->B) l l', map f (app l l') = app (map f l) (map f l').
  intros.
  induction l; auto.
  simpl.
  rewrite IHl.
  auto.
  Defined.
Lemma map_compose : forall A B C (f:A->B)(g:B->C)(l:list A),
  (map (g ○ f) l) = (map g (map f l)).
  intros.
  induction l.
  simpl; auto.
  simpl.
  rewrite IHl.
  auto.
  Defined.
Lemma list_cannot_be_longer_than_itself : forall `(a:A)(b:list A), b = (a::b) -> False.
  intros.
  induction b.
  inversion H.
  inversion H. apply IHb in H2.
  auto.
  Defined.
Lemma list_cannot_be_longer_than_itself' : forall A (b:list A) (a c:A), b = (a::c::b) -> False.
  induction b.
  intros; inversion H.
  intros.
  inversion H.
  apply IHb in H2.
  auto.
  Defined.

Lemma mapOptionTree_on_nil : forall `(f:A->B) h, [] = mapOptionTree f h -> h=[].
  intros.
  destruct h.
  destruct o. inversion H.
  auto.
  inversion H.
  Defined.

Lemma mapOptionTree_comp a b c (f:a->b) (g:b->c) q : (mapOptionTree g (mapOptionTree f q)) = mapOptionTree (g ○ f) q.
  induction q.
    destruct a0; simpl.
    reflexivity.
    reflexivity.
    simpl.
    rewrite IHq1.
    rewrite IHq2.
    reflexivity.
  Qed.

Lemma leaves_unleaves {T}(t:list T) : leaves (unleaves t) = t.
  induction t; auto.
  simpl.
  rewrite IHt; auto.
  Qed.

Lemma mapleaves' {T:Type}(t:list T){Q}{f:T->Q} : unleaves (map f t) = mapOptionTree f (unleaves t).
  induction t; simpl in *; auto.
  rewrite IHt; auto.
  Qed.

(* handy facts: map preserves the length of a list *)
Lemma map_on_nil : forall A B (s1:list A) (f:A->B), nil = map f s1 -> s1=nil.
  intros.
  induction s1.
  auto.
  assert False.
  simpl in H.
  inversion H.
  inversion H0.
  Defined.
Lemma map_on_singleton : forall A B (f:A->B) x (s1:list A), (cons x nil) = map f s1 -> { y : A & s1=(cons y nil) & (f y)=x }.
  induction s1.
  intros.
  simpl in H; assert False. inversion H. inversion H0.
  clear IHs1.
  intros.
  exists a.
  simpl in H.
  assert (s1=nil).
    inversion H. apply map_on_nil in H2. auto.
  subst.
  auto.
  assert (s1=nil).
    inversion H. apply map_on_nil in H2. auto.
  subst.
  simpl in H.
  inversion H. auto.
  Defined.

Lemma map_on_doubleton : forall A B (f:A->B) x y (s1:list A), ((x::y::nil) = map f s1) ->
  { z : A*A & s1=((fst z)::(snd z)::nil) & (f (fst z))=x /\ (f (snd z))=y }.
  intros.
  destruct s1.
  inversion H.
  destruct s1.
  inversion H.
  destruct s1.
  inversion H.
  exists (a,a0); auto.
  simpl in H.
  inversion H.
  Defined.

Lemma mapTree_compose : forall A B C (f:A->B)(g:B->C)(l:Tree A),
  (mapTree (g ○ f) l) = (mapTree g (mapTree f l)).
  induction l.
    reflexivity.
    simpl.
    rewrite IHl1.
    rewrite IHl2.
    reflexivity.
    Defined.

Lemma lmap_compose : forall A B C (f:A->B)(g:B->C)(l:list A),
  (map (g ○ f) l) = (map g (map f l)).
  intros.
  induction l.
  simpl; auto.
  simpl.
  rewrite IHl.
  auto.
  Defined.

(* sends a::b::c::nil to [[[[],,c],,b],,a] *)
Fixpoint unleaves' {A:Type}(l:list A) : Tree (option A) :=
  match l with
    | nil    => []
    | (a::b) => (unleaves' b),,[a]
  end.

(* sends a::b::c::nil to [[[[],,c],,b],,a] *)
Fixpoint unleaves'' {A:Type}(l:list ??A) : Tree ??A :=
  match l with
    | nil    => []
    | (a::b) => (unleaves'' b),,(T_Leaf a)
  end.

Lemma mapleaves {T:Type}(t:Tree ??T){Q}{f:T->Q} : leaves (mapOptionTree f t) = map f (leaves t).
  induction t.
  destruct a; auto.
  simpl.
  rewrite IHt1.
  rewrite IHt2.
  rewrite map_app.
  auto.
  Qed.

Fixpoint filter {T:Type}(l:list ??T) : list T :=
  match l with
    | nil => nil
    | (None::b) => filter b
    | ((Some x)::b) => x::(filter b)
  end.

Inductive distinct {T:Type} : list T -> Prop :=
| distinct_nil  : distinct nil
| distinct_cons : forall a ax, (@In _ a ax -> False) -> distinct ax -> distinct (a::ax).

Inductive distinctT {T:Type} : Tree ??T -> Prop :=
| distinctT_nil  : distinctT []
| distinctT_leaf : forall t, distinctT [t]
| distinctT_cons : forall t1 t2, (forall v, InT v t1 -> InT v t2 -> False) -> distinctT (t1,,t2).

Lemma in_decidable {VV:Type}{eqdVV:EqDecidable VV} : forall (v:VV)(lv:list VV), sumbool (In v lv) (not (In v lv)).
  intros.
  induction lv.
  right.
  unfold not.
  intros.
  inversion H.
  destruct IHlv.
  left.
  simpl.
  auto.
  set (eqd_dec v a) as dec.
  destruct dec.
  subst.
  left; simpl; auto.
  right.
  unfold not; intros.
  destruct H.
  subst.
  apply n0; auto.
  apply n.
  apply H.
  Defined.

Lemma distinct_decidable {VV:Type}{eqdVV:EqDecidable VV} : forall (lv:list VV), sumbool (distinct lv) (not (distinct lv)).
  intros.
  induction lv.
  left; apply distinct_nil.
  destruct IHlv.
  set (in_decidable a lv) as dec.
  destruct dec.
  right; unfold not; intros.
  inversion H.
  subst.
  apply H2; auto.
  left.
  apply distinct_cons; auto.
  right.
  unfold not; intros.
  inversion H.
  subst.
  apply n; auto.
  Defined.

Lemma map_preserves_length {A}{B}(f:A->B)(l:list A) : (length l) = (length (map f l)).
  induction l; auto.
  simpl.
  omega.
  Qed.

(* decidable quality on a list of elements which have decidable equality *)
Definition list_eq_dec : forall {T:Type}(l1 l2:list T)(dec:forall t1 t2:T, sumbool (eq t1 t2) (not (eq t1 t2))),
  sumbool (eq l1 l2) (not (eq l1 l2)).
  intro T.
  intro l1.
  induction l1; intros.
    destruct l2.
    left; reflexivity.
    right; intro H; inversion H.
  destruct l2 as [| b l2].
    right; intro H; inversion H.
  set (IHl1 l2 dec) as eqx.
    destruct eqx.
    subst.
    set (dec a b) as eqy.
    destruct eqy.
      subst.
      left; reflexivity.
      right. intro. inversion H. subst. apply n. auto.
    right.
      intro.
      inversion H.
      apply n.
      auto.
      Defined.

Instance EqDecidableList {T:Type}(eqd:EqDecidable T) : EqDecidable (list T).
  apply Build_EqDecidable.
  intros.
  apply list_eq_dec.
  apply eqd_dec.
  Defined.

Fixpoint listToString {T:Type}{tst:ToString T}(l:list T) : string :=
  match l with
    | nil  => "nil"
    | a::b => (toString a) +++ "::" +++ listToString b
  end.

Instance ListToString {T:Type}{tst:ToString T} : ToString (list T) :=
  { toString := @listToString _ _ }.

(*******************************************************************************)
(* Tree Flags                                                                  *)

(* TreeFlags is effectively a tree of booleans whose shape matches that of another tree *)
Inductive TreeFlags {T:Type} : Tree T -> Type :=
| tf_leaf_true  : forall x, TreeFlags (T_Leaf x)
| tf_leaf_false : forall x, TreeFlags (T_Leaf x)
| tf_branch     : forall b1 b2, TreeFlags b1 -> TreeFlags b2 -> TreeFlags (b1,,b2).

(* If flags are calculated using a local condition, this will build the flags *)
Fixpoint mkFlags {T}(f:T -> bool)(t:Tree T) : TreeFlags t :=
  match t as T return TreeFlags T with
    | T_Leaf x => if f x then tf_leaf_true x else tf_leaf_false x
    | T_Branch b1 b2 => tf_branch _ _ (mkFlags f b1) (mkFlags f b2)
  end.

(* takeT and dropT are not exact inverses! *)

(* drop replaces each leaf where the flag is set with a [] *)
Fixpoint dropT {T}{Σ:Tree ??T}(tf:TreeFlags Σ) : Tree ??T :=
  match tf with
    | tf_leaf_true  x         => []
    | tf_leaf_false x         => Σ
    | tf_branch b1 b2 tb1 tb2 => (dropT tb1),,(dropT tb2)
  end.

(* takeT returns only those leaves for which the flag is set; all others are omitted entirely from the tree *)
Fixpoint takeT {T}{Σ:Tree T}(tf:TreeFlags Σ) : ??(Tree T) :=
  match tf with
    | tf_leaf_true  x         => Some Σ
    | tf_leaf_false x         => None
    | tf_branch b1 b2 tb1 tb2 =>
      match takeT tb1 with
        | None     => takeT tb2
        | Some b1' => match takeT tb2 with
                        | None     => Some b1'
                        | Some b2' => Some (b1',,b2')
                      end
      end
  end.

Definition takeT' {T}{Σ:Tree ??T}(tf:TreeFlags Σ) : Tree ??T :=
  match takeT tf with
    | None   => []
    | Some x => x
  end.

(* lift a function T->bool to a function (option T)->bool by yielding (None |-> b) *)
Definition liftBoolFunc {T}(b:bool)(f:T -> bool) : ??T -> bool :=
  fun t =>
    match t with
      | None   => b
      | Some x => f x
    end.

(* decidable quality on a tree of elements which have decidable equality *)
Definition tree_eq_dec : forall {T:Type}(l1 l2:Tree T)(dec:forall t1 t2:T, sumbool (eq t1 t2) (not (eq t1 t2))),
  sumbool (eq l1 l2) (not (eq l1 l2)).
  intro T.
  intro l1.
  induction l1; intros.
    destruct l2.
    destruct (dec a t).
    subst.
    left; auto.
    right; unfold not; intro; apply n; inversion H; auto.
  right.
    unfold not; intro.
    inversion H.

  destruct l2.
    right; unfold not; intro; inversion H.
    destruct (IHl1_1 l2_1 dec);
    destruct (IHl1_2 l2_2 dec); subst.
    left; auto.
    right.
      unfold not; intro.
      inversion H; subst.
      apply n; auto.
    right.
      unfold not; intro.
      inversion H; subst.
      apply n; auto.
    right.
      unfold not; intro.
      inversion H; subst.
      apply n; auto.
      Defined.

Instance EqDecidableTree {T:Type}(eqd:EqDecidable T) : EqDecidable (Tree T).
  apply Build_EqDecidable.
  intros.
  apply tree_eq_dec.
  apply eqd_dec.
  Defined.

(*******************************************************************************)
(* Length-Indexed Lists                                                        *)

Inductive vec (A:Type) : nat -> Type :=
| vec_nil  : vec A 0
| vec_cons : forall n, A -> vec A n -> vec A (S n).

Fixpoint vec2list {n:nat}{t:Type}(v:vec t n) : list t :=
  match v with
    | vec_nil => nil
    | vec_cons n a va => a::(vec2list va)
  end.

Require Import Omega.
Definition vec_get : forall {T:Type}{l:nat}(v:vec T l)(n:nat)(pf:lt n l), T.
  intro T.
  intro len.
  intro v.
  induction v; intros.
    assert False.
    inversion pf.
    inversion H.
  rename n into len.
    destruct n0 as [|n].
    exact a.
    apply (IHv n).
    omega.
    Defined.

Definition vec_zip {n:nat}{A B:Type}(va:vec A n)(vb:vec B n) : vec (A*B) n.
  induction n.
  apply vec_nil.
  inversion va; subst.
  inversion vb; subst.
  apply vec_cons; auto.
  Defined.

Definition vec_map {n:nat}{A B:Type}(f:A->B)(v:vec A n) : vec B n.
  induction n.
  apply vec_nil.
  inversion v; subst.
  apply vec_cons; auto.
  Defined.

Fixpoint vec_In {A:Type} {n:nat} (a:A) (l:vec A n) : Prop :=
  match l with
    | vec_nil         => False
    | vec_cons _ n m  => (n = a) \/ vec_In a m
  end.
Implicit Arguments vec_nil  [ A   ].
Implicit Arguments vec_cons [ A n ].

Definition append_vec {n:nat}{T:Type}(v:vec T n)(t:T) : vec T (S n).
  induction n.
  apply (vec_cons t vec_nil).
  apply vec_cons; auto.
  Defined.

Definition list2vec {T:Type}(l:list T) : vec T (length l).
  induction l.
  apply vec_nil.
  apply vec_cons; auto.
  Defined.

Definition vec_head {n:nat}{T}(v:vec T (S n)) : T.
  inversion v;  auto.
  Defined.
Definition vec_tail {n:nat}{T}(v:vec T (S n)) : vec T n.
  inversion v;  auto.
  Defined.

Lemma vec_chop {T}{l1 l2:list T}{Q}(v:vec Q (length (app l1 l2))) : vec Q (length l1).
  induction l1.
  apply vec_nil.
  apply vec_cons.
  simpl in *.
  inversion v; subst; auto.
  apply IHl1.
  inversion v; subst; auto.
  Defined.

Lemma vec_chop' {T}{l1 l2:list T}{Q}(v:vec Q (length (app l1 l2))) : vec Q (length l2).
  induction l1.
  apply v.
  simpl in *.
  apply IHl1; clear IHl1.
  inversion v; subst; auto.
  Defined.

Lemma vec2list_len {T}{n}(v:vec T n) : length (vec2list v) = n.
  induction v; auto.
  simpl.
  omega.
  Qed.

Lemma vec2list_map_list2vec {A B}{n}(f:A->B)(v:vec A n) : map f (vec2list v) = vec2list (vec_map f v).
  induction v; auto.
  simpl. rewrite IHv.
  reflexivity.
  Qed.

Lemma vec2list_list2vec {A}(v:list A) : vec2list (list2vec v) = v.
  induction v; auto.
  set (vec2list (list2vec (a :: v))) as q.
  rewrite <- IHv.
  unfold q.
  clear q.
  simpl.
  reflexivity.
  Qed.

Notation "a ::: b" := (@vec_cons _ _ a b) (at level 20).

(*******************************************************************************)
(* Shaped Trees                                                                *)

(* a ShapedTree is a tree indexed by the shape (but not the leaf values) of another tree; isomorphic to (ITree (fun _ => Q)) *)
Inductive ShapedTree {T:Type}(Q:Type) : Tree ??T -> Type :=
| st_nil    : @ShapedTree T Q []
| st_leaf   : forall {t}, Q -> @ShapedTree T Q [t]
| st_branch : forall {t1}{t2}, @ShapedTree T Q t1 -> @ShapedTree T Q t2 -> @ShapedTree T Q (t1,,t2).

Fixpoint unshape {T:Type}{Q:Type}{idx:Tree ??T}(st:@ShapedTree T Q idx) : Tree ??Q :=
match st with
| st_nil => []
| st_leaf _ q => [q]
| st_branch _ _ b1 b2 => (unshape b1),,(unshape b2)
end.

Definition mapShapedTree {T}{idx:Tree ??T}{V}{Q}(f:V->Q)(st:ShapedTree V idx) : ShapedTree Q idx.
  induction st.
  apply st_nil.
  apply st_leaf. apply f. apply q.
  apply st_branch; auto.
  Defined.

Definition zip_shapedTrees {T:Type}{Q1 Q2:Type}{idx:Tree ??T}
   (st1:ShapedTree Q1 idx)(st2:ShapedTree Q2 idx) : ShapedTree (Q1*Q2) idx.
  induction idx.
    destruct a.
    apply st_leaf; auto.
    inversion st1.
    inversion st2.
    auto.
    apply st_nil.
    apply st_branch; auto.
    inversion st1; subst; apply IHidx1; auto.
    inversion st2; subst; auto.
    inversion st2; subst; apply IHidx2; auto.
    inversion st1; subst; auto.
  Defined.

Definition build_shapedTree {T:Type}(idx:Tree ??T){Q:Type}(f:T->Q) : ShapedTree Q idx.
  induction idx.
  destruct a.
  apply st_leaf; auto.
  apply st_nil.
  apply st_branch; auto.
  Defined.

Lemma unshape_map : forall {Q}{b}(f:Q->b){T}{idx:Tree ??T}(t:ShapedTree Q idx),
   mapOptionTree f (unshape t) = unshape (mapShapedTree f t).
  intros.
  induction t; auto.
  simpl.
  rewrite IHt1.
  rewrite IHt2.
  reflexivity.
  Qed.

(*******************************************************************************)
(* Type-Indexed Lists                                                          *)

(* an indexed list *)
Inductive IList (I:Type)(F:I->Type) : list I -> Type :=
| INil      :                                       IList I F nil
| ICons     :   forall i is, F i -> IList I F is -> IList I F (i::is).
Implicit Arguments INil [ I F ].
Implicit Arguments ICons [ I F ].

Notation "a :::: b" := (@ICons _ _ _ _ a b) (at level 20).

Definition ilist_head {T}{F}{x}{y} : IList T F (x::y) -> F x.
  intro il.
  inversion il.
  subst.
  apply X.
  Defined.

Definition ilist_tail {T}{F}{x}{y} : IList T F (x::y) -> IList T F y.
  intro il.
  inversion il.
  subst.
  apply X0.
  Defined.

Definition ilmap {I}{F}{G}{il:list I}(f:forall i:I, F i -> G i) : IList I F il -> IList I G il.
  induction il; intros; auto.
  apply INil.
  inversion X; subst.
  apply ICons; auto.
  Defined.

Lemma ilist_chop {T}{F}{l1 l2:list T}(v:IList T F (app l1 l2)) : IList T F l1.
  induction l1; auto.
  apply INil.
  apply ICons.
  inversion v; auto.
  apply IHl1.
  inversion v; auto.
  Defined.

Lemma ilist_chop' {T}{F}{l1 l2:list T}(v:IList T F (app l1 l2)) : IList T F l2.
  induction l1; auto.
  apply IHl1.
  inversion v; subst; auto.
  Defined.

Lemma ilist_app {T}{F}{l1:list T}(v1:IList T F l1) : forall {l2:list T}(v2:IList T F l2), IList T F (app l1 l2).
  induction l1; auto.
  intros.
  inversion v1.
  subst.
  simpl.
  apply ICons.
  apply X.
  apply IHl1; auto.
  Defined.

Definition ilist_ins {T}{F}{l:list T} z (fz:F z) : forall n (il:IList T F l), IList T F (list_ins n z l).
  induction l; simpl.
  intros.
  destruct n; simpl.
  apply ICons; [ apply fz | apply INil ].
  apply ICons; [ apply fz | apply INil ].
  intros.
  destruct n; simpl.
  apply ICons; auto.
  inversion il; subst.
  apply ICons; auto.
  Defined.

Fixpoint ilist_to_list {T}{Z}{l:list T}(il:IList T (fun _ => Z) l) : list Z :=
  match il with
  | INil   => nil
  | a::::b => a::(ilist_to_list b)
  end.

(* a tree indexed by a (Tree (option X)) *)
Inductive ITree (I:Type)(F:I->Type) : Tree ??I -> Type :=
| INone      :                                ITree I F []
| ILeaf      :  forall       i:     I, F i -> ITree I F [i]
| IBranch    :  forall it1 it2:Tree ??I, ITree I F it1 -> ITree I F it2 -> ITree I F (it1,,it2).
Implicit Arguments INil    [ I F ].
Implicit Arguments ILeaf   [ I F ].
Implicit Arguments IBranch [ I F ].

Definition itmap {I}{F}{G}{il:Tree ??I}(f:forall i:I, F i -> G i) : ITree I F il -> ITree I G il.
  induction il; intros; auto.
  destruct a.
  apply ILeaf.
  apply f.
  inversion X; auto.
  apply INone.
  apply IBranch; inversion X; auto.
  Defined.

Fixpoint itree_to_tree {T}{Z}{l:Tree ??T}(il:ITree T (fun _ => Z) l) : Tree ??Z :=
  match il with
  | INone     => []
  | ILeaf _ a => [a]
  | IBranch _ _ b1 b2 => (itree_to_tree b1),,(itree_to_tree b2)
  end.

(*******************************************************************************)
(* Extensional equality on functions                                           *)

Definition extensionality := fun (t1 t2:Type) => (fun (f:t1->t2) g => forall x:t1, (f x)=(g x)).
Hint Transparent extensionality.
Instance extensionality_Equivalence : forall t1 t2, Equivalence (extensionality t1 t2).
  intros; apply Build_Equivalence;
    intros; compute; intros; auto.
    rewrite H; rewrite H0; auto.
  Defined.
  Add Parametric Morphism (A B C:Type) : (fun f g => g ○ f)
  with signature (extensionality A B ==> extensionality B C ==> extensionality A C) as parametric_morphism_extensionality.
  unfold extensionality; intros; rewrite (H x1); rewrite (H0 (y x1)); auto.
  Defined.
Lemma extensionality_composes : forall t1 t2 t3 (f f':t1->t2) (g g':t2->t3),
  (extensionality _ _ f f') ->
  (extensionality _ _ g g') ->
  (extensionality _ _ (g ○ f) (g' ○ f')).
  intros.
  unfold extensionality.
  unfold extensionality in H.
  unfold extensionality in H0.
  intros.
  rewrite H.
  rewrite H0.
  auto.
  Qed.

Definition map2 {A}{B}(f:A->B)(t:A*A) : (B*B) := ((f (fst t)), (f (snd t))).

(* boolean "not" *)
Definition bnot (b:bool) : bool := if b then false else true.
Definition band (b1 b2:bool) : bool := if b1 then b2 else false.
Definition bor  (b1 b2:bool) : bool := if b1 then true else b2.

(* string stuff *)
Variable eol : string.
Extract Constant eol  => "'\n':[]".

Class Monad {T:Type->Type} :=
{ returnM : forall {a},     a -> T a
; bindM   : forall {a}{b},  T a -> (a -> T b) -> T b
}.
Implicit Arguments Monad [ ].
Notation "a >>>= b" := (@bindM _ _ _ _ a b) (at level 50, left associativity).

(* the Error monad *)
Inductive OrError (T:Type) :=
| Error : forall error_message:string, OrError T
| OK    : T      -> OrError T.
Notation "??? T" := (OrError T) (at level 10).
Implicit Arguments Error [T].
Implicit Arguments OK [T].

Definition orErrorBind {T:Type} (oe:OrError T) {Q:Type} (f:T -> OrError Q) :=
  match oe with
    | Error s => Error s
    | OK    t => f t
  end.
Notation "a >>= b" := (@orErrorBind _ a _ b) (at level 20).

Definition orErrorBindWithMessage {T:Type} (oe:OrError T) {Q:Type} (f:T -> OrError Q) err_msg :=
  match oe with
    | Error s => Error (err_msg +++ eol +++ "  " +++ s)
    | OK    t => f t
  end.

Notation "a >>=[ S ] b" := (@orErrorBindWithMessage _ a _ b S) (at level 20).

Definition addErrorMessage s {T} (x:OrError T) :=
  x >>=[ eol +++ eol +++ s ] (fun y => OK y).

Inductive Indexed {T:Type}(f:T -> Type) : ???T -> Type :=
| Indexed_Error : forall error_message:string, Indexed f (Error error_message)
| Indexed_OK    : forall t, f t -> Indexed f (OK t)
.

Require Import Coq.Arith.EqNat.
Instance EqDecidableNat : EqDecidable nat.
  apply Build_EqDecidable.
  intros.
  apply eq_nat_dec.
  Defined.

(* for a type with decidable equality, we can maintain lists of distinct elements *)
Section DistinctList.
  Context `{V:EqDecidable}.

  Fixpoint addToDistinctList (cv:V)(cvl:list V) :=
  match cvl with
  | nil       => cv::nil
  | cv'::cvl' => if eqd_dec cv cv' then cvl' else cv'::(addToDistinctList cv cvl')
  end.

  Fixpoint removeFromDistinctList (cv:V)(cvl:list V) :=
  match cvl with
  | nil => nil
  | cv'::cvl' => if eqd_dec cv cv' then removeFromDistinctList cv cvl' else cv'::(removeFromDistinctList cv cvl')
  end.

  Fixpoint removeFromDistinctList' (cvrem:list V)(cvl:list V) :=
  match cvrem with
  | nil         => cvl
  | rem::cvrem' => removeFromDistinctList rem (removeFromDistinctList' cvrem' cvl)
  end.

  Fixpoint mergeDistinctLists (cvl1:list V)(cvl2:list V) :=
  match cvl1 with
  | nil       => cvl2
  | cv'::cvl' => mergeDistinctLists cvl' (addToDistinctList cv' cvl2)
  end.
End DistinctList.

Lemma list2vecOrFail {T}(l:list T)(n:nat)(error_message:nat->nat->string) : ???(vec T n).
  set (list2vec l) as v.
  destruct (eqd_dec (length l) n).
    rewrite e in v; apply OK; apply v.
    apply (Error (error_message (length l) n)).
    Defined.

(* this makes a type function application, ensuring not to oversaturate it (though if it was undersaturated we can't fix that) *)
Fixpoint split_list {T}(l:list T)(n:nat) : ???(list T * list T) :=
  match n with
    | O    => OK (nil , l)
    | S n' => match l with
                | nil  => Error "take_list failed"
                | h::t => split_list t n' >>= fun t' => let (t1,t2) := t' in OK ((h::t1),t2)
              end
    end.

(* Uniques *)
Variable UniqSupply      : Type.                   Extract Inlined Constant UniqSupply     => "UniqSupply.UniqSupply".
Variable Unique          : Type.                   Extract Inlined Constant Unique         => "Unique.Unique".
Variable uniqFromSupply  : UniqSupply -> Unique.   Extract Inlined Constant uniqFromSupply => "UniqSupply.uniqFromSupply".
Variable splitUniqSupply : UniqSupply -> UniqSupply * UniqSupply.
    Extract Inlined Constant splitUniqSupply => "UniqSupply.splitUniqSupply".
Variable unique_eq       : forall u1 u2:Unique, sumbool (u1=u2) (u1≠u2).
    Extract Inlined Constant unique_eq => "(==)".
Variable unique_toString : Unique -> string.
    Extract Inlined Constant unique_toString => "show".
Instance EqDecidableUnique : EqDecidable Unique :=
  { eqd_dec := unique_eq }.
Instance EqDecidableToString : ToString Unique :=
  { toString := unique_toString }.

Inductive UniqM {T:Type} : Type :=
 | uniqM    : (UniqSupply -> ???(UniqSupply * T)) -> UniqM.
 Implicit Arguments UniqM [ ].

Instance UniqMonad : Monad UniqM :=
{ returnM := fun T (x:T) => uniqM (fun u => OK (u,x))
; bindM   := fun a b (x:UniqM a) (f:a->UniqM b) =>
  uniqM (fun u =>
    match x with
      | uniqM fa =>
        match fa u with
          | Error s   => Error s
          | OK (u',va) => match f va with
                           | uniqM fb => fb u'
                         end
        end
    end)
}.

Definition getU : UniqM Unique :=
  uniqM (fun us => let (us1,us2) := splitUniqSupply us in OK (us1,(uniqFromSupply us2))).

Notation "'bind' x = e ; f" := (@bindM _ _ _ _ e (fun x => f)) (x ident, at level 60, right associativity).
Notation "'return' x" := (returnM x) (at level 100).
Notation "'failM'  x" := (uniqM (fun _ => Error x)) (at level 100).

Record FreshMonad {T:Type} :=
{ FMT       :  Type -> Type
; FMT_Monad :> Monad FMT
; FMT_fresh :  forall tl:list T, FMT { t:T & @In _ t tl -> False }
}.
Implicit Arguments FreshMonad [ ].
Coercion FMT       : FreshMonad >-> Funclass.

Variable Prelude_error : forall {A}, string -> A.   Extract Inlined Constant Prelude_error => "Prelude.error".

Ltac eqd_dec_refl X :=
  destruct (eqd_dec X X) as [eqd_dec1 | eqd_dec2];
    [ clear eqd_dec1 | set (eqd_dec2 (refl_equal _)) as eqd_dec2'; inversion eqd_dec2' ].

Lemma unleaves_injective : forall T (t1 t2:list T), unleaves t1 = unleaves t2 -> t1 = t2.
  intros T.
  induction t1; intros.
  destruct t2.
  auto.
  inversion H.
  destruct t2.
  inversion H.
  simpl in H.
  inversion H.
  set (IHt1 _ H2) as q.
  rewrite q.
  reflexivity.
  Qed.

(* adapted from Adam Chlipala's posting to the coq-club list (thanks!) *)
Definition openVec A n (v: vec A (S n)) : exists a, exists v0, v = a:::v0 :=
  match v in vec _ N return match N return vec A N -> Prop with
                              | O => fun _ => True
                              | S n => fun v => exists a, exists v0, v = a:::v0
                            end v with
    | vec_nil => I
    | a:::v0 => ex_intro _ a (ex_intro _ v0 (refl_equal _))
  end.

Definition nilVec A (v: vec A O) : v = vec_nil :=
  match v in vec _ N return match N return vec A N -> Prop with
                              | O   => fun v => v = vec_nil
                              | S n => fun v => True
                            end v with
    | vec_nil => refl_equal _
    | a:::v0  => I
  end.

Lemma fst_zip : forall T Q n (v1:vec T n)(v2:vec Q n), vec_map (@fst _ _) (vec_zip v1 v2) = v1.
  intros.
  induction n.
  set (nilVec _ v1) as v1'.
  set (nilVec _ v2) as v2'.
  subst.
  simpl.
  reflexivity.
  set (openVec _ _ v1) as v1'.
  set (openVec _ _ v2) as v2'.
  destruct v1'.
  destruct v2'.
  destruct H.
  destruct H0.
  subst.
  simpl.
  rewrite IHn.
  reflexivity.
  Qed.

Lemma snd_zip : forall T Q n (v1:vec T n)(v2:vec Q n), vec_map (@snd _ _) (vec_zip v1 v2) = v2.
  intros.
  induction n.
  set (nilVec _ v1) as v1'.
  set (nilVec _ v2) as v2'.
  subst.
  simpl.
  reflexivity.
  set (openVec _ _ v1) as v1'.
  set (openVec _ _ v2) as v2'.
  destruct v1'.
  destruct v2'.
  destruct H.
  destruct H0.
  subst.
  simpl.
  rewrite IHn.
  reflexivity.
  Qed.

Fixpoint mapM {M}{mon:Monad M}{T}(ml:list (M T)) : M (list T) :=
  match ml with
    | nil  => return nil
    | a::b => bind a' = a ; bind b' = mapM b ; return a'::b'
  end.

Fixpoint list_to_ilist {T}{F}(f:forall t:T, F t) (l:list T) : IList T F l :=
  match l as L return IList T F L with
  | nil  => INil
  | a::b => ICons a b (f a) (list_to_ilist f b)
  end.

Fixpoint treeM {T}{M}{MT:Monad M}(t:Tree ??(M T)) : M (Tree ??T) :=
  match t with
    | T_Leaf None     => return []
    | T_Leaf (Some x) => bind x' = x ; return [x']
    | T_Branch b1 b2  => bind b1' = treeM b1 ; bind b2' = treeM b2 ; return (b1',,b2')
  end.

(* escapifies any characters which might cause trouble for LaTeX *)
Variable sanitizeForLatex    : string      -> string.
   Extract Inlined Constant sanitizeForLatex      => "sanitizeForLatex".
Inductive Latex     : Type := rawLatex     : string -> Latex.
Inductive LatexMath : Type := rawLatexMath : string -> LatexMath.

Class ToLatex (T:Type) := { toLatex : T -> Latex }.
Instance ConcatenableLatex : Concatenable Latex :=
  { concatenate := fun l1 l2 => match l1 with rawLatex l1' => match l2 with rawLatex l2' => rawLatex (l1'+++l2') end end }.
Instance LatexToString : ToString Latex := { toString := fun x => match x with rawLatex s => s end }.

Class ToLatexMath (T:Type) := { toLatexMath : T -> LatexMath }.
Instance ConcatenableLatexMath : Concatenable LatexMath :=
  { concatenate := fun l1 l2 =>
    match l1 with rawLatexMath l1' =>
      match l2 with rawLatexMath l2' => rawLatexMath (l1'+++l2')
      end end }.
Instance LatexMathToString : ToString LatexMath := { toString := fun x => match x with rawLatexMath s => s end }.

Instance ToLatexLatexMath : ToLatex LatexMath := { toLatex     := fun l => rawLatex     ("$"+++toString l+++"$") }.
Instance ToLatexMathLatex : ToLatexMath Latex := { toLatexMath := fun l => rawLatexMath ("\text{"+++toString l+++"}") }.

Instance StringToLatex     : ToLatex string := { toLatex := fun x => rawLatex (sanitizeForLatex x) }.
Instance StringToLatexMath : ToLatexMath  string := { toLatexMath := fun x => toLatexMath (toLatex x) }.
Instance LatexToLatex          : ToLatex     Latex      := { toLatex := fun x => x }.
Instance LatexMathToLatexMath  : ToLatexMath LatexMath  := { toLatexMath := fun x => x }.

Fixpoint treeToLatexMath {V}{ToLatexV:ToLatexMath V}(t:Tree ??V) : LatexMath :=
  match t with
    | T_Leaf None     => rawLatexMath "\langle\rangle"
    | T_Leaf (Some x) => (rawLatexMath "\langle")+++toLatexMath x+++(rawLatexMath "\rangle")
    | T_Branch b1 b2  => (rawLatexMath "\langle")+++treeToLatexMath b1+++(rawLatexMath " , ")
      +++treeToLatexMath b2+++(rawLatexMath "\rangle")
  end.