(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
Import ListNotations.
Open Scope char_scope.
Require Import Hw5Util.

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

(**

Use `yield_def`.
 *)
Theorem yield_eq: forall G A w, List.In (A, w) (Hw5Util.grammar_rules G) -> Hw5Util.Yield G [A] w.
Proof.
  intros.
  apply yield_def with (u:=[]) (v:=[]) (w:=w) (A:=A).
  - apply H.
  - reflexivity.
  - apply app_nil_end.
Qed.

(**
Use `yield_def` and `app_assoc` to correct the parenthesis.
 *)
Theorem yield_right: forall G w1 w2 r w3 w4, Hw5Util.Yield G w1 w2 -> w3 = w1 ++ r -> w4 = w2 ++ r -> Hw5Util.Yield G w3 w4.
Proof.
  intros.
  inversion H; subst; clear H.
  rewrite <- app_assoc.
  rewrite <- app_assoc.
  rewrite <- app_assoc.
  rewrite <- app_assoc.
  apply yield_def with (u:=u) (v:=v++r) (w:=w) (A:=A).
  - apply H2.
  - reflexivity.
  - reflexivity.
Qed.

(**
Similar proof than `yield_right`, but you should rewrite with
`app_assoc` after using `yield_def`, not before.
 *)
Theorem yield_left: forall G w1 w2 l w3 w4, Hw5Util.Yield G w1 w2 -> w3 = l ++ w1 -> w4 = l ++ w2 -> Hw5Util.Yield G w3 w4.
Proof.
  intros.
  inversion H; subst; clear H.
  apply yield_def with (u:=l++u) (v:=v) (w:=w) (A:=A).
  - apply H2.
  - rewrite app_assoc.
    reflexivity.
  - rewrite app_assoc.
    reflexivity.
Qed.

(**
Consider using one of the lemmas you have just proved.
When your goal is `In ("C", ...) (grammar_rules g1)`, `simpl; auto`
should solve it.
 *)
Theorem g1_rule_1: Hw5Util.Yield g1 ["C"] ["{"; "C"; "}"].
Proof.
  apply yield_def with (u:=[]) (v:=[]) (w:=["{"; "C"; "}"]) (A:="C").
  - simpl; auto.
  - reflexivity.
  - reflexivity.
Qed.

(**
Consider using one of the lemmas you have just proved.
When your goal is `In ("C", ...) (grammar_rules g1)`, `simpl; auto`
should solve it.
 *)
Theorem g1_rule_2: Hw5Util.Yield g1 ["C"] ["C"; "C"].
Proof.
  apply yield_def with (u:=[]) (v:=[]) (w:=["C"; "C"]) (A:="C").
  - simpl; auto.
  - reflexivity.
  - reflexivity.
Qed.

(**
Consider using one of the lemmas you have just proved.
When your goal is `In ("C", ...) (grammar_rules g1)`, `simpl; auto`
should solve it.
 *)
Theorem g1_rule_3: Hw5Util.Yield g1 ["C"] [].
Proof.
  apply yield_def with (u:=[]) (v:=[]) (w:=[]) (A:="C").
  - simpl; auto.
  - reflexivity.
  - reflexivity.
Qed.

(**
The proof should proceed by inversion and then case analysis on
string `u`.
 *)
Theorem yield_inv_start: forall G w, Hw5Util.Yield G [Hw5Util.grammar_start G] w -> In (Hw5Util.grammar_start G, w) (Hw5Util.grammar_rules G).
Proof.
  intros.
  inversion H; subst; clear H.
  induction u.
  - simpl in *.
    inversion H1; subst; clear H1.
    rewrite <- app_nil_end.
    apply H0.
  - induction u.
    + inversion H1.
    + inversion H1.
Qed.

(**
You will want to use `yield_inv_start`. Recall that that `List.In`
simplifies to a series of disjunctions.
 *)
Theorem g1_ex1: ~ Hw5Util.Yield g1 ["C"] ["{"].
Proof.
  unfold not.
  intros.
  apply yield_inv_start in H.
  destruct H.
  - inversion H.
  - unfold In in *.
    inversion H.
    + inversion H0.
    + inversion H0.
      * inversion H1.
      * assumption.
Qed.

(**
The idea is to use either: `yield_left`, `yield_right`, or `yield_def`.
 *)
Theorem g1_step_1: Hw5Util.Yield g1 ["C"; "C"] ["{"; "C"; "}"; "C"].
Proof.
  apply yield_def with (u:=[]) (v:=["C"]) (w:=["{";"C";"}"]) (A:="C").
  - simpl; auto.
  - reflexivity.
  - reflexivity.
Qed.

(**
The idea is to use either: `yield_left`, `yield_right`, or `yield_def`.
 *)
Theorem g1_step_2: Hw5Util.Yield g1 ["{"; "C"; "}"; "C"] ["{"; "}"; "C"].
Proof.
  apply yield_left with (w1:=["C"; "}"; "C"]) (w2:=["}";"C"]) (l:=["{"]).
  - apply yield_def with (u:=[]) (v:=["}";"C"]) (w:=[]) (A:="C").
    + simpl; auto.
    + simpl; auto.
    + simpl. auto.
  - reflexivity.
  - reflexivity.
Qed.

(**
The idea is to use either: `yield_left`, `yield_right`, or `yield_def`.
 *)
Theorem g1_step_3: Hw5Util.Yield g1 ["{"; "}"; "C"] ["{"; "}"; "{"; "C"; "}"].
Proof.
  apply yield_left with (w1:=["C"]) (w2:=["{"; "C"; "}"]) (l:=["{";"}"]).
  - apply g1_rule_1.
  - reflexivity.
  - reflexivity.
Qed.

(**
The idea is to use either: `yield_left`, `yield_right`, or `yield_def`.
 *)

Theorem g1_step_4: Hw5Util.Yield g1 ["{"; "}"; "{"; "C"; "}"] ["{"; "}"; "{"; "}"].
Proof.

Admitted.

(**
Use either `derivation_nil` or `derivation_cons`.
 *)
Theorem g1_der_1: Hw5Util.Derivation g1 [["C"]].
Proof.
  apply derivation_nil.
Qed.

(**
Use either `derivation_nil` or `derivation_cons`.
 *)
Theorem g1_der_2: Hw5Util.Derivation g1 [["C"; "C"]; ["C"]].
Proof.
  apply derivation_cons.
  - apply derivation_nil.
  - apply g1_rule_2.
Qed.

(**
Use either `derivation_nil` or `derivation_cons`.
 *)
Theorem g1_der_3: Hw5Util.Derivation g1 [["{"; "C"; "}"; "C"]; ["C"; "C"]; ["C"]].
Proof.
  apply derivation_cons.
  - apply g1_der_2.
  - apply g1_step_1.
Qed.

Theorem g1_der_4: Hw5Util.Derivation g1 [
    ["{"; "}"; "C"];
    ["{"; "C"; "}"; "C"];
    ["C"; "C"];
    ["C"]
].
Proof.
  apply derivation_cons.
  - apply g1_der_3.
  - apply g1_step_2.
Qed.

Theorem g1_der_5: Hw5Util.Derivation g1 [
    ["{"; "}"; "{"; "C"; "}"];
    ["{"; "}"; "C"];
    ["{"; "C"; "}"; "C"];
    ["C"; "C"];
    ["C"]
].
Proof.
  apply derivation_cons.
  - apply g1_der_4.
  - apply g1_step_3.
Qed.

Theorem g1_der_6: Hw5Util.Derivation g1 [
    ["{"; "}"; "{"; "}"];
    ["{"; "}"; "{"; "C"; "}"];
    ["{"; "}"; "C"];
    ["{"; "C"; "}"; "C"];
    ["C"; "C"];
    ["C"]
].
Proof.
  apply derivation_cons.
  - apply g1_der_5.
  - apply g1_step_4.
Qed.

(**
Use `g1_der_6`.
 *)

Theorem ex1: Accept g1 ["{"; "}"; "{"; "}"].
Proof.
  apply accept_def with
  (w:=["{"; "}"; "{"; "}"])
  (ws:= [
    ["{"; "}"; "{"; "C"; "}"];
    ["{"; "}"; "C"];
    ["{"; "C"; "}"; "C"];
    ["C"; "C"];
    ["C"]
  ]).
  - apply g1_der_6.
  - apply Forall_cons.
    + simpl; auto.
    + apply Forall_cons.
      * simpl; auto.
      * simpl; auto.
Qed.


Require Export Utf8_core.
Require Import HoTT.
Require Import equivalence lemmas colimit.
Require Import MyTacs.

Set Universe Polymorphism.
Global Set Primitive Projections.

Local Open Scope path_scope.

Section Dependent_diagrams.

  Context `{fs : Funext}.

  (** We define here the graph ∫D, also denoted G·D *)
  Definition integral (G:graph) (D:diagram G) : graph.
    refine (Build_graph _ _).
    - exact {i:G & D i}.
    - intros i j. exact {g:G i.1 j.1 & diagram1 D g i.2 = j.2}.
  Defined.

  (** Then, a dependent diagram E over D is just a diagram over ∫D. *)
  Definition dep_diagram' {G:graph} (D:diagram G) := diagram (integral G D).

  (** It is actually easier to use the following *)
  Definition dep_diagram {G:graph} (D:diagram G) := {E0 : forall (i:G), D i -> Type & forall (i j:G) (g:G i j) (u:D i), E0 i u -> E0 j (diagram1 D g u)}.

  (** They are indeed equivalent *)
  Lemma dep_diagram_simpl {G:graph} (D:diagram G)
  : dep_diagram' D <~> dep_diagram D.
    unfold dep_diagram.
    refine (equiv_adjointify _ _ _ _).
    - intros U.
      refine (exist _ _ _).
      intros i u. exact (U (i;u)).
      simpl. intros i j f u.
      refine (diagram1 U _).
      simpl. exists f. reflexivity.
    - intros X.
      refine (Build_diagram _ _ _); simpl.
      intros u. exact (X.1 u.1 u.2).
      intros [i u] [j v] [f p]; simpl in *. destruct p. refine (X.2 _ _ _ _).
    - intros X; simpl. reflexivity.
    - intros X; simpl.
      destruct X as [q qq].
      apply path_diagram.
      refine (exist _ _ _); simpl.
      reflexivity.
      intros [u r] [v s] [w p]; simpl in *. destruct p.
      intro x; reflexivity.
  Qed.

  Definition sum_diagram {G:graph} {D:diagram G} (E : dep_diagram D) : diagram G.
    refine (Build_diagram _ _ _).
    - intro i. exact {u:D i & E.1 i u}.
    - intros i j f x. simpl in *.
      exists (diagram1 D f x.1).
      exact (E.2 i j f x.1 x.2).
  Defined.

  Lemma foo (A:Type) (χ : A -> Type) y
  : {c : {v:A & χ v} & y = c.1 } <~> (χ y).
    refine (equiv_adjointify _ _ _ _).
    - intros [[c v] p]; simpl in *. destruct p. exact v.
    - intro x. exists (y;x). reflexivity.
    - intro x. reflexivity.
    - intros [[c v] p]; simpl in *; destruct p. reflexivity.
  Defined.

  (** A dependent diagram E over D is equifibered if *)
  Definition equifibered {G:graph} {D:diagram G} (E : dep_diagram D)
    := forall (i j:G) (f:G i j) (u:D i), IsEquiv (E.2 i j f u).

  (** This is actually equivalent to the following *)
  Definition equifibered' {G:graph} {D:diagram G} (E : dep_diagram D)
    := forall (i j:G) (f:G i j) (u:D i),
         IsEquiv ((λ x, (((diagram1 D f u) ; ((E.2 i j f u) x));1)) : E.1 i u -> (∃ (c : ∃ v : D j, E.1 j v), diagram1 D f u = c.1)).

  Lemma equifibered_lemma {G:graph} {D:diagram G} (E : dep_diagram D)
  : (equifibered E) <~> (equifibered' E).
    unfold equifibered, equifibered'.
    refine (equiv_functor_forall' _ _). apply equiv_idmap. intro i.
    refine (equiv_functor_forall' _ _). apply equiv_idmap. intro j.
    refine (equiv_functor_forall' _ _). apply equiv_idmap. intro f.
    refine (equiv_functor_forall' _ _). apply equiv_idmap. intro u.
    simpl.
    refine (equiv_adjointify _ _ _ _).
    - intro H.
      refine (isequiv_adjointify _ _ _ _).
      + intros [[v x] p]. simpl in *. destruct p. exact ((E.2 i j f u)^-1 x).
      + intros [[v x] p]. simpl in *. destruct p. rewrite eisretr. reflexivity.
      + intro x. apply eissect.
    - intro H.
      refine (isequiv_adjointify _ _ _ _).
      + intro x. apply (equiv_inv (IsEquiv := H)). refine (exist _ _ _).
        exists (diagram1 D f u). exact x. reflexivity.
      + intro x. simpl.
        destruct H as [inv retr sect adj]; simpl in *; clear adj. unfold Sect in *.
        specialize (retr ((diagram1 D f u; x); 1)). simpl in retr.
        apply pr1_path in retr.

  Admitted.

End Dependent_diagrams.

Section Descent.

  Context `{ua : Univalence}.
  Context `{fs : Funext}.

  (** The the descent theorem holds : "families of type over the colimit of D" is equivalent to "equifibered dependent diagrams over D" *)

  Theorem descent {G:graph} {D:diagram G}
  : {E:dep_diagram D & equifibered E} <~> (colimit D -> Type).
    refine (equiv_adjointify _ _ _ _).
    - intros [E Eq].
      refine (colimit_rectnd _ _ _ _ _).
      exact E.1.
      intros i j f c. symmetry.
      refine (path_universe (E.2 i j f c) (feq := _)).
      apply Eq.
    - intro P. refine (exist _ _ _).
      refine (exist _ _ _).
      intros i u. exact (P (colim u)).
      intros i j g u. simpl.
      pose (pp G D i j g u).
      exact (transport idmap (ap P p^)).
      unfold equifibered. intros i j f u.
      exact (isequiv_transport idmap _ _ (ap P (pp G D i j f u)^)).
    - intros P. simpl.
      apply path_forall.
      refine (colimit_rect _ _ _ _ _).
      intros i x; reflexivity.
      intros i j f x. simpl.
      rewrite transport_paths_FlFr. simpl.
      rewrite (colimit_rectnd_beta_pp). rewrite inv_V.
      rewrite path_universe_transport_idmap.
      rewrite ap_V. rewrite concat_p1. apply concat_Vp.
    - intros [E Eq]. simpl.
      refine (path_sigma' _ _ _).
      apply path_sigma' with 1.
      simpl.
      funext'; intros i j g u v.
      (* apply path_forall; intro i. *)
      (* apply path_forall; intro j. *)
      (* apply path_forall; intro g. *)
      (* apply path_forall; intro u. *)
      (* apply path_forall; intro v. *)
      rewrite ap_V. rewrite colimit_rectnd_beta_pp.
      rewrite inv_V. apply transport_path_universe.
      apply path_ishprop.
  Defined.

  Definition Rezk_P1_diag (G:graph) (D:diagram G) (Y:Type) (X := colimit D) (f : Y -> X) : diagram G.
    refine (Build_diagram _ _ _).
    - intro i. exact (@Pullback X (D i) Y (colim (i := i)) f).
    - intros i j g. simpl. intros [x p].
      exists (diagram1 D g x). exists p.1.
      etransitivity; [|exact p.2].
      apply pp.
  Defined.

  Definition Rezk_P1_fun (G:graph) (D:diagram G) (Y:Type) (X := colimit D) (f : Y -> X) (E := Rezk_P1_diag G D Y f) (Y' := colimit E)
  : Y' -> Y.
    refine (colimit_rectnd _ _ _ _ _); simpl.
    + intros i x. exact x.2.1.
    + intros i j φ x; simpl. reflexivity.
  Defined.

  Definition Rezk_P1 (G:graph) (D:diagram G) (Y:Type) (X := colimit D) (f : Y -> X) (E := Rezk_P1_diag G D Y f) (Y' := colimit E)
  : IsEquiv (Rezk_P1_fun G D Y f).
    assert ((colimit (Rezk_P1_diag G D Y f)) -> Type).
    { apply (descent (D := (Rezk_P1_diag G D Y f))).
      refine (exist _ _ _).
      refine (exist _ _ _).
      intro i. simpl. intro x. exact (D i).
      intros i j g u X0. simpl. exact (diagram1 D g X0).
      intros i j g u. simpl in *.
    refine (isequiv_adjointify _ _ _ _).
    - pose (p2f(colimit (Rezk_P1_diag G D Y f))).
      unfold p2f in f0. simpl in f0.

      pose (FamequivPow (colimit (Rezk_P1_diag G D Y f))). unfold Fam in e. simpl in e.

      intro y.
Abort.

End Descent.


Require Import List.
Import ListNotations.

Require Import TPPMark2019.Example.
Require Import TPPMark2019.CTM.
Require Import TPPMark2019.Tape.
Require Import TPPMark2019.Clearer.

Definition bool_tape_t := ListTape.t bool.
Definition example_tape : bool_tape_t := ListTape.from_list [true; false; false; true; false; true; true].
Definition clearer := Clearer.clearer (V:= bool).
Definition history := CTM.steps_history 100 clearer (CTM.start clearer example_tape).
Definition history_list := map (fun tms =>  (Tape.to_list (CTM.tape tms), Tape.head (CTM.tape tms), CTM.state tms)) history.
Compute history_list.


Require Export Iron.Language.Simple.SubstExpExp.
Require Import Iron.Language.Simple.Preservation.
Require Import Iron.Language.Simple.Ty.
Require Export Iron.Language.Simple.Step.
Require Export Iron.Language.Simple.Exp.

(********************************************************************)
(** Big Step Evaluation *)
(*  This is also called 'Natural Semantics'.
    It provides a relation between the expression to be reduced
    and its final value. *)
Inductive EVAL : exp -> exp -> Prop :=
 | EVDone
   :  forall v2
   ,  wnfX  v2
   -> EVAL   v2 v2

 | EVLamApp
   :  forall x1 t11 x12 x2 v2 v3
   ,  EVAL x1 (XLam t11 x12) -> EVAL x2 v2 -> EVAL (substX 0 v2 x12) v3
   -> EVAL (XApp x1 x2) v3.
Hint Constructors EVAL.

(* Invert all hypothesis that are compound eval statements. *)
Ltac inverts_eval :=
 repeat
  (match goal with
   | [ H: EVAL (XApp _ _)_ |- _ ] => inverts H
   end).

(* A terminating big-step evaluation always produces a whnf.
   The fact that the evaluation terminated is implied by the fact
   that we have a finite proof of EVAL to pass to this lemma. *)
Lemma eval_produces_whnfX
 :  forall x1 v1
 ,  EVAL   x1 v1
 -> wnfX  v1.
Proof.
 intros. induction H; eauto.
Qed.
Hint Resolve eval_produces_whnfX.

(********************************************************************)
(** * Big to Small steps *)
(* Convert a big-step evaluation into a list of individual
   machine steps. *)
Lemma steps_of_eval
 :  forall x1 t1 x2
 ,  TYPE nil x1 t1
 -> EVAL  x1 x2
 -> STEPS x1 x2.
Proof.
 intros x1 t1 v2 HT HE. gen t1.

 (* Induction over the form of (EVAL x1 x2) *)
 induction HE; intros.
 Case "EVDone".
  apply EsNone.

 Case "EVLamApp".
  inverts_type.
  spec IHHE1 H1.
  spec IHHE2 H3.

  lets T1: preservation_steps H1 IHHE1. inverts keep T1.
  lets T2: preservation_steps H3 IHHE2.
  lets T3: subst_exp_exp H0 T2.
  lets E3: IHHE3 T3.

  eapply EsAppend.
    lets D: steps_context XcApp1. eapply D. eauto.
   eapply EsAppend.
    lets D: steps_context XcApp2 IHHE2; eauto.
    unfold value. rip.
   eapply EsAppend.
    eapply EsStep.
     eapply EsLamApp.
      split; burn.
     eauto.
Qed.

(********************************************************************)
(** * Small to Big steps *)
(** Convert a list of individual machine steps to a big-step
    evaluation. The main part of this is the expansion lemma, which
    we use to build up the overall big-step evaluation one small-step
    at a time. The other lemmas are used to feed it small-steps.
 *)

(* Given an existing big-step evalution, we can produce a new one
   that does an extra step before returning the original value.
 *)
Lemma eval_expansion
 :  forall te x1 t1 x2 v3
 ,  TYPE te x1 t1
 -> STEP x1 x2 -> EVAL x2 v3
 -> EVAL x1 v3.
Proof.
 intros te x1 t1 x2 v3 HT HS HE. gen te t1 v3.
 induction HS; intros.

 Case "context".
  destruct H; inverts_type; inverts_eval; eauto; nope.

 Case "application".
  inverts_type.
  eapply EVLamApp; eauto.
  destruct v2; nope.
Qed.

(* Convert a list of small steps to a big-step evaluation. *)
Lemma eval_of_stepsl
 :  forall x1 t1 v2
 ,  TYPE nil x1 t1
 -> STEPSL   x1 v2 -> value v2
 -> EVAL     x1 v2.
Proof.
 intros x1 t1 v2 HT HS Hv.
 induction HS; try burn.

 Case "ESLStep".
  unfold value in *.
  rip.

 Case "ESLCons".
  eapply eval_expansion;
   eauto using preservation.
Qed.

(* Convert a multi-step evaluation to a big-step evaluation.
   We use stepsl_of_steps to flatten out the append constructors
   in the multi-step evaluation, leaving a list of individual
   small-steps. *)
Lemma eval_of_steps
 :  forall x1 t1 v2
 ,  TYPE nil x1 t1
 -> STEPS x1 v2 -> value v2
 -> EVAL  x1 v2.
Proof.
 intros.
 eapply eval_of_stepsl; eauto.
  apply stepsl_of_steps; auto.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the dynamic semantics of heap objects, pg. 60.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export FormalSyntax.

(* TODO can I make get and set assume Value v? then make then functions? *)

Inductive get : E -> P -> E -> Prop :=
(* Dan Bug, v' required. *)
 | get_pdot: forall (v v': E),
               Value v ->
               get v [] v'
 | get_l:    forall (v v0 v1 : E) (p : P),
               Value v  ->
               Value v0 ->
               Value v1 ->
               get v0 p v ->
               get (cpair v0 v1) ((i_pe (i_i 0)) :: p) v
 | get_r:    forall (v v0 v1 : E) (p : P),
               Value v  ->
               Value v0 ->
               Value v1 ->
               get v1 p v ->
               get (cpair v0 v1) ((i_pe (i_i 1)) :: p) v
 | get_pack: forall (v v1 : E) (p : P) (tau tau' : Tau) (alpha : TVar) (k : Kappa),
               Value v  ->
               Value v1 ->
               get v1 p v ->
               get (pack tau' v1 (etype aliases alpha k tau)) (u_pe :: p) v.

Inductive set : E -> P -> E -> E -> Prop :=
  (* Dan ? *)
  | set_ip: forall (v v' v'': E),
                Value v  ->
                Value v' ->
                Value v'' ->
                set v' [] v v''

  | set_l:    forall (v v' v0 v1 : E) (p : P),
                Value v  ->
                Value v' ->
                Value v0 ->
                set v0 p v v' ->
                set (cpair v0 v1)  ((i_pe (i_i 0)) :: p) v (cpair v' v1)
  | set_r:    forall (v v' v0 v1 : E) (p : P),
                Value v  ->
                Value v' ->
                Value v0 ->
                set v1 p v v' ->
                set (cpair v0 v1)  ((i_pe (i_i 1)) :: p) v (cpair v0 v')
  | set_pack: forall (v v' v1 : E) (p : P) (tau tau' : Tau) (q : Phi) (alpha : TVar) (k : Kappa),
                Value v  ->
                Value v' ->
                Value v1 ->
                set (pack tau' v1 (etype q alpha k tau)) (u_pe :: p) v (pack tau' v' (etype q alpha k tau)).


Require Export List.
Require Export Arith.Peano_dec.
Require Export Program.Syntax. (* eg for multiple exists tactic *)
Require Import Numbers.Natural.Peano.NPeano.
Require Import Arith.Compare_dec.
Require Import Omega.

Set Implicit Arguments.

(* List notation with head on the right *)
Notation "E '&' F" := (app F E) (at level 31, left associativity).
Notation " E  ;; x " := (cons x E) (at level 29, left associativity).

(* Testing the list notations: *)
Module ListNotationTests.
Definition head(l: list nat) := match l with
| nil => 777
| cons x xs => x
end.
Eval compute in nil ;; 1 ;; 2 ;; 3.
Eval compute in head (nil ;; 1 ;; 2 ;; 3).
Eval compute in head ((nil ;; 1 ;; 2 ;; 3) & (nil ;; 4 ;; 5)).
Eval compute in nil ;; 1 ;; 2 & nil ;; 3 ;; 4 & nil ;; 5 ;; 6.
(* Unset Printing Notations. (* or by CoqIDE menu *) *)
Check (nil ;; 0 & nil ;; 0 ;; 0 & nil ;; 0 ;; 0 ;; 0).
End ListNotationTests.

Definition var := nat.

(* If it's clear whether a field or method is meant, we use nat, if not, we use label: *)
Inductive label: Type :=
| label_fld: nat -> label
| label_mtd: nat -> label.

Lemma eq_label_dec: forall l1 l2: label, {l1 = l2} + {l1 <> l2}.
Proof.
  intros.
  destruct l1 as [n1|n1]; destruct l2 as [n2|n2];
  destruct (eq_nat_dec n1 n2); solve [
     (left; f_equal; assumption) |
     (right; unfold not; intro H; inversion H; rewrite H1 in n; apply n; reflexivity)].
Qed.

Inductive avar : Type :=
  | avar_b : nat -> avar  (* bound var (de Bruijn index) *)
  | avar_f : var -> avar. (* free var ("name"), refers to tenv or venv *)

Inductive typ : Type :=
  | typ_rcd  : list ndec -> typ (* record type *)
with ndec : Type := (* named declaration *)
  | ndec_fld : nat -> typ -> ndec
  | ndec_mtd : nat -> typ -> typ -> ndec.
Inductive dec : Type := (* declaration without name *)
  | dec_fld  : typ -> dec
  | dec_mtd  : typ -> typ -> dec.

Inductive trm : Type :=
  | trm_var  : avar -> trm
  | trm_new  : list nini -> trm -> trm
  | trm_sel  : trm -> nat -> trm
  | trm_call : trm -> nat -> trm -> trm
with nini : Type :=
  | nini_fld : nat -> avar -> nini (* cannot have term here, need to assign first *)
  | nini_mtd : nat -> typ -> trm -> nini.
Inductive ini : Type :=
  | ini_fld : avar -> ini
  | ini_mtd : typ -> trm -> ini.

(* Syntactic sugar *)
Definition trm_fun(T: typ)(body: trm) := trm_new (nil ;; nini_mtd 0 T body)
                                                 (trm_var (avar_b 0)).
Definition trm_app(func arg: trm) := trm_call func 0 arg.
Definition trm_let(T: typ)(rhs body: trm) := trm_app (trm_fun T body) rhs.
Definition trm_upcast(T: typ)(e: trm) := trm_app (trm_fun T (trm_var (avar_b 0))) e.
Definition typ_arrow(T1 T2: typ) := typ_rcd (nil ;; ndec_mtd 0 T1 T2).

(* ... opening ...
   replaces in some syntax a bound variable with dangling index (k) by a free variable x
*)

Fixpoint open_rec_avar (k: nat) (u: var) (a: avar) { struct a } : avar :=
  match a with
  | avar_b i => if eq_nat_dec k i then avar_f u else avar_b i
  | avar_f x => avar_f x
  end.

(* The only binders are trm_new and (n)ini_mtd, which cannot be inside a typ or
   inside a dec, so we don't need opening for typ and dec *)

Fixpoint open_rec_trm (k: nat) (u: var) (t: trm) { struct t } : trm :=
  match t with
  | trm_var  a     => trm_var (open_rec_avar k u a)
  | trm_new  is e  => trm_new (map (open_rec_nini (S k) u) is) (open_rec_trm (S k) u e)
  | trm_sel  e n   => trm_sel (open_rec_trm k u e) n
  | trm_call o m a => trm_call (open_rec_trm k u o) m (open_rec_trm k u a)
  end
with open_rec_nini (k: nat) (u: var) (i: nini) { struct i } : nini :=
  match i with
  | nini_fld n a   => nini_fld n (open_rec_avar k u a)
  | nini_mtd n T e => nini_mtd n T (open_rec_trm (S k) u e)
  end.

Definition open_avar u a := open_rec_avar 0 u a.
Definition open_trm  u e := open_rec_trm  0 u e.
Definition open_nini u i := open_rec_nini 0 u i.

Inductive fvar : avar -> Prop :=
  | fvar_f : forall x,
      fvar (avar_f x).

(*
Environment requirements:
   * Want to use the same definitions and lemmas for
     - decs
     - inis
     - tenv
     - venv
   * Intersection of two dec lists must be total, i.e. if we have
     (m: T -> U) in ds1 and (m: T) in ds2,
     then (ds1 /\ ds2) must be defined and contain both declarations.
     This requires that method labels be distinct from field labels, or that
     the environment data structure allows two decs with the same name if they
     are of a different kind.
   * Want to have generic dec (dec_typ, dec_mtd, dec_fld), and treat dec lists as
     as mappings from dec name to dec, instead of having three separate lists.
Hopefully, this module system approach satisfies the requirements.
*)

Module Type EnvParams.
Parameter K : Type.
Parameter V : Type.
Parameter B : Type.
Parameter key: B -> K.
Parameter value: B -> V.
Axiom eq_key_dec: forall k1 k2: K, {k1 = k2} + {k1 <> k2}.
Axiom key_val_eq_eq: forall b1 b2, key b1 = key b2 -> value b1 = value b2 -> b1 = b2.
End EnvParams.

Ltac inv H := inversion H; clear H; subst.

(* General environment *)
Module Env (params: EnvParams).
Import params.
Definition key := key.
Definition value := value.
Definition t := list B.
Fixpoint get(k: K)(E: t): option V := match E with
  | nil => None
  | bs ;; b => if eq_key_dec k (key b) then Some (value b) else get k bs
  end.
Definition binds(k: K)(v: V)(E: t): Prop := (get k E = Some v).
Definition unbound(k: K)(E: t): Prop := (get k E = None).

Ltac empty_binds_contradiction := match goal with
| H: binds _ _ [] |- _ => inversion H
end.
(*
Tactic Notation "unfoldg" reference(I)             := unfold I, get; fold get.
Tactic Notation "unfoldg" reference(I) "in" hyp(H) := unfold I, get in H; fold get in H.
*)
Ltac unfoldg I := unfold I, get in *; fold get in *.
Ltac destruct_key_if := match goal with
| H:   context[if eq_key_dec ?k1 ?k2 then _ else _] |- _ => destruct (eq_key_dec k1 k2)
|   |- context[if eq_key_dec ?k1 ?k2 then _ else _]      => destruct (eq_key_dec k1 k2)
end.
Ltac compare_keys := match goal with
| _ :  context[binds _ _ (?E ;; ?b)] |- _ => unfoldg binds;   destruct_key_if
|   |- context[binds _ _ (?E ;; ?b)]      => unfoldg binds;   destruct_key_if
| _ :  context[unbound _ (?E ;; ?b)] |- _ => unfoldg unbound; destruct_key_if
|   |- context[unbound _ (?E ;; ?b)]      => unfoldg unbound; destruct_key_if
end. (* We don't just put destruct_key_if 1x here, because if it fails, match has to try
        the next branch
Ltac compare_keys := match goal with
| _ :  context[binds _ _ (?E ;; ?b)] |- _ => unfoldg binds
|   |- context[binds _ _ (?E ;; ?b)]      => unfoldg binds
| _ :  context[unbound _ (?E ;; ?b)] |- _ => unfoldg unbound
|   |- context[unbound _ (?E ;; ?b)]      => unfoldg unbound
end; destruct_key_if. *)

Lemma map_head: forall (E: t) (b: B) (f: B -> B), map f (E ;; b) = (map f E) ;; (f b).
Proof.
  intros. simpl. reflexivity.
Qed.
Lemma concat_cons_assoc: forall (E1: t) (E2: t) (b: B), E1 & (E2 ;; b) = (E1 & E2) ;; b.
Proof.
  intros. simpl. reflexivity.
Qed.
Lemma binds_unbound_head_inv: forall E b, unbound (key b) (E ;; b) -> False.
Proof.
  intros. compare_keys.
  + discriminate H.
  + apply n. reflexivity.
Qed.
Lemma unbound_cons_inv: forall E k b, unbound k (E ;; b) -> unbound k E.
Proof.
  intros. compare_keys.
  + inversion H.
  + assumption.
Qed.
Lemma binds_push_eq_inv: forall E a b,
  binds (key a) (value b) (E ;; a) -> value a = value b.
Proof.
  intros. compare_keys.
  + inversion H. reflexivity.
  + contradiction n. reflexivity.
Qed.
Lemma binds_binding_inv: forall k v E, binds k v E -> exists b, key b = k /\ value b = v.
Proof.
  intros k v E. induction E; intros.
  + empty_binds_contradiction.
  + compare_keys.
    - inversion H. rewrite -> H1. exists a. symmetry in e. split; assumption.
    - unfold binds in IHE. apply IHE. assumption.
Qed.
Lemma binds_map: forall b (f : B -> B) E,
  (forall a, key (f a) = key a) ->
  binds (key b) (value b) E ->
  binds (key (f b)) (value (f b)) (map f E).
Proof.
  intros. induction E.
  + empty_binds_contradiction.
  + simpl. unfoldg binds. rewrite -> (H a). rewrite -> (H b). destruct_key_if.
    - inv H0. do 3 f_equal. symmetry in e. apply key_val_eq_eq; assumption.
    - rewrite -> (H b) in IHE. apply (IHE H0).
Qed.
Lemma unbound_map: forall k (f : B -> B) E,
  (forall a, key (f a) = key a) ->
  unbound k E ->
  unbound k (map f E).
Proof.
  intros. induction E.
  + simpl. assumption.
  + simpl. unfoldg unbound. fold get. rewrite -> (H a). destruct_key_if.
    - discriminate H0.
    - apply IHE. assumption.
Qed.
Lemma binds_concat_right : forall k v E1 E2,
  binds k v E2 ->
  binds k v (E1 & E2).
Proof.
  intros. induction E2.
  + empty_binds_contradiction.
  + rewrite -> concat_cons_assoc. compare_keys.
    - assumption.
    - apply IHE2. assumption.
Qed.
Lemma binds_concat_left_inv : forall k v E1 E2,
  binds k v (E1 & E2) ->
  unbound k E2 ->
  binds k v E1.
Proof.
  intros. induction E2.
  + simpl in H. assumption.
  + rewrite -> concat_cons_assoc in H. compare_keys.
    - exfalso. rewrite -> e in H0. apply (binds_unbound_head_inv H0).
    - apply IHE2. assumption. apply (unbound_cons_inv H0).
Qed.
Lemma binds_concat_left : forall k v E1 E2,
  binds k v E1 ->
  unbound k E2 ->
  binds k v (E1 & E2).
Proof.
  intros. induction E2.
  + simpl. assumption.
  + rewrite -> concat_cons_assoc. compare_keys.
    - exfalso. rewrite -> e in H0. apply (binds_unbound_head_inv H0).
    - apply IHE2. apply (unbound_cons_inv H0).
Qed.
Lemma binds_unbound_inv : forall k v E,
  binds k v E -> unbound k E -> False.
Proof.
  intros. induction E.
  + inv H.
  + compare_keys.
    - subst. apply (binds_unbound_head_inv H0).
    - apply IHE. assumption. apply (unbound_cons_inv H0).
Qed.
Lemma binds_unique : forall k v1 v2 E,
  binds k v1 E -> binds k v2 E -> v1 = v2.
Proof.
  intros. induction E.
  + inv H.
  + compare_keys.
    - inv H. inv H0. reflexivity.
    - inv H. inv H0. apply IHE; assumption.
Qed.
Lemma build_unbound: forall k E, (forall k' v, binds k' v E -> k' <> k) -> unbound k E.
Proof.
  intros. induction E.
  + reflexivity.
  + compare_keys.
    - specialize (H k (value a)). compare_keys.
      * specialize (H eq_refl). contradiction H. reflexivity.
      * contradiction n.
    - apply IHE. intros. destruct (eq_key_dec k' (key a)) eqn: Hdestr.
      * rewrite <- e in n. intro. symmetry in H1. contradiction H1.
      * apply H with v. unfoldg binds. rewrite -> Hdestr. assumption.
Qed.
End Env.

(* Module decs: For lists of declarations: [list ndec] or [label => dec] *)
Module decsParams <: EnvParams.
Definition K := label.
Definition V := dec.
Definition B := ndec.
Definition key(d: ndec): label := match d with
| ndec_fld n T => label_fld n
| ndec_mtd n T U => label_mtd n
end.
Definition value(d: ndec): dec := match d with
| ndec_fld n T => dec_fld T
| ndec_mtd n T U => dec_mtd T U
end.
Definition eq_key_dec := eq_label_dec.
Lemma key_val_eq_eq: forall b1 b2, key b1 = key b2 -> value b1 = value b2 -> b1 = b2.
Proof.
  intros. destruct b1, b2.
  + inv H. inv H0. reflexivity.
  + inv H.
  + inv H.
  + inv H. inv H0. reflexivity.
Qed.
End decsParams.
Module decs := Env(decsParams).

(* Module inis: For lists of initialisations: [list nini] or [label => ini] *)
Module inisParams <: EnvParams.
Definition K := label.
Definition V := ini.
Definition B := nini.
Definition key(i: nini): label := match i with
| nini_fld n T => label_fld n
| nini_mtd n T e => label_mtd n
end.
Definition value(i: nini): ini := match i with
| nini_fld n T => ini_fld T
| nini_mtd n T e => ini_mtd T e
end.
Definition eq_key_dec := eq_label_dec.
Lemma key_val_eq_eq: forall b1 b2, key b1 = key b2 -> value b1 = value b2 -> b1 = b2.
Proof.
  intros. destruct b1, b2.
  + inv H. inv H0. reflexivity.
  + inv H.
  + inv H.
  + inv H. inv H0. reflexivity.
Qed.
End inisParams.
Module inis := Env(inisParams).

(* Module tenv: For type environments: [var => typ] *)
Module tenvParams <: EnvParams.
Definition K := var.
Definition V := typ.
Definition B := (var * typ)%type.
Definition key := @fst var typ.
Definition value := @snd var typ.
Definition eq_key_dec := eq_nat_dec.
Lemma key_val_eq_eq: forall b1 b2, key b1 = key b2 -> value b1 = value b2 -> b1 = b2.
Proof.
  intros. destruct b1, b2. unfold key, fst, value, snd in *. subst. reflexivity.
Qed.
End tenvParams.
Module tenv := Env(tenvParams).

(* Module venv: For value environments: [var => inis] *)
Module venvParams <: EnvParams.
Definition K := var.
Definition V := inis.t.
Definition B := (var * inis.t)%type.
Definition key := @fst var inis.t.
Definition value := @snd var inis.t.
Definition eq_key_dec := eq_nat_dec.
Lemma key_val_eq_eq: forall b1 b2, key b1 = key b2 -> value b1 = value b2 -> b1 = b2.
Proof.
  intros. destruct b1, b2. unfold key, fst, value, snd in *. subst. reflexivity.
Qed.
End venvParams.
Module venv := Env(venvParams).

Module Type IntersectionPreview.

(* Will be part of syntax: *)
Parameter t_and: typ -> typ -> typ.
Parameter t_or:  typ -> typ -> typ.

(* Left as an exercise for the reader ;-) We define intersection by the spec below. *)
Parameter intersect: decs.t -> decs.t -> decs.t.

Axiom intersect_spec_1: forall l d ds1 ds2,
  decs.binds   l d ds1 ->
  decs.unbound l ds2 ->
  decs.binds   l d (intersect ds1 ds2).

Axiom intersect_spec_2: forall l d ds1 ds2,
  decs.unbound l ds1 ->
  decs.binds   l d ds2 ->
  decs.binds   l d (intersect ds1 ds2).

Axiom intersect_spec_12_fld: forall n T1 T2 ds1 ds2,
  decs.binds (label_fld n) (dec_fld T1) ds1 ->
  decs.binds (label_fld n) (dec_fld T2) ds2 ->
  decs.binds (label_fld n) (dec_fld (t_and T1 T2)) (intersect ds1 ds2).

Axiom intersect_spec_12_mtd: forall n S1 T1 S2 T2 ds1 ds2,
  decs.binds (label_mtd n) (dec_mtd S1 T1) ds1 ->
  decs.binds (label_mtd n) (dec_mtd S2 T2) ds2 ->
  decs.binds (label_mtd n) (dec_mtd (t_or S1 S2) (t_and T1 T2)) (intersect ds1 ds2).

End IntersectionPreview.

(* Exercise: Give any implementation of `intersect`, and prove that it satisfies
   the specification. Happy hacking! ;-) *)
Module IntersectionPreviewImpl <: IntersectionPreview.

(* Will be part of syntax: *)
Parameter t_and: typ -> typ -> typ.
Parameter t_or:  typ -> typ -> typ.

Fixpoint get_fld(n: nat)(ds: decs.t): option typ := match ds with
  | nil => None
  | tail ;; d => match d with
      | ndec_fld m T => if eq_nat_dec n m then Some T else get_fld n tail
      | _ => get_fld n tail
      end
  end.
(*
Lemma get_fld_spec: forall n ds, decs.get (label_fld n) ds = dec_fld (get_fld n ds).
Proof.
*)

Fixpoint refine_dec(d1: ndec)(ds2: decs.t): ndec := match ds2 with
| nil => d1
| tail2 ;; d2 => match d1, d2 with
    | ndec_fld n1 T1   , ndec_fld n2 T2    => if eq_nat_dec n1 n2
                                              then ndec_fld n1 (t_and T1 T2)
                                              else refine_dec d1 tail2
    | ndec_mtd n1 T1 S1, ndec_mtd n2 T2 S2 => if eq_nat_dec n1 n2
                                              then ndec_mtd n1 (t_or T1 T2) (t_and S1 S2)
                                              else refine_dec d1 tail2
    | _, _ => refine_dec d1 tail2
    end
end.

Ltac destruct_matchee :=
  match goal with
  | [ Hm: match ?e1 with _ => _ end = _ |- _ ]  =>
      remember e1 as mExpr; destruct mExpr
  | [ Hm: if ?e1 then _ else _ = _ |- _ ]  =>
      remember e1 as mExpr; destruct mExpr
  end.

Lemma refine_dec_spec_fld: forall ds2 n T1 T2,
  decs.binds (label_fld n) (dec_fld T2) ds2 ->
  (refine_dec (ndec_fld n T1) ds2) = (ndec_fld n (t_and T1 T2)).
Proof.
  intro ds2. induction ds2; intros.
  + decs.empty_binds_contradiction.
  + decs.compare_keys.
    - inv H. unfold decs.value, decsParams.value in H1. destruct a eqn: Heqa.
      * inv H1. inversion e. subst. simpl. destruct (eq_nat_dec n0 n0). reflexivity.
        contradiction n. reflexivity.
      * inv H1.
    - simpl. destruct a eqn: Heqa.
      * assert (Hnn: n <> n1). unfold not in *. intro. apply n0. simpl. f_equal. assumption.
        destruct (eq_nat_dec n n1). contradiction Hnn.
        apply IHds2. unfold decs.binds, decs.get. unfold decs.key, decsParams.key.
        assumption.
      * apply IHds2. unfold decs.binds, decs.get. unfold decs.key, decsParams.key.
        assumption.
Qed.

Lemma refine_dec_spec_mtd: forall ds2 n T1 S1 T2 S2,
  decs.binds (label_mtd n) (dec_mtd T2 S2) ds2 ->
  (refine_dec (ndec_mtd n T1 S1) ds2) = (ndec_mtd n (t_or T1 T2) (t_and S1 S2)).
Proof.
  intro ds2. induction ds2; intros.
  + decs.empty_binds_contradiction.
  + decs.compare_keys.
    - inv H. destruct a eqn: Heqa.
      * inv H1.
      * inv H1. inversion e. subst. simpl. destruct (eq_nat_dec n0 n0). reflexivity.
        contradiction n. reflexivity.
    - simpl. destruct a eqn: Heqa.
      * apply IHds2. assumption.
      * assert (Hnn: n <> n1). unfold not in *. intro. apply n0. simpl. f_equal. assumption.
        destruct (eq_nat_dec n n1). contradiction Hnn.
        apply IHds2. assumption.
Qed.

Lemma refine_dec_spec_label: forall d1 ds2, decs.key d1 = decs.key (refine_dec d1 ds2).
Proof.
  intros.
  induction ds2.
  + simpl. reflexivity.
  + unfold decs.key, decsParams.key. unfold refine_dec. destruct a; destruct d1.
    - destruct (eq_nat_dec n0 n).
      * simpl. reflexivity.
      * fold refine_dec. unfold decs.key, decsParams.key in IHds2.
        rewrite <- IHds2. reflexivity.
    - fold refine_dec. unfold decs.key, decsParams.key in IHds2.
        rewrite <- IHds2. reflexivity.
    - fold refine_dec. unfold decs.key, decsParams.key in IHds2.
        rewrite <- IHds2. reflexivity.
    - destruct (eq_nat_dec n0 n).
      * simpl. reflexivity.
      * fold refine_dec. unfold decs.key, decsParams.key in IHds2.
        rewrite <- IHds2. reflexivity.
Qed.

Lemma refine_dec_spec_unbound: forall d1 ds2,
  decs.unbound (decs.key d1) ds2 ->
  decs.value (refine_dec d1 ds2) = decs.value d1.
Proof.
  intros.
  induction ds2.
  + simpl. reflexivity.
  + unfold decs.key, decsParams.key. unfold refine_dec. destruct a; destruct d1.
    - destruct (eq_nat_dec n0 n) eqn: Hn0ndec.
      * subst.
        assert (Hkeq: (decs.key (ndec_fld n t0)) = (decs.key (ndec_fld n t)))
          by reflexivity.
        rewrite -> Hkeq in H.
        exfalso. apply (decs.binds_unbound_head_inv H).
      * fold refine_dec. apply IHds2.
        inv H. unfold decsParams.eq_key_dec in H1.
        destruct (eq_label_dec (label_fld n0) (label_fld n)).
        { inv e. contradiction n1. reflexivity. }
        { unfold decs.unbound. unfold decs.key, decsParams.key. assumption. }
    - fold refine_dec. unfold decs.key, decsParams.key in *.
      apply decs.unbound_cons_inv in H. apply (IHds2 H).
    - fold refine_dec. unfold decs.key, decsParams.key in *.
      apply decs.unbound_cons_inv in H. apply (IHds2 H).
    - destruct (eq_nat_dec n0 n) eqn: Hn0ndec.
      * subst.
        assert (Hkeq: (decs.key (ndec_mtd n t1 t2)) = (decs.key (ndec_mtd n t t0)))
          by reflexivity.
        rewrite -> Hkeq in H.
        exfalso. apply (decs.binds_unbound_head_inv H).
      * fold refine_dec. apply IHds2.
        inv H. unfold decsParams.eq_key_dec in H1.
        destruct (eq_label_dec (label_mtd n0) (label_mtd n)).
        { inv e. contradiction n1. reflexivity. }
        { unfold decs.unbound. unfold decs.key, decsParams.key. assumption. }
Qed.

Definition refine_decs(ds1: decs.t)(ds2: decs.t): decs.t :=
  map (fun d1 => refine_dec d1 ds2) ds1.

Lemma refine_decs_spec_unbound: forall l d ds1 ds2,
  decs.binds   l d ds1 ->
  decs.unbound l ds2 ->
  decs.binds   l d (refine_decs ds1 ds2).
Proof.
  intros. unfold refine_decs.
  assert (Hex: exists nd, decs.key nd = l /\ decs.value nd = d).
    apply (@decs.binds_binding_inv l d ds1 H).
  destruct Hex as [nd [Hl Hd]]. subst.
  remember (fun d1 => refine_dec d1 ds2) as f.
  assert (Hk: (decs.key nd) = decs.key (f nd)).
    subst. apply (refine_dec_spec_label nd ds2).
  rewrite -> Hk.
  assert (Hv: (decs.value nd) = decs.value (f nd)).
    subst. symmetry. apply (refine_dec_spec_unbound _ H0).
  rewrite -> Hv.
  apply decs.binds_map.
    intro. rewrite -> Heqf. symmetry. apply refine_dec_spec_label.
    assumption.
Qed.

Lemma refine_decs_spec_unbound_preserved: forall l ds1 ds2,
  decs.unbound l ds1 ->
  decs.unbound l (refine_decs ds1 ds2).
Proof.
  intros. unfold refine_decs. remember (fun d1 => refine_dec d1 ds2) as f.
  refine (@decs.unbound_map l f ds1 _ H).
  subst. intro. symmetry. apply refine_dec_spec_label.
Qed.

Lemma refine_decs_spec_fld: forall n ds1 ds2 T1 T2,
  decs.binds (label_fld n) (dec_fld T1) ds1 ->
  decs.binds (label_fld n) (dec_fld T2) ds2 ->
  decs.binds (label_fld n) (dec_fld (t_and T1 T2)) (refine_decs ds1 ds2).
Proof.
  intros n ds1 ds2 T1 T2 H. induction ds1; intros.
  + decs.empty_binds_contradiction.
  + unfold decs.binds, decs.get in H. destruct a eqn: Heqa.
    - fold decs.get in H. unfold decs.key, decsParams.key in H.
      destruct (decsParams.eq_key_dec (label_fld n) (label_fld n0)).
      * inv H. inv e.
        unfold decs.binds, decs.get. simpl. fold decs.get.
        rewrite <- (@refine_dec_spec_label (ndec_fld n0 T1) ds2).
        unfold decs.key, decsParams.key.
        destruct (decsParams.eq_key_dec (label_fld n0) (label_fld n0)). {
          f_equal. rewrite -> (@refine_dec_spec_fld ds2 n0 T1 T2 H0).
          simpl. reflexivity.
        } { contradiction n. reflexivity. }
      * assert (Hnn: n <> n0). unfold not in *. intro. apply n1. f_equal. assumption.
        unfold decs.binds, decs.get. simpl. fold decs.get.
        rewrite <- (@refine_dec_spec_label (ndec_fld n0 t) ds2).
        unfold decs.key, decsParams.key.
        destruct (decsParams.eq_key_dec (label_fld n) (label_fld n0)). {
          inv e. contradiction Hnn. reflexivity.
        } {
          unfold decs.binds in *. apply IHds1; assumption.
        }
    - fold decs.get in H. unfold decs.key, decsParams.key in H.
      destruct (decsParams.eq_key_dec (label_fld n) (label_fld n0)).
      * inv H. inv e.
        unfold decs.binds, decs.get. simpl. fold decs.get.
        rewrite <- (@refine_dec_spec_label (ndec_mtd n0 t t0) ds2).
        unfold decs.key, decsParams.key.
        destruct (decsParams.eq_key_dec (label_fld n0) (label_mtd n0)). {
          inv H2.
        } {
          unfold decs.binds in *. apply IHds1; assumption.
        }
      * assert (Hnn: n <> n0). unfold not in *. intro. apply n1. f_equal. assumption.
        unfold decs.binds, decs.get. simpl. fold decs.get.
        rewrite <- (@refine_dec_spec_label (ndec_mtd n0 t t0) ds2).
        unfold decs.key, decsParams.key.
        destruct (decsParams.eq_key_dec (label_fld n) (label_fld n0)). {
          inv e. contradiction Hnn. reflexivity.
        } {
          destruct (decsParams.eq_key_dec (label_fld n) (label_mtd n0)).
          + inv e.
          + unfold decs.binds in *. apply IHds1; assumption.
        }
Qed.

Lemma refine_decs_spec_mtd: forall n ds1 ds2 T1 S1 T2 S2,
  decs.binds (label_mtd n) (dec_mtd T1 S1) ds1 ->
  decs.binds (label_mtd n) (dec_mtd T2 S2) ds2 ->
  decs.binds (label_mtd n) (dec_mtd (t_or T1 T2) (t_and S1 S2)) (refine_decs ds1 ds2).
Proof.
  intros n ds1 ds2 T1 S1 T2 S2 H. induction ds1; intros.
  + decs.empty_binds_contradiction.
  + unfold decs.binds, decs.get in H. destruct a eqn: Heqa.
    - fold decs.get in H. unfold decs.key, decsParams.key in H.
      destruct (decsParams.eq_key_dec (label_mtd n) (label_mtd n0)).
      * inv H. inv e.
        unfold decs.binds, decs.get. simpl. fold decs.get.
        rewrite <- (@refine_dec_spec_label (ndec_fld n0 t) ds2).
        unfold decs.key, decsParams.key.
        destruct (decsParams.eq_key_dec (label_mtd n0) (label_fld n0)). {
          inv H2.
        } {
          unfold decs.binds in *. apply IHds1; assumption.
        }
      * assert (Hnn: n <> n0). unfold not in *. intro. apply n1. f_equal. assumption.
        unfold decs.binds, decs.get. simpl. fold decs.get.
        rewrite <- (@refine_dec_spec_label (ndec_fld n0 t) ds2).
        unfold decs.key, decsParams.key.
        destruct (decsParams.eq_key_dec (label_mtd n) (label_mtd n0)). {
          inv e. contradiction Hnn. reflexivity.
        } {
          destruct (decsParams.eq_key_dec (label_mtd n) (label_fld n0)).
          + inv e.
          + unfold decs.binds in *. apply IHds1; assumption.
        }
    - fold decs.get in H. unfold decs.key, decsParams.key in H.
      destruct (decsParams.eq_key_dec (label_mtd n) (label_mtd n0)).
      * inv H. inv e.
        unfold decs.binds, decs.get. simpl. fold decs.get.
        rewrite <- (@refine_dec_spec_label (ndec_mtd n0 T1 S1) ds2).
        unfold decs.key, decsParams.key.
        destruct (decsParams.eq_key_dec (label_mtd n0) (label_mtd n0)). {
          f_equal. rewrite -> (@refine_dec_spec_mtd ds2 n0 T1 S1 T2 S2 H0).
          simpl. reflexivity.
        } { contradiction n. reflexivity. }
      * assert (Hnn: n <> n0). unfold not in *. intro. apply n1. f_equal. assumption.
        unfold decs.binds, decs.get. simpl. fold decs.get.
        rewrite <- (@refine_dec_spec_label (ndec_mtd n0 t t0) ds2).
        unfold decs.key, decsParams.key.
        destruct (decsParams.eq_key_dec (label_mtd n) (label_mtd n0)). {
          inv e. contradiction Hnn. reflexivity.
        } {
          unfold decs.binds in *. apply IHds1; assumption.
        }
Qed.

(* refined decs shadow the outdated decs of ds2 *)
Definition intersect(ds1 ds2: decs.t): decs.t := ds2 & (refine_decs ds1 ds2).

Lemma intersect_spec_1: forall l d ds1 ds2,
  decs.binds   l d ds1 ->
  decs.unbound l ds2 ->
  decs.binds   l d (intersect ds1 ds2).
Proof.
  intros. unfold intersect. apply decs.binds_concat_right.
  apply refine_decs_spec_unbound; assumption.
Qed.

Lemma intersect_spec_2: forall l d ds1 ds2,
  decs.unbound l ds1 ->
  decs.binds   l d ds2 ->
  decs.binds   l d (intersect ds1 ds2).
Proof.
  intros. unfold intersect.
  apply (@decs.binds_concat_left l d ds2 (refine_decs ds1 ds2) H0).
  apply (@refine_decs_spec_unbound_preserved l ds1 ds2 H).
Qed.

Lemma intersect_spec_12_fld: forall n T1 T2 ds1 ds2,
  decs.binds (label_fld n) (dec_fld T1) ds1 ->
  decs.binds (label_fld n) (dec_fld T2) ds2 ->
  decs.binds (label_fld n) (dec_fld (t_and T1 T2)) (intersect ds1 ds2).
Proof.
  intros. unfold intersect. apply decs.binds_concat_right.
  apply refine_decs_spec_fld; assumption.
Qed.

Lemma intersect_spec_12_mtd: forall n S1 T1 S2 T2 ds1 ds2,
  decs.binds (label_mtd n) (dec_mtd S1 T1) ds1 ->
  decs.binds (label_mtd n) (dec_mtd S2 T2) ds2 ->
  decs.binds (label_mtd n) (dec_mtd (t_or S1 S2) (t_and T1 T2)) (intersect ds1 ds2).
Proof.
  intros. unfold intersect. apply decs.binds_concat_right.
  apply refine_decs_spec_mtd; assumption.
Qed.

End IntersectionPreviewImpl.

(** Operational Semantics **)
(* Note: Terms given by user are closed, so they only contain avar_b, no avar_f.
   Whenever we introduce a new avar_f (only happens in red_new), we choose one
   which is not in the store, so we never have name clashes. *)
Inductive red : venv.t -> trm -> venv.t -> trm -> Prop :=
  (* computation rules *)
  | red_call : forall (s: venv.t) (x y: var) (m: nat) (T: typ) (is: inis.t) (body: trm),
      venv.binds x is s ->
      inis.binds (label_mtd m) (ini_mtd T body) is ->
      red s (trm_call (trm_var (avar_f x)) m (trm_var (avar_f y)))
          s (open_trm y body)
  | red_sel : forall (s: venv.t) (x: var) (y: avar) (l: nat) (is: inis.t),
      venv.binds x is s ->
      inis.binds (label_fld l) (ini_fld y) is ->
      red s (trm_sel (trm_var (avar_f x)) l) s
            (trm_var y)
  | red_new : forall (s: venv.t) (is: inis.t) (e: trm) (x: var),
      venv.unbound x s ->
      red s (trm_new is e)
          (s ;; (x, is)) (open_trm x e)
  (* congruence rules *)
  | red_call1 : forall s o m a s' o',
      red s o s' o' ->
      red s  (trm_call o  m a)
          s' (trm_call o' m a)
  | red_call2 : forall s x m a s' a',
      red s a s' a' ->
      red s  (trm_call (trm_var (avar_f x)) m a )
          s' (trm_call (trm_var (avar_f x)) m a')
  | red_sel1 : forall s o l s' o',
      red s o s' o' ->
      red s  (trm_sel o  l)
          s' (trm_sel o' l).

(* Term typing *)
Inductive has : tenv.t -> venv.t -> trm -> label -> dec -> Prop :=
  | has_dec : forall G s e l d ds,
      typing_trm G s e (typ_rcd ds) ->
      decs.binds l d ds ->
      has G s e l d
with typing_trm : tenv.t -> venv.t -> trm -> typ -> Prop :=
  | typing_trm_var_g : forall G s x T,
      tenv.binds x T G ->
      venv.unbound x s ->
      typing_trm G s (trm_var (avar_f x)) T
  | typing_trm_var_s : forall G s x is ds,
      tenv.unbound x G ->
      venv.binds x is s ->
      typing_inis nil s is ds ->
      typing_trm G s (trm_var (avar_f x)) (typ_rcd ds)
  | typing_trm_sel : forall G s e l T,
      has G s e (label_fld l) (dec_fld T) ->
      typing_trm G s (trm_sel e l) T
  | typing_trm_call : forall G s t m U V u,
      has G s t (label_mtd m) (dec_mtd U V) ->
      typing_trm G s u U ->
      typing_trm G s (trm_call t m u) V
  | typing_trm_new : forall G s nis ds t T,
      typing_inis G s nis ds -> (* no self reference yet, no recursion *)
      (forall x, tenv.unbound x G ->
                 venv.unbound x s ->
                 typing_trm (G ;; (x, typ_rcd ds)) s (open_trm x t) T) ->
      typing_trm G s (trm_new nis t) T
with typing_ini : tenv.t -> venv.t -> nini -> ndec -> Prop :=
  | typing_ini_fld : forall G s l v T,
      typing_trm G s (trm_var v) T ->
      typing_ini G s (nini_fld l v) (ndec_fld l T)
  | typing_ini_mtd : forall G s m S T t,
      (forall x, tenv.unbound x G ->
                 venv.unbound x s ->
                 typing_trm (G ;; (x, S)) s (open_trm x t) T) ->
      typing_ini G s (nini_mtd m S t) (ndec_mtd m S T)
with typing_inis : tenv.t -> venv.t -> inis.t -> decs.t -> Prop :=
  | typing_inis_nil : forall G s,
      typing_inis G s nil nil
  | typing_inis_cons : forall G s is i ds d,
      typing_inis G s is ds ->
      typing_ini  G s i d ->
      typing_inis G s (is ;; i) (ds ;; d).

Scheme has_mut         := Induction for has         Sort Prop
with   typing_trm_mut  := Induction for typing_trm  Sort Prop
with   typing_ini_mut  := Induction for typing_ini  Sort Prop
with   typing_inis_mut := Induction for typing_inis Sort Prop.

Combined Scheme typing_mutind from has_mut, typing_trm_mut, typing_ini_mut, typing_inis_mut.

Lemma invert_has: forall G s e l d,
  has G s e l d ->
  exists ds, typing_trm G s e (typ_rcd ds) /\ decs.binds l d ds.
Proof.
  intros. inv H. eauto.
Qed.

Lemma invert_typing_trm_call: forall G s t m V u,
  typing_trm G s (trm_call t m u) V ->
  exists U, has G s t (label_mtd m) (dec_mtd U V) /\ typing_trm G s u U.
Proof.
  intros. inv H. eauto.
Qed.

Lemma invert_typing_var_s: forall s x ds,
  typing_trm nil s (trm_var (avar_f x)) (typ_rcd ds) ->
  exists is, venv.binds x is s /\ typing_inis nil s is ds.
Proof.
  intros. inv H.
  + tenv.empty_binds_contradiction.
  + eauto.
Qed.

Lemma invert_typing_var_s_with_given_inis: forall G s x is ds,
  typing_trm G s (trm_var (avar_f x)) (typ_rcd ds) ->
  venv.binds x is s ->
  typing_inis nil s is ds.
Proof.
  intros G s x is ds Hty Hbv.
  inversion Hty; subst.
  (* typing_var_g *)
  + exfalso. apply (@venv.binds_unbound_inv x is s); assumption.
  (* typing_var_s *)
  + assert (is0 = is) by apply (venv.binds_unique H4 Hbv). subst. assumption.
Qed.

Lemma invert_typing_ini_key: forall G s i d,
  typing_ini G s i d -> inis.key i = decs.key d.
Proof.
  intros. inv H; reflexivity.
Qed.

Lemma invert_typing_ini_cases: forall G s i d,
  typing_ini G s i d ->
  (exists l x T, i = (nini_fld l x) /\ d = (ndec_fld l T)) \/
  (exists m e T U, i = (nini_mtd m T e) /\ d = (ndec_mtd m T U)).
Proof.
  intros. inv H.
  + left. exists l v T. split; reflexivity.
  + right. exists m t S T. split; reflexivity.
Qed.

Lemma invert_typing_ini: forall G s i d,
  typing_ini G s i d ->
  exists k iv dv, inis.key i = k /\ inis.value i = iv /\
                  decs.key d = k /\ decs.value d = dv.
Proof.
  intros. destruct (invert_typing_ini_cases H)
    as [[l [x [T [Heq1 Heq2]]]] | [m [e [T [U [Heq1 Heq2]]]]]].
  + exists (label_fld l) (ini_fld x) (dec_fld T). subst. auto.
  + exists (label_mtd m) (ini_mtd T e) (dec_mtd T U). subst. auto.
Qed.

Lemma venv_gen_gt : forall s, exists x, forall y i, venv.binds y i s -> y < x.
Proof.
  intros. induction s.
  + exists 0. intros. venv.empty_binds_contradiction.
  + destruct IHs as [x IH].
    destruct (le_lt_dec x (venv.key a)) as [Hc | Hc].
    - exists (S (venv.key a)). intros.
      unfold venv.binds, venv.get in H. fold venv.get in H.
      unfold venvParams.eq_key_dec in H.
      destruct (eq_nat_dec y (venv.key a)).
      * omega.
      * unfold venv.binds in IH. specialize (IH y i H). omega.
    - exists x. intros.
      unfold venv.binds, venv.get in H. fold venv.get in H.
      unfold venvParams.eq_key_dec in H.
      destruct (eq_nat_dec y (venv.key a)).
      * omega.
      * apply (IH y i). unfold venv.binds. assumption.
Qed.

Lemma venv_gen_fresh : forall s, exists x, venv.unbound x s.
Proof.
  intros. destruct (venv_gen_gt s) as [x H]. exists x.
  apply venv.build_unbound. intros. specialize (H k' v H0). omega.
Qed.

Lemma decs_binds_to_inis_binds: forall l d is ds s,
  typing_inis nil s is ds ->
  decs.binds l d ds ->
  exists i, inis.binds l i is.
Proof.
  intros l d is ds s Hty Hbi. induction Hty.
  + decs.empty_binds_contradiction.
  + inis.compare_keys.
    - subst. exists (inis.value i). reflexivity.
    - destruct (invert_typing_ini H) as [k [iv [dv [Hik [Hiv [Hdk Hdv]]]]]]. subst.
      decs.compare_keys.
      * rewrite <- Hdk in n. contradiction e.
      * apply IHHty. assumption.
Qed.

Lemma inis_binds_fld_sync_val: forall n v is,
  inis.binds (label_fld n) v is -> exists x, v = (ini_fld x).
Proof.
  intros. induction is.
  + inis.empty_binds_contradiction.
  + inis.unfoldg inis.binds. destruct a; simpl in H; inis.destruct_key_if.
      * inv H. exists a. reflexivity.
      * apply IHis. unfold inis.binds. assumption.
      * inv e. (* contradiction *)
      * apply IHis. unfold inis.binds. assumption.
Qed.

Lemma inis_binds_mtd_sync_val: forall n v is,
  inis.binds (label_mtd n) v is -> exists T e, v = (ini_mtd T e).
Proof.
  intros. induction is.
  + inis.empty_binds_contradiction.
  + inis.unfoldg inis.binds. destruct a; simpl in H; inis.destruct_key_if.
      * inv e. (* contradiction *)
      * apply IHis. unfold inis.binds. assumption.
      * inv H. exists t t0. reflexivity.
      * apply IHis. unfold inis.binds. assumption.
Qed.

(*
Lemma decs_binds_fld_to_inis_binds_fld: forall l d is ds s,
  typing_inis nil s is ds ->
  decs.binds l (dec_fld T ds ->
  exists i, inis.binds l i is.
Proof.
*)

Definition progress_for(s: venv.t)(e: trm) :=
  (* can step *)
  (exists s' e', red s e s' e') \/
  (* or is a value *)
  (exists x is, e = (trm_var (avar_f x)) /\ venv.binds x is s).

Ltac auto_specialize :=
  repeat match goal with
  | Impl: ?Cond -> _ |- _ => let HC := fresh in
                             assert (HC: Cond) by auto; specialize (Impl HC); clear HC
  end.

Ltac rewrite_with EqT := match goal with
| H: EqT |- _ => rewrite H in *; clear H
end.

Lemma progress_proof: forall G s e T,
  typing_trm G s e T -> G = nil -> progress_for s e.
Proof.
  Definition P_has :=         fun G s e l d (Hhas: has G s e l d)
                              => G = nil -> progress_for s e.
  Definition P_typing_trm :=  fun G s e T (Hty: typing_trm G s e T)
                              => G = nil -> progress_for s e.
  Definition P_typing_ini :=  fun G s i d (Htyp: typing_ini G s i d)
                              => G = nil -> True.
  Definition P_typing_inis := fun G s is ds (Htyp: typing_inis G s is ds)
                              => G = nil -> True.
  apply (typing_trm_mut P_has P_typing_trm P_typing_ini P_typing_inis);
    unfold P_has, P_typing_trm, P_typing_ini, P_typing_inis, progress_for;
    intros;
    try apply I;
    rewrite_with (G = []);
    auto_specialize.
  (* case has_dec *)
  + assumption.
  (* case typing_trm_var_g *)
  + tenv.empty_binds_contradiction.
  (* case typing_trm_var_s *)
  + right. exists x is. split. reflexivity. assumption.
  (* case typing_trm_sel *)
  + left. destruct H as [IH | IH].
    (* receiver is an expression *)
    - destruct IH as [s' [e' IH]]. do 2 eexists. apply (red_sel1 l IH).
    (* receiver is a var *)
    - destruct IH as [x [is [Heq Hbv]]]. subst.
      destruct (invert_has h) as [ds [Hty Hbd]].
      inv Hty.
      (* receiver var is in empty Gamma *)
      * tenv.empty_binds_contradiction.
      (* receiver var is in s *)
      * rewrite -> (venv.binds_unique H4 Hbv) in *. clear H4. clear is0.
        destruct (decs_binds_to_inis_binds H5 Hbd) as [i Hbl].
        destruct (inis_binds_fld_sync_val Hbl) as [y Hieq]. subst.
        exists s (trm_var y).
        apply (red_sel Hbv Hbl).
  (* case typing_trm_call *)
  + left. destruct H as [IHrec | IHrec].
    (* case receiver is an expression *)
    - destruct IHrec as [s' [e' IHrec]]. do 2 eexists. apply (red_call1 m _ IHrec).
    (* case receiver is  a var *)
    - destruct IHrec as [x [is [Heqx Hbv]]]. subst.
      destruct H0 as [IHarg | IHarg].
      (* arg is an expression *)
      * destruct IHarg as [s' [e' IHarg]]. do 2 eexists. apply (red_call2 x m IHarg).
      (* arg is a var *)
      * destruct IHarg as [y [is' [Heqy Hbv']]]. subst.
        destruct (invert_has h) as [ds [Hty Hbd]].
        inv Hty.
        (* receiver var is in empty Gamma *)
          tenv.empty_binds_contradiction.
        (* receiver var is in s *)
          rewrite -> (venv.binds_unique H4 Hbv) in *. clear H4. clear is0.
          destruct (decs_binds_to_inis_binds H5 Hbd) as [i Hbl].
          destruct (inis_binds_mtd_sync_val Hbl) as [U' [e Hieq]]. subst.
          exists s (open_trm y e).
          apply (red_call y Hbv Hbl).
  (* case typing_trm_new *)
  + left. clear H. clear H0.
    destruct (venv_gen_fresh s) as [x Hxub].
    exists (s ;; (x, nis)) (open_trm x t).
    apply red_new. assumption.
Qed.

Theorem progress: forall s e T,
  typing_trm nil s e T -> progress_for s e.
Proof.
  intros. apply (progress_proof H eq_refl).
Qed.

Print Assumptions progress.

Tactic Notation "keep" constr(E) "as" ident(H) :=
    let Temp := type of E in assert (H: Temp) by apply E.

Lemma extract_typing_ini_from_typing_inis: forall s l i is d ds,
  typing_inis nil s is ds ->
  inis.binds l (inis.value i) is ->
  decs.binds l (decs.value d) ds ->
  typing_ini nil s i d.
Proof.
Admitted.

Lemma invert_typing_mtd_ini_inside_typing_inis: forall s is ds m S1 S2 T body,
  typing_inis nil s is ds ->
  inis.binds (label_mtd m) (ini_mtd S1 body) is ->
  decs.binds (label_mtd m) (dec_mtd S2 T) ds ->
  (* conclusion is the premise needed to construct a typing_mtd_ini: *)
  (forall y, venv.unbound y s -> typing_trm (nil ;; (y, S2)) s (open_trm y body) T).
Proof.
Admitted.

(* Values bound in store may depend on bindings defined earlier in store.
   Similarly, the types bound in gamma may depend on bindings defined earlier in gamma
     (once we have path types).
   Moreover, if we're in a given execution state with non-empty store, the types bound in
     gamma may depend on the values bound in the store.
     But the store cannot depend on gamma, because the store is "concrete", and gamma
     is "hypothetical".
   ---> it would make sense to invert the order of gamma/store to store/gamma -> TODO
*)

Lemma split_store_in_typing_trm_var_s: forall s y ds,
  typing_trm nil s (trm_var (avar_f y)) (typ_rcd ds) ->
  exists s1 s2 is, s = (s1 ;; (y, is) & s2) /\
                   typing_inis nil s1 is ds.
Admitted.

(*
  venv.unbound y s1 ->
  venv.unbound y s2 ->
  typing_trm (nil ;; (y, S)) (s1 & s2) e T ->
  typing_trm (s1 ;; (y, S) & s2) e T
*)

Theorem preservation: forall s e T s' e',
  typing_trm nil s e T -> red s e s' e' -> typing_trm nil s' e' T.
Proof.
  intros s e T s' e' Hty Hred. induction Hred.
  (* red_call *)
  + rename H0 into Hbi.
    destruct (invert_typing_trm_call Hty) as [S [Hhas Hty2]]. clear Hty.
    destruct (invert_has Hhas) as [ds [Hty3 Hbd]]. clear Hhas.
    keep (invert_typing_var_s_with_given_inis Hty3 H) as Hisds.
    keep (invert_typing_mtd_ini_inside_typing_inis Hisds Hbi Hbd) as Hmtd.
    destruct S as [dsy].
    destruct (split_store_in_typing_trm_var_s Hty2) as [s1 [s2 [isy [Heq Htis1]]]].
    subst.

stop

    destruct (invert_typing_var_s Hty2) as [isy [Hbvy Htyy]].

    destruct (decs_binds_to_inis_binds Hty4 Hbd) as [i Hbi].
    destruct (inis_binds_mtd_sync_val Hbi) as [S' [body' Heq]]. subst. (* <- already known*)

    assert (Hty4: typing_inis [] s is ds).

    refine (typing_trm_call _ Hty2).

  (* red_sel *)
  +
  (* red_new *)
  +
  (* red_call1 *)
  +
  (* red_call2 *)
  +
  (* red_sel1 *)
  +
Qed.

(* garbage .............. *)

(*
what's below is not needed because simpler:
assign everything first to a var -> no need to evaluate fields of record
and one type for record construction / fully evaluated record
*)

(* Value (: [list nslot] or [label => slot] *)
Module val <: env.
Definition K := loc.
Definition V := slot.
Definition B := nslot.
Definition t := list nslot.
Definition key(s: nslot): loc := match s with
| nslot_fld n lo => label_fld n
| nslot_mtd n T e => label_mtd n
end.
Definition value(s: nslot): slot := match s with
| nslot_fld n lo => slot_fld lo
| nslot_mtd n T e => slot_mtd T e
end.
End val.

(* fully evaluated record member *)
Inductive slot : Type :=
  | slot_fld : loc -> slot
  | slot_mtd : typ -> trm -> slot.

(* named slot *)
Inductive nslot : Type :=
  | nslot_fld : nat -> loc -> nslot
  | nslot_mtd : nat -> typ -> trm -> nslot.

(* Import List.ListNotations. *)

(*
theories/Lists/List, Module ListNotations:
Notation " [ ] " := nil : list_scope.
Notation " [ x ] " := (cons x nil) : list_scope.
Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope.

theories/Init/Datatypes:
Infix "++" := app (right associativity, at level 60) : list_scope.
Infix "::" := cons (at level 60, right associativity) : list_scope.
*)


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

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

This library 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
COPYING file for more details.
*)

(** Basic operations on floats: alignment, addition, multiplication *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_float_prop.

Section Float_ops.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Arguments Float [beta] _ _.

Definition Falign (f1 f2 : float beta) :=
  let '(Float m1 e1) := f1 in
  let '(Float m2 e2) := f2 in
  if Zle_bool e1 e2
  then (m1, (m2 * Zpower beta (e2 - e1))%Z, e1)
  else ((m1 * Zpower beta (e1 - e2))%Z, m2, e2).

Theorem Falign_spec :
  forall f1 f2 : float beta,
  let '(m1, m2, e) := Falign f1 f2 in
  F2R f1 = @F2R beta (Float m1 e) /\ F2R f2 = @F2R beta (Float m2 e).
Proof.
unfold Falign.
intros (m1, e1) (m2, e2).
generalize (Zle_cases e1 e2).
case (Zle_bool e1 e2) ; intros He ; split ; trivial.
now rewrite <- F2R_change_exp.
rewrite <- F2R_change_exp.
apply refl_equal.
omega.
Qed.

Theorem Falign_spec_exp:
  forall f1 f2 : float beta,
  snd (Falign f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros (m1,e1) (m2,e2).
unfold Falign; simpl.
generalize (Zle_cases e1 e2);case (Zle_bool e1 e2); intros He.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
Qed.

Definition Fopp (f1 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  Float (-m1)%Z e1.

Theorem F2R_opp :
  forall f1 : float beta,
  (F2R (Fopp f1) = -F2R f1)%R.
intros (m1,e1).
apply F2R_Zopp.
Qed.

Definition Fabs (f1 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  Float (Zabs m1)%Z e1.

Theorem F2R_abs :
  forall f1 : float beta,
  (F2R (Fabs f1) = Rabs (F2R f1))%R.
intros (m1,e1).
apply F2R_Zabs.
Qed.

Definition Fplus (f1 f2 : float beta) : float beta :=
  let '(m1, m2 ,e) := Falign f1 f2 in
  Float (m1 + m2) e.

Theorem F2R_plus :
  forall f1 f2 : float beta,
  F2R (Fplus f1 f2) = (F2R f1 + F2R f2)%R.
Proof.
intros f1 f2.
unfold Fplus.
generalize (Falign_spec f1 f2).
destruct (Falign f1 f2) as ((m1, m2), e).
intros (H1, H2).
rewrite H1, H2.
unfold F2R. simpl.
rewrite Z2R_plus.
apply Rmult_plus_distr_r.
Qed.

Theorem Fplus_same_exp :
  forall m1 m2 e,
  Fplus (Float m1 e) (Float m2 e) = Float (m1 + m2) e.
Proof.
intros m1 m2 e.
unfold Fplus.
simpl.
now rewrite Zle_bool_refl, Zminus_diag, Zmult_1_r.
Qed.

Theorem Fexp_Fplus :
  forall f1 f2 : float beta,
  Fexp (Fplus f1 f2) = Zmin (Fexp f1) (Fexp f2).
Proof.
intros f1 f2.
unfold Fplus.
rewrite <- Falign_spec_exp.
now destruct (Falign f1 f2) as ((p,q),e).
Qed.

Definition Fminus (f1 f2 : float beta) :=
  Fplus f1 (Fopp f2).

Theorem F2R_minus :
  forall f1 f2 : float beta,
  F2R (Fminus f1 f2) = (F2R f1 - F2R f2)%R.
Proof.
intros f1 f2; unfold Fminus.
rewrite F2R_plus, F2R_opp.
ring.
Qed.

Theorem Fminus_same_exp :
  forall m1 m2 e,
  Fminus (Float m1 e) (Float m2 e) = Float (m1 - m2) e.
Proof.
intros m1 m2 e.
unfold Fminus.
apply Fplus_same_exp.
Qed.

Definition Fmult (f1 f2 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  let '(Float m2 e2) := f2 in
  Float (m1 * m2) (e1 + e2).

Theorem F2R_mult :
  forall f1 f2 : float beta,
  F2R (Fmult f1 f2) = (F2R f1 * F2R f2)%R.
Proof.
intros (m1, e1) (m2, e2).
unfold Fmult, F2R. simpl.
rewrite Z2R_mult, bpow_plus.
ring.
Qed.

End Float_ops.