Require Import AggregateType.demo2.expr.
Require Import AggregateType.demo2.computable_theorems.

(***************************************************

1. Define two well-founded relation here and one induction principle here

***************************************************)

Module TypeTree.
Section TypeTree.

Context {cs: compspecs}.

Definition typeR (t1: type) (t2: type): Prop :=
  match t2 with
  | Tstruct sid => exists i1, In (i1, t1) (co_members (get_co sid))
  | _ => False
  end.

Lemma wf_typeR: well_founded typeR.
Proof.
  hnf; intro t.
  remember (rank_type cenv_cs t) eqn:?H.
  pose proof le_n n.
  rewrite H in H0 at 1; clear H.
  revert t H0; induction n; intros.
  + constructor; intros.
    destruct t.
    - inversion H.
    - destruct H as [yid ?].
      unfold get_co in H.
      cbv [rank_type] in H0; simpl in H0.
      destruct (Maps.PTree.get id cenv_cs) eqn:?; [inversion H0 |].
      simpl in H; inversion H.
  + constructor; intros.
    destruct t.
    - inversion H.
    - destruct H as [yid ?].
      unfold get_co in H.
      cbv [rank_type] in H0; simpl in H0.
      destruct (Maps.PTree.get id cenv_cs) eqn:?; [| inversion H].
      apply rank_type_members with (ce := cenv_cs) in H.
      pose proof co_consistent_rank _ _ (cenv_consistent id c Heqo).
      rewrite <- H1 in H.
      apply le_S_n in H0.
      apply IHn.
      apply le_trans with (co_rank c); assumption.
Defined.

End TypeTree.
End TypeTree.

Module RankLt.
Section RankLt.

Context {cs: compspecs}.

Definition typeR (t1: type) (t2: type): Prop := (rank_type cenv_cs t1 < rank_type cenv_cs t2)%nat.

Lemma wf_typeR: well_founded typeR.
Proof.
  hnf; intro t.
  remember (rank_type cenv_cs t) eqn:?H.
  pose proof le_n n.
  rewrite H in H0 at 1; clear H.
  revert t H0; induction n; intros.
  + constructor; intros.
    unfold typeR in H.
    pose proof le_trans _ _ _ H H0.
    inversion H1.
  + constructor; intros.
    destruct t.
    - inversion H.
    - unfold typeR in H.
      simpl in *.
      destruct (Maps.PTree.get id cenv_cs) eqn:?; [| inversion H].
      pose proof le_trans _ _ _ H H0.
      apply le_S_n in H1.
      apply IHn; auto.
Defined.

End RankLt.
End RankLt.

Module RankInd.
Section RankInd.

Context {cs: compspecs}.

Lemma type_ind: forall P : type -> Prop,
  (forall t,
  match t with
  | Tstruct id => let m := co_members (get_co id) in Forall (fun it => P (snd it)) m
  | _ => True
  end -> P t) ->
  forall t, P t.
Proof.
  intros P IH_TYPE.
  intros.
  remember (rank_type cenv_cs t) as n eqn: RANK'.
  assert (rank_type cenv_cs t <= n)%nat as RANK.
  subst. apply le_n.
  clear RANK'.
  revert t RANK.
  induction n;
  intros;
  specialize (IH_TYPE t); destruct t;
  try solve [specialize (IH_TYPE I); auto].
  + (* Tstruct level 0 *)
    simpl in RANK.
    unfold get_co in IH_TYPE.
    destruct (Maps.PTree.get id cenv_cs); [inv RANK | apply IH_TYPE; simpl; constructor].
  + (* Tstruct level positive *)
    simpl in RANK.
    pose proof I. (*get_co_members_no_replicate i.*)
    unfold get_co in *.
    destruct (Maps.PTree.get id cenv_cs) as [co |] eqn:CO; [| apply IH_TYPE; simpl; constructor].
    apply IH_TYPE; clear IH_TYPE.
    apply Forall_forall.
    intros [i0 t0] ?; simpl.
    apply IHn.
    pose proof rank_type_members _ _ _ _ H0.
    eapply le_trans; [eassumption |].
    apply le_S_n; auto.
    rewrite <- co_consistent_rank; auto.
    exact (cenv_consistent id co CO).
Defined.

End RankInd.

Ltac type_induction t :=
  pattern t;
  match goal with
  | |- ?P t =>
    apply type_ind; clear t;
    let t := fresh "t" in
    intros t IH;
    let id := fresh "id" in
    destruct t as [ | id]
  end.

End RankInd.

(***************************************************

2. Several different approaches of defining reptype.

***************************************************)

Module Fix_TypeTree.
Section Fix_TypeTree.

Context {cs: compspecs}.

Lemma typeR_spec_members_aux: forall (m : members),
  Forall (fun p : ident * type => exists i1 : ident, In (i1, snd p) m) m.
Proof.
  intros.
  induction m.
  + constructor.
  + destruct a.
    constructor.
    - exists i; left; auto.
    - revert IHm; apply Forall_impl.
      intros.
      destruct H as [i1 ?].
      exists i1.
      right; auto.
Defined.

Definition typeR_spec_members sid: Forall (fun p => TypeTree.typeR (snd p) (Tstruct sid)) (co_members (get_co sid)) :=
  typeR_spec_members_aux (co_members (get_co sid)).

Definition typeR_spec (t: type):
  match t with
  | Tint => True
  | Tstruct sid => Forall (fun p => TypeTree.typeR (snd p) t) (co_members (get_co sid))
  end :=
  match t with
  | Tint => I
  | Tstruct sid => typeR_spec_members sid
  end.

Definition reptype_fix_aux (y: type): (forall x, TypeTree.typeR x y -> Type) -> Type.
Proof.
  refine
  ((match y as y_PAT
      return match y_PAT with
             | Tint => True
             | Tstruct sid => Forall (fun p => TypeTree.typeR (snd p) y_PAT) (co_members (get_co sid))
             end ->
             (forall x : type, TypeTree.typeR x y_PAT -> Type) ->
             Type
    with
    | Tint => fun _ _ => val
    | Tstruct sid => fun H f =>
       (fix reptype_fix_aux_members (m: members): Forall (fun p => TypeTree.typeR (snd p) (Tstruct sid)) m -> Type :=
          match m as m_PAT
            return Forall (fun p => TypeTree.typeR (snd p) (Tstruct sid)) m_PAT -> Type
          with
          | nil => fun _ => unit
          | (i, t) :: m0 => fun H => prod (f t _) (reptype_fix_aux_members m0 _)
          end) _ H
    end) (typeR_spec y)).
  + apply Forall_inv in H; exact H.
  + apply Forall_inv2 in H; exact H.
Defined.

Definition reptype : type -> Type := Fix TypeTree.wf_typeR (fun _ => Type) reptype_fix_aux.

Lemma reptype_eq: forall t: type, reptype t =
  match t with
  | Tint => val
  | Tstruct id =>
      (fix reptype_members (m: members): Type :=
        match m with
        | nil => unit
        | cons (_, t0) m0 => (reptype t0 * reptype_members m0)%type
        end) (co_members (get_co id))
  end.
Proof.
  intros.
  unfold reptype.
  rewrite Fix_eq.
  Focus 2. {
    intros.
    unfold reptype_fix_aux.
    destruct x; auto.
    simpl in *.
    unfold typeR_spec_members.
    generalize (typeR_spec_members_aux (co_members (get_co id))).
    revert f g H.
    (* We should be really careful that we only do induction on the occurence as m not M. *)
    set (m := co_members (get_co id)) at 5 13 21. clearbody m.
    set (M := co_members (get_co id)). clearbody M.
    intros.
    induction m as [| [i0 t0] m]; auto.
    intros.
    f_equal; auto.
  } Unfocus.
  destruct t; auto.
  unfold reptype_fix_aux at 1; simpl.
  unfold typeR_spec_members.
  generalize (typeR_spec_members_aux (co_members (get_co id))).
  (* We should be really careful that we only do induction on the occurence as m not M. *)
  set (m := co_members (get_co id)) at 2 9 10; clearbody m.
  set (M := co_members (get_co id)); clearbody M.
  induction m as [| [i0 t0] m]; auto.
  intros.
  f_equal; auto.
Qed.

Definition default_val_fix_aux (y: type): (forall x, TypeTree.typeR x y -> reptype x) -> reptype y.
Proof.
  intros.
  (* We have to use explicit type casting here because we do not want to access the intermediate function Fix_F in standard WF-recursion library. *)
  refine
   (eq_rect_r (fun T => T)
    ((match y as y_PAT
        return match y_PAT with
               | Tint => True
               | Tstruct sid => Forall (fun p => TypeTree.typeR (snd p) y_PAT) (co_members (get_co sid))
               end ->
               (forall x : type, TypeTree.typeR x y_PAT -> reptype x) ->
               match y_PAT with
               | Tint => val
               | Tstruct id =>
                   (fix reptype_members (m: members): Type :=
                     match m with
                     | nil => unit
                     | cons (_, t0) m0 => (reptype t0 * reptype_members m0)%type
                     end) (co_members (get_co id))
               end
      with
      | Tint => fun _ _ => Vundef
      | Tstruct sid => fun H f =>
         (fix default_val_fix_aux_members (m: members):
            Forall (fun p => TypeTree.typeR (snd p) (Tstruct sid)) m ->
            (fix reptype_members (m: members): Type :=
                     match m with
                     | nil => unit
                     | cons (_, t0) m0 => (reptype t0 * reptype_members m0)%type
                     end) m :=
            match m as m_PAT
              return Forall (fun p => TypeTree.typeR (snd p) (Tstruct sid)) m_PAT ->
                     (fix reptype_members (m: members): Type :=
                     match m with
                     | nil => unit
                     | cons (_, t0) m0 => (reptype t0 * reptype_members m0)%type
                     end) m_PAT
            with
            | nil => fun _ => tt
            | (i, t) :: m0 => fun H => (f t _, default_val_fix_aux_members m0 _)
            end) _ H
      end) (typeR_spec y) X)
    (reptype_eq y)).
  + apply Forall_inv in H; exact H.
  + apply Forall_inv2 in H; exact H.
Defined.

Definition default_val: forall (t: type), reptype t := Fix TypeTree.wf_typeR reptype default_val_fix_aux.

End Fix_TypeTree.
End Fix_TypeTree.

Module Function_TypeTree.
Section Function_TypeTree.

Variable env: composite_env.
Hypothesis consist_env: composite_env_consistent env.

(* Automation system of Program Fixpoint fail to catch the correct induction principle. *)
(*
Program Fixpoint reptype (t: type) {wf (TypeTree.typeR env) t}: Type :=
  match t with
  | Tint => val
  | Tstruct id =>
      (fix reptype_members (m: members): Type :=
        match m with
        | nil => unit
        | cons (_, t0) m0 => ((reptype t0) * reptype_members m0)%type
        end) (co_members (get_co env id))
  end.
Next Obligation.
*)

(* Function keyword does not allow nested recursion. *)
(*
Function reptype (t: type) {wf (TypeTree.typeR env) t}: Type :=
  match t with
  | Tint => val
  | Tstruct id =>
      (fix reptype_members (m: members): Type :=
        match m with
        | nil => unit
        | cons (_, t0) m0 => ((reptype t0) * reptype_members m0)%type
        end) (co_members (get_co env id))
  end.
*)

End Function_TypeTree.
End Function_TypeTree.

Module ManualWf_TypeTree.

Section ManualWf_TypeTree.

Context {cs: compspecs}.

Inductive ForallT {A : Type} (P : A -> Type) : list A -> Type :=
    ForallT_nil : ForallT P nil
  | ForallT_cons : forall (x : A) (l : list A),
                  P x -> ForallT P l -> ForallT P (x :: l).

Inductive acc_type: type -> Type :=
  | acc_Tint: acc_type Tint
  | acc_Tstruct: forall id, ForallT (fun p => acc_type (snd p)) (co_members (get_co id)) -> acc_type (Tstruct id).

Section AccTypeInd.

Variable P: forall t, acc_type t -> Prop.

Fixpoint P_members (m: members) (wit_m: ForallT (fun p => acc_type (snd p)) m): Prop :=
  match wit_m with
  | ForallT_nil => True
  | ForallT_cons (i, t) m0 wit_t wit_m0 => P t wit_t /\ P_members m0 wit_m0
  end.

Hypothesis P_Tint: P Tint acc_Tint.

Hypothesis P_Tstruct: forall sid (wit: ForallT (fun p => acc_type (snd p)) (co_members (get_co sid))), P_members (co_members (get_co sid)) wit -> P (Tstruct sid) (acc_Tstruct sid wit).

Fixpoint acc_type__ind (t: type) (wit_t: acc_type t): P t wit_t :=
  match wit_t as wit_t_PAT in acc_type t_PAT
    return P t_PAT wit_t_PAT
  with
  | acc_Tint => P_Tint
  | acc_Tstruct sid wit =>
      P_Tstruct sid wit
      ((fix acc_type_ind_members (m: members) (wit_m: ForallT (fun p => acc_type (snd p)) m): P_members m wit_m :=
        match wit_m as wit_m_PAT in ForallT _ m_PAT
          return P_members m_PAT wit_m_PAT
        with
        | ForallT_nil => I
        | ForallT_cons (i0, t0) m0 wit_t0 wit_m0 => conj (acc_type__ind t0 wit_t0) (acc_type_ind_members m0 wit_m0)
        end) (co_members (get_co sid)) wit)
  end.

End AccTypeInd.

Definition acc_type_gen (t: type): acc_type t.
  remember (rank_type cenv_cs t) eqn:?H.
  pose proof le_n n.
  rewrite H in H0 at 1; clear H.
  revert t H0; induction n; intros.
  + destruct t.
    - constructor.
    - constructor.
      unfold get_co.
      cbv [rank_type] in H0; simpl in H0.
      destruct (Maps.PTree.get id cenv_cs) eqn:?; [apply le_Sn_0 in H0; inversion H0 |].
      simpl; constructor.
  + destruct t.
    - constructor.
    - constructor; intros.
      unfold get_co.
      cbv [rank_type] in H0; simpl in H0.
      destruct (Maps.PTree.get id cenv_cs) eqn:?; [| simpl; constructor].
      pose proof co_consistent_rank _ _ (cenv_consistent id c Heqo).
      rewrite H in H0.
      apply le_S_n in H0.
      remember (co_members c) as m.
      clear c Heqo Heqm H.
      induction m; constructor.
      * destruct a; simpl in H0 |- *.
        apply IHn.
        pose proof le_max_l (rank_type cenv_cs t) (rank_members cenv_cs m).
        eapply le_trans; eassumption.
      * apply IHm.
        destruct a; simpl in H0.
        pose proof le_max_r (rank_type cenv_cs t) (rank_members cenv_cs m).
        eapply le_trans; eassumption.
Defined.

Fixpoint reptype_aux (t: type) (wit_t: acc_type t): Type :=
  match wit_t in acc_type t_PAT with
  | acc_Tint => val
  | acc_Tstruct id wit_id =>
     (fix reptype_aux_members (m: members) (wit_m: ForallT (fun p => acc_type (snd p)) m): Type :=
        match wit_m with
        | ForallT_nil => unit
        | ForallT_cons (_, t0) m0 wit_t0 wit_m0 => (reptype_aux t0 wit_t0 * reptype_aux_members m0 wit_m0)%type
        end) (co_members (get_co id)) wit_id
  end.

Definition reptype (t: type) := reptype_aux t (acc_type_gen t).

Lemma reptype_eq: forall t: type, reptype t =
  match t with
  | Tint => val
  | Tstruct id =>
      (fix reptype_members (m: members): Type :=
        match m with
        | nil => unit
        | cons (_, t0) m0 => (reptype t0 * reptype_members m0)%type
        end) (co_members (get_co id))
  end.
Proof.
  intros.
  unfold reptype at 1.
  (* Because the function acc_type_gen is complicated. It is impossible to unfold it and prove by induction or case analysis on t. *)
  (* So, the only way is to prove (reptype_aux t wit1 = reptype_aux t wit2) first, which is similar to proving Fix_F_inv in the standard well-founded recursion library. Also, the proof goal will be much harder to read and operate in this specific example. *)
Abort.

Fixpoint default_val_aux (t: type) (wit_t: acc_type t): reptype_aux t wit_t :=
  match wit_t as wit_t_PAT in acc_type t_PAT return reptype_aux t_PAT wit_t_PAT with
  | acc_Tint => Vundef
  | acc_Tstruct id wit_id =>
     (fix default_val_aux_members (m: members) (wit_m: ForallT (fun p => acc_type (snd p)) m):
        (fix reptype_aux_members (m: members) (wit_m: ForallT (fun p => acc_type (snd p)) m): Type :=
        match wit_m with
        | ForallT_nil => unit
        | ForallT_cons (_, t0) m0 wit_t0 wit_m0 => (reptype_aux t0 wit_t0 * reptype_aux_members m0 wit_m0)%type
        end) m wit_m :=
        match wit_m  as wit_m_PAT in (ForallT _ m_PAT) return (fix reptype_aux_members (m: members) (wit_m: ForallT (fun p => acc_type (snd p)) m): Type :=
        match wit_m with
        | ForallT_nil => unit
        | ForallT_cons (_, t0) m0 wit_t0 wit_m0 => (reptype_aux t0 wit_t0 * reptype_aux_members m0 wit_m0)%type
        end) m_PAT wit_m_PAT with
        | ForallT_nil => tt
        | ForallT_cons (_, t0) m0 wit_t0 wit_m0 => (default_val_aux t0 wit_t0, default_val_aux_members m0 wit_m0)%type
        end) (co_members (get_co id)) wit_id
  end.

Definition default_val (t: type): reptype t := default_val_aux t (acc_type_gen t).

End ManualWf_TypeTree.

End ManualWf_TypeTree.

Module Fix_RankLt.

Section Fix_RankLt.

Context {cs: compspecs}.

Definition typeR (t1: type) (t2: type): Prop := (rank_type cenv_cs t1 < rank_type cenv_cs t2)%nat.

Lemma wf_typeR: well_founded typeR.
Proof.
  hnf; intro t.
  remember (rank_type cenv_cs t) eqn:?H.
  pose proof le_n n.
  rewrite H in H0 at 1; clear H.
  revert t H0; induction n; intros.
  + constructor; intros.
    unfold typeR in H.
    pose proof le_trans _ _ _ H H0.
    inversion H1.
  + constructor; intros.
    destruct t.
    - inversion H.
    - unfold typeR in H.
      simpl in *.
      destruct (Maps.PTree.get id cenv_cs) eqn:?; [| inversion H].
      pose proof le_trans _ _ _ H H0.
      apply le_S_n in H1.
      apply IHn; auto.
Defined.

Lemma typeR_spec_members_aux: forall (m : members),
  Forall (fun p : ident * type => rank_type cenv_cs (snd p) < S (rank_members cenv_cs m))%nat m.
Proof.
  intros.
  induction m.
  + constructor.
  + destruct a.
    constructor.
    - simpl.
      apply le_n_S.
      apply le_max_l.
    - revert IHm; apply Forall_impl.
      intros.
      apply (le_trans _ _ _ H).
      simpl.
      apply le_n_S.
      apply le_max_r.
Defined.

Lemma typeR_spec_members sid: Forall (fun p => typeR (snd p) (Tstruct sid)) (co_members (get_co sid)).
Proof.
  unfold typeR.
  simpl.
  unfold get_co.
  destruct (Maps.PTree.get sid cenv_cs) eqn:?.
  + erewrite co_consistent_rank by (eapply (cenv_consistent _ _ Heqo)).
    apply typeR_spec_members_aux.
  + constructor.
Defined.

Definition typeR_spec (t: type):
  match t with
  | Tint => True
  | Tstruct sid => Forall (fun p => typeR (snd p) t) (co_members (get_co sid))
  end :=
  match t with
  | Tint => I
  | Tstruct sid => typeR_spec_members sid
  end.

Definition reptype_fix_aux (y: type): (forall x, typeR x y -> Type) -> Type.
Proof.
  refine
  ((match y as y_PAT
      return match y_PAT with
             | Tint => True
             | Tstruct sid => Forall (fun p => typeR (snd p) y_PAT) (co_members (get_co sid))
             end ->
             (forall x : type, typeR x y_PAT -> Type) ->
             Type
    with
    | Tint => fun _ _ => val
    | Tstruct sid => fun H f =>
       (fix reptype_fix_aux_members (m: members): Forall (fun p => typeR (snd p) (Tstruct sid)) m -> Type :=
          match m as m_PAT
            return Forall (fun p => typeR (snd p) (Tstruct sid)) m_PAT -> Type
          with
          | nil => fun _ => unit
          | (i, t) :: m0 => fun H => prod (f t _) (reptype_fix_aux_members m0 _)
          end) _ H
    end) (typeR_spec y)).
  + apply Forall_inv in H; exact H.
  + apply Forall_inv2 in H; exact H.
Defined.

Definition reptype : type -> Type := Fix wf_typeR (fun _ => Type) reptype_fix_aux.

Lemma reptype_eq: forall t: type, reptype t =
  match t with
  | Tint => val
  | Tstruct id =>
      (fix reptype_members (m: members): Type :=
        match m with
        | nil => unit
        | cons (_, t0) m0 => (reptype t0 * reptype_members m0)%type
        end) (co_members (get_co id))
  end.
Proof.
  intros.
  unfold reptype.
  rewrite Fix_eq.
  Focus 2. {
    intros.
    unfold reptype_fix_aux.
    destruct x; auto.
    simpl in *.
    (* We should be careful not to unfold this proof at all. *)
    generalize (typeR_spec_members id).
    revert f g H.
    unfold typeR, get_co; simpl.
    destruct (Maps.PTree.get id cenv_cs) eqn:?; [| auto].
    set (m := (co_members c)). clearbody m.
    intros.
    induction m as [| [i0 t0] m]; auto.
    intros.
    f_equal; auto.
  } Unfocus.
  destruct t; auto.
  unfold reptype_fix_aux at 1; simpl.
  (* We should be careful not to unfold this proof at all. *)
  generalize (typeR_spec_members id).
  unfold typeR, get_co; simpl.
  destruct (Maps.PTree.get id cenv_cs) eqn:?; [| auto].
  set (m := (co_members c)). clearbody m.
  intros.
  induction m as [| [i0 t0] m]; auto.
  intros.
  f_equal; auto.
Qed.

Definition default_val_fix_aux (y: type): (forall x, typeR x y -> reptype x) -> reptype y.
Proof.
  intros.
  (* We have to use explicit type casting here because we do not want to access the intermediate function Fix_F in standard WF-recursion library. *)
  refine
   (eq_rect_r (fun T => T)
    ((match y as y_PAT
        return match y_PAT with
               | Tint => True
               | Tstruct sid => Forall (fun p => typeR (snd p) y_PAT) (co_members (get_co sid))
               end ->
               (forall x : type, typeR x y_PAT -> reptype x) ->
               match y_PAT with
               | Tint => val
               | Tstruct id =>
                   (fix reptype_members (m: members): Type :=
                     match m with
                     | nil => unit
                     | cons (_, t0) m0 => (reptype t0 * reptype_members m0)%type
                     end) (co_members (get_co id))
               end
      with
      | Tint => fun _ _ => Vundef
      | Tstruct sid => fun H f =>
         (fix default_val_fix_aux_members (m: members):
            Forall (fun p => typeR (snd p) (Tstruct sid)) m ->
            (fix reptype_members (m: members): Type :=
                     match m with
                     | nil => unit
                     | cons (_, t0) m0 => (reptype t0 * reptype_members m0)%type
                     end) m :=
            match m as m_PAT
              return Forall (fun p => typeR (snd p) (Tstruct sid)) m_PAT ->
                     (fix reptype_members (m: members): Type :=
                     match m with
                     | nil => unit
                     | cons (_, t0) m0 => (reptype t0 * reptype_members m0)%type
                     end) m_PAT
            with
            | nil => fun _ => tt
            | (i, t) :: m0 => fun H => (f t _, default_val_fix_aux_members m0 _)
            end) _ H
      end) (typeR_spec y) X)
    (reptype_eq y)).
  + apply Forall_inv in H; exact H.
  + apply Forall_inv2 in H; exact H.
Defined.

Definition default_val: forall (t: type), reptype t := Fix wf_typeR reptype default_val_fix_aux.

End Fix_RankLt.

End Fix_RankLt.

(***************************************************

3. Directly define reptype recursive on rank

***************************************************)

Module RankRec.

Require Import AggregateType.demo2.type_induction.
Open Scope nat.

Section RankRec.

Context {cs: compspecs}.

Fixpoint reptype_aux (n: nat) (t: type): Type :=
  match t with
  | Tint => val
  | Tstruct id =>
     match n with
     | O => unit
     | S n' => fold_right prod unit (map (reptype_aux n') (map snd (co_members (get_co id))))
     end
  end.

Definition reptype t := reptype_aux (rank_type cenv_cs t) t.

Lemma reptype_aux_rank_irrelevent: forall t n n0,
  n >= rank_type cenv_cs t ->
  n0 >= rank_type cenv_cs t ->
  reptype_aux n t = reptype_aux n0 t.
Proof.
  intros t.
  RankInd.type_induction t;
  intros;
  try solve [destruct n; simpl; auto; destruct n0; simpl; auto].
  + (* Tstruct *)
    unfold get_co in IH.
    destruct (Maps.PTree.get id cenv_cs) as [co |] eqn: CO.
    - erewrite rank_type_Tstruct in H by eauto.
      erewrite rank_type_Tstruct in H0 by eauto.
      destruct n; simpl in H; try solve [inv H].
      destruct n0; simpl in H; try solve [inv H0].
      simpl.
      f_equal.
      rewrite !map_map.
      apply list_map_exten.

      intros [i t] Hin.
      unfold get_co in H, H0, Hin. rewrite CO in H, H0, Hin.
      simpl in IH.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      specialize (IH (i, t) Hin n n0).
      apply le_S_n in H; apply le_S_n in H0.
      assert (H3 := rank_type_members cenv_cs i t _ Hin).
      symmetry; apply IH.
      * simpl.
        eapply le_trans; [ | eassumption].
        erewrite co_consistent_rank; [eapply rank_type_members; eassumption |].
        exact (cenv_consistent id co CO).
      * simpl.
        eapply le_trans; [ | eassumption].
        erewrite co_consistent_rank; [eapply rank_type_members; eassumption |].
        exact (cenv_consistent id co CO).
    - destruct n, n0; simpl;
      unfold get_co;
      rewrite ?CO; intros; auto.
Defined.

Lemma reptype_eq: forall t: type, reptype t =
  match t with
  | Tint => val
  | Tstruct id => fold_right prod unit (map reptype (map snd (co_members (get_co id))))
  end.
Proof.
  intros.
  RankInd.type_induction t; try reflexivity.
  + (* Tstruct *)
    unfold reptype in *.
    simpl reptype_aux.
    destruct (Maps.PTree.get id cenv_cs) as [co |] eqn:CO; simpl.
    - f_equal.
      rewrite !map_map.
      apply list_map_exten.
      intros [i t].
      unfold get_co; rewrite CO.
      intro Hin.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      apply reptype_aux_rank_irrelevent.
      * apply le_n.
      * simpl.
        erewrite co_consistent_rank; [eapply rank_type_members; eassumption |].
        exact (cenv_consistent id co CO).
    - unfold FTI_aux, get_co; rewrite CO.
      reflexivity.
Defined.

End RankRec.
End RankRec.

Module Test.

Require Import compcert.lib.Maps.

Definition _f1 := 1%positive.
Definition _f2 := 2%positive.
Definition _f3 := 3%positive.
Definition _f4 := 4%positive.
Definition _f5 := 5%positive.
Definition cd1 := Build_composite ((_f1, Tint) :: (_f2%positive, Tint) :: nil) 0.
Definition cd2 := Build_composite ((_f3, Tstruct 101%positive) ::
                                   (_f4, Tstruct 101%positive) ::
                                   (_f5, Tint) :: nil) 1.

Definition cenv : composite_env.
  pose (PTree.set 102%positive cd2 (PTree.set 101%positive cd1 (PTree.empty _))).
  cbv - [cd1 cd2] in t.
  match goal with
  | _ := ?t |- _ => clear; exact t
  end.
Defined.

Definition cenv_cons: composite_env_consistent cenv.
  hnf.
  intros.
  apply PTree.elements_correct in H.
  simpl in H.
  destruct H as [| [|[]]]; inversion H; subst.
  + split; reflexivity.
  + split; reflexivity.
Defined.

Instance test_cs: compspecs := mkcompspecs cenv cenv_cons.

Goal Fix_TypeTree.reptype (Tstruct 101%positive) = (val * (val * unit))%type.
  reflexivity.
Qed.

Goal Fix_TypeTree.reptype (Tstruct 102%positive) = ((val * (val * unit)) * ((val * (val * unit)) * (val * unit)))%type.
  reflexivity.
Qed.

Goal ManualWf_TypeTree.reptype (Tstruct 101%positive) = (val * (val * unit))%type.
  reflexivity.
Qed.

Goal ManualWf_TypeTree.reptype (Tstruct 102%positive) = ((val * (val * unit)) * ((val * (val * unit)) * (val * unit)))%type.
  reflexivity.
Qed.

Goal Fix_RankLt.reptype (Tstruct 101%positive) = (val * (val * unit))%type.
  reflexivity.
Qed.

Goal Fix_RankLt.reptype (Tstruct 102%positive) = ((val * (val * unit)) * ((val * (val * unit)) * (val * unit)))%type.
  reflexivity.
Qed.

Goal RankRec.reptype (Tstruct 101%positive) = (val * (val * unit))%type.
  reflexivity.
Qed.

Goal RankRec.reptype (Tstruct 102%positive) = ((val * (val * unit)) * ((val * (val * unit)) * (val * unit)))%type.
  reflexivity.
Qed.

End Test.


Require Export List.
Require Export ListSet.
Require Export Coq.Init.Nat.
Require Export Coq.Bool.Bool.
Require Export Coq.Logic.Classical.

Notation "[ ]" := nil (format "[ ]") : list_scope.
Notation "[ x ]" := (cons x nil) : list_scope.
Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) : list_scope.

(***************************************************************************)
(* 对Basic Paxos算法涉及到的对象全部进行抽象类型定义，并证明一些定理。                 *)
(***************************************************************************)
(***************************************************************************)
(* All Types involved in basic Paxos algorithm are defined as Inductive types, and some theorems are proved.                 *)
(***************************************************************************)
Inductive priest : Type :=
  | priestId : nat -> priest.

Inductive decree : Type :=
  | decreeId : nat -> decree.

Inductive number : Type :=
  | numberId : nat -> number.

Definition beq_priest (x1 x2 : priest) :=
  match x1, x2 with
  | priestId n1, priestId n2 => Nat.eqb n1 n2
  end.

Definition beq_decree (x1 x2 : decree) :=
  match x1, x2 with
  | decreeId n1, decreeId n2 => Nat.eqb n1 n2
  end.

Definition blt_decree (x1 x2 : decree) :=
  match x1, x2 with
  | decreeId n1, decreeId n2 => ltb n1 n2
  end.

Theorem beq_decree_true : forall d1 d2 : decree,
  beq_decree d1 d2 = true -> d1 = d2.
Proof.
  intros d1. destruct d1. intros d2. induction d2.
  generalize dependent n0. induction n.
  - intros n0. simpl. destruct n0.
    + intros. reflexivity.
    + intros. inversion H.
  - intros n0. simpl. destruct n0.
    + intros. inversion H.
    + intros H. simpl in IHn. apply IHn in H.
      inversion H. reflexivity.
Qed.

Theorem beq_decree_refl : forall d : decree,
  true = beq_decree d d.
Proof.
  intros d. destruct d. induction n.
  - reflexivity.
  - rewrite IHn. simpl. reflexivity.
Qed.

Theorem beq_decree_true_iff : forall d1 d2 : decree,
  beq_decree d1 d2 = true <-> d1 = d2.
Proof.
  split.
  - apply beq_decree_true.
  - intros. rewrite H. symmetry. apply beq_decree_refl.
Qed.

Definition beq_number (x1 x2 : number) :=
  match x1, x2 with
  | numberId n1, numberId n2 => Nat.eqb n1 n2
  end.

(* 小于判断 *)
Definition blt_number (x1 x2 : number) :=
  match x1, x2 with
  | numberId n1, numberId n2 => ltb n1 n2
  end.

Definition less_or_equal_number (x1 x2 : number) :=
  beq_number x1 x2 = true /\ blt_number x1 x2 = true.

Theorem beq_number_true : forall n1 n2 : number,
  beq_number n1 n2 = true -> n1 = n2.
Proof.
  intros n1. destruct n1. intros n2. induction n2.
  generalize dependent n0. induction n.
  - intros n0. simpl. destruct n0.
    + intros. reflexivity.
    + intros. inversion H.
  - intros n0. simpl. destruct n0.
    + intros. inversion H.
    + intros H. simpl in IHn. apply IHn in H.
      inversion H. reflexivity.
Qed.

Theorem beq_number_refl : forall num : number,
  true = beq_number num num.
Proof.
  intros num. destruct num. induction n.
  - reflexivity.
  - rewrite IHn. simpl. reflexivity.
Qed.

Theorem beq_number_true_iff : forall n1 n2 : number,
  beq_number n1 n2 = true <-> n1 = n2.
Proof.
  split.
  - apply beq_number_true.
  - intros. rewrite H. symmetry. apply beq_number_refl.
Qed.

Hypothesis Aeq_dec : forall x y:priest, {x = y} + {x <> y}.

(***************************************************************************)
(* Basic Paxos算法中，对Quorums的定义及其重要性质和引理的定义和证明。                *)
(***************************************************************************)
(***************************************************************************)
(* In the basic Paxos algorithm, the definition of Quorums, its important properties and the definition and proof of lemma.                *)
(***************************************************************************)
Variables Quorums : set (set priest).

Lemma DoublePredicate : forall Q1 Q2 : set priest, set_In Q1 Quorums -> set_In Q2 Quorums
  -> set_In Q1 Quorums /\ set_In Q2 Quorums.
Proof.
  intros. split. apply H. apply H0.
Qed.

Lemma DoublePredicateL : forall Q1 Q2 : set priest, set_In Q1 Quorums /\ set_In Q2 Quorums -> In Q1 Quorums.
Proof.
  intros. inversion H. apply H.
Qed.

Lemma DoublePredicateR : forall Q1 Q2 : set priest, set_In Q1 Quorums /\ set_In Q2 Quorums -> In Q2 Quorums.
Proof.
  intros. inversion H. apply H.
Qed.

Lemma empty_spec : forall x, ~(set_In x (empty_set priest)).
Proof.
  intros. unfold empty_set. unfold not.
  intros. inversion H.
Qed.

Lemma empty_spec_iff : forall x, set_In x (empty_set priest) <-> False.
Proof.
  intros. split.
  - apply empty_spec.
  - intros. inversion H.
Qed.

Lemma empty_spec_mem : forall Q , (exists x, set_mem Aeq_dec x Q = true) -> Q <> empty_set priest.
Proof.
  intros. inversion H. apply set_mem_correct1 in H0.
  unfold not. intros. rewrite H1 in H0.
  apply empty_spec_iff in H0. apply H0.
Qed.

(* 论文中的假设条件二。 *)
(* Hypothesis B2。 *)
Hypothesis QuorumsAssumption: forall Q1 Q2, In Q1 Quorums -> In Q2 Quorums ->
  set_inter Aeq_dec Q1 Q2 <> empty_set priest.

(* 论文中的假设条件二。 *)
(* Hypothesis B2。 *)
Hypothesis QuorumsAssumptionE: forall Q1 Q2 : set priest, In Q1 Quorums /\ In Q2 Quorums ->
  exists q, set_In q (set_inter Aeq_dec Q1 Q2).

Lemma QuorumNonEmptyAuxiliaryO : forall Q1 Q2, In Q1 Quorums /\ In Q2 Quorums ->
  Q1 <> empty_set priest /\ Q2 <> empty_set priest.
Proof.
  intros. apply  QuorumsAssumptionE in H. inversion H.
  apply set_inter_elim in H0. inversion H0. split.
  - apply empty_spec_mem. exists x.
    apply set_mem_correct2. apply H1.
  - apply empty_spec_mem. exists x.
    apply set_mem_correct2. apply H2.
Qed.

Lemma QuorumNonEmptyAuxiliaryT : forall Q1 Q2, In Q1 Quorums -> In Q2 Quorums ->
  Q1 <> empty_set priest /\ Q2 <> empty_set priest.
Proof.
  intros. specialize (DoublePredicate Q1 Q2).
  intros. apply H1 in H.
  - apply QuorumNonEmptyAuxiliaryO. apply H.
  - apply H0.
Qed.

Lemma QuorumNonEmpty : forall Q, In Q Quorums -> Q <> empty_set priest.
Proof.
  intros. specialize (QuorumNonEmptyAuxiliaryT Q Q).
  intros. apply H0 in H.
  - inversion H. apply H1.
  - apply H.
Qed.

(***************************************************************************)
(* 对集合性质的补充。                                                        *)
(***************************************************************************)
(***************************************************************************)
(* A complement to the properties of sets.                                                       *)
(***************************************************************************)
Definition subset (u v : set priest) := forall a, set_In a u -> set_In a v.

(* 修改nincl定义。*)
Inductive nincl (u v : set priest) : Prop :=
  nincl_cons : forall a, In a u -> ~ In a v -> nincl u v.

(* 修改sincl定义。*)
Definition sincl (u v : set priest) := subset u v /\ (exists a, In a v /\ ~In a u).

(* 增加Axiom_Set及以下两个推论并证明推论。*)
Axiom Axiom_Set : forall x y : set priest,
  x = y <-> (forall z, In z x <-> In z y).

Lemma Axiom_infer1 : forall x y : set priest,
  x <> y <-> ~(forall z, In z x <-> In z y).
Proof.
  intros. apply not_iff_compat. apply Axiom_Set.
Qed.

Lemma Axiom_infer2 : forall x y : set priest,
  ~(forall z, In z x <-> In z y) -> (exists a, In a x /\ ~In a y) \/ (exists a, In a y /\ ~In a x).
Proof.
  intros. apply not_all_ex_not in H.  inversion H. unfold iff in H0. apply not_and_or in H0.  destruct H0.
  - apply imply_to_and in H0. left. exists x0. apply H0.
  - apply imply_to_and in H0. right. exists x0. apply H0.
Qed.

(* 将原有的setDecR假设去掉，增加了对应的引理并证明。*)
Lemma setDecR : forall u v : set priest, (exists a, In a v /\ ~In a u) -> u <> v.
Proof.
  intros. inversion H. destruct (list_eq_dec Aeq_dec u v).
  + destruct e. unfold not. intros. inversion H0. unfold not in H3. apply H3 in H2. apply H2.
  + apply n.
Qed.

Lemma setDecL : forall u v : set priest, (exists a, In a u /\ ~In a v) -> u <> v.
Proof.
  intros. inversion H. destruct (list_eq_dec Aeq_dec u v).
  + destruct e. destruct H0. eauto.
  + apply n.
Qed.

(* 增加set_NotSubset引理并证明。*)
Lemma set_NotSubset : forall u v : set priest, (exists a, In a v /\ ~In a u) <-> ~ subset v u.
Proof.
  intros; split.
 - intros H1 H2. destruct H1. generalize (H2 x); intro H3. destruct H as [H H1].
   apply H3 in H. auto.
 - intro H. apply not_all_ex_not in H. destruct H. exists x. apply imply_to_and in H. auto.
Qed.

(* 将原有的setIntuition假设去掉，增加了对应的引理并证明。*)
Lemma setIntuitionL : forall u v , subset u v -> sincl u v \/ u = v.
Proof.
  intros. destruct (list_eq_dec Aeq_dec u v).
  - right. apply e.
  - left. apply Axiom_infer1 in n. apply Axiom_infer2 in n. unfold sincl. split.
    + apply H.
    + unfold subset in H. destruct n.
      { inversion H0. generalize (H x). intros. inversion H1.  apply H2 in H3.  eauto. }
      { apply H0. }
Qed.

Lemma setIntuitionR : forall u v, sincl u v \/ u = v -> subset u v.
Proof.
  intros. destruct H as [H1 | h2].
  - inversion H1. apply H.
  - unfold subset. intros. rewrite h2 in H. apply H.
Qed.

Lemma setIntuition : forall u v, sincl u v \/ u = v <-> subset u v.
Proof.
  intros. split.
  - apply setIntuitionR.
  - apply setIntuitionL.
Qed.

(* 将原有的sincl_spec假设去掉，增加了对应的引理并证明。*)
Lemma sincl_spec : forall u v, sincl u v -> sincl v u <-> False.
Proof.
  intros. destruct H as [H1 H2]. destruct H2. destruct H. split.
  - intro H2. destruct H2 as [H2 H3]. unfold subset in H2. generalize (H2 x). intros.
    apply H4 in H. auto.
  - intro. inversion H2.
Qed.

(* 引理名变更，证明对应setDecR做相应更改。*)
Lemma sincl_NotEqual : forall u v, sincl u v -> ~ u = v.
Proof.
  intros. inversion H. inversion H1. destruct H2. apply setDecR. apply H1.
Qed.

Lemma double_inclusion : forall u v, subset u v -> subset v u -> u = v.
Proof.
  intros. apply setIntuition in H. apply setIntuition in H0. destruct H.
  - destruct H0. specialize (sincl_spec u v).
    intros. apply H1 in H. apply H in H0.
    inversion H0. symmetry. apply H0.
  - apply H.
Qed.

(***************************************************************************)
(* 投票行为及性质的定义，及其性质定义。                                            *)
(***************************************************************************)
(* Formally, a ballot B consisted of the following four components. *)
Record Ballot : Type := mkBallot
{
  (* Bdec A decree (the one being voted on) *)
  dec : decree;
  (* Bqrm A nonempty set of priests (the ballot's quorum) *)
  qrm : set priest;
  (* Bvot A set of priests (the ones who cast votes for the decree) *)
  vot : set priest;
  (* Bbal A ballot number *)
  bal : number;
}.

Hypothesis Aeq_dec_Ballot : forall x y : Ballot, {(bal x) = (bal y)} + {blt_number (bal x) (bal y) = true}.

(***************************************************************************)
(* 消息行为抽象，及其性质定义。                                                  *)
(***************************************************************************)
(***************************************************************************)
(* Message behavior abstraction and its nature definition.                                                  *)
(***************************************************************************)
Record MessageNew : Type := mkMessageNew
{
  typeM : nat;         (* 消息的类型。 *)
  balM : number;       (* 消息的轮次。 *)
  maxVBalM : number;   (* 消息的轮次。只有type 2有。 *)
  maxValM : decree;     (* 消息的值。type 2表示曾经参与的最大值，type 3 4表示现阶段进行投票的值，type 1没有。 *)
  accM : priest;       (* 消息的发送者。type 2 4时有，其他的没有。 *)
}.

(***************************************************************************)
(* Basic Paxos算法涉及的变量及默认值定义，同时定义了相关性质和引理。                   *)
(***************************************************************************)
(***************************************************************************)
(* the definition of variables and default values Basic Paxos algorithm involves, and defines the related properties and lemmas.                   *)
(***************************************************************************)
Variables aBallots : set Ballot.
Variables Acceptors : set priest.
Variables Values : set decree.
Variables Numbers : list number.

Variables maxBal : priest -> number.
Variables maxVBal : priest -> number.
Variables maxVal : priest -> decree.
Variables None : decree.
Variables msgsNew : set MessageNew.

(* 论文中的假设条件一。 *)
(* Hypothesis B1 *)
Hypothesis Unique_Ballot : forall x y : Ballot, In x aBallots -> In y aBallots -> x = y <-> (bal x) = (bal y).

Axiom Axiom_Ballot : forall b1 b2,  In b2 aBallots -> In b2 aBallots -> (dec b1) = (dec b2)
                             /\(qrm b1) = (qrm b2)
                             /\(vot b1) = (vot b2)
                             /\(bal b1) = (bal b2) <-> b1 = b2.

Axiom Axiom_MessageNew : forall m1 m2,  In m1 msgsNew -> In m2 msgsNew -> (typeM m1) = (typeM m2)
                             /\(balM m1) = (balM m1)
                             /\(maxValM m1) = (maxValM m2)
                             /\(maxVBalM m1) = (maxVBalM m2)
                             /\(accM m1) = (accM m2) <-> m1 = m2.

Definition None_fact : Prop := ~In None Values.

Definition TypeCheck : Prop :=
    forall a, In a Acceptors -> In (maxVBal a) Numbers
  /\forall a, In a Acceptors -> In (maxBal a) Numbers
  /\forall a, In a Acceptors -> In (maxVal a) Values
  /\forall a, In a Acceptors -> less_or_equal_number (maxVBal a) (maxBal a).

Inductive VotedForInNew : priest -> decree -> number -> Prop :=
  | cons_VotedForInNew : forall a v b, In a Acceptors -> In v Values -> In b Numbers -> (exists m, In m msgsNew /\ (typeM m) = 4
                                       /\(balM m) = b
                                       /\(maxValM m) = v
                                       /\(accM m) = a) -> VotedForInNew a v b.

Inductive ChosenInNew : decree -> number -> Prop :=
  | cons_ChosenInNew : forall v b, In v Values -> In b Numbers -> (exists Q, In Q Quorums ->
      forall a, set_In a Q -> VotedForInNew a v b) -> ChosenInNew v b.

Inductive ChosenNew : decree -> Prop :=
  | cons_ChosenNew : forall v, In v Values -> (exists b, In b Numbers ->
      ChosenInNew v b) -> ChosenNew v.

Inductive Ballot_Equal_Dec : Ballot -> Ballot -> Prop :=
  | Ballot_Dec_cons : forall b1 b2, set_In b1 aBallots -> set_In b2 aBallots ->
                          b1 = b2 -> (dec b1) = (dec b2)
                                   /\(qrm b1) = (qrm b2)
                                   /\(vot b1) = (vot b2)
                                   /\(bal b1) = (bal b2) -> Ballot_Equal_Dec b1 b2.

Inductive Ballot_bal_Dec : Ballot -> Ballot -> Prop :=
  | Ballot_bal_Dec_cons : forall b1 b2, set_In b1 aBallots -> set_In b2 aBallots ->
    (bal b1) = (bal b2) -> b1 = b2 -> Ballot_bal_Dec b1 b2.

Lemma Ballot_Equal : forall b1 b2, set_In b1 aBallots -> set_In b2 aBallots ->
  Ballot_Equal_Dec b1 b2 -> b1 = b2 -> (dec b1) = (dec b2)
                                   /\(qrm b1) = (qrm b2)
                                   /\(vot b1) = (vot b2)
                                   /\(bal b1) = (bal b2).
Proof.
  intros. inversion H1. apply H6.
Qed.

Lemma Ballot_Equal_decree : forall b1 b2, set_In b1 aBallots -> set_In b2 aBallots ->
  Ballot_Equal_Dec b1 b2 -> b1 = b2 -> (dec b1) = (dec b2).
Proof.
  intros. inversion H1. inversion H6. apply H9.
Qed.

Lemma Ballot_bal : forall b1 b2, set_In b1 aBallots -> set_In b2 aBallots ->
  Ballot_bal_Dec b1 b2 -> (bal b1) = (bal b2) -> b1 = b2.
Proof.
  intros. inversion H1. apply H6.
Qed.

Inductive trivial_qrm : Ballot -> Prop :=
  | trivial_qrm_cons : forall b, set_In b aBallots -> set_In (qrm b) Quorums -> trivial_qrm b.

Inductive trivial_decree : Ballot -> Prop :=
  | trivial_decree_cons : forall b, set_In b aBallots -> set_In (dec b) Values -> trivial_decree b.

Inductive trivial_number : Ballot -> Prop :=
  | trivial_number_cons : forall b, set_In b aBallots -> set_In (bal b) Numbers -> trivial_number b.

Inductive trivial_qrm_vot : Ballot -> Prop :=
  | ttrivial_qrm_vot'_cons : forall b, set_In b aBallots -> subset (vot b) (qrm b) -> trivial_qrm_vot b.

Inductive trivial_vot_msg : Ballot -> Prop :=
  | trivial_vot_msg_cons : forall b a, In b aBallots -> set_In a (vot b) -> (exists m, In m msgsNew /\ (typeM m) = 4
                                                     /\(balM m) = (bal b)
                                                     /\(maxValM m) = (dec b)
                                                     /\(accM m) = a) -> trivial_vot_msg b.

Inductive trivial_vot : Ballot -> Prop :=
  | trivial_vot_cons : forall b, In b aBallots -> (forall a, set_In a (vot b) ->
      VotedForInNew a (dec b) (bal b)) -> trivial_vot b.

Inductive trivial_qrm_Acce : Ballot -> Prop :=
  | trivial_qrm_Acce_cons : forall b, set_In b aBallots -> (forall a, set_In a (qrm b) -> set_In a Acceptors) -> trivial_qrm_Acce b.

Inductive trivial : Ballot -> Prop :=
  | ttrivial_cons : forall b, trivial_qrm b /\ trivial_decree b /\ trivial_number b /\ trivial_qrm_vot b
                           /\ trivial_qrm_Acce b /\ trivial_vot b /\ trivial_vot_msg b -> trivial b.

Lemma equalQrmVot : forall b, trivial_qrm_vot b -> subset (qrm b) (vot b) ->  (qrm b) = (vot b).
Proof.
  intros. destruct H. apply double_inclusion.
  apply H0. apply H1.
Qed.

Inductive WontVoteInNew : priest -> number -> Prop :=
  | cons_WontVoteInNew : forall a b, In a Acceptors -> In b Numbers -> (forall v, In v Values -> ~ VotedForInNew a v b)
                    /\ blt_number b (maxBal a) = true -> WontVoteInNew a b.

Inductive SafeAtNew : decree -> number -> Prop :=
  | cons_SafeAtNew : forall v b, In v Values -> In b Numbers ->
      (forall c, In c Numbers -> blt_number c b = true ->
        (
          (exists Q,
              (forall ballot, trivial ballot -> In ballot aBallots -> (c = (bal ballot)) ->
                  Q = (qrm ballot) /\ (forall a, In a Q -> VotedForInNew a v c \/ WontVoteInNew a c)
              )
          )
        )
      )
       -> SafeAtNew v b.

(***************************************************************************)
(* Paxos phase 1a 1b 2a 2b                                                   *)
(***************************************************************************)
Inductive MsgInvNew : Prop :=
  | cons_MsgInvNew : (forall m, In m msgsNew -> ((typeM m) = 1 -> True)
                                    /\((typeM m) = 2 -> less_or_equal_number (balM m) (maxBal (accM m))
                                                    /\    (In (maxValM m) Values /\
                                                           In (maxVBalM m) Numbers /\
                                                           VotedForInNew (accM m) (maxValM m) (maxVBalM m)
                                                       \/ ((maxValM m) = None /\
                                                           (maxVBalM m) = numberId 0)))
                                    /\((typeM m) = 3 -> (SafeAtNew (maxValM m) (balM m)
                                                    /\ forall ma, set_In ma msgsNew -> (typeM ma) = 3 ->
                                                        (balM ma) = (balM m) -> ma = m))
                                    /\((typeM m) = 4 -> (less_or_equal_number (balM m) (maxVBal (accM m))
                                                    /\ exists ma, set_In ma msgsNew /\
                                                                  (typeM ma) = 3 /\
                                                                  (balM ma) = (balM m) /\
                                                                  (maxValM ma) = (maxValM m)))) -> MsgInvNew.

(***************************************************************************)
(* Basic Paxos算法的验证。                                                    *)
(***************************************************************************)
(***************************************************************************)
(* Verification of basic Paxos algorithm.                                                    *)
(***************************************************************************)
(* 将原有假设去掉，增加对应的引理并证明。 *)
Lemma QrmVotToSucc :
  forall b a, trivial b -> set_In b aBallots ->
  set_In a (qrm b) -> (qrm b) = (vot b) -> ChosenNew (dec b).
Proof.
  intros. apply cons_ChosenNew.
  - inversion H. inversion H3. inversion H6. inversion H7. apply H10.
  - inversion H. inversion H3. inversion H6. inversion H8. inversion H10.
    inversion H12. inversion H14. inversion H15. generalize (H18 a ); intros. rewrite H2 in H1. apply H20 in H1.
    inversion H1. exists b2. intros. apply (cons_ChosenInNew (dec b) b2).
    + apply H22.
    + apply H28.
    + exists (qrm b). intros. generalize (H18 a1); intros.
      rewrite H2 in H30. apply H31 in H30. rewrite H27. apply H30.
Qed.

Lemma SuccToEqual : forall b1 b2, trivial b1 -> trivial b2 -> subset (qrm b1) (vot b1) -> subset (qrm b2) (vot b2)
  -> (qrm b1) = (vot b1) /\ (qrm b2) = (vot b2).
Proof.
  intros. inversion H.
  inversion H0. split.
  - apply equalQrmVot. inversion H3.
    inversion H8. inversion H10.
    apply H12. apply H1.
  - apply equalQrmVot. inversion H5.
    inversion H8. inversion H10.
    apply H12. apply H2.
Qed.

Lemma SuccToChosen : forall b a, trivial b -> set_In b aBallots -> set_In a (qrm b) -> subset (qrm b) (vot b) ->
  ChosenNew (dec b).
Proof.
  intros. apply (QrmVotToSucc b a).
  - apply H.
  - apply H0.
  - apply H1.
  - apply equalQrmVot.
    + inversion H. inversion H3.
      inversion H6. inversion H8.
      inversion H10. apply H11.
    + apply H2.
Qed.

Lemma SuccToVoted : forall a b, trivial b -> subset (qrm b) (vot b) ->
  set_In a (qrm b) -> VotedForInNew a (dec b) (bal b).
Proof.
  intros. inversion H. inversion H2.
  inversion H5. inversion H7.
  inversion H9. inversion H11.
  inversion H13. inversion H14.
  generalize (H17 a); intros.
  generalize (equalQrmVot b); intros.
  apply H20 in H10.
  - rewrite H10 in H1. apply H19 in H1.
    apply H1.
  - apply H0.
Qed.

Lemma VotedInv :
  forall a v b, MsgInvNew -> In a Acceptors /\ In v Values /\ In b Numbers ->
                VotedForInNew a v b -> less_or_equal_number b (maxVBal a) /\ SafeAtNew v b.
Proof.
  intros. inversion H. inversion H1. inversion H6.
  generalize (H2 x); intros. inversion H10. apply H11 in H12.
  inversion H12. inversion H15. inversion H17. inversion H13.
  apply H19 in H20. inversion H20. inversion H21. inversion H25. split.
  - rewrite <- H27. rewrite <- H24. apply H22.
  - inversion H23. inversion H28. generalize (H2 x0); intros. apply H31 in H29.
    inversion H29. inversion H33. inversion H35. inversion H30. apply H36 in H38.
    inversion H38. inversion H39. rewrite <- H26. rewrite <- H24.
    rewrite <- H42. rewrite <- H43. apply H40.
Qed.

Lemma VotedInvForLe :
  forall a v b, MsgInvNew -> In a Acceptors /\ In v Values /\ In b Numbers ->
                VotedForInNew a v b -> less_or_equal_number b (maxVBal a).
Proof.
  intros. inversion H. inversion H1. inversion H6.
  generalize (H2 x); intros. inversion H10. apply H11 in H12.
  inversion H12. inversion H15. inversion H17. inversion H13.
  apply H19 in H20. inversion H20. inversion H21. inversion H25.
  rewrite <- H27. rewrite <- H24. apply H22.
Qed.

Lemma VotedInvForSafeAt :
  forall a v b, MsgInvNew -> In a Acceptors /\ In v Values /\ In b Numbers ->
                VotedForInNew a v b -> SafeAtNew v b.
Proof.
  intros. inversion H. inversion H1. inversion H6.
  generalize (H2 x); intros. inversion H10. apply H11 in H12.
  inversion H12. inversion H15. inversion H17. inversion H13.
  apply H19 in H20. inversion H20. inversion H21. inversion H25.
  inversion H23. inversion H28. generalize (H2 x0); intros. apply H31 in H29.
  inversion H29. inversion H33. inversion H35. inversion H30. apply H36 in H38.
  inversion H38. inversion H39. rewrite <- H26. rewrite <- H24.
  rewrite <- H42. rewrite <- H43. apply H40.
Qed.

Lemma VotedOnce :
  forall a1 a2 b v1 v2, MsgInvNew -> In a1 Acceptors ->
  In a2 Acceptors -> In b Numbers -> In v1 Values -> In v2 Values ->
  VotedForInNew a1 v1 b /\ VotedForInNew a2 v2 b -> (v1 = v2).
Proof.
  intros. inversion H5. inversion H.
  inversion H6. inversion H7.
  inversion H12. inversion H19.
  generalize (H8 x); intros.
  generalize (H8 x0); intros.
  inversion H23. inversion H24.
  apply H25 in H27. apply H26 in H29.
  inversion H27. inversion H32. inversion H34.
  inversion H29. inversion H38. inversion H40.
  inversion H28. inversion H30.
  apply H36 in H43. apply H42 in H45.
  inversion H43. inversion H45.
  inversion H48. inversion H50.
  inversion H51. inversion H52.
  generalize (H8 x1); intros.
  generalize (H8 x2); intros.
  apply H57 in H53. apply H58 in H55.
  inversion H53. inversion H60. inversion H62.
  inversion H55. inversion H66. inversion H68.
  inversion H54. inversion H56.
  apply H63 in H71. apply H69 in H73.
  inversion H71. inversion H73.
  generalize (H76 x2); intros.
  inversion H56. inversion H52. apply H79 in H82.
  - apply Axiom_MessageNew in H82.
    + inversion H54. inversion H56.
      inversion H85. inversion H87.
      inversion H44. inversion H46.
      inversion H93. inversion H95.
      rewrite <- H98. rewrite <- H96.
      rewrite <- H89. rewrite <- H91.
      inversion H82. inversion H101.
      inversion H103. symmetry. apply H104.
    + inversion H52. apply H85.
    + inversion H51. apply H85.
  - inversion H83. apply H84.
  - inversion H81. inversion H72.
    rewrite H86. rewrite H84.
    inversion H44. inversion H46.
    rewrite H88. rewrite H90. auto.
Qed.

Lemma SuccToSafeAt : forall b a, MsgInvNew -> trivial b -> In a (qrm b) ->
  subset (qrm b) (vot b) -> SafeAtNew (dec b) (bal b).
Proof.
  intros. inversion H.
  inversion H0. inversion H4.
  inversion H7. inversion H9.
  inversion H11. inversion H13.
  inversion H15. inversion H14.
  inversion H16. generalize (H19 a); intros.
  generalize (H22 a); intros.
  apply (VotedInvForSafeAt a).
  - apply H.
  - split.
    + apply H24 in H1. apply H1.
    + split.
      { inversion H8. apply H27. }
      { inversion H10. apply H27. }
  - apply SuccToVoted.
    + apply H0.
    + apply H2.
    + apply H1.
Qed.

Lemma SafeAtToVote : forall b1 b2, blt_number (bal b1) (bal b2)=true -> trivial b2 -> trivial b1 ->
  SafeAtNew (dec b2) (bal b2) ->
  (exists a, In a (qrm b1) /\ In a (qrm b2) /\ (VotedForInNew a (dec b2) (bal b1) \/ WontVoteInNew a (bal b1))).
Proof.
  intros. generalize (QuorumsAssumptionE (qrm b1) (qrm b2)); intros.
  inversion H0. inversion H4. inversion H6.
  inversion H1. inversion H11. inversion H13.
  generalize (DoublePredicate (qrm b1) (qrm b2)); intros.
  apply H18 in H16. apply H3 in H16.
  inversion H16. exists x.
  - intros. inversion H2. split.
    + apply set_inter_elim1 in H19. apply H19.
    + split.
      { apply set_inter_elim2 in H19. apply H19. }
      { generalize (H22 (bal b1)); intros.
        inversion H14. inversion H27. inversion H28.
        apply H25 in H31. inversion H31. generalize (H33 b1); intros.
        apply H34 in H1. inversion H1. generalize (H36 x); intros.
        apply set_inter_elim1 in H19. rewrite H35 in H37.
        apply H37 in H19. apply H19.
        - apply H30.
        - auto.
        - apply H. }
  - inversion H4. inversion H19. apply H22.
Qed.

Lemma SafeAtToCons : forall b1 b2 a,
  MsgInvNew -> trivial b1 -> trivial b2 -> In a (qrm b1) -> In a (qrm b2) ->
  (VotedForInNew a (dec b2) (bal b1) \/ WontVoteInNew a (bal b1)) ->
  VotedForInNew a (dec b1) (bal b1) -> (dec b1) = (dec b2).
Proof.
  intros. inversion H4.
  - apply (VotedOnce a a (bal b1) (dec b1) (dec b2)).
    + apply H.
    + inversion H0. inversion H7.
      inversion H10. inversion H12.
      inversion H14. inversion H16.
      inversion H17. generalize (H20 a); intros.
      apply H22 in H2. apply H2.
    + inversion H0. inversion H7.
      inversion H10. inversion H12.
      inversion H14. inversion H16.
      inversion H17. generalize (H20 a); intros.
      apply H22 in H2. apply H2.
    + inversion H0. inversion H7.
      inversion H10. inversion H12.
      inversion H13. apply H16.
    + inversion H0. inversion H7.
      inversion H10. inversion H11.
      apply H14.
    + inversion H1. inversion H7.
      inversion H10. inversion H11.
      apply H14.
    + split.
      { apply H5. }
      { apply H6. }
  - inversion H6. inversion H9.
    generalize (H12 (dec b1)); intros.
    inversion H0. inversion H15.
    inversion H18. inversion H19.
    apply H14 in H22. unfold not in H22.
    apply H22 in H5. inversion H5.
Qed.

Lemma ConsistentOfNotEqual : forall b1 b2, MsgInvNew ->
  trivial b1 -> trivial b2 -> subset (qrm b1) (vot b1) -> subset (qrm b2) (vot b2) ->
  blt_number (bal b1) (bal b2)=true -> (dec b1) = (dec b2).
Proof.
  intros. generalize (SafeAtToVote b1 b2); intros.
  apply H5 in H4. inversion H4. apply (SafeAtToCons b1 b2 x).
  - apply H.
  - apply H0.
  - apply H1.
  - inversion H6. apply H7.
  - inversion H6. inversion H8. apply H9.
  - inversion H6. inversion H8. apply H10.
  - generalize (SuccToVoted x b1); intros.
    apply H7 in H0.
    + apply H0.
    + apply H2.
    +inversion H6. apply H8.
  - apply H1.
  - apply H0.
  - inversion H1. inversion H6. inversion H9. inversion H11. inversion H13. inversion H15. inversion H17. inversion H19.
    generalize (SuccToSafeAt b2 a); intros. apply H24 in H.
    + apply H.
    + apply H1.
    + generalize (SuccToEqual b1 b2); intros. apply H25 in H0.
      { inversion H0. rewrite H27. apply H21. }
      { apply H1. }
      { apply H2. }
      { apply H3. }
    + apply H3.
Qed.

Lemma ConsistentOfEqual : forall b1 b2, trivial b1 -> trivial b2 ->
  subset (qrm b1) (vot b1) -> subset (qrm b2) (vot b2) ->
  (bal b1) = (bal b2) -> (dec b1) = (dec b2).
Proof.
  intros. apply (Axiom_Ballot b1 b2).
  - inversion H0. inversion H4. inversion H6. apply H8.
  - inversion H0. inversion H4. inversion H6. apply H8.
  - apply (Unique_Ballot b1 b2).
    + inversion H. inversion H4. inversion H6. apply H8.
    + inversion H0. inversion H4. inversion H6. apply H8.
    + apply H3.
Qed.

(***************************************************************************)
(* 共识性定理证明。                                                            *)
(***************************************************************************)
(***************************************************************************)
(* Consistent                                                           *)
(***************************************************************************)
Theorem Consistent : forall b1 b2, MsgInvNew ->
  trivial b1 -> trivial b2 -> subset (qrm b1) (vot b1) -> subset (qrm b2) (vot b2) ->
  (dec b1) = (dec b2).
Proof.
  intros. destruct (Aeq_dec_Ballot b1 b2).
  - apply (ConsistentOfEqual b1 b2).
    + apply H0.
    + apply H1.
    + apply H2.
    + apply H3.
    + apply e.
  - apply (ConsistentOfNotEqual b1 b2).
    + apply H.
    + apply H0.
    + apply H1.
    + apply H2.
    + apply H3.
    + apply e.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat seq order.
From ipcssr Require Import prelude avlmap forms normal_forms derivations kripke_trees
                           in_ngamma forces_ngamma derivable_def
                           in_gamma forces_gamma
                           nsearch sound minimal weight rules.

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Section Search.
Context {A : Type}.

Definition vlist : Type := seq (seq A * form A).

Fixpoint vlist2list (gamma : vlist) : seq (form A) :=
  if gamma is (l, a) :: gamma
    then vimp l a :: vlist2list gamma else [::].

Fixpoint vlist2hlist (gamma : vlist) : seq (form A) :=
  if gamma is (_, a) :: gamma
    then a :: vlist2hlist gamma else [::].

Fixpoint list2vlist (gamma : seq (form A)) : vlist :=
  if gamma is a :: gamma
    then ([::], a) :: list2vlist gamma else [::].

Lemma vlist_eq gamma : gamma = vlist2list (list2vlist gamma).
Proof. by elim: gamma=>//= a gamma {1}->. Qed.

End Search.

Section SearchOrd.
Context {disp : unit} {A : orderType disp}.

Definition search_atom_invariant (n : nat) :=
  forall (goal : A) (gamma : vlist) (work : seq (normal_form A))
         (ctx : seq (form A)) (j : A),
  (weight_gamma (vlist2hlist gamma) < n)%N ->
  csearch_spec (Atom goal) (vlist2list gamma) work ctx j.

Variant search_spec (goal : form A) (gamma : seq (form A)) : Type :=
  | Sderivable of Derivable gamma goal
  | Srefutable k of
      Is_Monotone_kripke_tree k &
      {in gamma, forall a, forces_t k a} &
      ~ forces_t k goal.

End SearchOrd.

(* TODO ssrnum? *)
Section SearchNat.

Lemma search_atom_aux n : search_atom_invariant (A:=[orderType of nat]) n.
Proof.
rewrite /search_atom_invariant /=; elim: n=>// n IH goal.
(* 0 < n *)
case=>/= [|a gamma] work ctx j.
- (* gamma = [::] *)
  rewrite /search_spec=>_ /= Hg _ Hc S M.
  case: (nsearch goal work ctx)=>/=.
  - move=>m a E.
    by apply/S/In_Work1/E.
  - move=>k Mk Fk.
    apply: M=>//; rewrite /forces_gamma=>c.
    case=>{c} //= m a E.
    by apply/Fk/onth_mem/E.
  - apply: derivable.
  move=>k Mk Fk Nk.
  apply: (refutable _ _ _ _ k)=>//.
  rewrite /forces_gamma=>c.
  case=>{c} // m a E.
  by apply/Fk/In_Work/E.
(* gamma = a :: gamma *)
case: a=>l a /=; rewrite ltnS.
elim: a l.
- (* a = Falsum *)
  rewrite /weight add1n => l L.
  by apply/(rule_shift_gamma_work _ _ NFalsum)/IH.
- (* a = Atom i *)
  rewrite /weight add1n=> i l L.
  by apply/(rule_shift_gamma_work _ _ (NAtom i))/IH.
- (* a = AndF a b *)
  move=>a _ b _ l; rewrite /weight -/weight addSn.
  case: l=>[|i1 l] L.
  - apply/rule_vimp_conj_gamma/(IH _ [:: ([::], a), ([::], b) & gamma])=>/=.
    by rewrite addnA.
  case: l=>[|i2 l].
  - apply/rule_vimp_conj_gamma/(IH _ [:: ([::i1], a), ([::i1], b) & gamma])=>/=.
    by rewrite addnA.
  apply: (rule_vimp_conj_gamma_new _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
  apply: (IH _ [:: ([::j], a), ([::j], b) & gamma])=>/=.
  by rewrite addnA.
- (* --------- a = OrF a b ---------- *)
  move=>+ _ b _ l; case.
  - (* a = Falsum *)
    rewrite /weight -/weight addSn => L.
    by apply/rule_vimp_falsum_or_a_gamma/(IH _ ((l, b) :: gamma)).
  - (* a = Atom i0 *)
    move=> i0; case b.
    - (* b = Falsum *)
      rewrite /weight -/weight add2n => L.
      apply/rule_vimp_a_or_falsum_gamma/(IH _ ((l, Atom i0) :: gamma)).
      by rewrite /= /weight -/weight add1n.
    - (* b = Atom i1 *)
      rewrite /weight -/weight add2n => i1 L.
      apply/(rule_shift_gamma_work _ _ (NDisj i0 i1))/IH.
      by apply/ltn_trans/L.
    - (* b = AndF b0 b1 *)
      move=>b0 b1; rewrite /weight -/weight !addSn=> L.
      apply: (rule_vimp_atom_or_a_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
      apply: (IH _ (([::j], AndF b0 b1) :: gamma)).
      by rewrite /= /weight -/weight addSn.
    - (* b = OrF b0 b1 *)
      move=>b0 b1; rewrite /weight -/weight addSn => L.
      apply: (rule_vimp_atom_or_a_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
      by apply: (IH _ (([::j], OrF b0 b1) :: gamma)).
    (* b = Imp b0 b1 *)
    move=> b0 b1; rewrite /weight /weight_neg -/weight -/weight_neg addSn => L.
    apply: (rule_vimp_atom_or_a_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
    by apply: (IH _ (([::j], Imp b0 b1) :: gamma)).
  - (* a = AndF a0 a0 *)
    move=>a0 a1; rewrite /weight -/weight addnS !addSn addnA=>L.
    apply: (rule_vimp_a_or_b_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
    apply: (IH _ [:: (l, OrF (Atom j) b), ([::j], AndF a0 a1) & gamma]).
    by rewrite /= /weight -/weight !addSn addnS !addnA.
  - (* a = OrF a0 a1 *)
    move=>a0 a1; rewrite /weight -/weight !addSn =>L.
    apply: (rule_vimp_a_or_b_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
    apply: (IH _ [:: (l, OrF (Atom j) b), ([::j], OrF a0 a1) & gamma]).
    by rewrite /= /weight -/weight addSn addnA.
  (* a = Imp a0 a1 *)
  move=>a0 a1; rewrite /weight /weight_neg -/weight -/weight_neg !addSn addnA=>L.
  apply: (rule_vimp_a_or_b_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
  apply: (IH _ [:: (l, OrF (Atom j) b), ([::j], Imp a0 a1) & gamma]).
  by rewrite /= /weight /weight_neg -/weight -/weight_neg addSn !addnA.
(******************* a = Imp a c *****************************)
move=>+ _ c; case.
- (* a = Falsum  *)
  move=>_ l; rewrite /weight /weight_neg -/weight -/weight_neg add0n=>L.
  apply/rule_vimp_falsum_imp_b_gamma/IH.
  rewrite -add1n; apply/leq_trans/L; rewrite leq_add2r.
  by apply: weight_ge_1.
- (* a = Atom i0 *)
  move=>i0 IHc l; rewrite /weight /weight_neg -/weight -/weight_neg add0n=>L.
  by apply/rule_vimp_atom_imp_b_gamma/IHc.
- (* a = AndF a b *)
  move=> a b _ l; rewrite /weight /weight_neg -/weight -/weight_neg !addSn=>L.
  apply/rule_vimp_and_imp_gamma/(IH _ ((l, Imp a (Imp b c)) :: gamma)).
  by rewrite /= /weight /weight_neg -/weight -/weight_neg addnA.
- (* a = OrF a b *)
  move=>a b _ l; rewrite /weight /weight_neg -/weight -/weight_neg !addSn.
  case: c.
  - (* c = Falsum *)
    rewrite /weight -/weight addn1 addSn => L.
    apply/rule_vimp_or_imp_gamma/(IH _ [:: (l, Imp a Falsum), (l, Imp b Falsum) & gamma]).
    rewrite /= /weight /weight_neg -/weight -/weight_neg !addn1 !addSn addnS addnA.
    by apply/ltn_trans/L.
  - (* c = Atom i *)
    move=>i; rewrite /weight -/weight addn1 addSn => L.
    apply/rule_vimp_or_imp_gamma/(IH _ [::(l, Imp a (Atom i)), (l, Imp b (Atom i)) & gamma]).
    rewrite /= /weight /weight_neg -/weight -/weight_neg !addn1 !addSn addnS addnA.
    by apply/ltn_trans/L.
  - (* c = AndF c0 c1 *)
    move=>c0 c1; rewrite /weight -/weight addnS addSn addnA=>L.
    apply: (rule_vimp_or_imp_gamma_new _ _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
    apply: (IH _ [:: (l, Imp a (Atom j)), (l, Imp b (Atom j)),
                     ([::j], AndF c0 c1) & gamma]).
    by rewrite /= /weight /weight_neg -/weight -/weight_neg !addn1 !addSn !addnS !addnA.
  - (* c = OrF c0 c1 *)
    move=>c0 c1; rewrite /weight -/weight => L.
    apply: (rule_vimp_or_imp_gamma_new _ _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
    apply: (IH _ [:: (l, Imp a (Atom j)), (l, Imp b (Atom j)),
                     ([::j], OrF c0 c1) & gamma]).
    by rewrite /= /weight /weight_neg -/weight -/weight_neg !addn1 !addSn !addnS !addnA.
  (* c = Imp c0 c1 *)
  move=>c0 c1; rewrite /weight /weight_neg -/weight -/weight_neg addnA => L.
  apply: (rule_vimp_or_imp_gamma_new _ _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
  apply: (IH _ [:: (l, Imp a (Atom j)), (l, Imp b (Atom j)),
                   ([::j], Imp c0 c1) & gamma]).
  by rewrite /= /weight /weight_neg -/weight -/weight_neg !addn1 !addSn !addnS !addnA.
(* a = Imp a b *)
move=>+ b _ l; case.
- (* a = Falsum *)
  rewrite /weight /weight_neg -/weight -/weight_neg add1n addSn=>L.
  by apply/rule_vimp_falsum_imp_imp_gamma/(IH _ ((l, c) :: gamma)).
- (* a = Atom i0 *)
  move=>i0; case: b.
  - (* b = Falsum *)
    rewrite /weight /weight_neg -/weight -/weight_neg add2n !addSn=>L.
    apply: (rule_vimp_imp_falsum_imp_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
    apply: (IH _ ((l, Imp (Imp (Atom i0) (Atom j)) c) :: gamma)).
    by rewrite /= /weight /weight_neg -/weight -/weight_neg add1n addSn.
  - (* b = Atom i1 *)
    move=>i1; case: c.
    - (* c = Falsum *)
      rewrite /weight /weight_neg -/weight -/weight_neg add1n add2n=>L.
      apply/(rule_shift_gamma_work _ _ (NImp_NF (NImp i0 i1 NFalsum)))/IH.
      by apply/ltn_trans/L.
    - (* c = Atom i2 *)
      move=>i2; rewrite /weight /weight_neg -/weight -/weight_neg add1n add2n=>L.
      apply/(rule_shift_gamma_work _ _ (NImp_NF (NImp i0 i1 (NAtom i2))))/IH.
      by apply/ltn_trans/L.
    - (* c = AndF c0 c1 *)
      move=>c0 c1; rewrite /weight /weight_neg -/weight -/weight_neg add1n !addSn=>L.
      apply: (rule_vimp_imp_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
      apply: (rule_shift_gamma_work _ _ (NImp_NF (NImp i0 i1 (NAtom j)))).
      by apply: (IH _ (([::j], AndF c0 c1) :: gamma)).
    - (* c = OrF c0 c1 *)
      move=>c0 c1; rewrite /weight /weight_neg -/weight -/weight_neg add1n addSn=>L.
      apply: (rule_vimp_imp_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
      apply: (rule_shift_gamma_work _ _ (NImp_NF (NImp i0 i1 (NAtom j)))).
      by apply: (IH _ (([::j], OrF c0 c1) :: gamma)).
    (* c = Imp c0 c1 *)
    move=>c0 c1; rewrite /weight /weight_neg -/weight -/weight_neg add1n addSn=>L.
    apply: (rule_vimp_imp_gamma _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
    apply: (rule_shift_gamma_work _ _ (NImp_NF (NImp i0 i1 (NAtom j)))).
    by apply: (IH _ (([::j], Imp c0 c1) :: gamma)).
  - (* (Imp (Imp (Atom i0) (AndF b0 b1)) c) *)
    move=>b0 b1; rewrite /weight /weight_neg -/weight -/weight_neg !addSn=>L.
    apply: (rule_atom_imp_b_imp_c_gamma _ _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
    apply: (IH _ [:: (l, Imp (Imp (Atom i0) (Atom j)) c),
                     (i0 :: l, Imp (AndF b0 b1) (Atom j)) & gamma]).
    by rewrite /= /weight /weight_neg -/weight -/weight_neg add1n addn1 !addSn !addnS addnC addnAC.
  - (* (Imp (Imp (Atom i0) (OrF b0 b1)) c) *)
    move=>b0 b1; rewrite /weight /weight_neg -/weight -/weight_neg !addSn=>L.
    apply: (rule_atom_imp_b_imp_c_gamma _ _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
    apply: (IH _ [:: (l, Imp (Imp (Atom i0) (Atom j)) c),
                     (i0 :: l, Imp (OrF b0 b1) (Atom j)) & gamma]).
    by rewrite /= /weight /weight_neg -/weight -/weight_neg add1n addn1 !addSn !addnS addnC addnAC.
  (* (Imp (Imp (Atom i0) (Imp b0 b1)) c) *)
  move=>b0 b1; rewrite /weight /weight_neg -/weight -/weight_neg !addSn=>L.
  apply: (rule_atom_imp_b_imp_c_gamma _ _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
  apply: (IH _ [:: (l, Imp (Imp (Atom i0) (Atom j)) c),
                   (i0 :: l, Imp (Imp b0 b1) (Atom j)) & gamma]).
  by rewrite /= /weight /weight_neg -/weight -/weight_neg add1n addn1 !addSn !addnS addnC addnAC.
- (* (Imp (Imp (AndF a0 a1) b) c) *)
  move=>a0 a1; rewrite /weight /weight_neg -/weight -/weight_neg
    addnS !addSn (addnAC _ _ (weight c)) addnA -!addSn => L.
  apply: (rule_a_imp_b_imp_c_gamma _ _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
  apply: (IH _ [:: (l, Imp (Imp (Atom j) b) c),
                   ([::j], AndF a0 a1) & gamma]).
  rewrite /= /weight /weight_neg -/weight -/weight_neg addSn addnS !addnA -!addSn.
  by apply/leq_trans/L; rewrite !leq_add2r !ltnS; case: {L}b.
- (* (Imp (Imp (OrF a0 a1) b) c) *)
  move=>a0 a1; rewrite /weight /weight_neg -/weight -/weight_neg -!addSn => L.
  apply: (rule_a_imp_b_imp_c_gamma _ _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
  apply: (IH _ [:: (l, Imp (Imp (Atom j) b) c),
                   ([::j], OrF a0 a1) & gamma]).
  rewrite /= /weight /weight_neg -/weight -/weight_neg addnA (addnAC _ (weight c)) -!addSn.
  by apply/leq_trans/L; rewrite !leq_add2r; case: {L}b.
(* (Imp (Imp (Imp a0 a1) b) c) *)
move=>a0 a1; rewrite /weight /weight_neg -/weight -/weight_neg -!addSn => L.
apply: (rule_a_imp_b_imp_c_gamma _ _ _ _ _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
apply: (IH _ [:: (l, Imp (Imp (Atom j) b) c),
                 ([::j], Imp a0 a1) & gamma]).
rewrite /= /weight /weight_neg -/weight -/weight_neg addnA (addnAC _ (weight c)) -!addSn.
by apply/leq_trans/L; rewrite !leq_add2r; case: {L}b.
Qed.

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

Lemma search_goal_invariant_weight n (goal : form nat) gamma work ctx j :
  (weight_goal goal < n)%N -> csearch_spec goal gamma work ctx j.
Proof.
elim: n =>[|n IH] // in goal gamma work ctx j *; rewrite ltnS.
case: goal=>/=.
- (* goal = Falsum *)
  move=>L.
  apply: (rule_gamma_falsum _ _ _ _ j.+1); first by rewrite ltEnat /=.
  rewrite (vlist_eq gamma).
  by apply: (search_atom_aux (weight_gamma (vlist2hlist (list2vlist gamma))).+1).
- (* goal = Atom i *)
  move=>i L.
  rewrite (vlist_eq gamma).
  by apply: (search_atom_aux (weight_gamma (vlist2hlist (list2vlist gamma))).+1).
- (* goal = AndF g0 g1 *)
  move=>g0 g1 L.
  apply: (rule_gamma_a _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
  by apply: IH.
- (* goal = OrF g0 g1 *)
  move=>g0 g1 L.
  apply: (rule_gamma_a _ _ _ _ _ j.+1); first by rewrite ltEnat /=.
  by apply: IH.
(* goal = Imp g0 g1 *)
move=>g0 g1 L.
by apply/rule_gamma_a_imp_b/IH.
Qed.

Lemma search_goal_invariant (goal : form nat) gamma work ctx j :
  csearch_spec goal gamma work ctx j.
Proof. by apply: (search_goal_invariant_weight (weight_goal goal).+1). Qed.

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

Theorem search (goal : form nat) gamma : search_spec goal gamma.
Proof.
move: (max_int_of_list_below (goal :: gamma)).
set j := max_int_of_list (goal :: gamma).
move=>/= /andP [Bj Bg].
case: (search_goal_invariant goal gamma [::] gamma j)=>//.
- rewrite /sound=>/= a; case=>{a} //= n a E.
  by apply/(Derivable_Intro _ _ (Var n))/ByAssumption.
- rewrite /minimal=> k M Fk a /onth_index E.
  by apply/Fk/(In_Gamma _ _ (index a gamma)).
- apply: Sderivable.
move=>k Mk Fk Nk.
apply: (Srefutable _ _ k)=>// a /onth_index E.
by apply/Fk/(In_Gamma _ _ (index a gamma)).
Qed.

End SearchNat.


Require Import Arith.
Require Import String.
Require Import Div2.
Require Import Bool.
Require Import List.
Require Import Program.
Require Vector.
Require Vectors.Fin.

Import ListNotations.

Require Import Word.
Require Import Parser.
Require Skipn.

Definition W := Word.word 32.
Definition H := Word.word 16.
Definition B := Word.word 8.
Definition W_zero := (natToWord 32 0).
Definition H_zero := (natToWord 16 0).
Definition B_zero := (natToWord 8 0).

Definition BtoW (b:B) : W :=
  combine (combine b B_zero) (natToWord 16 0).

Definition BtoH (b:B) : H :=
  combine b B_zero.

Definition HtoW (h:H) : W :=
  combine H_zero h.

(*
    Bytes are given in big-endian (aka normal human being) order
    but must be processed in little-endian order.
*)
Definition combine_bs (a b c d : B) : W :=
  combine (combine d c) (combine b a).

(*
  "Each instruction performs some action on the pseudo-machine state, which
   consists of an accumulator, index register, scratch memory store, and
   implicit program counter."
       -OpenBSD man page
*)

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

Fixpoint blt_nat (n m : nat) : bool :=
  match n with
    | O => if beq_nat m O then false else true
    | S n' =>
        match m with
          | O => false
          | S m' => ble_nat n' m'
        end
    end.

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

Fixpoint bge_nat (n m : nat) : bool :=
  match n with
    | O => if beq_nat m O then true else false
    | S n' =>
        match m with
          | O => true
          | S m' => ble_nat n' m'
        end
    end.

Definition scratch_mem := Vector.t (option W) 16.

Definition empty_mem : scratch_mem :=
  Vector.const None 16.

Definition get_fin (i:nat) : option (Vectors.Fin.t 16) :=
  match Vectors.Fin.of_nat i 16 with
    | inleft x => Some x
    | _ => None
  end.

Record vm_state : Type := make_state {
  acc : option W;
  x_reg : option W;
  ins : list instr;
  pkt : list B;
  smem : scratch_mem
}.

Inductive end_state : Type :=
  | Ret : W -> end_state
  | Error : string -> end_state.

Inductive state : Type :=
  | ContState : vm_state -> state
  | End : end_state -> state.

Definition init_state (ins:list instr) : vm_state :=
  make_state None None ins [] empty_mem.

Definition change_acc (s:vm_state) (l:list instr) (new_acc:W) : state :=
  ContState (make_state (Some new_acc) (x_reg s) l (pkt s) (smem s)).

Definition change_x_reg (s:vm_state) (l:list instr) (new_x:W) : state :=
  ContState (make_state (acc s) (Some new_x) l (pkt s) (smem s)).

Definition change_smem (s:vm_state) (l:list instr) (i:W) (v:W) : state :=
  match get_fin (wordToNat i) with
    | Some fin =>
        let new_mem := Vector.replace (smem s) fin (Some v) in
          ContState (make_state (acc s) (x_reg s) l (pkt s) new_mem)
    | None =>
        End (Error "accessed uninitialized memory")
  end.

Definition get_mem_ind (l:scratch_mem) (i:W) : option W :=
  match get_fin (wordToNat i) with
    | None => None
    | Some f => Vector.nth l f
  end.

Definition jump (s:vm_state) (n:W) : state :=
  ContState (make_state (acc s) (x_reg s) (skipn (wordToNat n) (ins s)) (pkt s) (smem s)).

Fixpoint step (s:vm_state) : state :=
  match (ins s) with
    | [] => End (Error "jumped or stepped past last instruction")
    | (curr_instr :: rest) =>
    match curr_instr with
      | SoloInstr s_op =>
        match s_op with
          | RetA =>
              match acc s with
                | None => End (Error "Returned uninitialized acc")
                | Some v => End (Ret v)
              end
          | XStoreA =>
              match acc s with
                | Some acc' =>
                    change_x_reg s rest acc'
                | None =>
                    End (Error "storing acc to uninitialized x reg")
              end
          | AStoreX =>
              match x_reg s with
                | Some x' =>
                    change_acc s rest x'
                | None =>
                    End (Error "storing x reg to uninitialized acc")
              end
              | AddX =>
                        match acc s, x_reg s with
                            | Some acc', Some x' =>
                                change_acc s rest (acc' ^+ x')
                            | None, _ =>
                                End (Error "Adding to uninitialized acc")
                            | _, None =>
                                End (Error "Adding uninitialized x reg")
                        end
                    | SubX =>
                        match acc s, x_reg s with
                            | Some acc', Some x' =>
                                change_acc s rest (acc' ^- x')
                            | None, _ =>
                                End (Error "Subtracting to uninitialized acc")
                            | _, None =>
                                End (Error "Subtracting uninitialized x reg")
                        end
                    | MulX =>
                        match acc s, x_reg s with
                            | Some acc', Some x' =>
                                change_acc s rest (acc' ^* x')
                            | None, _ =>
                                End (Error "Multiplying to uninitialized acc")
                            | _, None =>
                                End (Error "Multiplying uninitialized x reg")
                        end
                    | DivX =>
                        End (Error "*** fill in ***")
                    | AndX =>
                        match acc s, x_reg s with
                            | Some acc', Some x' =>
                                change_acc s rest (acc' ^& x')
                            | None, _ =>
                                End (Error "And-ing to uninitialized acc")
                            | _, None =>
                                End (Error "And-ing uninitialized x reg")
                        end
                    | OrX =>
                        match acc s, x_reg s with
                            | Some acc', Some x' =>
                                change_acc s rest (acc' ^| x')
                            | None, _ =>
                                End (Error "Or-ing to uninitialized acc")
                            | _, None =>
                                End (Error "Or-ing uninitialized x reg")
                        end
                    | SLX =>
                        End (Error "no shifts available yet")
                    | SRX =>
                        End (Error "no shifts available yet")
                    | LdXHdrLen =>
                        End (Error "*** fill in ***")
                    | LdLen =>
                        let pkt_len := Word.natToWord 32 (length (pkt s)) in
                        change_acc s rest pkt_len
                    | LdXLen =>
                        let pkt_len := Word.natToWord 32 (length (pkt s)) in
                        change_x_reg s rest pkt_len
                end
            | ImmInstr i_op i =>
                match i_op with
                    | RetK =>
                        End (Ret i)
                    | LdImm =>
                        change_acc s rest i
                    | AddImm =>
                        match acc s with
                            | Some acc' =>
                                change_acc s rest ((acc') ^+ i)
                            | None =>
                                End (Error "Adding to uninitialized acc")
                        end
                    | SubImm =>
                        match acc s with
                            | Some acc' =>
                                change_acc s rest ((acc') ^- i)
                            | None =>
                                End (Error "Subtracting to uninitialized acc")
                        end
                    | MulImm =>
                        match acc s with
                            | Some acc' =>
                                change_acc s rest ((acc') ^* i)
                            | None =>
                                End (Error "Multiplying to uninitialized acc")
                        end
                    | DivImm =>
                        End (Error "no div available for word (yet)")
                    | AndImm =>
                        match acc s with
                            | Some acc' =>
                                change_acc s rest ((acc') ^& i)
                            | None =>
                                End (Error "And-ing to uninitialized acc")
                        end
                    | OrImm =>
                        match acc s with
                            | Some acc' =>
                                change_acc s rest ((acc') ^| i)
                            | None =>
                                End (Error "Or-ing to uninitialized acc")
                        end
                    | SLImm =>
                        End (Error "no shifts available yet")
                    | SRImm =>
                        End (Error "no shifts available yet")
                    | Neg =>
                        match acc s with
                            | Some acc' =>
                                change_acc s rest (wneg acc')
                            | None =>
                                End (Error "Adding to uninitialized acc")
                        end
                    | JmpImm =>
                        jump s i
                    | LdXImm =>
                        change_x_reg s rest i
                end
            | MemInstr m_op m_addr =>
                match m_op with
                    | LdMem =>
                        match get_mem_ind (smem s) m_addr with
                          | None => End (Error "access to undefined or out-of-bounds mem")
                          | Some a => change_acc s rest a
                        end
                    | LdXMem =>
                        match get_mem_ind (smem s) m_addr with
                          | None => End (Error "access to undefined or out-of-bounds mem")
                          | Some x => change_x_reg s rest x
                        end
                    | Store =>
                        match acc s with
                          | None => End (Error "using uninitialized acc as mem addr")
                          | Some a => change_smem s rest m_addr a
                        end
                    | StoreX =>
                        match x_reg s with
                          | None => End (Error "using uninitialized x reg as mem addr")
                          | Some x => change_smem s rest m_addr x
                        end
                end
            | PktInstr p_op p_addr =>
                match p_op with
                    | LdWord =>
                        let fst_b := nth_error (pkt s) (wordToNat p_addr) in
                        let snd_b := nth_error (pkt s) ((wordToNat p_addr) + 1) in
                        let thr_b := nth_error (pkt s) ((wordToNat p_addr) + 2) in
                        let frt_b := nth_error (pkt s) ((wordToNat p_addr) + 3) in
                        match fst_b, snd_b, thr_b, frt_b with
                          | Some a, Some b, Some c, Some d =>
                              change_acc s rest (combine_bs a b c d)
                          | _, _, _ ,_ =>
                              End (Error "out-of-bounds packet access")
                        end
                    | LdHalf =>
                        let fst_b := nth_error (pkt s) (wordToNat p_addr) in
                        let snd_b := nth_error (pkt s) ((wordToNat p_addr) + 1) in
                        match fst_b, snd_b with
                          | Some a, Some b =>
                              change_acc s rest (HtoW (combine b a))
                          | _, _ =>
                              End (Error "out-of-bounds packet access")
                        end
                    | LdByte =>
                        match nth_error (pkt s) (wordToNat p_addr) with
                          | None => End (Error "out-of-bounds packet access")
                          | Some a => change_acc s rest (BtoW a)
                        end
                    | LdOfstWord =>
                        End (Error "*** fill in ***")
                    | LdOfstHalf =>
                        End (Error "*** fill in ***")
                    | LdXByte =>
                        match nth_error (pkt s) (wordToNat p_addr) with
                          | None => End (Error "out-of-bounds packet access")
                          | Some x => change_x_reg s rest (BtoW x)
                        end
                end
            (* "All conditionals use unsigned comparison conventions." *)
            | BrInstr b_op ofst1 ofst2 =>
                match b_op with
                    | JGTX =>
                        match acc s, x_reg s with
                            | Some acc', Some x' =>
                                if bgt_nat (wordToNat acc') (wordToNat x')
                                  then jump s (BtoW ofst1)
                                else jump s (BtoW ofst2)
                            | None, _ =>
                                End (Error "Testing uninitialized acc")
                            | _, None =>
                                End (Error "Testing uninitialized x reg")
                        end
                    | JGEX =>
                        match acc s, x_reg s with
                            | Some acc', Some x' =>
                                if bge_nat (wordToNat acc') (wordToNat x')
                                  then jump s (BtoW ofst1)
                                else jump s (BtoW ofst2)
                            | None, _ =>
                                End (Error "Testing uninitialized acc")
                            | _, None =>
                                End (Error "Testing uninitialized x reg")
                        end
                    | JEqX =>
                        match acc s, x_reg s with
                            | Some acc', Some x' =>
                                if beq_nat (wordToNat acc') (wordToNat x')
                                  then jump s (BtoW ofst1)
                                else jump s (BtoW ofst2)
                            | None, _ =>
                                End (Error "Testing uninitialized acc")
                            | _, None =>
                                End (Error "Testing uninitialized x reg")
                        end
                    | JAndX =>
                        match acc s, x_reg s with
                            | Some acc', Some x' =>
                                if weqb (acc' ^& x') W_zero
                                  then jump s (BtoW ofst2) (* note reversed branches *)
                                else jump s (BtoW ofst1)
                            | None, _ =>
                                End (Error "Testing uninitialized acc")
                            | _, None =>
                                End (Error "Testing uninitialized x reg")
                        end
                end
            | ImmBrInstr i_b_op i ofst1 ofst2 =>
                match i_b_op with
                    | JGTImm =>
                        match acc s, i with
                            | Some acc', i' =>
                                if bgt_nat (wordToNat acc') (wordToNat i')
                                  then jump s (BtoW ofst1)
                                else jump s (BtoW ofst2)
                            | None, _ =>
                                End (Error "Testing uninitialized acc")
                        end
                    | JGEImm =>
                        match acc s, i with
                            | Some acc', i' =>
                                if bge_nat (wordToNat acc') (wordToNat i')
                                  then jump s (BtoW ofst1)
                                else jump s (BtoW ofst2)
                            | None, _ =>
                                End (Error "Testing uninitialized acc")
                        end
                    | JEqImm =>
                        match acc s, i with
                            | Some acc', i' =>
                                if beq_nat (wordToNat acc') (wordToNat i')
                                  then jump s (BtoW ofst1)
                                else jump s (BtoW ofst2)
                            | None, _ =>
                                End (Error "Testing uninitialized acc")
                        end
                    | JAndImm =>
                        match acc s, i with
                            | Some acc', i' =>
                                if weqb (acc' ^& i') W_zero
                                  then jump s (BtoW ofst2) (* note reversed branches *)
                                else jump s (BtoW ofst1)
                            | None, _ =>
                                End (Error "Testing uninitialized acc")
                        end
                end
          end
  end.

Fixpoint prog_eval (fuel:nat) (s:vm_state) : end_state :=
  match fuel with
    | O => Error "ran out of fuel"
    | S n =>
        match step s with
          | End e_s => e_s
          | ContState cs => prog_eval n cs
        end
  end.

Definition run_filter (l:list instr) : end_state :=
  prog_eval (length l) (init_state l).

(*
   Used to prove that offsets stay on word (and hence instruction)
   boundaries.
*)
Definition word_aligned sz (w : Word.word sz) : bool :=
    let n := Word.wordToNat w in
        (negb (Word.mod2 n)) && (negb (Word.mod2 (div2 n))).


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

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

Print Assumptions mul.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


Module Type ELEM.
  Parameter A : Set.
  Parameter x : A.
End ELEM.

Module Nat.
    Definition A := nat.
    Definition x := 0.
End Nat.

Module List (X: ELEM).
  Inductive list : Set :=
    | nil : list
    | cons : X.A -> list -> list.

  Definition head (l : list) := match l with
                                | nil => X.x
                                | cons x _ => x
                                end.

  Definition singl (x : X.A) := cons x nil.

  Lemma head_singl : forall x : X.A, head (singl x) = x.
  auto.
  Qed.

End List.

Module N := List Nat.