Set Implicit Arguments.

CoInductive Process (In Out : Type) :=
buildP (f : (In -> ((Process In Out) * Out))).

Require Import Coq.Unicode.Utf8.

CoFixpoint mkPureProcess {In Out}
 (f : In -> Out) : Process In Out :=
buildP (λ inp, (mkPureProcess f, f inp)).

(* cofix works
Definition SPP1 := mkPureProcess (fun n:nat => 1).

Goal forall x, ((match SPP1 with
| buildP f =>  (f 0)
end) = x).
intros.
vm_compute.
*)

Definition getOutput {In Out : Type}
  (p: Process In Out) (inp : In ): Out :=
match p with
| buildP f => snd (f inp)
end.

Definition applyProc {In Out : Type}
  (p: Process In Out) (inp : In ): (Process In Out) * Out :=
match p with
| buildP f =>  (f inp)
end.

Definition getNewProc {In Out : Type}
  (p: Process In Out) (inp : In ): Process In Out :=
match p with
| buildP f => fst (f inp)
end.

Require Export Coq.Lists.List.

(* outermost event is the last event *)
Fixpoint getNewProcL  {In Out : Type}
  (p: Process In Out) (linp : list In ): Process In Out :=
match linp with
| nil => p
| hi::tli => getNewProc (getNewProcL p tli) hi
end.

Lemma getNewProcLPure : forall
    {In Out : Type}
    (f : In -> Out)
    (prefix : list In),
  getNewProcL (mkPureProcess f) prefix = (mkPureProcess f).
Proof.
  induction prefix; simpl;[ reflexivity| ].
  rewrite IHprefix.
  unfold getNewProc.
  simpl. reflexivity.
Qed.

Definition getLastOutput  {In Out : Type}
    (p: Process In Out)
    (prefix : list In)
    (last : In) : Out :=
  let procBeforeLast := getNewProcL p prefix in
  getOutput procBeforeLast last.

Lemma getLastOutputPure : forall
    {In Out : Type}
    (f : In -> Out)
    (prefix : list In)
    (last : In),
  getLastOutput (mkPureProcess f) prefix last
  = f last.
Proof.
  intros.
  unfold getLastOutput.
  rewrite getNewProcLPure.
  reflexivity.
Qed.

Definition getLastOutputL  {In Out : Type}
    (p: Process In (list Out))
    (allInputs : list In)  : list Out :=
    match allInputs with
    | nil => nil
    | last :: rest => getLastOutput p rest last
    end.


(** This file is part of CoqEAL, the Coq Effective Algebra Library.
(c) Copyright INRIA and University of Gothenburg, see LICENSE *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq path.
From mathcomp Require Import ssralg fintype matrix mxalgebra bigop zmodp perm choice.

Require Import dvdring mxstructure minor edr.

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

Import GRing.Theory.

Local Open Scope ring_scope.

Section Smith2x2.

Variable R : dvdRingType.

Variable smith2x2 : 'M[R]_2 -> 'M[R]_2 * seq R * 'M[R]_2.

Definition smith1xn n (smith2xn : 'M[R]_(2,n.+2) -> 'M[R]_2 * seq R * 'M[R]_n.+2)
                      (M : 'M[R]_(1,n.+2)) : 'M[R]_1 * seq R * 'M[R]_n.+2 :=
  let: (L,d,R) := smith2xn (col_mx M 0) in
  if d`_0 == 0 then (1%:M,[::],1%:M) else ((L 0 0)%:M, [:: d`_0], R).

Fixpoint smith2xn n : 'M[R]_(2,1 + (1 + n)) -> 'M[R]_2 * seq R * 'M[R]_n.+2 :=
  if n is p.+1 then fun A : 'M[R]_(2,1 + _) =>
    let: A1 := lsubmx A in let: A2 := rsubmx A in
    let: (P1,d1,Q1) := smith2xn A2 in
    let: C := row_mx (P1 *m A1) (P1 *m A2 *m Q1) : 'M[R]_(2,1 + (1 + _)) in
    let: D := row_mx (col 0 C) (col 1 C) in
    let: E := rsubmx (rsubmx C) in
    let: (P2,d2,Q2) := smith2x2 D in
    let: H := row_mx (P2 *m D *m Q2) (P2 *m E) : 'M[R]_(1 + 1, 1 + _) in
    let: y := d2`_0 in
    let: r' := map_mx (fun x => odflt 0 (x %/? y)) (ursubmx H) in
    let: H' := drsubmx H : 'rV_(2 + _) in
    let: (L1,d,R1) := smith1xn smith2x2 (lsubmx H') in
    let: R1' :=  (block_mx R1 0 0 1%:M) in
    (lift0_mx L1 *m P2 *m P1,
     y :: d,
     lift0_mx Q1 *m block_mx Q2 0 0 1%:M *m block_mx 1%:M (- r' *m R1') 0 R1')
  else fun A => smith2x2 A.

Fixpoint smithmxn_rec m n : 'M[R]_(1 + (1 + m),1 + (1 + n)) ->
 'M[R]_(1 + (1 + m)) * seq R * 'M[R]_(1 + (1 + n)) := match m,n with
  | 0,_ => fun A => smith2xn A
  | _,0 => fun A => let: (L,d,R) := smith2xn A^T in (R^T,d,L^T)
  | m'.+1,n'.+1 => fun A =>
     let: A1 := usubmx A in let: A2 := dsubmx A in
     let: (P1,x,Q1) := smithmxn_rec A2 in
     let: C := col_mx (A1 *m Q1) (P1 *m A2 *m Q1) in
     let: D := col_mx (row 0 C) (row 1 C) in
     let: E := dsubmx (dsubmx C) in
     let: (P2,y,Q2) := smith2xn D in
     let: H := col_mx (P2 *m D *m Q2) (E *m Q2) : 'M[R]_(1 + _, 1 + _) in
     let: y := y`_0 in
     let: c' := map_mx (fun x => odflt 0 (x %/? y)) (dlsubmx H) in
     let: (L1,d,R1) := smithmxn_rec (drsubmx H) in
     let: P := block_mx P2 0 0 1%:M : 'M[R]_(1 + _) in
    (block_mx 1%:M 0 (- L1 *m c') L1 *m P *m lift0_mx P1,
     y :: d,
     Q1 *m Q2 *m lift0_mx R1)
  end.

Definition smithmxn m n : 'M[R]_(m,n) -> 'M[R]_m * seq R * 'M[R]_n :=
  match m,n with
    | 0,_ => fun _ => (1%:M,[::],1%:M)
    | _,0 => fun _ => (1%:M,[::],1%:M)
    | 1,1 => fun A => (1%:M,[:: A 0 0],1%:M)
    | 1,_.+2 => smith1xn (@smith2xn _)
    | _.+2,1 => fun A => let: (L,d,R) := smith1xn (@smith2xn _) A^T
                         in (R^T,d,L^T)
    | _.+2,_.+2 => fun A => smithmxn_rec A
  end.

End Smith2x2.

Definition simplmx := (mulmx1,mul1mx,mul0mx,mulmx0,addr0,add0r).

Section Smith2x2_correctness.

Variable R : dvdRingType.

Variable smith2x2 : 'M[R]_2 -> 'M[R]_2 * seq R * 'M[R]_2.

Hypothesis smith2x2P : forall M, smith_spec M (smith2x2 M).

Lemma surgery m n (M : 'M[R]_(1 + (1 + m),n)) :
  M = col_mx (col_mx (row 0 M) (row 1 M)) (dsubmx (dsubmx M)).
Proof.
apply/matrixP=> i j; rewrite !mxE; case: splitP=> k hk; rewrite !mxE.
  by case: splitP=> l hl; rewrite !mxE; congr fun_of_matrix;
     apply/ord_inj; rewrite hk hl ord1.
by congr fun_of_matrix; apply/ord_inj.
Qed.

Lemma surgery2 m n (M : 'M[R]_(m,1 + (1 + n))) :
  M = row_mx (row_mx (col 0 M) (col 1 M)) (rsubmx (rsubmx M)).
Proof.
apply: trmx_inj; rewrite (tr_row_mx (row_mx (col 0 M) (col 1 M))).
by rewrite tr_row_mx !tr_col !trmx_rsub {1}[M^T]surgery.
Qed.

Hint Resolve dvdr0 : core.

Lemma smith1xnP n (M : 'M[R]_(1,1 + (1 + n)))
  (smith2xn : 'M[R]_(2,n.+2) -> 'M[R]_2 * seq R * 'M[R]_n.+2)
  (smith2xnP : forall M, smith_spec M (smith2xn M))  :
  smith_spec M (smith1xn smith2xn M).
Proof.
rewrite /smith1xn; case: smith2xnP; rewrite [2%N]/(1+1)%N=> P d Q h_eq hs hP hQ.
have [d0|d_neq0] := (boolP (d`_0 == 0)).
  constructor; rewrite ?unitmx1 // ?simplmx; apply/matrixP=> i j.
  move/(canRL (mulmxK hQ))/(canRL (mulKmx hP))/matrixP: h_eq.
  rewrite diag_mx_seq0; last by rewrite sorted_dvd0r // sorted_cons // dvd0r.
  rewrite mul0mx mulmx0 ord1 {i} diag_mx_seq_nil.
  by move/(_ (widen_ord (lt0n 2) 0) j); rewrite !mxE split1; case: unliftP.
move/matrixP: h_eq; rewrite -mulmxA [col_mx M 0 *m _]mul_col_mx mul0mx=> h_eq.
have hP00 : ((P 0 0)%:M : 'M_1) \in unitmx.
  rewrite unitmxE det_scalar expr1; apply/unitrPr; exists ((invmx P) 0 0).
  move/matrixP: (mulVmx hP) => /(_ 0 0); rewrite !mxE !big_ord_recl big_ord0.
  suff -> : P (lift 0 0) 0 = 0 by rewrite mulr0 !addr0 mulrC.
  rewrite -{1}[P]submxK (mul_block_col (ulsubmx P)) ?(mulmx0,addr0) in h_eq.
  move/eqP: (h_eq 1 0) (h_eq 0 0) d_neq0.
  rewrite ?(mxE,mulr0n,split1); case: unliftP unliftP=> // i _ [] //= _.
  rewrite ord1 ?(mxE,big_ord_recl,big_ord0) addr0 lshift0 rshift1 mulr1n.
  by rewrite mulf_eq0; case/orP=> /eqP -> // <-; rewrite mulr0 addr0 eqxx.
constructor=> //; apply/matrixP=> i j; rewrite ord1 {i}.
move: (h_eq 0 j); rewrite ?(big_ord_recl,big_ord0,addr0,mxE,split1,mulr1n).
case: unliftP unliftP => // _ [] //= k _ <-.
rewrite ?(ord1,mxE,big_ord_recl,mulr0,addr0,mulrDr,mulrA) {k} big_distrr /=.
by do ?congr (_ + _); apply: eq_bigr=> i _; rewrite ?(mxE,big_ord1) mulrA.
Qed.

Arguments nth : simpl never.

Lemma smith2xnP : forall n (M : 'M[R]_(2,1 + (1 + n))),
  smith_spec M (smith2xn smith2x2 M).
Proof.
elim=> [|n ih]; first exact: smith2x2P.
rewrite [n.+1]/(1 + n)%N => M /=; set A1 := lsubmx M; set A2 := rsubmx M.
case: ih=> /= P1 d1 Q1 h1 h2 hP1 hQ1; set E := rsubmx _.
set C := row_mx (P1 *m A1) _ : 'M[R]_(2,1 + (1 + _)); set D := row_mx _ _.
case: smith2x2P=> /= P2 d2 Q2 H1 H2 hP2 hQ2.
set H := row_mx (P2 *m D *m Q2) _ : 'M[R]_(1 + _, 1 + (1 + _)).
case: (smith1xnP _ smith2x2P)=> L1 d R1; rewrite -mulmxA=> hLdR dsorted hL1 hR1.
set r := ursubmx H; set r' := map_mx _ _; set H' := drsubmx H : 'rV[R]_(2 + n).
have dvd_d20_d0 : d2`_0 %| d1`_0.
  have -> : d1`_0 = D 0 (rshift 1 0).
    rewrite row_mxEr !mxE split1 h1; case: unliftP => //= j hj.
    by rewrite !mxE; case: j hj=> [[]].
  move/(canRL (mulmxK hQ2))/(canRL (mulKmx hP2)): H1 => ->.
  apply: dvdr_mulmxl=> i j; apply: dvdr_mulmxr=> {}i {}j.
  by rewrite !mxE; case: (i == j :> nat); rewrite ?sorted_nth0 ?mulr0n.
have hx0 i j : d1`_0 %| d1`_i *+ (i == j).
  by case: eqP => _; rewrite ?sorted_nth0 // mulr0n dvdr0.
have Hdvd i j : d2`_0 %| H i j.
  rewrite -[(1 + (1 + _))%N]/(2 + _)%N /H H1 dvdr_row_mx //; split=> {}i {}j.
    by rewrite !mxE; case: (i == j :> nat); rewrite ?sorted_nth0 ?mulr0n.
  apply: dvdr_mulmxl=> {}i {}j; rewrite /E row_mxKr h1 !mxE.
  move: (dvdr_trans dvd_d20_d0 (hx0 i (rshift 1 j))).
  by case: eqP => _; rewrite ?(mulr0n,dvdr0,mulr1n).
constructor; rewrite ?unitmx_mul; last first.
- rewrite !unitmxE ?(det_lblock,det_ublock,det_lblock Q2,det1,mulr1,mul1r).
  by rewrite -!unitmxE hQ1 hQ2 hR1.
- by rewrite hP2 hP1 unitmxE (@det_ublock _ 1) det1 mul1r -unitmxE hL1.
- apply: sorted_cons=> //; move/matrixP: hLdR => /(_ 0 0).
  rewrite [RHS]mxE mulr1n => <-.
  exact: (dvdr_mulmxl _ (dvdr_mulmxr _ (dvdr_lsubmx (n0:=2) (dvdr_drsubmx _)))).
rewrite -[M]hsubmxK -/A1 -/A2 -[_ *m P1 *m _]mulmxA (mul_mx_row _ A1) -!mulmxA.
rewrite [row_mx (P1 *m A1) _ *m (_ *m _)]mulmxA mul_row_block ?simplmx !mulmxA.
have -> : lift0_mx L1 *m P2 *m C *m block_mx Q2 0 0 1%:M =
          lift0_mx L1 *m block_mx d2`_0%:M r 0 H'.
  rewrite -!mulmxA; congr (_ *m _); rewrite mulmxA [C]surgery2 -mulmxA.
  rewrite (mul_row_block D) ?simplmx mul_mx_row mulmxA -/H -[H]submxK.
  f_equal; apply/rowP=> i; rewrite !mxE H1 ?ord1 ?lshift0;
  by case: splitP=> // j hj; rewrite !mxE -hj.
rewrite -[lift0_mx L1 *m _ *m _]mulmxA (mulmx_block d2`_0%:M r) ?simplmx.
rewrite mulmx_block ?simplmx mulmxA -mulmxDl mulmxN mul_scalar_mx.
have -> : - (d2`_0 *: r') + r = 0.
  apply/rowP=> i; rewrite 4!mxE.
  case: odivrP=> /= [w ->|]; first by rewrite mulrC addrC subrr mxE.
  move: (Hdvd (lshift _ 0) (rshift 1 i)); rewrite -[H]submxK block_mxEur.
  by case/dvdrP=> w hw /(_ w); rewrite hw eqxx.
rewrite mul0mx diag_mx_seq_cons; f_equal; rewrite -[H']hsubmxK mulmxA.
rewrite (mul_mx_row _ (lsubmx H')) (mul_row_block (L1 *m lsubmx H')) ?simplmx.
rewrite -mulmxA hLdR; apply/rowP=> i; rewrite !mxE.
case: splitP=> j ->; rewrite !mxE //= mulr0n big_ord1 !mxE /H' /E row_mxKr h1.
case: splitP=> [[[] // []]|] //= [[]] //= m hm hh.
by rewrite !mxE big_ord_recl big_ord1 ?(mxE,mulr0n,mulr0,addr0).
Qed.

Arguments smith2xn : simpl never.

Lemma smithmxn_recP : forall m n (M : 'M[R]_(1 + (1 + m),1 + (1 + n))),
  smith_spec M (smithmxn_rec smith2x2 M).
Proof.
elim=> [|m ih [|n] A] /=; first exact: smith2xnP.
  case: smith2xnP=> L0 d R0 h1 h2 h3 h4.
  constructor; rewrite ?unitmx_tr //; apply/trmx_inj.
  by rewrite !trmx_mul !trmxK tr_diag_mx_seq mulmxA.
set A1 := usubmx A; set A2 := dsubmx A.
case: (ih) => P1 x Q1 hP1xQ1 x_sorted hP1 hQ1; rewrite hP1xQ1.
set C := col_mx (A1 *m Q1) _; set D := col_mx (row 0 C) (row 1 C).
set E := dsubmx (dsubmx C).
case: smith2xnP=> P2 y Q2 hP2yQ2 y_sorted hP2 hQ2.
set H := col_mx (P2 *m D *m Q2) (E *m Q2) : 'M[R]_(1 + (1 + _),1 + (1 + _)).
set y0 := y`_0; set c := dlsubmx H; set c' := map_mx _ _; set H' := drsubmx H.
case: ih=> L1 d R1; rewrite -mulmxA=> hLdR d_sorted hL1 hR1.
have dvd_y0_x0 : y0 %| x`_0.
  have -> : x`_0 = D (rshift 1 0) 0.
    rewrite col_mxEd !mxE split1.
    by case: unliftP=> // [[[]]] //= i _; rewrite !mxE.
  move/(canRL (mulmxK hQ2))/(canRL (mulKmx hP2)): hP2yQ2=> ->.
  apply: dvdr_mulmxl=> i j; apply: dvdr_mulmxr=> {}i {}j.
  by rewrite !mxE; case: (i == j :> nat); rewrite ?sorted_nth0 ?mulr0n.
have hx0 i j : x`_0 %| x`_i *+ (i == j).
  by case: (i == j :> nat); rewrite ?sorted_nth0 // mulr0n dvdr0.
have Hdvd i j : y0 %| H i j.
  rewrite -[(1 + (1 + _))%N]/(2 + _)%N; apply: dvdr_col_mx; split=> {}i {}j.
    rewrite hP2yQ2 !mxE.
    by case: (i == j :> nat); rewrite ?sorted_nth0 // mulr0n dvdr0.
  apply: dvdr_mulmxr=> {}i {}j; rewrite /E col_mxKd.
  apply: dvdr_dsubmx=> {}i {}j; rewrite !mxE.
  move: (dvdr_trans dvd_y0_x0 (hx0 i j)).
  by case: (i == j :> nat); rewrite ?(mulr0n,dvdr0,mulr1n).
constructor; last first.
- by rewrite !unitmx_mul hQ1 hQ2 unitmxE det_lblock det1 mul1r -unitmxE.
- rewrite !unitmx_mul /lift0_mx ?(unitmxE,det_lblock,@det_lblock _ 2,det1,mul1r).
  by rewrite mulr1 -!unitmxE hL1 hP1 hP2.
- apply: sorted_cons=> //.
  move/matrixP: hLdR => /(_ 0 0); rewrite [RHS]mxE mulr1n => <-.
  exact: (dvdr_mulmxl L1 (dvdr_mulmxr R1 (dvdr_drsubmx Hdvd))).
rewrite -[A]vsubmxK -!mulmxA [_ *m (col_mx A1 _ *m _)]mulmxA mul_block_col.
rewrite !mul0mx addr0 add0r mul1mx [_ *m (Q1 *m _)]mulmxA [_ *m Q1]mul_col_mx.
rewrite hP1xQ1 [_ *m (C *m _)]mulmxA [_ *m (Q2 *m _)]mulmxA diag_mx_seq_cons.
have -> : block_mx P2 0 0 1%:M *m C *m Q2 = block_mx y0%:M 0 c H'.
  rewrite [C]surgery mul_block_col ?simplmx mul_col_mx -/H -[H]submxK.
  f_equal; apply/rowP=> i; rewrite !mxE hP2yQ2;
  by case: splitP=> // j hj; rewrite !mxE -hj.
rewrite !mulmx_block ?simplmx -hLdR; congr block_mx.
rewrite -mulmxA mulNmx -mulmxN -mulmxDr mul_mx_scalar.
suff -> : - (y0 *: c') + c = 0 by rewrite mulmx0.
apply/colP=> i; rewrite 4!mxE.
case: odivrP=> /= [w ->|]; first by rewrite mulrC addrC subrr mxE.
move: (Hdvd (rshift 1 i) (lshift _ 0)); rewrite -[H]submxK block_mxEdl.
by case/dvdrP=> w hw /(_ w); rewrite hw eqxx.
Qed.

Lemma smithmxnP : forall m n (M : 'M[R]_(m,n)),
  smith_spec M (smithmxn smith2x2 M).
Proof.
case=> [|[[|[|n M]]|m [|[M|n M]]]] /=;
  do ?by constructor; rewrite ?unitmx1 ?flatmx0 ?thinmx0 ?diag_mx_seq_nil.
- constructor; rewrite ?unitmx1 // mul1mx mulmx1.
  by apply/rowP=> i; rewrite ord1 !mxE.
- exact: (smith1xnP _ (@smith2xnP _)).
- case: (smith1xnP _ (@smith2xnP _))=> L1 d R1 h1 h2 h3 h4.
  constructor; rewrite ?unitmx_tr //.
  by apply/trmx_inj; rewrite !trmx_mul !trmxK tr_diag_mx_seq mulmxA.
exact: smithmxn_recP.
Qed.

End Smith2x2_correctness.

(* Bézout domains are Hermite rings *)
Section Bezout_hermite.

Variable R : bezoutDomainType.

Definition hermite (M : 'M[R]_2) := Bezout_step (M 0 0) (M 1 0) M 0.

Lemma hermite10 M : (hermite M) 1 0 = 0.
Proof.
rewrite /hermite Bezout_stepE /Bezout_mx /combine_mx.
rewrite !mxE !big_ord_recl big_ord0 addr0 /=.
case: egcdrP=> g u v a1 b1 heq hg ha1 hb1.
rewrite ?(mxE,mulr0n,mulr1n,mulr0,mulr1,addr0,add0r) /=.
have -> : lift 0 0 = 1 by move=> n; apply/ord_inj.
by rewrite ha1 hb1 !mulrA -mulrDl [a1 * b1]mulrC -mulrDl addrC subrr !mul0r.
Qed.

End Bezout_hermite.

Section Mx2.

Variable R : comRingType.

Definition mx2 a b c d := block_mx (a%:M : 'M[R]_1) b%:M c%:M d%:M.

Lemma mx2_E00 a b c d : (mx2 a b c d) 0 0 = a.
Proof.
by do ?(rewrite mxE split1; case: unliftP=> //=); rewrite mxE mulr1n.
Qed.

Lemma mx2_E01 a b c d : (mx2 a b c d) 0 1 = b.
Proof.
by do ?(rewrite mxE split1; case: unliftP=> //= * ); rewrite ord1 mxE mulr1n.
Qed.

Lemma mx2_E10 a b c d : (mx2 a b c d) 1 0 = c.
Proof.
by do ?(rewrite mxE split1; case: unliftP=> //= * ); rewrite ord1 mxE mulr1n.
Qed.

Lemma mx2_E11 a b c d : (mx2 a b c d) 1 1 = d.
Proof.
have -> : 1 = rshift 1 0 :> 'I_2 by apply/ord_inj.
by rewrite block_mxEdr mxE mulr1n.
Qed.

Lemma detmx2 a b c d : \det (mx2 a b c d) = a * d - c * b.
Proof. by rewrite det2 mx2_E00 mx2_E01 mx2_E10 mx2_E11. Qed.

End Mx2.

(* The necessary and sufficient first order condition in Kaplanskys paper *)
Section Kaplansky_suff.

Variable R : bezoutDomainType.

Variable kap : R -> R -> R -> R * R.

Hypothesis kapP : forall (a b c : R),
  gcdr a (gcdr b c) %= 1 ->
  let: (p,q) := kap a b c in coprimer (p * a) (p * b + q * c).

Lemma coprimerP (a b : R) :
  reflect (exists xy, xy.1 * a + xy.2 * b = 1) (coprimer a b).
Proof.
case: (egcdrP a b) => g u v a1 b1 h1 h2 h3 h4.
apply: (iffP idP)=> [/(eqd_trans h2) | [[x y]]] /=.
  rewrite -unitd1; case/unitrP=> x [hx1 hx2]; exists (x*u,x*v).
  by rewrite -!mulrA -mulrDr h3 h4 !mulrA -mulrDl h1 mul1r.
rewrite {1}h3 {1}h4 !mulrA -mulrDl=> H; move: (@unitr1 R).
rewrite -H unitrM !unitd1=> /andP [_ H'].
by rewrite /coprimer eqd_sym (eqd_trans _ h2) // eqd_sym.
Qed.

Definition kapW a b c : R * R :=
  let: (p,q) := kap a b c in
  if coprimerP (p * a) (p * b + q * c) is ReflectT P
     then projT1 (sig_eqW P) else (0,0).

Lemma kapWP a b c :
  let: (p,q) := kap a b c  in coprimer (p * a) (p * b + q * c) ->
  let: (x,y) := kapW a b c in x * (p * a) + y * (p * b + q * c) = 1.
Proof.
rewrite /kapW; case: kap => p q.
case: coprimerP=> // [[[x y]]] /= Hxy _.
by case: sig_eqW=> /= [[]].
Qed.

Definition egcdr3 (a b c : R) :=
  let: (g',u1,v1,b1,c1) := egcdr b c in
  let: (g, u, v, a1,g1) := egcdr a g' in
  (g, u, v * u1, v * v1, a1, b1 * g1, c1 * g1).

Variant egcdr3_spec a b c : R * R * R * R * R * R * R -> Type :=
  EgcdrSpec g x y z a1 b1 c1 of x * a1 + y * b1 + z * c1 = 1
  & g %= gcdr a (gcdr b c)
  & a = a1 * g & b = b1 * g & c = c1 * g : egcdr3_spec a b c (g,x,y,z,a1,b1,c1).

Lemma egcdr3P a b c : egcdr3_spec a b c (egcdr3 a b c).
Proof.
rewrite /egcdr3; case: egcdrP=> /= g' u1 v1 b1 c1 heq hg' hb1 hc1.
case: egcdrP=> /= g u v a1 g1 heq' hg ha1 hg1.
constructor; rewrite -?mulrA -?hg1 ?(eqd_trans hg) ?eqd_gcd //.
by rewrite -addrA -mulrDr !mulrA -mulrDl heq mul1r.
Qed.

Definition kap_smith (M : 'M[R]_2) : 'M[R]_2 * seq R * 'M[R]_2 :=
  let: A := hermite M in
  let: a00 := A 0 0 in let: a01 := A 0 1 in let: a11 := A 1 1 in
  let: (d,_,_,_,a,b,c) := egcdr3 a00 a01 a11 in
  if d == 0 then (Bezout_mx (M 0 0) (M 1 0) 0,[::],1%:M) else
    let: (p,q) := kap a b c in
    let: (x1,y1) := kapW a b c in
    let: (x,y) := (a * x1 + y1 * b, c * y1) in
     (mx2 p q (- y) x *m Bezout_mx (M 0 0) (M 1 0) 0,
      map (fun x => d * x) [:: 1; - a * c],
      mx2 x1 (p * b + q * c) y1 (- p * a)).

Arguments map : simpl never.

Lemma kap_smithP (M : 'M[R]_2) : smith_spec M (kap_smith M).
Proof.
rewrite /kap_smith; set A := hermite _ : 'M_(1+1).
set a00 := (_ 0 0); set a01 := (_ 0 1); set a11 := (_ 1 1).
case: egcdr3P=> /= d xd yd zd a b c heq; rewrite eqd_sym=> hgcd ha hb hc.
have [d0|dn0] := boolP (d == 0).
  constructor; rewrite ?unitmx1 ?unit_Bezout_mx // mulmx1 -Bezout_stepE.
  have -> : Bezout_step (M 0 0) (M 1 0) M 0 = A by [].
  rewrite diag_mx_seq_nil -(@block_mx0 _ 1 _ 1).
  have -> : A = mx2 a00 a01 0 a11.
    rewrite -[A]submxK.
    congr block_mx; apply/rowP=> i; rewrite !mxE ord1 ?lshift0 ?mulr1n ?rshift1 //;
    have -> // : lift 0 0 = 1 by move=> n; apply/ord_inj.
    by rewrite hermite10.
  by rewrite /mx2; f_equal; rewrite ?ha ?hb ?hc ?(eqP d0) ?mulr0 -scalemx1 scale0r.
have /kapP : gcdr a (gcdr b c) %= 1.
  rewrite -(eqd_mul2r _ _ dn0) mul1r (eqd_trans _ hgcd) //.
  rewrite (eqd_trans (mulr_gcdl _ _ _)) //.
  by rewrite -ha eqd_gcd ?(eqd_trans (mulr_gcdl _ _ _)) // -hb -hc.
move: (kapWP a b c); case: kap => p q H1 H3; move: (H1 H3).
case: kapW=> x1 y1 => {H1 H3} H; move: (H).
rewrite mulrCA [x1 * a]mulrC mulrDr [y1 * _]mulrCA addrA -mulrDr.
set x := a * x1 + y1 * b; rewrite mulrCA [y1 * c]mulrC; set y := c * y1=> Hxy.
constructor.
* set M1 := mx2 _ _ _ _; set M2 := mx2 _ _ _ _.
  rewrite -!mulmxA [_ *m (_ *m M2)]mulmxA -Bezout_stepE.
  have -> : Bezout_step (M 0 0) (M 1 0) M 0 = d *: mx2 a b 0 c.
    rewrite scale_block_mx -!mul_scalar_mx -!scalar_mxM mulr0 mulrC -ha mulrC.
    rewrite -hb -mulrC -hc -[Bezout_step _ _ _ _](@submxK _ 1).
    have h1 : lift 0 0 = 1 by move=> n; apply/ord_inj.
    f_equal; apply/rowP=> i; rewrite !mxE ord1 ?(lshift0,rshift1,h1) mulr1n //.
    by rewrite hermite10.
  rewrite -scalemxAl -!scalemxAr -diag_mx_seq_scale; congr (_ *: _).
  rewrite /M1 /M2 /mx2 !(@mulmx_block _ 1) -[0%:M]scalemx1 scale0r !mul0mx.
  rewrite !add0r -?(scalar_mxM,raddfD) /= mulrC [_ * y1]mulrC.
  rewrite !diag_mx_seq_cons diag_mx_seq_nil.
  f_equal.
  - by rewrite mulrC Hxy.
  - rewrite [a * _ + _]addrC [a * _]mulrDr addrA mulrCA [a * _]mulrCA.
    rewrite [b * a]mulrC mulNr addNr add0r ![_ * (- p * _)]mulrCA mulNr.
    by rewrite [c * _]mulrC [q * (_ * _)]mulrCA addrN -[0%:M]scalemx1 scale0r.
  - by rewrite -/x -/y mulNr mulrC addNr -[0%:M]scalemx1 scale0r.
  - apply/matrixP=> i j; rewrite !ord1 {i j} [RHS]mxE split1.
    case: unliftP=> //= _; rewrite [RHS]mxE split1; case: unliftP => //= _.
    rewrite !mxE !mulr1n !mulrDr !mulNr !mulrN opprK [_ + y * _]addrC addrA.
    rewrite [p * b]mulrC [a * (b * p)]mulrCA [p * a]mulrC addrN sub0r.
    rewrite ![_ * (a * _)]mulrCA -!mulNr -mulrDr mulrCA mulrAC -mulrA -mulrDr.
    by rewrite [x * p]mulrC addrC -mulrA Hxy mulr1.
* by apply: sorted_cons => //=; rewrite mulr1 dvdr_mulr.
* rewrite !unitmx_mul unit_Bezout_mx !unitmxE detmx2 /x /y mulNr opprK.
  by rewrite [_ * q]mulrC Hxy unitr1.
by rewrite unitmxE detmx2 mulNr mulrN -opprD -mulN1r unitrMl ?unitrN1 // H unitr1.
Qed.

End Kaplansky_suff.

Section Kaplansky_necc.

Variable R : edrType.

Variables a b c : R.

Lemma kapP : gcdr a (gcdr b c) %= 1 ->
             exists p q, coprimer (p * a) (p * b + q * c).
Proof.
case: (smithP (mx2 a b 0 c))=> /= P d Q; rewrite -dvdr1.
set D := diag_mx_seq _ _ _ => heq hsorted P_unitmx Q_unitmx Hgcd.
exists (P 0 0); exists (P 0 1).
suff [[x y /=]] : exists xy, xy.1 * (P 0 0 * a) +
                             xy.2 * (P 0 0 * b + P 0 1 * c) %= 1.
  rewrite -unitd1; case/unitrP=> z [hz1 _].
  by apply/coprimerP; exists (z*x,z*y); rewrite -!mulrA -mulrDr.
exists (Q 0 0,Q 1 0)=> /=.
suff : (D 0 0) \is a GRing.unit.
  rewrite -unitd1 -heq; do 2!(rewrite !mxE big_ord_recl big_ord1).
  rewrite big_ord_recl big_ord1 mx2_E00.
  have -> : lift 0 0 = 1 :> 'I_2 by apply/ord_inj.
  by rewrite mx2_E10 mx2_E11 mx2_E01 mulr0 addr0 mulrC [_ * Q 1 0]mulrC.
rewrite unitd1 -dvdr1; apply/(dvdr_trans _ Hgcd).
have Hij : forall i j, D 0 0 %| (mx2 a b 0 c) i j.
  rewrite (canRL (mulKmx P_unitmx) (canRL (mulmxK Q_unitmx) heq)).
  apply: dvdr_mulmxl; apply: dvdr_mulmxr=> i j; rewrite !mxE eqxx /=.
  case: eqP => _ /=; last by rewrite mulr0n dvdr0.
  by rewrite !mulr1n; exact: sorted_nth0.
rewrite !dvdr_gcd; move: (Hij 0 0) (Hij 0 1) (Hij 1 1).
by rewrite mx2_E00 mx2_E01 mx2_E11=> -> -> ->.
Qed.

End Kaplansky_necc.

Section AdequacyGdco.

Variable R : gcdDomainType.

Variant adequate_spec (a b : R) : R -> Type :=
  | AdequateSpec0 of b = 0 : adequate_spec a b 0
  | AdequateSpec r of b != 0
                      & r %| b
                      & coprimer r a
                      & (forall d, d * r %| b -> d \isn't a GRing.unit ->
                          ~~ coprimer d a)
                      : adequate_spec a b r.

Variant gdco_spec (a b : R) : R -> Type :=
  | GdcoSpec0 of b = 0 : gdco_spec a b 0
  | GdcoSpec r of b != 0
                  & r %| b
                  & coprimer r a
                  & (forall d, d %| b -> coprimer d a -> d %| r)
                  : gdco_spec a b r.

Lemma adequate_gdco a b r : adequate_spec a b r -> gdco_spec a b r.
Proof.
move=> [->|]; first by constructor => //; rewrite eqxx.
move=> {}r b_neq0 dvd_rb cra /= Hs; constructor=> //=.
move=> /= d dvd_db cda; have [du|dnu] := boolP (d \is a GRing.unit).
  by rewrite dvdUr ?eqd1.
case: dvdrP dvd_rb => // [[s ->]] _ in Hs dvd_db *.
rewrite -(@euclid _ s) // /coprimer 1?mulrC // -unitd1.
apply: (contraLR (Hs _ _)); first by rewrite dvdr_mul // dvdr_gcdr.
rewrite /coprimer -(eqd_ltrans (gcdrA _ _ _)).
exact: coprimer_dvdr (dvdr_gcdr _ _) _.
Qed.

Lemma gdco_adequate a b r : gdco_spec a b r -> adequate_spec a b r.
Proof.
move=> [|/= {}r b_neq0 rb cra Hd]; first by constructor.
constructor => //= d dr_dvd_b; apply: contra => cda.
case: dvdrP rb => [[s ->]|//] {b} _ in Hd dr_dvd_b b_neq0 *.
have r_neq0 : r != 0 by move: b_neq0; rewrite mulf_eq0 negb_or => /andP [].
have := Hd _ dr_dvd_b.
rewrite -[r as X in _ %| X]mul1r dvdr_mul2r // dvdr1 unitd1; apply.
by rewrite coprimer_mull cra cda.
Qed.

End AdequacyGdco.

Section AdequacyEDR.

Variable R : bezoutDomainType.

Variable gdco : R -> R -> R.
Hypothesis gdcoP : forall p q, gdco_spec p q (gdco p q).

Lemma coprimer_gdco q p : p != 0 -> coprimer (gdco q p) q.
Proof. by case: gdcoP => [->|//]; rewrite eqxx. Qed.

Definition gdco_kap (a b c : R) : R * R :=
  let: (_, x, y, z, _, _, _) := egcdr3 a b c in
  if a == 0 then (y, z)
  else let: r := gdco c a in
       let: (g, _, v, _, _) := egcdr r c in
       if (1 - b) %/? g is Some k' then (1, k' * v) else (1, 0).

Lemma gdco_kapP (a b c : R) : gcdr a (gcdr b c) %= 1 ->
  let: (p, q) := gdco_kap a b c in coprimer (p * a) (p * b + q * c).
Proof.
rewrite /gdco_kap /=.
have [g /= x y z a1 b1 c1] := egcdr3P a b c.
move=> Habc1 /eqd_ltrans <- Ha Hb Hc g_eq1.
move: Habc1 g_eq1 => /(congr1 ( *%R^~ g)); rewrite !mulrDl mul1r.
rewrite -!mulrA -Ha -Hb -Hc {Ha Hb Hc} => <- {g a1 b1 c1}.
have [-> | an0 Habc] := eqVneq a 0.
  rewrite /coprimer !mulr0 add0r => Hbc.
  by rewrite (eqd_ltrans (gcd0r _)).
case: egcdrP => /= g u v a' b' Hab' Hg Hc Hr.
move: Hab' Hg => /(congr1 ( *%R^~ g)); rewrite mulrDl mul1r.
rewrite -!mulrA -Hc -Hr {Hc Hr} => <- {a' b' g}.
rewrite (eqd_rtrans (coprimer_gdco c an0)) => Hu.
have: 1 %| 1 - b by rewrite dvd1r.
rewrite -(eqd_dvdl _ Hu) /dvdr.
case: odivrP => //= k' /(canRL (addrNK _)).
rewrite mulrDr !mulrA addrAC !mul1r => Hk' _.
rewrite /coprimer; set d := gcdr _ _.
have cdc: coprimer d c.
  apply: gcdr_def; rewrite ?dvd1r // => t td tc.
  rewrite -(eqd_dvdr _ Habc) -addrA dvdr_add //.
    by rewrite dvdr_mull ?(dvdr_trans td) /d ?dvdr_gcdl.
  rewrite -[y * b](@addrNK _ (y * (b + k' * v * c))).
  rewrite {1}mulrDr opprD addrA subrr sub0r addrAC dvdr_add //; last first.
    by rewrite dvdr_mull // (dvdr_trans td) /d // dvdr_gcdr.
  by rewrite !mulrA addrC -mulrBl dvdr_mull.
suff dr: d %| gdco c a.
  by rewrite -dvdr1 Hk' -addrA dvdr_add // /d ?dvdr_gcdr // dvdr_mull.
case: gdcoP => /= [a_eq0|r a_neq0 ra crc]; first by rewrite a_eq0 eqxx in an0.
by apply => //; rewrite dvdr_gcdl.
Qed.

Definition gdco_smith := smithmxn (kap_smith gdco_kap).

Lemma gdco_smithP m n (M : 'M[R]_(m,n)) : smith_spec M (gdco_smith M).
Proof.
rewrite /gdco_smith.
by apply: smithmxnP; apply: kap_smithP; apply: gdco_kapP.
Qed.

Definition gdcoEDRMixin := EDR.Mixin gdco_smithP.
Canonical gdcoEDRType   := Eval hnf in EDRType R gdcoEDRMixin.

End AdequacyEDR.

Section BezoutKrull1.

Variable R : bezoutDomainType.

Implicit Types a b u : R.

Hypothesis krull1 : forall a u, exists m v, a %| u ^+ m * (1 - u * v).

Lemma krull1_factor a b :
  exists n b1 b2, [&& 0 < n, b == b1 * b2, coprimer b1 a & b2 %| a ^+ n].
Proof.
wlog suff: / exists n b1 b2,
             [&& 0 < n, b %= b1 * b2, coprimer b1 a & b2 %| a ^+ n].
  case=> n [b1 [b2 /and4P [Hn Hb Hb1 Hb2]]].
  have [b2_eq0|b2_neq0] := eqVneq b2 0.
    exists n, b1, b2; move: Hn Hb Hb1 Hb2.
    by rewrite b2_eq0 mulr0 eqdr0 => -> -> -> ->.
  have : b2 %| b by rewrite (eqd_dvdr _ Hb) dvdr_mull.
  case: dvdrP Hb => [[b1' ->]|//]; rewrite eqd_mul2r // => eq_b1'.
  exists n, b1', b2; rewrite !eqxx Hn Hb2 /coprimer andbT /=.
  by rewrite (eqd_ltrans (eqd_gcd eq_b1' (eqdd _))).
have kidem x : exists d (s : R) k,
  [&& 0 < d, b %| s ^+ 2 - s, b %| x ^+ d - (x ^+ d) * s
                               & b %| s - k * x ^+ d].
  have [m [y]] := krull1 b x.
  have [-> Hy|m_gt0 Hy] := posnP m.
    exists 1%N, 1, y; rewrite !expr1n mulr1 expr1 !subrr dvdr0 /=.
    by move: Hy; rewrite expr0 mul1r mulrC.
  set s := (x * y) ^+ m; exists m, s, (y ^+ m).
  have xsn n : b %| x ^+ m * (x * y) ^+ n - x ^+ m.
    elim: n => [|n ihn]; first by rewrite mulr1 subrr dvdr0.
    rewrite -[X in X - _](addrNK (x ^+ m * (x * y) ^+ n)) -addrA dvdr_add //.
    rewrite exprS mulrA -mulrBl dvdr_mulr //.
    by rewrite -dvdrN opprB -[X in X - _]mulr1 -mulrBr.
  have s_idem n : b %| s * (x * y) ^+ n - s.
    elim: n => [|n ihn]; first by rewrite mulr1 subrr dvdr0.
    rewrite -[X in X - _](addrNK (s * (x * y) ^+ n)) -addrA dvdr_add //.
    rewrite exprS mulrA -mulrBl dvdr_mulr //.
    rewrite /s -exprSr !exprMn exprSr exprS mulrA -mulrBl dvdr_mulr //.
    by rewrite -dvdrN opprB -{1}[x ^+ m]mulr1 -mulrA -mulrBr.
  rewrite m_gt0 (s_idem m) /= -opprB dvdrN (xsn m) /=.
  by rewrite mulrC -exprMn subrr dvdr0.
have [d [s [k /and4P [d_gt0 s_idem ads ska]]]] := kidem a.
set b1 := gcdr b (1 - s); set b2 := gcdr b s; exists d, b1, b2.
have dvd_b2_bd: b2 %| a ^+ d.
  rewrite -[a ^+ d](addrNK (a ^+ d * s)) dvdr_add ?andbT //=; last 2 first.
    by rewrite (dvdr_trans (dvdr_gcdl _ _)) //.
  by rewrite dvdr_mull // dvdr_gcdr.
have eq_b : b %= b1 * b2.
  rewrite eqd_def /b1 /b2.
  rewrite -[b as X in _ %| X](addrNK (b * s)).
  rewrite -[X in X - b * s]mulr1 -mulrBr dvdr_add ?andbT //=; last 2 first.
    by rewrite mulrC dvdr_mul // (dvdr_gcdl, dvdr_gcdr).
  by rewrite dvdr_mul // (dvdr_gcdl, dvdr_gcdr).
  have [[x y gbs] [x' y' gbs']] := (bezoutP b s, bezoutP b (1 - s)).
  rewrite (eqd_dvdr _ (eqd_mulr _ gbs')) (eqd_dvdr _ (eqd_mull _ gbs)).
  rewrite [1 - s]lock !(mulrDr, mulrDl) -!lock !addrA dvdr_add //=.
    by rewrite ![_ * b * _](mulrAC, mulrA) !mulrA -!mulrDl dvdr_mull.
  by rewrite mulrCA -mulrA dvdr_mull // dvdr_mull // mulrBl mul1r -opprB dvdrN.
rewrite dvd_b2_bd eq_b d_gt0 andbT //=.
have: coprimer b1 b2.
  apply: gcdr_def; rewrite ?dvd1r //= => p ps' ps.
  rewrite -[1](addrNK s) dvdr_add //.
    by rewrite (dvdr_trans ps') ?dvdr_gcdr.
  by rewrite (dvdr_trans ps) ?dvdr_gcdr.
have b2_eq : gcdr b s %= gcdr b (a ^+ d).
  rewrite eqd_def !dvdr_gcd !dvdr_gcdl /=.
  rewrite -[a ^+ d as X in _ %| X](addrNK ((a ^+ d) * s)).
  rewrite dvdr_add //=; last 2 first.
    by rewrite (dvdr_trans (dvdr_gcdl _ _)).
    by rewrite dvdr_mull ?dvdr_gcdr.
  rewrite -[s as X in _ %| X](addrNK (k * (a ^+ d))) dvdr_add //.
    by rewrite (dvdr_trans (dvdr_gcdl _ _)).
  by rewrite dvdr_mull ?dvdr_gcdr.
rewrite /b2 /coprimer (eqd_ltrans (eqd_gcd (eqdd _) b2_eq)).
rewrite (eqd_ltrans (gcdrA _ _ _)).
have gb1b: gcdr b1 b %= b1.
  rewrite eqd_def dvdr_gcdl dvdr_gcd dvdrr /=.
  by rewrite (eqd_dvdr _ eq_b) dvdr_mulr.
rewrite (eqd_ltrans (eqd_gcd gb1b (eqdd _))).
apply: coprimer_dvdr.
by rewrite -[d]prednK // exprS dvdr_mulr.
Qed.

Lemma krull1_adequate a b : { r : R & adequate_spec a b r }.
Proof.
have [] := eqVneq b 0; first by exists 0; constructor.
move: (krull1_factor a b) => factored.
have /sigW : (exists (x : nat * (R * R)),
      [&& 0 < x.1, b == x.2.1 * x.2.2, coprimer x.2.1 a & x.2.2 %| a ^+ x.1]).
  by case: factored => n [b1 [b2]]; exists (n,(b1,b2)).
case=> /= [[n [b1 b2]]] /= /and4P [ngt0 /eqP -> ca1b dvda2bn aneq0].
exists b1; constructor => /= [|||d] //; first by rewrite dvdr_mulr.
rewrite mulrC dvdr_mul2l ?unitd1 => [dvdda2|].
  apply: contra; rewrite -(@coprimer_pexpr _ n) //.
  apply: dvdr_coprime; exact: (dvdr_trans dvdda2 dvda2bn).
by apply: contraNneq aneq0 => ->; rewrite mul0r.
Qed.

Definition krull1_gdco a b := projT1 (krull1_adequate a b).

Lemma krull1_gdcoP a b : gdco_spec a b (krull1_gdco a b).
Proof.
rewrite /krull1_gdco; case: (krull1_adequate a b)=> r hr /=.
exact: adequate_gdco.
Qed.

Definition krull1_smith := gdco_smith krull1_gdco.

Lemma krull1_smithP m n (M : 'M[R]_(m,n)) : smith_spec M (krull1_smith M).
Proof. by apply: gdco_smithP=> a b; apply: krull1_gdcoP. Qed.

Definition krull1EDRMixin := EDR.Mixin krull1_smithP.
Canonical krull1EDRType   := Eval hnf in EDRType R krull1EDRMixin.

End BezoutKrull1.

Section AdequacyPID.

Variable R : pidType.

Implicit Types a b : R.

Lemma pid_gdco a b : {r : R & gdco_spec a b r}.
Proof.
have [->|b_neq0] := eqVneq b 0; first by exists 0; constructor.
elim: (sdvdr_wf b) => {}b _ ihp in b_neq0 *.
have [cba|ncba] := boolP (coprimer a b).
  by exists b; constructor; rewrite ?cpa ?orbT // coprimer_sym.
have := dvdr_gcdr a b; case: dvdrP => // [/choice.sig_eqW /= [r b_eq _]].
have := b_neq0; rewrite b_eq mulf_eq0 negb_or => /andP [r_neq0 g_neq0].
have [||r' r_gdco] // := ihp r.
  by rewrite sdvdr_def b_eq dvdr_mulr //= dvdr_mull_l.
case: r_gdco r_neq0 => [->|/= {}r' _ dvdr'r cr'q r'P r_neq0].
  by rewrite eqxx.
exists r'; constructor; rewrite ?dvdr_mulr // -?b_eq //=.
move=> d dp cdq; apply: r'P => //.
rewrite -(@euclid _ (gcdr a b)) -?b_eq //.
exact: coprimer_dvdr (dvdr_gcdl _ _) _.
Qed.

Definition pid_smith := gdco_smith (fun a b => projT1 (pid_gdco a b)).

Lemma pid_smithP m n (M : 'M[R]_(m,n)) : smith_spec M (pid_smith M).
Proof.
by rewrite /pid_smith; apply: gdco_smithP=> a b; case: (pid_gdco a b).
Qed.

Definition pidEDRMixin := EDR.Mixin pid_smithP.
Canonical pidEDRType   := Eval hnf in EDRType R pidEDRMixin.

(* This should be provable *)
(* Lemma pri_krull1 (a : R) (u : R) : exists m v, a %| u ^+ m * (1 - u * v). *)
(* Proof. *)
(* admit. *)
(* Qed. *)

End AdequacyPID.


(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 5 *)

Require Import Frap Datatypes.
Export Datatypes.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu),
 * Ben Sherman (sherman@csail.mit.edu)
 *)

Set Implicit Arguments.

(** * Correctness of a Producer-Consumer implementation *)

(* In this problem set, we'll prove the correctness of a
 * Producer-Consumer implementation.
 * For general specification, refer to this article first:
 *   https://en.wikipedia.org/wiki/Producer%E2%80%93consumer_problem
 *
 * Like with the last problem set, we will provide hints
 * on the class website. You may wish to first attempt the problem
 * set without consulting the hints, but they are available if
 * you wish.
 *
 * We will implement Producer-Consumer with locks.
 * In addition to the concurrency control, we have to think about interleavings
 * between Producer and Consumer, since they communicate via a buffer.
 *
 * Therefore, in order to solve the problem, you should either 1) carefully
 * abstract the system enough to check with the FRAP model checker, or 2)
 * directly prove the given invariant (possibly with parameterized PRD_COUNT).
 *)

(* Here's another example of a reusable program for building multithreaded
 * systems out of systems for single threads.  We will build in general handling
 * of a standard locking protocol, in contrast to the freeform notion of shared
 * state in the [parallel] combinator we saw in class. *)

(* First, a general record type for adding a lock bit to a type of shared
 * state: *)
Record sharedWithLock shared := { Lock : bool; SharedOrig : shared }.

(* We force single-thread systems to use instantiations of this type for
 * their private state, to signal when they want to lock or unlock. *)
Inductive stateWithLock private :=
| Aprivate : private -> stateWithLock private
(* This is a state for a thread whose next step is *not* lock-related. *)

| Alock : stateWithLock private
| Aunlock : stateWithLock private
(* These states respectively indicate that the next thing the thread wants to do
 * is claim or relinquish the lock.  For simplicity, we make the arbitrary
 * choice that threads waiting to lock or unlock store no additional local
 * state, but the approach would generalize to including that state. *).

Arguments Alock {_}.
Arguments Aunlock {_}.
(* These lines ask Coq to infer the [private] type associated with a use of one
 * of the second two constructors. *)

(* Initial states of the two-thread system combine initial states of the
 * constituent systems, with the lock initialized to [false]. *)
Inductive locking_init shared private1 private2
          (init1 : threaded_state shared (stateWithLock private1) -> Prop)
          (init2 : threaded_state shared (stateWithLock private2) -> Prop)
  : threaded_state (sharedWithLock shared)
                   (stateWithLock private1 * stateWithLock private2) -> Prop :=
| Ainit : forall sh pr1 pr2,
    init1 {| Shared := sh; Private := pr1 |} ->
    init2 {| Shared := sh; Private := pr2 |} ->
    locking_init init1 init2 {| Shared := {| Lock := false; SharedOrig := sh |};
                            Private := (pr1, pr2) |}.

(* Here's the combined transition relation.  The rules come in symmetric pairs,
 * based on which of the two threads steps. *)
Inductive locking_step shared private1 private2
          (step1 : threaded_state shared (stateWithLock private1) ->
                   threaded_state shared (stateWithLock private1) -> Prop)
          (step2 : threaded_state shared (stateWithLock private2) ->
                   threaded_state shared (stateWithLock private2) -> Prop)
  : threaded_state (sharedWithLock shared) (stateWithLock private1 * stateWithLock private2) ->
    threaded_state (sharedWithLock shared) (stateWithLock private1 * stateWithLock private2) ->
    Prop :=

(* First, a thread that is not asking to lock or unlock may simply take a step
 * as normal. *)
| AstepN1 : forall sh pr1 pr2 sh' l pr1',
    step1 {| Shared := sh; Private := Aprivate pr1 |} {| Shared := sh'; Private := pr1' |} ->
    locking_step step1 step2
             {| Shared := {| Lock := l; SharedOrig := sh |}; Private := (Aprivate pr1, pr2) |}
             {| Shared := {| Lock := l; SharedOrig := sh' |}; Private := (pr1', pr2) |}
| AstepN2 : forall sh pr1 pr2 sh' l pr2',
    step2 {| Shared := sh; Private := Aprivate pr2 |} {| Shared := sh'; Private := pr2' |} ->
    locking_step step1 step2
             {| Shared := {| Lock := l; SharedOrig := sh |}; Private := (pr1, Aprivate pr2) |}
             {| Shared := {| Lock := l; SharedOrig := sh' |}; Private := (pr1, pr2') |}

(* A thread asking to lock may only step when the lock is not held, and then the
 * step toggles the lock. *)
| AstepLock1 : forall sh pr2 pr1',
    step1 {| Shared := sh; Private := Alock |} {| Shared := sh; Private := pr1' |} ->
    locking_step step1 step2
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (Alock, pr2) |}
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (pr1', pr2) |}
| AstepLock2 : forall sh pr1 pr2',
    step2 {| Shared := sh; Private := Alock |} {| Shared := sh; Private := pr2' |} ->
    locking_step step1 step2
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (pr1, Alock) |}
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (pr1, pr2') |}

(* A thread asking to unlock may only step when the lock is held, and then the
 * step toggles the lock. *)
| AstepUnlock1 : forall sh pr2 pr1',
    step1 {| Shared := sh; Private := Aunlock |} {| Shared := sh; Private := pr1' |} ->
    locking_step step1 step2
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (Aunlock, pr2) |}
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (pr1', pr2) |}
| AstepUnlock2 : forall sh pr1 pr2',
    step2 {| Shared := sh; Private := Aunlock |} {| Shared := sh; Private := pr2' |} ->
    locking_step step1 step2
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (pr1, Aunlock) |}
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (pr1, pr2') |}.

(* Here's the final definition of a two-thread system with locking. *)
Definition locking shared private1 private2
           (sys1 : trsys (threaded_state shared (stateWithLock private1)))
           (sys2 : trsys (threaded_state shared (stateWithLock private2))) :=
  {| Initial := locking_init sys1.(Initial) sys2.(Initial);
     Step := locking_step sys1.(Step) sys2.(Step)
  |}.

(* PRD_COUNT is the number of produced items by Producer.
 * This is large enough that direct use of "model_check" for the system
 * takes really long. Thus, yes, during grading for this problem set, we will
 * just stop the checker if it takes a long time.
 *
 * Note that for PRD_COUNT = 15, we have hundreds of possible states.
 *)
Definition PRD_COUNT := 15.

(* Below is pseudocode of our Producer-Consumer implementation.  Producer always
 * produces "1" and pushes it to the buffer [buf].  Consumer pops the value from
 * the buffer and adds it to [acc].
 *)
(* <<
   queue buf = empty;
   int cnt = PRD_COUNT;
   int acc = 0;

   void produce() {
     int local;
     while (cnt > 0) {
       lock();
       cnt = cnt - 1;
       buf.push(1);
       unlock();
     }
   }

   void consume() {
     int local, val;
     while (true) {
       lock();
       val = buf.pop();
       acc = acc + val;
       unlock();
     }
   }
   >>
 *)

Inductive pd_thread :=
| CheckCount
| DecCount
| Push.

Inductive cs_thread :=
| Pop
| Acc (n : nat).

Record pdcs_global_state :=
  { buf : list nat;
    cnt : nat;
    acc : nat }.

Definition pd_state :=
  threaded_state pdcs_global_state (stateWithLock pd_thread).

Definition cs_state :=
  threaded_state pdcs_global_state (stateWithLock cs_thread).

Inductive pd_init : pd_state -> Prop :=
| PdInit :
    pd_init {| Shared := {| buf := nil; cnt := PRD_COUNT; acc := 0 |};
               Private := Aprivate CheckCount |}.

Inductive cs_init : cs_state -> Prop :=
| CsInit :
    cs_init {| Shared := {| buf := nil; cnt := PRD_COUNT; acc := 0 |};
                 Private := Alock |}.

Inductive pd_step : pd_state -> pd_state -> Prop :=
| PdCheckCount :
    forall b c a,
      pd_step   {| Shared := {| buf := b; cnt := S c; acc := a |};
                   Private := Aprivate CheckCount |}
                {| Shared := {| buf := b; cnt := S c; acc := a |};
                   Private := Alock |}
| PdLock :
    forall sh, pd_step        {| Shared := sh; Private := Alock |}
                         {| Shared := sh; Private := Aprivate DecCount |}
| PdDecCount :
    forall b c a,
      pd_step   {| Shared := {| buf := b; cnt := S c; acc := a |};
                   Private := Aprivate DecCount |}
                {| Shared := {| buf := b; cnt := c; acc := a |};
                   Private := Aprivate Push |}
| PdPush :
    forall b c a,
      pd_step   {| Shared := {| buf := b; cnt := c; acc := a |};
                   Private := Aprivate Push |}
                {| Shared := {| buf := 1 :: b; cnt := c; acc := a |};
                   Private := Aunlock |}
| PdUnlock :
    forall sh, pd_step        {| Shared := sh; Private := Aunlock |}
                         {| Shared := sh; Private := Aprivate CheckCount |}.

Inductive cs_step : cs_state -> cs_state -> Prop :=
| CsLock :
    forall sh, cs_step        {| Shared := sh; Private := Alock |}
                         {| Shared := sh; Private := Aprivate Pop |}
| CsPop :
    forall bh bt c a,
      cs_step   {| Shared := {| buf := bh :: bt; cnt := c; acc := a |};
                   Private := Aprivate Pop |}
                {| Shared := {| buf := bt; cnt := c; acc := a |};
                   Private := Aprivate (Acc bh) |}
| CsAcc :
    forall b c a v,
      cs_step   {| Shared := {| buf := b; cnt := c; acc := a |};
                   Private := Aprivate (Acc v) |}
                {| Shared := {| buf := b; cnt := c; acc := a + v |};
                   Private := Aunlock |}
| CsUnlock :
    forall sh, cs_step        {| Shared := sh; Private := Aunlock |}
                         {| Shared := sh; Private := Alock |}.

Definition pdcs2_sys := locking
                          {| Initial := pd_init;
                             Step := pd_step |}
                          {| Initial := cs_init;
                             Step := cs_step |}.

(* The correctness of the system is given as below: when Producer completely
 * produces all values and Consumer consumes all of them, then the accumulated
 * value equals PRD_COUNT.
 *)
Definition pdcs2_correct
           (s : threaded_state (sharedWithLock pdcs_global_state)
                               (stateWithLock pd_thread * stateWithLock cs_thread)) :=
  s.(Shared).(SharedOrig).(cnt) = 0 ->
  s.(Shared).(SharedOrig).(buf) = nil ->
  s.(Shared).(Lock) = false ->
  s.(Shared).(SharedOrig).(acc) = PRD_COUNT.

Module Type S.
  Axiom pdcs2_ok : invariantFor pdcs2_sys pdcs2_correct.
End S.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md descbrides the contents of each file and
   provides instructions to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.
Require Import NPeano.
Require Import Classical_Prop.

Require Import misc_arith.
Require Import misc_list.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* PIGEONHOLE PRINCIPLE                                                  *)
(* --------------------------------------------------------------------- *)

Inductive remove {A} (a:A): list A -> list A -> Prop :=
 | remove_nil: remove a nil nil
 | remove_na: forall x xs ys, x <> a -> remove a xs ys -> remove a (x :: xs) (x :: ys)
 | remove_a: forall xs ys, remove a xs ys -> remove a (a :: xs) ys.

Lemma remove_exists:
forall {A: Type},
forall a: A,
forall xs: list A,
exists ys: list A,
remove a xs ys.
Proof.
induction xs.
- exists nil.
  apply remove_nil.
- elim IHxs; intros.
  generalize (classic (a=a0)); intros [HH|HH].
  subst; exists x; constructor 3; assumption.
  exists (a0 :: x).
  apply remove_na.
  + apply not_eq_sym.
    exact HH.
  + exact H.
Qed.

Lemma remove_notin:
forall {A: Type},
forall a: A,
forall xs ys: list A,
~ In a xs ->
remove a xs ys ->
ys = xs.
Proof.
induction xs.
- intros ys H1 H2.
  inversion H2.
  reflexivity.
- intros ys H1 H2.
  inversion H2.
  + subst.
    assert (~ In a xs).
      {
      simpl in H1.
      intros H4.
      apply H1.
      right.
      exact H4.
      }
    specialize (IHxs ys0 H H5).
    subst.
    reflexivity.
  + subst.
    destruct H1.
    simpl.
    left.
    reflexivity.
Qed.

Lemma remove_length_in:
forall {A: Type},
forall a: A,
forall xs ys: list A,
In a xs ->
remove a xs ys ->
length ys < length xs.
Proof.
intros A a xs ys H1 H2.
revert H1.
induction H2.
- intros H.
  simpl in H.
  contradiction.
- intros H3.
  simpl in H3.
  destruct H3 as [H3 | H3].
  + subst.
    destruct H.
    reflexivity.
  + specialize (IHremove H3).
    simpl.
    omega.
- intros H3.
  assert (In a xs \/ ~ In a xs).
    {
    apply classic.
    }
  destruct H as [H | H].
  + specialize (IHremove H).
    simpl.
    omega.
  + apply remove_notin in H2.
    * subst.
      simpl.
      omega.
    * exact H.
Qed.

Lemma remove_in_notin:
forall {A: Type},
forall a: A,
forall xs ys: list A,
forall e: A,
remove a xs ys ->
In e xs ->
e = a \/ In e ys.
Proof.
intros A a xs ys e H.
revert e.
induction H.
- intros e H.
  simpl in H.
  contradiction.
- intros e H1.
  simpl in H1.
  destruct H1 as [H1 | H1].
  + right.
    simpl.
    left.
    exact H1.
  + specialize (IHremove e H1).
    destruct IHremove as [IHremove | IHremove].
    * left.
      exact IHremove.
    * right.
      simpl.
      right.
      exact IHremove.
- intros e H1.
  simpl in H1.
  destruct H1 as [H1 | H1].
  + left.
    symmetry.
    exact H1.
  + specialize (IHremove e H1).
    exact IHremove.
Qed.

Lemma pigeon_aux:
forall {A: Type},
forall x y: list A,
(forall e, In e x -> In e y) ->
(length x > length y) ->
~ NoDup x.
Proof.
intros.
red.
intro.
revert y H H0.
elim H1.
- simpl; intros.
  omega.
- intros.
  simpl in H3.
  generalize (remove_exists x0 y); intros [y' Hy'].
  assert (length y' < length y).
  eapply remove_length_in; auto.
  apply H2 with (y:=y').
  + intros.
    generalize (@remove_in_notin A x0 y y').
    intros.
    destruct H7 with e.
    * exact Hy'.
    * apply H3.
      right.
      exact H6.
    * subst.
      destruct H.
      exact H6.
    * exact H8.
  + simpl in H4.
    omega.
Qed.

Lemma nodup_or:
forall A: Type,
forall a: A,
forall x: list A,
~ NoDup (a :: x) ->
~ NoDup x \/ In a x.
Proof.
intros.
apply imply_to_or.
intros.
generalize (classic (In a x)).
intros H1.
destruct H1 as [H1 | H1].
- exact H1.
- destruct H.
  constructor.
  + exact H1.
  + exact H0.
Qed.

Lemma pigeon:
forall A: Type,
forall x y: list A,
(forall e: A, In e x -> In e y) ->
length x = length y + 1->
exists d: A,
exists x1 x2 x3: list A,
x = x1 ++ [d] ++ x2 ++ [d] ++ x3.
Proof.
intros A x y H1 H2.
apply pigeon_aux in H1.
- clear H2.
  induction x.
  + destruct H1.
    apply NoDup_nil.
  + assert (~ NoDup x \/ In a x).
      {
      apply nodup_or.
      exact H1.
      }
    destruct H as [H | H].
    * specialize (IHx H).
      destruct IHx as [d [x1 [x2 [x3 IHx]]]].
      rewrite IHx.
      exists d, (a :: x1), x2, x3.
      repeat rewrite <- app_assoc.
      reflexivity.
    * apply in_split in H.
      destruct H as [l1 [l2 H]].
      exists a, [], l1, l2.
      rewrite H.
      simpl.
      reflexivity.
- omega.
Qed.


(** Author: Christian Doczkal *)
From mathcomp Require Import all_ssreflect.
From RegLang Require Import misc languages dfa nfa regexp.

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

(** Preliminaries *)

(* to be used after simplification and rewriting with [tupleE] *)
Lemma behead_cons (T:Type) n (t : n.-tuple T) a : behead_tuple (cons_tuple a t) = t.
Proof.
  rewrite /cons_tuple /behead_tuple /=.
  case: t => t tP /=. set X := (behead_tupleP _). by rewrite (eq_irrelevance X tP).
Qed.

(* overly specific statement *)
Lemma count_mem1 (T : eqType) (x : T) n (s : n.-tuple T) (i : 'I_n) :
  count_mem x s == 1 -> tnth s i = x -> index x s = i.
Proof.
  rewrite (tnth_nth x). case: i => i /= Hi. case: s => /= s /eqP Hs. subst.
  elim: s i Hi => //= a s IH i Hi. case: (ifP _) => /=.
  - rewrite add1n eqSS => /eqP-> /=. destruct i as [|i] => //.
    rewrite eqn0Ngt -has_count nth_cons => A B. case:notF.
    rewrite -(negbTE A) -B. apply/(has_nthP x). exists i => //=.
  - destruct i as [|i] => [/negbT /eqP //|/= A B C]. by rewrite (IH i).
Qed.

(** * Weak Monadic Second-Order Logic *)

(** We employ a minimal syntax for MSO formulas that permits only second-order
variables. *)

Inductive form :=
| Incl of  nat & nat
| Less of  nat & nat
| FF
| Imp of form & form
| Ex of form.

(** All variables are interpreted as finite sets (actually lists) of natural numbers *)
Definition valuation := nat -> seq nat.

Implicit Types (s t : form) (X Y : nat) (I : valuation) (N : seq nat).

Definition cons N I : valuation := fun k => if k is k'.+1 then I k' else N.

Fixpoint satisfies (I : valuation) (s : form) :=
  match s with
  | Incl X Y => {subset I X <= I Y}
  | Less X Y => forall x y, x \in I X -> y \in I Y -> x < y
  | FF => False
  | Imp s t => satisfies I s -> satisfies I t
  | Ex s => exists N, satisfies (cons N I) s
  end.

Fixpoint bound (s : form) : nat :=
  match s with
  | Incl X Y => maxn X.+1 Y.+1
  | Less X Y => maxn X.+1 Y.+1
  | FF => 0
  | Imp s t => maxn (bound s) (bound t)
  | Ex s => (bound s).-1
  end.

Definition agree n I I' := forall X, X < n -> I X =i I' X.

Lemma agree_dc n m I I' : n <= m -> agree m I I' -> agree n I I'.
Proof. move => A B X ltn_m. apply: B. exact: leq_trans A. Qed.

Lemma coincidence I I' s:
  agree (bound s) I I' -> satisfies I s <-> satisfies I' s.
Proof.
  elim: s I I' => [X Y|X Y||s IHs t IHt|s IHs] /= I I' C.
  - split.
    + move => A B. rewrite -!C ?leq_maxl ?leq_maxr //. exact: A.
    + move => A B. rewrite !C  ?leq_maxl ?leq_maxr //. exact: A.
  - split => H x y;[rewrite -!C|rewrite !C]; try solve [exact: H|by rewrite ?leq_maxl ?leq_maxr].
  - tauto.
  - by rewrite -(IHs I I') ?(IHt I I') //; apply: agree_dc C; rewrite ?leq_maxl ?leq_maxr.
  - have bound_s N : agree (bound s) (cons N I) (cons N I').
    { move => X. case: X C => //= Y A B. apply: A. rewrite -ltnS. by case: (bound s) B. }
    split.
    + move => [N] sat_s. exists N. rewrite -IHs. eassumption. exact: bound_s.
    + move => [N] sat_s. exists N. rewrite IHs. eassumption. exact: bound_s.
Qed.

Lemma weak_coincidence I I' s : (forall X, I X =i I' X) -> satisfies I s -> satisfies I' s.
Proof. move => H. by rewrite (@coincidence I I' s). Qed.

(** ** Language-Theoretic Interpretation *)

Section Language.
  Variables (char : finType).

  Definition I_of n (v : seq (n.-tuple bool)) : valuation :=
    fun X => [seq i <- iota 0 (size v) | nth false (nth [tuple of nseq n false] v i) X].

  Definition vec_of (w : word char) : seq (#|char|.-tuple bool) :=
    map (fun a => [tuple X == enum_rank a | X < #|char|]) w.

  (* Unify these Lemmas *)
  Lemma I_of_vev_max k (a:char) w:
    k \in I_of (vec_of w) (enum_rank a) -> k < size w.
  Proof. by rewrite /vec_of /I_of mem_filter mem_iota add0n size_map => /andP[_]. Qed.

  Lemma I_of_vecP k a w: k < size w ->
    (k \in I_of (vec_of w) (enum_rank a) = (nth a w k == a)).
  Proof.
    move => H. rewrite /vec_of /I_of mem_filter mem_iota add0n size_map /=.
    rewrite (nth_map a) // H andbT.
    rewrite (nth_map (enum_rank a)) ?size_tuple ?ltn_ord //.
    by rewrite nth_ord_enum (inj_eq enum_rank_inj) eq_sym.
  Qed.

  Definition vec_lang n s := fun v : seq (n.-tuple bool) => satisfies (I_of v) s.

  Definition mso_lang s := fun w => vec_lang s (vec_of w).

  Lemma vec_of_hom : homomorphism vec_of.
  Proof. exact: map_cat. Qed.

  Lemma mso_preim s : mso_lang s =p preimage vec_of (@vec_lang #|char| s).
  Proof. done. Qed.

End Language.

Notation vec n := [finType of n.-tuple bool].

(** ** Translation from MSO Formulas to NFAs *)

(** propositional connectives *)

Definition nfa_for_bot n := dfa_to_nfa (dfa_void (vec n)).

Definition nfa_for_imp n (A B : nfa (vec n)) :=
  dfa_to_nfa (dfa_op implb (nfa_to_dfa A) (nfa_to_dfa B)).

(** MSO Primitives *)

Definition nfa_for_incl n X Y :=
  {| nfa_state := [finType of unit];
     nfa_s := setT;
     nfa_fin := setT;
     nfa_trans := fun p (v : vec n) q => nth false v X ==> nth false v Y |}.

Definition enfa_for_ltn n X Y : enfa (vec n) :=
  {| enfa_s := [set false];
     enfa_f := setT;
     enfa_trans := fun (c : option (vec n)) p q =>
                     match p,c,q with
                     | false, Some a, false => ~~ nth false a Y
                     | true, Some a, true => ~~ nth false a X
                     | false, None, true => true
                     | _,_,_ => false
                     end; |}.

Definition nfa_for_ltn n X Y := nfa_of (enfa_for_ltn n X Y).

(** Existential Quantification *)

Definition prj0 n (w : seq (vec n.+1)) : seq (vec n) :=
  map (fun v : vec (n.+1) => [tuple of behead v]) w.
Prenex Implicits prj0.

Definition trans_b0 n (A : nfa (vec n.+1)) (p q : A) :=
  [exists b, nfa_trans p [tuple of b :: nseq n false] q].
Arguments trans_b0 [n] A p q.

Definition nfa_for_ex n (A : nfa (vec n.+1)) : nfa (vec n) :=
  {| nfa_s := nfa_s A;
     nfa_fin := [set p | [exists (q | q \in nfa_fin A), connect (trans_b0 A) p q]];
     nfa_trans := fun p (v : vec n) q => [exists b, nfa_trans p [tuple of b::v] q] |}.

(** Translation to NFAs *)

Fixpoint nfa_of_form  n s {struct s} : nfa (vec n) :=
  match s with
  | Incl X Y => nfa_for_incl n X Y
  | Less X Y => nfa_for_ltn n X Y
  | FF => nfa_for_bot n
  | Imp s t => nfa_for_imp (nfa_of_form n s) (nfa_of_form n t)
  | Ex s => nfa_for_ex (nfa_of_form n.+1 s)
  end.

(** ** Correctness of the Translation *)

(** Correctness of Existential Quantification *)

Fixpoint glue (bs : seq bool) n (w : seq (vec n)) :=
  match bs,w with
  | b::bs,v::w => [tuple of b :: v] :: glue bs w
  | b::bs,[::] => [tuple of b :: nseq n false] :: glue bs [::]
  | nil,w => map (fun v : vec n => [tuple of false :: v]) w
  end.

Lemma nfa_for_exI n (A : nfa (vec n.+1)) b w :
  glue b w \in nfa_lang A -> w \in nfa_lang (nfa_for_ex A).
Proof.
  rewrite /nfa_lang !inE.
  case/exists_inP => s s1 s2. apply/exists_inP. exists s => //.
  elim: b w s {s1} s2 => [w p /=|b bs IH w p].
  - elim: w p => /= [|v w IHw] p.
    + rewrite /= inE => H. by apply/exists_inP; exists p.
    + apply: sub_exists => q /andP [q1 q2]. rewrite IHw // andbT.
     by apply/existsP;exists false.
  - case: w => [|v w] /=.
    + case/exists_inP => q q1 /IH /= q2. rewrite !inE in q2 *.
      apply: sub_exists q2 => r /andP [r1 r2].
      rewrite r1 (connect_trans (connect1 _) r2) // /trans_b0. by apply/existsP;exists b.
    + apply: sub_exists => q /andP [q1 q2]. rewrite IH // andbT. by apply/existsP;exists b.
Qed.

Lemma nfa_for_exE n (A : nfa (vec n.+1)) w :
  w \in nfa_lang (nfa_for_ex A) -> exists b : seq bool, glue b w \in nfa_lang A.
Proof.
  rewrite /nfa_lang /= !inE => H.
  suff S (q:A) : @nfa_accept _ (nfa_for_ex A) q w -> exists b, nfa_accept q (glue b w).
  { case/exists_inP : H => p p1 /S [b b1]. exists b. rewrite inE. by apply/exists_inP; exists p. }
  elim: w q {H} => [|v vs IH] q /=.
  - rewrite inE => /exists_inP [f f1 /connectP[p]].
    elim: p q => [x _ |p ps IHp q /= /andP [pth1 pth2]] /= E; first by exists nil; subst.
    case: (IHp _ pth2 E) => bs Hbs. case/existsP : pth1 => b pth1. exists (b::bs).
    by apply/exists_inP; exists p.
  - case/exists_inP => p /= /existsP [b p1] p2. case: (IH _ p2) => bs Hbs. exists (b::bs).
    by apply/exists_inP; exists p.
Qed.

Lemma size_glue b n (v : seq (vec n)) : size (glue b v) = maxn (size b) (size v).
Proof.
  elim: b v => [|b bs IH] v /=; first by rewrite max0n size_map.
  case: v => [|v vs]; by rewrite /= ?maxnSS IH ?maxn0.
Qed.

Lemma nth_glue0 b n (v : seq (vec n)) k :
  nth false (nth [tuple of nseq n.+1 false] (glue b v) k) 0 =
  nth false b k.
Proof.
  elim: k v b => [|k IH] [|v vs] [|b bs] //; rewrite [glue _ _]/= ?nth_nil ?nth_cons ?IH //.
  case: (ltnP k (size vs)) => A.
  - by rewrite (nth_map [tuple of nseq n false]) //.
  - by rewrite [_ _ _ k]nth_default // size_map.
Qed.

Lemma I_of_glue0 i b n (v : seq (vec n)) :
  i \in I_of (glue b v) 0 = nth false b i.
Proof.
  rewrite mem_filter mem_iota add0n leq0n andTb.
  rewrite nth_glue0 size_glue leq_max andbC.
  case: (ltnP i (size b)) => //= A. by rewrite nth_default ?andbF.
Qed.

Lemma nth_glueS b n (v : seq (vec n)) i k :
  nth false (nth [tuple of nseq n.+1 false] (glue b v) k) i.+1 =
  nth false (nth [tuple of nseq n false] v k) i.
Proof.
  elim: k v b => [|k IH] [|v vs] [|b bs]  //.
  - by rewrite [glue _ _]/= IH !nth_nil nth_nseq if_same.
  - rewrite [glue _ _]/= !nth_cons.
    case: (ltnP k (size vs)) => A.
    + by rewrite (nth_map [tuple of nseq n false]).
    + by rewrite ![_ _ _ k]nth_default ?size_map.
  - by rewrite [glue _ _]/= !nth_cons.
Qed.

Lemma I_of_glueS i b n (v : seq (vec n)) k :
  i \in I_of (glue b v) k.+1 = nth false (nth [tuple of nseq n false] v i) k.
Proof.
  rewrite mem_filter mem_iota add0n leq0n andTb.
  rewrite nth_glueS size_glue leq_max andbC orbC.
  case: (ltnP i (size v)) => //= A.
  by rewrite [_ _ v i]nth_default // nth_nseq if_same andbF.
Qed.

Lemma vec_ex_glue s n (vs : seq (vec n)) :
  vec_lang (Ex s) vs -> exists bs, vec_lang s (glue bs vs).
Proof.
  rewrite /vec_lang /= => [[N sat_s]].
  exists [seq i \in N | i <- iota 0 (\max_(k <- N) k).+1].
  apply: weak_coincidence sat_s => X i.
  case: X => [|X].
  - rewrite I_of_glue0. case: (boolP (i < (\max_(k <- N) k).+1)) => ltn_max.
    + by rewrite (nth_map 0) ?size_iota // nth_iota.
    + rewrite nth_default ?size_map ?size_iota 1?leqNgt //.
      apply: contraNF ltn_max => H. rewrite ltnS. exact: bigmax_seq_sup H _ _.
  - rewrite I_of_glueS /= /I_of mem_filter mem_iota /= add0n.
    case: (ltnP i (size vs)) => H; first by rewrite andbT.
    rewrite andbF [nth _ _ i]nth_default //.
    by rewrite nth_nseq if_same.
Qed.

Lemma vec_lang0 s n (v : seq (vec n)) k :
  vec_lang s v <-> vec_lang s (v ++ nseq k [tuple of nseq n false]).
Proof.
  apply coincidence => X ? i. rewrite !mem_filter !mem_iota /= !add0n size_cat nth_cat.
  case: (boolP (i < size v)) => Hi; first by rewrite ltn_addr.
  by rewrite andbF !(nth_nseq,if_same).
Qed.

Lemma prj_glue bs n (v : seq (vec n)) :
  exists k, prj0 (glue bs v) = v ++ nseq k [tuple of nseq n false].
Proof.
  exists (size bs - size v). elim: bs v => [|b bs IH] v /=.
  - rewrite /prj0 -map_comp cats0 map_id_in //= => b. by rewrite !tupleE behead_cons.
  - case: v => [| v vs] /=; by rewrite IH /= ?subn0 ?subss !tupleE behead_cons.
Qed.

Lemma vec_Ex_prj0 s n (w : word (vec n.+1)) : vec_lang s w -> vec_lang (Ex s) (prj0 w).
Proof.
  rewrite /vec_lang => /= A.
  exists [seq i <- iota 0 (size w) | nth false (nth [tuple of nseq n.+1 false] w i) 0].
  apply: weak_coincidence A => X i. rewrite mem_filter mem_iota add0n /= /cons.
  case: X => [|X].
  + by rewrite mem_filter mem_iota /= add0n.
  + rewrite mem_filter mem_iota add0n size_map /prj0 andTb -nth_behead.
    (case: (boolP (i < _)); rewrite ?andbF ?andbT //) => A. congr nth.
      by erewrite nth_map.
Qed.

Lemma nfa_for_ex_correct n s (A : nfa (vec n.+1)) v:
  (forall u, reflect (vec_lang s u) (u \in nfa_lang A)) ->
  reflect (vec_lang (Ex s) v) (v \in nfa_lang (nfa_for_ex A)).
Proof.
  move => IHs. apply: (iffP idP).
  + case/nfa_for_exE => b. move/IHs. move/vec_Ex_prj0.
    case: (prj_glue b v) => k ->. by rewrite -vec_lang0.
  + case/vec_ex_glue => b. move/IHs. exact: nfa_for_exI.
Qed.

(** Correctness of the NFAs for the primitive operations *)

Lemma nfa_for_incl_correct X Y n (v : seq (vec n)):
  reflect (vec_lang (Incl X Y) v) (v \in nfa_lang (nfa_for_incl n X Y)).
Proof.
  rewrite /nfa_lang inE. apply: (equivP existsP).
  rewrite (_ : (exists _,_) <-> nfa_accept (tt : nfa_for_incl n X Y) v); last first.
  - split => [[x]|];[case: x|exists tt]; by rewrite inE.
  - rewrite (_ : vec_lang _ _ <-> (forall u, u \in v -> nth false u X -> nth false u Y)).
    + elim: v => //= v vs IH. split.
      * case/exists_inP => [[/implyP A] /IH B] u /predU1P []; first by move=>?;subst.
        exact: B.
      * move => A. apply/exists_inP; exists tt;[apply/implyP|].
        -- apply: A; exact: mem_head.
        -- apply/IH => u Hu. apply: A. by rewrite inE Hu orbT.
    + rewrite /vec_lang /=. split.
      * move => A u in_v u_X.
        set i := index u v.
        move: (A i). rewrite /I_of !mem_filter !mem_iota !add0n /=.
        rewrite index_mem in_v !andbT. rewrite nth_index //. by apply.
      * move => A => k. rewrite /I_of !mem_filter !mem_iota !add0n /=.
        case: (boolP (_ < _)); rewrite ?andbT ?andbF // => B.
        set u := nth [tuple of nseq n false] v k.
        apply A. by rewrite mem_nth.
Qed.

Definition zero_at n X := forall (v : vec n), nth false v X = false.

Lemma nfa_for_ltnP {X Y n} {v : seq (vec n)} :
  reflect (exists v1 v2, [/\ v = v1 ++ v2, {in v1,zero_at n Y} & {in v2,zero_at n X}])
          (v \in nfa_lang (nfa_for_ltn n X Y)).
Proof.
  move: v => v0. apply: (iffP (nfa_ofP _ _)).
  - rewrite /enfa_lang => [[[|_]]]; first by rewrite inE.
    suff S q v:
      enfa_accept (N := enfa_for_ltn n X Y) q v ->
      if q
      then {in v, zero_at n X}
      else (exists v1 v2, [/\ v = v1 ++ v2, {in v1,zero_at n Y} & {in v2,zero_at n X}]).
    { by move/S. }
    elim => // {v0 v} [||].
    + case => // _. by do 2 exists nil.
    + move => [|] a [|] //= v.
      * move => A _ B u. case/predU1P => [->|]; by [rewrite (negbTE A)| apply: B].
      * move => A _ [v1] [v2] [C D E].
        exists (a :: v1); exists v2; split => //; first by rewrite C.
        apply/all1s. split => //. by rewrite (negbTE A).
    + move => [|] [|] // v. by exists nil; exists v.
  - move => [v1] [v2] [->] A B. exists false; first by rewrite inE.
    elim: v1 A => /= [_|a v1 IH A].
    + (apply: EnfaNone; first instantiate (1 := true)) => //.
      elim: v2 B {v0} => [_|a s IH B].
      * constructor. by rewrite inE.
      * (apply: EnfaSome; first instantiate (1 := true)) => //=.
        -- by rewrite B ?inE ?eqxx.
        -- apply: IH => u C. apply B. by rewrite inE C orbT.
    + apply: EnfaSome; first instantiate (1 := false).
      * by rewrite /= A ?inE ?eqxx.
      * apply IH => u C. apply A. by rewrite inE C orbT.
Qed.

Lemma mem_I_of n (v : seq (vec n)) X k :
  (k \in I_of v X) = (k < size v) && nth false (nth [tuple of nseq n false] v k) X.
Proof. by rewrite mem_filter mem_iota add0n /= andbC. Qed.

Lemma nfa_for_ltn_correct X Y n (v : seq (vec n)):
  reflect (vec_lang (Less X Y) v) (v \in nfa_lang (nfa_for_ltn n X Y)).
Proof.
  apply: (iffP nfa_for_ltnP).
  - move => [v1] [v2] [A B C] i j.
    rewrite /I_of !mem_filter !mem_iota !add0n /= ![_ && (_ < _)]andbC.
    case: (boolP (_ < _)) => //= D. case: (boolP (_ < _)) => //= E F G.
    have Hi : i < size v1.
    { move: F. rewrite A nth_cat. case: (ifP _) => // /negbT H.
      rewrite C ?mem_nth //. rewrite -leqNgt in H.
      by rewrite -subSn // leq_subLR -size_cat -A. }
    have : size v1 <= j.
    { move: G. rewrite A nth_cat. case: (ltnP j (size v1)) => // H.
      by rewrite B ? mem_nth. }
    exact: leq_trans.
  - rewrite /vec_lang /= => A.
    case: (boolP (has predT (I_of v X))).
    + case/hasP => x0 /max_mem k_in_X _.
      set k := (\max_(i <- I_of v X) i) in k_in_X.
      have size_k: k < size v by move: k_in_X; rewrite mem_I_of => /andP[].
      have size_tk: size (take k.+1 v) = k.+1.
      { rewrite size_take.
        case: (ltnP k.+1 (size v)) size_k => // H1 H2.
        apply/eqP. by rewrite eqn_leq H1 H2. }
      exists (take k.+1 v); exists (drop k.+1 v); split; first by rewrite cat_take_drop.
      * move => u B. apply/negbTE/negP => D.
        pose i := index u (take k.+1 v).
        have E: i <= k by rewrite -ltnS -size_tk index_mem B.
        move: (A k i). case/(_ _ _)/Wrap => //; last by rewrite leqNgt ltnS E.
        rewrite mem_I_of (leq_ltn_trans E size_k) /=.
        rewrite /i index_take // nth_index //. exact: mem_take B.
      * move => u B. apply/negbTE/negP => D.
        pose i := k.+1 + index u (drop k.+1 v).
        have i_in_X : i \in I_of v X.
        { rewrite mem_I_of.
          rewrite -[v](cat_take_drop k.+1) size_cat size_tk.
          rewrite -addnS leq_add2l index_mem B andTb.
          rewrite nth_cat size_tk leqNgt leq_addr /= /i.
          by rewrite addnC -addnBA // subnn addn0 nth_index. }
        have: i <= k by apply: bigmax_seq_sup i_in_X _ _.
        by rewrite /i addSn -ltn_subRL subnn.
    + move/hasPn => /= B. exists nil; exists v; split => // u in_v.
      apply/negbTE/negP => D.
      pose i := index u v. move: (B i). case/(_ _)/Wrap => //.
      by rewrite mem_I_of index_mem in_v nth_index.
Qed.

Theorem nfa_of_form_correct n (v : seq (n.-tuple bool)) s :
  reflect (vec_lang s v) (v \in nfa_lang (nfa_of_form n s)).
Proof.
  elim: s n v => [X Y|X Y||s IHs t IHt|s IHs] /= n v.
  - exact: nfa_for_incl_correct.
  - exact: nfa_for_ltn_correct.
  - rewrite -dfa_to_nfa_correct in_simpl (negbTE (dfa_void_correct _ _)).
    by constructor.
  - rewrite -dfa_to_nfa_correct dfa_op_correct -!nfa_to_dfa_correct.
    by apply: (iffP implyP) => A /IHs/A/IHt.
  - exact: nfa_for_ex_correct.
Qed.

(** Greatest number used in first n variables *)
Definition lim I n := \max_(X < n) \max_(n <- I X) n.

Definition vec_of_val I n : seq (n.-tuple bool) :=
  [seq [tuple i \in I X | X < n] | i <- iota 0 (lim I n).+1].

Lemma vec_of_val_agrees : forall I n, agree n I (I_of (vec_of_val I n)).
Proof.
  move => I n X lt_n i.
  rewrite mem_filter mem_iota /= add0n size_map size_iota.
  case: (boolP (i < _)); rewrite ?(andbT,andbF) => A.
  + rewrite /vec_of_val.
    rewrite (nth_map 0) ?size_iota // nth_iota // add0n.
    by rewrite (nth_map (Ordinal lt_n)) ?size_enum_ord ?nth_enum_ord.
  + apply: contraNF A => A. rewrite ltnS. rewrite /lim.
    apply: bigmax_sup => //. instantiate (1 := Ordinal lt_n) => /=.
    exact: bigmax_seq_sup A _ _ .
Qed.

Lemma vec_of_valP I s : satisfies I s <-> satisfies (I_of (vec_of_val I (bound s))) s.
Proof. apply: coincidence. exact: vec_of_val_agrees. Qed.

Corollary satisfies_dec I s : decidable (satisfies I s).
Proof. apply: dec_iff (vec_of_valP I s).  exact: decP (nfa_of_form_correct _ _). Qed.

Corollary mso_dec s : decidable (exists I, satisfies I s).
Proof.
  pose n := bound s.
  case: (nfa_inhabP (nfa_of_form n s)) => A;[left|right].
  - case: A => w /(@nfa_of_form_correct n) Hw. by exists (I_of w).
  - move => [I sat_I_s]. apply A.
    exists (vec_of_val I n). apply/nfa_of_form_correct.
    by rewrite /vec_lang -vec_of_valP.
Qed.

Corollary vec_lang_regular n s : regular (@vec_lang n s).
Proof.
  apply/nfa_regular. exists (nfa_of_form n s) => x.
  apply: rwP. exact: nfa_of_form_correct.
Qed.

(** ** Regularity of the Language of an MSO formula *)

Corollary mso_regular (char: finType) s : regular (@mso_lang char s).
Proof.
  apply: regular_ext (mso_preim s).
  exact: preim_regular (@vec_of_hom _) (vec_lang_regular _ _).
Qed.

(** ** Translation from NFAs to WMSO *)

(** In order to translate NFAs to formulas, we define a number of defined
operations on top of the minimal syntax employed above. In particular, we make
use of the fact that [satisfies I s] is decidable and, hence, the logic behaves
classically. *)

Notation "I |= s" := (satisfies I s) (at level 50).

(** Propositional Connectives *)

Lemma satNNPP I s : ~ ~ I |= s -> I |= s.
Proof. case: (satisfies_dec I s); tauto. Qed.

Notation "s --> t" := (Imp s t) (at level 49, right associativity).
Definition Not s := Imp s FF.

Lemma satDN I s : I |= Not (Not s) <-> I |= s.
Proof. move: (@satNNPP I s) => /= ; tauto. Qed.

Lemma sat_imp I s t : I |= Imp s t <-> (I |= s -> I |= t).
Proof. done. Qed.

Lemma sat_not I s : I |= Not s <-> ~ I |= s.
Proof. done. Qed.

Definition TT := FF --> FF.

Lemma sat_true I : I |= TT.
Proof. done. Qed.

Definition And s t := Not (Imp s (Not t)).
Notation "s :/\: t" := (And s t) (at level 45).

Lemma sat_and I s t : I |= And s t <-> (I |= s /\ I |= t).
Proof.
  rewrite /And /Not /=. split => [A|]; last tauto.
  split; apply: satNNPP; tauto.
Qed.

Definition Or s t := Not s --> t.
Notation "s :\/: t" := (Or s t) (at level 47).

Lemma sat_or I s t : I |= s :\/: t <-> I |= s \/ I |= t.
Proof. rewrite /Or /Not /=. split;[case: (satisfies_dec I s)|];tauto. Qed.

Opaque And Or.

Definition Iff s t := (s --> t) :/\: (t --> s).
Notation "s <--> t" := (Iff s t) (at level 50).

Definition All s := Not (Ex (Not s)).

Lemma sat_all I s :
  I |= All s <-> (forall N, satisfies (cons N I) s).
Proof.
  split => [A N|A].
  - apply: satNNPP => B. apply: A. by exists N.
  - case: (satisfies_dec I (Ex (Not s))) => //= [[N B]].
    exfalso. exact: B.
Qed.

Opaque All.

(** Emptiness and Singletons *)

Definition empty X := All (Incl (X.+1) 0).

Lemma sat_empty I X :
  I |= empty X <-> I X =i pred0.
Proof.
  rewrite sat_all; split => [/= /(_ [::]) A k|A N k]; last by rewrite A.
  rewrite inE. apply: negbTE. apply/negP. by move/A.
Qed.

Lemma sat_emptyN I X :
  I |= Not (empty X) <-> (exists n, n \in I X).
Proof.
  rewrite satDN; split => [[N]|] /=.
  - case: (I X) => [|x IX _].
    + by case/(_ _)/Wrap.
    + by exists x; rewrite mem_head.
  - case => n A. exists [:: n.+1]. move/(_ _ A). by rewrite inE ltn_eqF.
Qed.

Definition single X := Not(empty X) :/\: All (Not(empty 0) --> Incl 0 X.+1 --> Incl X.+1 0).

Lemma sat_singles I X :
  I |= single X <-> exists n, I X =i [:: n].
Proof.
  rewrite sat_and sat_emptyN. split.
  - move => [[n A] B].
    exists n. move => m. rewrite inE. apply/idP/eqP => [H|-> //].
    move/sat_all/(_ [:: n]): B. rewrite 2!sat_imp. case/(_ _ _)/Wrap.
    + rewrite sat_emptyN. exists n. by rewrite inE.
    + move => k /=. by rewrite inE => /eqP->.
    + move/(_ _ H). by rewrite inE => /eqP->.
  - case => n A. split; first by exists n;rewrite A.
    apply/sat_all => N. rewrite 2!sat_imp sat_emptyN => /= [[k Hk] D] m E.
    move: (D _ Hk). rewrite A inE => /eqP ?; subst.
    rewrite A inE in E. by rewrite (eqP E).
Qed.

(** Big Operatiors *)

Notation "\or_ ( i <- r ) F" := (\big [Or/FF]_(i <- r)  F)
  (at level 42, F at level 42, i at level 0,
    format "'[' \or_ ( i  <-  r ) '/ '  F ']'").

Notation "\or_ ( i \in A ) F" := (\big [Or/FF]_(i <- enum A)  F)
  (at level 42, F at level 42, i at level 0,
    format "'[' \or_ ( i  \in  A ) '/ '  F ']'").

Notation "\and_ ( i <- r ) F" := (\big [And/TT]_(i <- r)  F)
  (at level 41, F at level 41, i at level 0,
    format "'[' \and_ ( i  <-  r ) '/ '  F ']'").

Notation "\and_ ( i \in A ) F" := (\big [And/TT]_(i <- enum A)  F)
 (at level 41, F at level 41, i at level 0,
 format "'[' \and_ ( i  \in  A ) '/ '  F ']'").

Lemma sat_orI (T:eqType) (s : seq T) x F I :
  x \in s -> I |= F x -> I |= \or_(i <- s) F i.
Proof. elim: s => // a s IH /predU1P [<-|/IH A]; rewrite big_cons sat_or; tauto. Qed.

Lemma sat_orE (T:eqType) (s : seq T) F I :
  I |= \or_(i <- s) F i -> exists2 x, x \in s & I |= F x.
Proof.
  elim: s => // [|a s IH]; first by rewrite big_nil.
  rewrite big_cons sat_or. case => [A|/IH [x A B]]; first by exists a.
  exists x => //. by rewrite inE A orbT.
Qed.

Lemma sat_bigand (T:eqType) (s : seq T) F I :
  I |= \and_(i <- s) F i <-> forall x, x \in s -> I |= F x.
Proof.
  elim: s => [|a s IH]; first by rewrite big_nil; split => // _; apply.
  rewrite big_cons sat_and IH. split => [[A B]x/predU1P[->//|]|A]. exact: B.
  split => [|x B]; apply: A => //. by rewrite inE B orbT.
Qed.

(** First-oder Quantification *)
(** Note that "first-order" variables are interpreted as one-element lists
rather than directly as numbers. Hence we need the lemmas [seq1P] and [sub1P] *)

Definition All1 s := All (single 0 --> s).

Lemma sat_all1 I s :
  I |= All1 s <-> (forall n, cons [:: n] I |= s).
Proof.
  rewrite sat_all; split.
  - move => H n. move: (H [:: n]) => {H} /=. apply. rewrite sat_singles. by exists n.
  - move => H N. rewrite sat_imp sat_singles => [[n Hn]].
    apply: weak_coincidence (H n). by case.
Qed.

Definition Ex1 s := Ex (single 0 :/\: s).

Lemma sat_ex1 I s :
  I |= Ex1 s <-> (exists n, cons [:: n] I |= s).
Proof.
  rewrite /Ex1; split.
  - case => N. rewrite -/satisfies => /sat_and [/sat_singles [n] /= B C]. exists n.
    apply: weak_coincidence C. by case.
  - case => n A. exists [:: n]. apply/sat_and;split => //.
    apply/sat_singles. by exists n.
Qed.

(* Successor relation and Zero Predicate *)

Lemma nat_succ x y : y = x.+1 <-> x < y /\ ~ exists k, x < k /\ k < y.
Proof.
  split.
  - move => ->. rewrite leqnn. split=>//.
    move => [k] [A B]. move:(leq_trans A B). by rewrite ltnn.
  - move => [A B]. apply/eqP. rewrite eqn_leq leqNgt A andbT.
    apply/negP. apply: impliesPn B. constructor.
    exists x.+1. by rewrite leqnn H.
Qed.

Definition succ X Y :=
  Less X Y :/\: Not (Ex1 (Less X.+1 0 :/\: Less 0 Y.+1)).

Lemma sat_succ I X x Y y : I X =i [:: x] -> I Y =i [:: y] ->
  I |= succ X Y <-> y = x.+1.
Proof.
  move => A B. rewrite sat_and sat_not sat_ex1 nat_succ.
  split => [[C D]|[C D]].
  - split; first apply C; rewrite ?A ?B //.
    apply: impliesPn D; constructor => [[k [k1 k2]]]. exists k.
    rewrite sat_and /=; split => ? ?; by rewrite ?A ?B => /seq1P-> /seq1P->.
  - split. move => ? ? ; by rewrite ?A ?B => /seq1P-> /seq1P->.
    apply: impliesPn D; constructor => [[k] /sat_and [k1 k2]]. exists k.
    split; [apply k1|apply k2]; by rewrite /= ?A ?B.
Qed.

Definition zero X := single X :/\: Not (Ex1 (succ 0 X.+1)).

Lemma sat_zero I X : I X =i [:: 0] <-> I |= zero X.
Proof.
  rewrite sat_and sat_singles sat_not sat_ex1.
  split.
  - move => A. split; first by exists 0.
    move => [n]. move/sat_succ. move/(_ 0 n) => /=. by case/(_ _ _)/Wrap.
  - move => [[n A] B] k. rewrite A !inE.
    suff S : n == 0. apply/idP/idP => /eqP->; by rewrite // eq_sym.
    destruct n as [|n] => //. exfalso. apply B.
    exists n. by rewrite (sat_succ (x := n) (y := n.+1)).
Qed.

Definition Leq X Y := All1 (succ Y.+1 0 --> Less X.+1 0).

Lemma sat_leq I X x Y y : I X =i [:: x] -> I Y =i [:: y] ->
  I |= Leq X Y <-> x <= y.
Proof.
  move => A B. rewrite sat_all1. split.
  - move/(_ y.+1). rewrite sat_imp. case/(_ _)/Wrap.
    + by rewrite (sat_succ (x := y) (y := y.+1)).
    + move/(_ x y.+1). rewrite /= A !inE ltnS. by apply.
  - move => C n. rewrite sat_imp. rewrite (sat_succ (x := y) (y := n)) // => ->.
    move => ? ? /=. rewrite A !inE => /eqP-> /eqP->. by rewrite ltnS.
Qed.

(** Interated existential quantification *)

Definition cat (Ns: seq (seq nat)) I :=
  fun x => if x < size Ns then nth [::] Ns x else I (x - size Ns).

Lemma cat_prefix I n (Ns : n.-tuple (seq nat)) X : X < n -> cat Ns I X = nth [::] Ns X.
Proof. move => A. by rewrite /cat size_tuple A. Qed.

Lemma cat_beyond I n (Ns : n.-tuple (seq nat)) X : n <= X -> cat Ns I X = I (X - n).
Proof. move => A. by rewrite /cat size_tuple ltnNge A. Qed.

Lemma cat_size I n (Ns : n.-tuple (seq nat)) : cat Ns I n = I 0.
Proof. by rewrite cat_beyond ?subnn. Qed.

Definition exn n s := iter n Ex s.

Lemma sat_exn n s I :
  (I |= exn n s) <-> (exists Ns : n.-tuple (seq nat), cat Ns I |= s).
Proof.
  elim: n I => [|n IH] I.
  - split.
    + exists [tuple]. rewrite /cat /=. apply: weak_coincidence H => X. by rewrite subn0.
    + case => Ns. rewrite tuple0 /cat /=.
      apply: weak_coincidence => X. by rewrite subn0.
  - have agr Ns N X : cat (rcons Ns N) I X =i cat Ns (cons N I) X.
      { rewrite /cat /= !size_rcons ltnS.
        case: (ltngtP X (size Ns)) => B.
        * by rewrite (ltnW B) nth_rcons B.
        * rewrite leqNgt B /=. by rewrite -[X - size Ns]prednK ?subn_gt0 //= subnS.
        * by rewrite B leqnn subnn nth_rcons ltnn eqxx. }
    rewrite /=. split => [[N] /IH [Ns A]|].
    + exists [tuple of rcons Ns N]. apply: weak_coincidence A => X k. by rewrite agr.
    + case. case => Ns /=. elim/last_ind : Ns => // Ns N _.
      rewrite size_rcons eqSS =>  A B.
      exists N. apply/IH. exists (Tuple A) => /=.
      exact: weak_coincidence _ B.
Qed.

Section NFAtoMSO.
  Variables (T : finType) (A : nfa T).
  Let n := #|A|.
  Notation rank := enum_rank.
  Notation val := enum_val.

  Definition max :=
    All1 (Less 0 1 <--> \or_(a \in T) Incl 0 (rank a).+2).

  Lemma sat_max (w : word T)  m :
    cons [:: m] (I_of (vec_of w)) |= max <-> m = size w.
  Proof.
    split.
    - move/sat_all1 => B.
      apply/eqP. rewrite eqn_leq [_ <= m]leqNgt [m <= _]leqNgt.
      apply/andP; split; apply/negP => C.
      + case: m C B => // m C /(_ m). case/sat_and => [/sat_imp B _]. move: B.
        case/(_ _)/Wrap; first by move => ? ? /seq1P-> /seq1P->.
        case/sat_orE => a _ /= /sub1P /I_of_vev_max => D. rewrite ltnS in C.
        move: (leq_trans D C). by rewrite ltnn.
      + move/(_ m) : B. case/sat_and => _. move/sat_imp.
        case/(_ _)/Wrap.
        * set a := (tnth (in_tuple w) (Ordinal C)).
          apply: (sat_orI (x := a)); first by rewrite mem_enum.
          apply/sub1P => /=. by rewrite I_of_vecP // {2}/a (tnth_nth a).
        * move/(_ m m) => /=. rewrite !mem_head ltnn. by case/(_ _ _)/Wrap.
    - move->.
      rewrite sat_all1 => k.
      rewrite sat_and; split.
      + rewrite /= => H.
        move: H => /(_ k (size w)). case/(_ _ _)/Wrap => // H.
        pose a0 := tnth (in_tuple w) (Ordinal H).
        apply (sat_orI (x := nth a0 w k)); first by rewrite mem_enum.
        rewrite /= => ? /seq1P->. by rewrite I_of_vecP ?(set_nth_default a0).
      + case/sat_orE => a _ /sub1P /=.
        rewrite /vec_of /I_of mem_filter => /andP [_].
        by rewrite mem_iota add0n size_map /= => H ? ? /seq1P-> /seq1P->.
  Qed.

  Definition part X :=
    All1 (Leq 0 X.+1 -->
          (\or_(q \in A) (Incl 0 (rank q).+1 :/\:
                        \and_(q' \in [pred x | q != x]) Not (Incl 0 (rank q').+1)))).

  Lemma sat_part X I k :
    I X =i [:: k] ->
    I |= part X <-> forall n, n <= k -> exists! q:A, n \in I (rank q).
  Proof.
    move => H0. split.
    - move => H1 m Hm. move/sat_all1 : H1 => /(_ m) /sat_imp. case/(_ _)/Wrap.
      + rewrite sat_leq ; first apply Hm; done.
      + case/sat_orE => q _ /sat_and [/= /sub1P q1 /sat_bigand q2].
        exists q; split => // q' B. apply/eqP. apply/negPn/negP => C.
        apply: (q2 q'); by [rewrite mem_enum inE|apply/sub1P].
    - move => H1.
      apply/sat_all1 => m. rewrite sat_imp => /sat_leq H2.
      have/H1 {H2} : m <= k by apply: H2.
      case => q [q1 q2]. apply: (sat_orI (x := q)); first by rewrite mem_enum.
      rewrite sat_and; split; first by move => ? /seq1P ->.
      apply/sat_bigand => q'. rewrite mem_enum inE => qq' /sub1P /q2 ?.
      subst. by rewrite eqxx in qq'.
  Qed.

  (* forall y x -> succ(x,y) -> x < max -> \or_( ... ) ... *)
  (*        1 0                                            *)
  Definition run X : form :=
    All1 (All1(succ 0 1 --> Less 0 X.+2 -->
               \or_(paq \in [pred x : A * T * A | nfa_trans x.1.1 x.1.2 x.2])
               let: (p,a,q) := paq in
                    Incl 0 ((rank a).+1 + X).+2 (* a at pos x *)
               :/\: Incl 0 (rank p).+2     (* state p active at time x *)
               :/\: Incl 1 (rank q).+2     (* state q is next state of run *)
         )).

  Lemma sat_run (Ns : n.-tuple (seq nat)) m I :
    cat Ns (cons [:: m] I) |= run n <->
    (forall k, k < m -> exists (p:A) (a:T) (q:A), nfa_trans p a q /\
                                       k \in I (rank a) /\
                                       k \in tnth Ns (rank p) /\
                                       k.+1 \in tnth Ns (rank q)).
  Proof.
    split.
    - move => H k lt_m. move/sat_all1/(_ k.+1) : H. move/sat_all1/(_ k).
      rewrite 2!sat_imp. case/(_ _ _)/Wrap.
      + by apply/(sat_succ (x := k) (y := k.+1)).
      + move => /= ? y /seq1P ->. rewrite cat_beyond // subnn /=.
        by move/seq1P->.
      + case/sat_orE => [[[p a] q]]. rewrite mem_enum inE /= => B.
        rewrite !sat_and. (do 2 case) => /= /sub1P C /sub1P D /sub1P E.
        exists p. exists a. exists q. repeat split => //.
        * by rewrite cat_beyond ?leq_addl -?addnBA // subnn addn0 in C.
        * by rewrite cat_prefix // -tnth_nth in D.
        * by rewrite cat_prefix // -tnth_nth in E.
    - move => H. apply/sat_all1 => k'. apply/sat_all1 => k. rewrite !sat_imp => B C.
      move/sat_succ : B => /(_ k' k). case/(_ _ _)/Wrap => // ?;subst.
      case: (H _ (C k m _ _)) => //=; first by rewrite cat_size //=.
      move => p [a] [q] [paq [D [E F]]].
      apply: (sat_orI (x := (p,a,q))); first by rewrite mem_enum.
      rewrite !sat_and; repeat split.
      + apply/sub1P. rewrite /= cat_beyond ?leq_addl //.
        rewrite -addnBA // subnn addn0. done.
      + apply/sub1P. by rewrite /= cat_prefix // -tnth_nth.
      + apply/sub1P. by rewrite /= cat_prefix // -tnth_nth.
  Qed.

  Definition init : form :=
    All1 (zero 0 --> \or_(q \in nfa_s A) Incl 0 (rank q).+1).

  Lemma sat_init (Ns : n.-tuple (seq nat)) I :
    cat Ns I |= init <-> exists2 q, q \in nfa_s A & 0 \in tnth Ns (rank q).
  Proof.
    split.
    - move/sat_all1/(_ 0)/sat_imp. case/(_ _)/Wrap; first exact/sat_zero.
      case/sat_orE => s. rewrite mem_enum /= => B /sub1P C. exists s => //.
      by rewrite cat_prefix // -tnth_nth in C.
    - case => q q1 q2. apply/sat_all1 => m. rewrite sat_imp. move/sat_zero => /= B.
      have -> : m = 0. move: (B 0). by rewrite !inE eqxx => /eqP.
      apply (sat_orI (x := q)); first by rewrite mem_enum.
      apply/sub1P. by rewrite /= cat_prefix -?tnth_nth.
  Qed.

  Definition accept X := \or_(q \in nfa_fin A) Incl X (rank q).

  Lemma sat_accept (Ns : n.-tuple (seq nat)) m I :
    cat Ns (cons [:: m] I) |= accept n <->
    exists2 q, q \in nfa_fin A & m \in tnth Ns (rank q).
  Proof.
    split.
    - case/sat_orE => q.
      rewrite mem_enum /= cat_size ?cat_prefix // -tnth_nth.
      move => B /sub1P C. by exists q.
    - case => q q1 q2. apply: (sat_orI (x := q)); first by rewrite mem_enum.
      rewrite /= cat_size ?cat_prefix // -tnth_nth. exact/sub1P.
  Qed.

  (** underneath of [exn], [#|A|] refers to the length of the word (i.e. "max") *)
  Definition form_of :=
    Ex1 (max :/\: exn #|A| (
      part #|A| :/\: init :/\: run #|A| :/\: accept #|A|)).

  Theorem form_ofP w : reflect (@mso_lang T form_of w) (w \in nfa_lang A).
  Proof.
    apply: (iffP nfaP).
    - move =>[s] [r] [r1 r2].
      rewrite /mso_lang /vec_lang sat_ex1. exists (size w).
      set I' := cons _ _.
      have Hmax : I' |= max by apply/sat_max.
      rewrite sat_and sat_exn. split => //.
      pose pos (i : 'I_#|A|) := [seq n <- iota 0 (size r).+1 | nth s (s::r) n == enum_val i].
      pose t := [tuple pos i | i < #|A|].
      exists t.
      have tP k N (i : 'I_#|A|) :
        k \in nth N t i = (k <= size r) && (nth s (s::r) k == val i).
      { by rewrite -tnth_nth tnth_mktuple mem_filter mem_iota /= add0n ltnS andbC. }
      rewrite !sat_and; repeat split.
      + apply/(sat_part (k := (size w))). by rewrite cat_size.
        move => k Hk. exists (nth s (s::r) k) ;split.
        * by rewrite cat_prefix // tP -(run_size r2) Hk enum_rankK eqxx.
        * move => q'. rewrite cat_prefix //.
          rewrite tP -(run_size r2) Hk enum_rankK. by move/eqP.
      + apply/sat_init. exists s => //. by rewrite tP /= enum_rankK.
      + apply/sat_run => k Hk. have Hk': k < size r by rewrite -(run_size r2).
        exists (nth s (s::r) k).
        exists (tnth (in_tuple w) (Ordinal Hk)).
        exists (nth s (s :: r) k.+1). repeat split.
        * exact: run_trans.
        * rewrite I_of_vecP //. set X := tnth _ _. by rewrite {2}/X (tnth_nth X).
        * by rewrite tP ltnW // enum_rankK eqxx.
        * by rewrite tP enum_rankK Hk' eqxx.
      + apply/sat_accept. exists (last s r); first exact: run_last r2.
        rewrite tP. by rewrite (run_size r2) leqnn enum_rankK nth_last /=.
    - rewrite /mso_lang /vec_lang sat_ex1 => [[m] /sat_and [/sat_max B /sat_exn [Ns]]].
      repeat case/sat_and. subst. set I' := cat _ _.
      move => /sat_part B /sat_init [s s1 s2] /sat_run D /sat_accept E.
      move: {B} (B (size w)).
      case/(_ _)/Wrap => [k|B]; first by rewrite /I' cat_size.
      have exP (i : 'I_(size w)) : exists q : A, i.+1 \in I' (rank q).
      { case: (B i.+1)=> // q [q1 q2]. by exists q. }
      exists s. pose r := [tuple xchoose (exP i) | i < size w]. exists r. split => //.
      have tP k p : k <= size w -> k \in tnth Ns (rank p) -> nth s (s::r) k = p.
      { case: k => [_|k lt_w] H /=.
        - case: (B 0 _) => // q' [q1 q2].
          by rewrite -[p]q2 -1?[s]q2 // /I' cat_prefix // -tnth_nth.
        - rewrite (nth_map (Ordinal lt_w)) ?size_enum_ord //.
          set m := nth _ _ _. move: (exP _) => F. move: (xchooseP F) => G.
          case: (B m.+1 _) => // q' [q1 q2].
          rewrite -[xchoose F]q2 -1?[p]q2 //.
          rewrite /I' cat_prefix // -tnth_nth.
          by rewrite /m nth_enum_ord.
      }
      apply: runI.
      + by rewrite size_tuple.
      + case: E => f f1 f2. rewrite (_ : last s r = f) //.
        by rewrite (last_nth s) size_tuple (tP _ _ _ f2).
      + move => i. move: (D _ (ltn_ord i)) => [p] [a] [q] [pq [Ha [Hp Hq]]].
        rewrite I_of_vecP // in Ha. rewrite (tnth_nth a) (eqP Ha) //.
        by rewrite (tP _ _ _ Hp) 1?ltnW // (tP _ _ _ Hq).
  Qed.

End NFAtoMSO.


Require Import Map.
Local Open Scope map_scope.

Require PeanoNat.
Require Import Program.

Create HintDb term discriminated.

Delimit Scope term_scope with t.
Local Open Scope term_scope.

Reserved Notation "[ ]".
Reserved Notation "[ x ]".
Reserved Infix "@" (at level 20, left associativity).
Reserved Infix "\" (at level 30, right associativity).
Reserved Infix "//" (at level 50, no associativity).
Reserved Notation "x ## s" (at level 50, no associativity).
Reserved Infix "\\" (at level 30, no associativity).

Local Ltac decide_right Q :=
  pattern Q; apply decide_right; [easy | intros _].

Local Ltac decide_left Q :=
  pattern Q; apply decide_left; [easy | intros _].

Module Id := PeanoNat.Nat.

Definition id := Id.t.

Definition id_eq := Id.eq_dec.

Inductive term :=
| Box
| Free (y: id)
| App (s t: term)
| Abs (n: map) (s: term).

Bind Scope term_scope with term.

Notation "[ ]" := Box (format "[ ]"): term_scope.
Notation "[ x ]" := (Free x): term_scope.
Infix "@" := App: term_scope.
Infix "\" := Abs: term_scope.

Function occb x s :=
  match s with
  | []    => false
  | [y]   => if id_eq x y then true else false
  | s @ t => occb x s || occb x t
  | _ \ s => occb x s
  end%bool.

Notation "x ## s" := (occb x s = false): term_scope.

Theorem occb_app x s1 s2:
  x ## (s1 @ s2) <-> x ## s1 /\ x ## s2.
Proof.
  split.
  - now intros []%Bool.orb_false_elim.
  - intros []; apply Bool.orb_false_intro; easy.
Qed.

Inductive dvd: map -> term -> Prop :=
| DBox0:    0   // []
| DBox1:    [1] // []
| DFree y:  0   // [y]
| DApp m s n t:
    m // s ->
    n // t ->
    m & n // s @ t
| DAbs m n s:
    m ⊥ n ->
    m // s ->
    n // s ->
    m // n \ s
where "m // s" := (dvd m s): term_scope.
Hint Constructors dvd: term.

Notation map_for s := {m | m // s}.

Notation wf := (dvd 0).
Notation wfterm := {t | wf t}.

Lemma div_wf n s: n // s -> wf s.
Proof. induction 1; split_0; auto with map term. Qed.

Lemma div_app m s n t:
  (m & n) // (s @ t) ->
  m // s /\ n // t.
Proof. inversion 1; mapp_inj; subst; auto. Qed.

Lemma div_abs m n s: m // n \ s -> m // s.
Proof. now inversion 1. Qed.

Corollary wf_app s t: wf (s @ t) <-> wf s /\ wf t.
Proof. split_0; split; [apply div_app | intros []; auto with term]. Qed.

Ltac div_app :=
  match goal with
  | H: (_ & _) // (_ @ _) |- _ =>
      let H1 := fresh H in
      let H2 := fresh H in
      apply div_app in H as [H1 H2]
  | H: wf (_ @ _) |- _ =>
      let H1 := fresh H in
      let H2 := fresh H in
      apply wf_app in H as [H1 H2]
  end.
Hint Extern 3 => div_app: term.

(* uses PI *)
Theorem wf_eq (s t: wfterm): `s = `t -> s = t.
Proof. destruct s, t; apply subset_eq_compat. Qed.

Hint Resolve div_wf div_abs wf_eq: term.

Function fill (s: term) (m: map) (e: term): option term :=
  match s with
  | [] =>
      match m with
      | 0   => Some []
      | M 1 => Some e
      | _   => None
      end
  | [y] =>
      match m with
      | 0 => Some [y]
      | _ => None
      end
  | s1 @ s2 =>
      match unmapp m with
      | Some (m1, m2) =>
          match fill s1 m1 e, fill s2 m2 e with
          | Some t1, Some t2 => Some (t1 @ t2)
          | _,       _       => None
          end
      | None => None
      end
  | n \ s' =>
      match fill s' m e with
      | Some t => Some (n \ t)
      | None   => None
      end
  end.

Theorem fill_some s m e:
  wf s -> m // s -> exists r, fill s m e = Some r.
Proof.
  intro S; induction 1; simpl; eauto.
  - destruct IHdvd1 as [? R1], IHdvd2 as [? R2]; eauto with term.
    rewrite mapp_unmapp, R1, R2; eauto.
  - destruct IHdvd1 as [? R]; eauto with term.
    rewrite R; eauto.
Qed.

Theorem fill_0 s e r:
  fill s 0 e = Some r -> r = s.
Proof.
  revert r.
  remember 0 as m.
  functional induction (fill s m e); try congruence; intros r R.
  - inversion e1; inversion R; subst; f_equal; auto.
  - inversion R; subst; f_equal; auto.
Qed.

Theorem fill_div s m e r n:
  n // s -> m // s -> m ⊥ n ->
  wf s -> wf e -> fill s m e = Some r ->
  n // r.
Proof.
  intro NS; revert m r.
  induction NS as [| | | p1 ? p2 | p]; intros m r MS MN S E R;
    try solve [functional inversion R; now subst].
  - functional inversion R; subst.
    + eauto with term.
    + now apply orth_1 in MN.
  - functional inversion R; subst.
    replace m with (m1 & m2) in *; [orth_inj |].
    + constructor; eauto with term.
    + pose proof (mapp_unmapp m1 m2).
      apply unmapp_inj; congruence.
  - apply div_abs in S.
    inversion MS; subst.
    functional inversion R; subst.
    constructor; eauto.
Qed.

Theorem fill_wf s m e r:
  wf s -> m // s -> wf e -> fill s m e = Some r -> wf r.
Proof.
  revert r.
  functional induction (fill s m e);
    intros r S MS E R; inversion R; subst; auto.
  - rewrite (mapp_unmapp' m m1 m2) in MS; auto.
    apply wf_app; split.
    + apply IHo; eauto with term.
    + apply IHo0; eauto with term.
  - inversion MS; subst.
    apply div_abs in S.
    constructor; auto with map.
    apply fill_div with (s := s') (m := m) (e := e); auto.
Qed.

Fixpoint make_map x s :=
  match s with
  | []    => 0
  | [y]   => if id_eq x y then M 1 else 0
  | s @ t => make_map x s & make_map x t
  | _ \ s => make_map x s
  end.

Fixpoint make_skel x s :=
  match s with
  | []    => []
  | [y]   => if id_eq x y then [] else [y]
  | s @ t => make_skel x s @ make_skel x t
  | n \ s => n \ make_skel x s
  end.

Theorem make_map_orth x s m:
  m // s -> make_map x s ⊥ m.
Proof.
  revert m; induction s; simpl;
    inversion_clear 1; auto with map term.
Qed.
Hint Resolve make_map_orth: term.

Lemma make_skel_div x s m:
  wf s -> m // s -> m // make_skel x s.
Proof with (auto with term).
  revert m. induction s; intros m S MS; simpl; auto.
  - destruct (id_eq x y); inversion MS; subst...
  - inversion_clear MS...
  - inversion_clear MS; apply div_abs in S...
Qed.
Hint Resolve make_skel_div: term.

Theorem make_map_skel_div x s:
  wf s -> make_map x s // make_skel x s.
Proof with (simpl; eauto with term).
  induction s; intro S...
  - destruct (id_eq x y)...
  - inversion_clear S; constructor...
Qed.
Hint Resolve make_map_skel_div: term.

Theorem make_skel_wf x s: wf s -> wf (make_skel x s).
Proof with (auto with term).
  induction s; intro S; simpl...
  - destruct (id_eq x y)...
  - split_0; constructor...
  - inversion_clear S...
Qed.
Hint Resolve make_skel_wf: term.

Theorem make_map_not_occ x s: x ## s -> make_map x s = 0.
Proof.
  intro S.
  induction s; auto.
  - functional inversion S; subst; simpl.
    now rewrite H1.
  - apply occb_app in S as [].
    simpl; split_0; f_equal; auto.
Qed.
Hint Resolve make_map_not_occ: term.

Theorem make_skel_not_occ x s: x ## make_skel x s.
Proof.
  induction s; auto.
  - simpl.
    destruct (id_eq x y); simpl; auto.
    decide_right (id_eq x y); auto.
  - now apply occb_app.
Qed.
Hint Resolve make_skel_not_occ: term.

Theorem make_skel_occ_diff x s z:
  x <> z ->
  occb z s = occb z (make_skel x s).
Proof.
  intro XY; induction s; auto.
  - simpl. destruct (id_eq z y), (id_eq x y); subst; simpl.
    + congruence.
    + now decide_left (id_eq y y).
    + easy.
    + now decide_right (id_eq z y).
  - simpl; f_equal; easy.
Qed.

Theorem make_skel_not_occ_eq x s:
  x ## s -> make_skel x s = s.
Proof.
  intro X.
  induction s; auto.
  - simpl. functional inversion X; subst.
    now decide_right (id_eq x y).
  - apply occb_app in X as [].
    simpl; f_equal; auto.
  - simpl in *; f_equal; auto.
Qed.
Hint Resolve make_skel_not_occ_eq: term.

Definition subst s x :=
  fill (make_skel x s) (make_map x s).

Theorem subst_wf s x e r:
  wf s -> wf e -> subst s x e = Some r -> wf r.
Proof.
  unfold subst. intros.
  apply fill_wf with (s := make_skel x s) (m := make_map x s) (e := e);
    auto with term.
Qed.

Section Subst_subterms.
  Local Arguments subst s x /.

  Theorem subst_self x s: subst s x [x] = Some s.
  Proof.
    induction s; simpl in *; auto.
    - destruct (id_eq x y); simpl; congruence.
    - now rewrite mapp_unmapp, IHs1, IHs2.
    - now rewrite IHs.
  Qed.

  Lemma subst_box x e: subst [] x e = Some [].
  Proof. easy. Qed.

  Lemma subst_free_eq x e: subst [x] x e = Some e.
  Proof. simpl; destruct (id_eq x x); easy. Qed.

  Lemma subst_free_ne x y e:
    x <> y -> subst [y] x e = Some [y].
  Proof. intro; simpl; destruct (id_eq x y); easy. Qed.

  Lemma subst_app s1 s2 x e r1 r2:
    subst s1 x e = Some r1 ->
    subst s2 x e = Some r2 ->
    subst (s1 @ s2) x e = Some (r1 @ r2).
  Proof. simpl; rewrite mapp_unmapp; intros -> ->; easy. Qed.

  Lemma subst_abs n s x e r:
    subst s x e = Some r ->
    subst (n \ s) x e = Some (n \ r).
  Proof. simpl; intros ->; easy. Qed.

  Lemma subst_app_split s1 s2 x e r:
    subst (s1 @ s2) x e = Some r ->
    exists r1 r2,
      r = r1 @ r2 /\
      subst s1 x e = Some r1 /\
      subst s2 x e = Some r2.
  Proof.
    simpl.
    rewrite mapp_unmapp.
    destruct fill, fill; try easy.
    inversion 1; eauto.
  Qed.

  Lemma subst_abs_split n s x e r:
    subst (n \ s) x e = Some r ->
    exists r',
      r = n \ r' /\
      subst s x e = Some r'.
  Proof.
    simpl.
    destruct fill; try easy.
    inversion 1; eauto.
  Qed.
End Subst_subterms.

Hint Rewrite
  subst_box subst_free_eq subst_free_ne subst_app subst_abs
  using solve [auto]: subst.

Lemma subst_not_occ s x e:
  x ## s -> subst s x e = Some s.
Proof.
  induction s; simpl; intro XS; auto.
  - unfold subst; simpl.
    now destruct (id_eq x y).
  - apply occb_app in XS as [].
    erewrite subst_app; eauto.
  - unfold subst; simpl. fold (subst s x).
    rewrite IHs; auto.
Qed.

Ltac invert_some :=
  match goal with
  | H: Some _ = Some _ |- _ =>
      inversion H; subst; clear H; simpl in *
  end.

Ltac subst_app_split :=
  (* these two matches can't be merged :/ *)
  match goal with
  | a: term |- _ =>
    match goal with
      | H: subst (_ @ _) _ _ = Some a |- _ =>
          let a1 := fresh a in let a2 := fresh a in
          let H1 := fresh H in let H2 := fresh H in
          apply subst_app_split in H as (a1 & a2 & -> & H1 & H2)
    end
  end.

Ltac subst_abs_split :=
  match goal with
  | a: term |- _ =>
      match goal with
      | H: subst (_ \ _) _ _ = Some a |- _ =>
          let a' := fresh a in let H' := fresh H in
          apply subst_abs_split in H as (a' & -> & H')
      end
  end.

Ltac simpl_subst := progress repeat
  (invert_some + subst_app_split + subst_abs_split +
   (progress autorewrite with subst in *)).

Theorem substitution:
  forall a x1 e1 x2 e2 a1 a2 e1' r1 r2,
  x1 <> x2 ->
  x1 ## e2 ->
  subst a  x1 e1  = Some a1  ->
  subst a1 x2 e2  = Some r1  ->
  subst a  x2 e2  = Some a2  ->
  subst e1 x2 e2  = Some e1' ->
  subst a2 x1 e1' = Some r2  ->
  r1 = r2.
Proof.
  intros until r2; intros X XE A1 R1 A2 E1' R2.
  revert a1 a2 r1 r2 A1 A2 R1 R2.
  induction a; intros.
  - now simpl_subst.
  - destruct (id_eq x1 y), (id_eq x2 y); subst.
    + contradiction.
    + simpl_subst; congruence.
    + simpl_subst; rewrite subst_not_occ in R2; congruence.
    + now simpl_subst.
  - simpl_subst; f_equal; eauto.
  - simpl_subst; f_equal; eauto.
Qed.

Definition lam x s :=
  make_map x s \ make_skel x s.
Infix "\\" := lam: term.

Theorem subst_lam_eq x s e:
  subst (lam x s) x e = Some (lam x s).
Proof. apply subst_not_occ, make_skel_not_occ. Qed.

Theorem subst_lam_not_occ x s y e:
  y ## s ->
  subst (lam x s) y e = Some (lam x s).
Proof.
  intro; destruct (id_eq x y) as [-> | ].
  + apply subst_lam_eq.
  + apply subst_not_occ; simpl.
    rewrite <- make_skel_occ_diff; auto.
Qed.