(* Copyright (c) 2014, Robert Dockins *)

Require Import String.
Require Import List.
Require Import Arith.
Require Import Lia.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import directed.
Require Import plotkin.
Require Import joinable.
Require Import approx_rels.
Require Import cpo.
Require Import profinite.
Require Import profinite_adj.
Require Import strict_utils.
Require Import fixes.
Require Import flat.

(** * Soundness and adequacy simply-typed SKI with booleans and fixpoints.

    The adequacy proof goes via a standard logical-relations argument.
    As a corollary of the main logical-relations lemma, we show that
    nonvalues are denoted by ⊥.
  *)

(**  We have arrow types and a single base type of booleans. *)
Inductive ty :=
  | ty_bool
  | ty_arrow : ty -> ty -> ty.

Delimit Scope ty_scope with ty.
Notation "2" := ty_bool : ty_scope.
Notation "x ⇒ y" := (ty_arrow (x)%ty (y)%ty) : ty_scope.
Bind Scope ty_scope with ty.

Delimit Scope ski_scope with ski.
Open Scope ski_scope.

(**  Terms are boolean constants, the standard combinators S, K and I,
     and an IF/THEN/ELSE combinator; and applications.  We also have
     the call-by-value fixpoint combinator Y.  As usual for the CBV
     fixpoint operator, it only calculates fixpoints at function types.
  *)
Inductive term : ty -> Type :=
  | tbool : forall b:bool,
                term 2

  | tapp : forall σ₁ σ₂,
                term (σ₁ ⇒ σ₂) ->
                term σ₁ ->
                term σ₂

  | tI : forall σ,
                term (σ ⇒ σ)

  | tK : forall σ₁ σ₂,
                term (σ₁ ⇒ σ₂ ⇒ σ₁)

  | tS : forall σ₁ σ₂ σ₃,
                term ((σ₁ ⇒ σ₂ ⇒ σ₃) ⇒ (σ₁ ⇒ σ₂) ⇒ σ₁ ⇒ σ₃)

  | tIF : forall σ,
                term (2 ⇒ σ ⇒ σ ⇒ σ)

  | tY : forall σ₁ σ₂,
                term ( ((σ₁ ⇒ σ₂) ⇒ (σ₁ ⇒ σ₂)) ⇒ (σ₁ ⇒ σ₂) ).

Arguments tapp [_ _] _ _.
Notation "x • y" := (tapp x y)
  (at level 52, left associativity, format "x • y") : ski_scope.

(**  The operational semantics is given in a big-step style, with the specification
     of redexes split out into a separate relation.
  *)
Inductive redex : forall σ₁ σ₂, term (σ₁ ⇒ σ₂) -> term σ₁ -> term σ₂ -> Prop :=
  | redex_I : forall σ x,
                  redex _ _ (tI σ) x x
  | redex_K : forall σ₁ σ₂ x y,
                  redex σ₂ σ₁ (tK σ₁ σ₂ • y) x y
  | redex_S : forall σ₁ σ₂ σ₃ f g x,
                  redex _ _ (tS σ₁ σ₂ σ₃ • f • g)
                            x
                            ((f•x)•(g•x))
  | redex_IFtrue : forall σ th el,
                  redex _ _ (tIF σ • tbool true • th) el th
  | redex_IFfalse : forall σ th el,
                  redex _ _ (tIF σ • tbool false • th) el el

  | redex_Y : forall σ₁ σ₂ (f:term ((σ₁ ⇒ σ₂) ⇒ (σ₁ ⇒ σ₂))) x,
                  redex _ _ (tY σ₁ σ₂ • f) x
                            (f•(tY σ₁ σ₂ • f)•x).

Inductive eval : forall τ, term τ -> term τ -> Prop :=
  | ebool : forall b, eval 2 (tbool b) (tbool b)
  | eI   : forall σ, eval _ (tI σ) (tI _)
  | eK   : forall σ₁ σ₂, eval _ (tK σ₁ σ₂) (tK _ _)
  | eS   : forall σ₁ σ₂ σ₃, eval _ (tS σ₁ σ₂ σ₃) (tS _ _ _)
  | eIF  : forall σ, eval _ (tIF σ) (tIF σ)
  | eY   : forall σ₁ σ₂, eval _ (tY σ₁ σ₂) (tY _ _)
  | eapp1 : forall σ₁ σ₂ m₁ m₂ n₁ n₂ r z,
             eval (σ₁ ⇒ σ₂) m₁ n₁ ->
             eval σ₁ m₂ n₂ ->
             redex σ₁ σ₂ n₁ n₂ r ->
             eval σ₂ r z ->
             eval σ₂ (m₁ • m₂) z
  | eapp2 : forall σ₁ σ₂ m₁ m₂ n₁ n₂,
             eval (σ₁ ⇒ σ₂) m₁ n₁ ->
             eval σ₁ m₂ n₂ ->
             ~(exists r, redex σ₁ σ₂ n₁ n₂ r) ->
             eval σ₂ (m₁ • m₂) (n₁ • n₂).

(**  Syntactic types have decicable equality, which
     implies injectivity for dependent pairs with
     (syntactic) types as the type being depended upon.
  *)
Lemma inj_pair2_ty : forall (F:ty -> Type) τ x y,
  existT F τ x = existT F τ y -> x = y.
Proof.
  intros.
  apply Eqdep_dec.inj_pair2_eq_dec in H. auto.
  decide equality.
Qed.

Ltac inj_ty :=
  repeat match goal with
           [ H : existT _ _ ?x = existT _ _ ?y |- _ ] =>
             apply inj_pair2_ty in H; subst
           end.

Ltac inv H :=
  inversion H; subst; inj_ty; subst.

(** Values are terms that evaluate to themselves.
  *)
Definition value σ (t:term σ) := eval _ t t.
Arguments value [σ] t.

(**  Here are some basic techincal results
     about the operational semantics.
  *)
Lemma eval_value τ x y :
  eval τ x y -> value y.
Proof.
  intro H. induction H.
  apply ebool.
  apply eI.
  apply eK.
  apply eS.
  apply eIF.
  apply eY.
  auto.
  apply eapp2; auto.
Qed.

Lemma redex_eq τ₁ τ₂ x y z1 z2 :
  redex τ₁ τ₂ x y z1 ->
  redex τ₁ τ₂ x y z2 ->
  z1 = z2.
Proof.
  intros; inv H; inv H; inv H0; auto.
Qed.

Lemma eval_eq τ x y1 y2 :
  eval τ x y1 -> eval τ x y2 -> y1 = y2.
Proof.
  intro H. revert y2.
  induction H.

  intros. inv H. auto.
  intros. inv H. auto.
  intros. inv H. auto.
  intros. inv H. auto.
  intros. inv H. auto.
  intros. inv H. auto.

  intros. inv H3.
  apply IHeval1 in H9.
  apply IHeval2 in H10.
  subst n₁0 n₂0.
  assert (r = r0).
  eapply redex_eq; eauto.
  subst r0.
  apply IHeval3; auto.
  apply IHeval1 in H9.
  apply IHeval2 in H10.
  subst n₁0 n₂0.
  elim H11; eauto.

  intros. inv H2.
  apply IHeval1 in H8.
  apply IHeval2 in H9.
  subst n₁0 n₂0.
  elim H1. eauto.
  f_equal; auto.
Qed.

Lemma eval_trans τ x y z :
  eval τ x y -> eval τ y z -> eval τ x z.
Proof.
  intros.
  replace z with y; auto.
  eapply eval_eq with y; auto.
  eapply eval_value; eauto.
Qed.

Lemma eval_app_congruence σ₁ σ₂ : forall x x' y y' z,
  (forall q, eval _ x q -> eval _ x' q) ->
  (forall q, eval _ y q -> eval _ y' q) ->
  eval _ (@tapp σ₁ σ₂ x y) z ->
  eval _ (@tapp σ₁ σ₂ x' y') z.
Proof.
  intros.
  inv H1.
  apply H in H7.
  apply H0 in H8.
  eapply eapp1; eauto.
  apply eapp2; auto.
Qed.

Lemma eval_no_redex : forall σ₁ σ₂ x x',
  eval σ₂ x x' ->
  forall m₁ m₂ n₁ n₂ r,
    x' = @tapp σ₁ σ₂ m₁ m₂ ->
    eval _ m₁ n₁ -> eval _ m₂ n₂ -> redex _ _ n₁ n₂ r -> False.
Proof.
  do 5 intro. induction H; intros; try discriminate; subst.
  eapply IHeval3; eauto.
  inv H2.
  assert (m₂0 = n₂0).
  eapply eval_eq; eauto.
  apply eval_trans with m₂0; auto.
  assert (m₁0 = n₁0).
  eapply eval_eq; eauto.
  apply eval_trans with m₁0; auto.
  subst.
  apply H1. eauto.
Qed.

Lemma value_app_inv σ₁ σ₂ x y :
  value (@tapp σ₁ σ₂ x y) ->
  value x /\ value y.
Proof.
  intros. inv H.
  elimtype False.
  eapply eval_no_redex.
  apply H8. reflexivity. eauto. eauto. eauto.
  split; auto.
Qed.

(*
Lemma eval_app_inv σ₁ σ₂ x y z :
  eval _ (@tapp σ₁ σ₂ x y) z ->
  exists x', exists y',
    eval _ x x' /\ eval _ y y' /\
    eval _ (x' • y') z.
Proof.
  intros. inv H.
  exists n₁. exists n₂.
  intuition.
  eapply eapp1.
  eapply eval_value; eauto.
  eapply eval_value; eauto.
  eauto. auto.
  exists n₁. exists n₂.
  intuition.
  apply eapp2.
  eapply eval_value; eauto.
  eapply eval_value; eauto.
  auto.
Qed.
*)

(**  "Inert" terms are those that will not evaluate if applied to
     one more argument.  We prove that every term at function type
     is either intert or forms a redex if applied to another term.
  *)
Inductive inert : forall σ₁ σ₂, term (σ₁ ⇒ σ₂) -> Prop :=
  | inert_K : forall σ₁ σ₂,
                  inert _ _ (tK σ₁ σ₂)
  | inert_S1 : forall σ₁ σ₂ σ₃,
                  inert _ _ (tS σ₁ σ₂ σ₃)
  | inert_S2 : forall σ₁ σ₂ σ₃ x,
                  inert _ _ (tS σ₁ σ₂ σ₃ • x)
  | inert_IF1 : forall σ,
                  inert _ _ (tIF σ)
  | inert_IF2 : forall σ x,
                  inert _ _ (tIF σ • x)
  | inert_Y : forall σ₁ σ₂,
                  inert _ _ (tY σ₁ σ₂).

Fixpoint tmsize τ (x:term τ) : nat :=
  match x with
  | tapp a b => (1 + tmsize _ a + tmsize _ b)%nat
  | _ => 1%nat
  end.

Lemma redex_inert_false : forall σ₁ σ₂ f g r,
  redex σ₁ σ₂ f g r ->
  inert σ₁ σ₂ f ->
  False.
Proof.
  intros. inv H; inv H0.
Qed.

Lemma redex_or_inert' n :
  forall τ (x:term τ) σ₁ σ₂ (f:term (σ₁ ⇒ σ₂))
    (Hτ : τ = (σ₁ ⇒ σ₂)%ty)
    (Hx : eq_rect τ term x _ Hτ = f)
    (Hsz : tmsize τ x = n),
    value f ->
    (forall g, exists r, redex σ₁ σ₂ f g r) \/ inert σ₁ σ₂ f.
Proof.
  induction n using (well_founded_induction lt_wf).
  intros τ x. rename H into Hind.
  destruct x; intros; try discriminate.

  subst σ₂. simpl in *. subst n f.
  destruct (value_app_inv _ _ _ _ H).
  assert (Hx1:tmsize _ x1 < S (tmsize _ x1 + tmsize _ x2)).
  lia.
  generalize (Hind (tmsize _ x1) Hx1 _ _ _ _ x1
    (refl_equal _) (refl_equal _) (refl_equal _) H0).
  intros. destruct H2.
  destruct (H2 x2).
  elimtype False. eapply eval_no_redex.
  apply H. reflexivity. apply H0. apply H1. eauto.
  inv H2.
  left; intros. econstructor. econstructor.
  right. constructor.
  left; intros. econstructor. econstructor.
  right. constructor.
  destruct (value_app_inv _ _ _ _ H0).
  inv H4.
  left; intros. destruct b.
  econstructor. econstructor.
  econstructor. econstructor.
  simpl in *.
  inv H13.
  elimtype False. eapply eval_no_redex.
  apply H13. reflexivity. eauto. eauto. eauto.
  assert (Hm₁ : tmsize _ m₁ <
         S (S (S (S (tmsize (σ₁ ⇒ ty_bool) m₁ + tmsize σ₁ m₂ + tmsize σ₂0 x2))))).
  lia.
  destruct (value_app_inv _ _ _ _ H4).
  generalize (Hind _ Hm₁ _ _ _ _ m₁
    (refl_equal _) (refl_equal _) (refl_equal _) H5).
  intros. destruct H11. destruct (H11 m₂).
  elimtype False. eapply eval_no_redex.
  apply H4. reflexivity. eauto. eauto. eauto.
  inv H11.
  assert (Hn₁ : tmsize _ n₁ <
         S (S (S (S (tmsize (σ₁ ⇒ ty_bool) n₁ + tmsize σ₁ n₂ + tmsize σ₂0 x2))))).
  lia.
  destruct (value_app_inv _ _ _ _ H4). simpl in Hind.
  generalize (Hind _ Hn₁ _ _ _ _ n₁
    (refl_equal _) (refl_equal _) (refl_equal _) H6).
  intros. destruct H13. destruct (H13 n₂).
  elimtype False. eapply eval_no_redex.
  apply H4. reflexivity. eauto. eauto. eauto.
  inv H13.

  left; intros. econstructor. econstructor.

  inv Hτ.
  replace Hτ with (refl_equal (σ₂ ⇒ σ₂)%ty). simpl.
  left; intros. econstructor. econstructor.
  apply Eqdep_dec.UIP_dec. decide equality.

  inv Hτ.
  replace Hτ with (refl_equal (σ₁0 ⇒ σ₂ ⇒ σ₁0)%ty). simpl.
  right. constructor.
  apply Eqdep_dec.UIP_dec. decide equality.

  inv Hτ.
  replace Hτ with (refl_equal ((σ₁ ⇒ σ₂ ⇒ σ₃) ⇒ (σ₁ ⇒ σ₂) ⇒ σ₁ ⇒ σ₃)%ty).
  simpl.
  right. constructor.
  apply Eqdep_dec.UIP_dec. decide equality.

  inv Hτ.
  replace Hτ with (refl_equal (ty_bool ⇒ σ ⇒ σ ⇒ σ)%ty).
  simpl.
  right. constructor.
  apply Eqdep_dec.UIP_dec. decide equality.

  inv Hτ.
  replace Hτ with (refl_equal (((σ₁ ⇒ σ₂) ⇒ σ₁ ⇒ σ₂) ⇒ σ₁ ⇒ σ₂)%ty).
  simpl.
  right. constructor.
  apply Eqdep_dec.UIP_dec. decide equality.
Qed.

Lemma redex_or_inert :
  forall σ₁ σ₂ (f:term (σ₁ ⇒ σ₂)),
    value f ->
    (forall g, exists r, redex σ₁ σ₂ f g r) \/ inert σ₁ σ₂ f.
Proof.
  intros.
  apply (redex_or_inert' (tmsize _ f) _ f _ _ f (refl_equal _));
    simpl; auto.
Qed.

Lemma canonical_bool : forall x,
  eval 2 x x ->
  x = tbool true \/ x = tbool false.
Proof.
  intros. inv H.
  destruct b; auto.

  elimtype False.
  eapply eval_no_redex.
  apply H6. reflexivity. eauto. eauto. eauto.
  inv H0. clear H0.
  destruct (redex_or_inert _ _ n₁); auto.
  elim H5; apply H0.
  inv H0.
Qed.

(**  Types are interpreted as pointed domains.  Booleans
     are the flat domain over booleans and the arrow type
     is the lifted strict function space.
  *)
Fixpoint tydom (τ:ty) : ∂PLT :=
  match τ with
  | ty_bool => flat enumbool
  | ty_arrow τ₁ τ₂ => colift (tydom τ₁ ⊸ tydom τ₂)
  end.

(**  Here we define the semantics of the Y combinator.
  *)
Section Ydefn.
  Variables σ₁ σ₂:ty.

  Definition Ybody
    : U (colift (tydom (σ₁ ⇒ σ₂) ⊸ tydom (σ₁ ⇒ σ₂)))
       → PLT.exp (U (tydom (σ₁ ⇒ σ₂))) (U (tydom (σ₁ ⇒ σ₂)))

       (*w : U (colift (tydom (σ₁ ⇒ σ₂) ⊸ tydom (σ₁ ⇒ σ₂))) *)
    := PLT.curry (*x:U (tydom (σ₁ ⇒ σ₂)))*) (strict_curry' (*y:U tydom σ₁ *)

                                                          (* w *)    (* x *)    (*y*)
        (strict_app' ∘ 〈strict_app' ∘ 〈π₁ ∘ π₁, π₂ ∘ π₁〉, π₂〉)
       ).

  Lemma Ybody_unroll : forall Γ
    (f:Γ → U (tydom ((σ₁ ⇒ σ₂) ⇒ (σ₁ ⇒ σ₂))))
    (x:Γ → U (tydom σ₁)),

    semvalue x ->

    let Yf := (fixes Ybody) ∘ f in

    strict_app' ∘ 〈Yf, x〉 ≈
    strict_app' ∘ 〈strict_app' ∘ 〈f,Yf〉 , x〉.
  Proof.
    intros. unfold Yf at 1.
    rewrite fixes_unroll. unfold Ybody at 1.
    rewrite PLT.curry_apply2.
    rewrite <- (cat_assoc PLT).
    rewrite strict_curry_app2'.
    rewrite (PLT.pair_compose_commute false).
    rewrite <- (cat_assoc PLT).
    apply cat_respects. auto.
    rewrite (PLT.pair_compose_commute false).
    rewrite <- (cat_assoc PLT).
    rewrite (PLT.pair_compose_commute false).
    rewrite <- (cat_assoc PLT).
    rewrite PLT.pair_commute1.
    rewrite PLT.pair_commute2.
    rewrite PLT.pair_commute1.
    rewrite <- (cat_assoc PLT).
    rewrite PLT.pair_commute1.
    rewrite PLT.pair_commute2.
    rewrite (cat_ident2 PLT).
    apply PLT.pair_eq. auto. auto.
    auto.
  Qed.

  Definition Ysem Γ
    : Γ → U (tydom (((σ₁ ⇒ σ₂) ⇒ (σ₁ ⇒ σ₂)) ⇒ (σ₁ ⇒ σ₂)))
    := strict_curry' (fixes Ybody ∘ π₂).
End Ydefn.

Notation "'Λ' f" := (strict_curry' f) : ski_scope.

(**  The denotation of terms.  The denotation of
     the S, K and I combinators a straightforward interpretation of the
     usual lambda term into the strict lambda and strict application
     denotation functions.
  *)
Fixpoint denote (τ:ty) (m:term τ) : 1 → U (tydom τ) :=
  match m in term τ return 1 → U (tydom τ) with
  | tbool b => flat_elem' b
  | tapp m₁ m₂ => strict_app' ∘ 〈〚m₁〛,〚m₂〛〉
  | tI σ => Λ(π₂)
  | tK σ₁ σ₂ => Λ(Λ(π₂ ∘ π₁))
  | tS σ₁ σ₂ σ₃ => Λ(Λ(Λ(
                     strict_app' ∘
                       〈 strict_app' ∘ 〈π₂ ∘ π₁ ∘ π₁, π₂〉
                       , strict_app' ∘ 〈π₂ ∘ π₁, π₂〉
                       〉
                      )))
  | tIF σ => Λ(flat_cases' (fun b:bool =>
                if b then Λ(Λ(π₂ ∘ π₁))
                     else Λ(Λ(π₂))
                ))
  | tY σ₁ σ₂ => Ysem σ₁ σ₂ 1
  end
 where "〚 m 〛" := (denote _ m) : ski_scope.

(**  This mutual induction shows that operational
     values have semantic values as denotations,
     and that inert operational values yield
     semantic values when applied to any semantic value.
  *)
Lemma value_inert_semvalue : forall n,
  (forall σ x,
    tmsize _ x = n ->
    eval σ x x -> semvalue 〚x〛) /\
  (forall σ₁ σ₂ x (y:1 → U (tydom σ₁)),
    tmsize _ x = n ->
    value x ->
    inert σ₁ σ₂ x ->
    semvalue y ->
    semvalue (strict_app' ∘ 〈〚x〛, y〉)).
Proof.
  intro n. induction n using (well_founded_induction lt_wf).

  split; intros.
  inv H1; simpl.
  apply flat_elem'_semvalue.

  apply strict_curry'_semvalue.
  apply strict_curry'_semvalue.
  apply strict_curry'_semvalue.
  apply strict_curry'_semvalue.
  unfold Ysem. apply strict_curry'_semvalue.

  elimtype False.
  eapply eval_no_redex.
  apply H8. reflexivity. eauto. eauto. eauto.

  inv H2. clear H2.
  destruct (redex_or_inert _ _ n₁); auto.
  elim H7; auto.
  simpl in H.
  assert (Hm1 : (tmsize _ n₁) < S (tmsize _ n₁ + tmsize _ n₂)).
  lia.
  destruct (H _ Hm1).
  apply H3; auto.
  clear H2 H3.
  assert (Hm2 : (tmsize _ n₂) < S (tmsize _ n₁ + tmsize _ n₂)).
  lia.
  destruct (H _ Hm2).
  apply H2; auto.

  inv H2; simpl.

  rewrite strict_curry_app'; auto.
  apply strict_curry'_semvalue2.

  rewrite strict_curry_app'; auto.
  apply strict_curry'_semvalue2.

  rewrite strict_curry_app'; auto.
  rewrite strict_curry_app2'; auto.
  apply strict_curry'_semvalue2.
  destruct (value_app_inv _ _ _ _ H1); auto.
  simpl in H.
  assert (tmsize _ x0 < S (S (tmsize _ x0))). lia.
  destruct (H _ H5). apply (H6 _ x0); auto.

  rewrite strict_curry_app'; auto.
  destruct (flat_elem_canon enumbool y H3) as [b ?].
  rewrite H0.
  simpl.
  rewrite flat_cases_elem'.
  destruct b.
  apply strict_curry'_semvalue2.
  apply strict_curry'_semvalue2.

  rewrite strict_curry_app'; auto.
  destruct (value_app_inv _ _ _ _ H1); auto.
  destruct (canonical_bool x0); auto; subst x0; simpl.
  rewrite flat_cases_elem'.
  rewrite strict_curry_app2'; auto.
  apply strict_curry'_semvalue2.
  rewrite flat_cases_elem'.
  rewrite strict_curry_app2'; auto.
  apply strict_curry'_semvalue2.

  destruct (value_app_inv _ _ _ _ H1); auto.
  simpl in H.
  assert (tmsize _ x0 < S (S (tmsize _ x0))). lia.
  destruct (H _ H5). apply (H6 _ x0); auto.

  unfold Ysem.
  rewrite strict_curry_app'; auto.
  rewrite (fixes_unroll _ _ (Ybody σ₁0 σ₂0)).
  unfold Ybody at 1.
  rewrite PLT.curry_apply2.
  rewrite <- (cat_assoc PLT).
  rewrite <- (cat_assoc PLT).
  apply strict_curry'_semvalue2.
Qed.

Lemma value_semvalue : forall σ (x:term σ),
  value x -> semvalue 〚x〛.
Proof.
  intros. destruct (value_inert_semvalue (tmsize _ x)); auto.
Qed.

Lemma inert_semvalue σ₁ σ₂ x y :
  value x -> inert σ₁ σ₂ x -> semvalue y ->
  semvalue (strict_app' ∘ 〈〚x〛, y 〉).
Proof.
  intros.
  destruct (value_inert_semvalue (tmsize _ x)).
  apply H3; auto.
Qed.

Hint Resolve value_semvalue.

(**  Now we can show the soundness of redexes.
  *)
Lemma redex_soundness : forall σ₁ σ₂ x y z,
  value x ->
  value y ->
  redex σ₁ σ₂ x y z ->
  strict_app' ∘ 〈〚x〛,〚y〛〉 ≈ 〚z〛.
Proof.
  intros. inv H1.

  inv H1. simpl.
  rewrite strict_curry_app'; auto.
  rewrite PLT.pair_commute2. auto.

  simpl.
  rewrite strict_curry_app'; auto.
  rewrite strict_curry_app2'; auto.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  rewrite PLT.pair_commute2. auto.
  destruct (value_app_inv _ _ _ _ H); auto.

  destruct (value_app_inv _ _ _ _ H).
  destruct (value_app_inv _ _ _ _ H2). clear H4.
  simpl.
  rewrite strict_curry_app'; auto.
  rewrite strict_curry_app2'; auto.
  rewrite strict_curry_app2'; auto.
  repeat rewrite <- (cat_assoc PLT).
  rewrite (PLT.pair_compose_commute false).
  repeat rewrite <- (cat_assoc PLT).
  rewrite (PLT.pair_compose_commute false).
  repeat rewrite <- (cat_assoc PLT).
  repeat rewrite PLT.pair_commute1.
  repeat rewrite PLT.pair_commute2.
  rewrite (PLT.pair_compose_commute false).
  repeat rewrite <- (cat_assoc PLT).
  repeat rewrite PLT.pair_commute1.
  repeat rewrite PLT.pair_commute2.
  auto.
  apply (value_semvalue _ g); auto.
  apply (value_semvalue _ f); auto.

  destruct (value_app_inv _ _ _ _ H). clear H2.
  simpl.
  rewrite strict_curry_app'; auto.
  rewrite flat_cases_elem'.
  rewrite strict_curry_app2'; auto.
  rewrite strict_curry_app2'; auto.
  repeat rewrite <- (cat_assoc PLT).
  repeat rewrite PLT.pair_commute1.
  repeat rewrite PLT.pair_commute2. auto.
  apply flat_elem'_semvalue.

  destruct (value_app_inv _ _ _ _ H). clear H2.
  inv H1.
  simpl.
  rewrite strict_curry_app'; auto.
  rewrite flat_cases_elem'.
  rewrite strict_curry_app2'; auto.
  rewrite strict_curry_app2'; auto.
  repeat rewrite PLT.pair_commute2. auto.
  apply flat_elem'_semvalue.

  destruct (value_app_inv _ _ _ _ H). clear H1 H2.
  simpl.
  unfold Ysem.
  rewrite strict_curry_app'; auto.
  rewrite fixes_unroll at 1. unfold Ybody at 1.
  rewrite PLT.curry_apply2.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute2.
  rewrite <- (cat_assoc PLT).
  rewrite strict_curry_app2'; auto.
  rewrite <- (cat_assoc PLT).
  apply cat_respects. auto.
  rewrite (PLT.pair_compose_commute false).
  rewrite PLT.pair_commute2.
  apply PLT.pair_eq. 2: auto.
  rewrite <- (cat_assoc PLT).
  apply cat_respects. auto.
  rewrite (PLT.pair_compose_commute false).
  apply PLT.pair_eq.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  rewrite (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  apply cat_ident2.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  rewrite (cat_assoc PLT).
  rewrite PLT.pair_commute2.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute2.
  auto.
  apply (value_semvalue _ f). auto.
Qed.

(** This leads easily into the soundness of evaluation.
  *)
Lemma soundness : forall τ (m z:term τ),
  eval τ m z -> 〚m〛≈〚z〛.
Proof.
  intros. induction H; simpl; auto.
  rewrite IHeval1.
  rewrite IHeval2.
  rewrite <- IHeval3.
  apply redex_soundness.
  eapply eval_value; eauto.
  eapply eval_value; eauto.
  auto.
  rewrite IHeval1.
  rewrite IHeval2.
  auto.
Qed.

(** * The logical relations lemma

    Now define the logical relation for adequacy.  It is defined
    by induction on the structure of types, in a standard way.
  *)
Fixpoint LR (τ:ty) :
  term τ -> (1 → U (tydom τ)) -> Prop :=
  match τ as τ' return
    term τ' -> (1 → U (tydom τ')) -> Prop
  with
  | ty_bool => fun m h => exists b:bool,
        m = tbool b /\ h ≈ flat_elem' b
  | ty_arrow σ₁ σ₂ => fun m h =>
        forall n h',
          LR σ₁ n h' -> value n -> semvalue h' ->
          semvalue (strict_app' ∘ 〈h, h'〉) ->
          exists z,
            eval _ (m • n) z /\
            LR σ₂ z (strict_app' ∘ 〈h, h'〉)
  end.

Lemma LR_equiv τ : forall m h h',
  h ≈ h' -> LR τ m h -> LR τ m h'.
Proof.
  induction τ; simpl. intros.
  destruct H0 as [b [??]]. exists b; split; auto.
  rewrite <- H; auto.
  simpl; intros.
  destruct (H0 n h'0 H1 H2 H3) as [z [??]]; auto.
  revert H4. apply semvalue_equiv.
  apply cat_respects; auto.
  apply PLT.pair_eq; auto.
  exists z.
  split; auto.
  revert H6. apply IHτ2.
  apply cat_respects; auto.
  apply PLT.pair_eq; auto.
Qed.

(**  Now we need a host of auxilary definitions to state
     the main lemmas regarding the logical relation.  These
     definitions allow us to apply an arbitrary number of
     arguments to a syntactic term and to the denotation of terms.
  *)
Fixpoint lrtys (ts:list ty) (z:ty) :=
  match ts with
  | nil => z
  | t::ts' => (t ⇒ (lrtys ts' z))%ty
  end.

Fixpoint lrsyn (ts:list ty) : Type :=
  match ts with
  | nil => unit
  | t::ts' => prod (lrsyn ts') (term t)
  end.

Fixpoint lrsem (ts:list ty) : Type :=
  match ts with
  | nil => unit
  | t::ts' => prod (lrsem ts') (1 → U (tydom t))
  end.

Fixpoint lrhyps (ls:list ty) : lrsyn ls -> lrsem ls -> Prop :=
  match ls with
  | nil => fun _ _ => True
  | t::ts => fun xs ys =>
    (eval _ (snd xs) (snd xs) /\ semvalue (snd ys)) /\
    LR t (snd xs) (snd ys) /\ lrhyps ts (fst xs) (fst ys)
  end.

Fixpoint lrapp (ls:list ty) z : lrsyn ls -> term (lrtys ls z) -> term z :=
  match ls as ls' return lrsyn ls' -> term (lrtys ls' z) -> term z with
  | nil => fun _ m => m
  | t::ts => fun xs m => lrapp ts _ (fst xs) (m • (snd xs))
  end.

Fixpoint lrsemapp (ls:list ty) z :
  lrsem ls -> (1 → U (tydom (lrtys ls z))) -> (1 → U (tydom z)) :=
  match ls as ls' return
    lrsem ls' -> (1 → U (tydom (lrtys ls' z)))  -> (1 → U (tydom z))
  with
  | nil => fun _ h => h
  | t::ts => fun ys h => lrsemapp ts _ (fst ys) (strict_app' ∘ 〈h, snd ys〉)
  end.

Lemma eval_lrapp_congruence ls : forall xs τ m m' z,
  (forall q, eval _ m q -> eval _ m' q) ->
  eval τ (lrapp ls τ xs m) z ->
  eval τ (lrapp ls τ xs m') z.
Proof.
  induction ls; simpl; intros.
  apply H. auto.
  fold lrtys in *.

  revert H0. apply IHls.
  intros.
  inv H0.
  apply H in H6.
  eapply eapp1; eauto.
  eapply eapp2; eauto.
Qed.

Lemma lrsemapp_equiv ls : forall τ ys h h',
  h ≈ h' -> lrsemapp ls τ ys h ≈ lrsemapp ls τ ys h'.
Proof.
  induction ls; simpl; intros; auto.
  apply IHls.
  apply cat_respects; auto.
  apply PLT.pair_eq; auto.
Qed.

Lemma semvalue_lrsemapp_out ls : forall τ ys h,
   semvalue (lrsemapp ls τ ys h) -> semvalue h.
Proof.
  induction ls; simpl; intros; auto.
  apply IHls in H.
  apply semvalue_app_out1' in H. auto.
Qed.

(**  This fact is important in the base cases of the fundamental lemma; it allows
     unwind a stack of applications.
  *)
Lemma LR_under_apply ls :
   forall (τ : ty) (m z0 : term (lrtys ls τ)) (xs : lrsyn ls)
     (ys : lrsem ls) (h : 1 → U (tydom (lrtys ls τ))),
   eval (lrtys ls τ) m z0 ->
   lrhyps ls xs ys ->
   semvalue (lrsemapp ls τ ys h) ->
   LR (lrtys ls τ) z0 h ->
   exists z : term τ,
     eval τ (lrapp ls τ xs m) z /\ LR τ z (lrsemapp ls τ ys h).
Proof.
  induction ls; simpl; intros.
  exists z0. split; auto.
  destruct xs as [xs x].
  destruct ys as [ys y]. simpl in *.
  destruct H0 as [[??][??]].
  destruct (H2 x y) as [z1 [??]]; auto.
  apply semvalue_lrsemapp_out in H1. auto.

  generalize (IHls τ (tapp z0 x) z1 xs ys (strict_app' ∘ PLT.pair h y)
     H6 H5 H1 H7).
  intros [q [??]].
  exists q; split; auto.
  revert H8.
  apply eval_lrapp_congruence. intro.
  apply eval_app_congruence; auto.
  fold lrtys. intros.
  apply eval_trans with z0; auto.
Qed.

(**  If a sup is a semantic value, then there is some element of the
     set is a semantic value.
  *)
Lemma semvalue_sup (B:∂PLT) (XS:dirset (PLT.homset_cpo _ 1 (U B))) :
  semvalue (∐XS) -> exists x, x ∈ XS /\ semvalue x.
Proof.
  intros.
  destruct (H tt) as [q ?].
  simpl in H0.
  apply union_axiom in H0.
  destruct H0 as [q' [??]].
  apply image_axiom2 in H0.
  destruct H0 as [q'' [??]].
  simpl in *.
  exists q''. split; auto.
  red; intro. destruct g.
  exists q. rewrite <- H2; auto.
Qed.

(**  The logical relation is admissible.  This is key to the
     fundamental lemma case for Y.
  *)
Lemma LR_admissible τ :
  forall m (XS:dirset (PLT.homset_cpo _ 1 (U (tydom τ)))),
  semvalue (∐XS) ->
  (forall x, x ∈ XS -> semvalue x -> LR τ m x) -> LR τ m (∐XS).
Proof.
  induction τ; simpl. intros.

  apply semvalue_sup in H. destruct H as [x [??]].
  destruct (H0 x) as [b [??]]; auto.
  subst m. exists b. split; auto.
  split.
  apply CPO.sup_is_least.
  hnf; simpl; intros.
  destruct (proj2_sig XS (x::x0::nil)). hnf; auto.
  hnf; intros. apply cons_elem in H4.
  destruct H4. rewrite H4. auto.
  rewrite (cons_elem _ x0 nil a) in H4.
  destruct H4. rewrite H4. auto.
  apply nil_elem in H4. elim H4.
  destruct H4.
  assert (x1 ≈ x).
  assert (x ≤ x1). apply H4. apply cons_elem; auto.
  split; auto.
  hnf; intros.
  rewrite H3 in H6.
  assert ((tt,Some b : U (flat enumbool)) ∈ PLT.hom_rel x1).
  apply H6.
  unfold flat_elem'.
  apply PLT.compose_hom_rel. exists (Some tt).
  split. simpl. apply adj_unit_rel_elem. auto.
  apply U_hom_rel. right.
  exists tt. exists b. split; auto.
  apply PLT.compose_hom_rel; auto.
  exists tt. split.
  simpl. apply eprod_elem. split; simpl.
  apply eff_complete. apply single_axiom; auto.
  simpl. apply single_axiom; auto.
  destruct H3. apply H9.
  destruct a. unfold flat_elem'.
  apply PLT.compose_hom_rel.
  exists (Some tt). split.
  simpl. apply adj_unit_rel_elem; simpl; auto.
  destruct c; auto.
  apply U_hom_rel.
  destruct c0; auto. right.
  exists tt. exists c0. split; auto.
  apply PLT.compose_hom_rel.
  exists tt.
  split. simpl.
  apply eprod_elem. split.
  apply eff_complete. apply single_axiom; auto.
  simpl. apply single_axiom; auto.
  cut (c0 = b). intros. subst c0; auto.
  destruct c.
  destruct (PLT.hom_directed _ _ _ x1 tt ((Some c0::Some b::nil))).
  hnf; auto.
  red; intros.
  rewrite (cons_elem _ _ _ a) in H10. destruct H10. rewrite H10.
  apply erel_image_elem. auto.
  apply cons_elem in H10. destruct H10. rewrite H10.
  apply erel_image_elem. auto.
  apply nil_elem in H10. elim H10.
  destruct H10.
  assert (Some c0 ≤ x2).
  apply H10. apply cons_elem; auto.
  assert (Some (b:enumbool) ≤ x2).
  apply H10. apply cons_elem. right. apply cons_elem; auto.
  destruct x2. hnf in H12. hnf in H13.
  subst c0. subst b. auto.
  elim H12.

  rewrite <- H3. rewrite <- H6.
  apply H4.
  apply cons_elem. right.
  apply (cons_elem _ x0). auto.
  apply CPO.sup_is_ub. rewrite <- H3. auto.

  simpl; intros.
  set (g := (postcompose _ strict_app' ∘ pair_left (U (tydom (τ1 ⇒ τ2))) h')).
  assert (strict_app' ∘ PLT.pair (∐XS) h' ≈ g (∐XS)).
  simpl; auto.
  assert (strict_app' ∘ PLT.pair (∐XS) h' ≈ ∐(image g XS)).
  rewrite H5.
  apply CPO.continuous_sup'.
  apply continuous_sequence.
  apply postcompose_continuous.
  apply pair_left_continuous.

  assert (exists q, q ∈ XS /\
    semvalue (strict_app' ∘ PLT.pair q h')).
  rewrite H6 in H4.
  destruct (H4 tt) as [q ?].
  simpl.
  simpl in H7.
  apply union_axiom in H7.
  destruct H7 as [q' [??]].
  apply image_axiom2 in H7.
  destruct H7 as [q'' [??]].
  apply image_axiom2 in H7.
  destruct H7 as [q''' [??]].
  exists q'''. split; auto.
  rewrite H9 in H8.
  rewrite H10 in H8.
  red; intros.
  exists q. auto.
  destruct H7 as [q [??]].
  assert (semvalue q).
  apply semvalue_app_out1' in H8. auto.
  destruct (H0 q H7 H9 n h' H1 H2 H3 H8) as [z [??]].
  exists z. split; auto.
  cut (LR τ2 z (∐(image g XS))).
  apply LR_equiv; auto.
  apply IHτ2; auto.
  rewrite <- H6. auto.

  intros.
  apply image_axiom2 in H12. destruct H12 as [y [??]].
  rewrite H14 in H13.
  simpl in H13.
  assert (semvalue y).
  apply semvalue_app_out1' in H13. auto.
  destruct (H0 y H12 H15 n h' H1 H2 H3) as [z' [??]]; auto.
  assert (z = z').
  eapply eval_eq; eauto. subst z'.
  revert H17.
  apply LR_equiv; auto.
Qed.

(**  Here we prove fundamental lemma case for he main body
     of Y combinator. This proof goes by Scott induction.
  *)
Lemma LR_Ybody σ₁ σ₂
  (f:term ((σ₁ ⇒ σ₂) ⇒ σ₁ ⇒ σ₂)) hf :
  LR _ f hf -> value f -> semvalue hf ->

  forall (x:term σ₁) hx,
    LR σ₁ x hx -> value x -> semvalue hx ->
    semvalue (strict_app' ∘ 〈fixes (Ybody σ₁ σ₂) ∘ hf, hx〉) ->
    exists z:term σ₂,
      eval _ (tY σ₁ σ₂ • f • x) z /\
      LR _ z (strict_app' ∘ 〈fixes (Ybody σ₁ σ₂) ∘ hf, hx〉).
Proof.
  intros Hf1 Hf2 Hf3. unfold fixes.
  apply scott_induction.
  split.

  intros.
  apply semvalue_app_out1' in H2.
  destruct (H2 tt) as [q ?].
  apply (PLT.compose_hom_rel _ _ _ _ hf ⊥ tt (Some q : (colift _))) in H3.
  destruct H3 as [?[??]].
  elimtype False. revert H4.
  clear. simpl bottom.
  intros.
  unfold plt_hom_adj' in H4; simpl in H4.
  apply PLT.compose_hom_rel in H4.
  destruct H4 as [?[??]].
  simpl in H.
  (* FIXME: In 8.6, Coq gets stuck in a reduction loop if we do not apply this
     generalized lemma *)
  assert (aurl : forall (X : PLT) (x : X) (x' : U (L X)),
             (x, x') ∈ adj_unit_rel X (PLT.effective X) <-> x' ≤ Some x).
  { intros Y y y'. exact (@adj_unit_rel_elem (PLT.ord Y) _ y y'). }
  apply aurl in H. clear aurl.
  apply U_hom_rel in H0.
  destruct H0. discriminate.
  destruct H0 as [? [? [?[??]]]].
  subst x. inv H2.
  simpl in H0.
  apply union_axiom in H0.
  destruct H0 as [?[??]].
  apply image_axiom2 in H0.
  destruct H0 as [?[??]].
  apply empty_elem in H0. elim H0.

  intros.
  set (g := (postcompose _ strict_app'
            ∘ pair_left (U (tydom (σ₁ ⇒ σ₂))) hx
            ∘ precompose _ hf)).
  assert (strict_app' ∘ PLT.pair (∐XS ∘ hf) hx ≈ g (∐XS)). auto.
  assert (strict_app' ∘ PLT.pair (∐XS ∘ hf) hx ≈ ∐(image g XS)).
  rewrite H5.

  apply CPO.continuous_sup'.
  apply continuous_sequence.
  apply continuous_sequence.
  apply postcompose_continuous.
  apply pair_left_continuous.
  apply precompose_continuous.

  assert (exists q, q ∈ XS /\
    semvalue (strict_app' ∘ PLT.pair (q ∘ hf) hx)).
  rewrite H6 in H4.
  apply semvalue_sup in H4.
  destruct H4 as [q [??]].
  apply image_axiom2 in H4 as [q' [??]].
  exists q'. split; auto.
  simpl in H8. rewrite <- H8. auto.

  destruct H7 as [q [??]].
  destruct (H0 q H7 x hx H1 H2 H3) as [z [??]]; auto.
  exists z.
  split; auto.
  cut (LR σ₂ z (∐(image g XS))).
  apply LR_equiv; auto.
  apply LR_admissible.
  rewrite <- H6; auto.
  intros.
  apply image_axiom2 in H11. destruct H11 as [y [??]].
  simpl in H13. rewrite H13 in H12.
  destruct (H0 y H11 x hx) as [z' [??]]; auto.
  assert (z = z'). eapply eval_eq; eauto. subst z'.
  revert H15; apply LR_equiv; auto.

  intros.
  destruct (H0 x0 hx H1 H2 H3) as [z [??]]. rewrite H; auto.
  exists z; split; auto.
  revert H6. apply LR_equiv. rewrite <- H; auto.

  intros.
  simpl in H3. unfold fixes_step in H3.
  unfold Ybody in H3.
  rewrite PLT.curry_apply2 in H3.
  rewrite <- (cat_assoc PLT) in H3.
  rewrite (PLT.pair_compose_commute false) in H3.
  rewrite strict_curry_app2' in H3.
  rewrite <- (cat_assoc PLT) in H3.
  rewrite (PLT.pair_compose_commute false) in H3.
  rewrite PLT.pair_commute2 in H3.
  rewrite <- (cat_assoc PLT) in H3.
  rewrite (PLT.pair_compose_commute false) in H3.
  rewrite <- (cat_assoc PLT) in H3.
  rewrite PLT.pair_commute1 in H3.
  rewrite PLT.pair_commute1 in H3.
  rewrite <- (cat_assoc PLT) in H3.
  rewrite PLT.pair_commute1 in H3.
  rewrite PLT.pair_commute2 in H3.
  rewrite (cat_ident2 PLT) in H3.

  simpl in Hf1.
  destruct (Hf1 (tapp (tY _ _) f) (x ∘ hf)) as [q [??]]; auto.
  apply eapp2. apply eY. auto.
  intros [? Hr]; inv Hr.
  apply semvalue_app_out1' in H3.
  apply semvalue_app_out2' in H3. auto.
  apply semvalue_app_out1' in H3. auto.
  destruct (H5 x0 hx) as [q' [?]]; auto.
  exists q'. split.
  eapply eapp1.
  apply eapp2. apply eY. eauto.
  intros [? Hr]; inv Hr. eauto.
  apply redex_Y.
  revert H6. apply eval_app_congruence; intros; auto.
  apply eval_trans with q; auto.
  revert H7. apply LR_equiv.
  simpl. unfold fixes_step. unfold Ybody.
  symmetry.

  rewrite PLT.curry_apply2.
  rewrite <- (cat_assoc PLT).
  rewrite (PLT.pair_compose_commute false).
  rewrite strict_curry_app2'.
  rewrite <- (cat_assoc PLT).
  rewrite (PLT.pair_compose_commute false).
  rewrite PLT.pair_commute2.
  rewrite <- (cat_assoc PLT).
  rewrite (PLT.pair_compose_commute false).
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  rewrite PLT.pair_commute1.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  rewrite PLT.pair_commute2.
  rewrite (cat_ident2 PLT).
  auto.
  apply semvalue_app_out2' in H3. auto.
  auto.
Qed.

(**  Now we can prove the fundamental lemma cases for
     each of the system combinators.
  *)

Lemma LR_I σ : LR _ (tI σ) 〚tI σ〛.
Proof.
  simpl. intros.
  exists n. split.
  eapply eapp1.
  apply eI. apply H0.
  apply redex_I. auto.
  revert H. apply LR_equiv. rewrite strict_curry_app'.
  rewrite PLT.pair_commute2; auto. auto.
Qed.

Lemma LR_K σ₁ σ₂ : LR _ (tK σ₁ σ₂) 〚tK σ₁ σ₂〛.
Proof.
  simpl. intros.

  exists (tapp (tK _ _) n). split.
  apply eapp2. apply eK. auto.
  intros [? Hr]. inv Hr.
  intros.
  exists n. split.
  eapply eapp1.
  apply eapp2. apply eK. eauto.
  intros [? Hr]. inv Hr. eauto.
  apply redex_K. auto.
  revert H.
  apply LR_equiv.
  rewrite strict_curry_app'.
  rewrite strict_curry_app2'.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  rewrite PLT.pair_commute2.
  auto. auto. auto.
Qed.

Lemma LR_S σ₁ σ₂ σ₃ : LR _ (tS σ₁ σ₂ σ₃) 〚tS σ₁ σ₂ σ₃〛.
Proof.
  simpl; intros.
  exists (tapp (tS _ _ _) n). split.
  apply eapp2. apply eS. auto.
  intros [? Hr]; inversion Hr.
  intros.
  exists (tapp (tapp (tS _ _ _) n) n0). split.
  apply eapp2. apply eapp2. apply eS. auto.
  intros [? Hr]; inversion Hr. auto.
  intros [? Hr]; inversion Hr. intros.

  assert ( (strict_app'
           ∘ PLT.pair
               (strict_app'
                ∘ PLT.pair
                    (strict_app'
                     ∘ PLT.pair
                         (strict_curry'
                            (strict_curry'
                               (strict_curry'
                                  (strict_app'
                                   ∘ PLT.pair
                                       (strict_app'
                                        ∘ PLT.pair (π₂ ∘ π₁ ∘ π₁) π₂)
                                       (strict_app'
                                        ∘ PLT.pair (π₂ ∘ π₁) π₂))))) h')
                    h'0) h'1)
     ≈
     strict_app' ∘ PLT.pair
       (strict_app' ∘ PLT.pair h' h'1)
       (strict_app' ∘ PLT.pair h'0 h'1)).
  clear -H9 H5 H1.

  rewrite strict_curry_app'; auto.
  rewrite strict_curry_app2'; auto.
  rewrite strict_curry_app2'; auto.
  rewrite <- (cat_assoc PLT).
  apply cat_respects. auto.
  rewrite <- (cat_assoc PLT).
  rewrite (PLT.pair_compose_commute false).
  apply PLT.pair_eq.
  rewrite <- (cat_assoc PLT).
  rewrite (PLT.pair_compose_commute false).
  apply cat_respects. auto.
  apply PLT.pair_eq.
  rewrite <- (cat_assoc PLT).
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  rewrite PLT.pair_commute1.
  rewrite PLT.pair_commute2.
  auto.
  rewrite PLT.pair_commute2.
  auto.
  rewrite <- (cat_assoc PLT).
  apply cat_respects; auto.
  rewrite (PLT.pair_compose_commute false).
  apply PLT.pair_eq; auto.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  rewrite PLT.pair_commute2.
  auto.
  rewrite PLT.pair_commute2.
  auto.

  rewrite H11 in H10.

  destruct (H3 n1 h'1) as [z0 [??]]; auto; clear H3.
  apply semvalue_app_out2' in H10. auto.

  destruct (H n1 h'1) as [z1 [??]]; auto; clear H.
  apply semvalue_app_out1' in H10. auto.

  destruct (H14 z0 (strict_app' ∘ PLT.pair h'0 h'1)) as [z2 [??]]; auto; clear H14.
  eapply eval_value; eauto.
  apply semvalue_app_out2' in H10. auto.
  exists z2. split.
  eapply eapp1.
  apply eapp2. apply eapp2. apply eS. eauto.
  intros [? Hr]; inv Hr. eauto.
  intros [? Hr]; inv Hr. eauto.
  apply redex_S.
  revert H.
  apply eval_app_congruence.
  intros. apply eval_trans with z1; auto.
  intros. apply eval_trans with z0; auto.
  revert H15. apply LR_equiv. auto.
Qed.

Lemma LR_Y σ₁ σ₂ : LR _ (tY σ₁ σ₂) 〚tY σ₁ σ₂〛.
Proof.
  simpl; intros.
  exists (tapp (tY _ _) n).
  split. apply eapp2. apply eY. auto.
  intros [? Hr]; inv Hr.
  intros.
  unfold Ysem in H6.
  rewrite strict_curry_app' in H6.
  rewrite <- (cat_assoc PLT) in H6.
  rewrite PLT.pair_commute2 in H6.
  destruct (LR_Ybody σ₁ σ₂ n h' H H0 H1 n0 h'0 H3 H4 H5 H6) as [z [??]].
  exists z. split; auto.
  revert H8. apply LR_equiv.
  unfold Ysem.
  rewrite strict_curry_app'.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute2.
  auto.
  auto.
  auto.
Qed.

Lemma LR_IF σ : LR _ (tIF σ) 〚tIF σ〛.
Proof.
  simpl. intros.
  exists (tapp (tIF σ) n). split. apply eapp2.
  apply eIF. auto.
  intros [? Hr]. inv Hr.
  intros.
  exists (tapp (tapp (tIF σ) n) n0). split. apply eapp2. apply eapp2.
  apply eIF. auto.
  intros [? Hr]. inv Hr. auto.
  intros [? Hr]. inv Hr.
  intros.
  destruct H as [b [??]]. subst n.
  destruct b.
  exists n0. split.
  eapply eapp1. apply eapp2. apply eapp2.
  apply eIF. apply ebool.
  intros [? Hr]. inv Hr. eauto.
  intros [? Hr]. inv Hr. eauto.
  econstructor. auto.
  revert H3. apply LR_equiv.
  rewrite H11.
  rewrite strict_curry_app'; auto.
  rewrite flat_cases_elem'.
  rewrite strict_curry_app2'; auto.
  rewrite strict_curry_app2'; auto.
  rewrite <- (cat_assoc PLT).
  rewrite PLT.pair_commute1.
  rewrite PLT.pair_commute2. auto.
  apply flat_elem'_semvalue.
  exists n1.
  split.
  eapply eapp1. apply eapp2. apply eapp2.
  apply eIF. apply ebool.
  intros [? Hr]. inv Hr. eauto.
  intros [? Hr]. inv Hr. eauto.
  econstructor. auto.
  revert H7. apply LR_equiv.
  rewrite H11.
  rewrite strict_curry_app'; auto.
  rewrite flat_cases_elem'.
  rewrite strict_curry_app2'; auto.
  rewrite strict_curry_app2'; auto.
  rewrite PLT.pair_commute2. auto.
  apply flat_elem'_semvalue.
Qed.

(**  Now the fundamental lemma follows by induction on terms.
  *)
Lemma fundamental_lemma : forall σ (n:term σ) ls τ m xs ys
  (Hσ : σ = lrtys ls τ),
  eq_rect σ term n (lrtys ls τ) Hσ = m ->
  lrhyps ls xs ys ->
  semvalue (lrsemapp ls τ ys 〚m〛) ->
  exists z,
    eval _ (lrapp ls τ xs m) z /\
    LR τ z (lrsemapp ls τ ys 〚m〛).
Proof.
  induction n; intros.

  (* bool case *)
  destruct ls; simpl in *. subst τ.
  simpl in H. subst m.
  exists (tbool b).
  split. apply ebool.
  simpl.
  exists b. split; auto.
  inv Hσ.

  (* application case *)
  subst σ₂. simpl in H. subst m.

  destruct (IHn2 nil σ₁ n2 tt tt (Logic.refl_equal _) (Logic.refl_equal _) I)
    as [q2[??]]; auto.
  simpl.
  apply semvalue_lrsemapp_out in H1. simpl in H1.
  apply semvalue_app_out2' in H1. auto.

  destruct (IHn1 (σ₁::ls) _ n1 (xs, q2) (ys, denote σ₁ q2)
    (Logic.refl_equal _) (Logic.refl_equal _)) as [q1 [??]].
  simpl; intuition. eapply eval_value; eauto.
  apply value_semvalue; auto.  eapply eval_value; eauto.
  revert H2. apply LR_equiv.
  simpl. simpl in H. apply soundness; auto.
  simpl. revert H1.
  apply semvalue_equiv.
  apply lrsemapp_equiv.
  simpl. apply cat_respects; auto.
  apply PLT.pair_eq; auto.
  apply soundness; auto.
  exists q1. split.
  revert H3.
  simpl. apply eval_lrapp_congruence.
  intro q. apply eval_app_congruence; intros; auto.
  apply eval_trans with q2; auto.
  revert H4.
  apply LR_equiv. simpl.
  apply lrsemapp_equiv.
  simpl. apply cat_respects; auto.
  apply PLT.pair_eq; auto.
  symmetry.
  apply soundness; auto.

  (* I case *)
  cut (exists z : term (σ ⇒ σ),
     eval (σ ⇒ σ) (tI σ) z /\ LR (σ ⇒ σ) z (denote _ (tI _))).
  revert H.
  generalize (tI σ).
  generalize Hσ.
  rewrite Hσ. intro H.
  replace H with (refl_equal (lrtys ls τ)). simpl. intros.
  subst t. clear H Hσ.
  destruct H3 as [z0 [??]].
  eapply LR_under_apply; eauto.
  apply Eqdep_dec.UIP_dec. decide equality.

  exists (tI σ). split. apply eI. apply LR_I.

  (* K case *)
  cut (exists z,
     eval _ (tK σ₁ σ₂) z /\ LR _ z (denote _ (tK _ _))).
  revert H.
  generalize (tK σ₁ σ₂).
  generalize Hσ.
  rewrite Hσ. intro H.
  replace H with (refl_equal (lrtys ls τ)). simpl. intros.
  subst t. clear H Hσ.
  destruct H3 as [z0 [??]].
  eapply LR_under_apply; eauto.
  apply Eqdep_dec.UIP_dec. decide equality.

  exists (tK _ _). split. apply eK. apply LR_K.

  (* S case *)
  cut (exists z,
     eval _ (tS σ₁ σ₂ σ₃) z /\ LR _ z (denote _ (tS _ _ _))).
  revert H.
  generalize (tS σ₁ σ₂ σ₃).
  generalize Hσ.
  rewrite Hσ. intro H.
  replace H with (refl_equal (lrtys ls τ)). simpl. intros.
  subst t. clear H Hσ.
  destruct H3 as [z0 [??]].
  eapply LR_under_apply; eauto.
  apply Eqdep_dec.UIP_dec. decide equality.

  exists (tS _ _ _).
  split. simpl. apply eS. apply LR_S.

  (* IF case *)
  cut (exists z,
     eval _ (tIF σ) z /\ LR _ z (denote _ (tIF _))).
  revert H.
  generalize (tIF σ).
  generalize Hσ.
  rewrite Hσ. intro H.
  replace H with (refl_equal (lrtys ls τ)). simpl. intros.
  subst t. clear H Hσ.
  destruct H3 as [z0 [??]].
  eapply LR_under_apply; eauto.
  apply Eqdep_dec.UIP_dec. decide equality.

  exists (tIF σ). split. apply eIF.
  apply LR_IF.

  (* Y case *)
  cut (exists z,
     eval _ (tY σ₁ σ₂) z /\ LR _ z (denote _ (tY σ₁ σ₂))).
  revert H.
  generalize (tY σ₁ σ₂).
  generalize Hσ.
  rewrite Hσ. intro H.
  replace H with (refl_equal (lrtys ls τ)). simpl. intros.
  subst t. clear H Hσ.
  destruct H3 as [z0 [??]].
  eapply LR_under_apply; eauto.
  apply Eqdep_dec.UIP_dec. decide equality.

  exists (tY σ₁ σ₂). split. apply eY. apply LR_Y.
Qed.

(**  A specialization of the fundamental lemma to empty contexts
  *)
Lemma fundamental_lemma' : forall τ (m:term τ),
  semvalue 〚m〛 ->
  exists z, eval τ m z /\ LR τ z 〚m〛.
Proof.
  intros.
  apply (fundamental_lemma τ m nil τ m tt tt (refl_equal _) (refl_equal _) I).
  simpl. auto.
Qed.

(** * Contextual equivalance and the adequacy theorem.

     Now we define contextual equivalance.  Contexts here are
     given in "inside-out" form, which makes the induction in the
     adequacy proof significantly easier.
  *)
Inductive context τ : ty -> Type :=
  | cxt_top : context τ τ
  | cxt_appl : forall σ₁ σ₂,
                    term σ₁ ->
                    context τ σ₂ ->
                    context τ (σ₁ ⇒ σ₂)
  | cxt_appr : forall σ₁ σ₂,
                    term (σ₁ ⇒ σ₂) ->
                    context τ σ₂ ->
                    context τ σ₁.

Fixpoint plug τ σ (C:context τ σ) : term σ -> term τ :=
  match C in context _ σ return term σ -> term τ with
  | cxt_top _ => fun x => x
  | cxt_appl _ σ₁ σ₂ t C' => fun x => plug τ _ C' (tapp x t)
  | cxt_appr _ σ₁ σ₂ t C' => fun x => plug τ _ C' (tapp t x)
  end.

Definition cxt_eq τ σ (m n:term σ):=
  forall (C:context τ σ) (z:term τ),
    eval τ (plug τ σ C m) z <-> eval τ (plug τ σ C n) z.

(**  Adequacy means that terms with equivalant denotations
     are contextually equivalant in any boolean context.
  *)
Theorem adequacy : forall τ (m n:term τ),
  〚m〛≈〚n〛 -> cxt_eq 2 τ m n.
Proof.
  intros. intro.
  revert n m H.
  induction C.

  simpl; intros.
  split; intros.
  destruct (fundamental_lemma' _ m) as [zm [??]].
  simpl.
  apply semvalue_equiv with (denote _ z).
  symmetry. apply soundness. auto.
  apply value_semvalue. eapply eval_value; eauto.
  destruct (fundamental_lemma' _ n) as [zn [??]].
  simpl.
  apply semvalue_equiv with (denote _ z).
  symmetry. rewrite <- H.
  apply soundness. auto.
  apply value_semvalue. eapply eval_value; eauto.
  destruct H2 as [b [??]].
  destruct H4 as [b' [??]].
  simpl in *.
  rewrite H in H5. rewrite H5 in H6.
  assert (b = b').
  apply flat_elem'_inj in H6. auto.
  exact tt.
  subst b'.
  subst zm zn.
  assert (z = (tbool b)).
  eapply eval_eq; eauto.
  subst z. auto.

  destruct (fundamental_lemma' _ m) as [zm [??]].
  simpl.
  apply semvalue_equiv with (denote _ z).
  symmetry. rewrite H. apply soundness. auto.
  apply value_semvalue. eapply eval_value; eauto.
  destruct (fundamental_lemma' _ n) as [zn [??]].
  simpl.
  apply semvalue_equiv with (denote _ z).
  symmetry. apply soundness. auto.
  apply value_semvalue. eapply eval_value; eauto.
  destruct H2 as [b [??]].
  destruct H4 as [b' [??]].
  simpl in *.
  rewrite H in H5. rewrite H5 in H6.
  assert (b = b').
  apply flat_elem'_inj in H6. auto.
  exact tt.
  subst b'.
  subst zm zn.
  assert (z = (tbool b)).
  eapply eval_eq; eauto.
  subst z. auto.

  simpl. intros.
  apply IHC. simpl.
  apply cat_respects; auto.
  apply PLT.pair_eq; auto.

  simpl; intros.
  apply IHC. simpl.
  apply cat_respects; auto.
  apply PLT.pair_eq; auto.
Qed.

(** Every term fails to evaluate iff the denotation is bottom. *)
Corollary denote_bottom_nonvalue : forall τ (m:term τ),
  (~exists z, eval τ m z) <-> 〚m〛 ≈ ⊥.
Proof.
  intros. split; intro.

  split. 2: apply bottom_least.
  hnf. intros [u x] Hx. destruct x.
  elimtype False.
  destruct (fundamental_lemma' τ m) as [z [??]].
  red; intros. destruct g. simpl.
  exists c. auto.
  elim H. eauto.
  apply PLT.compose_hom_rel.
  simpl. exists None.
  split.
  apply adj_unit_rel_elem. hnf; auto.
  apply U_hom_rel. auto.

  intros [z ?].
  assert (denote τ z ≈ ⊥).
  rewrite <- soundness; eauto.
  assert (value z).
  eapply eval_value; eauto.
  apply value_semvalue in H2.
  hnf in H2.
  destruct (H2 tt) as [x ?].
  destruct H1. apply H1 in H3.
  simpl bottom in H3.
  apply (PLT.compose_hom_rel) in H3.
  destruct H3 as [q [??]].
  apply U_hom_rel in H5.
  destruct H5.
  inversion H5.
  destruct H5 as [q' [?[??]]].
  simpl in H5.
  apply union_axiom in H5.
  destruct H5 as [?[??]].
  apply image_axiom2 in H5. destruct H5 as [? [??]].
  apply empty_elem in H5. elim H5.
Qed.

(** These should print "Closed under the global context", meaning these
    theorems hold without the use of any axioms.
  *)
Print Assumptions adequacy.
Print Assumptions denote_bottom_nonvalue.


From mathcomp
Require Import all_ssreflect ssralg fingroup zmodp poly ssrnum.
From mathcomp
Require Import matrix mxalgebra vector falgebra ssrnum algC algnum.
From mathcomp
Require Import fieldext.
From mathcomp Require Import vector.

(* From mathcomp Require classfun. *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope ring_scope.
Import GRing.Theory Num.Theory.

Reserved Notation "'[ u , v ]"
  (at level 2, format "'[hv' ''[' u , '/ '  v ] ']'").
Reserved Notation "'[ u , v ]_ M"
         (at level 2, format "'[hv' ''[' u , '/ '  v ]_ M ']'").
Reserved Notation "'[ u ]_ M" (at level 2, format "''[' u ]_ M").
Reserved Notation "'[ u ]" (at level 2, format "''[' u ]").
Reserved Notation "u '``_' i"
    (at level 3, i at level 2, left associativity, format "u '``_' i").
Reserved Notation "A ^_|_"    (at level 8, format "A ^_|_").
Reserved Notation "A _|_ B" (at level 69, format "A  _|_  B").
Reserved Notation "eps_theta .-sesqui" (at level 2, format "eps_theta .-sesqui").

Notation "u '``_' i" := (u (GRing.zero (Zp_zmodType O)) i) : ring_scope.
Notation "''e_' i" := (delta_mx 0 i)
 (format "''e_' i", at level 3) : ring_scope.

Local Notation "M ^ phi" := (map_mx phi M).
Local Notation "M ^t phi" := (map_mx phi (M ^T)) (phi at level 30, at level 30).

Structure revop X Y Z (f : Y -> X -> Z) := RevOp {
  fun_of_revop :> X -> Y -> Z;
  _ : forall x, f x =1 fun_of_revop^~ x
}.

Lemma eq_map_mx (R S : ringType) m n (M : 'M[R]_(m,n))
      (g f : R -> S) : f =1 g -> M ^ f = M ^ g.
Proof. by move=> eq_fg; apply/matrixP=> i j; rewrite !mxE. Qed.

Lemma map_mx_id (R : ringType) m n (M : 'M[R]_(m,n)) : M ^ id = M.
Proof. by apply/matrixP=> i j; rewrite !mxE. Qed.

Lemma eq_map_mx_id (R : ringType) m n (M : 'M[R]_(m,n)) (f : R -> R) :
  f =1 id -> M ^ f = M.
Proof. by move=> /eq_map_mx->; rewrite map_mx_id. Qed.

Module Bilinear.

Section ClassDef.

Variables (R : ringType) (U U' : lmodType R) (V : zmodType) (s s' : R -> V -> V).
Implicit Type phUU'V : phant (U -> U' -> V).

Local Coercion GRing.Scale.op : GRing.Scale.law >-> Funclass.
Definition axiom (f : U -> U' -> V) (s_law : GRing.Scale.law s) (eqs : s = s_law)
                                    (s'_law : GRing.Scale.law s') (eqs' : s' = s'_law) :=
  ((forall u', GRing.Linear.axiom (f^~ u') eqs)
  * (forall u, GRing.Linear.axiom (f u) eqs'))%type.

Record class_of (f : U -> U' -> V) : Prop := Class {
  basel : forall u', GRing.Linear.class_of s (f^~ u');
  baser : forall u, GRing.Linear.class_of s' (f u)
}.

Lemma class_of_axiom f s_law s'_law Ds Ds' :
   @axiom f s_law Ds s'_law Ds' -> class_of f.
Proof.
by pose coa := GRing.Linear.class_of_axiom; move=> [/(_ _) /coa ? /(_ _) /coa].
Qed.

Structure map phUU'V := Pack {apply; _ : class_of apply}.
Local Coercion apply : map >-> Funclass.

Definition class (phUU'V : _)  (cF : map phUU'V) :=
   let: Pack _ c as cF' := cF return class_of cF' in c.

Canonical additiver phU'V phUU'V (u : U) cF := GRing.Additive.Pack phU'V
  (baser (@class phUU'V cF) u).
Canonical linearr phU'V  phUU'V (u : U) cF := GRing.Linear.Pack phU'V
  (baser (@class phUU'V cF) u).

(* Fact applyr_key : unit. Proof. exact. Qed. *)
Definition applyr_head t (f : U -> U' -> V) u v := let: tt := t in f v u.
Notation applyr := (@applyr_head tt).

Canonical additivel phUV phUU'V (u' : U') (cF : map _) :=
  @GRing.Additive.Pack _ _ phUV (applyr cF u') (basel (@class phUU'V cF) u').
Canonical linearl phUV phUU'V  (u' : U') (cF : map _) :=
  @GRing.Linear.Pack _ _ _ _ phUV (applyr cF u') (basel (@class phUU'V cF) u').

Definition pack (phUV : phant (U -> V)) (phU'V : phant (U' -> V))
           (revf : U' -> U -> V) (rf : revop revf) f (g : U -> U' -> V) of (g = fun_of_revop rf) :=
  fun (bFl : U' -> GRing.Linear.map s phUV) flc of (forall u', revf u' = bFl u') &
      (forall u', phant_id (GRing.Linear.class (bFl u')) (flc u')) =>
  fun (bFr : U -> GRing.Linear.map s' phU'V) frc of (forall u, g u = bFr u) &
      (forall u, phant_id (GRing.Linear.class (bFr u)) (frc u)) =>
  @Pack (Phant _) f (Class flc frc).

(* (* Support for right-to-left rewriting with the generic linearZ rule. *) *)
(* Notation mapUV := (map (Phant (U -> U' -> V))). *)
(* Definition map_class := mapUV. *)
(* Definition map_at (a : R) := mapUV. *)
(* Structure map_for a s_a := MapFor {map_for_map : mapUV; _ : s a = s_a}. *)
(* Definition unify_map_at a (f : map_at a) := MapFor f (erefl (s a)). *)
(* Structure wrapped := Wrap {unwrap : mapUV}. *)
(* Definition wrap (f : map_class) := Wrap f. *)

End ClassDef.

Module Exports.
Delimit Scope linear_ring_scope with linR.
Notation bilinear_for s s' f := (axiom f (erefl s) (erefl s')).
Notation bilinear f := (bilinear_for *:%R *:%R f).
Notation biscalar f := (bilinear_for *%R *%R f).
Notation bilmorphism_for s s' f := (class_of s s' f).
Notation bilmorphism f := (bilmorphism_for *:%R *:%R f).
Coercion class_of_axiom : axiom >-> bilmorphism_for.
Coercion baser : bilmorphism_for >-> Funclass.
Coercion apply : map >-> Funclass.
Notation "{ 'bilinear' fUV | s & s' }" := (map s s' (Phant fUV))
  (at level 0, format "{ 'bilinear'  fUV  |  s  &  s' }") : ring_scope.
Notation "{ 'bilinear' fUV | s }" := (map s.1 s.2 (Phant fUV))
  (at level 0, format "{ 'bilinear'  fUV  |  s }") : ring_scope.
Notation "{ 'bilinear' fUV }" := {bilinear fUV | *:%R & *:%R}
  (at level 0, format "{ 'bilinear'  fUV }") : ring_scope.
Notation "{ 'biscalar' U }" := {bilinear U -> U -> _ | *%R & *%R}
  (at level 0, format "{ 'biscalar'  U }") : ring_scope.
Notation "[ 'bilinear' 'of' f 'as' g ]" :=
  (@pack  _ _ _ _ _ _ _ _ _ _ f g erefl _ _
         (fun=> erefl) (fun=> idfun) _ _ (fun=> erefl) (fun=> idfun)).
Notation "[ 'bilinear' 'of' f ]" :=  [bilinear of f as f]
  (at level 0, format "[ 'bilinear'  'of'  f ]") : form_scope.
Coercion additiver : map >-> GRing.Additive.map.
Coercion linearr : map >->  GRing.Linear.map.
Canonical additiver.
Canonical linearr.
Canonical additivel.
Canonical linearl.
Notation applyr := (@applyr_head _ _ _ _ tt).
(* Canonical additive. *)
(* (* Support for right-to-left rewriting with the generic linearZ rule. *) *)
(* Coercion map_for_map : map_for >-> map. *)
(* Coercion unify_map_at : map_at >-> map_for. *)
(* Canonical unify_map_at. *)
(* Coercion unwrap : wrapped >-> map. *)
(* Coercion wrap : map_class >-> wrapped. *)
(* Canonical wrap. *)
End Exports.

End Bilinear.
Include Bilinear.Exports.

Section BilinearTheory.

Variable R : ringType.

Section GenericProperties.

Variables (U U' : lmodType R) (V : zmodType) (s : R -> V -> V) (s' : R -> V -> V).
Variable f : {bilinear U -> U' -> V | s & s'}.

Lemma linear0r z : f z 0 = 0. Proof. by rewrite raddf0. Qed.
Lemma linearNr z : {morph f z : x / - x}. Proof. exact: raddfN. Qed.
Lemma linearDr z : {morph f z : x y / x + y}. Proof. exact: raddfD. Qed.
Lemma linearBr z : {morph f z : x y / x - y}. Proof. exact: raddfB. Qed.
Lemma linearMnr z n : {morph f z : x / x *+ n}. Proof. exact: raddfMn. Qed.
Lemma linearMNnr z n : {morph f z : x / x *- n}. Proof. exact: raddfMNn. Qed.
Lemma linear_sumr z I r (P : pred I) E :
  f z (\sum_(i <- r | P i) E i) = \sum_(i <- r | P i) f z (E i).
Proof. exact: raddf_sum. Qed.

Lemma linearZr_LR z : scalable_for s' (f z). Proof. exact: linearZ_LR. Qed.
Lemma linearPr z a : {morph f z : u v / a *: u + v >-> s' a u + v}.
Proof. exact: linearP. Qed.

Lemma applyrE x : applyr f x =1 f^~ x. Proof. by []. Qed.

Lemma linear0l z : f 0 z = 0. Proof. by rewrite -applyrE raddf0. Qed.
Lemma linearNl z : {morph f^~ z : x / - x}.
Proof. by move=> ?; rewrite -applyrE raddfN. Qed.
Lemma linearDl z : {morph f^~ z : x y / x + y}.
Proof. by move=> ??; rewrite -applyrE raddfD. Qed.
Lemma linearBl z : {morph f^~ z : x y / x - y}.
Proof. by move=> ??; rewrite -applyrE raddfB. Qed.
Lemma linearMnl z n : {morph f^~ z : x / x *+ n}.
Proof. by move=> ?; rewrite -applyrE raddfMn. Qed.
Lemma linearMNnl z n : {morph f^~ z : x / x *- n}.
Proof. by move=> ?; rewrite -applyrE raddfMNn. Qed.
Lemma linear_suml z I r (P : pred I) E :
  f (\sum_(i <- r | P i) E i) z = \sum_(i <- r | P i) f (E i) z.
Proof. by rewrite -applyrE raddf_sum. Qed.

Lemma linearZl_LR z : scalable_for s (f^~ z).
Proof. by move=> ??; rewrite -applyrE linearZ_LR. Qed.
Lemma linearPl z a : {morph f^~ z : u v / a *: u + v >-> s a u + v}.
Proof. by move=> ??; rewrite -applyrE linearP. Qed.

End GenericProperties.

Section BidirectionalLinearZ.

Variables (U : lmodType R) (V : zmodType) (s : R -> V -> V).
Variables (S : ringType) (h : S -> V -> V) (h_law : GRing.Scale.law h).

(* Lemma linearZr z c a (h_c := GRing.Scale.op h_law c) (f : GRing.Linear.map_for U s a h_c) u : *)
(*   f z (a *: u) = h_c (GRing.Linear.wrap (f z) u). *)
(* Proof. by rewrite linearZ_LR; case: f => f /= ->. Qed. *)

End BidirectionalLinearZ.

End BilinearTheory.

Canonical rev_mulmx (R : ringType) m n p := @RevOp _ _ _ (@mulmxr R m n p)
  (@mulmx R m n p) (fun _ _ => erefl).

Canonical mulmx_bilinear (R : comRingType) m n p := [bilinear of @mulmx R m n p].

(* Section classfun. *)
(* Import mathcomp.character.classfun. *)

(* Canonical rev_cfdot (gT : finGroupType) (B : {set gT}) :=  *)
(*   @RevOp _ _ _ (@cfdotr_head gT B tt) *)
(*   (@cfdot gT B) (fun _ _ => erefl). *)

(* Section Cfdot. *)
(* Variables (gT : finGroupType) (G : {group gT}). *)
(* Lemma cfdot_is_linear xi : linear_for (@conjC _ \; *%R) (cfdot xi : 'CF(G) -> algC^o). *)
(* Proof. *)
(* move=> /= a phi psi; rewrite cfdotC -cfdotrE linearD linearZ /=. *)
(* by rewrite !['[_, xi]]cfdotC rmorphD rmorphM !conjCK. *)
(* Qed. *)
(* Canonical cfdot_additive xi := Additive (cfdot_is_linear xi). *)
(* Canonical cfdot_linear xi := Linear (cfdot_is_linear xi). *)
(* End Cfdot. *)

(* Canonical cfdot_bilinear (gT : finGroupType) (B : {group gT}) := *)
(*   [bilinear of @cfdot gT B]. *)
(* End classfun. *)

Section BilinearForms.

Variables (R : fieldType) (theta : {rmorphism R -> R}).
Variables (n : nat) (M : 'M[R]_n).
Implicit Types (a b : R) (u v : 'rV[R]_n) (N P Q : 'M[R]_n).

Definition form u v := (u *m M *m (v ^t theta)) 0 0.

Local Notation "''[' u , v ]" := (form u%R v%R) : ring_scope.
Local Notation "''[' u ]" := '[u, u] : ring_scope.

Lemma form0l u : '[0, u] = 0.
Proof. by rewrite /form !mul0mx mxE. Qed.

Lemma form0r u : '[u, 0] = 0.
Proof. by rewrite /form trmx0 map_mx0 mulmx0 mxE. Qed.

Lemma formDl u v w : '[u + v, w] = '[u, w] + '[v, w].
Proof. by rewrite /form !mulmxDl mxE. Qed.

Lemma formDr u v w : '[u, v + w] = '[u, v] + '[u, w].
Proof. by rewrite /form linearD !map_mxD !mulmxDr mxE. Qed.

Lemma formZr a u v : '[u, a *: v] = theta a * '[u, v].
Proof. by rewrite /form !(linearZ, map_mxZ) /= mxE. Qed.

Lemma formZl a u v : '[a *: u, v] = a * '[u, v].
Proof.
by do !rewrite /form  -[_ *: _ *m _]/(mulmxr _ _) linearZ /=; rewrite mxE.
Qed.

Lemma formNl u v : '[- u, v] = - '[u, v].
Proof. by rewrite -scaleN1r formZl mulN1r. Qed.

Lemma formNr u v : '[u, - v] = - '[u, v].
Proof. by rewrite -scaleN1r formZr rmorphN1 mulN1r. Qed.

Lemma formee i j : '['e_i, 'e_j] = M i j.
Proof.
rewrite /form -rowE -map_trmx map_delta_mx -[M in LHS]trmxK.
by rewrite -tr_col -trmx_mul -rowE !mxE.
Qed.

Lemma form0_eq0 : M = 0 -> forall u v, '[u, v] = 0.
Proof. by rewrite/form=> -> u v; rewrite mulmx0 mul0mx mxE. Qed.

End BilinearForms.

Section Sesquilinear.

Variable R : fieldType.
Variable n : nat.
Implicit Types (a b : R) (u v : 'rV[R]_n) (N P Q : 'M[R]_n).

Section Def.
Variable eps_theta : (bool * {rmorphism R -> R}).

Definition sesqui :=
  [qualify M : 'M_n | M == ((-1) ^+ eps_theta.1) *: M ^t eps_theta.2].
Fact sesqui_key : pred_key sesqui. Proof. by []. Qed.
Canonical sesqui_keyed := KeyedQualifier sesqui_key.
End Def.

Local Notation "eps_theta .-sesqui" := (sesqui eps_theta).

Variables (eps : bool) (theta : {rmorphism R -> R}).
Variables (M : 'M[R]_n).
Local Notation "''[' u , v ]" := (form theta M u%R v%R) : ring_scope.
Local Notation "''[' u ]" := '[u, u] : ring_scope.

Lemma sesquiE : (M \is (eps,theta).-sesqui) = (M == (-1) ^+ eps *: M ^t theta).
Proof. by rewrite qualifE. Qed.

Lemma sesquiP : reflect (M = (-1) ^+ eps *: M ^t theta)
                        (M \is (eps,theta).-sesqui).
Proof. by rewrite sesquiE; apply/eqP. Qed.

Hypothesis (thetaK : involutive theta).
Hypothesis (M_sesqui : M \is (eps, theta).-sesqui).

Lemma trmx_sesqui : M^T = (-1) ^+ eps *: M ^ theta.
Proof.
rewrite [in LHS](sesquiP _) // -mul_scalar_mx trmx_mul.
by rewrite tr_scalar_mx mul_mx_scalar map_trmx trmxK.
Qed.

Lemma maptrmx_sesqui : M^t theta = (-1) ^+ eps *: M.
Proof.
by rewrite trmx_sesqui map_mxZ rmorph_sign -map_mx_comp eq_map_mx_id.
Qed.

Lemma formC u v : '[u, v] = (-1) ^+ eps * theta '[v, u].
Proof.
rewrite /form [M in LHS](sesquiP _) // -mulmxA !mxE rmorph_sum mulr_sumr.
apply: eq_bigr => /= i _; rewrite !(mxE, mulr_sumr, mulr_suml, rmorph_sum).
apply: eq_bigr => /= j _; rewrite !mxE !rmorphM  mulrCA -!mulrA.
by congr (_ * _); rewrite mulrA mulrC thetaK.
Qed.

Lemma form_eq0C u v : ('[u, v] == 0) = ('[v, u] == 0).
Proof. by rewrite formC mulf_eq0 signr_eq0 /= fmorph_eq0. Qed.

Definition ortho m (B : 'M_(m,n)) := (kermx (M *m (B ^t theta))).
Local Notation "B ^_|_" := (ortho B) : ring_scope.
Local Notation "A _|_ B" := (A%MS <= B^_|_)%MS : ring_scope.

Lemma normalE u v : (u _|_ v) = ('[u, v] == 0).
Proof.
by rewrite (sameP sub_kermxP eqP) mulmxA [_ *m _^t _]mx11_scalar fmorph_eq0.
Qed.

Lemma form_eq0P {u v} : reflect ('[u, v] = 0) (u _|_ v).
Proof. by rewrite normalE; apply/eqP. Qed.

Lemma normalP p q (A : 'M_(p, n)) (B :'M_(q, n)) :
  reflect (forall (u v : 'rV_n), (u <= A)%MS -> (v <= B)%MS -> u _|_ v)
          (A _|_ B).
Proof.
apply: (iffP idP) => AnB.
  move=> u v uA vB; rewrite (submx_trans uA) // (submx_trans AnB) //.
  apply/sub_kermxP; have /submxP [w ->] := vB.
  rewrite trmx_mul map_mxM !mulmxA -[kermx _ *m _ *m _]mulmxA.
  by rewrite [kermx _ *m _](sub_kermxP _) // mul0mx.
apply/rV_subP => u /AnB /(_ _) /sub_kermxP uMv; apply/sub_kermxP.
suff: forall m (v : 'rV[R]_m),
  (forall i, v *m 'e_i ^t theta = 0 :> 'M_1) -> v = 0.
  apply => i; rewrite !mulmxA -!mulmxA -map_mxM -trmx_mul uMv //.
  by apply/submxP; exists 'e_i.
move=> /= m v Hv; apply: (can_inj (@trmxK _ _ _)).
rewrite trmx0; apply/row_matrixP=> i; rewrite row0 rowE.
apply: (can_inj (@trmxK _ _ _)); rewrite trmx0 trmx_mul trmxK.
by rewrite -(map_delta_mx theta) map_trmx Hv.
Qed.

Lemma normalC p q (A : 'M_(p, n)) (B :'M_(q, n)) : (A _|_ B) = (B _|_ A).
Proof.
gen have nC : p q A B / A _|_ B -> B _|_ A; last by apply/idP/idP; apply/nC.
move=> AnB; apply/normalP => u v ? ?; rewrite normalE.
rewrite formC mulf_eq0 ?fmorph_eq0 ?signr_eq0 /=.
by rewrite -normalE (normalP _ _ AnB).
Qed.

Lemma normal_ortho_mx p (A : 'M_(p, n)) : ((A^_|_) _|_ A).
Proof. by []. Qed.

Lemma normal_mx_ortho p (A : 'M_(p, n)) : (A _|_ (A^_|_)).
Proof. by rewrite normalC. Qed.

Lemma rank_normal u : (\rank (u ^_|_) >= n.-1)%N.
Proof.
rewrite mxrank_ker -subn1 leq_sub2l //.
by rewrite (leq_trans (mxrankM_maxr  _ _)) // rank_leq_col.
Qed.

Definition rad := 1%:M^_|_.

Lemma rad_ker : rad = kermx M.
Proof. by rewrite /rad /ortho trmx1 map_mx1 mulmx1. Qed.

(* Pythagore *)
Theorem formDd u v : u _|_ v -> '[u + v] = '[u] + '[v].
Proof.
move=> uNv; rewrite formDl !formDr ['[v, u]]formC.
by rewrite ['[u, v]](form_eq0P _) // rmorph0 mulr0 addr0 add0r.
Qed.

Lemma formZ a u : '[a *: u]= (a * theta a) * '[u].
Proof. by rewrite formZl formZr mulrA. Qed.

Lemma formN u : '[- u] = '[u].
Proof. by rewrite formNr formNl opprK. Qed.

Lemma form_sign m u : '[(-1) ^+ m *: u] = '[u].
Proof. by rewrite -signr_odd scaler_sign; case: odd; rewrite ?formN. Qed.

Lemma formD u v : let d := '[u, v] in
  '[u + v] = '[u] + '[v] + (d + (-1) ^+ eps * theta d).
Proof. by rewrite formDl !formDr ['[v, _]]formC [_ + '[v]]addrC addrACA. Qed.

Lemma formB u v : let d := '[u, v] in
  '[u - v] = '[u] + '[v] - (d + (-1) ^+ eps * theta d).
Proof. by rewrite formD formN !formNr rmorphN mulrN -opprD. Qed.

Lemma formBd u v : u _|_ v -> '[u - v] = '[u] + '[v].
Proof.
by move=> uTv; rewrite formDd ?formN // normalE formNr oppr_eq0 -normalE.
Qed.

(* Lemma formJ u v : '[u ^ theta, v ^ theta] = (-1) ^+ eps * theta '[u, v]. *)
(* Proof. *)
(* rewrite {1}/form -map_trmx -map_mx_comp (@eq_map_mx _ _ _ _ _ id) ?map_mx_id //. *)
(* set x := (_ *m _); have -> : x 0 0 = theta ((x^t theta) 0 0) by rewrite !mxE. *)
(* rewrite !trmx_mul trmxK map_trmx mulmxA !map_mxM. *)
(* rewrite maptrmx_sesqui -!scalemxAr -scalemxAl mxE rmorphM rmorph_sign. *)

(* Lemma formJ u : '[u ^ theta] = (-1) ^+ eps * '[u]. *)
(* Proof.  *)
(* rewrite {1}/form -map_trmx -map_mx_comp (@eq_map_mx _ _ _ _ _ id) ?map_mx_id //. *)
(* set x := (_ *m _); have -> : x 0 0 = theta ((x^t theta) 0 0) by rewrite !mxE. *)
(* rewrite !trmx_mul trmxK map_trmx mulmxA !map_mxM. *)
(* rewrite maptrmx_sesqui -!scalemxAr -scalemxAl mxE rmorphM rmorph_sign. *)
(* rewrite !map_mxM. *)
(* rewrite -map_mx_comp eq_map_mx_id //. *)
(*  !linearZr_LR /=. linearZ. *)
(*  linearZl. *)
(* rewrite trmx_sesqui. *)

(* rewrite mapmx. *)
(* rewrite map *)
(* apply/matrixP.  *)

(* rewrite formC. *)
(* Proof. by rewrite cfdot_conjC geC0_conj // cfnorm_ge0. Qed. *)

(* Lemma cfCauchySchwarz u v : *)
(*   `|'[u, v]| ^+ 2 <= '[u] * '[v] ?= iff ~~ free (u :: v). *)
(* Proof. *)
(* rewrite free_cons span_seq1 seq1_free -negb_or negbK orbC. *)
(* have [-> | nz_v] /= := altP (v =P 0). *)
(*   by apply/lerifP; rewrite !cfdot0r normCK mul0r mulr0. *)
(* without loss ou: u / '[u, v] = 0. *)
(*   move=> IHo; pose a := '[u, v] / '[v]; pose u1 := u - a *: v. *)
(*   have ou: '[u1, v] = 0. *)
(*     by rewrite cfdotBl cfdotZl divfK ?cfnorm_eq0 ?subrr. *)
(*   rewrite (canRL (subrK _) (erefl u1)) rpredDr ?rpredZ ?memv_line //. *)
(*   rewrite cfdotDl ou add0r cfdotZl normrM (ger0_norm (cfnorm_ge0 _)). *)
(*   rewrite exprMn mulrA -cfnormZ cfnormDd; last by rewrite cfdotZr ou mulr0. *)
(*   by have:= IHo _ ou; rewrite mulrDl -lerif_subLR subrr ou normCK mul0r. *)
(* rewrite ou normCK mul0r; split; first by rewrite mulr_ge0 ?cfnorm_ge0. *)
(* rewrite eq_sym mulf_eq0 orbC cfnorm_eq0 (negPf nz_v) /=. *)
(* apply/idP/idP=> [|/vlineP[a {2}->]]; last by rewrite cfdotZr ou mulr0. *)
(* by rewrite cfnorm_eq0 => /eqP->; apply: rpred0. *)
(* Qed. *)

End Sesquilinear.

Notation "eps_theta .-sesqui" := (sesqui _ eps_theta) : ring_scope.

Notation symmetric_form := (false, [rmorphism of idfun]).-sesqui.
Notation skew := (true, [rmorphism of idfun]).-sesqui.
Notation hermitian := (false, @conjC _).-sesqui.

(* Section ClassificationForm. *)

(* Variables (F : fieldType) (L : fieldExtType) (theat : 'Aut()) *)

(* Notation "''[' u , v ]_ M" := (form M%R u%R v%R) : ring_scope. *)
(* Notation "''[' u ]_ M" := (form M%R u%R u%R) : ring_scope. *)

(* Hypothesis (thetaK : involutive theta). *)

(* Lemma sesqui_test M : (forall u v, '[v, u]_M = 0 -> '[u, v]_M = 0) -> *)
(*                       {eps | eps^+2 = 1 & M \is (eps,theta).-sesqui}. *)
(* Proof. *)
(* pose  *)

(*                       [/\ forall u, '[u] = 0, theta =1 id & eps = -1] *)
(*                       \/ ((exists u, '[u] != 0) /\ (eps = 1)). *)
(* Proof. *)
(* move=> M_neq0 form_eq0. *)
(* have [] := boolP [forall i : 'I_n, '['e_i] == 0]; last first. *)
(*   rewrite negb_forall => /existsP [i ei_neq0]. *)
(*   right; split; first by exists ('e_i). *)
(*   apply/eqP; *)

(*  contraT *)

(* suff [f_eq0|] : (forall u, '[u] = 0) \/ (exists u, '[u] != 0). *)
(*   left; split=> //. *)

(* have [] := boolP [forall i : 'I_n, '['e_i] == 0]. *)

(* suff /eqP : eps ^+ 2 = 1. *)
(*   rewrite -subr_eq0 subr_sqr_1 mulf_eq0. *)
(*   move => /orP[]; rewrite addr_eq0 ?opprK=> /eqP eps_eq. *)
(*     right; split=> //. *)

(* have [] := boolP [forall i : 'I_n, '['e_i] == 0]. *)

(* have := sesquiC u u. *)

(* rewrite !linearZ /= -[eps *: _ *m _]/(mulmxr _ _) linearZ /= mxE; congr (_ * _). *)
(* have : u = map_mx theta (map_mx theta u). *)
(*   apply/rowP=> i; rewrite !mxE. *)
(* rewrite -[in LHS]mulmxA -map_mxM. *)
(* rewrite  *)
(*  !mxE rmorph_sum; apply: eq_bigr => /= i _; rewrite !mxE. *)
(* rewrite !rmorphM thetaK rmorph_sum. *)

(* Hypothesis (M_sesqui : M \is (eps, theta).-sesqui). *)

(* rewrite -[a *: u *m _]/(mulmxr _ _). *)
(* rewrite linearZ. *)

(* Variables (R : fieldType) (n : nat). *)

(* Local Notation "A _|_ B" := (A%MS <= kermx B%MS^T)%MS. *)

(* Lemma normal_sym k m (A : 'M[R]_(k,n)) (B : 'M[R]_(m,n)) : *)
(*   A _|_ B = B _|_ A. *)
(* Proof. *)
(* rewrite !(sameP sub_kermxP eqP) -{1}[A]trmxK -trmx_mul. *)
(* by rewrite -{1}trmx0 (inj_eq (@trmx_inj _ _ _)). *)
(* Qed. *)

(* Lemma normalNm k m (A : 'M[R]_(k,n)) (B : 'M[R]_(m,n)) : (- A) _|_ B = A _|_ B. *)
(* Proof. by rewrite eqmx_opp. Qed. *)

(* Lemma normalmN k m (A : 'M[R]_(k,n)) (B : 'M[R]_(m,n)) : A _|_ (- B) = A _|_ B. *)
(* Proof. by rewrite ![A _|_ _]normal_sym normalNm. Qed. *)

(* Lemma normalDm k m p (A : 'M[R]_(k,n)) (B : 'M[R]_(m,n)) (C : 'M[R]_(p,n)) : *)
(*   (A + B _|_ C) = (A _|_ C) && (B _|_ C). *)
(* Proof. by rewrite addsmxE !(sameP sub_kermxP eqP) mul_col_mx col_mx_eq0. Qed. *)

(* Lemma normalmD  k m p (A : 'M[R]_(k,n)) (B : 'M[R]_(m,n)) (C : 'M[R]_(p,n)) : *)
(*   (A _|_ B + C) = (A _|_ B) && (A _|_ C). *)
(* Proof. by rewrite ![A _|_ _]normal_sym normalDm. Qed. *)

(* Definition dot (u v : 'rV[R]_n) : R := (u *m v^T) 0 0. *)

(* Notation "''[' u , v ]" := (dot u v) : ring_scope. *)
(* Notation "''[' u ]" := '[u, u]%MS : ring_scope. *)

(* Lemma dotmulE (u v : 'rV[R]_n) : '[u, v] = \sum_k u``_k * v``_k. *)
(* Proof. by rewrite [LHS]mxE; apply: eq_bigr=> i; rewrite mxE. Qed. *)

(* Lemma normalvv (u v : 'rV[R]_n) : (u _|_ v) = ('[u, v] == 0). *)
(* Proof. by rewrite (sameP sub_kermxP eqP) [_ *m _^T]mx11_scalar fmorph_eq0. Qed. *)

(* End Normal. *)

(* Local Notation "''[' u , v ]" := (form u v) : ring_scope. *)
(* Local Notation "''[' u ]" := '[u%R, u%R] : ring_scope. *)
(* Local Notation "A _|_ B" := (A%MS <= kermx B%MS^T)%MS. *)


From Undecidability.TRAKHTENBROT Require Import bpcp red_undec fo_sig.
From Undecidability.Synthetic Require Import Undecidability ReducibilityFacts.
From Undecidability.FOL.Syntax Require Import Core.
From Undecidability.FOL.Semantics.FiniteTarski Require Fragment Full DoubleNegation.
From Undecidability.FOL.Undecidability Require Import Reductions.FSATd_to_FSATdc Reductions.TRAKHTENBROT_to_FSAT.

Section Full.
  Import Full.

  Theorem FSAT_undec :
    undecidable FSAT.
  Proof.
    apply (undecidability_from_reducibility BPCP_problem_undec).
    eapply reduces_transitive; [| apply reduction].
    apply (@FULL_TRAKHTENBROT_non_informative (Σrel 2)). left. exists tt. auto.
  Qed.

  Theorem FSATd_undec :
    undecidable FSATd.
  Proof.
    apply (undecidability_from_reducibility BPCP_problem_undec).
    eapply reduces_transitive; try apply reduction_disc.
    eapply reduces_transitive; try apply (@FULL_TRAKHTENBROT_non_informative (Σrel 2)).
    - left. exists tt. auto.
    - exists (fun phi => phi). intros phi. apply red_utils.fo_form_fin_dec_SAT_discr_equiv.
  Qed.

  Theorem FSATdc_undec :
    undecidable FSATdc.
  Proof.
   apply (undecidability_from_reducibility FSATd_undec).
   apply FSATd_to_FSATdc.reduction.
  Qed.
End Full.


Require Import Coq.ZArith.ZArith. Local Open Scope Z_scope.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List. Import ListNotations.
Require Import coqutil.Tactics.Tactics.
Require Import riscv.Spec.Machine.
Require Import riscv.Platform.Memory.
Require Import riscv.Spec.CSRFile.
Require Import riscv.Utility.Utility.
Require Import coqutil.Datatypes.RecordSetters. Export OCamlLikeNotations.
Require Import coqutil.Z.Lia.
Require Import coqutil.Map.Interface.
Require Import riscv.Platform.MaterializeRiscvProgram.

Module map.
  (* Swap argument order to enable usage of partially applied `map.set k v` as an updater *)
  Definition set{key value}{map: map.map key value}(k: key)(v: value)(m: map): map :=
    map.put m k v.
End map.

Section Riscv.
  Context {width: Z} {BW: Bitwidth width} {word: word width} {word_ok: word.ok word}.
  Context {Mem: map.map word byte}.
  Context {Registers: map.map Z word}.

  (* (memory before call, call name, arg values) and (memory after call, return values) *)
  Definition LogItem: Type := (Mem * string * list word) * (Mem * list word).

  Record State := mkState {
    regs: Registers;
    pc: word;
    nextPc: word;
    mem: Mem;
    log: list LogItem;
    csrs: CSRFile
  }.

  (* TODO: add XAddrs tracking so that executing an instruction written in a previous cycle
     (which potentially is already in the pipeline) is not allowed *)

  Definition store(n: nat)(ctxid: SourceType)(a: word) v (mach: State)(post: State -> Prop) :=
    match Memory.store_bytes n mach.(mem) a v with
    | Some m => post { mach with mem := m }
    | None => False
    end.

  Definition load(n: nat)(ctxid: SourceType)(a: word)(mach: State)(post: _ -> _ -> Prop) :=
    match Memory.load_bytes n mach.(mem) a with
    | Some v => post v mach
    | None => False
    end.

  Definition updatePc(mach: State): State :=
    { mach with pc := mach.(nextPc); nextPc ::= word.add (word.of_Z 4) }.

  Definition getReg(regs: Registers)(reg: Z): word :=
    if ((0 <? reg) && (reg <? 32))%bool then
      match map.get regs reg with
      | Some x => x
      | None => word.of_Z 0
      end
    else word.of_Z 0.

  Definition setReg(reg: Z)(v: word)(regs: Registers): Registers :=
    if ((0 <? reg) && (reg <? 32))%bool then map.put regs reg v else regs.

  Definition run_primitive(a: riscv_primitive)(mach: State):
             (primitive_result a -> State -> Prop) -> (State -> Prop) -> Prop :=
    match a with
    | GetRegister reg => fun postF postA => postF (getReg mach.(regs) reg) mach
    | SetRegister reg v => fun postF postA => postF tt { mach with regs ::= setReg reg v }
    | GetPC => fun postF postA => postF mach.(pc) mach
    | SetPC newPC => fun postF postA => postF tt { mach with nextPc := newPC }
    | LoadByte ctxid a => fun postF postA => load 1 ctxid a mach postF
    | LoadHalf ctxid a => fun postF postA => load 2 ctxid a mach postF
    | LoadWord ctxid a => fun postF postA => load 4 ctxid a mach postF
    | LoadDouble ctxid a => fun postF postA => load 8 ctxid a mach postF
    | StoreByte ctxid a v => fun postF postA => store 1 ctxid a v mach (postF tt)
    | StoreHalf ctxid a v => fun postF postA => store 2 ctxid a v mach (postF tt)
    | StoreWord ctxid a v => fun postF postA => store 4 ctxid a v mach (postF tt)
    | StoreDouble ctxid a v => fun postF postA => store 8 ctxid a v mach (postF tt)
    | StartCycle => fun postF postA =>
        postF tt { mach with nextPc := word.add mach.(pc) (word.of_Z 4) }
    | EndCycleNormal => fun postF postA => postF tt (updatePc mach)
    | EndCycleEarly _ => fun postF postA => postA (updatePc mach) (* ignores postF containing the continuation *)
    | GetCSRField f => fun postF postA =>
                         match map.get mach.(csrs) f with
                         | Some v => postF v mach
                         | None => False
                         end
    | SetCSRField f v => fun postF postA =>
                           (* only allow setting CSR fields that are supported (not None) on this machine *)
                           match map.get mach.(csrs) f with
                           | Some _ => postF tt { mach with csrs ::= map.set f v }
                           | None => False
                           end
    | GetPrivMode => fun postF postA => postF Machine mach
    | SetPrivMode mode => fun postF postA =>
                            match mode with
                            | Machine => postF tt mach
                            | User | Supervisor => False
                            end
    | MakeReservation _
    | ClearReservation _
    | CheckReservation _
    | Fence _ _
        => fun postF postA => False
    end.

  Lemma weaken_load: forall n c a m (post1 post2:_->_->Prop),
      (forall r s, post1 r s -> post2 r s) ->
      load n c a m post1 -> load n c a m post2.
  Proof.
    unfold load. intros. destruct (load_bytes n m.(mem) a); intuition eauto.
  Qed.

  Lemma weaken_store: forall n c a v m (post1 post2:_->Prop),
      (forall s, post1 s -> post2 s) ->
      store n c a v m post1 -> store n c a v m post2.
  Proof.
    unfold store. intros. destruct (store_bytes n m.(mem) a v); intuition eauto.
  Qed.

  Lemma weaken_run_primitive: forall a (postF1 postF2: _ -> _ -> Prop) (postA1 postA2: _ -> Prop),
    (forall r s, postF1 r s -> postF2 r s) ->
    (forall s, postA1 s -> postA2 s) ->
    forall s, run_primitive a s postF1 postA1 -> run_primitive a s postF2 postA2.
  Proof.
    destruct a; cbn; intros; try solve [intuition eauto using weaken_load, weaken_store];
      destruct_one_match; eauto.
  Qed.

End Riscv.