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

 This defines the static semantics of statements and expressions, pg. 63.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export DynamicSemanticsHeapObjects.
Require Export StaticSemanticsTypingHeapObjects.
Require Export StaticSemanticsKindingAndContextWellFormedness.
(* I want to be able to work with Tau and Term without module paths. *)
(* But they collide. *)
(* and if I change TM then I I have to fold/unfold in places. *)

Inductive ret : St -> Prop :=
| ret_ret       : forall (e : E),
                       ret (retn e)

| ret_if        : forall (e : E) (s1 s2 : St),
                       ret s1 ->
                       ret s2 ->
                       ret (if_s e s1 s2)

| ret_seq_1     : forall (s s' : St),
                       ret s ->
                       ret (seq s s')

| ret_seq_2     : forall (s s' : St),
                       ret s' ->
                       ret (seq s s')

| ret_let       : forall (x : EV.T) (e : E) (s : St),
                       ret s ->
                       ret (letx x e s)

| ret_open      : forall (e : E) (alpha : TV.T) (x : EV.T) (s : St),
                       ret s ->
                       ret (open e alpha x s)

| ret_openstar  : forall (e : E) (alpha : TV.T) (x : EV.T) (s : St),
                       ret s ->
                       ret (openstar e alpha x s).

(* TODO inconsistent naming. *)
Inductive styp : Delta -> Upsilon -> Gamma -> Tau -> St   -> Prop :=
(* This is correct, return at end of program. *)
  | styp_e_3_1    : forall (d : Delta) (u : Upsilon) (g : Gamma)
                           (tau tau': T.T) (e : E),
                      (* This just messes up the proofs. *)
                      rtyp d u g e  tau' ->
                      (* rtyp d u g e  tau -> *)
                      styp d u g tau (e_s e)

  | styp_return_3_2 : forall (d : Delta) (u : Upsilon) (g : Gamma)
                             (tau : T.T) (e : E),
                         rtyp d u g e tau ->
                         styp d u g tau (retn e)

  | styp_seq_3_3    : forall (d : Delta) (u : Upsilon) (g : Gamma)
                             (tau : T.T) (s1 s2 : St),
                         styp d u g tau s1 ->
                         styp d u g tau s2 ->
                         styp d u g tau (seq s1 s2)

  | styp_while_3_4  : forall (d : Delta) (u : Upsilon) (g : Gamma)
                             (tau : T.T) (e: E) (s : St),
                         rtyp d u g e T.cint ->
                         styp d u g tau s ->
                         styp d u g tau (while e s)

  | styp_if_3_5     :  forall (d : Delta) (u : Upsilon) (g : Gamma)
                              (tau : T.T) (e: E) (s1 s2 : St),
                          rtyp d u g e T.cint ->
                          styp d u g tau s1 ->
                          styp d u g tau s2 ->
                          styp d u g tau (if_s e s1 s2)

(* Bug 38 wrong tau' in styp. *)
  | styp_let_3_6    :  forall (d : Delta) (u : Upsilon) (g : Gamma)
                               (x : EV.T)  (tau tau' : T.T)
                               (s : St) (e : E),
                          G.map g x = None ->
                          K d tau' A ->  (* Thesis change. *)
                          styp d u (G.ctxt x tau' g) tau s ->
                          rtyp d u g e    tau' ->
                          styp d u g tau  (letx x e s)

(* Bug 33, alpha conversion of alpha here ? *)
(* TODO can I unfold the expected pack here and make these syntax directed ? *)
(* I think so. *)
(* Bug 44, forgot not in domain checks. *)
  | styp_open_3_7   :  forall (d : Delta) (u : Upsilon) (g : Gamma)
                               (x : EV.T)  (p : Phi) (alpha : TV.T)
                               (k : Kappa) (tau tau' : T.T)
                               (s : St) (e : E),
                          D.map d alpha = None ->
                          G.map g x = None ->
                          K d tau A      ->
                          rtyp d u g e (T.etype p alpha k tau') ->
                          styp (D.ctxt alpha k d) u (G.ctxt x tau' g)
                               tau s ->
                          styp d u g tau (open e alpha x s)

  | styp_openstar_3_8 :  forall (d : Delta) (u : Upsilon) (g : Gamma)
                               (x : EV.T)  (alpha : TV.T)
                               (k : Kappa) (tau tau' : T.T)
                               (s : St) (e : E),
                          rtyp d u g e (T.etype aliases alpha k tau') ->
                          styp (D.ctxt alpha k d)
                               u
                               (G.ctxt x tau' g)
                               tau s ->
                          D.map d alpha = None ->
                          G.map g x = None ->
                          K d tau A      ->
                          styp d u g tau (openstar e alpha x s)

with      ltyp :   Delta -> Upsilon -> Gamma -> E -> T.T -> Prop :=

  | SL_3_1     : forall (d : Delta) (g : Gamma) (u : Upsilon)
                           (x : EV.T) (p : Path) (tau tau': T.T),
                      G.map g x = Some tau' ->
                      gettype u x nil tau' p tau ->
                      WFC d u g ->
                      K d tau' A ->
                      ltyp d u g (p_e x p) tau

  | SL_3_2     : forall (d : Delta) (u : Upsilon) (g : Gamma)
                        (e : E) (tau : T.T) ,
                      rtyp d u g e (T.ptype tau) ->
                      K d tau A ->
                      ltyp d u g (star e) tau

  | SL_3_3     : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : T.T),
                      ltyp d u g e (T.cross t0 t1) ->
                      ltyp d u g (TM.dot e Pth.zero_pe) t0

  | SL_3_4     : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : T.T),
                      ltyp d u g e (T.cross t0 t1) ->
                      ltyp d u g (TM.dot e Pth.one_pe) t1

with      rtyp :  Delta -> Upsilon -> Gamma -> E   -> T.T -> Prop :=
  | SR_3_1  : forall (d : Delta) (g : Gamma) (u : Upsilon)
                        (x  : EV.T) (p : Path) (tau tau': T.T),
                   G.map g x = Some tau' ->
                   gettype u x nil tau' p tau ->
                   K d tau' A ->
                   WFC d u g ->
                   rtyp d u g (p_e x p) tau

  | SR_3_2  :  forall (e : E) (tau : T.T)
                      (d : Delta) (u : Upsilon) (g : Gamma),
                    rtyp d u g e (T.ptype tau) ->
                    K d tau A ->
                    rtyp d u g (TM.star e) tau

  | SR_3_3  :  forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : T.T),
                        rtyp d u g e (T.cross t0 t1) ->
                        rtyp d u g (TM.dot e Pth.zero_pe) t0

  | SR_3_4  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : T.T),
                      rtyp d u g e (T.cross t0 t1) ->
                      rtyp d u g (TM.dot e Pth.one_pe) t1

  | SR_3_5  : forall (d : Delta) (u : Upsilon) (g : Gamma) (z : Z),
                   WFC d u g ->
                   rtyp d u g (i_e (i_i z)) T.cint

  | SR_3_6  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (tau : T.T),
                   ltyp d u g e tau ->
                   rtyp d u g (amp e) (T.ptype tau)

  | SR_3_7  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e0 e1: E) (t0 t1 : T.T),
                   rtyp d u g e0 t0 ->
                   rtyp d u g e1 t1 ->
                   rtyp d u g (cpair e0 e1) (T.cross t0 t1)

  | SR_3_8  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e1 e2 : E) (tau : T.T),
                   ltyp d u g e1 tau ->
                   rtyp d u g e2 tau ->
                   ASGN d tau    ->
                   rtyp d u g (assign e1 e2) tau

  | SR_3_9  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e1 e2 : E) (tau tau' : T.T),
                   rtyp d u g e1 (T.arrow tau' tau) ->
                   rtyp d u g e2 tau' ->
                   rtyp d u g (TM.appl e1 e2) tau

  | SR_3_10 : forall (d : Delta) (u : Upsilon) (g : Gamma) (tau : T.T) (s : St),
                   styp d u g tau s ->
                   ret s ->
                   rtyp d u g (call s) tau

  | SR_3_11 : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E)
                        (tau tau': T.T) (alpha : TV.T) (k : Kappa),
                   rtyp d u g e (T.utype alpha k tau') ->
                   AK   d tau k ->
                   rtyp d u g (inst e tau) (subst_Tau tau' tau alpha)

  | SR_3_12 : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E)
                        (tau tau': T.T) (alpha : TV.T) (k : Kappa) (p : Phi),
                   rtyp d u g e (subst_Tau tau tau' alpha) ->
                   AK   d tau' k ->
                   K    d (T.etype p alpha k tau) A ->
                   rtyp d u g (pack tau' e (T.etype p alpha k tau))
                              (T.etype p alpha k tau)

  | SR_3_13 : forall (d : Delta) (u : Upsilon) (g : Gamma) (tau tau': T.T)
                     (s : St) (x : EV.T),
                   G.map g x = None ->
                   styp d u (G.ctxt x tau g) tau' s ->
                   ret s ->
                   rtyp d u g (f_e (dfun tau x tau' s)) (T.arrow tau tau')

  | SR_3_14 : forall (d : Delta) (u : Upsilon) (g : Gamma) (f : F)
                        (tau : T.T) (alpha : TV.T) (k : Kappa),
                   D.map d alpha = None ->
                   WFC  d u g ->
                   rtyp (D.ctxt alpha k d) u g (f_e f) tau ->
                   rtyp d u g (f_e (ufun alpha k f)) (T.utype alpha k tau).

Scheme styp_ind_mutual := Induction for styp Sort Prop
with   ltyp_ind_mutual := Induction for ltyp Sort Prop
with   rtyp_ind_mutual := Induction for rtyp Sort Prop.
Combined Scheme typ_ind_mutual from
          styp_ind_mutual, ltyp_ind_mutual, rtyp_ind_mutual.

(*
Lemma ltyp_context_dependent_induction_mutual:
  forall P : forall (beta : TV.T) (k : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
                    (t : Tau) (s : St),
       styp (D.ctxt beta k d) u g t s -> Prop,
    forall P0 : forall (beta : TV.T) (k : Kappa) (d : Delta) (u : Upsilon)
                       (g : Gamma) (e : E) (t : T.T),
        ltyp (D.ctxt beta k d) u g e t -> Prop,
     forall P1 : forall (beta : TV.T) (k : Kappa) (d : Delta) (u : Upsilon)
                        (g : Gamma) (e : E) (t : T.T),
        rtyp (D.ctxt beta k d) u g e t -> Prop,
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
         (tau tau' : T.T) (e : E) (r : rtyp (D.ctxt beta k' d) u g e tau'),
       P1 beta k' d u g e tau' r ->
       P beta k' d u g tau (e_s e) (styp_e_3_1 tau r)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (tau : T.T) (e : E) (r : rtyp (D.ctxt beta k' d) u g e tau),
        P1 beta k' d u g e tau r ->
        P beta k' d u g tau (retn e) (styp_return_3_2 r)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (tau : T.T) (s1 s2 : St) (s : styp (D.ctxt beta k' d) u g tau s1),
        P beta k' d u g tau s1 s ->
        forall s0 : styp (D.ctxt beta k' d) u g tau s2,
        P beta k' d u g tau s2 s0 ->
        P beta k' d u g tau (seq s1 s2) (styp_seq_3_3 s s0)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (tau : T.T) (e : E) (s : St) (r : rtyp (D.ctxt beta k' d) u g e T.cint),
        P1 beta k' d u g e T.cint r ->
        forall s0 : styp (D.ctxt beta k' d) u g tau s,
        P beta k' d u g tau s s0 ->
        P beta k' d u g tau (while e s) (styp_while_3_4 r s0)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (tau : T.T) (e : E) (s1 s2 : St) (r : rtyp (D.ctxt beta k' d) u g e T.cint),
        P1 beta k' d u g e T.cint r ->
        forall s : styp (D.ctxt beta k' d) u g tau s1,
        P beta k' d u g tau s1 s ->
        forall s0 : styp (D.ctxt beta k' d) u g tau s2,
        P beta k' d u g tau s2 s0 ->
        P beta k' d u g tau (if_s e s1 s2) (styp_if_3_5 r s s0)) ->
(* s0 wrong both ways *)
(*
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (x : EV.T) (tau tau' : T.T) (s : St) (e : E)
          (e0 : G.map g x = None) (k : K d tau' A)
          (s0 : styp (D.ctxt beta k' d) u (G.ctxt x tau' g) tau s),
        P beta k' d u (G.ctxt x tau' g) tau s s0 ->
        forall r : rtyp (D.ctxt beta k' d) u g e tau',
        P1 beta k' d u g e tau' r ->
        P beta k' d u g tau (letx x e s) (styp_let_3_6 e0 k s0 r)) ->
*)
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (x : EV.T) (p : Phi) (alpha : TV.T) (k : Kappa)
          (tau tau' : T.T) (s : St) (e : E) (e0 : D.map d alpha = None)
          (e1 : G.map g x = None) (k0 : K d tau A)
          (r : rtyp d u g e (T.etype p alpha k tau')),
        P1 beta k' d u g e (T.etype p alpha k tau') r ->
        forall s0 : styp (D.ctxt beta k' (D.ctxt alpha k d)) u (G.ctxt x tau' g) tau s,
        P beta k' (D.ctxt alpha k d) u (G.ctxt x tau' g) tau s s0 ->
        P beta k' d u g tau (open e alpha x s) (styp_open_3_7 e0 e1 k0 r s0)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (x : EV.T) (alpha : TV.T) (k : Kappa) (tau tau' : T.T)
          (s : St) (e : E) (r : rtyp (D.ctxt beta k' d) u g e (T.etype aliases alpha k tau')),
        P1 beta k' d u g e (T.etype aliases alpha k tau') r ->
        forall s0 : styp (D.ctxt alpha k d) u (G.ctxt x tau' g) tau s,
        P beta k' (D.ctxt alpha k d) u (G.ctxt x tau' g) tau s s0 ->
        forall (e0 : D.map d alpha = None) (e1 : G.map g x = None)
          (k0 : K d tau A),
        P beta k' d u g tau (openstar e alpha x s) (styp_openstar_3_8 r s0 e0 e1 k0)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (g : Gamma) (u : Upsilon)
          (x : EV.T) (p : Path) (tau tau' : T.T) (e : G.map g x = Some tau')
          (g0 : gettype u x [] tau' p tau) (w : WFC d u g)
          (k : K d tau' A), P0 beta k' d u g (p_e x p) tau (SL_3_1 e g0 w k)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (e : E) (tau : T.T) (r : rtyp d u g e (T.ptype tau)),
        P1 beta k' d u g e (T.ptype tau) r ->
        forall k : K d tau A, P0 beta k' d u g (star e) tau (SL_3_2 r k)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (e : E) (t0 t1 : T.T) (l : ltyp d u g e (T.cross t0 t1)),
        P0 beta k' d u g e (T.cross t0 t1) l ->
        P0 beta k' d u g (TM.dot e Pth.zero_pe) t0 (SL_3_3 l)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (e : E) (t0 t1 : T.T) (l : ltyp d u g e (T.cross t0 t1)),
         P0 beta k' d u g e (T.cross t0 t1) l ->
         P0 beta k' d u g (TM.dot e Pth.one_pe) t1 (SL_3_4 l)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (g : Gamma) (u : Upsilon)
           (x : EV.T) (p : Path) (tau tau' : T.T) (e : G.map g x = Some tau')
           (g0 : gettype u x [] tau' p tau) (k : K d tau' A)
           (w : WFC d u g), P1 beta k' d u g (p_e x p) tau (SR_3_1 e g0 k w)) ->
  (forall (beta : TV.T) (k' : Kappa) (e : E) (tau : T.T) (d : Delta) (u : Upsilon)
           (g : Gamma) (r : rtyp d u g e (T.ptype tau)),
         P1 beta k' d u g e (T.ptype tau) r ->
         forall k : K d tau A, P1 beta k' d u g (TM.star e) tau (SR_3_2 r k)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (e : E) (t0 t1 : T.T) (r : rtyp d u g e (T.cross t0 t1)),
         P1 beta k' d u g e (T.cross t0 t1) r ->
         P1 beta k' d u g (TM.dot e Pth.zero_pe) t0 (SR_3_3 r)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (e : E) (t0 t1 : T.T) (r : rtyp d u g e (T.cross t0 t1)),
         P1 beta k' d u g e (T.cross t0 t1) r ->
         P1 beta k' d u g (TM.dot e Pth.one_pe) t1 (SR_3_4 r)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
          (z : Z) (w : WFC d u g),
         P1 beta k' d u g (i_e (i_i z)) T.cint (SR_3_5 z w)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (e : E) (tau : T.T) (l : ltyp d u g e tau),
         P0 beta k' d u g e tau l -> P1 beta k' d u g (amp e) (T.ptype tau) (SR_3_6 l)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (e0 e1 : E) (t0 t1 : T.T) (r : rtyp d u g e0 t0),
         P1 beta k' d u g e0 t0 r ->
         forall r0 : rtyp d u g e1 t1,
         P1 beta k' d u g e1 t1 r0 ->
         P1 beta k' d u g (cpair e0 e1) (T.cross t0 t1) (SR_3_7 r r0)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (e1 e2 : E) (tau : T.T) (l : ltyp d u g e1 tau),
         P0 beta k' d u g e1 tau l ->
         forall r : rtyp d u g e2 tau,
         P1 beta k' d u g e2 tau r ->
         forall a : ASGN d tau, P1 beta k' d u g (assign e1 e2) tau (SR_3_8 l r a)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (e1 e2 : E) (tau tau' : T.T)
           (r : rtyp d u g e1 (T.arrow tau' tau)),
         P1 beta k' d u g e1 (T.arrow tau' tau) r ->
         forall r0 : rtyp d u g e2 tau',
         P1 beta k' d u g e2 tau' r0 ->
         P1 beta k' d u g (TM.appl e1 e2) tau (SR_3_9 r r0)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (tau : T.T) (s : St) (s0 : styp d u g tau s),
         P beta k' d u g tau s s0 ->
         forall r : ret s, P1 beta k' d u g (call s) tau (SR_3_10 s0 r)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (e : E) (tau tau' : T.T) (alpha : TV.T)
           (k : Kappa) (r : rtyp d u g e (T.utype alpha k tau')),
         P1 beta k' d u g e (T.utype alpha k tau') r ->
         forall a : AK d tau k,
         P1 beta k' d u g (inst e tau) (subst_Tau tau' tau alpha) (SR_3_11 r a)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (e : E) (tau tau' : T.T) (alpha : TV.T)
           (k : Kappa) (p : Phi)
           (r : rtyp d u g e (subst_Tau tau tau' alpha)),
         P1 beta k' d u g e (subst_Tau tau tau' alpha) r ->
         forall (a : AK d tau' k) (k0 : K d (T.etype p alpha k tau) A),
         P1 beta k' d u g (pack tau' e (T.etype p alpha k tau))
           (T.etype p alpha k tau) (SR_3_12 r a k0)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (tau tau' : T.T) (s : St) (x : EV.T) (e : G.map g x = None)
           (s0 : styp d u (G.ctxt x tau g) tau' s),
         P beta k' d u (G.ctxt x tau g) tau' s s0 ->
         forall r : ret s,
         P1 beta k' d u g (f_e (dfun tau x tau' s)) (T.arrow tau tau')
           (SR_3_13 e s0 r)) ->
  (forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
           (f24 : F) (tau : T.T) (alpha : TV.T) (k : Kappa)
           (e : D.map d alpha = None) (w : WFC d u g)
           (r : rtyp (D.ctxt alpha k d) u g (f_e f24) tau),
         P1 beta k' (D.ctxt alpha k d) u g (f_e f24) tau r ->
         P1 beta k' d u g (f_e (ufun alpha k f24)) (T.utype alpha k tau)
           (SR_3_14 e w r)) ->
  forall (beta : TV.T) (k' : Kappa) (d : Delta) (u : Upsilon) (g : Gamma)
         (e : E) (t : T.T) (l : ltyp d u g e t), P0 beta k' d u g e t l.
Proof.
Admitted.
*)

(* Bug 42, getH *)

Inductive htyp: Upsilon -> Gamma -> Heap -> Gamma -> Prop :=
   | htyp_empty : forall (u : Upsilon) (g: Gamma),
                       htyp u g hdot gdot
   | htyp_xv    : forall (u : Upsilon) (g g': Gamma) (h h': Heap) (x : EV.T) (v : E) (tau : T.T),
                      H.map h x = Some v ->
                      Value v ->
                      H.delete h x = h' ->
                      htyp u g h' g' ->
                      rtyp ddot u g v tau ->
                      htyp u g h (G.ctxt x tau g').

(* Bug 43, HM.map *)
Inductive refp  : Heap -> Upsilon -> Prop :=
  | refp_empty  : forall (h : Heap),
                       refp h udot
  | refp_pack  : forall (h : Heap) (u : Upsilon) (x : EV.T) (p : Path) (tau tau' : T.T) (alpha : TV.T) (k : Kappa) (v v' : E),
                      H.map h x = Some v' ->
                      get v' p (pack tau' v (etype aliases alpha k tau)) ->
                      refp h u ->
                      refp h (U.ctxt (x,p) tau' u).

Inductive prog  : Heap -> St -> Prop :=
  | program  : forall (h : Heap) (u : Upsilon) (g : Gamma) (tau : T.T) (s : St),
                    htyp u g h g ->
                    refp h u     ->
                    styp ddot u g tau s ->
                    ret s ->
                    prog h s.


Require Import bedrock2.Semantics.
Require Import Rupicola.Lib.Api.
Require Import Crypto.Algebra.Group.
Require Import Crypto.Algebra.Hierarchy.
Require Import Crypto.Algebra.ScalarMult.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Specs.ScalarField.

Class GroupParameters :=
  { (** mathematical parameters **)
    G : Type;
    eq : G -> G -> Prop;
    add : G -> G -> G;
    zero : G;
    opp : G -> G;
    scalarmult : Z -> G -> G;

    (** function names for bedrock2 **)
    scmul : string;
  }.

Class GroupParameters_ok {group_parameters : GroupParameters} :=
  { group_ok : @group G eq add zero opp;
    scalarmult_ok : @is_scalarmult G eq add zero opp scalarmult;
  }.

Class GroupRepresentation {G : Type} {semantics : Semantics.parameters} :=
  { gelem : Type;
    grepresents : gelem -> G -> Prop;
    GElem : word -> gelem -> Semantics.mem -> Prop;
  }.

Section FunctionSpecs.
  Context {semantics : Semantics.parameters}
          {scalar_field_parameters : ScalarFieldParameters}
          {scalar_representaton : ScalarRepresentation}.
  Context {group_parameters : GroupParameters}
          {group_representaton : GroupRepresentation (G:=G)}.

  (* N.B. spec_of_scmul has only one separation-logic condition for now because
     using multiple results in problems with stack allocation. Should be further
     looked into. *)
  Definition spec_of_scmul : spec_of scmul :=
    (forall! (x old_out : gelem) (k : scalar) (X : G)
           (pout px pk : word),
        (fun Rr mem =>
           grepresents x X
           /\ (GElem pout old_out * GElem px x * Scalar pk k * Rr)%sep mem)
          ===>
          scmul @ [pout; px; pk]
          ===>
          (fun _ =>
             liftexists (xk : gelem),
             (emp (grepresents xk (scalarmult (F.to_Z (sceval k)) X))
              * GElem pout xk * GElem px x * Scalar pk k)%sep)).
End FunctionSpecs.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** Assorted facts about lists. *)

Require Import Coq.Lists.List.
Require Import Coq.Lists.SetoidList.

Require Import CoqUniquenessTac.

Open Scope list_scope.

(* ********************************************************************** *)
(** * List structure *)

Lemma cons_eq_app : forall (A : Type) (z : A) (xs ys zs : list A),
  z :: zs = xs ++ ys ->
  (exists qs, xs = z :: qs /\ zs = qs ++ ys) \/
  (xs = nil /\ ys = z :: zs).
Proof.
  destruct xs; intros ? ? H; simpl in *.
    auto.
    injection H. intros. subst. eauto.
Qed.

Lemma app_eq_cons : forall (A : Type) (z : A) (xs ys zs : list A),
  xs ++ ys = z :: zs ->
  (exists qs, xs = z :: qs /\ zs = qs ++ ys) \/
  (xs = nil /\ ys = z :: zs).
Proof. auto using cons_eq_app. Qed.

Lemma nil_eq_app : forall (A : Type) (xs ys : list A),
  nil = xs ++ ys ->
  xs = nil /\ ys = nil.
Proof. auto using List.app_eq_nil. Qed.

Lemma app_cons_not_nil : forall (A : Type) (y : A) (xs ys : list A),
  xs ++ y :: ys <> nil.
Proof.
  intros ? ? ? ? H. symmetry in H. revert H. apply List.app_cons_not_nil.
Qed.

(* ********************************************************************** *)
(** * List membership *)

Lemma In_map : forall (A B : Type) (xs : list A) (x : A) (f : A -> B),
  In x xs ->
  In (f x) (map f xs).
Proof.
  induction xs; intros ? ? H; simpl in *.
    auto.
    destruct H; subst; auto.
Qed.

(* ********************************************************************** *)
(** * List non-membership *)

Lemma not_In_cons : forall (A : Type) (ys : list A) (x y : A),
  x <> y ->
  ~ In x ys ->
  ~ In x (y :: ys).
Proof. unfold not. inversion 3; auto. Qed.

Lemma not_In_app : forall (A : Type) (xs ys : list A) (x : A),
  ~ In x xs ->
  ~ In x ys ->
  ~ In x (xs ++ ys).
Proof. intros ? xs ys x ? ? H. apply in_app_or in H. intuition. Qed.

Lemma elim_not_In_cons : forall (A : Type) (y : A) (ys : list A) (x : A),
  ~ In x (y :: ys) ->
  x <> y /\ ~ In x ys.
Proof. simpl. intuition. Qed.

Lemma elim_not_In_app : forall (A : Type) (xs ys : list A) (x : A),
  ~ In x (xs ++ ys) ->
  ~ In x xs /\ ~ In x ys.
Proof. split; auto using in_or_app. Qed.

(* ********************************************************************** *)
(** * List inclusion *)

Lemma incl_nil : forall (A : Type) (xs : list A),
  incl nil xs.
Proof. unfold incl. inversion 1. Qed.

Lemma In_incl : forall (A : Type) (x : A) (ys zs : list A),
  In x ys ->
  incl ys zs ->
  In x zs.
Proof. unfold incl. auto. Qed.

Lemma elim_incl_cons : forall (A : Type) (x : A) (xs zs : list A),
  incl (x :: xs) zs ->
  In x zs /\ incl xs zs.
Proof. unfold incl. auto with datatypes. Qed.

Lemma elim_incl_app : forall (A : Type) (xs ys zs : list A),
  incl (xs ++ ys) zs ->
  incl xs zs /\ incl ys zs.
Proof. unfold incl. auto with datatypes. Qed.

(* ********************************************************************** *)
(** * Setoid facts *)

(** [InA] and [In] are related when the relation is [eq].  The lemma
    [In_InA], the converse of [InA_In], is in Coq's standard
    library. *)

Lemma InA_In : forall (A : Type) (x : A) (xs : list A),
  InA (@eq _) x xs -> In x xs.
Proof.
  induction xs; intros H.
    inversion H.
    inversion H; subst; simpl in *; auto.
Qed.

Lemma InA_iff_In : forall (A : Type) (x : A) (xs : list A),
  InA (@eq _) x xs <-> In x xs.
Proof. split; auto using InA_In, SetoidList.In_InA. Qed.

(** Whether a list is sorted is a decidable proposition. *)

Section DecidableSorting.

  Variable A : Type.
  Variable leA : relation A.
  Hypothesis leA_dec : forall x y, {leA x y} + {~ leA x y}.

  Theorem lelistA_dec : forall a xs,
    {lelistA leA a xs} + {~ lelistA leA a xs}.
  Proof with auto.
    destruct xs as [ | x xs ]...
    destruct (leA_dec a x)...
    right. intros J. inversion J...
  Defined.

  Theorem sort_dec : forall xs,
    {sort leA xs} + {~ sort leA xs}.
  Proof with auto.
    induction xs as [ | x xs [Yes | No] ]...
    destruct (lelistA_dec x xs)...
      right. intros K. inversion K...
    right. intros K. inversion K...
  Defined.

End DecidableSorting.

(** Two sorted lists with the same elements are equal to each other.*)

Section SortedListEquality.

  Variable A : Type.
  Variable ltA : relation A.
  Hypothesis ltA_trans : forall x y z, ltA x y -> ltA y z -> ltA x z.
  Hypothesis ltA_not_eqA : forall x y, ltA x y -> x <> y.
  Hypothesis ltA_eqA : forall x y z, ltA x y -> y = z -> ltA x z.
  Hypothesis eqA_ltA : forall x y z, x = y -> ltA y z -> ltA x z.

  Hint Resolve ltA_trans.
  Hint Immediate ltA_eqA eqA_ltA.

  Notation Inf := (lelistA ltA).
  Notation Sort := (sort ltA).

  Lemma eqlist_eq : forall (xs ys : list A),
    eqlistA (@eq _) xs ys ->
    xs = ys.
  Proof. induction xs; destruct ys; inversion 1; f_equal; auto. Qed.

  Lemma Sort_InA_eq : forall xs ys,
    Sort xs ->
    Sort ys ->
    (forall a, InA (@eq _) a xs <-> InA (@eq _) a ys) ->
    xs = ys.
  Proof.
    intros xs ys ? ? ?.
    cut (eqlistA (@eq _) xs ys).
    auto using eqlist_eq.
    eauto using trans_eq, SetoidList.SortA_equivlistA_eqlistA.
  Qed.

  Lemma Sort_In_eq : forall xs ys,
    Sort xs ->
    Sort ys ->
    (forall a, In a xs <-> In a ys) ->
    xs = ys.
  Proof with auto using In_InA, InA_In.
    intros ? ? ? ? H.
    apply Sort_InA_eq...
    intros a; specialize (H a); intuition...
  Qed.

End SortedListEquality.

(* ********************************************************************** *)
(** * Uniqueness of proofs *)

(** Uniqueness of proofs for predicates on lists often comes up when
    discussing extensional equality on finite sets, as implemented by
    the FSets library. *)

Section Uniqueness_Of_SetoidList_Proofs.

  Variable A : Type.
  Variable R : A -> A -> Prop.

  Hypothesis R_unique : forall (x y : A) (p q : R x y), p = q.
  Hypothesis list_eq_dec : forall (xs ys : list A), {xs = ys} + {xs <> ys}.

  Scheme lelistA_ind' := Induction for lelistA Sort Prop.
  Scheme sort_ind'    := Induction for sort Sort Prop.
  Scheme eqlistA_ind' := Induction for eqlistA Sort Prop.

  Theorem lelistA_unique :
    forall (x : A) (xs : list A) (p q : lelistA R x xs), p = q.
  Proof. induction p using lelistA_ind'; uniqueness 1. Qed.

  Theorem sort_unique :
    forall (xs : list A) (p q : sort R xs), p = q.
  Proof. induction p using sort_ind'; uniqueness 1. apply lelistA_unique. Qed.

  Theorem eqlistA_unique :
    forall (xs ys : list A) (p q : eqlistA R xs ys), p = q.
  Proof. induction p using eqlistA_ind'; uniqueness 2. Qed.

End Uniqueness_Of_SetoidList_Proofs.


Require Import Omega.
Require Import List.
Require Import Lists.ListTactics.
Require Import Ensembles.
Require Import String.
(* Require Import PartialMap. *)
(*Require Import Poset.*)

(* Before understanding a request, a SA must
   be established using ISAKMP. The goal of
   ISAKMP is to define a procedure for authenticating
   a communicating peer as well as a procedure for key
   generation techniques.

   This is done through a series of headers that describe
   the payload types, and exchange types

 *)

(* Coq Inductive terms are used to create a data structure *)

Inductive SA_param : Type :=
| authMethod (a : string)
| encrypMethod (e : string)
| HMAC (h : string)
| DHgroup (g : nat)
| time (t : nat).

(* Can have one parameter or more than one parameter
   specificed by the SA *)

Inductive SA : Type :=
| One (p1 : SA_param)
| More (p1 p2 : SA).

(* I identified each SA by a natural number *)

Inductive SA_id : Type :=
| SA_ID (n : nat).

Inductive SA_map : Type :=
| SA_empty
| SA_record (i : SA_id) (sa : SA) (m : SA_map).

Definition my_SA_map_base := SA_record (SA_ID 0) (One (time (1200)))  (SA_empty).
Check my_SA_map_base.

Definition SA_update (d: SA_map) (i : SA_id) (t_value : SA) : SA_map :=
  SA_record i t_value d.

Inductive SA_option : Type :=
| Some (sa : SA)
| None.

Definition eqb_id (x1 x2 : SA_id) :=
  match x1, x2 with
  | SA_ID x1, SA_ID x2 => x1 =? x2
  end.

Fixpoint SA_find (x : SA_id) (d : SA_map) : SA_option :=
  match d with
  | SA_empty => None
  | SA_record y r d' => if  eqb_id x y
                     then Some r
                     else SA_find x d'
  end.

Compute SA_find (SA_ID 0) (my_SA_map_base).
Compute SA_find (SA_ID 1) (my_SA_map_base).

(* What can you prove about SA??*)
(* Where do I store the values for the SA? *)
(* We need a delete option for the partial map?
   How should I write that? *)

Definition place := nat.

Inductive term : Type :=
| KIM : nat -> term
| USM : nat -> term
| AT : place -> term -> term
| SEQ : term -> term -> term
| PAR : term -> term -> term
| SIG : term -> term.

Check term.

Definition myterm1 := (KIM 3).
Definition myterm2 := (AT 4 (USM 4)).
Definition myterm3 := (SIG (KIM 3)).
Definition myterm4 := (SEQ (KIM 3)).
Definition myterm5 := (PAR (SIG (USM 4))).

(* A request is generated by the appraiser and
   holds something in it. It is not necessarily evidence yet
   but something else that dictates was the appraiser wants
   to know about the target. For now, I will say that the request
   is composed of certificates that enforce the privacy policy
   of the appraiser. *)

(*Inductive request (term : Type) :=
| EV : term -> (request term)
| SUM : term -> (request term) -> (request term)
| PROD : term -> (request term) -> (request term). *)

(* I built a data structure with a base type of evidence
   where it can be composed of evidence as a sum
   or product. Still unsure how this differs from
   the other type of Inductive request definition *)

Inductive request : Type :=
| EV (t : term)
| SUM (t1 t2 : request)
| PROD (t1 t2 : request).

Theorem request_comm : forall (r1 r2 : request),
    SUM r1 r2 = SUM r2 r1.
Proof.
  intros r1.
  induction r1.
  + intros. simpl.
Admitted.

(* We have now defined request as type SET *)
(* We need it to be communitive for SUM and PROD so
   order doesnt matter *)

Definition protocol := term.

Check request.

Definition myrequest0 := EV (myterm1).
Definition myrequest1 := EV (myterm3).
Definition myrequest2 := SUM (myrequest1) (myrequest0).
Definition myrequest3 := SUM (EV (KIM 3)) (EV (KIM 10)).
Definition myrequest4 := SUM (EV (KIM 10)) (EV (KIM 3)).

(*Definition myrequest3 := request (myterm1).*)

Definition myprotocol1 := PAR (KIM 3) (USM 3).

(* A protocol is  a list of terms
   But those terms can be arranged in certain ways
   like parallel execution, *)

Definition proposal := list protocol.

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(* What about examples of protocols? *)
(* Not sure which definition works? *)

(* Definition proposal := (request) -> protocol. *)

(* Options to match a request with are nothing,
   evidence, sum, product.

   When nothing, go to the empty list, otherwise,
   add to the front of the list.
 *)

Inductive R_id : Type :=
| R_ID (r : request).

Check R_id.

(* Definition eqb_id (t1 t2 : id) :=
  match t1, t2 with
  | ID t1, ID t2 => Same_set t1 t2
  end. *)

(* Two ways to construct partial map, either empty or using record with an existing
   partial map to construct a key-to-value mapping *)

(* For now, we will request a term. The map will be built upon terms that can be requested.
   You can look up the requested term in the map and the request protocol will be
   returned. *)

Inductive protocol_map : Type :=
| R_empty
| R_record (i : R_id) (p : protocol) (m : protocol_map).

(* Where each entry of the map is
   an ID that is the request *)

(* For now we will assume there is only
   one term being requested at a time *)

Definition my_protocol_map_base := R_record (R_ID (EV (KIM 3))) (KIM 3) (R_empty).
Check my_protocol_map_base.

Definition R_update (d: protocol_map) (i : R_id) (t_value : protocol) : protocol_map :=
  R_record i t_value d.

Definition my_partial_map_1 := R_update (my_protocol_map_base) (R_ID (EV (USM 3))) (SEQ (USM 3) (KIM 3)).

(* Now we need to be able to find the value with the key. *)

Inductive requestoption : Type :=
| R_Some (p : protocol)
| R_None.

(* Now we need the option to return none. This can be done by seeing
   if the two terms are equal. But we need an equality function to
   tell if they are the same where the equality function returns
   the bool true if they are the same. *)

(* term is of the type SET. What equality relations hold over
   set? *)

Check request.

Definition conditional_eq {A} (x y : A) := x = y.
Check conditional_eq.

Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.

Fixpoint eq_list (l1 l2 : list nat) : bool :=
match l1, l2 with
| nil , nil => true
| _ , nil => false
| nil , _ => false
| h1 :: t1 , h2 :: t2 => match eqb h1 h2 with
                         | true => eq_list t1 t2
                         | false => false
                         end
end.

(* Definition eq_request (r1 r2 : request) := forall a : term , In a r1 <-> In a r2. *)

Locate "=".
Print eq.

(* Inductive eq (A : Type) (x : A) : A -> Prop :=
  eq_refl : x = x. *)

Print eq_refl.

Compute eq 5 5.
Compute eq 5 6.

Inductive termeq : Type :=
| TTrue : termeq
| TFalse : termeq
| TEq : term -> term -> termeq.

(* For evaluating the terms, we only care if the
  pieces are equal. I guess making it in a list
  is fine, just have to be able to prove that
  two terms are equal. *)

(* Im not 100% sure that this definition
   of teval is correct since combining
   lists is not the correct way hmm *)

Inductive tevalR : term -> list nat -> Prop :=
| E_KIM (n1 :nat):
    tevalR (KIM n1) (n1 :: nil)
| E_USM (n1:nat):
    tevalR (USM n1) (n1 :: nil)
| E_AT (n1:place) (t1:term) (l1: list nat) :
    tevalR t1 l1 ->
    tevalR (AT n1 t1) (n1 :: l1)
| E_SEQ (t1 t2 : term) (l1 l2 : list nat):
    tevalR t1 l1 ->
    tevalR t2 l2 ->
    tevalR (SEQ t1 t2) (l1 ++ l2)
| E_PAR (t1 t2 : term) (l1 l2 : list nat):
    tevalR t1 l1 ->
    tevalR t2 l2 ->
    tevalR (PAR t1 t2) (l1 ++ l2)
| E_SIG (t1: term) (l1: list nat):
    tevalR t1 l1 ->
    tevalR (SIG t1) (l1).

Inductive teqR : termeq -> bool -> Prop :=
| E_TTrue :
    teqR (TTrue) true
| E_TFalse :
    teqR (TFalse) false
| E_termeq (t1 t2 : term) (t3 t4 : list nat) :
    tevalR t1 t3 ->
    tevalR t2 t4 ->
    teqR (TEq t1 t2) (eq_list t3 t4).

Compute teqR (TEq (KIM 3) (KIM 3)) (true).

Theorem eq_KIM_3 : teqR (TEq (KIM 3) (KIM 3)) (true).
Proof.
  Admitted.
(* Inductive tevalR : term -> Set -> Prop :=
| E_KIM (t1 : term) (n1 : nat) (S : Set) :
    tevalR (KIM n1) t1 ->
    tevalR In (t1) Empty_set.
| E_USM (t1 : term) (n1 : nat):
    tevalR (USM n1) t1
| E_SEQ (t1 t2 : term) (t3 t4 : term):
    tevalR t1 t3 ->
    tevalR t2 t4 ->
    tevalR (SEQ t1 t2) (Union t3 t4). *)

Inductive reqR : Type :=
| RTrue : reqR
| RFalse : reqR
| Req : request -> request -> reqR
| Ror : request -> request -> reqR
| Rand : request -> request -> reqR.

Fixpoint eq_term (t1 t2 : term) : bool :=
match t1 with
| KIM x1 => match t2 with
            | KIM x2 => if x1 =? x2 then true else false
            | _ => false
            end
| USM x1  => match t2 with
            | USM x2 => if x1 =? x2 then true else false
            | _ => false
            end
| AT p1 x1 => match t2 with
              | AT p2 x2 => if p1 =? p2 then eq_term x1 x2 else false
              | _ => false
              end
| SEQ x1 x2 => match t2 with
               | SEQ x3 x4 => if eq_term x1 x3 then eq_term x2 x4 else false
               | _ => false
               end
| PAR x1 x2 => match t2 with
               | PAR x3 x4 => if eq_term x1 x3 then eq_term x2 x4 else false
               | _ => false
               end
| SIG x1 => match t2 with
            | SIG x2 => eq_term x1 x2
            | _ => false
            end
end.

Compute eq_term (SEQ (KIM 1) (KIM 2)) (SEQ (KIM 1) (KIM 2)).
Compute eq_term (PAR (KIM 1) (KIM 2)) (PAR (KIM 1) (KIM 2)).
Compute eq_term (KIM 3) (KIM 3).
Compute eq_term (KIM 3) (USM 3).
Compute eq_term (AT 1 (KIM 2)) (AT 1 (KIM 2)).

Inductive revalR : request -> term -> Prop :=
| R_EV (t1 : term) :
    revalR (EV t1) t1
| R_SUM (t1 t2 : term):
    revalR t1 t3 ->
    revalR t2 t4 ->
    revalR (SUM t1 t2) Union t3 t4.

Fixpoint eq_term (t1 t2 : term) : bool :=
match t1 with
| KIM x1 => match t2 with
            | KIM x2 => if x1 =? x2 then true else false
            | _ => false
            end
| USM x1  => match t2 with
            | USM x2 => if x1 =? x2 then true else false
            | _ => false
            end
| AT p1 x1 => match t2 with
              | AT p2 x2 => if p1 =? p2 then eq_term x1 x2 else false
              | _ => false
              end
| SEQ x1 x2 => eq_term x1 x2
| PAR x1 x2 => eq_term x1 x2
| SIG x1 => match t2 with
            | SIG x2 => eq_term x1 x2
            | _ => false
            end
end.

Compute eq_term (KIM 3) (KIM 3).
Compute eq_term (KIM 3) (USM 3).

Fixpoint eq_request (r1 r2 : R_id) : bool :=
  match r1, r2 with
  | R_ID (EV x1) , R_ID (EV x2) => if eq_term x1 x2 then true else false
  | R_ID (SUM x1 x2) , R_ID (SUM x3 x4) => if (eq_request (R_ID x1) (R_ID x3))
                                           then true
                                           else if (eq_request (R_ID x1) (R_ID x4))
                                                  then true
                                                  else if (eq_request (R_ID x2) (R_ID x3))
                                                       then true
                                                       else if (eq_request (R_ID x2) (R_ID x4))
                                                         then true
                                                         else false
  | R_ID (PROD x1 x2), R_ID (PROD x3 x4) => false (* if eq_request (R_ID x1) (R_ID x3)
                                            then true (* eq_request (R_ID x2) (R_ID x4)*)
                                            else false *)
  | _ , _ => false
  end.

Compute eq_request (R_ID myrequest1) (R_ID myrequest2).
Compute eq_request (R_ID (EV (KIM 1))) (R_ID (EV (KIM 1))).
Compute eq_request (R_ID myrequest2) (R_ID myrequest4). (* These should be equal *)

(* The problem is with the sum and prod parts.
   But I'm not quite sure what we can do to
   eliminate. It must recurse for each element
   of sum and prod to make sure they match.
   But the thing about sum and prod is that x1 can
   either match x3 or x4. So how to communicate
   that is tricky. *)

(* Prove that the sets of sum and prod are communitive!!!!! *)

(* ERROR : cannot guess decreasing argument of fix *)

(*Fixpoint eq_request (r1 r2 : R_id) : bool :=
  match r1  with
  | R_ID (EV x1) => match r2 with
                    | R_ID (EV x2) => if eq_term x1 x2 then true else false
                    | _ => false
                    end
  | R_ID (SUM x1 x2) => match r2 with
                        | R_ID (SUM x3 x4) => if (eq_request (R_ID x1) (R_ID x3))
                                              then (eq_request (R_ID x2) (R_ID x4))
                                              else false
                        | _ => false
                        end
  | R_ID (PROD x1 x2) => match r2 with
                         | R_ID (PROD x3 x4) => if (eq_request (R_ID x1) (R_ID x3))
                                                then (eq_request (R_ID x2) (R_ID x4))
                                                else false
                         | _ => false
                         end
  end. *)

Fixpoint R_find (x : R_id) (d : protocol_map) : requestoption :=
  match d with
  | R_empty => R_None
  | R_record y r d' => if eq_request x y
                     then R_Some r
                     else R_find x d'
  end.

(* How does request shape into the list??
   Should we be storing values somewhere??  *)

(* After a proposal is generated, the appraiser must then select
   the appropriate protocol for the attestation manager.
   This implies there must be some notion of best and some
   notion of worst and that the protocols must be ordered.

   This brings me back to my inital thoughts that I have no idea
   where the notion of ordering should begin. Somehow we must
   define a hierarcy of protocols in order to make the
   decision. Maybe a function is the best way to go about
   establishing an ordering. *)

(* Things to discuss
   1. properties of request
   2. why two requests can't be equal
   3. where are we saving the examples?
      Is there a way to save examples and import them from a file?
 *)

Fixpoint targ_priv_poly (p : protocol) : bool :=
  match p with
  | KIM x => true
  | _ => false
  end.

(* Defining like this wouldnt make it situationally dependent *)


(***************************************************************************
* Equivalence of big-step and small-step in call-by-value - Infrastructure *
* Arthur Chargueraud, March 2009                                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN BigStep_Definitions.

(* ********************************************************************** *)
(** ** Additional Definitions used in the Proofs *)

(** Computing free variables of a term. *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs t1    => (fv t1)
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  end.

(** Substitution for names *)

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs t1    => trm_abs (subst z u t1)
  | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2)
  end.

Notation "[ z ~> u ] t" := (subst z u t) (at level 68).

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67)
  : infrastructure_scope.

Local Open Scope infrastructure_scope.

(* ********************************************************************** *)
(** ** Instanciation of tactics *)

(** Tactic [gather_vars] returns a set of variables occurring in
    the context of proofs, including domain of environments and
    free variables in terms mentionned in the context. *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : trm => fv x) in
  constr:(A \u B \u C).

(** Tactic [pick_fresh x] adds to the context a new variable x
    and a proof that it is fresh from all of the other variables
    gathered by tactic [gather_vars]. *)

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

(** Tactic [apply_fresh T as y] takes a lemma T of the form
    [forall L ..., (forall x, x \notin L, P x) -> ... -> Q.]
    instantiate L to be the set of variables occuring in the
    context (by [gather_vars]), then introduces for the premise
    with the cofinite quantification the name x as "y" (the second
    parameter of the tactic), and the proof that x is not in L. *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.
Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto_star.
Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.
Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; auto_star.

Hint Constructors term value beta reds.

(* ********************************************************************** *)
(** ** Properties of substitution *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ; simpls; inversion* Equ; fequals*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; fequals*. unfolds open.
  pick_fresh x. apply* (@open_rec_term_core t1 0 (trm_fvar x)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin fv t ->  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; fequals*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ ([x ~> u]t2).
Proof.
  intros. unfold open. generalize 0.
  induction t1; intros; simpl; fequals*.
  case_nat*. case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_var : forall x y u t, y <> x -> term u ->
  ([x ~> u]t) ^ y = [x ~> u] (t ^ y).
Proof.
  introv Neq Wu. rewrite* subst_open. simpl. case_var*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_intro : forall x t u,
  x \notin (fv t) -> term u ->
  t ^^ u = [x ~> u](t ^ x).
Proof.
  introv Fr Wu. rewrite* subst_open.
  rewrite* subst_fresh. simpl. case_var*.
Qed.

Lemma subst_intro' : forall x t u,
  x \notin (fv t) ->
  t ^^ u = [x ~> u](t ^ x).
Proof.
  introv H. unfold open. generalize 0. gen H.
  induction t; simpl; intros; fequals*.
  case_nat*.
  simpl. case_var*.
  case_var*.
Qed.
(* todo *)

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpls*.
  case_var*.
  apply_fresh term_abs. rewrite* subst_open_var.
Qed.

Hint Resolve subst_term.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> body t1.
Proof. intros. unfold body. inversion* H. Qed.

Lemma body_to_term_abs : forall t1,
  body t1 -> term (trm_abs t1).
Proof. intros. inversion* H. Qed.

Hint Resolve term_abs_to_body body_to_term_abs.

(** ** Opening a body with a term gives a term *)

Lemma open_term : forall t u,
  body t -> term u -> term (t ^^ u).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro y).
Qed.

Hint Resolve open_term.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall e,
  value e -> term e.
Proof.
  induction 1; autos*.
Qed.

(** A reduction relation only holds on pairs of locally-closed terms. *)

Lemma beta_regular : forall e e',
  beta e e' -> term e /\ term e'.
Proof.
  induction 1; autos* value_regular.
Qed.

Lemma beta_star_regular : forall e e',
  beta_star e e' -> term e /\ term e'.
Proof.
  induction 1.
  autos*.
  destruct* (beta_regular H).
Qed.

Lemma reds_regular : forall e e',
  reds e e' -> term e /\ term e'.
Proof.
  induction 1; autos* value_regular.
Qed.

(** Automation for reasoning on well-formedness. *)

Hint Extern 1 (term ?t) =>
  match goal with
  | H: value t |- _ => apply (value_regular H)
  | H: beta t _ |- _ => apply (proj1 (beta_regular H))
  | H: beta _ t |- _ => apply (proj2 (beta_regular H))
  | H: beta_star t _ |- _ => apply (proj1 (beta_star_regular H))
  | H: beta_star _ t |- _ => apply (proj2 (beta_star_regular H))
  | H: reds t _ |- _ => apply (proj1 (reds_regular H))
  | H: reds _ t |- _ => apply (proj2 (reds_regular H))
  end.


Require Import String.
Require Import List.

(* utils *)

Definition ret {A : Type} (x : A) := Some x.

Definition bind {A B : Type} (a : option A) (f : A -> option B) : option B :=
  match a with
    | Some x => f x
    | None => None
  end.

Definition guard (b : bool) : option unit := if b then Some tt else None.

Hint Unfold ret bind guard.

Notation "A >>= F" := (bind A F) (at level 42, left associativity).

Notation "X <-- A ; B" :=
  (bind A (fun X => B))
  (right associativity, at level 60).

Notation "A ;; B" :=
  (bind A (fun _ => B))
  (right associativity, at level 60).

(* tactics *)

Ltac try_inv :=
  match goal with
  | [ H : _ |- _ ] => solve [inversion H; auto]
  | _ => idtac
  end.

Ltac ind_rem h b Hb :=
  remember h as b eqn:Hb;
  (* apply eq_sym in Hb; *)
  induction b;
  cbn in *;
  try_inv.

Ltac di h := destruct h; try_inv; cbn in *.

(* main *)

Definition var := string.
(*
Eval compute in (if string_dec "a" "b" then 1 else 2). (* porównanie napisów *)
Eval compute in (if string_dec "a" "a" then 1 else 2). (* porównanie napisów *)
*)

Inductive type :=
| typebool : type
| typevar : var -> type
| typelam : type -> type -> type
.
Notation "a ~> b" :=
  (typelam a b)
  (at level 62, right associativity)
.
Fixpoint type_eq (a b : type) : bool :=
  match a, b with
  | typebool, typebool => true
  | typevar x, typevar y => if string_dec x y then true else false
  | a1 ~> a2, b1 ~> b2 => andb (type_eq a1 b1) (type_eq a2 b2)
  | _, _ => false
  end
.
Inductive term :=
| termbool : bool -> term
| termif : term -> term -> term -> term
| termvar : var -> term
| lam : var -> type -> term -> term
| termapp : term -> term -> term
.
Notation "M · N" :=
  (termapp M N)
  (at level 61, left associativity)
.
Definition ctx := list (var * type)
.
Fixpoint lookup (G : ctx) (x : var) : option type :=
  match G with
  | nil => None
  | (v, t) :: G' => if string_dec v x then Some t else lookup G' x
  end
.
Inductive has_type : ctx -> term -> type -> Prop :=
| bool_has_type : forall G b, has_type G (termbool b) typebool
| if_has_type : forall G b c1 c2 a,
  has_type G b typebool ->
  has_type G c1 a ->
  has_type G c2 a ->
  has_type G (termif b c1 c2) a
| var_has_type : forall G x a, lookup G x = Some a -> has_type G (termvar x) a
| lam_has_type : forall G x M (a b : type),
  has_type ((x, b) :: G) M a ->
  has_type G (lam x b M) (b ~> a)
| app_has_type : forall G (M N : term) (a b : type),
  has_type G M (a ~> b) -> has_type G N a -> has_type G (M · N) b
.
Hint Constructors has_type term type.

Fixpoint infer (G : ctx) (M : term) : option type :=
  match M with
  | termbool _ => Some typebool
  | termif b c1 c2 =>
    check G b typebool ;;
    a <-- infer G c1 ;
    check G c2 a ;;
    ret a
  | termvar x => lookup G x
  | lam x a N =>
    b <-- infer ((x, a) :: G) N ;
    ret (a ~> b)
  | M1 · M2 =>
    match infer G M1 with
    | Some (a ~> b) =>
      check G M2 a ;;
      ret b
    | _ => None
    end
  end
with check (G : ctx) (M : term) (A : type) : option unit :=
  match M with
  | termbool _ =>
    guard (type_eq A typebool) ;;
    ret tt
  | termif b c1 c2 =>
    check G b typebool ;;
    check G c1 A ;;
    check G c2 A
  | termvar x =>
    a <-- lookup G x ;
    guard (type_eq A a) ;;
    ret tt
  | lam x a N =>
    match A with
    | a' ~> b =>
      guard (type_eq a' a) ;;
      check ((x, a) :: G) N b
    | _ => None
    end
  | M1 · M2 =>
    match infer G M1 with
    | Some (a2 ~> a) =>
      guard (type_eq a A) ;;
      check G M2 a2
    | _ => None
    end
  (* | _ =>
    a' <-- infer G M ;
    if type_eq a a' then Some a else None *)
  end
.

Definition vx := termvar "x"%string.
Definition vy := termvar "y"%string.
Definition vz := termvar "z"%string.
Definition va := typevar "a"%string.
Definition vb := typevar "b"%string.
Definition vc := typevar "c"%string.
Compute infer nil (lam "x"%string va vx).
Compute infer nil
  (lam "x"%string (vb ~> vc)
    (lam "y"%string (va ~> vb)
      (lam "z"%string va (vx · (vy · vz))))).

Lemma from_guard_type_eq : forall a b, Some tt = guard (type_eq a b) -> a = b.
Proof.
  intros.
  generalize dependent b. induction a; intros.
  { ind_rem (type_eq typebool b) t Ht. di b. }
  { ind_rem (type_eq (typevar v) b) t Ht. di b. di (string_dec v v0). }
  { ind_rem (type_eq (a1 ~> a2) b) t Ht. di b.
    ind_rem (type_eq a1 b1) t1 Ht1.
    assert (guard (type_eq a1 b1) = Some tt). rewrite <- Ht1; auto.
    assert (guard (type_eq a2 b2) = Some tt). rewrite <- Ht; auto.
    rewrite IHa1 with b1; auto.
    rewrite IHa2 with b2; auto.
  }
  Qed.

Lemma check_lam : forall G v t M a, check G (lam v t M) a = Some tt ->
  exists b, a = t ~> b /\ check ((v, t) :: G) M b = Some tt.
Proof.
  intros.
  cbn in H.
  di a.
  ind_rem (guard (type_eq a1 t)) g Hg.
  exists a2. split; auto.
  di a; apply from_guard_type_eq in Hg. rewrite Hg. reflexivity.
  Qed.

Lemma check_app : forall G M1 M2 a, check G (M1 · M2) a = Some tt ->
  exists b, infer G M1 = Some (b ~> a) /\ check G M2 b = Some tt.
Proof.
  intros.
  ind_rem (check G (M1 · M2) a) ch Hch.
  ind_rem (infer G M1) im1 Him1.
  di a1.
  ind_rem (guard (type_eq a1_2 a)) g Hg.
  di a1; apply from_guard_type_eq in Hg. subst.
  exists a1_1. di a0.
  Qed.

Lemma check_to_infer : forall G M a, check G M a = Some tt -> infer G M = Some a.
Proof.
  intros. generalize dependent a. generalize dependent G.
  induction M; intros.
  - cbn in *.
    ind_rem (guard (type_eq a typebool)) t Ht. di a0.
    apply from_guard_type_eq in Ht. subst. auto.
  - cbn in *.
    di (check G M1 typebool).
    ind_rem (check G M2 a) m2 Hm2. di a0.
    apply eq_sym in Hm2.
    apply IHM2 in Hm2 as Hcm2.
    (* apply IHM3 in H. *)
    rewrite Hcm2. cbn. rewrite H. cbn. auto.
  - cbn in *. di (lookup G v).
    ind_rem (guard (type_eq a t)) eqat Heq.
    di a0. apply from_guard_type_eq in Heq. subst. auto.
  - apply check_lam in H; destruct H as [b H]; destruct H as [Ha H].
    cbn.
    apply IHM in H. rewrite H. cbn. rewrite Ha. reflexivity.
  - apply check_app in H; destruct H as [b H]; destruct H as [Hi Hc].
    cbn. rewrite Hi. rewrite Hc. cbn. auto.
  Qed.

Lemma infer_lam : forall G v t M a, infer G (lam v t M) = Some a ->
  exists b, a = t ~> b /\ infer ((v, t) :: G) M = Some b.
Proof.
  intros.
  cbn in H.
  ind_rem (infer ((v, t) :: G) M) im Him.
  inversion H; subst; clear H.
  exists a0; auto.
  Qed.

Lemma infer_app : forall G M1 M2 a, infer G (M1 · M2) = Some a ->
  exists b, infer G M1 = Some (b ~> a) /\ check G M2 b = Some tt.
Proof.
  intros.
  ind_rem (infer G (M1 · M2)) im Him.
  ind_rem (infer G M1) im1 Him1.
  di a1.
  ind_rem (check G M2 a1_1) cm2 Hcm2.
  inversion H. inversion Him. subst. clear H Him.
  destruct a1.
  exists a1_1.
  auto.
  Qed.

(* Lemma infer_check_ok : forall M G a,
  infer G M = Some a \/ check G M a = Some tt -> has_type G M a.
Proof.
  induction M; intros.
  - destruct H.
    cbn in H. inversion H. constructor.
    cbn in H. ind_rem (type_eq a typebool) t Ht. destruct a; try_inv.
  - cbn in H.
    ind_rem (check G M1 typebool) cm1 Hcm1. di a0.
    ind_rem (infer G M2) im2 Him2.
    ind_rem (check G M3 a0) cm3 Hcm3. di a1.
    inversion H. subst. clear H.
    apply eq_sym in Hcm1. apply check_to_infer in Hcm1. apply IHM1 in Hcm1.
    apply eq_sym in Hcm3. apply check_to_infer in Hcm3. apply IHM3 in Hcm3.
    apply eq_sym in Him2. apply IHM2 in Him2.
    constructor; assumption.
  - constructor. cbn in H. auto.
  - apply infer_lam in H as H1; destruct H1 as [ b H1 ];
      destruct H1 as [H0 H1]; rewrite H0 in *; clear H0.
    constructor.
    apply IHM.
    assumption.
  - apply infer_app in H as H1;
      destruct H1 as [b H1]; destruct H1 as [H1 H2].
    apply app_has_type with b.
    + apply IHM1. assumption.
    + apply check_to_infer in H2. apply IHM2. auto.
  Qed. *)

Lemma infer_ok : forall G M a, infer G M = Some a -> has_type G M a.
Proof.
  intros. generalize dependent a. generalize dependent G.
  induction M; intros.
  - cbn in H. inversion H. constructor.
  - cbn in H.
    ind_rem (check G M1 typebool) cm1 Hcm1. di a0.
    ind_rem (infer G M2) im2 Him2.
    ind_rem (check G M3 a0) cm3 Hcm3. di a1.
    inversion H. subst. clear H.
    apply eq_sym in Hcm1. apply check_to_infer in Hcm1. apply IHM1 in Hcm1.
    apply eq_sym in Hcm3. apply check_to_infer in Hcm3. apply IHM3 in Hcm3.
    apply eq_sym in Him2. apply IHM2 in Him2.
    constructor; assumption.
  - constructor. cbn in H. auto.
  - apply infer_lam in H as H1; destruct H1 as [ b H1 ];
      destruct H1 as [H0 H1]; rewrite H0 in *; clear H0.
    constructor.
    apply IHM.
    assumption.
  - apply infer_app in H as H1;
      destruct H1 as [b H1]; destruct H1 as [H1 H2].
    apply app_has_type with b.
    + apply IHM1. assumption.
    + apply check_to_infer in H2. apply IHM2. auto.
  Qed.

Definition typecheck (G : ctx) (M : term) : option { A : type | has_type G M A }.
  ind_rem (infer G M) o H.
  - refine (Some (exist _ a _)).
    apply infer_ok. auto.
  - refine None.
Defined.