(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export Recdef.
Require Export Eqdep_dec.
Require Export opid.
Require Export variables.
(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing $  $\times$ #×# *)
(** printing &  $\times$ #×# *)

(**
  We can now define the terms of the Nuprl language as an inductive type.
  There are several considerations in choosing the right definition.
  The definition needs to be general enough so that adding
  new constructs to the term language does
  not break proofs about general properties of general operations on terms.
  For example, the substitution operation and the alpha equality
  relation only care about the getting access to the variables and
  do not care about the other operators(constucts) of the language.

  Our term definition(similar to %\cite{Howe:1989}%)
  exposes the variables, especially the concept
  of bound variables in a uniform way so that these
  and many other operations and proofs work unchanged
  when adding/removing constructs from the language.
  These robust proofs run into several thousands of lines and include the
  many properties about substitution and alpha equality that
  we need for formalizing all of Nurpl.

  Many alternative approaches for variable bindings
  have been discussed in the
  literature %~\cite{Pfenning:1988,Capretta:2007,Chlipala:cpdt}%.
  Our choice avoided the overhead of translating
  the paper definitions about Nuprl to some other style of variable
  bindings.

  We will first intuitively explain parts of the definition before showing it.
  Firstly, we have a constructor ([vterm]) that builds a term([NTerm]) from a variable([NVar])).
  Variable bindings are made explicit by the concept of a bound term ([BTerm]).
  [bterm] is the only constructor of [BTerm]. It takes a list of variables (say [lv])
  and a term (say [nt]) and constructs a bound term. Intuitively, a variable that is
  free in [nt] gets bound to its first occurence in [lv], if any.
  For example, the bound term [bterm [nvarx] (vterm nvarx)] will
  be used soon in constructing an identity function($\lambda x.x$).

  The rest of our term definition is
  parametrized by a collection of
  operators([Opid]). Operators take bound terms as input and construct another
  term.  For example, there is an operator that takes [[bterm [nvarx] (vterm nvarx)]]
  and constructs the lambda term $\lambda x.x$.
  With that in mind, here is the inductive type([NTerm]) that represents the terms of Nurpl:

 *)
Inductive NTerm {p} : tuniv :=
| vterm: NVar -> NTerm
| sterm : (nat -> NTerm) -> NTerm (* closed free choice sequence *)
| oterm: @Opid p -> list BTerm -> NTerm
with BTerm {p} : tuniv :=
| bterm: (list NVar) -> NTerm -> BTerm.

(*
  The [Opid] type contains one element corresponding to every operator
  of the language, e.g. lambda abstraction, funtion application,
  dependent function type constructor. As a more concrete example,
  the [Can NLambda] is the element of [Opid] that represents lambda
  abstractions.
  To construct a bound term([BTerm]), we need a list of variables and
  an [NTerm] (see the [bterm] constructor). As a concrete example,
   $ \lambda x.x$ is represented in this type
  as [(oterm  (Can NLambda) (bterm [nvarx] (vterm nvarx)))].
*)

(**
  It is a mutually inductive definition that simultaneously defines terms
  and bound terms. As mentioned before, the [vterm] constructor
  takes an [NVar] and constructs an [NTerm]. The other constructor([oterm])
  takes an [Opid] and a list of bound terms ([BTerm]s) and constructs an [NTerm].
  Note that not all members of [NTerm] are meaningful(well-formed).
  For example, the [Opid] corresponding to lambda abstractions must be
  provided with exactly one bound term as argument. Moreover, that
  bound term must have exactly one bound variable. So, we have a function
  [OpBindings] in type [Opid -> list nat] that specifies both the
  number of arguments and the number of bound variables in each argument([BTerm]).
  We will use it soon to define the subcollection of well-formed terms.
*)

(* begin hide *)
Inductive ord :=
| OZ : ord
| OS : ord -> ord
| OL : (nat -> ord) -> ord.

Notation O1 := (OS OZ).

Fixpoint oadd (o1 o2 : ord) :=
  match o1 with
    | OZ => o2
    | OS o => OS (oadd o o2)
    | OL f => OL (fun x => oadd (f x) o2)
  end.

Fixpoint oaddl (ts : list ord) : ord :=
  match ts with
  | nil => OZ
  | n :: ns => oadd n (oaddl ns)
  end.

Fixpoint osize {o} (t : @NTerm o) : ord :=
  match t with
    | vterm _ => O1
    | sterm f => OS (OL (fun x => osize (f x)))
    | oterm op bterms => OS (oaddl (map osize_bterm bterms))
  end
with osize_bterm {o} (bt : BTerm) : ord :=
  match bt with
    | bterm lv nt => osize nt
  end.

Fixpoint opred_type (o : ord) : Set :=
  match o with
    | OZ    => False
    | OS o' => option (opred_type o')
    | OL f  => { n : nat & opred_type (f n) }
  end.

Fixpoint opred (o : ord) : opred_type o -> ord :=
  match o return opred_type o -> ord with
    | OZ    => fun i => match i with end
    | OS o' => fun i => match i with
                          | None => o'
                          | Some t  => opred o' t
                        end
    | OL f  => fun i => match i with
                          | existT _ n t => opred (f n) t
                        end
  end.

Inductive ord_le : ord -> ord -> Type :=
| le_OZ : forall o, ord_le OZ o
| le_OS : forall o1 o2 i, ord_le o1 (opred o2 i) -> ord_le (OS o1) o2
| le_OL : forall f o, (forall n, ord_le (f n) o) -> ord_le (OL f) o.
Hint Constructors ord_le.

Definition ord_lt (o1 o2 : ord) := {i : opred_type o2 & ord_le o1 (opred o2 i)}.

Definition ord_eq o1 o2 := ord_le o1 o2 # ord_le o2 o1.

Notation "o1 << o2" := (ord_lt o1 o2) (at level 0).
Notation "o1 <=< o2" := (ord_le o1 o2) (at level 0).
Notation "o1 =o= o2" := (ord_eq o1 o2) (at level 0).

Lemma not_ord_lt_zero : forall o, !(o << OZ).
Proof.
  induction o; intro olt; unfold ord_lt in olt; exrepnd; allsimpl; tcsp.
Qed.

Lemma ord_le_opred_implies_ord_lt :
  forall o1 o2 t, o1 <=< (opred o2 t) -> o1 << o2.
Proof.
  introv ole.
  exists t; auto.
Qed.

Lemma ord_le_ex_opred_type :
  forall o1 o2,
    opred_type o1
    -> o1 <=< o2
    -> opred_type o2.
Proof.
  induction o1 as [|?|? ind]; introv opt ole; allsimpl; tcsp.
  - destruct opt as [t|].
    + inversion ole as [|? ? t' ole'|]; subst; clear ole; auto.
    + inversion ole as [|? ? t' ole'|]; subst; clear ole; auto.
  - exrepnd.
    inversion ole as [|?|? ? i]; subst; clear ole.
    pose proof (i n) as ole; clear i.
    apply ind in ole; auto.
Qed.

Lemma ord_le_opred_right_implies_le :
  forall o1 o2 (t : opred_type o2),
    o1 <=< (opred o2 t)
    -> o1 <=< o2.
Proof.
  induction o1 as [|? ind|? ind]; introv ole; allsimpl; tcsp.
  - apply (le_OS _ _ t).
    inversion ole as [|? ? t' ole'|]; subst; clear ole.
    apply ind in ole'; auto.
  - inversion ole as [|?|? ? i]; subst; clear ole.
    constructor; introv.
    pose proof (i n) as h; clear i.
    apply ind in h; auto.
Qed.

Lemma ord_le_opred_right_implies_lt :
  forall o1 o2 (t : opred_type o2),
    o1 <=< (opred o2 t)
    -> o1 << o2.
Proof.
  introv ole; exists t; auto.
Qed.

Lemma implies_ord_le_opred_left :
  forall o1 o2 (t1 : opred_type o1),
    o1 <=< o2
    -> (opred o1 t1) <=< o2.
Proof.
  induction o1 as [|? ind|? ind]; introv ole; allsimpl; tcsp.
  - inversion ole as [|? ? t ole'|]; subst; clear ole.
    apply ord_le_opred_right_implies_le in ole'; auto.
    destruct t1; tcsp.
  - inversion ole as [|?|? ? i]; subst; clear ole; exrepnd.
    apply ind; auto.
Qed.

Lemma ord_le_trans :
  forall o1 o2 o3, o1 <=< o2 -> o2 <=< o3 -> o1 <=< o3.
Proof.
  introv ole.
  revert o3.

  induction ole as [|? ? ? ? ind|]; introv ole2; auto; clear ole.

  induction ole2 as [|? ? ? ? ind2|? ? ? ind2]; introv; allsimpl; tcsp.

  - apply (le_OS _ _ i0).
    apply ind.
    destruct i; allsimpl; tcsp.
    apply implies_ord_le_opred_left; auto.

  - exrepnd.
    apply (ind2 n i0); auto.
Qed.
Hint Resolve ord_le_trans : slow.

Lemma ord_lt_trans :
  forall o1 o2 o3, o1 << o2 -> o2 << o3 -> o1 << o3.
Proof.
  introv olt1 olt2.
  allunfold ord_lt; exrepnd.
  exists i.
  eapply ord_le_trans;[exact olt2|].
  apply implies_ord_le_opred_left; auto.
Qed.
Hint Resolve ord_lt_trans : slow.

Lemma implies_ord_le_opred :
  forall o1 o2 (t1 : opred_type o1),
    o1 <=< o2
    -> {t2 : opred_type o2 & (opred o1 t1) <=< (opred o2 t2)}.
Proof.
  induction o1 as [|? ind|? ind]; introv ole; allsimpl; tcsp.

  - inversion ole as [|? ? t ole'|]; subst; clear ole.
    destruct t1; allsimpl.

    + apply ind.
      eapply ord_le_opred_right_implies_le; eauto.

    + exists t; auto.

  - inversion ole as [|?|? ? i]; subst; clear ole; exrepnd.
    pose proof (i n) as h; clear i.
    applydup ind in h as t; auto.
Qed.

Lemma ord_lt_le_trans :
  forall o1 o2 o3, o1 << o2 -> o2 <=< o3 -> o1 << o3.
Proof.
  introv olt1 olt2.
  allunfold ord_lt; exrepnd.
  pose proof (implies_ord_le_opred o2 o3 i olt2) as h; exrepnd.
  exists t2.
  eapply ord_le_trans;[|exact h0]; auto.
Qed.

Lemma implies_ord_le_limit_right :
  forall o f n, o <=< (f n) -> o <=< (OL f).
Proof.
  induction o as [|?|? ind]; introv ole; auto.
  - inversion ole as [|? ? t ole'|]; subst; clear ole.
    apply (le_OS o (OL f) (existT (fun n => opred_type (f n)) n t)); simpl; auto.
  - inversion ole as [|?|? ? i]; subst; clear ole; exrepnd.
    constructor; introv.
    eapply ind; apply i.
Qed.

Lemma ord_le_refl : forall o, o <=< o.
Proof.
  induction o; auto.
  - apply (le_OS o (OS o) None); simpl; auto.
  - constructor; introv.
    eapply implies_ord_le_limit_right; eauto.
Qed.
Hint Resolve ord_le_refl : slow.

Lemma ord_eq_refl : forall o, o =o= o.
Proof.
  introv.
  split; apply ord_le_refl.
Qed.

Lemma ord_eq_sym :
  forall o1 o2, o1 =o= o2 -> o2 =o= o1.
Proof.
  introv oeq.
  allunfold ord_eq; sp.
Qed.

Lemma ord_le_eq_trans :
  forall o1 o2 o3, o1 <=< o2 -> o2 =o= o3 -> o1 <=< o3.
Proof.
  introv ole oeq.
  allunfold ord_eq; repnd.
  eapply ord_le_trans;eauto.
Qed.

Lemma ord_lt_eq_trans :
  forall o1 o2 o3, o1 << o2 -> o2 =o= o3 -> o1 << o3.
Proof.
  introv olt oeq.
  allunfold ord_eq; repnd.
  eapply ord_lt_le_trans;eauto.
Qed.

Lemma implies_ord_lt_OS :
  forall o1 o2, o1 <=< o2 -> o1 << (OS o2).
Proof.
  introv ole.
  unfold ord_lt.
  exists (None : opred_type (OS o2)); simpl; auto.
Qed.

Lemma ord_le_oadd_l :
  forall o1 o2, o1 <=< (oadd o1 o2).
Proof.
  induction o1; introv; auto; simpl.
  - apply (le_OS o1 (OS (oadd o1 o2)) None); simpl; auto.
  - constructor; introv.
    eapply implies_ord_le_limit_right; eauto.
Qed.

Lemma ord_le_OS :
  forall o, o <=< (OS o).
Proof.
  induction o as [|? ind|? ind]; introv; auto; simpl.
  - apply (le_OS o (OS (OS o)) None); simpl; auto.
  - constructor; introv.
    eapply ord_le_trans;[apply ind|].
    apply (le_OS (o n) (OS (OL o)) None); simpl; auto.
    eapply implies_ord_le_limit_right; apply ord_le_refl.
Qed.

Lemma ord_le_oadd_r :
  forall o1 o2, o2 <=< (oadd o1 o2).
Proof.
  induction o1 as [|? ind|? ind]; introv; auto; simpl.
  - apply ord_le_refl.
  - eapply ord_le_trans;[apply ind|]; auto.
    apply ord_le_OS.
  - eapply ord_le_trans;[apply (ind 0)|]; auto.
    eapply implies_ord_le_limit_right; apply ord_le_refl.
Qed.

Lemma ord_lt_OS_implies :
  forall o1 o2,
    o1 << (OS o2)
    -> o1 <=< o2.
Proof.
  introv olt.
  unfold ord_lt in olt; exrepnd; allsimpl.
  destruct i; allsimpl; tcsp.
  eapply ord_le_trans;[exact olt0|].
  apply implies_ord_le_opred_left.
  apply ord_le_refl.
Qed.

Lemma comp_ind_ord :
  forall (P: ord -> Type),
    (forall n, (forall m, m << n -> P m) -> P n)
    -> forall n, P n.
Proof.
 intros P IH n.

 assert (forall n m, ord_lt m n -> P m) as h.
 { intro n0.
   induction n0 as [|n' ind|f ind]; introv h.
   - apply not_ord_lt_zero in h; tcsp.
   - unfold ord_lt in h; exrepnd; allsimpl.
     destruct i; allsimpl.
     + apply IH; auto.
       apply ord_le_opred_implies_ord_lt in h0.
       introv q.
       eapply ord_lt_trans in h0;[|exact q].
       apply ind; auto.
     + apply IH.
       introv ltm.
       apply ind.
       eapply ord_lt_le_trans; eauto.
   - unfold ord_lt in h; exrepnd; allsimpl.
     exrepnd; allsimpl.
     apply ord_le_opred_right_implies_lt in h0.
     apply ind in h0; auto. }

 apply IH; apply h.
Defined.

Definition ntseq {o} : Type := nat -> @NTerm o.

Definition bterm2term {o} (b : @BTerm o) :=
  match b with
    | bterm _ t => t
  end.

(*
Scheme NTerm_mut := Induction for NTerm Sort Prop
with BTerm_mut := Induction for BTerm Sort Prop.
*)

(*
Definition term_rel := NTerm -> NTerm -> Type.
*)

Definition isvar {p} (t : @NTerm p) :=
  match t with
    | vterm _ => true
    | _ => false
  end.

Definition isvariable {p} (t : @NTerm p) :=
  match t with
    | vterm _ => True
    | _ => False
  end.

Definition iscanonical {p} (t : @NTerm p) :=
  match t with
    | oterm (Can _) _ => true
    | sterm _ => true
    | _ => false
  end.

Definition iscan {p} (t : @NTerm p) :=
  match t with
    | oterm (Can _) _ => True
    | sterm _ => True
    | _ => False
  end.

Definition isnoncan {p} (t : @NTerm p) :=
  match t with
    | vterm _ => False
    | sterm _ => False
    | oterm o _ =>
      match o with
        | NCan _ => True
        | _ => False
      end
  end.

Definition isexception {p} (t: @NTerm p) :=
  match t with
    | vterm _ => false
    | sterm _ => false
    | oterm o _ =>
      match o with
        | Exc => true
        | _ => false
      end
  end.

Definition isexc {p} (t: @NTerm p) :=
  match t with
    | vterm _ => False
    | sterm _ => False
    | oterm o _ =>
      match o with
        | Exc => True
        | _ => False
      end
  end.

Definition isabs {p} (t: @NTerm p) :=
  match t with
    | vterm _ => False
    | sterm _ => False
    | oterm o _ =>
      match o with
        | Abs _ => True
        | _ => False
      end
  end.

Definition isseq {p} (t : @NTerm p) :=
  match t with
    | vterm _ => False
    | sterm _ => True
    | oterm _ _ => False
  end.

Ltac d_isnoncan H :=
  match type of H with
      isnoncan ?t =>
      let tlbt := fresh t "lbt" in
      let tnc := fresh t "nc" in
      let tt := fresh "temp" in
      destruct t as [tt|tt|tt tlbt];
        [complete (inverts H as H)|complete (inverts H as H)|];
        destruct tt as [tt|tnc|tex|tabs];
        [ complete(inverts H as H)
        | idtac
        | complete(inverts H as H)
        | complete(inverts H as H)
        ]
  end.

Ltac d_isexc H :=
  match type of H with
      isexc ?t =>
      let tlbt := fresh t "lbt" in
      let tnc := fresh t "nc" in
      let tt := fresh "temp" in
      destruct t as [tt|tt|tt tlbt];
        [complete (inverts H as H)|complete (inverts H as H)|];
        destruct tt as [tt|tnc|tex|tabs];
        [ complete(inverts H as H)
        | complete(inverts H as H)
        | idtac
        | complete(inverts H as H)
        ]
  end.

Ltac d_isabs H :=
  match type of H with
      isabs ?t =>
      let x  := fresh t "x" in
      let bs := fresh t "bs" in
      let tt := fresh "temp" in
      destruct t as [tt|tt|tt tlbt];
        [complete (inverts H as H)|complete (inverts H as H)|];
        destruct tt as [tt|tnc|tex|tabs];
        [ complete(inverts H as H)
        | complete(inverts H as H)
        | complete(inverts H as H)
        | idtac
        ]
  end.

(*Notation "x # b" := (bterm [x] b) (at level 70, right associativity).
(*Check [[ btermO (vterm(nvar 0))]] *)
(* Notation "< N >" := (btermO N). *)
Notation "\\ f" :=
  (oterm (Can NLambda) [[f]]) (at level 70, right associativity).

*)

Notation "(| a , b |)" :=
  (oterm (Can NPair) [bterm [] a, bterm [] b]) (at level 70, right associativity).

(* ------ CONSTRUCTORS ------ *)

(* --- primitives --- *)

(* end hide *)

(** Here are some handy definitions that will
    reduce the verbosity of some of our later definitions.
*)

Definition nobnd {p} (f : @NTerm p) := bterm [] f.

Definition mk_var {p} (nv : NVar) : @NTerm p := vterm nv.

Definition mk_lam {p} (v : NVar) (b : @NTerm p) := oterm (Can NLambda) [bterm [v] b].

Definition mk_fix {p} (f : @NTerm p) := oterm (NCan NFix) [ bterm [] f ].

Definition mk_apply {p} (f a : @NTerm p) := oterm (NCan NApply) [nobnd f , nobnd a].

Definition mk_eapply {p} (f a : @NTerm p) := oterm (NCan NEApply) [nobnd f , nobnd a].

Definition mk_apseq {p} (f : nseq) (a : @NTerm p) := oterm (NCan (NApseq f)) [nobnd a].

Definition mk_token {p} s : @NTerm p := oterm (Can (NTok s)) [].

Definition mk_utoken {p} (u : get_patom_set p) : @NTerm p := oterm (Can (NUTok u)) [].

Definition mk_exception {p} (a e : @NTerm p) := oterm Exc [nobnd a; nobnd e].

(** %\noindent \\*% We define similar abstractions for other [Opid]s.
    This document does not show them. As mentioned before, one can click
    at the hyperlinked filename that is closest above to open a
    webpage that shows complete contents of this file.
*)

(** %\noindent% Whenever we talk about the [NTerm] of a [BTerm], this is
what we would mean:

*)
Definition get_nt {p} (bt : @BTerm p) : NTerm :=
 match bt with
 | bterm lv nt => nt
 end.

Definition get_vars {p} (bt: @BTerm p) : list NVar :=
 match bt with
 | bterm lv nt => lv
 end.

Definition num_bvars {p} (bt : @BTerm p) := length (get_vars bt).

(**
    We define functions that compute the free variables and
    bound variables of a term.
    Note how these functions have just two cases
    and are robust against addition/deletion of new operators([Opid]s) to the
    language.
    If we had defined [NTerm] in the usual way(with one constructor for each [Opid]),
    these definitions would be of the form of a long pattern match with one case for each [Opid].
    However, these definitions only care about the binding structure.
    We will reap more benefits of this uniformity when we define substitution and alpha equality
    in the next subsection.
*)

(* --- variables --- *)

(* What could be the free vars of [sterm f]?  The union of the free vars of
   all the [f n] for all nats [n]?  For now let's consider closed sequences
   only.
 *)
Fixpoint free_vars {p} (t:@NTerm p) : list NVar :=
  match t with
  | vterm v => [v]
  | sterm _ => []
  | oterm op bts => flat_map free_vars_bterm bts
  end
 with free_vars_bterm {p} (bt : BTerm) :=
  match bt with
  | bterm  lv nt => remove_nvars lv (free_vars nt)
  end.

Fixpoint bound_vars {p} (t : @NTerm p) : list NVar :=
  match t with
  | vterm _ => []
  | sterm _ => []
  | oterm _ bts => flat_map bound_vars_bterm bts
  end
 with bound_vars_bterm {p} (bt : BTerm) :=
  match bt with
  | bterm lv nt => lv ++ bound_vars nt
  end.

Definition all_vars {p} (t : @NTerm p) := free_vars t ++ bound_vars t.

Definition closed {p} (t : @NTerm p) := free_vars t = [].

Definition get_utokens_c {p} (c : @CanonicalOp p) : list (get_patom_set p) :=
  match c with
    | NUTok u => [u]
    | _ => []
  end.

Definition get_utokens_o {p} (o : @Opid p) : list (get_patom_set p) :=
  match o with
    | Can c => get_utokens_c c
    | _ => []
  end.

Fixpoint get_utokens {p} (t : @NTerm p) : list (get_patom_set p) :=
  match t with
    | vterm _ => []
    | sterm _ => []
    | oterm o bterms => (get_utokens_o o) ++ (flat_map get_utokens_b bterms)
  end
with get_utokens_b {p} (bt : @BTerm p) : list (get_patom_set p) :=
       match bt with
         | bterm _ t => get_utokens t
       end.

Definition noutokens {o} (t : @NTerm o) := get_utokens t = [].

(**

  First, we define the [allvars] function that extracts all the
  variables from a term, i.e., both its free and bound variables.  We
  prove that [allvars t] is equivalent as a set to [all_vars t].

 *)

Fixpoint allvars {p} (t : @NTerm p) : list NVar :=
  match t with
    | vterm v => [v]
    | sterm _ => []
    | oterm o bts => flat_map allvarsbt bts
  end
with allvarsbt {p} (bt : BTerm) :=
  match bt with
    | bterm vs t => vs ++ allvars t
  end.

Set Implicit Arguments.

Inductive OList T :=
| OLO : T -> OList T
| OLL : list (OList T) -> OList T
| OLS : (nat -> OList T) -> OList T.

Fixpoint olist_size {T} (l : OList T) : ord :=
  match l with
    | OLO _ => O1
    | OLL l => OS (oaddl (map olist_size l))
    | OLS f => OS (OL (fun x => olist_size (f x)))
  end.

Lemma implies_ord_le_oaddl :
  forall l o,
    {x : ord & LIn x l # o <=< x}
    -> o <=< (oaddl l).
Proof.
  induction l; introv h; exrepnd; allsimpl; tcsp.
  eapply ord_le_trans;[exact h0|]; clear h0.
  repndors; subst; tcsp.
  - apply ord_le_oadd_l.
  - eapply ord_le_trans;[apply IHl|].
    { eexists; dands; eauto 3 with slow. }
    { apply ord_le_oadd_r. }
Qed.

Lemma olist_better_ind {T} :
  forall P : OList T -> Type,
    (forall x : T, P (OLO x))
    -> (forall l, (forall x, LIn x l -> P x) -> P (OLL l))
    -> (forall f, (forall n, P (f n)) -> P (OLS f))
    -> forall o, P o.
Proof.
  introv ho hl hs.

  assert (forall n o, (olist_size o) =o= n -> P o) as Hass;
    [|introv;
       apply Hass with (n := olist_size o);
       apply ord_eq_refl];[].

  induction n as [n Hind] using comp_ind_ord.
  introv Hsz.
  destruct o as [v|l|f]; auto.

  - apply hl; introv i; allsimpl.
    pose proof (Hind (olist_size x)) as h; clear Hind.
    autodimp h hyp; [|apply h; apply ord_eq_refl].
    eapply ord_lt_eq_trans;[|exact Hsz]; clear Hsz.
    apply implies_ord_lt_OS.
    apply implies_ord_le_oaddl.
    exists (olist_size x); dands; eauto 3 with slow.
    rw in_map_iff; eexists; eauto.

  - apply hs; introv; allsimpl.
    pose proof (Hind (olist_size (f n0))) as h; clear Hind.
    autodimp h hyp; [|apply h; apply ord_eq_refl].
    eapply ord_lt_eq_trans;[|exact Hsz]; clear Hsz.
    apply implies_ord_lt_OS.
    eapply implies_ord_le_limit_right; apply ord_le_refl.
Defined.

Inductive in_olist {T} (v : T) : OList T -> Type :=
| in_olist_v : in_olist v (OLO v)
| in_olist_l :
    forall l,
      {o : OList T & LIn o l # in_olist v o}
      -> in_olist v (OLL l)
| in_olist_s :
    forall f,
      {n : nat & in_olist v (f n)}
      -> in_olist v (OLS f).
Hint Constructors in_olist.

Definition subseto {T} (l : list T) (o : OList T) : Type :=
  forall x, LIn x l -> in_olist x o.

Definition osubset {T} (o1 o2 : OList T) :=
  forall x, in_olist x o1 -> in_olist x o2.

Lemma osubset_singleton_OLS_l {T} :
  forall f (l : OList T),
    osubset (OLS f) l <=> (forall n, osubset (f n) l).
Proof.
  unfold osubset.
  introv; split; introv h i; allsimpl.
  - apply h.
    constructor; eexists; eauto.
  - inversion i; exrepnd; subst.
    eapply h; eauto.
Qed.

Lemma implies_osubset_singleton_OLS_r {T} :
  forall (o : @OList T) n f,
    osubset o (f n)
    -> osubset o (OLS f).
Proof.
  introv i j.
  constructor.
  exists n; auto.
Qed.

Lemma implies_osubset_singleton_OLS_r_ex {T} :
  forall (l : OList T) f,
    {n : nat & osubset l (f n)}
    -> osubset l (OLS f).
Proof.
  introv h; exrepnd.
  eapply implies_osubset_singleton_OLS_r; eauto.
Qed.

Definition onil {T} : OList T := OLL [].

Lemma osubset_nil_l {T} :
  forall (l : OList T), osubset onil l.
Proof.
  introv i.
  inversion i; subst; exrepnd; allsimpl; tcsp.
Qed.
Hint Resolve osubset_nil_l : slow.

Lemma in_olist_in_trans {T} :
  forall l (x : T) o,
    in_olist x o
    -> LIn o l
    -> in_olist x (OLL l).
Proof.
  introv i j.
  constructor.
  eexists; eauto.
Qed.

Lemma osubset_in_trans {T} :
  forall (o1 : OList T) o2 l,
    osubset o1 o2
    -> LIn o2 l
    -> osubset o1 (OLL l).
Proof.
  introv i j k.
  constructor.
  eexists; dands; eauto.
Qed.

Lemma osubset_OLO_implies_in_olist_eq {T} :
  forall (o : OList T) x,
    osubset o (OLO x)
    -> (forall v, in_olist v o -> v = x).
Proof.
  introv h q.
  apply h in q.
  inversion q; auto.
Qed.

Lemma osubset_refl {T} :
  forall (l : OList T), osubset l l.
Proof.
  introv i; auto.
Qed.
Hint Resolve osubset_refl : slow.

(*
Lemma olist_in_if_in {T} :
  forall o (l : list (OList T)), LIn o l -> olist_in o (OLL l).
Proof.
  introv i.
  apply olist_in_iff; introv j.
  constructor.
  eexists; dands; eauto.
Qed.
*)

Definition osubset_as_osubseto {T} :
  forall (l : list T) (os : OList T),
    subseto l os <=> osubset (OLL (map (@OLO T) l)) os.
Proof.
  unfold osubset, subseto.
  introv; split; introv h.
  - introv i.
    inversion i as [|? q|]; subst; clear i; exrepnd.
    allrw in_map_iff; exrepnd; subst.
    inversion q0; subst; clear q0; auto.
  - introv i.
    apply h.
    constructor.
    exists (OLO x); dands; auto.
    rw in_map_iff; eexists; eauto.
Qed.

Lemma subseto_nil_l {T} :
  forall (os : OList T), subseto [] os.
Proof.
  introv h; allsimpl; tcsp.
Qed.
Hint Resolve subseto_nil_l : slow.

Lemma subseto_app_l {T} :
  forall l1 l2 (os : OList T),
    subseto (l1 ++ l2) os <=> (subseto l1 os # subseto l2 os).
Proof.
  introv; split; intro h.
  - dands; introv i; apply h; rw in_app_iff; sp.
  - repnd; introv i; allrw in_app_iff; repndors; discover; auto.
Qed.

Lemma implies_subseto_app_r {T} :
  forall l (os1 os2 : list (OList T)),
    (subseto l (OLL os1) [+] subseto l (OLL os2))
    -> subseto l (OLL (os1 ++ os2)).
Proof.
  introv h i.
  constructor.
  repndors; apply h in i; clear h; inversion i; subst; exrepnd;
  eexists; dands; eauto; rw in_app_iff; tcsp.
Qed.

Lemma implies_subseto_cons_ols_r {T} :
  forall l f (os : list (OList T)),
    ({n : nat & subseto l (f n)} [+] subseto l (OLL os))
    -> subseto l (OLL (OLS f :: os)).
Proof.
  introv h i.
  repndors.
  - exrepnd.
    apply h0 in i.
    constructor; simpl.
    eexists; dands; eauto.
  - apply h in i; exrepnd.
    inversion i; subst; exrepnd.
    constructor; simpl.
    eexists; dands; eauto.
Qed.

Lemma subseto_refl {T} :
  forall (l : list T), subseto l (OLL (map (@OLO T) l)).
Proof.
  introv i.
  constructor.
  exists (OLO x); dands; auto.
  rw in_map_iff; eexists; eauto.
Qed.
Hint Resolve osubset_refl : slow.

Lemma subseto_flat_map_l :
  forall {A B} (f : A -> list B) (l : list A) (k : OList B),
    subseto (flat_map f l) k <=> (forall x : A, LIn x l -> subseto (f x) k).
Proof.
  introv; split; intro h.
  - introv i j.
    apply h.
    rw lin_flat_map; eexists; eauto.
  - introv i; allrw lin_flat_map; exrepnd.
    applydup h in i1.
    applydup i2 in i0; auto.
Qed.

Lemma subseto_flat_map2 :
  forall {A B} (f : A -> list B) (g : A -> OList B) (l : list A),
    (forall x : A, LIn x l -> subseto (f x) (g x))
    -> subseto (flat_map f l) (OLL (map g l)).
Proof.
  introv imp i.
  allrw lin_flat_map; exrepnd.
  applydup imp in i1.
  applydup i2 in i0.
  constructor.
  eexists; dands; eauto.
  rw in_map_iff; eexists; eauto.
Qed.

Lemma osubset_singleton_OLL_l {T} :
  forall l (o : OList T),
    osubset (OLL l) o <=> (forall x, LIn x l -> osubset x o).
Proof.
  unfold osubset.
  introv; split; introv h i; allsimpl.
  - introv j.
    apply h.
    constructor.
    eexists; eauto.
  - inversion i; exrepnd; subst; clear i.
    eapply h; eauto.
Qed.

Lemma implies_osubset_singleton_OLL_r {T} :
  forall l (o : OList T),
    {x : OList T & LIn x l # osubset o x}
    -> osubset o (OLL l).
Proof.
  unfold osubset; introv h i; exrepnd.
  constructor.
  eexists; eauto.
Qed.

Definition oeqset {T} (o1 o2 : OList T) :=
  forall x, in_olist x o1 <=> in_olist x o2.

Lemma oeqset_refl {T} :
  forall o : OList T, oeqset o o.
Proof.
  introv; unfold oeqset; introv; sp.
Qed.
Hint Resolve oeqset_refl : slow.

Lemma oeqset_sym {T} :
  forall (o1 o2 : OList T), oeqset o1 o2 <=> oeqset o2 o1.
Proof.
  introv; unfold oeqset; split; intro h; introv; rw h; sp.
Qed.
Hint Resolve oeqset_sym : slow.

Lemma oeqset_trans {T} :
  forall (o1 o2 o3 : OList T), oeqset o1 o2 -> oeqset o2 o3 -> oeqset o1 o3.
Proof.
  unfold oeqset; introv h1 h2; introv.
  rw h1; rw h2; sp.
Qed.
Hint Resolve oeqset_trans : slow.

Fixpoint oflatten {T} (o : OList T) : list (OList T) :=
  match o with
    | OLL l => flat_map oflatten l
    | _ => [o]
  end.

Definition oappl {T} (l : list (OList T)) : OList T :=
  match flat_map oflatten l with
    | [o] => o
    | l => OLL l
  end.

Definition oapp {T} (o1 o2 : OList T) : OList T := oappl [o1, o2].

Lemma in_olist_OLL_app {T} :
  forall x (l1 l2 : list (OList T)),
    in_olist x (OLL (l1 ++ l2))
    <=> (in_olist x (OLL l1) [+] in_olist x (OLL l2)).
Proof.
  introv; split; introv h.
  - inversion h as [|? q|]; clear h; subst; exrepnd.
    allrw in_app_iff; repndors.
    + left; constructor; eexists; eauto.
    + right; constructor; eexists; eauto.
  - constructor; repndors; inversion h as [|? q|]; clear h; subst; exrepnd.
    + eexists;dands;[|eauto]; rw in_app_iff; sp.
    + eexists;dands;[|eauto]; rw in_app_iff; sp.
Qed.

Lemma in_olist_OLL_cons {T} :
  forall x o (l : list (OList T)),
    in_olist x (OLL (o :: l))
    <=> (in_olist x o [+] in_olist x (OLL l)).
Proof.
  introv; split; introv h.
  - inversion h as [|? q|]; clear h; subst; exrepnd.
    allsimpl; repndors; subst; tcsp.
    right; constructor; eexists; eauto.
  - constructor; repndors; inversion h as [|? q|]; clear h; subst; exrepnd; simpl;
    try (complete (eexists; eauto)).
    exists (OLL l0); dands; auto.
    constructor.
    eexists; eauto.
Qed.

Lemma in_olist_OLL_singleton {T} :
  forall x (o : OList T),
    in_olist x (OLL [o]) <=> in_olist x o.
Proof.
  introv; split; intro h.
  - inversion h as [|? q|]; subst; clear h; exrepnd.
    allsimpl; repndors; subst; tcsp.
  - constructor; simpl; eexists; eauto.
Qed.

Lemma oeqset_singleton_l {T} :
  forall (o : OList T), oeqset (OLL [o]) o.
Proof.
  repeat introv.
  apply in_olist_OLL_singleton.
Qed.

Lemma implies_oeqset_OLL_OLL2 {T} :
  forall (l1 l2 : list (OList T)),
    (forall o x, LIn o l1 -> in_olist x o -> in_olist x (OLL l2))
    -> (forall o x, LIn o l2 -> in_olist x o -> in_olist x (OLL l1))
    -> oeqset (OLL l1) (OLL l2).
Proof.
  introv h1 h2; introv; split; intro h.
  - inversion h as [|? q|]; subst; clear h; exrepnd.
    apply h1 in q0; auto.
  - inversion h as [|? q|]; subst; clear h; exrepnd.
    apply h2 in q0; auto.
Qed.

Lemma in_olist_OLL_map {A T} :
  forall x (f : A -> OList T) (l : list A),
    in_olist x (OLL (map f l)) <=> {a : A & LIn a l # in_olist x (f a)}.
Proof.
  introv; split; intro h.
  - inversion h as [|? q|]; subst; clear h; exrepnd.
    allrw in_map_iff; exrepnd; subst.
    eexists; eauto.
  - exrepnd.
    constructor; eexists; dands; eauto.
    rw in_map_iff; eexists; eauto.
Qed.

Lemma in_olist_OLL_flat_map {A T} :
  forall x (f : A -> list (OList T)) (l : list A),
    in_olist x (OLL (flat_map f l))
    <=> {a : A & LIn a l # in_olist x (OLL (f a))}.
Proof.
  introv; split; intro h.
  - inversion h as [|? q|]; subst; clear h; exrepnd.
    allrw lin_flat_map; exrepnd; subst.
    eexists; eauto.
  - exrepnd.
    constructor.
    inversion h0; subst; exrepnd; clear h0.
    eexists; dands; eauto.
    rw lin_flat_map; dands.
    eexists; dands; eauto.
Qed.

Lemma oeqset_OLL_oflatten {T} :
  forall o : OList T, oeqset (OLL (oflatten o)) o.
Proof.
  induction o as [|l ind|f ind] using olist_better_ind; allsimpl.
  - apply oeqset_singleton_l.
  - introv; split; intro h; allrw @in_olist_OLL_flat_map; exrepnd.
    + applydup ind in h1.
      apply h2 in h0.
      constructor.
      eexists; dands; eauto.
    + inversion h as [|? q|]; clear h; subst; exrepnd.
      applydup ind in q1.
      eexists; dands; eauto.
      apply q2; auto.
  - apply oeqset_singleton_l.
Qed.

Lemma oeqset_oapp_OLL_app_oflatten {T} :
  forall (o1 o2 : OList T),
    oeqset (oapp o1 o2) (OLL (oflatten o1 ++ oflatten o2)).
Proof.
  repeat introv.
  unfold oapp, oappl; simpl; allrw app_nil_r.
  remember (oflatten o1) as l1.
  remember (oflatten o2) as l2.
  destruct l1; simpl.
  - destruct l2; simpl; tcsp.
    destruct l2; simpl; tcsp.
    rw @oeqset_singleton_l; tcsp.
  - destruct l1; simpl; tcsp.
    destruct l2; simpl; tcsp.
    rw @oeqset_singleton_l; tcsp.
Qed.

Lemma oeqset_app_if {T} :
  forall (l1 l2 l3 l4 : list (OList T)),
    oeqset (OLL l1) (OLL l3)
    -> oeqset (OLL l2) (OLL l4)
    -> oeqset (OLL (l1 ++ l2)) (OLL (l3 ++ l4)).
Proof.
  unfold oeqset.
  introv h1 h2; introv.
  split; introv q;
  allrw @in_olist_OLL_app; repndors;
  try (complete (apply h1 in q; sp));
  try (complete (apply h2 in q; sp)).
Qed.

Lemma oeqset_cons_if {T} :
  forall o1 o2 (l1 l2 : list (OList T)),
    oeqset o1 o2
    -> oeqset (OLL l1) (OLL l2)
    -> oeqset (OLL (o1 :: l1)) (OLL (o2 :: l2)).
Proof.
  unfold oeqset.
  introv h1 h2; introv.
  split; introv q;
  allrw @in_olist_OLL_cons; repndors; tcsp;
  try (complete (apply h1 in q; sp));
  try (complete (apply h2 in q; sp)).
Qed.

Lemma fold_oapp {T} :
  forall (o1 o2 : OList T), oeqset (oapp o1 o2) (OLL [o1, o2]).
Proof.
  introv.
  eapply oeqset_trans;[apply oeqset_oapp_OLL_app_oflatten|].
  assert ([o1,o2] = [o1] ++ [o2]) as e by sp.
  rw e; clear e.
  apply oeqset_app_if.
  - eapply oeqset_trans;[apply oeqset_OLL_oflatten|].
    apply oeqset_sym.
    apply oeqset_singleton_l.
  - eapply oeqset_trans;[apply oeqset_OLL_oflatten|].
    apply oeqset_sym.
    apply oeqset_singleton_l.
Qed.

Lemma oapp_nil_l {T} :
  forall (o : OList T), oeqset (oapp onil o) o.
Proof.
  introv.
  eapply oeqset_trans;[apply oeqset_oapp_OLL_app_oflatten|].
  simpl.
  apply oeqset_OLL_oflatten.
Qed.

Lemma flat_map_eq_singleton_implies :
  forall {A B} (f : A -> list B) l x,
    flat_map f l = [x] -> {a : A & LIn a l # f a = [x]}.
Proof.
  induction l; introv e; allsimpl; ginv.
  remember (f a) as l1.
  destruct l1; allsimpl.
  - apply IHl in e; exrepnd.
    eexists; dands; eauto.
  - destruct l1; allsimpl; ginv.
    remember (flat_map f l) as l2.
    destruct l2; allsimpl; ginv.
    exists a; sp.
Qed.

Lemma oflatten_singleton {T} :
  forall o1 o2 : OList T,
    oflatten o1 = [o2] -> oflatten o2 = [o2].
Proof.
  induction o1 as [|l ind|f ind] using olist_better_ind;
  introv h; allsimpl; ginv; allsimpl; auto.
  apply flat_map_eq_singleton_implies in h; exrepnd.
  eapply ind; eauto.
Qed.

Lemma oeqset_OLL_cons {T} :
  forall (o : OList T) l, oeqset (OLL (o :: l)) (oapp o (OLL l)).
Proof.
  introv.
  eapply oeqset_trans;[|apply oeqset_sym; apply fold_oapp].
  apply oeqset_cons_if; eauto 3 with slow.
  eapply oeqset_sym.
  apply oeqset_singleton_l.
Qed.

Lemma oeqset_flat_map_oflatten {T} :
  forall (l : list (OList T)),
    oeqset (OLL (flat_map oflatten l)) (OLL l).
Proof.
  induction l; simpl; eauto 3 with slow.
  rw cons_as_app.
  apply oeqset_app_if; auto.
  eapply oeqset_trans;[apply oeqset_OLL_oflatten|].
  apply oeqset_sym.
  apply oeqset_singleton_l.
Qed.

Lemma oappl_nil {T} : @oappl T [] = OLL [].
Proof. sp. Qed.
Hint Rewrite @oappl_nil : slow.

Lemma oappl_OLL_nil {T} :
  oappl [OLL []] = @OLL T [].
Proof.
  sp.
Qed.
Hint Rewrite @oappl_OLL_nil : slow.

Lemma in_oflatten_singleton {T} :
  forall (o1 o2 : OList T),
    LIn o2 (oflatten o1) -> oflatten o2 = [o2].
Proof.
  induction o1 as [|l ind|f ind] using olist_better_ind;
  introv i; allsimpl; ginv; allsimpl; auto; repndors; subst; tcsp.
  allrw lin_flat_map; exrepnd.
  eapply ind; eauto.
Qed.

Lemma in_oflatten_diff_OLL {T} :
  forall (o1 o2 : OList T) l,
    LIn o2 (oflatten o1) -> o2 <> OLL l.
Proof.
  induction o1 as [|l ind|f ind] using olist_better_ind;
  introv i; introv e; allsimpl; ginv; allsimpl; auto; repndors; subst; tcsp; ginv.
  allrw lin_flat_map; exrepnd.
  eapply ind; eauto.
Qed.

Lemma subset_flat_map_oflatten_singleton {T} :
  forall (k l : list (OList T)),
    subset k (flat_map oflatten l)
    -> flat_map oflatten k = k.
Proof.
  induction k; introv h; allsimpl; auto.
  allrw @cons_subset; repnd.
  allrw lin_flat_map; exrepnd.
  apply in_oflatten_singleton in h1; rw h1; simpl; f_equal.
  eapply IHk; eauto.
Qed.

Lemma osubset_app_left {T} :
  forall (l1 l2 l : list (OList T)),
    osubset (OLL l1) (OLL l)
    -> osubset (OLL l2) (OLL l)
    -> osubset (OLL (l1 ++ l2)) (OLL l).
Proof.
  introv h1 h2 i.
  apply in_olist_OLL_app in i; repndors.
  - apply h1 in i; auto.
  - apply h2 in i; auto.
Qed.

Lemma oappl_cons_oappl {T} :
  forall l1 l2 : list (OList T),
    oappl (oappl l1 :: l2) = oappl (l1 ++ l2).
Proof.
  introv; unfold oappl; simpl.
  rw flat_map_app.
  remember (flat_map oflatten l1) as k1.
  remember (flat_map oflatten l2) as k2.
  destruct k1; simpl; auto.
  destruct k1; simpl; auto.
  - symmetry in Heqk1.
    apply flat_map_eq_singleton_implies in Heqk1; exrepnd.
    apply oflatten_singleton in Heqk0; rw Heqk0; simpl; auto.
  - symmetry in Heqk1.

    assert (LIn o (flat_map oflatten l1)) as i1.
    { rw Heqk1; simpl; sp. }
    assert (LIn o0 (flat_map oflatten l1)) as i2.
    { rw Heqk1; simpl; sp. }
    assert (subset k1 (flat_map oflatten l1)) as ss.
    { rw Heqk1; repeat (apply subset_cons1); auto. }

    allrw lin_flat_map; exrepnd.
    apply in_oflatten_singleton in i3.
    apply in_oflatten_singleton in i0.
    apply subset_flat_map_oflatten_singleton in ss.
    rw i0; rw i3; rw ss; simpl; auto.
Qed.
Hint Rewrite @oappl_cons_oappl : slow.

Lemma implies_oappl_cons {T} :
  forall (o : OList T) l1 l2,
    oappl l1 = oappl l2
    -> oappl (o :: l1) = oappl (o :: l2).
Proof.
  introv h.
  allunfold @oappl; allsimpl.
  remember (oflatten o) as k1.
  remember (flat_map oflatten l1) as k2.
  remember (flat_map oflatten l2) as k3.
  destruct k1; allsimpl; tcsp; ginv.
  destruct k1; allsimpl; tcsp; ginv.
  - destruct k2; allsimpl; tcsp; ginv.
    + destruct k3; allsimpl; tcsp; ginv.
      destruct k3; allsimpl; tcsp; ginv.
      subst.
      assert (LIn (OLL []) (flat_map oflatten l2)) as i.
      { rw <- Heqk3; simpl; tcsp. }
      rw lin_flat_map in i; exrepnd.
      apply in_oflatten_singleton in i0; allsimpl; ginv.
    + destruct k2; allsimpl; tcsp; ginv.
      * destruct k3; allsimpl; tcsp; ginv.
        { subst.
          assert (LIn (OLL []) (flat_map oflatten l1)) as i.
          { rw <- Heqk2; simpl; tcsp. }
          rw lin_flat_map in i; exrepnd.
          apply in_oflatten_singleton in i0; allsimpl; ginv. }
        { destruct k3; allsimpl; tcsp; ginv.
          subst.
          assert (LIn (OLL (o2 :: o3 :: k3)) (flat_map oflatten l1)) as i.
          { rw <- Heqk2; simpl; tcsp. }
          rw lin_flat_map in i; exrepnd.
          eapply in_oflatten_diff_OLL in i0; destruct i0; eauto. }
      * destruct k3; allsimpl; tcsp; ginv.
        destruct k3; allsimpl; tcsp; ginv.
        subst.
        assert (LIn (OLL (o1 :: o2 :: k2)) (flat_map oflatten l2)) as i.
        { rw <- Heqk3; simpl; tcsp. }
        rw lin_flat_map in i; exrepnd.
        eapply in_oflatten_diff_OLL in i0; destruct i0; eauto.
  - destruct k2; allsimpl; tcsp; ginv.
    + destruct k3; allsimpl; tcsp; ginv.
      destruct k3; allsimpl; tcsp; ginv.
      subst.
      assert (LIn (OLL []) (flat_map oflatten l2)) as i.
      { rw <- Heqk3; simpl; tcsp. }
      rw lin_flat_map in i; exrepnd.
      apply in_oflatten_singleton in i0; allsimpl; ginv.
    + destruct k2; allsimpl; tcsp; ginv.
      * destruct k3; allsimpl; tcsp; ginv.
        { subst.
          assert (LIn (OLL []) (flat_map oflatten l1)) as i.
          { rw <- Heqk2; simpl; tcsp. }
          rw lin_flat_map in i; exrepnd.
          apply in_oflatten_singleton in i0; allsimpl; ginv. }
        { destruct k3; allsimpl; tcsp; ginv.
          subst.
          assert (LIn (OLL (o3 :: o4 :: k3)) (flat_map oflatten l1)) as i.
          { rw <- Heqk2; simpl; tcsp. }
          rw lin_flat_map in i; exrepnd.
          eapply in_oflatten_diff_OLL in i0; destruct i0; eauto. }
      * destruct k3; allsimpl; tcsp; ginv.
        destruct k3; allsimpl; tcsp; ginv.
        subst.
        assert (LIn (OLL (o2 :: o3 :: k2)) (flat_map oflatten l2)) as i.
        { rw <- Heqk3; simpl; tcsp. }
        rw lin_flat_map in i; exrepnd.
        eapply in_oflatten_diff_OLL in i0; destruct i0; eauto.
Qed.

Lemma oappl_cons_oappl2 {T} :
  forall (o : OList T) l1 l2,
    oappl (o :: oappl l1 :: l2)
    = oappl (o :: l1 ++ l2).
Proof.
  introv.
  apply implies_oappl_cons.
  autorewrite with slow; auto.
Qed.
Hint Rewrite @oappl_cons_oappl2 : slow.

Lemma oappl_cons_oappl3 {T} :
  forall (o1 o2 : OList T) l1 l2,
    oappl (o1 :: o2 :: oappl l1 :: l2)
    = oappl (o1 :: o2 :: l1 ++ l2).
Proof.
  introv.
  repeat (apply implies_oappl_cons).
  autorewrite with slow; auto.
Qed.
Hint Rewrite @oappl_cons_oappl3 : slow.

Lemma oappl_cons_oappl4 {T} :
  forall (o1 o2 o3 : OList T) l1 l2,
    oappl (o1 :: o2 :: o3 :: oappl l1 :: l2)
    = oappl (o1 :: o2 :: o3 :: l1 ++ l2).
Proof.
  introv.
  repeat (apply implies_oappl_cons).
  autorewrite with slow; auto.
Qed.
Hint Rewrite @oappl_cons_oappl4 : slow.

Lemma oappl_cons_oappl5 {T} :
  forall (o1 o2 o3 o4 : OList T) l1 l2,
    oappl (o1 :: o2 :: o3 :: o4 :: oappl l1 :: l2)
    = oappl (o1 :: o2 :: o3 :: o4 :: l1 ++ l2).
Proof.
  introv.
  repeat (apply implies_oappl_cons).
  autorewrite with slow; auto.
Qed.
Hint Rewrite @oappl_cons_oappl5 : slow.

Lemma oappl_app_oappl {T} :
  forall (l1 l2 : list (OList T)),
    oappl (l1 ++ [oappl l2])
    = oappl (l1 ++ l2).
Proof.
  induction l1; introv; simpl.
  - rw @oappl_cons_oappl; allrw app_nil_r; auto.
  - apply implies_oappl_cons; auto.
Qed.

Lemma oappl_app_as_oapp {T} :
  forall (l1 l2 : list (OList T)),
    oappl (l1 ++ l2) = oapp (oappl l1) (oappl l2).
Proof.
  unfold oapp; introv.
  rw @oappl_cons_oappl.
  rw @oappl_app_oappl; auto.
Qed.

Lemma oapp_assoc {T} :
  forall (o1 o2 o3 : OList T),
    oapp (oapp o1 o2) o3 = oapp o1 (oapp o2 o3).
Proof.
  introv; unfold oapp.
  allrw @oappl_cons_oappl; simpl.
  allrw @oappl_cons_oappl2; simpl; auto.
Qed.

Lemma oeqset_oappl_cons {T} :
  forall (o : OList T) l, oappl (o :: l) = oapp o (oappl l).
Proof.
  introv; unfold oapp.
  rw @oappl_cons_oappl2; allrw app_nil_r; auto.
Qed.

Lemma oeqset_oappl_OLL {T} :
  forall l : list (OList T),
    oeqset (oappl l) (OLL l).
Proof.
  induction l; simpl; eauto 3 with slow.
  rw @oeqset_oappl_cons.
  eapply oeqset_trans;[apply fold_oapp|].
  apply oeqset_cons_if; eauto 3 with slow.
  eapply oeqset_trans;[apply oeqset_singleton_l|]; auto.
Qed.

Lemma in_olist_oapp {T} :
  forall x (o1 o2 : OList T),
    in_olist x (oapp o1 o2) <=> (in_olist x o1 [+] in_olist x o2).
Proof.
  introv.
  rw @oeqset_oapp_OLL_app_oflatten.
  rw @in_olist_OLL_app.
  allrw @oeqset_OLL_oflatten; sp.
Qed.

Lemma oeqset_oapp_sym {T} :
  forall (o1 o2 : OList T), oeqset (oapp o1 o2) (oapp o2 o1).
Proof.
  introv; unfold oeqset; introv; split; intro h; allrw @in_olist_oapp;
  repndors; tcsp.
Qed.

Lemma oapp_OLL_left {T} :
  forall l (o : OList T),
    oeqset (oapp (OLL l) o) (OLL (l ++ [o])).
Proof.
  repeat introv.

  split; intro h;
  allrw @in_olist_oapp;
  allrw @in_olist_OLL_app;
  allrw @oeqset_singleton_l; tcsp.
Qed.

Lemma implies_oeqset_OLL_OLL {T} :
  forall (l1 l2 : list (OList T)),
    (forall o x, LIn o l1 -> in_olist x o -> {z : OList T & LIn z l2 # in_olist x z})
    -> (forall o x, LIn o l2 -> in_olist x o -> {z : OList T & LIn z l1 # in_olist x z})
    -> oeqset (OLL l1) (OLL l2).
Proof.
  introv h1 h2; introv; split; intro h.
  - inversion h as [|? q|]; subst; clear h; exrepnd.
    apply h1 in q0; auto.
  - inversion h as [|? q|]; subst; clear h; exrepnd.
    apply h2 in q0; auto.
Qed.

Lemma oeqset_oapp_if {T} :
  forall (o1 o2 o3 o4 : OList T),
    oeqset o1 o3
    -> oeqset o2 o4
    -> oeqset (oapp o1 o2) (oapp o3 o4).
Proof.
  introv oeq1 oeq2.
  constructor; introv i;
  allrw @in_olist_oapp; repndors;
  try (complete (apply oeq1 in i; tcsp));
  try (complete (apply oeq2 in i; tcsp)).
Qed.

Lemma osubset_oapp_if {T} :
  forall (o1 o2 o3 o4 : OList T),
    osubset o1 o3
    -> osubset o2 o4
    -> osubset (oapp o1 o2) (oapp o3 o4).
Proof.
  introv oeq1 oeq2.
  introv i;
  allrw @in_olist_oapp; repndors;
  try (complete (apply oeq1 in i; tcsp));
  try (complete (apply oeq2 in i; tcsp)).
Qed.

Lemma osubset_trans {T} :
  forall (o1 o2 o3 : OList T), osubset o1 o2 -> osubset o2 o3 -> osubset o1 o3.
Proof.
  introv h1 h2 i.
  apply h2; apply h1; auto.
Qed.

Lemma oeqset_implies_osubset {T} :
  forall (o1 o2 : OList T), oeqset o1 o2 -> osubset o1 o2.
Proof.
  introv h i.
  apply h; auto.
Qed.

Lemma implies_osubset_oapp {T} :
  forall o o1 o2 : OList T,
    (osubset o o1 [+] osubset o o2)
    -> osubset o (oapp o1 o2).
Proof.
  introv h i.
  apply in_olist_oapp; sp.
Qed.

Lemma osubset_app_if {T} :
  forall (l1 l2 l3 l4 : list (OList T)),
    osubset (OLL l1) (OLL l3)
    -> osubset (OLL l2) (OLL l4)
    -> osubset (OLL (l1 ++ l2)) (OLL (l3 ++ l4)).
Proof.
  introv h1 h2 i.
  allrw @in_olist_OLL_app; repndors.
  - apply h1 in i; sp.
  - apply h2 in i; sp.
Qed.

Lemma subseto_oeqset {T} :
  forall l (o1 o2 : OList T),
    subseto l o1
    -> oeqset o1 o2
    -> subseto l o2.
Proof.
  introv h1 h2 i.
  apply h2; auto.
Qed.

Definition OVar := OList NVar.
Definition ovar_v v : OVar := OLO v.
Definition ovar_l l : OVar := OLL l.
Definition ovar_s f : OVar := OLS f.

Fixpoint allovars {p} (t : @NTerm p) : OVar :=
  match t with
    | vterm v => ovar_v v
    | sterm f => ovar_s (fun n => allovars (f n))
    | oterm o bts => oappl (map allovarsbt bts)
  end
with allovarsbt {p} (bt : BTerm) : OVar :=
       match bt with
         | bterm vs t => oappl (map ovar_v vs ++ [allovars t])
       end.

Definition disj_ovar (v : NVar) l := !(in_olist v l).

Definition disj_ovars (vs : list NVar) (os : OVar) : Prop :=
  forall v o, LIn v vs -> disj_ovar v o.

Definition sat_ntseq {o} (f : ntseq) (P : @NTerm o -> Prop) : Prop :=
  forall n, P (f n).

(** % \noindent \\* % We define
    a predicate [nt_wf] on [NTerm] such that
    [nt_wf nt] asserts that [nt] is a well-formed term.  %\\* %
*)
Inductive nt_wf {p} : @NTerm p -> [univ] :=
| wfvt: forall nv, nt_wf (vterm nv)
| wfst: forall f,
          (forall n, nt_wf (f n) # closed (f n) # noutokens (f n))
          -> nt_wf (sterm f)
| wfot: forall (o: Opid) (lnt: list BTerm),
          (forall l, LIn l lnt -> bt_wf l)
          -> map (num_bvars) lnt
             = OpBindings o
          -> nt_wf (oterm o lnt)
with bt_wf {p} : @BTerm p -> [univ] :=
| wfbt : forall (lnv : list NVar) (nt: NTerm),
           nt_wf nt -> bt_wf (bterm lnv nt).
Hint Constructors nt_wf bt_wf.

(*  For example, the Opid [(Can NLambda)] takes only one [BTerm] an that [BTerm]
  must have exactly one bound variable.
  Hence [OpBindings (Can NLambda) = [1]]. *)

(** % \noindent \\* %
  The only interesting case here is for the [oterm] case. The
  [wfot] constructor requires
  that the number of bound variables of the bound terms in the list
  match the signature ([OpBindings o]) of the corresponding operator [o].

  % \noindent \\* % We abstract the [Opid]s into two categories, canonical
    and noncanonical.

  [
    Inductive Opid : Set :=

     | Can  : CanonicalOp -> Opid

     | NCan : NonCanonicalOp -> Opid.

  ]
% \noindent \\* % This distinction is important from the point of view of computation
    and simplifies many definitions and properties about computation and
    also makes them more easily extensible.
    Nuprl has a lazy computation system and
    an [NTerm] is in normal(canonical) form if its outermost [Opid] is a [CanonicalOp].
    No further computation is performed on terms in canonical form.
    For example, lambda abstraction are constructed by the following [Opid] :

% \noindent \\* % [Can NLambda]

% \noindent \\* % We have [OpBindings (Can NLambda) = [1]].

    On the other hand, an [NTerm] whose outermost [Opid] is a [NonCanonicalOp] is
    not in normal form and can compute to some other term, or to an error.
    An an  example, terms denoting function applications are constructed by the
    following [Opid]:
% \noindent \\* % [NCan NApply]

% \noindent \\* % We have [OpBindings (NCan NApply) = [0,0]].

    The only restriction in defining [CanonicalOp] and [NonCanonicalOp] is
    that the equality in these types should be decidable.
    We will soon show the full-blown definition of
    the [Opid]s of Nuprl.
*)

(* Howe's T_0(L) *)
Definition isprogram {p} (t : @NTerm p) := closed t # nt_wf t.

(** %\noindent \\*% Now, we will describe the [Opid]s of Nuprl and then describe some
other useful definitions and lemmas about [NTerm]. *)

(* begin hide *)

Definition isvalue_like {o} (t : @NTerm o) := iscan t [+] isexc t.
Definition is_can_or_exc {p} (t : @NTerm p) := iscan t [+] isexc t.
Definition isp_can_or_exc {p} (t : @NTerm p) := isprogram t # is_can_or_exc t.

Lemma is_can_or_exc_implies_isvalue_like {o} :
  forall (t : @NTerm o),
    is_can_or_exc t -> isvalue_like t.
Proof.
  introv h.
  unfold isvalue_like; unfold is_can_or_exc in h; sp.
Qed.
Hint Resolve is_can_or_exc_implies_isvalue_like : slow.

Lemma isp_can_or_exc_implies_is_program {p} :
  forall t : @NTerm p, isp_can_or_exc t -> isprogram t.
Proof.
  introv i; inversion i; sp.
Qed.
Hint Resolve isp_can_or_exc_implies_is_program : slow.

Lemma isexc_exc {o} :
  forall (l : list (@BTerm o)),
    isexc (oterm Exc l).
Proof. sp. Qed.
Hint Resolve isexc_exc.

Lemma iscan_can {o} :
  forall c (l : list (@BTerm o)),
    iscan (oterm (Can c) l).
Proof. sp. Qed.
Hint Resolve iscan_can.

Lemma isnoncan_noncan {o} :
  forall nc (l : list (@BTerm o)),
    isnoncan (oterm (NCan nc) l).
Proof. sp. Qed.
Hint Resolve isnoncan_noncan.

Lemma isabs_abs {o} :
  forall abs (l : list (@BTerm o)),
    isabs (oterm (Abs abs) l).
Proof. sp. Qed.
Hint Resolve isabs_abs.

Lemma noncan_not_is_can_or_exc {p} :
  forall e : @NTerm p,
    isnoncan e
    -> is_can_or_exc e
    -> False.
Proof.
  introv Hisnc Hisv.
  destruct e as [|?| o lbt]; allsimpl; cpx.
  destruct o; cpx.
  destruct Hisv as [Hisv|Hisv]; auto.
Qed.
Hint Resolve noncan_not_is_can_or_exc : slow.

Lemma isabs_not_is_can_or_exc {p} :
  forall e : @NTerm p,
    isabs e
    -> is_can_or_exc e
    -> False.
Proof.
  introv Hisnc Hisv.
  destruct e as [|?|o lbt]; allsimpl; cpx.
  destruct o; cpx.
  destruct Hisv as [Hisv|Hisv]; auto.
Qed.
Hint Resolve isabs_not_is_can_or_exc : slow.

Definition ispexc {p} (t : @NTerm p) := isexc t # isprogram t.

Lemma ispexc_implies_is_can_or_exc {p} :
  forall t : @NTerm p, ispexc t -> is_can_or_exc t.
Proof.
  introv i.
  destruct i as [isp ise].
  right; sp.
Qed.

Lemma isexc_exception {o} :
  forall a e : @NTerm o, isexc (mk_exception a e).
Proof. sp. Qed.
Hint Resolve isexc_exception : slow.

Lemma is_can_or_exc_isexc {o} :
  forall t : @NTerm o, isexc t -> is_can_or_exc t.
Proof. sp. Qed.
Hint Resolve is_can_or_exc_isexc : slow.

Lemma isvalue_like_can {o} :
  forall t : @NTerm o, iscan t -> isvalue_like t.
Proof. sp. Qed.
Hint Resolve isvalue_like_can : slow.

Lemma isvalue_like_exc {o} :
  forall t : @NTerm o, isexc t -> isvalue_like t.
Proof. sp. Qed.
Hint Resolve isvalue_like_exc : slow.

(* end hide *)


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Import securite.

Lemma POinvprel3 :
 forall (l l0 : list C) (k k0 k1 k2 : K) (c c0 c1 c2 : C)
   (d d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19
    d20 : D),
 inv0
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 inv1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 invP
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 rel3
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l)
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0) ->
 invP
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0).

Proof.
do 32 intro.
unfold inv0, invP, rel3 in |- *; intros know_c_c0_l Inv1 know_Kab and1.
elim know_c_c0_l; intros know_c_l know_c0_l.
elim and1; intros eq_l0 t1.
clear know_c_c0_l Inv1 and1 t1.
rewrite eq_l0.
unfold quint in |- *.
apply D2.
simpl in |- *.
repeat apply C2 || apply C3 || apply C4.
apply
 equivncomp
  with
    (Encrypt
       (quad (B2C (D2B d17)) (B2C (D2B d4)) (B2C (D2B d16)) (B2C (D2B Bid)))
       (KeyX Bid) :: l ++ rngDDKKeyABminusKab).
apply AlreadyIn; apply E0; apply EP0; assumption.
unfold quad in |- *.
repeat apply C2 || apply C3 || apply C4.
apply D1; assumption.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
discriminate.
Qed.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Coqlib.
Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import Values.

Require Import EvalTac.

Require Import SplitAt.

Lemma eval_c :
  eval_expr ge empty c (bits (v 3)).
Proof.
  g.
  e. e. e. e. e. g.
  e. e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. repeat e. e.
  repeat e.
  e. e. e. e. e. e.
  e. e. e. e.
  e. simpl. reflexivity.
  e. e. e. g.
  e. e. e. e. e. e. e. e.
  e.
  e. repeat e.
  e.
  eapply select_slice. e.
  reflexivity.
  e. e.
  e. e.
  e. e.
  Unshelve.
  all: try exact nz; simpl; unfold Pos.to_nat; simpl; try congruence.
Qed.


Require Import FloydSeq.base2.
Require Import FloydSeq.client_lemmas.
Require Import CSplit.strong.

Import LiftNotation.
Local Open Scope logic.

Lemma typed_true_nullptr:
 forall v t0 t t',
   typed_true t0 (force_val (sem_cmp Ceq (tptr t) (tptr t') v (Vint Int.zero))) ->
   v=nullval.
Proof.
 intros.
 simpl in H. rewrite !andb_false_r in H. simpl in H.
 unfold typed_true, force_val, sem_cmp_pp, strict_bool_val, nullval in *.
 destruct Archi.ptr64  eqn:Hp;
 destruct t0, v; inv H;
 unfold sem_cmp_pp, strict_bool_val in H1;
 try (clear i; rename i0 into i);
 pose proof (Int.eq_spec i Int.zero);
 destruct (Int.eq i Int.zero); inv H1; auto.
Qed.

Lemma typed_true_nullptr':
  forall  {cs: compspecs} t0  t t' v,
    typed_true t0 (eval_binop Cop.Oeq (tptr t) (tptr t') v nullval) -> v=nullval.
Proof.
 intros.
 simpl in H. unfold sem_binary_operation' in H.
 unfold tptr, typed_true, force_val, sem_cmp, Cop.classify_cmp, sem_cmp_pp,
   typeconv, remove_attributes, change_attributes, strict_bool_val, nullval, Val.of_bool in *.
   rewrite (proj2 (eqb_type_false (Tpointer t noattr) int_or_ptr_type)) in H
     by (intro Hx; inv Hx).
   rewrite (proj2 (eqb_type_false (Tpointer t' noattr) int_or_ptr_type)) in H
     by (intro Hx; inv Hx).
   simpl in H.
 destruct Archi.ptr64  eqn:Hp;
 destruct t0, v; inv H;
 try solve [revert H1; simple_if_tac; intro H1; inv H1].
 pose proof (Int64.eq_spec i0 Int64.zero);
 destruct (Int64.eq i0 Int64.zero); inv H1; auto.
 pose proof (Int.eq_spec i0 Int.zero);
 destruct (Int.eq i0 Int.zero); inv H1; auto.
Qed.

Lemma typed_true_Oeq_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_true tint) (`(eval_binop Cop.Oeq (tptr t) (tptr t')) v `(nullval))) |--
   local (`(eq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 unfold tptr in H; simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 destruct (v rho); inv H.
 unfold sem_cmp_pp, strict_bool_val, nullval in *.
 destruct Archi.ptr64  eqn:Hp; simpl in H1;
 try solve [inv H1];
 try solve [pose proof (Int64.eq_spec i Int64.zero);
                destruct (Int64.eq i Int64.zero); inv H1; auto];
 try solve [pose proof (Int.eq_spec i Int.zero);
                destruct (Int.eq i Int.zero); inv H1; auto].
Qed.

Definition  binary_operation_to_comparison (op: Cop.binary_operation) :=
 match op with
 | Cop.Oeq => Some (@eq Z)
 | Cop.One => Some Zne
 | Cop.Olt => Some Z.lt
 | Cop.Ole => Some Z.le
 | Cop.Ogt => Some Z.gt
 | Cop.Oge => Some Z.ge
 | _ => None
 end.

(*
Lemma typed_true_binop_int:
  forall op op' e1 e2 Espec  {cs: compspecs} Delta P Q R c Post,
   binary_operation_to_comparison op = Some op' ->
   typeof e1 = tint ->
   typeof e2 = tint ->
   (PROPx P (LOCALx (tc_env Delta :: Q) (SEPx R))) |--  tc_expr Delta e1 ->
   (PROPx P (LOCALx (tc_env Delta :: Q) (SEPx R))) |-- tc_expr Delta e2 ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`op' (`force_signed_int (eval_expr e1)) (`force_signed_int (eval_expr e2))
          :: Q) (SEPx R))) c Post ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`(typed_true
          (typeof (Ebinop op e1 e2 tint)))
          (eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre; [clear H4 | apply H4].
eapply derives_trans with
 (tc_expr Delta e1 && (tc_expr Delta e2
   && PROPx P (LOCALx (tc_environ Delta :: `(typed_true (typeof (Ebinop op e1 e2 tint)))(eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R)))).
rewrite <- andp_assoc.
apply andp_right; auto.
do 2 rewrite <- insert_local.
rewrite <- andp_assoc.
rewrite (andp_comm (local _)).
rewrite andp_assoc.
apply andp_left2.
rewrite insert_local.
apply andp_right; auto.
clear H2 H3.
(*do 2 rewrite insert_local.*)
unfold PROPx, LOCALx; intro rho; simpl.
normalize.
autorewrite with norm1 norm2; normalize.
rewrite <- andp_assoc.
apply andp_derives; auto.
eapply derives_trans.
apply andp_derives; apply typecheck_expr_sound; auto.
normalize. split; auto.
rewrite H1,H0 in *.
clear H5 H2 H0 H1.
destruct (eval_expr e1 rho); inv H6.
destruct (eval_expr e2 rho); inv H7.
unfold force_signed_int, force_int.
unfold typed_true, eval_binop in H4.
destruct op; inv H; simpl in H4.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); subst; auto.
 contradiction H4; auto.
unfold Zne.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); subst; auto.
contradict H.
rewrite <- (Int.repr_signed i).
rewrite <- (Int.repr_signed i0).
f_equal; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i) (Int.signed i0)); auto; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i0) (Int.signed i)); auto; try omega; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i0) (Int.signed i)); auto; try omega; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i) (Int.signed i0)); auto; try omega; contradict H4; auto.
Qed.
*)

Definition  binary_operation_to_opp_comparison (op: Cop.binary_operation) :=
 match op with
 | Cop.Oeq => Some Zne
 | Cop.One => Some (@eq Z)
 | Cop.Olt => Some Z.ge
 | Cop.Ole => Some Z.gt
 | Cop.Ogt => Some Z.le
 | Cop.Oge => Some Z.lt
 | _ => None
 end.

(*
Lemma typed_false_binop_int:
  forall op op' e1 e2 Espec  {cs: compspecs} Delta P Q R c Post,
   binary_operation_to_opp_comparison op = Some op' ->
   typeof e1 = tint ->
   typeof e2 = tint ->
   (PROPx P (LOCALx (tc_environ Delta :: Q) (SEPx R))) |-- (tc_expr Delta e1) ->
   (PROPx P (LOCALx (tc_environ Delta :: Q) (SEPx R))) |-- (tc_expr Delta e2) ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`op' (`force_signed_int (eval_expr e1)) (`force_signed_int (eval_expr e2))
          :: Q) (SEPx R))) c Post ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`(typed_false
          (typeof (Ebinop op e1 e2 tint)))
          (eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre; [clear H4 | apply H4].
eapply derives_trans with
 ( local (tc_environ Delta) && ((tc_expr Delta e1) && ( (tc_expr Delta e2)
   && PROPx P (LOCALx (tc_environ Delta :: `(typed_false (typeof (Ebinop op e1 e2 tint)))(eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))))).
apply andp_right.
rewrite <- insert_local. apply andp_left1; auto.
rewrite <- andp_assoc.
apply andp_right; auto.
do 2 rewrite <- insert_local.
rewrite <- andp_assoc.
rewrite (andp_comm (local _)).
rewrite andp_assoc.
apply andp_left2.
rewrite insert_local.
apply andp_right; auto.
clear H2 H3.
unfold PROPx, LOCALx; intro rho; simpl.
unfold local,lift1 at 1.
apply derives_extract_prop; intro TCE.
eapply derives_trans.
apply andp_derives; [ apply typecheck_expr_sound; auto | ].
apply andp_derives; [ apply typecheck_expr_sound; auto | ].
apply derives_refl.
normalize. autorewrite with norm1 norm2; normalize.
apply andp_right; auto. apply prop_right.
split; auto.
clear H6 TCE.
rewrite H0 in *; rewrite H1 in *.
clear H0 H1 H4.
destruct (eval_expr e1 rho); inv H2.
destruct (eval_expr e2 rho); inv H3.
unfold force_signed_int, force_int.
unfold typed_true, eval_binop in H5.
destruct op; inv H; simpl in H5.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); inv H5; auto.
intro; apply H.
rewrite <- (Int.repr_signed i).
rewrite <- (Int.repr_signed i0).
f_equal; auto.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); inv H5; auto.
unfold Int.lt in H5.
destruct (zlt (Int.signed i) (Int.signed i0)); inv H5; auto.
unfold Int.lt in H5.
destruct (zlt (Int.signed i0) (Int.signed i)); inv H5; omega.
unfold Int.lt in H5.
destruct (zlt (Int.signed i0) (Int.signed i)); inv H5; omega.
unfold Int.lt in H5.
destruct (zlt (Int.signed i) (Int.signed i0)); inv H5; omega.
Qed.
*)

Lemma typed_false_One_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_false tint) (`(eval_binop Cop.One (tptr t) (tptr t')) v `(nullval))) |--
    local (`(eq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 unfold sem_cmp_pp, nullval in *.
 destruct Archi.ptr64 eqn:Hp;
 destruct (v rho); inv H.
 pose proof (Int64.eq_spec i Int64.zero).
 destruct (Int64.eq i Int64.zero); inv H1.
 reflexivity.
 pose proof (Int.eq_spec i Int.zero).
 destruct (Int.eq i Int.zero); inv H1.
 reflexivity.
Qed.

Lemma typed_true_One_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_true tint) (`(eval_binop Cop.One (tptr t) (tptr t')) v `(nullval))) |--
   local (`(ptr_neq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 unfold sem_cmp_pp, ptr_neq, ptr_eq, nullval in *; simpl; intro.
 destruct (v rho); try contradiction.
 simpl in *.
 unfold typed_true, force_val, strict_bool_val in *.
 destruct Archi.ptr64 eqn:?; auto.
 destruct H0 as [? [? ?]].
 first [ pose proof (Int64.eq_spec Int64.zero i)
        | pose proof (Int.eq_spec Int.zero i)];
 rewrite H1 in H3;
 subst; inv H.
Qed.

Lemma typed_false_Oeq_nullval:
 forall  {cs: compspecs} v t t',
   local (`(typed_false tint) (`(eval_binop Cop.Oeq (tptr t) (tptr t')) v `(nullval))) |--
   local (`(ptr_neq nullval) v).
Proof.
intros. subst.
 unfold_lift; intro rho.  unfold local, lift1; apply prop_derives; intro.
 simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 intro. apply ptr_eq_e in H0. rewrite <- H0 in H.
 inv H.
Qed.

Lemma local_entail_at:
  forall n S T (H: local (locald_denote S) |-- local (locald_denote T))
    P Q R,
    nth_error Q n = Some S ->
    PROPx P (LOCALx Q (SEPx R)) |--
    PROPx P (LOCALx (replace_nth n Q T) (SEPx R)).
Proof.
 intros.
 unfold PROPx, LOCALx; simpl; intro rho;  apply andp_derives; auto.
 apply andp_derives; auto.
 unfold local, lift1.
 specialize (H rho). unfold local,lift1 in H.
 revert Q H0; induction n; destruct Q; simpl; intros; inv H0.
 unfold_lift; repeat rewrite prop_and.
 apply andp_derives; auto.
  unfold_lift; repeat rewrite prop_and.
 apply andp_derives; auto.
Qed.

Lemma local_entail_at_semax_0:
  forall Espec {cs: compspecs}Delta P Q1 Q1' Q R c Post,
   local (locald_denote Q1) |-- local (locald_denote Q1') ->
   @semax cs Espec Delta (PROPx P (LOCALx (Q1'::Q) (SEPx R))) c Post  ->
   @semax cs Espec Delta (PROPx P (LOCALx (Q1::Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre0.
eapply (local_entail_at 0).
apply H. reflexivity.
auto.
Qed.

(*
Ltac simplify_typed_comparison :=
match goal with
| |- semax _ (PROPx _ (LOCALx (`(typed_true _) ?A :: _) _)) _ _ =>
 (eapply typed_true_binop_int;
   [reflexivity | reflexivity | reflexivity
   | try solve [go_lowerx; apply prop_right; auto ]
   | try solve [go_lowerx; apply prop_right; auto ]
   | ])
 ||
  (let a := fresh "a" in set (a:=A); simpl in a; unfold a; clear a;
   eapply local_entail_at_semax_0; [
    first [ apply typed_true_Oeq_nullval
           | apply typed_true_One_nullval
           ]
    |  ])
| |- semax _ (PROPx _ (LOCALx (`(typed_false _) ?A :: _) _)) _ _ =>
 (eapply typed_false_binop_int;
   [reflexivity | reflexivity | reflexivity
   | try solve [go_lowerx; apply prop_right; auto ]
   | try solve [go_lowerx; apply prop_right; auto ]
   | ])
 ||
  let a := fresh "a" in set (a:=A); simpl in a; unfold a; clear a;
   eapply local_entail_at_semax_0; [
    first [ apply typed_false_Oeq_nullval
           | apply typed_false_One_nullval
           ]
    |  ]
| |- _ => idtac
end.
*)

Definition compare_pp op p q :=
   match p with
            | Vptr b z =>
               match q with
               | Vptr b' z' => if eq_block b b'
                              then Vint (if Ptrofs.cmpu op z z' then Int.one else Int.zero)
                              else Vundef
               | _ => Vundef
               end
             | _ => Vundef
   end.

Lemma force_sem_cmp_pp:
  forall op p q,
  isptr p -> isptr q ->
  force_val (sem_cmp_pp op p q) =
   match op with
   | Ceq => Vint (if eq_dec p q then Int.one else Int.zero)
   | Cne => Vint (if eq_dec p q then Int.zero else Int.one)
   | _ => compare_pp op p q
   end.
Proof.
intros.
destruct p; try contradiction.
destruct q; try contradiction.
clear.
unfold sem_cmp_pp, compare_pp, Ptrofs.cmpu, Val.cmplu_bool.
destruct Archi.ptr64 eqn:Hp.
destruct op; simpl; auto.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true; reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
if_tac. congruence. reflexivity.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true by auto. reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
rewrite if_false by congruence. reflexivity.
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
destruct op; simpl; auto; rewrite Hp.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true; reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
if_tac. congruence. reflexivity.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true by auto. reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
rewrite if_false by congruence. reflexivity.
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
Qed.

Hint Rewrite force_sem_cmp_pp using (now auto) : norm.


Require Import VST.floyd.proofauto.
Require Import x448.
Require Import stdpp.list.
Require Import ZArith.
Require Import compcert.lib.Coqlib.
Require Import list_int_functions.
Require Import Verif_gf_cpy.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition t_gf := Tstruct __257 noattr.

Local Open Scope Z.

Definition gf_mul_spec : ident * funspec :=
    DECLARE _gf_mul
    WITH
        c: val, shc : share, contents_c : list val,
        a: val, sha : share, contents_a : list Z,
        b: val, shb : share, contents_b : list Z,
        gv : globals
    PRE [ tptr t_gf, tptr t_gf, tptr t_gf ]
        PROP   (writable_share shc;
                readable_share sha;
                readable_share shb;
                Zlength contents_a = 16;
                Zlength contents_b = 16;
                Zlength contents_c = 16)
        PARAMS (c ; a ; b) GLOBALS (gv)
        SEP    (field_at shc t_gf (DOT _limb) contents_c c;
                field_at sha t_gf (DOT _limb) (map Vint (map Int.repr contents_a)) a;
                field_at shb t_gf (DOT _limb) (map Vint (map Int.repr contents_b)) b)
    POST [ tvoid ]
        PROP   ()
        RETURN ()
        SEP    (field_at shc t_gf (DOT _limb) (map Vint
                (map Int.repr (int_to_list ((list_to_int contents_a) * (list_to_int contents_b))))) c;
                field_at sha t_gf (DOT _limb) (map Vint (map Int.repr contents_a)) a;
                field_at shb t_gf (DOT _limb) (map Vint (map Int.repr contents_b)) b).

Definition Gprog : funspecs := ltac:(with_library prog [ gf_mul_spec; gf_cpy_spec ]).

Lemma body_gf_cpy : semax_body Vprog Gprog f_gf_mul gf_mul_spec.
Proof.
    start_function.
    Search "field_address".
    forward_call (v_aa, Tsh, (field_address t_gf (DOT _limb) v_aa)).
Admitted.


(* En este archivo se demuestra la corrección de la acción grantAuto*)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import EqTheorems.
Require Import Semantica.
Require Import RuntimePermissions.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import ValidStateLemmas.

Section GrantAuto.

Lemma postGrantAutoCorrect : forall (s:System) (a:idApp) (p:Perm), (pre (grantAuto p a) s) -> validstate s -> post_grantAuto p a s (grantAuto_post p a s).
Proof.
    intros.
    unfold post_grantAuto.
    split. simpl; auto.
    simpl in H.
    unfold pre_grantAuto in H;simpl in H.
    destruct H.

    split.
  - destruct H .
    destruct H.
    assert (In a (apps (state s)) \/ (exists sysapp:SysImgApp, In sysapp (systemImage (environment s)) /\ idSI sysapp = a)).
    destruct H.
    left.
    apply (ifManifestThenInApps s H0 a x);auto.
    right.
    destruct H.
    destruct_conj H.
    exists x0;auto.
    assert (exists v, map_apply idApp_eq (perms (state s)) a = Value idApp v).
    apply (ifInAppsOrSysAppThenPerms);auto.
    destruct H4.
    unfold grantPerm.
    unfold grantAuto_post;unfold grantPermission;simpl.
    rewrite H4.
    split;intros.
    elim (classic (a=a'));intros.

    exists (p::x0).
    split.
    rewrite H6.
    rewrite<- (addAndApply idApp_eq a' (p::x0) (perms (state s))).
    auto.
    rewrite H6 in H4.
    rewrite H4 in H5.
    assert (x0=lPerm).
    inversion H5.
    auto.
    intros.
    rewrite H7.
    apply in_cons.
    auto.

    exists lPerm.
    split.
    rewrite overrideNotEq; auto.
    intros.
    auto.

    split;intros.
    elim (classic (a=a'));intro.

    exists x0.
    split.
    rewrite H6 in H4.
    auto.
    intros.
    split;auto.
    rewrite H6 in H5.
    rewrite <-(addAndApply idApp_eq a' (p::x0) (perms (state s))) in H5.
    inversion H5.
    rewrite <-H10 in H7.
    inversion H7.
    auto.
    contradiction.

    exists lPerm'.
    rewrite overrideNotEq in H5.
    split;auto.
    intros;contradiction.
    auto.
    split.
    exists (p::x0).
    split.
    symmetry.
    apply addAndApply.
    apply in_eq.
    apply addPreservesCorrectness.
    apply permsCorrect;auto.
  - unfold grantAuto_post. simpl. repeat split; auto.
Qed.

Lemma existsManifest : forall (a: idApp) (s: System) (p: Perm),
  negb (InBool Perm Perm_eq p (permsInUse a s)) = false ->
    exists m : Manifest, isManifestOfApp a m s /\ In p (use m).
Proof.
  intros a s p H.
  rewrite negb_false_iff in H.
  unfold InBool in H.
  rewrite existsb_exists in H.
  destruct H as [perm H].
  destruct H as [H H0].
  unfold permsInUse in H.

  unfold isManifestOfApp.
  case_eq (map_apply idApp_eq (manifest (environment s)) a); intros m H1; rewrite H1 in *.
  exists m.
  destruct Perm_eq in H0.
  rewrite e.
  split;auto.
  discriminate H0.

  case_eq ((map (fun sysapp : SysImgApp => use (manifestSI sysapp)) (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s)))));intros; rewrite H2 in *;simpl in H.
  destruct H.
  assert (In l (map (fun sysapp : SysImgApp => use (manifestSI sysapp)) (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s))))).
  rewrite H2.
  apply in_eq.
  rewrite in_map_iff in H3.
  destruct H3 as [sysImg H3].
  destruct H3.
  exists (manifestSI sysImg).
  split.
  right.
  exists sysImg.
  rewrite filter_In in H4.
  destruct H4.
  destruct idApp_eq in H5.
  rewrite e;auto.
  discriminate H5.
  destruct Perm_eq in H0.
  rewrite e.
  rewrite H3 in *.
  auto.
  discriminate H0.
Qed.

Lemma notPreGrantAutoThenError : forall (s:System) (a:idApp) (p:Perm), ~(pre (grantAuto p a) s) -> validstate s -> exists ec : ErrorCode, response (step s (grantAuto p a)) = error ec /\ ErrorMsg s (grantAuto p a) ec /\ s = system (step s (grantAuto p a)).
Proof.
    intros.
    simpl.
    simpl in H.
    unfold pre_grantAuto in H.
    unfold grantAuto_safe.
    unfold grantAuto_pre.

    case_eq (negb (InBool Perm Perm_eq p (permsInUse a s)));intros.
    exists perm_not_in_use.
    split;auto.
    split;auto.
    rewrite negb_true_iff in H1.
    invertBool H1.
    intro.
    apply H1.
    destruct H2.
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    unfold permsInUse.
    destruct H2.
    rewrite H2.
    destruct Perm_eq;auto.

    case_eq (negb (InBool Perm Perm_eq p (getAllPerms s)));intros.
    exists no_such_perm.
    split;auto.
    split;auto.
    rewrite negb_true_iff in H2.
    invertBool H2.
    intro;apply H2.
    unfold getAllPerms.
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    rewrite in_app_iff.
    split.
    destruct H3.
    left.
    apply isSysPermCorrect;auto.
    right.
    apply inUsrDefPermsIff;auto.
    destruct Perm_eq;auto.

    case_eq (InBool Perm Perm_eq p (grantedPermsForApp a s));intros.
    exists perm_already_granted.
    split;auto.
    split;auto.
    unfold InBool in H3.
    rewrite existsb_exists in H3.
    destruct H3.
    destruct H3.
    unfold grantedPermsForApp in H3.
    case_eq (map_apply idApp_eq (perms (state s)) a);intros; rewrite H5 in H3.
    exists l.
    destruct Perm_eq in H4.
    rewrite e;auto.
    discriminate H4.
    inversion H3.
    case_eq ((if permLevel_eq (pl p) dangerous then false else true));intros.
    exists perm_not_dangerous.
    split;auto.
    split;auto.
    destruct permLevel_eq in H4.
    discriminate H4.
    auto.

    case_eq (negb (isSomethingBool idGrp (maybeGrp p))); intros.
    exists perm_not_grouped. simpl.
    split; auto. split; auto.
    rewrite negb_true_iff in H5.
    unfold isSomethingBool in H5.
    destruct (maybeGrp p); auto. inversion H5.

    case_eq (negb (groupIsGranted a p s)); intros.
    simpl. exists cannot_auto_grant. split; auto.

    rewrite negb_true_iff in H6.
    rewrite negb_false_iff in H5.
    unfold isSomethingBool in H5.

    case_eq (maybeGrp p);intros.
  - unfold groupIsGranted in H6.
    clear H5. rewrite H7 in H6.
    case_eq (map_apply idApp_eq (grantedPermGroups (state s)) a); intros.
 -- rewrite H5 in H6. split; auto.
    exists i, l. repeat split;auto.
    unfold not. intros.
    clear H5.
    induction l. inversion H8.
    simpl in H6.
    destruct (idGrp_eq i a0).
    inversion H6.
    simpl in H6, H8.
    destruct H8.
    symmetry in H5. contradiction.
    apply IHl; auto.
 -- apply existsManifest in H1.
    destruct H1 as [m [H1 _]].
    assert (vs:= H0).
    destructVS H0.
    destructSC statesConsistencyVS a.
    destruct grantedPermGroupsSC.
    assert (exists l : list idGrp,
       map_apply idApp_eq (grantedPermGroups (state s)) a = Value idApp l).
    destruct H1. clear mfstSC certSC defPermsSC permsSC.
    apply ifManifestThenInApps in H1; auto.
    apply H0. right. destruct H1 as [sysImg [H9 [H10 H11]]].
    exists sysImg; auto.
    destruct H9. rewrite H5 in H9. inversion H9.
  - unfold groupIsGranted in H6. rewrite H7 in H5.
    inversion H5.
  - destruct H.
    split.
    apply existsManifest; auto.

    split.
    rewrite negb_false_iff in H2.
    unfold InBool in H2.
    rewrite existsb_exists in H2.
    destruct H2.
    destruct H.
    destruct Perm_eq in H2.
    rewrite e.
    unfold getAllPerms in H.
    rewrite in_app_iff in H.
    destruct H.
    left.
    apply isSysPermCorrect;auto.
    right.
    apply inUsrDefPermsIff;auto.
    discriminate H2.
    split.
    invertBool H3.
    intro;apply H3.
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    destruct H.
    destruct H.
    unfold grantedPermsForApp.
    rewrite H.
    destruct Perm_eq;auto.
    split.
    destruct permLevel_eq in H4.
    auto.
    discriminate H4.
    rewrite negb_false_iff in H5.
    rewrite negb_false_iff in H6.
    unfold isSomethingBool in H5.
    case_eq (maybeGrp p); intros.
 -- unfold groupIsGranted in H6.
    rewrite H in H6.
    case_eq (map_apply idApp_eq (grantedPermGroups (state s)) a);intros.
    exists i, l. repeat split;auto.
    rewrite H7 in H6.
    unfold InBool in H6.
    rewrite existsb_exists in H6.
    destruct H6 as [i' [H6 H8]].
    destruct (idGrp_eq i i').
    rewrite e. auto.
    inversion H8.
    rewrite H7 in H6. inversion H6.
 -- rewrite H in H5. inversion H5.
Qed.

Lemma grantAutoIsSound : forall (s:System) (a:idApp) (p:Perm),
        validstate s -> exec s (grantAuto p a) (system (step s (grantAuto p a))) (response (step s (grantAuto p a))).
Proof.
    intros.
    unfold exec.
    split.
    auto.
    elim (classic (pre (grantAuto p a) s));intro.
    left.
    assert(grantAuto_pre p a s = None).
    unfold grantAuto_pre.
    destruct H0.

    assert (InBool Perm Perm_eq p (permsInUse a s) = true).
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    split.
    destruct H0.
    destruct H0.
    unfold permsInUse.
    destruct H0.
    rewrite H0.
    auto.
    case_eq (map_apply idApp_eq (manifest (environment s)) a);intros.
    apply ifManifestThenInApps in H3;auto.
    destruct H0.
    assert (~(In a (apps (state s)) /\ In x0 (systemImage (environment s)) /\ idSI x0 = a)).
    apply sysAppInApps;auto.
    destruct_conj H0.
    destruct H4;auto.
    destruct H0.
    destruct_conj H0.
    assert (In x0 (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s)))).
    rewrite filter_In.
    rewrite H0.
    destruct idApp_eq;auto.
    remember (fun sysapp : SysImgApp => use (manifestSI sysapp)) as theFun.
    remember (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s))) as theList.
    assert ((hd nil (map theFun theList)) = theFun (hd defaultSysApp theList )).
    apply ifNotNilHdMap.
    apply inNotNilExists.
    exists x0;auto.
    rewrite H7.
    rewrite HeqtheFun.
    assert ((hd defaultSysApp theList)=x0).
    rewrite HeqtheList in H5.
    assert (exists x0, In x0 (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s)))).
    exists x0;auto.
    apply ifExistsFilter with (dflt:=defaultSysApp) in H8.
    rewrite HeqtheList.
    remember (hd defaultSysApp (filter (fun sysapp : SysImgApp => if idApp_eq a (idSI sysapp) then true else false) (systemImage (environment s)))) as theHead.
    destruct H8.
    apply (notDupSysAppVS s);auto.
    rewrite H0 in *.
    destruct idApp_eq in H9;auto.
    discriminate H9.

    rewrite H8;rewrite H6;auto.

    destruct Perm_eq.
    auto.
    auto.
    rewrite H2.
    assert (negb true=false).
    rewrite negb_false_iff;auto.
    rewrite H3.

    assert (InBool Perm Perm_eq p (getAllPerms s) = true).
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    split.
    destruct H1.
    unfold getAllPerms.
    apply in_app_iff.
    destruct H1.
    left.
    apply isSysPermCorrect;auto.
    right.
    unfold usrDefPerms.
    apply in_concat.
    unfold usrDefPerm in H1.
    destruct H1.
    destruct H1.
    destruct H1.
    destruct H1.
    exists x0.
    split.
    apply in_app_iff.
    left.
    apply inGetValuesBack.
    exists (map_apply idApp_eq (defPerms (environment s)) x).
    split.
    apply in_map_iff.
    exists x.
    split.
    auto.
    apply (ifDefPermsThenInApps s H x x0);auto.
    auto.
    auto.
    destruct H1.
    destruct H1.
    exists (defPermsSI x).
    split.
    apply in_app_iff.
    right.
    apply in_map_iff.
    exists x.
    split;auto.
    auto.
    destruct Perm_eq.
    auto.
    destruct n;auto.
    rewrite H4.
    assert (negb true=false).
    rewrite negb_false_iff;auto.
    rewrite H3.

    assert (InBool Perm Perm_eq p (grantedPermsForApp a s) <> true).
    unfold InBool.
    unfold not;intros.
    rewrite existsb_exists in H6.
    destruct H6.
    destruct H6.
    destruct H1.
    apply H8.
    unfold grantedPermsForApp in H6.
    case_eq (map_apply idApp_eq (perms (state s)) a);intros; rewrite H9 in H6.
    exists l.
    destruct Perm_eq in H7.
    rewrite<- e in H6.
    split;auto.
    discriminate H7.
    destruct H6.
    rewrite not_true_iff_false in H6.
    rewrite H6.
    destruct_conj H1.
    destruct permLevel_eq.
    destruct H10 as [g [lGroup [H10 H11]]].
    rewrite H10. simpl.
    destruct H11 as [H11 H12].
    unfold groupIsGranted.
    rewrite H10, H11.
    case_eq (negb (InBool idGrp idGrp_eq g lGroup)); intros.
    rewrite negb_true_iff in H9.
    clear H11.
    induction lGroup. inversion H12.
    simpl in H12, H9.
    destruct (idGrp_eq g a0).
    inversion H9.
    destruct H12.
    symmetry in H11. contradiction.
    simpl in H9. apply IHlGroup; auto.
    auto.
    contradiction.
    unfold step;simpl.
    unfold grantAuto_safe;simpl.
    rewrite H1;simpl.
    split;auto. split; auto.
    apply postGrantAutoCorrect;auto.
    right.
    apply (notPreGrantAutoThenError);auto.
Qed.
End GrantAuto.


Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.
Require Import EffState.
Require Import Ref.
Require Import ESoundS.

Open Scope string_scope.

Section Test_Section.

  Definition D := UnitType :+: RefType.

  Definition E := RefE.

  Definition V := StuckValue :+: LocValue :+: UnitValue.

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{State_ME : StateM ME (list (Value V))}.
  Context {Fail_ME : FailMonad ME}.

  Definition WFV := (WFValue_Unit D V _) ::+:: (WFValue_Loc D V _).
  Definition WFVM := (WFValueM_base D V MT ME _ WFV) ::+::
    (WFValueM_State D V MT ME _
      (TypContextCE := DType_Env_CE _)
      (TypContext_WFE := DType_Env_WFE _ _ WFV)).

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D MT) (E).
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

  Lemma eval_Sound :
    forall (Sigma : Env (DType D)) (e : Exp E) (T : DType D) (env : Env (Value V)),
      WF_Environment D V _ WFV Sigma env Sigma ->
      typeof D E MT (proj1_sig e) = return_ T ->
      exists v : Value V,
        exists env' : Env (Value V),
          exists Sigma' : Env (DType D),
            (put env) >> evalM V E ME (proj1_sig e) =
            put env' >> return_ (M := ME) v /\
            WFValueC D V _ WFV Sigma' v T.
  Proof.
    intros; eapply eval_State_Sound with (WFVM' := WFVM);
      eauto 10 with typeclass_instances.
    eauto 15 with typeclass_instances.
    eapply Ref_eval_soundness'' with (WFV := WFV) (WFVM := WFVM)
      (TypContextCE :=  _) (TypContext_S := _)
      (TypContext_WFE := DType_Env_WFE _ _ WFV);
      eauto 250 with typeclass_instances.
    simpl; eauto.
  Qed.

  Eval compute in ("Soundness for 'References' Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import CoqlibC.
Require Import Simulation.
Require Import LinkingC.
Require Import Skeleton.
Require Import Values.
Require Import JMeq.
Require Import Smallstep.
Require Import Integers.
Require Import Events.

Require Import Skeleton ModSem Mod Sem.
Require Import SimSymb SimMem SimMod SimModSem SimProg (* SimLoad *) SimProg.
Require Import SemProps Ord.
Require Import Sound Preservation.
Require Import Memory.

Set Implicit Arguments.

Section ADQSOUND.

  Context `{SM: SimMem.class}.
  Context {SS: SimSymb.class SM}.
  Context `{SU: Sound.class}.

  Variable pp: ProgPair.t.
  Hypothesis SIMPROG: ProgPair.sim pp.
  Let p_src := (ProgPair.src pp).
  Let p_tgt := (ProgPair.tgt pp).
  Hypothesis (WFSKSRC: forall md (IN: In md p_src), <<WF: Sk.wf md>>).
  Hypothesis (WFSKTGT: forall md (IN: In md p_tgt), <<WF: Sk.wf md>>).

  Variable sk_link_src sk_link_tgt: Sk.t.
  Hypothesis LINKSRC: (link_sk p_src) = Some sk_link_src.
  Hypothesis LINKTGT: (link_sk p_tgt) = Some sk_link_tgt.
  Let sem_src := Sem.sem p_src.
  Let sem_tgt := Sem.sem p_tgt.

  Let skenv_link_src := (Sk.load_skenv sk_link_src).
  Let skenv_link_tgt := (Sk.load_skenv sk_link_tgt).

  Variable ss_link: SimSymb.t.
  Hypothesis (SIMSKENV: exists sm, SimSymb.sim_skenv sm ss_link skenv_link_src skenv_link_tgt).

  Hypothesis INCLSRC: forall mp (IN: In mp pp), SkEnv.includes skenv_link_src (Mod.sk mp.(ModPair.src)).
  Hypothesis INCLTGT: forall mp (IN: In mp pp), SkEnv.includes skenv_link_tgt (Mod.sk mp.(ModPair.tgt)).
  Hypothesis SSLE: forall mp (IN: In mp pp), SimSymb.le mp.(ModPair.ss) ss_link.

  Let WFSKLINKSRC: Sk.wf sk_link_src. eapply link_list_preserves_wf_sk; et. Qed.
  Let WFSKLINKTGT: Sk.wf sk_link_tgt. eapply link_list_preserves_wf_sk; et. Qed.

  (* Let ge: Ge.t := sem_src.(Smallstep.globalenv). *)

  Inductive sound_ge (su0: Sound.t) (m0: mem): Prop :=
  | sound_ge_intro
      (GE: Forall (fun ms => su0.(Sound.skenv) m0 ms.(ModSem.skenv) /\ su0.(Sound.skenv) m0 ms.(ModSem.skenv_link))
                  (fst sem_src.(Smallstep.globalenv)))
  .

  Lemma lepriv_preserves_sound_ge
        m0 su0 su1
        (GE: sound_ge su0 m0)
        (LE: Sound.lepriv su0 su1):
      <<GE: sound_ge su1 m0>>.
  Proof.
    inv GE. econs; eauto. rewrite Forall_forall in *. ii. split; eapply Sound.skenv_lepriv; try apply GE0; eauto.
  Qed.

  Lemma hle_preserves_sound_ge
        m0 su0 su1
        (WF: Sound.wf su0)
        (GE: sound_ge su0 m0)
        (LE: Sound.hle su0 su1):
      <<GE: sound_ge su1 m0>>.
  Proof.
    eapply lepriv_preserves_sound_ge; eauto. eapply Sound.hle_lepriv; et.
  Qed.

  Lemma mle_preserves_sound_ge
        m0 m1 su0
        (GE: sound_ge su0 m0)
        (LE: Sound.mle su0 m0 m1):
      <<GE: sound_ge su0 m1>>.
  Proof.
    inv GE. econs; eauto. rewrite Forall_forall in *. ii. split; eapply Sound.skenv_mle; try apply GE0; eauto.
  Qed.

  (* stack can go preservation when su0 is given *)
  Inductive sound_stack (args: Args.t): list Frame.t -> Prop :=
  | sound_stack_nil
      (EXSU: exists su_ex, Sound.args su_ex args /\ sound_ge su_ex (Args.get_m args)):
      sound_stack args []
  | sound_stack_cons
      args_tail tail ms lst0
      (TL: sound_stack args_tail tail)
      (FORALLSU: forall su0
          (SUARGS: Sound.args su0 args_tail)
          (SUGE: sound_ge su0 (Args.get_m args_tail)),
          (<<HD: forall
                 sound_state_all
                 (PRSV: local_preservation_noguarantee ms sound_state_all),
                 <<SUST: sound_state_all su0 (Args.get_m args_tail) lst0>>>>)
          /\
          (<<K: forall
                 sound_state_all
                 (PRSV: local_preservation_noguarantee ms sound_state_all),
                 (* (<<SUST: sound_state_all su0 args.(Args.get_m) lst0>>) *)
                 (* /\ *)
                 exists su_gr,
                   (<<ARGS: Sound.args su_gr args>>) /\
                   (<<LE: Sound.lepriv su0 su_gr>>) /\
                   (<<K: forall retv lst1 su_ret
                       (LE: Sound.hle su_gr su_ret)
                       (SURETV: Sound.retv su_ret retv)
                       (MLE: Sound.mle su_gr (Args.get_m args) (Retv.get_m retv))
                       (AFTER: ms.(ModSem.after_external) lst0 retv lst1),
                       (* sound_state_all su0 args.(Args.get_m) lst1>>) *)
                       sound_state_all su0 (Args.get_m args_tail) lst1>>)
             >>)
          /\
          (<<MLE: Sound.mle su0 (Args.get_m args_tail) (Args.get_m args)>>)
      )
      (EXSU: exists su_ex, Sound.args su_ex args_tail /\ sound_ge su_ex (Args.get_m args_tail))
      (EX: exists sound_state_ex, local_preservation ms sound_state_ex):
      sound_stack args ((Frame.mk ms lst0) :: tail).

  Inductive sound_state: state -> Prop :=
  | sound_state_normal
      args_tail tail ms lst0 m_arg
      (TL: sound_stack args_tail tail)
      (EXSU: exists su_ex, Sound.args su_ex args_tail /\ sound_ge su_ex m_arg)
      (FORALLSU: forall su0
          (SUARGS: Sound.args su0 args_tail)
          (SUGE: sound_ge su0 (Args.get_m args_tail)),
          (<<HD: forall
              sound_state_all
              (PRSV: local_preservation_noguarantee ms sound_state_all),
              <<SUST: sound_state_all su0 m_arg lst0>>>>))
      (EX: exists sound_state_ex, local_preservation ms sound_state_ex)
      (ABCD: (Args.get_m args_tail) = m_arg)
    :
      sound_state (State ((Frame.mk ms lst0) :: tail))
  | sound_state_call
      m_tail frs args
      (* (ARGS: Sound.args su0 args) *)
      (STK: sound_stack args frs)
      (* (MLE: Sound.mle su0 m_tail args.(Args.get_m)) *)
      (EQ: (Args.get_m args) = m_tail)
      (EXSU: exists su_ex, Sound.args su_ex args /\ sound_ge su_ex m_tail):
      sound_state (Callstate args frs).

  Lemma sound_init
        st0
        (INIT: sem_src.(Smallstep.initial_state) st0):
    <<SU: sound_state st0>>.
  Proof.
    inv INIT. clarify. clear skenv_link_tgt p_tgt skenv_link_tgt sem_tgt LINKTGT INCLTGT WFSKTGT SIMSKENV.
    hexploit Sound.init_spec; eauto. i; des. esplits; eauto.
    assert(WFSKE: SkEnv.wf (Sk.load_skenv sk_link_src)).
    { eapply SkEnv.load_skenv_wf; et. }
    assert(GE: sound_ge su_init m_init).
    { econs. rewrite Forall_forall. intros ? IN. ss. des_ifs. u in IN.
      rewrite in_map_iff in IN. des; ss; clarify.
      + s. split; try eapply Sound.system_skenv; eauto.
      + assert(INCL: SkEnv.includes (Sk.load_skenv sk_link_src) (Mod.sk x0)).
        { unfold p_src in IN0. unfold ProgPair.src in *. rewrite in_map_iff in IN0. des. clarify. eapply INCLSRC; et. }
        split; ss.
        * eapply Sound.skenv_project; eauto.
          { eapply link_load_skenv_wf_mem; et. }
          rewrite <- Mod.get_modsem_skenv_spec; ss. eapply SkEnv.project_impl_spec; et.
        * rewrite Mod.get_modsem_skenv_link_spec. ss.
    }
    econs; eauto. econs; eauto.
    (* - eapply Sound.greatest_adq; eauto. *)
    (* - econs; eauto. *)
    (* - eapply vle_preserves_sound_ge; eauto. *)
    (*   eapply Sound.greatest_adq; eauto. *)
  Unshelve.
    all: ss.
  Qed.

  Lemma sound_progress
        st0 tr st1
        (SUST: sound_state st0)
        (STEP: Step sem_src st0 tr st1):
      <<SUST: sound_state st1>>.
  Proof.
    inv STEP.
    - (* CALL *)
      inv SUST. ss. des. exploit FORALLSU; eauto. { eapply local_preservation_noguarantee_weak; eauto. } intro T; des.
      inv EX. exploit CALL; eauto. i; des. esplits; eauto. econs; eauto; cycle 1.
      + esplits; eauto. eapply lepriv_preserves_sound_ge; eauto.
        { eapply mle_preserves_sound_ge; eauto. }
      + econs; eauto; cycle 1.
        { esplits; eauto. econs; eauto. }
        ii. esplits; eauto.
        * ii. exploit FORALLSU; try apply SUARGS; eauto.
        * ii. exploit FORALLSU; try apply SUARGS; eauto. intro U; des.
          inv PRSV. exploit CALL0; eauto. i; des. esplits; eauto. ii. eapply K0; eauto.
        * exploit FORALLSU; eauto.
          { eapply local_preservation_noguarantee_weak; eauto. econs; eauto. }
          i; des. exploit CALL; eauto. i; des. ss.
    - (* INIT *)
      inv SUST. ss. des_ifs. esplits; eauto. econs; eauto.
      + ii. esplits; eauto.
        * ii. inv PRSV. inv SUGE. rewrite Forall_forall in *.
          exploit GE; eauto. { ss. des_ifs. eapply MSFIND. } intro T; des. eapply INIT0; et.
      + inv MSFIND. ss. rr in SIMPROG. rewrite Forall_forall in *. des; clarify.
        { eapply system_local_preservation. }
        u in MODSEM. rewrite in_map_iff in MODSEM. des; clarify. rename x into md_src.
        assert(exists mp, In mp pp /\ mp.(ModPair.src) = md_src).
        { clear - MODSEM0. rr in pp. rr in p_src. subst p_src. rewrite in_map_iff in *. des. eauto. }
        des. exploit SIMPROG; eauto. intros MPSIM. inv MPSIM.
        destruct SIMSKENV. exploit SIMMS.
        { eapply INCLSRC; et. }
        { eapply INCLTGT; et. }
        { eapply SkEnv.load_skenv_wf; et. }
        { eapply SkEnv.load_skenv_wf; et. }
        { eapply SSLE; eauto. }
        { eauto. }
        intro SIM; des. inv SIM. ss. esplits; eauto.
    - (* INTERNAL *)
      inv SUST. ss. esplits; eauto. econs; eauto. i. des.
      exploit FORALLSU; eauto. { eapply local_preservation_noguarantee_weak; eauto. } intro U; des. esplits; eauto. i. ss. inv PRSV.
      eapply STEP; eauto.
      + eapply FORALLSU; eauto. econs; eauto.
      + split; ii; ModSem.tac.
    - (* RETURN *)
      inv SUST. ss. rename ms into ms_top. rename args_tail into args_tail_top.
      inv TL. ss. unfold Frame.update_st. s. des. esplits; eauto. econs; eauto. ii. esplits; eauto.
      + ii. exploit FORALLSU0; eauto. i; des. exploit K; eauto. i; des. inv EX.
        exploit RET; eauto.
        { eapply FORALLSU; eauto.
          { eapply lepriv_preserves_sound_ge. { eapply mle_preserves_sound_ge; eauto. } eauto. }
          { eapply local_preservation_noguarantee_weak; eauto. econs; et. } }
        i; des.
        eapply K0; eauto.
  Unshelve.
    all: ss.
  Qed.

  (* Lemma sound_progress_star *)
  (*       st0 tr st1 *)
  (*       (SUST: sound_state st0) *)
  (*       (STEP: Star sem_src st0 tr st1): *)
  (*     <<SUST: sound_state st1>>. *)
  (* Proof. *)
  (*   induction STEP. *)
  (*   - esplits; eauto. *)
  (*   - clarify. i. exploit sound_progress; eauto. *)
  (* Qed. *)

  (* Lemma sound_progress_plus *)
  (*       st0 tr st1 *)
  (*       (SUST: sound_state st0) *)
  (*       (STEP: Plus sem_src st0 tr st1): *)
  (*     <<SUST: sound_state st1>>. *)
  (* Proof. *)
  (*   eapply sound_progress_star; eauto. eapply plus_star; eauto. *)
  (* Qed. *)

  Theorem preservation: @preservation sem_src sound_state.
  Proof.
    econs.
    - eapply sound_init.
    - eapply sound_progress.
  Qed.

End ADQSOUND.