(*TODO : Import definitions*)
Require Import HoTT.

(*Stuff that probably should be removed:*)
(*
(*Alternative definition to Omega. Should be possible to show that these are equivalent.*)
Fixpoint Omega' (n:nat) (A:pType) : pType :=
	match n with
		|O => A
		|S n => Build_pType (point A = point A) idpath
	end.

Definition pSph0_to_Bool : pSphere 0 ->* pBool.
	refine (Build_pMap _ _ _ _).
			-exact Sph0_to_Bool.
			-reflexivity.
Defined.

Lemma isequiv_pSph0_to_Bool : IsEquiv pSph0_to_Bool.
	exact isequiv_Sph0_to_Bool.
Qed.

(* Definition sph0map_to_boolmap {A:pType} : (pBool -> A) -> (pSphere 0 -> A)
	 := functor_arrow pSph0_to_Bool idmap.

Lemma isEquiv_sph0mapToBoolmap `{Funext} {A:pType} : IsEquiv (@sph0map_to_boolmap A).
	apply isequiv_functor_arrow.
Qed. *)

Lemma equiv_sph0pMap_boolpMap `{Funext} {A:pType} : (pBool ->* A) <~> (pSphere 0 ->* A).
	refine (BuildEquiv _ _ _ _).
		*intro f.
		refine (Build_pMap _ _ _ _).
			-exact (sph0mapToBoolmap f).
			-(* cbn. *)
			unfold sph0mapToBoolmap.
			unfold functor_arrow.
			unfold functor_forall.
			rewrite (point_eq pSph0ToBool).
			exact (point_eq f).
		*refine (BuildIsEquiv _ _ _ _).

(* Lemma pIsEquiv_Sph0ToBool : IsEquiv pSph0ToBool.
	exact isequiv_Sph0_to_Bool.
Defined. *)

(*Construct map equivalence between omega and iterated loops (base case)*)

Definition f {A:pType} : Omega 0 A -> A.
	intro h.
	exact (h South).
Defined.

Definition g {A:pType} : A -> Omega 0 A.
	intro a.
	unfold Omega.
	refine (Build_pMap _ _ _ _).
		(*Construct map from S^0 to A. North is mapped to point A, South is mapped to a.*)
		*transparent assert (bin : (Bool -> A)).
			intro b.
			exact match b with
				|true => point A
				|false => a
			end.
		exact (bin o pSph0ToBool).
		*reflexivity.
Defined.

Lemma Omega0_Equiv_A {A:pType} : Omega 0 A <~> A.
	refine (BuildEquiv _ _ _ _).
		*exact f.
		*refine (BuildIsEquiv  _ _ _ _ _ _ _).
			-exact g.
			-unfold Sect. reflexivity. (*fg==id*)
			-unfold Sect. (*gf==id*)
			intro h.

			unfold Omega.
			intro h.
			unfold f.
			unfold g.
			intro x; elim x; intros h p; clear x.
			simpl.
			unfold g.
			unfold point at 1 in p. simpl in p.

Theorem omega_loops_equiv `{Funext} : forall n:nat, forall A:pType,
	Omega n A <~> iterated_loops n A.
	intros n A.
	induction n.
	(*Base case*)
		*refine (BuildEquiv _ _ _ _).
			(*Construct equivalence*)
			-simpl.
			intro f.
			exact (f South).
			(*Show that it is an equivalence*)
			-refine (BuildIsEquiv  _ _ _ _ _ _ _).
				(*Construct inverse*)
				+simpl.
				intro a.
				refine (Build_pMap _ _ _ _).
				transparent assert (g : (Susp Empty -> A)).
					intro x.
					exact (match x with
						|North => point A
						|South => a
					end ).

	Definition pBool_to_two_pts : pBool ->* two_pts.
		refine (Build_pMap _ _ _ _).
				(*Construct map*)
				-intro b.	exact (if b then (inr tt) else (inl tt)).
				(*Show it is pointed.*)
				-exact idpath.
	Defined.

	Definition two_pts_to_bool : add_pt Unit -> pBool.
		intro x; elim x.
					(*Left element (non-basepoint*)
					apply Unit_rec. exact false.
					(*Right element (basepoint)*)
					apply Unit_rec. exact true.
	Defined.

	Definition Sect_1 : Sect two_pts_to_bool pBool_to_two_pts.
		unfold Sect. induction x.
				+ induction a. exact idpath.
				+ induction b. exact idpath.
	Defined.

	Definition Sect_2 : Sect pBool_to_two_pts two_pts_to_bool.
			-unfold Sect. apply Bool_ind ; exact idpath.
	Defined.

	Lemma pequiv_bool_addpt1 : pBool <~>* add_pt Unit.
		Proof.
		refine (Build_pEquiv pBool (add_pt Unit) pBool_to_two_pts _).
		refine (BuildIsEquiv pBool (add_pt Unit) pBool_to_two_pts two_pts_to_bool Sect_1 Sect_2 _).
		apply Bool_ind ; reflexivity.
	Qed. *)


Require Import String.
Require Import Relations.

Require Export SystemFR.PrimitiveSize.
Require Export SystemFR.PrimitiveRecognizers.

Inductive cbv_value: tree -> Prop :=
| IVUnit: cbv_value uu
| IVZero: cbv_value zero
| IVSucc: forall v, cbv_value v -> cbv_value (succ v)
| IVFalse: cbv_value tfalse
| IVTrue: cbv_value ttrue
| IVPair: forall v1 v2, cbv_value v1 -> cbv_value v2 -> cbv_value (pp v1 v2)
| IVLambda: forall t, cbv_value (notype_lambda t)
| IVLeft: forall v, cbv_value v -> cbv_value (tleft v)
| IVRight: forall v, cbv_value v -> cbv_value (tright v)
.

#[export]
Hint Constructors cbv_value: values.

Inductive is_nat_value: tree -> Prop :=
| INVZero: is_nat_value zero
| INVSucc: forall v, is_nat_value v -> is_nat_value (succ v)
.

#[export]
Hint Constructors is_nat_value: is_nat_value.

Ltac cbv_value t :=
  match goal with
  | H: cbv_value t |- _ => idtac
  | H: is_nat_value t |- _ => idtac
  | _ => match t with
        | zero => idtac
        | uu => idtac
        | tfalse => idtac
        | ttrue => idtac
        | succ ?v => cbv_value v
        | pp ?v1 ?v2 => cbv_value v1; cbv_value v2
        | notype_lambda _ => idtac
        | tleft ?v => cbv_value v
        | tright ?v => cbv_value v
        | build_nat ?n => idtac
        end
  end.

Ltac not_cbv_value t := tryif cbv_value t then fail else idtac.

Ltac t_invert_nat_value :=
  match goal with
  | H: is_nat_value _ |- _ => inversion H
  end.

Lemma is_nat_value_buildable:
  forall v, is_nat_value v ->
    exists n, v = build_nat n.
Proof.
  induction 1; steps.
  - exists 0; steps.
  - exists (S n); steps.
Qed.

Ltac is_nat_value_buildable :=
  match goal with
  | H: is_nat_value ?v |- _ =>
    poseNew (Mark v "is_nat_value_buildable");
    pose proof (is_nat_value_buildable v H)
  end.

Lemma tree_size_build_nat:
  forall n, tree_size (build_nat n) = n.
Proof.
  induction n; steps.
Qed.

Lemma is_nat_value_build_nat:
  forall n, is_nat_value (build_nat n).
Proof.
  induction n; steps; eauto with is_nat_value.
Qed.

Lemma cbv_value_build_nat:
  forall n, cbv_value (build_nat n).
Proof.
  induction n; steps; eauto with values.
Qed.

Lemma cbv_value_is_pair:
  forall v, cbv_value (is_pair v).
Proof.
  destruct v; steps.
Qed.

Lemma cbv_value_is_succ:
  forall v, cbv_value (is_succ v).
Proof.
  destruct v; steps.
Qed.

Lemma cbv_value_is_lambda:
  forall v, cbv_value (is_lambda v).
Proof.
  destruct v; steps.
Qed.

#[export]
Hint Immediate is_nat_value_build_nat: values.
#[export]
Hint Immediate cbv_value_build_nat: values.
#[export]
Hint Immediate cbv_value_is_pair: values.
#[export]
Hint Immediate cbv_value_is_succ: values.
#[export]
Hint Immediate cbv_value_is_lambda: values.

Reserved Notation "t1 '~>' t2" (at level 20).

Inductive scbv_step: tree -> tree -> Prop :=
(* beta reduction *)
| SPBetaProj1: forall v1 v2,
    cbv_value v1 ->
    cbv_value v2 ->
    pi1 (pp v1 v2) ~> v1
| SPBetaProj2: forall v1 v2,
    cbv_value v1 ->
    cbv_value v2 ->
    pi2 (pp v1 v2) ~> v2

| SPBetaApp: forall t v,
    cbv_value v ->
    scbv_step
      (app (notype_lambda t) v)
      (open 0 t v)

| SPBetaIte1: forall t1 t2,
    ite ttrue t1 t2 ~> t1
| SPBetaIte2: forall t1 t2,
    ite tfalse t1 t2 ~> t2

(* `notype_tfix` has a dummy hole which is used for type annotation in the `tfix` tree.
   During evaluation, we fill it with a zero *)
| SPBetaFix: forall ts,
    notype_tfix ts ~> open 0 (open 1 ts zero) (notype_tfix ts)

| SPBetaMatch0: forall t0 ts,
    tmatch zero t0 ts ~> t0
| SPBetaMatchS: forall v t0 ts,
    cbv_value v ->
    tmatch (succ v) t0 ts ~> open 0 ts v

| SPBetaMatchLeft: forall v tl tr,
    cbv_value v ->
    sum_match (tleft v) tl tr ~> open 0 tl v
| SPBetaMatchRight: forall v tl tr,
    cbv_value v ->
    sum_match (tright v) tl tr ~> open 0 tr v

| SPBetaSize:
    forall v,
      cbv_value v ->
      tsize v ~> build_nat (tsize_semantics v)

| SPBetaIsPair:
    forall v,
      cbv_value v ->
      boolean_recognizer 0 v ~> is_pair v
| SPBetaIsSucc:
    forall v,
      cbv_value v ->
      boolean_recognizer 1 v ~> is_succ v
| SPBetaIsLambda:
    forall v,
      cbv_value v ->
      boolean_recognizer 2 v ~> is_lambda v

(* Primitive beta reduction *)
| SPBetaPlus: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    scbv_step (binary_primitive Plus v1 v2) (build_nat (n1 + n2))
| SPBetaMinus: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    n1 >= n2 ->
    scbv_step (binary_primitive Minus v1 v2) (build_nat (n1 - n2))
| SPBetaMul: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    scbv_step (binary_primitive Mul v1 v2) (build_nat (n1 * n2))
| SPBetaDiv: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    n2 > 0 ->
    scbv_step (binary_primitive Div v1 v2) (build_nat (PeanoNat.Nat.div n1 n2))
| SPBetaEq: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    scbv_step (binary_primitive Eq  v1 v2) (if PeanoNat.Nat.eqb n1 n2 then ttrue else tfalse)
| SPBetaNeq: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    scbv_step (binary_primitive Neq v1 v2) (if (PeanoNat.Nat.eq_dec n1 n2) then tfalse else ttrue)
| SPBetaLt: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    scbv_step (binary_primitive Lt  v1 v2) (if PeanoNat.Nat.ltb n1 n2 then ttrue else tfalse)
| SPBetaLeq: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    scbv_step (binary_primitive Leq v1 v2) (if PeanoNat.Nat.leb n1 n2 then ttrue else tfalse)
| SPBetaGt: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    scbv_step (binary_primitive Gt  v1 v2) (if PeanoNat.Nat.leb n1 n2 then tfalse else ttrue)
| SPBetaGeq: forall v1 v2 n1 n2,
    v1 = build_nat n1 ->
    v2 = build_nat n2 ->
    scbv_step (binary_primitive Geq v1 v2) (if PeanoNat.Nat.ltb n1 n2 then tfalse else ttrue)

| SPBetaNot1: scbv_step (unary_primitive Not ttrue) tfalse
| SPBetaNot2: scbv_step (unary_primitive Not tfalse) ttrue

| SPBetaAnd1: scbv_step (binary_primitive And ttrue ttrue) ttrue
| SPBetaAnd2: scbv_step (binary_primitive And ttrue tfalse) tfalse
| SPBetaAnd3: scbv_step (binary_primitive And tfalse ttrue) tfalse
| SPBetaAnd4: scbv_step (binary_primitive And tfalse tfalse) tfalse

| SPBetaOr1: scbv_step (binary_primitive Or tfalse tfalse) tfalse
| SPBetaOr2: scbv_step (binary_primitive Or tfalse ttrue) ttrue
| SPBetaOr3: scbv_step (binary_primitive Or ttrue tfalse) ttrue
| SPBetaOr4: scbv_step (binary_primitive Or ttrue ttrue) ttrue

(* reduction inside terms *)
| SPAppLeft: forall t1 t2 t,
    t1 ~> t2 ->
    app t1 t ~> app t2 t
| SPAppRight: forall t1 t2 v,
    cbv_value v ->
    t1 ~> t2 ->
    app v t1 ~> app v t2
| SPPairL: forall t1 t2 t,
    t1 ~> t2 ->
    pp t1 t ~> pp t2 t
| SPPairR: forall t1 t2 v,
    t1 ~> t2 ->
    cbv_value v ->
    pp v t1 ~> pp v t2
| SPProj1: forall t1 t2,
    t1 ~> t2 ->
    pi1 t1 ~> pi1 t2
| SPProj2: forall t1 t2,
    t1 ~> t2 ->
    pi2 t1 ~> pi2 t2

| SPSucc: forall t1 t2,
    t1 ~> t2 ->
    succ t1 ~> succ t2
| SPMatch: forall t1 t2 t0 ts,
    t1 ~> t2 ->
    tmatch t1 t0 ts ~> tmatch t2 t0 ts

| SPUnaryPrimitive: forall o t1 t2,
    scbv_step t1 t2 ->
    scbv_step (unary_primitive o t1) (unary_primitive o t2)
| SPBinaryPrimitive1: forall o t1 t2 t,
    scbv_step t1 t2 ->
    scbv_step (binary_primitive o t1 t) (binary_primitive o t2 t)
| SPBinaryPrimitive2: forall o v t1 t2,
    scbv_step t1 t2 ->
    cbv_value v ->
    scbv_step (binary_primitive o v t1) (binary_primitive o v t2)

| SPIte: forall t1 t1' t2 t3,
    t1 ~> t1' ->
    ite t1 t2 t3 ~> ite t1' t2 t3

| SPLeft: forall t1 t2,
    t1 ~> t2 ->
    tleft t1 ~> tleft t2
| SPRight: forall t1 t2,
    t1 ~> t2 ->
    tright t1 ~> tright t2
| SPSumMatch: forall t1 t2 tl tr,
    t1 ~> t2 ->
    sum_match t1 tl tr ~> sum_match t2 tl tr

| SPTSize: forall t1 t2,
    t1 ~> t2 ->
    tsize t1 ~> tsize t2

| SPRecognizer: forall r t1 t2,
    t1 ~> t2 ->
    boolean_recognizer r t1 ~> boolean_recognizer r t2
  where "t1 ~> t2" := (scbv_step t1 t2).

Notation "t1 ~>* t2" := (Relation_Operators.clos_refl_trans_1n _ scbv_step t1 t2) (at level 20).

#[export]
Hint Constructors scbv_step: smallstep.

Lemma scbv_step_same:
  forall t1 t2 t3,
    t1 ~> t2 ->
    t2 = t3 ->
    t1 ~> t3.
Proof.
  steps.
Qed.

Ltac t_invert_step :=
  match goal with
  | _ => step_inversion scbv_step
  | H: boolean_recognizer _ _ ~> _ |- _ => inversion H; clear H
  | H: app _ _ ~> _ |- _ => inversion H; clear H
  | H: tunfold _ ~> _ |- _ => inversion H; clear H
  | H: tunfold_in _ _ ~> _ |- _ => inversion H; clear H
  | H: ite _ _ _ ~> _ |- _ => inversion H; clear H
  | H: tmatch _ _ _ ~> _ |- _ => inversion H; clear H
  | H: pp _ _ ~> _ |- _ => inversion H; clear H
  | H: pi1 _ ~> _ |- _ => inversion H; clear H
  | H: pi2 _ ~> _ |- _ => inversion H; clear H
  | H: sum_match _ _ _ ~> _ |- _ => inversion H; clear H
  | H: tsize _ ~> _ |- _ => inversion H; clear H
  | H: unary_primitive _ _ ~> _ |- _ => inversion H; clear H
  | H: binary_primitive _ _ _ ~> _ |- _ => inversion H; clear H
  end.

Lemma evaluate_step:
  forall v,
    cbv_value v ->
    forall t,
      v ~> t ->
      False.
Proof.
  induction 1;
    repeat
      step || step_inversion cbv_value || t_invert_step;
    eauto.
Qed.

Lemma evaluate_step2:
  forall t v,
    v ~> t ->
    cbv_value v ->
    False.
Proof.
  intros; eapply evaluate_step; eauto.
Qed.

Lemma evaluate_step3:
  forall t t',
    t ~> t' ->
    forall e,
      t = notype_lambda e ->
      False.
Proof.
  steps; t_invert_step.
Qed.

Lemma evaluate_step4:
  forall t t',
    t ~> t' ->
    forall e,
      t = type_abs e ->
      False.
Proof.
  steps; t_invert_step.
Qed.

Lemma is_nat_value_value:
  forall v,
    is_nat_value v ->
    cbv_value v.
Proof.
  induction 1; steps; eauto with values.
Qed.

#[export]
Hint Immediate is_nat_value_value: values.

Lemma evaluate_step_build_nat:
  forall t n,
    scbv_step (build_nat n) t -> False.
Proof.
  eauto using evaluate_step2 with values.
Qed.
#[export]
Hint Immediate evaluate_step_build_nat: smallstep.

Lemma is_nat_value_erased:
  forall v,
    is_nat_value v ->
    is_erased_term v.
Proof.
  induction 1; steps.
Qed.

#[export]
Hint Immediate is_nat_value_erased: erased.

Ltac no_step :=
  match goal with
  | H: cbv_value err |- _ => inversion H
  | H: build_nat ?n ~> ?t |- _ => apply evaluate_step_build_nat in H; apply False_ind, H
  | H1: cbv_value ?v,
    H2: ?v ~> ?t |- _ =>
    apply False_ind; apply evaluate_step with v t; auto 2
  | H1: is_nat_value ?v,
    H2: ?v ~> ?t |- _ =>
    apply False_ind; apply evaluate_step with v t; eauto 2 with values
  | H1: cbv_value ?v1,
    H2: cbv_value ?v2,
    H3: pp ?v1 ?v2 ~> ?t |- _ =>
    apply False_ind; apply evaluate_step with (pp v1 v2) t; auto with values
  | H1: cbv_value ?v,
    H3: succ ?v ~> ?t |- _ =>
    apply False_ind; apply evaluate_step with (succ v) t; auto with values
  | _ => t_invert_step; fail
  end.

#[export]
Hint Immediate evaluate_step2: smallstep.
#[export]
Hint Immediate evaluate_step3: smallstep.

Lemma deterministic_step:
  forall t1 t2,
    t1 ~> t2 ->
    forall t3,
      t1 ~> t3 ->
      t2 = t3.
Proof.
  induction 1; repeat light || t_equality;
    try solve [ t_invert_step; repeat light || no_step || t_equality || build_nat_inj ];
    try solve [ t_invert_step; repeat light; try t_invert_step; repeat light || no_step || t_equality ].
Qed.

Ltac deterministic_step :=
  match goal with
  | H1: ?t1 ~> ?t2,
    H2: ?t1 ~> ?t3 |- _ =>
    pose proof (deterministic_step _ _ H1 _ H2); clear H2
  end.

#[export]
Hint Extern 1 => deterministic_step: smallstep.

Definition closed_term t :=
  pfv t term_var = nil /\
  wf t 0 /\
  is_erased_term t.

Definition closed_value v :=
  closed_term v /\
  cbv_value v.

Lemma cbv_value_open:
  forall v k rep,
    cbv_value v ->
    cbv_value (open k v rep).
Proof.
  induction 1;
    repeat step;
    eauto with values.
Qed.

Lemma cbv_value_subst:
  forall v l tag,
    cbv_value v ->
    cbv_value (psubstitute v l tag).
Proof.
  induction 1;
    repeat step;
    eauto with values.
Qed.


Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Lists.List.
Require Import Coq.Lists.SetoidList.
Require Import Coq.MSets.MSetPositive.
Require Import Coq.MSets.MSetFacts.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.ListUtil.SetoidList.
Require Import Crypto.Util.Logic.ExistsEqAnd.

Local Set Implicit Arguments.

Set Implicit Arguments.
Unset Strict Implicit.

Module PositiveSetFacts.
  Module F := Facts PositiveSet.
  Include F.
  Import PositiveSet.

  Global Instance elements_Proper_Equal
    : Proper (Equal ==> Logic.eq) elements | 10.
  Proof.
    intros p1 p2 Hp.
    apply eqlistA_eq_iff.
    eapply SortA_equivlistA_eqlistA; try apply elements_spec2; try exact _.
    cbv [equivlistA]; intro.
    rewrite !elements_spec1.
    apply Hp.
  Qed.

  Lemma In_elements_mem_iff {x p}
    : List.In x (elements p) <-> PositiveSet.mem x p = true.
  Proof using Type.
    rewrite elements_b, existsb_exists; cbv [eqb].
    repeat first [ apply conj
                 | progress intros
                 | progress destruct_head'_ex
                 | progress destruct_head'_and
                 | eexists
                 | eassumption
                 | break_innermost_match_step
                 | break_innermost_match_hyps_step
                 | congruence ].
  Qed.
End PositiveSetFacts.


Set Implicit Arguments.

Require Import Coq.Program.Equality.
Require Import TLC.LibLN.
Require Import Definitions Binding.

(** * Stack-Based Operational Semantics *)

Reserved Notation "t1 '|->' t2" (at level 40, t2 at level 39).

Inductive red : sta * trm -> sta * trm -> Prop :=
(** [s(x) = nu(T)...{a = t}...]  #
#
    [―――――――――――――――――――――――――]  #
#
    [(s, x.a) |-> (s, t)      ]  *)
| red_sel : forall x m s t T ds,
    binds x (val_new T ds) s ->
    defs_has (open_defs x ds) (def_trm m t) ->
    (s, trm_sel (avar_f x) m) |-> (s, t)

(** [s(x) = lambda(T)t]      #
#
    [―――――――――――――――――――――]  #
#
    [(s, x y) |-> (s, t^y)]  *)
| red_app : forall f a s T t,
    binds f (val_lambda T t) s ->
    (s, trm_app (avar_f f) (avar_f a)) |-> (s, open_trm a t)

(** [(s, let x = v in t) |-> ((s, x = v), t^x)] *)
| red_let_val : forall v t s x,
    x # s ->
    (s, trm_let (trm_val v) t) |-> (s & x ~ v, open_trm x t)

(** [(s, let y = x in t) |-> (s, t^x)] *)
| red_let_var : forall t s x,
    (s, trm_let (trm_var (avar_f x)) t) |-> (s, open_trm x t)

(** [(s, t0) |-> (s', t0')]                             #
#
    [―――――――――――――――――――――――――――――――――――――――――――――――]  #
#
    [(s, let x = t0 in t) |-> (s', let x = t0' in t)]  *)
| red_let_tgt : forall t0 t s t0' s',
    (s, t0) |-> (s', t0') ->
    (s, trm_let t0 t) |-> (s', trm_let t0' t)

where "t1 '|->' t2" := (red t1 t2).

(** ** Normal forms *)
(** Variables and values are considered to be in normal form. *)
Inductive norm_form: trm -> Prop :=
| nf_var: forall x, norm_form (trm_var x)
| nf_val: forall v, norm_form (trm_val v).

Hint Constructors red norm_form.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import Ascii String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Elab.Elab
  Theory.Renaming
  Tools.Matches Compilers.Parameterizer.
Import Core.Notations.

Require Coq.derive.Derive.

Definition cat_def : lang _ :=
  {[l
  [s|
      -----------------------------------------------
      #"obj" srt
  ];
  [s| "G" : #"obj", "G'" : #"obj"
      -----------------------------------------------
      #"arr" "G" "G'" srt
  ];
  [:| "G" : #"obj"
       -----------------------------------------------
       #"id" : #"arr" "G" "G"
  ];
  [:| "G1" : #"obj", "G2" : #"obj", "G3" : #"obj",
       "f" : #"arr" "G1" "G2",
       "g" : #"arr" "G2" "G3"
       -----------------------------------------------
       #"cmp" "f" "g" : #"arr" "G1" "G3"
  ];
  [:= "G" : #"obj", "G'" : #"obj", "f" : #"arr" "G" "G'"
      ----------------------------------------------- ("id_right")
      #"cmp" "f" #"id" = "f" : #"arr" "G" "G'"
  ];
  [:= "G" : #"obj", "G'" : #"obj", "f" : #"arr" "G" "G'"
       ----------------------------------------------- ("id_left")
       #"cmp" #"id" "f" = "f" : #"arr" "G" "G'"
  ];
   [:= "G1" : #"obj",
         "G2" : #"obj",
         "G3" : #"obj",
         "G4" : #"obj",
         "f" : #"arr" "G1" "G2",
         "g" : #"arr" "G2" "G3",
         "h" : #"arr" "G3" "G4"
         ----------------------------------------------- ("cmp_assoc")
         #"cmp" "f" (#"cmp" "g" "h") = #"cmp" (#"cmp" "f" "g") "h" : #"arr" "G1" "G4"
   ]
  ]}.

Require Import Coq.derive.Derive.

Derive cat
       SuchThat (elab_lang_ext [] cat_def cat)
       As cat_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve cat_wf : elab_pfs.

(* TODO: beyond this point there are some category-theoretic
   names that could be used but which I would get wrong in choosing.
 *)
Definition obj_consumer_def : lang _ :=
  {[l
  [s| "G" : #"obj"
      -----------------------------------------------
      #"unit" "G" srt
  ]
  ]}.

Derive obj_consumer
       SuchThat (elab_lang_ext cat obj_consumer_def obj_consumer)
       As obj_consumer_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve obj_consumer_wf : elab_pfs.

Definition unit_action_def : lang _ :=
  {[l
  [:| "G" : #"obj", "G'" : #"obj", "g" : #"arr" "G" "G'",
       "u" : #"unit" "G'"
       -----------------------------------------------
       #"act" "g" "u" : #"unit" "G"
  ];
  [:= "G" : #"obj", "u" : #"unit" "G"
       ----------------------------------------------- ("act_id")
       #"act" #"id" "u" = "u" : #"unit" "G"
  ];
  [:= "G1" : #"obj", "G2" : #"obj", "G3" : #"obj",
       "f" : #"arr" "G1" "G2", "g" : #"arr" "G2" "G3",
       "u" : #"unit" "G3"
       ----------------------------------------------- ("act_cmp")
       #"act" "f" (#"act" "g" "u")
       = #"act" (#"cmp" "f" "g") "u"
       : #"unit" "G1"
  ]
  ]}.

Derive unit_action
       SuchThat (elab_lang_ext (obj_consumer++cat) unit_action_def unit_action)
       As unit_action_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve unit_action_wf : elab_pfs.

Definition unit_cartesian_def : lang _ :=
{[l
  [:|
      -----------------------------------------------
      #"emp" : #"obj"
  ];
  [:| "G" : #"obj"
      -----------------------------------------------
      #"forget" : #"arr" "G" #"emp"
  ];
  [:= "G" : #"obj", "G'" : #"obj", "g" : #"arr" "G" "G'"
       ----------------------------------------------- ("cmp_forget")
       #"cmp" "g" #"forget" = #"forget" : #"arr" "G" #"emp"
  ];
  [:=
      ----------------------------------------------- ("id_emp_forget")
      #"id" = #"forget" : #"arr" #"emp" #"emp"
  ];
  [:| "G" : #"obj"
       -----------------------------------------------
       #"ext" "G" : #"obj"
  ];
  [:| "G" : #"obj", "G'" : #"obj",
      "g" : #"arr" "G" "G'",
      "u" : #"unit" "G"
       -----------------------------------------------
       #"snoc" "g" "u" : #"arr" "G" (#"ext" "G'")
  ];
  [:| "G" : #"obj"
       -----------------------------------------------
       #"wkn" : #"arr" (#"ext" "G") "G"
  ];
  [:| "G" : #"obj"
       -----------------------------------------------
       #"hd" : #"unit" (#"ext" "G")
  ];
   [:= "G" : #"obj", "G'" : #"obj",
      "g" : #"arr" "G" "G'",
      "u" : #"unit" "G"
      ----------------------------------------------- ("wkn_snoc")
      #"cmp" (#"snoc" "g" "u") #"wkn" = "g" : #"arr" "G" "G'"
  ];
   [:= "G" : #"obj", "G'" : #"obj",
       "g" : #"arr" "G" "G'",
       "u" : #"unit" "G"
       ----------------------------------------------- ("snoc_hd")
       #"act" (#"snoc" "g" "u") #"hd" = "u"
       : #"unit" "G"
  ];
   [:= "G1" : #"obj", "G2" : #"obj", "G3" : #"obj",
       "f" : #"arr" "G1" "G2",
       "g" : #"arr" "G2" "G3",
       "u" : #"unit" "G2"
       ----------------------------------------------- ("cmp_snoc")
       #"cmp" "f" (#"snoc" "g" "u")
       = #"snoc" (#"cmp" "f" "g") (#"act" "f" "u")
       : #"arr" "G1" (#"ext" "G3")
   ];
      [:= "G" : #"obj"
       ----------------------------------------------- ("snoc_wkn_hd")
        #"snoc" #"wkn" #"hd" = #"id" : #"arr" (#"ext" "G") (#"ext" "G")
   ]
]}.

Derive unit_cartesian
  SuchThat (elab_lang_ext (unit_action++obj_consumer++cat)
              unit_cartesian_def unit_cartesian)
       As unit_cartesian_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve unit_cartesian_wf : elab_pfs.

(*TODO: careful; parameterize doesn't check freshness*)
Definition elt_cartesian_rename (n : string) : string :=
  match n with
  | "unit" => "elt"
  | "u" => "v"
  | _ => n
  end.

#[local] Definition elt_cartesian_in := (rename_lang elt_cartesian_rename
            (unit_cartesian ++ unit_action ++ obj_consumer)).
#[local] Definition elt_cartesian_ps := (elab_param "A" elt_cartesian_in
                           [("ext", Some 0); ("elt",Some 0)]).

(* TODO: beyond this point there are some category-theoretic
   names that could be used but which I would get wrong in choosing.
 *)
Definition typed_consumer : lang _ :=
  Eval compute in
  (parameterize_lang "A" {{s #"ty"}}
     elt_cartesian_ps
     (rename_lang elt_cartesian_rename (obj_consumer))).

Definition elt_action :=
  Eval compute in
  (parameterize_lang "A" {{s #"ty"}}
     elt_cartesian_ps
     (rename_lang elt_cartesian_rename (unit_action))).

Definition elt_cartesian :=
  Eval compute in
  (parameterize_lang "A" {{s #"ty"}}
     elt_cartesian_ps
     (rename_lang elt_cartesian_rename unit_cartesian)).

Definition typed_consumer_def :=
  Eval compute in Rule.hide_lang_implicits
                    (typed_consumer
                       ++[("ty",sort_rule [] [])]++cat)
                    typed_consumer.

Definition elt_action_def :=
  Eval compute in Rule.hide_lang_implicits
                    (elt_action++typed_consumer
                       ++[("ty",sort_rule [] [])]++cat)
                    elt_action.

Definition elt_cartesian_def :=
  Eval compute in Rule.hide_lang_implicits
                    (elt_cartesian++elt_action++typed_consumer
                       ++[("ty",sort_rule [] [])]++cat)
                    elt_cartesian.

Lemma simple_sort_wf {V} `{Eqb V} (n : V)
  : wf_lang_ext [] [(n,sort_rule [] [])].
Proof.
  constructor;
    basic_core_crush.
Qed.
#[export] Hint Resolve simple_sort_wf : elab_pfs.

Lemma typed_consumer_wf
  : elab_lang_ext ([("ty",sort_rule [] [])]++cat)
      typed_consumer_def typed_consumer.
Proof. auto_elab. Qed.
#[export] Hint Resolve typed_consumer_wf : elab_pfs.

Lemma elt_action_wf
  : elab_lang_ext (typed_consumer++[("ty",sort_rule [] [])]++cat)
      elt_action_def elt_action.
Proof. auto_elab. Qed.
#[export] Hint Resolve elt_action_wf : elab_pfs.

Lemma elt_cartesian_wf
  : elab_lang_ext (elt_action++typed_consumer++[("ty",sort_rule [] [])]++cat)
      elt_cartesian_def elt_cartesian.
Proof. auto_elab. Qed.
#[export] Hint Resolve elt_cartesian_wf : elab_pfs.

Definition ty_subst_lang :=
  rename_lang
    (fun n =>
       match n with
       | "obj" => "ty_env"
       | "arr" => "ty_sub"
       | "act" => "ty_subst"
       | "unit" => "ty"
       | "u" => "A"
       | "g"
       | "f"
       | "h" => n
       | String "G"%char s => String "D" s
       (*needed for injectivity*)
       | "env" => "_env"
       | "subst" => "_subst"
       (**)
       | _ => ("ty_"++ n)%string
       end)
    (unit_cartesian ++ unit_action++obj_consumer++cat).

Definition ty_subst_def :=
  Eval compute in Rule.hide_lang_implicits
                    (ty_subst_lang)
                    ty_subst_lang.

Lemma ty_subst_wf
  : elab_lang_ext [] ty_subst_def ty_subst_lang.
Proof. auto_elab. Qed.
(*apply Renaming.rename_lang_mono.
2:now prove_from_known_elabs.
(*TODO: injectivity machinery*)
Admitted.*)
#[export] Hint Resolve ty_subst_wf : elab_pfs.

Definition val_subst :=
  rename_lang
    (fun n =>
       match n with
       | "obj" => "env"
       | "arr" => "sub"
       | "elt" => "val"
       | String "a" (String "c" (String "t" s)) => ("val_subst" ++ s)%string
       (*needed for injectivity; currently not sufficient, but not important*)
       | "env" => "_env"
       | "sub" => "_sub"
       | "val_subst" => "_val_subst"
       | String "_"%char _ => ("_"++n)%string
       (**)
       | _ => n
       end)
    (elt_cartesian++elt_action++typed_consumer++cat).

Definition val_subst_def :=
  Eval compute in Rule.hide_lang_implicits
                    (val_subst++[("ty",sort_rule [] [])])
                    val_subst.

Lemma val_subst_wf
  : elab_lang_ext [("ty",sort_rule [] [])] val_subst_def val_subst.
Proof. auto_elab. Qed.
#[export] Hint Resolve val_subst_wf : elab_pfs.

Definition exp_subst_base :=
  rename_lang
    (fun n =>
       match n with
       | "obj" => "env"
       | "arr" => "sub"
       | "elt" => "exp"
       | "v" => "e"
       | String "a" (String "c" (String "t" s)) => ("exp_subst" ++ s)%string
       (*needed for injectivity; currently not sufficient, but not important*)
       | "env" => "_env"
       | "sub" => "_sub"
       | "val_subst" => "_val_subst"
       | String "_"%char _ => ("_"++n)%string
       (**)
       | _ => n
       end)
    (elt_action++typed_consumer).

Definition exp_subst_base_def :=
  Eval compute in Rule.hide_lang_implicits
                    (exp_subst_base ++ val_subst++[("ty",sort_rule [] [])])
                    exp_subst_base.

Lemma exp_subst_base_wf
  : elab_lang_ext (val_subst++[("ty",sort_rule [] [])])
      exp_subst_base_def exp_subst_base.
Proof. auto_elab. Qed.
#[export] Hint Resolve exp_subst_base_wf : elab_pfs.

Definition definitely_fresh (s : string) (l : list string) :=
  let len := List.fold_left Nat.max (map String.length l) 0 in
  String.append s (string_of_list_ascii (repeat ("'"%char : ascii) len)).

Definition choose_fresh (s : string) (c:ctx string) :=
  if negb (inb s (map fst c)) then s else definitely_fresh s (map fst c).

(*TODO: duplicated*)
Definition under s :=
  {{e #"snoc" (#"cmp" #"wkn" {s}) #"hd"}}.

Definition get_subst_constr s :=
  match s with
  | "exp" => Some "exp_subst"
  | "val" => Some "val_subst"
  | "blk" => Some "blk_subst"
  | _ => None
  end.

Section GenRHSSubterms.
  Context (G : string)
          (g : string).

  (*TODO: careful! _ in patterns does bad things (treated as a var)
   document &/or fix *)
  Fixpoint gen_arg_subst s :=
    match s with
    | {{e#"emp"}} => {{e#"forget"}}
    | var G' => if G =? G' then var g else {{e#"ERR1"}}
    | {{e#"ext" {s'} {_} }} => under (gen_arg_subst s')
    | _ => {{e#"ERR2" {s} }}
    end.

  Fixpoint gen_rhs_subterms c args {struct c} :=
    match c, args with
    | (n1,t)::c', n2::args' =>
      if n1 =? n2
      then
        match t with
        | scon name [G']
        | scon name [_;G'] =>
          match get_subst_constr name with
          | Some subst_constr =>
            let s := gen_arg_subst G' in
            let e := {{e #subst_constr {s} n1 }} in
            e::(gen_rhs_subterms c' args')
          | _ => (var n1)::(gen_rhs_subterms c' args')
          end
        | _ => (var n1)::(gen_rhs_subterms c' args')
        end
      else gen_rhs_subterms c' args
    | _, _ => []
    end.
End GenRHSSubterms.

Definition substable_constr name c args t : option (lang _) :=
  match t with
  (*TODO: assumes arbitrary G below the line. Is that the behavior I want or can I generalize?*)
  | scon s [A; var G] =>
    match get_subst_constr s with
    | Some subst_constr =>
      let constr_rule := term_rule c args t in
      let G' := choose_fresh "G'" c in
      let g := choose_fresh "g" c in
      let c' := (g,{{s#"sub" G' G }})
                  ::(G', {{s#"env"}})
                  ::c in
      let blank_term := con name (map var args) in
      let lhs := {{e #subst_constr g {blank_term} }} in
      let rhs := con name (gen_rhs_subterms G g c args) in
      let t' := scon s [A; var G'] in
      let subst_rule :=
          term_eq_rule c' lhs rhs t' in
      Some [(append name "-subst",subst_rule);(name, constr_rule)]
    | None => None
    end
  (*TODO: duplicated work for blocks since there is no A*)
  | scon s [var G] =>
    match get_subst_constr s with
    | Some subst_constr =>
      let constr_rule := term_rule c args t in
      let G' := choose_fresh "G'" c in
      let g := choose_fresh "g" c in
      let c' := (g,{{s#"sub" G' G }})
                  ::(G', {{s#"env"}})
                  ::c in
      let blank_term := con name (map var args) in
      let lhs := {{e #subst_constr g {blank_term} }} in
      let rhs := con name (gen_rhs_subterms G g c args) in
      let t' := scon s [var G'] in
      let subst_rule :=
          term_eq_rule c' lhs rhs t' in
      Some [(append name "-subst",subst_rule);(name, constr_rule)]
    | None => None
    end
  | _ => None
  end.

Definition sc '(n,r) :=
  match r with
  |term_rule c args t =>
   match substable_constr n c args t with
   | Some l => l
   | None => [(n,r)]
   end
  | r => [(n,r)]
  end.

Notation "'{[l/subst' r1 ; .. ; r2 ]}" :=
  (List.flat_map sc (cons r2 .. (cons r1 nil) ..))%rule
  (format "'[' {[l/subst '[hv' r1 ; '/' .. ; '/' r2 ']' ]} ']'") : lang_scope.

Definition exp_ret_def : lang _ :=
  {[l/subst
  [:| "G" : #"env", "A" : #"ty", "v" : #"val" "G" "A"
       -----------------------------------------------
       #"ret" "v" : #"exp" "G" "A"
    ] ]}.

Derive exp_ret
  SuchThat (elab_lang_ext (exp_subst_base++val_subst++[("ty",sort_rule [] [])])
              exp_ret_def exp_ret)
       As exp_ret_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve exp_ret_wf : elab_pfs.

(* TODO: note about ordering: have to gen G subst coherence rules
   before parameterizing w/ D?
 *)
(*
issue: if  I parameterize elt_action as normal, what to do about G, A?
-both should be parameterized by D
-both should have substs applied to them by coherence rules

For now: writing one manually to see how it goes
*)

Definition exp_and_val_parameterized :=
  Eval compute in
    let ps := (elab_param "D" (exp_ret ++ exp_subst_base
                                 ++ val_subst++[("ty",sort_rule[][])])
               [("sub", Some 2);
                ("ty", Some 0);
                ("env", Some 0);
                ("val",Some 2);
                ("exp",Some 2)]) in
  parameterize_lang "D" {{s #"ty_env"}}
    ps (exp_ret ++ exp_subst_base ++ val_subst).

Definition exp_and_val_parameterized_def :=
  Eval compute in Rule.hide_lang_implicits
                    (exp_and_val_parameterized
                       ++ty_subst_lang)
                    exp_and_val_parameterized.

Lemma exp_and_val_parameterized_wf
  : elab_lang_ext ty_subst_lang
      exp_and_val_parameterized_def
      exp_and_val_parameterized.
Proof. auto_elab. Qed.
#[export] Hint Resolve exp_and_val_parameterized_wf : elab_pfs.

Definition env_ty_subst_rename :=
    (fun n =>
       match n with
       | "obj" => "ty_env"
       | "arr" => "ty_sub"
       | "act" => "env_ty_subst"
       | "unit" => "env"
       | "u" => "G"
       | "g"
       | "f"
       | "h" => n
       | String "G"%char s => String "D" s
       | "act_cmp" => "env_ty_act_cmp"
       | "act_id" => "env_ty_act_id"
       (*needed for injectivity*)
       | "env" => "_env"
       | "subst" => "_subst"
       (**)
       | _ => ("ty_"++ n)%string
       end).

(*TODO: autogenerate coherence rules*)
Definition env_ty_subst :=
  Eval compute in
    (rename_lang env_ty_subst_rename (unit_action)).

(*TODO: add & generate coherence rules*)
Definition exp_ty_subst_def : lang _ :=
  {[l
       [:| "D" : #"ty_env",
           "D'" : #"ty_env",
           "g" : #"ty_sub" "D" "D'",
           "G" : #"env" "D'",
           "A" : #"ty" "D'",
           "e" : #"exp" "D'" "G" "A"
           -----------------------------------------------
           #"exp_ty_subst" "g" "e"
           : #"exp" "D" (#"env_ty_subst" "g" "G") (#"ty_subst" "g" "A")
       ]
      ]}.

Definition env_ty_subst_def :=
  Eval compute in Rule.hide_lang_implicits
                    (env_ty_subst++
                       exp_and_val_parameterized
                       ++ty_subst_lang)
                    (env_ty_subst).

Lemma env_ty_subst_wf
  : elab_lang_ext (exp_and_val_parameterized++ty_subst_lang)
      env_ty_subst_def
      (env_ty_subst).
Proof. auto_elab. Qed.
#[export] Hint Resolve env_ty_subst_wf : elab_pfs.

Derive exp_ty_subst
  SuchThat (elab_lang_ext (env_ty_subst
                             ++exp_and_val_parameterized
                             ++ty_subst_lang)
      exp_ty_subst_def
      exp_ty_subst)
       As exp_ty_subst_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve exp_ty_subst_wf : elab_pfs.

Definition poly_def : lang _ :=
  {[l/subst
  [:| "D" : #"ty_env", "A" : #"ty" (#"ty_ext" "D")
      -----------------------------------------------
      #"All" "A" : #"ty" "D"
  ];
    [:| "D" : #"ty_env",
       "G" : #"env" "D",
       "A" :  #"ty" (#"ty_ext" "D"),
       "e" : #"exp" (#"ty_ext" "D") (#"env_ty_subst" #"ty_wkn" "G") "A"
       -----------------------------------------------
       #"Lam" "e" : #"val" "D" "G" (#"All" "A")
  ];
  [:| "D" : #"ty_env",
      "G" : #"env" "D",
        "A" : #"ty" (#"ty_ext" "D"),
       "e" : #"exp" "D" "G" (#"All" "A"),
       "B" : #"ty" "D"
       -----------------------------------------------
       #"@" "e" "B"
       : #"exp" "D" "G"
         (#"ty_subst" (#"ty_snoc" #"ty_id" "B") "A")
  ];
  [:=  "D" : #"ty_env",
      "G" : #"env" "D",
        "A" : #"ty" (#"ty_ext" "D"),
       "e" : #"exp" (#"ty_ext" "D") (#"env_ty_subst" #"ty_wkn" "G") "A",
       "B" : #"ty" "D"
      ----------------------------------------------- ("Lam-beta")
      #"@" (#"ret" (#"Lam" "e")) "B"
      = #"exp_ty_subst" (#"ty_snoc" #"ty_id" "B") "e"
      : #"exp" "D" "G" (#"ty_subst" (#"ty_snoc" #"ty_id" "B") "A")
  ]
    (*
  [:= "D" : #"ty_env",
      "G" : #"env" "D",
        "A" : #"ty" (#"ty_ext" "D"),
       "v" : #"val" "D" "G" (#"All" "A")
        ----------------------------------------------- ("Lam-eta")
      #"Lam" (#"@" (#"ret" "v") (#"ret" #"ty_hd"))
      = "v"
      : #"val" "D" "G" (#"All" "A")
  ] *)
  ]}.

Derive poly
  SuchThat (elab_lang_ext (exp_ty_subst
                             ++env_ty_subst
                             ++exp_and_val_parameterized
                             ++ty_subst_lang)
              poly_def poly)
       As poly_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve exp_ty_subst_wf : elab_pfs.

Definition block_subst : lang _ :=
  rename_lang
    (fun n =>
       match n with
       | "obj" => "env"
       | "arr" => "sub"
       | String "a" (String "c" (String "t" s)) => ("blk_subst" ++ s)%string
       | "unit" => "blk"
       | "id" => "id"
       | "cmp" => "cmp"
       | "u" => "e"
       | String "G"%char _
       | "g"
       | "f"
       | "h" => n
       (*needed for injectivity*)
       | "env" => "_env"
       | "subst" => "_subst"
       (**)
       | _ => ("blk_"++ n)%string
       end)
    ( unit_action++obj_consumer).

Definition block_subst_def :=
  Eval compute in Rule.hide_lang_implicits
                    (block_subst ++ val_subst ++[("ty",sort_rule [] [])])
                    block_subst.

Lemma block_subst_wf
  : elab_lang_ext (val_subst ++[("ty",sort_rule [] [])])
      block_subst_def block_subst.
Proof. auto_elab. Qed.
#[export] Hint Resolve block_subst_wf : elab_pfs.

Definition block_and_val_parameterized :=
  Eval compute in
    let ps := (elab_param "D" (block_subst
                                 ++ val_subst++[("ty",sort_rule[][])])
               [("sub", Some 2);
                ("ty", Some 0);
                ("env", Some 0);
                ("val",Some 2);
                ("blk",Some 1)]) in
  parameterize_lang "D" {{s #"ty_env"}}
    ps (block_subst ++ val_subst).

Definition block_and_val_parameterized_def :=
  Eval compute in Rule.hide_lang_implicits
                    (block_and_val_parameterized
                       ++ty_subst_lang)
                    block_and_val_parameterized.

Lemma block_and_val_parameterized_wf
  : elab_lang_ext ty_subst_lang
      block_and_val_parameterized_def
      block_and_val_parameterized.
Proof. auto_elab. Qed.
#[export] Hint Resolve block_and_val_parameterized_wf : elab_pfs.

(*
Fixpoint find_differing {X A} `{Eqb X} `{Eqb A} `{WithDefault A}
  (l1 l2 : @NamedList.named_list X A) :=
  match l1 with
  | [] => []
  | p::l1 =>
      (if inb p l2
       then []
       else [[snd p;named_list_lookup default l2 (fst p)]])
        ++find_differing l1 l2
  end.

Eval vm_compute in (find_differing (exp_subst_base ++
                    val_subst ++
                    [("ty",sort_rule [] [])])
         (SimpleVSubst.exp_subst ++ SimpleVSubst.value_subst)).
Eval vm_compute in (find_differing blk_subst SimpleVSubst.block_subst).
*)


From oadt.lang_oadt Require Import base syntax semantics typing.
Import syntax.notations typing.notations.

(** * Weakening lemmas  *)

Lemma pared_weakening Σ e e' :
  Σ ⊢ e ⇛ e' ->
  forall Σ', Σ ⊆ Σ' ->
        Σ' ⊢ e ⇛ e'.
Proof.
  induction 1; intros;
    econstructor; eauto; qauto use: lookup_weaken.
Qed.

Lemma pared_equiv_weakening Σ e e' :
  Σ ⊢ e ≡ e' ->
  forall Σ', Σ ⊆ Σ' ->
        Σ' ⊢ e ≡ e'.
Proof.
  induction 1; intros; qauto use: pared_equiv, pared_weakening.
Qed.

Lemma weakening_ Σ :
  (forall Γ e l τ,
    Σ; Γ ⊢ e :{l} τ ->
    forall Σ' Γ',
      Σ ⊆ Σ' ->
      Γ ⊆ Γ' ->
      Σ'; Γ' ⊢ e :{l} τ) /\
  (forall Γ τ κ,
    Σ; Γ ⊢ τ :: κ ->
    forall Σ' Γ',
      Σ ⊆ Σ' ->
      Γ ⊆ Γ' ->
      Σ'; Γ' ⊢ τ :: κ).
Proof.
  apply typing_kinding_mutind; intros; subst;
    try qauto l: on ctrs: typing, kinding;
    try qauto l: on use: lookup_weaken ctrs: typing, kinding;
    try qauto l: on use: insert_mono ctrs: typing, kinding;
    (* For the [case]/[~case] cases and the [TConv] case. *)
    econstructor; eauto using insert_mono; qauto use: pared_equiv_weakening.
Qed.

Lemma weakening Σ Γ Σ' Γ' e l τ :
  Σ; Γ ⊢ e :{l} τ ->
  Σ ⊆ Σ' ->
  Γ ⊆ Γ' ->
  Σ'; Γ' ⊢ e :{l} τ.
Proof.
  hauto use: weakening_.
Qed.

Lemma kinding_weakening Σ Γ Σ' Γ' τ κ :
  Σ; Γ ⊢ τ :: κ ->
  Σ ⊆ Σ' ->
  Γ ⊆ Γ' ->
  Σ'; Γ' ⊢ τ :: κ.
Proof.
  hauto use: weakening_.
Qed.

Lemma weakening_empty Σ Γ e l τ :
  Σ; ∅ ⊢ e :{l} τ ->
  Σ; Γ ⊢ e :{l} τ.
Proof.
  eauto using weakening, map_empty_subseteq.
Qed.

Lemma kinding_weakening_empty Σ Γ τ κ :
  Σ; ∅ ⊢ τ :: κ ->
  Σ; Γ ⊢ τ :: κ.
Proof.
  eauto using kinding_weakening, map_empty_subseteq.
Qed.

Lemma weakening_insert Σ Γ e l τ τ' x :
  Σ; Γ ⊢ e :{l} τ ->
  x ∉ dom Γ ->
  Σ; <[x:=τ']>Γ ⊢ e :{l} τ.
Proof.
  eauto using weakening, insert_fresh_subseteq.
Qed.

Lemma kinding_weakening_insert Σ Γ τ τ' κ x :
  Σ; Γ ⊢ τ :: κ ->
  x ∉ dom Γ ->
  Σ; <[x:=τ']>Γ ⊢ τ :: κ.
Proof.
  eauto using kinding_weakening, insert_fresh_subseteq.
Qed.


(** * Parallel: Working with Parallel composition *)

(*Require Export Induction.*)
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Omega.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.

(** Parallel Composition **)

(** Generalizing the definition of parllel composition, we can
    describe the type of parallel composition like this:
    "A parallel composition component
    is either the empty or else a composition of one or and more entity
    of type A" **)

Set Implicit Arguments.

Inductive comp (A : Type) : Type :=
 | empty_comp : comp A
 | par_comp : A -> comp A -> comp A.

(*Implicit Arguments empty_comp [A].*)

Infix "|:" := par_comp (at level 60, right associativity).

Theorem empty_cons : forall (A:Type)(x:A) (l:comp A),
  empty_comp A <> x |: l.
 intros.
 discriminate.
Qed.

Fixpoint app (A : Type)(l m:comp A) : comp A :=
  match l with
  | empty_comp _ => m
  | a |: l' => a |: (app l' m)
  end.

(* Structural Congruence *)
(* Two processes are structurally congruent, if they are identical up to structure. *)
Inductive congruence (A : Type) : comp A -> comp A -> Prop :=
| no_pro : forall P,
            congruence P (app P (empty_comp A))
| commutative : forall P Q,
                         congruence (app P Q) (app Q P)
| associative : forall P Q R,
                       congruence (app P (app Q R))
                      (app (app P Q) R)
| par_com : forall P Q P' Q',
                  congruence P P' ->
                  congruence Q Q' ->
                  congruence (app P Q) (app P' Q')
| same : forall P,
              congruence P P
| symmetric : forall P Q,
                     congruence P Q ->
                     congruence Q P
| transitive : forall P Q R,
                   congruence P Q ->
                   congruence Q R ->
                   congruence P R.

Check congruence.

Print congruence.

Inductive comp_operation (A : Type) : comp A -> comp A-> Prop :=
| par1 : comp_operation (empty_comp _) (empty_comp _)
| par2 : forall Q R Q',
            comp_operation Q Q' ->
            comp_operation (app Q R) (app Q' R)
| par3 : forall Q R R',
            comp_operation R R' ->
            comp_operation (app Q R) (app Q R').

Check comp_operation.

Print comp_operation.

(** P --> P' then there exists P'' such that P' == P'' /\ P --> P''. **)
Theorem x: forall (A : Type) (P P' : comp A),
comp_operation P P' ->
exists P'', congruence P' P'' /\
comp_operation P P''.
Proof.
 intros A P P' H.
 induction H.
 exists (empty_comp A).
 split.
 apply same.
 apply par1.
 exists (app Q' R).
 split.
 apply same.
 apply par2.
 assumption.
 exists (app Q R').
 split.
 apply same.
 apply par3.
 assumption.
Qed.

(** P --> Q there exists Q' such that P --> Q' then Q == Q'. *)
Theorem b : forall (A : Type) (P Q : comp A),
comp_operation P Q ->
exists Q', comp_operation P Q' ->
congruence Q Q'.
Proof.
 intros A P Q H.
 destruct H.
 exists (empty_comp A).
 intros.
 apply same.
 exists (app Q' R).
 intros.
 apply same.
 exists (app Q R').
 intros.
 apply same.
Qed.

(** P == P' /\ P' --> Q' /\ Q == Q'
then P --> Q. **)
Theorem z : forall (A : Type) (P Q P' Q' : comp A),
congruence P P' /\
comp_operation P' Q' /\ congruence Q Q' ->
exists (P : comp A) , exists (Q : comp A), comp_operation P Q.
Proof.
 intros A P Q P' Q' H.
 destruct H. destruct H0.
 exists P'. exists Q'.
 assumption.
Qed.

(** P --> Q then there exists P' : P == P' /\ P' --> Q. **)
Theorem y : forall (A : Type) (P Q : comp A),
comp_operation P Q ->
exists (P' : comp A), congruence P P' /\
comp_operation P' Q.
Proof.
 intros A P Q H.
 induction H.
 exists (empty_comp A).
 split.
 apply same.
 apply par1.
 exists (app Q R).
 split.
 apply same.
 apply par2.
 assumption.
 exists (app Q R).
 split.
 apply same.
 apply par3.
 assumption.
Qed.

(** P --> Q then
there exists P' Q' : P' --> Q' /\ Q == Q' /\ P == P'. **)
Theorem a : forall (A : Type) (P Q : comp A),
comp_operation P Q ->
exists (P' : comp A) , exists (Q' : comp A),
comp_operation P' Q' /\ congruence Q Q' /\
congruence P P'.
Proof.
 intros A P Q H.
 induction H.
 exists (empty_comp A).
 exists (empty_comp A).
 split.
 apply par1.
 split.
 apply same.
 apply same.
 destruct IHcomp_operation.
 exists (app Q R).
 exists (app Q' R).
 split.
 apply par2.
 assumption.
 split.
 apply same.
 apply same.
 exists (app Q R).
 exists (app Q R').
 split.
 apply par3.
 assumption.
 split.
 apply same.
 apply same.
Qed.

(** P |+| Q == Q |+| P. **)
Theorem congruence_commutative : forall (A : Type) (P Q : comp A),
congruence (app P Q) (app Q P).
Proof.
 intros A P Q.
 apply commutative.
Qed.

(** P |+| Q == Q |+| P. **)
Theorem congruence_associativity : forall (A : Type) (P Q R : comp A),
congruence (app P (app Q R))
                      (app (app P Q) R).
Proof.
 intros A P Q R.
 apply associative.
Qed.

(** P |+| no_process == P **)
Theorem congruence_no_process : forall (A : Type) (P : comp A),
congruence (app P (empty_comp _)) P.
Proof.
 intros A P.
 apply symmetric.
 apply no_pro.
Qed.

(** P == P |+| no_process **)
Theorem congruence_no_process' : forall (A : Type) (P : comp A),
congruence P (app P (empty_comp _)).
Proof.
 intros A P.
 apply symmetric.
 apply symmetric.
 apply no_pro.
Qed.

(** Two processes are said to bisimilar if they can mimic each other step by step **)
CoInductive bisimilar (A : Type) : comp A -> comp A -> Prop :=
bsm : forall P Q,
             (forall P',
            comp_operation P P' ->
            exists Q', comp_operation Q Q' /\
            bisimilar P' Q') /\
            (forall Q',
            comp_operation Q Q' ->
            exists P', comp_operation P P' /\
            bisimilar P' Q') ->
            bisimilar P Q.

Hypothesis eq_A : forall (A : Type) (x y : A), {x = y}+{x <> y}.

(* override updates a type p in the program P with p1. *)
Fixpoint override (A : Type ) (p : A) (P : comp A) (p1 : A) : comp A :=
match P with
| empty_comp _=> empty_comp _
| p' |: P' => match eq_A p p' with
               | left _ => p1 |: P'
               | right _ => p' |: override p P' p1
              end
end.

(* in_comp states that process P is present in composition. *)
Fixpoint  in_comp (A : Type) (Q : A) (P : comp A) : bool :=
match P with
| empty_comp _ => false
| P1 |: P1' => match eq_A Q P1 with
                     | left _ => true
                     | right _ => in_comp Q P1'
end
end.

(** Remove process from the parallel composition **)
 Fixpoint remove (A : Type) (x : A) (l : comp A) : comp A :=
    match l with
      | empty_comp _ => empty_comp _
      | y |: tl => if (eq_A x y) then remove x tl else y |: (remove x tl)
    end.

(* Subset *)
Fixpoint is_subset (A : Type) (P : comp A) (P' : comp A) : bool :=
match P with
| empty_comp _ => true
| P1 |: P1' => if (in_comp P1 P') then (is_subset P1' (remove P1 P1')) else false
end.

(* Number of entity in the parallel composition. *)
Fixpoint number (A : Type) (P : comp A) : nat :=
match P with
| empty_comp _=> 0
| P1 |: P1' => S (number P1')
end.

Variable P1 : Type.
Variable P2 : Type.
Variable P3 : Type.
Variable P4 : Type.
Variable P5 : Type.

Example test_number_parallel1:  number (P1 |: (P2 |: (P3 |: empty_comp _))) = 3.
Proof.
reflexivity.
Qed.

(** Addition **)
(** The [add_comp] a entity to the existing parallel composition .**)
Fixpoint add_comp (A : Type) (P : comp A) (P1 : A) : comp A :=
 match P with
  | empty_comp _ => P1 |: empty_comp _
  | Q |: P' => Q |: (add_comp P' P1)
 end.

Example test_add_comp1:  add_comp (P1 |: (P2 |: (P3 |: empty_comp _))) P4 =
(P1 |: (P2 |: (P3 |: (P4 |: empty_comp _)))).
Proof.
reflexivity.
Qed.

Example test_add_comp2:  add_comp (empty_comp _) P4 =
(P4 |: empty_comp _).
Proof.
reflexivity.
Qed.

(* Same parallel compositions *)
Definition same_comp (A : Type) (P: comp A) (Q: comp A) : Prop :=
is_subset P Q = true /\ is_subset Q P = true.

(* P = Q *)
Axiom equal_comp : forall (A : Type) (P Q : comp A),
same_comp P Q -> P = Q.

Example test_override_1 : forall (A : Type) (P1 P1' : comp A), override P1 (empty_comp _) P1' =
(empty_comp _).
Proof.
reflexivity.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(**** Tests of Field with real numbers ****)

Require Import Rbase LegacyRfield.

(* Example 1 *)
Goal
forall eps : R,
(eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)))%R = (eps * (1 / 2))%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 2 *)
Goal
forall (f g : R -> R) (x0 x1 : R),
((f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)))%R =
((f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)))%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 3 *)
Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 4 *)
Goal
forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 5 *)
Goal forall a : R, 1%R = (1 * (1 / a) * a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 6 *)
Goal forall a b : R, b = (b * / a * a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 7 *)
Goal forall a b : R, b = (b * (1 / a) * a)%R.
Proof.
  intros.
   legacy field.
Abort.

(* Example 8 *)
Goal
forall x y : R,
(x * (1 / x + x / (x + y)))%R =
(- (1 / y) * y * (- (x * (x / (x + y))) - 1))%R.
Proof.
  intros.
   legacy field.
Abort.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.

(*** Simplification *)
Theorem open_Sch_wrt_Ty_rec_mono : forall (n : nat) (ty1 ty2 : Ty),
    open_Sch_wrt_Ty_rec n ty2 (S_Mono ty1) = S_Mono (open_Ty_wrt_Ty_rec n ty2 ty1).
Proof. reflexivity. Qed.
#[export] Hint Rewrite open_Sch_wrt_Ty_rec_mono : core.

(*** openening lc terms *)
(* Lemma open_Ty_wrt_Ty_lc_Ty : forall Ty2 Ty1, lc_Ty Ty2 -> open_Ty_wrt_Ty Ty2 Ty1 = Ty2. *)
Theorem open_Ty_wrt_Ty_lc_Ty_rec : forall (n : nat) (ty1 ty2 : Ty),
    lc_Ty ty1
  -> open_Ty_wrt_Ty_rec n ty2 ty1 = ty1.
Proof. introv LC. induction LC; crush. Qed.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


From Undecidability.L.Computability Require Export Scott Acceptability.
Import Undecidability.L.Prelim.ARS.ARSNotations.
Import L_Notations.

(* * The self halting problem is not L-acceptable *)

Definition self_diverging (s : term) := ~ pi s s.

Definition self_diverging_comb := conj self_diverging proc.

Lemma self_div : ~ lacc self_diverging.
Proof.
  intros H.
  destruct H as [u [[cls_u lam_u] H]].
  unfold self_diverging in H. specialize (H u). intuition.
Qed.

Lemma self_div_comb : ~ lacc self_diverging_comb.
Proof.
  intros [u [[cls_u lam_u] H]].
  unfold self_diverging_comb in H. unfold conj in H.
  specialize (H u). unfold self_diverging in H.
  destruct H. unfold proc in *. tauto.
Qed.

(* * Rice's Theorem *)

Lemma Rice1 (M : term -> Prop) : (M <=1 proc) ->
                                 (forall (s t : term), proc t -> M s -> (forall u, pi s u <-> pi t u) -> M t) ->
                                 (exists p, proc p /\ ~ M p) -> (exists p, proc p /\ M p) ->
                                 M (lam Omega) -> ~ lacc M.
Proof with eauto; try now intuition.
  intros M_proc M_cl_equiv [t2 [cls_t2 nMt2]] [t1 [cls_t1 nMt1]] MLO [u [[cls_u lam_u] Hu]].

  eapply (self_div_comb).

  destruct (dec_lacc ldec_proc) as [c [[cls_c lam_c] Hc]].
  pose (v  := lam ( u ((ext lam) ((ext app) (enc (lam (t2 #1))) ((ext app) #0 ((ext (enc(X:= term))) #0)))))).
  pose (v' := acc_conj c v).
  assert (proc v). subst v;unfold acc_conj;Lproc.
  assert (proc v'). subst v';unfold acc_conj;Lproc.
  exists v'; split. Lproc.
  intros s.
  pose (vs := lam ((lam (t2 #1)) (s (enc s)))).

  symmetry.
  transitivity (pi v s /\ proc s).
  {
    unfold v'. rewrite acc_conj_correct;try Lproc. rewrite <- Hc. tauto.
  }

  unfold self_diverging_comb, conj.

  transitivity (pi u vs /\ proc s).
  {
    split; intros [R cls_s];(split;[|Lproc]).
    -revert R. eapply converges_proper. symmetry. subst v. now Lsimpl.
    -revert R. eapply converges_proper. subst v. now Lsimpl.
  }

  transitivity (M vs /\ proc s).
  split; intros [? ?]; intuition; try (now rewrite Hu).  (* apply Hu;tauto. *)

  {
    split.
    - intros [Mvs cls_s]; intuition.
      intros [w [Hw lw]].
      assert (forall t, pi vs t <-> pi t2 t). {
        intros t. eapply converges_proper.
        assert (closed w). eapply (equiv_lambda lw) in Hw. eapply closed_star. exact Hw. Lproc. subst vs. Lsimpl_old. rewrite Hw. now Lsimpl.
      }
      eapply nMt2. eapply M_cl_equiv; eassumption.
    - intros [npi_s_s cls_s]; intuition.
      assert (forall t, pi (lam Omega) t <-> pi vs t). {
        intros t; split; intros H'.
        - exfalso. destruct H' as [w [Hw lw]]. inv lw. eapply Omega_diverges. rewrite <- Hw. symmetry. clear Hw. now redStep.
        - exfalso. eapply npi_s_s.
          assert (A: converges (lam ( t2 (enc t)) (s (enc s)))). revert H'. eapply converges_proper. symmetry. unfold vs. now Lsimpl_old.
          eapply app_converges in A. firstorder.
      }
                                                       subst vs.
      eapply M_cl_equiv; try Lproc;try eassumption.
  }
Qed.

Lemma Rice2 (M : term -> Prop) : (M <=1 proc) ->
                                 (forall (s t : term), proc t -> M s -> (forall u, pi s u <-> pi t u) -> M t) ->
                                 (exists p, proc p /\ ~ M p) -> (exists p, proc p /\ M p) ->
                                 ~ M (lam Omega) -> ~ lacc (complement M).
Proof.
  intros M_cls M_cl_equiv [t2 [cls_t2 nMt2]] [t1 [cls_t1 nMt1]] nMLO decM.
  destruct decM as [u [[cls_u lam_u] Hu]]. unfold complement in Hu.

  eapply (self_div_comb).

  destruct (dec_lacc ldec_proc) as [c [[cls_c lam_c] Hc]].
  pose (v  := lam ( u ((ext lam) ((ext app) (enc (lam (t1 #1))) ((ext app) #0 ((ext (enc (X:=term))) #0)))))).
  pose (v' := acc_conj c v).
  exists v'; split. subst v' v. unfold acc_conj. Lproc.
  intros s.
  pose (vs := lam ((lam (t1 #1)) (s (enc s)))).
  assert (cv:closed v) by (subst v; Lproc).

  symmetry.
  transitivity (pi v s /\ proc s).
  {
    unfold v'. rewrite acc_conj_correct;try Lproc. intuition ; now apply Hc. }

  unfold self_diverging_comb, conj.

  transitivity (pi u vs /\ proc s).
  {
    split; intros [R cls_s];(split;[|Lproc]).
    -revert R. eapply converges_proper. symmetry. subst v. now Lsimpl.
    -revert R. eapply converges_proper. subst v. now Lsimpl.
  }

  transitivity (~ M vs /\ proc s).
  {
    split; intros [? ?]; try (rewrite Hu); intuition; firstorder.
  }

  {
    split.
    - intros [Mvs cls_s]; intuition.
      intros [w [Hw lw]].
      assert (forall t, pi t1 t <-> pi vs t). {
        intros t. symmetry. assert (closed w). eapply closed_star. eapply equiv_lambda;eauto. Lproc.  eapply converges_proper.
        transitivity (lam ( t1 (enc t)) (s (enc s))). unfold vs. now Lsimpl_old. rewrite Hw. now Lsimpl.
      }
      eapply Mvs. eapply M_cl_equiv;try subst vs; try Lproc; try eassumption.
    - intros [npi_s_s cls_s]; intuition.
      assert (forall t, pi (lam Omega) t <-> pi vs t). {
        intros t; split; intros A.
        - exfalso. destruct A as [w [Hw lw]]. inv lw. eapply Omega_diverges. rewrite <- Hw. symmetry. clear Hw. now LsimplRed.
        - exfalso. eapply npi_s_s.
          assert (B: converges (lam ( t1 (enc t)) (s (enc s)))). revert A. eapply converges_proper. symmetry. unfold vs. Lsimpl_old.
          eapply app_converges in B. firstorder.
      }
      eapply nMLO.
      eapply M_cl_equiv; try (symmetry); eauto. Lproc.
  }
Qed.

(* ** Rice's Theorem, classical *)

Theorem Rice (M : term -> Prop) : (M <=1 proc) ->
                                 (forall (s t : term), proc t -> M s -> (forall u, pi s u <-> pi t u) -> M t) ->
                                  (exists p, proc p /\ ~ M p) -> (exists p, proc p /\ M p) ->
                                  ~ ldec M.
Proof.
  intros. intros A. assert (B : ldec M) by eassumption. destruct A as [u [proc_u Hu]].
  destruct (Hu (lam Omega)) as [[] [eq m]].
  - eapply Rice1; try eassumption. apply dec_lacc. exists u; tauto.
  - eapply Rice2; try eassumption. apply dec_lacc. apply ldec_complement. exists u; tauto.
Qed.

Lemma lamOmega s : ~ pi (lam Omega) s.
Proof.
   intros A. destruct A as [? [H l]]. inv l. eapply Omega_diverges. rewrite <- H. clear H. symmetry. now redSteps.
Qed.

(* * Applications of Rice's Theorem *)

Goal ~ ldec (fun s => proc s /\ forall t, pi s t).
Proof.
  eapply Rice.
  - firstorder.
  - intuition;now apply H1.
  - exists (lam Omega). split. Lproc. intros [_ A]. eapply lamOmega; eauto.
  - exists (lam I). repeat split;try Lproc. intros t; eexists; split; [|eexists;reflexivity]. now Lsimpl.
Unshelve. repeat econstructor.
Qed.

Goal ~ lacc (fun s => proc s /\ exists t, ~ pi s t).
Proof.
  eapply Rice1.
  - firstorder.
  - intros s t cls_t [cls_s [t0 H]] He. split; eauto.
    exists t0. rewrite <- He. eassumption.
  - exists (lam I). split.  Lproc. intros [_ [? H]]. eapply H. eexists;split;[|eexists;reflexivity]. now Lsimpl.
  - exists (lam Omega). repeat split;try Lproc. exists I. eapply lamOmega.
  - split. Lproc. exists I. eapply lamOmega.
Qed.

(* * Rice's Theorem, classical, on combinators *)

Theorem Rice_classical (M : term -> Prop) : (M <=1 closed) ->
                                 (forall (s t : term), closed t -> M s -> (forall u, pi s u <-> pi t u) -> M t) ->
                                  (exists p, closed p /\ ~ M p) -> (exists p, closed p /\ M p) ->
                                  ~ ldec M.
Proof.
  intros. eapply Scott.
  - firstorder.
  - intros. eapply H0; try eassumption. intros. unfold pi. now rewrite H5.
  - destruct H2; eauto.
  - destruct H2; eauto.
Qed.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo117:
  prime  5665946868464462250896653->
  prime  125925669151623297995917822831.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      125925669151623297995917822831
      22225
      ((5665946868464462250896653,1)::nil)
      0
      61440
      16
      256)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Require Import String.
Require Import ZArith.
Require Import List.
Import BinIntDef.

Inductive mname := mod_name : string -> mname.
Inductive vname := var_name : string -> vname.
Inductive pname := fun_name : string -> pname.
Inductive tname := type_name : string -> tname.
Inductive cname := constr_name : string -> cname.
Inductive constr := constr_def : cname -> list tname -> constr.

(* 比較演算子がない *)
Inductive binop :=
| b_and
| b_or
| b_plus
| b_minus
| b_time
| b_div
| b_mod
| b_eq
| b_lt
| b_append.

(* あと整数とかboolとか *)
Inductive exp : Set :=
| var : vname -> exp
| con : cname -> exp
| boolean : bool -> exp
| num : Z -> exp
| str : string -> exp
| binary : binop -> exp -> exp -> exp
| application : exp -> exp -> exp.

Coercion num : Z >-> exp.
Coercion boolean : bool >-> exp.

Open Scope string.
Open Scope Z.

Notation "'V' @ x" := (var (var_name x)) (at level 10).
Notation "'C' @ x" := (con (constr_name x)) (at level 10).
Notation "x +' y" := (binary b_plus x y) (at level 15).
Notation "'S' @ x" := (str x) (at level 10).
Notation "x $ y" := (application x y) (at level 14, left associativity).

Inductive val : Set :=
| con_val : con_values -> val (* induction schemeが怪しいので注意 *)
| boolean_val : bool -> val
| num_val : Z -> val
| str_val : string -> val

with con_values : Set :=
| con_name : cname -> con_values
| con_args : con_values -> val -> con_values
.

Coercion num_val : Z >-> val.
Coercion boolean_val : bool >-> val.

Notation "'C' # s" := (con_name (constr_name s)) (at level 10).
Notation "'S' # x" := (str_val x) (at level 10).
Notation "x #$ y" := (con_args x y) (at level 14, left associativity).
Notation "[[ x ]]" := (con_val x) (at level 15).

Inductive proc : Set :=
| Pseq    : proc -> proc -> proc
| Pwhile  : exp -> proc -> proc
| Pmatch  : exp -> list proc -> proc
| Passign : vname -> exp -> proc
| Pcall   : pname -> proc
.

Notation "x :== y" := (Passign (var_name x) y) (at level 20).
Notation "P1 ;; P2" := (Pseq P1 P2) (at level 22).

Inductive declaration :=
| type_decl : tname -> list constr -> declaration
| proc_decl : pname -> proc -> declaration.

Record module := { Mname : mname; Mdecls : list declaration }.

Record program := { Pmods : list mname; Pdecls : list declaration; Pmain : proc }.

Record in_program := { Idecls : list declaration; current : proc }.

Axiom var_val : vname -> val -> Prop.
Axiom var_val_eq :forall v v1 v2, var_val v v1 -> var_val v v2 -> v1 = v2.
Definition var_val_neq : forall v v1 v2, ~ var_val v v1 -> var_val v v2 -> v1 <> v2.
intros.
intro.
apply H; rewrite H1; apply H0.
Qed.
(*
Inductive list_forall {A B : Type} (P : A -> B -> Prop) : list A -> list B -> Prop :=
| nil_forall : list_forall P nil nil
| cons_forall : forall a b la lb, P a b -> list_forall P la lb -> list_forall P (cons a la) (cons b lb).
*)

Definition Zlt_bool x y :=
match (x ?= y) with
| Lt => true
| _ => false
end.

(** semantics of exp **)
Inductive binop_apply : binop -> val -> val -> val -> Prop :=
| binop_and  : forall b1 b2, binop_apply b_and (boolean_val b1) (boolean_val b2) (boolean_val (andb b1 b2))
| binop_or   : forall b1 b2, binop_apply b_or  (boolean_val b1) (boolean_val b2) (boolean_val (orb  b1 b2))
| binop_plus  : forall z1 z2, binop_apply b_plus (num_val z1) (num_val z2) (num_val (z1 + z2))
| binop_minus : forall z1 z2, binop_apply b_minus (num_val z1) (num_val z2) (num_val (z1 - z2))
| binop_time  : forall z1 z2, binop_apply b_time (num_val z1) (num_val z2) (num_val (z1 * z2))
| binop_div   : forall z1 z2, binop_apply b_div (num_val z1) (num_val z2) (num_val (z1 / z2))
| binop_mod   : forall z1 z2, binop_apply b_mod (num_val z1) (num_val z2) (num_val (z1 mod z2))
| binop_eq   : forall z1 z2, binop_apply b_eq (num_val z1) (num_val z2) (boolean_val (Zeq_bool z1 z2))
| binop_lt   : forall z1 z2, binop_apply b_lt (num_val z1) (num_val z2) (boolean_val (Zlt_bool z1 z2))
| binop_append : forall s1 s2, binop_apply b_append (str_val s1) (str_val s2) (str_val (append s1 s2))
.

Inductive exp_val : exp -> val -> Prop :=
| val_var : forall v e, var_val v e -> exp_val (var v) e
| val_constructor : forall c v, exp_val_constructor c v -> exp_val c (con_val v)
| val_boolean : forall b, exp_val (boolean b) (boolean_val b)
| val_num : forall z, exp_val (num z) (num_val z)
| val_str : forall s, exp_val (str s) (str_val s)
| val_binop : forall op e1 e2 v1 v2 v, exp_val e1 v1 -> exp_val e2 v2 -> binop_apply op v1 v2 v -> exp_val (binary op e1 e2) v

with exp_val_constructor : exp -> con_values -> Prop :=
| val_con_name : forall c, exp_val_constructor (con c) (con_name c)
| val_con_args : forall c e cv v, exp_val_constructor c cv -> exp_val e v -> exp_val_constructor (application c e) (con_args cv v)
.

Notation "x #~> y" := (exp_val x y) (at level 25).

Axiom pname_decl : list declaration -> pname -> proc -> Prop.

(* no type checking. If a program is not well-typed, the semantics of it may not be defined. *)

Inductive verify (decls : list declaration) : proc -> Prop -> Prop -> Prop :=
| Vseq    : forall p1 p2 P1 P P2, verify decls p1 P1 P -> verify decls p2 P P2 -> verify decls (Pseq p1 p2) P1 P2
| Vwhile  : forall e p P, verify decls p (P /\ exp_val e (boolean_val true)) P -> verify decls (Pwhile e p) P (P /\ exp_val e (boolean_val false))
(* | Pmatch  : exp -> list proc -> proc *)
| Vassign : forall v e (P : exp -> Prop), verify decls (Passign v e) (P e) (P (var v))
| Vcall   : forall pn p P1 P2, pname_decl decls pn p -> verify decls p P1 P2 -> verify decls (Pcall pn) P1 P2
| Vweaken : forall p (P1 P2 P : Prop), verify decls p P P2 -> (P1 -> P) -> verify decls p P1 P2
.

Notation "D ||- {- P -} p {- Q -}" := (verify D p P Q) (at level 26).

Goal nil ||- {- V @ "b" #~> 0 -} "a":== V @ "b" +' 1 {- V @ "a" #~> 1 -}.
apply Vweaken with (P := V @ "b" +' 1 #~> 1).
apply Vassign with (P := fun v => v #~> 1).
intro.
inversion H; subst.
apply val_binop with 0 1.
 auto.
 constructor.
 constructor.
Qed.

(* lazy verification system (unsound if you do not care about assignment) *)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(************************************************************************)
(*                                                                      *)
(*                          Cong.v                                      *)
(*                                                                      *)
(*    Laurent.Thery @sophia.inria.fr        March 2002                  *)
(************************************************************************)
(** * Congruence *)
Require Export ZArith.
Require Import Zdivides.
Require Import sTactic.

(** Useful lemmae *)

Theorem Zabs_absolu : forall z : Z, Zabs z = Z_of_nat (Zabs_nat z).
intros z; case z; simpl in |- *; auto; intros p; apply POS_inject.
Qed.

Theorem Zlt_ZERO_minus : forall a b : Z, (a < b)%Z -> (0 < b - a)%Z.
intros; unfold Zminus in |- *; apply Zlt_left_lt; auto.
Qed.

Theorem lt_inj : forall a b : nat, (Z_of_nat a < Z_of_nat b)%Z -> a < b.
intros a b H; case (le_or_lt b a); auto; intros H0.
Contradict H; apply Zle_not_lt; apply Znat.inj_le; auto with zarith arith.
Qed.

(** Definition of the congruence *)
Definition congZ (i : nat) (a b : Z) :=
  exists c : Z, a = (b + c * Z_of_nat i)%Z.

(** Some basic properties of the congruence *)
Theorem congZ_id : forall (i : nat) (a : Z), congZ i a a.
intros i a; exists 0%Z; simpl in |- *; ring.
Qed.
Hint Resolve congZ_id.

Theorem congZ_sym : forall (a b : Z) (i : nat), congZ i a b -> congZ i b a.
intros a b i (x, H); exists (- x)%Z; rewrite H; ring.
Qed.

Theorem congZ_trans :
 forall (a b c : Z) (i : nat), congZ i a b -> congZ i b c -> congZ i a c.
intros a b c i (x, H) (y, H1); exists (x + y)%Z; rewrite H; rewrite H1; ring.
Qed.

Theorem congZ_plus :
 forall (a b c d : Z) (i : nat),
 congZ i a b -> congZ i c d -> congZ i (a + c) (b + d).
intros a b c d i (x, H) (y, H1); exists (x + y)%Z; rewrite H; rewrite H1;
 ring.
Qed.

Theorem congZ_minus :
 forall (a b c d : Z) (i : nat),
 congZ i a b -> congZ i c d -> congZ i (a - c) (b - d).
intros a b c d i (x, H) (y, H1); exists (x - y)%Z; rewrite H; rewrite H1;
 ring.
Qed.

Theorem congZ_mult :
 forall (a b : Z) (i j : nat),
 congZ i a b -> congZ (i * j) (a * Z_of_nat j) (b * Z_of_nat j).
intros a b i j (x, H); exists x; rewrite H; rewrite Znat.inj_mult; ring.
Qed.

Definition fcong (i : nat) (a b : Z) :=
  match i with
  | O => 0
  | S i1 =>
      let ab := (a - b)%Z in
      match (ab - Z_of_nat i * Zquotient ab (Z_of_nat i))%Z with
      | Zneg p1 => Zabs_nat (Z_of_nat i + Zneg p1)
      | p => Zabs_nat p
      end
  end.

Theorem fcong_correct :
 forall (i : nat) (a b : Z),
 i <> 0 -> congZ i a (b + Z_of_nat (fcong i a b)) /\ fcong i a b < i.
intros i a b; unfold fcong in |- *; case i; auto.
intros H; elim H; auto.
intros n H.
case (ZquotientProp (a - b) (Z_of_nat (S n))); auto with arith.
simpl in |- *; red in |- *; intros; discriminate.
intros x (H1, H2).
replace (a - b - Z_of_nat (S n) * Zquotient (a - b) (Z_of_nat (S n)))%Z with
 x; [ idtac | pattern (a - b)%Z at 1 in |- *; rewrite H1; ring ].
generalize H1 H2; case x; clear H1 H2 x.
intros H1 (H2, H3); split; simpl in |- *.
exists (Zquotient (a - b) (Z_of_nat (S n))).
apply trans_equal with (b + (a - b))%Z.
ring.
pattern (a - b)%Z at 1 in |- *; rewrite H1; ring; auto with arith.
auto with arith.
intros p H1 (H2, H3); split; auto.
exists (Zquotient (a - b) (Z_of_nat (S n))).
apply trans_equal with (b + (a - b))%Z.
ring.
pattern (a - b)%Z at 1 in |- *; rewrite H1; ring_simplify;
  eapply Zplus_eq_compat; [reflexivity | simpl; apply POS_inject].
case (le_or_lt (S n) (Zabs_nat (Zpos p))); intros H4; auto.
Contradict H3; simpl in |- *.
apply Zle_not_lt.
repeat rewrite POS_inject.
rewrite nat_of_P_o_P_of_succ_nat_eq_succ; apply Znat.inj_le;
 auto with zarith arith.
intros p H1 (H2, H3); split; auto.
exists (Zquotient (a - b) (Z_of_nat (S n)) - 1)%Z.
apply trans_equal with (b + (a - b))%Z.
ring.
replace (Z_of_nat (Zabs_nat (Z_of_nat (S n) + Zneg p))) with
 (Z_of_nat (S n) + Zneg p)%Z.
pattern (a - b)%Z at 1 in |- *; rewrite H1; ring.
rewrite <- Zabs_absolu; auto.
apply sym_equal; apply Zabs_eq.
change (0 <= Z_of_nat (S n) - Zpos p)%Z in |- *.
apply Zlt_le_weak; apply Zlt_ZERO_minus.
rewrite <- (Zabs_eq (Z_of_nat (S n))); auto with zarith arith.
apply lt_inj.
rewrite <- Zabs_absolu; auto.
rewrite Zabs_eq.
pattern (Z_of_nat (S n)) at 2 in |- *;
 replace (Z_of_nat (S n)) with (Z_of_nat (S n) + 0)%Z;
 auto with zarith.
change (0 <= Z_of_nat (S n) - Zpos p)%Z in |- *.
apply Zlt_le_weak; apply Zlt_ZERO_minus.
rewrite <- (Zabs_eq (Z_of_nat (S n))); auto with zarith arith.
Qed.

Theorem neg_cong :
 forall (i : nat) (a b : Z),
 i <> 0 ->
 ~ congZ i a b -> exists x : _, 0 < x /\ x < i /\ congZ i a (b + Z_of_nat x).
intros i a b H H0; exists (fcong i a b).
case (fcong_correct i a b); auto; intros H1 H2.
repeat split; auto.
generalize H1; case (fcong i a b); simpl in |- *; auto with arith.
replace (b + 0)%Z with b; auto with zarith.
intros H3; case H0; auto.
Qed.

(** Congruence is decidable *)
Definition congZ_dec :
  forall (i : nat) (a b : Z), {congZ i a b} + {~ congZ i a b}.
intros i a b; case i.
generalize (Z_eq_bool_correct a b); case (Z_eq_bool a b).
intros H; left; exists 0%Z; rewrite H; ring.
intros H; right; red in |- *; intros (x, H0); case H; rewrite H0; ring.
intros n; case (ZdividesP (a - b) (Z_of_nat (S n))).
intros H; left; case H; intros x H1.
exists x; replace a with (b + (a - b))%Z; [ rewrite H1 | idtac ]; ring.
intros H; right; red in |- *; intros (x, H0); case H.
exists x; rewrite H0; ring.
Defined.

Theorem congZ_O_Eq : forall a b, congZ 0 a b <-> a = b.
intros a b; split.
intros (m1, H1); rewrite H1; ring.
intros H1; rewrite H1; exists 0%Z; ring.
Qed.


(* Don't need any of these yet. *)

Lemma getU_nil_none:
  forall  (x : EVar) (p : P) (tau : Tau),
     ~(getU [] x p tau).
Proof.
  intros x p tau.
  compute.
  intros.
  inversion H.
Qed.

(* TODO jrw these properties don't hold on nil. *)
Lemma getU_weakening :
  forall (u : Upsilon) (x x': EVar) (p p': P) (tau tau': Tau),
    getU (u ++ [((x', p'),tau')]) x p tau ->
    x <> x' ->
    p <> p' ->
    getU u x p tau.
Proof.
  intros.
  induction u.
  Case "u = []".
   assert (A: ~ getU [] x p tau).
   apply getU_nil_none.
   compute in A.
   admit. (* How do I show this contradiction? *)
  Case "u = a :: u".
   destruct a.
   destruct p0.
   eapply getU_next.
Admitted.

Lemma getU_partial_function:
  forall (u : Upsilon) (x : EVar) (p : P) (tau : Tau),
    WFU u ->
    getU u x p tau ->
    forall (tau' : Tau),
      getU u x p tau' ->
      tau = tau'.
Proof.
  intros.
  induction u.
  Case "u = []".
   inversion H0.
  Case "a :: u".
   destruct a.
   destruct p0.
   inversion H.
   apply IHu in H7.
   assumption.
Admitted.

Lemma getU_function_inversion:
  forall (u : Upsilon),
    WFU u ->
    forall  (x : EVar) (p : P) (tau : Tau),
      getU u x p tau ->
      forall (tau' : Tau),
        (getU u x p tau' /\ tau = tau').
Proof.
  intros u WFUder.
  induction (rev u).
  intros.
  split.
  inversion H.
  inversion H.
  intros.
  inversion WFUder.
  crush.
Admitted.

(* TODO not strictly true as d is a list. *)
Lemma getD_weakening_some_left:
  forall (d : Delta) (alpha : TVar) (k : Kappa),
    WFD d ->
     getD d         alpha   = Some k ->
    forall (d' : Delta),
      WFD (d ++ d') ->
      getD (d ++ d') alpha   = Some k.
Proof.
Admitted.

Lemma getD_weakening_some_right:
  forall (d : Delta) (alpha : TVar) (k : Kappa),
    WFD d ->
    getD d         alpha   = None ->
    forall (d' : Delta),
      WFD (d ++ d') ->
      getD d'        alpha   = Some k ->
      getD (d ++ d') alpha   = Some k.
Proof.
Admitted.

(* TODO how to prove these? *)
Lemma getD_Some_None_Implies_Different_Variables:
  forall (d : Delta) (n : nat) (k : Kappa),
      getD d (tvar n ) = Some k ->
      forall (n' : nat),
        getD d (tvar n') = None ->
        beq_nat n' n = false.
Proof.
  intros d n k.
  induction d.
  Case "d = []".
   discriminate.
  Case "d = a :: d".
   intros getdadnsome n'.
   intros getdadn'none.
   unfold getD in getdadnsome.
   fold getD in getdadnsome.
Admitted.

Lemma getD_None_None_Implies_Different_Variables:
  forall (d : Delta) (n n' : nat) (k : Kappa),
    (* TODO d <> nil *)
    getD d (tvar n ) = None ->
    getD (d ++ [(tvar n, k)]) (tvar n') = None ->
    beq_nat n' n = false.
Proof.
Admitted.

Lemma add_alpha_to_Delta_get_beta_None_still_None :
  forall (d : Delta) (n n0 : nat) (k : Kappa),
    n <> n0 ->
    getD d (tvar n0) = None ->
    getD (d ++ [(tvar n, k)]) (tvar n0) = None.
Proof.
Admitted.

Lemma getD1:
 forall (alpha : TVar) (k : Kappa) (d : Delta),
  WFD ([(alpha, k)] ++ d) ->
  getD d alpha = None.
Proof.
Admitted.

Lemma getD2:
 forall (alpha : TVar) (d d' : Delta),
  getD d alpha = None ->
  getD d' alpha = None ->
  getD (d ++ d') alpha = None.
Proof.
Admitted.


From Hammer Require Import Hammer.

Require Import List.
Import ListNotations.

Inductive inductively_barred P : list bool -> Prop :=
| now l : P l -> inductively_barred P l
| propagate l :
inductively_barred P (true::l) ->
inductively_barred P (false::l) ->
inductively_barred P l.

Fixpoint approx X (l:list bool) :=
match l with
| [] => True
| b::l => approx X l /\ (if b then X (length l) else ~ X (length l))
end.

Definition barred P :=
forall (X:nat -> Prop), exists l, approx X l /\ P l.

Fixpoint Y P (l:list bool) :=
match l with
| [] => True
| b::l =>
Y P l /\
if b then inductively_barred P (false::l) else ~ inductively_barred P (false::l)
end.

Lemma Y_unique : forall P l1 l2, length l1 = length l2 -> Y P l1 -> Y P l2 -> l1 = l2.
Proof. hammer_hook "WeakFan" "WeakFan.Y_unique".
induction l1, l2.
- trivial.
- discriminate.
- discriminate.
- intros H (HY1,H1) (HY2,H2).
injection H as H.
pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1.
subst l1.
f_equal.
destruct a, b; firstorder.
Qed.

Definition X P n := exists l, length l = n /\ Y P (true::l).

Lemma Y_approx : forall P l, approx (X P) l -> Y P l.
Proof. hammer_hook "WeakFan" "WeakFan.Y_approx".
induction l.
- trivial.
- intros (H,Hb). split.
+ auto.
+ unfold X in Hb.
destruct a.
* destruct Hb as (l',(Hl',(HYl',HY))).
rewrite <- (Y_unique P l' l Hl'); auto.
* firstorder.
Qed.

Theorem WeakFanTheorem : forall P, barred P -> inductively_barred P [].
Proof. hammer_hook "WeakFan" "WeakFan.WeakFanTheorem".
intros P Hbar.
destruct Hbar with (X P) as (l,(Hd%Y_approx,HP)).
assert (inductively_barred P l) by (apply (now P l), HP).
clear Hbar HP.
induction l as [|a l].
- assumption.
- destruct Hd as (Hd,HX).
apply (IHl Hd). clear IHl.
destruct a; unfold X in HX; simpl in HX.
+ apply propagate; assumption.
+ exfalso; destruct (HX H).
Qed.


Require Import floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.verif_sha_update3.
Local Open Scope Z.
Local Open Scope logic.

Lemma Hblocks_lem:
 forall {blocks: list int} {frag: list Z} {data},
 intlist_to_Zlist blocks = frag ++ sublist 0 (Zlength blocks * 4 - Zlength frag) data ->
 Zlength frag <= Zlength blocks * 4.
Proof.
intros.
assert (Zlength (intlist_to_Zlist blocks) =
               Zlength ( frag ++
     sublist 0 (Zlength blocks * 4 - Zlength frag) data)) by congruence.
 autorewrite with sublist in H0.
 pose proof (Zlength_nonneg (sublist 0 (Zlength blocks * 4 - Zlength frag) data)).
 omega.
Qed.

Definition sha_update_loop_body :=
  (Ssequence
     (Scall None
        (Evar _sha256_block_data_order
           (Tfunction
              (Tcons (tptr t_struct_SHA256state_st) (Tcons (tptr tvoid) Tnil))
              tvoid cc_default))
        [Etempvar _c (tptr t_struct_SHA256state_st);
        Etempvar _data (tptr tuchar)])
     (Ssequence
        (Sset _data
           (Ebinop Oadd (Etempvar _data (tptr tuchar))
              (Ebinop Omul (Econst_int (Int.repr 16) tint)
                 (Econst_int (Int.repr 4) tint) tint) (tptr tuchar)))
        (Sset _len
           (Ebinop Osub (Etempvar _len tuint)
              (Ebinop Omul (Econst_int (Int.repr 16) tint)
                 (Econst_int (Int.repr 4) tint) tint) tuint)))).

Definition update_outer_if :=
     Sifthenelse
        (Ebinop Cop.One (Etempvar _n tuint) (Econst_int (Int.repr 0) tint) tint)
        (Ssequence
           (Sset _fragment
              (Ebinop Osub
                 (Ebinop Omul (Econst_int (Int.repr 16) tint)
                    (Econst_int (Int.repr 4) tint) tint) (Etempvar _n tuint)
                 tuint)) update_inner_if)
        Sskip.

Lemma update_outer_if_proof:
 forall  (Espec : OracleKind) (hashed : list int)
           (dd data : list Z) (c d : val) (sh : share) (len : Z) kv
   (H : 0 <= len <= Zlength data)
   (Hsh: readable_share sh)
   (HBOUND : bitlength hashed dd + len * 8 < two_p 64)
   (H3 : Zlength dd < CBLOCKz)
   (H3' : Forall isbyteZ dd)
   (H4 : (LBLOCKz | Zlength hashed))
   (Hlen : len <= Int.max_unsigned),
semax
  (initialized_list [_data; _p; _n]
     (func_tycontext f_SHA256_Update Vprog Gtot))
  (PROP  ()
   LOCAL
   (temp _p (field_address t_struct_SHA256state_st [StructField _data] c);
    temp _n (Vint (Int.repr (Zlength dd)));
    temp _data d; temp _c c;temp _data_ d;
    temp _len (Vint (Int.repr len));
    gvar _K256 kv)
   SEP  (data_at Tsh t_struct_SHA256state_st
                 (map Vint (hash_blocks init_registers hashed),
                  (Vint (lo_part (bitlength hashed dd + len*8)),
                   (Vint (hi_part (bitlength hashed dd + len*8)),
                    (map Vint (map Int.repr dd) ++ list_repeat (Z.to_nat (CBLOCKz-Zlength dd)) Vundef,
                     Vint (Int.repr (Zlength dd))))))
               c;
     K_vector kv;
     data_block sh data d))
  update_outer_if
  (overridePost (sha_update_inv sh hashed len c d dd data kv false)
     (function_body_ret_assert tvoid
        (EX  a' : s256abs,
         PROP  (update_abs (sublist 0 len data) (S256abs hashed dd) a')
         LOCAL ()
         SEP  (K_vector kv;
                 sha256state_ a' c; data_block sh data d)))).
Proof.
intros.
unfold update_outer_if.
forward_if (sha_update_inv sh hashed len c d dd data kv false).
* (* then clause *)

Time forward.  (* fragment = SHA_CBLOCK-n; *) (*2.2*)
drop_LOCAL 5%nat.
rewrite semax_seq_skip.
fold (inv_at_inner_if sh hashed len c d dd data kv).
apply semax_seq with (sha_update_inv sh hashed len c d dd data kv false).
change Delta with Delta_update_inner_if.
weak_normalize_postcondition.
normalize. change (16*4)%Z with 64.
simple apply (update_inner_if_proof Espec hashed dd data c d sh len kv);
  try assumption.
forward.
apply andp_left2; auto.
* (* else clause *)
forward.  (* skip; *)
Exists (@nil int). rewrite <- app_nil_end.
apply repr_inj_unsigned in H0; try Omega1. rename H0 into H1.
rewrite H1 in *.
rewrite Zlength_correct in H1;  destruct dd; inv H1.
autorewrite with sublist.
simpl intlist_to_Zlist.
Time entailer!.  (* 4.6; was: 139 sec -> 3.27 sec *)
split.
apply Z.divide_0_r.
rewrite field_address0_offset by auto with field_compatible.
simpl. normalize.

(* TODO:  see if a "stronger" proof system could work here
  rewrite data_at_field_at.
   apply field_at_stronger.
  ...
  with automatic cancel...
*)
 Time unfold_data_at 1%nat. (*0.7*)
 Time unfold_data_at 1%nat. (*0.8*)
 Time cancel. (*0.4*)
Time Qed. (*5.4*)

Lemma update_while_proof:
 forall (Espec : OracleKind) (hashed : list int) (dd data: list Z) kv
    (c d : val) (sh : share) (len : Z)
  (H : 0 <= len <= Zlength data)
   (Hsh: readable_share sh)
  (HBOUND : bitlength hashed dd + len * 8 < two_p 64)
  (H3 : Zlength dd < CBLOCKz)
  (H3' : Forall isbyteZ dd)
  (H4 : (LBLOCKz | Zlength hashed))
  (Hlen : len <= Int.max_unsigned),
 semax
     (initialized_list [_p; _n; _data]
       (func_tycontext f_SHA256_Update Vprog Gtot))
  (sha_update_inv sh hashed len c d dd data kv false)
  (Swhile
     (Ebinop Oge (Etempvar _len tuint)
        (Ebinop Omul (Econst_int (Int.repr 16) tint)
           (Econst_int (Int.repr 4) tint) tint) tint) sha_update_loop_body)
  (normal_ret_assert (sha_update_inv sh hashed len c d dd data kv true)).
Proof.
intros.
abbreviate_semax.
unfold sha_update_inv.
Intros blocks.
rewrite semax_seq_skip. (* should be part of forward_while *)
forward_while
    (sha_update_inv sh hashed len c d dd data kv false);
  try rename blocks0 into blocks'.
*
 Exists blocks. entailer!.
*
  entailer!.
*
 clear H8.
 normalize_postcondition.
 clear dependent blocks.
 rename blocks' into blocks.
 pose proof (Hblocks_lem H7).
 assert (H0': (Zlength dd <= Zlength blocks * 4)%Z) by Omega1.
 clear H0; rename H0' into H0.
 rewrite Int.unsigned_repr in HRE by omega.
 assert_PROP (Forall isbyteZ data) as BYTESdata
  by (rewrite (data_block_isbyteZ sh data d); entailer!).
 pose (bl := Zlist_to_intlist (sublist (Zlength blocks * 4 - Zlength dd)
                                                   (Zlength blocks * 4 - Zlength dd + CBLOCKz) data)).
assert (Zlength bl = LBLOCKz). {
 apply Zlength_Zlist_to_intlist.
 pose proof CBLOCKz_eq; pose proof LBLOCKz_eq;
  autorewrite with sublist. reflexivity.
}
 {
  rename H6 into Hdiv. rename H7 into Hblocks. rename H0 into H7.
  rename HRE into Hlen_ge.  clear H5.
  assert (H6: sublist (Zlength blocks * 4 - Zlength dd)
                    (Zlength blocks * 4 - Zlength dd + CBLOCKz) data =
        intlist_to_Zlist bl).
  unfold bl; rewrite Zlist_to_intlist_to_Zlist; auto.
  pose proof CBLOCKz_eq;  autorewrite with sublist.
  exists LBLOCKz; reflexivity.
  rename dd into frag.
  clear H7; rename H1 into H7.
  rename HBOUND into LEN64.
  clear - Hsh H Hdiv H4 Hblocks H3 Hlen Hlen_ge H6 H7 LEN64.
  unfold sha_update_loop_body.
  assert (Hblocks' := Hblocks_lem Hblocks).
  Time assert_PROP (field_compatible (tarray tuchar (Zlength data)) [] d) as FC by entailer!. (*1.8*)
  assert (DM: Zlength data < Int.modulus).
  { clear - FC. red in FC. simpl in FC. rewrite Z.max_r in FC. omega.
    specialize (Zlength_nonneg data); intros; omega. }
  set (lo := Zlength blocks * 4 - Zlength frag) in *.
  replace_SEP 2
    (data_block sh (sublist 0 lo data) d *
       data_block sh (sublist lo (lo+CBLOCKz) data)
         (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc lo] d) *
       data_block sh (sublist (lo+CBLOCKz) (Zlength data) data)
         (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc (lo+CBLOCKz)] d)).
  { Time entailer!. (*2.5*)
   rewrite (split3_data_block lo (lo+CBLOCKz) sh data); auto;
     subst lo; Omega1.
  }
 rewrite H6.
 Time forward_call (* sha256_block_data_order (c,data); *)
   (hashed++ blocks,  bl, c,
    field_address0 (tarray tuchar (Zlength data))  [ArraySubsc lo] d,
    sh, kv). (*3.8*)
  { Time unfold_data_at 1%nat. (*0.8*)
    Time cancel. (*2.5*)
  }
 split3; auto. apply divide_length_app; auto.
 Time forward. (* data += SHA_CBLOCK; *) (*5*)
 simpl (temp _data _).
 Time forward. (* len  -= SHA_CBLOCK; *) (*6*)
 Exists (blocks++ bl).
 Time entailer!. (*17.4 SLOW*)
 subst lo. autorewrite with sublist.
 rewrite Z.mul_add_distr_r.
 {repeat split; auto.
  + Omega1.
  + rewrite H7; apply Z.divide_add_r; auto. apply Z.divide_refl.
  + rewrite intlist_to_Zlist_app.
      rewrite Hblocks; rewrite <- H6.
      rewrite app_ass.
      f_equal.
      rewrite <- sublist_split; try Omega1.
      f_equal. Omega1.
  + assert (0 <= Zlength blocks * 4 + Zlength bl * 4 - Zlength frag <= Zlength data)
         by Omega1.
      rewrite !field_address0_offset by auto with field_compatible.
      rewrite offset_offset_val.
      simpl. f_equal. Omega1.
  + f_equal. f_equal. Omega1.
 }
 Time unfold_data_at 1%nat. (*0.8*)
 rewrite (split3_data_block lo (lo+CBLOCKz) sh data d)
    by (auto; subst lo; try Omega1).
 rewrite app_ass.
 rewrite H6.
 Time cancel. (*1.2*)
 }
*
 assert  (Zlength blocks' * 4 >= Zlength dd).
   rewrite <- (Zlength_intlist_to_Zlist blocks').
   rewrite H7. autorewrite with sublist. Omega1.
 normalize in HRE.
 unfold sha_update_inv.
 clear dependent blocks.
 forward.
 Exists blocks'.
 Time entailer!. (*2.9*)
Time Qed. (*31.3 *)


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
Require Import Functor.Functor_Extender.
Require Import NatTrans.Main.
Require Import Ext_Cons.Prod_Cat.Main.
Require Import Adjunction.Adjunction Adjunction.Duality Adjunction.Adj_Facts.
Require Import KanExt.Local KanExt.LocalFacts.Main.

Local Notation NID := NatTrans_id (only parsing).
Local Notation FCAT := Func_Cat (only parsing).

Local Open Scope functor_scope.

(** Local right kan extensions are preserved by right adjoints and local left
    kan extensions are preserved by left adjoints. *)
Section Right_Adjoint_Preserves_Hom_Local_Right_KanExt.
  Context
    {C C' : Category}
    (p : C –≻ C')
    {D : Category}
    (F : C –≻ D)
    (hlrke : Hom_Local_Right_KanExt p F)
    {E : Category}
    {L : E –≻ D}
    {R : D –≻ E}
    (adj : UCU_Adjunct L R)
  .

  (** Hom_Func_{Func_Cat C E}(- ∘ p, R ∘ F)
        ≃ Hom_Func_{Func_Cat C D}(L ∘ - ∘ p, F) *)
  Local Definition Ext_p_F_Hom_Adjunct_Lifted :=
    ((
        ((Fix_Bi_Func_2_NatIso (Hom_Adjunct_Lifted adj C) F)
           ∘ (Fix_Bi_Func_2_Functor_id_swap_NatIso _ _ F)⁻¹
        )
          ∘_h
          (NatTrans_id_Iso (Left_Functor_Extender p E)^op)
       )⁻¹
    )%isomorphism%natiso.

  Local Definition Conv_1 :=
    (
      NatIso_Functor_assoc
       ((Left_Functor_Extender p E)^op)
       ((Right_Functor_Extender L C)^op)
       (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ F (Hom_Func (Func_Cat C D)))
    ).

  Local Definition Conv_2 :=
    (
      (
        (NatTrans_id_Iso (@Fix_Bi_Func_2
                            _ (Func_Cat _ _) _ F (Hom_Func (Func_Cat C D))))
          ∘_h ((Right_Left_Functor_Extension_Iso p L)⁻¹)^op
      )⁻¹
    )%isomorphism%natiso.

  Local Definition Conv_3 :=
    (
      (
        NatIso_Functor_assoc
          ((Right_Functor_Extender L C')^op)
          ((Left_Functor_Extender p D)^op)
          (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ F (Hom_Func (Func_Cat C D)))
      )⁻¹
    )%isomorphism.

  Local Definition Conv := ((Conv_3 ∘ Conv_2) ∘ Conv_1)%isomorphism.

  Local Definition Ext_L_HLRKE_Iso :=
    (
      (HLRKE_Iso hlrke)
        ∘_h (NatTrans_id_Iso (Right_Functor_Extender L C')^op)
    )%natiso.

  Local Definition Fix2_hlrke_Hom_Adjunct_Lifted :=
    (
      (Fix_Bi_Func_2_NatIso (Hom_Adjunct_Lifted adj C') (hlrke))
        ∘ (Fix_Bi_Func_2_Functor_id_swap_NatIso _ _ (hlrke))⁻¹
    )%isomorphism.

  Local Definition Local_Preservation_Iso_underlying :=
    (
      (
        (Fix2_hlrke_Hom_Adjunct_Lifted ∘ Ext_L_HLRKE_Iso)
          ∘Conv
      )
        ∘ Ext_p_F_Hom_Adjunct_Lifted
    )%isomorphism
  .

  Local Definition Left_simplifier :=
    (
      (
        (
          (Fix_Bi_Func_2_NatIso
             (Func_Prod_of_ids_NatIso (Hom_Func (Func_Cat C E))) (R ∘ F))
            ∘ (Fix_Bi_2_Func_Prod_Func_NatIso
                 (Functor_id (Func_Cat C E) ^op)
                 (Right_Functor_Extender R C)
                 (Hom_Func (Func_Cat C E))
                 F
              )
        )⁻¹
      )
        ∘_h (NatTrans_id_Iso (Left_Functor_Extender p E)^op)
    )%isomorphism%natiso
  .

  Local Definition Right_simplifier :=
    (
      (
        Fix_Bi_Func_2_NatIso
          (Func_Prod_of_ids_NatIso (Hom_Func (Func_Cat C' E)))
          (R ∘ hlrke)
      )
        ∘
        (
          Fix_Bi_2_Func_Prod_Func_NatIso
            (Functor_id (Func_Cat C' E) ^op)
            (Right_Functor_Extender R C')
            (Hom_Func (Func_Cat C' E))
            (hlrke)
        )
      )%isomorphism
  .

  Definition Local_Preservation_Iso :=
    (Right_simplifier ∘ (Local_Preservation_Iso_underlying
                           ∘ Left_simplifier))%isomorphism
  .

  Definition Right_Adjoint_Preserves_Hom_Local_Right_KanExt :
    Hom_Local_Right_KanExt p (R ∘ F) :=
    {|
      HLRKE := (R ∘ (HLRKE hlrke));
      HLRKE_Iso := Local_Preservation_Iso
    |}.

End Right_Adjoint_Preserves_Hom_Local_Right_KanExt.

Section Right_Adjoint_Preserves_Local_Right_KanExt.
  Context {C C' : Category}
          (p : C –≻ C')
          {D : Category}
          (F : C –≻ D)
          (lrke : Local_Right_KanExt p F)
          {E : Category}
          {L : E –≻ D}
          {R : D –≻ E}
          (adj : UCU_Adjunct L R)
  .

  Definition Right_Adjoint_Preserves_Local_Right_KanExt :
    Local_Right_KanExt p (R ∘ F) :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt
      (
        Right_Adjoint_Preserves_Hom_Local_Right_KanExt
          _
          _
          (Local_Right_KanExt_to_Hom_Local_Right_KanExt lrke)
          adj
      )
  .

End Right_Adjoint_Preserves_Local_Right_KanExt.

Section Left_Adjoint_Preserves_Hom_Local_Left_KanExt.
  Context {C C' : Category}
          (p : C –≻ C')
          {D : Category}
          (F : C –≻ D)
          (hllke : Hom_Local_Left_KanExt p F)
          {E : Category}
          {L : D –≻ E}
          {R : E –≻ D}
          (adj : UCU_Adjunct L R)
  .

  Definition Left_Adjoint_Preserves_Hom_Local_Left_KanExt :
    Hom_Local_Left_KanExt p (L ∘ F) :=
    Right_Adjoint_Preserves_Hom_Local_Right_KanExt
      _
      _
      hllke
      (Adj_to_UCU_Adj _ _ (Adjunct_Duality (UCU_Adj_to_Adj _ _ adj)))
  .

End Left_Adjoint_Preserves_Hom_Local_Left_KanExt.

Section Left_Adjoint_Preserves_Local_Left_KanExt.
  Context {C C' : Category}
          (p : C –≻ C')
          {D : Category}
          (F : C –≻ D)
          (hllke : Local_Left_KanExt p F)
          {E : Category}
          {L : D –≻ E}
          {R : E –≻ D}
          (adj : UCU_Adjunct L R)
  .

  Definition Left_Adjoint_Preserves_Local_Left_KanExt :
    Local_Left_KanExt p (L ∘ F) :=
    Right_Adjoint_Preserves_Local_Right_KanExt
      _
      _
      hllke
      (Adj_to_UCU_Adj _ _ (Adjunct_Duality (UCU_Adj_to_Adj _ _ adj)))
  .

End Left_Adjoint_Preserves_Local_Left_KanExt.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.