Require Import QArith.QArith_base.
Require Import QArith.Qabs.
Require Import QArith.Qpower.
Require Import QArith.Qround.
Require Import ZArith.Znat.
Require Import Psatz.
Require Import Init.Nat.
Require Import Omega.
Require Extraction.

Module Type Sig.

Parameter R : Type.
Parameter Rzero : R.
Parameter Rone : R.
Parameter Req : R -> R -> Prop.
Parameter Rlt : R -> R -> Prop.
Parameter Radd : R -> R -> R.
Parameter Radd_inv : R -> R.
Parameter Rmult : R -> R -> R.
Parameter Rmult_inv  : R -> R.
(*Req is an equivalence relation.*)
Axiom Req_refl : forall (r:R), Req r r.
Axiom Req_trans : forall (r1 r2 r3:R), Req r1 r2 -> Req r2 r3 -> Req r1 r3.
Axiom Req_symm : forall (r1 r2:R), Req r1 r2 -> Req r2 r1.

(*Radd,Radd_inv,Req forms a commutative group*)
Axiom Radd_commutative : forall (r1 r2:R), Req (Radd r1 r2) (Radd r2 r1).
Axiom Radd_associative : forall (r1 r2 r3:R), Req (Radd r1 (Radd r2 r3)) (Radd (Radd r1 r2) r3).
Axiom Radd_inv_compat  : forall (r:R), Req (Radd r (Radd_inv r)) Rzero.

(*Rmult,Rmult_inv form commutative semigroup*)
Axiom Rmult_commutative : forall (r1 r2:R), Req (Rmult r1 r2) (Rmult r2 r1).
Axiom Rmult_associative : forall (r1 r2 r3:R), Req (Rmult r1 (Rmult r2 r3)) (Rmult (Rmult r1 r2) r3).
Axiom Rmult_inv_compat : forall r, (not (Req r Rzero)) -> Req (Rmult r (Rmult_inv r)) Rone.

(*Radd,Rmult,Radd_inv,Rmult_inv,Req form field*)

Axiom Rmult_distributes_Radd : forall (a b c:R), Req (Rmult (Radd a b) c) (Radd (Rmult a c) (Rmult b c)).

End Sig.

Definition Cauchy (F:Q->Q) := forall err err1 err2, err>0 -> err1>0 -> err2>0 ->
          err1<err -> err2<err ->
          ((Qabs ((F err1) - (F err2))) < err).

Definition R := { F:Q->Q | Cauchy F}.

Lemma Qabs_extensional : forall q1 q2, q1==q2 -> Qabs q1 == Qabs q2.
Proof.
intros.
destruct q1. destruct q2.
unfold Qabs. unfold Z.abs.
destruct Qnum, Qnum0.
* lra.
* auto.
* assert( not (0 # Qden == Z.neg p # Qden0) ).
** unfold Qeq. assert( (Qnum (0 # Qden) = 0)%Z ) by auto with *.
   rewrite H. auto with *.
** contradiction.
* auto.
* auto.
* assert( not (Zpos p # Qden == Z.neg p0 # Qden0) ).
** unfold Qeq. auto with *.
** contradiction.
* assert( not (Z.neg p # Qden == 0 # Qden0) ).
** unfold Qeq. auto with *.
** contradiction.
* assert( not ( Z.neg p # Qden == ' p0 # Qden0) ).
** unfold Qeq. auto with *.
** contradiction.
* unfold Qeq. unfold Qeq in H. simpl. simpl in H.
  assert ( (p*Qden0 = p0*Qden)%positive ).
** nia.
** rewrite H0. auto with *.

Qed.

Definition injectQ (q:Q) : R.
Proof.
unfold R.
exists (fun err =>q ).
unfold Cauchy.
intros.
assert( Qabs(q-q) == Qabs(0) ).
{
  apply Qabs_extensional. lra.
}
rewrite H4.
simpl.
lra.
Defined.

Definition oneR := injectQ 1.
Definition zeroR := injectQ 0.
Definition twoR := injectQ (1+1).

Definition Rplus (r1:R) (r2:R) : R.
Proof.
apply (Rmake (fun q => (F r1) (q*(1#2)) + (F r2) (q*(1#2)))).
intros.
remember (F r1 (err1 * (1 # 2))) as x.
remember (F r2 (err1 * (1 # 2))) as y.
remember (F r1 (err2 * (1 # 2))) as z.
remember (F r2 (err2 * (1 # 2))) as u.
assert( Qabs( x + y - (z+u) ) == Qabs((x-z) + (y-u)) ).
{
  apply (Qabs_extensional).
  field.
}
rewrite H4.
assert( Qabs (x-z +y-u) <= Qabs (x-z) + Qabs(y-u) ).
{
  assert( Qabs (x-z+y-u) == Qabs( (x-z) + (y-u) )).
  {
    apply Qabs_extensional. field.
  }
  rewrite H5.
  apply Qabs_triangle.
}
assert( Qabs (x-z) < err * (1#2) ).
{
  rewrite Heqx. rewrite Heqz.
  apply ((Cauchy r1) (err*(1#2)) (err1*(1#2)) (err2*(1#2))).
  * lra.
  * lra.
  * lra.
  * lra.
  * lra.
}
assert( Qabs (y-u) < err*(1#2) ).
{
  rewrite Heqy. rewrite Hequ.
  apply ((Cauchy r2) (err*(1#2)) (err1*(1#2)) (err2*(1#2))).
  * lra.
  * lra.
  * lra.
  * lra.
  * lra.
}
assert( (Qabs (x - z) + Qabs (y - u)) < err ) by lra.
assert( Qabs (x - z + y - u) == Qabs( x - z + (y-u) )).
{
  apply Qabs_extensional.
  field.
}
rewrite H9 in H5.
lra.
Defined.

Definition Req (r1 r2 : R):= {c | forall q, q>0 -> Qabs( (F r1) q - (F r2) q) < c*q}.

Theorem z_not_eq_1 : (Req zeroR oneR) -> False.

Theorem req_works : Req oneR oneR.
Proof.
unfold Req.
exists 1.
intros.
unfold oneR.
simpl.
lra.
Qed.

Theorem req_refl : forall (r:R), Req r r.
Proof.
intros.
unfold Req.
exists 1.
intros.
remember (F r q) as z.
assert(Qabs (z-z)==Qabs 0).
{
  assert((z-z)==0) by field.
  apply (Qabs_extensional (z-z)). auto.
}
rewrite H0.
simpl. lra.
Qed.

Theorem req_trans : forall (r1 r2 r3:R), Req r1 r2 -> Req r2 r3 -> Req r1 r3.
Proof.
intros.
unfold Req in H.
unfold Req in H0.
destruct H.
destruct H0.
unfold Req.
exists (x+x0).
intros.
remember (F r1 q1) as z1.
remember (F r3 q1) as z3.
remember (F r2 q1) as z2.
assert( Qabs(z1 - z3) == Qabs( (z1 - z2) + (z2 - z3) ) ).
{
  apply Qabs_extensional.
  field.
}
rewrite H0.
assert( Qabs (z1-z2 + (z2-z3)) <= Qabs (z1-z2) + Qabs (z2-z3) ) by apply Qabs_triangle.
assert(Qabs(z1-z2) < x * q1).
{
  rewrite Heqz1.
  rewrite Heqz2.
  apply (q q1 H).
}
assert(Qabs(z2-z3) < x0*q1).
{
  rewrite Heqz2. rewrite Heqz3.
  apply (q0 q1 H).
}
assert( Qabs (z1 - z2) + Qabs (z2 - z3) < (x+x0)*q1 ) by lra.
lra.
Qed.

Theorem req_symm : forall (r1 r2 : R), Req r1 r2 -> Req r2 r1.
Proof.
intros.
unfold Req.
unfold Req in H.
destruct H.
exists x.
intros.
remember (F r1 q0) as z1.
remember (F r2 q0) as z2.
assert( Qabs(z2 - z1) == Qabs (z1 - z2) ).
{
  assert(Qabs (z2-z1) == Qabs ( -(z1-z2) ) ).
  {
    apply Qabs_extensional. field.
  }
  rewrite H0.
  apply Qabs_opp.
}
rewrite H0.
rewrite Heqz1.
rewrite Heqz2.
apply (q q0 H).
Qed.

Theorem rplus_req_compat : forall (r1 r2 : R), Req (Rplus r1 r2) (Rplus r2 r1).
Proof.
intros.
unfold Req.
exists 1.
intros.
unfold Rplus. simpl. remember (q*(1#2)) as p.
remember (Qnum (F r1 p)) as z1.
remember (Zpos (Qden (F r2 p))) as z2.
remember (Qnum (F r2 p)) as z3.
remember (Zpos (Qden (F r1 p))) as z4.
remember (Zpos (Qden (F r2 p))) as z5.
assert( (' (Qden (F r2 p) * Qden (F r1 p)) = z4*z5)%Z ).
{
  nia.
}
rewrite H0.
assert( (Zpos (Qden (F r1 p) * Qden (F r2 p)) = z4*z5)%Z ).
{
  nia.
}
rewrite H1.
assert( (((z1 * z2 + z3 * z4) * (z4 * z5) +
   - (z3 * z4 + z1 * z2) * (z4 * z5)) = 0)%Z ) by nia.
rewrite H2.
simpl.
assert( 0
# Qden (F r1 p) * Qden (F r2 p) *
  (Qden (F r2 p) * Qden (F r1 p)) == 0).
{
  unfold Qeq. simpl. auto.
}
rewrite H3.
lra.

Qed.

Definition Rmult (r1 r2:R) : R.
Proof.
apply (Rmake (fun q => (F r1 q)*(F r2 q) ) ).
intros.
remember (F r1 err1) as z11.
remember (F r2 err1) as z21.
remember (F r1 err2) as z12.
remember (F r2 err2) as z22.
Admitted.

Module ConReal <: Sig.
Definition R:= R.
End ConReal.

Eval vm_compute in (F (Rplus oneR oneR)).


Inductive bool : Type :=
| true
| false.

Definition negb (b: bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1: bool) (b2: bool): bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1: bool) (b2: bool): bool :=
  match b1 with
  | true => true
  | false => b2
end.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require real.Real.
Require real.RealInfix.

Parameter pow2: Z -> R.

Axiom Power_0 : ((pow2 0%Z) = 1%R).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_s_all : forall (n:Z), ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (Rdiv 1%R 2%R)%R).

Axiom Power_1 : ((pow2 1%Z) = 2%R).

Axiom Power_neg1 : ((pow2 (-1%Z)%Z) = (05 / 10)%R).

Axiom Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z -> ~ ((pow2 n) = 0%R).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 2.
Open Scope Z_scope.

(* Why3 goal *)
Theorem Power_neg_aux : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (-n)%Z) = (Rdiv 1%R (pow2 n))%R).
intros n Hn.
generalize Hn.
pattern n; apply Z_lt_induction; auto.
clear n Hn.
intros n Hind Hn.
assert (h:n=0\/n>0) by omega; destruct h.
ae.
replace n with (n-1+1) by omega.
replace (- (n - 1 + 1)) with (-(n-1) -1)  by omega.
rewrite Power_p;auto with zarith.
rewrite Power_s;auto with zarith.
ae.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* A Coq computable reduction from n-registers MM termination
    to 2-registers MMA termination. Beware that the semantics
    of MMA is a bit different than the semantics of MM:

       the DEC instruction jumps when not zero instead of when zero

    Compare mm_sss  (MinskyMachines/mm_defs.v)
    and     mma_sss (MinskyMachines/mma_defs.v)

    The reduction goes via regular FRACTRAN termination *)

Require Import Undecidability.Synthetic.Definitions.

From Undecidability.Shared.Libs.DLW Require Import pos vec sss.

From Undecidability.FRACTRAN Require Import FRACTRAN FRACTRAN_sss.
From Undecidability.MinskyMachines Require Import mma_defs fractran_mma.

Set Implicit Arguments.

Local Notation "P //ₐ s ↓" := (sss_terminates (@mma_sss 2) P s) (at level 70, no associativity).

Section FRACTRAN_REG_MMA2_and_ON_ZERO.

  Let f : FRACTRAN_REG_PROBLEM -> MMA2_PROBLEM.
  Proof.
    intros (Q & x & _).
    exact (fractran_mma0 Q,x##0##vec_nil).
  Defined.

  Theorem FRACTRAN_REG_MMA2_HALTING : FRACTRAN_REG_HALTING ⪯ MMA2_HALTING.
  Proof.
    exists f; intros (? & ? & ?); simpl.
    now apply fractran_reg_mma0_reductions.
  Qed.

  Theorem FRACTRAN_REG_MMA2_HALTS_ON_ZERO : FRACTRAN_REG_HALTING ⪯ MMA2_HALTS_ON_ZERO.
  Proof.
    exists f; intros (? & ? & ?); simpl.
    now apply fractran_reg_mma0_reductions.
  Qed.

End FRACTRAN_REG_MMA2_and_ON_ZERO.

Check FRACTRAN_REG_MMA2_HALTING.
Check FRACTRAN_REG_MMA2_HALTS_ON_ZERO.


(* (c) Copyright ? *)

(*****************************************************************************
  Verification of formula deductions in paper "Exact-Wiberg Algorithm for
  Matrix Factorization with Missing Data" (ECCV 2014 submission)

  Main definitions:
        C :  ringType. Type of constants.
        E :  unitComAlgType C. Type of variables and matrix elements.
        D :  comBimodType E. The co-domain of differentiation operator.
       \d :  {linearDer E -> D}. The differentiation operator (derivation)
             on elements.
      \\d :  Matrix differentiation, which is just element-wise
             differentiation.
    m n r :  non-zero natural numbers
      W M :  'M[E]_(m,n). The weight and target matrix in the matrix
             decomposition problem. They are lifted from 'M[C]_(m,n),
             so they are constant.
        U :  'M[E]_(m,r)
        v :  C
       ~W == diag_mx (vec W)^T
       \m == vec M
       ~U == I *ol U
     eps1 == ~W *m \m - ~W *m ~U *m (~W *m ~U)^-v *m ~W *m \m
        H == I - ~W *m ~U *m (~W *m ~U)^-v
       V* == (cvec_mx ((~W *m ~U)^-v *m ~W *m \m))^T
    R == W .* (M - U *m V*^T)
      ~V* == V* *o I
        T == trT _ _ _. The permutation matrix for transposing.
       v* == (~W *m ~U)^-v *m ~W *m \m
      ~WR == (W .* R) *o I
      A^+ == A^-0
       J1 == -(H *m ~W *m ~V* + ((~W *m ~U)^-v)^T *m ((W .* R)^T *o I) *m T)
             The Jacobian matrix of eps1
       J2 == 0 - (~W *m ~U)^-v *m ~W *m (V* *o I) +
             ((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m
             ((W .* R)^T *o I) *m T.
             The Jacobian matrix of v*

  Main results:
    vec_dot : forall V,
      vec (W .* (M - U *m V^T)) = ~W *m \m - ~W *m ~U *m vec V^T
      Corresponds to Equation (10)~(13)

    d_eps1_part1 :
      \\d eps1 = 0 - H *m ~W *ml (I *ol \\d U) *mr ((~W *m ~U)^-v *m ~W *m \m) -
                ((~W *m ~U)^-v)^T *ml (I *ol (\\d U)^T) *mr (~W^T *m H *m ~W *m \m)
      Corresponds to Equation (20)~(26)

    to_vec_dot :
      ~W^T *m H *m ~W *m \m = vec (W .* R)
      Corresponds to Equation (28)~(31)

    d_eps1 :
      \\d eps1 = -(H *m ~W *m ~V* + ((~W *m ~U)^-v)^T *m ((W .* R)^T *o I) *m T)
                 *ml \\d (vec U)
      Corresponds to Equation (32)~(34)

    d_vstar_part1 :
      \\d v* = 0 - (~W *m ~U)^-v *m ~W *ml (I *ol \\d U) *mr
               ((~W *m ~U)^-v *m ~W *m \m) +
               ((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *ml
               (I *ol \\d U)^T *mr (~W^T *m (I - (~W *m ~U) *m (~W *m ~U)^-v)
               *m ~W *m \m)
      Corresponds to Equation (36)~(40)

    d_vstar_part2 :
      \\d v* = (0 - (~W *m ~U)^-v *m ~W *m (V* *o I) + ((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m ((W .* R)^T *o I) *m T) *ml vec (\\d U)
      Corresponds to Equation (40')~(48)

    J2_simpl :
      J2 = 0 - ((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m ((I *o U^T)*m ~W^T *m ~W *m (V* *o I) - ((W .* R)^T *o I) *m T)
      Corresponds to Equation (49)~(52)

    d_vstar :
      \\d v* = - (((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m ((I *o U^T)*m ~W^T *m ~W *m (V* *o I) - ((W .* R)^T *o I) *m T)) *ml \\d (vec U)
      direct corollary from d_vstar_part2 and J2_simpl

    J1_J1 :
      J1^T *m J1 = ~V*^T *m ~W^T *m H *m ~W *m ~V* + T^T *m ~WR *m ((~W *m ~U)^T *m (~W *m ~U))^^-1 *m ~WR^T *m T
      Corresponds to Equation (54)~(56)

    J1_eps1 :
      -J1^T *m eps1 = ~V*^T *m ~W^T *m H *m ~W *m \m
      Corresponds to Equation (57)~(58)

    d_eps1_UV :
      \\d eps1_UV = 0 - ~W *m ~U *ml \\d (vec V^T) - ~W *m (V *o I) *ml \\d (vec U)
      Corresponds to Equation (60)~(62) where
        V : 'M[E]_(n, r)
        eps1_UV == vec (W .* (M - U *m V^T))

  When instantiate the previous results with the following instantiation:
        p == r * m. The number of free variables (which is also the
             number of elements of U).
        E :  funType p C. Single-value functions on C with up-to p arity.
             The vector of the p free variables are denoted as \x.
       \d :  {gradient E}. A gradient operator on E. This is where
             the Jacobian matrix is defined.
        U == cvec_mx \x.
             (vec U) is the basis vector of the free variables, with
             regard to which we want to compute the Jacobian matrices.
       \J == Jacob \d. The Jacobian matrix operator from \d.

  With this instantiation, we then have the following results:
    J_eps1 :
      \J eps1 = -(H *m ~W *m ~V* + ((~W *m ~U)^-v)^T *m ((W .* R)^T *o I) *m T)

    J_vstar :
      \J v* = -(((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m
              ((I *o U^T)*m ~W^T *m ~W *m (V* *o I) - ((W .* R)^T *o I) *m T))

  All results are under the assumption: invertible (mupinv_core v (~W *m ~U)).
  Sometimes I write (0 - a *m b) instead of (- a *m b) because the unary minus
  sign binds tighter than *m, which I find counter-intuitive.

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

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

Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq choice fintype.
Require Import finfun bigop prime binomial.

Require Import matrix.
Require Import ssralg.
Import GRing.Theory.
Open Local Scope ring_scope.

Require Import bimodule.
Require Import derivation.
Require Import mxutil.
Import Notations.
Require Import mxmodule.
Import Notations.
Require Import mxdiff.
Import Notations.
Require Import example_appendix.
Import Notations.

Section Section3.

(* Constants *)
Variable C : ringType.
(* Variables and matrix elements *)
Variable E : unitComAlgType C.
(* Co-domain of differentiation operator *)
Variable D : comBimodType E.
Variable der : {linearDer E -> D}.
Notation "\d" := (LinearDer.apply der).
Notation "\\d" := (map_mx \d).

(* All dimensions are non-zero. All matrices are non-empty. *)
Variable m' n' r' : nat.
Local Notation m := m'.+1.
Local Notation n := n'.+1.
Local Notation r := r'.+1.

(* W : weight matrix
   M : target matrix
   They are constant matrices, and are lifted to participate in matrix operations.
*)
Variable cW cM : 'M[C]_(m, n).
Notation W := (lift cW).
Notation M := (lift cM).
Variable U : 'M[E]_(m, r).
Notation "~W" := (diag_mx (vec W)^T).
Notation "\m" := (vec M).
Notation "~U" := (I *o U).
(* Regularization rate *)
Variable v : C.
Notation eps1 := (~W *m \m - ~W *m ~U *m (~W *m ~U)^-v *m ~W *m \m).
Notation H := (I - ~W *m ~U *m (~W *m ~U)^-v).
Notation "V*" := ((cvec_mx ((~W *m ~U)^-v *m ~W *m \m))^T).
Notation R := (W .* (M - U *m V*^T)).
Notation "~V*" := (V* *o I).
(* The permutation matrix for transposing *)
Notation T := (trT _ _ _).
Notation "v*" := ((~W *m ~U)^-v *m ~W *m \m).
Notation J2 := (0 - (~W *m ~U)^-v *m ~W *m (V* *o I) + ((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m ((W .* R)^T *o I) *m T).
Notation J1 := (-(H *m ~W *m ~V* + ((~W *m ~U)^-v)^T *m ((W .* R)^T *o I) *m T)).
Notation "~WR" := ((W .* R) *o I).

Hypothesis h_invertible : invertible (mupinv_core v (~W *m ~U)).

(* Corresponds to Equation (10)~(13) *)
Lemma vec_dot V : vec (W .* (M - U *m V^T)) = ~W *m \m - ~W *m ~U *m vec V^T.
Proof.
  set goal := RHS.
  rewrite vec_elemprod.
  rewrite !raddfB /=.
  by rewrite vec_kron !mulmxA.
Qed.

Lemma dmmr {p} (A : 'M[E]_(p, _)) : \\d (A *m \m) = \\d A *mr \m.
Proof.
  by rewrite -!lift_vec !dmcr.
Qed.

Lemma dmWr {p} (A : 'M[E]_(p, _)) : \\d (A *m ~W) = \\d A *mr ~W.
Proof.
  by rewrite -!lift_vec map_trmx -map_diag_mx !dmcr.
Qed.

Lemma dmWl {p} (A : 'M[E]_(_, p)) : \\d (~W *m A) = ~W *ml \\d A.
Proof.
  by rewrite -!lift_vec map_trmx -map_diag_mx !dmcl.
Qed.

(* Corresponds to Equation (20)~(26) *)
Lemma d_eps1_part1 : \\d eps1 = 0 - H *m ~W *ml (I *ol \\d U) *mr ((~W *m ~U)^-v *m ~W *m \m) - ((~W *m ~U)^-v)^T *ml (I *ol (\\d U)^T) *mr (~W^T *m H *m ~W *m \m).
Proof.
  set goal := RHS.
  rewrite raddfB /= -(mul1mx (~W *m \m)) !mulmxA !dmmr !dmWr dmI !rmul0mx.
  rewrite (dm_AmupinvA _ h_invertible). (* (22) *)
  rewrite dmWl (dm_lkron1mx _ _ U) !lmulmxA /=. (* (25) *)
  by rewrite /sym [in _^T + _]addrC !trmx_rmulmx !trmx_lmulmx !trmx_mul /= (trmx_lkron I (\\d U)) raddfB /= AmupinvA_sym !trmx1 !rmulmxDl opprD addrA !lrmulmxA !rmulmxA -!rmulmxA !mulmxA.
Qed.

Lemma to_Vstar : (~W *m ~U)^-v *m ~W *m \m = vec V*^T.
Proof.
  by rewrite (trmxK V*) cvec_mxK.
Qed.

(* Corresponds to Equation (28)~(31) *)
Lemma to_vec_dot : ~W^T *m H *m ~W *m \m = vec (W .* R).
Proof.
  set goal := RHS.
  rewrite mulmxBr !mulmxBl !mulmxA mulmx1.
  rewrite -(mulmxA _ _ ~W) -(mulmxA _ (_ *m _) \m) to_Vstar.
  rewrite -!mulmxA -mulmxBr !mulmxA -vec_dot.
  by rewrite tr_diag_mx -vec_elemprod.
Qed.

(* Corresponds to Equation (32)~(34) *)
Lemma d_eps1 : \\d eps1 = -(H *m ~W *m ~V* + ((~W *m ~U)^-v)^T *m ((W .* R)^T *o I) *m T) *ml \\d (vec U).
Proof.
  set goal := RHS.
  rewrite d_eps1_part1 to_vec_dot {1}to_Vstar.
  by rewrite -!lrmulmxA !lkron_shift (trmxK V*) !lmulmxA -trTPcrmul !lmulmxA sub0r -opprD -!(lmulmxDl _ _ (vec (\\d U))) -(map_vec _ U) -(lmulNmx _ (\\d _)).
Qed.

Lemma dmWTr {p} (A : 'M[E]_(p, _)) : \\d (A *m ~W^T) = \\d A *mr ~W^T.
Proof.
  by rewrite -!lift_vec map_trmx -map_diag_mx  map_trmx !dmcr.
Qed.

(* Corresponds to Equation (36)~(40) *)
Lemma d_vstar_part1 : \\d v* = 0 - (~W *m ~U)^-v *m ~W *ml (I *ol \\d U) *mr ((~W *m ~U)^-v *m ~W *m \m) + ((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *ml (I *ol \\d U)^T *mr (~W^T *m (I - (~W *m ~U) *m (~W *m ~U)^-v) *m ~W *m \m).
Proof.
  set goal := RHS.
  rewrite dmmr dmWr.
  rewrite (dm_mupinv _ h_invertible) 2!rmulmxDl 2!rmulmxBl !rmul0mx.
  by rewrite (map_trmx \d) trmx_mul dmWl dmWTr -(map_trmx \d) !(dm_lkron1mx _ _ U) /= !lrmulmxA !lmulmxA -!rmulmxA !mulmxA -trmx_mul -[in _^T *m _ *m _]mulmxA.
Qed.

(* Corresponds to Equation (40')~(48) *)
Lemma d_vstar_part2 : \\d v* = (0 - (~W *m ~U)^-v *m ~W *m (V* *o I) + ((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m ((W .* R)^T *o I) *m T) *ml vec (\\d U).
Proof.
  set goal := RHS.
  rewrite d_vstar_part1 trmx_lkron trmx1.
  rewrite to_Vstar to_vec_dot.
  rewrite -!lrmulmxA !lkron_shift (trmxK V*) !lmulmxA.
  by rewrite -trTPcrmul !lmulmxA sub0r addrC -!(lmulmxBl _ _ (vec (\\d U))) addrC -sub0r.
Qed.

(* Corresponds to Equation (49)~(52) *)
Lemma J2_simpl : J2 = 0 - ((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m ((I *o U^T)*m ~W^T *m ~W *m (V* *o I) - ((W .* R)^T *o I) *m T).
Proof.
  set goal := RHS.
  rewrite -{1}fold_mupinv sub0r addrC -opprB -!(mulmxA _^^-1) -mulmxBr.
  by rewrite [in _ - _]trmx_mul [in ~U^T]trmx_kron trmx1 -sub0r.
Qed.

Lemma d_vstar : \\d v* = - (((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m ((I *o U^T)*m ~W^T *m ~W *m (V* *o I) - ((W .* R)^T *o I) *m T)) *ml \\d (vec U).
Proof.
  set goal := RHS.
  by rewrite d_vstar_part2 J2_simpl sub0r -(map_vec _ U).
Qed.

Hypothesis v_0 : v = 0.

Notation "A ^+" := (A^-0) (at level 3, format "A ^+").

Lemma mulpinvmx m n (A : 'M[E]_(m,n)) : invertible (mupinv_core 0 A) -> A^+ *m A = I.
Proof.
  rewrite unlock /mupinv /mupinv_core lscale0mx addr0.
  by move => h; rewrite -(mulmxA _^^-1) mulVmx.
Qed.

Lemma pinv_pinv m n (A : 'M[E]_(m,n)) : invertible (mupinv_core 0 A) -> A^+ *m A^+^T = (A^T *m A)^^-1.
Proof.
  move => h.
  by rewrite [in _^+^T]unlock /mupinv /mupinv_core /= lscale0mx addr0 !trmx_mul !trmxK !mulmxA (mulpinvmx h) mul1mx trmx_inv !trmx_mul !trmxK.
Qed.

Lemma pinvWU_WU : (~W *m ~U)^+ *m ~W *m ~U = I.
Proof.
  move: h_invertible; rewrite v_0 => h.
  by rewrite -mulmxA (mulpinvmx h).
Qed.

Lemma WU_H_0 : (~W *m ~U)^+ *m H = 0.
Proof.
  by rewrite mulmxBr mulmx1 !mulmxA pinvWU_WU mul1mx v_0 addrN.
Qed.

Lemma trmx_kronmx1 (R : comRingType) m1 n1 m2 (A : 'M[R]_(m1,n1)) : (A *o I)^T = A^T *o (I : 'M_m2).
Proof. by rewrite trmx_kron trmx1. Qed.

Lemma J1_simpl : J1 = -(H *m ~W *m ~V* + ((~W *m ~U)^+)^T *m ~WR^T *m T).
Proof.
  set goal := RHS.
  by rewrite [in (_^-v)^T]v_0 -[in (W .* R)^T *o _]trmx_kronmx1.
Qed.

Lemma H_H : H^T *m H = H.
Proof.
  by rewrite !raddfB /= AmupinvA_sym !trmx1 mulmx1 mulmxBl mul1mx -!mulmxA ![in _^-v *m _]mulmxA v_0 pinvWU_WU !mulmxA !mulmx1 addrN subr0.
Qed.

Lemma pinvWU_pinvWU : (~W *m ~U)^+ *m (~W *m ~U)^+^T = ((~W *m ~U)^T *m (~W *m ~U))^^-1.
Proof.
  move: h_invertible; rewrite v_0 => h.
  by rewrite (pinv_pinv h).
Qed.

(* This notation works better with Latex *)
Notation "{( A )^+}" := (A^-0) (at level 3).

(* Corresponds to Equation (54)~(56) *)
Lemma J1_J1 : J1^T *m J1 = ~V*^T *m ~W^T *m H *m ~W *m ~V* + T^T *m ~WR *m ((~W *m ~U)^T *m (~W *m ~U))^^-1 *m ~WR^T *m T.
Proof.
  set goal := RHS.
  rewrite J1_simpl [in _^T] raddfN /= mulNmx mulmxN opprK [in _^T] raddfD /= !trmx_mul (trmxK ~WR) (trmxK _^+) [_ *m (_ + _)]mulmxDl mulmxDr mulmxDr !mulmxA !addrA.
  rewrite -!(mulmxA _ _ H) WU_H_0 -!(mulmxA _ _ _^+^T) -[H^T *m _^+^T]trmx_mul WU_H_0 !mulmxA trmx0 !mulmx0 !mul0mx !addr0.
  by rewrite -!(mulmxA _ _ H) H_H -(mulmxA _ _ _^+^T) pinvWU_pinvWU.
Qed.

(* Corresponds to Equation (57)~(58) *)
Lemma J1_eps1 : -J1^T *m eps1 = ~V*^T *m ~W^T *m H *m ~W *m \m.
Proof.
  set goal := RHS.
  rewrite -mulmxBl -mulmx1Bl J1_simpl raddfN /= opprK raddfD /= !trmx_mul (trmxK ~WR) (trmxK _^+) !mulmxA !mulmxDl.
  by rewrite -!(mulmxA _ _ H) H_H -!(mulmxA _ _ H) WU_H_0 !mulmx0 !mul0mx !addr0 !mulmxA.
Qed.

Variable V : 'M[E]_(n, r).
Notation eps1_UV := (vec (W .* (M - U *m V^T))).

(* Corresponds to Equation (60)~(62) *)
Lemma d_eps1_UV : \\d eps1_UV = 0 - ~W *m ~U *ml \\d (vec V^T) - ~W *m (V *o I) *ml \\d (vec U).
Proof.
  set goal := RHS.
  rewrite vec_elemprod !raddfB /= -(mul1mx (~W *m \m)) !mulmxA !dmmr !dmWr dmI !rmul0mx dmWl.
  by rewrite vec_kron dmM /= (dm_lkron1mx _ _ U) /= lkron_shift [in _ *o _](trmxK V) -(map_vec _ U) lmulmxDr !lmulmxA [in _ *ml _ + _]addrC opprD addrA.
Qed.

End Section3.

Require Import nfun.

Section Jacobian.

(* All dimensions are non-zero. All matrices are non-empty. *)
Variable m' n' r' : nat.
Notation m := m'.+1.
Notation n := n'.+1.
Notation r := r'.+1.
(* The number of free variables, which is the number of elements of U *)
Notation p := (r * m)%nat.

Variable C : ringType.
Variable E : funType p C.
Variable d : {gradient E}.
Notation "\d" := (Gradient.apply d).
Notation "\\d" := (map_mx \d).

Variable cW cM : 'M[C]_(m, n).
Notation W := (lift cW).
Notation M := (lift cM).
(* (vec U) is the basis vector of the free variables *)
Definition  U : 'M[E]_(m, r) := cvec_mx \x.
Notation "~W" := (diag_mx (vec W)^T).
Notation "\m" := (vec M).
Notation "~U" := (I *o U).
Variable v : C.
Notation eps1 := (~W *m \m - ~W *m ~U *m (~W *m ~U)^-v *m ~W *m \m).
Notation H := (I - ~W *m ~U *m (~W *m ~U)^-v).
Hypothesis h_invertible : invertible (mupinv_core v (~W *m ~U)).
Notation "V*" := ((cvec_mx ((~W *m ~U)^-v *m ~W *m \m))^T).
Notation R := (W .* (M - U *m V*^T)).
Notation "~V*" := (V* *o I).
Notation T := (trT _ _ _).

Notation "\J" := (Jacob \d).

Lemma J_eps1 : \J eps1 = -(H *m ~W *m ~V* + ((~W *m ~U)^-v)^T *m ((W .* R)^T *o I) *m T).
Proof.
  by apply jacob_intro; rewrite (d_eps1 _ _ h_invertible) cvec_mxK.
Qed.

Notation "v*" := ((~W *m ~U)^-v *m ~W *m \m).

Lemma J_vstar : \J v* = -(((~W *m ~U)^T *m (~W *m ~U) + v *ml: I)^^-1 *m ((I *o U^T)*m ~W^T *m ~W *m (V* *o I) - ((W .* R)^T *o I) *m T)).
Proof.
  by apply jacob_intro; rewrite (d_vstar _ _ h_invertible) cvec_mxK.
Qed.

End Jacobian.

Section Section4.

(* All dimensions are non-zero. All matrices are non-empty. *)
Variable m' n' r' : nat.
Notation m := m'.+1.
Notation n := n'.+1.
Notation r := r'.+1.
(* The number of free variables, which is the number of elements of U and V *)
Notation p := (r * m + n * r)%nat.

Variable C : ringType.
Variable E : funType p C.
Variable d : {gradient E}.
Notation "\d" := (Gradient.apply d).
Notation "\\d" := (map_mx \d).

Variable cW cM : 'M[C]_(m, n).
Notation W := (lift cW).
Notation M := (lift cM).
Variable U : 'M[E]_(m, r).
Variable V : 'M[E]_(n, r).
(* Now both U and V are the free variables *)
Hypothesis UV_x : col_mx (vec U) (vec V^T) = \x.
Notation "~W" := (diag_mx (vec W)^T).
Notation "~U" := (I *o U).
Notation "~V" := (V *o I).
Notation eps := (vec (W .* (M - U *m V^T))).
Notation H a := (I - ~W *m ~U *m (~W *m ~U)^-a).
Notation "\J" := (Jacob \d).

Lemma J_eps : \J eps = - row_mx (~W *m ~V) (~W *m ~U).
Proof.
  apply jacob_intro.
  rewrite -UV_x d_eps1_UV /=.
  symmetry; set goal := RHS.
  by rewrite map_col_mx lmulNmx lmul_row_col addrC opprD -sub0r.
Qed.

Variable lambda : C.
Notation J := (\J eps).
Variable delta : 'cV[E]_p.
Hypothesis Levenberg : (J^T *m J + lambda *ml: I) *m delta = -J^T *m eps.
Variable dU : 'M[E]_(m, r).
Variable dV : 'M[E]_(n, r).
Hypothesis UV_delta : col_mx (vec dU) (vec dV^T) = delta.

Lemma JT_J_I : J^T *m J + lambda *ml: I = block_mx (~V^T *m ~W^T *m ~W *m ~V + lambda *ml: I) (~V^T *m ~W^T *m ~W *m ~U) (~U^T *m ~W^T *m ~W *m ~V) (~U^T *m ~W^T *m ~W *m ~U + lambda *ml: I).
Proof.
  set goal := RHS.
  rewrite J_eps !raddfN /= mulNmx opprK tr_row_mx mul_col_row scalar_mx_block lscale_block_mx add_block_mx !lscalemx0 !addr0.
  by subst goal; rewrite !trmx_mul !mulmxA.
Qed.

Lemma H_sym a : (H a)^T = H a.
Proof.
  by rewrite raddfB /= AmupinvA_sym trmx1.
Qed.

Hypothesis h_invertible : invertible (mupinv_core lambda (~W *m ~U)).

Lemma futher_damping_U : (~V^T *m ~W^T *m H lambda *m ~W *m ~V + lambda *ml: I) *m vec dU = ~V^T *m ~W^T *m (H lambda)^T *m eps.
Proof.
  set goal := _ = _.
  move: Levenberg.
  rewrite JT_J_I -UV_delta [in J^T]J_eps -raddfN /= opprK tr_row_mx [in R in _ =  R] mul_col_mx.
  move => h; pose (Schur_complement h).
  edestruct a as [h1 h2].
  by move: h_invertible; rewrite /mupinv_core trmx_mul !mulmxA.
  by rewrite !trmx_mul !mulmxA !trmxK.
  clear a h h2.
  subst goal; symmetry; set goal := RHS.
  set goal1 := RHS in h1.
  set from := LHS.
  have step1: from = goal1.
  subst from.
  rewrite H_sym !mulmxBr mulmx1 mulmxBl unlock /mupinv /mupinv_core.
  by subst goal1; rewrite !trmx_mul !mulmxA.
  rewrite step1 -h1.
  subst goal; symmetry; set goal := RHS.
  rewrite unlock /mupinv /mupinv_core !mulmxBr mulmx1 !mulmxBl -addrA [in - _ + _]addrC addrA.
  by subst goal; rewrite !trmx_mul !mulmxA !trmxK.
Qed.

End Section4.


Require Import
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Lib2.Word.
Require Import
        Bedrock.Word.

Section Nat.
  Variable sz : nat.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {transformer : Transformer B}.
  Context {transformerUnit : TransformerUnit transformer bool}.

  Definition encode_nat (n : nat) (ce : CacheEncode) : B * CacheEncode :=
    encode_word (natToWord sz n) ce.

  Definition decode_nat (b : B) (cd : CacheDecode) : nat * B * CacheDecode :=
    let (bundle, cd) := decode_word (sz:=sz) b cd in
    let (w, b) := bundle in
        (wordToNat w, b, cd).

  Local Open Scope nat.
  Theorem Nat_decode_correct :
    encode_decode_correct cache transformer (fun n => n < pow2 sz) encode_nat decode_nat.
  Proof.
    unfold encode_decode_correct, encode_nat, decode_nat.
    intros env env' xenv xenv' n n' bin' ext ext' Eeq Ppred Penc Pdec.
    destruct (decode_word (transform bin' ext) env') as [[? ?] ?] eqn: ?.
    inversion Pdec; subst; clear Pdec.
    pose proof (Word_decode_correct env env' xenv xenv' (natToWord sz n) w
                  bin' ext ext' Eeq I Penc Heqp).
    intuition eauto.
    rewrite <- H.
    destruct (wordToNat_natToWord' sz n).
    assert (x = 0).
    { destruct x; eauto.
      rewrite <- H1 in Ppred. exfalso. simpl in Ppred.
      clear - Ppred.
      replace (wordToNat (natToWord sz n) + (pow2 sz + x * pow2 sz)) with
              (pow2 sz + (wordToNat (natToWord sz n) + x * pow2 sz)) in Ppred by omega.
      remember (wordToNat (natToWord sz n) + x * pow2 sz) as n'; clear Heqn'.
      omega. }
    rewrite H3 in H1. simpl in H1. rewrite <- plus_n_O in H1. rewrite H1. reflexivity.
  Qed.
End Nat.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Nat.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Inductive queue : Type :=
  | Queue : lst -> lst -> queue.

Fixpoint len (l : lst) : nat :=
match l with
  | Nil => 0
  | Cons a l1 => 1 + (len l1)
end.

Lemma len_pos: forall l, (len l) >= 0.
Proof.
  induction l.
  - simpl. apply le_0_n.
  - simpl. apply le_0_n.
Qed.

Definition qlen (q : queue) : nat :=
match q with
  | Queue l1 l2 => (len l1) + (len l2)
end.

Fixpoint app (l : lst) (m: lst): lst :=
match l with
  | Nil => m
  | Cons a l1 => Cons a (app l1 m)
end.

Fixpoint rev (l: lst): lst :=
match l with
  | Nil => Nil
  | Cons a l1 => app (rev l1) (Cons a Nil)
end.

Fixpoint leb (n m : nat) : bool :=
match (n, m) with
  | (0, _) => true
  | (S n', S m') => leb n' m'
  | _ => false
end.

Definition amortizeQueue (l1 l2 : lst) : queue :=
  if leb (len l2)  (len l1) then Queue l1 l2
  else Queue (app l1 (rev l2)) Nil.

Lemma len_app : forall l1 l2, len (app l1 l2) = (len l1) + (len l2).
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Lemma plus_comm: forall m n, m + n = n + m.
Proof.
induction m.
- intros. simpl. rewrite <- plus_n_O. reflexivity.
- intros. simpl. rewrite IHm. rewrite plus_n_Sm. reflexivity.
Qed.

Lemma len_rev : forall l, len (rev l) = len l.
Proof.
induction l.
- reflexivity.
- simpl. rewrite len_app. simpl. rewrite plus_comm. simpl. rewrite IHl. reflexivity.
Qed.

Theorem queue_len : forall l1 l2, qlen (amortizeQueue l1 l2) = (len l1) + (len l2).
Proof.
  intros. unfold amortizeQueue. destruct (leb (len l2) (len l1)).
  - simpl. reflexivity.
  - simpl. rewrite <- plus_n_O.
    rewrite len_app.
    apply f_equal2_plus.
    * reflexivity.
    * lfind. Admitted.


Require Import Problem Omega Lia Nat.

Lemma iter_S_l (f : nat -> nat) (n k : nat) : iter (S k) f n = f (iter k f n).
Proof.
  auto.
Qed.

Lemma iter_S_r (f : nat -> nat) (n k : nat) : iter (S k) f n = iter k f (f n).
Proof.
  induction k; [auto|].
  simpl.
  rewrite <- IHk.
  auto.
Qed.

Lemma iter_split (f : nat -> nat) (a n k : nat) : iter (a + k) f n = iter a f (iter k f n).
Proof.
  induction a; [auto|].
  simpl.
  f_equal.
  auto.
Qed.

Lemma skip' : forall f n k, iter k f n = iter (2 * S k) f n -> forall i, i <= k -> hare_catches_tortoise f (iter (k - i) f n) (iter (2 * (k - i)) f (f n)).
Proof.
  induction i.
  - replace (k - 0) with k by omega.
    intro.
    apply CatchNext.
    rewrite H; clear H H0.
    replace (2 * S k) with (S (S (2 * k))) by omega.
    rewrite iter_S_r.
    auto.
  - intro.
    apply CatchLater.
    repeat rewrite <- iter_S_l.
    replace (S (S (2 * (k - S i)))) with (2 * (k - i)) by omega.
    replace (S (k - S i)) with (k - i) by omega.
    apply IHi.
    omega.
Qed.

Lemma skip : forall f n, (exists k, iter k f n = iter (2 * S k) f n) -> hare_catches_tortoise f n (f n).
Proof.
  intros.
  destruct H as [k].
  assert (k <= k) by omega.
  specialize (skip' f n k H k H0); intro.
  replace (k - k) with 0 in H1 by omega.
  simpl in H1.
  auto.
Qed.

Lemma extract : forall f n m, hare_catches_tortoise f n m -> exists k, iter k f n = iter (2 * k + 1) f m.
Proof.
  intros.
  induction H.
  - exists 0.
    simpl.
    auto.
  - destruct IHhare_catches_tortoise as [k].
    exists (S k).
    replace (2 * S k + 1) with (S (S (2 * k + 1))) by omega.
    repeat rewrite iter_S_r.
    auto.
Qed.

Lemma crash_point : forall t m0, t > 0 -> exists i, i * t > m0 + 2.
Proof.
  intros.
  exists (m0 + 3).
  assert (t >= 1) by omega.
  apply (Nat.mul_le_mono_l 1 t (m0 + 3)) in H0.
  omega.
Qed.

Theorem solution: task.
Proof.
  unfold task.
  unfold eventually_periodic.
  intros; split; intros.
  - destruct H as [t].
    destruct H as [m0].
    destruct H.
    apply skip.
    destruct (crash_point t m0 H) as [i].
    remember (i * t - 2) as k.
    exists k.
    assert (m0 < k) by omega.
    apply H0 in H2; clear H0.
    assert (k + 2 = i * t) by omega.
    replace (2 * S k) with ((k + 2) + k) by omega.
    rewrite H0.
    clear Heqk H0 H1 m0.
    induction i; [auto|].
    replace (S i * t + k) with (i * t + (t + k)) by lia.
    rewrite iter_split.
    rewrite H2.
    rewrite <- iter_split.
    auto.
  - destruct (extract f n (f n) H) as [k]; clear H.
    rewrite <- iter_S_r in H0.
    exists (k + 2); exists k.
    split; [omega|].
    intros.
    replace (S (2 * k + 1)) with (k + 2 + k) in H0 by omega.
    replace m with ((m - k) + k) by omega.
    remember (m - k) as a; clear Heqa m H.
    replace (k + 2 + (a + k)) with (a + (k + 2 + k)) by omega.
    rewrite iter_split.
    rewrite <- H0.
    rewrite iter_split.
    auto.
Qed.


Require Import LL.SL.FLL.Specifications.Bipoles.

(** ** Syntax *)
Inductive LJCon := TT | FF.
Inductive LJBin := OR | AND | IMP .
Inductive LJQu := EX | ALL .

#[export]Instance LJSyntax : OLSyntax:=
  {|
    OLType := nat;
    ccon := LJCon;
    ucon := Empty_set;
    bcon := LJBin;
    qcon := Empty_set
  |}.

(** ** Inference rules *)

(** *** Constants *)
Definition LJrulesC (c:ccon) :=
  match c return ruleC with
 | TT => {| rc_rgtBody := Top;
                  rc_lftBody  := Zero |}
 | FF => {| rc_rgtBody := Zero;
                  rc_lftBody  := Top |}

  end.

(** *** Unary connectives *)
Definition LJrulesU  (c:ucon) :=
  match c return ruleU with
  end.

(** *** Binary connectives *)
Definition LJrulesB (c :bcon) :=
  match c with
  | OR => {| rb_rgtBody := fun F G => AOr  (Bang (atom (up F))) (Bang (atom (up G) ));
                 rb_lftBody  := fun F G => AAnd (atom (down F) ) (atom (down G)) |}
  | AND => {| rb_rgtBody := fun F G => AAnd  (Bang (atom (up F))) (Bang (atom (up G) ));
                 rb_lftBody  := fun F G => AOr (atom (down F) ) (atom (down G)) |}
  | IMP => {| rb_rgtBody := fun F G => MOr (atom (down F)) (Bang (atom (up G)) );
                 rb_lftBody  := fun F G => MAnd (Bang (atom (up F)) ) (atom (down G)) |}
  end.

(** *** Quantifiers *)
Definition LJrulesQ (c :qcon) :=
  match c return ruleQ with
 (*  | EX => {| rq_rgtBody := fun FX => Some (fun x => atom (up (FX x)));
                 rq_lftBody  := fun FX => All (fun x => atom (down (FX x)))  |}
  | ALL => {| rq_rgtBody := fun FX => Some (fun x => atom (up (FX x))) ;
              rq_lftBody  := fun FX => All (fun x => atom (down (FX x))) |}
  *) end.

#[export] Instance LJRules : OORules :=
  {|
    rulesC := LJrulesC;
    rulesU := LJrulesU ;
    rulesB := LJrulesB;
    rulesQ := LJrulesQ
  |}.


Set Implicit Arguments.
Require Import Morphisms Omega List std calculus
        higher_order_unification systemunification
        nth_order_unification.
Import ListNotations.

(** * Conservativity *)

Section Constants.

  (** ** Constant Operations *)
  Section ConstantsOfTerm.
    Context {X: Const}.
    Implicit Types (s t: exp X).

    Fixpoint consts s :=
      match s with
      | var x => nil
      | const c => [c]
      | lambda s => consts s
      | app s t => consts s ++ consts t
      end.

    Definition Consts S := (flat_map consts S).

    Lemma Consts_consts s S:
      s ∈ S -> consts s ⊆ Consts S.
    Proof.
      unfold Consts; eauto using flat_map_in_incl.
    Qed.

    Lemma Consts_montone S T:
      S ⊆ T -> Consts S ⊆ Consts T.
    Proof.
      unfold Consts; eauto using flat_map_incl.
    Qed.

    Lemma consts_ren delta s:
      consts (ren delta s) = consts s.
    Proof.
      induction s in delta |-*; cbn; intuition; congruence.
    Qed.

    Lemma vars_subst_consts x s sigma:
      x ∈ vars s -> consts (sigma x) ⊆ consts (sigma • s).
    Proof.
      intros H % vars_varof; induction H in sigma |-*; cbn; intuition.
      rewrite <-IHvarof; cbn; unfold funcomp; now rewrite consts_ren.
    Qed.

    Lemma consts_subst_in x sigma s:
      x ∈ consts (sigma • s) -> x ∈ consts s \/
                           exists y, y ∈ vars s /\ x ∈ consts (sigma y).
    Proof.
      induction s in sigma |-*.
      - right; exists f; intuition.
      - cbn; intuition.
      - intros H % IHs; cbn -[vars]; intuition.
        destruct H0 as [[]]; cbn -[vars] in *; intuition.
        right. exists n. intuition.
        unfold funcomp in H1; now rewrite consts_ren in H1.
      - cbn; simplify; intuition.
        + specialize (IHs1 _ H0); intuition.
          destruct H as [y]; right; exists y; intuition.
        + specialize (IHs2 _ H0); intuition.
          destruct H as [y]; right; exists y; intuition.
    Qed.

    Lemma consts_subset_step s t:
      s > t -> consts t ⊆ consts s.
    Proof.
      induction 1; cbn; intuition.
      subst. unfold beta.
      intros x ? % consts_subst_in; simplify; intuition.
      destruct H as [[|y] ?]; cbn in *; intuition.
    Qed.

    Lemma consts_subset_steps s t:
      s >* t -> consts t ⊆ consts s.
    Proof.
      induction 1; firstorder using consts_subset_step.
    Qed.

    Lemma consts_subst_vars sigma s:
      consts (sigma • s) ⊆ consts s ++ Consts (map sigma (vars s)).
    Proof.
      intros x [|[y]] % consts_subst_in; simplify; intuition.
      right; eapply Consts_consts; eauto using in_map.
    Qed.

    Lemma consts_Lam k s:
      consts (Lambda k s) === consts s.
    Proof.
      induction k; cbn; intuition.
    Qed.

    Lemma consts_AppL S t:
      consts (AppL S t) === Consts S ++ consts t.
    Proof.
      induction S; cbn; intuition.
      rewrite IHS; now rewrite app_assoc.
    Qed.

    Lemma consts_AppR s T:
      consts (AppR s T) === consts s ++ Consts T.
    Proof.
      induction T; cbn; intuition.
      rewrite IHT. intuition.
      split; intros c; simplify; intuition.
    Qed.

  End ConstantsOfTerm.

  Section ConstantSubstitution.

    Implicit Types (X Y Z : Const).

    Fixpoint subst_consts {X Y} (kappa: X -> exp Y) s :=
      match s with
      | var x => var x
      | const c => kappa c
      | lambda s => lambda (subst_consts (kappa >> ren shift) s)
      | app s t => (subst_consts kappa s) (subst_consts kappa t)
      end.

    Lemma ren_subst_consts_commute X Y (zeta: X -> exp Y) delta s:
      subst_consts (zeta >> ren delta) (ren delta s) = ren delta (subst_consts zeta s).
    Proof.
      induction s in delta, zeta |-*; cbn; eauto.
      - f_equal. rewrite <-IHs. f_equal.
        asimpl. reflexivity.
      - now rewrite IHs1, IHs2.
    Qed.

    Lemma subst_consts_comp X Y Z (zeta: X -> exp Y) (kappa: Y -> exp Z) s:
      subst_consts kappa (subst_consts zeta s) =
      subst_consts (zeta >> subst_consts kappa) s.
    Proof.
      induction s in zeta, kappa |-*; cbn; eauto.
      - f_equal. rewrite IHs. f_equal. fext.
        unfold funcomp at 4; unfold funcomp at 4.
        intros; rewrite <-ren_subst_consts_commute.
        reflexivity.
      - now rewrite IHs1, IHs2.
    Qed.

    Lemma subst_consts_ident Y zeta s:
      (forall x: Y, x ∈ consts s -> zeta x = const x) -> subst_consts zeta s = s.
    Proof.
      intros; induction s in zeta, H |-*; cbn; eauto.
      eapply H; cbn; eauto.
      rewrite IHs; eauto.
      unfold funcomp; now intros x -> % H.
      rewrite IHs1, IHs2; eauto.
      all: intros; apply H; cbn; simplify; intuition.
    Qed.

    Lemma subst_const_comm {X Y} (zeta: X -> exp Y) sigma delta s:
      (forall x, sigma (delta x) = var x) ->
      subst_consts zeta (sigma • s) = (sigma >> subst_consts zeta) • (subst_consts (zeta >> ren delta) s).
    Proof.
      induction s in zeta, sigma, delta |-*; intros H; cbn.
      - reflexivity.
      - unfold funcomp; asimpl.
        rewrite idSubst_exp; eauto.
        intros y; unfold funcomp; cbn.
        rewrite H; reflexivity.
      - f_equal. erewrite IHs with (delta := 0 .: delta >> shift).
        2: intros []; cbn; unfold funcomp; eauto; rewrite H; reflexivity.
        f_equal; [| now asimpl].
        fext; intros []; cbn; eauto.
        unfold funcomp at 2.
        now rewrite ren_subst_consts_commute.
      - erewrite IHs1, IHs2; eauto.
    Qed.

    Global Instance step_subst_consts X Y:
      Proper (Logic.eq ++> step ++> step) (@subst_consts X Y).
    Proof.
      intros ? zeta -> s t H; induction H in zeta |-*; cbn; eauto.
      econstructor; subst; unfold beta.
      erewrite subst_const_comm with (delta := shift).
      f_equal. fext.
      all: intros []; cbn; eauto.
    Qed.

    Global Instance steps_subst_consts X Y:
      Proper (Logic.eq ++> star step ++> star step) (@subst_consts X Y).
    Proof.
      intros ? zeta -> s t H; induction H in zeta |-*; cbn; eauto; rewrite H; eauto.
    Qed.

    Global Instance equiv_subst_consts X Y:
      Proper (Logic.eq ++> equiv step ++> equiv step) (@subst_consts X Y).
    Proof.
      intros ? zeta -> s t [v [H1 H2]] % church_rosser; eauto;
        now rewrite H1, H2.
    Qed.

    Lemma subst_consts_consts X Y (zeta: X -> exp Y) (s: exp X):
      consts (subst_consts zeta s) === Consts (map zeta (consts s)).
    Proof.
      unfold Consts; induction s in zeta |-*; cbn; simplify; intuition.
      - rewrite IHs.
        unfold funcomp; rewrite <-map_map, !flat_map_concat_map, map_map.
        erewrite map_ext with (g := consts); intuition.
        now rewrite consts_ren.
      - rewrite IHs1, IHs2, !flat_map_concat_map; simplify.
        now rewrite concat_app.
    Qed.

    Lemma consts_in_subst_consts X Y (kappa: X -> exp Y) c s:
      c ∈ consts (subst_consts kappa s) -> exists d, d ∈ consts s /\ c ∈ consts (kappa d).
    Proof.
      rewrite subst_consts_consts.
      unfold Consts; rewrite in_flat_map; intros [e []]; mapinj.
      exists x; intuition.
    Qed.

    Lemma subst_consts_up Y Z (zeta: Y -> exp Z) (sigma: fin -> exp Y):
      up (sigma >> subst_consts zeta) = up sigma >> subst_consts (zeta >> ren shift).
    Proof.
      fext; intros []; cbn; eauto.
      unfold funcomp at 1 2.
      now rewrite <-ren_subst_consts_commute.
    Qed.

    Lemma subst_const_comm_id Y zeta sigma (s: exp Y):
      subst_consts zeta s = s ->
      (sigma >> subst_consts zeta) • s = subst_consts zeta (sigma • s).
    Proof.
      induction s in zeta, sigma |-*; cbn; eauto.
      - injection 1 as H. f_equal.
        rewrite <-IHs; eauto.
        now rewrite subst_consts_up.
      - injection 1 as H. f_equal; eauto.
    Qed.

    Lemma typing_constants X n Gamma s A :
      Gamma ⊢(n) s : A -> forall c, c ∈ consts s -> ord (ctype X c) <= S n.
    Proof.
      induction 1; cbn;  intuition; subst; eauto.
      simplify in H1; intuition.
    Qed.

    Lemma typing_Consts X c n Gamma S' L:
      Gamma ⊢₊(n) S' : L -> c ∈ Consts S' -> ord (ctype X c) <= S n.
    Proof.
      induction 1; cbn; simplify; intuition eauto using typing_constants.
    Qed.

    Lemma preservation_consts X Y Gamma s A (zeta: X -> exp Y):
      Gamma ⊢ s : A -> (forall x, x ∈ consts s -> Gamma ⊢ zeta x : ctype X x) ->
      Gamma ⊢ subst_consts zeta s : A.
    Proof.
      induction 1 in zeta |-*; cbn; eauto.
      - intros H'. econstructor. eapply IHtyping.
        intros; eapply preservation_under_renaming; eauto.
        intros ?; cbn; eauto.
      - intros H'. econstructor.
        eapply IHtyping1; intros ??; eapply H'; simplify; intuition.
        eapply IHtyping2; intros ??; eapply H'; simplify; intuition.
    Qed.

    Lemma ordertyping_preservation_consts X Y n Gamma s A (zeta: X -> exp Y):
      Gamma ⊢(n) s : A -> (forall x, x ∈ consts s -> Gamma ⊢(n) zeta x : ctype X x) ->
      Gamma ⊢(n) subst_consts zeta s : A.
    Proof.
      induction 1 in zeta |-*; cbn; eauto.
      - intros H'. econstructor. eapply IHordertyping.
        intros; eapply ordertyping_preservation_under_renaming; eauto.
        intros ?; cbn; eauto.
      - intros H'. econstructor.
        eapply IHordertyping1; intros ??; eapply H'; simplify; intuition.
        eapply IHordertyping2; intros ??; eapply H'; simplify; intuition.
    Qed.

    Lemma subst_consts_Lambda Y Z (zeta: Y -> exp Z) k s:
        subst_consts zeta (Lambda k s) = Lambda k (subst_consts (zeta >> ren (plus k)) s).
    Proof.
        induction k in zeta |-*; cbn; asimpl; eauto.
        f_equal. rewrite IHk. f_equal. f_equal.
        asimpl. fext; intros x; unfold funcomp; f_equal; fext; intros ?.
        unfold shift; simplify; f_equal; omega.
    Qed.

    Lemma subst_consts_AppL X Y (tau: X -> exp Y) S t:
        subst_consts tau (AppL S t) = AppL (map (subst_consts tau) S) (subst_consts tau t).
    Proof.
        induction S; cbn; congruence.
    Qed.

    Lemma subst_consts_AppR X Y (tau: X -> exp Y) s T:
        subst_consts tau (AppR s T) = AppR (subst_consts tau s) (map (subst_consts tau) T).
    Proof.
        induction T; cbn; congruence.
    Qed.

  End ConstantSubstitution.
End Constants.

Hint Rewrite @consts_Lam @consts_AppL @consts_AppR : simplify.

(** ** Inhabiting Types *)
Section InhabitingTypes.

  Variable (X: Const).
  Implicit Types (s t: exp X) (Gamma Delta: ctx) (sigma tau: fin -> exp X).

  Definition inhab (x: fin) (A: type) := Lambda (arity A) (@var X (arity A + x)).

  Lemma inhab_ren delta x A: ren delta (inhab x A) = inhab (delta x) A.
  Proof.
    unfold inhab. asimpl. f_equal. f_equal.
    rewrite it_up_ren_ge; simplify; eauto.
  Qed.

  Lemma inhab_typing Delta x A:
    nth Delta x = Some (target A) -> Delta ⊢(1) inhab x A : A.
  Proof.
    intros H2. unfold inhab.
    destruct (type_decompose A) as (L & beta & ->); simplify in H2; cbn in H2.
    specialize (arity_decomposed L beta) as H3.
    rewrite H3. eapply Lambda_ordertyping; eauto.
    econstructor; cbn; eauto.
    rewrite nth_error_app2; simplify; eauto; omega.
  Qed.

  Lemma inhab_typing_inv Gamma x A:
    Gamma ⊢(1) inhab x A : A -> nth Gamma x = Some (target A).
  Proof.
    intros H; unfold inhab in H.
    eapply Lambda_ordertyping_inv in H as (L & B & ? & ? & ?); subst.
    inv H. rewrite <-H1 in H3.
    rewrite nth_error_app2 in H3; simplify in *; eauto.
    destruct B; cbn in H1; try omega. now rewrite H3.
  Qed.

  Lemma inhab_app Gamma Delta x A:
      Gamma ⊢(1) inhab x A : A -> Delta ++ Gamma ⊢(1) inhab (length Delta + x) A : A.
  Proof.
    intros H % inhab_typing_inv. eapply inhab_typing.
    rewrite nth_error_app2; simplify; eauto.
  Qed.

  Lemma inhab_typing' Gamma x A:
    nth Gamma x = Some A -> target' Gamma ⊢(1) inhab x A : A.
  Proof.
    intros H; eapply inhab_typing.
    unfold target'; erewrite map_nth_error; now eauto.
  Qed.

  Lemma consts_inhab x A: consts (inhab x A) === nil.
  Proof.
    unfold inhab; rewrite consts_Lam; reflexivity.
  Qed.

  Lemma normal_inhab x A: normal (inhab x A).
  Proof.
    unfold inhab. generalize (arity A + x) as k.
    induction (arity A); cbn; eauto using normal_lam_intro.
  Qed.

End InhabitingTypes.

Hint Resolve inhab_app inhab_typing inhab_typing' ord_target'.

(** ** Conservativity *)
Section Conservativity.
  Variable (X: Const).

  Section DowncastLemmas.

    Implicit Types (s t: exp X) (Gamma: ctx)  (A: type).
    Variable (n: nat).
    Hypothesis (Leq: 1 <= n).

    Lemma downcast_variables Gamma s t Delta sigma:
      Delta ⊩ sigma : Gamma -> sigma • s ≡ sigma • t ->
      exists Sigma tau, Sigma ⊩ tau : Gamma /\ tau • s ≡ tau • t /\ ord' Sigma <= 1.
    Proof.
      intros.
      pose (tau x := match nth Delta x with
                  | Some A => inhab X x A
                  | None => var x
                  end).
      exists (target' Delta). exists (sigma >> subst_exp tau). split; [|split].
      - intros ???; eapply preservation_under_substitution; eauto.
        unfold tau; intros ?? EQ; rewrite EQ.
        eauto using ordertyping_soundness.
      - erewrite <-compSubstSubst_exp; eauto. symmetry.
        erewrite <-compSubstSubst_exp; eauto. symmetry.
        now rewrite H0.
      - eauto.
    Qed.

    Lemma downcast_constants_ordered m Gamma s t Delta sigma:
      1 <= m -> Delta ⊩(m) sigma : Gamma -> sigma • s ≡ sigma • t ->
      exists Sigma tau, Delta ++ Sigma ⊩(m) tau : Gamma /\ tau • s ≡ tau • t /\
      ord' Sigma <= 1 /\ (forall x c, c ∈ consts (tau x) -> c ∈ Consts [s; t]).
    Proof.
      intros L' T EQ.
      pose (C0 := Consts [s; t]).
      pose (C := Consts (map sigma (nats (length Gamma)))).
      pose (zeta c := match find c C0 with
                  | Some n => const c
                  | None =>
                    match find c C with
                    | Some x => inhab X (length Delta + x) (ctype X c)
                    | None => var 0
                    end
                  end).
      exists (target' (map (ctype X) C)). exists (sigma >> subst_consts zeta). intuition.
      - intros ???. eapply ordertyping_preservation_consts.
        now eapply weakening_ordertyping_app, T.
        intros c H1. unfold zeta.
        destruct (find c C0); eauto.
        + econstructor; eapply typing_constants; eauto.
        + eapply Consts_consts
            with (S := (map sigma (nats (length Gamma)))) in H1 as H2.
          unfold C; eapply find_in in H2 as [y H2]. rewrite H2.
          eapply ordertyping_monotone, inhab_app, inhab_typing'; eauto.
          erewrite map_nth_error; eauto. now eapply find_Some.
          eapply in_map, lt_nats, nth_error_Some_lt; eauto.
      - rewrite !subst_const_comm_id. now rewrite EQ.
        all: eapply subst_consts_ident; intros x;
          rewrite Consts_consts with (S := [s; t]); intuition.
        all: now unfold zeta, C0; eapply find_in in H as [? ->].
      - eapply consts_in_subst_consts in H as [d []].
        unfold zeta in *. destruct find eqn: H1.
        + cbn in H0; intuition; subst.
          eapply find_Some, nth_error_In in H1; exact H1.
        + destruct (find d C) eqn: H2.
          all: rewrite ?consts_inhab in H0; cbn in H0; intuition.
    Qed.

    Lemma downcast_constants Gamma s t Delta sigma:
      Delta ⊩ sigma : Gamma -> sigma • s ≡ sigma • t ->
      exists Sigma tau, Delta ++ Sigma ⊩ tau : Gamma /\ tau • s ≡ tau • t /\
      ord' Sigma <= 1 /\ (forall x c, c ∈ consts (tau x) -> c ∈ Consts [s; t]).
    Proof.
      intros [m H] % ordertypingSubst_complete EQ.
      eapply ordertypingSubst_monotone with (m0 := S m) in H; eauto.
      eapply downcast_constants_ordered in H as (Sigma & tau & ?); [|omega|eauto].
      exists Sigma; exists tau; intuition. eapply ordertypingSubst_soundness; eauto.
    Qed.

    Lemma ordertyping_from_basetyping Sigma u B:
      (forall c, c ∈ consts u -> ord (ctype X c) <= S n) ->
      Sigma ⊢ u : B -> normal u -> ord B <= S n -> ord' Sigma <= n ->
      Sigma ⊢(n) u : B.
    Proof.
      induction 2; [eauto|eauto| |].
      - simplify; intros; econstructor; eapply IHtyping; intuition.
        eauto using normal_lam_elim. cbn; simplify; intuition.
      - intros; enough (ord A <= n).
        + econstructor; [eapply IHtyping1 | eapply IHtyping2].
          1, 5: intros; eapply H; cbn; intuition.
          1, 4: eauto using normal_app_r, normal_app_l.
          2, 4: eauto.
          1, 2: simplify; eauto; intuition.
        + eapply head_atom in H0; eauto; cbn in H0.
          destruct (head_decompose s) as [T].
          rewrite H3 in H0_.
          eapply AppR_typing_inv in H0_ as (? & ? & ?).
          enough (ord (Arr (rev x) (A → B)) <= S n)
            as H6 by (simplify in H6; intuition).
          destruct (head s); cbn in H0; eauto.
          all: inv H5.
          eapply ord'_elements in H2; eauto.
          eapply H; cbn; simplify; cbn; intuition.
    Qed.

  Lemma ordertyping_weak_ordertyping Gamma Delta sigma (s t: exp X):
    (forall x A, nth Gamma x = Some A -> x ∈ vars s ++ vars t -> Delta ⊢(n) sigma x : A) ->  sigma • s ≡ sigma • t ->
    (exists Sigma tau, Sigma ⊩(n) tau : Gamma /\ tau • s ≡ tau • t).
  Proof.
    intros T EQ.
    pose (tau x := if x el (vars s ++ vars t)
                then sigma x
                else match nth Gamma x with
                      | Some A => inhab X (length Delta + x) A
                      | None => var x
                      end).
    exists (Delta ++ target' Gamma). exists tau. split.
    - intros x B H'. unfold tau. rewrite H'; destruct dec_in.
      eapply weakening_ordertyping_app, T; eauto.
      eapply ordertyping_monotone; eauto.
    - rewrite !(subst_extensional) with (sigma0 := tau) (tau0 := sigma); eauto.
      all: intros; unfold tau; destruct dec_in; eauto; simplify in *.
      all: exfalso; eauto.
  Qed.

  Lemma unification_downcast sigma Gamma s t Delta A:
    Delta ⊩ sigma : Gamma -> Gamma ⊢(n) s : A -> Gamma ⊢(n) t : A -> sigma • s ≡ sigma • t ->
    exists Sigma tau, Sigma ⊩(n) tau : Gamma /\ tau • s ≡ tau • t.
  Proof.
    intros T T1 T2 H.
    pose (P x := x ∈ vars s ++ vars t).
    edestruct (downcast_variables) as (Sigma' & tau' & T' & H' & O');
      eauto; clear T H sigma Delta.
    edestruct (downcast_constants) as (Sigma'' & tau'' & T'' & H'' & O'' & C'');
      eauto; clear T' H' tau'.
    edestruct (normalise_subst) as (tau''' & R & H & T); eauto.
    eapply ordertyping_weak_ordertyping with (sigma := tau''').
    - intros. eapply ordertyping_from_basetyping.
      + intros ?; erewrite consts_subset_steps; eauto.
        intros H2 % C''; cbn in H2; simplify in H2.
        destruct H2; eapply typing_constants; [|eauto| |eauto]; eauto.
      + eauto.
      + domin H0; eauto.
      + simplify in H1; destruct H1; eapply vars_ordertyping_nth; eauto.
      + simplify; rewrite O', O''; cbn; eauto.
    - rewrite !subst_pointwise_equiv with (sigma := tau''') (tau := tau''); eauto.
  Qed.

  Lemma linearize_consts (S: list (exp X)):
    consts (linearize_terms S) === Consts S.
  Proof.
    unfold linearize_terms. cbn; simplify.
    split; intros ? [x] % in_flat_map; eapply in_flat_map.
    all: intuition; try mapinj. eexists; intuition; eauto.
    now rewrite consts_ren in H1.
    exists (ren shift x); intuition. now rewrite consts_ren.
  Qed.

  Lemma unification_downcast_eqs sigma Delta (E: eqs X) Gamma L:
    (Gamma ⊢₊₊(n) E : L) ->
    (Delta ⊩ sigma : Gamma) -> (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E) ->
    exists Sigma tau, Sigma ⊩(n) tau : Gamma /\ (tau •₊ left_side E) ≡₊ (tau •₊ right_side E).
  Proof.
    intros T1 T2 H.
    pose (P x := x ∈ Vars' E). pose (s := linearize_terms (left_side E)).
    pose (t := linearize_terms (right_side E)).
    edestruct (downcast_variables) with (s := s) (t := t) as (Sigma' & tau' & T' & H' & O'); eauto.
    1: unfold s, t; now rewrite !linearize_terms_subst, linearize_terms_equiv.
    clear T2 H sigma Delta.
    edestruct (downcast_constants) with (s := s) (t := t)
      as (Sigma'' & tau'' & T'' & H'' & O'' & C''); eauto; clear T' H' tau'.
    edestruct (normalise_subst) as (tau''' & R & H & T); eauto.
    edestruct ordertyping_weak_ordertyping with (s := s) (t := t) (sigma := tau''').
    - intros. eapply ordertyping_from_basetyping.
      + intros ?; erewrite consts_subset_steps; eauto.
        intros H2 % C''. cbn [Consts flat_map] in H2.
        simplify in H2. unfold s, t in H2.
        rewrite !linearize_consts in H2.
        destruct H2; eapply typing_Consts.
        eapply left_ordertyping; eauto. eauto.
        eapply right_ordertyping; eauto. eauto.
      + eauto.
      + domin H0; eauto.
      + simplify in H1. unfold s, t in H1; rewrite !linearize_vars in H1.
        destruct H1 as [H1|H1]; eapply Vars_listordertyping in H1.
        2, 4: eauto using left_ordertyping, right_ordertyping.
        all: destruct H1 as [? [H1 H2]]; rewrite H0 in H1;
          injection H1 as ->; eauto.
      + simplify; rewrite O', O''; cbn; eauto.
    - rewrite !subst_pointwise_equiv with (sigma := tau''') (tau := tau''); eauto.
    - destruct H0 as [tau]. exists x. exists tau. destruct H0; split; eauto.
      unfold s, t in H1; now rewrite <-linearize_terms_equiv, <-!linearize_terms_subst.
  Qed.

  End DowncastLemmas.

  Program Instance unification_monotone {n} (D: orduni n X): orduni (S n) X :=
    {  Gamma₀ := Gamma₀; s₀ := s₀ ; t₀ := t₀; A₀ := A₀; }.

  Lemma unification_monotone_forward n (I: orduni n X):
    OU n X I -> OU (S n) X (unification_monotone I).
  Proof.
    intros (Delta & sigma & T & H). exists Delta; exists sigma. intuition.
    eapply ordertypingSubst_monotone; eauto.
  Qed.

  Lemma unification_monotone_backward n (I: orduni n X):
    1 <= n -> OU (S n) X (unification_monotone I) -> OU n X I.
  Proof.
    intros Leq (Delta & sigma & T & H).
    unfold OU. eapply unification_downcast; eauto.
    intros ???; eapply ordertyping_soundness; eauto.
  Qed.

  Program Instance unification_conservative {n} (D: orduni n X): uni X :=
    {  Gammaᵤ := Gamma₀; sᵤ := s₀ ; tᵤ := t₀; Aᵤ := A₀; }.
  Next Obligation.
    eapply ordertyping_soundness; eauto.
  Qed.
  Next Obligation.
    eapply ordertyping_soundness; eauto.
  Qed.

  Lemma unification_conservative_forward n (I: orduni n X):
    OU n X I -> U X (unification_conservative I).
  Proof.
    intros (Delta & sigma & T & H). exists Delta; exists sigma. intuition.
    eapply ordertypingSubst_soundness; eauto.
  Qed.

  Lemma unification_conservative_backward n (I: orduni n X):
    1 <= n -> U X (unification_conservative I) -> OU n X I.
  Proof.
    intros Leq (Delta & sigma & T & H).
    unfold OU. eapply unification_downcast; eauto.
  Qed.

  Program Instance SU_monotone {n} (I: ordsysuni X n): ordsysuni X (S n) :=
    {  Gamma₀' := @Gamma₀' _ _ I; E₀' := @E₀' _ _ I ; L₀' := @L₀' _ _ I; }.
  Next Obligation.
    eapply eqs_ordertyping_step, @H₀'.
  Qed.

  Lemma SU_monotone_forward n (I: ordsysuni X n):
    SOU X n I -> SOU X (S n) (SU_monotone I).
  Proof.
    intros (Delta & sigma & T & H). exists Delta; exists sigma. intuition.
    eapply ordertypingSubst_monotone; eauto.
  Qed.

  Lemma SU_monotone_backward n (I: ordsysuni X n):
    1 <= n -> SOU X (S n) (SU_monotone I) -> SOU X n I.
  Proof.
    intros Leq (Delta & sigma & T & H).
    unfold OU. eapply unification_downcast_eqs; eauto using @H₀'.
    intros ???; eapply ordertyping_soundness; eauto.
  Qed.

  Program Instance SU_conservative {n} (I: ordsysuni X n): sysuni X :=
    {  Gammaᵤ' := @Gamma₀' _ _ I; Eᵤ' := @E₀' _ _ I ; Lᵤ' := @L₀' _ _ I; }.
  Next Obligation.
    eapply eqs_ordertyping_soundness, H₀'.
  Qed.

  Lemma SU_conservative_forward n (I: ordsysuni X n):
    SOU X n I -> SU X (SU_conservative I).
  Proof.
    intros (Delta & sigma & T & H). exists Delta; exists sigma. intuition.
    eapply ordertypingSubst_soundness; eauto.
  Qed.

  Lemma SU_conservative_backward n (I: ordsysuni X n):
    1 <= n -> SU X (SU_conservative I) -> SOU X n I.
  Proof.
    intros Leq (Delta & sigma & T & H).
    eapply unification_downcast_eqs; eauto using H₀'.
  Qed.

  Theorem unification_step n: 1 <= n -> OU n X ⪯ OU (S n) X.
  Proof.
    intros H; exists unification_monotone; split;
      eauto using unification_monotone_forward, unification_monotone_backward.
  Qed.

  Theorem unification_steps n m: 1 <= n <= m -> OU n X ⪯ OU m X.
  Proof.
    intros [H1 H2]; induction H2; eauto using unification_step, le_trans.
  Qed.

  Theorem unification_conserve n: 1 <= n -> OU n X ⪯ U X.
  Proof.
    intros H; exists unification_conservative; split;
      eauto using unification_conservative_forward, unification_conservative_backward.
  Qed.

  Theorem systemunification_step n: 1 <= n -> @SOU X n ⪯ @SOU X (S n).
  Proof.
    intros H; exists SU_monotone; split;
      eauto using SU_monotone_forward, SU_monotone_backward.
  Qed.

  Theorem systemunification_steps n m: 1 <= n <= m -> @SOU X n ⪯ @SOU X m.
  Proof.
    intros [H1 H2]; induction H2; eauto using systemunification_step, le_trans.
  Qed.

  Theorem systemunification_conserve n: 1 <= n -> @SOU X n ⪯ @SU X.
  Proof.
    intros H; exists SU_conservative; split;
      eauto using SU_conservative_forward, SU_conservative_backward.
  Qed.

End Conservativity.

(** ** Consequences *)
Require Import third_order.pcp third_order.simplified third_order.huet.

Corollary MPCP_U X: MPCP ⪯ U X.
Proof.
  eapply reduction_transitive. eapply MPCP_U3.
  eapply unification_conserve; eauto.
Qed.

Corollary PCP_U X: PCP ⪯ U X.
Proof.
  eapply reduction_transitive. eapply PCP_U3.
  eapply unification_conserve; eauto.
Qed.


From Games Require Import
     Utils
     Games.

From Coq Require Import
     List.

Import ListNotations.

Section Cell_Game.

  (**
     A game corresponding to the interaction with a single cell of memory
     containing a [nat].
   *)

  (* Four events: the "client" requesting a read or a write, and the "server"
  answering them *)
  Inductive Cell_Event :=
  | RdC
  | WrC (_: nat)
  | WrS
  | RdS (_: nat).

  Notation state_cell := (list Cell_Event).

  Fixpoint get_write (σ: state_cell): option nat :=
    match σ with
    | [] => None
    | WrC n :: _ => Some n
    | _ :: σ => get_write σ
    end.

  Inductive move_cell: player -> state_cell -> state_cell -> Prop :=
  | Move_RdC: forall σ, move_cell P1 σ (RdC :: σ)
  | Move_WrC: forall σ n, move_cell P1 σ (WrC n :: σ)
  | Move_RdS: forall σ n, get_write σ = Some n -> move_cell P2 (RdC :: σ) (RdS n :: RdC :: σ)
  | Move_WrS: forall σ n, move_cell P2 (WrC n :: σ) (WrS :: WrC n :: σ).

  Definition Cell_Game: Game :=
    {|
      state := list Cell_Event;
      initial_state := [];
      move := move_cell
    |}.

End Cell_Game.