Set Implicit Arguments.
Require Import Morphisms Omega FinFun std.
Require Export syntax semantics calculus.confluence.

(** * Equational Theory *)
Section Equivalence.
  Context {X: Const}.
  Notation "s ≡ t" := (equiv (@step X) s t) (at level 70).

  (** ** Compatibility Properties *)
  Section CompatibilityProperties.

    Global Instance equiv_lam_proper:
      Proper (equiv step ++> equiv step) (@lam X).
    Proof.
      intros ? ? (v & H1 & H2) % church_rosser; eauto.
      rewrite H1, H2. reflexivity.
    Qed.

    Global Instance equiv_app_proper:
      Proper (equiv step ++> equiv step ++> equiv step) (@app X).
    Proof.
      intros ? ? (v & H1 & H2) % church_rosser ? ? (v' & H3 & H4) % church_rosser;
        eauto.
      rewrite H1, H2, H3, H4. reflexivity.
    Qed.

    Lemma ren_equiv s t delta:
      s ≡ t -> ren delta s ≡ ren delta t.
    Proof.
      intros (v & ? & ?) % church_rosser; eauto.
      transitivity (ren delta v); [| symmetry].
      all: eapply equiv_star, ren_steps; eauto.
    Qed.

    Global Instance ren_equiv_proper:
      Proper (eq ++> equiv step ++> equiv step) (@ren X).
    Proof.
      intros ? zeta -> s t H; now eapply ren_equiv.
    Qed.

    Lemma subst_equiv s t sigma:
      s ≡ t -> sigma • s ≡ sigma • t.
    Proof.
      intros (v & ? & ?) % church_rosser; eauto.
      transitivity (sigma • v); [| symmetry].
      all: eapply equiv_star, subst_steps; eauto.
    Qed.

    Global Instance subst_equiv_proper:
      Proper (eq ++> equiv step ++> equiv step) (@subst_exp X).
    Proof.
      intros ? zeta -> s t H; now eapply subst_equiv.
    Qed.

    Lemma subst_pointwise_equiv (s: exp X) sigma tau:
      (forall x, x ∈ vars s -> sigma x ≡ tau x) -> sigma • s ≡ tau • s.
    Proof.
      induction s in sigma, tau |-*; cbn -[vars]; eauto.
      - intros H; eapply equiv_lam_proper, IHs.
        intros []; cbn -[vars]. reflexivity.
        intros ? % vars_varof % varofLambda % varof_vars % H.
        unfold funcomp.
        now eapply ren_equiv.
      - intros H; rewrite IHs1, IHs2; eauto.
    Qed.

  End CompatibilityProperties.

  (** ** Injectivity Properties *)
  Section InjectivityProperties.

    Lemma equiv_var_eq (x y: fin):
      var x ≡ var y -> x = y.
    Proof.
      intros; eapply equiv_unique_normal_forms in H; eauto.
      congruence.
    Qed.

    Lemma equiv_const_eq (x y: X):
      const x ≡ const y -> x = y.
    Proof.
      intros; eapply equiv_unique_normal_forms in H; eauto.
      congruence.
    Qed.

    Lemma equiv_lam_elim (s t: exp X):
      lambda s ≡ lambda t -> s ≡ t.
    Proof.
      intros (v & [] %steps_lam & [] %steps_lam) % church_rosser; intuition; subst.
      injection H as ->; eauto.
    Qed.

    Lemma equiv_app_elim (s s' t t': exp X):
      s t ≡ s' t' ->  isAtom (head s) -> isAtom (head s') -> s ≡ s' /\ t ≡ t'.
    Proof.
      intros (v & [] % steps_app & [] % steps_app) % church_rosser H3; eauto.
      * do 2 destruct H, H0; intuition; subst;
          injection H as -> ->; eauto.
      * do 2 destruct H; destruct H0; intuition; subst.
        all: destruct (head s'); cbn in *; intuition.
      * do 2 destruct H0; destruct H; intuition; subst.
        all: destruct (head s); cbn in *; intuition.
      * destruct H, H0; intuition.
        all: destruct (head s); cbn in *; intuition.
    Qed.

    Lemma equiv_anti_ren delta (s t: exp X):
      Injective delta -> ren delta s ≡ ren delta t -> s ≡ t.
    Proof.
      intros ? (v & H1 & H2) % church_rosser; eauto.
      eapply steps_anti_ren in H1 as [].
      eapply steps_anti_ren in H2 as [].
      intuition; subst.
      eapply anti_ren in H4; eauto.
      subst; eauto.
    Qed.

  End InjectivityProperties.

  (** ** Disjointness Properties *)
  Section DisjointnessProperties.

    Lemma equiv_neq_var_app (x: nat) (s t: exp X):
      var x ≡ s t -> isAtom (head s) -> False.
    Proof.
      intros EQ.
      destruct (head s) as [y | | | ] eqn: H'; intuition.
      all: eapply church_rosser in EQ as (v & L & R); eauto.
      all: inv L; firstorder using normal_var.
      all: eapply steps_app in R as [R|R].
      1, 3: destruct R as (? & ? & ? & ?); discriminate.
      all:  destruct R; intuition; rewrite H' in *; syn.
    Qed.

    Lemma equiv_neq_lambda_app (s' s t: exp X):
      lambda s' ≡ s t -> isAtom (head s) -> False.
    Proof.
      intros EQ.
      destruct (head s) as [y | | | ] eqn: H'; intuition.
      all: eapply church_rosser in EQ as (v & L & R); eauto.
      all: eapply steps_lam in L as (v' & ? & ?); subst.
      all: eapply steps_app in R as [R|R].
      1, 3: destruct R as (? & ? & ? & ?); discriminate.
      all: destruct R; intuition; rewrite H' in *; syn.
    Qed.

    Lemma equiv_neq_var_lambda (x: nat) s: ~ var x ≡ lambda s.
    Proof.
      intros (v & ? & ?) % church_rosser; eauto.
      inv H; firstorder using normal_var.
      eapply steps_lam in H0 as []; intuition; discriminate.
    Qed.

    Lemma equiv_neq_var_const (x: nat) c: ~ var x ≡ const c.
    Proof.
      intros (v & ? & ?) % church_rosser; eauto.
      inv H; firstorder using normal_var.
      inv H0. inv H.
    Qed.

    Lemma equiv_neq_const_lam  s c: ~ const c ≡ lambda s.
    Proof.
      intros (v & ? & ?) % church_rosser; eauto.
      inv H; firstorder using normal_var.
      eapply steps_lam in H0 as []; intuition; discriminate.
      inv H1.
    Qed.

    Lemma equiv_neq_const_app (s t: exp X) c:
      const c ≡ s t -> isAtom (head s) -> False.
    Proof.
      intros EQ.
      destruct (head s) as [y | | | ] eqn: H'; intuition.
      all: eapply church_rosser in EQ as (v & L & R); eauto.
      all: inv L; firstorder using normal_const.
      all: eapply steps_app in R as [R|R].
      1, 3: destruct R as (? & ? & ? & ?); discriminate.
      all:  destruct R; intuition; rewrite H' in *; syn.
    Qed.

  End DisjointnessProperties.

  (** ** Huet Definition *)
  Section HuetDefinition.
    Variable (s t v1 v2: exp X).
    Hypothesis (E1: s ▷ v1) (E2: t ▷ v2).

    Lemma equiv_huet_forward:
      s ≡ t ->  v1 = v2.
    Proof.
      destruct E1 as [H1 N1], E2 as [H2 N2].
      intros H; eapply equiv_unique_normal_forms; eauto.
      now rewrite <-H1, <-H2.
    Qed.

    Lemma equiv_huet_backward:
      v1 = v2 -> s ≡ t.
    Proof.
      intros; subst; destruct E1, E2; eapply equiv_join; eauto.
    Qed.
  End HuetDefinition.

End Equivalence.

Notation "s ≡ t" := (equiv step s t) (at level 70).

Hint Resolve equiv_neq_var_app equiv_neq_var_lambda equiv_neq_var_const
     equiv_neq_const_app equiv_neq_const_lam equiv_neq_lambda_app.

Ltac ClearRefl H :=
  let T := type of H in
  match T with
  | ?X ≡ ?X => clear H
  | _ => idtac
  end.

Ltac Injection H :=
  let T := type of H in
  let H1 := fresh "H" in
  let H2 := fresh "H" in
  match T with
  | var _ ≡ var _ => eapply equiv_var_eq in H as H1; ClearRefl H1
  | const _ ≡ const _ => eapply equiv_const_eq in H as H1; ClearRefl H1
  | lambda _ ≡ lambda _ => eapply equiv_lam_elim in H as H1; ClearRefl H1
  | app _ _ ≡ app _ _ =>  eapply equiv_app_elim in H as [H1 H2]; [| atom..]; ClearRefl H1; ClearRefl H2
  end.

Ltac Discriminate :=
  match goal with
  | [H: var _ ≡ const _ |- _] => eapply equiv_neq_var_const in H as []
  | [H: const _ ≡ var _ |- _] => symmetry in H; eapply equiv_neq_var_const in H as []
  | [H: var _ ≡ app _ _ |- _] => solve [eapply equiv_neq_var_app in H as []; atom]
  | [H: app _ _ ≡ var _ |- _] => solve [symmetry in H; eapply equiv_neq_var_app in H as []; atom]
  | [H: var _ ≡ lambda _ |- _] => eapply equiv_neq_var_lambda in H as []
  | [H: lambda _ ≡ var _ |- _] => symmetry in H; eapply equiv_neq_var_lambda in H as []
  | [H: const _ ≡ lambda _ |- _] => eapply equiv_neq_const_lam in H as []
  | [H: lambda _ ≡ const _ |- _] => symmetry in H; eapply equiv_neq_const_lam in H as []
  | [H: const _ ≡ app _ _ |- _] => solve [eapply equiv_neq_const_app in H as []; atom]
  | [H: app _ _ ≡ const _ |- _] => solve [symmetry in H; eapply equiv_neq_const_app in H as []; atom]
  | [H: lambda _ ≡ app _ _ |- _] => solve [eapply equiv_neq_lambda_app in H as []; atom]
  | [H: app _ _ ≡ lambda _ |- _] => solve [symmetry in H; eapply equiv_neq_lambda_app in H as []; atom]
  | [H: var _ ≡ var _ |- _] => solve [eapply equiv_var_eq in H as ?; discriminate]
  | [H: const _ ≡ const _ |- _] => solve [eapply equiv_const_eq in H as ?; discriminate]
  end.

Lemma equiv_head_equal X (s t: exp X):
  s ≡ t -> isAtom (head s) -> isAtom (head t) -> head s = head t.
Proof.
  induction s in t |-*; destruct t; intros; try Discriminate; Injection H; subst; eauto.
  - cbn in *; intuition.
  - cbn; eapply IHs1; eauto.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Cat.Facts.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Functor.Representable.Hom_Func.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
Require Import NatTrans.NatTrans NatTrans.Func_Cat NatTrans.NatIso.

Local Open Scope nattrans_scope.

Section Y_emb.
  Context (C : Category).

  (** The dual of the Yoneda embedding for category C – the curry of hom functor of C. *)
  Definition CoYoneda : (C^op –≻ (Func_Cat C Type_Cat))%functor := Exp_Cat_morph_ex (Hom_Func C).

  (** The Yoneda embedding for category C – the curry of hom functor of Cᵒᵖ. *)
  Definition Yoneda : (C –≻ (Func_Cat (C^op) Type_Cat))%functor := Exp_Cat_morph_ex (Hom_Func (C^op)).

End Y_emb.

Section Y_Left_Right.
  Context (C : Category).

  (** The left hand side of the Yoneda lemma's isomorphism *)
  Definition Y_left :
    ((C^op × (Func_Cat (C^op) Type_Cat)) –≻ Type_Cat)%functor
    :=
      ((Hom_Func _) ∘ (Prod_Functor ((Yoneda C)^op) (Functor_id (Func_Cat (C^op) Type_Cat))))%functor.

  (** The right hand side of the Yoneda lemma's isomorphism *)
  Definition Y_right : ((C^op × (Func_Cat (C^op) Type_Cat)) –≻ Type_Cat)%functor :=
    ((Exp_Cat_Eval (C^op) Type_Cat) ∘ (Twist_Func _ _))%functor.

End Y_Left_Right.

Local Obligation Tactic := idtac.

(** The left to right natural transformation of Yoneda lemma. *)
Program Definition Y_left_to_right (C : Category) : (Y_left C) –≻ (Y_right C) :=
{|
  Trans := fun c_F => fun N => ((Trans N (fst c_F))) (id (fst c_F))
|}.

Next Obligation. (* Trnas_com *)
Proof.
  intros C [c F] [c' F'] [h1 h2].
  extensionality N; cbn.
  cbn in *.
  match goal with
    [|- _ = ?W] =>
    match W with
      (?F _a ?X (?Y ?Z))%morphism =>
      change W with (((F _a X) ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn.
  match goal with
    [|- _ = Trans h2 c' ?W] =>
    match W with
      (?F _a ?X (?Y ?Z))%morphism =>
      change W with (((F _a X) ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn.
  auto.
Qed.

Next Obligation.
Proof.
  symmetry.
  apply Y_left_to_right_obligation_1.
Qed.

(** The natural transformation needed to make the right to left natural transformation of Yoneda lemma. *)
Program Definition Y_right_to_left_NT (C : Category) (c : Obj)
        (F : (C^op –≻ Type_Cat)%functor) (h : (F _o c)%object)
  :
    ((Yoneda _) _o c)%object –≻ F :=
{|
  Trans := fun c' => fun g => (F _a g)%morphism h
|}.

Next Obligation. (* Trnas_com *)
Proof.
  intros C c F h c1 c2 h'.
  extensionality g; cbn.
  simpl_ids.
  match goal with
    [|- (?F _a (?X ∘ ?Y) ?Z)%morphism = _] =>
      transitivity (((F _a Y) ∘ (F _a X)) Z)%morphism; trivial
  end.
  auto.
Qed.

Next Obligation.
Proof.
  symmetry.
  apply Y_right_to_left_NT_obligation_1.
Qed.

(** The right to left natural transformation of Yoneda lemma. *)
Program Definition Y_right_to_left (C : Category) : (Y_right C) –≻ (Y_left C) :=
{|
  Trans := fun c_F => fun h => Y_right_to_left_NT C (fst c_F) (snd c_F) h
|}.

Next Obligation. (* Trans_com *)
Proof.
  intros C [c f] [c' f'] [h N].
  cbn in *.
  extensionality g; cbn.
  apply NatTrans_eq_simplify.
  extensionality d; extensionality g'; cbn.
  simpl_ids.
  match goal with
    [|- ?W = _] =>
    match W with
      (?F _a ?X (?F _a ?Y ?Z))%morphism =>
      change W with (((F _a X) ∘ (F _a Y)) Z)%morphism
    end
  end.
  rewrite <- F_compose; cbn.
  match goal with
    [|- ?W = _] =>
    match W with
      ?X (?Y ?Z) =>
      change W with ((X ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn; trivial.
Qed.

Next Obligation.
Proof.
  symmetry.
  apply Y_right_to_left_obligation_1.
Qed.

(** The Yoneda Lemma*)
Program Definition Yoneda_Lemma (C : Category) :
  ((Y_left C) ≃ (Y_right C))%natiso :=
  NatIso _ _ (Y_left_to_right C) (Y_right_to_left C) _ _.

Next Obligation.
Proof.
  intros C [c F]; FunExt; cbn in *.
  rewrite (F_id F).
  trivial.
Qed.

Next Obligation.
  intros C [c F]; FunExt; cbn in *.
  apply NatTrans_eq_simplify.
  FunExt.
  cbn in *.
  match goal with
    [|- ?W = _] =>
    match W with
      ?X (?Y ?Z) =>
      change W with ((X ∘ Y) Z)%morphism
    end
  end.
  rewrite <- Trans_com; cbn.
  auto.
Qed.

(** Yoneda embedding is faithful. *)
Lemma Yoneda_Faithful (C : Category) : Faithful_Func (Yoneda C).
Proof.
  intros c c' f f' H.
  cbn in *.
  match type of H with
      ?X = ?Y =>
      assert(H' : Trans X c id= Trans Y c id)
  end.
  + rewrite H; trivial.
  + cbn in H'.
    simpl_ids in H'.
    trivial.
Qed.

(** Yoneda embedding is full. *)
Lemma Yoneda_Full (C : Category) : Full_Func (Yoneda C).
Proof.
  intros c c' N.
  exists (Trans (Y_left_to_right C) (c, (((Yoneda C) _o)%object c')) N).
  apply NatTrans_eq_simplify.
  extensionality x; extensionality h.
  transitivity ((((Yoneda C) _o c')%object _a h ∘ (Trans N c)) id)%morphism.
  + cbn; auto.
  + rewrite <- Trans_com.
    cbn; auto.
Qed.

(** Yoneda embedding is indeed an embedding. *)
Definition Yoneda_Emb (C : Category) : Embedding C (Func_Cat (C^op) Type_Cat) :=
{|
  Emb_Func := Yoneda C;
  Emb_Faithful := Yoneda_Faithful C;
  Emb_Full := Yoneda_Full C
|}.

(** Yoneda is conservative of isomorphisms. *)
Theorem Yoneda_Iso (C : Category) : forall (c c' : Obj), ((Yoneda C) _o c ≃ (Yoneda C) _o c')%isomorphism → (c ≃ c')%isomorphism.
Proof.
  intros.
  apply (Emb_Conservative _ _ (Yoneda_Emb C) _); trivial.
Qed.

Ltac Yoneda := apply Yoneda_Iso.

(** The dual of Yoneda is conservative of isomorphisms. *)
Theorem CoYoneda_Iso (C : Category) : forall (c c' : Obj), ((CoYoneda C) _o c ≃ (CoYoneda C) _o c')%isomorphism → (c ≃ c')%isomorphism.
Proof.
  intros; Yoneda; trivial.
Qed.

Ltac CoYoneda := apply CoYoneda_Iso.


(** A finitary model of the calculus of construction: hereditarily
    finite sets.
 *)

Require Import Bool List.
Require Import HFcoc.
Require Import Models GenModelSyntax.

(** * Instance of the abstract model *)

Module HF_Coc_Model <: CC_Model.

Definition X := hf.
Definition inX := In_hf.
Definition eqX := Eq_hf.
Definition eqX_equiv : Equivalence Eq_hf.
split.
 apply eq_hf_refl.
 apply eq_hf_sym.
 apply eq_hf_trans.
Qed.
Definition inclX := Incl_hf.

Notation "x ∈ y" := (inX x y).
Notation "x == y" := (eqX x y).

Lemma in_ext: Proper (eqX ==> eqX ==> iff) inX.
Proof In_hf_morph.

Definition props := props.
Definition app := cc_app.
Definition lam := cc_lam.
Definition prod := cc_prod.

Definition eq_fun (x:X) (f1 f2:X->X) :=
  forall y1 y2, y1 ∈ x -> y1 == y2 -> f1 y1 == f2 y2.

Lemma lam_ext :
  forall x1 x2 f1 f2,
  x1 == x2 ->
  eq_fun x1 f1 f2 ->
  lam x1 f1 == lam x2 f2.
Proof cc_lam_ext.

Lemma app_ext: Proper (eqX ==> eqX ==> eqX) app.
Proof cc_app_morph.

Lemma prod_ext :
  forall x1 x2 f1 f2,
  x1 == x2 ->
  eq_fun x1 f1 f2 ->
  prod x1 f1 == prod x2 f2.
Proof cc_prod_ext.

Lemma prod_intro : forall dom f F,
  eq_fun dom f f ->
  eq_fun dom F F ->
  (forall x, x ∈ dom -> f x ∈ F x) ->
  lam dom f ∈ prod dom F.
Proof cc_prod_intro.

Lemma prod_elim : forall dom f x F,
  eq_fun dom F F ->
  f ∈ prod dom F ->
  x ∈ dom ->
  app f x ∈ F x.
Proof cc_prod_elim.

Lemma impredicative_prod : forall dom F,
  eq_fun dom F F ->
  (forall x, x ∈ dom -> F x ∈ props) ->
  prod dom F ∈ props.
Proof cc_impredicative_prod.

Lemma beta_eq:
  forall dom F x,
  eq_fun dom F F ->
  x ∈ dom ->
  app (lam dom F) x == F x.
Proof cc_beta_eq.

End HF_Coc_Model.

Module Soundness := GenModelSyntax.MakeModel(HF_Coc_Model).

Import Soundness.
Import T.

(** * Principles supported by the model *)

(** Deciding whether [f] is true for all valuations *)
Fixpoint forall_int_env (e:Env.env) (f:(nat->hf)->bool) {struct e} : bool :=
  match e with
    nil => f (fun _ => empty)
  | T::e' => forall_int_env e'
      (fun i_f => forall_elt (fun x => f (V.cons x i_f)) (int (int_trm T) i_f))
  end.

(** Deciding whether a context is satisfiable *)
Definition valid_context (e:Env.env) : bool :=
  negb (forall_int_env e (fun _ => false)).

(*
  Lemma valid_context_ok : forall e,
    valid_context e = true -> forall M M', ~ eq_typ e M M' FALSE.
*)

Require Import Term TypeJudge.

Definition int_clos T := int (int_trm T) vnil.

(** ** Consistency of CC *)
  Lemma cc_consistency : forall M M', ~ eq_typ nil M M' FALSE.
apply non_provability.
 intros.
 Time compute.
 discriminate.
Qed.

(** ** Properties not validated by the model *)
Eval vm_compute in (int_clos FALSE). (*consistency *)

(** ** Properties validated by the model *)
Eval vm_compute in (int_clos TRUE).

(** NAT is inhabited *)
Eval vm_compute in (int_clos INAT).
(** excluded-middle: *)
Eval vm_compute in (int_clos EM).
(** proof-irrelevance: *)
Eval vm_compute in (int_clos PI).
(** extensionality of funs of Prop -> Prop *)
Eval vm_compute in (int_clos (EXT prop prop)).


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Equiv.

Lemma open_tt_var_rev: forall A B (X:atom),
    X \notin fv_tt A \u fv_tt B ->
    open_tt A X = open_tt B X ->
    A = B.
Proof with auto.
  unfold open_tt.
  generalize 0.
  intros n A B.
  generalize dependent n.
  generalize dependent B.
  induction A;induction B;intros;simpl in *;try solve [inversion H0|destruct (n0==n);subst;inversion H0]...
  -
    destruct (n1==n);destruct (n1==n0);subst...
    inversion H0.
    inversion H0.
  -
    destruct (n0==n);subst...
    inversion H0.
    rewrite <- H2 in H.
    solve_notin_self X.
  -
    destruct (n0==n);subst...
    inversion H0.
    rewrite  H2 in H.
    solve_notin_self X.
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
  -
    inversion H0.
    apply IHA in H2...
    subst...
  -
    inversion H0.
    apply IHA in H3...
    subst...
  -
    inversion H0.
    apply IHA1 in H3...
    apply IHA2 in H4...
    subst...
Qed.

Lemma binds_split: forall E X U,
    binds X (bind_sub U) E ->
    exists E1 E2,
      E = E1 ++ X~(bind_sub U) ++ E2.
Proof with auto.
  induction E;intros...
  analyze_binds H.
  destruct a.
  analyze_binds H.
  -
    exists nil.
    exists E...
  -
    apply IHE in BindsTac...
    destruct_hypos.
    rewrite H.
    exists ((a,b)::x).
    exists x0...
Qed.

Inductive sub_tvar_chain : env -> env -> atom -> atom -> Prop :=
| sub_tvar_refl: forall E U X,
    wf_env E -> binds X (bind_sub U) E ->
    sub_tvar_chain E (X ~ bind_sub U) X X
| sub_tvar_cons: forall E1 E2 W (X1 X2 X3:atom),
    wf_env (E1 ++ X1 ~ bind_sub X2 ++ E2) ->
    sub_tvar_chain (E1 ++ X1 ~ bind_sub X2 ++ E2) W X2 X3 ->
    sub_tvar_chain
      (E1 ++ X1 ~ bind_sub X2 ++ E2)
      (X1 ~ bind_sub X2 ++ W) X1 X3.

Lemma sub_tvar_chain_subset: forall E W X Y,
  sub_tvar_chain E W X Y ->
  forall K V, binds K V W -> binds K V E.
Proof with auto.
  intros. induction H.
  - inversion H0. { inversion H2;subst... }
    inversion H2.
  - destruct H0...
    inversion H0...
Qed.

Lemma sub_tvar_chain_strengthening: forall Z U W E2 X Y,
  sub_tvar_chain (Z ~ U ++ E2) W X Y ->
  Z \notin dom W ->
  sub_tvar_chain (E2) W X Y.
Proof with auto.
  intros. dependent induction H.
  - apply sub_tvar_refl with (U:=U0)...
    { apply wf_env_cons in H... }
    { destruct H0... inversion H0. subst.
      exfalso. apply H1. simpl... }
  - destruct E1.
    { inversion x;subst. exfalso.
      apply H1. simpl... }
    { inversion x;subst.
      specialize (IHsub_tvar_chain Z U (E1 ++ X1 ~ bind_sub X2 ++ E0) JMeq_refl).
      eapply sub_tvar_cons...
      rewrite <- app_comm_cons  in H.
      rewrite cons_app_one in H. apply wf_env_cons in H...
    }
Qed.
Lemma binds_uniq: forall E X A B,
    wf_env E ->
    binds X (bind_sub A) E ->
    binds X (bind_sub B) E ->
    A = B.
Proof with auto.
  induction E;intros...
  analyze_binds H0.
  destruct a.
  analyze_binds_uniq H0.
  -
    apply uniq_from_wf_env...
  -
    analyze_binds_uniq H1...
    inversion BindsTacVal...
  -
    analyze_binds_uniq H1...
    apply IHE with (X:=X)...
    dependent destruction H...
Qed.
Lemma sub_tvar_inv:forall E U (X:atom),
    sub E U X ->
    exists Y, U = typ_fvar Y.
Proof with auto.
  intros.
  dependent induction H...
  exists X...
  exists X0...
  inversion H1.
Qed.

Lemma sub_tvar_next_fvar: forall (X X0:atom) E1 E2 U,
   wf_env (E1 ++ [(X, bind_sub U)] ++ E2) ->
   sub (E1 ++ [(X, bind_sub U)] ++ E2) X X0 ->
   X <> X0 ->
   exists Y, U = typ_fvar Y.
Proof with auto.
  intros. dependent destruction H0.
  - exfalso...
  - destruct (sub_tvar_inv H1) as [X' Et]. subst U0.
    assert (binds X (bind_sub U) (E1 ++ [(X, bind_sub U)] ++ E2)) by auto. pose proof binds_uniq _ _ _ H H0 H3. subst U.
    exists X'...
  - inversion H1.
Qed.

Lemma suba_sub_tvar_chain: forall E (X1 X2:atom),
    sub E X1 X2 ->
    exists W, sub_tvar_chain E W X1 X2.
Proof with auto.
  intros.
  dependent induction H.
  - inversion H0;subst.
    exists (X2 ~ bind_sub U).
    apply sub_tvar_refl with (U:=U)...
  - pose proof sub_regular H0. destruct_hypos.
    pose proof binds_split _ _ _ H.
    destruct H4 as [E1 [E2 H4]].
    pose proof sub_tvar_inv  H0. destruct H5 as [X' H5]. subst U.
    specialize (IHsub X' X2 eq_refl eq_refl).
    destruct IHsub as [W IHsub].
    subst E. exists (X1 ~ bind_sub X' ++ W).
    eapply sub_tvar_cons with (E2:=E2) (X2:=X')...
  - inversion H0.
Qed.

Inductive sub_env: env -> env -> Prop :=
| sub_env_nil : forall E, sub_env E empty
| sub_env_cons_some : forall E W K V,
    sub_env E W ->
    sub_env (K ~ V ++ E) (K ~ V ++ W)
| sub_env_cons_none : forall E W K V,
    sub_env E W ->
    sub_env (K ~ V ++ E) W.

Lemma sub_env_app: forall E1 E2 W,
    sub_env E2 W ->
    sub_env (E1 ++ E2) W.
Proof. intros E1.
  induction E1;intros...
  - apply H.
  - simpl. rewrite cons_app_one.
    destruct a. apply sub_env_cons_none.
    apply IHE1. auto.
Qed.

Lemma WF_from_binds_typ_strong:
forall (x : atom) (U : typ) (E1 E2 : env),
  wf_env (E1 ++ [(x, bind_sub U)] ++ E2) ->
  WF E2 U.
Proof with auto.
intros.
dependent induction H.
-
  destruct E1;inversion x.
-
  destruct E1;inversion x;subst...
  specialize (IHwf_env _ _ _ _ JMeq_refl)...
-
  destruct E1;inversion x;subst...
  specialize (IHwf_env _ _ _ _ JMeq_refl)...
Qed.

Lemma sub_env_clos: forall E W,
  sub_env E W ->
  forall X, X `in` dom W -> X `in` dom E.
Proof with auto.
  intros E W H.
  induction H;intros;simpl in*...
  - apply empty_iff in H. exfalso...
  - rewrite KeySetProperties.add_union_singleton in *.
    apply union_iff. apply union_iff in H0.
    destruct H0...
Qed.

Lemma sub_env_cut_head:
  forall  E2 X1 X2 T1 T2 W,
  X1 <> X2 ->
  sub_env (X1 ~ T1 ++ E2) (X2 ~ T2 ++ W) ->
  sub_env E2 (X2 ~ T2 ++ W).
Proof with auto.
  intros.
  inversion H0;subst...
  exfalso...
Qed.

Lemma sub_env_cut_heads:
  forall E1 E2 X T W, uniq (E1 ++ X ~ T ++ E2) ->
  sub_env (E1 ++ X ~ T ++ E2) (X ~ T ++ W) ->
  sub_env E2 W.
Proof with auto.
  intros E1. induction E1...
  - intros. inversion H0;subst...
    pose proof sub_env_clos H5.
    apply uniq_cons_2 in H.
    exfalso. apply H. simpl. apply H1. simpl...
  - intros.  destruct a as [X' T'].
    simpl in H0. rewrite cons_app_one in H0.
    apply sub_env_cut_head in H0.
    2:{ apply uniq_cons_2 in H... }
    inversion H;subst.
    apply IHE1 with (X:=X) (T:=T)...
Qed.

Lemma uniq_split_eq: forall (E1 E2 E1' E2':env) (X:atom) (T T':binding),
  uniq (E1 ++ X ~ T ++ E2) ->
  E1 ++ X ~ T ++ E2 = E1' ++ X ~ T' ++ E2' ->
  E1 = E1' /\ T = T' /\ E2 = E2'.
Proof with auto.
  intros E1.
  induction E1;intros.
  - destruct E1'.
    { inversion H0... }
    destruct p. inversion H0;subst.
    apply uniq_cons_2 in H. exfalso...
    rewrite dom_app in H. simpl in H...
  - destruct E1'.
    { inversion H0. destruct a. inversion H2;subst.
      apply uniq_cons_2 in H. exfalso...
      rewrite dom_app in H. simpl in H... }
    inversion H0;subst.
    inversion H;subst.
    specialize (IHE1 _ _ _ _ _ _ H4 H3).
    destruct_hypos;subst...
Qed.

Lemma binds_uniq': forall X U T E1 E2,
  wf_env (E1 ++ [(X, bind_sub T)] ++ E2) ->
  binds X (bind_sub U) (E1 ++ [(X, bind_sub T)] ++ E2) ->
  U = T.
Proof.
  intros.
  assert (binds X (bind_sub T) (E1 ++ [(X, bind_sub T)] ++ E2)) by auto.
  pose proof binds_uniq _ _ _ H H0 H1...
  auto.
Qed.

Lemma sub_tvar_chain_sub_env: forall E W X Y,
  sub_tvar_chain E W X Y ->
  sub_env E W.
Proof with auto.
  intros. dependent induction H;intros...
  - apply binds_split in H0. destruct H0 as [E1 [E2 H0]].
    rewrite H0. apply sub_env_app.
    apply sub_env_cons_some. apply sub_env_nil.
  - pose proof WF_from_binds_typ_strong _ _ _ _ H.
    inversion H1;subst. apply binds_split in H4.
    destruct H4 as [E3 [E4 H5]]. subst E2.
    apply sub_env_app.
    apply sub_env_cons_some.
    apply sub_env_app.
    inversion H0;subst.
    { rewrite <- app_assoc in H3.
      rewrite <- app_assoc in H3. apply binds_uniq' in H3.
      2:{ rewrite !app_assoc... }
      subst U0. apply sub_env_cons_some. apply sub_env_nil. }
    { rewrite <- app_assoc in IHsub_tvar_chain.
      rewrite <- app_assoc in IHsub_tvar_chain.
      replace (E1 ++ (X1, bind_sub X2) :: E3 ++ (X2, bind_sub U) :: E4)
      with ((E1 ++ (X1, bind_sub X2) :: E3) ++ [(X2, bind_sub U)] ++ E4) in H2.
      2:{ rewrite !app_assoc... }
      replace (E0 ++ (X2, bind_sub X4) :: E2) with
      (E0 ++ [(X2, bind_sub X4)] ++ E2) in H2...
      pose proof uniq_from_wf_env H3.
      pose proof uniq_split_eq _ _ _ _ _ _ _ H5 H2.
      destruct_hypos. inversion H7. subst.
      apply sub_env_cons_some.
      apply sub_env_cut_heads in IHsub_tvar_chain...
      apply uniq_from_wf_env... rewrite !app_assoc...
    }
Qed.

Lemma sub_tvar_chain_tail_in: forall E W X Y,
  sub_tvar_chain E W X Y ->
  exists W' T, W = W' ++ Y ~ bind_sub T.
Proof with auto.
  intros.
  induction H...
  - exists nil, ( U)...
  - destruct IHsub_tvar_chain as [W' [T IH]].
    exists (X1 ~ bind_sub X2 ++ W'), T.
    rewrite IH...
Qed.

Lemma sub_env_binds: forall E W X T,
  sub_env E W ->
  binds X T W ->
  binds X T E.
Proof with auto.
  intros.
  induction H...
  - inversion H0.
  - destruct H0... inversion H0...
Qed.

Lemma sub_tvar_chain_antisym: forall E W1 W2 X Y,
  sub_tvar_chain E W1 X Y ->
  sub_tvar_chain E W2 Y X ->
  X = Y.
Proof with auto.
  intros.
  inversion H;subst...
  inversion H0;subst...
  destruct (X == Y)...

  assert (exists T, binds Y (bind_sub T) E2).
  {
    pose proof sub_tvar_chain_sub_env H.
    apply sub_env_cut_heads in H6.
    2:{ apply uniq_from_wf_env... }
    pose proof sub_tvar_chain_tail_in H.
    destruct H7 as [W' [T H7]].
    destruct W';inversion H7;subst...
    { exfalso... }
    exists T.
    apply sub_env_binds with (X:=Y) (T:=bind_sub T) in H6...
  }

  assert (exists T, binds X (bind_sub T) E3).
  {
    rewrite !cons_app_one in H3. rewrite <- H3 in H0.
    pose proof sub_tvar_chain_sub_env H0.
    apply sub_env_cut_heads in H7.
    2:{ apply uniq_from_wf_env... }
    pose proof sub_tvar_chain_tail_in H0.
    destruct H8 as [W' [T H8]].
    destruct W';inversion H8;subst...
    { exfalso... }
    exists T.
    apply sub_env_binds with (X:=X) (T:=bind_sub T) in H7...
  }

  destruct H6. destruct H7.
  apply binds_split in H6.
  apply binds_split in H7.
  destruct H6 as [E1a [E1b H6]], H7 as [E2a [E2b H7]].
  rewrite H6, H7 in H3.
  rewrite !cons_app_one in H3. rewrite <-app_assoc in H3.
  rewrite <- app_assoc in H3.
  apply uniq_split_eq in H3.
  2:{ apply uniq_from_wf_env. rewrite !app_assoc.
      rewrite H7 in H4... }
  destruct_hypos. subst.
  apply uniq_from_wf_env in H1.
  rewrite !app_assoc in H1.
  apply uniq_app_2 in H1.
  apply uniq_cons_2 in H1.
  rewrite !dom_app in H1...
  exfalso. apply H1. apply union_iff. right.
  apply union_iff. right. apply union_iff. right.
  apply union_iff. left. apply KeySetFacts.add_iff...
Qed.


Require Import Bool Peano_dec Vector List String.
Require Import Lib.CommonTactics Lib.StringEq Lib.Word Lib.FMap Lib.StringEq Lib.ilist Lib.Struct Lib.Indexer.

Require Import FunctionalExtensionality. (* for appendAction_assoc *)
Require Import Eqdep. (* for signature_eq *)

Set Implicit Arguments.
Set Asymmetric Patterns.

(* `Vec n` is effectively a map from bit vectors of length
   `n` to elements of `A` *)
Inductive Vec (A: Type): nat -> Type :=
| Vec0: A -> Vec A 0
| VecNext n: Vec A n -> Vec A n -> Vec A (S n).

Fixpoint replicate (A: Type) (v: A) n :=
  match n with
  | 0 => Vec0 v
  | S m => VecNext (replicate v m) (replicate v m)
  end.

Inductive Kind :=
| Bool    : Kind
| Bit     : nat -> Kind
| Vector  : Kind -> nat -> Kind
| Struct  : forall n, Vector.t (Attribute Kind) n -> Kind
| Array   : Kind -> nat -> Kind.

Fixpoint type (t: Kind): Type :=
  match t with
  | Bool => bool
  | Bit n => word n
  | Vector nt n => word n -> type nt
  | Struct n ks =>
    forall i: Fin.t n,
      Vector.nth (Vector.map (fun p => type (attrType p)) ks) i
  | Array nt n => Fin.t n -> type nt
  end.

Inductive FullKind: Type :=
| SyntaxKind: Kind -> FullKind
| NativeKind (t: Type) (c: t) : FullKind.

Section Vector_dec.
  Variables (A: Type) (n: nat).
  Variable decA: forall a1 a2: A, {a1 = a2} + {a1 <> a2}.

  Lemma decA_true_iff_sumbool:
    forall a1 a2,
      (if decA a1 a2 then true else false) = true <-> a1 = a2.
  Proof.
    intros; destruct (decA a1 a2); intuition congruence.
  Qed.

  Definition Vector_dec:
    forall v1 v2: Vector.t A n, {v1 = v2} + {v1 <> v2} :=
    Vector.eq_dec _ _ decA_true_iff_sumbool _.

End Vector_dec.

Lemma vector_0_nil A: forall ls: Vector.t A 0, Vector.nil A = ls.
Proof.
  intros; apply Vector.case0; reflexivity.
Defined.

Definition structHd (k: Kind): Attribute Kind :=
  match k with
  | Struct _ Vector.nil => Build_Attribute "FAIL" (Bit 0)
  | Struct _ (Vector.cons attr _ _) => attr
  | _ => Build_Attribute "FAIL" (Bit 0)
  end.

Definition structTl (k: Kind): Kind :=
  match k with
  | Struct _ Vector.nil => Bit 0
  | Struct _ (Vector.cons _ _ tl) => Struct tl
  | _ => Bit 0
  end.

Lemma structHd_ok: forall k1 k2, k1 = k2 -> structHd k1 = structHd k2.
Proof.
  intros; destruct k1, k2; try (inversion H || simpl; reflexivity).
Defined.

Lemma struct_eq_hd:
  forall n (t1 t2: Vector.t _ n),
    Struct t1 = Struct t2 -> structHd (Struct t1) = structHd (Struct t2).
Proof. intros; exact (structHd_ok H). Defined.

Lemma structTl_ok: forall k1 k2, k1 = k2 -> structTl k1 = structTl k2.
Proof.
  intros; destruct k1, k2; try (inversion H || simpl; reflexivity).
Defined.

Lemma struct_eq_tl:
  forall n (t1 t2: Vector.t _ n),
    Struct t1 = Struct t2 -> structTl (Struct t1) = structTl (Struct t2).
Proof. intros; exact (structTl_ok H). Defined.

Lemma struct_eq_inv:
  forall n (t t1: Vector.t _ n), Struct t1 = Struct t -> t1 = t.
Proof.
  induction t; intros.
  - symmetry; apply vector_0_nil.
  - rewrite (VectorSpec.eta t1) in *.
    pose proof (struct_eq_hd H).
    pose proof (struct_eq_tl H).
    simpl in *.
    apply IHt in H1; subst.
    reflexivity.
Defined.

Fixpoint decKind (k1 k2: Kind) : {k1 = k2} + {k1 <> k2}.
  refine match k1, k2 return {k1 = k2} + {k1 <> k2} with
         | Bool, Bool => left eq_refl
         | Bit n, Bit m =>
           match PeanoNat.Nat.eq_dec n m with
           | left l => left match l in _ = Y return Bit n = Bit Y with
                            | eq_refl => eq_refl
                            end
           | right r => right _
           end
         | Vector k1 n1, Vector k2 n2 =>
           match PeanoNat.Nat.eq_dec n1 n2 with
           | left l => match decKind k1 k2 with
                       | left kl => left match l in _ = Y, kl in _ = kY
                                               return Vector k1 n1 = Vector kY Y with
                                         | eq_refl, eq_refl => eq_refl
                                         end
                       | right kr => right _
                       end
           | right r => right _
           end
         | Struct n1 l1, Struct n2 l2 =>
           match PeanoNat.Nat.eq_dec n1 n2 with
           | left l =>
             match l in _ = Y return
                   forall l2: Vector.t _ Y,
                     {Struct l1 = Struct l2} + {Struct l1 <> Struct l2} with
             | eq_refl =>
               fun l2 =>
                 (fix help n l1 :=
                    match l1 in Vector.t _ n'
                          return forall l2: Vector.t _ n',
                        {Struct l1 = Struct l2} + {Struct l1 <> Struct l2} with
                    | Vector.nil => fun l2 => left (f_equal (@Struct 0) (vector_0_nil l2))
                    | Vector.cons h n'' t =>
                      fun l2 => _
                    end) n1 l1 l2
             end l2
           | right r => right _
           end
         | Array k1 n1, Array k2 n2 =>
           match PeanoNat.Nat.eq_dec n1 n2 with
           | left l => match decKind k1 k2 with
                       | left kl => left match l in _ = Y, kl in _ = kY
                                               return Array k1 n1 = Array kY Y with
                                         | eq_refl, eq_refl => eq_refl
                                         end
                       | right kr => right _
                       end
           | right r => right _
           end
         | _, _ => right _
         end;
    try (clear decKind;
         abstract (intro; try inversion H; try inversion H0; destruct_existT; congruence)).

  generalize t (help _ t); clear help t.
  apply (Vector.caseS
           (fun n (l2: Vector.t (Attribute Kind) (S n)) =>
              forall t1, (forall t2: Vector.t (Attribute Kind) n,
                             {Struct t1 = Struct t2} + {Struct t1 <> Struct t2}) ->
                         {Struct (Vector.cons _ h n t1) = Struct l2}
                         + {Struct (Vector.cons _ h n t1) <> Struct l2})).
  intros.
  destruct h, h0.
  destruct (decKind attrType attrType0).
  - destruct (string_dec attrName attrName0).
    + destruct (H t).
      * left; do 2 f_equal.
        { congruence. }
        { exact (struct_eq_inv e1). }
      * clear decKind; right; abstract (intro; inversion H0; destruct_existT; congruence).
    + clear decKind; right; abstract (intro; injection H0; intros; destruct_existT; congruence).
  - clear decKind; right; abstract (intro; injection H0; intros; destruct_existT; congruence).
Defined.

Lemma kind_eq: forall k, decKind k k = left eq_refl.
Proof.
  intros; destruct (decKind k k).
  - rewrite UIP_refl with (p:= e); auto.
  - elim n; auto.
Qed.

Inductive ConstT: Kind -> Type :=
| ConstBool: bool -> ConstT Bool
| ConstBit n: word n -> ConstT (Bit n)
| ConstVector k n: Vec (ConstT k) n -> ConstT (Vector k n)
| ConstStruct n (ls: Vector.t _ n): ilist (fun a => ConstT (attrType a)) ls -> ConstT (Struct ls)
| ConstArray k n: Vector.t (ConstT k) n -> ConstT (Array k n).

Inductive ConstFullT: FullKind -> Type :=
| SyntaxConst k: ConstT k -> ConstFullT (SyntaxKind k)
| NativeConst t (c c': t): ConstFullT (NativeKind c).

Coercion ConstBool : bool >-> ConstT.
Coercion ConstBit : word >-> ConstT.

Fixpoint vector_repeat A n (a: A) :=
  match n return Vector.t A n with
  | 0 => Vector.nil A
  | S m => Vector.cons A a m (@vector_repeat A m a)
  end.

Fixpoint getDefaultConst (k: Kind): ConstT k :=
  match k with
    | Bool => ConstBool false
    | Bit n => ConstBit (wzero _)
    | Vector k n => ConstVector (replicate (getDefaultConst k) n)
    | Struct n ls =>
      ConstStruct ((fix help n (ls: Vector.t _ n) :=
                      match ls return ilist (fun a => ConstT (attrType a)) ls with
                        | Vector.nil => inil _
                        | Vector.cons x m xs => icons x (getDefaultConst (attrType x)) (help m xs)
                      end) n ls)
    | Array k n => ConstArray (vector_repeat n (getDefaultConst k))
  end.

Fixpoint evalConstStruct n (vs: Vector.t _ n) (ils: ilist (fun a => type (attrType a)) vs) {struct ils}: type (Struct vs) :=
  match vs in Vector.t _ k return ilist (fun a => type (attrType a)) vs -> type (Struct vs) with
  | Vector.nil => fun ils0 i0 => Fin.case0 _ i0
  | Vector.cons a1 n1 vs1 =>
    fun ils1 i1 =>
      match ils1 in ilist _ (Vector.cons a n2 vs2)
            return forall i2: Fin.t (S n2),
          Vector.nth
            (Vector.map (fun p => type (attrType p)) (Vector.cons _ a n2 vs2)) i2 with
      | inil => idProp
      | icons t3 n3 vs3 b ils3 =>
        fun k =>
          match k as k4 in Fin.t (S n4) return
                forall (vs4: Vector.t _ n4),
                  type (Struct vs4) ->
                  (Vector.nth (Vector.map (fun p => type (attrType p))
                                          (Vector.cons _ t3 n4 vs4)) k4)
          with
          | Fin.F1 s5 => fun _ _ => b
          | Fin.FS s5 f5 => fun vs5 f => f f5
          end vs3 (@evalConstStruct _ _ ils3)
      end i1
  end ils.

Fixpoint getDefaultConstNative (k: Kind): type k :=
  match k return type k with
  | Bool => false
  | Bit n => wzero _
  | Vector k n => fun _ => getDefaultConstNative k
  | Struct n attrs =>
    fun i =>
      ilist_to_fun _ ((fix help n (ls: Vector.t _ n) :=
                         match ls return ilist (fun a => type (attrType a)) ls with
                         | Vector.nil => inil _
                         | Vector.cons x _ xs =>
                           icons x (getDefaultConstNative (attrType x)) (help _ xs)
                         end) n attrs) i
  | Array k n => fun _ => getDefaultConstNative k
  end.

Definition getDefaultConstFull (k: FullKind): ConstFullT k :=
  match k with
    | SyntaxKind k' => SyntaxConst (getDefaultConst k')
    | NativeKind t c => NativeConst c c
  end.

Record SignatureT :=
  { arg: Kind;
    ret: Kind
  }.

Definition SignatureT_dec: forall (s1 s2: SignatureT), {s1 = s2} + {s1 <> s2}.
Proof.
  decide equality.
  apply decKind.
  apply decKind.
Defined.

Lemma signature_eq: forall sig, SignatureT_dec sig sig = left eq_refl.
Proof.
  intros; destruct (SignatureT_dec sig sig).
  - rewrite UIP_refl with (p:= e); auto.
  - elim n; auto.
Qed.

Inductive UniBoolOp: Set :=
| NegB: UniBoolOp.

Inductive BinBoolOp: Set :=
| AndB: BinBoolOp
| OrB: BinBoolOp.

Inductive UniBitOp: nat -> nat -> Set :=
| Inv n: UniBitOp n n
| Neg n: UniBitOp n n
| ConstExtract n1 n2 n3: UniBitOp (n1 + n2 + n3) n2 (* LSB : n1, MSB : n3 *)
| Trunc n1 n2: UniBitOp (n1 + n2) n1 (* LSB : n1 *)
| ZeroExtendTrunc n1 n2: UniBitOp n1 n2
| SignExtendTrunc n1 n2: UniBitOp n1 n2
| TruncLsb n1 n2 : UniBitOp (n1 + n2) n2. (* MSB : n2 *)

Inductive BinSign := SignSS | SignSU | SignUU.

Inductive BinBitOp: nat -> nat -> nat -> Set :=
| Add n: BinBitOp n n n
| Sub n: BinBitOp n n n
| Mul n: BinSign -> BinBitOp n n n
| Div n: bool -> BinBitOp n n n
| Rem n: bool -> BinBitOp n n n
| Band n: BinBitOp n n n
| Bor n: BinBitOp n n n
| Bxor n: BinBitOp n n n
| Sll n m: BinBitOp n m n
| Srl n m: BinBitOp n m n
| Sra n m: BinBitOp n m n
| Concat n1 n2: BinBitOp n1 n2 (n2 + n1). (* MSB : n1, LSB : n2 *)

Inductive BinBitBoolOp: nat -> nat -> Set :=
| Lt n: BinBitBoolOp n n
| Slt n: BinBitBoolOp n n.

Section Phoas.
  Variable ty: Kind -> Type.
  Definition fullType k := match k with
                           | SyntaxKind k' => ty k'
                           | NativeKind k' _ => k'
                           end.

  Definition FieldKind {n} (ls: Vector.t (Attribute Kind) n)
             (i: Fin.t n) :=
    Vector.nth (Vector.map (@attrType _) ls) i.

  Inductive Expr: FullKind -> Type :=
  | Var k: fullType k -> Expr k
  | Const k: ConstT k -> Expr (SyntaxKind k)
  | UniBool: UniBoolOp -> Expr (SyntaxKind Bool) -> Expr (SyntaxKind Bool)
  | BinBool: BinBoolOp -> Expr (SyntaxKind Bool) -> Expr (SyntaxKind Bool) -> Expr (SyntaxKind Bool)
  | UniBit n1 n2: UniBitOp n1 n2 -> Expr (SyntaxKind (Bit n1)) -> Expr (SyntaxKind (Bit n2))
  | BinBit n1 n2 n3: BinBitOp n1 n2 n3 ->
                     Expr (SyntaxKind (Bit n1)) -> Expr (SyntaxKind (Bit n2)) ->
                     Expr (SyntaxKind (Bit n3))
  | BinBitBool n1 n2: BinBitBoolOp n1 n2 ->
                      Expr (SyntaxKind (Bit n1)) -> Expr (SyntaxKind (Bit n2)) ->
                      Expr (SyntaxKind Bool)
  | ITE k: Expr (SyntaxKind Bool) -> Expr k -> Expr k -> Expr k
  | Eq k: Expr (SyntaxKind k) -> Expr (SyntaxKind k) -> Expr (SyntaxKind Bool)
  | ReadIndex i k: Expr (SyntaxKind (Bit i)) ->
                   Expr (SyntaxKind (Vector k i)) -> Expr (SyntaxKind k)
  | ReadField n (ls: Vector.t _ n) (i: Fin.t n):
      Expr (SyntaxKind (Struct ls)) -> Expr (SyntaxKind (FieldKind ls i))
  | BuildVector n k: Vec (Expr (SyntaxKind n)) k -> Expr (SyntaxKind (Vector n k))
  | BuildStruct n (attrs: Vector.t _ n):
      ilist (fun a => Expr (SyntaxKind (attrType a))) attrs -> Expr (SyntaxKind (Struct attrs))
  | UpdateVector i k: Expr (SyntaxKind (Vector k i)) ->
                      Expr (SyntaxKind (Bit i)) -> Expr (SyntaxKind k) ->
                      Expr (SyntaxKind (Vector k i))
  | ReadArrayIndex i k sz: Expr (SyntaxKind (Bit i)) ->
                           Expr (SyntaxKind (Array k (S sz))) ->
                           Expr (SyntaxKind k)
  | BuildArray n k:
      Vector.t (Expr (SyntaxKind n)) k -> Expr (SyntaxKind (Array n k))
  | UpdateArray k sz i: Expr (SyntaxKind (Array k (S sz))) ->
                        Expr (SyntaxKind (Bit i)) ->
                        Expr (SyntaxKind k) ->
                        Expr (SyntaxKind (Array k (S sz))).

  Inductive BitFormat :=
  | Binary
  | Decimal
  | Hex.

  Definition FullBitFormat := (nat * BitFormat)%type.

  Inductive Disp: Type :=
  | DispBool: FullBitFormat -> Expr (SyntaxKind Bool) -> Disp
  | DispBit: FullBitFormat -> forall n, Expr (SyntaxKind (Bit n)) -> Disp
  | DispStruct n: (Vector.t FullBitFormat n) ->
                  forall ls, Expr (SyntaxKind (@Struct n ls)) -> Disp
  | DispArray: FullBitFormat -> forall n k, Expr (SyntaxKind (Array n k)) -> Disp.

  Inductive ActionT (lretT: Kind) : Type :=
  | MCall (meth: string) s:
      Expr (SyntaxKind (arg s)) ->
      (ty (ret s) -> ActionT lretT) ->
      ActionT lretT
  | Let_ lretT': Expr lretT' -> (fullType lretT' -> ActionT lretT) -> ActionT lretT
  | ReadNondet:
      forall k, (fullType k -> ActionT lretT) -> ActionT lretT
  | ReadReg (r: string):
      forall k, (fullType k -> ActionT lretT) -> ActionT lretT
  | WriteReg (r: string) k:
      Expr k -> ActionT lretT -> ActionT lretT
  | IfElse: Expr (SyntaxKind Bool) -> forall k,
                                        ActionT k ->
                                        ActionT k ->
                                        (ty k -> ActionT lretT) ->
                                        ActionT lretT
  | Assert_: Expr (SyntaxKind Bool) -> ActionT lretT -> ActionT lretT
  | Displ: list Disp -> ActionT lretT -> ActionT lretT
  | Return: Expr (SyntaxKind lretT) -> ActionT lretT.

  Section StructUpdate.

    Lemma nth_map_transparent {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2):
      Vector.nth (Vector.map f v) p1 = f (Vector.nth v p2).
    Proof.
      subst p2; induction p1.
      - revert n v; refine (@caseS _ _ _); now simpl.
      - revert n v p1 IHp1; refine (@caseS _  _ _); now simpl.
    Defined.

    Fixpoint getFinList n: Vector.t (Fin.t n) n :=
      match n with
      | 0 => Vector.nil _
      | S m => Vector.cons _ Fin.F1 _ (Vector.map (fun x => Fin.FS x) (getFinList m))
      end.

    Fixpoint zipVector (A: Type) B n (va: Vector.t A n): Vector.t B n -> Vector.t (A * B) n :=
      match va in Vector.t _ n return Vector.t B n -> Vector.t (A * B) n
      with
      | Vector.nil => fun _ => Vector.nil _
      | Vector.cons a n' va' =>
        fun vb => match vb in Vector.t _ n2 return Vector.t A (pred n2) ->
                                                   Vector.t (A * B) n2 with
                  | Vector.nil => fun _ => Vector.nil _
                  | Vector.cons b n3 vb' =>
                    fun va' => Vector.cons _ (a, b) _ (zipVector va' vb')
                  end va'
      end.

    Definition getVectorFin (A: Type) n (ls: Vector.t A n) :=
      zipVector ls (getFinList n).

    Definition getIlistExpr' n (ls: Vector.t (Attribute Kind) n)
               (e: Expr (SyntaxKind (Struct ls))):
      ilist@{Set Type}
           (fun i : Attribute Kind * Fin.t n =>
              Expr (SyntaxKind (attrType (Vector.nth ls (snd i)))))
           (zipVector ls (getFinList n)) :=
      imap_list _ (fun i => match @nth_map_transparent _ _ (@attrType _) _
                                                       ls (snd i) (snd i) eq_refl
                                  in _ = Y
                                  return Expr (SyntaxKind Y)
                            with
                            | eq_refl => ReadField (snd i) e
                            end) (zipVector ls (getFinList n)).

    Lemma Vector_in_cons (A: Type) (P: A -> Prop) (h: A) n (ls: Vector.t A n):
      (forall a, Vector.In a (Vector.cons A h n ls) -> P a) ->
      forall x, Vector.In x ls -> P x.
    Proof.
      intros pf x in_pf; apply pf.
      apply Vector.In_cons_tl; assumption.
    Defined.

    Section Vec.
      Section VIn.
        Variable A: Type.
        Inductive vIn : A -> forall (n : nat), Vector.t A n -> Prop :=
          In_cons_hd : forall a (m : nat) (v : Vector.t A m), vIn a (Vector.cons A a m v)
        | In_cons_tl : forall a (m : nat) (x : A) (v : Vector.t A m),
            vIn a v -> vIn a (Vector.cons A x m v).

        Lemma vIn_In: forall (a: A) n vs, @vIn a n vs <-> @Vector.In _ a n vs.
        Proof.
          intros.
          split; intros.
          - induction H.
            + apply Vector.In_cons_hd.
            + apply Vector.In_cons_tl; auto.
          - induction H.
            + constructor.
            + constructor; auto.
        Defined.

        Fixpoint VIn (a: A) n (l: Vector.t A n) : Prop :=
          match l with
          | Vector.nil => False
          | Vector.cons b n' ls' => a = b \/ VIn a ls'
          end.

        Lemma VIn_In: forall (a: A) n vs, @VIn a n vs <-> @Vector.In _ a n vs.
        Proof.
          intros.
          split; intros.
          - induction vs.
            + simpl in *.
              exfalso; auto.
            + simpl in H.
              destruct H; subst; constructor; auto.
          - induction H; simpl; auto.
        Defined.

        Lemma in_cons: forall n (ls: Vector.t A n) a b,
            Vector.In a (Vector.cons _ b _ ls) -> a = b \/ Vector.In a ls.
        Proof.
          intros.
          apply VIn_In in H.
          destruct H.
          left; assumption.
          right; apply VIn_In; assumption.
        Defined.

        Lemma Vector_In_nil : forall a, ~ Vector.In a (Vector.nil A).
        Proof.
          unfold not; intros.
          apply VIn_In in H.
          simpl in H.
          assumption.
        Defined.
      End VIn.

      Variables A B: Type.

      Lemma in_zip2: forall n a b (la: Vector.t A n) (lb: Vector.t B n),
          Vector.In (a, b) (zipVector la lb) -> Vector.In b lb.
      Proof.
        induction la; intros.
        - rewrite <- vector_0_nil with (ls := lb) in H.
          simpl in H.
          apply Vector_In_nil in H.
          exfalso; auto.
        - specialize (IHla (Vector.tl lb)).
          rewrite Vector.eta with (v := lb) in H.
          simpl in H.
          apply in_cons in H.
          destruct H.
          + rewrite Vector.eta with (v := lb).
            inv H.
            apply Vector.In_cons_hd.
          + specialize (IHla H).
            rewrite Vector.eta with (v := lb).
            econstructor; eauto.
      Defined.
    End Vec.

    Section Overall.
      Section Imap_change_vec.
        Variable A: Set.
        Variable B: Set.
        Variable f: A -> Type.
        Variable g: B -> Type.
        Variable h: A -> B.
        Fixpoint imap_change_vec n (ls: Vector.t A n):
          ilist f ls -> (forall a, Vector.In a ls -> f a = g (h a)) -> ilist g (Vector.map h ls)
          := match ls in Vector.t _ n
                   return ilist f ls -> (forall a, Vector.In a ls -> f a = g (h a)) ->
                          ilist g (Vector.map h ls)
             with
             | Vector.nil => fun _ _ => inil _
             | Vector.cons h0 n0 ls0 =>
               fun ila pf =>
                 icons (h h0) match pf _ (Vector.In_cons_hd _ _) in _ = Y return Y with
                              | eq_refl => ilist_hd' ila
                              end (imap_change_vec (ilist_tl' ila) (Vector_in_cons _ pf))
             end.
      End Imap_change_vec.

      Section Map.
        Variable A B C: Type.
        Variable f: B -> C.

        Lemma map_zip n (la: Vector.t A n):
          forall (lb: Vector.t B n),
            Vector.map fst (zipVector la lb) = la.
        Proof.
          induction la; intros; auto.
          specialize (IHla (Vector.tl lb)).
          rewrite Vector.eta with (v := lb).
          simpl.
          f_equal; auto.
        Defined.

        Lemma in_zip_map n (la: Vector.t A n):
          forall (lb: Vector.t B n) a c,
            Vector.In (a, c) (zipVector la (Vector.map f lb)) ->
            exists b, c = f b /\ Vector.In (a, b) (zipVector la lb).
        Proof.
          induction la; intros; auto.
          - apply Vector_In_nil in H; exfalso; auto.
          - rewrite Vector.eta with (v := lb) in H.
            simpl in H.
            apply in_cons in H.
            destruct H.
            + inversion H; subst.
              exists (Vector.hd lb).
              split.
              * reflexivity.
              * rewrite Vector.eta with (v := lb).
                simpl.
                apply Vector.In_cons_hd.
            + rewrite Vector.eta with (v := lb).
              specialize (IHla _ _ _ H).
              destruct IHla as [b [ceq vin]].
              simpl.
              exists b.
              split; auto.
              apply Vector.In_cons_tl; auto.
        Defined.
      End Map.

      Variable A: Set.
      Variable f: A -> Type.

      Lemma in_eq n ls:
        (forall a : A * Fin.t n,
            Vector.In a (zipVector ls (getFinList n)) ->
            (fun i : A * Fin.t n => f (Vector.nth ls (snd i))) a = f (fst a)).
      Proof.
        induction ls; intros; destruct a.
        - apply Fin.case0; assumption.
        - simpl in H.
          cbv [fst snd].
          apply in_cons in H.
          destruct H.
          + inversion H; subst.
            reflexivity.
          + apply in_zip_map in H.
            dest; subst.
            apply IHls in H0.
            apply H0.
      Defined.

      Definition elim_fin n (ls: Vector.t A n)
                 (il: ilist@{Set Type} (fun i: (A * Fin.t n) => f (Vector.nth ls (snd i)))
                           (zipVector ls (getFinList n))): ilist@{Set Type} f ls :=
        match map_zip ls (getFinList n) in _ = Y return _ Y with
        | eq_refl => imap_change_vec f (@fst A (Fin.t n)) il (in_eq ls)
        end.
    End Overall.

    Definition getIlistExpr n (ls: Vector.t (Attribute Kind) n)
               (e: Expr (SyntaxKind (Struct ls))):
      ilist@{Set Type} (fun a => Expr (SyntaxKind (attrType a))) ls :=
      elim_fin _ _ (getIlistExpr' e).

    Definition updStruct n (ls: Vector.t (Attribute Kind) n) (e: Expr (SyntaxKind (Struct ls)))
               (i: Fin.t n)
               (v: Expr (SyntaxKind (Vector.nth (Vector.map (@attrType _) ls) i))):
      Expr (SyntaxKind (Struct ls)) :=
      BuildStruct
        (replace_Index (getIlistExpr e) i
                       (match @nth_map_transparent _ _ (@attrType _) _ ls i i eq_refl
                              in _ = Y return Expr (SyntaxKind Y) with
                        | eq_refl => v
                        end)).
  End StructUpdate.

End Phoas.

Definition Action (retTy : Kind) := forall ty, ActionT ty retTy.
Definition MethodT (sig : SignatureT) := forall ty, ty (arg sig) -> ActionT ty (ret sig).

Inductive RegInitValue :=
| RegInitCustom: sigT ConstFullT -> RegInitValue
| RegInitDefault: FullKind -> RegInitValue.

Definition RegInitT := Attribute RegInitValue.
Definition DefMethT := Attribute (sigT MethodT).

Definition filterDm (dms: list DefMethT) (filt: string) :=
  filter (fun dm => if string_dec (attrName dm) filt then false else true) dms.

Definition filterDms (dms: list DefMethT) (filt: list string) :=
  filter (fun dm => if string_in (attrName dm) filt then false else true) dms.

Definition Void := Bit 0.

Record PrimitiveModule :=
  { pm_name: string;
    pm_regInits: list RegInitT;
    pm_rules: list (Attribute (Action Void));
    pm_methods: list DefMethT }.

Inductive Modules: Type :=
| PrimMod (prim: PrimitiveModule): Modules
| Mod (regs: list RegInitT)
      (rules: list (Attribute (Action Void)))
      (dms: list DefMethT): Modules
| ConcatMod (m1 m2: Modules): Modules.

Fixpoint getRules m :=
  match m with
  | PrimMod prim => prim.(pm_rules)
  | Mod _ rules _ => rules
  | ConcatMod m1 m2 => getRules m1 ++ getRules m2
  end.

Fixpoint getRegInits m :=
  match m with
  | PrimMod prim => prim.(pm_regInits)
  | Mod regs _ _ => regs
  | ConcatMod m1 m2 => getRegInits m1 ++ getRegInits m2
  end.

Fixpoint getDefsBodies (m: Modules): list DefMethT :=
  match m with
  | PrimMod prim => prim.(pm_methods)
  | Mod _ _ meths => meths
  | ConcatMod m1 m2 => (getDefsBodies m1) ++ (getDefsBodies m2)
  end.

Definition getDefs m: list string := namesOf (getDefsBodies m).

Lemma getDefs_in:
  forall ma mb k,
    In k (getDefs (ConcatMod ma mb)) ->
    In k (getDefs ma) \/ In k (getDefs mb).
Proof.
  unfold getDefs, namesOf; intros.
  simpl in *; rewrite map_app in H.
  apply in_app_or; auto.
Qed.

Lemma getDefs_in_1:
  forall ma mb k,
    In k (getDefs ma) -> In k (getDefs (ConcatMod ma mb)).
Proof.
  unfold getDefs, namesOf; intros.
  simpl in *; rewrite map_app.
  apply in_or_app; auto.
Qed.

Lemma getDefs_in_2:
  forall ma mb k,
    In k (getDefs mb) -> In k (getDefs (ConcatMod ma mb)).
Proof.
  unfold getDefs, namesOf; intros.
  simpl in *; rewrite map_app.
  apply in_or_app; auto.
Qed.

Lemma getDefs_app:
  forall ma mb,
    getDefs (ConcatMod ma mb) = getDefs ma ++ getDefs mb.
Proof.
  intros.
  unfold getDefs; simpl.
  unfold namesOf; rewrite map_app; reflexivity.
Qed.

Section AppendAction.
  Variable ty: Kind -> Type.

  Fixpoint appendAction {retT1 retT2} (a1: ActionT ty retT1)
           (a2: ty retT1 -> ActionT ty retT2): ActionT ty retT2 :=
    match a1 with
      | MCall name sig ar cont => MCall name sig ar (fun a => appendAction (cont a) a2)
      | Let_ _ ar cont => Let_ ar (fun a => appendAction (cont a) a2)
      | ReadNondet k cont => ReadNondet k (fun a => appendAction (cont a) a2)
      | ReadReg reg k cont => ReadReg reg k (fun a => appendAction (cont a) a2)
      | WriteReg reg _ e cont => WriteReg reg e (appendAction cont a2)
      | IfElse ce _ ta fa cont => IfElse ce ta fa (fun a => appendAction (cont a) a2)
      | Assert_ ae cont => Assert_ ae (appendAction cont a2)
      | Displ ls cont => Displ ls (appendAction cont a2)
      | Return e => Let_ e a2
    end.

  Lemma appendAction_assoc:
    forall {retT1 retT2 retT3}
           (a1: ActionT ty retT1) (a2: ty retT1 -> ActionT ty retT2)
           (a3: ty retT2 -> ActionT ty retT3),
      appendAction a1 (fun t => appendAction (a2 t) a3) = appendAction (appendAction a1 a2) a3.
  Proof.
    induction a1; simpl; intuition idtac; f_equal; try extensionality x; eauto.
  Qed.

End AppendAction.

Section GetCalls.
  Definition typeUT (k: Kind): Type := unit.
  Definition fullTypeUT := fullType typeUT.
  Definition getUT (k: FullKind): fullTypeUT k :=
    match k with
      | SyntaxKind _ => tt
      | NativeKind t c => c
    end.

  Fixpoint getCallsA_Sig {k} (a: ActionT typeUT k): list (string * SignatureT) :=
    match a with
      | MCall m s _ c => (m, s) :: (getCallsA_Sig (c tt))
      | Let_ fk e c => getCallsA_Sig
                         (c match fk as fk' return fullType typeUT fk' with
                              | SyntaxKind _ => tt
                              | NativeKind _ c' => c'
                            end)
      | ReadNondet fk c => getCallsA_Sig
                             (c match fk as fk' return fullType typeUT fk' with
                                | SyntaxKind _ => tt
                                | NativeKind _ c' => c'
                                end)
      | ReadReg _ fk c => getCallsA_Sig
                            (c match fk as fk' return fullType typeUT fk' with
                                 | SyntaxKind _ => tt
                                 | NativeKind _ c' => c'
                               end)
      | WriteReg _ _ _ c => getCallsA_Sig c
      | IfElse _ _ aT aF c =>
        (getCallsA_Sig aT) ++ (getCallsA_Sig aF)
                           ++ (getCallsA_Sig (c tt))
      | Assert_ _ c => getCallsA_Sig c
      | Displ ls c => getCallsA_Sig c
      | Return _ => nil
    end.

  Fixpoint getCallsA {k} (a: ActionT typeUT k): list string :=
    match a with
      | MCall m _ _ c => m :: (getCallsA (c tt))
      | Let_ fk e c => getCallsA
                         (c match fk as fk' return fullType typeUT fk' with
                              | SyntaxKind _ => tt
                              | NativeKind _ c' => c'
                            end)
      | ReadNondet fk c => getCallsA
                            (c match fk as fk' return fullType typeUT fk' with
                                 | SyntaxKind _ => tt
                                 | NativeKind _ c' => c'
                               end)
      | ReadReg _ fk c => getCallsA
                            (c match fk as fk' return fullType typeUT fk' with
                                 | SyntaxKind _ => tt
                                 | NativeKind _ c' => c'
                               end)
      | WriteReg _ _ _ c => getCallsA c
      | IfElse _ _ aT aF c =>
        (getCallsA aT) ++ (getCallsA aF)
                       ++ (getCallsA (c tt))
      | Assert_ _ c => getCallsA c
      | Displ ls c => getCallsA c
      | Return _ => nil
    end.

  Lemma getCallsA_Sig_getCallsA k (a: ActionT typeUT k):
    map fst (getCallsA_Sig a) = getCallsA a.
  Proof.
    induction a; auto; simpl; try f_equal; firstorder idtac.
    rewrite ?map_app; congruence.
  Qed.

  Lemma getCallsA_appendAction:
    forall {retK1} (a1: ActionT typeUT retK1)
           {retK2} (a2: typeUT retK1 -> ActionT typeUT retK2),
      getCallsA (appendAction a1 a2) =
      getCallsA a1 ++ getCallsA (a2 tt).
  Proof.
    induction a1; simpl; intros; auto.
    - f_equal; auto.
    - do 2 rewrite <-app_assoc.
      f_equal; f_equal; auto.
  Qed.

  Definition getCallsRule (r: Attribute (Action (Bit 0)))
  : list string :=
    getCallsA (attrType r typeUT).

  Definition getCallsRule_Sig (r: Attribute (Action (Bit 0))) :=
    getCallsA_Sig (attrType r typeUT).

  Lemma getCallsRule_Sig_getCallsRule r:
    map fst (getCallsRule_Sig r) = getCallsRule r.
  Proof.
    unfold getCallsRule_Sig, getCallsRule.
    rewrite getCallsA_Sig_getCallsA.
    auto.
  Qed.

  Fixpoint getCallsR (rl: list (Attribute (Action (Bit 0))))
  : list string :=
    match rl with
      | nil => nil
      | r :: rl' => (getCallsA (attrType r typeUT)) ++ (getCallsR rl')
    end.

  Fixpoint getCallsR_Sig (rl: list (Attribute (Action (Bit 0)))) :=
    match rl with
      | nil => nil
      | r :: rl' => (getCallsA_Sig (attrType r typeUT)) ++ (getCallsR_Sig rl')
    end.

  Lemma getCallsR_Sig_getCallsR r:
    map fst (getCallsR_Sig r) = getCallsR r.
  Proof.
    induction r; auto; simpl.
    rewrite map_app.
    rewrite IHr.
    rewrite getCallsA_Sig_getCallsA.
    auto.
  Qed.

  Definition getCallsDm (dm: DefMethT): list string :=
    getCallsA (projT2 (attrType dm) typeUT tt).

  Definition getCallsDm_Sig (dm: DefMethT) :=
    getCallsA_Sig (projT2 (attrType dm) typeUT tt).

  Lemma getCallsDm_Sig_getCallsDm r:
    map fst (getCallsDm_Sig r) = getCallsDm r.
  Proof.
    unfold getCallsDm_Sig, getCallsDm.
    rewrite getCallsA_Sig_getCallsA.
    auto.
  Qed.

  Fixpoint getCallsM (ms: list DefMethT): list string :=
    match ms with
      | nil => nil
      | m :: ms' => (getCallsA ((projT2 (attrType m)) typeUT tt))
                      ++ (getCallsM ms')
    end.

  Fixpoint getCallsM_Sig (ms: list DefMethT) :=
    match ms with
      | nil => nil
      | m :: ms' => (getCallsA_Sig ((projT2 (attrType m)) typeUT tt))
                      ++ (getCallsM_Sig ms')
    end.

  Lemma getCallsM_Sig_getCallsM r:
    map fst (getCallsM_Sig r) = getCallsM r.
  Proof.
    induction r; simpl; auto.
    rewrite map_app, IHr, getCallsA_Sig_getCallsA.
    auto.
  Qed.

  Lemma getCallsM_implies_getCallsDm s ms:
    In s (getCallsM ms) -> exists dm, In dm ms /\ In s (getCallsDm dm).
  Proof.
    induction ms; intros; simpl in *.
    - intuition.
    - apply in_app_or in H.
      destruct H.
      + exists a.
        intuition.
      + specialize (IHms H).
        destruct IHms.
        destruct H0.
        exists x.
        intuition.
  Qed.

  Lemma getCallsM_app: forall ms1 ms2, getCallsM (ms1 ++ ms2) = getCallsM ms1 ++ getCallsM ms2.
  Proof.
    induction ms1; intros; [reflexivity|].
    simpl; rewrite IHms1; apply app_assoc.
  Qed.

  Lemma getCallsR_app: forall ms1 ms2, getCallsR (ms1 ++ ms2) = getCallsR ms1 ++ getCallsR ms2.
  Proof.
    induction ms1; intros; [reflexivity|].
    simpl; rewrite IHms1; apply app_assoc.
  Qed.

  Definition getCalls m := getCallsR (getRules m) ++ getCallsM (getDefsBodies m).

  Definition getCalls_Sig m := getCallsR_Sig (getRules m) ++ getCallsM_Sig (getDefsBodies m).

  Lemma getCalls_Sig_getCalls m:
    map fst (getCalls_Sig m) = getCalls m.
  Proof.
    unfold getCalls_Sig, getCalls.
    rewrite map_app, getCallsR_Sig_getCallsR, getCallsM_Sig_getCallsM.
    auto.
  Qed.

  Lemma getCalls_in:
    forall ma mb k,
      In k (getCalls (ConcatMod ma mb)) ->
      In k (getCalls ma) \/ In k (getCalls mb).
  Proof.
    unfold getCalls; intros.
    apply in_app_or in H; destruct H.
    - simpl in H; rewrite getCallsR_app in H.
      apply in_app_or in H; destruct H.
      + left; apply in_or_app; auto.
      + right; apply in_or_app; auto.
    - simpl in H; rewrite getCallsM_app in H.
      apply in_app_or in H; destruct H.
      + left; apply in_or_app; auto.
      + right; apply in_or_app; auto.
  Qed.

  Lemma getCalls_in_1:
    forall ma mb k,
      In k (getCalls ma) -> In k (getCalls (ConcatMod ma mb)).
  Proof.
    unfold getCalls; intros.
    apply in_or_app; apply in_app_or in H; destruct H.
    - left; simpl; rewrite getCallsR_app.
      apply in_or_app; auto.
    - right; simpl; rewrite getCallsM_app.
      apply in_or_app; auto.
  Qed.

  Lemma getCalls_in_2:
    forall ma mb k,
      In k (getCalls mb) -> In k (getCalls (ConcatMod ma mb)).
  Proof.
    unfold getCalls; intros.
    apply in_or_app; apply in_app_or in H; destruct H.
    - left; simpl; rewrite getCallsR_app.
      apply in_or_app; auto.
    - right; simpl; rewrite getCallsM_app.
      apply in_or_app; auto.
  Qed.

  Lemma getCalls_subList_1:
    forall m1 m2, SubList (getCalls m1 ++ getCalls m2) (getCalls (ConcatMod m1 m2)).
  Proof.
    unfold SubList; intros.
    apply in_app_or in H; destruct H.
    - apply getCalls_in_1; auto.
    - apply getCalls_in_2; auto.
  Qed.

  Lemma getCalls_subList_2:
    forall m1 m2, SubList (getCalls (ConcatMod m1 m2)) (getCalls m1 ++ getCalls m2).
  Proof.
    unfold SubList; intros.
    apply getCalls_in in H; destruct H; apply in_or_app; auto.
  Qed.

  Lemma getCallsR_SubList:
    forall ra rb,
      SubList ra rb ->
      SubList (getCallsR ra) (getCallsR rb).
  Proof.
    induction ra; simpl; intros.
    - apply SubList_nil.
    - apply SubList_cons_inv in H; dest.
      apply SubList_app_3; auto.
      clear -H; induction rb; simpl; [inv H|].
      inv H.
      + apply SubList_app_1, SubList_refl.
      + apply SubList_app_2; auto.
  Qed.

  Lemma getCallsM_SubList:
    forall ra rb,
      SubList ra rb ->
      SubList (getCallsM ra) (getCallsM rb).
  Proof.
    induction ra; simpl; intros.
    - apply SubList_nil.
    - apply SubList_cons_inv in H; dest.
      apply SubList_app_3; auto.
      clear -H; induction rb; simpl; [inv H|].
      inv H.
      + apply SubList_app_1, SubList_refl.
      + apply SubList_app_2; auto.
  Qed.

  Lemma module_structure_indep_getCalls:
    forall ma mb,
      SubList (getRules ma) (getRules mb) ->
      SubList (getDefsBodies ma) (getDefsBodies mb) ->
      SubList (getCalls ma) (getCalls mb).
  Proof.
    intros.
    unfold getCalls.
    apply SubList_app_3.
    - apply SubList_app_1.
      apply getCallsR_SubList; auto.
    - apply SubList_app_2.
      apply getCallsM_SubList; auto.
  Qed.

  Definition DefCallSub (impl spec: Modules) :=
    SubList (getDefs spec) (getDefs impl) /\
    SubList (getCalls spec) (getCalls impl).

  Lemma DefCallSub_refl:
    forall m, DefCallSub m m.
  Proof.
    intros; split; apply SubList_refl.
  Qed.
  #[local] Hint Immediate DefCallSub_refl.

  Lemma DefCallSub_modular:
    forall m1 m2 m3 m4,
      DefCallSub m1 m3 ->
      DefCallSub m2 m4 ->
      DefCallSub (ConcatMod m1 m2) (ConcatMod m3 m4).
  Proof.
    unfold DefCallSub, SubList; intros; dest; split; intros.
    - specialize (H e); specialize (H0 e); specialize (H1 e); specialize (H2 e).
      apply getDefs_in in H3; destruct H3.
      + apply getDefs_in_1; auto.
      + apply getDefs_in_2; auto.
    - specialize (H e); specialize (H0 e); specialize (H1 e); specialize (H2 e).
      apply getCalls_in in H3; destruct H3.
      + apply getCalls_in_1; auto.
      + apply getCalls_in_2; auto.
  Qed.

End GetCalls.

Section NoInternalCalls.
  Fixpoint isLeaf {retT} (a: ActionT typeUT retT) (cs: list string) :=
    match a with
    | MCall name _ _ cont => (negb (string_in name cs)) && (isLeaf (cont tt) cs)
    | Let_ _ ar cont => isLeaf (cont (getUT _)) cs
    | ReadNondet k cont => isLeaf (cont (getUT _)) cs
    | ReadReg reg k cont => isLeaf (cont (getUT _)) cs
    | WriteReg reg _ e cont => isLeaf cont cs
    | IfElse ce _ ta fa cont => (isLeaf ta cs) && (isLeaf fa cs) && (isLeaf (cont tt) cs)
    | Assert_ ae cont => isLeaf cont cs
    | Displ ls cont => isLeaf cont cs
    | Return e => true
    end.

  Definition noCallDm (dm: DefMethT) (tgt: DefMethT) :=
    isLeaf (projT2 (attrType dm) typeUT tt) (attrName tgt :: nil).

  Fixpoint noCallsDms (dms: list DefMethT) (calls: list string) :=
    match dms with
    | nil => true
    | dm :: dms' =>
      if isLeaf (projT2 (attrType dm) typeUT tt) calls
      then noCallsDms dms' calls
      else false
    end.

  Fixpoint noCallsRules (rules: list (Attribute (Action Void)))
           (calls: list string) :=
    match rules with
    | nil => true
    | r :: rules' =>
      if isLeaf (attrType r typeUT) calls
      then noCallsRules rules' calls
      else false
    end.

  Definition noCalls (m: Modules) (calls: list string) :=
    (noCallsRules (getRules m) calls)
      && (noCallsDms (getDefsBodies m) calls).

  Definition noInternalCalls (m: Modules) :=
    noCalls m (getDefs m).

End NoInternalCalls.

Definition getExtDefsBodies (m: Modules) :=
  filter (fun dm => negb (string_in (attrName dm) (getCalls m))) (getDefsBodies m).

Definition getExtDefs (m: Modules) :=
  filter (fun d => negb (string_in d (getCalls m))) (getDefs m).

Definition getExtCalls (m: Modules) :=
  filter (fun c => negb (string_in c (getDefs m))) (getCalls m).

Definition getIntDefs (m: Modules) :=
  filter (fun d => string_in d (getCalls m)) (getDefs m).

Definition getIntCalls (m: Modules) :=
  filter (fun c => string_in c (getDefs m)) (getCalls m).

Definition getExtMeths (m: Modules) := getExtDefs m ++ getExtCalls m.
Definition getIntMeths (m: Modules) := getIntDefs m ++ getIntCalls m.

Lemma getExtDefs_getDefs:
  forall m, SubList (getExtDefs m) (getDefs m).
Proof.
  unfold SubList, getExtDefs; intros.
  apply filter_In in H; dest; auto.
Qed.

Lemma getExtCalls_getCalls:
  forall m, SubList (getExtCalls m) (getCalls m).
Proof.
  unfold SubList, getExtCalls; intros.
  apply filter_In in H; dest; auto.
Qed.

Lemma getExtMeths_meths:
  forall m, SubList (getExtMeths m) (getDefs m ++ getCalls m).
Proof.
  intros; apply SubList_app_3.
  - apply SubList_app_1, getExtDefs_getDefs.
  - apply SubList_app_2, getExtCalls_getCalls.
Qed.

Lemma getIntDefs_getDefs:
  forall m, SubList (getIntDefs m) (getDefs m).
Proof.
  unfold SubList, getIntDefs; intros.
  apply filter_In in H; dest; auto.
Qed.

Lemma getIntCalls_getCalls:
  forall m, SubList (getIntCalls m) (getCalls m).
Proof.
  unfold SubList, getIntCalls; intros.
  apply filter_In in H; dest; auto.
Qed.

Lemma getIntMeths_meths:
  forall m, SubList (getIntMeths m) (getDefs m ++ getCalls m).
Proof.
  intros; apply SubList_app_3.
  - apply SubList_app_1, getIntDefs_getDefs.
  - apply SubList_app_2, getIntCalls_getCalls.
Qed.

Lemma getIntCalls_getExtCalls_disj:
  forall m, DisjList (getIntCalls m) (getExtCalls m).
Proof.
  unfold getIntCalls, getExtCalls; intros.
  apply DisjList_logic; intros.
  apply filter_In in H; apply filter_In in H0; dest.
  rewrite H2 in H1; discriminate.
Qed.

Lemma getIntDefs_getExtDefs_disj:
  forall m, DisjList (getIntDefs m) (getExtDefs m).
Proof.
  unfold getIntDefs, getExtDefs; intros.
  apply DisjList_logic; intros.
  apply filter_In in H; apply filter_In in H0; dest.
  rewrite H2 in H1; discriminate.
Qed.

Lemma getCalls_flattened:
  forall m,
    getCalls (Mod (getRegInits m) (getRules m) (getDefsBodies m)) =
    getCalls m.
Proof. reflexivity. Qed.

Lemma getDefs_flattened:
  forall m,
    getDefs (Mod (getRegInits m) (getRules m) (getDefsBodies m)) =
    getDefs m.
Proof. reflexivity. Qed.

Lemma getExtDefs_in:
  forall m1 m2 s,
    In s (getExtDefs (ConcatMod m1 m2)) ->
    In s (getExtDefs m1) \/ In s (getExtDefs m2).
Proof.
  unfold getExtDefs; intros.
  apply filter_In in H; dest.
  apply negb_true_iff, eq_sym in H0.
  apply string_in_dec_not_in in H0.
  rewrite getDefs_app in H; apply in_app_or in H; destruct H.
  - left; apply filter_In; split; auto.
    apply negb_true_iff.
    remember (string_in _ _) as sin; destruct sin; auto.
    apply string_in_dec_in in Heqsin.
    elim H0; apply getCalls_in_1; auto.
  - right; apply filter_In; split; auto.
    apply negb_true_iff.
    remember (string_in _ _) as sin; destruct sin; auto.
    apply string_in_dec_in in Heqsin.
    elim H0; apply getCalls_in_2; auto.
Qed.

Lemma getExtCalls_in:
  forall m1 m2 s,
    In s (getExtCalls (ConcatMod m1 m2)) ->
    In s (getExtCalls m1) \/ In s (getExtCalls m2).
Proof.
  unfold getExtCalls; intros.
  apply filter_In in H; dest.
  apply negb_true_iff, eq_sym in H0.
  apply string_in_dec_not_in in H0.
  apply getCalls_in in H; destruct H.
  - left; apply filter_In; split; auto.
    apply negb_true_iff.
    remember (string_in _ _) as sin; destruct sin; auto.
    apply string_in_dec_in in Heqsin.
    elim H0; rewrite getDefs_app; apply in_or_app; auto.
  - right; apply filter_In; split; auto.
    apply negb_true_iff.
    remember (string_in _ _) as sin; destruct sin; auto.
    apply string_in_dec_in in Heqsin.
    elim H0; rewrite getDefs_app; apply in_or_app; auto.
Qed.

Lemma getExtMeths_in:
  forall m1 m2 s,
    In s (getExtMeths (ConcatMod m1 m2)) ->
    In s (getExtMeths m1) \/ In s (getExtMeths m2).
Proof.
  unfold getExtMeths; intros.
  apply in_app_or in H; destruct H.
  - apply getExtDefs_in in H; destruct H.
    + left; apply in_or_app; auto.
    + right; apply in_or_app; auto.
  - apply getExtCalls_in in H; destruct H.
    + left; apply in_or_app; auto.
    + right; apply in_or_app; auto.
Qed.

#[global] Hint Unfold pm_rules pm_regInits pm_methods
     getRules getRegInits getDefs getCalls getDefsBodies
     getExtDefsBodies getExtDefs getExtCalls getExtMeths
     getIntDefs getIntCalls getIntMeths.

(** Notations *)

Declare Scope kami_struct_scope.
Notation "name :: ty" := {| attrName := name; attrType := ty |} : kami_struct_scope.
Delimit Scope kami_struct_scope with struct.

Declare Scope kami_scope.
Notation "m1 ++ m2" := (ConcatMod m1 m2) : kami_scope.
Delimit Scope kami_scope with kami.


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

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

Print Assumptions square.


Section ml.
Theorem Dm_alln: forall A:Set -> Prop,
(forall x:Set, ~ A x) -> (~ exists x:Set, A x).
Proof.
intro f.
intro h0.
intro h1.
case h1.
intro x.
intro fx.
apply h0 with x.
assumption.
Qed.
End ml.

Check Dm_alln.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Require Import PeanoNat.
Require Import Psatz. (* lia tactic for linear integer arithmetic *)

Require Export Parser.Structures.
Require Export Parser.Tactics.

Fixpoint remove_id (xs : names) (i : id) : names := match xs with
  | nil => nil
  | cons y ys =>
    if id_eq_dec i y
    then remove_id ys i
    else cons y (remove_id ys i)
  end.

Lemma remove_id_smaller : forall xs i,
  length (remove_id xs i) <= length xs.
Proof.
  induction xs; repeat light || destruct_match; firstorder with lia.
Qed.

Ltac t_remove_id_smaller :=
  match goal with
  | |- context[remove_id ?xs ?i] =>
    poseNew (Mark (xs, i) "remove_id_smaller");
    pose proof (remove_id_smaller xs i)
  end.

Lemma remove_id_strictly_smaller : forall xs i,
  In i xs ->
  length (remove_id xs i) < length xs.
Proof.
  induction xs; repeat light || destruct_match || instantiate_any || t_remove_id_smaller; lia.
Qed.

Ltac t_remove_id_strictly_smaller :=
  match goal with
  | H: In ?i ?xs |- context[length (remove_id ?xs ?i)] =>
    poseNew (Mark (i,xs) "remove_id_strictly_smaller");
    pose proof (remove_id_strictly_smaller xs i)
  end.

Lemma remove_id_preserve_others : forall xs i j,
  (i <> j) ->
  In j xs ->
  In j (remove_id xs i).
Proof.
  induction xs; repeat light || destruct_match.
Qed.

Ltac t_remove_id_preserve_others :=
  match goal with
  | H1: ?i = ?j -> False, H2: In ?j ?xs |- _ =>
    is_var xs;
    poseNew (Mark (i,j,xs) "remove_id_preserve_others");
    pose proof (remove_id_preserve_others _ _ _ H1 H2)
  | H1: ?j = ?i -> False, H2: In ?j ?xs |- _ =>
    is_var xs;
    poseNew (Mark (i,j,xs) "remove_id_preserve_others");
    unshelve epose proof (remove_id_preserve_others _ _ _ _ H2)
  end.

Lemma remove_id_no_new : forall xs i j,
  In j (remove_id xs i) ->
  In j xs.
Proof.
  induction xs; repeat light || destruct_match; eauto.
Qed.

Lemma remove_id_not_in : forall xs i,
  ~In i xs ->
  remove_id xs i = xs.
Proof.
  induction xs; repeat light || destruct_match || f_equal; eauto.
Qed.

Lemma remove_id_sub_names_1 : forall n x,
  incl (remove_id n x) n.
Proof.
  unfold incl; intros; eauto using remove_id_no_new.
Qed.

Lemma remove_id_sub_names_2 : forall n0 n x,
  incl n n0 ->
  incl (remove_id n x) n0.
Proof.
  unfold incl; intros; eauto using remove_id_no_new.
Qed.

Lemma remove_id_commute: forall n i j,
  remove_id (remove_id n i) j = remove_id (remove_id n j) i.
Proof.
  induction n; repeat light || destruct_match.
Qed.

Lemma in_remove_self: forall n i,
  In i (remove_id n i) -> False.
Proof.
  induction n; repeat light || destruct_match; eauto.
Qed.

Ltac t_in_remove_self :=
  match goal with
  | H: In ?i (remove_id ?n ?i) |- _ =>
    apply (False_ind _ (in_remove_self _ _ H))
  end.

Lemma remove_id_twice: forall n i,
  remove_id (remove_id n i) i = remove_id n i.
Proof.
  induction n; repeat light || destruct_match.
Qed.

Ltac decide_id_equalities :=
  match goal with
  | i1: id, i2: id |- _ =>
    poseNew (Mark (i1, i2) "Nat.eq_dec");
    poseNew (Mark (i2, i1) "Nat.eq_dec");
    pose proof (id_eq_dec i1 i2)
  end.

Lemma remove_id_sub_names_both : forall n1 n2 x,
  incl n2 n1 ->
  incl (remove_id n2 x) (remove_id n1 x).
Proof.
  unfold incl; repeat light || decide_id_equalities || t_in_remove_self || apply remove_id_preserve_others || apply_any;
    eauto using remove_id_no_new.
Qed.


Require Export D.

Theorem hoare_post_true : forall (P Q:Assertion) c,
  (forall st, Q st) -> {{P}} c {{Q}}.
Proof. intros. unfold hoare_triple.
  intros. apply H. Qed.

Theorem hoare_post_false : forall (P Q:Assertion) c,
  (forall st, ~(P st)) -> {{P}} c {{Q}}.
Proof. intros. unfold hoare_triple. intros. apply H in H1. contradiction. Qed.

Theorem big_small :
  (fun st => st X < 10) ->> (fun st => st X < 11).
Proof. unfold "->>".
intros. apply le_trans with 10. unfold "<" in H. assumption. apply le_S. apply le_n. Qed.

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof. intros. unfold assn_sub. unfold hoare_triple. intros.
  inversion H; subst. assumption. Qed.

(* 이 문제의 포인트는, (X::=a) / st||st', st X = m 일 때,
  st = (update st' X m) 인 것을 이해하는 것인 듯. *)
Theorem hoare_asgn_fwd :
  (forall {X Y: Type} {f g : X -> Y},
     (forall (x: X), f x = g x) -> f = g) ->
  forall m a P,
  {{fun st => P st /\ st X = m}}
    X ::= a
  {{fun st => P (update st X m) /\ st X = aeval (update st X m) a }}.
Proof.
  intros functional_extensionality m a P.
  unfold hoare_triple; intros.
  split. destruct H0.
  (* X를 바꿨지만, 바꾸기 전에 st X = m이었으니까, P 에도 X값이 m이되는 state를 넣어주면 성립한다 *)
Case "left".
  assert (st = update st' X m). apply functional_extensionality. intros.
  inversion H; subst.
  unfold update. destruct (eq_id_dec X x). rewrite e. reflexivity. reflexivity. rewrite<-H2. assumption.
  Case "right".
  destruct H0. inversion H; subst.
  assert (st = (update (update st X (aeval st a)) X (st X))).
  unfold update. apply functional_extensionality. intros.
  destruct (eq_id_dec X x). rewrite e. reflexivity. reflexivity.
  rewrite<-H1. unfold update. rewrite eq_id. reflexivity.
  Qed.

(* 이건 존재하는게 뭔지 잘 생각해서 넣는 게 중요 *)
Theorem hoare_asgn_fwd_exists :
  (forall {X Y: Type} {f g : X -> Y},
     (forall (x: X), f x = g x) -> f = g) ->
  forall a P,
  {{fun st => P st}}
    X ::= a
  {{fun st => exists m, P (update st X m) /\
                st X = aeval (update st X m) a }}.
Proof.
  intros functional_extensionality a P.
  unfold hoare_triple. intros.
  exists (st X). inversion H; subst.
  assert (st = update (update st X (aeval st a)) X (st X)). apply functional_extensionality. intros.
  unfold update. destruct (eq_id_dec X x); try rewrite e; try reflexivity.
  rewrite<-H1. split; try apply H0.
  unfold update. apply eq_id. Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof. unfold hoare_triple. intros. apply (H st st'). apply H1.
  unfold assert_implies in H0. apply (H0 st). assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof. unfold hoare_triple; unfold assert_implies; intros.
  apply (H0 st'); apply (H st st'); assumption. Qed.

Example hoare_asgn_example1 :
  {{fun st => True}} (X ::= (ANum 1)) {{fun st => st X = 1}}.
Proof.
(* 내가 한거
  unfold hoare_triple. intros.
  inversion H; subst. unfold update; apply eq_id. Qed.
*)
(* 모범? 답안 *)
  apply hoare_consequence_pre
    with (P' := (fun st => st X = 1) [ X |-> ANum 1]).
 (* apply hoare_asgn.*)
  unfold assn_sub. unfold hoare_triple. intros.
  inversion H; subst. assumption.
(****************************************************)
 unfold assert_implies. intros.
  reflexivity.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hpre Hp.
  apply hoare_consequence_post.
  apply (hoare_consequence_pre P P' Q'); assumption.
Qed.

Example hoare_asgn_example1' :
  {{fun st => True}}
  (X ::= (ANum 1))
  {{fun st => st X = 1}}.
Proof.
(* 내가 한게 더 깔끔한듯?
 unfold hoare_triple. intros.
  inversion H; subst. simpl. reflexivity. Qed.
  *)

(* 이거 대신
  apply hoare_consequence_pre
    with (P' := (fun st => st X = 1) [X|->ANum 1]). *)
  eapply hoare_consequence_pre.
  apply hoare_asgn.
  unfold assert_implies. intros.
  reflexivity.
  Qed.

Lemma silly1 : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (forall x y : nat, P x y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof. intros. eapply H0. apply H with (y:=42). Qed.
Qed.

Lemma silly2 :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof. intros. eapply H0. destruct H.
 (* apply H.*)
Abort.

Lemma silly2_fixed :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ.
(* 얘네 둘의 순서가 중요하다! *)
destruct HP as [y HP'].  eapply HQ.
apply HP'.
Qed.

Lemma silly2_eassumption : forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof. intros. destruct H. eapply H0. eassumption. Qed.

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof. unfold hoare_triple. intros.
inversion H; subst. assumption. Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof. unfold hoare_triple. intros P Q R c1 c2 H1 H2.
  intros st st' Hc Hp. inversion Hc; subst.
  eapply H1. eassumption.
  eapply H2. eassumption.
  assumption. Qed.

Example hoare_asgn_example3 : forall a n,
  {{fun st => aeval st a = n}}
  (X ::= a;; SKIP)
  {{fun st => st X = n}}.
Proof. intros. apply hoare_seq with (Q := (fun st => st X = n)).
  unfold hoare_triple; intros. inversion H; subst. reflexivity.
  unfold hoare_triple; intros. inversion H; subst. reflexivity.
Qed.

(*
Definition swap_program : com :=
  (* FILL IN HERE *) admit.

 Theorem swap_exercise :
  {{fun st => st X <= st Y}}
  swap_program
  {{fun st => st Y <= st X}}.
Proof.
*)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof. intros. unfold bassn. assumption. Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof. intros. unfold bassn, not. intros. rewrite H in H0. inversion H0. Qed.

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof. intros. unfold hoare_triple in *. intros.
  destruct (beval st b) eqn:Hb.
  Case "True".
  inversion H1; subst.
  apply (H st); try split; try assumption.
  rewrite Hb in H8. inversion H8.
  Case "False".
  inversion H1; subst.
  rewrite Hb in H8. inversion H8.
  apply (H0 st); try split; try assumption.
  unfold bassn. rewrite Hb. unfold not; intros; inversion H3.
Qed.

Lemma beq_nat_same : forall n, (beq_nat n 0 = true) -> n = 0.
Proof. intros. induction n. reflexivity. inversion H. Qed.

Example if_example :
    {{fun st => True}}
  IFB (BEq (AId X) (ANum 0))
    THEN (Y ::= (ANum 2))
    ELSE (Y ::= APlus (AId X) (ANum 1))
  FI
    {{fun st => st X <= st Y}}.
Proof. apply hoare_if; unfold hoare_triple; intros.
  Case "True".
  inversion H; subst. simpl.
  destruct H0. inversion H1. assert (st X = 0). apply beq_nat_same in H3. assumption.
 unfold update. rewrite eq_id. destruct (eq_id_dec Y X).
  apply le_n. rewrite H2. apply le_S. apply le_S. apply le_n.
  Case "False".
  inversion H; subst. simpl. unfold update.
  rewrite eq_id. destruct (eq_id_dec Y X). apply le_n.
  replace (st X + 1) with (S (st X)).  apply le_S, le_n. omega.
Qed.

(* if_minus_plus 까지만 함. 그 밑에꺼 연습할 것 *)


Require Import Lists.List.
Require Import JMeq.

Fixpoint distinct (A : Type) (l : list A) : Prop :=
  match l with
    | nil => True
    | cons a l' => (~ In a l') /\ distinct A l'
  end.

Implicit Arguments distinct [A].

Lemma nth_error_in : forall A (l : list A) a n, nth_error l n = Some a -> In a l.
  induction l; intros; destruct n; simpl in *|-*; try discriminate.
  inversion H. auto.
  right. apply (IHl _ _ H).
Qed.

Ltac Forall2_trans' :=
  match goal with
    | [ H : forall l l', Forall2 ?R l ?l -> Forall2 ?R' ?l l' -> Forall2 ?R'' l l'|- _] => eapply H; eauto
    | [H : Forall2 ?R ?l ?l',
           H0 : Forall2 ?R' ?l' ?l''
       |- Forall2 ?R'' ?l ?l''] =>
      generalize H H0; clear;
      generalize l l''; induction l'; intros; inversion H0; subst;
      try assumption;
      inversion l''; inversion H; subst; try constructor
    | _ => idtac
  end.

Ltac Forall2_trans := repeat Forall2_trans'.

Lemma Forall2_length : forall A B (R : A -> B -> Prop) l l',
                         Forall2 R l l' -> length l = length l'.
  induction l; induction l'; intros; inversion H; subst; try reflexivity.
  simpl; auto.
Qed.

Lemma Forall2_nth_error :
  forall A B (R : A -> B -> Prop) l l',
    Forall2 R l l' ->
    (forall a n, nth_error l n = Some a ->
                 exists b, nth_error l' n = Some b /\ R a b) /\
    (forall n, nth_error l n = None -> nth_error l' n = None).
  intros A B R l l' H.
  split; induction H; intros; induction n;
  try reflexivity; try discriminate; try inversion H1; try eapply @IHForall2;
  subst; repeat eexists; eauto.
Qed.

Ltac existT_eq' :=
  match goal with
    | [ H : existT ?f ?t ?a = existT ?f ?t ?b,
            H' : JMeq ?a ?b |- _ ] =>
      subst; clear H
    | [ H : existT ?f ?t ?a = existT ?f ?t ?b |- JMeq ?a ?b] =>
      change (match existT f t a with
                | existT t c => JMeq c b
              end); rewrite H; constructor
    | [ H : existT ?f ?t ?a = existT ?f ?t ?b |- _] =>
      assert (JMeq a b)

    | [ H : JMeq (existT ?f ?t ?a) (existT ?f ?t ?b),
            H' : JMeq ?a ?b |- _ ] =>
      subst; clear H
    | [ H : JMeq (existT ?f ?t ?a) (existT ?f ?t ?b) |- JMeq ?a0 ?b0] =>
      change (match existT f t a with
                | existT t c => JMeq c b0
              end); rewrite H; constructor
    | [ H : JMeq (existT ?f ?t ?a) (existT ?f ?t ?b) |- _ ] =>
      assert (JMeq a b)

    | _ => fail
  end.

Ltac existT_eq := repeat existT_eq'.


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

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

Print Assumptions mul.


Require Import Basics Types Diagram Colimit CoEqualizer Colimit_Sigma MyTacs MyLemmas.

Local Open Scope path_scope.
Generalizable All Variables.

Context `{Funext}.

Section KernelPair.
  Definition KP_diag `(f: A -> B) : diagram coequalizer_graph.
    simple refine (Build_diagram _ _ _).
    - intro x; destruct x.
      exact {a:A & {a':A & f a = f a'}}. exact A.
    - intros i j; destruct i, j; intro H; destruct H. exact pr1. exact (λ w, w.2.1).
  Defined.

  Definition KP_cocone `{f: A -> B} `(q: A -> Q) (Hq: forall x y, f x = f y -> q x = q y)
  : cocone (KP_diag f) Q.
  simple refine (Build_cocone _ _).
  - intros i x; destruct i; simpl in *. exact (q x.1). exact (q x).
  - intros i j g x; destruct i, j, g; simpl in *. reflexivity.
    simple refine (Hq _ _ _). exact x.2.2^.
  Defined.

  Definition KP `(f: A -> B) := colimit (KP_diag f).

  Definition KP_colimit `(f: A -> B) : is_colimit (KP_diag f) (KP f)
    := is_colimit_colimit _.

  Definition kp `{f: A -> B} : A -> KP f :=
    @colim _ (KP_diag f) false.

  Definition kp_eq `{f: A -> B} : forall (a a': A), f a = f a' -> @kp _ _ f a = kp a'.
    intros a a' p.
    etransitivity. exact (@pp _ (KP_diag f) true false true (a; (a'; p))).
    exact (@pp _ (KP_diag f) true false false (a; (a'; p)))^.
  Defined.
End KernelPair.

Section T.
  Definition T_diag (X: Type) : diagram coequalizer_graph.
    simple refine (Build_diagram _ _ _).
    - intro x; destruct x.
      exact (X * X). exact X.
    - intros i j g; destruct i, j, g. exact fst. exact snd.
  Defined.

  Definition T_diag_equiv `(e: X <~> Y) : (T_diag X) ≃ (T_diag Y).
    simple refine (Build_diagram_equiv (Build_diagram_map _ _) _).
    - intros i; destruct i; simpl. exact (functor_prod e e). exact e.
    - intros i j g; destruct i, j, g; reflexivity.
    - intros i; destruct i; simpl. apply isequiv_functor_prod. apply e.
  Defined.

  Definition T_cocone {X: Type} `(f: X -> Y) (Hf: forall x y, f x = f y)
  : cocone (T_diag X) Y.
    simple refine (Build_cocone _ _).
    - intros i x; destruct i; simpl in *. exact (f (fst x)). exact (f x).
    - intros i j g x; destruct i, j, g; simpl in *. reflexivity. apply Hf.
  Defined.

  Definition T_diag_KP_diag {X: Type} : T_diag X ≃ (KP_diag (λ _:X, tt)).
    simple refine (Build_diagram_equiv _ _).
    - simple refine (Build_diagram_map _ _).
      + intros i x; destruct i; simpl in *. exact (fst x; (snd x; 1)). exact x.
      + intros i j g x; destruct i, j, g; reflexivity.
    - intros i; destruct i; simpl.
      + simple refine (isequiv_adjointify (λ x, (x.1, x.2.1)) _ _); intro; simpl.
        2:reflexivity. simple refine (path_sigma' _ 1 (path_sigma' _ 1 _)).
        simpl. apply path_ishprop.
      + apply isequiv_idmap.
  Defined.

  Definition T (X: Type) := colimit (T_diag X).

  Definition T_colimit (X: Type) : is_colimit (T_diag X) (T X)
    := is_colimit_colimit _.

  Definition α {X: Type} : X -> T X :=
    @colim _ (T_diag X) false.

  Definition β {X: Type} : forall x y: X, α x = α y
      := λ x y, (@pp _ (T_diag X) true false true (x,y))
                  @ (@pp _ (T_diag X) true false false (x,y))^.

  Definition T_functor_equiv `(e: X <~> Y) : (T X) <~> (T Y)
    := functoriality_colimit_equiv (T_diag_equiv e) (T_colimit _) (T_colimit _).
End T.

Section KP_Sigma.
  Context {X Y: Type} (f: X -> Y).

  Definition diagram_map_fib_fib_diag : diagram_map (KP_diag f) (sigma_diag (λ y, T_diag (hfiber f y))).
    simple refine (Build_diagram_map _ _).
    - intros i x; destruct i; simpl in *.
      exists (f x.1). exact ((x.1; 1), (x.2.1; x.2.2^)).
      exact (f x; (x; 1)).
    - intros i j g x; destruct i, j, g; simpl in *. reflexivity.
      simple refine (path_sig_hfiber _ _ _). reflexivity.
  Defined.

  Definition diagram_equiv_fib_fib_diag :  diagram_equiv (KP_diag f) (sigma_diag (λ y, T_diag (hfiber f y))).
    simple refine (Build_diagram_equiv diagram_map_fib_fib_diag _).
    intros i; destruct i; simpl.
    - simple refine (isequiv_adjointify _ _ _).
      + intros w. exists (fst w.2).1. exists (snd w.2).1.
        exact ((fst w.2).2 @ (snd w.2).2^).
      + intros [y [[x e] [x' e']]]; simpl.
        destruct e. hott_simpl.
      + intros x; simpl. hott_simpl.
    - simple refine (isequiv_adjointify _ _ _).
      + intros w; exact w.2.1.
      + intros [y [x e]]; simpl. by destruct e.
      + intros x. reflexivity.
  Defined.

  Context `(HQ1: is_colimit (KP_diag f) Q1) {Q2: Y -> Type}
          (HQ2: forall y:Y, is_colimit (T_diag (hfiber f y)) (Q2 y)).

  Definition KP_slicing : Q1 <~> sig Q2.
    simple refine (functoriality_colimit_equiv diagram_equiv_fib_fib_diag HQ1 _).
    apply is_colimit_sigma. assumption.
  Defined.

  Definition KP_lift : Q1 -> Y.
    simple refine (postcompose_cocone_inv HQ1 _).
    simple refine (KP_cocone f (λ x y e, e)).
  Defined.

  Definition ok : KP_cocone f (λ x y e, e) = postcompose_cocone (precompose_cocone diagram_map_fib_fib_diag (sigma_cocone _ HQ2)) pr1.
    simple refine (path_cocone _ _).
    - intros i x; destruct i; reflexivity.
    - intros i j g x; destruct i, j, g; simpl in *; hott_simpl; unfold path_sigma'.
      + match goal with
          | |- ?ee = ap pr1 (path_sigma ?PP ?uu ?vv ?pp ?qq) =>
                       exact (@pr1_path_sigma _ PP uu vv pp qq)^
        end.
      + rewrite ap_pp.
        match goal with
          | |- ?ee = ?ee2 @ ap pr1 (path_sigma ?PP ?uu ?vv ?pp ?qq) =>
                       change (ee = ee2 @ (path_sigma PP uu vv pp qq)..1);
                       rewrite (@pr1_path_sigma _ PP uu vv pp qq)
        end.
        rewrite concat_p1.
        symmetry; etransitivity.
        exact (ap_compose _ _ _)^. simpl. unfold path_sig_hfiber.
        rewrite ap_V. unfold path_sigma'.
        match goal with
          | |- (ap _ (path_sigma ?PP ?uu ?vv ?pp ?qq))^ = ?ee =>
                       change (((path_sigma PP uu vv pp qq)..1)^ = ee);
                       rewrite (@pr1_path_sigma _ PP uu vv pp qq)
        end. hott_simpl.
  Defined.

  (* Definition KP_slicing_map : Q1 -> sig Q2. *)
  (*   simple refine (postcompose_cocone_inv HQ1 _). *)
  (*   simple refine (precompose_cocone diagram_map_fib_fib_diag _). *)
  (*   simple refine (sigma_cocone _ _). *)
  (*   intros y; apply HQ2. *)
  (* Defined. *)

  (* Definition KP_slicing_map_ok : KP_slicing_map = KP_slicing. *)
  (*   reflexivity. *)
  (* Defined. *)

  Definition KP_lift_slicing : KP_lift = pr1 o KP_slicing.
    simple refine (equiv_inj (postcompose_cocone HQ1) _). apply HQ1.
    unfold KP_lift, postcompose_cocone_inv. rewrite eisretr.
    rewrite ok. etransitivity. 2:simple refine (postcompose_cocone_comp _ _ _)^.
    apply ap10.
    (* Set Printing Implicit. *)
    simple refine (apD10 _ Y). apply ap.
    cbn. unfold functoriality_colimit. unfold postcompose_cocone_inv; rewrite eisretr.
    reflexivity.
  Defined.

  Definition KP_lift_hfiber (y: Y) : hfiber KP_lift y <~> Q2 y.
    etransitivity. simple refine (equiv_functor_sigma' KP_slicing _).
    exact (λ x, KP_lift (KP_slicing^-1 x) = y).
    intros a. simple refine (equiv_paths _). f_ap.
    exact (eissect KP_slicing a)^.
    etransitivity. simple refine (equiv_functor_sigma_id _).
    exact (λ x, x.1 = y).
    intros w. simple refine (equiv_paths _).
    etransitivity. exact (ap10 KP_lift_slicing _).
    apply ap. apply eisretr.
    { simple refine (equiv_adjointify _ _ _ _).
      - intros w. simple refine (w.2 # w.1.2).
      - intros w. simple refine (exist _ _ _). exists y. exact w. reflexivity.
      - intros w. reflexivity.
      - intros [w e]. destruct e. reflexivity. }
  Defined.
End KP_Sigma.

(*  *)


Require Import Coq.omega.Omega.
Require Import Platform.AutoSep.

Set Implicit Arguments.

Lemma wordToNat_positive : forall w : W,
  ($0 < w)%word
  -> wordToNat w = S (wordToNat (w ^- $1)).
  intros.
  replace (wordToNat w) with (wordToNat ($1 ^+ (w ^- $1))) by (f_equal; words).
  rewrite wordToNat_wplus; auto.
  assert ($1 <= w)%word.
  pre_nomega.
  change (wordToNat $0) with 0 in *.
  change (wordToNat $1) with 1.
  omega.
  rewrite wordToNat_wminus; auto.
  change (wordToNat $1) with 1.
  replace (1 + (wordToNat w - 1)) with (wordToNat w); auto.
  nomega.
Qed.


(* Discrete uniform distribution as an ival *)
From discprob.basic Require Import base sval order monad nify.
Require Import Reals Psatz Omega.

Require ClassicalEpsilon.
From discprob.prob Require Import double rearrange.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
Global Set Bullet Behavior "Strict Subproofs".
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype finset finfun bigop.

Local Open Scope R_scope.
From discprob.idxval Require Import ival ival_dist extrema markov.
From discprob.prob Require Import prob finite stochastic_order.
From discprob.prob Require Export countable.

Lemma iter_Rplus: ∀ m n p, iter n (Rplus m) p = (m * INR n + p).
Proof.
  intros m n. revert m. induction n => m p; first (rewrite //=; field).
  rewrite iterS IHn S_INR. field.
Qed.

Lemma is_seriesC_unif n:
  is_series (countable_sum (λ _ : [finType of 'I_n.+1], 1 / INR n.+1)) 1.
Proof.
  apply SeriesF_is_seriesC'. rewrite /val big_const iter_Rplus.
  rewrite card_ord. field; rewrite S_INR; specialize (pos_INR n); nra.
Qed.

Definition ival_unif (n: nat) : ivdist nat.
  unshelve (econstructor).
  - refine {| idx := [finType of ordinal (S n)]; ind := @nat_of_ord (S n);
              val := λ x, 1 / INR (S n)|}.
    abstract (intros; apply Rle_ge; left;
              rewrite S_INR; apply Rdiv_lt_0_compat; specialize (pos_INR n); nra).
  - apply is_seriesC_unif.
Defined.

Lemma Pr_eq_ival_unif (n: nat) k:
  (k <= n)%coq_nat →
  Pr (λ x, x = k) (ival_unif n) = 1 / INR (S n).
Proof.
  intros Hle. rewrite /Pr/Ex_ival.
  f_equal.
  apply is_series_unique.
  assert (k < S n)%nat as Hlt by (nify; omega).
  eapply is_seriesC_ext; last apply (is_seriesC_bump [finType of ordinal (S n)] (Ordinal Hlt)).
  intros [n' Hlt']. rewrite //=.
  destruct ClassicalEpsilon.excluded_middle_informative.
  * subst. rewrite //=.
    case: ifP; first (intros; ring).
    move /eqP => Hneq. exfalso. apply Hneq. apply ord_inj => //=.
  * subst. rewrite //=.
    case: ifP; last (intros; ring).
    move /eqP => Hneq. inversion Hneq; subst; eauto.
    contradiction.
Qed.

Lemma ival_unif_primitive (n: nat) : ival_primitive (ival_unif n).
Proof.
  intros [i1 ?] [i2 ?] => //= Heq.
  subst. apply ord_inj => //=.
Qed.


Require Export section_09_fundamental_theorem.

Definition is_prop (A : Type) : Type := forall x y : A, is_contr (Id x y).

Definition is_prop' (A : Type) : Type := forall x y : A, Id x y.

Definition is_prop_coh {A : Type} (H : is_prop' A) : is_prop' A.
Proof.
  intros x y.
  refine (concat _ _).
  exact (inv (H x x)).
  exact (H x y).
Defined.


Fixpoint fact n :=
  match n with
    | O    => 1
    | S n' => n * fact n'
  end.

(* 1.26 1.27 *)
Theorem fact5 : fact 5 = 120.
Proof.
  simpl.
  reflexivity.
Qed.