Require Import Coq.Strings.String. Open Scope string_scope.
Require Import ZArith.
Require Import Lia.
Require Import List.

Require Setoid.
Require RelationClasses.
Require Import Relations.

Require Import Utils.
Require Import Lattices.
Require Import Instr.
Require Import AbstractCommon.
Require Import AbstractMachine.
Require TINI.

(** The Abstract Machine satisfies TINI. *)

Set Implicit Arguments.

Section ObsEquiv.

Context {Label: Type}.
Context {Latt: JoinSemiLattice Label}.

(** * Low equivalence relations *)
Definition low_pc (o: Label) (s: AS) : Prop :=
  snd (apc s) <: o = true.

Lemma low_pc_dec: forall o s, {low_pc o s}+{~ low_pc o s}.
Proof.
  intros. unfold low_pc.
  destruct (flows (snd (apc s)) o); auto.
Qed.

Inductive low_equiv_atom (o: Label) : relation (@Atom Label) :=
| le_a_low : forall l v, l <: o = true -> low_equiv_atom o (v,l) (v,l)
| le_a_high: forall l1 l2 v1 v2,
  l1 <: o = false ->
  l2 <: o = false ->
  low_equiv_atom o (v1,l1) (v2,l2).
Hint Constructors low_equiv_atom : core.

Global Instance low_atom (o: Label) : @Equivalence (@Atom Label) (low_equiv_atom o).
Proof.
  constructor.
  (* reflexive *) intro x. destruct x;
  destruct (flows l o) eqn:?; auto.
  (* symmetric *) intros x y Hxy. inv Hxy ; auto.
  (* transitive *) intros x y z Hxy Hyz.
  inv Hxy; auto. inv Hyz ; auto.
Qed.

Hint Extern 1 =>
  match goal with
    | |- low_equiv_atom _ _ _ => reflexivity
  end : core.

Lemma low_equiv_atom_join_value:
  forall o v1 v0 v v2 vl vl0  vl2 vl1,
    low_equiv_atom o (v1, vl) (v, vl0) ->
    low_equiv_atom o (v2, vl2) (v0, vl1) ->
    low_equiv_atom o (v1, vl \_/ vl2) (v, vl0 \_/ vl1).
Proof.
  intros.
  inv H; inv H0; econstructor; eauto with lat.
Qed.

Inductive low_equiv_stkelt (o: Label) : @StkElmt Label -> @StkElmt Label -> Prop :=
| le_data : forall a1 a2
  (LEa: low_equiv_atom o a1 a2),
  low_equiv_stkelt o (AData a1) (AData a2)
| le_aret : forall a1 a2 b
  (LEa: low_equiv_atom o a1 a2),
  low_equiv_stkelt o (ARet a1 b) (ARet a2 b).
Hint Constructors low_equiv_stkelt : core.

Global Instance low_stkelt (o: Label) : @Equivalence (@StkElmt Label) (low_equiv_stkelt o).
Proof.
  constructor.
  (* reflexive *) intro x. destruct x; auto.
  (* symmetric *) intros x y Hxy. inv Hxy ; constructor ; symmetry; auto.
  (* transitive *) intros x y z Hxy Hyz.
  inv Hxy; inv Hyz; constructor; etransitivity; eauto.
Qed.

Hint Extern 1 =>
  match goal with
    | |- low_equiv_stkelt _ _ _ => reflexivity
  end : core.

Inductive low_equiv_list (A: Type) (low_equiv_a: A -> A -> Prop) :
  list A -> list A -> Prop :=
| le_nil: low_equiv_list low_equiv_a nil nil
| le_cons: forall a1 a2 l1 l2,
  (low_equiv_a a1 a2) ->
  (low_equiv_list low_equiv_a l1 l2) ->
  low_equiv_list low_equiv_a (a1::l1) (a2::l2).
Hint Constructors low_equiv_list : core.

Lemma low_equiv_list_app_left (A: Type) (low_equiv_a: A -> A -> Prop) :
  forall l1 l1' l2 l2',
    low_equiv_list low_equiv_a (l1++l2) (l1'++l2') ->
    length l1 = length l1' ->
    low_equiv_list low_equiv_a l1 l1'.
Proof.
  induction l1; intros; simpl in *.
  destruct l1'; [ eauto | inv H0].
  destruct l1'; [inv H0 | eauto].
  simpl in *; inv H; auto.
  constructor ; eauto.
Qed.

Lemma low_equiv_list_app_right (A: Type) (low_equiv_a: A -> A -> Prop) :
  forall l1 l1' l2 l2',
    low_equiv_list low_equiv_a (l1++l2) (l1'++l2') ->
    length l1 = length l1' ->
    low_equiv_list low_equiv_a l2 l2'.
Proof.
  induction l1; intros; simpl in *.
  destruct l1' ; [simpl in * ; auto | inv H0].
  destruct l1'; [ inv H0 | simpl in * ].
  inv H; auto.
  eapply IHl1 ; eauto.
Qed.

Lemma low_equiv_list_app (A: Type) (R: A -> A -> Prop) : forall l1 l2 l1' l2',
  low_equiv_list R l1 l2 ->
  low_equiv_list R l1' l2' ->
  low_equiv_list R (l1++l1') (l2++l2').
Proof.
  induction l1; intros.
  inv H.  simpl ; auto.
  inv H. simpl. constructor ; auto.
Qed.
(*
Lemma join_low_equiv_list (f: Z -> Z -> Z):
  forall o s1 s2 v1 v2 v1' v2' v1l v1'l v2l v2'l,
  low_equiv_list (low_equiv_stkelt o) s1 s2 ->
  low_equiv_atom o (v1, v1l) (v2, v2l) ->
  low_equiv_atom o (v1', v1'l) (v2', v2'l) ->
  low_equiv_list (low_equiv_stkelt o)
  ((AData (f v1 v1', join v1l v1'l)) :: s1)
  ((AData (f v2 v2', join v2l v2'l)) :: s2).
Proof.
  intros. constructor ; auto.
  inv H0; inv H1; constructor; auto with lat.
Qed.
*)
Lemma index_list_low_eq (A: Type) (low_equiv: A -> A -> Prop) :
  forall n l1 l2 v1 v2,
    low_equiv_list low_equiv l1 l2 ->
    index_list n l1 = Some v1 ->
    index_list n l2 = Some v2 ->
    low_equiv v1 v2.
Proof.
  induction n ; intros.
  inv H; (simpl in * ; congruence).
  destruct l1, l2; (simpl in * ; try congruence).
  inv H.
  eapply IHn ; eauto.
Qed.

Lemma index_list_Z_low_eq (A: Type) (low_equiv: A -> A -> Prop) :
  forall i l1 l2 v1 v2,
    low_equiv_list low_equiv l1 l2 ->
    index_list_Z i l1 = Some v1 ->
    index_list_Z i l2 = Some v2 ->
    low_equiv v1 v2.
Proof.
  intros. eapply index_list_low_eq; eauto.
  eapply index_list_Z_nat; eauto.
  eapply index_list_Z_nat; eauto.
Qed.

Lemma update_list_high: forall o m1 m2,
  low_equiv_list (low_equiv_atom o) m1 m2 ->
  forall a m1' o1 v l1 l2
    (Hl1 : l1 <: o = false)
    (Hl2 : l2 <: o = false),
    index_list a m1 = Some (o1, l1) ->
    update_list a (v, l2) m1 = Some m1' ->
    low_equiv_list (low_equiv_atom o) m1' m2.
Proof.
  induction 1; intros.
  destruct a; simpl in *; allinv.

  destruct a; simpl in *; allinv.
  constructor ; auto. inv H ; auto.

  case_eq (update_list a (v, l3) l1) ; intros;
  rewrite H3 in *; allinv.
  constructor; auto.
  eapply (IHlow_equiv_list a l o1 v l0) ; eauto.
Qed.

Lemma update_list_Z_high: forall o m1 m2,
  low_equiv_list (low_equiv_atom o) m1 m2 ->
  forall a m1' o1 v l1 l2
    (Hl1 : l1 <: o = false)
    (Hl2 : l2 <: o = false),
    index_list_Z a m1 = Some (o1, l1) ->
    update_list_Z a (v, l2) m1 = Some m1' ->
    low_equiv_list (low_equiv_atom o) m1' m2.
Proof.
  intros.
  eapply update_list_high with (l1 := l1) (l2 := l2); eauto.
  eapply index_list_Z_nat; eauto.
  eapply update_list_Z_nat; eauto.
Qed.

Global Instance low_list
          (A: Type)
          (R: relation A)
          (EqR: Equivalence R) : @Equivalence (list A) (@low_equiv_list A R).
Proof.
  constructor.
  (* reflexive *) unfold Reflexive. induction x; intros; constructor; auto. reflexivity.
  (* symmetric *)
  unfold Symmetric.
  induction x ; intros; (inv H ; constructor ; auto). symmetry; auto.
  (* transitive *)
  unfold Transitive.
  induction x; intros.
  inv H. auto. inv H. inv H0.
  constructor. etransitivity; eauto.
  eapply IHx ; eauto.
Qed.

Hint Extern 1 =>
  match goal with
    | |- low_equiv_list _ _ _ => reflexivity
  end : core.

Lemma update_list_low_equiv: forall a obs l  m m' o v
  (Hl : l <: obs = false),
  index_list a m = Some (o, l) ->
  update_list a (v, l) m = Some m' ->
  low_equiv_list (low_equiv_atom obs) m m'.
Proof.
  induction a; intros.
  destruct m ; simpl in *; allinv.
  constructor; auto.

  destruct m ; simpl in *; allinv.
  case_eq (update_list a (v, l) m) ; intros; rewrite H1 in *; allinv.
  constructor; eauto.
Qed.

Lemma update_list_Z_low_equiv: forall a obs l  m m' o v
  (Hl : l <: obs = false),
  index_list_Z a m = Some (o, l) ->
  update_list_Z a (v, l) m = Some m' ->
  low_equiv_list (low_equiv_atom obs) m m'.
Proof.
  intros. eapply update_list_low_equiv; eauto.
  eapply index_list_Z_nat; eauto.
  eapply update_list_Z_nat; eauto.
Qed.

Lemma update_list_low : forall o n m1 m2 a1 a2 m1' m2',
  low_equiv_list (low_equiv_atom o) m1 m2 ->
  low_equiv_atom o a1 a2 ->
  update_list n a1 m1 = Some m1' ->
  update_list n a2 m2 = Some m2' ->
  low_equiv_list (low_equiv_atom o) m1' m2'.
Proof.
  induction n ; intros.
  inv H; simpl in *; allinv.
  constructor ; auto.

  inv H.
  simpl in *; allinv.
  simpl in H2, H1.
  case_eq (update_list n a2 l2) ; case_eq (update_list n a1 l1) ; intros;
    rewrite H in * ; rewrite H5 in * ; allinv.
  constructor ; eauto.
Qed.

Lemma update_list_Z_low : forall o n m1 m2 a1 a2 m1' m2',
  low_equiv_list (low_equiv_atom o) m1 m2 ->
  low_equiv_atom o a1 a2 ->
  update_list_Z n a1 m1 = Some m1' ->
  update_list_Z n a2 m2 = Some m2' ->
  low_equiv_list (low_equiv_atom o) m1' m2'.
Proof.
  intros. eapply update_list_low; eauto.
  eapply update_list_Z_nat; eauto.
  eapply update_list_Z_nat; eauto.
Qed.

Lemma low_equiv_list_update_Z: forall o a1 a2 a1l a2l o1 o1l o2 o2l m1 m2 m1' m2' v1 v1l v2 v2l,
    low_equiv_atom o (a1, a1l) (a2, a2l) ->
    low_equiv_list (low_equiv_atom o) m1 m2 ->
    index_list_Z a1 m1 = Some (o1, o1l) ->
    index_list_Z a2 m2 = Some (o2, o2l) ->
     a1l <: o1l = true ->
     a2l <: o2l = true ->
    low_equiv_atom o (v1, v1l) (v2, v2l) ->
    update_list_Z a1 (v1, join a1l v1l) m1 = Some m1' ->
    update_list_Z a2 (v2, join a2l v2l) m2 = Some m2' ->
    low_equiv_list (low_equiv_atom o) m1' m2'.
Proof.
  intros.
  inv H; inv H5.

  eapply (@update_list_Z_low o) ; eauto.

  eapply update_list_Z_low with (3:= H6) (4:= H7) ; eauto.
  econstructor 2; eauto with lat.

  assert (low_equiv_list (low_equiv_atom o) m1' m1).
  assert (a1l \_/ v2l <: o = false) by eauto with lat.
  eapply update_list_Z_high with (4:= H1); eauto.
  destruct (flows o1l o) eqn:?; auto.
  assert (flows a1l o = true); eauto with lat.

  assert (low_equiv_list (low_equiv_atom o) m1' m2) by (etransitivity; eauto).
  assert (a2l \_/ v2l <: o = false) by eauto with lat.
  exploit (@update_list_Z_spec Atom (v2, a1l \_/ v2l)) ; eauto. intros HH.
  assert (low_equiv_list (low_equiv_atom o) m2' m2).
  eapply update_list_Z_high with (4:= H2); eauto.
  destruct (flows o2l o) eqn:?; auto.
  assert (flows a2l o = true); eauto with lat.
  etransitivity; eauto. symmetry; auto.

  assert (a1l \_/ v1l <: o = false) by eauto with lat.
  assert (low_equiv_list (low_equiv_atom o) m1' m1).
  eapply update_list_Z_high with (4:= H1); eauto.
  destruct (flows o1l o) eqn:?; auto.
  assert (flows a1l o = true); eauto with lat.

  exploit (@update_list_Z_spec Atom (v1, a1l \_/ v1l)) ; eauto. intros HH.
  assert (low_equiv_list (low_equiv_atom o) m1' m2).
  etransitivity ; eauto.

  assert (a2l \_/ v2l <: o = false) by eauto with lat.
  assert (low_equiv_list (low_equiv_atom o) m2' m2).
  eapply update_list_Z_high with (4:= H2); eauto.
  destruct (flows o2l o) eqn:?; auto.
  assert (flows a2l o = true); eauto with lat.
  etransitivity; eauto. symmetry; eauto.
Qed.

Lemma update_high_low_equiv: forall o addr m v l l' v' m',
  index_list addr m = Some (v,l) ->
  l <: o = false ->
  l <: l' = true ->
  update_list addr (v',l') m = Some m' ->
  low_equiv_list (low_equiv_atom o) m m'.
Proof.
  induction addr; intros.
  destruct m ; simpl in *; allinv.
  constructor ; eauto.
  constructor 2; auto with lat.
  destruct (flows l' o) eqn:?; auto.
  assert (flows l o = true); eauto with lat.

  destruct m ; simpl in *; allinv.
  remember (update_list addr (v', l') m) as up.
  destruct up; allinv.
  constructor; eauto.
Qed.

Lemma update_Z_high_low_equiv: forall o addr m v l l' v' m',
  index_list_Z addr m = Some (v,l) ->
  l <: o = false ->
  l <: l' = true ->
  update_list_Z addr (v',l') m = Some m' ->
  low_equiv_list (low_equiv_atom o) m m'.
Proof.
  intros. eapply update_high_low_equiv; eauto.
  eapply index_list_Z_nat; eauto.
  eapply update_list_Z_nat; eauto.
Qed.

Fixpoint below_lret (o: Label) (stk: list (@StkElmt Label)) : list StkElmt :=
  match stk with
    | nil => nil
    | (ARet (_,l) _)::stk' =>
      match flows l o with
        | true => stk
        | false => below_lret o stk'
      end
    | _::stk' => below_lret o stk'
  end.

Lemma below_lret_low_equiv : forall o l1 l2,
  low_equiv_list (low_equiv_stkelt o) l1 l2 ->
  low_equiv_list (low_equiv_stkelt o) (below_lret o l1) (below_lret o l2).
Proof.
  induction 1; intros.
  simpl ; auto.
  inv H; (simpl; auto).
  inv LEa; (rewrite H in *; auto).
  rewrite H1 ; auto.
Qed.

Lemma below_lret_adata : forall o l l',
  (forall d, In d l -> exists a : Atom, d = AData a) ->
  below_lret o (l ++ l') = below_lret o l'.
Proof.
  induction l; intros.
  simpl; auto.
  destruct a. simpl ; auto. eapply IHl ; eauto.
  intros. eapply H ; eauto. constructor 2 ; auto.

  eelim (H (ARet a b)); intros.
  congruence.
  constructor ; auto.
Qed.

Inductive low_equiv_full_state (o: Label) : @AS Label -> @AS Label -> Prop :=
| low_equiv_high:
  forall l1 l2 m1 m2 i stk1 stk2 pcv1 pcv2
    (Flowl1: l1 <: o = false)
    (Flowl2: l2 <: o = false)
    (LEm : low_equiv_list (low_equiv_atom o) m1 m2)
    (LEsH : low_equiv_list (low_equiv_stkelt o) (below_lret o stk1) (below_lret o stk2)),
    low_equiv_full_state o
      (AState m1 i stk1 (pcv1,l1))
      (AState m2 i stk2 (pcv2,l2))
| low_equiv_low:
  forall l m1 m2 i stk1 stk2 pcv
    (Flowl: l <: o = true)
    (LEm : low_equiv_list (low_equiv_atom o) m1 m2)
    (LEs : low_equiv_list (low_equiv_stkelt o) stk1 stk2),
    low_equiv_full_state o
      (AState m1 i stk1 (pcv,l))
      (AState m2 i stk2 (pcv,l)).
Hint Constructors low_equiv_full_state : core.

Global Instance low_state (o: Label) : @Equivalence AS (@low_equiv_full_state o).
Proof.
  constructor.
  (* reflexive *) intros x. destruct x. destruct apc.
  destruct (flows l o) eqn:?.
  constructor 2 ; eauto.
  constructor ; eauto.
  (* symmetry *)
  intros s s' Hss'.  inv Hss'.
  (constructor; eauto); symmetry ; eauto.
  (constructor 2; eauto) ; symmetry; eauto.
  (* transitive *)
  intros s s' s'' Hss' Hs's''.
  inv Hss' ; inv Hs's''.
  (constructor ; eauto); etransitivity; eauto.
  (constructor ; eauto); etransitivity; eauto.
  apply below_lret_low_equiv; auto.
  (constructor ; eauto); etransitivity; eauto.
  apply below_lret_low_equiv in LEs; auto.
  etransitivity; eauto.
  (constructor 2 ; eauto); etransitivity; eauto.
Qed.

Hint Extern 1 =>
  match goal with
    | |- low_equiv_full_state _ _ _ => reflexivity
  end : core.

Lemma pc_labels1 : forall o s1 s2,
  low_equiv_full_state o s1 s2 ->
  low_pc o s1 ->
  low_pc o s2.
Proof.
  induction 1; intros. unfold low_pc in *;  simpl in *.
  inv H. congruence.
  unfold low_pc in *;  simpl in *. auto.
Qed.

Lemma pc_labels2 : forall o s1 s2,
  low_equiv_full_state o s1 s2 ->
  low_pc o s2 ->
  low_pc o s1.
Proof.
  induction 1; intros. unfold low_pc in *;  simpl in *.
  inv H. congruence.
  unfold low_pc in *;  simpl in *. auto.
Qed.

Lemma index_list_low_equiv_some: forall (A: Type) (R: relation A) n e l l',
  low_equiv_list R l l' ->
  index_list n l = None ->
  index_list n l' = Some e ->
  False.
Proof.
  induction n ; intros.
  destruct l' ; inv H ; simpl in *; try congruence.
  destruct l' ; inv H ; simpl in * ; try congruence.
  eapply IHn ; eauto.
Qed.

Lemma index_list_Z_low_equiv_some: forall (A: Type) (R: relation A) n e l l',
  low_equiv_list R l l' ->
  index_list_Z n l = None ->
  index_list_Z n l' = Some e ->
  False.
Proof.
  unfold index_list_Z. intros.
  destruct (n <? 0)%Z. congruence.
  eapply index_list_low_equiv_some; eauto.
Qed.

(** Visible event for a given observer [o] *)
Inductive visible_event (o : Label) : (@Event Label) -> Prop :=
| ve_low : forall i l, l <: o = true -> visible_event o (EInt (i, l)).
Hint Constructors visible_event : core.

Lemma visible_event_dec : forall o e, {visible_event o e} + {~ visible_event o e}.
Proof.
  intros o [[x l]].
  destruct (l <: o) eqn: Hl; auto.
  right. intros H. inv H. congruence.
Defined.

End ObsEquiv.

Hint Resolve low_state : core.

Hint Constructors
  low_equiv_atom
  low_equiv_stkelt
  low_equiv_list
  low_equiv_full_state : core.

Hint Extern 1 =>
  match goal with
    | |- low_equiv_atom _ _ _ => reflexivity
    | |- low_equiv_stkelt _ _ _ => reflexivity
    | |- low_equiv_list _ _ _ => reflexivity
    | |- low_equiv_full_state _ _ _ => reflexivity
  end : core.

(** * Non-interference property *)

(** Instantiating the generic lockstep non-interference property for
    our particular abstract machine *)

Section ParamMachine.

Context {observer: Type}
        {Latt: JoinSemiLattice observer}.

Ltac exploit_low :=
    repeat match goal with
        | [H: low_equiv_list _ (_::_) (_::_) |- _ ] => inv H
        | [H: low_equiv_stkelt _ (AData _) (AData _) |- _ ] => inv H
        | [H: low_equiv_stkelt _ (ARet _ _) (ARet _ _) |- _ ] => inv H
    end.

Ltac spec_pop_return :=
  (exploit @pop_to_return_spec; eauto);
  let stk := fresh "stk" in
  let Hstk := fresh "Hstk" in
  (intros [? [? [? [? [Hstk ?]]]]]);
  match type of Hstk with
    | ?aastk = _ =>
      match goal with
        | [HH: pop_to_return aastk _ |- _ ] => (subst ; move_to_top HH)
      end
  end.

Inductive abstract_i_equiv (o : observer) : relation (init_data abstract_machine) :=
  | ai_equiv : forall p d1 d2 n b
                      (STK : low_equiv_list (low_equiv_atom o) d1 d2),
                 abstract_i_equiv o (p,d1,n,b) (p,d2,n,b).

Global Program Instance AMObservation : TINI.Observation abstract_machine := {
  e_low := visible_event;
  e_low_dec := visible_event_dec;
  i_equiv := abstract_i_equiv
}.

Lemma low_equiv_step_pop_to_return: forall o  stk1 stk2,
  low_equiv_list (low_equiv_stkelt o) stk1 stk2 ->
  forall  rstk1 rstk2 ,
    pop_to_return stk1 rstk1 ->
    pop_to_return stk2 rstk2 ->
    low_equiv_list (low_equiv_stkelt o) rstk1 rstk2.
Proof.
  induction 1; intros.
  - invh @pop_to_return.
  - invh @pop_to_return.
    + invh @pop_to_return; eauto.
      invh low_equiv_stkelt.
    + invh (pop_to_return (a1::l1)); eauto.
      invh low_equiv_stkelt.
Qed.

Section fix_observer.
Variable o : observer.
Notation "'<<' m i s pc '>>'" := (AState m i s pc).
Notation "m1 '~~m' m2" := (low_equiv_list (low_equiv_atom o) m1 m2) (at level 20).
Notation "s1 '~~l' s2" := (low_equiv_list (low_equiv_stkelt o) s1 s2) (at level 20).
Notation "a1 '~~a' a2" := (low_equiv_atom o a1 a2) (at level 20).

Arguments low_pc {Label Latt} o s /.

Local Ltac go :=
  try congruence;
  try lia;
  auto using below_lret_low_equiv with lat;
  try apply below_lret_low_equiv;
  [> once (constructor; go) ..].

Local Ltac inv_equiv_atom :=
 match goal with
   | h: (_,_) ~~a (_,_) |- _ => inv h; simpl in *
  end.

Lemma lowstep : forall as1 e as1' as2 e' as2',
  low_equiv_full_state o as1 as2 ->
  low_pc o as1  ->
  a_step as1 e as1' ->
  a_step as2 e' as2' ->
  low_equiv_full_state o as1' as2'.
Proof.
  intros as1 e as1' as2 e' as2' He Hpc Hs1 Hs2.
  inv He. inv Hpc; congruence.

  (*destruct (a_step_instr Hs1) as [instr Hinstr].*)

  (inv Hs1 ; try congruence);
    (inv Hs2 ; try congruence); exploit_low;
  try (repeat inv_equiv_atom; go).

  Case "Push".
    assert (cv = cv0) by congruence; subst cv.
    go.

  Case "Load".
    inv_equiv_atom; try go.
    SCase "Load from low addresses".
    assert (Hmemv: low_equiv_atom o (xv, xl) (xv0, xl0)) by
        (eapply index_list_Z_low_eq with (1 := LEm)  ; eauto).
    inv Hmemv; go.

  Case "Store".
    repeat inv_equiv_atom;
    assert (m' ~~m m'0)
      by (eapply low_equiv_list_update_Z with (8:= STORE) (9:= STORE0);
          eauto with lat);
    go.

  Case "BranchNZ".
    assert (offv = offv0) by congruence; subst offv.
    inv_equiv_atom; go.

  Case "Call".
    assert (length args = length args0) by congruence.
    assert (r0 = r) by congruence; subst r0.
    exploit low_equiv_list_app_left ; eauto; intros Hl.
    exploit low_equiv_list_app_right ; eauto; intros Hr.
    inv_equiv_atom.
    SCase "Low Call".
       constructor 2; eauto with lat.
       eapply low_equiv_list_app ; eauto.

    SCase "High Call".
       constructor; auto with lat.
       rewrite below_lret_adata ; eauto.
       rewrite below_lret_adata ; eauto.
       simpl; rewrite Flowl; go.

  Case "Ret".
    spec_pop_return.
    spec_pop_return.
    exploit low_equiv_step_pop_to_return; eauto; intros HspecRet.
    inv HspecRet.
    exploit_low.
    inv_equiv_atom; go.

  Case "VRet".
    spec_pop_return.
    spec_pop_return.
    exploit low_equiv_step_pop_to_return; eauto; intros HspecRet.
    exploit_low.
    repeat inv_equiv_atom; go.
Qed.

Lemma highstep : forall as1 e as1',
  ~low_pc o as1 ->
  a_step as1 e as1' ->
  ~low_pc o as1' ->
  low_equiv_full_state o as1 as1'.
Proof.
  intros as1 e as1' Hpc Hs Hpc'.
  destruct as1. destruct apc as [ z t ]. simpl in *.
  assert (t <: o = false) by (destruct (flows t o); congruence).
  clear Hpc. inv Hs; try go.

  Case "Store".
    destruct (flows ml o) eqn:?.
    SCase "ml <: o = true".
      assert (t <: o = true) by eauto with lat.
      congruence.
    SCase "ml <: o = false".
      assert (m' ~~m amem) by
        (eapply update_list_Z_high with (4:= LOAD) (5:= STORE); eauto with lat).
      constructor ; eauto. symmetry ; auto.

  Case "Call".
    constructor; eauto with lat.
    simpl.
    erewrite below_lret_adata; [idtac|eauto].
    erewrite below_lret_adata; [idtac|eauto].
    simpl in *.
    destruct (t<:o) eqn:Hc; go.

  Case "Ret".
    spec_pop_return.
    simpl in *.
    exploit @pop_to_return_spec2; eauto. intros HTEMP. inv HTEMP.
    exploit @pop_to_return_spec3; eauto. intros HTEMP. inv HTEMP.
    destruct (flows pcl' o) eqn:e; try congruence.
    constructor ; eauto.
    rewrite below_lret_adata; eauto.
    simpl. rewrite e.
    auto.

 Case "VRet".
    spec_pop_return.
    exploit @pop_to_return_spec2; eauto. intros HTEMP. inv HTEMP.
    exploit @pop_to_return_spec3; eauto. intros HTEMP. inv HTEMP.
    simpl in *.
    destruct (flows pcl' o) eqn:e; try congruence.
    constructor ; eauto.
    simpl.
    rewrite below_lret_adata; eauto.
    simpl. rewrite e.
    auto.
Qed.

Lemma highlowstep : forall as1 e as1' as2 e' as2',
  low_equiv_full_state o as1 as2 ->
  ~low_pc o as1 ->
  a_step as1 e as1' ->
  low_pc o as1' ->
  a_step as2 e' as2' ->
  low_pc o as2' ->
  low_equiv_full_state o as1' as2'.
Proof.
  intros as1 e as1' as2 e' as2' Heq Hpc Hs1 Hpc' Hs2 Hpc''.
  inv Heq; [clear Hpc | elim Hpc; simpl ; auto].

  exploit a_step_instr; eauto. intros [instr1 Hinstr1].

  (* instr1 is Ret or VRet *)
  inv Hs1; simpl in *;
  try assert (l1 <: o = true) by (eapply join_2_rev; eassumption);
  try congruence;
  inv Hs2; simpl in *;
  try assert (l2 <: o = true) by (eapply join_2_rev; eassumption);
  try congruence.

  Case "P1 is Ret and P2 is Ret".
    spec_pop_return.
    spec_pop_return.
    revert POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP.
    intros POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP0.
    rewrite below_lret_adata in LEsH; eauto.
    rewrite below_lret_adata in LEsH; eauto.
    revert LEsH; simpl.
    rewrite Hpc'; rewrite Hpc''.
    intros Temp; inv Temp.
    exploit_low.
    inv_equiv_atom; go.

  Case "P1 is Ret and P2 is Vret". (* contradiction *)
    spec_pop_return.
    spec_pop_return.
    revert POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP; intros POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP0.
    rewrite below_lret_adata in LEsH; eauto.
    rewrite below_lret_adata in LEsH; eauto.
    revert LEsH; simpl.
    rewrite Hpc'; rewrite Hpc''.
    intros Temp; inv Temp.
    exploit_low.

  Case "P1 is VRet and P2 is Ret". (* contradiction *)
    spec_pop_return.
    spec_pop_return.
    revert POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP; intros POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP0.
    rewrite below_lret_adata in LEsH; eauto.
    rewrite below_lret_adata in LEsH; eauto.
    revert LEsH; simpl.
    rewrite Hpc'; rewrite Hpc''.
    intros Temp; inv Temp.
    exploit_low.

  Case "P1 is Vret and P2 is Vret".
    spec_pop_return.
    spec_pop_return.
    revert POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP; intros POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP0.
    rewrite below_lret_adata in LEsH; eauto.
    rewrite below_lret_adata in LEsH; eauto.
    revert LEsH; simpl.
    rewrite Hpc'; rewrite Hpc''.
    intros Temp; inv Temp.
    exploit_low.
    inv_equiv_atom; go.
Qed.

End fix_observer.

Lemma low_equiv_list_map : forall E1 E2
                                  (R1: relation E1)
                                  (R2: relation E2)
                                  g f (l1 l2: list E1),
                             (forall x y, R1 x y -> R2 (f x) (g y)) ->
                             low_equiv_list R1 l1 l2 ->
                             low_equiv_list R2 (map f l1) (map g l2).
Proof.
  induction 2; intros; simpl; auto.
Qed.

Lemma below_lret_alldata :
  forall o l,
    (forall e, In e l -> exists a, e = AData a) ->
    (below_lret o l) = nil.
Proof.
  induction l ; intros.
  auto.
  destruct a ; simpl. eapply IHl ; eauto.
  intros ; eapply H ; eauto. constructor 2; auto.
  eelim (H (ARet a b)) ; eauto.
  congruence. constructor; auto.
Qed.

Lemma map_AData :
  forall T (l: list (@Atom T)) e,
   In e (map (fun a : Atom => AData a) l) -> exists a : Atom, e = AData a.
Proof.
  induction l ; intros; inv H; eauto.
Qed.

Program Instance AMUnwindingSemantics :
  TINI.UnwindingSemantics AMObservation := {
  s_equiv := low_equiv_full_state;
  s_low := low_pc;
  s_low_dec := low_pc_dec
}.

Next Obligation.
  inv H.
  destruct (flows o0 o) eqn:E.
  constructor 2; eauto.
  eapply low_equiv_list_map; eauto.
  constructor ; eauto.
  rewrite below_lret_alldata; eauto.
  rewrite below_lret_alldata; eauto.
  apply map_AData.
  apply map_AData.
Qed.

Next Obligation.
  intros x y H. rewrite <- H. reflexivity.
Qed.

Next Obligation.
  inv H; split; intros H; inv H; try congruence;
  unfold low_pc; simpl; trivial.
Qed.

Next Obligation.
  unfold low_pc.
  inv H; simpl;
  try match goal with
        | H : visible_event _ _ |- _ =>
          inv H
      end.
  eauto with lat.
Qed.

Next Obligation.
  inv H1; inv H2;
  try solve [[> once (econstructor ; intros H'; inv H'; solve [eauto]) ..]];
  match goal with
    | H : low_equiv_full_state _ _ _ |- _ =>
      inv H; try congruence
  end;
  try solve [
        constructor; intros H; inv H;
        match goal with
          | H1 : ?pcl <: ?o = false,
            H2 : ?l \_/ ?pcl <: ?o = true |- _ =>
            apply join_2_rev in H2; congruence
        end
      ];
  try solve [exploit @index_list_Z_low_eq_instr; eauto; intros H; inv H].
  exploit_low.
  inv LEa; try reflexivity.
  constructor; intros H; inv H;
  match goal with
    | H : ?l \_/ ?pcl <: ?o = true |- _ =>
      apply join_1_rev in H; congruence
  end.
Qed.

Next Obligation.
  eapply lowstep; eauto.
Qed.

Next Obligation.
  rewrite <- H0.
  symmetry.
  eapply highstep; eauto.
Qed.

Next Obligation.
  eapply highlowstep; eauto.
Qed.

Theorem abstract_noninterference_short :
  TINI.tini AMObservation.
Proof.
  apply TINI.noninterference.
  exact AMUnwindingSemantics.
Qed.

Theorem abstract_noninterference :
  @TINI.tini abstract_machine AMObservation.
Proof.
  apply TINI.noninterference.
  exact AMUnwindingSemantics.
Qed.

End ParamMachine.


Load Common.

Require Import Psatz.
Require Import UserTactics.
Require Export Formula.
Require Import MiscFacts.
Require Import ListFacts.

(*Notation label := (nat * nat).*)

Module Lc.
Lemma instantiate_eq : forall (s t : formula) (m n : nat), lc m t -> m <= n -> instantiate s n t = t.
Proof.
intros s t.
induction t; intros m' n' Lc_t Le_mn; simpl; inversion Lc_t; eauto using f_equal, f_equal2, le_n_S.
by inspect_eqb.
Qed.

(*instantiating a locally closed formula t does nothing*)
Lemma instantiate_eq0 : forall (s t : formula) (n : nat), lc 0 t -> instantiate s n t = t.
Proof.
eauto using instantiate_eq with arith.
Qed.

Lemma relax : forall (s : formula) (n m : nat), lc n s -> n <= m -> lc m s.
Proof.
elim; intros.
gimme lc; inversion; constructor; omega.
constructor.
gimme lc; inversion; constructor; eauto.
gimme lc; inversion; constructor; eapply H. eassumption. omega.
Qed.

Lemma instantiate_pred : forall s t n, lc (1 + n) s -> lc 0 t -> lc n (instantiate t n s).
Proof.
elim.
(*case var*)
move => n t m; intros.
simpl.
gimme shape (lc (1 + m) _) => H_lc; inversion H_lc.
subst.
have : n = m \/ n < m by omega.
case; intros; inspect_eqb.
apply : Lc.relax; [eassumption | omega].
by constructor.
(*case atom*)
intros; constructor.
(*case arr*)
intros. simpl.
gimme shape (lc _ (arr _ _)). inversion.
constructor; auto.
(*case quant*)
intros. simpl.
gimme shape (lc _ (quant _)); inversion.
constructor. auto.
Qed.

Lemma instantiate_prenex_eq : forall (t : formula) (n : nat) (f : nat -> option formula),
  lc n t -> (forall (m : nat), m < n -> f m = None) -> instantiate_prenex f t = t.
Proof.
elim; intros * => IH; intros; simpl; gimme lc; inversion.
(have : f n = None by auto) => ->.
auto.
done.
f_equal; eauto.
(*case quant*)
f_equal.
apply: IH. eassumption.
intros.
revert dependent m.
case; eauto with arith.
Qed.
End Lc.

Lemma chain_arr : forall (s t : formula) (params : list formula) (a : label), chain (arr s t) a params ->
  exists (ss : list formula), params = s :: ss /\ chain t a ss.
Proof.
move => s t params a.
case; intros; gimme contains; inversion; eauto.
Qed.

Lemma chain_atom : forall (a b : label) (params : list formula), chain (atom a) b params -> params = [ ] /\ a = b.
Proof.
intros *.
inversion; gimme contains; inversion; auto.
Qed.

Lemma instantiate_quantification (s t : formula) : forall (n : nat) (m : nat),
  instantiate s m (quantify_formula n t) = quantify_formula n (instantiate s (n+m) t).
Proof.
elim; first auto.

intros.
have : forall n m, 1 + (n + m) = n + (1 + m) by intros; omega.
cbn => ->.
by f_equal.
Qed.

Lemma quantified_arrow_not_contains_atom : forall n s t a, contains (quantify_formula n (arr s t)) (atom a) -> False.
Proof.
elim; simpl; intros; gimme contains; inversion.
gimme contains; rewrite instantiate_quantification; eauto.
Qed.

Lemma instantiate_prenex_after_instantiate : forall (s t : formula) (n : nat) (f g : nat -> option formula),
  lc 0 t
  -> (forall (n' : nat), g n' = (fun m => if m =? n then Some t else f m) n')
  -> instantiate_prenex f (instantiate t n s) = instantiate_prenex g s.
Proof.
elim.
move => m ? n.
intros until 1 => Hg *.
case (Nat.eq_dec n m); intros; subst; cbn; rewrite Hg; do 2 inspect_eqb.
apply : Lc.instantiate_prenex_eq; [ eassumption | intros; omega ].
done.

(*case atom*) done.
(*case arr*) intros; cbn; f_equal; eauto.
(*case quant*)
intros * => IH.
intros until 1 => Hg *; cbn; f_equal.
apply : IH => //.
case.
by inspect_eqb.
move => n'.
rewrite Hg.
case (Nat.eq_dec n' n); intros; do 2 inspect_eqb => //.
Qed.

Lemma contains_to_prenex_instantiation : forall n s t s' t',
  contains (quantify_formula n (arr s t)) (arr s' t') -> lc n t ->
  exists (f : nat -> option formula), t' = instantiate_prenex f t
  /\ (forall m, (m < n -> exists (u : formula), f m = Some u /\ lc 0 u))
  /\ (forall m, n <= m -> f m = None).
Proof.
elim.
(*base case n = 0*)
intros *.
inversion. intros.
exists (fun _ => None).
split.
apply eq_sym.
eapply Lc.instantiate_prenex_eq; last done. eassumption. split; [intros; omega | auto].
(*inductive case n > 0*)
simpl.
intros * => IH; intros.
gimme contains; inversion.
match goal with | [_ : lc 0 ?s |- _] => rename s into u end.
gimme contains; rewrite instantiate_quantification.
(have : n + 0 = n by omega) => ->.
(*have : n + 0 = n by omega.*)
simpl.
case /IH; first (apply : Lc.instantiate_pred; assumption).
move => f [H21 [H221 H222]].

(*pose f' m := if Nat.eq_dec m n then s0 else f m.*)
(*pose f' m := if Nat.compare m n is Eq then s0 else f m.*)

exists (fun m => if m =? n then Some u else f m).
subst.
split.

apply : instantiate_prenex_after_instantiate => //.
split => m.

have H' : m < 1 + n -> m = n \/ m < n by omega.
case /H' {H'}; intros; inspect_eqb; [exists u | ]; auto.

(*case m > n*)
intros. have : n <= m by omega.
inspect_eqb; auto.
Qed.

Lemma contains_prenex_instantiation : forall (f : nat -> option formula) (n : nat) (t : formula),
  lc n t ->
  (forall (m : nat), m < n -> exists (s : formula), f m = Some s /\ lc 0 s) ->
  contains (quantify_formula n t) (instantiate_prenex f t).
Proof.
move => f. elim.
(*base case n = 0*)
intros.
rewrite -> (Lc.instantiate_prenex_eq (n:=0));
  [constructor | assumption | intros; omega].
(*inductive case n > 0*)
move => n IH t ? Hf.
move /(_ n ltac:(omega)) : (Hf) => [s [Hfn Hs]].
cbn.
apply : contains_trans; first eassumption.
rewrite instantiate_quantification.
(have : n + 0 = n by omega) => ->.
have ? : lc n (instantiate s n t) by apply : Lc.instantiate_pred; auto.
have := @instantiate_prenex_after_instantiate t s n f f Hs.
nip.
move => n'; have := Nat.eq_dec n' n; case => ?; inspect_eqb; subst; auto.
move => <-.
apply : IH; auto.
Qed.

Fixpoint formula_label_bound (s : formula) : nat :=
  match s with
  | (var n) => 0
  | (atom (x, y)) => 1 + y
  | (arr t u) => 1 + (formula_label_bound t) + (formula_label_bound u)
  | (quant t) => 1 + (formula_label_bound t)
  end.

Lemma fresh_in_quantified : forall (n : nat) (a : label) (s : formula), fresh_in a s -> fresh_in a (quantify_formula n s).
Proof.
elim; eauto using fresh_in.
Qed.

(*try to assert freshness in a given type*)
Ltac inspect_freshness := do ? (do [constructor | case; omega | apply : fresh_in_quantified]).

Lemma exists_fresh : forall (formulae : list formula),
  exists (a : label), Forall (fresh_in a) formulae.
Proof.
move => formulae.

have n := 0.
exists (4, (fold_left Nat.add (map formula_label_bound formulae) n)).
elim : formulae n.
auto.

move => s formulae IH n.
cbn.
constructor; last auto.
clear.

elim : s n; cbn.
(*case var*) eauto using fresh_in.
(*case atom*)

move => a n.
apply fresh_in_atom.
rewrite -> (surjective_pairing a).
case => _.
have := @fold_sum_gt (map formula_label_bound formulae) (n + S (snd a)) (snd a).
lia.

(*case arr*)
move => s ? t ? n.
apply fresh_in_arr.
have : (n + S (formula_label_bound s + formula_label_bound t)) =
((1 + n + formula_label_bound t) + (formula_label_bound s)) by omega.
move => ->; auto.
have : (n + S (formula_label_bound s + formula_label_bound t)) =
((1 + n + formula_label_bound s) + (formula_label_bound t)) by omega.
move => ->; auto.

(*case quant*)
move => s ? n.
apply : fresh_in_quant.
have : (n + S (formula_label_bound s)) =
(1 + n + (formula_label_bound s)) by omega.
move => ->; auto.
Qed.

Lemma substitute_instantiation : forall (t s : formula) (a b : label) (n : nat),
  instantiate (substitute_label a b s) n (substitute_label a b t) = substitute_label a b (instantiate s n t).
Proof.
elim; cbn.
move => n ? ? ? n' *; case : (n' =? n) => //.
move => c ? a *; case : (Label.eqb a c) => //.
all : cbn; intros; f_equal; eauto.
Qed.

Lemma lc_substitute : forall (s : formula) (a b : label) (n : nat),
  lc n s -> lc n (substitute_label a b s).
Proof.
elim; cbn.
(*case var*) auto.
(*case atom*) intros; rewrite if_fun; constructor.
(*case arr/quant*)
all : intros; gimme lc; inversion; eauto using lc.
Qed.

Lemma rename_instantiation : forall (s : formula) (n : nat) (a b : label),
  fresh_in a s -> substitute_label a b (instantiate (atom a) n s) = instantiate (atom b) n s.
Proof.
elim; cbn.
intros.
case : (n0 =? n); cbn; try (rewrite -> (iffRL (Label.eqb_eq _ _))); auto.

all: intros; gimme fresh_in; inversion.

rewrite -> Label.neq_neqb; auto.

all: f_equal; auto.
Qed.

Lemma instantiate_renaming_eq : forall (t : formula) (a b c : label) (n : nat),
  c <> a -> c <> b -> fresh_in c t ->
  (instantiate (atom a) n (substitute_label a b t)) = substitute_label c a (substitute_label a b (instantiate (atom c) n t)).
Proof.
elim; cbn.

(*case var*)
intros.
case : (Nat.eq_dec n n0); cbn; intros; inspect_eqb; cbn => //.
rewrite -> Label.neq_neqb; auto.
cbn. rewrite -> (iffRL (Label.eqb_eq _ _)); auto.

(*case atom*)
intros.
cbn.
rewrite if_fun.
cbn.
gimme fresh_in; inversion.
case : (Label.eqb a l); rewrite -> Label.neq_neqb; auto.

(*case arr*)
intros.
gimme shape (fresh_in c (arr _ _)); inversion.
cbn; f_equal; eauto.

(*case quant*)
intros.
gimme shape (fresh_in c (quant _)); inversion.
cbn; f_equal; eauto.
Qed.

(*auxiliary predicate for induction on depth*)
Inductive contains_depth : nat -> formula → formula → Prop :=
  | contains_depth_rfl : ∀ (s: formula), contains_depth 0 s s
  | contains_depth_trans : ∀ (n : nat) (s t u: formula), lc 0 s → contains_depth n (instantiate s 0 u) t → contains_depth (1+n) (quant u) t.

Lemma contains_exists_depth : forall s t, contains s t -> exists n, contains_depth n s t.
Proof.
move => s t.
elim.

intros.
exists 0.
constructor.

intros.
move : H1 => [n H'].
exists (1+n).
eauto using contains_depth.
Qed.

Lemma contains_erase_depth : forall s t n, contains_depth n s t -> contains s t.
Proof.
intros *.
elim; eauto using contains.
Qed.

Lemma substitute_contains : forall (s t : formula) (a b: label),
  contains s t -> contains (substitute_label a b s) (substitute_label a b t).
Proof.
intros *.
move /contains_exists_depth => [n ?].
gimme contains_depth. do 2 (gimme formula). gimme nat.
elim.
intros; gimme contains_depth; inversion; eauto using contains.

intros * => IH.
intros *; inversion.
cbn.
gimme lc. move /(lc_substitute a b) => ?.
apply : contains_trans.
eassumption.
rewrite substitute_instantiation.
apply : (IH).
assumption.
Qed.

Lemma instantiate_renaming_neq : forall (s : formula) (n : nat) (a b c : label), a <> c ->
  instantiate (atom c) n (substitute_label a b s) = substitute_label a b (instantiate (atom c) n s).
Proof.
elim; cbn.
(*case var*)
move => n n' *.
case : (n' =? n) => //.
cbn; rewrite -> Label.neq_neqb => //.

(*case atom*) move => d ? a *; case : (Label.eqb a d ) => //.
(*case arr/quant*) all: intros; f_equal; auto.
Qed.

Lemma substitute_chain : forall (s : formula) (params : list formula) (a b c : label),
  chain s c params -> chain (substitute_label a b s) (if Label.eqb a c then b else c) (map (substitute_label a b) params).
Proof.
intros *.
elim; cbn; intros.

constructor.
gimme contains; move /(substitute_contains a b).
rewrite <- if_fun.
apply.

apply : (chain_cons (u := substitute_label a b u)).
gimme contains; apply /(substitute_contains a b).
assumption.
Qed.

Lemma substitute_fresh_label : forall (s : formula) (a b : label),
  fresh_in a s -> s = substitute_label a b s.
Proof.
elim; cbn.
auto.
all : intros; gimme fresh_in; inversion; (try (f_equal; auto)).
rewrite -> Label.neq_neqb => //.
Qed.

Lemma map_substitute_fresh_label : forall (a b : label) (Γ : list formula), Forall (fresh_in a) Γ -> Γ = (map (substitute_label a b) Γ).
Proof.
move => a b.
elim => //.
cbn.
intros.
have ? := substitute_fresh_label.
decompose_Forall.
f_equal; auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e256m2e32m977_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(* FIXME: Copied these from pset4; probably won't need all of them. *)
Require Import Bool Arith List Omega ListSet.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Sorting.Permutation.
Import ListNotations.
Require Import OrderedType.

Module NatMap := FMapList.Make Nat_as_OT.
Module NatMapFacts := FMapFacts.WFacts_fun Nat_as_OT NatMap.

Section MachineModel.
  Definition var : Type := nat.

  Definition condition : Type := nat.
  Inductive location : Type :=
  | Not_cnd : nat -> location
  | Cnd : condition -> location.

  Inductive ref_type : Set :=
  | Mut
  | Immut.

  Definition is_Cnd (l: location) : Prop :=
    match l with
    | Not_cnd _ => False
    | Cnd _ => True
    end.
  Definition is_Not_cnd (l: location) : Prop :=
    match l with
    | Not_cnd _ => True
    | Cnd _ => False
    end.
  Definition locations_eq l1 l2: bool :=
    match l1, l2 with
    | Not_cnd n, Not_cnd n' => n =? n'
    | Cnd c, Cnd c' => c =? c'
    | _, _ => false
    end.

  Definition register (value_t: Type) : Type := var -> value_t.
  Definition memory (value_t: Type) : Type := location -> value_t.

  Definition update {B: Type} (f: nat -> B) (x: nat) (y: B) :=
    fun x0 => if x =? x0 then y else f x0.
End MachineModel.

Section Security.
  Inductive sec_level : Set :=
  | L : sec_level
  | H : sec_level
  | T : sec_level.

  Inductive sec_level_rel : relation sec_level :=
  | sec_level_l_rel : sec_level_rel L H
  | sec_level_h_rel : sec_level_rel H T.

  Definition sec_level_le := clos_refl_trans sec_level sec_level_rel.

  Global Instance sec_level_le_refl : Reflexive sec_level_le.
  intro sl; destruct sl; unfold sec_level_le; apply rt_refl.
  Defined.

  Global Instance sec_level_le_trans : Transitive sec_level_le.
  intros sl1 sl2 sl3;  unfold sec_level_le; intros.
  apply rt_trans with (y:=sl2); auto.
  Defined.

  Lemma sec_level_le_dec : forall sl sl', {sec_level_le sl sl'} + {sec_level_le sl' sl}.
  Proof.
    intros; destruct sl, sl'; intuition;
      [left|left|right|left|right|right]; unfold sec_level_le.
    apply rt_step; apply sec_level_l_rel.
    apply rt_trans with (y := H); apply rt_step; [apply sec_level_l_rel | apply sec_level_h_rel].
    apply rt_step; apply sec_level_l_rel.
    apply rt_step; apply sec_level_h_rel.
    apply rt_trans with (y := H); apply rt_step; [apply sec_level_l_rel | apply sec_level_h_rel].
    apply rt_step; apply sec_level_h_rel.
  Qed.

  Definition sec_level_le_compute (sl sl': sec_level) :=
    match sl, sl' with
      | H, L | T, L | T, H => false
      | _, _ => true
    end.
  Lemma sec_level_le_correct (sl sl': sec_level) :
    sec_level_le_compute sl sl' = true <-> sec_level_le sl sl'.
  Proof.
    destruct sl, sl'; intuition; try discriminate; unfold sec_level_le in *.
    apply rt_step. constructor.
    apply rt_trans with (y := H); apply rt_step; constructor.
    (* XXX why is it so hard to prove that sec_level_le H L is False? *)
  Admitted.

  Definition sec_level_join (sl sl': sec_level) : sec_level :=
    match sl, sl' with
    | T, _ | _, T => T
    | H, _ | _, H => H
    | L, L => L
    end.

  Inductive policy0 : Type :=
  | LevelP : sec_level -> policy0
  | ErasureP (l1: sec_level) (cnd: condition) (l2: sec_level)
             (l1_le_l2: sec_level_le l1 l2) : policy0.

  Inductive policy0_le : relation policy0 :=
  | BPLE1 : forall l1 l2,
      sec_level_le l1 l2 ->
      policy0_le (LevelP l1) (LevelP l2)
  | BPLE2 : forall p1 l2 l2' cnd pf,
      policy0_le p1 (LevelP l2) ->
      policy0_le p1 (ErasureP l2 cnd l2' pf)
  | BPLE3 : forall l1 l1' p2 cnd pf,
      policy0_le (LevelP l1') p2 ->
      policy0_le (ErasureP l1 cnd l1' pf) p2
  | BPLE4 : forall l1 l1' l2 l2' cnd pf1 pf2,
      sec_level_le l1 l2 ->
      sec_level_le l1' l2' ->
      policy0_le (ErasureP l1 cnd l1' pf1) (ErasureP l2 cnd l2' pf2).

  Definition ub x y z := policy0_le x z /\ policy0_le y z.

  Definition lub x y z :=
    ub x y z /\ (forall z0, ub x y z0 -> policy0_le z z0).

  Inductive policy : Type :=
  | SingleP : policy0 -> policy
  | JoinP : policy -> policy -> policy.

  Inductive pdenote : policy -> policy0 -> Prop :=
  | Psingle : forall p0, pdenote (SingleP p0) p0
  | Pjoin : forall p p0 p' p'0 q,
      pdenote p p0 ->
      pdenote p' p'0 ->
      lub p0 p'0 q ->
      pdenote (JoinP p p') q.

  Definition sec_spec : Type :=  location -> policy.

  Definition policy_le (p q: policy) : Prop :=
    forall p0 q0,
      pdenote p p0 ->
      pdenote q q0 ->
      policy0_le p0 q0.

  Definition liftp p := SingleP p.
  Definition low := SingleP (LevelP L).

  (* XXX might need axioms about sec policy lattice. *)

  (*
  Lemma policy_le_refl : reflexive sec_policy policy_le.
  Proof.
    intro x. destruct x.
    - apply PLE1. apply sec_level_le_refl.
    - apply PLE4; apply sec_level_le_refl.
    -
  Qed.

  Lemma policy_le_antisymmetric : antisymmetric sec_policy policy_le.
  Proof.
  Admitted.

  Lemma policy_le_transitive : transitive sec_policy policy_le.
  Proof.
  Admitted.

  Lemma policy_le_partial_order : order sec_policy policy_le.
  Proof.
    split.
    - apply policy_le_refl.
    - apply policy_le_transitive.
    - apply policy_le_antisymmetric.
  Qed.

  Parameter policy_join : sec_policy -> sec_policy -> sec_policy.
  Axiom policy_le_join : forall p1 p2,
      policy_le p1 (policy_join p1 p2) /\ policy_le p2 (policy_join p1 p2).
  *)
  Function cur (p : policy0) (U : set condition) : sec_level :=
    match p with
    | LevelP l => l
    | ErasureP l1 cnd l2 _ => if (set_mem Nat.eq_dec cnd U) then l1 else l2
    end.
(*
  Inductive protected : sec_policy -> set condition -> Prop :=
  | level_high: forall S, protected (LevelP H) S
  | level_top: forall S, protected (LevelP T) S
  | erase_high: forall cnd S sl pf,
      protected (ErasureP H cnd sl pf) S
  | erase_low: forall cnd S sl pf,
      set_In cnd S -> protected (ErasureP L cnd sl pf) S.
  *)

End Security.

Lemma nth_pres_map {A B: Type} i (xs: list A) (f: A -> B) y z :
    i < length xs ->
    nth i (map f xs) y = f (nth i xs z).
Proof.
  revert xs. induction i; intros; destruct xs; simpl in *.
  - omega.
  - auto.
  - inversion H0.
  - apply lt_S_n in H0. auto.
Qed.

Lemma nth_map_default {A B: Type}: forall i (xs: list A) (x: B),
    nth i (map (fun _ => x) xs) x = x.
Proof.
  induction i; destruct xs; simpl; auto.
Qed.


Require Export TransFunc.

Section ModelProperties.

(*This is the defintion of a secure state from the DAC security      *)
(*policy point of view.                                              *)

Definition DACSecureState (s : SFSstate) : Prop :=
  forall (eSub : ENTITY) (eObj : ENTITY),
  match fsecmat (secmat s) eSub with
  | None => True
  | Some y =>
      (set_In eObj (EntReadingList y) -> PreDACRead s eSub eObj) /\
      (set_In eObj (EntWritingList y) -> PreDACWrite s eSub eObj)
  end.

(*This is the defintion of a secure state from the MAC security      *)
(*policy point of view. It says that an state is MAC secure if for   *)
(*each ENTITY accesing an ENTITY, the security class of the former  *)
(*is dominates the security class of the ENTITY.                     *)

Definition MACSecureState (s : SFSstate) : Prop :=
  forall (eSub : ENTITY) (eObj : ENTITY),
  match fsecmat (secmat s) eSub, fESC (entitySC s) eObj, fESC (entitySC s) eSub with
  | None, _, _ => True
  | _, None, _ => True
  | _, _, None => True
  | Some x, Some y, Some z =>
      set_In eObj (EntReadingList x) \/ set_In eObj (EntWritingList x) -> le_sc y z
  end.

(*An state is secure if it's both DAC and MAC secure.                *)

Definition SecureState (s : SFSstate) : Prop :=
  DACSecureState s /\ MACSecureState s.

(*This is the definition of the *-property adapted from the          *)
(*Bell-LaPadula's model. It says that whenever a ENTITY is accesing *)
(*an ENTITY for reading and, possibly, another ENTITY for writing,   *)
(*then the security class of any ENTITY that is being open for       *)
(*reading must be dominated by the security class of any             *)
(*of those ENTITYs that are already open for writing.                *)

Definition StarProperty (s : SFSstate) : Prop :=
  forall (eSub : ENTITY) (eObj1 eObj2 : ENTITY),
  match
    fsecmat (secmat s) eSub, fESC (entitySC s) eObj2, fESC (entitySC s) eObj1
  with
  | None, _, _ => True
  | _, None, _ => True
  | _, _, None => True
  | Some x, Some y, Some z =>
      set_In eObj1 (EntWritingList x) -> set_In eObj2 (EntReadingList x) -> le_sc y z
  end.

(*We also want operations that deal securely with control            *)
(*attributes, i.e. the owners of an ACL, the security class          *)
(*associated with ENTITYs and ENTITYs, etc.                         *)
(*Informally, the policy says that the owner of an ENTITY or a       *)
(*member of RootGrp are the only allowed to change the DAC           *)
(*control attributes associated with the ENTITY; that the members    *)
(*of SecAdmGrp are the ones that can change the MAC control          *)
(*attributes associated with ENTITYs and ENTITYs; and that RootGrp  *)
(*must always be owner of all ENTITYs.                               *)

Inductive CapabilityChanged : CapabilityData -> CapabilityData -> Prop :=
  | ER :
      forall (a : CapabilityData) (b c : set ENTITY),
      b <> c ->
      CapabilityChanged
        (capdata b (CanWriteEntities a))
        (capdata c (CanWriteEntities a))
  | EW :
      forall (a : CapabilityData) (b c : set ENTITY),
      b <> c ->
      CapabilityChanged
        (capdata (CanReadEntities a) b)
        (capdata (CanReadEntities a) c).

Inductive DACCtrlAttrHaveChanged (s t : SFSstate) (e : ENTITY) : Prop :=
  | Capabilities :
      forall y z : CapabilityData,
      fcap (cap s) e = Some y ->
      fcap (cap t) e = Some z ->
      CapabilityChanged y z -> DACCtrlAttrHaveChanged s t e.

Inductive SecClassChanged : SecClass -> SecClass -> Prop :=
  | Level :
      forall (a : SecClass) (b c : set CATEGORY),
      b <> c -> SecClassChanged (sclass (level a) b) (sclass (level a) c)
  | Categ :
      forall (a : SecClass) (b c : SECLEV),
      b <> c -> SecClassChanged (sclass b (categs a)) (sclass c (categs a)).

Inductive MACEntCtrlAttrHaveChanged (s t : SFSstate) (e : ENTITY) : Prop :=
    SCe :
      forall x y : SecClass,
      fESC (entitySC s) e = Some x ->
      fESC (entitySC t) e = Some y ->
      SecClassChanged x y -> MACEntCtrlAttrHaveChanged s t e.

(*对应原来的WFSI3*)
Axiom
  WFSI1 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (e : ENTITY),
    DOM ENTeq_dec (cap s) =
    DOM ENTeq_dec (entitycontent s) ->
    TransFunc e s op t ->
    DOM ENTeq_dec (cap t) =
    DOM ENTeq_dec (entitycontent t).

Definition FuncPre1 (s : SFSstate) : Prop :=
  DOM ENTeq_dec (cap s) =
  DOM ENTeq_dec (entitycontent s).

(*对应原来的WFSI4*)
Axiom
  WFSI2 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (e : ENTITY),
    DOM ENTeq_dec (cap s) = DOM ENTeq_dec (entitySC s) ->
    TransFunc e s op t -> DOM ENTeq_dec (cap t) = DOM ENTeq_dec (entitySC t).

Definition FuncPre2 (s : SFSstate) : Prop :=
  DOM ENTeq_dec (cap s) = DOM ENTeq_dec (entitySC s).

(*对应原来的WFSI5*)
Axiom
  WFSI3 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (e : ENTITY),
    Included (DOM ENTeq_dec (secmat s)) (DOM ENTeq_dec (cap s)) ->
    TransFunc e s op t ->
    Included (DOM ENTeq_dec (secmat t)) (DOM ENTeq_dec (cap t)).

Definition FuncPre3 (s : SFSstate) : Prop :=
  Included (DOM ENTeq_dec (secmat s)) (DOM ENTeq_dec (cap s)).

(*对应原来的WFSI6*)
Axiom
  WFSI4 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (e : ENTITY),
    IsPARTFUNC ENTeq_dec (cap s) ->
    TransFunc e s op t -> IsPARTFUNC ENTeq_dec (cap t).

Definition FuncPre4 (s : SFSstate) : Prop := IsPARTFUNC ENTeq_dec (cap s).

(*对应原来的WFSI7*)
Axiom
  WFSI5 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (e : ENTITY),
    IsPARTFUNC ENTeq_dec (secmat s) ->
    TransFunc e s op t -> IsPARTFUNC ENTeq_dec (secmat t).

Definition FuncPre5 (s : SFSstate) : Prop := IsPARTFUNC ENTeq_dec (secmat s).

(*对应原来的WFSI8*)
Axiom
  WFSI6 :
    forall (s : SFSstate) (op : Operation) (t : SFSstate) (e : ENTITY),
    IsPARTFUNC ENTeq_dec (entitySC s) ->
    TransFunc e s op t -> IsPARTFUNC ENTeq_dec (entitySC t).

Definition FuncPre6 (s : SFSstate) : Prop :=
  IsPARTFUNC ENTeq_dec (entitySC s).

End ModelProperties.

Hint Unfold SecureState DACSecureState MACSecureState.

Hint Resolve ER EW Level Categ.
Hint Resolve WFSI1 WFSI2 WFSI3 WFSI4 WFSI5 WFSI6.


Require Export Tukey_Lemma.

(* The Proof of Axiom of Choice *)

Module Type AC_Proof.

Declare Module Tu : Tukey_Lemma.

(* Special form of Choice Function *)

Definition Choice_Function' ε u : Prop :=
  Ensemble u /\ Function ε /\ dom(ε) = u /\ ran(ε) ⊂ ∪u
  /\ (forall x, x ∈ dom(ε) -> ε[x] ∈ x).

(* Hypotheses *)

Definition En_f X :=
  \{ λ g, exists A, A ⊂ (pow(X)~[Φ]) /\ Choice_Function' g A \}.

(* Properties *)

Lemma Property_CF x : Ensemble x -> Choice_Function' Φ Φ.
Proof.
  intros.
  unfold Choice_Function'; repeat split; intros.
  - generalize (Theorem26 x); intros.
    apply Theorem33 in H0; auto.
  - unfold Relation; intros.
    generalize (Theorem16 z); contradiction.
  - destruct H0; generalize (Theorem16 ([x0,y])).
    intros; contradiction.
  - apply AxiomI; split; intros.
    + unfold Domain in H0; apply AxiomII in H0; destruct H0, H1.
      generalize (Theorem16 ([z,x0])); contradiction.
    + generalize (Theorem16 z); contradiction.
  - unfold Included; intros; unfold Range in H0.
    apply AxiomII in H0; destruct H0, H1.
    generalize (Theorem16 ([x0,z])); contradiction.
  - unfold Domain in H0; apply AxiomII in H0; destruct H0, H1.
    generalize (Theorem16 ([x0,x1])); contradiction.
Qed.

Lemma Included_Function : forall (g f: Class),
  Function g /\ Function f /\ g ⊂ f -> (dom(g) ⊂ dom(f))
  /\ (forall x, x ∈ dom(g) -> g[x] = f[x]).
Proof.
  intros.
  destruct H, H0.
  unfold Included in H1; split.
  - unfold Included; intros.
    unfold Domain in H2; apply AxiomII in H2; destruct H2, H3.
    unfold Domain; apply AxiomII; split; auto.
    exists x; apply H1 in H3; auto.
  - intros; apply Property_Value in H2; auto.
    apply H1 in H2; apply Theorem70 in H0; auto.
    rewrite H0 in H2; apply AxiomII_P in H2; apply H2.
Qed.

(* Lemma *)

Lemma Lemma_Fin_not_Em : forall X,
  Ensemble X -> FiniteSet (En_f X) /\ (En_f X) ≠ Φ.
Proof.
  intros.
  assert ((En_f X) ≠ Φ).
  { apply Property_NotEmpty; auto.
    exists Φ; unfold En_f; apply AxiomII; split.
    - assert (Φ ⊂ X); try apply Theorem26.
      apply Theorem33 in H0; auto.
    - exists Φ; split; try apply Theorem26.
      apply (Property_CF X); auto. }
  split; auto; unfold FiniteSet; repeat split; intros.
  - assert (En_f X ⊂ pow(pow(X) × (∪pow(X)))).
    { unfold Included; intros.
      unfold En_f in H1; apply AxiomII in H1; destruct H1.
      destruct H2 as [A H2]; destruct H2.
      assert (pow(X) ~ [Φ] ⊂ pow(X)).
      { unfold Setminus, Included; intros.
        apply Theorem4' in H4; apply H4. }
      add (pow(X)~[Φ] ⊂ pow( X)) H2; apply Theorem28 in H2.
      unfold Choice_Function' in H3; destruct H3, H5, H6, H7.
      unfold PowerSet at 1; apply AxiomII; split.
      - rewrite <- H6 in H3; apply Theorem75; auto.
      - unfold Included; intros; unfold Cartesian.
        PP' H10; apply AxiomII_P; repeat split; Ens.
        + apply Property_dom in H9; rewrite H6 in H9.
          unfold Included in H2; apply H2; auto.
        + apply Property_ran in H9.
          unfold Included in H7; apply H7 in H9.
          apply Theorem31 in H2; destruct H2.
          unfold Included in H2; apply H2; auto. }
    apply Theorem38 in H; auto; double H.
    apply AxiomVI in H2; add (Ensemble (∪ pow( X))) H.
    apply Theorem74 in H; apply Theorem38 in H; auto.
    apply Theorem33 in H1; auto.
  - destruct H2; unfold En_f in H1; unfold En_f.
    apply AxiomII in H1; apply AxiomII; destruct H1.
    destruct H4 as [D H4], H4; unfold Choice_Function' in H5.
    destruct H5, H6, H7, H8; split.
    + apply Theorem33 in H2; auto.
    + generalize (classic (z=Φ)); intros; destruct H10.
      * exists Φ; split; try apply Theorem26.
        rewrite H10; apply (Property_CF X); auto.
      * assert (Function z).
        { unfold Function in H6; destruct H6.
          unfold Function; split; intros.
          - unfold Relation in H6; unfold Relation; intros.
            unfold Included in H2; apply H2 in H12.
            apply H6 in H12; destruct H12, H12; exists x, x0; auto.
          - destruct H12; unfold Included in H2.
            apply H2 in H12; apply H2 in H13.
            add ([x,z0] ∈ F) H12; apply H11 in H12; auto. }
        double H11; add (Function F /\ z⊂F) H11.
        apply Included_Function in H11; destruct H11.
        exists (dom(z)); split.
        -- rewrite H7 in H11; add (D ⊂ pow(X)~[Φ]) H11.
           apply Theorem28 in H11; auto.
        -- { unfold Choice_Function'; repeat split; try apply H12; auto.
             - rewrite H7 in H11; apply Theorem33 in H11; auto.
             - unfold Included; intros.
               unfold Element_U; apply AxiomII.
               unfold Range in H14; apply AxiomII in H14.
               destruct H14, H15; double H15; split; auto.
               apply Theorem70 in H12; auto.
               rewrite H12 in H15; apply AxiomII_P in H15.
               apply Property_dom in H16; destruct H15.
               exists x; split; auto; rewrite H17; double H16.
               unfold Included in H11; apply H11 in H16.
               apply H9 in H16; apply H13 in H18; rewrite H18; auto.
             - intros; double H14.
               unfold Included in H11; apply H11 in H14.
               apply H9 in H14; apply H13 in H15; rewrite H15; auto. }
  - intros; destruct H1.
    unfold En_f; apply AxiomII; split; auto.
    assert (F ⊂ ∪(En_f X) /\ ∪(En_f X) ⊂ ((pow( X) ~ [Φ]) × X)).
    { split.
      - unfold Included; intros; AssE z.
        unfold Element_U; apply AxiomII; split; auto.
        exists [z]; split.
        + unfold Singleton; apply AxiomII; split; auto.
        + apply H2; split; try apply Finite_Single; auto.
          unfold Included; intros; unfold Singleton in H5; apply AxiomII in H5.
          destruct H5; apply Theorem19 in H4; apply H6 in H4; rewrite H4; auto.
      - unfold Included; intros.
        unfold Element_U in H3; apply AxiomII in H3.
        destruct H3, H4 as [f1 H4], H4.
        unfold Cartesian; apply (Property_P' _); intros.
        rewrite H6; rewrite H6 in H3; rewrite H6 in H4.
        apply AxiomII_P; split; auto.
        unfold En_f in H5; apply AxiomII in H5.
        destruct H5, H7 as [A H7], H7.
        unfold Choice_Function' in H8.
        destruct H8, H9, H10, H11; split.
        + apply Property_dom in H4; rewrite H10 in H4.
          unfold Included in H7; apply H7 in H4; auto.
        + apply Property_ran in H4.
          unfold Included in H11; apply H11 in H4.
          unfold Element_U in H4; apply AxiomII in H4.
          destruct H4, H13, H13.
          unfold Included in H7; apply H7 in H14.
          unfold Setminus in H14; apply Theorem4' in H14; destruct H14.
          unfold PowerSet in H14; apply AxiomII in H14; destruct H14.
          unfold Included in H16; apply H16 in H13; auto. }
    elim H3; intros; apply Theorem28 in H3.
    generalize (classic (F = Φ)); intros; destruct H6.
    + exists Φ; split; try apply Theorem26.
      rewrite H6; apply (Property_CF X); auto.
    + assert (Function F).
      { unfold Function, Relation; split; intros.
        - unfold Included in H3; apply H3 in H7; PP H7 a b; Ens.
        - destruct H7.
          assert ([[x,y]|[x,z]] ⊂ F /\ Finite ([[x,y]|[x,z]])).
          { unfold Included, Unordered; split; intros.
            - apply AxiomII in H9; destruct H9, H10.
              + unfold Singleton in H10; apply AxiomII in H10.
                destruct H10; rewrite H11; auto; apply Theorem19; Ens.
              + unfold Singleton in H10; apply AxiomII in H10.
                destruct H10; rewrite H11; auto; apply Theorem19; Ens.
            - apply Theorem168; split; apply Finite_Single; Ens. }
          apply H2 in H9; unfold En_f in H9; apply AxiomII in H9.
          destruct H9, H10, H10; unfold Choice_Function' in H11.
          destruct H11, H12, H13; unfold Function in H12.
          apply H12 with (x0:=x); split; unfold Unordered; apply AxiomII.
          + split; try left; Ens; unfold Singleton; apply AxiomII; Ens.
          + split; try right; Ens; unfold Singleton; apply AxiomII; Ens. }
      exists dom(F); split.
      * unfold Included; intros; apply Property_Value in H8; auto.
        unfold Included in H3; apply H3 in H8.
        unfold Cartesian in H8; apply AxiomII_P in H8; apply H8.
      * { unfold Choice_Function'; repeat split; try apply H7; auto; intros.
          - assert (dom(F) ⊂ pow(X)).
            { unfold Included; intros.
              unfold Domain in H8; apply AxiomII in H8; destruct H8, H9.
              unfold Included in H3; apply H3 in H9.
              unfold Cartesian in H9; apply AxiomII_P in H9; destruct H9, H10.
              unfold Setminus in H10; apply Theorem4' in H10; apply H10. }
            apply Theorem33 in H8; apply Theorem38 in H; auto.
          - unfold Included; intros; apply AxiomII; split; Ens.
            unfold Range in H8; apply AxiomII in H8; destruct H8, H9.
            double H9; exists x; apply Property_dom in H9; split; auto.
            unfold Element_U in H4; apply H4 in H10.
            apply AxiomII in H10; destruct H10, H11 as [f H11], H11.
            unfold En_f in H12; apply AxiomII in H12; destruct H12, H13, H13.
            unfold Choice_Function' in H14; destruct H14, H15, H16, H17.
            double H11; apply Property_dom in H19; double H19.
            apply Property_Value in H20; auto; apply H18 in H19.
            add ([x,z] ∈ f) H20; unfold Function in H15.
            apply H15 in H20; rewrite H20 in H19; auto.
          - apply Property_Value in H8; auto; apply H4 in H8.
            unfold Element_U in H8; apply AxiomII in H8.
            destruct H8, H9 as [f H9], H9; unfold En_f in H10.
            apply AxiomII in H10; destruct H10, H11, H11.
            unfold Choice_Function' in H12; destruct H12, H13, H14, H15.
            double H9; apply Property_dom in H17; double H17.
            apply H16 in H17; apply Property_Value in H18; auto.
            add ([x,F[x]] ∈ f) H18; unfold Function in H13.
            apply H13 in H18; rewrite H18 in H17; auto. }
Qed.

Theorem Tukey_Choice : forall X,
  Ensemble X -> exists ε, Choice_Function ε X.
Proof.
  intros.
  double H; apply Lemma_Fin_not_Em in H0.
  apply Tu.Tukey in H0; destruct H0 as [F H0]; exists F.
  assert ((En_f X) ≠ Φ).
  { apply Property_NotEmpty; exists Φ; unfold En_f; apply AxiomII; split.
    - assert (Φ ⊂ X); try apply Theorem26; apply Theorem33 in H1; auto.
    - exists Φ; split; try apply Theorem26; apply (Property_CF X); auto. }
  unfold MaxMember in H0; apply H0 in H1; clear H0.
  assert (Ensemble (En_f X)).
  { assert (En_f X ⊂ pow(pow(X) × (∪pow(X)))).
    { clear H1; unfold Included; intros; unfold En_f in H0.
      apply AxiomII in H0; destruct H0, H1 as [A H1]; destruct H1.
      assert (pow(X) ~ [Φ] ⊂ pow(X)).
      { unfold Setminus, Included; intros; apply Theorem4' in H3; apply H3. }
      add (pow(X)~[Φ] ⊂ pow( X)) H1; apply Theorem28 in H1.
      unfold Choice_Function' in H2; destruct H2, H4, H5, H6.
      unfold PowerSet at 1; apply AxiomII; split.
      - rewrite <- H5 in H2; apply Theorem75; auto.
      - unfold Included; intros; unfold Cartesian.
        PP' H9; apply AxiomII_P; repeat split; Ens.
        + apply Property_dom in H8; rewrite H5 in H8; apply H1; auto.
        + apply Property_ran in H8; unfold Included in H6; apply H6 in H8.
          apply Theorem31 in H1; destruct H1; apply H1; auto. }
    apply Theorem38 in H; auto; double H; apply AxiomVI in H2.
    add (Ensemble (∪ pow( X))) H; apply Theorem74 in H.
    apply Theorem38 in H; auto; apply Theorem33 in H0; auto. }
  destruct H1; double H1; unfold En_f in H3; apply AxiomII in H3.
  destruct H3, H4 as [D H4], H4; apply Property_ProperSubset in H4; destruct H4.
  - double H4; apply Property_ProperSubset' in H6; destruct H6 as [E H6], H6.
    double H6; unfold Setminus in H8; apply Theorem4' in H8; destruct H8.
    clear H8; unfold Complement in H9; apply AxiomII in H9; destruct H9.
    unfold NotIn in H9; assert (E ∈ [Φ] <-> Ensemble E /\ (E=Φ)).
    { split; intros.
      - unfold Singleton in H10; apply AxiomII in H10; destruct H10.
        split; auto; apply H11; apply Theorem19.
        generalize (Theorem26 E); intros; apply Theorem33 in H12; auto.
      - destruct H10; unfold Singleton; apply AxiomII; split; auto. }
    apply definition_not in H10; auto; clear H9.
    apply not_and_or in H10; destruct H10; try contradiction.
    apply Property_NotEmpty in H9; destruct H9 as [e H9].
    cut ((F ∪ [[E,e]])∈ (En_f X) /\ F ⊊ (F ∪ [[E,e]])); intros.
    { destruct H10; apply H2 in H10; contradiction. }
    assert (Ensemble ([E,e])). { apply Theorem49; split; Ens. }
    unfold Choice_Function' in H5; destruct H5, H11, H12, H13.
    assert (F ⊊ (F ∪ [[E,e]])).
    { unfold ProperSubset; split.
      - unfold Included; intros; apply Theorem4; left; auto.
      - intro; rewrite <- H12 in H7; assert ([E,e]∈F).
        { rewrite H15; apply Theorem4; right.
          unfold Singleton; apply AxiomII; split; auto. }
        apply Property_dom in H16; contradiction. }
    split; auto; unfold En_f; apply AxiomII; split.
    + apply AxiomIV; split; auto; apply Theorem42; auto.
    + { exists (D ∪ [E]); split.
        - unfold Included; intros; apply Theorem4 in H16; destruct H16.
          + unfold ProperSubset in H4; destruct H4.
            unfold Included in H4; apply H4 in H16; auto.
          + unfold Singleton in H16; apply AxiomII in H16.
            destruct H8; destruct H16; rewrite H17; auto.
            apply Theorem19; Ens.
        - assert (Function (F ∪ [[E,e]])).
          { unfold Function; split.
            - unfold Function in H11; destruct H11.
              unfold Relation in H11; unfold Relation; intros.
              apply Theorem4 in H17; destruct H17.
              + apply H11 in H17; auto.
              + unfold Singleton in H17; apply AxiomII in H17.
                exists E, e; apply H17; apply Theorem19; auto.
            - intros; destruct H16; apply Theorem4 in H16.
              apply Theorem4 in H17; destruct H16, H17.
              + unfold Function in H11; apply H11 with (x:=x); auto.
              + apply Property_dom in H16; rewrite H12 in H16.
                double H10; unfold Singleton in H17; apply AxiomII in H17.
                destruct H17; apply Theorem19 in H18; apply H19 in H18.
                apply Theorem49 in H10; apply (Theorem55 _ _ x z) in H10.
                symmetry in H18; apply H10 in H18; destruct H18.
                rewrite H18 in H7; contradiction.
              + apply Property_dom in H17; rewrite H12 in H17.
                double H10; unfold Singleton in H16; apply AxiomII in H16.
                destruct H16; apply Theorem19 in H18; apply H19 in H18.
                apply Theorem49 in H10; apply (Theorem55 _ _ x y) in H10.
                symmetry in H18; apply H10 in H18; destruct H18.
                rewrite H18 in H7; contradiction.
              + unfold Singleton in H16, H17.
                apply AxiomII in H16; apply AxiomII in H17.
                destruct H16, H17; double H10; apply Theorem19 in H20.
                double H20; apply H18 in H20; apply H19 in H21; double H10.
                apply Theorem49 in H10; apply (Theorem55 _ _ x y) in H10.
                apply Theorem49 in H22; apply (Theorem55 _ _ x z) in H22.
                symmetry in H20, H21; apply H10 in H20; apply H22 in H21.
                destruct H20, H21; rewrite <- H23, <- H24; auto. }
          assert (dom((F ∪ [[E,e]])) = D ∪ [E]).
          { apply AxiomI; split; intros.
            - unfold Domain in H17; apply AxiomII in H17.
              destruct H17, H18; apply Theorem4 in H18; destruct H18.
              + apply Property_dom in H18; rewrite H12 in H18.
                apply Theorem4; tauto.
              + unfold Singleton in H18; apply AxiomII in H18; double H10.
                destruct H18; apply Theorem19 in H10; apply H20 in H10.
                apply Theorem49 in H19; apply (Theorem55 _ _ z x) in H19.
                symmetry in H10; apply H19 in H10; destruct H10.
                apply Theorem4; right; unfold Singleton.
                apply AxiomII; split; auto.
            - unfold Domain; apply AxiomII; split; Ens.
              apply Theorem4 in H17; destruct H17.
              + exists F[z]; apply Theorem4; left.
                rewrite <- H12 in H17; apply Property_Value in H17; auto.
              + exists e; apply Theorem4; right; unfold Singleton in H17.
                apply AxiomII in H17; destruct H17.
                rewrite H18; try (apply Theorem19; Ens).
                unfold Singleton; apply AxiomII; split; auto. }
          unfold Choice_Function'; repeat split; try apply H16; auto.
          + apply AxiomIV; split; try apply Theorem42; Ens.
          + unfold Included; intros.
            unfold Range in H18; apply AxiomII in H18; destruct H18, H19.
            apply Theorem4 in H19; destruct H19.
            * unfold Element_U; apply AxiomII; split; auto.
              apply Property_ran in H19.
              unfold Included in H13; apply H13 in H19.
              unfold Element_U in H19; apply AxiomII in H19.
              destruct H19, H20, H20; exists x0; split; auto.
              apply Theorem4; tauto.
            * unfold Singleton in H10; apply AxiomII in H19.
              double H10; apply Theorem19 in H20; destruct H19.
              apply H21 in H20; apply Theorem49 in H10.
              apply (Theorem55 _ _ x z) in H10; symmetry in H20.
              apply H10 in H20; destruct H20; unfold Element_U.
              apply AxiomII; split; auto; exists E; rewrite <- H22.
              split; auto; apply Theorem4; right.
              unfold Singleton; apply AxiomII; split; Ens.
          + intros; unfold ProperSubset in H15; destruct H15.
            add (Function (F ∪ [[E, e]]) /\ F ⊂ (F ∪ [[E, e]])) H11.
            apply Included_Function in H11; destruct H11.
            rewrite H17 in H18; apply Theorem4 in H18; destruct H18.
            * rewrite <- H12 in H18; double H18; apply H14 in H18.
              apply H20 in H21; rewrite <- H21; auto.
            * unfold Singleton in H18; apply AxiomII in H18; destruct H18.
              assert (Ensemble E); Ens.
              apply Theorem19 in H22; apply H21 in H22.
              assert (E ∈ dom(F ∪ [[E, e]])).
              { rewrite H17; apply Theorem4; right.
                unfold Singleton; apply AxiomII; auto. }
              apply Property_Value in H23; auto.
              assert ([E,e] ∈ (F ∪ [[E, e]])).
              { apply Theorem4; right.
                unfold Singleton; apply AxiomII; auto. }
              pattern E at 3 in H23; rewrite <- H22 in H23.
              add ([E, e] ∈ (F ∪ [[E, e]])) H23; unfold Function in H16.
              apply H16 in H23; rewrite H23; rewrite H22; auto. }
  - rewrite H4 in H5.
    unfold Choice_Function' in H5; unfold Choice_Function.
    destruct H5, H6, H7, H8; repeat split; try apply H6; auto.
    unfold Included; intros; unfold Included in H8.
    apply H8 in H10; unfold Element_U in H10.
    apply AxiomII in H10; destruct H10, H11, H11.
    unfold Setminus in H12; apply Theorem4' in H12.
    destruct H12; unfold PowerSet in H12.
    apply AxiomII in H12; destruct H12.
    unfold Included in H14; apply H14 in H11; auto.
Qed.

Hint Resolve Tukey_Choice : Axiom_of_Choice.

End AC_Proof.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj13synthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (Succ (plus Zero (plus lv0 lv1))) (plus lv0 (Succ lv1))).
Admitted.
QuickChick conj13synthconj1.


(** * Definition and Notations for [for (int i = i₀; i < i∞; i += Δi)] *)
Require Import Coq.ZArith.BinInt.
Require Import Crypto.Util.Notations.
(** Note: These definitions are fairly tricky.  See
    https://github.com/REDACTED/REDACTED/issues/164 and
    https://github.com/REDACTED/REDACTED/pull/163 for more
    discussion.

    TODO: Fix the definitions to make them more obviously right. *)

Section with_body.
  Context {stateT : Type}
          (body : nat -> stateT -> stateT).

  Fixpoint repeat_function (count : nat) (st : stateT) : stateT
    := match count with
       | O => st
       | S count' => repeat_function count' (body count st)
       end.
End with_body.

Local Open Scope bool_scope.
Local Open Scope Z_scope.

Definition for_loop {stateT} (i0 finish : Z) (step : Z) (initial : stateT) (body : Z -> stateT -> stateT)
  : stateT
  := let count := Z.to_nat (Z.quot (finish - i0 + step - Z.sgn step) step) in
     repeat_function (fun c => body (i0 + step * Z.of_nat (count - c))) count initial.

Notation "'for' i (:= i0 ; += step ; < finish ) 'updating' ( state := initial ) {{ body }}"
  := (for_loop i0 finish step initial (fun i state => body))
     : core_scope.

Module Import ForNotationConstants.
  Definition eq := @eq Z.
  Module Z.
    Definition ltb := Z.ltb.
    Definition ltb' := Z.ltb.
    Definition gtb := Z.gtb.
    Definition gtb' := Z.gtb.
  End Z.
End ForNotationConstants.

Delimit Scope for_notation_scope with for_notation.
Notation "x += y" := (eq x (Z.pos y)) : for_notation_scope.
Notation "x -= y" := (eq x (Z.neg y)) : for_notation_scope.
Notation "++ x" := (x += 1)%for_notation : for_notation_scope.
Notation "-- x" := (x -= 1)%for_notation : for_notation_scope.
Notation "x ++" := (x += 1)%for_notation : for_notation_scope.
Notation "x --" := (x -= 1)%for_notation : for_notation_scope.
Infix "<" := Z.ltb : for_notation_scope.
Infix ">" := Z.gtb : for_notation_scope.
Notation "x <= y" := (Z.ltb' x (y + 1)) : for_notation_scope.
Notation "x >= y" := (Z.gtb' x (y - 1)) : for_notation_scope.

Class class_eq {A} (x y : A) := make_class_eq : x = y.
Global Instance class_eq_refl {A x} : @class_eq A x x := eq_refl.

Class for_loop_is_good (i0 : Z) (step : Z) (finish : Z) (cmp : Z -> Z -> bool)
  := make_good :
       ((Z.sgn step =? Z.sgn (finish - i0))
          && (cmp i0 finish))
       = true.
Hint Extern 0 (for_loop_is_good _ _ _ _) => vm_compute; reflexivity : typeclass_instances.

Definition for_loop_notation {i0 : Z} {step : Z} {finish : Z} {stateT} {initial : stateT}
           {cmp : Z -> Z -> bool}
           step_expr finish_expr (body : Z -> stateT -> stateT)
           {Hstep : class_eq (fun i => i = step) step_expr}
           {Hfinish : class_eq (fun i => cmp i finish) finish_expr}
           {Hgood : for_loop_is_good i0 step finish cmp}
  : stateT
  := for_loop i0 finish step initial body.

Notation "'for' ( 'int' i = i0 ; finish_expr ; step_expr ) 'updating' ( state1 .. staten = initial ) {{ body }}"
  := (@for_loop_notation
        i0%Z _ _ _ initial%Z _
        (fun i : Z => step_expr%for_notation)
        (fun i : Z => finish_expr%for_notation)
        (fun (i : Z) => (fun state1 => .. (fun staten => body) .. ))
        _ _ _).
Notation "'for' ( 'int' i = i0 ; finish_expr ; step_expr ) 'updating' ( state1 .. staten = initial ) {{ body }}"
  := (@for_loop_notation
        i0%Z _ _ _ initial%Z _
        (fun i : Z => step_expr%for_notation)
        (fun i : Z => finish_expr%for_notation)
        (fun (i : Z) => (fun state1 => .. (fun staten => body) .. ))
        eq_refl eq_refl _).


Require Import Bool.
Require Import Metalib.Metatheory.
Require Import List.
Require Import syntaxb_ott.

Inductive exp : Set :=  (*r expressions *)
 | e_var_b (_:nat) (*r variables *)
 | e_var_f (x:var) (*r variables *)
 | e_lit (i5:i) (*r lit *)
 | e_abs (e:exp) (*r abstractions *)
 | e_app (e1:exp) (e2:exp) (*r applications *)
 | e_anno (e:exp) (A:typ) (*r annotation *)
 | e_add : exp (*r addition *)
 | e_addl (i5:i) (*r addl *).

Inductive dirflag : Set :=  (*r checking direction *)
 | Inf : dirflag
 | Chk : dirflag.

Definition ctx : Set := list ( atom * typ ).

Definition ls : Set := list st.

(** opening up abstractions *)
Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => e_var_b nat
        | inleft (right _) => e_5
        | inright _ => e_var_b (nat - 1)
      end
  | (e_var_f x) => e_var_f x
  | (e_lit i5) => e_lit i5
  | (e_abs e) => e_abs (open_exp_wrt_exp_rec (S k) e_5 e)
  | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_anno e A) => e_anno (open_exp_wrt_exp_rec k e_5 e) A
  | e_add => e_add
  | (e_addl i5) => e_addl i5
end.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     (lc_exp (e_var_f x))
 | lc_e_lit : forall (i5:i),
     (lc_exp (e_lit i5))
 | lc_e_abs : forall (e:exp),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_abs e))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_anno : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_exp (e_anno e A))
 | lc_e_add :
     (lc_exp e_add)
 | lc_e_addl : forall (i5:i),
     (lc_exp (e_addl i5)).
(** free variables *)
Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x) => {{x}}
  | (e_lit i5) => {}
  | (e_abs e) => (fv_exp e)
  | (e_app e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_anno e A) => (fv_exp e)
  | e_add => {}
  | (e_addl i5) => {}
end.

(** substitutions *)
Fixpoint subst_exp (e_5:exp) (x5:var) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => (if eq_var x x5 then e_5 else (e_var_f x))
  | (e_lit i5) => e_lit i5
  | (e_abs e) => e_abs (subst_exp e_5 x5 e)
  | (e_app e1 e2) => e_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_anno e A) => e_anno (subst_exp e_5 x5 e) A
  | e_add => e_add
  | (e_addl i5) => e_addl i5
end.

(* principal types for values*)
Fixpoint principal_type (v:exp) : typ :=
  match v with
  | (e_lit i5) => t_int
  | (e_anno e A) => A
  | (e_abs e) => (t_arrow t_dyn t_dyn)
  | (e_add) => (t_arrow t_int (t_arrow t_int t_int))
  | (e_addl i5) => (t_arrow t_int t_int)
  | _ => t_dyn
  end.

(* defns Values *)
Inductive value : exp -> Prop :=    (* defn value *)
 | value_lit : forall (i5:i),
     value (e_lit i5)
 | value_add :
     value e_add
 | value_addl : forall (i5:i),
     value  ( (e_addl i5) )
 | value_abs : forall e ,
     lc_exp (e_abs e) ->
     value (e_abs e)
 | value_fanno : forall (v:exp) (A B C D:typ),
     value v ->
      (t_arrow C D)  =   (principal_type   ( v )  )   ->
     value (e_anno v (t_arrow A B))
 | value_dyn : forall (v:exp),
     Ground   (principal_type  v )   ->
     value v ->
     value  ( (e_anno v t_dyn) ) .

Inductive walue : exp -> Prop :=
 | walue_val : forall v,
     value v ->
     walue v
 | walue_abs : forall e ,
     lc_exp (e_abs e) ->
     walue (e_abs e).

Definition FLike A := not (A = t_dyn) /\ not (A = (t_arrow t_dyn t_dyn)) /\ (sim A (t_arrow t_dyn t_dyn)).

Inductive pattern : typ -> typ -> Prop :=
 | pa_arr : forall A B,
     pattern (t_arrow A B) (t_arrow A B)
 | pa_dyn :
     pattern t_dyn (t_arrow t_dyn t_dyn).

(* defns Typing *)
Inductive Typing : ctx -> exp -> dirflag -> typ -> Prop :=    (* defn Typing *)
 | Typ_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     Typing G (e_lit i5) Inf t_int
 | Typ_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     Typing G (e_var_f x) Inf A
 | Typ_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (B:typ),
      ( forall x , x \notin  L  -> Typing  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk B )  ->
     Typing G (e_abs e) Chk (t_arrow A B)
 | Typ_absd : forall (L:vars) (G:ctx) (e:exp),
      ( forall x , x \notin  L  -> Typing  (cons ( x , t_dyn )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk t_dyn )  ->
     Typing G (e_abs e) Chk t_dyn
 | Typ_sugar : forall (L:vars) (G:ctx) (e:exp),
     ( forall x , x \notin  L  -> Typing  (cons ( x , t_dyn )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk t_dyn )  ->
    Typing G (e_abs e) Inf (t_arrow t_dyn t_dyn)
 | Typ_app : forall (G:ctx) (e1 e2:exp) (A1 A2 A:typ),
    pattern A (t_arrow A1 A2) ->
    Typing G e1 Inf A ->
    Typing G e2 Chk A1 ->
    Typing G (e_app e1 e2) Inf A2
 | Typ_add : forall (G:ctx),
     uniq  G  ->
     Typing G e_add Inf (t_arrow t_int  (t_arrow t_int t_int) )
 | Typ_addl : forall (G:ctx) (i1:i),
     uniq  G  ->
     Typing G (e_addl i1) Inf (t_arrow t_int t_int)
 | Typ_anno : forall (G:ctx) (e:exp) (A:typ),
     Typing G e Chk A ->
     Typing G  ( (e_anno e A) )  Inf A
 | Typ_sim : forall (G:ctx) (e:exp) (B A:typ),
     Typing G e Inf A ->
     sim A B ->
     not(exists e', e = (e_abs e')) ->
     Typing G e Chk B.

Inductive ttyping : ctx -> exp -> dirflag -> typ -> term -> Prop :=    (* defn Typing *)
 | ttyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     ttyping G (e_lit i5) Inf t_int (trm_lit i5)
 | ttyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     ttyping G (e_var_f x) Inf A (trm_var_f x)
 | ttyp_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (B:typ) (t:term),
      ( forall x , x \notin  L  -> ttyping  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk B ( open_term_wrt_term t (trm_var_f x) ))  ->
     ttyping G (e_abs e) Chk (t_arrow A B) (trm_abs A t)
 | ttyp_absd : forall (L:vars) (G:ctx) (e:exp) (t:term),
      ( forall x , x \notin  L  -> ttyping  (cons ( x , t_dyn )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk t_dyn ( open_term_wrt_term t (trm_var_f x) ))  ->
     ttyping G (e_abs e) Chk t_dyn (trm_cast (trm_abs t_dyn t) (t_arrow t_dyn t_dyn) t_dyn)
 | ttyp_sugar : forall (L:vars) (G:ctx) (e:exp) (t:term),
     ( forall x , x \notin  L  -> ttyping  (cons ( x , t_dyn )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk t_dyn ( open_term_wrt_term t (trm_var_f x) ))  ->
    ttyping G (e_abs e) Inf (t_arrow t_dyn t_dyn) (trm_abs t_dyn t)
 | ttyp_app : forall (G:ctx) (e1 e2:exp) (B A:typ) (t1 t2:term),
     ttyping G e1 Inf (t_arrow A B) t1 ->
     ttyping G e2 Chk A t2 ->
     ttyping G (e_app e1 e2) Inf B (trm_app t1 t2)
 | ttyp_add : forall (G:ctx),
      uniq  G  ->
     ttyping G e_add Inf (t_arrow t_int  (t_arrow t_int t_int) ) trm_add
 | ttyp_addl : forall (G:ctx) (i1:i),
      uniq  G  ->
     ttyping G (e_addl i1) Inf (t_arrow t_int t_int) (trm_addl i1)
 | ttyp_anno : forall (G:ctx) (e:exp) (A:typ) (t:term),
     ttyping G e Chk A t ->
     ttyping G  ( (e_anno e A) )  Inf A t
 | ttyp_sim : forall (G:ctx) (e:exp) (B A:typ) (t:term),
     ttyping G e Inf A t ->
     sim A B ->
     not(exists e', e = (e_abs e')) ->
     ttyping G e Chk B (trm_cast t A B)
 | ttyp_appd : forall (G:ctx) (e1 e2:exp) (t1 t2:term),
     ttyping G e1 Inf t_dyn t1 ->
     ttyping G e2 Chk t_dyn t2 ->
     ttyping G (e_app e1 e2) Inf t_dyn (trm_app (trm_cast t1 t_dyn (t_arrow t_dyn t_dyn)) t2).

Inductive ctx_item : Type :=
     | appCtxL : exp -> ctx_item
     | appCtxR : exp -> ctx_item
     | annoCtx : typ -> ctx_item.

Inductive wellformed : ctx_item -> Prop :=
     | wf_appCtxL : forall (e : exp),
                   lc_exp e ->
                    wellformed (appCtxL e)
     | wf_appCtxR : forall (v : exp) A B,
                    principal_type v = (t_arrow A B) ->
                    value v ->
                    wellformed (appCtxR v)
     | wf_annoCtx : forall (A : typ),
                    wellformed (annoCtx A).

Definition fill (E : ctx_item) (e : exp) : exp :=
     match E with
     | appCtxL e2 => e_app e e2
     | appCtxR v1 => e_app v1 e
     | annoCtx A => e_anno e A
     end.

Inductive res : Type :=
     | e_exp  : exp -> res
     | e_blame : res.

(* defns Semantics *)
Inductive TypedReduce : exp -> typ -> res -> Prop :=    (* defn TypedReduce *)
 | TReduce_abs: forall v A B C D,
   sim (t_arrow C D) (t_arrow A B) ->
   principal_type v = (t_arrow C D) ->
   TypedReduce v (t_arrow A B) (e_exp (e_anno v (t_arrow A B)))
  | TReduce_v : forall (v:exp),
   Ground(principal_type v) ->
   TypedReduce v t_dyn (e_exp (e_anno v t_dyn))
 | TReduce_lit : forall (i5:i),
     TypedReduce (e_lit i5) t_int (e_exp (e_lit i5))
 | TReduce_dd : forall (v:exp),
     lc_exp v ->
     TypedReduce  ( (e_anno v t_dyn) )  t_dyn  (e_exp  (e_anno v t_dyn) )
 | TReduce_anyd : forall (v:exp),
      FLike (principal_type  v )  ->
     TypedReduce v t_dyn  (e_exp (e_anno  ( (e_anno v (t_arrow t_dyn t_dyn)) )  t_dyn) )
 | TReduce_adyn : forall e (A:typ),
    FLike A ->
    TypedReduce  ( (e_anno (e_abs e) t_dyn) )  A  (e_exp (e_anno (e_anno (e_abs e) (t_arrow t_dyn t_dyn)) A))
 | TReduce_absd : forall e,
    TypedReduce  ( (e_anno (e_abs e) t_dyn) )  (t_arrow t_dyn t_dyn)  (e_exp (e_anno (e_abs e) (t_arrow t_dyn t_dyn)))
 | TReduce_dyna : forall (v:exp) (A:typ),
      FLike A ->
     sim (principal_type v) A ->
     not(exists e, (v = e_abs e)) ->
    TypedReduce  ( (e_anno v t_dyn) )  A  (e_exp (e_anno v A) )
 | TReduce_vany : forall (v:exp),
   not(exists e, (v = e_abs e)) ->
   TypedReduce (e_anno v t_dyn) (principal_type  v) (e_exp v)
 | TReduce_blame : forall (v:exp) (A:typ),
      not (sim A (principal_type  v ))  ->
     TypedReduce (e_anno v t_dyn) A e_blame.

Inductive step : exp -> res -> Prop :=    (* defn step *)
  | do_step E e1 e2 :
       wellformed E ->
       step e1 (e_exp e2 ) ->
      step (fill E e1) (e_exp (fill E e2))
  | blame_step E e1:
      wellformed E ->
      step e1 e_blame ->
      step (fill E e1) e_blame
  | Step_nbeta : forall (e:exp) (v v' : exp),
    lc_exp (e_abs e) ->
    value v ->
    TypedReduce v t_dyn (e_exp v') ->
    step (e_app (e_abs e) v)  (e_exp (e_anno (open_exp_wrt_exp  e v' ) t_dyn) )
 | Step_beta : forall (A:typ) (e:exp) (B:typ) (v v' : exp),
    lc_exp (e_abs e) ->
    value v ->
    TypedReduce v A (e_exp v') ->
    step (e_app (e_anno (e_abs e) (t_arrow A B)) v)  (e_exp (e_anno (open_exp_wrt_exp  e v' ) B) )
 | Step_addL : forall (A:typ) (e:exp) (B:typ) (v v' : exp),
    value v ->
    TypedReduce v A (e_exp v') ->
    step (e_app (e_anno (e_add) (t_arrow A B)) v)  (e_exp (e_anno (e_app e_add v') B) )
 | Step_addR : forall (A:typ) (e:exp) (B:typ) (v v' : exp) i,
    value v ->
    TypedReduce v A (e_exp v') ->
    step (e_app (e_anno (e_addl i) (t_arrow A B)) v)  (e_exp (e_anno (e_app (e_addl i) v') B) )
 | Step_betap : forall (v1:exp) (A B:typ) (v2 :exp),
    value  ( (e_anno v1 (t_arrow A B)) )  ->
    TypedReduce v2 A e_blame ->
    value v2 ->
    step (e_app (e_anno v1 (t_arrow A B)) v2) e_blame
 | Step_annov : forall (v:exp) (A:typ) (v':res),
     value v ->
     TypedReduce v A v' ->
     not (value (e_anno v A)) ->
     step (e_anno v A) v'
 | Step_add : forall (v1:exp) (i1:i),
     value v1 ->
     TypedReduce v1 t_int (e_exp (e_lit i1)) ->
     step (e_app e_add v1) (e_exp (e_addl i1))
 | Step_addp : forall (v1:exp),
     value v1 ->
     TypedReduce v1 t_int e_blame ->
     step (e_app e_add v1) e_blame
 | Step_addl : forall (i1:i) (v2:exp) (i2:i),
     value v2 ->
     TypedReduce v2 t_int (e_exp (e_lit i2)) ->
     step (e_app  ( (e_addl i1) )  v2)  (e_exp (e_lit ( i1  +  i2 )))
 | Step_addlp : forall (i1:i) (v2:exp),
     value v2 ->
     TypedReduce v2 t_int e_blame ->
     step (e_app  ( (e_addl i1) )  v2)  e_blame
 | Step_abeta : forall (v1:exp) (A B C D:typ) (v2 v2':exp),
     value (e_anno v1 (t_arrow A B))  ->
     TypedReduce v2 C (e_exp v2') ->
     value v2 ->
     step (e_app (e_anno (e_anno v1 (t_arrow A B)) (t_arrow C D))  v2) (e_exp (e_anno (e_app (e_anno v1 (t_arrow A B)) v2') D))
 | Step_betad : forall (v1:exp) (v2:exp),
    value  ( (e_anno v1 t_dyn) )  ->
    step (e_app (e_anno v1 t_dyn) v2) (e_exp (e_app (e_anno (e_anno v1 t_dyn) (t_arrow t_dyn t_dyn)) v2)).

Inductive steps : exp -> res -> Prop :=
  | step_refl e:
    steps e (e_exp e)

  | step_n e t' e':
    step e (e_exp e') ->
    steps e' (e_exp t') ->
    steps e  (e_exp t')

  | step_nb e e':
    step e (e_exp e') ->
    steps e' e_blame ->
    steps e  e_blame

  | step_b e:
    step e (e_blame) ->
    steps e (e_blame).

(** infrastructure *)
Hint Constructors pattern Ground walue value sim TypedReduce step steps wellformed Typing ttyping lc_exp : core.


Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Import Strings.String.
Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Appsub.
Require Import Subtyping.Unisub.
Require Import Disjoint.
Require Import Value.
Require Import PrincipalTyping.
Require Import Consistent.

Import ListNotations.

(** * Definition *)

Inductive mode : Set :=
| Inf
| Chk.

Inductive typing : ctx -> term -> mode -> type -> Prop :=
| Ty_Int : forall T n,
    uniq T ->
    typing T (Lit n) Inf Int
| Ty_Var : forall T x A,
    uniq T -> binds x A T ->
    typing T (Fvar x) Inf A
| Ty_Lam : forall L T A B e,
    (forall x, x \notin L ->
          typing ((one (x, A)) ++ T) (open e (Fvar x)) Chk B) ->
    typing T (Lam A e B) Inf (Arr A B)
| Ty_Rcd : forall T e l A,
    typing T e Inf A ->
    typing T (Fld l e) Inf (Rcd l A)
| Ty_Ann : forall T A e,
    typing T e Chk A ->
    typing T (Ann e A) Inf A
| Ty_App : forall T A B C e1 e2,
    typing T e1 Inf A ->
    typing T e2 Inf B ->
    uunisub A (uP (Avt B)) (Some C) ->
    typing T (App e1 e2) Inf C
| Ty_Prj : forall T e l A B,
    typing T e Inf A ->
    uunisub A (uP (Alt l)) (Some B) ->
    typing T (Prj e l) Inf B
| Ty_Mrg : forall T A B e1 e2,
    disjoint A B ->
    typing T e1 Inf A ->
    typing T e2 Inf B ->
    typing T (Mrg e1 e2) Inf (And A B)
| Ty_Mrg_Uv : forall T A B u1 u2,
    uniq T ->
    uvalue u1 -> uvalue u2 ->
    consistent u1 u2 ->
    typing nil u1 Inf A ->
    typing nil u2 Inf B ->
    typing T (Mrg u1 u2) Inf (And A B)
| Ty_Sub : forall T e A B,
    typing T e Inf A ->
    sub A B ->
    typing T e Chk B.

Hint Constructors typing : core.

Notation "T ⊢ e ⇒ A" := (typing T e Inf A) (at level 50).
Notation "T ⊢ e ⇐ A" := (typing T e Chk A) (at level 50).

(** * Typing & PrincipalTyping *)

Lemma typing_to_ptype :
  forall u A,
    uvalue u ->
    typing nil u Inf A ->
    ptype u A.
Proof.
  introv Uval Typ. gen A.
  induction Uval; intros;
    dependent destruction Typ; eauto.
Qed.

Hint Resolve typing_to_ptype : core.

(** * Typing & Consistent *)

(** ** Reflexivity *)

(** Well-typed values are consistent with themselves *)

Lemma consistent_reflexivity :
  forall v A,
    typing nil v Inf A ->
    value v ->
    consistent v v.
Proof.
  introv Typ Val. gen A.
  induction Val; eauto; intros.
  dependent destruction Typ; eauto.
  Case "Merge".
  dependent destruction Typ.
  - SCase "Disjoint".
    assert (consistent v1 v2) by (eapply Con_Dj; eauto).
    eapply Con_Mrg_L; eauto.
    eapply Con_Mrg_R; eauto.
    now apply consistent_symmetry.
  - SCase "Consistent".
    eapply Con_Mrg_L; eauto.
    eapply Con_Mrg_R; eauto.
    now apply consistent_symmetry.
Qed.

Hint Resolve consistent_reflexivity : core.

(** * Typing & LC *)

Lemma typing_to_lc :
  forall T e A,
    typing T e Inf A -> lc e.
Proof.
  introv Typ.
  induction Typ; eauto 3; try solve [econstructor; eauto].
Qed.

Hint Resolve typing_to_lc : core.

(** * Check Subsumption *)

Lemma typing_chk_sub :
  forall A B e T,
    typing T e Chk A ->
    sub A B ->
    typing T e Chk B.
Proof.
  introv Typ Sub.
  dependent destruction Typ.
  eapply Ty_Sub; eauto.
  eapply sub_transitivity; eauto.
Qed.


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

  Why can't I induct on K and keep d connected?

*)

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

Require Export FormalSyntax.
Require Export VarLemmas.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export ContextExtensionRelation.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.

Require Export AlphaConversion.
Require Export GetLemmasRelation.

Inductive K3 : TVar -> Kappa -> Delta -> Tau -> Kappa -> Prop :=

 | K3_int   : forall (alpha : TVar) (k : Kappa) (d : Delta),
                  K ([(alpha, k)] ++ d) cint B ->
                  K3 alpha  k d cint B

 | K3_B     : forall (beta : TVar) (k : Kappa) (d : Delta) (alpha : TVar),
               getD d alpha = Some B ->
               K ([(beta,k)] ++ d) (tv_t alpha) B ->
               K3 beta k d (tv_t alpha) B

 | K3_star_A  : forall (beta : TVar) (k : Kappa) (d : Delta) (alpha : TVar),
                 getD d alpha = Some A ->
                 K ([(beta,k)] ++ d) (ptype (tv_t alpha)) B ->
                 K3 beta k d (ptype (tv_t alpha)) B

| K3_B_A     : forall (alpha : TVar) (k : Kappa) (d : Delta) (tau : Tau),
                  K  ([(alpha,k)] ++ d) tau A ->
                  K3 alpha k d tau A

 | K3_cross   : forall (alpha : TVar) (k : Kappa) (d : Delta) (t0 t1 : Tau),
                    K ([(alpha,k)] ++ d) t0 A ->
                    K ([(alpha,k)] ++ d) t1 A ->
                    K3 alpha k d (cross t0 t1) A.
(*
 | K3_arrow   : forall (d : Delta) (t0 t1 : Tau),
                    K3 d t0 A ->
                    K3 d t1 A ->
                    K3 d (arrow t0 t1) A

 | K3_ptype    :  forall (d : Delta) (tau : Tau),
                    K3 d tau A ->
                    K3 d (ptype tau) B

 | K3_utype  : forall (d : Delta) (alpha : TVar) (k : K3appa) (tau : Tau),
                   WFD ([(alpha, k)] ++ d) ->
                   getD d alpha = None ->
                   K3 ([(alpha, k)] ++ d) tau A ->
                   K3 d (utype alpha k tau) A

 | K3_etype  : forall (d : Delta) (alpha : TVar) (k : K3appa) (tau : Tau) (p : Phi),
                   WFD ([(alpha, k)] ++ d) ->
                   getD d alpha = None ->
                   K3 ([(alpha, k)] ++ d) tau A ->
                   K3 d (etype p alpha k tau) A.
*)

Print K3_ind.

Inductive AK3 : Delta -> Tau -> Kappa -> Prop :=

 | AK3_AK3_K3  : forall (alpha : TVar) (k' : Kappa)
                        (d : Delta) (tau : Tau) (k : Kappa),
                   K3  alpha k' d tau k ->
                   AK3 d tau k

 | AK3_A     : forall (d : Delta) (alpha : TVar),
                getD d alpha = Some A ->
                AK3 d (tv_t alpha) A.

Lemma A_6_Substitution_1_more_wrapping_judgement:
  forall (d : Delta) (t' : Tau) (k' : Kappa) (alpha : TVar) (k : Kappa),
    K3 alpha k d  t' k' ->
    WFD ([(alpha,k)] ++ d) ->
    forall (t : Tau),
      AK3 d t k ->
      K d (subst_Tau t' t alpha) k'.
Proof.
  intros d t' k' alpha k K3Der.
  induction K3Der.
 Case "K d cint B".
  intros.
  simpl.
  constructor.
 Case "K d (tv_t alpha) B".
  intros.
  simpl.
  case_eq (beq_tvar beta alpha).
  SCase "(beq_tvar beta alpha) = true".
   intros.
   apply beq_tvar_eq in H3.
   rewrite H3 in *.
   (* invert goal away on WFD ([(alpha, k)] ++ d) *)
   admit.
  SCase "(beq_tvar beta alpha) = false".
   intros.
   apply K3_B in H0; try assumption.
   (* I think this is correct so far. *)
   admit.
 Case "K d (ptype (tv_t alpha)) B".
  intros.
  simpl.
  case_eq (beq_tvar beta alpha).
  SCase "(beq_tvar beta alpha) = true".
   intros.
   admit.
  SCase "(beq_tvar beta alpha) = false".
   intros.
   apply K_star_A in H.
   assumption.
 Case "K d tau A".
  intros.
  constructor.
  inversion H1.
  (* Perhaps unsolvable. *)
  admit.
  admit.
 Case "K d (cross t0 t1) A".
  intros.
  (* No nice induction hypothesis. Total Failure again. *)
 Case "K d (arrow t0 t1) A".
  admit.
 Case "K d (ptype tau) B".
  admit.
 Case "K d (utype alpha k tau) A".
  admit.
 Case "K d (etype p alpha k tau) A)".
  admit.
Qed.