(* --------------------------------------------------------------------
 * (c) Copyright 2011--2012 Microsoft Corporation and Inria.
 * (c) Copyright 2012--2014 Inria.
 * (c) Copyright 2012--2014 IMDEA Software Institute.
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype seq.
From mathcomp Require Import fintype choice tuple perm zmodp ssrfun.
From mathcomp Require Import bigop ssralg ssrint ssrnum generic_quotient.

Require Import xseq xmatrix polyall polydec polyfrac.
Require Import freeg.
Require Import Setoid.

Require Import ec ecpoly eceval ecorder ecdiv ecrr.
Require Import fraction ecpolyfrac.

(* -------------------------------------------------------------------- *)
Import GRing.Theory.
Import Num.Theory.
Import fraction.FracField.
Import fracfield.FracField.

Open Local Scope ring_scope.

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

Local Notation simpm := Monoid.simpm.

(* -------------------------------------------------------------------- *)
Section LinearReduction.
  Variable K : ecuDecFieldType.
  Variable E : ecuType K.

  Notation Xpoly   := (@Xpoly K E).
  Notation ecpoly  := (@ecpoly K E).
  Notation oncurve := (@oncurve K E).
  Notation "f .[ x , y ]" := (eceval f x y).
  Notation "p %:E" := (ECPoly E (0, p)).

  Implicit Types f : {fraction ecpoly}.

  Hypothesis closedK : GRing.ClosedField.axiom K.

  Import PreClosedField.

  Hint Resolve closedK.

  Local Notation clK := (ClosedFieldType K closedK).
  Local Notation PEF := (@tofrac _ \o ((ecX E) \o polyC)).
  Local Notation "x %:PEF" := (PEF x) (at level 2).
  Local Notation "x %:F"  := (tofrac x).
  Local Notation "x // y" := (x%:F / y%:F) (at level 50, no associativity).

  Local Notation "\+%G" := (@ECGroup.add _ E).

  Local Notation "\- x" := (@ECGroup.neg _ x).
  Local Notation "x \+ y" := (@ECGroup.add _ E x y).
  Local Notation "x \- y" := (x \+ (\- y)).

  Local Notation "D1 :~: D2" := (@ecdeqv _ E D1 D2).

  Definition lr_r (D : {freeg (point K)}) :=
    let iter p n := nosimpl iterop _ n \+%G p ∞ in
      \big[\+%G/∞]_(p <- dom D | p != ∞) (iter p `|coeff p D|%N).

  Definition lr (D : {freeg (point K)}) : point K :=
    let: (Dp, Dn) := (fgpos D, fgneg D) in
      lr_r Dp \- lr_r Dn.

  Local Notation "D1 <=g D2" := (fgle D1 D2).

  (* FIXME: move this *)
  Lemma oncurve_natmul n p: oncurve p -> oncurve (iterop n \+%G p ∞).
  Proof.
    move=> p_oncve; rewrite /iterop; elim: n => [//|n IH].
    by rewrite iteriS; case: n IH => [//|n] IH; apply ECGroup.addO.
  Qed.

  (* FIXME: move this *)
  Lemma oncurve_sum (I : Type) (F : I -> point K) (ps : seq I):
    all (oncurve \o F) ps -> oncurve (\big[\+%G/∞]_(p <- ps) (F p)).
  Proof.
    elim: ps => [|p ps IH]; first by rewrite big_nil.
    move=> /= /andP [oncve_p oncve_ps]; rewrite big_cons.
    by apply: ECGroup.addO => //; apply: IH.
  Qed.

  Add Parametric Relation (E : ecuType K):
    {freeg (point K)} (ecdeqv E)
      reflexivity  proved by (@ecdeqv_refl  _ E)
      symmetry     proved by (@ecdeqv_sym   _ E)
      transitivity proved by (@ecdeqv_trans _ E)
    as ecdeqv_rel.

  Add Parametric Morphism (E : ecuType K):
    (@GRing.opp _) with signature
          (ecdeqv E)
      ==> (ecdeqv E)
    as ecdeqv_morph_opp.
  Proof. by move=> D1 D2 eqv; apply: ecdeqv_opp. Qed.

  Add Parametric Morphism (E : ecuType K):
    (@GRing.add _) with signature
          (ecdeqv E)
      ==> (ecdeqv E)
      ==> (ecdeqv E)
    as ecdeqv_morph_add.
  Proof. by move=> D1 D2 eqv D'1 D'2 eqv'; apply: ecdeqv_add. Qed.

  Require Import ssrring.

  Lemma Nsym_ecdivpE (p : ecpoly) cs:
       (forall x y, y != 0 -> (p.[x, y] != 0) || (p.[x, -y] != 0))
    -> (forall x y, (x, y) \in cs -> oncurve (|x, y|))
    -> (forall x y, (x, y) \in cs -> p.[x, y] = 0)
    -> perm_eq (map (@fst _ _) cs) (roots (normp p))
    -> ecdivp p = \sum_(i <- cs) << (|i.1, i.2|) >> + << order p%:F ∞ *g ∞ >>.
  Proof.
    move=> Nsym csoncve csok; have [->|nz_p] := eqVneq p 0.
      rewrite ecdivp0 norm0 roots0 => /perm_eq_small.
      move/(_ (erefl true)); case: {csok csoncve} cs => [|//] _.
      by rewrite big_nil order0 freegU0 addr0.
    move=> csroots; apply/eqP/freeg_eqP => ecp.
    rewrite ecdivpE coeffD raddf_sum /=; case: ecp => [|x y].
      rewrite big1; last first.
        by move=> i _; rewrite coeffU mulr0.
      by rewrite add0r coeffU eqxx mulr1.
    have [oncve|Noncve] := boolP (oncurve (|x, y|)); last first.
      rewrite order_outcve // big_seq big1; last first.
        case=> [x' y'] /= /csoncve oncve.
        move/memPn: Noncve => /(_ _ oncve) => ne.
        by rewrite coeffU (negbTE ne) mulr0.
      by rewrite add0r coeffU mulr0.
    rewrite coeffU /= mulr0 addr0.
    move: (erefl (order (normp p)%:E%:F (|x, y|))).
    rewrite {1}orderF poly_order_mu // -conjp_normp.
    rewrite tofracM order_mul ?(mulf_neq0, tofrac_eq0, conjp_eq0) //.
    have [z_y|nz_y] := eqVneq y 0; first rewrite z_y.
      rewrite -conjF -{4}[0]oppr0 (order_conj _ (|x, 0|)).
      rewrite eqxx /= -mulr2n PoszM pmulrn mulrzz => /mulIf <- //.
      rewrite (bigID (fun i => i.1 == x)) /= addrC big1; last first.
        by move=> i ne_i1_x; rewrite coeffU eqE /= (negbTE ne_i1_x) mulr0.
      rewrite add0r big_seq_cond (eq_bigr (fun i => 1)); last first.
        case=> [x' y'] /= /andP [x'y'_in_cs /eqP eq_x'x]; rewrite coeffU eqE /=.
        rewrite eq_x'x eqxx /= mul1r; move/csoncve: x'y'_in_cs => /=.
        by rewrite eq_x'x -(eqP oncve) z_y expr0n /= sqrf_eq0 => ->.
      rewrite -big_seq_cond -big_filter big_const_seq count_predT.
      rewrite -Monoid.iteropE /= -/(GRing.natmul _ _) size_filter.
      by rewrite roots_mu ?norm_eq0 // -(perm_eqP csroots) count_map natz.
    have [z_ord|] := eqVneq (order p%:F (|x, y|)) 0.
      move=> _; rewrite z_ord big_seq big1 ?addr0 //.
      move=> [x' y'] x'y'_in_cs; rewrite coeffU mul1r.
      case: (_ =P _) => [|//] /= eq; move/csok/eqP: x'y'_in_cs.
      move/eqP: z_ord; rewrite -order_poly_cmp0 //.
      by case: eq => -> -> /negbTE ->.
    rewrite -order_poly_cmp0 // negbK => /eqP z_pxy.
    have := (Nsym x y nz_y); rewrite z_pxy eqxx /= => nz_pxNy.
    rewrite -conjF -{3}[y]opprK (order_conj _ (|x, -y|)).
    have ->: order p%:F (|x, -y|) = 0.
      move: nz_pxNy; rewrite order_poly_cmp0 -?(oncurveN E (|x, y|)) //.
      by move/eqP => ->.
    rewrite addr0 => <-; rewrite (negbTE nz_y) muln1.
    rewrite (bigID (fun i => i.1 == x)) /= addrC big1; last first.
      by move=> i ne_i1_x; rewrite coeffU eqE /= (negbTE ne_i1_x) mulr0.
    rewrite add0r big_seq_cond (eq_bigr (fun i => 1)); last first.
      case=> [x' y'] /andP [x'y'_in_cs /= /eqP eq_x'x].
      rewrite coeffU mul1r eqE /= eq_x'x eqxx /=.
      have/csoncve := x'y'_in_cs; rewrite eq_x'x /= -(eqP oncve).
      rewrite eqf_sqr; case/orP => [->//|/eqP y'E].
      move: (csok _ _ x'y'_in_cs); rewrite eq_x'x y'E => /eqP.
      by rewrite (negbTE nz_pxNy).
    rewrite -big_seq_cond -big_filter big_const_seq count_predT.
    rewrite -Monoid.iteropE /= -/(GRing.natmul _ _) size_filter.
    by rewrite roots_mu ?norm_eq0 // -(perm_eqP csroots) count_map natz.
  Qed.

  Lemma lrline p1 p2:
       oncurve p1
    -> oncurve p2
    -> (<< p1 >> + << p2 >>) :~: (<< p1 \+ p2 >> + << ∞ >>).
  Proof.
    case: p1 p2 => [|x1 y1] [|x2 y2].
    + by move=> _ _; rewrite ECGroup.add0o; reflexivity.
    + by move=> _ oncve; rewrite ECGroup.add0o // addrC; reflexivity.
    + by move=> oncve _; rewrite ECGroup.addoC ECGroup.add0o // addrC; reflexivity.
    move=> oncve_1 oncve_2; case h: (ECGroup.line E (x1, y1) (x2, y2)) => [[u v] c].
    set a := (_ \+ _); pose r : ecpoly := [ecp u%:P *Y + v *: 'X - c%:P].
    have oncve_a: oncurve a by rewrite /a ECGroup.addO.
    case: (u =P 0) => [z_u|/eqP nz_u].
      move: h z_u; rewrite /ECGroup.line oncve_1 oncve_2 /=.
      case: (x1 =P x2) => [eq_x1x2|_]; last first.
        by case=> <- _ _ /eqP; rewrite oner_eq0.
      case b: (_ && _); first by move=> [<- _ _] /eqP; rewrite oner_eq0.
      rewrite /a; move=> _ _; rewrite /ECGroup.add oncve_1 oncve_2.
      rewrite -eq_x1x2 eqxx b; have ->: y2 = -y1.
        move: oncve_1 oncve_2 => /=; rewrite -eq_x1x2 => /eqP <-.
        rewrite eqr_sqr ![y2 == _]eq_sym; case/orP; last by move/eqP=>->.
        move/eqP=> eq_y1y2; move: b; rewrite eq_y1y2 eqxx /=.
        by move/negbT; rewrite negbK => /eqP ->; rewrite oppr0.
      case: (ecdeqv_lineS oncve_1) => f Ef; exists f.
      by rewrite Ef /= subr0 freegUD.
    have: ecdivp r = <<(|x1, y1|)>> + <<(|x2, y2|)>> + <<\- a>> - << 3%:Z *g ∞ >>.
      pose z := u ^- 2 * v ^+ 2 - (x1 + x2).
      have: perm_eq (roots (normp r)) [:: x1; x2; z].
        move: (@ECGroup.thdimp K E (x1, y1) (x2, y2)).
        rewrite h => /(_ nz_u) /=; rewrite -/z; move: (erefl (normp r)).
        rewrite {1}/r {1}normpE /= => /(congr1 ( *%R (u ^- 2)%:P)).
        rewrite mulrBr [X in _-X=_]mulrA -polyC_exp -polyC_mul.
        rewrite mulVf ?expf_neq0 // polyC1 mul1r -{1}exprVn.
        rewrite polyC_exp -exprMn !mul_polyC => /(congr1 -%R).
        rewrite opprB => -> /eqP; rewrite eqr_oppLR => /eqP.
        move/(congr1 ( *%R (u^+2)%:P)); rewrite -mul_polyC mulrA.
        rewrite -exprVn 2!polyC_exp -exprMn -polyC_mul divff //.
        rewrite polyC1 expr1n mul1r => ->; apply/perm_eqlP => x.
        rewrite mulrN -mulNr -polyC_exp -[X in roots (X * _)]polyC_opp.
        rewrite -!mulrA mul_polyC roots_mulC ?(oppr_eq0, expf_neq0) //.
        move: x; apply/perm_eqlP; move: (perm_eq_roots_factors [:: x1; x2; z]).
        by rewrite unlock /= mulr1.
      move=> rsr; pose yz := u^-1 * (c - v * z); have NaE: \- a = (|z, yz|).
        rewrite -ECGroup.ladd_addE /ECGroup.ladd !(oncve_1, oncve_2).
        by rewrite h (negbTE nz_u) /yz /z.
      pose cs := [:: (x1, y1); (x2, y2); (z, yz)].
      rewrite (@Nsym_ecdivpE _ cs); last first.
      + by rewrite /cs /= perm_eq_sym.
      + move=> x y; rewrite /cs mem_seq3; case/or3P => /eqP;
          case=> -> ->; rewrite /r /eceval !hornerE /=.
        * by move: (ECGroup.line_okl E (x1, y1) (x2, y2)); rewrite h.
        * by move: (ECGroup.line_okr E (x1, y1) (x2, y2)); rewrite h.
        * by rewrite divff // mul1r; move: {rsr yz NaE cs} z => z; ssring.
      + move=> x y; rewrite /cs mem_seq3; case/or3P => /eqP [->->] //.
        by rewrite -NaE; move: oncve_a; rewrite oncurveN.
      + move=> x y nz_y; rewrite -negb_and; apply/negP => /andP [].
        move/eqP => <- /eqP; rewrite /eceval => /addIr/eqP.
        rewrite mulrN eq_sym ECGroup.eqrN_eq0 mulf_eq0.
        by rewrite (negbTE nz_y) orbF /r /= !hornerE (negbTE nz_u).
      rewrite /cs unlock /= addr0 NaE !addrA; congr (_ + _).
      rewrite orderF /poly_order /= /r eqE /= eqE /=.
      rewrite polyC_eq0 (negbTE nz_u) /= degreeE /=.
      rewrite polyC_eq0 size_polyC !(negbTE nz_u) muln1 /=.
      rewrite /maxn; case: ltnP => /=; first by rewrite -freegUN.
      have [->|nz_v] := eqVneq v 0.
        by rewrite scale0r sub0r size_opp size_polyC; case: (c != 0).
      have {1}->: c = v * (c / v) by rewrite mulrCA divff // mulr1.
      rewrite !polyC_mul -{1}mul_polyC -mulrBr mul_polyC -polyC_mul.
      by rewrite size_scale // size_XsubC.
    case: (ecdeqv_lineS oncve_a) => f /eqP; rewrite subr0 eq_sym.
    rewrite subr_eq eq_sym -subr_eq => /eqP/esym {1}-> /eqP.
    rewrite eq_sym subr_eq eq_sym -subr_eq => /eqP <-.
    have eq: << 2%:Z *g ∞ >> - <<\- a>> + <<∞>> = << 3%:Z *g ∞ >> - <<\- a>>.
      by rewrite addrAC freegUD.
    have [->|nz_f] := eqVneq f 0.
      rewrite ecdiv0 add0r eq; symmetry; exists (r%:F)^-1.
      rewrite -[ecdivp _ + _ + _]addrA; set z := << _ *g _ >> - _.
      by rewrite opprD addrCA subrr addr0 ecdivV ecdivF.
    exists (r%:F / f). rewrite -[X in _ = X-_]addrA.
    set z := << _ *g _ >> - _; move: {-2}z (erefl z).
    rewrite {}/z => z Ez; rewrite -!addrA opprD.
    rewrite [<< 2%:Z *g _ >> + _] addrA eq -Ez !addrA.
    rewrite addrAC -[_ + z - z]addrA subrr addr0.
    rewrite ecdivM ?(mulf_neq0, invr_eq0, tofrac_eq0) //; last first.
      by rewrite /r eqE /= eqE /= polyC_eq0 (negbTE nz_u).
    by rewrite ecdivV ecdivF.
  Qed.

  Lemma oncurve_lr_r D: all oncurve (dom D) -> oncurve (lr_r D).
  Proof.
    move=> oncve; rewrite /lr_r -big_filter; set ps := [seq _ <- _ | _].
    have oncve_ps: all oncurve ps.
      rewrite {}/ps; apply/allP=> p; rewrite mem_filter.
      by case/andP=> _; move/allP: oncve; apply.
    elim: ps oncve_ps => [|p ps IH]; first by rewrite big_nil.
    move=> /= /andP [oncve_p oncve_ps]; rewrite big_cons.
    by apply: ECGroup.addO; apply: IH.
  Qed.

  Lemma oncurve_lr D: all oncurve (dom D) -> oncurve (lr D).
  Proof. by move=> oncve; rewrite /lr; apply: ECGroup.addO. Qed.

  Lemma ecdeqv_lr_r D: 0 <=g D -> all oncurve (dom D) ->
    D :~: << lr_r D >> + << deg D - 1 *g ∞ >>.
  Proof.
    move=> D_ge0 oncve; rewrite /lr_r - big_filter addrC; symmetry.
    rewrite {1}[D]div_sumE degD degU raddf_sum /= -big_filter.
    rewrite addrAC [X in << X *g _ >>]addrC; symmetry.
    rewrite (eq_bigr (fun p => coeff p D)); last by move=> p _; rewrite degU.
    rewrite {1}[D]div_sumE addrC [X in _ :~: X]addrC -big_filter.
    set ps := [seq p <- dom D | p != ∞].
    have oncve_ps: all oncurve ps.
      apply/allP=> p; rewrite mem_filter => /andP [_ p_in_D].
      by move/allP/(_ p p_in_D): oncve.
    elim: ps oncve_ps => [|p ps IH] /=.
      by rewrite !big_nil !add0r freegUD addrCA subrr addr0; reflexivity.
    case/andP=> oncve_p oncve_ps; rewrite !big_cons;
      set px  := (iterop _ _ _ _);
      set psx := \big[\+%G/∞]_(_ <- _ | _) _.
    rewrite -[<<_ \+ _>>]addr0 -{2}(subrr <<∞>>) !addrA -lrline; first 1 last.
    + by apply: oncurve_natmul.
    + apply/oncurve_sum/allP => q q_in_ps /=; apply/oncurve_natmul.
      by move/allP/(_ q q_in_ps): oncve_ps.
    rewrite -addrA IH // -/psx; set s := \sum_(_ <- _) _.
    rewrite -!freegUD !addrA; do 3! apply/ecdeqv_addl.
    rewrite addrC [<<px>>+_]addrC -!addrA; apply/ecdeqv_addr.
    rewrite [-_+_]addrC freegUB {}/px {}/psx.
    set k := coeff _ _; have k_ge0: k >= 0 by move/fgposP/(_ p): D_ge0.
    rewrite {1 3}[k]intEsign ltrNge k_ge0 expr0 mul1r.
    move: {k_ge0} k => k; move: (absz _) => {k} n; rewrite /iterop.
    set f := fun n q => _; have oncve_it k: oncurve (iteri k f ∞).
      by apply: oncurve_natmul.
    elim: n => [|n IHn] //=.
      by rewrite freegU0 sub0r -freegUN subrr; reflexivity.
    case: n IHn => [|n].
      by move=> _; rewrite subrr freegU0 addr0; reflexivity.
    set r := (iteri _ _ _); have: oncurve r by apply: oncve_it.
    move: r => {oncve_it} r oncve_r IHn; rewrite {}/f.
    rewrite -{1}addn1 PoszD -freegUD IHn /= !subzn // !subn1 /=.
    rewrite addrAC [<<r>> + _]addrC lrline // -addrA.
    rewrite freegUD -PoszD add1n; reflexivity.
  Qed.

  Lemma ecdeqv_lr D: all oncurve (dom D) ->
    D :~: << lr D >> + << deg D - 1 *g ∞ >>.
  Proof.
    move=> oncve; rewrite {1}[D]fg_decomp /lr.
    set rP := lr_r (fgpos D); set rN := lr_r (fgneg D).
    have oncveP: all oncurve (dom (fgpos D)).
      by apply/allP=> p /fgpos_dom; move/allP/(_ p): oncve.
    have oncveN: all oncurve (dom (fgneg D)).
      by apply/allP=> p /fgneg_dom; move/allP/(_ p): oncve.
    have oncve_rP: oncurve rP by apply: oncurve_lr_r.
    have oncve_rN: oncurve rN by apply: oncurve_lr_r.
    rewrite {1}[fgpos D]ecdeqv_lr_r ?fgpos_le0 //.
    rewrite {1}[fgneg D]ecdeqv_lr_r ?fgneg_le0 //.
    rewrite -/rP -/rN opprD addrCA -addrA freegUB.
    rewrite opprD opprK [deg _ - _ + _]addrAC !addrA.
    rewrite -degB -fg_decomp [_ - 1]addrAC [_+1]addrC.
    rewrite -freegUD !addrA; apply: ecdeqv_addl.
    rewrite [-_+_]addrC -[<<rN>>]subr0 -(ecdeqv_lineS oncve_rN).
    rewrite !opprD !opprK !addrA [_ + <<rN>>]addrAC.
    rewrite -[_ - <<rN>>]addrA subrr addr0 lrline -?oncurveN //.
    rewrite -!addrA -[X in _ :~:X]addr0; apply: ecdeqv_addr.
    rewrite addrCA freegUD -PoszD addrC freegUB subrr.
    by rewrite freegU0; reflexivity.
  Qed.

  Lemma ecnorm_lr_le1 D: ecnorm (<< lr D >> + << deg D - 1 *g ∞ >>) <= 1.
  Proof.
    rewrite /lr; move: (_ \- _)=> x; case: (x =P ∞) => [->|].
    + by rewrite freegUD ecnormU eqxx mulr0 ler01.
    + move/eqP=> x_neq0; case: (deg D - 1 =P 0) => [->|].
        by rewrite freegU0 addr0 ecnormU x_neq0 mulr1.
      move/eqP=> pdegD_neq0; rewrite ecnormD; last first.
        move=> p; rewrite !inE domU1 domU // !mem_seq1.
        by apply/negP=> /andP [/eqP->]; rewrite (negbTE x_neq0).
      by rewrite !ecnormU x_neq0 eqxx !(mulr0, mulr1) addr0.
  Qed.

  Lemma ecnorm_lr_deg0_le1 D: deg D = 0 ->
    ecnorm (<< lr D >> - << ∞ >>) <= 1.
  Proof.
    move=> degD_eq0; move: (ecnorm_lr_le1 D).
    by rewrite degD_eq0 sub0r -freegUN.
  Qed.

  Lemma ecdeqv_lr_deg0 (D : {freeg (point K)}):
    deg D = 0 -> all oncurve (dom D) ->
      D :~: (<< lr D >> - << ∞ >>).
  Proof.
    move=> degD_eq0 oncveD; rewrite {1}(ecdeqv_lr oncveD).
    by rewrite degD_eq0 sub0r -freegUN; reflexivity.
  Qed.

  Lemma ecdeqv_lr_deg0_uniq (D : {freeg point K}) (p : point K):
       deg D = 0 -> all oncurve (dom D)
    -> D :~: (<< p >> - << ∞ >>)
    -> p = lr D.
  Proof.
    move=> degD_eq0 oncve; rewrite {1}[D]ecdeqv_lr_deg0 //.
    by move/ecdeqv_addIl/(L_2_40 closedK)/esym.
  Qed.

  Lemma lr0: lr 0 = ∞.
  Proof.
    rewrite /lr fgposE fgnegE dom0 !big_nil.
    by rewrite /lr_r dom0 !big_nil.
  Qed.

  Lemma lrD D1 D2:
    deg D1 = 0 -> all oncurve (dom D1) ->
    deg D2 = 0 -> all oncurve (dom D2) ->
    lr (D1 + D2) = lr D1 \+ lr D2.
  Proof.
    move=> degD1_eq0 oncveD1 degD2_eq0 oncveD2.
    have lrD1 := (ecdeqv_lr_deg0 degD1_eq0 oncveD1).
    have lrD2 := (ecdeqv_lr_deg0 degD2_eq0 oncveD2).
    have := ecdeqv_add lrD1 lrD2; rewrite addrCA !addrA.
    rewrite [<<lr D2>>+_]addrC lrline; first 1 last.
    + by apply: oncurve_lr. + by apply: oncurve_lr.
    rewrite -[X in _ :~: X - _]addrA subrr addr0.
    move/ecdeqv_lr_deg0_uniq/esym; apply.
    + by rewrite degD degD1_eq0 degD2_eq0.
    + apply/allP=> p /domD_subset; rewrite mem_cat; case/orP.
      * by move/allP/(_ p): oncveD1.
      * by move/allP/(_ p): oncveD2.
  Qed.

  Lemma lrN D:
    deg D = 0 -> all oncurve (dom D) -> lr (-D) = \- (lr D).
  Proof.
    move=> degD_eq0 oncveD; have lrD := (ecdeqv_lr_deg0 degD_eq0 oncveD).
    have := ecdeqv_opp lrD; rewrite opprD opprK.
    have ->: <<lr D>> :~: -<<\- (lr D)>> + <<2%:Z *g ∞>>.
    + have /ecdeqv_lineS: oncurve (lr D) by apply oncurve_lr.
      by case=> f fE; exists f; rewrite fE subr0 opprD opprK addrA.
    rewrite opprD opprK -addrA freegUN freegUD.
    have ->: -2%:Z + 1 = -1 by [].
    rewrite -freegUN => /ecdeqv_lr_deg0_uniq/esym; apply.
    + by apply/eqP; rewrite degN oppr_eq0 degD_eq0.
    + by apply/allP=> p; rewrite domN => pD; move/allP/(_ p pD): oncveD.
  Qed.

  Lemma lrB D1 D2:
    deg D1 = 0 -> all oncurve (dom D1) ->
    deg D2 = 0 -> all oncurve (dom D2) ->
    lr (D1 - D2) = lr D1 \- lr D2.
  Proof.
    move=> degD1_eq0 oncveD1 degD2_eq0 oncveD2; rewrite lrD ?lrN //.
    + by apply/eqP; rewrite degN oppr_eq0 degD2_eq0.
    + by apply/allP=> p; rewrite domN => pD; move/allP/(_ p pD): oncveD2.
  Qed.

  Lemma oncurve_lrpi p:
    oncurve p -> all oncurve (dom (<<p>> - <<∞>> : {freeg point _})).
  Proof.
    case: (p =P ∞) => [->|/eqP]; first by rewrite subrr dom0.
    move=> nz_p oncve; apply/allP=> q /domD_subset; rewrite mem_cat.
    by case/orP; rewrite ?domN domU1 mem_seq1 => /eqP ->.
  Qed.

  Lemma lrpi p: oncurve p -> lr (<<p>> - <<∞>>) = p.
  Proof.
    move=> oncve_p; move: (ecdeqv_refl E (<<p>> - <<∞>>)).
    move/ecdeqv_lr_deg0_uniq => {2}-> //.
    + by rewrite degB !degU subrr.
    + by apply: oncurve_lrpi.
  Qed.
End LinearReduction.


Require Import Program.Equality.
Require Import LibTactics.
Require Import Lia.

Inductive typ :=
  | int : typ
  | top : typ
  | and : typ -> typ -> typ
  | rcd : nat -> typ -> typ
  | arr : typ -> typ -> typ.

Inductive mode := inf | chk.

Inductive fmode := bl | wh.

Inductive exp :=
  | lit : nat -> exp
  | unit : exp
  | ctx : exp
  | merge : exp -> exp -> exp
  | ann : exp -> typ -> exp
  | rec : nat -> exp -> exp
  | proj : exp -> nat -> exp
  | lam : fmode -> exp -> exp
  | app : exp -> exp -> exp
  | box : exp -> exp -> exp
  | fixp : typ -> exp -> exp.

Inductive sub : typ -> typ -> Prop :=
  | sint  : sub int int
  | stop  : forall A, sub A top
  | sand  : forall A B C, sub A B -> sub A C -> sub A (and B C)
  | sandl : forall A B C, sub A C -> sub (and A B) C
  | sandr : forall A B C, sub B C -> sub (and A B) C
  | srcd  : forall x A B, sub A B -> sub (rcd x A) (rcd x B)
  | sarr  : forall A B C D, sub C A -> sub B D -> sub (arr A B) (arr C D).

Inductive gord : typ -> Prop :=
  | GO_int :
      gord int
  | GO_arrow : forall A B,
      gord B ->
      gord (arr A B)
  | GO_rcd : forall x B,
      gord B ->
      gord (rcd x B).

Definition cost_spec A B := exists C, gord C /\ sub A C /\ sub B C.

Definition disjoint A B := ~ (cost_spec A B).

Inductive value : exp -> Prop :=
  | vlit : forall i, value (lit i)
  | vunit : value unit
  | vmrg : forall e1 e2, value e1 -> value e2 -> value (merge e1 e2)
  | vrec : forall x e, value e -> value (rec x e)
  | vclos : forall e1 e A B, value e1 -> value (box e1 (ann (lam bl e) (arr A B)))
  | vsclos : forall e1 e A B l, value e1 -> value (box e1 (ann (lam wh e) (arr (rcd l A) B)))
  | vfclos : forall e1 e A B, value e1 -> value (box e1 (ann (fixp A e) B)).

Inductive genv : typ -> exp -> Prop :=
  | genv_top : genv top unit
  | genv_arr : forall A B v,
      genv B v ->
      genv (arr A B) (box unit (ann (lam bl v) (arr A B)))
  | genv_and : forall A B v1 v2, genv A v1 -> genv B v2 -> genv (and A B) (merge v1 v2)
  | genv_rcd : forall A l v, genv A v -> genv (rcd l A) (rec l v).

Inductive ord : typ -> Prop :=
  | O_int :
      ord int
  | O_arrow : forall A B,
      ord (arr A B)
  | O_rcd : forall x B,
      ord (rcd x B).

Inductive toplike : typ -> Prop :=
  | TL_top :
      toplike top
  | TL_and : forall A B,
      toplike A ->
      toplike B ->
      toplike (and A B)
  | TL_arr : forall (A B:typ),
      toplike B ->
      toplike (arr A B)
  | TL_rcd : forall x (B:typ),
      toplike B ->
      toplike (rcd x B).

Inductive ext : typ -> fmode -> typ -> Prop :=
  | ext_bl: forall A, ext A bl A
  | ext_wh: forall x A, ext (rcd x A) wh A.

Inductive casting : exp -> typ -> exp -> Prop :=
  | cast_top  : forall v, casting v top unit
  | cast_int  : forall i, casting (lit i) int (lit i)
  | cast_mrgl : forall v1 v2 A v1',
      casting v1 A v1' ->
      ord A ->
      casting (merge v1 v2) A v1'
  | cast_mrgr : forall v1 v2 A v2',
      casting v2 A v2' ->
      ord A ->
      casting (merge v1 v2) A v2'
  | cast_and : forall v v1 v2 A B,
      casting v A v1 ->
      casting v B v2 ->
      casting v (and A B) (merge v1 v2)
  | cast_rcd : forall v A v' x,
      casting v A v' ->
      casting (rec x v) (rcd x A) (rec x v')
  | cast_arr : forall e v A B C D A' fm,
      value v ->
      ~ toplike D ->
      ext A fm A' ->
      sub C A' ->
      sub B D ->
      casting (box v (ann (lam fm e) (arr A B))) (arr C D) (box v (ann (lam fm e) (arr A D)))
  | cast_arr_tl : forall e v A B C D v' fm A',
      value v ->
      toplike D ->
      ext A fm A' ->
      sub C A' ->
      sub B D ->
      genv (arr C D) v' ->
      casting (box v (ann (lam fm e) (arr A B))) (arr C D) v'
  | cast_fix : forall A B C e v,
      value v ->
      sub B C ->
      ~ toplike C ->
      ord C ->
      casting (box v (ann (fixp A e) B)) C (box v (ann (fixp A e) C))
  | cast_fix_tl: forall A B C e v v',
      value v ->
      sub B C ->
      toplike C ->
      ord C ->
      genv C v' ->
      casting (box v (ann (fixp A e) B)) C v'.

Definition consistencySpec v1 v2 :=
  forall A v1' v2', casting v1 A v1' -> casting v2 A v2' -> v1' = v2'.

Inductive has_type : typ -> exp -> mode -> typ -> Prop :=
  | tlit : forall G i, has_type G (lit i) inf int
  | tunit : forall G, has_type G unit inf top
  | tctx : forall G, has_type G ctx inf G
  | tmrg : forall G e1 e2 A B,
      has_type G e1 inf A ->
      has_type (and G A) e2 inf B ->
      disjoint A B ->
      disjoint G A ->
      has_type G (merge e1 e2) inf (and A B)
  | tcon : forall G v1 v2 A B,
      has_type G v1 inf A ->
      has_type G v2 inf B ->
      value v1 ->
      value v2 ->
      consistencySpec v1 v2->
      has_type G (merge v1 v2) inf (and A B)
  | tann : forall G e A,
      has_type G e chk A ->
      has_type G (ann e A) inf A
  | tlam : forall A e B G C fm A',
      disjoint G A ->
      ext A fm A' ->
      sub C A' ->
      has_type (and G A) e chk B ->
      has_type G (ann (lam fm e) (arr A B)) inf (arr C B)
  | tfixp : forall G A e,
      disjoint G A ->
      has_type (and G A) e chk A ->
      has_type G (fixp A e) inf A
  | tapp : forall G e1 e2 A B,
      has_type G e1 inf (arr A B) ->
      has_type G e2 chk A ->
      has_type G (app e1 e2) inf B
  | tbox : forall e1 e2 A B G,
      has_type G e1 inf B ->
      has_type B e2 inf A ->
      has_type G (box e1 e2) inf A
  | tsub : forall G e A B,
      has_type G e inf A ->
      sub A B ->
      has_type G e chk B
  | trec : forall G e x A,
      has_type G e inf A ->
      has_type G (rec x e) inf (rcd x A)
  | tproj : forall G e x A,
      has_type G e inf (rcd x A) ->
      has_type G (proj e x) inf A.

Inductive constr : typ -> exp -> fmode -> exp -> Prop :=
  | constr_bl: forall A v, constr A v bl v
  | constr_wh: forall x A v, constr (rcd x A) v wh (rec x v).

Inductive step : exp -> exp -> exp -> Prop :=
  | step_ctx : forall v, value v -> step v ctx v
  | step_annv : forall v v1 A v1', value v -> casting v1 A v1' -> value v1 -> step v (ann v1 A) v1'
  | step_anne : forall v e e' A, step v e e' -> step v (ann e A) (ann e' A)
  | step_mrgr : forall v e e' v1, step (merge v v1)  e e' -> value v1 -> step v (merge v1 e) (merge v1 e')
  | step_mrgl : forall v e1 e1' e2, step v e1 e1' -> step v (merge e1 e2) (merge e1' e2)
  | step_rcde : forall v e' e x, step v e e' -> step v (rec x e) (rec x e')
  | step_projv : forall v v1 x, value v -> value v1 -> step v (proj (rec x v1) x) v1
  | step_proje : forall v e' e x, step v e e' -> step v (proj e x) (proj e' x)
  | step_switch : forall v e A B fm,
      value v ->
      step v (ann (lam fm e) (arr A B)) (box v (ann (lam fm e) (arr A B)))
  | step_beta : forall v v1 A B v1' e v2 A' fm v3,
      ext A fm A' ->
      casting v1 A' v1' ->
      value v ->
      value v1 ->
      value v2 ->
      constr A v1' fm v3 ->
      step v (app (box v2 (ann (lam fm e) (arr A B))) v1) (box (merge v2 v3) (ann e B))
  | step_fixp: forall v e  A,
      value v ->
      step v (fixp A e) (box v (ann (fixp A e) A))
  | step_fixbt: forall v v1 A B C v2 e,
      value v ->
      value v1 ->
      value v2 ->
      step v (app (box v2 (ann (fixp C e) (arr A B))) v1) (box (merge v2 (box v2 (ann (fixp C e) C))) (app (ann e (arr A B)) v1))
  | step_fixrc: forall v B C v2 e l,
      value v ->
      value v2 ->
      step v (proj (box v2 (ann (fixp C e) (rcd l B))) l) (box (merge v2 (box v2 (ann (fixp C e) C))) (proj (ann e (rcd l B)) l))
  | step_appl : forall v e1 e1' e2, step v e1 e1' -> step v (app e1 e2) (app e1' e2)
  | step_appr : forall v v1 e2 e2', step v e2 e2' -> value v1 -> step v (app v1 e2) (app v1 e2')
  | step_boxv : forall v v1 v2, value v -> value v1 -> value v2 -> step v (box v1 v2) v2
  | step_boxe : forall e e' v v1,
      step v1 e e' ->
      value v ->
      ~ value (box v1 e) ->
      step v (box v1 e) (box v1 e')
  | step_boxc : forall e1 e2 v e,
      step v e1 e2 ->
      value v ->
      step v (box e1 e) (box e2 e).

#[export]
Hint Constructors typ mode exp sub gord value genv ord toplike casting has_type step fmode ext constr: core.


(**********************************************************************)
(* Copyright 2020 Barry Jay                                           *)
(*                                                                    *)
(* Permission is hereby granted, free of charge, to any person        *)
(* obtaining a copy of this software and associated documentation     *)
(* files (the "Software"), to deal in the Software without            *)
(* restriction, including without limitation the rights to use, copy, *)
(* modify, merge, publish, distribute, sublicense, and/or sell copies *)
(* of the Software, and to permit persons to whom the Software is     *)
(* furnished to do so, subject to the following conditions:           *)
(*                                                                    *)
(* The above copyright notice and this permission notice shall be     *)
(* included in all copies or substantial portions of the Software.    *)
(*                                                                    *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,    *)
(* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF *)
(* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND              *)
(* NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT        *)
(* HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,       *)
(* WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, *)
(* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER      *)
(* DEALINGS IN THE SOFTWARE.                                          *)
(**********************************************************************)

(**********************************************************************)
(*              Reflective Programs in Tree Calculus                  *)
(*                  Chapter 3: Tree Calculus                          *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import String Lia.

Set Default Proof Using "Type".

Ltac caseEq f := generalize (refl_equal f); pattern f at -1; case f.
Ltac auto_t:= eauto with TreeHintDb.

Open Scope string_scope.
Declare Scope tree_scope.
Open Scope tree_scope.

(* Section 3.3 Tree Calculus *)

(* The type Tree0 supports inductive definitions *)
Inductive Tree0:  Set :=
  | Ref : string -> Tree0  (* variables are indexed by strings *)
  | Node : Tree0
  | App : Tree0 -> Tree0 -> Tree0
.

Hint Constructors Tree0 : TreeHintDb.

Notation "△" := Node : tree_scope.
Notation "x @ y" := (App x y) (at level 65, left associativity) : tree_scope.

Definition K := △ @ △.
Definition I := △ @ (△ @ △) @ (△ @ △).
Definition KI := K@I.
Definition D := △ @ (△ @ △) @ (△ @ △ @ △).
Definition d x := △ @ (△@x).
Definition Sop := d (K @ D)@(d K @(K@D)).

Ltac inv1 prop :=
match goal with
| H: prop (Ref _) |- _ => inversion H; clear H; inv1 prop
| H: prop (_ @ _) |- _ => inversion H; clear H; inv1 prop
| H: prop △ |- _ => inversion H; clear H; inv1 prop
| _ => auto
 end.

(* Equational Theory *)

(* The type Tree is axiomatic, so no inductive definitions ... *)
Axiom Tree: Set.
Axiom Req : string -> Tree.
Axiom Noq : Tree.
Axiom Apq : Tree -> Tree -> Tree.

(* The two types are related by quotienting *)
Fixpoint quotient M :=
  match M with
  | Ref x => Req x
  | Node => Noq
  | M1 @ M2 => Apq (quotient M1) (quotient M2)
  end.

Definition eq_q x y := quotient x = quotient y.

Notation "x === y" := (eq_q x y) (at level 85) : tree_scope.

(* ... but it does support axioms for equational reasoning *)
Axiom k_eq : forall y z, Apq (Apq (Apq Noq Noq) y) z = y.
Axiom s_eq : forall x y z, Apq (Apq (Apq Noq (Apq Noq x)) y) z = Apq (Apq y z) (Apq x z).
Axiom f_eq : forall w x y z, Apq (Apq (Apq Noq (Apq (Apq Noq w) x)) y) z = Apq (Apq z w) x.

Hint Resolve Req Noq Apq k_eq s_eq f_eq : TreeHintDb.

Ltac ktac := rewrite ? k_eq.
Ltac stac := rewrite ? k_eq.
Ltac ftac := rewrite ? k_eq.

Ltac tree_eq := intros; cbv; repeat (rewrite ? s_eq; rewrite ? k_eq; rewrite ? f_eq); auto.

Lemma quotient_node: quotient Node = Noq.
  Proof. auto_t. Qed.

Lemma quotient_app: forall M1 M2, quotient (M1 @ M2) = Apq (quotient M1) (quotient M2).
Proof. auto_t. Qed.

Lemma eq_q_refl: forall x, x===x.
Proof. unfold eq_q; auto. Qed.

Lemma eq_q_sym: forall x y, x=== y -> y ===x.
Proof. unfold eq_q; auto. Qed.

Lemma eq_q_trans: forall x y z, x===y -> y===z -> x === z.
Proof.  unfold eq_q; intros; eapply eq_trans; eauto. Qed.

Ltac f_equal_q := rewrite quotient_app; apply eq_sym; rewrite quotient_app; apply eq_sym; f_equal.

Ltac unquotient_tac := repeat rewrite <- quotient_node; repeat rewrite <- quotient_app.

Ltac qtac e :=
  unfold eq_q; repeat ((rewrite e || auto_t) || rewrite quotient_app);
  rewrite ? quotient_node;
  repeat (rewrite ? s_eq || rewrite ? k_eq || rewrite ? f_eq); unquotient_tac; auto_t.

(* Section 3.4: Programs *)

Inductive program : Tree0 -> Prop :=
| pr_leaf : program △
| pr_stem : forall M, program M -> program (△ @ M)
| pr_fork : forall M N, program M -> program N -> program (△ @ M @ N)
.

Ltac program_tac := cbv; repeat (apply pr_fork || apply pr_stem || apply pr_leaf); auto.

(* Section 3.5: Propositional Logic *)

(* Booleans *)

Definition conjunction := d (K@KI).
Definition disjunction := d (K@K) @I.
Definition implies := d (K@K).
Definition negation := d (K@K) @ (d (K@KI) @ I).
Definition bi_implies := △@ (△@ I @ negation)@△.

Lemma conjunction_true : forall y, conjunction @ K @ y === y.
Proof.  tree_eq. Qed.

(* Section 3.6: Pairs *)

Definition Pair := △ .
Definition first p :=  △@ p@ △@ K.
Definition second p := △ @p@ △@ KI.

Lemma first_pair : forall x y, (first (Pair @x@y)) === x.
Proof.   tree_eq. Qed.

Lemma second_pair : forall x y, second (Pair @x@y) === y .
Proof.  tree_eq. Qed.

(* 3.7: Natural Numbers *)

Definition zero := △.
Definition successor := K.

Definition isZero := d (K@ (K@ (K@ KI))) @ (d (K@ K) @ △).

Definition predecessor := d (K@ KI) @ (d (K@ △) @  △).

Lemma isZero_zero : isZero @ △ === K.
Proof.  tree_eq. Qed.

Lemma isZero_successor : forall n, isZero @ (K@ n) === KI.
Proof.  tree_eq. Qed.

(* Section 3.8: The Fundamental Queries *)

Definition query is0 is1 is2 :=
  d (K@is1)
   @(d (K@KI)
      @(d (K@ (K@ (K@(K@(K@ is2)))))
         @(d (K@(K@(K@ is0)))@△))).

Definition isLeaf := query K (K @ I) (K @ I).
Definition isStem := query (K @ I) K KI.
Definition isFork := query KI KI K.

Lemma query_eq_0:
  forall is0 is1 is2, query is0 is1 is2 @  △ === is0.
Proof.   tree_eq. Qed.

Lemma query_eq_1:
  forall is0 is1 is2 P,  query is0 is1 is2 @ (△ @ P) === is0 @ KI @ is1.
Proof. tree_eq.  Qed.

Lemma query_eq_2:
  forall is0 is1 is2 P Q,  query is0 is1 is2 @ (△@ P@ Q) === is2.
Proof. tree_eq. Qed.

Ltac unfold_op := unfold isLeaf, isStem, isFork, query, Sop, D, KI, I, K, d, first, second.
Ltac eqtac := unfold_op; qtac s_eq; auto_t.
(*
  repeat (unfold quotient; fold quotient; rewrite ? s_eq; rewrite ? k_eq; rewrite ? f_eq).
 *)

Fixpoint term_size M :=
  match M with
  | App M1 M2 => term_size M1 + term_size M2
  |  _ => 1
  end.

(* Exercises *)

(* 1 *)

Definition D_variant := Sop @ (K@(Sop @ Sop)) @ K.

Lemma d_variant_eval: forall x y z, D_variant @ x @ y @ z === y@ z @ (x @ z).
Proof. tree_eq. Qed.

(* 2 *)
Lemma conjunction_false: forall y, conjunction @ KI @ y === K@I.
Proof.  tree_eq. Qed.

(* 3 *)
Lemma disjunction_true : forall y, disjunction @ K @y === K.
Proof.  tree_eq. Qed.

Lemma disjunction_false: forall y, disjunction @ KI @y === y.
Proof.  tree_eq. Qed.

Lemma implies_true : forall y, implies @ K @ y === y.
Proof.  tree_eq. Qed.

Lemma implies_false: forall y, implies @ KI @ y === K.
Proof.  tree_eq. Qed.

Lemma negation_true : negation @ K === KI.
Proof.  tree_eq. Qed.

Lemma negation_false : negation @ (K@I) === K.
Proof.  tree_eq. Qed.

Lemma iff_true : forall y, bi_implies @K@y === y.
Proof.  tree_eq. Qed.

Lemma iff_false_true : bi_implies @ KI @K === K@I.
Proof.  tree_eq. Qed.

Lemma iff_false_false : bi_implies @ KI @ KI === K.
Proof.  tree_eq. Qed.

(* 4 *)
Definition first0 := d (K@K) @ (d (K@ △) @ △).
Definition second0 := d (K@(K@I)) @ (d (K@ △) @ △).

Lemma first0_first: forall p, first0 @ p === (first p).
Proof.  tree_eq. Qed.

Lemma second0_second: forall p, second0 @ p === (second p).
Proof.  tree_eq. Qed.

(* 5 *)

Lemma predecessor_zero: predecessor @ △ === △.
Proof.  tree_eq. Qed.

Lemma predecessor_successor : forall n, predecessor @ (K@ n) === n.
Proof.  tree_eq. Qed.

(* 6 *)

Definition successor_variant := △.
Definition isZero_variant := d (K @ KI) @ (d (K@K) @ △).

Definition predecessor_variant :=
 d (K@K)
   @ (d (K@ (K@(K@ △)))
        @ (d (d (K@ △) @ I) @ (K@△))
     ).

Lemma predecessor_variant_zero: predecessor_variant @ △ === △.
Proof.  tree_eq. Qed.

Lemma predecessor_successor_variant : forall n, predecessor_variant @ (successor_variant @ n) === n.
Proof.  tree_eq. Qed.

Lemma isZero_variant_Zero : isZero_variant @ zero === K.
Proof. tree_eq. Qed.

Lemma isZero_variant_successor : forall n, isZero_variant @ (successor_variant @ n) === KI.
Proof. tree_eq. Qed.

(* 7 *)

Lemma isLeaf_node: isLeaf @ △ === K.
Proof.  tree_eq. Qed.

Lemma isLeaf_K: isLeaf @ K === KI.
Proof.  tree_eq. Qed.

Lemma isLeaf_Knode: isLeaf @ (K@△) === KI.
Proof.  tree_eq. Qed.

(* 8 *)

Fixpoint maxdepth n :=
  match n with
    0 => 0
  | S k => (1 + maxdepth k + maxdepth k * maxdepth k) (* count leaves, stems and forks *)
  end.

(*
Compute (maxdepth 3 = 13).
Compute (maxdepth 4 = 183).
Compute (maxdepth 5 = 33673).
*)

Definition exactdepth n :=
  match n with
  | 0 => 0
  | S k => (maxdepth (S k) - (maxdepth k))
  end.

(*
Compute (exactdepth 3 = 10%Z).
Compute (exactdepth 4 = 170%Z).
Compute (exactdepth 5 = 33490%Z).
*)


(* PUBLIC DOMAIN *)
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
Require Import Logic.FunctionalExtensionality.
Require Import Coq.Program.Wf.
Require Import Lia.
Add LoadPath "/home/user/0data/COQ/SHEN/".
Require Export ListForallT.

Definition SetVars  := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.
Record PSV := MPSV{
 ps : PredSymb;
 psv : nat;
}.

Section All.
  Variable T : Type.
  Variable P : T -> Prop.

  Fixpoint All (ls : list T) : Prop :=
    match ls with
      | nil => True
      | cons h t => P h /\ All t
    end.
End All.

Unset Elimination Schemes.
Inductive preTerms : Type :=
| FVC :> SetVars -> preTerms
| FSC (f:FSV) : list preTerms -> preTerms.
Set Elimination Schemes.

Section preTerms_ind'.
  Variable P : preTerms -> Prop.

Section preTerms_ind'.
  Variable P : preTerms -> Prop.
  Variable Q : FSV -> list preTerms -> Prop.
  Hypothesis preTerms_case1 : forall (sv : SetVars), P (FVC sv).

  Hypothesis preTerms_case2 : forall (f : FSV) (ls : list preTerms),
    ((Q f ls)/\(All preTerms P ls)) -> P (FSC f ls).

  Fixpoint preTerms_ind (tr : preTerms) : P tr.
  Proof.
  destruct tr.
  exact (preTerms_case1 _).
  apply preTerms_case2.
  revert l; fix G 1; intro l.
  split.

  destruct l;simpl;trivial.
  split.
  apply preTerms_ind.
  apply G.
  Defined.
End preTerms_ind'.