(*

  Copyright 2014 Cornell University
  Copyright 2015 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 Import terms2.

Lemma deq_nvar_refl :
  forall v, deq_nvar v v = left eq_refl.
Proof.
  introv.
  destruct (deq_nvar v v); sp.
  generalize (@UIPReflDeq NVar deq_nvar v e); intro k.
  rw k; auto.
Qed.

Ltac boolvar_step :=
  match goal with
    | [ |- context[beq_var ?v ?v] ] => rewrite <- beq_var_refl
    | [ |- context[deq_nvar ?v ?v] ] => rewrite deq_nvar_refl
    | [ |- context[deq_nvar ?v1 ?v2] ] =>
      destruct (deq_nvar v1 v2);[try(subst v1)|];try(complete auto)
    | [ |- context[memvar ?v ?s] ] =>
        let name := fresh "b" in
          remember (memvar v s) as name;
        match goal with
          | [ H : name = memvar v s |- _ ] =>
              symmetry in H;
              destruct name;
              [ rewrite fold_assert in H;
                  trw_h assert_memvar H;
                  simpl in H
              | trw_h not_of_assert H;
                  trw_h assert_memvar H;
                  simpl in H
              ]
        end
    | [ |- context[beq_var ?v1 ?v2] ] =>
        let name := fresh "b" in
          remember (beq_var v1 v2) as name;
        match goal with
          | [ H : name = beq_var v1 v2 |- _ ] =>
            destruct name;
              [ apply beq_var_true in H; try subst
              | apply beq_var_false in H
              ]
        end

    | [ H : context[beq_var ?v ?v] |- _ ] => rewrite <- beq_var_refl in H
    | [ H : context[deq_nvar ?v ?v] |- _ ] => rewrite deq_nvar_refl in H
    | [ H : context[deq_nvar ?v1 ?v2] |- _ ] =>
      destruct (deq_nvar v1 v2);[try(subst v1)|];try(complete auto)
    | [ H : context[memvar ?v ?s] |- _ ] =>
      let name := fresh "b" in
      remember (memvar v s) as name;
        match goal with
          | [ J : name = memvar v s |- _ ] =>
            symmetry in J;
              destruct name;
              [ rewrite fold_assert in J;
                trw_h assert_memvar J;
                simpl in J
              | trw_h not_of_assert J;
                trw_h assert_memvar J;
                simpl in J
              ]
        end
    | [ H : context[beq_var ?v1 ?v2] |- _ ] =>
        let name := fresh "b" in
        remember (beq_var v1 v2) as name;
          match goal with
            | [ J : name = beq_var v1 v2 |- _ ] =>
              destruct name;
                [ apply beq_var_true in J; try subst
                | apply beq_var_false in J
                ]
          end

    | [ |- context[if ?x then _ else _] ] =>
      match type of x with
        | {_} + {_} => destruct x
      end
    | [ |- context[if ?x then _ else _] ] =>
      match type of x with
        | sum _ _ => destruct x
      end
    | [ |- context[if ?x then _ else _] ] =>
      match type of x with
        | decidable _ => destruct x
      end
    | [ |- context[d2b ?x] ] =>
      match type of x with
        | decidable _ => destruct x
      end

    | [H : context[if ?x then _ else _] |- _ ] =>
      match type of x with
        | {_} + {_} => destruct x
      end
    | [H : context[if ?x then _ else _] |- _ ] =>
      match type of x with
        | sum _ _ => destruct x
      end
    | [H : context[if ?x then _ else _] |- _ ] =>
      match type of x with
        | decidable _ => destruct x
      end
    | [H : context[d2b ?x] |- _ ] =>
      match type of x with
        | decidable _ => destruct x
      end

    | [ |- context[deq_nat           ?x ?y] ] => destruct (deq_nat           x y)
    | [ |- context[String.string_dec ?x ?y] ] => destruct (String.string_dec x y)
    | [ |- context[opsign_dec        ?x ?y] ] => destruct (opsign_dec        x y)
    | [ |- context[Z_noteq_dec       ?x ?y] ] => destruct (Z_noteq_dec       x y)
    | [ |- context[parameter_dec     ?x ?y] ] => destruct (parameter_dec     x y)
    | [ |- context[parameters_dec    ?x ?y] ] => destruct (parameters_dec    x y)

    | [ H : context[deq_nat           ?x ?y] |- _ ] => destruct (deq_nat           x y)
    | [ H : context[String.string_dec ?x ?y] |- _ ] => destruct (String.string_dec x y)
    | [ H : context[opsign_dec        ?x ?y] |- _ ] => destruct (opsign_dec        x y)
    | [ H : context[Z_noteq_dec       ?x ?y] |- _ ] => destruct (Z_noteq_dec       x y)
    | [ H : context[parameter_dec     ?x ?y] |- _ ] => destruct (parameter_dec     x y)
    | [ H : context[parameters_dec    ?x ?y] |- _ ] => destruct (parameters_dec    x y)

    | [ H : context[if memberb _ _ _ then _ else _] |- _ ] => rewrite memberb_din in H
    | [ |- context[if memberb _ _ _ then _ else _] ] => rewrite memberb_din
  end.

Ltac boolvar := repeat boolvar_step.

Lemma fold_mk_prod {o} :
  forall (a : @NTerm o) v b,
    v = newvar b
    -> mk_product a v b = mk_prod a b.
Proof.
  introv e; subst; sp.
Qed.

Lemma fold_mk_fun {o} :
  forall (a : @NTerm o) v b,
    v = newvar b
    -> mk_function a v b = mk_fun a b.
Proof.
  introv e; subst; sp.
Qed.

Lemma fold_mk_ufun {o} :
  forall (a : @NTerm o) v b,
    v = newvar b
    -> mk_isect a v b = mk_ufun a b.
Proof.
  introv e; subst; sp.
Qed.

Lemma int_zero {o} :
  @mk_integer o 0 = mk_zero.
Proof. sp. Qed.

Definition absolute_value {o} (t : @NTerm o) :=
  mk_less t mk_zero (mk_minus t) t.

Ltac fold_terms_step :=
  match goal with
    | [ |- context[@oterm ?p (Can NAxiom) []] ] => fold (@mk_axiom p)
    | [ |- context[@oterm ?p (Can NInt) []] ] => fold (@mk_int p)
    | [ |- context[@oterm ?p (Can (NUTok ?a)) []] ] => fold (@mk_utoken p a)
    | [ |- context[@oterm ?p (Can (NTok ?a)) []] ] => fold (@mk_token p a)
    | [ |- context[@mk_approx ?p mk_axiom mk_axiom] ] => fold (@mk_true p)
    | [ |- context[@mk_approx ?p mk_axiom mk_bot] ] => fold (@mk_false p)
    | [ |- context[@mk_lam ?p nvarx (mk_var nvarx)] ] => fold (@mk_id p)
    | [ |- context[@mk_fix ?p mk_id] ] => fold (@mk_bottom p)
    | [ |- context[@mk_bottom ?p] ] => fold (@mk_bot p)
    | [ |- context[@bterm ?p [] ?x] ] => fold (@nobnd p x)
    | [ |- context[@vterm ?p ?v] ] => fold (@mk_var p v)
    | [ |- context[@oterm ?p (Can (Nint ?z)) []] ] => fold (@mk_integer p z)
    | [ |- context[@mk_integer ?p (Z.of_nat ?n)] ] => fold (@mk_nat p n)
    | [ |- context[@mk_nat ?p 0] ] => fold (@mk_zero p)
    | [ |- context[@oterm ?p (Can (Nseq ?f)) []] ] => fold (@mk_nseq p f)
    | [ |- context[oterm (Can NLambda) [bterm [?v] ?t]] ] => fold (mk_lam v t)
    | [ |- context[oterm (Can NApprox) [nobnd ?a, nobnd ?b]] ] => fold (mk_approx a b)
    | [ |- context[oterm (Can NEquality) [nobnd ?a, nobnd ?b, nobnd ?c]] ] => fold (mk_equality a b c)
    | [ |- context[oterm (Can NREquality) [nobnd ?a, nobnd ?b, nobnd ?c]] ] => fold (mk_requality a b c)
    | [ |- context[oterm (Can NFreeFromAtom) [nobnd ?a, nobnd ?b, nobnd ?c]] ] => fold (mk_free_from_atom a b c)
    | [ |- context[oterm (Can NEFreeFromAtom) [nobnd ?a, nobnd ?b, nobnd ?c]] ] => fold (mk_efree_from_atom a b c)
    | [ |- context[oterm (Can NFreeFromAtoms) [nobnd ?a, nobnd ?b]] ] => fold (mk_free_from_atoms a b)
    | [ |- context[oterm (Can NFunction) [nobnd ?a, bterm [?v] ?b]] ] => fold (mk_function a v b)
    | [ |- context[oterm (Can NProduct) [nobnd ?a, bterm [?v] ?b]] ] => fold (mk_product a v b)
    | [ |- context[oterm (Can NUnion) [nobnd ?x, nobnd ?y]] ] => fold (mk_union x y)
    | [ |- context[oterm (Can NEUnion) [nobnd ?x, nobnd ?y]] ] => fold (mk_eunion x y)
    | [ |- context[oterm (Can NTExc) [nobnd ?x, nobnd ?y]] ] => fold (mk_texc x y)
    | [ |- context[oterm (NCan NApply) [nobnd ?x, nobnd ?y]] ] => fold (mk_apply x y)
    | [ |- context[oterm (NCan NEApply) [nobnd ?x, nobnd ?y]] ] => fold (mk_eapply x y)
(*    | [ |- context[oterm (NCan (NApseq ?f)) [nobnd ?x] ] ] => fold (mk_apseq f x)*)
    | [ |- context[oterm (NCan NDecide) [nobnd ?d, bterm [?x] ?f, bterm [?y] ?g]] ] => fold (mk_decide d x f y g)
    | [ |- context[oterm (NCan NSpread) [nobnd ?p, bterm [?x,?y] ?f]] ] => fold (mk_spread p x y f)
    | [ |- context[oterm (NCan NTryCatch) [nobnd ?a, nobnd ?b, bterm [?v] ?c]] ] => fold (mk_try a b v c)
    | [ |- context[oterm (NCan NFix) [nobnd ?x]] ] => unfold nobnd; fold (mk_fix x); try (fold nobnd)
    | [ |- context[oterm (NCan NCbv) [nobnd ?a, bterm [?v] ?b]] ] => fold (mk_cbv a v b)
    | [ |- context[oterm (NCan NFresh) [bterm [?v] ?b]] ] => fold (mk_fresh v b)
    | [ |- context[oterm (NCan (NCompOp CompOpLess)) [nobnd ?a, nobnd ?b, nobnd ?c, nobnd ?d]] ] => fold (mk_less a b c d)
    | [ |- context[oterm Exc [nobnd ?a, nobnd ?x]] ] => fold (mk_exception a x)
    | [ |- context[oterm (Can NIsect) [nobnd ?a, bterm [?v] ?b] ] ] => fold (mk_isect a v b)
    | [ |- context[oterm (Can NSet) [nobnd ?a, bterm [?v] ?b] ] ] => fold (mk_set a v b)
    | [ |- context[oterm (NCan NMinus) [nobnd ?a] ] ] => fold (mk_minus a)
    | [ |- context[mk_equality ?t ?t ?T] ] => fold (mk_member t T)
    | [ |- context[mk_less ?t mk_zero (mk_minus ?t) ?t] ] => fold (absolute_value t)
    | [ |- context[mk_less ?a ?b mk_true mk_false] ] => fold (mk_less_than a b)
    | [ |- context[@mk_integer ?o 0] ] => rewrite (@int_zero o)
    | [ |- context[@mk_false ?o] ] => fold (@mk_void o)
    | [ |- context[mk_fun ?a mk_void] ] => fold (mk_not a)
    | [ |- context[mk_not (mk_less_than ?b ?a)] ] => fold (mk_le a b)

    | [ H : ?v = newvar ?b |- context[mk_product ?a ?v ?b] ] => rewrite (fold_mk_prod a v b H)
    | [ H : ?v = newvar ?b |- context[mk_function ?a ?v ?b] ] => rewrite (fold_mk_fun a v b H); auto
    | [ H : ?v = newvar ?b |- context[mk_isect ?a ?v ?b] ] => rewrite (fold_mk_ufun a v b H); auto

    | [ H : context[@oterm ?p (Can NAxiom) []] |- _ ] => fold (@mk_axiom p) in H
    | [ H : context[@oterm ?p (Can NInt) []] |- _ ] => fold (@mk_int p) in H
    | [ H : context[@oterm ?p (Can (NUTok ?a)) []] |- _ ] => fold (@mk_utoken p a) in H
    | [ H : context[@oterm ?p (Can (NTok ?a)) []] |- _ ] => fold (@mk_token p a) in H
    | [ H : context[@mk_approx ?p mk_axiom mk_axiom] |- _ ] => fold (@mk_true p) in H
    | [ H : context[@mk_approx ?p mk_axiom mk_bot] |- _ ] => fold (@mk_false p) in H
    | [ H : context[@mk_lam ?p nvarx (mk_var nvarx)] |- _ ] => fold (@mk_id p) in H
    | [ H : context[@mk_fix ?p mk_id] |- _ ] => fold (@mk_bottom p) in H
    | [ H : context[@mk_bottom ?p] |- _ ] => fold (@mk_bot p) in H
    | [ H : context[@bterm ?p [] ?x] |- _ ] => fold (@nobnd p x) in H
    | [ H : context[@vterm ?p ?v] |- _ ] => fold (@mk_var p v) in H
    | [ H : context[@oterm ?p (Can (Nint ?z)) []] |- _ ] => fold (@mk_integer p z) in H
    | [ H : context[@mk_integer ?p (Z.of_nat ?n)] |- _ ] => fold (@mk_nat p n) in H
    | [ H : context[@mk_nat ?p 0] |- _ ] => fold (@mk_zero p) in H
    | [ H : context[@oterm ?p (Can (Nseq ?f)) []] |- _ ] => fold (@mk_nseq p f) in H
    | [ H : context[oterm (Can NLambda) [bterm [?v] ?t]] |- _ ] => fold (mk_lam v t) in H
    | [ H : context[oterm (Can NApprox) [nobnd ?a, nobnd ?b]] |- _ ] => fold (mk_approx a b) in H
    | [ H : context[oterm (Can NEquality) [nobnd ?a, nobnd ?b, nobnd ?c]] |- _ ] => fold (mk_equality a b c) in H
    | [ H : context[oterm (Can NREquality) [nobnd ?a, nobnd ?b, nobnd ?c]] |- _ ] => fold (mk_requality a b c) in H
    | [ H : context[oterm (Can NFreeFromAtom) [nobnd ?a, nobnd ?b, nobnd ?c]] |- _ ] => fold (mk_free_from_atom a b c) in H
    | [ H : context[oterm (Can NEFreeFromAtom) [nobnd ?a, nobnd ?b, nobnd ?c]] |- _ ] => fold (mk_efree_from_atom a b c) in H
    | [ H : context[oterm (Can NFreeFromAtoms) [nobnd ?a, nobnd ?b]] |- _ ] => fold (mk_free_from_atoms a b) in H
    | [ H : context[oterm (Can NFunction) [nobnd ?a, bterm [?v] ?b]] |- _ ] => fold (mk_function a v b) in H
    | [ H : context[oterm (Can NProduct) [nobnd ?a, bterm [?v] ?b]] |- _ ] => fold (mk_product a v b) in H
    | [ H : context[oterm (Can NUnion) [nobnd ?x, nobnd ?y]] |- _ ] => fold (mk_union x y) in H
    | [ H : context[oterm (Can NEUnion) [nobnd ?x, nobnd ?y]] |- _ ] => fold (mk_eunion x y) in H
    | [ H : context[oterm (Can NTExc) [nobnd ?x, nobnd ?y]] |- _ ] => fold (mk_texc x y) in H
    | [ H : context[oterm (NCan NApply) [nobnd ?x, nobnd ?y]] |- _ ] => fold (mk_apply x y) in H
    | [ H : context[oterm (NCan NEApply) [nobnd ?x, nobnd ?y]] |- _ ] => fold (mk_eapply x y) in H
(*    | [ H : context[oterm (NCan (NApseq ?f)) [nobnd ?x] ] |- _ ] => fold (mk_apseq f x) in H*)
    | [ H : context[oterm (NCan NDecide) [nobnd ?d, bterm [?x] ?f, bterm [?y] ?g]] |- _ ] => fold (mk_decide d x f y g) in H
    | [ H : context[oterm (NCan NSpread) [nobnd ?p, bterm [?x,?y] ?f]] |- _ ] => fold (mk_spread p x y f) in H
    | [ H : context[oterm (NCan NTryCatch) [nobnd ?a, nobnd ?b, bterm [?v] ?c]] |- _ ] => fold (mk_try a b v c) in H
    | [ H : context[oterm (NCan NFix) [nobnd ?x]] |- _ ] => unfold nobnd in H; fold (mk_fix x) in H; try (fold nobnd in H)
    | [ H : context[oterm (NCan NCbv) [nobnd ?a, bterm [?v] ?b]] |- _ ] => fold (mk_cbv a v b) in H
    | [ H : context[oterm (NCan NFresh) [bterm [?v] ?b]] |- _ ] => fold (mk_fresh v b) in H
    | [ H : context[oterm (NCan (NCompOp CompOpLess)) [nobnd ?a, nobnd ?b, nobnd ?c, nobnd ?d]] |- _ ] => fold (mk_less a b c d) in H
    | [ H : context[oterm Exc [nobnd ?a, nobnd ?x]] |- _ ] => fold (mk_exception a x) in H
    | [ H : context[oterm (Can NIsect) [nobnd ?a, bterm [?v] ?b] ] |- _ ] => fold (mk_isect a v b) in H
    | [ H : context[oterm (Can NSet) [nobnd ?a, bterm [?v] ?b] ] |- _ ] => fold (mk_set a v b) in H
    | [ H : context[oterm (NCan NMinus) [nobnd ?a] ] |- _ ] => fold (mk_minus a) in H
    | [ H : context[mk_equality ?t ?t ?T] |- _ ] => fold (mk_member t T) in H
    | [ H : context[mk_less ?t mk_zero (mk_minus ?t) ?t] |- _ ] => fold (absolute_value t) in H
    | [ H : context[mk_less ?a ?b mk_true mk_false] |- _ ] => fold (mk_less_than a b) in H
    | [ H : context[@mk_integer ?o 0] |- _ ] => rewrite (@int_zero o) in H
    | [ H : context[@mk_false ?o] |- _ ] => fold (@mk_void o) in H
    | [ H : context[mk_fun ?a mk_void] |- _ ] => fold (mk_not a) in H
    | [ H : context[mk_not (mk_less_than ?b ?a)] |- _ ] => fold (mk_le a b) in H

    | [ H : ?v = newvar ?b, J : context[mk_product ?a ?v ?b] |- _ ] => rewrite (fold_mk_prod a v b H) in J; auto
    | [ H : ?v = newvar ?b, J : context[mk_function ?a ?v ?b] |- _ ] => rewrite (fold_mk_fun a v b H) in J; auto
    | [ H : ?v = newvar ?b, J : context[mk_isect ?a ?v ?b] |- _ ] => rewrite (fold_mk_ufun a v b H) in J; auto

  end.

Ltac fold_terms := repeat fold_terms_step.


Require Import String. Import StringSyntax.
From Ling Require Import BS.
Import Ling.

(* Is this relevant? *)

Add LoadPath  "/local/res/josh/coq" as Ling.

(* First compile BS.v as follows.
 /Applications/CoqIDE_8.13.1.app/Contents/Resources/bin/coqc -Q . Ling -vos BS.v

Josh has put in changes from BSm.v.
*)

(* muddy, copulatives *)

Definition muddy : AP := ET "muddy".
Definition is : (DP \ S) / AP := fun x y => x y.

(* Generalized bind *)
Definition gbind {a b c : Cat} (x : a || b -- c) : a || (c >> b) -- c :=
  fun k => x (fun e => k e e).

(* This is going to be thhe type of a structured antecedent. *)

Notation "x [ y ]" := (Focus y x) (at level 30, format "x [ y ]").

Definition bought := mkTV "bought".
Definition lunch : DP := Ec "lunch".
Definition alice : DP := Ec "alice".
(* Definition focus (x : DP) : DP[DP] := (x, id). *)
Definition focus {a : Cat} (x : a) : a[a] := (x, id).

Definition fextract {a b c d : Cat} (x : a || b -- (c[d])) : a || b -- c := fmap (fun (s : c[d]) => (snd s) (fst s)) x.

Definition fappf {a b c : Cat} (y : a / b) (x : b[c]) : a[c] :=
  (fst x, fun a => y (snd x a)).
Definition fappb {a b c : Cat} (x : b[c]) (y : b \ a) : a[c] :=
  (fst x, fun a => y (snd x a)).

Notation "x :f> y" := (fappf x y) (at level 40).
Notation "x <f: y" := (fappb x y) (at level 40).

Definition contrast {a} (f : S || S -- (S[a])) : (S[a] >> S) || S -- S := (fun k old => k (f (fun new => (snd new) (fst new) /\ (snd new) = (snd old) /\ (fst new) <> (fst old)))).

Definition ALICE_bought_lunch : S || (S[DP] >> S) -- S :=
    fextract (gbind (lift (focus alice <f: (bought :> lunch)))).

Definition JOHN_bought_lunch :=
    contrast (lift (focus john <f: (bought :> lunch))).

Check ALICE_bought_lunch.
Eval compute in ALICE_bought_lunch.
(*
     = fun k : Prop -> E * (E -> Prop) -> Prop =>
       k (EET "bought" (Ec "lunch") (Ec "alice"))
         (Ec "alice",
         fun a : E => EET "bought" (Ec "lunch") a)
     :
S || S[DP] >> S
--
S
*)

Check bought :> lunch.
Check focus (bought :> lunch).
Check geach alice.
Check (geach alice) :f> (focus (bought :> lunch)).

Check fextract (gbind (lift ((geach alice) :f> (focus (bought :> lunch))))).

(*
Definition ALICE_bought_lunch : S || (S[DP] >> S) -- S :=
    fextract (gbind (lift (focus alice <f: (bought :> lunch)))).
*)

(* Structured VP-proposition antecedent. NB this does not have to do with focus. *)

Definition alice_BOUGHT_LUNCH : S || (S[DP \ S] >> S) -- S :=
    fextract (gbind (lift ((geach alice) :f> (focus (bought :> lunch))))).

Check alice_BOUGHT_LUNCH.
(*
S || S[DP \ S] >> S
--
S
*)

Eval compute in alice_BOUGHT_LUNCH.

(*
     = fun
         k : Prop ->
             (E -> Prop) * ((E -> Prop) -> Prop) -> Prop
       =>
       k (EET "bought" (Ec "lunch") (Ec "alice"))
         (EET "bought" (Ec "lunch"),               VP antecedent
         fun a : E -> Prop => a (Ec "alice"))      Abstract of the rest of the sentence.

(E -> Prop) * ((E -> Prop) -> Prop) is the type of the structured antecedent.  It's a pair of
a property and a proposition with a property hole.

The category of the structured binder is

S || S[DP \ S] >> S
--
S

indicating power to bind a S[DP \ S] pronoun. The category of [BEN did ---] should be

S[DP \ S] >> S || S
--
S

indicating a S[DP \ S] pronoun that is seeking an antecedent.

This is the type of [BEN is muddy] in the analysis from focus.v.  It indicates an unbound pronoun of
propositional type.

lower (focus ben <| lift (is :> muddy))
     :
(S >> S) || S
--
S

And this is the semantics.

fun (f : Prop -> Prop) (p : Prop) =>
       f (alt p (fun x : E => ET "muddy" x) (Ec "ben")) /\
       ET "muddy" (Ec "ben"
*)

(* Comment out stuff from older version.

Eval compute in (lower (ALICE_bought_lunch <| (lift and |> JOHN_bought_lunch))).

 How is this related to focus?

Definition only {b : Cat} (x : b) : S || S -- (b).
  simpl.
  refine (fun k => k x /\ forall z, k z -> z = x).
Defined.

Eval compute in (lower (only john <| (lift (bought :> lunch)))). *)

(* Individuals *)
Definition ari : DP := Ec "ari".
Definition ben : DP := Ec "ben".

(* Copied from focus.v renaming focus to foc. *)

Parameter (alt : Prop -> ((interp DP) -> Prop) -> (interp DP) -> Prop).

Definition foc (x : DP) : ((S >> S) || S -- S)|| S -- DP :=
  fun k => (fun f => (fun p => (f (alt p k x)) /\ k x)).

(* Example with focus anaphora. This should be modified to parasitic focus-vp anaphora. *)

Check lower ((gbind (lift (ari <: (is :> muddy)))) <|
      ((lift and) |> (lower ((foc ben)  <| (lift (is :> muddy)))))).

Eval compute in lower ((gbind (lift (ari <: (is :> muddy)))) <|
      ((lift and) |> (lower ((foc ben)  <| (lift (is :> muddy)))))).

(*
First conjunct of the focus example. It donates the antecedent using gbind.

S || S >> S
--
S
*)

Check gbind (lift (ari <: (is :> muddy))) : S || S >> S -- S.
Check alice_BOUGHT_LUNCH.

(*
It is comparable to this, which binds S[DP\S] rather than S.
S || S[DP \ S] >> S
--
S

*)

(* The semantics for the first clauses compare as follows. The first function plugs in
the left conjunct proposition twice.

fun k : Prop -> Prop -> Prop =>
    k (ET "muddy" (Ec "ari"))
      (ET "muddy" (Ec "ari"))

The function for the structured antecedent ...

fun
  k : Prop ->                              Bound variable in position of left S.
      (E -> Prop) * ((E -> Prop) -> Prop)  Bound for a structured proposition.
          -> Prop
       =>
       k
         (EET "bought" (Ec "lunch")        Locally plug in the propistion 'alice bought lunch'
            (Ec "alice"))
         (EET "bought" (Ec "lunch"),       Distally plug in the structured proposition.
         fun a : E -> Prop => a (Ec "alice"))

*)

Eval compute in gbind (lift (ari <: (is :> muddy))) : S || S >> S -- S.

Eval compute in alice_BOUGHT_LUNCH.

(*
Look at the right conjunct for the focus case, to try to figure out what the right conjunct
for the ellipsis case should be.

(S >> S) || S
--
S

fun (f : Prop -> Prop)  Rest of the tree, with an argument for the local proposition position.
    (p : Prop)          Antecedent proposition.
    => f
         (alt p (fun x : E => ET "muddy" x)
            (Ec "ben")) /\
       ET "muddy" (Ec "ben")

Guess the semantics of BEN_F_did.

fun (f : Prop -> Prop)  Rest of the tree, maybe this is the same.
    (x : (E -> Prop) * ((E -> Prop) -> Prop)) antecedent structured proposition, it is a pair, use fst, snd.
    => f
         (alt ((snd x) (fst x)) (fun y : E => (fst x) y)
            (Ec "ben")) /\
       (fst x) (Ec "ben")
*)

Check lower ((foc ben)  <| (lift (is :> muddy))).
Eval compute in lower ((foc ben)  <| (lift (is :> muddy))).

Definition BEN_F_is_muddy : ((S >> S) || S -- S) := lower ((foc (ben : DP))  <| (lift (is :> muddy))).

Check BEN_F_is_muddy.

Definition BEN_F_did : ((S[DP \ S] >> S) || S -- S) :=
      fun (f : Prop -> Prop)
      (x : (E -> Prop) * ((E -> Prop) -> Prop))
    => f
         (alt ((snd x) (fst x)) (fun y : E => (fst x) y)
            (Ec "ben")) /\
       (fst x) (Ec "ben").

Check BEN_F_did.
(*
(S[DP \ S] >> S) || S
--
S
*)

Eval compute in alice_BOUGHT_LUNCH.
Check lower ((alice_BOUGHT_LUNCH <| ((lift and) |> BEN_F_did))).

Eval compute in lower ((alice_BOUGHT_LUNCH <| ((lift and) |> BEN_F_did))).

(*
(EET "bought" (Ec "lunch") (Ec "alice") /\
        alt
          (EET "bought" (Ec "lunch")
             (Ec "alice"))
          (fun y : E =>
           EET "bought" (Ec "lunch") y)
          (Ec "ben")) /\
       EET "bought" (Ec "lunch") (Ec "ben")
     : S
This looks good.
The conjunct in the middle is the focus presupposition.

*)


Require Import FP.Data.Function.
Require Import FP.Data.List.
Require Import FP.Data.Option.
Require Import FP.Structures.Alternative.
Require Import FP.Structures.Applicative.
Require Import FP.Structures.Eqv.
Require Import FP.Structures.Functor.
Require Import FP.Structures.MonadFix.

Import AlternativeNotation.
Import ApplicativeNotation.
Import FunctionNotation.
Import FunctorNotation.
Import ListNotation.

Class LLParser T p :=
  { ll_parser_Applicative :> Applicative p
  ; ll_parser_Alternative :> Alternative p
  ; parse_refine : forall {A}, (T -> option A) -> p A
  }.

Section LLParser.
  Context {p T} {pP:LLParser T p}.

  Context {tE:EqvDec T}.

  Context {MF:MonadFix p}.

  Definition parse_predicate (f:T -> bool) : p T :=
    parse_refine (fun x => if f x then Some x else None).
  Definition parse_token (t:T) : p T := parse_predicate (eqv_dec t).
  Fixpoint parse_sequence (ts:list T) : p (list T) :=
    match ts with
    | nil => fret nil
    | t::ts' => cons <$> parse_token t <@> parse_sequence ts'
    end.

  Fixpoint count {A} (i:nat) (aP:p A) : p (list A) :=
    match i with
    | O => fret nil
    | S i' => cons <$> aP <@> count i' aP
    end.

  Definition optional {A} (aP:p A) : p (option A) :=
    Some <$> aP <|> fret None.

  Definition between {O C A} (open:p O) (close:p C) (aP:p A) : p A :=
    open @> aP <@ close.

  Definition many {A} : p A -> p (list A) :=
    mfix $ fun many a =>
      cons <$> a <@> many a
      <|>
      fret nil.

  Definition many1 {A} (aP:p A) : p (list A) :=
    cons <$> aP <@> many aP.

  Definition sep_by {A B} (aP:p A) (sep:p B) : p (list A) :=
    cons <$> aP <@> many (const id <$> sep <@> aP).

  Definition sep_opt_begin_by {A B} (aP:p A) (sep:p B) : p (list A) :=
    optional sep @> sep_by aP sep.

  Definition many_till {A B} : p A -> p B -> p (list A) :=
    mfix2 $ fun many_till aP nd =>
      const nil <$> nd
      <|>
      cons <$> aP <@> many_till aP nd.
End LLParser.


From distris Require Export lang network.
From stdpp Require Export strings.
Set Default Proof Using "Type".

Import Network.

Notation "½" := (1/2)%Qp.
Notation "¼" := (1/4)%Qp.
Notation "¾" := (3/4)%Qp.

Coercion LitInt : Z >-> base_lit.
Coercion LitBool : bool >-> base_lit.
Coercion LitLoc : loc >-> base_lit.
Coercion LitAddressFamily : address_family >-> base_lit.
Coercion LitSocketType : socket_type >-> base_lit.
Coercion LitProtocol : protocol >-> base_lit.
Coercion LitSocketAddress : socket_address >-> base_lit.
Coercion LitString : string >-> base_lit.

Coercion App : ground_lang.expr >-> Funclass.
Coercion of_val : val >-> expr.
Coercion ground_lang.of_val : ground_lang.val >-> ground_lang.expr.

Coercion Var : string >-> ground_lang.expr.

Coercion BNamed : string >-> binder.
Notation "<>" := BAnon : binder_scope.

(* Definition mkExpr (n : node) (e : ground_lang.expr) := (n,e) : expr. *)
(* Definition mkVal (n : node) (v : ground_lang.val) := (n,v) : val. *)

(* Note that the scope for expressions and values are NOT the same:
   Expressions have brackets that comes from the sequence \<, with name
   MATHEMATICAL LEFT ANGLE BRACKET where as values has brackets
   that come from \〈 (name: LEFT-POINTING ANGLE BRACKET) *)
Notation "⟨ n ; e ⟩" := (mkExpr n e)
                      (at level 0, right associativity).
Notation "〈 n ; v 〉" := (mkVal n v%V).

(* No scope for the values, does not conflict and scope is often not inferred
properly. *)
Notation "# l" := (LitV l%Z%V) (at level 8, format "# l").
Notation "# l" := (Lit l%Z%V) (at level 8, format "# l") : expr_scope.

(** Syntax inspired by Coq/Ocaml. Constructions with higher precedence come
    first. *)
Notation "( e1 , e2 , .. , en )" := (Pair .. (Pair e1 e2) .. en) : expr_scope.
Notation "( e1 , e2 , .. , en )" := (PairV .. (PairV e1 e2) .. en) : val_scope.

(*
Using the '[hv' ']' printing box, we make sure that when the notation for match
does not fit on a single line, line breaks will be inserted for *each* breaking
point '/'. Note that after each breaking point /, one can put n spaces (for
example '/  '). That way, when the breaking point is turned into a line break,
indentation of n spaces will appear after the line break. As such, when the
match does not fit on one line, it will print it like:

  match: e0 with
    InjL x1 => e1
  | InjR x2 => e2
  end

Moreover, if the branches do not fit on a single line, it will be printed as:

  match: e0 with
    InjL x1 =>

  | InjR x2 =>
    even more stuff bla bla bla bla bla bla bla bla
  end
*)
Notation "'match:' e0 'with' 'InjL' x1 => e1 | 'InjR' x2 => e2 'end'" :=
  (Match e0 x1%bind e1 x2%bind e2)
  (e0, x1, e1, x2, e2 at level 200,
   format "'[hv' 'match:'  e0  'with'  '/  ' '[' 'InjL'  x1  =>  '/  ' e1 ']'  '/' '[' |  'InjR'  x2  =>  '/  ' e2 ']'  '/' 'end' ']'") : expr_scope.
Notation "'match:' e0 'with' 'InjR' x1 => e1 | 'InjL' x2 => e2 'end'" :=
  (Match e0 x2%bind e2 x1%bind e1)
  (e0, x1, e1, x2, e2 at level 200, only parsing) : expr_scope.

Notation "()" := LitUnit : val_scope.
Notation "! e" := (Load e%E) (at level 9, right associativity) : expr_scope.
Notation "'ref' e" := (Alloc e%E)
  (at level 30, right associativity) : expr_scope.
Notation "- e" := (UnOp MinusUnOp e%E)
  (at level 35, right associativity) : expr_scope.
Notation "e1 + e2" := (BinOp PlusOp e1%E e2%E)
  (at level 50, left associativity) : expr_scope.
Notation "e1 - e2" := (BinOp MinusOp e1%E e2%E)
  (at level 50, left associativity) : expr_scope.
Notation "e1 ≤ e2" := (BinOp LeOp e1%E e2%E) (at level 70) : expr_scope.
Notation "e1 < e2" := (BinOp LtOp e1%E e2%E) (at level 70) : expr_scope.
Notation "e1 = e2" := (BinOp EqOp e1%E e2%E) (at level 70) : expr_scope.
Notation "e1 ^^ e2" := (BinOp StringApp e1%E e2%E) (at level 70) : expr_scope.
Notation "e1 ≠ e2" := (UnOp NegOp (BinOp EqOp e1%E e2%E)) (at level 70) : expr_scope.
Notation "~ e" := (UnOp NegOp e%E) (at level 75, right associativity) : expr_scope.
(* The unicode ← is already part of the notation "_ ← _; _" for bind. *)
Notation "e1 <- e2" := (Store e1%E e2%E) (at level 80) : expr_scope.

(* The breaking point '/  ' makes sure that the body of the rec is indented
by two spaces in case the whole rec does not fit on a single line. *)
Notation "'rec:' f x := e" := (Rec f%bind x%bind e%E)
  (at level 102, f at level 1, x at level 1, e at level 200,
   format "'[' 'rec:'  f  x  :=  '/  ' e ']'") : expr_scope.
Notation "'rec:' f x := e" := (locked (RecV f%bind x%bind e%E))
  (at level 102, f at level 1, x at level 1, e at level 200,
   format "'[' 'rec:'  f  x  :=  '/  ' e ']'") : val_scope.
Notation "'if:' e1 'then' e2 'else' e3" := (If e1%E e2%E e3%E)
  (at level 200, e1, e2, e3 at level 200) : expr_scope.

(** Derived notions, in order of declaration. The notations for let and seq
are stated explicitly instead of relying on the Notations Let and Seq as
defined above. This is needed because App is now a coercion, and these
notations are otherwise not pretty printed back accordingly. *)
Notation "'rec:' f x y .. z := e" := (Rec f%bind x%bind (Lam y%bind .. (Lam z%bind e%E) ..))
  (at level 102, f, x, y, z at level 1, e at level 200,
   format "'[' 'rec:'  f  x  y  ..  z  :=  '/  ' e ']'") : expr_scope.
Notation "'rec:' f x y .. z := e" := (locked (RecV f%bind x%bind (Lam y%bind .. (Lam z%bind e%E) ..)))
  (at level 102, f, x, y, z at level 1, e at level 200,
   format "'[' 'rec:'  f  x  y  ..  z  :=  '/  ' e ']'") : val_scope.

(* The breaking point '/  ' makes sure that the body of the λ: is indented
by two spaces in case the whole λ: does not fit on a single line. *)
Notation "λ: x , e" := (Lam x%bind e%E)
  (at level 102, x at level 1, e at level 200,
   format "'[' 'λ:'  x ,  '/  ' e ']'") : expr_scope.
Notation "λ: x y .. z , e" := (Lam x%bind (Lam y%bind .. (Lam z%bind e%E) ..))
  (at level 102, x, y, z at level 1, e at level 200,
   format "'[' 'λ:'  x  y  ..  z ,  '/  ' e ']'") : expr_scope.

(* When parsing lambdas, we want them to be locked (so as to avoid needless
unfolding by tactics and unification). However, unlocked lambda-values sometimes
appear as part of compound expressions, in which case we want them to be pretty
printed too. We achieve that by first defining the non-locked notation, and then
the locked notation. Both will be used for pretty-printing, but only the last
will be used for parsing. *)
Notation "λ: x , e" := (LamV x%bind e%E)
  (at level 102, x at level 1, e at level 200,
   format "'[' 'λ:'  x ,  '/  ' e ']'") : val_scope.
Notation "λ: x , e" := (locked (LamV x%bind e%E))
  (at level 102, x at level 1, e at level 200,
   format "'[' 'λ:'  x ,  '/  ' e ']'") : val_scope.
Notation "λ: x y .. z , e" := (LamV x%bind (Lam y%bind .. (Lam z%bind e%E) .. ))
  (at level 102, x, y, z at level 1, e at level 200,
   format "'[' 'λ:'  x  y  ..  z ,  '/  ' e ']'") : val_scope.
Notation "λ: x y .. z , e" := (locked (LamV x%bind (Lam y%bind .. (Lam z%bind e%E) .. )))
  (at level 102, x, y, z at level 1, e at level 200,
   format "'[' 'λ:'  x  y  ..  z ,  '/  ' e ']'") : val_scope.

Notation "'let:' x := e1 'in' e2" := (Lam x%bind e2%E e1%E)
  (at level 102, x at level 1, e1, e2 at level 200,
   format "'[' 'let:'  x  :=  '[' e1 ']'  'in'  '/' e2 ']'") : expr_scope.
Notation "e1 ;; e2" := (Lam BAnon e2%E e1%E)
  (at level 100, e2 at level 200,
   format "'[' '[hv' '[' e1 ']'  ;;  ']' '/' e2 ']'") : expr_scope.

(* Shortcircuit Boolean connectives *)
Notation "e1 && e2" :=
  (If e1%E e2%E (Lit (LitBool false))) (only parsing) : expr_scope.
Notation "e1 || e2" :=
  (If e1%E (Lit (LitBool true)) e2%E) (only parsing) : expr_scope.

(** Notations for option *)
Notation NONE := (InjL #()) (only parsing).
Notation SOME x := (InjR x) (only parsing).

Notation NONEV := (InjLV #()) (only parsing).
Notation SOMEV x := (InjRV x) (only parsing).

Notation "'match:' e0 'with' 'NONE' => e1 | 'SOME' x => e2 'end'" :=
  (Match e0 BAnon e1 x%bind e2)
  (e0, e1, x, e2 at level 200, only parsing) : expr_scope.
Notation "'match:' e0 'with' 'SOME' x => e2 | 'NONE' => e1 'end'" :=
  (Match e0 BAnon e1 x%bind e2)
    (e0, e1, x, e2 at level 200, only parsing) : expr_scope.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** This file defines a number of data types and operations used in
  the abstract syntax trees of many of the intermediate languages. *)

Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Floats.
Require Import ClassesAndNotations.
Set Implicit Arguments.

(** * Syntactic elements *)

(** Identifiers (names of local variables, of global symbols and functions,
  etc) are represented by the type [positive] of positive integers. *)

(*c2t* super short *)
Definition ident := positive.

Definition ident_eq := peq.

(** The intermediate languages are weakly typed, using only two types:
  [Tint] for integers and pointers, and [Tfloat] for floating-point
  numbers. *)

Inductive typ : Type :=
  | Tint : typ
  | Tfloat : typ.

Definition typesize (ty: typ) : Z :=
  match ty with Tint => 4 | Tfloat => 8 end.

Lemma typesize_pos: forall ty, typesize ty > 0.
Proof. destruct ty; simpl; omega. Qed.

Lemma typ_eq: forall (t1 t2: typ), {t1=t2} + {t1<>t2}.
Proof. decide equality. Qed.

Module TypEqDec <: EQUALITY_TYPE.
  Definition t := typ.
  Global Instance EqDec_t: EqDec typ :=
  { eq_dec := typ_eq}.
End TypEqDec.

Lemma opt_typ_eq: forall (t1 t2: option typ), {t1=t2} + {t1<>t2}.
Proof. decide equality. apply typ_eq. Qed.

(** Additionally, function definitions and function calls are annotated
  by function signatures indicating the number and types of arguments,
  as well as the type of the returned value if any.  These signatures
  are used in particular to determine appropriate calling conventions
  for the function. *)

Record signature : Type := mksignature {
  sig_args: list typ;
  sig_res: option typ
}.

Definition proj_sig_res (s: signature) : typ :=
  match s.(sig_res) with
  | None => Tint
  | Some t => t
  end.

(** Memory accesses (load and store instructions) are annotated by
  a ``memory chunk'' indicating the type, size and signedness of the
  chunk of memory being accessed. *)

Inductive memory_chunk : Type :=
  | Mint8signed : memory_chunk     (**r 8-bit signed integer *)
  | Mint8unsigned : memory_chunk   (**r 8-bit unsigned integer *)
  | Mint16signed : memory_chunk    (**r 16-bit signed integer *)
  | Mint16unsigned : memory_chunk  (**r 16-bit unsigned integer *)
  | Mint32 : memory_chunk          (**r 32-bit integer, or pointer *)
  | Mfloat32 : memory_chunk        (**r 32-bit single-precision float *)
  | Mfloat64 : memory_chunk.       (**r 64-bit double-precision float *)

(** The type (integer/pointer or float) of a chunk. *)

Definition type_of_chunk (c: memory_chunk) : typ :=
  match c with
  | Mint8signed => Tint
  | Mint8unsigned => Tint
  | Mint16signed => Tint
  | Mint16unsigned => Tint
  | Mint32 => Tint
  | Mfloat32 => Tfloat
  | Mfloat64 => Tfloat
  end.

(** Initialization data for global variables. *)

Inductive init_data: Type :=
  | Init_int8: int -> init_data
  | Init_int16: int -> init_data
  | Init_int32: int -> init_data
  | Init_float32: float -> init_data
  | Init_float64: float -> init_data
  | Init_space: Z -> init_data
  | Init_addrof: ident -> int -> init_data.  (**r address of symbol + offset *)

(** Information attached to global variables. *)

Record globvar (V: Type) : Type := mkglobvar {
  gvar_info: V;                    (**r language-dependent info, e.g. a type *)
  gvar_init: list init_data;       (**r initialization data *)
  gvar_readonly: bool;             (**r read-only variable? (const) *)
  gvar_volatile: bool              (**r volatile variable? *)
}.

(** Whole programs consist of:
- a collection of function definitions (name and description);
- the name of the ``main'' function that serves as entry point in the program;
- a collection of global variable declarations (name and information).

The type of function descriptions and that of additional information
for variables vary among the various intermediate languages and are
taken as parameters to the [program] type.  The other parts of whole
programs are common to all languages. *)

Record program (F V: Type) : Type := mkprogram {
  prog_funct: list (ident * F);
  prog_main: ident;
  prog_vars: list (ident * globvar V)
}.

Definition prog_funct_names (F V: Type) (p: program F V) : list ident :=
  map (@fst ident F) p.(prog_funct).

Definition prog_var_names (F V: Type) (p: program F V) : list ident :=
  map (@fst ident (globvar V)) p.(prog_vars).

(** * Generic transformations over programs *)

(** We now define a general iterator over programs that applies a given
  code transformation function to all function descriptions and leaves
  the other parts of the program unchanged. *)

Section TRANSF_PROGRAM.

Variable A B V: Type.
Variable transf: A -> B.

Definition transf_program (l: list (ident * A)) : list (ident * B) :=
  List.map (fun id_fn => (fst id_fn, transf (snd id_fn))) l.

Definition transform_program (p: program A V) : program B V :=
  mkprogram
    (transf_program p.(prog_funct))
    p.(prog_main)
    p.(prog_vars).

Lemma transform_program_function:
  forall p i tf,
  In (i, tf) (transform_program p).(prog_funct) ->
  exists f, In (i, f) p.(prog_funct) /\ transf f = tf.
Proof.
  simpl. unfold transf_program. intros.
  exploit list_in_map_inv; eauto.
  intros [[i' f] [EQ IN]]. simpl in EQ. inversion EQ; subst.
  exists f; split; auto.
Qed.

End TRANSF_PROGRAM.

(** The following is a variant of [transform_program] where the
  code transformation function can fail and therefore returns an
  option type. *)

Open Local Scope string_scope.

Section MAP_PARTIAL.

Variable A B C: Type.
Variable prefix_errmsg: A -> errmsg.
Variable f: B -> res C.

Fixpoint map_partial (l: list (A * B)) : res (list (A * C)) :=
  match l with
  | nil => OK nil
  | (a, b) :: rem =>
      match f b with
      | Error msg => Error (prefix_errmsg a ++ msg)%list
      | OK c =>
          do rem' <- map_partial rem;
          OK ((a, c) :: rem')
      end
  end.

Remark In_map_partial:
  forall l l' a c,
  map_partial l = OK l' ->
  In (a, c) l' ->
  exists b, In (a, b) l /\ f b = OK c.
Proof.
  induction l; simpl.
  intros. inv H. elim H0.
  intros until c. destruct a as [a1 b1].
  caseEq (f b1); try congruence.
  intro c1; intros. monadInv H0.
  elim H1; intro. inv H0. exists b1; auto.
  exploit IHl; eauto. intros [b [P Q]]. exists b; auto.
Qed.

Remark map_partial_forall2:
  forall l l',
  map_partial l = OK l' ->
  list_forall2
    (fun (a_b: A * B) (a_c: A * C) =>
       fst a_b = fst a_c /\ f (snd a_b) = OK (snd a_c))
    l l'.
Proof.
  induction l; simpl.
  intros. inv H. constructor.
  intro l'. destruct a as [a b].
  caseEq (f b). 2: congruence. intro c; intros. monadInv H0.
  constructor. simpl. auto. auto.
Qed.

End MAP_PARTIAL.

Remark map_partial_total:
  forall (A B C: Type) (prefix: A -> errmsg) (f: B -> C) (l: list (A * B)),
  map_partial prefix (fun b => OK (f b)) l =
  OK (List.map (fun a_b => (fst a_b, f (snd a_b))) l).
Proof.
  induction l; simpl.
  auto.
  destruct a as [a1 b1]. rewrite IHl. reflexivity.
Qed.

Remark map_partial_identity:
  forall (A B: Type) (prefix: A -> errmsg) (l: list (A * B)),
  map_partial prefix (fun b => OK b) l = OK l.
Proof.
  induction l; simpl.
  auto.
  destruct a as [a1 b1]. rewrite IHl. reflexivity.
Qed.

Section TRANSF_PARTIAL_PROGRAM.

Variable A B V: Type.
Variable transf_partial: A -> res B.

Definition prefix_name (id: ident) : errmsg :=
  MSG "In function " :: CTX id :: MSG ": " :: nil.

Definition transform_partial_program (p: program A V) : res (program B V) :=
  do fl <- map_partial prefix_name transf_partial p.(prog_funct);
  OK (mkprogram fl p.(prog_main) p.(prog_vars)).

Lemma transform_partial_program_function:
  forall p tp i tf,
  transform_partial_program p = OK tp ->
  In (i, tf) tp.(prog_funct) ->
  exists f, In (i, f) p.(prog_funct) /\ transf_partial f = OK tf.
Proof.
  intros. monadInv H. simpl in H0.
  eapply In_map_partial; eauto.
Qed.

Lemma transform_partial_program_main:
  forall p tp,
  transform_partial_program p = OK tp ->
  tp.(prog_main) = p.(prog_main).
Proof.
  intros. monadInv H. reflexivity.
Qed.

Lemma transform_partial_program_vars:
  forall p tp,
  transform_partial_program p = OK tp ->
  tp.(prog_vars) = p.(prog_vars).
Proof.
  intros. monadInv H. reflexivity.
Qed.

End TRANSF_PARTIAL_PROGRAM.

(** The following is a variant of [transform_program_partial] where
  both the program functions and the additional variable information
  are transformed by functions that can fail. *)

Section TRANSF_PARTIAL_PROGRAM2.

Variable A B V W: Type.
Variable transf_partial_function: A -> res B.
Variable transf_partial_variable: V -> res W.

Definition transf_globvar (g: globvar V) : res (globvar W) :=
  do info' <- transf_partial_variable g.(gvar_info);
  OK (mkglobvar info' g.(gvar_init) g.(gvar_readonly) g.(gvar_volatile)).

Definition transform_partial_program2 (p: program A V) : res (program B W) :=
  do fl <- map_partial prefix_name transf_partial_function p.(prog_funct);
  do vl <- map_partial prefix_name transf_globvar p.(prog_vars);
  OK (mkprogram fl p.(prog_main) vl).

Lemma transform_partial_program2_function:
  forall p tp i tf,
  transform_partial_program2 p = OK tp ->
  In (i, tf) tp.(prog_funct) ->
  exists f, In (i, f) p.(prog_funct) /\ transf_partial_function f = OK tf.
Proof.
  intros. monadInv H.
  eapply In_map_partial; eauto.
Qed.

Lemma transform_partial_program2_variable:
  forall p tp i tg,
  transform_partial_program2 p = OK tp ->
  In (i, tg) tp.(prog_vars) ->
  exists v,
     In (i, mkglobvar v tg.(gvar_init) tg.(gvar_readonly) tg.(gvar_volatile)) p.(prog_vars)
  /\ transf_partial_variable v = OK tg.(gvar_info).
Proof.
  intros. monadInv H. exploit In_map_partial; eauto. intros [g [P Q]].
  monadInv Q. simpl in *. exists (gvar_info g); split. destruct g; auto. auto.
 Qed.

Lemma transform_partial_program2_main:
  forall p tp,
  transform_partial_program2 p = OK tp ->
  tp.(prog_main) = p.(prog_main).
Proof.
  intros. monadInv H. reflexivity.
Qed.

End TRANSF_PARTIAL_PROGRAM2.

(** The following is a relational presentation of
  [transform_program_partial2].  Given relations between function
  definitions and between variable information, it defines a relation
  between programs stating that the two programs have the same shape
  (same global names, etc) and that identically-named function definitions
  are variable information are related. *)

Section MATCH_PROGRAM.

Variable A B V W: Type.
Variable match_fundef: A -> B -> Prop.
Variable match_varinfo: V -> W -> Prop.

Inductive match_funct_entry: ident * A -> ident * B -> Prop :=
  | match_funct_entry_intro: forall id fn1 fn2,
      match_fundef fn1 fn2 ->
      match_funct_entry (id, fn1) (id, fn2).

Inductive match_var_entry: ident * globvar V -> ident * globvar W -> Prop :=
  | match_var_entry_intro: forall id info1 info2 init ro vo,
      match_varinfo info1 info2 ->
      match_var_entry (id, mkglobvar info1 init ro vo)
                      (id, mkglobvar info2 init ro vo).

Definition match_program (p1: program A V) (p2: program B W) : Prop :=
  list_forall2 match_funct_entry p1.(prog_funct) p2.(prog_funct)
  /\ p1.(prog_main) = p2.(prog_main)
  /\ list_forall2 match_var_entry p1.(prog_vars) p2.(prog_vars).

End MATCH_PROGRAM.

Remark transform_partial_program2_match:
  forall (A B V W: Type)
         (transf_partial_function: A -> res B)
         (transf_partial_variable: V -> res W)
         (p: program A V) (tp: program B W),
  transform_partial_program2 transf_partial_function transf_partial_variable p = OK tp ->
  match_program
    (fun fd tfd => transf_partial_function fd = OK tfd)
    (fun info tinfo => transf_partial_variable info = OK tinfo)
    p tp.
Proof.
  intros. monadInv H. split.
  apply list_forall2_imply with
    (fun (ab: ident * A) (ac: ident * B) =>
       fst ab = fst ac /\ transf_partial_function (snd ab) = OK (snd ac)).
  eapply map_partial_forall2. eauto.
  intros. destruct v1; destruct v2; simpl in *. destruct H1; subst. constructor. auto.
  split. auto.
  apply list_forall2_imply with
    (fun (ab: ident * globvar V) (ac: ident * globvar W) =>
       fst ab = fst ac /\ transf_globvar transf_partial_variable (snd ab) = OK (snd ac)).
  eapply map_partial_forall2. eauto.
  intros. destruct v1; destruct v2; simpl in *. destruct H1; subst.
  monadInv H2. destruct g; simpl in *. constructor. auto.
Qed.

(** * External functions *)

(** For most languages, the functions composing the program are either
  internal functions, defined within the language, or external functions
  (a.k.a. system calls) that emit an event when applied.  We define
  a type for such functions and some generic transformation functions. *)

Record external_function : Type := mkextfun {
  ef_id: ident;
  ef_sig: signature;
  ef_inline: bool
}.

(** Function definitions are the union of internal and external functions. *)

Inductive fundef (F: Type): Type :=
  | Internal: F -> fundef F
  | External: external_function -> fundef F.

Implicit Arguments External [F].

Section TRANSF_FUNDEF.

Variable A B: Type.
Variable transf: A -> B.

Definition transf_fundef (fd: fundef A): fundef B :=
  match fd with
  | Internal f => Internal (transf f)
  | External ef => External ef
  end.

End TRANSF_FUNDEF.

Section TRANSF_PARTIAL_FUNDEF.

Variable A B: Type.
Variable transf_partial: A -> res B.

Definition transf_partial_fundef (fd: fundef A): res (fundef B) :=
  match fd with
  | Internal f => do f' <- transf_partial f; OK (Internal f')
  | External ef => OK (External ef)
  end.

End TRANSF_PARTIAL_FUNDEF.


From aneris.aneris_lang Require Import lang resources.
From stdpp Require Import gmap.
From aneris.prelude Require Import misc.
From aneris.examples.ccddb.spec Require Import base.
From aneris.examples.ccddb.model Require Import model_update_prelude
     model_lhst model_update_lsec.

Section Lhst_udpate.
  Context `{!anerisG Mdl Σ, !DB_params}.

  Lemma lhst_add_ext i s e :
    DBM_lhst_valid i s →
    (∀ e', e' ∈ s → ae_time e' = ae_time e → False) →
    DBM_lhst_ext (s ∪ {[e]}).
  Proof.
    intros ? ? e1 e2
           [He1| ->%elem_of_singleton]%elem_of_union
           [He2| ->%elem_of_singleton]%elem_of_union;
      [by eapply DBM_LHV_ext| set_solver .. ].
  Qed.

  Lemma DBM_lhst_ext_update e i t s :
    DBM_lhst_valid i s →
    (∀ e, e ∈ s → vector_clock_le e.(ae_time) t) →
    update_condition i e t →
    DBM_lhst_ext (s ∪ {[e]}).
  Proof.
    intros His Ht Hcnd.
    eapply lhst_add_ext; first done.
    intros e1 He1 He1t.
    specialize (Ht e1 He1). rewrite He1t in Ht.
    assert (vector_clock_lt (ae_time e) t) as Hlt.
    { apply vector_clock_le_eq_or_lt in Ht as [ | ]; last done.
      subst. by eapply update_condition_absurd in Hcnd. }
    eapply update_condition_time; eauto.
  Qed.

  Lemma DBM_lhst_seqids_update e i t s :
    DBM_lhst_valid i s →
    e.(ae_seqid) = (S (size s)) →
    update_condition i e t →
    DBM_lhst_seqids (s ∪ {[e]}).
  Proof.
    intros Hvl Hseq Hcnd.
    pose proof Hcnd as
        (Hi & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
    intros e' [ He' | ->%elem_of_singleton]%elem_of_union.
    + pose proof (DBM_LHV_seqids Hvl e' He').
      apply (Nat.le_trans _ (size s)); first done.
      by apply subseteq_size; set_solver.
    + rewrite size_union_alt.
      rewrite Hseq difference_disjoint_L;
          first by rewrite size_singleton; lia.
      apply elem_of_disjoint; intros ? ->%elem_of_singleton He.
        by pose proof (DBM_LHV_seqids Hvl e He); lia.
  Qed.

  Lemma DBM_lhst_origs_times_update e i t s :
    DBM_lhst_valid i s →
    update_condition i e t →
    let s' := (s ∪ {[e]}) in
    DBM_lhst_times s' ∧
    DBM_lhst_origs i s' ∧
    DBM_lhst_keys s'.
  Proof.
    simpl; intros Hvl Hcnd.
    destruct Hcnd as (Hi & Htlen & Hetlen & Hkey & Heorig & Het & Het' & Het'').
    repeat split; intros e' [ | ?%elem_of_singleton_1]%elem_of_union.
    - by eapply DBM_LHV_times.
    - set_solver.
    - by eapply DBM_LHV_origs.
    - set_solver.
    - by eapply DBM_LHV_keys.
    - set_solver.
  Qed.

  Lemma DBM_lhst_update e i t s :
    DBM_lhst_valid i s →
    update_condition i e t →
    e.(ae_seqid) = (S (size s)) →
    (∀ e : apply_event, e ∈ s → vector_clock_le (ae_time e) t) →
    t !! ae_orig e = Some (length (elements (DBM_lsec (ae_orig e) s))) →
    (ae_orig e = i
     → ∀ j, j < strings.length DB_addresses
            → t !! j = Some (length (elements (DBM_lsec j s)))) →
     (∀ j, j < length DB_addresses →
          default O (t !! j) <= (length (elements (DBM_lsec j s)))) →
     DBM_lhst_valid i (s ∪ {[ e ]}).
  Proof.
    intros Hvl Hcnd He Ht.
    pose proof Hcnd as (Hi & _).
    split; try eapply (DBM_lhst_origs_times_update e i t); eauto.
    - eapply DBM_lhst_ext_update; eauto.
    - eapply DBM_lhst_lsec_update; eauto.
    - eapply DBM_lhst_seqids_update; eauto.
  Qed.

End Lhst_udpate.