Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Types.
From PLF Require Import Smallstep.

Inductive ty : Type :=
  | Ty_Top : ty
  | Ty_Bool : ty
  | Ty_Base : string -> ty
  | Ty_Arrow : ty -> ty -> ty
  | Ty_Unit : ty
  | Ty_Prod : ty -> ty -> ty.

Inductive tm : Type :=
  | tm_var : string -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : string -> ty -> tm -> tm
  | tm_true : tm
  | tm_false : tm
  | tm_if : tm -> tm -> tm -> tm
  | tm_unit : tm
  | tm_pair : tm -> tm -> tm
  | tm_fst : tm -> tm
  | tm_snd : tm -> tm.

Declare Custom Entry stlc.
Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99,
                     t custom stlc at level 99,
                     y custom stlc at level 99,
                     left associativity).
Coercion tm_var : string >-> tm.
Notation "'Bool'" := Ty_Bool (in custom stlc at level 0).
Notation "'if' x 'then' y 'else' z" :=
  (tm_if x y z) (in custom stlc at level 89,
                    x custom stlc at level 99,
                    y custom stlc at level 99,
                    z custom stlc at level 99,
                    left associativity).
Notation "'true'" := true (at level 1).
Notation "'true'" := tm_true (in custom stlc at level 0).
Notation "'false'" := false (at level 1).
Notation "'false'" := tm_false (in custom stlc at level 0).
Notation "'Unit'" :=
  (Ty_Unit) (in custom stlc at level 0).
Notation "'unit'" := tm_unit (in custom stlc at level 0).
Notation "'Base' x" := (Ty_Base x) (in custom stlc at level 0).
Notation "'Top'" := (Ty_Top) (in custom stlc at level 0).

Notation "X * Y" :=
  (Ty_Prod X Y) (in custom stlc at level 2, X custom stlc, Y custom stlc at level 0).
Notation "( x ',' y )" := (tm_pair x y) (in custom stlc at level 0,
                                                x custom stlc at level 99,
                                                y custom stlc at level 99).
Notation "t '.fst'" := (tm_fst t) (in custom stlc at level 0).
Notation "t '.snd'" := (tm_snd t) (in custom stlc at level 0).

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).
Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | tm_var y =>
      if eqb_string x y then s else t
  | <{\y:T, t1}> =>
      if eqb_string x y then t else <{\y:T, [x:=s] t1}>
  | <{t1 t2}> =>
      <{([x:=s] t1) ([x:=s] t2)}>
  | <{true}> =>
      <{true}>
  | <{false}> =>
      <{false}>
  | <{if t1 then t2 else t3}> =>
      <{if ([x:=s] t1) then ([x:=s] t2) else ([x:=s] t3)}>
  | <{unit}> =>
      <{unit}>
  | <{ ( l , r ) }> => <{ ( [x:=s]l , [x:=s]r ) }>
  | <{ t.fst }> => <{ ([x:=s]t).fst }>
  | <{ t.snd }> => <{ ([x:=s]t).snd }>
  end
where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc).

Inductive value : tm -> Prop :=
  | v_abs : forall x T2 t1,
      value <{\x:T2, t1}>
  | v_true :
      value <{true}>
  | v_false :
      value <{false}>
  | v_unit :
      value <{unit}>
  | v_pair : forall v1 v2,
      value v1 ->
      value v2 ->
      value <{(v1, v2)}>.

Hint Constructors value : core.
Reserved Notation "t '-->' t'" (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T2 t1 v2,
         value v2 ->
         <{(\x:T2, t1) v2}> --> <{ [x:=v2]t1 }>
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         <{t1 t2}> --> <{t1' t2}>
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         <{v1 t2}> --> <{v1 t2'}>
  | ST_IfTrue : forall t1 t2,
      <{if true then t1 else t2}> --> t1
  | ST_IfFalse : forall t1 t2,
      <{if false then t1 else t2}> --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      <{if t1 then t2 else t3}> --> <{if t1' then t2 else t3}>
  | ST_Pair1 : forall t1 t1' t2,
       t1 --> t1' ->
       <{ (t1 , t2) }> --> <{ (t1' , t2) }>
  | ST_Pair2 : forall v1 t2 t2',
       value v1 ->
       t2 --> t2' ->
       <{ (v1 , t2) }> --> <{ (v1 , t2') }>
  | ST_PairFstStep : forall t t',
       t --> t' ->
       <{ t.fst }> --> <{ t'.fst }>
  | ST_PairFst : forall v1 v2,
       <{ (v1 , v2).fst }> --> <{ v1 }>
  | ST_PairSndStep : forall t t',
       t --> t' ->
       <{ t.snd }> --> <{ t'.snd }>
  | ST_PairSnd : forall v1 v2,
       <{ (v1 , v2).snd }> --> <{ v2 }>
where "t '-->' t'" := (step t t').
Hint Constructors step : core.

Reserved Notation "T '<:' U" (at level 40).
Inductive subtype : ty -> ty -> Prop :=
  | S_Refl : forall T,
      T <: T
  | S_Trans : forall S U T,
      S <: U ->
      U <: T ->
      S <: T
  | S_Top : forall S,
      S <: <{Top}>
  | S_Arrow : forall S1 S2 T1 T2,
      T1 <: S1 ->
      S2 <: T2 ->
      <{S1->S2}> <: <{T1->T2}>
  | S_Pair : forall S1 S2 T1 T2,
      S1 <: T1 ->
      S2 <: T2 ->
      <{S1 * S2}> <: <{T1 * T2}>
where "T '<:' U" := (subtype T U).

Hint Constructors subtype : core.
Module Examples.
Open Scope string_scope.
Notation x := "x".
Notation y := "y".
Notation z := "z".
Notation A := <{Base "A"}>.
Notation B := <{Base "B"}>.
Notation C := <{Base "C"}>.
Notation String := <{Base "String"}>.
Notation Float := <{Base "Float"}>.
Notation Integer := <{Base "Integer"}>.

Example subtyping_example_0 :
  <{C->Bool}> <: <{C->Top}>.
Proof. auto. Qed.

Definition Person : ty := <{ (String * Top)}>.

Definition Student : ty := <{ (String * Float)}>.

Definition Employee : ty := <{ (String * Integer)}>.

Example sub_student_person :  Student <: Person.
Proof. apply S_Pair. apply S_Refl. apply S_Top. Qed.

Example sub_employee_person :  Employee <: Person.
Proof. apply S_Pair. apply S_Refl. apply S_Top. Qed.

Example subtyping_example_1 :
  <{Top->Student}> <: <{(C->C)->Person}>.
Proof with eauto.
  apply S_Arrow...
  apply sub_student_person. Qed.

Example subtyping_example_2 :
  <{Top->Person}> <: <{Person->Top}>.
Proof with eauto.
  apply S_Arrow... Qed.

End Examples.

Definition context := partial_map ty.
Reserved Notation "Gamma '|-' t '\in' T" (at level 40, t custom stlc, T custom stlc at level 0).
Inductive has_type : context -> tm -> ty -> Prop :=
  (* Same as before: *)
  (* pure STLC *)
  | T_Var : forall Gamma x T1,
      Gamma x = Some T1 ->
      Gamma |- x \in T1
  | T_Abs : forall Gamma x T1 T2 t1,
      (x |-> T2 ; Gamma) |- t1 \in T1 ->
      Gamma |- \x:T2, t1 \in (T2 -> T1)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (T2 -> T1) ->
      Gamma |- t2 \in T2 ->
      Gamma |- t1 t2 \in T1
  | T_True : forall Gamma,
       Gamma |- true \in Bool
  | T_False : forall Gamma,
       Gamma |- false \in Bool
  | T_If : forall t1 t2 t3 T1 Gamma,
       Gamma |- t1 \in Bool ->
       Gamma |- t2 \in T1 ->
       Gamma |- t3 \in T1 ->
       Gamma |- if t1 then t2 else t3 \in T1
  | T_Unit : forall Gamma,
      Gamma |- unit \in Unit
  (* New rule of subsumption: *)
  | T_Sub : forall Gamma t1 T1 T2,
      Gamma |- t1 \in T1 ->
      T1 <: T2 ->
      Gamma |- t1 \in T2
  (* Pair *)
  | T_Pair : forall Gamma t1 t2 T1 T2,
      Gamma |- t1 \in T1 ->
      Gamma |- t2 \in T2 ->
      Gamma |- (t1 , t2) \in (T1 * T2)
  | T_PairFst : forall Gamma t T1 T2,
      Gamma |- t \in (T1 * T2) ->
      Gamma |- t.fst \in T1
  | T_PairSnd : forall Gamma t T1 T2,
      Gamma |- t \in (T1 * T2) ->
      Gamma |- t.snd \in T2
where "Gamma '|-' t '\in' T" := (has_type Gamma t T).
Hint Constructors has_type : core.

Module Examples2.
Import Examples.

Example e21: forall A B, empty |- ((\z:A, z) , (\z:B, z)) \in ((A->A) * (B->B)).
Proof. intros A B. eapply (T_Pair empty <{ \z:A, z }> <{ \z:B, z }> <{ A->A }> <{ B->B }>).
  - apply T_Abs. apply T_Var. auto.
  - apply T_Abs. apply T_Var. auto.
Qed.

Example e22: forall A B, empty |- (\x:(Top * (B->B)), x.snd) ((\z:A, z), (\z:B, z)) \in (B -> B).
Proof. intros A B.
  eapply T_App.
  - apply T_Abs. eapply T_PairSnd. apply T_Var. unfold "|->". rewrite t_update_eq. reflexivity.
  - apply T_Pair.
    + apply T_Sub with <{ A -> A }>. (* Anything subtype of Top *)
      * apply T_Abs. apply T_Var. unfold "|->". rewrite t_update_eq. reflexivity.
      * apply S_Top.
    + apply T_Abs. apply T_Var. unfold "|->". rewrite t_update_eq. reflexivity.
Qed.

Example e23: forall A B C, empty |- (\z:(C->C)->(Top * (B->B)), (z (\x:C, x)).snd)
              (\z:C->C, ((\z:A, z), (\z:B, z)))
         \in (B->B).
Proof. intros A B C.
  apply T_App with <{ (C -> C) -> Top * (B -> B) }>.
  - apply T_Abs. eapply T_PairSnd. eapply T_App.
    + apply T_Var. unfold "|->". rewrite t_update_eq. reflexivity.
    + apply T_Abs. apply T_Var. unfold "|->". rewrite t_update_eq. reflexivity.
  - apply T_Abs. apply T_Pair.
    + apply T_Sub with <{ A -> A }>.
      * apply T_Abs. apply T_Var. unfold "|->". rewrite t_update_eq. reflexivity.
      * apply S_Top.
    + apply T_Abs. apply T_Var. unfold "|->". rewrite t_update_eq. reflexivity.
Qed.

End Examples2.

Lemma sub_inversion_Bool : forall U,
     U <: <{Bool}> -> U = <{Bool}>.
Proof with auto.
  intros U Hs.
  remember <{Bool}> as V.
  induction Hs; subst; try auto; try (inversion HeqV).
  - rewrite -> IHHs1; apply IHHs2; reflexivity.
Qed.

Lemma sub_inversion_arrow : forall U V1 V2,
     U <: <{ V1 -> V2 }> ->
     exists U1 U2, U = <{ U1 -> U2 }> /\ V1 <: U1 /\ U2 <: V2.
Proof with eauto.
  intros U V1 V2 Hs.
  remember <{ V1 -> V2 }> as V.
  generalize dependent V2. generalize dependent V1.
  induction Hs; intros V1 V2 Ev; subst; try (inversion Ev).
  - exists V1, V2. split; try reflexivity. split; apply S_Refl.
  - destruct (IHHs2 V1 V2) as [ U1 [ U2  [Eu [ Hv1s Hu2s] ] ] ]. reflexivity.
    subst.
    destruct (IHHs1 U1 U2) as [ U1' [ U2'  [Eu' [ Hv1s' Hu2s'] ] ] ]. reflexivity.
    subst.
    exists U1', U2'.
    split. reflexivity.
    split.
    + apply (S_Trans _ _ _ Hv1s Hv1s').
    + apply (S_Trans _ _ _ Hu2s' Hu2s).
  - exists S1, S2.
    split. reflexivity.
    split.
    + rewrite <- H0. assumption.
    + rewrite <- H1. assumption.
Qed.

Lemma bool_if_bottom_for_true: forall G T, G |- true \in T -> <{ Bool }> <: T.
Proof.
  intros G T H.
  remember <{ true }> as t eqn:Et.
  induction H; try (discriminate Et).
  - constructor.
  - subst. apply S_Trans with T1.
    + apply IHhas_type. reflexivity.
    + assumption.
Qed.

Lemma true_isnt_arrow: forall G T1 T2, ~(G |- true \in (T1 -> T2)).
Proof.
  intros G T1 T2 H.
  inversion H; subst.
  apply bool_if_bottom_for_true in H.
  apply sub_inversion_arrow in H.
  destruct H as [U1 [U2 [HT0 [HU1 HU2]]]].
  discriminate HT0.
Qed.

Lemma bool_if_bottom_for_false: forall G T, G |- false \in T -> <{ Bool }> <: T.
Proof.
  intros G T H.
  remember <{ false }> as t eqn:Et.
  induction H; try (discriminate Et).
  - constructor.
  - subst. apply S_Trans with T1.
    + apply IHhas_type. reflexivity.
    + assumption.
Qed.

Lemma false_isnt_arrow: forall G T1 T2, ~(G |- false \in (T1 -> T2)).
Proof.
  intros G T1 T2 H.
  inversion H; subst.
  apply bool_if_bottom_for_false in H.
  apply sub_inversion_arrow in H.
  destruct H as [U1 [U2 [HT0 [HU1 HU2]]]].
  discriminate HT0.
Qed.

Lemma unit_is_bottom_for_unit: forall G T, G |- unit \in T -> <{ Unit }> <: T.
Proof.
  intros G T H.
  remember <{ unit }> as t eqn:Et.
  induction H; try (discriminate Et).
  - constructor.
  - subst. apply S_Trans with T1.
    + apply IHhas_type. reflexivity.
    + assumption.
Qed.

Lemma unit_isnt_arrow: forall G T1 T2, ~(G |- unit \in (T1 -> T2)).
Proof.
  intros G T1 T2 H.
  inversion H; subst.
  apply unit_is_bottom_for_unit in H.
  apply sub_inversion_arrow in H.
  destruct H as [U1 [U2 [HT0 [HU1 HU2]]]].
  discriminate HT0.
Qed.

Lemma pair_is_bottom_for_pair: forall G v1 v2 T, G |- (v1, v2) \in T -> exists T1 T2, <{ T1 * T2 }> <: T.
Proof.
  intros G v1 v2 T H.
  remember <{ (v1, v2) }> as t eqn:Et.
  induction H; try (discriminate Et).
  - subst.
    destruct IHhas_type as [T2' [T3' H']]. reflexivity.
    exists T2', T3'.
    apply S_Trans with T1.
    + apply H'.
    + assumption.
  - exists T1, T2. constructor.
Qed.

Lemma pair_isnt_arrow: forall G v1 v2 T1 T2, ~(G |- (v1, v2) \in (T1 -> T2)).
Proof.
  intros G v1 v2 T1 T2 H.
  inversion H; subst.
  apply pair_is_bottom_for_pair in H.
  destruct H as [T' [T'' H']].
  apply sub_inversion_arrow in H'.
  destruct H' as [U1 [U2 [HT0 [HU1 HU2]]]].
  discriminate HT0.
Qed.

Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
  Gamma |- s \in (T1 -> T2) ->
  value s ->
  exists x S1 s2, s = <{ \x:S1, s2 }>.
Proof with eauto.
  intros G s T1 T2 Ht Hv.
  generalize dependent G.
  generalize dependent T1.
  generalize dependent T2.
  induction Hv.
  - intros T1 T2' G Ht. exists x, T2, t1. reflexivity.
  - intros T2 T1 G Ht. exfalso. apply (true_isnt_arrow G T1 T2 Ht).
  - intros T2 T1 G Ht. exfalso. apply (false_isnt_arrow G T1 T2 Ht).
  - intros T2 T1 G Ht. exfalso. apply (unit_isnt_arrow G T1 T2 Ht).
  - intros T2 T1 G Ht. exfalso. apply (pair_isnt_arrow G v1 v2 T1 T2 Ht).
Qed.

Lemma abs_is_bottom_for_abs: forall G x xT b T, G |- (\x:xT, b) \in T -> exists T1 T2, <{ T1 -> T2 }> <: T.
Proof.
  intros G x xT b T H.
  remember <{ (\x:xT, b) }> as f eqn:Ef.
  induction H; try (discriminate Ef).
  - subst.
    injection Ef as Ex Et Eb. subst.
    exists xT, T1. constructor.
  - subst.
    destruct IHhas_type as [T2' [T3' H']]. reflexivity.
    exists T2', T3'.
    apply S_Trans with T1.
    + apply H'.
    + assumption.
Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     Gamma |- (\x:S1, t2) \in T ->
     exists S2, <{ S1 -> S2 }> <: T  /\  (x |-> S1 ; Gamma) |- t2 \in S2.
Proof.
  intros G x S1 t2 T H.
  remember <{ (\x:S1, t2) }> as f eqn:Ef.
  induction H; try (discriminate Ef).
  - injection Ef as Ex Et Eb. subst.
    exists T1. split.
      constructor.
      assumption.
  - subst.
    destruct IHhas_type as [T2' [T3' H']]. reflexivity.
    exists T2'.
    split.
    * apply S_Trans with T1; assumption.
    * assumption.
Qed.

Lemma sub_inversion_pair : forall U V1 V2,
     U <: <{ V1 * V2 }> ->
     exists U1 U2, U = <{ U1 * U2 }> /\ U1 <: V1 /\ U2 <: V2.
Proof with eauto.
  intros U V1 V2 Hs.
  remember <{ V1 * V2 }> as V.
  generalize dependent V2. generalize dependent V1.
  induction Hs; intros V1 V2 Ev; subst; try (inversion Ev).
  - exists V1, V2. split; try reflexivity. split; apply S_Refl.
  - destruct (IHHs2 V1 V2) as [ U1 [ U2  [Eu [ Hv1s Hu2s] ] ] ]. reflexivity.
    subst.
    destruct (IHHs1 U1 U2) as [ U1' [ U2'  [Eu' [ Hv1s' Hu2s'] ] ] ]. reflexivity.
    subst.
    exists U1', U2'.
    split. reflexivity.
    split.
    + apply (S_Trans _ _ _ Hv1s' Hv1s).
    + apply (S_Trans _ _ _ Hu2s' Hu2s).
  - exists S1, S2.
    split. reflexivity.
    split.
    + rewrite <- H0. assumption.
    + rewrite <- H1. assumption.
Qed.

Lemma canonical_forms_of_pair_types : forall Gamma s T1 T2,
  Gamma |- s \in (T1 * T2) ->
  value s ->
  exists v1 v2, s = <{ (v1, v2) }>.
Proof with eauto.
  intros G s T1 T2 Ht Hv.
  generalize dependent G.
  generalize dependent T1.
  generalize dependent T2.
  induction Hv.
  - intros T1 T' G Ht. exfalso.
    apply abs_is_bottom_for_abs in Ht.
    destruct Ht as [T2' [T3' Ht]].
    apply sub_inversion_pair in Ht.
    destruct Ht as [U1' [U2' [Ht [Hu1 Hu2]]]].
    discriminate Ht.
  - intros T2 T1 G Ht. exfalso.
    apply bool_if_bottom_for_true in Ht.
    apply sub_inversion_pair in Ht.
    destruct Ht as [U1' [U2' [Ht [Hu1 Hu2]]]].
    discriminate Ht.
  - intros T2 T1 G Ht. exfalso.
    apply bool_if_bottom_for_false in Ht.
    apply sub_inversion_pair in Ht.
    destruct Ht as [U1' [U2' [Ht [Hu1 Hu2]]]].
    discriminate Ht.
  - intros T2 T1 G Ht. exfalso.
    apply unit_is_bottom_for_unit in Ht.
    apply sub_inversion_pair in Ht.
    destruct Ht as [U1' [U2' [Ht [Hu1 Hu2]]]].
    discriminate Ht.
  - intros T2 T1 G Ht. exists v1, v2. reflexivity.
Qed.

Lemma abs_is_bottom_for_fun: forall G x T2 t1 T, G |- \ x : T2, t1 \in T -> exists T1, <{ T2 -> T1 }> <: T.
Proof.
  intros G x T2 t1 T H.
  remember <{ (\x : T2, t1) }> as t eqn:Et.
  induction H; try (discriminate Et).
  - injection Et as Et1 Et2 Et3. subst. exists T1. constructor.
  - subst.
    destruct IHhas_type as [T3' H'].
      reflexivity.
    exists T3'. apply S_Trans with T1.
    + apply H'.
    + assumption.
Qed.

Lemma typing_inversion_var : forall Gamma (x:string) T,
  Gamma |- x \in T ->
  exists S, Gamma x = Some S /\ S <: T.
Proof with eauto.
  intros G x T H.
  remember (tm_var x) as t eqn:Et.
  induction H; try (discriminate Et).
  - exists T1. split.
    + injection Et as Et. rewrite Et in H. assumption.
    + constructor.
  - destruct IHhas_type as [S' [Hl' Hr']]...
Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  Gamma |- t1 t2 \in T2 ->
  exists T1,  Gamma |- t1 \in (T1 -> T2) /\ Gamma |- t2 \in T1.
Proof with eauto.
  intros G t1 t2 T2 H.
  remember <{ t1 t2 }> as t eqn:Et.
  induction H; try (discriminate Et).
  - exists T2.
    injection Et as Et1 Et2. subst.
    split; assumption.
  - destruct IHhas_type as [t2' [Hl' Hr']]...
Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  empty |- (\x:S1, s2) \in (T1 -> T2) ->
     T1 <: S1 /\ (x |-> S1 ; empty) |- s2 \in T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty1]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  injection Heq as Heq; subst... Qed.

Lemma canonical_forms_of_Bool : forall Gamma s,
  Gamma |- s \in Bool ->
  value s ->
  s = tm_true \/ s = tm_false.
Proof. intros G s H.
  inversion H; intro Hv; subst; try (inversion Hv; subst).
  - left. reflexivity.
  - right. reflexivity.
  - exfalso.
    apply abs_is_bottom_for_fun in H.
    destruct H as [T' H].
    apply sub_inversion_Bool in H.
    discriminate H.
  - left. reflexivity.
  - right. reflexivity.
  - exfalso.
    apply unit_is_bottom_for_unit in H.
    apply sub_inversion_Bool in H.
    discriminate H.
  - exfalso.
    apply pair_is_bottom_for_pair in H.
    destruct H as [T1' [T2' H]].
    apply sub_inversion_Bool in H.
    discriminate H.
Qed.

Theorem progress : forall t T,
     empty |- t \in T   ->   value t \/ (exists t', t --> t').
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  induction Ht; subst Gamma; auto.
  - (* T_Var *)
    discriminate.
  - (* T_App *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
        eapply canonical_forms_of_arrow_types in Ht1; [|assumption].
        destruct Ht1 as [x [S1 [s2 H1]]]. subst.
        exists (<{ [x:=t2]s2 }>)...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. exists <{ t1 t2' }>...
    + (* t1 steps *)
      destruct H as [t1' Hstp]. exists <{ t1' t2 }>...
  - (* T_Test *)
    right.
    destruct IHHt1.
    + (* t1 is a value *) eauto.
    + apply canonical_forms_of_Bool in Ht1; [|assumption].
      destruct Ht1; subst...
    + destruct H. rename x into t1'. eauto.
  - (* T_Pair *)
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. right. exists <{ (t1 , t2') }>...
    + (* t1 steps *)
      destruct H as [t1' Hstp]. right. exists <{ (t1' , t2) }>...
  - (* T_PairFst *)
    destruct IHHt...
    + (* value pair *)
      destruct (canonical_forms_of_pair_types _ _ _ _ Ht) as [v1 [v2 Ht']]; auto.
      right. subst. exists v1. constructor.
    + destruct H as [t' H]. right. exists (tm_fst t')...
  - (* T_PairSnd *)
    destruct IHHt...
    + (* value pair *)
      destruct (canonical_forms_of_pair_types _ _ _ _ Ht) as [v1 [v2 Ht']]; auto.
      right. subst. exists v2. constructor.
    + destruct H as [t' H]. right. exists (tm_snd t')...
Qed.

Lemma weakening : forall Gamma Gamma' t T,
     inclusion Gamma Gamma' ->
     Gamma |- t \in T ->
     Gamma' |- t \in T.
Proof.
  intros Gamma Gamma' t T H Ht.
  generalize dependent Gamma'.
  induction Ht; eauto using inclusion_update.
Qed.

Lemma weakening_empty : forall Gamma t T,
     empty |- t \in T ->
     Gamma |- t \in T.
Proof.
  intros Gamma t T.
  eapply weakening.
  discriminate.
Qed.

Lemma substitution_preserves_typing : forall Gamma x U t v T,
   (x |-> U ; Gamma) |- t \in T ->
   empty |- v \in U ->
   Gamma |- [x:=v]t \in T.
Proof.
Proof.
  intros Gamma x U t v T Ht Hv.
  remember (x |-> U; Gamma) as Gamma'.
  generalize dependent Gamma.
  induction Ht; intros Gamma' G; simpl; eauto.
  - destruct (eqb_stringP x x0).
    + subst. rewrite update_eq in H. injection H as H. subst.
      apply weakening_empty. assumption.
    + subst. rewrite update_neq in H.
        constructor. assumption.
        assumption.
  - destruct (eqb_stringP x x0); subst.
    + constructor.
      rewrite update_shadow in Ht.
      assumption.
    + constructor.
      apply IHHt.
      rewrite update_permute.
        reflexivity.
        assumption.
Qed.

Lemma pair_destr: forall v1 v2 T1 T2,
  empty |- (v1, v2) \in (T1 * T2) ->
  empty |- v1 \in T1  /\  empty |- v2 \in T2.
Proof.
  intros v1 v2 T1 T2 H.
  remember <{(v1, v2)}> as p eqn:Ep.
  remember <{(T1 * T2)}> as t eqn:Et.
  generalize dependent T1.
  generalize dependent T2.
  induction H; try (discriminate Ep); subst.
  - intros T2' T1' Hv. subst.
    apply sub_inversion_pair in H0.
    destruct H0 as [U1 [U2 [H' [Hu1 Hu2]]]]. subst.
    assert (HG: Gamma |- v1 \in U1 /\ Gamma |- v2 \in U2). {
      apply IHhas_type.
        reflexivity.
        reflexivity.
    }
    clear IHhas_type.
    destruct HG as [Hvu1 Hvu2].
    split.
    + eapply T_Sub. apply Hvu1. apply Hu1.
    + eapply T_Sub. apply Hvu2. apply Hu2.
  - intros T1' T2' Ets. injection Ets as Ets1 Ets2. subst.
    injection Ep as tv1 tv2. subst.
    split.
      assumption.
      assumption.
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T ->
     t --> t' ->
     empty |- t' \in T.
Proof with eauto.
  intros t t' T HT. generalize dependent t'.
  remember empty as Gamma.
  induction HT;
       intros t' HE; subst;
       try solve [inversion HE; subst; eauto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and eauto takes care of them *)
    + (* ST_AppAbs *)
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T0...
  - (* T_PairFst *)
    inversion HE; subst...
    apply pair_destr in HT.
    destruct HT as [Ht1 Ht2].
    assumption.
  - (* T_PairSnd *)
  inversion HE; subst...
  apply pair_destr in HT.
  destruct HT as [Ht1 Ht2].
  assumption.
Qed.


Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.RIneq.
Require Import Coq.micromega.Psatz.
Require Import SMTC.Tactic.
Require Import Logic.Syntax.
Require Import Logic.Semantics.
Require Import Logic.Lib.
Require Import Logic.ProofRules.
Require Import Logic.Automation.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.

(* Some useful tactics for our examples. *)

Ltac cut_setoid_rewrite_r X :=
  let xx := fresh "xx" in
  cut X; [ intro xx; rewrite xx; clear xx | ].

Ltac cut_setoid_rewrite_l X :=
  let xx := fresh "xx" in
  cut X; [ intro xx; rewrite <- xx; clear xx | ].

Ltac rewrite_rename_equiv F m :=
  cut_setoid_rewrite_r (F -|- Rename m F);
  [ | rewrite <- Rename_ok by eauto with rw_rename; reflexivity ].

Ltac decompose_hyps :=
  repeat first [ rewrite Lemmas.land_lor_distr_R
               | rewrite Lemmas.land_lor_distr_L ] ;
  repeat apply lorL.

Ltac destruct_ite :=
  match goal with
  | [ |- context [ if ?e then _ else _ ] ]
    => destruct e
  end.

Fixpoint get_vars_term (t : Term) : list Var :=
  match t with
  | VarNextT t | VarNowT t => t :: nil
  | NatT _ | RealT _ => nil
  | PlusT a b | MinusT a b | MultT a b | MaxT a b
  | Binop _ a b =>
                             get_vars_term a ++
                                           get_vars_term b
  | InvT a | CosT a | SinT a | SqrtT a | ArctanT a
  | ExpT a | Unop _ a =>
                                         get_vars_term a
  end.

Definition get_image_vars (m:list (Var*Term)) :=
  List.flat_map (fun p => get_vars_term (snd p)) m.

Fixpoint get_witness (m : list (Var*Term)) : state -> state :=
  match m with
  | nil => fun st => st
  | (x,VarNowT y) :: m =>
    fun st z =>
      if String.string_dec z y
      then st x else get_witness m st z
  | _ => fun st => st
  end.

Fixpoint get_next_vars_term (t : Term) : list Var :=
  match t with
  | VarNextT t => t :: nil
  | VarNowT _ | NatT _ | RealT _ => nil
  | PlusT a b | MinusT a b | MultT a b | MaxT a b
  | Binop _ a b =>
                             get_next_vars_term a ++
                             get_next_vars_term b
  | InvT a | CosT a | SinT a | SqrtT a | ArctanT a
  | ExpT a | Unop _ a => get_next_vars_term a
  end.

Fixpoint get_next_vars_formula (f : Formula) : list Var :=
  match f with
  | Always a | Eventually a | Enabled a =>
                              get_next_vars_formula a
  | And a b | Or a b | Imp a b =>
                       get_next_vars_formula a ++
                       get_next_vars_formula b
  | Rename _ a => get_next_vars_formula a
  | Comp l r _ => get_next_vars_term l ++
                                     get_next_vars_term r
  | _ => nil
  end.

Fixpoint remove_dup (ls : list Var) : list Var :=
  match ls with
  | nil => nil
  | l :: ls => let ls' := remove_dup ls in
               if in_dec string_dec l ls'
               then ls' else l :: ls'
  end.

Ltac enable_ex_st :=
  match goal with
  | |- lentails _ (Enabled ?X) =>
    let vars := eval compute in
    (remove_dup (get_next_vars_formula X)) in
        let rec foreach ls :=
            match ls with
            | @cons _ ?l ?ls => eapply (ex_state l); simpl;
                                foreach ls
            | _ => idtac
            end
        in
        eapply Enabled_action; simpl; intros;
        foreach vars
  end; try (eapply ex_state_any; (let st := fresh in
                                  intro st; clear st)).

Ltac enable_ex_st' :=
  match goal with
  | |- _ |-- Enabled ?X =>
        let vars := eval compute in (remove_dup (get_next_vars_formula X)) in
        let rec foreach ls :=
         (match ls with
          | ?l :: ?ls => eapply (ex_state l); simpl; foreach ls
          | _ => idtac
          end) in
        eapply Enabled_action'; [ tlaIntuition | ]; simpl; intros; foreach vars
  end; try (eapply ex_state_any; (let st := fresh in
                                  intro st; clear st)).

Ltac smart_repeat_eexists :=
  repeat match goal with
           |- exists x, _ => eexists
         end.

(* The old tactic, very slow. *)
(*
Ltac enable_ex_st :=
  eapply Enabled_action; intros; eapply ex_state_flow_any;
  auto; simpl; intros;
  repeat match goal with
         | |- context [ ?X ] =>
           match type of X with
           | Var => idtac
           | String.string => idtac
           end ;
             try match goal with
                 | X := _ |- _ => unfold X
                 end;
             eapply (@ex_state X) ; simpl ;
             match goal with
             | |- exists x (y : _), (@?F x) => fail 1
             | |- _ => idtac
             end
         end;
  try (eapply ex_state_any ;
       let st := fresh in intro st ; clear st).
*)

Lemma reason_action : forall P Q,
    (forall a b tr,
        eval_formula
          P
          (Stream.Cons a
                       (Stream.Cons b tr)) ->
        eval_formula
          Q (Stream.Cons a (Stream.Cons b tr))) ->
    (P |-- Q).
Proof.
  red. red. red. intros. destruct tr.
  destruct tr. auto.
Qed.

Ltac reason_action_tac :=
  eapply reason_action; simpl;
  let pre := fresh "pre" in
  let post := fresh "post" in
  let tr := fresh "tr" in
  intros pre post tr;
    breakAbstraction; simpl; unfold eval_comp;
    simpl; intros.

(* This solves linear real arithmetic goals.
   It should be complete. *)
Ltac solve_linear :=
  breakAbstraction; intros; unfold eval_comp in *;
  simpl in *; intuition; try psatzl R.

(* This tries to solve nonlinear real
   arithmetic goals. It is not complete
   and can be incredibly inefficient. *)
Ltac solve_nonlinear :=
  breakAbstraction; intros; unfold eval_comp in *;
  simpl in *; intuition; try psatz R.

Ltac zero_deriv_tac v :=
  eapply ContinuousProofRules.zero_deriv
  with (x:=v); [ charge_tauto | solve_linear | ].

Ltac always_imp_tac :=
  match goal with
  | [ |- ?H |-- _ ]
    => match H with
       | context[ Always ?HH ] =>
         tlaAssert (Always HH);
           [ charge_tauto |
             apply Lemmas.forget_prem; apply Always_imp ]
       end
  end.

Ltac specialize_arith_hyp H :=
  repeat match type of H with
         | ?G -> _ =>
           let HH := fresh "H" in
           assert G as HH by solve_linear;
             specialize (H HH); clear HH
         end.

Ltac specialize_arith :=
  repeat match goal with
         | [ H : ?G -> _ |- _ ] =>
           specialize_arith_hyp H
         end.

(* This simplifies real arithmetic goals.
   It sometimes is useful to run this before
   sending things to solve_nonlinear. *)
Ltac R_simplify :=
  unfold state, Value; field_simplify;
  unfold Rdiv;
  repeat rewrite RMicromega.Rinv_1;
  repeat
    match goal with
    | H:_ |- _ =>
      unfold state, Value in H; field_simplify in H;
      unfold Rdiv in H;
      repeat rewrite RMicromega.Rinv_1 in H;
      revert H
    end; intros.

(* Doesn't change the goal but runs
   z3 on real arithmetic goals. At the
   moment, you have to look in the *coq*
   buffer for the output. *)
Ltac z3_prepare :=
  intros.

Ltac z3_solve :=
  z3_prepare; smt solve.

Ltac z3_quick :=
  z3_prepare; smt solve.

(* rewrites the values of variables in the next
   state into hypothesis and goals. *)
Ltac rewrite_next_st :=
  repeat match goal with
           | [ H : eq (Stream.hd (Stream.tl _) _)  _ |- _ ]
             => rewrite H in *
         end.

(* Gets rid of arithmetic expressions of the
   form 0+_, _+0, 0*_, and _*0, _-0, 0-_. *)
Ltac rewrite_real_zeros :=
  repeat (first
            [ rewrite Rmult_0_r in *
            | rewrite Rmult_0_l in *
            | rewrite Rplus_0_r in *
            | rewrite Rplus_0_l in *
            | rewrite Rminus_0_r in *
            | rewrite Rminus_0_l in * ]).

Ltac simpl_Rmax :=
  repeat first [rewrite Rbasic_fun.Rmax_left in * by solve_linear |
                rewrite Rbasic_fun.Rmax_right in * by solve_linear ].

Local Open Scope HP_scope.

(* I'm not sure what the following three
   tactics do *)
(*
Ltac find_zeros eqs :=
  match eqs with
    | nil => constr:(@nil Var)
    | cons (DiffEqC ?y (ConstC (NatC O))) ?eqs =>
      let rest := find_zeros eqs in
      constr:(cons y rest)
    | cons _ ?eqs =>
      let rest := find_zeros eqs in
      rest
  end.
*)

(*
Ltac extract_unchanged eqs :=
  let xs := find_zeros eqs in
  let rec aux l :=
      match l with
        | nil => idtac
        | cons ?y ?l => apply zero_deriv
                        with (cp:=eqs) (x:=y);
                        try (aux l)
      end in
  aux xs.
*)

Ltac get_var_inv F x :=
  match F with
    | And ?F1 _ =>
      get_var_inv F1 x
    | And _ ?F2 =>
      get_var_inv F2 x
    | Comp (next_term x) (next_term ?e) Eq =>
      constr:(Comp x e Eq)
  end.

(* Applies differential induction with
   a known differential invariant *)
Ltac prove_diff_inv known :=
  match goal with
      |- context [ Continuous ?eqs ] =>
      match goal with
          |- (|-- _ -->> Comp (next_term ?t1)
                   (next_term ?t2) ?op) =>
          apply diff_ind with
          (Hyps:=known) (G:=Comp t1 t2 op) (cp:=eqs)
      end
  end.

(* Removes ! from variables in a Term *)
Fixpoint unnext_term (t:Term) : Term :=
  match t with
    | VarNowT x => VarNowT x
    | VarNextT x => VarNowT x
    | RealT r => RealT r
    | NatT n => NatT n
    | PlusT t1 t2 =>
      PlusT (unnext_term t1) (unnext_term t2)
    | MinusT t1 t2 =>
      MinusT (unnext_term t1) (unnext_term t2)
    | MultT t1 t2 =>
      MultT (unnext_term t1) (unnext_term t2)
    | InvT t => InvT (unnext_term t)
    | CosT t => CosT (unnext_term t)
    | SinT t => SinT (unnext_term t)
    | SqrtT t => SqrtT (unnext_term t)
    | ArctanT t => ArctanT (unnext_term t)
    | ExpT t => ExpT (unnext_term t)
    | MaxT t1 t2 => MaxT (unnext_term t1) (unnext_term t2)
    | Unop f t => Unop f (unnext_term t)
    | Binop f t1 t2 => Binop f (unnext_term t1)
                             (unnext_term t2)
  end.

(* Removes ! from variables in a Formula *)
Fixpoint unnext (F:Formula) : Formula :=
  match F with
    | Comp t1 t2 op =>
      Comp (unnext_term t1) (unnext_term t2) op
    | And F1 F2 => And (unnext F1) (unnext F2)
    | Or F1 F2 => Or (unnext F1) (unnext F2)
    | Imp F1 F2 => Imp (unnext F1) (unnext F2)
    | Syntax.Exists T f => Syntax.Exists T (fun t => unnext (f t))
    | Syntax.Forall T f => Syntax.Forall T (fun t => unnext (f t))
    | _ => F
  end.

(* Tries to prove (discrete) inductive goals in our examples.
   Only works for linear arithmetic. Leaves unsolved subgoals
   unchanged. *)
Ltac prove_inductive :=
  repeat apply or_next; repeat apply and_right;
  match goal with
    | [ |- context [Continuous ?deqs] ] =>
      match goal with
(*        | [ |- (|-- _ -->> (?HH -->> ?GG))] =>
          abstract (apply diff_ind_imp
                    with (eqs:=deqs) (H:=unnext HH)
                                     (G:=unnext GG);
                    solve [reflexivity |
                           simpl; intuition;
                           solve_linear])*)
(*        | [ |- _ ] =>
          abstract
            (apply unchanged_continuous with (eqs:=deqs);
             solve_linear)*)
        | [ |- (|-- _ -->> ?GG) ] =>
          abstract (eapply diff_ind
                    with (cp:=deqs) (G:=unnext GG)
                                    (Hyps:=TRUE);
                    try solve [reflexivity |
                               simpl; intuition;
                               solve_linear] )
      end
    | [ |- _ ] =>
      try abstract (solve_linear)
  end.

Ltac rewrite_projT2_L s :=
  let H := fresh in
  pose proof (projT2 s) as H;
    cbv beta in H; rewrite <- H; clear H.

Ltac rewrite_projT2_R s :=
  let H := fresh in
  pose proof (projT2 s) as H;
    cbv beta in H; rewrite H; clear H.


Set Implicit Arguments.

Require Import fcf.FCF.
Require Import fcf.CompFold.
Require Import fcf.PRF.
Require Import fcf.PRG_NA.

Local Open Scope list_scope.
Section HMAC_DRBG_PRG_NA.

(* HMAC-DRBG spec *)

(* The security parameter eta determines the size of PRF keys *)
Variable eta : nat.
Variable eta_nz : eta <> O.
(* The function f models HMAC *)
Variable f : Bvector eta -> Blist -> Bvector eta.

Definition RndK : Comp (Bvector eta) := {0,1}^eta.
Definition RndV : Comp (Bvector eta) := {0,1}^eta.
Definition KV : Set := (Bvector eta * Bvector eta)%type.

(* The Instantiate function *)
(* NOTE: does not reflect NIST spec *)
Definition Instantiate : Comp KV :=
  k <-$ RndK;
  v <-$ RndV;
  ret (k, v).

(* The Generate function *)
Definition to_list (A : Type) (n : nat) (v : Vector.t A n) := Vector.to_list v.

Fixpoint Gen_loop (k : Bvector eta) (v : Bvector eta) (n : nat)
  : list (Bvector eta) * Bvector eta :=
  match n with
  | O => (nil, v)
  | S n' =>
    let v' := f k (to_list v) in
    let (bits, v'') := Gen_loop k v' n' in
    (v' :: bits, v'')
  end.

(* Spec says "V || 0x00"; here we will use a list of 8 bits of 0 (a byte) *)
Fixpoint replicate {A} (n : nat) (a : A) : list A :=
  match n with
  | O => nil
  | S n' => a :: replicate n' a
  end.

Definition zeroes : list bool := replicate 8 false.

Definition Generate (state : KV) (n : nat) :
  Comp (list (Bvector eta) * KV) :=
  [k, v] <-2 state;
  [bits, v'] <-2 Gen_loop k v n;
  k' <- f k (to_list v' ++ zeroes);
  v'' <- f k' (to_list v');
  ret (bits, (k', v'')).

(* The adversary against the PRG *)
Variable blocksPerCall : nat.       (* blocks generated by GenLoop *)
Variable blocksPerCall_gt_0 : blocksPerCall > O.
Variable numCalls : nat.        (* number of calls to Generate *)
Variable numCalls_gt_0: numCalls > O.
Definition requestList : list nat := replicate numCalls blocksPerCall.
Variable A : list (list (Bvector eta)) -> Comp bool.
Variable A_wf : forall ls, well_formed_comp (A ls).

(* The constructed adversary against the PRF *)
Fixpoint oracleCompMap_inner {D R OracleIn OracleOut : Set}
           (e1 : EqDec ((list R) * (nat * KV)))
           (e2 : EqDec (list R))
           (* this is an oracleComp, not an oracle *)
           (* the oracle has type (D * R) -> D -> Comp (R, (D * R)) *)
           (oracleComp : (nat * KV) -> D -> OracleComp OracleIn OracleOut (R * (nat * KV)))
           (state : (nat * KV)) (* note this state type -- it is EXPLICITLY being passed around *)
           (inputs : list D) : OracleComp OracleIn OracleOut (list R * (nat * KV)) :=
  match inputs with
  | nil => $ ret (nil, state)
  | input :: inputs' =>
    [res, state'] <--$2 oracleComp state input;
    [resList, state''] <--$2 oracleCompMap_inner _ _ oracleComp state' inputs';
    $ ret (res :: resList, state'')
  end.

Definition oracleCompMap_outer {D R OracleIn OracleOut : Set}
           (e1 : EqDec ((list R) * (nat * KV)))
           (e2 : EqDec (list R))
           (oracleComp : (nat * KV) -> D -> OracleComp OracleIn OracleOut (R * (nat * KV)))
           (inputs : list D) : OracleComp OracleIn OracleOut (list R) :=
  [k, v] <--$2 $ Instantiate;   (* generate state inside, instead of being passed state *)
  [bits, _] <--$2 oracleCompMap_inner _ _ oracleComp (O, (k, v)) inputs;
  (* the "_" here has type (nat * KV) *)
  $ ret bits.

Definition Generate_v_PRF_oc (state : KV) (n : nat) :
  OracleComp (list bool) (Bvector eta) (list (Bvector eta) * KV) :=
  [k, v] <-2 state;
  v' <- f k (to_list v);
  [bits, v''] <-2 Gen_loop k v' n;
  k' <- f k (to_list v'' ++ zeroes);
  $ ret (bits, (k', v'')).

Fixpoint Gen_loop_oc (v : Bvector eta) (n : nat)
  : OracleComp (list bool) (Bvector eta) (list (Bvector eta) * Bvector eta) :=
  match n with
  | O => $ ret (nil, v)
  | S n' =>
    v' <--$ (OC_Query _ (to_list v)); (* ORACLE USE *)
    [bits, v''] <--$2 Gen_loop_oc v' n';
    $ ret (v' :: bits, v'')
  end.

Definition Generate_v_oc (state : KV) (n : nat) :
  OracleComp (list bool) (Bvector eta) (list (Bvector eta) * KV) :=
  [k, v_0] <-2 state;
  v <--$ (OC_Query _ (to_list v_0)); (* ORACLE USE *)
  [bits, v'] <--$2 Gen_loop_oc v n;
  (* TODO what's the state type here? and the global Generate_v_oc return type? *)
  k' <--$ (OC_Query _ (to_list v' ++ zeroes)); (* ORACLE USE *)
  $ ret (bits, (k', v')).

Definition Generate_noV_oc (state : KV) (n : nat) :
  OracleComp (list bool) (Bvector eta)  (list (Bvector eta) * KV) :=
  [k, v] <-2 state;
  [bits, v'] <--$2 Gen_loop_oc v n;
  (* TODO what's the state type here? and the global Generate_v_oc return type? *)
  k' <--$ (OC_Query _ (to_list v' ++ zeroes)); (* ORACLE USE *)
  $ ret (bits, (k', v')).

Fixpoint Gen_loop_rb_intermediate (k : Bvector eta) (v : Bvector eta) (n : nat)
  : Comp (list (Bvector eta) * Bvector eta) :=
  match n with
  | O => ret (nil, v)
  | S n' =>
    v' <-$ {0,1}^eta;
    [bits, v''] <-$2 Gen_loop_rb_intermediate k v' n';
    ret (v' :: bits, v'')
  end.

Definition Generate_rb_intermediate_oc (state : KV) (n : nat)
  : OracleComp (list bool) (Bvector eta) (list (Bvector eta) * KV) :=
  [k, v] <-2 state;
  v' <--$ $ {0,1}^eta;
  [bits, v''] <--$2 $ Gen_loop_rb_intermediate k v' n;    (* promote comp to oraclecomp, then remove from o.c. *)
  $ ret (bits, (k, v'')).

Definition Oi_oc' (i : nat) (sn : nat * KV) (n : nat)
  : OracleComp Blist (Bvector eta) (list (Bvector eta) * (nat * KV)) :=
  [callsSoFar, state] <-2 sn;
  let Generate_v_choose :=
      (* this behavior (applied with f_oracle) needs to match that of choose_Generate's *)
      if lt_dec callsSoFar i (* callsSoFar < i (override all else) *)
           then Generate_rb_intermediate_oc (* this implicitly has no v to update *)
      else if beq_nat callsSoFar O (* use oracle on 1st call w/o updating v *)
           then Generate_noV_oc
      else if beq_nat callsSoFar i (* callsSoFar = i *)
           then Generate_v_oc    (* uses provided oracle (PRF or RF) *)
      else Generate_v_PRF_oc in        (* uses PRF with (k,v) updating *)
  [bits, state'] <--$2 Generate_v_choose state n;
  $ ret (bits, (S callsSoFar, state')).

Definition PRF_Adversary (i : nat) : OracleComp Blist (Bvector eta) bool :=
  bits <--$ oracleCompMap_outer _ _ (Oi_oc' i) requestList;
  $ A bits.
(* End constructed adversary definition *)

Definition Pr_collisions := (S blocksPerCall)^2 / 2^eta.
Definition PRF_Advantage_Game i : Rat :=
  PRF_Advantage RndK ({0,1}^eta) f _ _ (PRF_Adversary i).
Fixpoint argMax(f : nat -> Rat) (n : nat) :=
  match n with
    | O => O
    | S n' => let p := (argMax f n') in
              if (le_Rat_dec (f (S n')) (f p)) then p else (S n')
                                                             end.

Definition PRF_Advantage_Max := PRF_Advantage_Game (argMax PRF_Advantage_Game numCalls).
Definition Gi_Gi_plus_1_bound := PRF_Advantage_Max + Pr_collisions.

(* The desired security property: HMAC_DRBG is a non-adaptive PRG *)
Definition HMAC_DRBG_PRG_NA :=
  PRG_Nonadaptive_Advantage _ _ ({0,1}^eta) Instantiate Generate
  (ret requestList) A <= (numCalls / 1) * Gi_Gi_plus_1_bound.

(* The proof of this property is imported and applied below *)
Require Import HMAC_DRBG_nonadaptive.

Theorem Generate_rb_eq_ideal :
  forall b x,
  evalDist (Generate_ideal (Bvector_EqDec eta) ({ 0 , 1 }^ eta) b) x ==
  evalDist (Generate_rb eta b) x.

  unfold Generate_rb, Generate_ideal in *.
  Local Opaque evalDist.
  induction b; intuition; simpl in *.
  - fcf_simp.
    reflexivity.

  - fcf_inline_first.
    fcf_skip.
    fcf_inline_first.
    fcf_skip.
    rewrite IHb.
    rewrite evalDist_right_ident.
    reflexivity.
    rewrite evalDist_right_ident.
    reflexivity.
Qed.

Theorem PRG_Advantage_eq :
  PRG_Nonadaptive_Advantage _ _ ({0,1}^eta) HMAC_DRBG_PRG_NA.Instantiate HMAC_DRBG_PRG_NA.Generate
  (ret HMAC_DRBG_PRG_NA.requestList) A ==
  | Pr [G_real f _ A blocksPerCall numCalls ] -
       Pr [G_ideal A blocksPerCall numCalls ] |.

  unfold PRG_Nonadaptive_Advantage.
  apply ratDistance_eqRat_compat.
  - unfold PRG_G1, G_real.
    fcf_skip.
    reflexivity.
    fcf_simp.
    reflexivity.

  - unfold PRG_G2, G_ideal.
    fcf_simp.
    fcf_skip.
    eapply compMap_eq; intuition.
    apply list_pred_eq.
    subst.
    apply Generate_rb_eq_ideal.
Qed.

Theorem HMAC_DRBG_PRG_NA_true : HMAC_DRBG_PRG_NA.

  unfold HMAC_DRBG_PRG_NA, PRG_Nonadaptive_Advantage.
  eapply leRat_trans.
  apply eqRat_impl_leRat.
  apply PRG_Advantage_eq.
  apply G1_G2_close; intuition.

Qed.


Require Import ssreflect.
From mathcomp Require Import ssrnat zify.
Require Import BinNums.

Require Import UMLang.UrsusLib.
Require Import UrsusTVM.Cpp.tvmTypes.
Require Import UrsusTVM.Cpp.tvmFunc.
Require Import UrsusTVM.Cpp.tvmNotations.
Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.EpsilonMonad.
Require Import FinProof.StateMonad21.
Require Import FinProof.ProgrammingWith.
Require Import FinProof.MonadTransformers21.
Require Import FinProof.StateMonad21Instances.
Require Import UMLang.UrsusLib.
Require Import UrsusStdLib.Cpp.stdNotations.
Require Import UrsusStdLib.Cpp.stdFuncNotations.
Require Import UMLang.UrsusLib.

Require Import UrsusStdLib.Cpp.stdTypes.
Require Import UrsusStdLib.Cpp.stdNotations.
Require Import UrsusStdLib.Cpp.stdFuncNotations.
Require Import KWproject.Contracts.ProofsCommon.

Require Import SuperLedger GenTree.

Require Import List.

Require Import FinProof.Lib.BoolEq.
Require Import FinProof.Lib.GenTree.

Import ListNotations.

Import UrsusNotations.
Local Open Scope ursus_scope.
Local Open Scope ucpp_scope.
(* Local Open Scope xlist_scope. *)

Set Typeclasses Depth 100.

Set Implicit Arguments.

Section MessageTree.

Notation LedgerClassT lT :=
  (LedgerClass
    XBool
    (Ledger                  lT)
    (LedgerMainState         lT)
    (LedgerLocalState        lT)
    VMStateLRecord
    (LedgerMessagesAndEvents lT)
    GlobalParamsLRecord
    OutgoingMessageParamsLRecord).

Context (Interfaces Contracts : Type).
Context `{ContractsUtils Interfaces Contracts}.

Notation nodeType         := (@nodeType         Interfaces Contracts).
Notation superLedger      := (@superLedger      Interfaces Contracts).
Notation externalNodeType := (@externalNodeType Interfaces Contracts).

Definition messageTree := Tree nodeType.

Implicit Type t : messageTree.

Record state := {
  MessagesQueue : list nodeType;
  SuperLedger   : superLedger;
  RunOutOfFuel  : bool;
}.

(*  *)
(* Notation StateT := (simpleState superLedger). *)

Check MonadState.

Context (StateTG : Type -> Type -> Type).
Context `{Mo : forall S, Monad (StateTG S)} `{forall S, @MonadState (StateTG S) S (Mo S)}.

Notation StateT' := (StateTG state).
Notation StateT  := (StateTG superLedger).

Definition putMessageQueue (n : list nodeType) : state -> state :=
  fun '(Build_state ms sl r) => Build_state n sl r.

Definition putSuperLedger (s : superLedger) : state -> state :=
  fun '(Build_state ms sl r) => Build_state ms s r.

Definition runOut : state -> state :=
  fun '(Build_state ms sl r) => Build_state ms sl true.

Local Obligation Tactic := idtac.

Local Open Scope bool_scope.

Context `{nodeEqType: eqb_spec nodeType}.

Fixpoint takeheads {T} (l : list (list T)) :=
  match l with
  | (h :: t) :: ls => h :: takeheads ls
  | [ ] :: ls => takeheads ls
  | [ ] => [ ]
  end.

Fixpoint checkRoots (R : nodeType -> nodeType -> Prop) ts qss: Prop :=
  match ts, qss with
  | [ ]    , [ ]             => True
  | t :: ts, (q :: _) :: qss => R (Tree.root t) q /\ checkRoots R ts qss
  | _      , _               => False
  end.

#[global, program]
Instance XBoolEquableList {T} `{XBoolEquable bool T} : XBoolEquable bool (list T).
Next Obligation.
intros ??.
refine (fix foo (l1 l2 : list _) :=
  match l1, l2 with
  | h1 :: t1, h2 :: t2 => eqb h1 h2 && foo t1 t2
  | nil     , nil      => true
  | _       , _        => false
  end).
Defined.

Fixpoint checkTreeT (mt : messageTree) (qss : list (list nodeType)) :
  StateT bool :=
  let fix Checks mts qss : StateT bool :=
    match mts, qss with
    | [ ]    , [ ]               => $true
    | t :: ts, (q :: qs) :: qss  =>
      do sl ← get;
      let sl'  := sl_of  (InterpretNode (Tree.root t) sl) in
      let tss  := tss_of (InterpretNode (Tree.root t) sl) in
      let err  := errTp_of (InterpretNode (Tree.root t) sl) in
      let qss' := if qs is nil then tss else qs :: tss    in
      (put sl' >>
      do b  ← checkTreeT t qss';
      do bs ← Checks ts qss;
      $ (eqb (Tree.root t) (putError q err) && b && bs))
    | _      , _                 => $ false
    end in
  Checks (Tree.nodes mt) qss.

Fixpoint checkTreesT mts qss : StateT bool :=
  match mts, qss with
  | [ ]    , [ ]               => $true
  | t :: ts, (q :: qs) :: qss  =>
    do sl ← get;
    let sl'  := sl_of  (InterpretNode (Tree.root t) sl) in
    let tss  := tss_of (InterpretNode (Tree.root t) sl) in
    let err  := errTp_of (InterpretNode (Tree.root t) sl) in
    let qss' := if qs is nil then tss else qs :: tss    in
   (put sl' >>
    do b  ← checkTreeT t qss';
    do bs ← checkTreesT ts qss;
    $ (eqb (Tree.root t) (putError q err) && b && bs))
  | _      , _                 => $ false
  end.

Lemma checkTreeE (n : nodeType)  :
  (forall t q qs qss ts, checkTreeT (Node n (t :: ts)) ((q :: qs) :: qss) =
    do sl ← get;
    let sl'  := sl_of  (InterpretNode (Tree.root t) sl) in
    let tss  := tss_of (InterpretNode (Tree.root t) sl) in
    let err  := errTp_of (InterpretNode (Tree.root t) sl) in
    let qss' := if qs is nil then tss else qs :: tss    in
    (put sl' >>
    do b  ← checkTreeT t qss';
    do bs ← checkTreeT (Node n ts) qss ;
    $ (eqb (Tree.root t) (putError q err) && b && bs))) *
  (checkTreeT (Node n nil) nil = $true).
Proof. by [ ].  Qed.

Lemma checkTreeE2 (n : nodeType) ts qss :
  checkTreeT (Node n ts) qss = checkTreesT ts qss.
Proof. by [ ]. Qed.

Fixpoint checkForestT (l : list messageTree) : (StateT bool) :=
  match l with
  | [ ]     => $ true
  | t :: ts =>
    modify (setTime (getTime (Tree.root t))) >>
    do sl ← get;
    let: mk_IN sl' qss err := InterpretNode (Tree.root t) sl in
    put sl' >>
    do b  ← checkTreeT   t qss;
    do bs ← checkForestT ts;
    $ (b && bs && eqb (getError (Tree.root t)) err)
  end.

Lemma checkForestE t ts :
  checkForestT (t :: ts) =
    modify (setTime (getTime (Tree.root t))) >>
    do sl ← get;
    let: mk_IN sl' qss err := InterpretNode (Tree.root t) sl in
    put sl' >>
    do b  ← checkTreeT   t qss;
    do bs ← checkForestT ts;
    $ (b && bs && eqb (getError (Tree.root t)) err).
Proof. by [ ]. Qed.

Definition mapNode (l : list externalNodeType) : list nodeType := map inl l.

Definition checkForest (l : list messageTree) (ems : list externalNodeType) (sl : superLedger) :=
  eval_state (checkForestT l) sl &&
  eqb
    (map (fun t => putError (Tree.root t) (Build_errorType None false)) l)
    (map (fun m => putError m (Build_errorType None false)) (mapNode ems)).

Definition execForest (l : list messageTree) (sl : superLedger) :=
  exec_state (checkForestT l) sl.

#[global] Arguments checkTreeT : simpl never.

Lemma checkTreesE t ts q qs qss:
  checkTreesT (t :: ts) ((q :: qs) :: qss) =
  do sl ← get;
  let sl'  := sl_of  (InterpretNode (Tree.root t) sl) in
  let tss  := tss_of (InterpretNode (Tree.root t) sl) in
  let err  := errTp_of (InterpretNode (Tree.root t) sl) in
  let qss' := if qs is nil then tss else qs :: tss    in
  (put sl' >>
  do b  ← checkTreeT t qss';
  do bs ← checkTreesT ts qss;
  $ (eqb (Tree.root t) (putError q err) && b && bs)).
Proof. by [ ]. Qed.

(*
  1) addrR parent = addrS children +
  2) все кроме root -- internalNodeType +
  3) bounce onBounce = false
  4) messge queue is empty for intermediate ledgers +
  .) balance = const
  .) add new field option ErrorType +
  .) if ↑ = Some error ==> exists message onBounce somewhere (come up with spec)

  1) InterpretNode n sl = (sl', qss) ->
  Forall (Forall (fun n' => addrS_of n' = addrR_of n)) qss.
  2) InterpretNode n sl = (sl', qss) ->
  sum_balance sl = sum_balance sl'.
  3) InterpretNode n sl = (sl', qss) ->
  Forall (Forall (fun n' => isOnBoune n' -> bouncce n' = false))) qss.
 *)

Fixpoint Builds (Build : nodeType -> StateT' messageTree)
  (nss : list (list nodeType)) : StateT' (list messageTree) :=
  match nss with
  | (n :: ns) :: nss =>
    modify (putMessageQueue ns) >>
    do mt  ← Build n;
    do mts ← Builds Build nss;
    $ (mt :: mts)
  | _ :: nss => modify runOut >> $ nil
  | _        => $ nil
  end.

Fixpoint Build (fuel : nat) (n : nodeType) : StateT' messageTree :=
  if fuel is S fuel then
    do sl ← embed_fun SuperLedger;
    do ms ← embed_fun MessagesQueue;
    let Int := (InterpretNode n sl)                  in
    let sl' := sl_of  Int                            in
    let nss := tss_of Int                            in
    let err := errTp_of Int                          in
    let qss' := if ms is nil then nss else ms :: nss in
    modify (putSuperLedger sl') >>
    if qss' is nil then $ (Node (putError n err) nil) else
    do mts ← Builds (Build fuel) qss';
    $ (Node (putError n err) mts)
  else modify runOut >> $ (Node n nil).

Fixpoint buildForestT fuel (l : list nodeType) : (StateT' (list messageTree)) :=
  match l with
  | [ ] => $ [ ]
  | n :: tln => modify (fun '(Build_state ms sl r) => Build_state ms (setTime (getTime n) sl) r) >>
                do tree ← Build fuel n;
                do forest ← buildForestT (fuel - 1) tln;
                $ (tree :: forest)
  end.

Definition buildForest fuel (l : list externalNodeType) (sl : superLedger) :=
  eval_state (buildForestT fuel (mapNode l)) (Build_state nil sl false).

Definition buildSLedger fuel (l : list externalNodeType) (sl : superLedger) :=
  SuperLedger (exec_state (buildForestT fuel (mapNode l)) (Build_state nil sl false)).

Definition buildFinished fuel (l : list externalNodeType) (sl : superLedger) :=
  negb (RunOutOfFuel (exec_state (buildForestT fuel (mapNode l)) (Build_state nil sl false))).

(* Context `{nodeEqType : eqb_spec nodeType}. *)

Arguments run : simpl never.

Lemma runmodify {M : Type -> Type} {S : Type} `{Monad M}
  {MonadState : MonadState S} (f : S -> S)
  (s : S) : run (modify f) s = (f s, f s)%xprod.
Proof. by rewrite /modify runbind runget /Basics.compose runput. Qed.

Lemma runmodifybind {M : Type -> Type} {S : Type} `{Monad M}
  {MonadState : MonadState S} (f : S -> S) X (m : M X)
  (s : S) : run (modify f >> m) s = run m (f s).
Proof.
  rewrite runbind'.
  case E: (run _); rewrite runmodify in E.
  by case: E=>?->.
Qed.

Lemma runputbind {M : Type -> Type} {S : Type} `{Monad M}
  {MonadState : MonadState S} (f : S) X (m : M X)
  (s : S) : run (put f >> m) s = run m f.
Proof.
  rewrite runbind'.
  case E: (run _); rewrite runput in E.
  by case: E=>?->.
Qed.

From mathcomp Require Import ssreflect ssrbool zify.

Inductive run_chekTree_spec tr que stat stat' : Prop :=
  | Run_step t sl' tss st  q qs qss qss' sl ts x err
    (trE   : tr   = Node x (t :: ts))
    (queE  : que = (q :: qs) :: qss)
    (statE : stat = sl)
    (tE    : Tree.root t = putError q err)
    (INt   : InterpretNode (Tree.root t) sl = mk_IN sl' tss err)
    (qss'E : qss' = if qs is nil then tss else qs :: tss)
    (runE1 : run (checkTreeT t qss') sl' = (true, st)%xprod)
    (runE2 : run (checkTreeT (Node x ts) qss) st = (true, stat')%xprod)
    (runE3 :
      run
        (checkTreeT (Node x (t :: ts)) ((q :: qs) :: qss))
        sl =
        (true, stat')%xprod)  :
      run_chekTree_spec tr que stat stat'
  | Run_empty x sl
    (runE : run (checkTreeT (Node x nil) nil) sl =
      (true, sl)%xprod)
    (trE    : tr    = Node x nil)
    (queE   : que   = nil)
    (statE  : stat  = sl)
    (stat'E : stat' = sl) :
      run_chekTree_spec tr que stat stat' .

Arguments eqb : simpl never.

Lemma run_checkTreeE x ts sl qss :
  run (checkTreeT (Node x ts) qss) sl =
  match ts, qss with
  | t :: ts, (q :: qs) :: qss =>
    let: mk_IN sl' tss err      := InterpretNode (Tree.root t) sl in
    let: (b , st)%xprod  := run
      (checkTreeT t (if qs is nil then tss else qs :: tss))
      sl' in
    let: (b', st')%xprod := run (checkTreeT (Node x ts) qss) st in
      (eqb (Tree.root t) (putError q err) && b && b', st')%xprod
  | [ ]    , [ ]              => (true, sl)%xprod
  | _      , _                => (false, sl)%xprod
  end.
Proof.
case: ts qss=> [|t ts] [|[>|q qs qss] ].
{ by rewrite checkTreeE rununit. }
1-4: by rewrite /checkTreeT /= rununit.
rewrite checkTreeE runbind runget /SuperLedger.
rewrite runputbind /putSuperLedger.
destruct (InterpretNode (Tree.root t) sl) as [sl' tss err] eqn:E.
set qss' := match qs with
            | [ ] => snd (fst (sl', tss, err))
            | _ :: _ => qs :: snd (fst (sl', tss, err))
            end.
rewrite runbind /fst.
destruct (run (checkTreeT t qss') _) as [b st] eqn:E1.
rewrite runbind.
destruct (run (checkTreeT (Node x ts) qss) _) as [b1 st'] eqn:E2.
by rewrite rununit.
Qed.

(* Arguments Builds : simpl never. *)

Lemma run_BuildE n fuel ms sl r:
  run (Build fuel n) (Build_state ms sl r) =
  if fuel is fuel.+1 then
    let: mk_IN sl' tss err := InterpretNode n sl in
    let: qss               := if ms is nil then tss else ms :: tss in
      match qss with
      | nil      => ([putError n err | [ ] ], (Build_state ms sl' r))%xprod
      | nil :: _ => ([putError n err | [ ] ], (Build_state ms sl' true))%xprod
      | ((q :: qs) :: qss) =>
        let: (trh, st)%xprod :=
          run (Build fuel q) (Build_state qs sl' r) in
        let: (trt, st')%xprod :=
          run (Builds (Build fuel) qss) st in
          ([putError n err | trh :: trt], st')%xprod
      end
  else ([n | [ ] ], (Build_state ms sl true))%xprod.
Proof.
case: fuel=> [|fuel].
{ by rewrite /= @runmodifybind rununit. }
do ? rewrite /= runbind runembed /=.
case E: (InterpretNode n sl)=> [sl' tss err] /=.
set qss := if ms is nil then tss else ms :: tss.
case: qss=> [|[|q qs] qss].
{ by rewrite runmodifybind rununit. }
{ by rewrite runmodifybind /= runbind /Builds runmodifybind ?rununit. }
rewrite runmodifybind /= runbind runmodifybind runbind.
case: (run _ _)=> [trh st].
rewrite runbind.
case: (run _ _)=> [trt st'].
by rewrite ?rununit.
Qed.

Arguments Builds : simpl nomatch.

Lemma run_BuildsE Build st nss:
  run (Builds Build nss) st =
  match nss with
  | (n :: ns) :: nss =>
    let: (trh, st1)%xprod :=
      run (Build n) (putMessageQueue ns st) in
    let: (trt, st2)%xprod :=
      run (Builds (Build) nss) st1 in
      (trh :: trt, st2)%xprod
  | _ :: nss => (nil, runOut st)%xprod
  | _        => (nil, st)%xprod
  end.
Proof.
case: nss=> [|[|]>].
1-2: by rewrite /= ?runmodifybind rununit.
rewrite /= runbind runmodify runbind.
case: (run _ _)=>>.
rewrite runbind.
case: (run _ _)=>>.
by rewrite rununit.
Qed.

Inductive run_Build_spec n ms1 sl1 ms2 sl2 t : nat -> list (list nodeType) -> Prop :=
  | Runb_step err tss sl sl' q qs qss fuel trh trt ms'
    (INt   : InterpretNode n sl1 = mk_IN sl tss err)
    (qssE  : (q :: qs) :: qss = if ms1 is nil then tss else ms1 :: tss)
    (runE1 :
      run (Build fuel q) (Build_state qs sl false) =
      (trh, Build_state ms' sl' false)%xprod)
    (runE2 :
      run (Builds (Build fuel) qss) (Build_state ms' sl' false) =
      (trt, Build_state ms2 sl2 false)%xprod)
    (runE4 :
      run (Build fuel.+1 n) (Build_state ms1 sl1 false) =
      ([putError n err | trh :: trt], Build_state ms2 sl2 false)%xprod)
    (tE : [putError n err | trh :: trt] = t)
    (* (nE : n = putError n err) *)
      : run_Build_spec n ms1 sl1 ms2 sl2 t (fuel.+1) ((q :: qs) :: qss)
  | Runb_empty err tss sl fuel
    (INt  : InterpretNode n sl1 = mk_IN sl tss err)
    (qssE : nil = if ms1 is nil then tss else ms1 :: tss)
    (runE : run (Build fuel.+1 n) (Build_state ms1 sl1 false) =
      ([putError n err | [ ] ], (Build_state ms1 sl false))%xprod)
    (* (nE   : t = putError n err) *)
    (msE  : ms1 = ms2)
    (sl2E : sl2 = sl)
    (tE : [putError n err | [ ] ] = t)
      : run_Build_spec n ms1 sl1 ms2 sl2 t (fuel.+1) nil.

Lemma Build_RunOutOfFuel_aux ts nss n t sl sl' ms ms' fuel r:
  (run (Build fuel n) (Build_state ms sl r) = (t, (Build_state ms' sl' false))%xprod ->
  r = false) *
  (run (Builds (Build fuel) nss) (Build_state ms sl r) = (ts, (Build_state ms' sl' false))%xprod ->
  r = false).
Proof.
elim: fuel nss n t sl sl' ms ms' r ts.
{ move=> nss ? ? sl sl' ms ms' r ts; rewrite run_BuildE; split=> //.
  elim: nss sl sl' r ms ms' ts=> [>|[|n ns] ? IHnss >]; rewrite run_BuildsE //.
  { by case. }
  case E1: (run _ _)=> [t1 st1].
  case E2: (run _ _)=> [t2 [ ] ]; move: E2.
  rewrite run_BuildE in E1.
  move=> /[swap]=> -[???->].
  by case: E1=> ? <- /IHnss. }
move=> fuel IHfuel.
have HB: forall n t sl sl' ms ms' r,
  run (Build fuel.+1 n) (Build_state ms sl r) = (t, Build_state ms' sl' false)%xprod ->
  r = false.
{ move=> n t sl sl' ms ms' r.
  rewrite run_BuildE.
  case: (InterpretNode _ _)=> [? tss ?].
  set (qss := if ms is nil then tss else ms :: tss).
  case E: qss=> [|[|q qs] qss']=> //.
  { by case. }
  case E1: (run _ _)=> [t1 [ ] ].
  case E2: (run _ _)=> [t2 [ ] ]; move: E2.
  move=> /[swap] -[???->].
  edestruct IHfuel as [_ IH2].
  move: E1=> /[swap] /IH2 ->.
  edestruct IHfuel as [IH1 _].
  by move/IH1. }
move=> nss n t sl sl' ms ms' r ts; split.
{ exact/HB. }
elim: nss ms ms' sl sl' r ts=> [>|[|n' ns] nss IHnss >]; rewrite run_BuildsE //.
{ by case. }
case E1: (run _ _)=> [t1 [ ] ].
case E2: (run _ _)=> [t2 [ ] ]; move: E2.
move=> /[swap] -[???->] /IHnss.
by move: E1=> /[swap]-> /HB.
Unshelve. all: done.
Qed.

Lemma Build_RunOutOfFuel n t sl sl' ms ms' fuel r:
  run (Build fuel n) (Build_state ms sl r) = (t, (Build_state ms' sl' false))%xprod ->
  r = false.
Proof.
edestruct Build_RunOutOfFuel_aux as [IH1]; exact/IH1.
Unshelve. all: exact/nil.
Qed.

Lemma Builds_RunOutOfFuel (n : nodeType) nss ts t sl sl' ms ms' fuel r:
  run (Builds (Build fuel) nss) (Build_state ms sl r) = (ts, (Build_state ms' sl' false))%xprod ->
  r = false.
Proof.
edestruct Build_RunOutOfFuel_aux as [_ IH1]; exact/IH1.
Unshelve.
{ exact/n. }
exact/[n | nil].
Qed.

Lemma run_BuildP n t sl sl' ms ms' fuel :
  run (Build fuel n) (Build_state ms sl false) = (t, (Build_state ms' sl' false))%xprod ->
  let: mk_IN _ tss _ := InterpretNode n sl in
  run_Build_spec n ms sl ms' sl' t fuel (if ms is nil then tss else ms :: tss).
Proof.
move=> /[dup] rE.
rewrite run_BuildE.
case E1: (InterpretNode _ _) => [s tss err].
case E2: fuel=> //.
set qss := (if ms is nil then tss else ms :: tss).
case E3: qss=> [|[|q qs] qss']=> // [ [<-<-<-]|].
{ econstructor=> //.
  { exact/E1. }
  { exact/eq_sym/E3. }
  by rewrite -E2 run_BuildE /= E1 -/qss E3 E2. }
case E4: (run _ _)=> [trh [ ] ].
case E5: (run _ _)=> [trt st2].
case=> /[dup] tE <- st2E.
econstructor=> //.
{ exact/E1. }
{ exact/eq_sym/E3. }
{ move: st2E E5 E4=> {1}-> /Builds_RunOutOfFuel-/(_ n t)->; exact. }
{ move: st2E E5 (E5)=> {1 2}-> /Builds_RunOutOfFuel-/(_ n t)->; exact. }
by rewrite -E2 rE tE.
Qed.

Lemma run_checkTreeP x ts qss sl sl' :
    (run_chekTree_spec (Node x ts) qss sl sl') <->
    (run (checkTreeT (Node x ts) qss) sl = (true, sl')%xprod).
Proof.
  split.
  { case=> [>[->->->->qE]*|?>? [->->->->->] ] //. }
  case: ts qss=> [|t ts] [|[>|q qs qss] ].
  2-5: by rewrite /checkTreeT /= rununit.
  { rewrite /checkTreeT /= rununit=> -[->].
    apply/(@Run_empty _ _ _ _ x sl')=> //.
    by rewrite /checkTreeT /= rununit. }
  move=> /[dup] r.
  rewrite run_checkTreeE.
  destruct (InterpretNode (Tree.root t) sl) as [sl'' tss err] eqn:E.
  set qss' := match qs with
              | [ ] => snd (sl'', tss)
              | _ :: _ => qs :: snd (sl'', tss)
              end.
  destruct (run (checkTreeT t qss') _) as [b st] eqn:E1.
  destruct (run (checkTreeT (Node x ts) qss) st) as [b1 ?] eqn:E2.
  move=> -[/andP ] [/andP ] [/eqb_spec_reflect] tE bE b1E sE.
  rewrite bE in E1; rewrite b1E sE in E2.
  exact/(Run_step _ _ _ _ E (eq_refl qss') E1 E2).
Qed.

Lemma eval_state_checkTreeP x ts qss st :
  reflect
    (run_chekTree_spec (Node x ts) qss st (xsnd (run (checkTreeT (Node x ts) qss) st)))
    (eval_state (checkTreeT (Node x ts) qss) st).
Proof.
  apply: (iffP idP); rewrite /eval_state.
  { move=> RE; apply/run_checkTreeP; move: RE.
    by case: (run _ _)=> /= ??->. }
  by move/run_checkTreeP=>->.
Qed.

Lemma putError_internal q err : isInternal q = true -> isInternal (putError q err).
Proof.
  intros.
  unfold putError;
  destruct q.
  destruct e.
  { simpl in H1; auto. }
  destruct i; simpl in *; auto.
Qed.

Lemma checkTree_intrenalN (t : messageTree) (qss : list (list nodeType)) sl :
  Forall (Forall (fun n => isInternal n = true)) qss ->
  eval_state (checkTreeT t qss) sl = true ->
  Forall (Tree.Forall (fun n => isInternal n = true)) (Tree.nodes t).
Proof.
  revert qss sl.
  induction t as [|t ts].
  { intros; constructor. }
  intros qss sl qsI; simpl.
  move=> /eval_state_checkTreeP runC.
  destruct runC; subst; try done.
  injection (eq_sym trE); intros; subst.
  destruct t as [n ts'].
  do ? constructor.
  { inversion qsI as [|?? X]; inversion X as [|?? Y].
    apply putError_internal with (err:=err) in Y;
    by rewrite <- tE in Y. }
  { apply (f_equal xfst) in runE1.
    eapply (IHt _ _ _ runE1); auto.
    Unshelve.
    apply IN_internal in INt.
    inversion qsI as [|?? X]; inversion X.
    by destruct qs; auto; constructor. }
  apply (f_equal xfst) in runE2.
  eapply IHt0 with (qss := qss0) (sl := st); auto.
  by inversion qsI.
Qed.

Lemma checkTree_checkRoots t qss sl :
  eval_state (checkTreeT t qss) sl = true ->
  checkRoots (fun n1 n2 => getAddrS n1 = getAddrS n2) (Tree.nodes t) qss.
Proof.
elim/Tree_ind: t qss sl=> [|t ts].
{ move=> ? [? /eval_state_checkTreeP-[|] //|>].
  by rewrite /eval_state /checkTreeT /= rununit. }
move=> n IHt1 IHt2 [>|[>|q qs qss] ].
1-2: by rewrite /eval_state /checkTreeT /= rununit.
move=> ? /eval_state_checkTreeP-[ ]//.
move=> ??? > [<-<-<-] [<-<-<-] <- qE.
move=> ??? /(f_equal xfst) r /= *.
split; last exact/IHt2/r.
by rewrite qE errorE.
Qed.

Arguments InterpretNode : simpl never.

Inductive addr_spec : messageTree -> Prop :=
  | Addr_spec1 n (t : messageTree) ts
    (addrRt       : getAddrS n = getAddrS (Tree.root t))
    (addrSts      : Forall (fun n' => getAddrS (Tree.root n') = getAddrR n) ts)
    (addr_spec_tr : Forall addr_spec (t :: ts)) :
      addr_spec (Node n (t :: ts))
  | Addr_spec2 n ts
    (addrSts      : Forall (fun n' => getAddrS (Tree.root n') = getAddrR n) ts)
    (addr_spec_tr : Forall addr_spec ts) :
      addr_spec (Node n ts).

Definition addr_spec_nodes n qss :=
  match qss with
  | q :: qs =>
    Forall (Forall (fun n' => getAddrS n' = getAddrR n)) qss \/
    Forall (Forall (fun n' => getAddrS n' = getAddrR n)) qs /\
    Forall (fun n' => getAddrS n' = getAddrS n) q
  | nil => True
  end.

Lemma add_spec_nodesF n qss :
  Forall (Forall (fun n' => getAddrS n' = getAddrR n)) qss ->
  addr_spec_nodes n qss.
Proof. by case: qss=> //=; left. Qed.

Lemma checkRoots_Forall ts qss (P : nodeType -> Prop)
  (R : nodeType -> nodeType -> Prop) :
  (forall x y, P y -> R x y -> P x) ->
  Forall (Forall P) qss ->
  checkRoots R ts qss ->
  Forall P (map (@Tree.root _) ts).
Proof.
  elim: ts qss=> /=; first by constructor.
  move=>> IHts -[ ] // [ ] //> RP X.
  inversion X as [|?? Y]; inversion Y.
  move=> [/RP] PP { }/IHts IHts.
  constructor=> //; last exact/IHts.
  exact/PP.
Qed.

Hint Resolve Tree.size_lt_cons Tree.size_lt_add_root : core.

Lemma checkTree_addr_spec t qss sl :
  addr_spec_nodes (Tree.root t) qss ->
  eval_state (checkTreeT t qss) sl = true ->
  addr_spec t.
Proof.
have AH: (forall n x y,
  getAddrS y = getAddrR n -> getAddrS x = getAddrS y -> getAddrS x = getAddrR n).
{ by move=>> ->. }
elim/Tree.ind_size: t qss sl=> -[n ts] IHt qss sl.
case: qss=> [|[|q qs] qss].
1-2: case: (ts)=> [|>]; rewrite /checkTreeT /= /eval_state rununit //.
{ by do ? constructor. }
case: ts IHt=> [|t ts] IHt.
{ by rewrite /checkTreeT /= /eval_state rununit. }
move=> ads.
case/eval_state_checkTreeP=> // ?? tss > [<-<-<-] [<-<-<-] <-.
move=> qE IN qss'E r1 r2 r3.
have adsts: (addr_spec (Node n ts)).
{ apply/IHt=> //; last exact/(f_equal xfst r2).
  move: ads=> /= -[|[ ] ] X *; apply/add_spec_nodesF=> //.
  by inversion X. }
have adstss: addr_spec_nodes (Tree.root t) tss.
{ exact/add_spec_nodesF/IN_addrS/IN. }
move: ads.
rewrite /addr_spec_nodes=> /[dup] ? -[ads|[ads1 ads2] ].
{ constructor 2.
  { move/(f_equal xfst)/checkTree_checkRoots: r3.
    by move=> /checkRoots_Forall-/(_ _ (AH _) ads) /Forall_map. }
  constructor.
  { apply/IHt=> //; last exact/(f_equal xfst r1).
    case: (qs) qss'E ads=> [|a l]-> // /Forall_forall f.
    right; split.
    { exact/IN_addrS/IN. }
    rewrite qE; apply/Forall_forall=> x In.
    move: (f (q :: a :: l))=> /(_ (or_introl eq_refl))/Forall_forall.
    move=> /[dup]/(_ x)/(_ (or_intror In))->.
    move=> /(_ q)/(_ (or_introl eq_refl)).
    by rewrite errorE=>->. }
  by inversion adsts. }
constructor 1.
{ rewrite qE.
  move/Forall_forall/(_ q (or_introl eq_refl)): ads2.
  by rewrite errorE=>->. }
{ move/(f_equal xfst)/checkTree_checkRoots: r2=> /=.
  by move=> /checkRoots_Forall-/(_ _ (AH _) ads1) /Forall_map. }
constructor; last by inversion adsts.
apply/IHt=> //; last exact/(f_equal xfst r1).
case: (qs) qss'E ads2=> [|a l]-> // /Forall_forall f.
right; split=> //.
{ exact/IN_addrS/IN. }
rewrite qE; apply/Forall_forall=> x In.
move: (f x)=> /(_ (or_intror In)).
move: (f q)=> /(_ (or_introl eq_refl)).
by rewrite errorE=>->.
Qed.

Definition error_spec `{eqb_spec Interfaces} (t : messageTree) :=
  forall t',
    let rt' := Tree.root t' in
    Tree.sub t' t ->
    isInternal rt' ->
    isSome (err_of (getError rt'))  ->
    has_money_for_on_bounce (getError rt') ->
    getBounce (getMess rt') ->
    exists2 n,
      Tree.In n t' &
      onBounce_spec (getAddrR rt') n.

Lemma checkTree_qss t sl qss :
  eval_state (checkTreeT t qss) sl = true ->
  forall x q, In q qss -> In x q -> exists err, Tree.In (putError x err) t.
Proof.
elim/Tree.ind_size: t sl qss=> -[t [|tsh tst] ] IHt sl qss.
all: case/eval_state_checkTreeP=> //.
{ by move=>> ?? ->. }
move=> ??????????? err [<-<-<-].
destruct qss as [|[|q qs] qss]=> //.
case=><-<-<-<- qE IN qss'E /(f_equal xfst) r1 /(f_equal xfst) r2 r3.
move=> ?? /= [<-/=[<-|] |].
{ by exists err; constructor 2; do ? constructor 1. }
{ case: (qs) r1 qss'E=> // ?? /IHt/[swap]->/[apply]-[ ] //.
  { by left. }
  by move=> err'; exists err'; constructor 2; constructor 1. }
move: r2=> /IHt/[apply]/[apply]-[//|] err'.
exists err'; exact/Tree.In_cons.
Qed.

Lemma checkTree_error_hyps {sl qs qss n tsh tst q qss'} :
  eval_state (checkTreeT (Node n (tsh :: tst)) qss) sl = true ->
  qss = (q :: qs) :: qss' ->
  let IntN := InterpretNode (Tree.root tsh) sl in
  [/\ getError (Tree.root tsh) = errTp_of IntN                                    ,
  incl (tss_of IntN) (if qs is nil then (tss_of IntN) else qs :: (tss_of IntN)) &
  eval_state
    (checkTreeT tsh (if qs is nil then (tss_of IntN) else qs :: (tss_of IntN)))
    (sl_of IntN) = true].
Proof.
  case/eval_state_checkTreeP=>> //.
  case=> <-<-<--><- qE IN qss'E r1 r2 r3 [? qsE ?] IntN.
  rewrite -qsE /IntN IN /= qE errorE -qss'E; split=>//.
  { move: qss'E; rewrite qsE; case: (qs)=>[|??]-> //; by right. }
  by move/(f_equal xfst): r1.
Qed.

Lemma checkTree_error_spec `{eqb_spec Interfaces} sl qss tr:
  (let IntN := InterpretNode (Tree.root tr) sl in
  getError (Tree.root tr) = errTp_of IntN ->
  incl (tss_of IntN) qss ->
  eval_state (checkTreeT tr qss) (sl_of IntN) = true ->
    error_spec tr) /\
  (eval_state (checkTreeT tr qss) sl = true ->
    Forall error_spec (Tree.nodes tr)).
Proof.
elim/Tree.ind_size: tr sl qss=> -[n ts] IHtr sl qss.
split.
{ move=> IntN err inc.
  destruct ts as [|tsh tst]=> /eval_state_checkTreeP-[ ] //.
  { move=> ? sl' ? [xE] qssE; move: inc err; rewrite /IntN qssE xE /Tree.root.
    move=> inc err <- r; rewrite /error_spec=> ?.
    rewrite Tree.subE=> -[ ]; last by move=> X; inversion X.
    move->=> /=; by rewrite err=> /IN_error/[apply]/[apply]/[apply]-[?/inc]. }
  move=> ? sl' ? sl'' ? qs qss1 qss'>; move: inc err => inc err.
  case=> <-<-<- /[dup] qssE <-<- qE IN qss'E.
  move=> r1 /(f_equal xfst) r2 /(f_equal xfst) r3.
  move=> t' /=; rewrite Tree.subE=> -[->|].
  { rewrite err => /IN_error/[apply]/[apply]/[apply]-[ ]; rewrite /Tree.root.
    move/checkTree_qss: r3=> qss_sub.
    move=> x /inc/qss_sub x_sub /Exists_exists .
    case=> n' -[/x_sub-[err' ] ]; exists (putError n' err')=> //.
    exact/onBounce_spec_putError. }
  move=> /= /Exists_cons-[ ].
    { have s: (Tree.size tsh < Tree.size (Node n (tsh :: tst)))%coq_nat by [ ].
    case: (IHtr _ s (sl_of IntN) qss')=> +_.
    case: (checkTree_error_hyps r3 qssE).
    rewrite IN -qss'E=> ???; exact. }
  have s: (Tree.size (Node n tst) < Tree.size (Node n (tsh :: tst)))%coq_nat by [ ].
  case: (IHtr _ s sl'' qss1)=> _.
  move: r2=> /[swap]/[apply] /=.
  move=> /Forall_forall f /Exists_exists-[n' [/f] ]; exact. }
destruct ts as [|tsh tst].
{ by constructor. }
case/eval_state_checkTreeP=> // ? sl' ? sl'' ? qs qss1 qss'>.
case=> <-<-<- /[dup] qssE <-<- qE IN qss'E.
move=> r1 /(f_equal xfst) r2 /(f_equal xfst) r3.
constructor.
{ have s: (Tree.size tsh < Tree.size (Node n (tsh :: tst)))%coq_nat by [ ].
  case: (IHtr _ s sl qss')=> +_.
  case: (checkTree_error_hyps r3 qssE).
  rewrite IN -qss'E=> ???; exact. }
have s: (Tree.size (Node n tst) < Tree.size (Node n (tsh :: tst)))%coq_nat by [ ].
case: (IHtr _ s sl'' qss1)=> _.
by move: r2=> /[swap]/[apply] /=.
Qed.

Lemma checkForest_IN
  (P : list (list nodeType) -> nodeType -> Prop)
  (Q : messageTree -> Prop)
  sl trs :
  (forall n sl qss err sl',
    InterpretNode n sl = mk_IN sl' qss err ->
    P qss n) ->
  (forall qss sl tr,
    P qss (Tree.root tr) ->
    eval_state (checkTreeT tr qss) sl = true -> Q tr) ->
  eval_state (checkForestT trs) sl = true -> Forall Q trs.
Proof.
move=> PP QP.
elim: trs sl; first by constructor.
move=> trh trt IHtrs sl.
rewrite checkForestE /eval_state runmodifybind runbind runget.
case E1: (InterpretNode _ _).
rewrite runputbind runbind.
case E2: (run _ _); move/(f_equal xfst): E2=> E2.
rewrite runbind.
case E3: (run _ _); move/(f_equal xfst): E3=> E3.
rewrite rununit /==> /andP-[/andP-[ ] ]; rewrite /is_true=>*; subst.
constructor.
{ exact/QP/E2/PP/E1. }
exact/IHtrs/E3.
Qed.

Arguments Tree.root {_}.
Arguments Tree.nodes {_}.

Theorem checkForest_messages_type trs ems sl :
  checkForest trs ems sl ->
  (forall tr, In tr trs -> isExternal (Tree.root tr)) /\
  (forall tr, In tr trs ->
    Forall (Tree.Forall (fun x => isInternal x)) (Tree.nodes tr)).
Proof.
move=> /andP-[/checkForest_IN] IN Eq; split.
{ elim: (trs) ems Eq=> // trh trt IHtrs [ ] // e ?.
  rewrite /= /eqb /==> /andP-[/eqb_spec_intro] tE { }/IHtrs IHtrs.
  move=> tr -[<-|/IHtrs] //.
  rewrite (isExternal_putError _ (Build_errorType None false)) tE.
  by case: (e). }
apply/Forall_forall/IN=>>.
{ exact/IN_internal. }
exact/checkTree_intrenalN.
Qed.

Theorem checkForest_addr_spec trs ems sl :
  checkForest trs ems sl ->
  Forall addr_spec trs.
Proof.
move=> /andP-[/checkForest_IN] + _; apply=>>.
{ apply IN_addrS. }
by move=> ?; apply/checkTree_addr_spec/add_spec_nodesF.
Qed.

Theorem checkForest_error_spec `{eqb_spec Interfaces} trs ems sl :
  checkForest trs ems sl ->
  Forall error_spec trs.
Proof.
move=> /andP-[+_].
elim: trs sl; first by constructor.
move=> trh trt IHtrs sl.
rewrite checkForestE /eval_state runmodifybind runbind runget.
case E1: (InterpretNode _ _)=> [sl' tss' err'].
rewrite runputbind runbind.
case E2: (run _ _); move/(f_equal xfst): E2=> E2.
rewrite runbind.
case E3: (run _ _); move/(f_equal xfst): E3=> E3.
rewrite rununit /==> /andP-[/andP-[ ] ]; rewrite /is_true=>??; subst.
move/eqb_spec_intro=> ?.
constructor.
{ case: (checkTree_error_spec (setTime (getTime (Tree.root trh)) sl) tss' trh)=> +_.
  by apply; rewrite E1. }
exact/IHtrs/E3.
Qed.

Arguments Tree.size : simpl never.

Lemma checkTreeT_inj t1 t2 tss sl :
  Tree.root t1 = Tree.root t2 ->
  eval_state (checkTreeT t1 tss) sl = true ->
  eval_state (checkTreeT t2 tss) sl = true ->
  ((t1 = t2) *
  (run (checkTreeT t2 tss) sl =
   run (checkTreeT t2 tss) sl))%type.
Proof.
move=> rE e1 e2; suff->: (t1 = t2) by [ ].
move: rE e1 e2.
elim/Tree.ind_size: t1=> -[x ts] IHt1 in t2 tss sl *.
move=> /= rE /eval_state_checkTreeP rP.
inversion rP; subst; destruct t2 as [x' ts']=> //=; first last.
all: move=> /eval_state_checkTreeP rP'.
all: inversion rP'; subst=> //.
all: case: trE=> ??; subst.
all: case: trE0=> ??; subst=> //.
case/(@eq_sym _ _ _): queE=> *; subst.
move: INt INt0 (tE) (tE0).
rewrite {1}tE {1}tE0 ?errorE=> -> -[??->/[swap]<-].
move/IHt1=> /= IH; subst.
move: (f_equal xfst runE1) (f_equal xfst runE0).
move=> { }/IH/[apply]/(_ (@Tree.size_lt_add_root _ _ _ _)).
move=> ?; subst.
move: runE1 runE0=>-> [?]; subst.
move/IHt1: (f_equal xfst runE2) (f_equal xfst runE4)=> /[apply].
by move/(_ (@Tree.size_lt_cons _ _ _ _))/(_ eq_refl)=> [->].
Qed.

Lemma MessagesQueue_run_BuildE {n fuel sl ms} :
  RunOutOfFuel (exec_state (Build fuel n) (Build_state ms sl false)) = false ->
  MessagesQueue (exec_state (Build fuel n) (Build_state ms sl false)) = [ ].
Proof.
set eq := (@eq_refl _ (run (Build fuel n) (Build_state ms sl false))).
move: {2}(run _ _) eq=> -[t [ms' sl' ?] ]=> /[dup]+/[swap].
rewrite /exec_state=>{1}->/=-> /[dup]{2}-> /=.
elim: fuel=> [|fuel IHfuel] in t n ms ms' sl sl' *.
{ by rewrite run_BuildE. }
move/run_BuildP.
case E: (InterpretNode _ _)=> [? tss ?].
set qss := if ms is nil then tss else ms :: tss.
move=> rP.
inversion rP; subst; first last.
{ by case: (ms')=> [|??] in qssE *. }
move/IHfuel: runE1=> ?; subst.
move: IHfuel runE2; clear=> IHfuel.
elim: qss0=> [|[|q qs] qss IHqss] in trt sl'0 ms' sl' *; rewrite run_BuildsE //=.
{ by case. }
case E: (run _ _)=> [?[?? r] ].
case E1: (run _ _)=> [?[ ] ]; move: E1=> /[swap].
case=> ? ->->-> E1.
have rE: r = false by exact/Builds_RunOutOfFuel/E1.
subst.
move/IHfuel: E=> ?; subst.
exact/IHqss/E1.
Qed.

Lemma run_Build_eq_root fuel n  ms sl ms1 sl1 t :
  run (Build fuel n) (Build_state ms sl false) =
  (t, Build_state ms1 sl1 false)%xprod ->
    Tree.root t = putError n (InterpretNode (Tree.root t) sl).
Proof.
move/run_BuildP.
case E: (InterpretNode _ _)=> [>] rP.
by inversion rP; rewrite -tE /= errorE INt.
Qed.

Lemma run_Build_eq_root2 fuel n  ms sl ms1 sl1 t :
  run (Build fuel n) (Build_state ms sl false) =
  (t, Build_state ms1 sl1 false)%xprod ->
    Tree.root t = putError n (InterpretNode n sl).
Proof.
move/run_BuildP.
case E: (InterpretNode _ _)=> [>] rP.
by inversion rP; rewrite -tE -E /= INt.
Qed.

Lemma checkTreeBuildE n t fuel sl sl' ms :
  let: tss  := tss_of (InterpretNode n sl) in
  let: sl'' := sl_of (InterpretNode n sl) in
  let: qss  := (if ms is nil then tss else ms :: tss)  in
  run (Build fuel n) (Build_state ms sl false) =
  (t, (Build_state nil sl' false))%xprod ->
  run (checkTreeT t qss) sl'' = (true, sl')%xprod.
Proof.
elim: fuel t ms n sl sl'=>[>|].
{ by rewrite run_BuildE. }
move=> fuel IHfuel [x ts] ms n sl sl'.
case E: (InterpretNode n sl)=> [sl'' tss err].
rewrite /tss_of /sl_of.
set qss  := (if ms is nil then tss else ms :: tss).
move/run_BuildP; rewrite {1}E -/qss=> rP.
inversion rP=> //; have slE: sl'' = sl0 by rewrite INt in E; case: E=> slE.
all: subst; rewrite -tE.
2: { by rewrite run_checkTreeE. }
rewrite run_checkTreeE.
case E6: (InterpretNode _ _)=> [sl'' tss'' err''].
case E7: (run _ _)=> [b1 s1].
case E8: (run _ _)=> [b2 s2].
move/run_Build_eq_root: (runE1) (E6)=> /[swap] -> /= /[dup] rE->.
rewrite eqbxx /=.
move: (@MessagesQueue_run_BuildE q fuel sl0 qs) (runE1).
rewrite /exec_state {1 2}runE1 /= => -> // /IHfuel.
rewrite rE errorE in E6; rewrite E6 /=.
rewrite E7=> -[-> sE] /=; subst.
elim: (qss0) (ms') (sl') (sl'0) (b2) (s2) (trt) runE2 E8.
{ clear=>>; rewrite run_BuildsE run_checkTreeE.
  by case=><-?<- [->->]. }
move: IHfuel nodeEqType; clear=> IHfuel nodeEqType.
move=> [|q qs] qss IHqss ?? sl' >; rewrite run_BuildsE //=.
case E1: (run _ _)=> [trt [?? r] ].
case E2: (run _ _)=> [trt1 st1].
case=> <- st1E; subst.
rewrite run_checkTreeE.
case E6: (InterpretNode _ _)=> [sl'' tss'' err''].
case E7: (run _ _)=> [b3 s3].
case E8: (run _ _)=> [b4 s4].
have rE: r = false by exact/Builds_RunOutOfFuel/E2.
subst.
move/run_Build_eq_root: (E1) (E6)=> /[swap] -> /= /[dup] rE->.
rewrite eqbxx /= .
move: (@MessagesQueue_run_BuildE q fuel sl' qs) (E1).
rewrite /exec_state {1 2}E1 /= => -> // /IHfuel.
rewrite rE errorE in E6; rewrite E6 /=.
rewrite E7=> -[-> sE] /=; subst.
by move/IHqss: E2=> /(_ _ _ E8)=> -[->->][->->].
Qed.

Lemma checkTreeP n t fuel sl sl' ms :
  let: tss  := tss_of (InterpretNode n sl) in
  let: sl'' := sl_of (InterpretNode n sl) in
  let: qss  := if ms is nil then tss else ms :: tss  in
  RunOutOfFuel (exec_state (Build fuel n) (Build_state ms sl false)) = false ->
  run (Build fuel n) (Build_state ms sl false) =
  (t, (Build_state nil sl' false))%xprod <->
  putError n (InterpretNode n sl) = Tree.root t /\
  run (checkTreeT t qss) sl'' = (true, sl')%xprod.
Proof.
move=> rofE; split.
{ by move=> /[dup] /run_Build_eq_root2-> /checkTreeBuildE->. }
case=> tE.
set rb := run (Build fuel n) (Build_state ms sl false).
set st := xsnd rb.
move: (@checkTreeBuildE n (xfst rb) fuel sl (SuperLedger st) ms).
move: (rofE) (MessagesQueue_run_BuildE rofE).
rewrite /exec_state /st /rb; case E: (run _ _)=> [? [ ] ].
move=> /= ->-> /(_ eq_refl).
rewrite /exec_state E /= in rofE; rewrite rofE in E.
move/run_Build_eq_root2: E=> rootE.
do 2? move=> /[dup] /(f_equal xsnd) /= {-1}<- /[swap].
move=> /(f_equal xfst)/[swap] /(f_equal xfst) /=.
by move/checkTreeT_inj/[apply]; rewrite rootE -tE=> /(_ eq_refl)-[->].
Qed.

Lemma run_buildForestE fuel ls ms sl r :
  run (buildForestT fuel ls) (Build_state ms sl r) =
  match ls with
  | [ ] => ([ ], Build_state ms sl r)%xprod
  | n :: tln =>
    let: (tree, st)%xprod :=
      run
        (Build fuel n)
        (Build_state ms (setTime (getTime n) sl) r) in
    let: (forest, st')%xprod := run (buildForestT (fuel - 1) tln) st in
      (tree :: forest, st')%xprod
  end.
Proof.
case: ls=> //= *; rewrite (rununit, runmodifybind) //.
do ? (rewrite runbind; case: (run _ _)=> * ).
by rewrite rununit.
Qed.

Lemma eval_state_buildForest1E fuel l sl ms r :
  eval_state (buildForestT fuel (l :: nil)) (Build_state ms sl r) =
  [eval_state (Build fuel l) (Build_state ms (setTime (getTime l) sl) r)].
Proof.
rewrite /eval_state run_buildForestE.
by case: (run _ _)=> [?[ ] ] *; rewrite run_buildForestE.
Qed.

Lemma exec_state_buildForest1E fuel l sl ms r :
  exec_state (buildForestT fuel (l :: nil)) (Build_state ms sl r) =
  exec_state (Build fuel l) (Build_state ms (setTime (getTime l) sl) r).
Proof.
rewrite /exec_state run_buildForestE.
by case: (run _ _)=> [?[ ] ] *; rewrite run_buildForestE.
Qed.

Lemma buildForest_RunOutOfFuel ls sl fuel ms r:
  RunOutOfFuel
    (exec_state (buildForestT fuel ls) (Build_state ms sl r)) = false ->
  r = false.
Proof.
elim: ls=> [|l ls IHl] in fuel ms sl r *; rewrite /exec_state /=.
{ by rewrite rununit. }
rewrite runmodifybind runbind.
case E1: (run _ _)=> [? [ ] ]; rewrite runbind.
case E2: (run _ _)=> [? [ ] ]; rewrite rununit.
move: E2=> /[swap] /=-> /(f_equal xsnd)/(f_equal RunOutOfFuel)/IHl.
move=> ?; subst.
exact/Build_RunOutOfFuel/E1.
Qed.

Lemma MessageQueue_run_buildForestE {ls fuel sl}:
  RunOutOfFuel
    (exec_state (buildForestT fuel ls) (Build_state nil sl false)) = false ->
  MessagesQueue
    (exec_state (buildForestT fuel ls) (Build_state nil sl false)) = nil.
Proof.
elim: ls=> [|l ls IHl] in fuel sl *; rewrite /exec_state /=.
{ by rewrite rununit. }
rewrite runmodifybind runbind.
case E1: (run _ _)=> [? [ ] ]; rewrite runbind.
case E2: (run _ _)=> [? [ ] ]; rewrite rununit.
move: (E2)=> /[swap] /= ?; subst.
move/[dup]/(f_equal xsnd)/(f_equal RunOutOfFuel).
move/buildForest_RunOutOfFuel=> ?; subst.
move/[dup]/(f_equal xsnd)/(f_equal RunOutOfFuel).
move/(f_equal xsnd)/(f_equal RunOutOfFuel)/MessagesQueue_run_BuildE: (E1).
rewrite /= /exec_state E1 /= => ?; subst=>/IHl.
by rewrite /exec_state E2.
Qed.

Lemma rof_buildForest_cons {l ls fuel sl tr tr' ms1 sl1 ms2 sl2 r1 r2} :
  let: st1 := Build_state ms1 sl1 r1 in
  let: st2 := Build_state ms2 sl2 r2 in
  RunOutOfFuel
  (exec_state (buildForestT fuel (l :: ls)) (Build_state nil sl false)) = false ->
  run (Build fuel l) (Build_state nil (setTime (getTime l) sl) false) =
     (tr, st1)%xprod ->
  run (buildForestT (fuel - 1) ls) st1 = (tr', st2)%xprod ->
  (r1  = false) *
  (r2  = false) *
  (ms1 = nil)   *
  (ms2 = nil).
Proof.
rewrite /exec_state /= runmodifybind runbind.
case E1: (run _ _)=> [? [ ] ]; rewrite runbind.
case E2: (run _ _)=> [? [ ] ]; rewrite rununit.
move=> /= ?; subst.
move/(f_equal xsnd)/(f_equal RunOutOfFuel)/buildForest_RunOutOfFuel: (E2)=> /= ?.
subst.
move/(f_equal xsnd)/(f_equal RunOutOfFuel)/MessagesQueue_run_BuildE: (E1)=> /= E.
rewrite /exec_state E1 /= in E; subst.
move/(f_equal xsnd)/(f_equal RunOutOfFuel)/MessageQueue_run_buildForestE: (E2).
by rewrite /exec_state E2=> /= ?; subst=> -[? <-<-<-]; rewrite E2=> -[?<-?<-].
Qed.

Lemma checkForestTP fr ls fuel sl sl' :
  RunOutOfFuel
    (exec_state (buildForestT fuel ls) (Build_state nil sl false)) = false ->
  (map (fun t => putError (Tree.root t) (Build_errorType None false)) fr) =
  (map (fun m => putError m (Build_errorType None false)) ls) /\
  run (checkForestT fr) sl = (true, sl')%xprod <->
  run (buildForestT fuel ls) (Build_state nil sl false) =
  (fr, Build_state nil sl' false)%xprod.
Proof.
elim: ls=> [/=|l ls IHl] in fr fuel sl sl' *.
{ rewrite /exec_state ?rununit /==> ?.
  case: fr=> [/=|]; last split=> [ [ ]|] //.
  by rewrite rununit; split=> [ [? [ ] ]|[ ] ]->. }
move=> rofE /=.
rewrite runmodifybind runbind.
case E1: (run (Build _ _) _)=> [a [? sl'' ?] ].
rewrite runbind.
case E2: (run (buildForestT _ _) _)=> [b [? sl0 ?] ].
rewrite rununit.
have runE1 := E1; have runE2 := E2.
rewrite ?(rof_buildForest_cons rofE E1 E2) {E1 E2} in runE1 runE2 *.
split.
{ case=> lsE ct.
  destruct fr as [|tr fr]=> //.
  move: ct; rewrite /=.
  rewrite runmodifybind runbind runget.
  case E3: (InterpretNode _ _)=> [sl1 tss1 err1].
  rewrite runputbind runbind.
  case E4: (run _ _)=> [? sl'''].
  rewrite runbind.
  case E5: (run _ _)=> [ ].
  rewrite rununit=> -[/andP-[/andP-[ ] ] ]; rewrite /is_true=> ??+?; subst.
  move=> /eqb_spec_reflect.
  move: (@checkTreeP l tr fuel (setTime (getTime l) sl) sl''' nil).
  move: lsE=> /= [ ] /(f_equal (fun x => putError x (getError l))).
  rewrite ?errorE=> {5 6 7 8 9 10 11}<- lsE.
  rewrite ?errorE ?E3 /= => -[ ].
  { by rewrite /exec_state runE1. }
  move=> _ /[swap]<-; rewrite ?errorE E4=> /(_ (conj eq_refl eq_refl)).
  rewrite runE1=> -[??]; subst.
  case: (IHl fr (fuel - 1) sl''' sl').
  { by rewrite /exec_state runE2. }
  rewrite lsE E5=> /(_ (conj eq_refl eq_refl)).
  by rewrite runE2=> -[->->]. }
case=> <-<- /=.
rewrite runmodifybind runbind runget.
case E3: (InterpretNode _ _)=> [sl1 tss1 err1].
rewrite runputbind runbind.
case E4: (run _ _)=> [? sl'''].
rewrite runbind.
case E5: (run _ _)=> [ ].
rewrite rununit.
move: (@checkTreeP l a fuel (setTime (getTime l) sl) sl'' nil).
case.
{ by rewrite /exec_state runE1. }
move=> /(_ runE1) -[ ] ++ _.
move=> aE; move: E3; rewrite -aE ?errorE=>-> /=.
rewrite ?errorE eqbxx E4=> -[??]; subst.
case: (IHl b (fuel - 1) sl'' sl0).
{ by rewrite /exec_state runE2. }
by move=> _ /(_ runE2) -[-> ]; rewrite E5=> -[->->].
Qed.

Lemma checkForestP fr scen fuel sl :
  buildFinished fuel scen sl ->
  reflect (fr = buildForest fuel scen sl) (checkForest fr scen sl).
Proof.
rewrite /buildFinished=> /negbTE /[dup] rofE /checkForestTP cE.
rewrite /checkForest /buildForest /eval_state.
apply/(iffP andP).
{ case=> fE /eqb_spec_reflect ?.
  rewrite (proj1 (cE fr (xsnd (run (checkForestT fr) sl)))); split=> //.
  by case: (run _ _) fE=> //= ??->. }
move=> frE.
destruct
  (cE
    fr
    (SuperLedger
      (xsnd
        (run
          (buildForestT fuel (mapNode scen))
          (Build_state nil sl false))))) as [_ bE].
case: bE=> [|-> ->] //=; last by rewrite eqbxx.
move/MessageQueue_run_buildForestE: rofE (rofE).
by rewrite frE /exec_state; case: (run _ _)=> /= ? [/=> ->->].
Qed.

Lemma execForestE fr scen fuel sl :
  buildFinished fuel scen sl ->
  checkForest fr scen sl ->
  execForest fr sl = buildSLedger fuel scen sl.
Proof.
move=> /[dup] + /checkForestP/[apply]+->.
rewrite /buildFinished=> /negbTE /[dup] rofE /checkForestTP cE.
rewrite /execForest /buildSLedger /exec_state /=.
case: (cE (buildForest fuel scen sl)
  (SuperLedger
    (xsnd
      (run
        (buildForestT fuel (mapNode scen))
        (Build_state nil sl false)))))=> _ [|?->] //.
move/MessageQueue_run_buildForestE: rofE (rofE).
rewrite /exec_state; case E: (run _ _)=> [? [/=> ] ].
by move=>->->; rewrite /buildForest /eval_state E.
Qed.

Arguments buildForestT : simpl never.

Lemma buildForest_cat fuel ems1 ems2 sl :
  buildFinished fuel ems1 sl ->
  buildForest fuel (ems1 ++ ems2) sl =
  buildForest fuel ems1 sl ++
  buildForest (fuel - length ems1) ems2 (buildSLedger fuel ems1 sl).
Proof.
elim: ems1=> [/=|em ems1 IHems1 /=] in fuel ems2 sl *.
{ rewrite /buildForest /eval_state rununit /= subn0.
  by rewrite /buildSLedger /exec_state /= rununit. }
rewrite /buildFinished=> /negbTE rofE.
rewrite /buildForest /buildSLedger /eval_state /exec_state /=.
rewrite 2?run_buildForestE.
case E1: (run (Build _ _) _)=> [a [? sl' ?] ].
case E2: (run (buildForestT _ _) _)=> [b [ ] ].
case E3: (run (buildForestT _ _) _)=> [c [ ] ].
case E4: (run (buildForestT _ _) _)=> [d [ ] ].
move=> /=; apply/f_equal.
move: (IHems1 (fuel - 1) ems2 sl').
rewrite /buildForest /eval_state.
have runE1 := E1; have runE3 := E3.
rewrite !(rof_buildForest_cons rofE E1 E3) {E1 E3} in runE1 runE3 E4 E2 *.
have->: fuel - 1 - length ems1 = fuel - (length ems1).+1 by lia.
rewrite /buildFinished /buildSLedger /exec_state ?runE3 E2 /= E4.
exact.
Qed.

Section LedgerInvariants.

Variable (P : superLedger -> Prop).

Hypothesis P_inv_IN : forall n sl sl',
  P sl ->
  sl' = sl_of (InterpretNode n sl) ->
  P sl'.

(* Lemma P_inv_CT tr qss st :
  P st ->
  P (exec_state (checkTreeT tr qss) st).
Proof.
  rewrite /exec_state.
  case: st qss; elim/Tree.ind: tr=> /=.
  { move=> x ms sl qss ?; case: qss.
    { by rewrite run_checkTreeE. }
    by rewrite /checkTreeT /= rununit. }
  move=> t ts x ++++ qss.
  case: qss=> [*|[*|q qs qss IHtr1 IHtr2 ms sl Psl] ].
  1-2: by rewrite /checkTreeT /= rununit.
  rewrite run_checkTreeE.
  case E1: (InterpretNode _ _)=> [sl' tss].
  set qss' := if ms is nil then tss else ms :: tss.
  case E2: (run (checkTreeT _ _) _)=> [b [ms1 sl1] ].
  case E3: (run _ _) => [b' st' /=].
  move/(f_equal xsnd): E3=> /=<-.
  apply/IHtr2.
  move/(f_equal xsnd)/(f_equal SuperLedger): E2=> /=<-.
  apply/IHtr1/(P_inv_IN (Tree.root t) Psl).
  by rewrite E1.
Qed. *)

End LedgerInvariants.

End MessageTree.


Require Import Lia.
Require Import RelationClasses.

From Paco Require Import paco.
From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
Require Import Time.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.
Require Import Behavior.

Require Import AMemory.
Require Import ALocal.
Require Import AThread.
Require Import Race.

Require Import APF.
Require Import PF.
Require Import PFSingle.
Require Import DRF_PF.

Lemma sim_apf_pf_racefree c
      (RACEFREE: pf_racefree PFSingle.step c)
  :
    pf_racefree PFConfiguration.step c.
Proof.
  ii. ginduction STEPS; i.
  - eapply RACEFREE; eauto.
  - inv H. exploit PFSingle.step_sim; eauto. i. des.
    eapply IHSTEPS; auto. ii. eapply RACEFREE; cycle 1; eauto. etrans.
    + eapply rtc_implies; try apply STEPS0. i. inv H. econs; eauto.
    + econs; eauto. econs; eauto.
Qed.

Theorem drf_single_pf s
        (RACEFREE: pf_racefree PFSingle.step (Configuration.init s))
  :
    behaviors Configuration.step (Configuration.init s) <1=
    behaviors PFSingle.step (Configuration.init s).
Proof.
  ii. eapply PFSingle.long_step_equiv.
  eapply drf_pf; eauto.
  eapply sim_apf_pf_racefree; eauto.
Qed.


Require Import Raft.
Require Import TraceUtil.

Section InputBeforeOutputInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Section inner.
  Variables client id : nat.

  Definition input_before_output (tr : list (name * (raft_input + list raft_output))) :=
    before_func (is_input_with_key client id) (is_output_with_key client id) tr.
  End inner.

  Class input_before_output_interface : Prop :=
    {
      output_implies_input_before_output :
        forall client id failed net tr,
          step_f_star step_f_init (failed, net) tr ->
          key_in_output_trace client id tr ->
          input_before_output client id tr
    }.
End InputBeforeOutputInterface.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C G Aprime Aprimeprime Bprime Cprime Bprimeprime Bprimeprimeprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprimeprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ G Aprime /\ (wd_ G Aprimeprime /\ (wd_ G Bprimeprime /\ (wd_ Aprime Bprimeprime /\ (wd_ Bprimeprime Bprimeprimeprime /\ (wd_ G Bprimeprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (wd_ A G /\ (wd_ Aprimeprime A /\ (wd_ A Aprime /\ (col_ Aprime Bprime Bprimeprimeprime /\ (col_ G Bprimeprime Bprimeprimeprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ G Aprime Aprimeprime /\ (col_ Aprimeprime A G /\ (col_ Aprime B C /\ (col_ Aprime Bprimeprime Aprime /\ (col_ A Aprimeprime Aprime /\ col_ Aprime Bprimeprime A))))))))))))))))))))))))))))))))))) -> col_ A B G)).
Proof.
  time tac.
Qed.

End FOFProblem.