Require Import String List Bool Compare_dec Euclid Omega.

Set Implicit Arguments.

Module GradebookModel.

  Definition ID := nat.
  Definition PassHash := nat.
  Definition Assignment := nat.
  Definition Grade := nat.
  Definition Section := nat.

  Definition id_dec : forall (k1 k2:ID), {k1 = k2} + {k1 <> k2}.
    exact eq_nat_dec.
  Qed.
  Definition ph_dec : forall (k1 k2:PassHash), {k1 = k2} + {k1 <> k2}.
    exact eq_nat_dec.
  Qed.
  Definition assign_dec : forall (k1 k2:Assignment), {k1 = k2} + {k1 <> k2}.
    exact eq_nat_dec.
  Qed.
  Definition grade_dec : forall (k1 k2:Grade), {k1 = k2} + {k1 <> k2}.
    exact eq_nat_dec.
  Qed.
  Definition section_dec : forall (k1 k2:Grade), {k1 = k2} + {k1 <> k2}.
    exact eq_nat_dec.
  Qed.

  Inductive ParseCommand : Set :=
  | SetGrade'       : string -> string -> string -> string -> Grade -> ParseCommand
  | GetGrade'       : string -> string -> string -> string -> ParseCommand
  | Average'        : string -> string -> string -> ParseCommand.

  Inductive Command : Set :=
  | SetGrade       : ID -> PassHash -> ID -> Assignment -> Grade -> Command
  | GetGrade       : ID -> PassHash -> ID -> Assignment -> Command
  | Average        : ID -> PassHash -> Assignment -> Command.

  (* Configuration correctness *******************************************)

  Record Config : Set := mkCfg {
    students : list ID;
    tas      : list ID;
    profs    : list ID;
    sections : list (ID * Section );
    hashes   : list (ID * PassHash);
    totals   : list Grade;
    strings  : list (string * nat)
  }.

  Definition translate (cfg: Config) (str: string) : nat :=
    match find (fun x => if string_dec str (fst x) then true else false) (strings cfg) with
      | None => 0
      | Some (_,res) => res
    end.

  Definition compileCommand (cfg: Config) (q : ParseCommand) : Command :=
    match q with
      | SetGrade' u p i a g => SetGrade (translate cfg u) (translate cfg p) (translate cfg i) (translate cfg a) g
      | GetGrade' u p i a   => GetGrade (translate cfg u) (translate cfg p) (translate cfg i) (translate cfg a)
      | Average' u p a      => Average  (translate cfg u) (translate cfg p) (translate cfg a)
    end.

  Fixpoint lookup t x (l: list (ID * t)) : option t :=
    match l with
      | nil => None
      | (x',y) :: b => if id_dec x x' then Some y else lookup x b
    end.

  Fixpoint in_dec x (l: list ID) :=
    match l with
      | nil => false
      | a :: b => if id_dec x a then true else in_dec x b
    end.

  Fixpoint excludes (l1: list ID) (l2: list ID) {struct l1}  :=
    match l1 with
      | nil => true
      | a :: b => if in_dec a l2
        then false
        else excludes b l2
    end.

  (* this takes too long to compute *)
  Definition disjoint_dec (cfg: Config) := true.
(*
    (excludes (students cfg) (tas cfg)) &&
    (excludes (students cfg) (profs cfg)) &&
    (excludes (tas cfg) (students cfg)) &&
    (excludes (tas cfg) (profs cfg)) &&
    (excludes (profs cfg) (students cfg)) &&
    (excludes (profs cfg) (tas cfg)).
*)

  Fixpoint total_dec t (l1: list ID) (l2: list (ID * t)) {struct l1} :=
    match l1 with
      | nil => true
      | a :: b => if lookup a l2
        then total_dec b l2
        else false
    end.

  Definition correct_cfg cfg : bool := disjoint_dec cfg &&
    total_dec (students cfg ++ tas cfg ++ profs cfg) (hashes cfg) &&
    total_dec (students cfg ++ tas cfg) (sections cfg).

  (* Data constraints ***************************************************)

  Fixpoint bounded (l': list Grade) (l: list Grade) {struct l'} : bool :=
    match l', l with
      | nil, nil => true
      | a :: b, c :: d => (if le_gt_dec a c then true else false) && bounded b d
      | _ , _ => false
    end.

  Fixpoint store_inv1 (l: list (ID * (list Grade))) (cfg : Config) {struct l} : bool :=
    match l with
      | nil => true
      | a :: b => bounded (snd a) (totals cfg) &&
        store_inv1 b cfg
    end.

  Fixpoint noduples (st: list ID) (ll: list (ID * list Grade)) {struct ll} :=
    match ll with
      | nil => true
      | a :: b => match lookup (fst a) b with
                    | None =>   in_dec (fst a) st && noduples st b
                    | Some _ => false
                  end
    end.

  Section U.
    Variable T : Type.
    Variable dec : forall (a b : T), {a = b} + {a <> b}.
    Fixpoint unique (l : list T) : bool :=
      match l with
        | nil => true
        | a :: b => if In_dec dec a b then false else unique b
      end.
  End U.

  Definition config_inv (cfg : Config) : bool :=
    unique id_dec (students cfg) && unique id_dec (profs cfg) && unique id_dec (tas cfg).

  Definition store_inv l cfg :=
    store_inv1 l cfg && total_dec (students cfg) l && noduples (students cfg) l
    && config_inv cfg.

  (* Privacy ************************************************************)

Section Privacy.
  Hypothesis cfg:Config.

  Definition accessOk f id pass := in_dec id (f cfg)
    && match lookup id (hashes cfg) with
         | Some x => if id_dec x pass then true else false
         | None => false
       end.

  Definition isProf := accessOk profs.
  Definition isTA := accessOk tas.
  Definition isStudent := accessOk students.

  Definition taFor id pass x :=
    match lookup x (sections cfg) with
      | None => false
      | Some section =>
        match lookup id (sections cfg) with
          | None => false
          | Some section' => if section_dec section section'
            then isTA id pass && if in_dec id (students cfg) then true else false
            else false
        end
    end.

  Definition private (q: Command) : bool :=
    match q with
      | SetGrade id pass x _ a => in_dec x (students cfg)
                                    && (isProf id pass || taFor id pass x)
      | GetGrade id pass x a   => in_dec x (students cfg)
                                     && (isProf id pass
        || (isStudent id pass && if id_dec id x then true else false)
        || taFor id pass x )
      | Average  id pass a     => (isProf id pass || isStudent id pass || isTA id pass)
    end.

  Definition lt_dec (a b : nat) : {a < b} + {a >= b}.
    intros; destruct (le_lt_dec a b); destruct (eq_nat_dec a b); solve [ left; omega | right; omega ].
  Qed.

  Definition validAssignment (a : nat) :
    {a < length (totals cfg)} + {a >= length (totals cfg)} := lt_dec a (length (totals cfg)).

End Privacy.

  Inductive Status : Set :=
  | ERR_NOTPRIVATE : Status
  | ERR_BADGRADE : Status
  | ERR_NOINV : Status
  | OK  : Status
  | RET : Grade -> Status.

  Fixpoint nth_set (g: Grade) (a: Assignment) (l: list Grade) {struct l} : list Grade :=
    match l with
      | nil => nil
      | a' :: b => match a with
                     | O => g :: b
                     | S n => a' :: (nth_set g n b )
                   end
    end.

  Fixpoint insert (id: ID) (l: list Grade) (ll: list (ID * list Grade)) {struct ll}: list (ID * list Grade) :=
    match ll with
      | nil => (id,l)::  nil
      | a :: b => if id_dec (fst a) id then (id, l) :: b else a :: insert id l b
    end.

  Fixpoint nth_get (a: Assignment) (l: list Grade) {struct l} : option Grade :=
    match l with
      | nil => None
      | a' :: b => match a with
                     | O => Some a'
                     | S n => nth_get n b
                   end
    end.

  Definition inbounds (g: Grade) (a: Assignment) (tots: list Grade) : bool :=
    match nth_get a tots with
      | None => false
      | Some g' => if le_gt_dec g g' then true else false
    end.

  Fixpoint sum_all (l: list Grade) :=
    match l with
      | nil => 0
      | a :: b => a + (sum_all b)
    end.

  Fixpoint proj (x: Assignment) (l: list (ID * list Grade)) : option (list Grade) :=
    match l with
      | nil => Some nil
      | a :: b => match nth_get x (snd a) with
                    | None => None
                    | Some a' => match proj x b with
                                   | None => None
                                   | Some rest => Some (a' :: rest)
                                 end
                  end
    end.

  (* a / b *)
  Require Import Euclid.
  Definition divcheck0 : forall (a b: nat), nat.
  intros; refine (
    match b as b' return b = b' -> nat with
      | 0 => fun _ => 0
      | S n' => fun pf => match eucl_dev b _ a   with
                            | divex q _ _ _ => q
                          end
    end (refl_equal _)); omega.
  Qed.

  Definition avg (l: list Grade) : nat := divcheck0 (sum_all l) (length l).

  Definition mutate (q: Command) (mm: (Config * list (ID * list Grade)))
    : (Status * (Config * list (ID * list Grade))) :=
    match mm with
      | (cfg, m) =>
        if private cfg q
        then match q with
               | SetGrade id pass x a g =>
                 if inbounds g a (totals cfg)
                 then match lookup x m with
                        | None => (ERR_NOINV, mm)
                        | Some g' => (OK, (cfg, insert x (nth_set g a g') m))
                      end
                 else (ERR_BADGRADE, mm)
               | GetGrade id pass x a =>
                 match lookup x m with
                   | None => (ERR_NOINV, mm)
                   | Some g' => match nth_get a g' with
                                  | None => (ERR_BADGRADE, mm)
                                  | Some g'' => (RET g'', mm)
                                end
                 end
               | Average  id pass a =>
                 if validAssignment cfg a then
                   match proj a m with
                     | None => (ERR_NOINV, mm)
                     | Some x => (RET (avg x), mm)
                   end
                   else (ERR_BADGRADE, mm)
             end
        else (ERR_NOTPRIVATE, mm)
    end.

  (** Tactics **)
  Ltac exhaustive solver :=
    simpl;
    repeat (match goal with
              | [ |- context [ if ?X then _ else _ ] ] => case_eq X
              | [ |- context [ match ?X with | Some _ => _ | None => _ end ] ] => case_eq X
              | [ |- context [ match ?X with | SetGrade _ _ _ _ _ => _ | GetGrade _ _ _ _ => _ | Average _ _ _ => _ end ] ] => case_eq X
            end; intros; simpl; try solver).

  Ltac isTrue P H :=
    assert (P  = true); [ destruct P; [ reflexivity | simpl in H; inversion H ] | ].

  Ltac all := idtac;
    let rec smallest P :=
      match P with
        | Bool.ifb ?X _ _ => smallest X
        | _ => P
      end
    in repeat match goal with
                | [ H : Bool.ifb ?X ?Y false = true |- _ ] =>
                  let T := smallest X in
                  let H' := fresh "F" in
                  assert (T = true) as H';
                    [ destruct (T); [ reflexivity | simpl in H; inversion H ]
                    | rewrite H' in H; simpl in H ]
                | [ H : andb ?X _ = true |- _ ] =>
                  let T := smallest X in
                  let H' := fresh "F" in
                  assert (T = true) as H';
                    [ destruct (T); [ reflexivity | simpl in H; inversion H ]
                    | rewrite H' in H; simpl in H ]
              end.

  Ltac each := repeat match goal with
                        | [ |- ifb ?X ?Y false = true ] =>
                          let H := fresh "H" in
                          assert (H : X = true); [ | rewrite H; simpl ]
                        | [ |- andb ?X ?Y = true ] =>
                          let H := fresh "H" in
                          assert (H : X = true); [ | rewrite H; simpl ]
                      end.
(*
  Ltac inv T := idtac;
    let rec run T := idtac;
      match goal with
        | [ |- ?A :: ?B = ?C :: ?D ] =>
          let H := fresh "H" in
          let H' := fresh "H" in
          assert (A = C) as H; [ T | assert (B = D) as H'; [ T | (try rewrite H); (try rewrite H'); reflexivity ] ]
        | [ |- (?A, ?B) = (?C, ?D) ] =>
          let H := fresh "H" in
          let H' := fresh "H" in
          assert (A = C) as H; [ T | assert (B = D) as H'; [ T | (try rewrite H); (try rewrite H'); reflexivity ] ]
        | [ |- Some ?A = Some ?B ] =>
          let H := fresh "H" in
          assert (A = B) as H; [ T | (try rewrite H); reflexivity ]
      end
    in run T.
*)

 Ltac inv T := idtac;
    let rec run T := idtac;
      match goal with
        | [ |- ?A :: ?B = ?C :: ?D ] =>
          let H := fresh "H" in
          let H' := fresh "H" in
          assert (A = C) as H; [ T | assert (B = D) as H'; [ T | (try rewrite H); (try rewrite H'); reflexivity ] ]
        | [ |- (?A, ?B) = (?C, ?D) ] =>
          let H := fresh "H" in
          let H' := fresh "H" in
          assert (A = C) as H; [ T | assert (B = D) as H'; [ T | (try rewrite H); (try rewrite H'); reflexivity ] ]
        | [ |- Some ?A = Some ?B ] =>
          let H := fresh "H" in
          assert (A = B) as H; [ T | (try rewrite H); reflexivity ]
        | [ |- S ?A = S ?B ] =>
          let H := fresh "H" in
          assert (A = B) as H; [ T | (try rewrite H); reflexivity ]
      end
    in run T.

  (* This definition of mutate applies just as well to non-wellformed stores and
     and configurations.  Further properties are useful for implementations. *)

  Theorem bounded_length : forall a b,
    bounded a b = true -> length a = length b.
    induction a. induction b. trivial. simpl in *. intros; discriminate. simpl in *.
    intros. destruct b. discriminate. simpl in *. cut (length a0 = length b). intros. congruence.
    destruct (le_gt_dec a g). simpl in H. apply (IHa b H). simpl in H. discriminate.
  Qed.

  Theorem insert_inv : forall cfg (l: list (ID * list Grade)) id gr,
    store_inv1 l cfg = true -> bounded gr (totals cfg) = true
    -> store_inv1 (insert id gr l) cfg = true.
    induction l. simpl. intros. rewrite H0. simpl. trivial.
    simpl in *. destruct a. simpl in *. intros.
    destruct (id_dec i id). simpl in *. rewrite H0.
    assert (store_inv1 l cfg = true). destruct (store_inv1 l cfg). trivial.
    destruct (bounded l0 (totals cfg)). simpl in H. discriminate. simpl in H. discriminate.
    simpl. assumption.
    simpl in *; destruct (bounded l0 (totals cfg)); try (simpl;
      apply IHl; simpl in H; trivial). simpl in H. discriminate.
  Qed.

  Theorem inv_bounded : forall l c i0 (H: store_inv1 l c = true)
    (x : list Grade) (H1 : lookup i0 l = Some x),
    bounded x (totals c) = true.
    intros. induction l. simpl in *. discriminate.
    simpl in *. destruct a. simpl in *.  destruct (id_dec i0 i).
    assert (l0 = x). congruence. subst. destruct (bounded x (totals c)).
    simpl in H. trivial. simpl in H. discriminate. apply IHl.
    destruct (bounded l0 (totals c)). simpl in H. trivial. simpl in H.
    discriminate. trivial.
  Qed.

  Theorem insert_nthset_inv : forall l c g a i0 x
    (H0 : inbounds g a (totals c) = true)
    (pf: bounded x (totals c) = true)
    (H: store_inv1 l c = true), store_inv1 (insert i0 (nth_set g a x) l) c = true.
    intros. apply insert_inv; trivial. clear H l i0.
    generalize dependent a. generalize dependent g. generalize dependent pf. destruct c.
    simpl in *. clear students0 tas0 profs0 sections0 hashes0. generalize dependent totals0.
    induction x.
      destruct totals0; trivial.
      simpl in *. destruct totals0; intros; try discriminate. all.
      remember (le_gt_dec a g) as RM; destruct RM; try discriminate.
      destruct a0. simpl. each; trivial. simpl in *. rewrite <- HeqRM.
      simpl. apply IHx; auto.
  Qed.

  Theorem inv_inbounds : forall g a c i0 l
    (H : store_inv1 l c = true),
    store_inv1 (snd (snd
      (if inbounds g a (totals c)
        then
          match lookup i0 l with
            | Some g' => (OK, (c, insert i0 (nth_set g a g') l))
            | None => (ERR_NOINV, (c, l))
          end
        else (ERR_BADGRADE, (c, l))))) c = true.
    intros.
    assert (inbounds g a (totals c) = true \/ inbounds g a (totals c) = false).
    destruct (inbounds g a (totals c)); try firstorder.
    destruct H0; rewrite H0.
    assert (exists x, lookup i0 l = Some x \/ lookup i0 l = None).
    destruct (lookup i0 l); simpl in *; try trivial. exists l0. firstorder.
    exists (@ nil Grade). right. trivial. destruct H1. destruct H1.
    rewrite H1. simpl. eapply insert_nthset_inv. trivial. trivial.
    apply (inv_bounded l c i0 H H1). trivial. rewrite H1. simpl. trivial.
    simpl. trivial.
  Qed.

  Theorem mutate_inv_set: forall l c g a i0 p i, store_inv1 l c = true ->
    store_inv1 (snd (snd (mutate (SetGrade i p i0 a g) (c, l)))) c = true.
    intros; simpl; destruct (validAssignment c g); destruct (in_dec i0 (students c)); destruct (isProf c i p);  destruct (taFor c i p i0); simpl; try trivial; apply inv_inbounds; trivial.
  Qed.

  Theorem const_config2 : forall (T : Type) x (t : Config * T) q,
    fst x = fst t -> fst t = fst (snd (mutate q x)).
    intros. unfold mutate. destruct x; exhaustive ltac:(firstorder).
  Qed.

  Theorem const_config : forall x q, fst x = fst (snd (mutate q x)).
    intros; apply (const_config2 x x q); auto.
  Qed.

  Lemma insert_preserves_inv : forall l0 i0 l g a c,
    Some l0 = lookup i0 l ->
    true = inbounds g a (totals c) ->
    store_inv1 l c = true ->
    store_inv1 (insert i0 (nth_set g a l0) l) c = true.
    intros. apply insert_nthset_inv. auto. auto.
    eapply inv_bounded. eassumption. symmetry. eassumption. assumption.
  Qed.

  Lemma lookup_insertSome : forall l a b c l1,
    lookup a l = Some l1 -> exists e, lookup a (insert b c l) = Some e.
    induction l.
    intros; simpl in *; congruence.
    intros. destruct (id_dec a0 b). simpl. destruct (id_dec (fst a) b).
    rewrite e. simpl. destruct (id_dec b b); try congruence. exists c. trivial.
    simpl. remember a as zz. destruct zz. subst. simpl in *. destruct (id_dec b i);
    try congruence. eapply IHl. eassumption.
    simpl. remember a as r. destruct r. simpl in H. simpl. destruct (id_dec i b).
    simpl. rewrite e in H. destruct (id_dec a0 b); try congruence. eauto.
    simpl. destruct (id_dec a0 i). eauto. eapply IHl; eassumption.
  Qed.

  Lemma lookup_insertNone : forall l a b c,
    a <> b -> lookup a l = None -> lookup a (insert b c l) = None.
    induction l.
      intros. simpl. destruct (id_dec a b); try congruence.
      intros. simpl. destruct a. simpl.
      remember (id_dec i b) as RM. destruct RM. simpl.
      destruct (id_dec a0 b); try congruence. simpl in H0. rewrite e in H0.
      destruct (id_dec a0 b); try congruence.
      simpl. destruct (id_dec a0 i). simpl in H0. destruct (id_dec a0 i); try congruence.
      simpl in H0. destruct (id_dec a0 i); try congruence. apply IHl; auto.
  Qed.

  Lemma insert_preserves_total_dec : forall c l0 i0 l g a,
    Some l0 = lookup i0 l ->
    total_dec c l = true ->
    total_dec c (insert i0 (nth_set g a l0) l) = true.
    induction c.
      reflexivity.
      intros. simpl in *. remember (lookup a l) as RM. destruct RM; try congruence.
      symmetry in HeqRM.
      destruct (lookup_insertSome l a i0 (nth_set g a0 l0) HeqRM). auto. rewrite H1. apply IHc; auto.
  Qed.

  Lemma insert_preserves_noduples : forall l0 i0 g a l o,
    Some l0 = lookup i0 l ->
    noduples o l = true ->
    noduples o (insert i0 (nth_set g a l0) l) = true.
    induction l. simpl. intros. discriminate.
      intros. simpl in *. destruct a0. simpl in H0. remember (lookup i l) as RM. destruct RM; try congruence.
      simpl. destruct (id_dec i i0). simpl. rewrite <- e. rewrite <- HeqRM. auto.

      simpl. destruct (id_dec i0 i); try congruence. all.
      rewrite (IHl o H H0).
      remember (lookup i (insert i0 (nth_set g a l0) l)) as RM'. destruct RM'; try trivial.
      symmetry in HeqRM.
      pose (@lookup_insertNone l i i0 (nth_set g a l0) n HeqRM). congruence. firstorder.
  Qed.

  Theorem mutate_inv : forall l c q, store_inv1 l c = true ->
    store_inv1 (snd (snd (mutate q (c, l)))) (fst (snd (mutate q (c, l)))) = true.
    intros; destruct q;
      [ rewrite <- (const_config (c,l) (SetGrade i p i0 a g));
        apply (mutate_inv_set l c g a i0 p i); assumption
      | simpl in *; exhaustive ltac:(firstorder)
      | simpl in *; exhaustive ltac:(firstorder) ].
  Qed.
(* NOT USED
  Theorem mutate_l_get : forall l id pass x a c,
    (l = snd (snd (mutate (GetGrade id pass x a) (c, l)))).
    intros; exhaustive ltac:(trivial).
  Qed.

  Theorem mutate_cfg_get : forall l id pass x a c,
    (c = fst (snd (mutate (GetGrade id pass x a) (c, l)))).
    intros; exhaustive ltac:(trivial).
  Qed.

  Theorem mutate_cfg_inv : forall q c l, correct_cfg c = true ->
    correct_cfg (fst (snd (mutate q (c, l)))) = true.
    intros; destruct l; exhaustive ltac:(firstorder).
  Qed.

  Lemma total_inv : forall q l c,
    total_dec (students c) l = true ->
    total_dec (students (fst (snd (mutate q (c, l)))))
      (snd (snd (mutate q (c, l)))) = true.
    destruct q; intros; [ | exhaustive ltac:(firstorder) | exhaustive ltac:(firstorder) ].
    exhaustive ltac:(firstorder).
    unfold andb in HeqRM. symmetry in HeqRM. isTrue (in_dec i0 (students c)) HeqRM.
    apply insert_preserves_total_dec; assumption.
  Qed.
*)

  Lemma denoteLookup : forall T l (z : ID) (t : T),
    Some t = lookup z l -> In (z,t) l.
    induction l.
    intros; discriminate.
    intros. unfold lookup in H. destruct a. destruct (id_dec z i). inversion H. subst; firstorder.
    unfold In. right. apply IHl. auto.
  Qed.

  Lemma denoteLookupNone : forall T (z : ID) l,
    None = lookup z l -> forall x (t' : T), In (x,t') l -> x <> z.
    induction l.
      firstorder.
      intros. unfold In in H0. destruct H0. rewrite H0 in H. simpl in H. destruct (id_dec z x); congruence.
      eapply IHl. simpl in H. destruct a. destruct (id_dec z i); try congruence. auto. eassumption.
  Qed.

  Lemma denoteTotalDec : forall T x (l : list (ID * T)),
    total_dec x l = true ->
    forall z, In z x -> exists x, In (z, x) l.
    induction x.
      firstorder.
      intros. simpl in H. remember (lookup a l) as RM. destruct RM; try congruence.
      pose (IHx _ H). unfold In in H0. destruct H0.
      subst. exists t.
      apply denoteLookup; auto.
      apply e; auto.
  Qed.

  Lemma denoteInDec : forall x l, in_dec x l = true -> In x l.
    induction l; intros.
    simpl in *; congruence.
    unfold in_dec in H. destruct (id_dec x a). subst. firstorder.
    unfold In. right. apply IHl; auto.
  Qed.

  Lemma NotInDenote : forall T l x (x0:T),
    In (x, x0) l -> ~lookup x l = None.
    induction l.
      firstorder.
      intros. simpl. destruct a. remember (id_dec x i) as RM. destruct RM. unfold not; intros; congruence.
      eapply IHl. unfold In in H. destruct H. inversion H. congruence. eauto.
  Qed.

  Lemma in_dec_total_dec : forall l x c,
    in_dec x (students c) = true -> total_dec (students c) l = true
    -> exists g' : list Grade, lookup x l = Some g'.
    intros.
    destruct (denoteTotalDec _ _ H0 x (denoteInDec x (students c) H)).
    remember (lookup x l) as RM. destruct RM. exists l0; auto.
    pose (NotInDenote _  x x0 H1). congruence.
  Qed.

(**
  Theorem valid_bounded : forall c assign, validAssignment c assign = true ->
    S assign < S (length (totals c)).
    intros. cut (assign < length (totals c)). intros pf. omega.
    unfold validAssignment in H. unfold lt. destruct (lt_dec assign (length (totals c))); try congruence; omega.
  Qed.
**)

End GradebookModel.

Module ExampleConfig.
  Import GradebookModel.

  Open Local Scope string_scope.

  Definition test_config : Config :=
     mkCfg (4::5::6::nil)              (* students *)
           (2::3::nil)                 (* tas *)
           (1::nil)                    (* profs *)
           ((6,1)::(2,2)::(3,1)::(4,1)::(5,2)::nil)  (* sections *)
           ((1,11)::(2,22)::(3,33)::(4,44)
            ::(5,55)::(6,66)::nil)       (* passwords *)
           (70::80::100::nil)              (* assignments totals *)
           (("alice", 2) :: ("bob", 3) :: ("carol", 4) ::
            ("derek", 5) :: ("evan", 6) :: ("paul", 1) ::
            ("apass", 22) :: ("bpass", 33) :: ("cpass", 44) ::
            ("dpass", 55) :: ("epass", 66) :: ("ppass", 11) ::
            ("hw1", 0) :: ("hw2", 1) :: ("exam1", 2) :: nil).

  Definition test_grades : list (ID * list Grade) :=
    (4,65::63::75::nil)::
    (5,68::76::80::nil)::
    (6,70::80::94::nil)::
    nil.

  Definition test_model : Config * list (ID * (list Grade)) :=
    (test_config, test_grades).

  Theorem test_model_inv : store_inv1 test_grades test_config = true.
    unfold store_inv1.
    compute. trivial.
  Qed.

  Theorem test_cfg_inv' : correct_cfg test_config = true.
    compute;
    repeat match goal with
             | [ |- context [id_dec ?X ?Y] ] => destruct (id_dec X Y); simpl in *; try (discriminate || contradiction || firstorder)
             | [ H : context [id_dec ?X ?Y] |- _ ] => destruct (id_dec X Y); simpl in *; try (discriminate || contradiction || firstorder)
           end.
  Qed.

  Theorem test_cfg_inv : store_inv (snd test_model) (fst test_model) = true.
    unfold store_inv. pose (test_cfg_inv'). unfold config_inv. simpl.
    repeat match goal with
             | [ |- context [id_dec ?X ?Y] ] => destruct (id_dec X Y); simpl in *; try (discriminate || contradiction || firstorder)
             | [ H : context [id_dec ?X ?Y] |- _ ] => destruct (id_dec X Y); simpl in *; try (discriminate || contradiction || firstorder)
           end.
  Qed.

End ExampleConfig.

Export GradebookModel.


Load "Example20".

(*****************************************some theorems**********************************************************)
(**************************************************************************************************)

Theorem mor_eval_andB : forall (n1 : nat) (t1 t2:message), (if_then_else_M (Bvar n1)& (Bvar (n1+1)) t1 t2) #
(if_then_else_M (Bvar n1) (if_then_else_M (Bvar (n1+1)) ((n1+1):=TRue)((n1:=TRue)t1) ((n1+1):=FAlse)((n1:=TRue)t2)) (((n1:=FAlse)t2))).

Proof. intros.
unfold andB.
rewrite <- IFSAME_M with (b:= (Bvar n1)) (x:=  (if_then_else_M (if_then_else_B (Bvar n1) (Bvar (n1+1)) FAlse) t1 t2)) .
rewrite IFEVAL_M .
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFFALSE_M.
assert(H: (beq_nat (n1+1) n1 = false)).
rewrite Nat.eqb_sym.
induction n1.
reflexivity.
simpl. auto.
rewrite H.
rewrite IFEVAL_M with (n:= (n1+1)).
reflexivity.
Qed.

(***************corollary*********************************************)
Axiom mor_eval_andB' : forall (b1 b2 : Bool) (t1 t2 : message) , (if_then_else_M b1 & b2 t1 t2 ) # (if_then_else_M b1 (if_then_else_M b2 (subbol_msg' b2 TRue (subbol_msg' b1 TRue t1))  (subbol_msg' b2 FAlse (subbol_msg' b1 TRue t2))) (subbol_msg' b1 FAlse t2)).

Theorem breq_msgeq: forall (n:nat) (m1 m2 m3 m4 :message) , ((n:= TRue)m1)# ((n:= TRue)m3) -> ((n:= FAlse)m2)# ((n:= FAlse)m4) -> (if_then_else_M (Bvar n) m1 m2) # (if_then_else_M (Bvar n) m3 m4).
Proof. intros.
rewrite IFEVAL_M. rewrite H. rewrite H0. rewrite IFEVAL_M with (t1:= m3) (t2:= m4).
reflexivity. Qed.

(*****************Corollary ***********************************************)
Theorem breq_msgeq': forall (  b :Bool) (m1  m2 m3 m4 :message) ,  (subbol_msg' b TRue m1) # (subbol_msg' b TRue m2) -> (subbol_msg' b FAlse m3) # (subbol_msg' b FAlse m4) -> (if_then_else_M b m1 m3) # (if_then_else_M b m2 m4).

Proof. intros.
rewrite IFEVAL_M'.
rewrite IFEVAL_M' with (t1:= m2).
rewrite H, H0.
reflexivity.
Qed.
(************using (Bvar n)*****************)
Theorem breq_msgeq'': forall (n:nat) (m1  m2 m3 m4 :message) ,  (subbol_msg n TRue m1) # (subbol_msg n TRue m2) -> (subbol_msg n FAlse m3) # (subbol_msg n FAlse m4) -> (if_then_else_M (Bvar n) m1 m3) # (if_then_else_M (Bvar n) m2 m4).

Proof. intros.

rewrite IFEVAL_M.
rewrite IFEVAL_M with (t1:= m2).
rewrite H, H0.
reflexivity.
Qed.

Axiom breq_msgeq''': forall (n:nat) (b:Bool) (m1  m2 m3 m4 :message) ,  (if_then_else_M (Bvar n) m1 m3) # (if_then_else_M (Bvar n) m2 m4) ->   (if_then_else_M b m1 m3) # (if_then_else_M b m2 m4).
(***Proof.
 intros.

apply Forall_ELM_EVAL_M with (n:=n) (x:=b) in H.
simpl in H. rewrite <- beq_nat_refl in H. ***)
(****************************** then branches are equal******************)
Axiom breq_msgeq1: forall (n:nat) ( m2 m3 m4 :message) ,  ((n:= FAlse)m2)# ((n:= FAlse)m4) -> (if_then_else_M (Bvar 1) m3 m2) # (if_then_else_M (Bvar n) m3 m4).

 Theorem breq_msgeq1': forall (  b :Bool) ( m2 m3 m4 :message) ,  (subbol_msg' b FAlse m2) # (subbol_msg' b FAlse m4) -> (if_then_else_M b m3 m2) # (if_then_else_M b m3 m4).

Proof. intros . rewrite IFEVAL_M'.
rewrite IFEVAL_M' with (t2:= m4).
rewrite H.
reflexivity.
Qed.

Theorem  andB_elm : forall (n1 n2 : nat) (x y: message), (if_then_else_M (Bvar n1) &  (Bvar n2) x y) # (if_then_else_M (Bvar n1) (if_then_else_M (Bvar n2) x y) y).
Proof. intros.
rewrite <- IFSAME_M with (b:= (Bvar n1)) (x:= (if_then_else_M (Bvar n1) & (Bvar n2) x y)) at 1.
rewrite IFEVAL_M with (n:= n1). simpl.
rewrite <- beq_nat_refl.
Eval compute in subbol_msg' (Bvar n1) TRue x.

rewrite IFEVAL_M with (n:= n1) (t2:= y).
simpl.
 rewrite IFTRUE_B, IFFALSE_B, IFFALSE_M.

reflexivity .

Qed.

Axiom andB_elm': forall (b1 b2: Bool) (x y : message), (if_then_else_M b1& b2 x y) #  (if_then_else_M b1 (if_then_else_M b2 x y ) y).
(**
Proof. intros.
pose proof (andB_elm 0 1 x y).
apply Forall_ELM_EVAL_M with (x:= b1) (n:=0) in H. simpl in H.
apply Forall_ELM_EVAL_M with (x:= b2) (n:=1) in H. simpl in H.
Check message_ind.
Scheme message_mut := Induction for message Sort Prop
with Bool_mut := Induction for Bool Sort Prop.
Check message_mut.

Check message_ind.
Check Bool_mut.
assert ([1 := b2](b1) ## b1).
(**apply (message_mut (fun m : Bool => forall b: Bool,
         (subbol_bol 1 m b) ## b)
    (fun m1 : Bool => forall b1 : Bool,
            (subbol_bol 1 m1 b1) ## b1)).
apply ( Bool_mut (fun m : message => forall b: Bool,
         (submsg_bol 1 m b) ## b)
    (fun m1 : Bool => forall b1 : Bool,
            (subbol_bol 1 m1 b1) ## b1)).
**)
Admitted.
**)

Theorem  breq_msgeq_andB : forall (n1 n2:nat) (m1 m2 m1' m2' :message), ( (n1 := TRue) (n2 := TRue) m1) #  ((n1 := TRue) (n2 := TRue) m1') ->  ( (n1 := TRue) (n2 := FAlse) m2) #
 ( (n1 := TRue) (n2 := FAlse) m2') -> ((n1 := FAlse) m2) #  ((n1 := FAlse) m2') -> (if_then_else_M (Bvar n1) (if_then_else_M (Bvar n2) m1 m2) m2) #  (if_then_else_M (Bvar n1) (if_then_else_M (Bvar n2) m1' m2') m2').
 Proof. intros.  rewrite IFEVAL_M with (t1:= m1) (t2:= m2). rewrite IFEVAL_M with (t2:= m2).
simpl. rewrite IFEVAL_M with (t1:= m1') (t2:= m2'). rewrite IFEVAL_M with (t2:= m2').
simpl. rewrite H; rewrite H0 ; rewrite H1. reflexivity. Qed.

(*******************************************************************)

Axiom sub_invar: forall (t:message)  (b:Bool), (subbol_msg' b b t) # t.
(**Proof.  apply (message_mut (fun t: message => forall b:Bool, (subbol_msg' b b t) # t) (fun B:Bool => forall M:message ,
(subbol_msg' B B M) # M)).
Check Bool_mut.
induction n.
intros. simpl. reflexivity.
intros.
simpl. reflexivity.
reflexivity. reflexivity.  intros. simpl . reflexivity.   intros.  simpl.  apply H1.
induction n. intros.
simpl.  reflexivity.
simpl.
apply nat_ind.
 apply (Bool_mut (fun M1: message => forall b:Bool, (subbol_msg' b b M1) # M1) (fun B:Bool => forall M:message ,
(subbol_msg' B B M) # M)).

intros.
simpl. reflexivity.
apply Bool_ind.

induction t.
induction b. repeat ( simpl;  reflexivity);simpl.
t *)
Axiom sub_in_sub: forall (b1 b2 b3 b4:Bool) (t:message), (**(occbol_in_msg b1 t = false) ->**) (subbol_msg' b1 b2 (subbol_msg' b3 b4 t)) # (subbol_msg' b3 (subbol_bol' b1 b2 b4) t).
(*Axiom sub_msg_sub: forall (n:nat) (b1 b2 : Bool) (x t:message), {{ n:= x}} (subbol_msg' b1 b2 t) # (subbol_msg' (submsg_bol n x b1) (submsg_bol n x b2) (submsg_msg n x t)). *)
Axiom dist_sesns_neq: forall (n1 n2:nat), (beq_nat n1 n2) =false  ->  (EQ_M (i n1) (i n2)) ##  FAlse.

Theorem dist_sesns_false: forall (n1 n2:nat),  (beq_nat n1 n2 = false) ->  (EQ_M (Mvar 1) (i n1)) & (EQ_M (Mvar 1) (i n2)) ## FAlse.
Proof.  intros.
unfold andB.
pose proof( EQ_BRmsg_msg''  (Mvar 1) (Mvar 1)  (i n1)    (EQ_M (Mvar 1) (i n2))  FAlse).
simpl in H0.
rewrite H0.
apply dist_sesns_neq in H.
rewrite H.
rewrite IFSAME_B.
 reflexivity.

Qed.

Theorem dist_sesns_false' : forall (n1 n2:nat) (x:message) , (beq_nat n1 n2 = false) ->  (EQ_M x (i n1)) & (EQ_M x (i n2)) ## FAlse .
Proof .
intros.
apply dist_sesns_false in H.
apply Forall_ELM_EVAL_B1 with (n:= 1) (b:= x) in H. simpl in H. assumption. Qed.

Theorem IFEVAL_M'': forall (n1 n2: nat) ( t1 t2:message), (beq_nat n1 n2 = false) -> (if_then_else_M  (EQ_M (Mvar 1) (i n1)) t1 t2) # (if_then_else_M  (EQ_M (Mvar 1) (i n1)) (subbol_msg' (EQ_M (Mvar 1) (i n2)) FAlse t1) t2).
Proof.
intros.

apply dist_sesns_false in H.
assert( (if_then_else_M (EQ_M (Mvar 1) (i n1)) t1 t2) #  (if_then_else_M (EQ_M (Mvar 1) (i n1)) (subbol_msg' (EQ_M (Mvar 1) (i n2)) (EQ_M (Mvar 1) (i n2)) t1) t2)).

rewrite sub_invar with(b:= (EQ_M (Mvar 1) (i n2))) (t:= t1). reflexivity.
assert( (EQ_M (Mvar 1) (i n2))  ##  (EQ_M (Mvar 1) (i n2)) & TRue).
simpl. unfold andB. rewrite IFTFb. reflexivity.
rewrite H1 in H0 at 2.
assert((if_then_else_M (EQ_M (Mvar 1) (i n1))
            (subbol_msg' (EQ_M (Mvar 1) (i n2))
               (EQ_M (Mvar 1) (i n2)) & (TRue) t1) t2) # (if_then_else_M (EQ_M (Mvar 1) (i n1))
            (subbol_msg' (EQ_M (Mvar 1) (i n2))
               (EQ_M (Mvar 1) (i n2)) & (EQ_M (Mvar 1) (i n1))  t1)  t2)).

 rewrite IFEVAL_M' with (t1:=  (subbol_msg' (EQ_M (Mvar 1) (i n2))
           (EQ_M (Mvar 1) (i n2)) & (EQ_M (Mvar 1) (i n1)) t1)).
rewrite IFEVAL_M'.
simpl.
assert( (subbol_msg' (EQ_M (Mvar 1) (i n1)) TRue
         (subbol_msg' (EQ_M (Mvar 1) (i n2)) (EQ_M (Mvar 1) (i n2)) & (TRue)
            t1)) # (subbol_msg' (EQ_M (Mvar 1) (i n1)) TRue
           (subbol_msg' (EQ_M (Mvar 1) (i n2))
              (EQ_M (Mvar 1) (i n2)) & (EQ_M (Mvar 1) (i n1)) t1))).
repeat rewrite sub_in_sub.

simpl.  rewrite <- beq_nat_refl.
SearchAbout beq_nat.
rewrite <- Nat.eqb_sym.
destruct beq_nat. reflexivity.  reflexivity.

rewrite H2. reflexivity.
rewrite H2 in H0.
rewrite andB_comm in H.
rewrite H in H0.
assumption.
Qed.
Axiom IFMORPH_M2':  forall  ( b b1 b2 : Bool) (y z : message),
      (if_then_else_M (if_then_else_B b b1 b2) y z)
      # (if_then_else_M b (if_then_else_M b1 y z)
           (if_then_else_M b2 y z)).
Axiom IFEVAL_M''': forall (n1 n2: nat) (x t1 t2:message), beq_nat n1 n2 = false -> (if_then_else_M  (EQ_M x (i n1)) t1 t2) # (if_then_else_M  (EQ_M x (i n1)) (subbol_msg' (EQ_M x (i n2)) FAlse t1) t2).
(*Axiom EQbrmsg_msg'' :forall  ( m m1 m2 m3 m4 :message) ,  (if_then_else_M  (EQ_M m1 m2 )  (submsg_msg' m m1 m3) m4) #  (if_then_else_M (EQ_M m1 m2)   (submsg_msg' m m2 m3) m4).
*)
Axiom andB_elm'':  forall (b1 b2 : Bool) (x y : message),
        (if_then_else_M (if_then_else_B b1 b2 FAlse) x y)
       # (if_then_else_M b1 (if_then_else_M b2 x y) y).


Require Import Coq.Lists.List.

Require Import Bedrock.PropX.

Set Implicit Arguments.

Notation "i @@ sp" := (ExX, Cptr i #0 /\ Al st, sp st ---> #0 st)%PropX
  (no associativity, at level 39) : PropX_scope.

Section machine.
  Variables pc state : Type.

  Inductive subs : list Type -> Type :=
  | SNil : subs nil
  | SCons : forall T Ts, (last (T :: Ts) -> PropX pc state) -> subs (eatLast (T :: Ts)) -> subs (T :: Ts).

  Fixpoint SPush G T (s : subs G) (f : T -> PropX pc state) : subs (T :: G) :=
    match s in subs G return subs (T :: G) with
      | SNil => SCons _ nil f SNil
      | SCons T' Ts f' s' => SCons T (T' :: Ts) f' (SPush s' f)
    end.

  Fixpoint SHead G (s : subs G) : hd (Empty_set : Type) G -> PropX pc state:=
    match s in subs G return hd (Empty_set : Type) G -> PropX pc state with
      | SNil => fun x => match x with end
      | SCons T G' f s' =>
        match G' return (last (T :: G') -> _) -> (hd (Empty_set : Type) (eatLast (T :: G')) -> PropX pc state) -> (T -> PropX pc state) with
          | nil => fun f _ => f
          | _ :: _ => fun _ SHead_s' => SHead_s'
        end f (SHead s')
    end.

  Fixpoint STail G (s : subs G) : subs (tl G) :=
    match s in subs G return subs (tl G) with
      | SNil => SNil
      | SCons T G' f s' =>
        match G' return (last (T :: G') -> _) -> subs (tl (eatLast (T :: G'))) -> subs G' with
          | nil => fun _ _ => SNil
          | T' :: G'' => fun f STail_s' => SCons T' G'' f STail_s'
        end f (STail s')
    end.

  Fixpoint Substs G (s : subs G) : propX pc state G -> PropX pc state :=
    match s in subs G return propX pc state G -> PropX pc state with
      | SNil => fun p => p
      | SCons _ _ f s' => fun p => Substs s' (subst p f)
    end.

  Section specs.
    Variable specs : codeSpec pc state.

    Section weaken.
      Hint Constructors valid.

      Hint Extern 1 (In _ _) => simpl; tauto.

      Hint Extern 3 (incl _ _) =>
        let x := fresh "x" in intro x;
          repeat match goal with
                   | [ H : incl _ _ |- _ ] => generalize (H x); clear H
                 end; simpl; intuition (subst; assumption).

      Theorem incl_cons : forall A x (G G' : list A),
        incl G G'
        -> incl (x :: G) (x :: G').
        auto.
      Qed.

      Hint Resolve incl_cons.

      Lemma valid_weaken : forall G Q, valid (state := state) specs G Q
        -> forall G', incl G G'
          -> valid specs G' Q.
      Proof.
        induction 1; intros.
        intuition.
        intuition.
        eapply Inj_E; [ eauto | auto ].
        intuition.
        eapply Cptr_E; [ eauto | auto ].
        intuition.
        eapply And_E1; [ eauto ].
        eapply And_E2; [ eauto ].
        eapply Or_I1; eapply IHvalid; eassumption.
        eapply Or_I2; eapply IHvalid; eassumption.
        eapply Or_E. eapply IHvalid1; eassumption. eapply IHvalid2. clear -H2. eauto.  eapply IHvalid3. clear -H2. eauto.
        intuition.
        eapply Imply_E; [ eauto | auto ].
        intuition.
        eapply Forall_E. eauto.
        eapply Exists_I; eauto.
        eapply Exists_E; eauto.
        intuition.
        eapply ExistsX_I; eauto.
      Qed.

      Theorem interp_weaken : forall Q, interp (state := state) specs Q
        -> forall G, valid specs G Q.
        intros; eapply valid_weaken; eauto.
      Qed.

      Theorem valid_weaken1 : forall G (P : PropX pc state), valid specs G P
        -> forall T, valid specs (T :: G) P.
        intros; eapply valid_weaken; eauto.
      Qed.
    End weaken.

    Fixpoint simplify G (p : propX pc state G) : subs G -> Prop :=
      match p with
        | Inj _ P => fun _ => P
        | Cptr _ f a => fun s => specs f = Some (fun x => Substs s (a x))
        | And _ p1 p2 => fun s => simplify p1 s /\ simplify p2 s
        | Or _ p1 p2 => fun s => simplify p1 s \/ simplify p2 s
        | Imply _ p1 p2 => fun s => interp specs (Substs s (Imply p1 p2))
        | Forall _ _ p1 => fun s => forall x, simplify (p1 x) s
        | Exists _ _ p1 => fun s => exists x, simplify (p1 x) s
        | Var0 _ _ v => fun s => interp specs (SHead s v)
        | Lift _ _ p1 => fun s => simplify p1 (STail s)
        | ForallX _ _ p1 => fun s => forall a, simplify p1 (SPush s a)
        | ExistsX _ _ p1 => fun s => exists a, simplify p1 (SPush s a)
      end.

    Lemma Substs_Inj : forall G (s : subs G) P,
      Substs s (Inj P)= Inj P.
      induction s; simpl; intuition.
    Qed.

    Lemma Substs_Cptr_fwd : forall G (s : subs G) f a,
      interp specs (Substs s (Cptr f a))
      -> interp specs (Cptr f (fun x => Substs s (a x))).
      induction s; simpl; intuition.
    Qed.

    Lemma Substs_Cptr_bwd : forall G (s : subs G) f a,
      interp specs (Cptr f (fun x => Substs s (a x)))
      -> interp specs (Substs s (Cptr f a)).
      induction s; simpl; intuition.
    Qed.

    Lemma Substs_And : forall G (s : subs G) p1 p2,
      Substs s (And p1 p2) = And (Substs s p1) (Substs s p2).
      induction s; simpl; intuition.
    Qed.

    Lemma Substs_Or : forall G (s : subs G) p1 p2,
      Substs s (Or p1 p2) = Or (Substs s p1) (Substs s p2).
      induction s; simpl; intuition.
    Qed.

    Lemma Substs_Imply : forall G (s : subs G) p1 p2,
      Substs s (Imply p1 p2) = Imply (Substs s p1) (Substs s p2).
      induction s; simpl; intuition.
    Qed.

    Lemma Substs_Forall_fwd : forall G (s : subs G) A (p1 : A -> _),
      interp specs (Substs s (Forall p1))
      -> interp specs (Forall (fun x => Substs s (p1 x))).
      induction s; simpl; intuition.
    Qed.

    Lemma Substs_Forall_bwd : forall G (s : subs G) A (p1 : A -> _),
      interp specs (Forall (fun x => Substs s (p1 x)))
      -> interp specs (Substs s (Forall p1)).
      induction s; simpl; intuition.
    Qed.

    Lemma Substs_Exists_fwd : forall G (s : subs G) A (p1 : A -> _),
      interp specs (Substs s (Exists p1))
      -> interp specs (Exists (fun x => Substs s (p1 x))).
      induction s; simpl; intuition.
    Qed.

    Lemma Substs_Exists_bwd : forall G (s : subs G) A (p1 : A -> _),
      interp specs (Exists (fun x => Substs s (p1 x)))
      -> interp specs (Substs s (Exists p1)).
      induction s; simpl; intuition.
    Qed.

    Lemma subs_nil' : forall G (s : subs G) p,
      match G return subs G -> Prop with
        | nil => fun s => Substs s p = p
        | _ :: _ => fun _ => True
      end s.
      destruct s; simpl; intuition.
    Qed.

    Theorem subs_nil : forall (s : subs nil) p, Substs s p = p.
      intros; apply (subs_nil' s).
    Qed.

    Hint Immediate subs_nil.

    Lemma Substs_Var0' : forall G (s : subs G),
      match G return subs G -> Prop with
        | nil => fun _ => True
        | T :: G' => fun s => forall v, Substs s (Var0 v) = SHead s v
      end s.
      induction s; simpl; intuition.
      destruct Ts; simpl in *; intuition.
    Qed.

    Lemma Substs_Var0 : forall T G (s : subs (T :: G)) v,
      Substs s (Var0 v) = SHead s v.
      intros; apply (Substs_Var0' s); assumption.
    Qed.

    Lemma Substs_Lift' : forall G (s : subs G),
      match G return subs G -> Prop with
        | nil => fun _ => True
        | T :: G' => fun s => forall p1, Substs s (Lift p1) = Substs (STail s) p1
      end s.
      induction s; simpl; intuition.
      destruct Ts; simpl in *; intuition.
    Qed.

    Lemma Substs_Lift : forall T G (s : subs (T :: G)) p1,
      Substs s (Lift p1) = Substs (STail s) p1.
      intros; apply (Substs_Lift' s); assumption.
    Qed.

    Theorem Imply_easyL'' : forall G (p1 p2 p : PropX pc state),
      valid specs G (Imply p1 (Imply p2 p))
      -> valid specs G (Imply (And p1 p2) p).
      intros.
      apply Imply_I.
      eapply Imply_E.
      eapply Imply_E.
      apply valid_weaken1; eauto.
      eapply And_E1; apply Env; simpl; tauto.
      eapply And_E2; apply Env; simpl; tauto.
    Qed.

    Hint Rewrite Substs_Inj Substs_And Substs_Or Substs_Imply Substs_Var0 Substs_Lift : Substs.

    Hint Resolve interp_weaken valid_weaken1.

    Lemma simplify_bwd_ForallX : forall G A s (p : propX pc state (A :: G)),
      (forall a, interp specs (Substs (SPush s a) p))
      -> interp specs (Substs s (AlX : A, p)).
      induction s; simpl; intuition.
      apply ForallX_I; auto.
    Qed.

    Lemma simplify_bwd_ExistsX : forall G A a s (p : propX pc state (A :: G)),
      interp specs (Substs (SPush s a) p)
      -> interp specs (Substs s (ExX : A, p)).
      induction s; simpl; intuition.
      apply ExistsX_I with a; auto.
    Qed.

    Lemma simplify_bwd' : forall G (p : propX pc state G) s,
      simplify p s
      -> interp specs (Substs s p).
      induction p; simpl; intuition; autorewrite with Substs in *.

      apply Inj_I; auto.
      apply Substs_Cptr_bwd; apply Cptr_I; auto.
      apply And_I; auto.
      apply Or_I1; auto.
      apply Or_I2; auto.
      apply Substs_Forall_bwd; apply Forall_I; auto.
      apply Substs_Exists_bwd; destruct H0 as [x]; apply Exists_I with x; auto.
      assumption.
      auto.
      apply simplify_bwd_ForallX; firstorder.
      destruct H as [x]; apply simplify_bwd_ExistsX with x; firstorder.
    Qed.

    Lemma simplify_bwd : forall p,
      simplify p SNil
      -> interp specs p.
      intros; change (interp specs (Substs SNil p)); apply simplify_bwd'; auto.
    Qed.

    Lemma simplify_fwd_ForallX : forall G A a s (p : propX pc state (A :: G)),
      interp specs (Substs s (AlX  : A, p))
      -> interp specs (Substs (SPush s a) p).
      induction s; simpl; intuition.
      apply ForallX_sound; auto.
    Qed.

    Lemma simplify_fwd_ExistsX : forall G A s (p : propX pc state (A :: G)),
      interp specs (Substs s (ExX  : A, p))
      -> exists a, interp specs (Substs (SPush s a) p).
      induction s; simpl; intuition.
      apply ExistsX_sound; auto.
    Qed.

    Lemma simplify_fwd' : forall G (p : propX pc state G) s,
      interp specs (Substs s p)
      -> simplify p s.
      induction p; simpl; intuition; autorewrite with Substs in *.

      apply (Inj_sound H).
      apply Substs_Cptr_fwd in H0; apply (Cptr_sound H0).
      apply And_sound in H; intuition.
      apply And_sound in H; intuition.
      apply Or_sound in H; intuition.
      apply Substs_Forall_fwd in H0; specialize (Forall_sound H0); intuition.
      apply Substs_Exists_fwd in H0; specialize (Exists_sound H0); firstorder.
      assumption.
      auto.
      apply IHp; apply simplify_fwd_ForallX; auto.
      apply simplify_fwd_ExistsX in H; firstorder.
    Qed.

    Lemma simplify_fwd : forall p,
      interp specs p
      -> simplify p SNil.
      intros; apply simplify_fwd'; auto.
    Qed.

    Fixpoint simplifyH G (p : propX pc state G) : subs G -> Prop :=
      match p with
        | Inj _ P => fun _ => P
        | Cptr _ f a => fun s => exists a', specs f = Some a' /\ forall x, a' x = Substs s (a x)
        | And _ p1 p2 => fun s => simplifyH p1 s /\ simplifyH p2 s
        | Or _ p1 p2 => fun s => simplifyH p1 s \/ simplifyH p2 s
        | _ => fun _ => True
      end.

    Lemma Substs_Cptr : forall G (s : subs G) f a,
      exists a', Substs s (Cptr f a) = Cptr f a'
        /\ forall x, a' x = Substs s (a x).
      induction s; simpl; intuition eauto.
    Qed.

    Lemma simplifyH_ok : forall G (p : propX pc state G) s PG p',
      In (Substs s p) PG
      -> (simplifyH p s -> valid specs PG (Substs s p'))
      -> valid specs PG (Substs s p').
      induction p; simpl; intuition; autorewrite with Substs in *.

      eapply Inj_E; [ constructor; eauto | auto ].

      destruct (Substs_Cptr s p p0) as [? [ Heq ] ]; rewrite Heq in *.
      eapply Cptr_E; [ constructor; eauto | eauto ].

      assert (valid specs PG (Substs s p1 ---> Substs s p2 ---> Substs s p')%PropX).
      repeat apply Imply_I.
      apply IHp1.
      simpl; tauto.
      intro.
      apply IHp2.
      simpl; tauto.
      eauto.
      eapply Imply_E.
      eapply Imply_E.
      eassumption.
      eapply And_E1; econstructor; eauto.
      eapply And_E2; econstructor; eauto.

      eapply Or_E.
      constructor; eauto.
      intuition.
      intuition.
    Qed.

    Theorem simplify_Imply : forall p1 p2,
      (simplifyH p1 SNil -> simplify p2 SNil)
      -> interp specs (Imply p1 p2).
      intros.
      change (interp specs (Imply (Substs SNil p1) (Substs SNil p2))).
      apply Imply_I.
      eapply simplifyH_ok.
      simpl; tauto.
      intros.
      apply valid_weaken1.
      apply simplify_bwd.
      auto.
    Qed.

    Theorem Imply_easyL' : forall G (p1 p2 p : PropX pc state),
      (simplifyH p1 SNil -> valid specs G (Imply p2 p))
      -> valid specs G (Imply (And p1 p2) p).
      intros; apply Imply_easyL''.
      apply Imply_I.
      change (p2 ---> p)%PropX with (Substs SNil (p2 ---> p)%PropX).
      eapply simplifyH_ok.
      simpl; tauto.
      intro.
      simpl.
      apply valid_weaken1; auto.
    Qed.

    Theorem Imply_easyL : forall (p1 p2 p : PropX pc state),
      (simplifyH p1 SNil -> interp specs (Imply p2 p))
      -> interp specs (Imply (And p1 p2) p).
      intros; apply Imply_easyL'; auto.
    Qed.

    Theorem Imply_trans' : forall G (p1 p2 p3 : PropX pc state),
      valid specs G (Imply p1 p2)
      -> valid specs G (Imply p2 p3)
      -> valid specs G (Imply p1 p3).
      intros; apply Imply_I.
      eapply Imply_E.
      apply valid_weaken1; eassumption.
      eapply Imply_E.
      apply valid_weaken1; eassumption.
      apply Env; simpl; tauto.
    Qed.

    Theorem Imply_trans : forall p1 p2 p3 : PropX pc state,
      interp specs (Imply p1 p2)
      -> interp specs (Imply p2 p3)
      -> interp specs (Imply p1 p3).
      unfold interp; intros; eapply Imply_trans'; eauto.
    Qed.

    Theorem Imply_easyEx' : forall G T (p1 : T -> _) (p : PropX pc state),
      (forall x, valid specs G (Imply (p1 x) p))
      -> valid specs G (Imply (Exists p1) p).
      intros; apply Imply_I.
      eapply Exists_E.
      apply Env; simpl; tauto.
      intros.
      eapply Imply_E.
      eapply valid_weaken.
      apply H.
      red; intuition.
      apply Env; simpl; tauto.
    Qed.

    Theorem Imply_easyEx : forall T (p1 : T -> _) (p : PropX pc state),
      (forall x, interp specs (Imply (p1 x) p))
      -> interp specs (Imply (Exists p1) p).
      unfold interp; intros; apply Imply_easyEx'; auto.
    Qed.

    Theorem Env1 : forall (G : list (PropX pc state)) P, valid specs (P :: G) P.
      intros; apply Env; simpl; tauto.
    Qed.
  End specs.
End machine.

Ltac propx :=
  repeat match goal with
           | [ H : interp _ _ |- _ ] => apply simplify_fwd in H; progress simpl in H
         end;
  try (apply simplify_bwd; simpl(*;
    repeat (apply simplify_Imply; simpl; intro)*)).

Ltac propxFo' := intuition auto.

Ltac doImply H := eapply Imply_E; [ apply H | apply simplify_bwd; simpl; propxFo' ].

Ltac propxFo := propxFo'; repeat progress (propx; propxFo');
  repeat match goal with
           | [ H : True |- _ ] => clear H
           | [ |- simplify _ _ _ ] => apply simplify_fwd'; simpl; auto
           | [ H : simplify _ _ _ |- _ ] => apply simplify_bwd' in H; simpl in H
           | [ H : ex _ |- _ ] => destruct H; propxFo'
         end.

Hint Resolve interp_weaken Env1.

Ltac ensureNoUnifs E :=
  first [ has_evar E; fail 1 | idtac ].

Ltac ensureNotUnif E :=
  first [ ensureNoUnifs E
        | match E with
            | ?f _ => ensureNotUnif f
            | ?f _ _ => ensureNotUnif f
            | ?f _ _ _ => ensureNotUnif f
            | ?f _ _ _ _ => ensureNotUnif f
          end ].


Require Import Zee.lattice Zee.lang Zee.dec Zee.vals Zee.frame Zee.maplike Zee.sem.
Require Import Arith List Coq.Program.Basics Coq.Lists.ListSet Lia Coq.ZArith.BinInt.
Require Import Coq.Classes.RelationClasses.

Section TypeSystem.
  Context {A : Set} {BinOpS : Set} `{lattice A}.
  Definition Lab := @Lab A.
  Definition Ty := @Ty A.
  Definition LabVar := @LabVar A.
  Definition SecTy := @SecTy A.
  Definition SecTyV := @SecTyV A.
  Definition AtomSecTy := @AtomSecTy A.
  Definition Cmd := @Cmd A BinOpS.
  Definition Expr := @Expr A BinOpS.
  Definition V := @V A.

  Context {δ : string -> option Z}.
  Context {F: string -> option (list (string * Lab) *
                               list (string * Lab) *
                               list (string * SecTy) * Lab * Lab * Cmd) }.
  Context {eval_binop: BinOpS -> V -> V -> V}.
  Context {type_binop: BinOpS -> SecTy -> SecTy -> SecTy -> Prop}.
  Notation "o ':' s1 ',' s2 '⤇' s" := (type_binop o s1 s2 s) (at level 70, s at next level).

  Context {VarT ArgT LocT MemT : Type}
          {H_var_finmaplike: FinMapLike VarT string (A + SecTyV)}
          {H_arg_finmaplike: FinMapLike ArgT string SecTyV}
          {H_loc_finmaplike: FinMapLike LocT string SecTyV}
          {H_mem_maplike: MapLike MemT nat V}.
  Definition Frame := @Frame A VarT ArgT LocT MemT _ _ _ _.
  Definition PFrame := @PFrame A VarT ArgT LocT _ _ _.
  Definition EFrame := @EFrame A MemT _.

  Definition Formula := list (Lab * Lab).

  Global Instance Raiseable_AtomSecTy : Raiseable AtomSecTy (@Word A string) := {}.
  intros t k.
  destruct t.
  - exact (STy t (l ⊔ k)).
  - exact (VarTy s (l ⊔ k)).
  Defined.

  Global Instance Raiseable_SecTy : Raiseable SecTy (@Word A string) := {}.
  exact (fun s k => let fix visit s :=
                     match s with
                       ASecTy a => ASecTy (a ^^ k)
                     | ProdTy a s => ProdTy (a ^^ k) (visit s)
                     | NilTy => NilTy
                     end
                 in visit s).
  Defined.

  Definition TEnv := string -> option SecTy.

  Inductive Kind := KLabel | KType.
  Hint Constructors Kind.
  Definition KEnv := string -> option (Kind * Lab).

  Notation "'〚' x '〛' f" := (eval f x) (at level 30, f at next level).

  Reserved Notation "'⊨' ϕ" (at level 70, ϕ at next level).
  Inductive holds: Formula -> Prop :=
    holds_nil: holds nil
  | holds_cons ϕ k1 k2:
      k1 ⊑ k2 ->
      ⊨ ϕ ->
      ⊨ ((k1, k2) :: ϕ)
  where "'⊨' ϕ" := (holds ϕ).
  Hint Constructors holds.

  Definition flowsto_with (ϕ: Formula) (k1 k2 : Lab): Prop :=
    ⊨ ϕ -> k1 ⊑ k2.
  Notation "ϕ '⊢' k1 '⊑' k2" := (flowsto_with ϕ k1 k2) (at level 70, k1, k2 at next level).
  Notation "ϕ '⊢' k1 '===' k2" := (flowsto_with ϕ k1 k2 /\ flowsto_with ϕ k2 k1) (at level 70, k1, k2 at next level).

  Reserved Notation "ϕ '⊢' s1 '<:' s2 " (at level 70, s1, s2 at next level).
  Reserved Notation "ϕ '⊢ₐ' s1 '<:' s2 " (at level 70, s1, s2 at next level).

  Inductive subtype: Formula -> SecTy -> SecTy -> Prop :=
    sub_atom a1 a2 ϕ:
      ϕ ⊢ₐ a1 <: a2 ->
      ϕ ⊢ ASecTy a1 <: ASecTy a2
  | sub_prod ϕ (a1 a2 : AtomSecTy) s1 s2:
      ϕ ⊢ₐ a1 <: a2 ->
      ϕ ⊢ s1 <: s2 ->
      ϕ ⊢ a1 · s1 <: a2 · s2
   | sub_forget ϕ (a : AtomSecTy) s:
       ϕ ⊢ a · s <: a
   | sub_nil s ϕ: ϕ ⊢ s <: ε
   | sub_trans s2 ϕ s1 s3:
       ϕ ⊢ s1 <: s2 ->
       ϕ ⊢ s2 <: s3 ->
       ϕ ⊢ s1 <: s3
  where "ϕ '⊢' s1 '<:' s2 " := (subtype ϕ s1 s2) with
  subtype_atom: Formula -> AtomSecTy -> AtomSecTy -> Prop :=
    sub_atom_sty ϕ t k1 k2: ϕ ⊢ k1 ⊑ k2 -> ϕ ⊢ₐ STy t k1 <: STy t k2
  | sub_atom_var ϕ k1 k2 x: ϕ ⊢ k1 ⊑ k2 -> ϕ ⊢ₐ VarTy x k1 <: VarTy x k2
  where "ϕ '⊢ₐ' s1 '<:' s2 " := (subtype_atom ϕ s1 s2).

  Reserved Notation "'[' Π ',' ϕ ']' '⊢ₖ' k1 ':' k2" (at level 70, k1, k2 at next level).
  Inductive wt_lab: KEnv -> Formula -> Lab -> Lab -> Prop :=
    wt_labvar κ Π ϕ k: Π κ = Some (KLabel, k) ->
                       [Π, ϕ] ⊢ₖ WordVar κ : k
  | wt_lit Π ϕ (ℓ : A): [Π, ϕ] ⊢ₖ Lit ℓ : ⊥
  | wt_join Π ϕ k1 k2 k1' k2':
      [Π, ϕ] ⊢ₖ k1 : k1' ->
      [Π, ϕ] ⊢ₖ k2 : k2' ->
      [Π, ϕ] ⊢ₖ Join k1 k2 : k1' ⊔ k2'
  | wt_meet Π ϕ k1 k2 k1' k2':
      [Π, ϕ] ⊢ₖ k1 : k1' ->
      [Π, ϕ] ⊢ₖ k2 : k2' ->
      [Π, ϕ] ⊢ₖ Meet k1 k2 : k1' ⊔ k2'
  | wt_lab_sub ϕ Π k k1 k2:
      [Π, ϕ] ⊢ₖ k : k1 ->
      ϕ ⊢ k1 ⊑ k2 ->
      [Π, ϕ] ⊢ₖ k : k2
  where "'[' Π ',' ϕ ']' '⊢ₖ' k1 ':' k2" := (wt_lab Π ϕ k1 k2).

  Global Instance is_dec_eq_string : is_dec_eq string := {}.
  exact string_dec.
  Defined.

  Reserved Notation "'[' Π ',' ϕ ']' '⊢ₛ' s ':' k" (at level 70, s, k at next level).
  Reserved Notation "'[' Π ',' ϕ ']' '⊢ₐ' a ':' k" (at level 70, a, k at next level).
  Reserved Notation "'[' Π ',' ϕ ']' '⊢ₜ' t ':' k" (at level 70, t, k at next level).

  Inductive wt_sectype: KEnv -> Formula -> SecTy -> Lab -> Prop :=
    wt_secty_atom a Π ϕ k: [Π, ϕ] ⊢ₐ a : k -> [Π, ϕ] ⊢ₛ ASecTy a : k
  | wt_secty_prod a s Π ϕ k1 k2:
      [Π, ϕ] ⊢ₐ a : k1 ->
      [Π, ϕ] ⊢ₛ s : k2 ->
      [Π, ϕ] ⊢ₛ a · s : k1 ⊔ k2
  | wt_secty_nil Π ϕ: [Π, ϕ] ⊢ₛ ε : ⊥
  | wt_secty_sub Π ϕ s k1 k2:
      [Π, ϕ] ⊢ₛ s : k1 ->
      ϕ ⊢ k1 ⊑ k2 ->
      [Π, ϕ] ⊢ₛ s : k2
  where "'[' Π ',' ϕ ']' '⊢ₛ' s ':' k" := (wt_sectype Π ϕ s k) with
  wt_atom_sectype: KEnv -> Formula -> AtomSecTy -> Lab -> Prop :=
    wt_atom_ty t k Π ϕ k1 k2:
      [Π, ϕ] ⊢ₜ t : k1 ->
      [Π, ϕ] ⊢ₖ k : k2 ->
      [Π, ϕ] ⊢ₐ STy t k : k1 ⊔ k2
  | wt_atom_var α k1 k2 k Π ϕ:
      Π α = Some (KType, k1) ->
      [Π, ϕ] ⊢ₖ k : k2 ->
      [Π, ϕ] ⊢ₐ VarTy α k : k1 ⊔ k2
  | wt_atom_sub Π ϕ a k1 k2:
      [Π, ϕ] ⊢ₐ a : k1 ->
      ϕ ⊢ k1 ⊑ k2 ->
      [Π, ϕ] ⊢ₐ a : k2
  where "'[' Π ',' ϕ ']' '⊢ₐ' a ':' k" := (wt_atom_sectype Π ϕ a k) with
  wt_ty: KEnv -> Formula -> Ty -> Lab -> Prop :=
    wt_int Π ϕ: [Π, ϕ] ⊢ₜ IntTy : ⊥
  | wt_ptr Π ϕ s k k1 k2:
      [Π, ϕ] ⊢ₛ s : k1 ->
      [Π, ϕ] ⊢ₖ k : k2 ->
      [Π, ϕ] ⊢ₜ k # s : k1 ⊔ k2
  | wt_sptr Π ϕ s1 s2 k1 k2:
      [Π, ϕ] ⊢ₛ s1 : k1 ->
      [Π, ϕ] ⊢ₛ s2 : k2 ->
      [Π, ϕ] ⊢ₜ s1 @ s2 : k1 ⊔ k2
  | wt_exty Π ϕ k k' α s k'':
      [Π, ϕ] ⊢ₖ k : k' ->
      [Π[α ↦ (KType, k)], ϕ] ⊢ₛ s : k'' ->
      [Π, ϕ] ⊢ₜ (∃ₛ (α ::: k) s) : k' (* I hope we don't need to join with k'' *)
  | wt_exlab Π ϕ k k' κ s k'':
      [Π, ϕ] ⊢ₖ k : k' ->
      [Π[κ ↦ (KLabel, k)], ϕ] ⊢ₛ s : k'' ->
      [Π, ϕ] ⊢ₜ (∃ₖ (κ ::: k) s) : k' (* I hope we don't need to join with k'' *)
  | wt_rec Π ϕ α k k' s:
      [Π, ϕ] ⊢ₖ k : k' ->
      [Π[α ↦ (KType, k')], ϕ] ⊢ₛ s : k' ->
      [Π, ϕ] ⊢ₜ (μ (α ::: k) s) : k'
  | wt_size Π ϕ s k:
      [Π, ϕ] ⊢ₛ s : k ->
      [Π, ϕ] ⊢ₜ |s| : k
  | wt_ty_sub Π ϕ s k1 k2:
      [Π, ϕ] ⊢ₜ s : k1 ->
      ϕ ⊢ k1 ⊑ k2 ->
      [Π, ϕ] ⊢ₜ s : k2
  where "'[' Π ',' ϕ ']' '⊢ₜ' t ':' k" := (wt_ty Π ϕ t k).

  Definition T_st (pc fr k : Lab) : SecTy :=
    STy (μ ("α" ::: k)
           (STy (∃ₛ ("β" ::: fr)
                  (STy (∃ₛ ("γ" ::: fr)
                         (STy (VarTy "β" ⊥ · ASecTy (VarTy "α" ⊥) @ VarTy "γ" ⊥) pc)) ⊥)) ⊥)) ⊥.
  Notation "'Tₛₜ' '(' pc ',' fr ',' k ')'" := (T_st pc fr k).
  Hint Unfold T_st.

  Class Substeable (A S B : Type) :=
    {
      subst : A -> S -> B -> B
    }.
  Notation "b '[[' a './' x ']]'" := (subst a x b) (at level 8, left associativity).

  Fixpoint subst_upto {A S B : Type} `{Substeable A S B} (i : nat) (as' : list A) (xs : list S) (b : B): B :=
    match i with
      0 => b
    | S i =>
      match as', xs with
        nil, _ => b
      | _, nil => b
      | a :: as', x :: xs => (subst_upto i as' xs b) [[ a ./ x ]]
      end
    end.
  Notation "b '[[' a './' x ']' i ']'" := (subst_upto i a x b) (at level 8, left associativity).

  Instance Substeable_many (A S B : Type) `{Substeable A S B}: Substeable (list A) (list S) B := {}.
  intros as' xs b.
  exact (b [[ as' ./ xs ] (length xs)]).
  Defined.

  Reserved Notation "Π1 '⊢ₚ' p '⇝' '[' k ']' Π2 ':' s" (at level 70, Π2, s at next level).
  Reserved Notation "Π1 '⊢ₐ' p '⇝' '[' k ']' Π2 ':' s" (at level 70, Π2, s at next level).
  Inductive make_kenv: KEnv -> SecPat -> Lab -> KEnv -> SecTy -> Prop :=
  | make_kenv_prod p1 p2 s1 s2 Π Π' Π'' k:
      Π ⊢ₐ p1 ⇝ [k] Π' : s1 ->
      Π' ⊢ₚ p2 ⇝ [k] Π'' : s2 ->
      Π ⊢ₚ p1 · p2 ⇝ [k] Π'' : s1 · s2
  | make_kenv_nil k Π:
      Π ⊢ₚ ε ⇝ [k] Π : ε
  | make_kenv_atom Π p k Π' s:
      Π ⊢ₐ p ⇝ [k] Π' : s ->
      Π ⊢ₚ p ⇝ [k] Π' : s
  where "Π₁ '⊢ₚ' p '⇝' '[' k ']' Π₂ ':' s" := (make_kenv Π₁ p k Π₂ s) with
  atom_make_kenv: KEnv -> AtomPat -> Lab -> KEnv -> AtomSecTy -> Prop :=
    atom_make_kenv_var α k Π:
      Π ⊢ₐ PVar α ⇝ [k] Π[α ↦ (KType, k)] : VarTy α ⊥
  | atom_make_kenv_int Π k κ:
      Π ⊢ₐ SPat PInt κ ⇝ [k] Π[κ ↦ (KLabel, k)] : STy IntTy (LabVar κ)
  | atom_make_kenv_sptr Π Π' Π'' k κ p1 p2 s1 s2:
      Π ⊢ₚ p1 ⇝ [k] Π' : s1 ->
      Π' ⊢ₚ p2 ⇝ [k] Π'' : s2 ->
      Π'' ⊢ₐ SPat (p1 @ p2) κ ⇝ [k] Π''[κ ↦ (KLabel, k)] : STy (s1 @ s2) (LabVar κ)
  | atom_make_kenv_ptr Π Π' k κ1 κ2 p s:
      Π ⊢ₚ p ⇝ [k] Π' : s ->
      Π ⊢ₐ SPat (κ1 # p) κ2 ⇝ [k]
        Π'[κ1 ↦ (KLabel, k)][κ2 ↦ (KLabel, k)] : STy (LabVar κ1 # s) (LabVar κ2)
  where "Π₁ '⊢ₐ' p '⇝' '[' k ']' Π₂ ':' s" := (atom_make_kenv Π₁ p k Π₂ s).

  Fixpoint prodSecTy (τ1 : SecTy) (τ2 : SecTy) : SecTy :=
    match τ1 with
      ASecTy a => ProdTy a τ2
    | ProdTy a τ => ProdTy a (prodSecTy τ τ2)
    | NilTy => τ2
    end.

  Fixpoint subst_secty_secty (s1 : SecTy) (x : string) (s2 : SecTy) :=
    let fix subst s : SecTy :=
        match s with
          ASecTy a =>
          match subst_secty_atom s1 x a with
            inl a => a
          | inr s => s
          end
        | ProdTy a s =>
          match subst_secty_atom s1 x a with
            inl a => ProdTy a (subst s)
          | inr s' => prodSecTy s' (subst s)
          end
        | NilTy => NilTy
        end
    in subst s2 with
  subst_secty_atom (s1 : SecTy) (x : string) (a : AtomSecTy) : AtomSecTy + SecTy :=
    let fix subst a : AtomSecTy + SecTy :=
        match a with
          STy t k => inl (STy (subst_secty_ty s1 x t) k)
        | VarTy y k =>
          match (string_dec x y) with
            left _ => inr s1
          | right _ => inl (VarTy y k)
          end
        end
    in subst a with
  subst_secty_ty (s : SecTy) (x : string) (t : Ty) : Ty :=
    let fix subst t : Ty :=
        match t with
        | IntTy => IntTy
        | PtrTy k s' => PtrTy k (subst_secty_secty s x s')
        | SPtrTy s1 s2 => SPtrTy (subst_secty_secty s x s1) (subst_secty_secty s x s2)
        | ExTyTy α k s' =>
          ExTyTy α k
                 (match string_dec x α with
                    left _ => s'
                  | right _ => subst_secty_secty s x s'
                  end)
        | ExLabTy κ k s' =>
          ExLabTy κ k
                  (match string_dec x κ with
                     left _ => s'
                   | right _ => subst_secty_secty s x s'
                   end)
        | RecTy k y s' => RecTy k y
          (match string_dec x y with
             left _ => s'
           | right _ => subst_secty_secty s x s'
           end)
        | SizeTy s' => SizeTy (subst_secty_secty s x s')
        end
    in subst t.

  Instance Substeable_SecTy_SecTy : Substeable SecTy string SecTy := {}.
  exact subst_secty_secty.
  Defined.

  Instance Substeable_SecTy_Ty : Substeable SecTy string Ty := {}.
  exact subst_secty_ty.
  Defined.

  Instance Substeable_SecTy_Expr : Substeable SecTy string Expr := {}.
  exact (fun s x e =>
           let fix subst e :=
               match e with
               | Var x => Var x
               | Num n => Num n
               | BinOp o e1 e2 => BinOp o (subst e1) (subst e2)
               | Unroll e => Unroll (subst e)
               | Roll e => Roll (subst e)
               | PackTy s1 e k α s2 =>
                 PackTy s1[[s ./ x]] (subst e) k α
                        (match string_dec x α with
                           left _ => s2
                         | right _ => s2[[s ./ x]]
                         end)
               | PackLab k1 e k2 κ s' =>
                 PackLab k1 (subst e) k2 κ
                        (match string_dec x κ with
                           left _ => s'
                         | right _ => s'[[s ./ x]]
                         end)
               | SizeOf s' => SizeOf s'[[s ./ x]]
               | AddrOf x => AddrOf x
               end
           in subst e).
  Defined.

  Instance Substeable_list (A S B : Type) `{Substeable A S B} : Substeable A S (list B) := {}.
  exact (fun a x bs =>
           let fix subst bs :=
               match bs with
                 nil => nil
               | b :: bs' => b [[ a ./ x ]] :: subst bs'
               end
           in subst bs).
  Defined.

  Class Binds (A : Type) := binds : string -> A -> bool.

  Fixpoint binds_pat (x : string) (p : SecPat) : bool :=
    match p with
      PProd a p => binds_atompat x a || binds_pat x p
    | PNil => false
    | PAtom a => binds_atompat x a
    end
  with binds_atompat (x : string) (a : AtomPat) : bool :=
         match a with
           SPat p κ => eqb x κ || binds_pat' x p
         | PVar α => eqb x α
         end
  with binds_pat' (x : string) (p : Pat) : bool :=
         match p with
           PInt => false
         | PSPtr p1 p2 => binds_pat x p1 || binds_pat x p2
         | PPtr κ p => eqb x κ || binds_pat x p
         end.

  Instance Binds_SecPat : Binds SecPat := {}.
  eapply binds_pat.
  Defined.

  Instance Binds_AtomPat : Binds AtomPat := {}.
  eapply binds_atompat.
  Defined.

  Instance Binds_Pat : Binds Pat := {}.
  eapply binds_pat'.
  Defined.

  Fixpoint subst_secty_cmd (s : SecTy) (x : string) (c : Cmd) : Cmd :=
    let fix subst c :=
        match c with
        | CSkip => CSkip
        | CLet y s' e c =>
          CLet y s'[[ s ./ x  ]] e[[ s ./ x ]]
               match string_dec x y with
                 left _ => c
               | right _ => subst c
               end
        | CIf e c1 c2 => CIf e[[ s ./ x ]] (subst c1) (subst c2)
        | CWhile e c => CWhile e[[ s ./ x ]] (subst c)
        | CSeq c1 c2 => CSeq (subst c1) (subst c2)
        | CWrite e1 e2 => CWrite e1[[s ./ x]] e2[[s ./ x]]
        | CRead y e => CRead y e[[s ./ x]]
        | CAt k e c => CAt k e[[s ./ x]] (subst c)
        | CLabIf k1 k2 c1 c2 => CLabIf k1 k2 (subst c1) (subst c2)
        | CMatch α ps =>
          CMatch α (map (fun pc : (SecPat * Cmd) => let (p, c) := pc in
                                if binds x p then (p, c)
                                else (p, subst c)) ps)
        | CFP y => CFP y
        | CCall f ks ss es =>
          CCall f ks
                (map (subst_secty_secty s x) ss)
                (map (fun e => e [[ s ./ x ]]) es)
        | CUnpTy α k y s' e c =>
          CUnpTy α k y
                 (match string_dec x α with
                    left _ => s'
                  | right _ => s'[[ s ./ x ]]
                  end) e[[ s ./ x ]]
                 (match string_dec x α, string_dec x y with
                    right _, right _ => subst c
                  | _, _ => c
                  end)
        | CUnpLab κ k y s' e c =>
          CUnpLab κ k y
                  (match string_dec x κ with
                     left _ => s'
                   | right _ => s'[[ s ./ x ]]
                   end) e[[ s ./ x ]]
                  (match string_dec x κ, string_dec x y with
                     right _, right _ => subst c
                   | _, _ => c
                   end)
        | CDelay n => CDelay n
        | CUnsc y => CUnsc y
        | CEpi => CEpi
        | CStop => CStop
        end
    in subst c.

  Instance Substeable_SecTy_Cmd : Substeable SecTy string Cmd := {}.
  exact subst_secty_cmd.
  Defined.

  Instance Substeable_env {A S B : Type} `{Substeable A S B}: Substeable A S (S -> option B) := {}.
  intros a x f y.
  destruct (f y).
  - exact (Some (b [[a ./ x]])).
  - exact None.
  Defined.

  Instance Substeable_pair1 {A S B C : Type} `{Substeable A S B}: Substeable A S (B * C) | 10 := {}.
  intros a x [b c].
  exact (b [[a ./ x]], c).
  Defined.

  Instance Substeable_pair2 {A S B C : Type} `{Substeable A S C}: Substeable A S (B * C) | 10 := {}.
  intros a x [b c].
  exact (b, c [[a ./ x]]).
  Defined.

  Instance Substeable_pair {A S B C : Type} `{Substeable A S B} `{Substeable A S C}: Substeable A S (B * C) | 0 := {}.
  intros a x [b c].
  exact (b [[a ./ x]], c [[a ./ x]]).
  Defined.

  Instance Substeable_Lab_Lab : Substeable Lab string Lab := {}.
  exact (fun k1 x k2 =>
             let fix subst (k : Lab) : Lab :=
                 match k with
                   WordVar y =>
                   match string_dec x y with
                     left _ => k1
                   | right _ => WordVar y
                   end
                 | Lit a => Lit a
                 | Join w1 w2 => Join (subst w1) (subst w2)
                 | Meet w1 w2 => Meet (subst w1) (subst w2)
                 end
             in subst k2).
  Defined.

  Fixpoint subst_lab_secty (k : Lab) (x : string) (s2 : SecTy) :=
    let fix subst s : SecTy :=
        match s with
          ASecTy a => ASecTy (subst_lab_atom k x a)
        | ProdTy a s => ProdTy (subst_lab_atom k x a) (subst s)
        | NilTy => NilTy
        end
    in subst s2 with
  subst_lab_atom (k : Lab) (x : string) (a : AtomSecTy) : AtomSecTy :=
    let fix subst a : AtomSecTy :=
        match a with
          STy t k' => STy (subst_lab_ty k x t) k'[[k ./ x]]
        | VarTy y k' => VarTy y k'[[k ./ x]]
        end
    in subst a with
  subst_lab_ty (k : Lab) (x : string) (t : Ty) : Ty :=
    let fix subst t : Ty :=
        match t with
        | IntTy => IntTy
        | PtrTy k' s => PtrTy k[[k ./ x]] (subst_lab_secty k x s)
        | SPtrTy s1 s2 => SPtrTy (subst_lab_secty k x s1) (subst_lab_secty k x s2)
        | ExTyTy α k' s =>
          ExTyTy α k'[[k ./ x]] (match string_dec α x with
                                   left _ => s
                                 | right _ => subst_lab_secty k x s
                                 end)
        | ExLabTy κ k' s =>
          ExLabTy κ k'[[k ./ x]] (match string_dec κ x with
                                    left _ => s
                                  | right _ => subst_lab_secty k x s
                                  end)
        | RecTy k' y s => RecTy k'[[k ./ x]] y
                               (match string_dec x y with
                                  left _ => s
                                | right _ => subst_lab_secty k x s
                                end)
        | SizeTy s => SizeTy (subst_lab_secty k x s)
        end
    in subst t.

  Instance Substeable_Lab_SecTy : Substeable Lab string SecTy := {}.
  exact subst_lab_secty.
  Defined.

  Reserved Notation "'[' Γ ',' Π ',' ϕ ']' '⊢' e ':' r" (at level 70, e, r at next level).
  Inductive wt_expr: TEnv -> KEnv -> Formula -> Expr -> SecTy -> Prop :=
  | wt_var x Γ Π ϕ s:
      Γ x = Some s ->
      [Γ, Π, ϕ] ⊢ Var x : s
  | wt_num n Γ Π ϕ:
      [Γ, Π, ϕ] ⊢ Num n : STy IntTy ⊥
  | wt_binop Γ Π ϕ o e1 e2 s1 s2 s:
      [Γ, Π, ϕ] ⊢ e1 : s1 ->
      [Γ, Π, ϕ] ⊢ e2 : s2 ->
      o : s1, s2 ⤇ s ->
      [Γ, Π, ϕ] ⊢ BinOp o e1 e2 : s
  | wt_unroll Γ Π ϕ α k1 k2 s e:
      [Γ, Π, ϕ] ⊢ e : STy (μ (α ::: k1) s) k2 ->
      [Γ, Π, ϕ] ⊢ Unroll e : s [[ ASecTy (STy (μ (α ::: k1) s) k2) ./ α ]]
  | wt_roll Γ Π ϕ α k1 k2 s e:
      [Γ, Π, ϕ] ⊢ e : s [[ ASecTy (STy (μ (α ::: k1) s) k2) ./ α ]] ->
      [Γ, Π, ϕ] ⊢ Roll e : STy (μ (α ::: k1) s) k2
  | wt_packty Γ Π ϕ s e α k1 k2 s2:
      [Π, ϕ] ⊢ₛ s : k1 ->
      [Π[α ↦ (KType, k1)], ϕ] ⊢ₛ s2 : k2 ->
      [Γ, Π, ϕ] ⊢ e : s2[[ s ./ α ]] ->
      [Γ, Π, ϕ] ⊢ (TYPACK (s, e) AS ∃ ( α ::: k1 ) s2) : STy (∃ₛ (α ::: k1) s2) ⊥
  | wt_packlab Γ Π ϕ s1 e κ k1 k2 k s2:
      [Π, ϕ] ⊢ₖ k : k1 ->
      [Π[κ ↦ (KLabel, k1)], ϕ] ⊢ₛ s2 : k2 ->
      [Γ, Π, ϕ] ⊢ e : s2[[ s1 ./ κ ]] ->
      [Γ, Π, ϕ] ⊢ (LABPACK (k, e) AS ∃ ( κ ::: k1 ) s2) : STy (∃ₖ (κ ::: k1) s2) ⊥
  | wt_sizeof Γ Π ϕ s k:
      [Π, ϕ] ⊢ₛ s : k ->
      [Γ, Π, ϕ] ⊢ |s| : STy (|s|) k
  | wt_addrof Γ Π ϕ x s:
      Γ x = Some s ->
      [Γ, Π, ϕ] ⊢ (&(x)) : STy (ε @ s) ⊥
  | wt_sub Γ Π ϕ e s1 s2:
      [Γ, Π, ϕ] ⊢ e : s1 ->
      ϕ ⊢ s1 <: s2 ->
      [Γ, Π, ϕ] ⊢ e : s2
  where "'[' Γ ',' Π ',' ϕ ']' '⊢' e ':' r" := (wt_expr Γ Π ϕ e r).

  Reserved Notation "'[' Γ ',' Π ',' ϕ ',' pc ',' fr ']' '⊢' c" (at level 70, c at next level).
  Inductive wt: TEnv -> KEnv -> Formula -> Lab -> Lab -> Cmd -> Prop :=
  | WtSkip Γ Π ϕ pc fr:
      [Γ, Π, ϕ, pc, fr] ⊢ SKIP
  | WtDelay Γ Π ϕ pc fr n:
      [Γ, Π, ϕ, pc, fr] ⊢ CDelay n
  | WtUnsc Γ Π ϕ pc fr x:
      [Γ, Π, ϕ, pc, fr] ⊢ CUnsc x
  | WtEpi Γ Π ϕ pc fr:
      [Γ, Π, ϕ, pc, fr] ⊢ CEpi
  | WtLet Γ Π ϕ pc fr x s r e c k:
      [Γ, Π, ϕ] ⊢ e : r ->
      [Π, ϕ] ⊢ₛ s : k ->
      ϕ ⊢ r ^^ pc <: s ->
      ϕ ⊢ k ⊑ fr ->
      [Γ[x ↦ s], Π, ϕ, pc, fr] ⊢ c ->
      [Γ, Π, ϕ, pc, fr] ⊢ LET x AS s ::= e IN c ENDLET
  | WtAt Γ Π ϕ pc fr k e c:
      [Π, ϕ] ⊢ₖ k : pc ->
      ϕ ⊢ k ⊑ pc ->
      [Γ, Π, ϕ] ⊢ e : STy IntTy pc ->
      [Γ, Π, ϕ, k, fr] ⊢ c ->
      [Γ, Π, ϕ, pc, fr] ⊢ AT k WITH BOUND e DO c TA
  | WtIf Γ Π ϕ pc fr e c1 c2:
      [Γ, Π, ϕ] ⊢ e : STy IntTy pc ->
      [Γ, Π, ϕ, pc, fr] ⊢ c1 ->
      [Γ, Π, ϕ, pc, fr] ⊢ c2 ->
      [Γ, Π, ϕ, pc, fr] ⊢ IF e THEN c1 ELSE c2 FI
  | WtFP Γ Π ϕ pc fr k1 x s:
      [Π, ϕ] ⊢ₖ fr : k1 ->
      Γ x = Some s ->
      ϕ ⊢ s ^^ pc <: Tₛₜ(pc, fr, k1) ->
      [Γ, Π, ϕ, pc, fr] ⊢ x <- FP
  | WtMatch Γ Π ϕ pc fr α ps k:
      Π α = Some (KType, k) ->
      ϕ ⊢ k ⊑ pc ->
      (forall i p c Π' s,
          nth_error ps i = Some (p, c) ->
          Π ⊢ₚ p ⇝ [k] Π' : s ->
          [ Γ[[ s ./ α]], Π, ϕ, pc, fr] ⊢ c[[ s ./ α ]]) ->
      [Γ, Π, ϕ, pc, fr] ⊢ CMatch α ps
  (* I don't think we need to consider k as we're TI (i.e., an out of bounds read/write will only leak the fact that we terminated).*)
  | WtRead Γ Π ϕ pc fr x e s s1 s2 k:
      [Γ, Π, ϕ] ⊢ e : STy (s1 @ s2) k ->
      Γ x = Some s ->
      ϕ ⊢ s2 ^^ pc <: s ->
      [Γ, Π, ϕ, pc, fr] ⊢ x =* e
  | WtWrite Γ Π ϕ pc fr e1 e2 s s1 s2 k:
      [Γ, Π, ϕ] ⊢ e1 : STy (s1 @ s2) k ->
      [Γ, Π, ϕ] ⊢ e2 : s ->
      ϕ ⊢ s ^^ pc <: s2 ->
      [Γ, Π, ϕ, pc, fr] ⊢ e1 *= e2
  | WtUnpTy Γ Π ϕ pc fr α k x s e c k1 k2 r:
      [Γ, Π, ϕ] ⊢ e : STy (∃ₛ (α ::: k1) r) pc ->
      ϕ ⊢ r ^^ pc <: s ->
      [Π[α ↦ (KType, k1)], ϕ] ⊢ₛ r : k2 ->
      [Γ[x ↦ s], Π[α ↦ (KType, k1)], ϕ, pc, fr ⊔ k1 ⊔ k2] ⊢ c ->
      [Γ, Π, ϕ, pc, fr] ⊢ UNPACKTY α AS TYPE k, x AS s ::= e IN c ENDUNPACKTY
  | WtUnpLab Γ Π ϕ pc fr κ k x s e c k1 k2 r:
      [Γ, Π, ϕ] ⊢ e : STy (∃ₖ (κ ::: k1) r) pc ->
      ϕ ⊢ r ^^ pc <: s ->
      [Π[κ ↦ (KLabel, k1)], ϕ] ⊢ₛ r : k2 ->
      [Γ[x ↦ s], Π[κ ↦ (KLabel, k1)], ϕ, pc, fr ⊔ k1 ⊔ k2] ⊢ c ->
      [Γ, Π, ϕ, pc, fr] ⊢ UNPACKLAB κ AS LABEL k, x AS s ::= e IN c ENDUNPACKLAB
  | WtIfLab Γ Π ϕ pc fr k1 k2 c1 c2:
      [Π, ϕ] ⊢ₖ k1 : pc ->
      [Π, ϕ] ⊢ₖ k2 : pc ->
      [Γ, Π, ϕ, pc, fr] ⊢ c1 ->
      [Γ, Π, ϕ, pc, fr] ⊢ c2 ->
      [Γ, Π, (k1, k2) :: ϕ, pc, fr] ⊢ IF k1 FLOWS k2 THEN c1 ELSE c2 FI
  | WtWhile Γ Π ϕ pc fr c e:
      [Γ, Π, ϕ] ⊢ e : STy IntTy pc ->
      [Γ, Π, ϕ, pc, fr] ⊢ c ->
      [Γ, Π, ϕ, pc, fr] ⊢ WHILE e DO c END
  | WtSeq Γ Π ϕ pc fr c1 c2:
      [Γ, Π, ϕ, pc, fr] ⊢ c1 ->
      [Γ, Π, ϕ, pc, fr] ⊢ c2 ->
      [Γ, Π, ϕ, pc, fr] ⊢ (c1 ;; c2)
  | WtCall Γ Π ϕ pc fr c f ks ss es f_ks1 f_ks2 f_ss f_fr f_pc:
      F f = Some (f_ks1, f_ks2, f_ss, f_fr, f_pc, c) ->
      length f_ks1 = length ks ->
      length f_ks2 = length ss ->
      length f_ss = length es ->
      (forall i kᵢ kᵢ' x, nth_error ks i = Some kᵢ ->
                    nth_error f_ks1 i = Some (x, kᵢ') ->
                    [Π, ϕ] ⊢ₖ kᵢ : kᵢ'[[ ks ./ (map fst f_ks1) ] i-1]) ->
      (forall i sᵢ kᵢ x, nth_error ss i = Some sᵢ ->
                   nth_error f_ks2 i = Some (x, kᵢ) ->
                   [Π, ϕ] ⊢ₛ sᵢ : kᵢ[[ ks ./ (map fst f_ks1) ]]) ->
      (forall i sᵢ eᵢ x, nth_error es i = Some eᵢ ->
                   nth_error f_ss i = Some (x, sᵢ) ->
                   [Γ, Π, ϕ] ⊢ eᵢ : sᵢ[[ ks ./ (map fst f_ks1) ]]
                                      [[ ss ./ (map fst f_ks2) ]]) ->
      ϕ ⊢ pc === f_pc[[ ks ./ (map fst f_ks1) ]] ->
      ϕ ⊢ fr ⊑ f_fr[[ ks ./ (map fst f_ks1) ]] ->
      [Γ, Π, ϕ, pc, fr] ⊢ CCall f ks ss es
  where "'[' Γ ',' Π ',' ϕ ',' pc ',' fr ']' '⊢' c" := (wt Γ Π ϕ pc fr c).

  Lemma subst_secty_cmd_skip:
    forall x s,
      CSkip[[s ./ x]] = CSkip.
  Proof.
    intros.
    cbn.
    unfold subst_secty_cmd.
    cbn.
    destruct s; reflexivity.
  Qed.

  Lemma subst_secty_cmd_write:
    forall e1 e2 x s,
      (e1 *= e2)[[s ./ x]] = (e1[[s ./ x]] *= e2[[s ./ x]]).
  Proof.
    intros.
    cbn.
    unfold subst_secty_cmd.
    cbn.
    destruct s; reflexivity.
  Qed.

  Lemma subst_secty_expr_addrof:
    forall x y s,
      (&(x)) [[s ./ y]] = &(x).
  Proof.
    intros.
    reflexivity.
  Qed.

  Lemma subst_secty_expr_num:
    forall (n : nat) y s,
      (Num n) [[s ./ y]] = Num n.
  Proof.
    intros.
    reflexivity.
  Qed.

  Instance Substeable_SecTy_AtomSecTy : Substeable SecTy string AtomSecTy := {}.
  exact (fun s x a =>
           let fix subst a :=
               match a with
               | STy t k => STy t[[s ./ x]] k
               | VarTy y k => VarTy y k
               end
           in subst a).
  Defined.

  Lemma subst_secty_atom_STy:
    forall (t : Ty) (k : Lab) (s : SecTy) (x : string),
      (STy t k)[[ s ./ x ]] = STy t[[s ./ x]] k.
  Proof.
    intros.
    reflexivity.
  Qed.

  Lemma raise_sty:
    forall t k1 k2,
      (STy t k1) ^^ k2 = STy t (k1 ⊔ k2).
  Proof.
    intros.
    reflexivity.
  Qed.

  Lemma raise_asecty:
    forall a k,
      ASecTy a ^^ k = ASecTy (a ^^ k).
  Proof.
    intros.
    reflexivity.
  Qed.

  Global Instance MorphismR_flowsto_with :
    forall ϕ,
      MorphismR (flowsto_with ϕ).
  Proof.
    intros.
    constructor.
    intros.
    unfold flowsto_with in *.
    split.
    - intros.
      rewrite <- H, <- H1.
      firstorder.
    - intros.
      rewrite -> H, H1.
      firstorder.
  Defined.

  Global Instance Reflexive_flowsto_with (ϕ: Formula): Reflexive (flowsto_with ϕ) := {}.
  Proof.
    intros.
    unfold flowsto_with.
    intros.
    reflexivity.
  Qed.

  Global Instance MorphismUR_wt_ty :
    forall Π ϕ t,
      MorphismUR (wt_ty Π ϕ t).
  Proof.
    intros.
    constructor.
    intros.
    split; intros.
    - induction H1.
      + eapply wt_ty_sub.
        * constructor.
        * rewrite -> H.
          reflexivity.
      + eapply wt_ty_sub.
        * constructor; eassumption.
        * rewrite <- H.
          reflexivity.
      + eapply wt_ty_sub.
        * constructor; eassumption.
        * rewrite <- H.
          reflexivity.
      + eapply wt_ty_sub.
        * eapply wt_exty; eassumption.
        * rewrite <- H.
          reflexivity.
      + eapply wt_ty_sub.
        * eapply wt_exlab; eassumption.
        * rewrite <- H.
          reflexivity.
      + eapply wt_ty_sub.
        * eapply wt_rec; eassumption.
        * rewrite <- H.
          reflexivity.
      + eapply wt_ty_sub.
        * eapply wt_size; eassumption.
        * rewrite <- H.
          reflexivity.
      + eapply wt_ty_sub.
        * eassumption.
        * rewrite -> H.
          assumption.
    - induction H1.
      + eapply wt_ty_sub.
        * constructor.
        * rewrite <- H.
          reflexivity.
      + eapply wt_ty_sub.
        * constructor; eassumption.
        * rewrite -> H.
          reflexivity.
      + eapply wt_ty_sub.
        * constructor; eassumption.
        * rewrite -> H.
          reflexivity.
      + eapply wt_ty_sub.
        * eapply wt_exty; eassumption.
        * rewrite -> H.
          reflexivity.
      + eapply wt_ty_sub.
        * eapply wt_exlab; eassumption.
        * rewrite -> H.
          reflexivity.
      + eapply wt_ty_sub.
        * eapply wt_rec; eassumption.
        * rewrite -> H.
          reflexivity.
      + eapply wt_ty_sub.
        * eapply wt_size; eassumption.
        * rewrite -> H.
          reflexivity.
      + eapply wt_ty_sub.
        * eassumption.
        * rewrite <- H.
          assumption.
  Qed.

  Global Instance MorphismUR_wt_atom_sectype :
    forall Π ϕ a,
      MorphismUR (wt_atom_sectype Π ϕ a).
  Proof.
    intros.
    constructor.
    intros.
    split; intros.
    - induction H1.
      + eapply wt_atom_sub.
        * constructor; eassumption.
        * rewrite <- H.
          reflexivity.
      + eapply wt_atom_sub.
        * constructor; eassumption.
        * rewrite <- H.
          reflexivity.
      + eapply wt_atom_sub.
        * eassumption.
        * rewrite -> H.
          assumption.
    - induction H1.
      + eapply wt_atom_sub.
        * constructor; eassumption.
        * rewrite -> H.
          reflexivity.
      + eapply wt_atom_sub.
        * constructor; eassumption.
        * rewrite -> H.
          reflexivity.
      + eapply wt_atom_sub.
        * eassumption.
        * rewrite <- H.
          assumption.
  Qed.

  Global Instance MorphismUR_wt_sectype :
    forall Π ϕ s,
      MorphismUR (wt_sectype Π ϕ s).
  Proof.
    intros.
    constructor.
    intros.
    split.
    - intros.
      revert x H.
      induction H1; intros.
      + constructor.
        rewrite -> H1.
        assumption.
      + eapply wt_secty_sub.
        * constructor.
          -- eassumption.
          -- eapply IHwt_sectype.
             reflexivity.
        * rewrite <- H2.
          reflexivity.
      + eapply wt_secty_sub.
        * eapply wt_secty_nil.
        * unfold flowsto_with.
          intros.
          eapply bot_is_bot.
      + eapply wt_secty_sub.
        * eassumption.
        * rewrite -> H2.
          assumption.
    - intros.
      revert y H.
      induction H1; intros.
      + constructor.
        rewrite <- H1.
        assumption.
      + eapply wt_secty_sub.
        * constructor.
          -- eassumption.
          -- eapply IHwt_sectype.
             reflexivity.
        * rewrite -> H2.
          reflexivity.
      + eapply wt_secty_sub.
        * eapply wt_secty_nil.
        * unfold flowsto_with.
          intros.
          eapply bot_is_bot.
      + eapply wt_secty_sub.
        * eassumption.
        * rewrite <- H2.
          assumption.
  Qed.

End TypeSystem.

Notation "'[' Γ ',' Π ',' ϕ ',' pc ',' fr ']' '⊢' c" := (wt Γ Π ϕ pc fr c) (at level 70, c at next level).


From stdpp Require Export strings.
From stdpp Require Import relations numbers.
From Coq Require Import Ascii.
From stdpp Require Import options.

Class Pretty A := pretty : A → string.
Definition pretty_N_char (x : N) : ascii :=
  match x with
  | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" | 4 => "4"
  | 5 => "5" | 6 => "6" | 7 => "7" | 8 => "8" | _ => "9"
  end%char%N.
Fixpoint pretty_N_go_help (x : N) (acc : Acc (<)%N x) (s : string) : string :=
  match decide (0 < x)%N with
  | left H => pretty_N_go_help (x `div` 10)%N
     (Acc_inv acc (N.div_lt x 10 H eq_refl))
     (String (pretty_N_char (x `mod` 10)) s)
  | right _ => s
  end.
Definition pretty_N_go (x : N) : string → string :=
  pretty_N_go_help x (wf_guard 32 N.lt_wf_0 x).
Lemma pretty_N_go_0 s : pretty_N_go 0 s = s.
Proof. done. Qed.
Lemma pretty_N_go_help_irrel x acc1 acc2 s :
  pretty_N_go_help x acc1 s = pretty_N_go_help x acc2 s.
Proof.
  revert x acc1 acc2 s; fix FIX 2; intros x [acc1] [acc2] s; simpl.
  destruct (decide (0 < x)%N); auto.
Qed.
Lemma pretty_N_go_step x s :
  (0 < x)%N → pretty_N_go x s
  = pretty_N_go (x `div` 10) (String (pretty_N_char (x `mod` 10)) s).
Proof.
  unfold pretty_N_go; intros; destruct (wf_guard 32 N.lt_wf_0 x).
  destruct wf_guard. (* this makes coqchk happy. *)
  unfold pretty_N_go_help at 1; fold pretty_N_go_help.
  by destruct (decide (0 < x)%N); auto using pretty_N_go_help_irrel.
Qed.
Instance pretty_N : Pretty N := λ x, pretty_N_go x ""%string.
Lemma pretty_N_unfold x : pretty x = pretty_N_go x "".
Proof. done. Qed.
Instance pretty_N_inj : Inj (=@{N}) (=) pretty.
Proof.
  assert (∀ x y, x < 10 → y < 10 →
    pretty_N_char x =  pretty_N_char y → x = y)%N.
  { compute; intros. by repeat (discriminate || case_match). }
  cut (∀ x y s s', pretty_N_go x s = pretty_N_go y s' →
    String.length s = String.length s' → x = y ∧ s = s').
  { intros help x y Hp.
    eapply (help x y "" ""); [by rewrite <-!pretty_N_unfold|done]. }
  assert (∀ x s, ¬String.length (pretty_N_go x s) < String.length s) as help.
  { setoid_rewrite <-Nat.le_ngt.
    intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros s.
    assert (x = 0 ∨ 0 < x)%N as [->|?] by lia; [by rewrite pretty_N_go_0|].
    rewrite pretty_N_go_step by done.
    etrans; [|by eapply IH, N.div_lt]; simpl; lia. }
  intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros y s s'.
  assert ((x = 0 ∨ 0 < x) ∧ (y = 0 ∨ 0 < y))%N as [[->|?] [->|?]] by lia;
    rewrite ?pretty_N_go_0, ?pretty_N_go_step, ?(pretty_N_go_step y) by done.
  { done. }
  { intros -> Hlen; edestruct help; rewrite Hlen; simpl; lia. }
  { intros <- Hlen; edestruct help; rewrite <-Hlen; simpl; lia. }
  intros Hs Hlen; apply IH in Hs; destruct Hs;
    simplify_eq/=; split_and?; auto using N.div_lt_upper_bound with lia.
  rewrite (N.div_mod x 10), (N.div_mod y 10) by done.
  auto using N.mod_lt with f_equal.
Qed.
Instance pretty_Z : Pretty Z := λ x,
  match x with
  | Z0 => "" | Zpos x => pretty (Npos x) | Zneg x => "-" +:+ pretty (Npos x)
  end%string.
Instance pretty_nat : Pretty nat := λ x, pretty (N.of_nat x).
Instance pretty_nat_inj : Inj (=@{nat}) (=) pretty.
Proof. apply _. Qed.


Set Implicit Arguments.

Require Import Variable_Sets.
Require Import deBruijn_Isomorphism.

(** This file provides a connection between the generic meta library
   and some simple typed languages such as STLC or ML
   based on some isomorphisms.

   A concrete type/term class [TT] is isomorphic to the generic
   representation [RR] when there is an isomorphism
   between [TT] and [Interpret RR].

   In the following, two modules [MT] and [MY] are used.
   - MT stands for module for terms of e.g. STLC.
   - MY stands for module for types of e.g. STLC
   *)

Module dBTemplate (iso1 iso2 : Iso_full).

  Hint Rewrite iso1.To_From iso1.From_To iso2.To_From iso2.From_To : isorew.

  Hint Resolve iso1.To_From iso1.From_To iso2.To_From iso2.From_To.

  (**************************************************************)
  (** * Shifting *)
  (**************************************************************)

  (** Shifting for a iso1 variable in a iso2 *)

  Definition Tshift (X : atom) (T : iso2.TT) : iso2.TT :=
    iso2.To (shift X iso1.RR (iso2.From T)).

  (**************************************************************)
  (** * Substitution *)
  (**************************************************************)

  (** Substitution for a iso1 variable in a iso2 *)

  Definition Tsubst (T:iso2.TT) (m:atom) (U:iso1.TT) : iso2.TT :=
    iso2.To (subst (iso2.From T) m (iso1.From U)).

  (**************************************************************)
  (** * Term size *)
  (**************************************************************)

  Definition Ysize (T:iso1.TT) : nat := size (iso1.From T).

  (**************************************************************)
  (** * A tactic unfolding everything *)
  (**************************************************************)

  Ltac gunfold :=
    unfold Tshift, Tsubst in *;
    unfold Ysize in *;
    intros;
    repeat rewrite iso2.To_From in *;
    repeat rewrite iso2.From_To in *;
    repeat rewrite iso1.From_To in *;
    repeat rewrite iso1.From_To in *;
    simpl in *.

  (**************************************************************)
  (** * Homomorphisms *)
  (**************************************************************)

  (** [From] is a homomorphism w.r.t. substitutions. *)

  Lemma From_Tshift : forall (T:iso2.TT) (a:atom),
    iso2.From (Tshift a T) = shift a iso1.RR (iso2.From T).
  Proof.
    unfold Tshift; intros; autorewrite with isorew; auto.
  Qed.

  (** [From] is a homomorphism w.r.t. substitutions. *)

  Lemma From_Tsubst : forall (T:iso2.TT) (a:atom) (U:iso1.TT),
    iso2.From (Tsubst T a U) = subst (iso2.From T) a (iso1.From U).
  Proof.
    unfold Tsubst; intros; autorewrite with isorew; auto.
  Qed.

  (**************************************************************)
  (** Tshift and Tsubst are identity function when no [Repr] occurs. *)
  (**************************************************************)

  Lemma Tshift_id: forall n T,
    noRepr iso2.RR ->
    iso1.RR <> iso2.RR ->
    Tshift n T = T.
  Proof.
    gunfold; rewrite <- noRepr_shift_hetero; autorewrite with isorew; auto.
  Qed.

  Lemma Tsubst_id : forall n T U,
    noRepr iso2.RR ->
    iso1.RR <> iso2.RR ->
    Tsubst T n U = T.
  Proof.
    gunfold; rewrite <- noRepr_subst_hetero; autorewrite with isorew; auto.
  Qed.

  (**************************************************************)
  (** * Environments *)
  (**************************************************************)

  (** TEnv is (TT * TT) list.
     - [inl] is used for type variable binding.
     - [inr] is used for term variable binding. *)

  Notation TEnv := (Env iso1.TT).

  Fixpoint From_TEnv (e:TEnv) : (ENV iso1.RR) :=
    match e with
      | nil => nil
      | inl T :: e' => inl (iso1.From T) :: (From_TEnv e')
      | inr T :: e' => inr (iso1.From T) :: (From_TEnv e')
    end.

  Fixpoint To_TEnv (e:ENV iso1.RR) : TEnv :=
    match e with
      | nil => nil
      | inl T :: e' => inl (iso1.To T) :: (To_TEnv e')
      | inr T :: e' => inr (iso1.To T) :: (To_TEnv e')
    end.

  Lemma From_To_TEnv : forall e : ENV iso1.RR, From_TEnv (To_TEnv e) = e.
  Proof.
    induction e;
      [ simpl; auto
        | destruct a;
          simpl; rewrite IHe; rewrite iso1.From_To; auto
      ].
  Qed.

  Lemma To_From_TEnv : forall e : TEnv, To_TEnv (From_TEnv e) = e.
  Proof.
    induction e; simpl; auto.
    destruct a; simpl; rewrite IHe, iso1.To_From; auto.
  Qed.

  Hint Resolve From_To_TEnv.
  Hint Rewrite From_To_TEnv : isorew.

  Definition Tlth (e : TEnv) : atom := lth (From_TEnv e).

  Notation "[[[ e ]]]" := (Tlth e).

  (** Tremove_right removes the x th element in environment. *)

  Fixpoint Tremove_right (e : TEnv) (x : nat) {struct e} : TEnv :=
    match e with
      | nil         => nil
      | (inl T)::e' => (inl T)::(Tremove_right e' x)
      | (inr T)::e' =>
        match x with
          | O   => e'
          | S x => (inr T::(Tremove_right e' x))
        end
    end.

  (**************************************************************)
  (** To and From function on (option TT) *)
  (**************************************************************)

  Fixpoint opt_To (T : option (Interpret iso1.RR)) : option iso1.TT :=
    match T with
      | None => None
      | Some T' => Some (iso1.To T')
    end.

  Fixpoint opt_From (T : option (iso1.TT)) : option (Interpret iso1.RR) :=
    match T with
      | None => None
      | Some T' => Some (iso1.From T')
    end.

  Lemma opt_To_preserving_none (T : option (Interpret iso1.RR)) :
    T = None -> opt_To T = None.
  Proof.
    intros; rewrite H; auto.
  Qed.

  Lemma opt_To_preserving_none_rev (T : option (Interpret iso1.RR)) :
    opt_To T = None -> T = None.
  Proof.
    induction T; simpl; intros; [discriminate | auto].
  Qed.

  Lemma opt_From_preserving_some (T : option iso1.TT) (t : iso1.TT):
    T = Some t -> opt_From T = Some (iso1.From t).
  Proof.
    intros; rewrite H; auto.
  Qed.

  Lemma opt_To_preserving_some (T : option (Interpret iso1.RR)) (t : Interpret iso1.RR):
    T = Some t -> opt_To T = Some (iso1.To t).
  Proof.
    intros; rewrite H; auto.
  Qed.

  Lemma opt_To_preserving_some_rev (T : option (Interpret iso1.RR)) (t : Interpret iso1.RR):
    opt_To T = Some (iso1.To t) -> T = Some t.
  Proof.
    induction T; simpl; intros; [idtac | discriminate].
    rewrite <- (iso1.From_To a);rewrite <- (iso1.From_To t0).
    rewrite <- opt_To_preserving_some with (T:= Some a) in H;auto.
    rewrite <- opt_To_preserving_some with (T:= Some t0) in H;auto.
    inversion H; rewrite H1;reflexivity.
  Qed.

  Lemma opt_To_preserving_eq (T U : option (Interpret iso1.RR)) :
    T = U -> opt_To T = opt_To U.
  Proof.
    intros; rewrite H; auto.
  Qed.

  Lemma opt_To_preserving_eq_rev (T U : option (Interpret iso1.RR)) :
    opt_To T = opt_To U -> T = U.
  Proof.
    induction T; induction U; intros;
      [ inversion H;
        rewrite <- (iso1.From_To a); rewrite <- (iso1.From_To a0);
        rewrite H1; reflexivity
      | inversion H
      | inversion H
      | auto
      ].
  Qed.

  Hint Resolve
    opt_To_preserving_none opt_To_preserving_none_rev
    opt_To_preserving_some opt_To_preserving_some_rev
    opt_To_preserving_eq opt_To_preserving_eq_rev
    opt_From_preserving_some
    : opt.

  (**************************************************************)
  (** Generic versions of [Tget_left] and [Tget_right] *)
  (**************************************************************)

  Definition gTget_left (e : TEnv) (X : atom) : option (iso1.TT) :=
    opt_To (get_left (From_TEnv e) X).

  Definition gTget_right (e : TEnv) (X : atom) : option (iso1.TT) :=
    opt_To (get_right (From_TEnv e) X).

  (**************************************************************)
  (** * Well-formedness in an environment *)
  (**************************************************************)

  (** Well-formed types in an environment *)

  Definition Twf_typ (e : TEnv) (T : iso1.TT) : Prop :=
    HO_wf [[From_TEnv e]] (iso1.From T).

  Fixpoint Twf_env (e : TEnv) : Prop :=
    match e with
      nil          => True
      | (inr T)::e => Twf_typ e T /\ Twf_env e
      | (inl T)::e => Twf_typ e T /\ Twf_env e
    end.

  Definition gTwf_env (e : TEnv) : Prop :=
    wf_env (From_TEnv e).

  Lemma Twf_env_gTwf_env : forall (e: TEnv),
    Twf_env e -> gTwf_env e.
  Proof.
    unfold gTwf_env;induction e;auto.
    simpl;destruct a;intros;destruct H;simpl;
      (split;
        [ unfold Twf_typ in H;auto
          | auto
        ]).
  Qed.

  Lemma gTwf_env_Twf_env : forall (e: TEnv),
    gTwf_env e -> Twf_env e.
  Proof.
    unfold gTwf_env;induction e;auto.
    simpl;destruct a;intros;destruct H;simpl;
      (split;
        [ unfold Twf_typ in H;auto
          | auto
        ]).
  Qed.

  Lemma Twf_env_weaken : forall (T : iso1.TT) (n m : TEnv),
    [[[n]]] <= [[[m]]] ->
    Twf_typ n T ->
    Twf_typ m T.
  Proof.
    unfold Twf_typ.
    eauto using HO_wf_weaken.
  Qed.

  (** Generic version of [Tremove_right] *)

  Definition gTremove_right (e : TEnv) (x : nat) : TEnv :=
    To_TEnv (remove_right (From_TEnv e) x).

  Lemma Tremove_right_gTremove_right: forall (e:TEnv)(x:nat),
    Tremove_right e x = gTremove_right e x.
  Proof.
    unfold gTremove_right.
    induction e; simpl; intros; auto.
    destruct a;
    [ simpl; rewrite IHe, iso1.To_From; auto
    | destruct x;
      [ simpl; rewrite To_From_TEnv; auto
      | simpl; rewrite iso1.To_From; rewrite IHe; auto
      ]
    ].
  Qed.

  Lemma Twf_typ_remove_right : forall (e : TEnv) (x : nat) (T : iso1.TT),
    Twf_typ e T -> Twf_typ (Tremove_right e x) T.
  Proof.
    intros.
    rewrite Tremove_right_gTremove_right.
    unfold Twf_typ, gTremove_right; intros.
    autorewrite with isorew.
    auto using HO_wf_remove_right.
  Qed.

  Lemma Twf_typ_insert_right : forall (e : TEnv) (n : nat) (T : iso1.TT),
    Twf_typ (Tremove_right e n) T -> Twf_typ e T.
  Proof.
    intros.
    rewrite Tremove_right_gTremove_right in H.
    unfold Twf_typ, gTremove_right in *; intros.
    autorewrite with isorew in *.
    eauto using HO_wf_insert_right.
  Qed.

  Lemma Twf_env_remove_right : forall (e : TEnv) (x : nat),
    Twf_env e ->
    Twf_env (Tremove_right e x).
  Proof.
    intros.
    rewrite Tremove_right_gTremove_right.
    apply gTwf_env_Twf_env.
    apply Twf_env_gTwf_env in H.
    unfold gTwf_env, gTremove_right in *; intros.
    autorewrite with isorew.
    eauto using wf_env_remove_right.
  Qed.

  (** Generic version of [Tinsert_left] *)

  Definition gTinsert_left n (e e':TEnv) :=
    insert_left n (From_TEnv e) (From_TEnv e').

  (** Isomorphisms between generic well-formedness and specific well-formedness *)

  Definition Tinsert (n: nat) (e: TEnv) (T: iso1.TT) (H:Twf_typ nil T) : TEnv :=
    To_TEnv (insert n (From_TEnv e) (iso1.From T) H).

  Lemma Tinsert_S : forall (e:TEnv) (n:nat) U H,
    S [[[e]]] = [[[Tinsert n e U H]]].
  Proof.
    unfold Tinsert, Tlth; intros.
    autorewrite with isorew.
    apply insert_S.
  Qed.

  Hint Resolve Tinsert_S.

  Lemma Twf_typ_weakening_right : forall (e : TEnv) (T U : iso1.TT),
    Twf_typ e U -> Twf_typ ((inr T)::e) U.
  Proof.
    unfold Twf_typ.
    auto using HO_wf_weakening_right.
  Qed.

  Lemma Twf_typ_strengthening_right : forall (e : TEnv) (T U : iso1.TT),
    Twf_typ ((inr T)::e) U -> Twf_typ e U.
  Proof.
    unfold Twf_typ.
    eauto using HO_wf_strengthening_right.
  Qed.

  Lemma Twf_typ_eleft : forall (T U V : iso1.TT) (e : TEnv),
    Twf_typ ((inl U)::e) T -> Twf_typ ((inl V)::e) T.
  Proof.
    unfold Twf_typ.
    eauto using HO_wf_left.
  Qed.

End dBTemplate.