Require Import Bool Arith List CpdtTactics SfLib LibTactics.
Require Import Coq.Program.Equality.

Set Implicit Arguments.

Require Import Identifier Environment Imperative WellFormedness LowEq Types.

(* Non-interference for expressions *)
Theorem ni_exp: forall Γ m1 m2 e u v ℓ,
  {{ Γ ⊢ e : ℓ }} ->
  state_low_eq Γ m1 m2 ->
  eval e m1 u ->
  eval e m2 v ->
  val_low_eq ℓ u v.
Proof.
  intros.
  generalize dependent v.
  generalize dependent u.
  exp_has_level_cases(induction H) Case.
  Case "T_Const".
    intros.
    assert (u = n) as Hu.
    apply eval_const_aux with m1; assumption.
    assert (v = n) as Hv.
    apply eval_const_aux with m2; assumption.
    crush.
    induction ℓ ;[ apply VLEqL | apply VLEqH]; crush.
  Case "T_Id".
    intros.
    apply vars_low_eq with Γ m1 m2 x;
      repeat (try assumption; apply eval_var_aux).
  Case "T_Plus".
    intros.
    level_cases (induction ℓ) SCase; [ | apply VLEqH]; crush.
    inversion H2.
    inversion H3.
    crush.

    Ltac lleq a b :=
      assert (val_low_eq Low a b); auto.

    lleq u0 u1.
    lleq v0 v1.

    assert (u0 = u1); inversion H6 ; inversion H7; auto.
    apply VLEqL. auto.
  Case "T_Sub".
    intros.
    induction ℓ'; [ | apply VLEqH]; crush.
    assert (ℓ = Low).
    inversion H1; auto.
    rewrite H5 in H4.
    apply H4; crush.
Qed.


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

Require Import List.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import finite.

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

From Undecidability.TRAKHTENBROT
  Require Import notations utils decidable fol_ops fo_sig fo_terms fo_logic.

Set Default Proof Using "Type".

Set Implicit Arguments.

Local Notation ø := vec_nil.

(* * Definition of first order satisfiability *)

Section satisfiability.

  Variable (Σ : fo_signature) (e : rels Σ) (E : ar_rels Σ e = 2) (A : fol_form Σ).

  (* A first order formula over signature Σ is finitely satisfiable over
      type X if there exists a model M interpreting the signature Σ over type X
      which is both finite (strongly listable) and strongly decidable,
      and a valuation φ : nat -> X in which A is satisfied *)

  Definition fo_form_fin_SAT_in X :=
    exists (M : fo_model Σ X)
           (_ : finite_t X)
           (φ : nat -> X),
           fol_sem M φ A.

  Definition fo_form_fin_dec_SAT_in X :=
    exists (M : fo_model Σ X)
           (_ : finite_t X)
           (_ : fo_model_dec M)
           (φ : nat -> X),
           fol_sem M φ A.

  Definition fo_form_fin_dec_eq_SAT_in X :=
    exists (M : fo_model Σ X)
           (_ : finite_t X)
           (_ : fo_model_dec M)
           (_ : forall x y, fom_rels M e (cast (x##y##ø) (eq_sym E)) <-> x = y)
           (φ : nat -> X),
           fol_sem M φ A.

  Definition fo_form_fin_discr_dec_SAT_in X :=
    exists (_ : discrete X),
           fo_form_fin_dec_SAT_in X.

  Definition fo_form_fin_SAT := ex fo_form_fin_SAT_in.
  Definition fo_form_fin_dec_SAT := ex fo_form_fin_dec_SAT_in.
  Definition fo_form_fin_dec_eq_SAT := ex fo_form_fin_dec_eq_SAT_in.
  Definition fo_form_fin_discr_dec_SAT := ex fo_form_fin_discr_dec_SAT_in.

  Fact fo_form_fin_discr_dec_SAT_fin_dec : fo_form_fin_discr_dec_SAT -> fo_form_fin_dec_SAT.
  Proof. intros (X & _ & ?); exists X; trivial. Qed.

  Fact fo_form_fin_dec_SAT_fin : fo_form_fin_dec_SAT -> fo_form_fin_SAT.
  Proof. intros (X & M & H & _ & ?); exists X, M, H; trivial. Qed.

End satisfiability.

Definition FSAT := @fo_form_fin_dec_SAT.
Definition FSATEQ := @fo_form_fin_dec_eq_SAT.
Definition FSAT' := @fo_form_fin_discr_dec_SAT.

Arguments FSAT : clear implicits.
Arguments FSAT' : clear implicits.


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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.
Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem append_rev_cons:
   forall (l1 l2: lst) (x: natural),
   rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
   induction l1; induction l2; try (simpl; reflexivity).
   { intro. simpl. rewrite IHl1. simpl. lfind. Admitted.


Require Export prosa.util.notation prosa.util.nat prosa.util.list.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Additional lemmas about max. *)
Section ExtraLemmas.

  Lemma leq_bigmax_cond_seq (T : eqType) (P : pred T) (r : seq T) F i0 :
    i0 \in r -> P i0 -> F i0 <= \max_(i <- r | P i) F i.
  Proof.
    intros IN0 Pi0; by rewrite (big_rem i0) //= Pi0 leq_maxl.
  Qed.

  Lemma bigmax_sup_seq:
    forall (T: eqType) (i: T) r (P: pred T) m F,
      i \in r -> P i -> m <= F i -> m <= \max_(i <- r| P i) F i.
  Proof.
    intros.
    induction r.
    - by rewrite in_nil  in H.
      move: H; rewrite in_cons; move => /orP [/eqP EQA | IN].
      {
        clear IHr; subst a.
        rewrite (big_rem i) //=; last by rewrite in_cons; apply/orP; left.
        apply leq_trans with (F i); first by done.
          by rewrite H0 leq_maxl.
      }
      {
        apply leq_trans with (\max_(i0 <- r | P i0) F i0); first by apply IHr.
        rewrite [in X in _ <= X](big_rem a) //=; last by rewrite in_cons; apply/orP; left.

        have Ob: a == a; first by done.
          by rewrite Ob leq_maxr.
      }
  Qed.

  Lemma bigmax_leq_seqP (T : eqType) (P : pred T) (r : seq T) F m :
    reflect (forall i, i \in r -> P i -> F i <= m)
            (\max_(i <- r | P i) F i <= m).
  Proof.
    apply: (iffP idP) => leFm => [i IINR Pi|];
      first by apply: leq_trans leFm; apply leq_bigmax_cond_seq.
    rewrite big_seq_cond; elim/big_ind: _ => // m1 m2.
      by intros; rewrite geq_max; apply/andP; split.
      by move: m2 => /andP [M1IN Pm1]; apply: leFm.
  Qed.

  Lemma leq_big_max (T : eqType) (P : pred T) (r : seq T) F1 F2 :
    (forall i, i \in r -> P i -> F1 i <= F2 i) ->
    \max_(i <- r | P i) F1 i <= \max_(i <- r | P i) F2 i.
  Proof.
    intros; apply /bigmax_leq_seqP; intros.
    specialize (H i); feed_n 2 H; try(done).
    rewrite (big_rem i) //=; rewrite H1.
      by apply leq_trans with (F2 i); [ | rewrite leq_maxl].
  Qed.

  Lemma bigmax_ord_ltn_identity n :
    n > 0 ->
    \max_(i < n) i < n.
  Proof.
    intros LT.
    destruct n; first by rewrite ltn0 in LT.
    clear LT.
    induction n; first by rewrite big_ord_recr /= big_ord0 maxn0.
    rewrite big_ord_recr /=.
      by unfold maxn at 1; rewrite IHn.
  Qed.

  Lemma bigmax_ltn_ord n (P : pred nat) (i0: 'I_n) :
    P i0 ->
    \max_(i < n | P i) i < n.
  Proof.
    intros LT.
    destruct n; first by destruct i0 as [i0 P0]; move: (P0) => P0'; rewrite ltn0 in P0'.
    rewrite big_mkcond.
    apply leq_ltn_trans with (n := \max_(i < n.+1) i).
    {
      apply/bigmax_leqP; ins.
      destruct (P i); last by done.
      by apply leq_bigmax_cond.
    }
    by apply bigmax_ord_ltn_identity.
  Qed.

  Lemma bigmax_pred n (P : pred nat) (i0: 'I_n) :
    P (i0) ->
    P (\max_(i < n | P i) i).
  Proof.
    intros PRED.
    induction n.
    {
      destruct i0 as [i0 P0].
      by move: (P0) => P1; rewrite ltn0 in P1.
    }
    rewrite big_mkcond big_ord_recr /=. destruct (P n) eqn:Pn.
    {
      destruct n; first by rewrite big_ord0 maxn0.
      unfold maxn at 1.
      destruct (\max_(i < n.+1) (match P (@nat_of_ord (S n) i) return nat with
                    | true => @nat_of_ord (S n) i
                    | false => O
                                 end) < n.+1) eqn:Pi; first by rewrite Pi.
      exfalso.
      apply negbT in Pi; move: Pi => /negP BUG.
      apply BUG.
      apply leq_ltn_trans with (n := \max_(i < n.+1) i).
      {
        apply/bigmax_leqP; ins.
        destruct (P i); last by done.
        by apply leq_bigmax_cond.
      }
      by apply bigmax_ord_ltn_identity.
    }
    {
      rewrite maxn0.
      rewrite -big_mkcond /=.
      have LT: i0 < n.
      {
        rewrite ltn_neqAle; apply/andP; split;
          last by rewrite -ltnS; apply ltn_ord.
        apply/negP; move => /eqP BUG.
        by rewrite -BUG PRED in Pn.
      }
      by rewrite (IHn (Ordinal LT)).
    }
  Qed.

End ExtraLemmas.


Require Import List.
Import ListNotations.

Set Implicit Arguments.

Section list_util.
  Variables A : Type.

  Lemma list_neq_cons :
    forall (l : list A) x,
      x :: l <> l.
  Proof using.
    intuition.
    symmetry in H.
    induction l;
      now inversion H.
  Qed.
End list_util.


From Equations Require Import Equations.
Require Import Examples.Fin.
Require Import Relations Utf8.
Require Import Relations Wellfounded.
Require Import Setoid RelationClasses Morphisms.
Require Import Lia.
Require Import Bool.
Require Import List Arith String.
From Coq Require Import FunctionalExtensionality.

Set Equations Transparent.
Set Keyed Unification.
Set Asymmetric Patterns.

Section Equality.
  Class Eq (A : Type) :=
    { eqb : A -> A -> bool;
      eqb_spec : forall x y, reflect (x = y) (eqb x y) }.

  Equations fin_eq {k} (f f' : fin k) : bool :=
  fin_eq fz fz => true;
  fin_eq (fs f) (fs f') => fin_eq f f';
  fin_eq _ _ => false.

  Global Instance fin_Eq k : Eq (fin k).
  Proof.
    exists fin_eq. intros x y. induction x; depelim y; simp fin_eq; try constructor; auto.
    intro H; noconf H.
    intro H; noconf H.
    destruct (IHx y). subst x; now constructor. constructor. intro H; noconf H. now apply n0.
  Defined.

  Global Instance bool_Eq : Eq bool.
  Proof.
    exists bool_eq. intros [] []; now constructor.
  Defined.

  Global Instance prod_eq A B : Eq A -> Eq B -> Eq (A * B).
  Proof.
    intros. exists (fun '(x, y) '(x', y') => eqb x x' && eqb y y').
    intros [] []. destruct (eqb_spec a a0); subst.
    destruct (eqb_spec b b0); subst. constructor; auto.
    constructor; auto. intro H; noconf H. now elim n.
    constructor; auto. simplify *. now elim n.
  Defined.

  Equations option_eq {A : Type} {E:Eq A} (o o' : option A) : bool :=
    option_eq None None := true;
    option_eq (Some o) (Some o') := eqb o o';
    option_eq _ _ := false.

  Global Instance option_Eq A : Eq A -> Eq (option A).
  Proof.
    intros A_Eq. exists option_eq. intros [] []; simp option_eq; try constructor.
    destruct (eqb_spec a a0); subst. now constructor.
    constructor. intro H; noconf H. now elim n.
    simplify *. simplify *. constructor.
  Defined.

  Section EqFin_fn.
    Context {A} `{Eq A}.

    Equations eq_fin_fn {k} (f g : fin k -> A) : bool :=
    eq_fin_fn (k:=0) f g := true;
    eq_fin_fn (k:=S k) f g := eqb (f fz) (g fz) && eq_fin_fn (fun n => f (fs n)) (fun n => g (fs n)).

    Global Instance Eq_graph k : Eq (fin k -> A).
    Proof.
      exists eq_fin_fn. induction k; intros; simp eq_fin_fn. constructor; auto.
      extensionality i. depelim i.
      destruct (eqb_spec (x fz) (y fz)). simpl. destruct (IHk (fun n => x (fs n)) (fun n => y (fs n))).
      constructor; auto. extensionality n. depelim n. auto. eapply equal_f in e0. eauto. constructor.
      intro H'. subst. elim n. extensionality n'. reflexivity.
      simpl. constructor. intros H'; elim n. subst. reflexivity.
    Defined.
  End EqFin_fn.
End Equality.

Definition dec_rel {X:Type} (R : X → X → Prop) := ∀ x y, {R x y} + {not (R x y)}.

Section AlmostFull.
  Context {X : Type}.

  Inductive WFT : Type :=
  | ZT : WFT
  | SUP : (X -> WFT) -> WFT.
  Derive NoConfusion Subterm for WFT.

  Definition sec_disj (R : X -> X -> Prop) x y z := R y z \/ R x y.

  Fixpoint SecureBy (R : X -> X -> Prop) (p : WFT) : Prop :=
    match p with
    | ZT => forall x y, R x y
    | SUP f => forall x, SecureBy (fun y z => R y z \/ R x y) (f x)
    end.

  Lemma SecureBy_mon p (R' S : X -> X -> Prop) (H : forall x y, R' x y -> S x y) :
    SecureBy R' p -> SecureBy S p.
  Proof.
    revert R' S H.
    induction p. simpl. intros. apply H. apply H0.
    simpl. intros.
    eapply H. 2:apply H1.
    intros. simpl in H2. intuition.
  Defined.

  Definition almost_full (R : X -> X -> Prop) := exists p, SecureBy R p.

  Context (R : X -> X -> Prop) (decR : dec_rel R).

  Fixpoint af_tree_iter {x : X} (accX : Acc R x) :=
    match accX with
    | Acc_intro f => SUP (fun y =>
                            match decR y x with
                            | left Ry => af_tree_iter (f y Ry)
                            | right _ => ZT
                            end)
    end.

  Context (wfR : well_founded R).
  Definition af_tree : X → WFT :=
    fun x => af_tree_iter (wfR x).

  Scheme Acc_ind_dep := Induction for Acc Sort Prop.

  Lemma secure_from_wf : SecureBy (fun x y => not (R y x)) (SUP af_tree).
  Proof.
    intro x. unfold af_tree. generalize (wfR x).
    induction a using Acc_ind_dep. simpl.
    intros y. destruct (decR y x). simpl.
    eapply SecureBy_mon; eauto. simpl; intros.
    intuition. simpl. intros. intuition auto.
  Defined.

  Corollary af_from_wf : almost_full (fun x y => not (R y x)).
  Proof. exists (SUP af_tree). apply secure_from_wf. Defined.

End AlmostFull.

Class AlmostFull {X} (R : X -> X -> Prop) :=
  is_almost_full : almost_full R.

#[export] Instance proper_af X : Proper (relation_equivalence ==> iff) (@AlmostFull X).
Proof.
  intros R S eqRS.
  split; intros.
  destruct H as [p Hp]. exists p.
  revert R S eqRS Hp. induction p; simpl in *; intros. now apply eqRS.
  apply (H x (fun y z => R y z \/ R x y)). repeat red; intuition.
  apply Hp.

  destruct H as [p Hp]. exists p.
  revert R S eqRS Hp. induction p; simpl in *; intros. now apply eqRS.
  apply (H x _ (fun y z => S y z \/ S x y)). repeat red; intuition.
  apply Hp.
Qed.
Arguments WFT _ : clear implicits.

#[export] Instance almost_full_le : AlmostFull Peano.le.
Proof.
  assert (relation_equivalence Peano.le (fun x y => ~ (y < x))) as ->.
  { cbn. intros x y. intuition auto. red in H0. lia. lia. }
  red. eapply af_from_wf. 2:apply lt_wf.
  intros x y. apply lt_dec.
Defined.

Arguments WFT X : clear implicits.

Section WfFromAF.
  Context {X : Type}.

  Lemma clos_trans_n1_left {R : X -> X -> Prop} x y z : R x y -> clos_trans_n1 _ R y z -> clos_trans_n1 _ R x z.
  Proof.
    induction 2. econstructor 2; eauto. constructor; auto.
    econstructor 2. eauto. auto.
  Defined.

  Lemma clos_trans_1n_n1 {R : X -> X -> Prop} x y : clos_trans_1n _ R x y -> clos_trans_n1 _ R x y.
  Proof.
    induction 1. now constructor. eapply clos_trans_n1_left; eauto.
  Defined.

  Lemma clos_refl_trans_right {R : X -> X -> Prop} x y z :
    R y z -> clos_refl_trans _ R x y -> clos_trans_n1 _ R x z.
  Proof.
    intros Ryz Rxy. apply clos_rt_rtn1_iff in Rxy.
    induction Rxy in Ryz, z |- *. econstructor 1; eauto. econstructor 2; eauto.
  Defined.

  Lemma clos_trans_1n_right {R : X -> X -> Prop} x y z : R y z -> clos_trans_1n _ R x y -> clos_trans_1n _ R x z.
  Proof.
    induction 2. econstructor 2; eauto. constructor; auto.
    econstructor 2. eauto. auto.
  Defined.

  Lemma clos_trans_n1_1n {R : X -> X -> Prop} x y : clos_trans_n1 _ R x y -> clos_trans_1n _ R x y.
  Proof.
    induction 1. now constructor. eapply clos_trans_1n_right; eauto.
  Defined.

  Lemma acc_from_af (p : WFT X) (T R : X → X → Prop) y :
    (∀ x z, clos_refl_trans X T z y ->
            clos_trans_1n X T x z ∧ R z x → False)
    → SecureBy R p → Acc T y.
  Proof.
    induction p as [|p IHp] in T, R, y |- * .
    + simpl. intros. constructor.
      intros z Tz. specialize (H z y). elim H. constructor 2. split; auto.
      constructor. auto.
    + intros cond secure. constructor. intros z Tzy.
      simpl in secure.
      specialize (IHp y T (fun y0 z0 => R y0 z0 \/ R y y0) z). apply IHp; auto.
      intros x w wz.
      assert(wy: clos_refl_trans X T w y).
      { econstructor 3. eauto. now constructor. }
      pose proof (cond x w wy). intuition.
      specialize (cond w y). apply cond. constructor 2.
      intuition. apply clos_trans_n1_1n. eapply clos_refl_trans_right; eauto.
  Defined.

  Lemma wf_from_af (p : WFT X) (T R : X → X → Prop) :
    (∀ x y, clos_trans_1n X T x y ∧ R y x → False)
    → SecureBy R p → well_founded T.
  Proof.
    intros. intro x. eapply acc_from_af;eauto.
  Defined.

  Definition compose_rel {X} (R S : X -> X -> Prop) : relation X :=
    fun x y => exists z, R x z /\ S z y.

  Equations power (k : nat) (T : X -> X -> Prop) : X -> X -> Prop :=
    power 0 T := T;
    power (S k) T := fun x y => exists z, power k T x z /\ T z y.
  Transparent power.

  Lemma acc_incl (T T' : X -> X -> Prop) x : (forall x y, T' x y -> T x y) -> Acc T x -> Acc T' x.
  Proof.
    intros HT H; induction H in |- *.
    constructor. intros. apply HT in H1. now apply H0.
  Qed.

  Lemma power_clos_trans (T : X -> X -> Prop) k : inclusion _ (power k T) (clos_trans _ T).
  Proof.
    intros x y. induction k in x, y |- *. simpl. now constructor.
    simpl. intros [z [Pxz Tzy]]. econstructor 2. apply IHk; eauto. constructor. auto.
  Qed.

  Lemma clos_trans_power (T : X -> X -> Prop) x y : clos_trans _ T x y -> exists k, power k T x y.
  Proof.
    rewrite clos_trans_tn1_iff. induction 1. exists 0; auto.
    destruct IHclos_trans_n1 as [k pkyz]. exists (S k). simp power. now exists y.
  Qed.

  Lemma acc_power (T : X -> X -> Prop) x k : Acc T x -> Acc (power k T) x.
  Proof.
    intros. apply Acc_clos_trans in H. revert H.
    apply acc_incl. intros. now apply (power_clos_trans _ k).
  Qed.

  Equations secure_power (k : nat) (p : WFT X) : WFT X :=
    secure_power 0 p := p;
    secure_power (S k) p := SUP (fun x => secure_power k p).
  Transparent secure_power.
  Lemma secure_by_power R p (H : SecureBy R p) k :
    SecureBy R (secure_power k p).
  Proof.
    induction k in R, p, H |- *; trivial.
    induction p. simpl in *. intros. apply IHk. simpl. intuition.
    simpl. intros.
    apply IHk. simpl. intros. simpl in H0. simpl in H.
    specialize (H x0). eapply SecureBy_mon. 2:eauto. simpl. intuition.
  Qed.

  Lemma acc_from_power_af (p : WFT X) (T R : X → X → Prop) y k :
    (∀ x z, clos_refl_trans _ T z y ->
            clos_trans_1n X (power k T) x z ∧ R z x → False)
    → SecureBy R (secure_power k p) → Acc T y.
  Proof.
    (* induction k in T, R, y |- *. simpl. intros. simp secure_power in H0. eapply acc_from_af; eauto. admit. *)
    (* intros. *)
    (* simp secure_power in H0. simpl in H0. *)
    (* constructor. intros x Txy. *)
    (* specialize (IHk T (sec_disj R x)). specialize (H0 x). *)
    (* apply IHk; auto. *)
    (* intros. destruct H1; subst. unfold sec_disj in *. *)
    (* intuition. *)
    (* intuition. red in H4. apply (H x z). *)

    induction p as [|p IHp] in T, R, y, k |- * .
  (*   + simpl. intros. constructor. *)
  (*     intros z Tz. specialize (H z y). elim H. constructor 2. split; auto. *)
  (*     constructor. auto. *)
  (*   + intros cond secure. constructor. intros z Tzy. *)
  (*     simpl in secure. *)
  (*     specialize (IHp y T (fun y0 z0 => R y0 z0 \/ R y y0) z). eapply (IHp k); auto. *)
  (*     intros x w wz. *)
  (*     assert(wy: clos_refl_trans X (power (S k) T) w y). *)
  (*     { econstructor 3. eauto. constructor.    now constructor. } *)
  (*     pose proof (cond x w wy). intuition. *)
  (*     specialize (cond w y). apply cond. constructor 2. *)
  (*     intuition. apply clos_trans_n1_1n. eapply clos_refl_trans_right; eauto. *)
  (* Defined. *)
    Admitted.

    (* induction k. eapply acc_from_af; eauto. *)
    (* apply IHk. intros. eapply H. eauto. *)
    (* constructor. intros. *)
    (* apply IHk; auto. intros x z Hzy [Hxz Rzx]. *)
    (* specialize (H x z). *)
    (* specialize (H x _ H2). apply H. split; intuition. *)
    (* induction H4. constructor. simpl. exists *)

(* eapply acc_power with 0. eapply acc_from_af; eauto. intros. intuition. *)
(*     simpl power in *. *)
(*     apply clos_trans_1n_n1 in H3. destruct H3. *)
(*     specialize (H x _ H1). apply H; split; auto. *)
(*     specialize (H *)
(*     induction p as [|p IHp] in T, R, y |- * . *)
(*     + simpl. intros. constructor. *)
(*       intros z Tz. specialize (H z y). elim H. constructor 2. split; auto. *)
(*       constructor. auto. *)
(*     + intros cond secure. constructor. intros z Tzy. *)
(*       simpl in secure. *)
(*       specialize (IHp y T (fun y0 z0 => R y0 z0 \/ R y y0) z). apply IHp; auto. *)
(*       intros x w wz. *)
(*       assert(wy: clos_refl_trans X T w y). *)
(*       { econstructor 3. eauto. now constructor. } *)
(*       pose proof (cond x w wy). intuition. *)
(*       specialize (cond w y). apply cond. constructor 2. *)
(*       intuition. apply clos_trans_n1_1n. eapply clos_refl_trans_right; eauto. *)
(*   Defined. *)

  Lemma wf_from_power_af (p : WFT X) (T R : X → X → Prop) k :
    (∀ x y, clos_trans_1n X (power k T) x y ∧ R y x → False)
    → SecureBy R p → well_founded T.
  Proof.
    intros. intro x. eapply acc_from_power_af; eauto. apply secure_by_power. apply H0.
  Defined.

End WfFromAF.

Section FixAF.
  Context {X : Type} (T R : X -> X -> Prop).
  Context {af : AlmostFull R}.
  Context (H : forall x y, clos_trans_1n X T x y /\ R y x -> False).

  Global Instance af_wf : WellFounded T.
  Proof. red. destruct af. eapply wf_from_af; eauto. Defined.
End FixAF.

Section PowerAf.
  Context {X : Type}.
  Context (T R : X -> X -> Prop).
  Context {af : AlmostFull R}.
  Context (k : nat).
  Context (H : forall x y, clos_trans_1n X (power k T) x y /\ R y x -> False).

  Global Instance af_power_wf : WellFounded T.
  Proof.
    destruct af as [p Sp].
    eapply wf_from_power_af; eauto.
  Defined.
End PowerAf.

Equations cofmap {X Y : Type} (f : Y -> X) (p : WFT X) : WFT Y :=
  cofmap f ZT := ZT;
  cofmap f (SUP w) := SUP (fun y => cofmap f (w (f y))).
Transparent cofmap.

Lemma cofmap_secures {X Y : Type} (f : Y -> X) (p : WFT X) (R : X -> X -> Prop) :
  SecureBy R p -> SecureBy (fun x y => R (f x) (f y)) (cofmap f p).
Proof.
  induction p in R |- *; simpl; auto.
  intros.
  specialize (H (f x) (fun y z : X => R y z \/ R (f x) y)). simpl in H.
  apply H. apply H0.
Defined.

#[export] Instance AlmostFull_MR {X Y} R (f : Y -> X) : AlmostFull R -> AlmostFull (Wf.MR R f).
Proof. intros [p sec]. exists (cofmap f p). apply (cofmap_secures f p _ sec). Defined.

Fixpoint oplus_nullary {X:Type} (p:WFT X) (q:WFT X) :=
  match p with
  | ZT => q
  | SUP f => SUP (fun x => oplus_nullary (f x) q)
  end.

Lemma oplus_nullary_sec_intersection {X} (p : WFT X) (q: WFT X)
      (C : X → X → Prop) (A : Prop) (B : Prop) :
  SecureBy (fun y z => C y z ∨ A) p →
  SecureBy (fun y z => C y z ∨ B) q →
  SecureBy (fun y z => C y z ∨ (A ∧ B)) (oplus_nullary p q).
Proof.
  revert C q.
  induction p; simpl; intros; auto.
  induction q in C, H, H0 |- *; simpl in *; intuition.
  specialize (H x y). specialize (H0 x y). intuition.
  specialize (H1 x (fun y z => (C y z \/ A /\ B) \/ C x y)). simpl in *.
  eapply SecureBy_mon. 2:eapply H1. simpl. intuition. intuition. firstorder auto.
  eapply SecureBy_mon. 2:eapply H0. simpl. firstorder auto.

  specialize (H x (fun y z => C y z \/ C x y)). simpl in *.
  eapply SecureBy_mon. 2:eapply H. all:simpl.
  intros. firstorder auto.
  eapply SecureBy_mon. 2:eapply H0. simpl. intros. intuition.
  eapply SecureBy_mon. 2:eapply H1. simpl. intros. intuition.
Qed.

Section OplusUnary.
  Context {X : Type}.

  (* Nested version is harder to work with *)
  (* Equations oplus_unary (p : WFT X) (q : WFT X) : WFT X by struct p := *)
  (* oplus_unary ZT q := q; *)
  (* oplus_unary (SUP f) g := SUP (fun x => oplus_unary_right g x) *)

  (*   where oplus_unary_right (q : WFT X) (x : X) : WFT X by struct q := *)
  (*   { oplus_unary_right ZT x := f x; *)
  (*     oplus_unary_right (SUP g) x := *)
  (*       oplus_nullary (oplus_unary (f x) (SUP g)) *)
  (*                     (oplus_unary_right (g x) x) }. *)

  Equations? oplus_unary (p : WFT X) (q : WFT X) : WFT X
    by wf (p, q) (Subterm.lexprod _ _ WFT_subterm WFT_subterm) :=
  oplus_unary ZT q := q;
  oplus_unary p ZT := p;
  oplus_unary (SUP f) (SUP g) :=
      SUP (fun x => oplus_nullary (oplus_unary (f x) (SUP g))
                                  (oplus_unary (SUP f) (g x))).
  Proof. repeat constructor.
         constructor 2. repeat constructor.
  Defined.

  Equations? oplus_binary (p : WFT X) (q : WFT X) : WFT X
    by wf (p, q) (Subterm.lexprod _ _ WFT_subterm WFT_subterm) :=
  oplus_binary ZT q := q;
  oplus_binary p ZT := p;
  oplus_binary (SUP f) (SUP g) :=
      SUP (fun x => oplus_unary (oplus_binary (f x) (SUP g))
                                (oplus_binary (SUP f) (g x))).
  Proof. repeat constructor.
         constructor 2. repeat constructor.
  Defined.

End OplusUnary.

Set Firstorder Solver auto.

(* Lemma oplus_unary_sec_intersection {X} (p q : WFT X) *)
(*       (C : X -> X -> Prop) (A B : X -> Prop) : *)
(*   SecureBy (fun y z => C y z \/ A y) p -> *)
(*   SecureBy (fun y z => C y z \/ B y) q -> *)
(*   SecureBy (fun y z => C y z \/ (A y /\ B y)) (oplus_unary p q). *)
(* Proof. *)
(*   intros. *)
(*   revert H H0. revert q C. induction p. *)
(*   intros. simp oplus_unary. eapply SecureBy_mon; [|eapply H0]. firstorder. *)
(*   simpl. induction q. simpl. intros. *)
(*   eapply SecureBy_mon; [|eapply H0]. simpl. firstorder auto. *)
(*   intros. *)
(*   simp oplus_unary. simpl. intros x. *)
(*   eapply SecureBy_mon; [|eapply (oplus_nullary_sec_intersection _ _ _ (A x) (B x))]. simpl. *)
(*   intros. destruct H3; [|intuition]. rewrite <- or_assoc. left. eapply H3. *)
(*   - simpl. simpl in H2. *)
(*     eapply SecureBy_mon; [|eapply (H _ _ (fun y z => C y z \/ C x y \/ A x))]; auto. simpl; intros. *)
(*     intuition auto. *)
(*     eapply SecureBy_mon; [|eapply H1]; simpl. intros. intuition auto. *)
(*     simpl. intros. *)
(*     eapply SecureBy_mon; [|eapply H2]; simpl. intros. intuition auto. *)
(*   - simpl. eapply SecureBy_mon; [|eapply (H0 _ (fun y z => C y z \/ C x y \/ B x))]; simpl. intuition auto. *)
(*     intuition. simpl in H2. eapply SecureBy_mon; [|eapply H1]; simpl. intuition auto. *)
(*     eapply SecureBy_mon; [|eapply H2]; simpl. intros. intuition auto. *)
(* Defined. *)

Lemma oplus_unary_sec_intersection {X} (p q : WFT X)
      (C : X -> X -> Prop) (A B : X -> Prop) :
  SecureBy (fun y z => C y z \/ A y) p ->
  SecureBy (fun y z => C y z \/ B y) q ->
  SecureBy (fun y z => C y z \/ (A y /\ B y)) (oplus_unary p q).
Proof.
  funelim (oplus_unary p q); simpl; intros.
  - eapply SecureBy_mon; [|eapply H0]; simpl; firstorder.
  - eapply SecureBy_mon; [|eapply H]. simpl; firstorder.
  - eapply SecureBy_mon. 2:eapply (oplus_nullary_sec_intersection _ _ _ (A x) (B x)). simpl.
    intros. destruct H3; [|intuition auto]. rewrite <- or_assoc. left. eapply H3.
    -- simpl.
       eapply SecureBy_mon; [|eapply (H _ (fun y z => C y z \/ C x y \/ A x) A B)]. simpl.
       intuition auto.
       eapply SecureBy_mon; [|eapply H1]; simpl. intros. intuition auto.
       simpl. intros.
       eapply SecureBy_mon; [|eapply H2]; simpl. intros. intuition auto.
    -- simpl. specialize (H0 x (SUP f) (g x)). eqns_specialize_eqs H0. eapply SecureBy_mon; [|eapply (H0 (fun y z => C y z \/ C x y \/ B x) A B)]; simpl. intuition auto.
       intuition. simpl in H2. eapply SecureBy_mon; [|eapply H1]; simpl. intuition auto.
       eapply SecureBy_mon; [|eapply H2]; simpl. intros. intuition auto.
Qed.

Lemma oplus_binary_sec_intersection' {X} (p q : WFT X)
      (C : X -> X -> Prop) (A B : X -> X -> Prop) :
  SecureBy (fun y z => C y z \/ A y z) p ->
  SecureBy (fun y z => C y z \/ B y z) q ->
  SecureBy (fun y z => C y z \/ (A y z /\ B y z)) (oplus_binary p q).
Proof.
  funelim (oplus_binary p q); simpl; intros.
  eapply SecureBy_mon. 2:eapply H0. simpl. firstorder.
  eapply SecureBy_mon; [|eapply H]. simpl; firstorder.
  eapply SecureBy_mon. 2:eapply (oplus_unary_sec_intersection _ _ _ (A x) (B x)). simpl.
  intros. destruct H3; [|intuition auto]. rewrite <- or_assoc. left. eapply H3.
  - simpl.
    eapply SecureBy_mon; [|eapply (H _ (fun y z => C y z \/ C x y \/ A x y) A B)]. simpl.
    intuition auto.
    eapply SecureBy_mon; [|eapply H1]; simpl. intros. intuition auto.
    simpl. intros.
    eapply SecureBy_mon; [|eapply H2]; simpl. intros. intuition auto.
  - simpl. specialize (H0 x (SUP f) (g x)). eqns_specialize_eqs H0.
    eapply SecureBy_mon; [|eapply (H0 (fun y z => C y z \/ C x y \/ B x y) A B)]; simpl. intuition auto.
    intuition. simpl in H2. eapply SecureBy_mon; [|eapply H1]; simpl. intuition auto.
    eapply SecureBy_mon; [|eapply H2]; simpl. intros. intuition auto.
Defined.

Lemma oplus_binary_sec_intersection {X} (p q : WFT X)
      (A B : X -> X -> Prop) :
  SecureBy A p ->
  SecureBy B q ->
  SecureBy (fun y z => A y z /\ B y z) (oplus_binary p q).
Proof.
  revert p q A B; intros p q. funelim (oplus_binary p q); simpl; intros.
  eapply SecureBy_mon. 2:eapply H0. simpl. firstorder.
  eapply SecureBy_mon; [|eapply H]. simpl; firstorder.
  eapply SecureBy_mon. 2:eapply (oplus_unary_sec_intersection _ _ _ (A x) (B x)). simpl.
  intros. destruct H3; [|intuition auto]. left. eapply H3.
  - simpl.
    eapply SecureBy_mon; [|eapply (H _ (fun y z => A y z \/ A x y) B)]; simpl. unfold sec_disj.
    intuition auto.
    eapply SecureBy_mon; [|eapply H1]; simpl. intros. intuition auto.
    simpl. intros.
    eapply SecureBy_mon; [|eapply H2]; simpl. intros. intuition auto.
  - simpl. specialize (H0 x (SUP f) (g x)). eqns_specialize_eqs H0.
    eapply SecureBy_mon; [|eapply (H0 A (fun y z => B y z \/ B x y))]; simpl. intuition auto.
    intuition. simpl in H2. apply H2.
Defined.

Definition inter_rel {X : Type} (A B : X -> X -> Prop) := fun x y => A x y /\ B x y.

Corollary af_interesection {X : Type} (A B : X -> X -> Prop) :
  AlmostFull A -> AlmostFull B -> AlmostFull (inter_rel A B).
Proof.
  intros [pa Ha] [pb Hb]. exists (oplus_binary pa pb). now apply oplus_binary_sec_intersection.
Defined.

(* Non-functional construction in intuition auto! *)
(* Lemma oplus_unary_sec_intersection' {X} (p q : WFT X) *)
(*       (C : X -> X -> Prop) (A B : X -> Prop) : *)
(*   SecureBy (fun y z => C y z \/ A y) p -> *)
(*   SecureBy (fun y z => C y z \/ B y) q -> *)
(*   SecureBy (fun y z => C y z \/ (A y /\ B y)) (oplus_unary p q). *)
(* Proof. *)
(*   revert p q C; intros p q. funelim (oplus_unary p q); simpl; intros. *)
(*   eapply SecureBy_mon. 2:eapply H0. simpl. firstorder. *)
(*   eapply SecureBy_mon; [|eapply H]. simpl; firstorder. *)
(*   eapply SecureBy_mon. 2:eapply (oplus_nullary_sec_intersection _ _ _ (A x) (B x)). simpl. *)
(*   intros. destruct H3; [|intuition auto]. rewrite <- or_assoc. left. eapply H3. *)
(*   - simpl. *)
(*     eapply SecureBy_mon; [|eapply (H _ (fun y z => C y z \/ C x y \/ A x))]. simpl. *)
(*     clear H H0. (* BUG *) intuition auto. *)
(*     eapply SecureBy_mon; [|eapply H1]; simpl. intros. intuition auto. *)
(*     simpl. intros. *)
(*     eapply SecureBy_mon; [|eapply H2]; simpl. intros. intuition auto. *)
(*   - simpl. eapply SecureBy_mon; [|eapply (H0 _ (fun y z => C y z \/ C x y \/ B x))]; simpl. intuition auto. *)
(*     intuition. simpl in H2. eapply SecureBy_mon; [|eapply H1]; simpl. intuition auto. *)
(*     eapply SecureBy_mon; [|eapply H2]; simpl. intros. intuition auto. *)
(* Qed. *)

Definition af_bool : AlmostFull (@eq bool).
Proof.
  exists (SUP (fun _ => SUP (fun _ => ZT))).
  simpl. intros x y z w. destruct x, y, z, w; intuition.
Defined.

Definition product_rel {X Y : Type} (A : X -> X -> Prop) (B : Y -> Y -> Prop) :=
  fun x y => A (fst x) (fst y) /\ B (snd x) (snd y).

#[export] Instance af_product {X Y : Type} (A : X -> X -> Prop) (B : Y -> Y -> Prop) :
  AlmostFull A -> AlmostFull B -> AlmostFull (product_rel A B).
Proof.
  intros. pose (af_interesection (Wf.MR A fst) (Wf.MR B snd)).
  assert (relation_equivalence (inter_rel (Wf.MR A fst) (Wf.MR B snd)) (product_rel A B)).
  repeat red; intuition. rewrite <- H1. apply a; typeclasses eauto.
Defined.

Definition T (x y : nat * nat) : Prop :=
  (fst x = snd y /\ snd x < snd y) \/
  (fst x = snd y /\ snd x < fst y).

Definition Tl (x y : nat * (nat * unit)) : Prop :=
  (fst x = fst (snd y) /\ fst (snd x) < fst (snd y)).

Definition Tr (x y : nat * (nat * unit)) : Prop :=
  (fst x = fst (snd y) /\ fst (snd x) < fst y).

Ltac destruct_pairs := repeat
  match goal with
    [ x : _ * _ |- _ ] => let x0 := fresh x in let x1 := fresh x in destruct x as [x0 x1]; simpl in *
  | [ x : exists _ : _, _ |- _ ] => destruct x
  | [ x : _ /\ _ |- _ ] => destruct x
end.

Require Import ssreflect.

Section SCT.

  Definition subgraph k k' := fin k -> option (bool * fin k').
  Definition graph k := subgraph k k.

  Definition strict {k} (f : fin k) := Some (true, f).
  Definition large {k} (f : fin k) := Some (false, f).

  Declare Scope fin_scope.
  Delimit Scope fin_scope with fin.
  Bind Scope fin_scope with fin.
  Notation "0" := fz : fin_scope.
  Notation "1" := (fs 0) : fin_scope.
  Open Scope fin_scope.
  (* bug scopes not handled well *)
  Equations T_graph_l (x : fin 2) : option (bool * fin 2) :=
    { T_graph_l fz := large (fs fz);
      T_graph_l (fs fz) := strict (fs fz) }.
  Equations T_graph_r (x : fin 2) : option (bool * fin 2) :=
    { T_graph_r fz := large (fs fz);
      T_graph_r (fs fz) := strict fz }.

  Equations graph_compose {k} (g1 g2 : graph k) : graph k :=
    graph_compose g1 g2 arg0 with g1 arg0 :=
      { | Some (weight, arg1) with g2 arg1 :=
            { | Some (weight', arg2) => Some (weight || weight', arg2);
              | None => None };
        | None => None }.

  Infix "⋅" := graph_compose (at level 90).

  Eval compute in (T_graph_l ⋅ T_graph_r) fz.

  Equations k_tuple_type (k : nat) : Type :=
  k_tuple_type 0 := unit;
  k_tuple_type (S n) := nat * k_tuple_type n.

  Equations k_tuple_val {k : nat} (f : fin k) (t : k_tuple_type k) : nat :=
    k_tuple_val fz (x, _) := x;
    k_tuple_val (fs f) (_, t) := k_tuple_val f t.

  Equations k_related (k k' : nat) (G : subgraph k k') : k_tuple_type k -> k_tuple_type k' -> Prop :=
    k_related 0 k' g := fun _ _ => True;
    k_related (S k) k' g with g fz :=
      { | Some (weight, d) := fun x y =>
                                (if weight then k_tuple_val fz x < k_tuple_val d y
                                 else (Peano.le (k_tuple_val fz x) (k_tuple_val d y))) /\
                                k_related k k' (fun f => g (fs f)) (snd x) y;
        | None => fun _ _ => False }.

  Definition graph_relation {k : nat} (G : graph k) : relation (k_tuple_type k) :=
    k_related k k G.

  Lemma k_related_spec {k k' : nat} (G : subgraph k k') :
    forall x y, k_related k k' G x y <->
                (forall f : fin k,
                    match G f with
                    | Some (weight, d) =>
                      if weight then k_tuple_val f x < k_tuple_val d y
                      else Peano.le (k_tuple_val f x) (k_tuple_val d y)
                    | None => False
                    end).
    Proof.
      eapply k_related_elim.
      split; auto. intros []. intros f. depelim f.
      intros n k'' g b f. intros H.
      intros gz [x rx] y.
      specialize (H (x, rx) y rx y). simpl.
      rewrite H. clear H.
      split.
      + intros [xlt relr].
        intros f'. depelim f'. rewrite gz. apply xlt. apply relr.
      + intros Hf. split.
        specialize (Hf fz). rewrite gz in Hf. apply Hf.
        intros f'. apply Hf.
      + intros n k'' g gf x y.
        split. intros [].
        intros f. specialize (f fz). now rewrite gf in f.
    Qed.

  Lemma graph_relation_spec {k : nat} (G : graph k) :
    forall x y, graph_relation G x y <->
                (forall f : fin k,
                    match G f with
                    | Some (weight, d) =>
                      if weight then k_tuple_val f x < k_tuple_val d y
                      else Peano.le (k_tuple_val f x) (k_tuple_val d y)
                    | None => False
                    end).
    Proof.
      unfold graph_relation. intros x y. now rewrite k_related_spec.
    Qed.

  Definition approximates {k} (G : graph k) (R : relation (k_tuple_type k)) :=
    inclusion _ R (graph_relation G).

  Eval compute in k_tuple_type 2.
  Example approximates_T_l :
    @approximates 2 T_graph_l Tl.
  Proof. intros x y Tlr. red in x, y, Tlr. destruct_pairs.
         unfold graph_relation. simp k_related T_graph_l; simpl.
         lia.
  Qed.

  Example approximates_T_r :
    @approximates 2 T_graph_r Tr.
  Proof. intros x y Tlr. red in x, y, Tlr. destruct_pairs. subst.
         unfold graph_relation. simp k_related T_graph_l; simpl.
         intuition.
  Qed.

  Lemma compose_approximates {k} (G0 G1 : graph k) (R0 R1 : relation (k_tuple_type k)) :
    approximates G0 R0 -> approximates G1 R1 ->
    approximates (G0 ⋅ G1) (compose_rel R0 R1).
  Proof.
    unfold approximates. intros ag0 ag1.
    intros x z [y [Hxy Hyz]]. rewrite graph_relation_spec.
    intros f. specialize (ag0 _ _ Hxy). specialize (ag1 _ _ Hyz).
    rewrite -> graph_relation_spec in ag0, ag1. specialize (ag0 f).
    funelim (graph_compose G0 G1 f). now rewrite Heq in ag0.
    rewrite Heq0 in ag0. specialize (ag1 arg1). rewrite Heq in ag1.
    destruct weight, weight'; simpl;  try lia.
    specialize (ag1 arg1). now rewrite Heq in ag1.
  Qed.

  Equations fin_union {A n} (f : fin n -> relation A) : relation A :=
    fin_union (n:=0)   f := fun _ _ => False;
    fin_union (n:=S n) f := fun x y => f fz x y \/ fin_union (fun f' => f (fs f')) x y.

  Lemma fin_union_spec {A n} (f : fin n -> relation A) :
    forall x y, fin_union f x y <-> exists k, f k x y.
  Proof.
    intros x y. funelim (fin_union f). split. intros [].
    intros [k _]. depelim k.
    split. intros [Hfz|Hfs].
    now exists fz.
    specialize (H x y x y). rewrite -> H in Hfs.
    destruct Hfs. now exists (fs x0).
    intros [k Hk]. depelim k. intuition. right.
    rewrite (H x y). now exists k.
  Qed.

  Equations fin_all k (p : fin k -> bool) : bool :=
    fin_all 0     _ := true;
    fin_all (S k) p := p fz && fin_all k (fun f => p (fs f)).

  Lemma fin_all_spec k (p : fin k -> bool) :
    reflect (forall f, p f = true) (fin_all k p).
  Proof.
    induction k; simp fin_all.
    constructor. intros f; depelim f.
    destruct (p fz) eqn:pfz. simpl. specialize (IHk (fun f => p (fs f))).
    simpl in IHk. destruct IHk; constructor. intros f; depelim f; auto.
    intro Hf. apply n. intros f'. apply Hf.
    simpl. constructor. intros H. specialize (H fz). rewrite pfz in H. discriminate.
  Qed.

  Definition graph_eq {k} (g g' : graph k) : bool :=
    fin_all k (fun f => eqb (g f) (g' f)).

  Equations power_graph_n {k} (n : nat) (g : graph k) : graph k :=
    power_graph_n 0 g := g;
    power_graph_n (S n) g := power_graph_n n g ⋅ g.

  Lemma approximates_power {k} (n : nat) (g : graph k) T :
    approximates g T ->
    approximates (power_graph_n n g) (power n T).
  Proof.
    induction n; simp power power_graph_n; auto.
    intros. specialize (IHn H).
    now apply compose_approximates.
  Qed.

  Equations list_union {A} (rs : list (relation A)) : relation A :=
    list_union nil := fun _ _ => False;
    list_union (cons r rs) := fun x y => r x y \/ list_union rs x y.

  Definition approximates_family {k} (graphs : list (graph k)) (R : relation (k_tuple_type k)) :=
    inclusion _ R (list_union (List.map graph_relation graphs)).

  Equations fin_all_compose {k n} (g : graph k) (p : fin n -> graph k) : fin n -> graph k :=
    fin_all_compose g p f := p f ⋅ g.

  Equations compose_family {k} (g : list (graph k)) (g' : list (graph k)) : list (graph k) :=
    compose_family nil _ := nil;
    compose_family (cons g gs) g' := app (map (fun g' => g ⋅ g') g') (compose_family gs g').

  Definition is_transitive_closure {k} (gs : list (graph k)) (l : list (graph k)) : Prop :=
    (forall g, In g gs -> In g l) /\ forall g g', In g l /\ In g' l -> In (g ⋅ g') l.

  Definition graphs_relation {k} (gs : list (graph k)) : relation (k_tuple_type k) :=
    list_union (map graph_relation gs).

  Lemma list_union_app {A} (rs rs' : list (relation A)) :
    forall x y, list_union (rs ++ rs') x y <-> list_union rs x y \/ list_union rs' x y.
  Proof.
    induction rs; intros; simpl; simp list_union; intuition.
    rewrite -> IHrs in H0. intuition.
  Qed.

  Equations map_k_tuple k (p : k_tuple_type k) (f : fin k -> nat) : k_tuple_type k :=
    map_k_tuple 0 p f := p;
    map_k_tuple (S n) (x, xs) f := (f fz, map_k_tuple n xs (fun i => f (fs i))).

  Lemma graph_relation_compose {k} x y (g g' : graph k) z :
    graph_relation g x z -> graph_relation g' z y ->
    graph_relation (g ⋅ g') x y.
  Proof.
    intros gzx g'zy. rewrite -> graph_relation_spec in gzx, g'zy |- *. intros f.
    specialize (gzx f). simp graph_compose. destruct (g f) as [[[] d]|];
    simpl. specialize (g'zy d); destruct (g' d) as [[[] d']|]; simp graph_compose;
    simpl; lia. specialize (g'zy d).
    destruct (g' d) as [[[] d']|]; simpl in *. lia. lia. lia. lia.
  Qed.

  Lemma union_graph_relation_compose {k} x y a (g : list (graph k)) z:
    graph_relation a x z -> list_union (map graph_relation g) z y ->
    list_union (map (fun x => graph_relation (a ⋅ x)) g) x y.
  Proof.
    induction g; simpl. 1:firstorder.
    intros Hxz Hzy.
    destruct Hzy.
    specialize (graph_relation_compose x y a a0). left; firstorder.
    firstorder.
  Qed.

  Lemma graphs_relation_compose {k} (g g' : list (graph k)) x y z :
    graphs_relation g x z -> graphs_relation g' z y ->
    graphs_relation (compose_family g g') x y.
  Proof.
    intros gxz gzy.
    induction g in g', x, y, z, gxz, gzy |- *; simp compose_family.
    unfold graphs_relation in gxz.
    simpl in gxz. destruct gxz.
    unfold graphs_relation.
    unfold compose_family.
    rewrite -> map_app, map_map, list_union_app.
    left.
    apply (union_graph_relation_compose _ _ _ _ z H gzy).
    specialize (IHg g' x y z H gzy).
    unfold graphs_relation. rewrite -> map_app, map_map, list_union_app.
    right; auto.
  Qed.

  Lemma in_transitive_closure {k} (g : list (graph k)) (l : list (graph k))
        (T : relation (k_tuple_type k))
        (approx : approximates_family g T) :
    is_transitive_closure g l ->
    forall i,  exists fam : list (graph k),
          (forall g, In g fam -> In g l) /\ approximates_family fam (power i T).
  Proof.
    unfold is_transitive_closure. intros.
    destruct H as [inS inScomp].
    (* assert (exists G, approximates G (power i (fin_union T)) /\ In G l). *)
    induction i in |- *; simp power.
    unfold approximates.
    - exists g. intuition.
    - destruct IHi as [famgi [Ingi gixz]].
      exists (compose_family famgi g).
      intuition.
      + revert H. clear -inS inScomp Ingi.
        induction famgi. simpl. intros [].
        simpl. rewrite in_app_iff in_map_iff.
        intros [[x [<- Inx]]| Ing]. apply inScomp. intuition auto.
        apply Ingi. constructor. auto.
        apply IHfamgi; auto. intros.
        apply Ingi; eauto with datatypes.
      + red. intros x y [z [powxz Tzy]].
        do 2 red in approx, gixz.
        specialize (gixz _ _ powxz).
        specialize (approx _ _ Tzy).
        eapply graphs_relation_compose; intuition.
  Qed.

  Equations fin_list {n A} (f : fin n -> A) : list A :=
    fin_list (n:=0) f := nil;
    fin_list (n:=S n) f := f fz :: fin_list (fun i => f (fs i)).

  Lemma size_change_wf {k} (n : nat)
        (T : fin n -> relation (k_tuple_type k))
        (graphs : list (graph k))
        (approx : approximates_family graphs (fin_union T))
        (S : list (graph k))
        (Strans : is_transitive_closure graphs S)
        (R : relation (k_tuple_type k))
        (AF : AlmostFull R) :
    (forall G, In G S -> forall x y, graph_relation G x y /\ R y x -> False) ->
    well_founded (fin_union T).
  Proof.
    intros H. apply (af_wf _ R).
    intros x y [Txy Ryx].
    rewrite <- clos_trans_t1n_iff in Txy.
    apply clos_trans_power in Txy as [k' Tkxy].
    red in Strans. destruct (in_transitive_closure graphs S (fin_union T) approx Strans k') as [g' [Ings Hg]].
    apply Hg in Tkxy.
    clear Hg.
    induction g'; simpl in Tkxy. elim Tkxy.
    destruct Tkxy. specialize (Ings a). forward Ings by constructor; auto.
    now apply (H a Ings x y).
    apply IHg'; auto. intros. apply Ings; intuition.
  Defined.

  Lemma size_change_wf_fam {k} (n : nat)
        (T : fin n -> relation (k_tuple_type k))
        (graphs : fin n -> graph k)
        (approx : forall f, approximates (graphs f) (T f))
        (S : list (graph k))
        (Strans : is_transitive_closure (fin_list graphs) S)
        (R : relation (k_tuple_type k))
        (AF : AlmostFull R) :
    (forall G, In G S -> forall x y, graph_relation G x y /\ R y x -> False) ->
    well_founded (fin_union T).
  Proof.
    intros H. apply (af_wf _ R).
    intros x y [Txy Ryx].
    rewrite <- clos_trans_t1n_iff in Txy.
    apply clos_trans_power in Txy as [k' Tkxy].
    red in Strans.
    assert(approximates_family (fin_list graphs) (fin_union T)).
    { clear -approx. induction n. simpl. red. auto. red. simpl. auto.
      red. intros x y Rxy. specialize (IHn (fun f => T (fs f)) (fun f => graphs (fs f)) (fun f => approx (fs f))).
      do 2 red in IHn. specialize (IHn x y).
      destruct Rxy. simp fin_list. simpl.
      left. now apply approx. intuition. simp fin_list. simpl.
      intuition. }
    destruct (in_transitive_closure (fin_list graphs) S (fin_union T) H0 Strans k') as [g' [Ings Hg]].
    apply Hg in Tkxy.
    clear Hg.
    induction g'; simpl in Tkxy. elim Tkxy.
    destruct Tkxy. specialize (Ings a). forward Ings by constructor; auto.
    now apply (H a Ings x y).
    apply IHg'; auto. intros. apply Ings; intuition.
  Defined.

  Equations TI_graph k : graph k :=
    TI_graph 0 := λ{ | ! } ;
    TI_graph (S n) := fun f => Some (false, f).

  Lemma TI_compose k (G : graph k) : forall f, (G ⋅ TI_graph k) f = G f.
  Proof.
    induction k. unfold TI_graph. do 2 red in G. intros f; depelim f.
    intros f. depelim f. simp TI_graph graph_compose.
    destruct (G fz) as [[weight d]|]; simpl; try easy. now rewrite orb_false_r.
    simp TI_graph graph_compose.
    destruct (G (fs f)) as [[weight d]|]; simpl; trivial. now rewrite orb_false_r.
  Qed.

  Definition TI k : relation (k_tuple_type k) := graph_relation (TI_graph k).

  Equations intersection k : relation (k_tuple_type k) :=
    intersection 0 := fun x y => True;
    intersection (S n) := fun x y => Nat.le (fst x) (fst y) /\ intersection n (snd x) (snd y).

  Lemma TI_intersection_equiv k : relation_equivalence (TI k) (intersection k).
    induction k.
    - intros x y. red. split. intros []. exact I. intros. exact I.
    - intros [x rx] [y ry]. simpl. split.
      + unfold TI.
        intros Hg. pose proof Hg. rewrite -> graph_relation_spec in H.
        intros. pose (H fz). simpl in y0. intuition.
        assert (graph_relation (TI_graph k) rx ry).
        rewrite graph_relation_spec. intros. clear y0. specialize (H (fs f)). simpl in H.
        unfold TI_graph. destruct k. depelim f. auto.
        do 2 red in IHk. simpl in IHk. rewrite <- IHk. apply H0.
      + intros [Hle Hi]. unfold TI. rewrite graph_relation_spec.
        intros. depelim f. simpl. auto. simpl.
        do 2 red in IHk. simpl in IHk. rewrite <- IHk in Hi.
        red in Hi. rewrite -> graph_relation_spec in Hi.
        clear -Hi. induction k. depelim f.
        specialize (Hi f). simpl in Hi. auto.
  Qed.

  #[global] Instance TI_AlmostFull k : AlmostFull (TI k).
  Proof.
    rewrite TI_intersection_equiv.
    induction k. simpl. red. red. exists ZT. simpl. intros. exact I.
    simpl. apply af_interesection.
    apply (AlmostFull_MR Nat.le). apply almost_full_le.
    apply (AlmostFull_MR (intersection k)). apply IHk.
  Qed.

  Lemma TI_compose' k (G : graph k) : (G ⋅ TI_graph k) = G.
  Proof. extensionality f. apply TI_compose. Qed.

  Lemma sct_power_check {k} G (T : relation (k_tuple_type k)) :
    approximates G T ->
    (exists n f, power_graph_n n G f = Some (true, f)) ->
    (forall x y, T x y -> TI _ y x -> False).
  Proof.
    intros approx [n [f eqpow]] x y Txy TIyx.
    assert (compose_rel T (TI k) x x). exists y; easy.
    assert (power n (compose_rel T (TI k)) x x).
    { clear -H. induction n; simp power; auto.
      exists x. intuition. }
    pose (compose_approximates G (TI_graph k) T (TI k)).
    forward a; auto. forward a; auto. unfold TI. red. intuition.
    rewrite TI_compose' in a.
    apply (approximates_power n) in a.
    specialize (a x x). specialize (a H0).
    rewrite -> graph_relation_spec in a. specialize (a f).
    rewrite eqpow in a. lia.
  Qed.

  Theorem size_change_termination {k} (n : nat)
          (T : fin n -> relation (k_tuple_type k))
          (graphs : fin n -> graph k)
          (approx : forall f, approximates (graphs f) (T f))
          (S : list (graph k))
          (Strans : is_transitive_closure (fin_list graphs) S)
          (haspow : forall G, In G S -> exists n f, power_graph_n n G f = Some (true, f)) :
          well_founded (fin_union T).
  Proof.
    apply size_change_wf_fam with graphs S (TI k); auto.
    - apply TI_AlmostFull.
    - intros.
      specialize (haspow G H). destruct Strans.
      refine (sct_power_check G (graph_relation G) _ haspow x y _ _). red. firstorder.
      intuition. intuition.
  Qed.

  Import ListNotations.

  Inductive trans_clos_answer (k : nat) : Set :=
    | OutOfFuel
    | Finished (l : list (graph k)).
  Derive NoConfusion for trans_clos_answer.

  Section find_opt.
    Context {A : Type}.
    Equations find_opt (l : list A) (f : A -> option A) : option A :=
    find_opt [] f := None;
    find_opt (x :: xs) f with f x :=
                       { | Some y => Some y;
                         | None => find_opt xs f }.
  End find_opt.

  Lemma find_opt_spec {A} (l : list A) (f : A -> option A) :
    match find_opt l f with
    | Some x => exists a, In a l /\ f a = Some x
    | None => forall a, In a l -> f a = None
    end.
  Proof.
    funelim (find_opt l f); intros. elim H.
    exists x; simpl; intuition eauto.
    destruct (find_opt xs f); now firstorder subst.
  Qed.

  Equations compute_transitive_closure {k} (n : nat) (gs : list (graph k)) : trans_clos_answer k by struct n :=
    compute_transitive_closure 0 _ := OutOfFuel _;
    compute_transitive_closure (S n) gs := aux gs []
     where aux (l : list (graph k)) (acc : list (graph k)) : trans_clos_answer k by struct l :=
     aux nil acc := Finished _ acc;
     aux (g :: gs') acc := with_new_candidate new_candidate
       where with_new_candidate : option (graph k) -> trans_clos_answer k :=
       { | Some newg => compute_transitive_closure n (newg :: g :: gs' ++ acc);
         | None => aux gs' (g :: acc) }
       where new_candidate : option (graph k) :=
       new_candidate := let gs'' := g :: acc in
                        find_opt gs'' (fun g' =>
                                         let gcomp := g' ⋅ g in
                                         (* if eqb g gcomp then None else *)
                                           if List.existsb (eqb gcomp) gs'' then
                                             let gcomp' := g ⋅ g' in
                                             if List.existsb (eqb gcomp') gs'' then None
                                             else Some gcomp'
                                           else Some gcomp).
  (* Hint Extern 10 => progress simpl : Below. *)
  (* FIXME bug when using with *)

  (* Equations compute_transitive_closure {k} (n : nat) (gs : list (graph k)) : trans_clos_answer k *)
  (*   by wf n lt := *)
  (*   compute_transitive_closure 0 _ := OutOfFuel _; *)
  (*   compute_transitive_closure (S n) gs := aux gs [] *)
  (*    where aux (l : list (graph k)) (acc : list (graph k)) : trans_clos_answer k by struct l := *)
  (*    aux nil acc := Finished _ acc; *)
  (*    aux (g :: gs') acc := *)
  (*      let gs'' := g :: gs' ++ acc in *)
  (*      let new_candidate := *)
  (*          find_opt gs'' (fun g' => *)
  (*                           let gcomp := g' ⋅ g in *)
  (*                           if eqb g gcomp then None else *)
  (*                             if List.existsb (eqb gcomp) gs'' then *)
  (*                               let gcomp' := g ⋅ g' in *)
  (*                               if List.existsb (eqb gcomp') gs'' then None *)
  (*                               else Some gcomp' *)
  (*                             else Some gcomp) *)
  (*      in *)
  (*      match new_candidate with *)
  (*      | Some newg => compute_transitive_closure n (newg :: gs'') *)
  (*      | None => aux gs' (g :: acc) *)
  (*      end. *)

  Definition becoming_transitive_closure {k} (acc : list (graph k)) (l : list (graph k)) : Prop :=
    (forall g, In g acc -> In g l) /\ forall g g', In g acc -> In g' acc -> In (g ⋅ g') l.

  Definition transitive_closure_of {k} (g : graph k) (l : list (graph k)) : Prop :=
    forall g', In g' l -> In (g ⋅ g') l /\ In (g' ⋅ g) l.

  Definition incl_transitive_closure_of {k} (l : list (graph k)) (l' : list (graph k)) : Prop :=
    forall trl, is_transitive_closure l trl -> incl l' trl.

  Definition new_candid k n gs g l acc :=
    (compute_transitive_closure_clause_2_aux_clause_2_new_candidate
       (@compute_transitive_closure) k n gs
       (compute_transitive_closure_clause_2_aux (@compute_transitive_closure) k n gs) g l acc).
  Notation aux := compute_transitive_closure_clause_2_aux.

  Definition with_new_candid k n gs g l acc :=
    (compute_transitive_closure_clause_2_aux_clause_2_with_new_candidate (@compute_transitive_closure) k n gs
(aux (@compute_transitive_closure) k n gs) g l acc).

  Lemma is_transitive_closure_incl:
    ∀ (k : nat) (gs : list (graph k)) (g : graph k) (l acc l' : list (graph k)),
      is_transitive_closure gs l'
      → incl_transitive_closure_of gs ((g :: l) ++ acc) → incl_transitive_closure_of ((g :: l) ++ acc) l'.
  Proof.
    intros k gs g l acc l' H0 H3.
    red in H3. pose proof (H3 _ H0).
    red. intros. assert (is_transitive_closure (g :: l ++ acc) l').
    red. intuition. red in H0. intuition.
    red in H1, H2 |- *. intuition.
  Admitted.

  Ltac apply_find_opt_spec :=
    match goal with
    | |- context [find_opt ?g ?f] => pose proof (find_opt_spec g f)
    end.
  Lemma existsb_spec {A} (p : A -> bool) l : reflect (exists x, In x l /\ p x = true) (existsb p l).
  Proof.
    destruct existsb eqn:Heq. constructor. now apply existsb_exists in Heq.
    constructor. intro. apply existsb_exists in H. rewrite Heq in H; discriminate.
  Qed.
  Lemma eqb_refl {A} `{E:Eq A} (a : A) : eqb a a = true.
  Proof. destruct (eqb_spec a a); intuition. Qed.
  Lemma eqb_eq {A} `{E:Eq A} (a b : A) : eqb a b = true <-> a = b.
  Proof. destruct (eqb_spec a b); intuition. discriminate. Qed.
  Lemma eqb_neq {A} `{E:Eq A} (a b : A) : eqb a b = false <-> a <> b.
  Proof. destruct (eqb_spec a b); intuition. Qed.
  Lemma incl_transitive_closure:
    ∀ (k : nat) (l l' trl : list (graph k)),
      is_transitive_closure l' trl ->
      incl l l' -> incl_transitive_closure_of l l' → is_transitive_closure l trl.
  Proof.
    intros. red in H, H0, H1 |- *. intuition.
  Qed.

  Lemma incl_switch_head {A} (x : A) (y l r : list A) : incl (x :: y ++ l) r -> incl (y ++ x :: l) r.
  Proof.
    unfold incl in *. intuition auto. specialize (H a). apply H.
    simpl in *; rewrite -> in_app_iff in *. simpl in *.
    intuition auto.
  Qed.

  Lemma incl_switch_head' {A} (x : A) (y l r : list A) : incl r (x :: y ++ l) -> incl r (y ++ x :: l).
  Proof.
    unfold incl in *. intuition. specialize (H a H0).
    simpl in *; rewrite -> in_app_iff in *. simpl in *.
    intuition auto.
  Qed.
  Hint Resolve incl_switch_head' : core.

  Lemma tr_clos_incl {k} {l l' : list (graph k)} : is_transitive_closure l l' -> incl l l'.
  Proof. unfold is_transitive_closure. intuition. Qed.
  Hint Resolve tr_clos_incl : core.

  Lemma becoming_empty {k} {l: list (graph k)} : becoming_transitive_closure [] l.
  Proof. unfold becoming_transitive_closure. intuition. inversion H. inversion H. Qed.
  Hint Resolve becoming_empty : core.

  Lemma compute_transitive_closure_spec {k} n (gs : list (graph k)) l :
    compute_transitive_closure n gs = Finished _ l ->
    is_transitive_closure gs l.
  Proof.
    eapply (compute_transitive_closure_elim
              (fun k n gs r => forall l,
                   r = Finished k l -> is_transitive_closure gs l)
              (fun k n gs l acc res =>
                 is_transitive_closure acc acc ->
                 forall l', res = Finished k l' ->
                            incl (l ++ acc) l' /\
                            (incl gs (l ++ acc) ->
                            incl_transitive_closure_of gs (l ++ acc) ->
                            becoming_transitive_closure acc l' ->
                            incl (l ++ acc) l' /\
                            incl_transitive_closure_of (l ++ acc) l' /\
                            (* becoming_transitive_closure l l' *) is_transitive_closure gs l'))
              (fun k n gs g l acc newc =>
                 let gs' := (g :: acc) in
                 match newc with
                 | None => is_transitive_closure gs' gs' /\ transitive_closure_of g gs'
                 | Some g' => ~ In g' gs' /\
                              exists a, In a gs' /\ (g' = (g ⋅ a) \/ g' = (a ⋅ g))
                 end)
              (fun k n gs g l acc newc res =>
                 forall l', res = Finished k l' ->
                            incl (l ++ acc) l' /\
                            (match newc with
                            | Some c =>
                              incl gs (c :: g :: l ++ acc) /\
                              incl_transitive_closure_of gs (c :: g :: l ++ acc)
                            | None =>
                              incl gs (g :: l ++ acc) /\
                              incl_transitive_closure_of gs (g :: l ++ acc) /\
                              transitive_closure_of g (g :: acc) /\
                              becoming_transitive_closure (g :: acc) l'
                            end ->
                            is_transitive_closure gs l'))); clear.
      all:try discriminate; eauto.
    + intros * H l Haux.
(*      forward H. red. intuition.
      specialize (H l Haux). apply H. auto with datatypes.
      rewrite app_nil_r. red. intuition. intuition.
    + intros * n * tracc l' [= <-]. simpl. split. intuition.
      intros inclgs incltrgs becacc.
      intuition. red. intuition. red.
      intuition.
    + intros *. simpl.
      fold (new_candid k n gs g l acc).
      fold (with_new_candid k n gs g l acc).
      intros Hcand IH tracc l' Hnewc. split. admit.
      intros inclgs incltrgs becaccl'.
      specialize (IH _ Hnewc). destruct IH as [incll' IH]. split. admit.
      forward IH.
      ++ destruct new_candid.
         destruct Hcand as [ng [a [Ina Ha]]].
         split. intuition.
         +++ intros trl Htrl. specialize (incltrgs trl Htrl).
             intros x Inx. destruct Inx. subst x.
             destruct Ha as [-> | ->]; apply Htrl; intuition.
             now apply incltrgs.
         +++ intuition. clear H2.
             red. split. intros x Inx. simpl in Inx. intuition. subst x.

             admit. admit.
             (* destruct Ing' as [<-|Inlacc]. red in becaccl'. *)

      ++ intuition.
         clear Hcand.
         eapply is_transitive_closure_incl; eauto.
    + intros.
      remember (g :: acc) as gs''. cbv zeta.
      apply_find_opt_spec. destruct find_opt.
      ++ destruct H as [a [Inags'' Ineq]]. subst gs'0.
         destruct (existsb_spec (eqb (a ⋅ g)) gs'').
         destruct (existsb_spec (eqb (g ⋅ a)) gs'').
         all:admit. *)
    (*      discriminate. *)
    (*      noconf Ineq. split. *)
    (*      +++ intros Inga. apply n0. subst gs''. *)
    (*          exists (g ⋅ a). intuition auto. subst. apply eqb_refl. *)
    (*      +++ exists a. intuition. *)
    (*      +++ noconf Ineq. split. *)
    (*          intros Inag. apply n0. exists (a ⋅ g). intuition. apply eqb_refl. *)
    (*          exists a. intuition. *)
    (*   ++ split; intuition. subst gs'0. split; intros g' ?g''; auto. *)
    (*      intros [ing' ing'']. *)
    (*      specialize (H g' ing'). *)
    (*      destruct (existsb_spec (eqb (g' ⋅ g)) gs''). *)
    (*      destruct (existsb_spec (eqb (g ⋅ g')) gs''). *)
    (*      destruct e, e0; destruct_pairs. apply (eqb_eq _ x) in H3. apply (eqb_eq _ x0) in H2. *)
    (*      subst. admit. admit. admit. admit. *)
    (* + intros * IH * Hf. specialize (IH _ Hf). clear Hf. *)
    (*   split. intros x Inx. destruct IH as [IH _]. intuition. *)
    (*   intros [inclgs incltrgs]. *)
    (*   intuition. eapply incl_transitive_closure; eauto. *)
    (* + intros * IH * Hf. split. admit. *)
    (*   intros [inclgs [incltrgs [trg trg']]]. *)
    (*   apply IH. admit. auto. *)
    (*   red in trg. now eapply incl_switch_head' in inclgs. *)
    (*   red in incltrgs |- *. intros trl Htrl. specialize (incltrgs _ Htrl). *)
    (*   now apply incl_switch_head in incltrgs. apply trg'. *)
  Admitted.

  Definition gn_set : list (graph 2) :=
    [ T_graph_l; T_graph_r ].
  Transparent compute_transitive_closure.

  (* I so wish we could get the scope without everything *)
  Local Open Scope string_scope.

  Equations print_fin {k} (f : fin k) : String.string :=
    print_fin fz := "0";
    print_fin (fs fz) := "1";
    print_fin (fs (fs fz)) := "2";
    print_fin (fs (fs (fs fz))) := "3";
    print_fin f := "> 3".

  Equations print_nat (n : nat) : string :=
    print_nat 0 := "0";
    print_nat 1 := "1";
    print_nat 2 := "2";
    print_nat 3 := "3";
    print_nat 4 := "4";
    print_nat x := "5".

  Equations print_node {k'} (f : nat) (data : option (bool * fin k')) : string :=
    print_node f None := "";
    print_node f (Some (weight, f')) := print_nat f ++ (if weight then "<" else "<=") ++ print_fin f'.

  Equations print_fin_fn {k k'} (f : fin k -> option (bool * fin k')) : string :=
    print_fin_fn (k := 0) f := "";
    print_fin_fn (k := S k) f := print_node (k' - S k) (f fz) ++ " , " ++ print_fin_fn (fun n => f (fs n)).

  Equations print_graph {k} (f : graph k) : string :=
    print_graph (k := 0) f := "empty";
    print_graph (k := S n) f := print_fin_fn f.

  Equations print_list {A} (f : A -> string) (l : list A) : string :=
    print_list f nil := "";
    print_list f (cons a b) := f a ++ " ; " ++ print_list f b.

  Eval compute in print_list print_graph gn_set.

  Definition eq_dec_graph {k} : forall x y : graph k, { x = y } + { x <> y }.
  Proof.
    intros x y. destruct (eqb x y) eqn:Heq.
    left. destruct (eqb_spec x y). auto. discriminate.
    right. destruct (eqb_spec x y). auto. discriminate. auto.
  Defined.

  Definition uniquize {k} (l : list (graph k)) := nodup (@eq_dec_graph k) l.

  Definition T_trans_clos := match compute_transitive_closure 10 gn_set with
                  | Finished l => l
                  | OutOfFuel => gn_set end.
  (* Eval compute in T_trans_clos. *)

  Eval compute in match compute_transitive_closure 10 gn_set with
                  | Finished l => print_list print_graph (uniquize l)
                  | OutOfFuel => "outoffuel"%string end.

End SCT.

Eval compute in match compute_transitive_closure 10 gn_set with
                | Finished l => print_list print_graph (uniquize l)
                | OutOfFuel => "outoffuel"%string end.

Print Assumptions size_change_wf.
Print Assumptions size_change_termination.

Definition R := product_rel Nat.le Nat.le.
Require Import Lia.

Derive Signature for clos_trans_1n.

Definition antisym {X} (R : X -> X -> Prop) :=
  forall x y, R x y -> R y x -> False.

Equations T_rel (f : fin 2) : relation (k_tuple_type 2) :=
  T_rel fz := Tl;
  T_rel (fs fz) := Tr.

Equations T_graphs (f : fin 2) : graph 2 :=
  T_graphs fz := T_graph_l;
  T_graphs (fs fz) := T_graph_r.

Definition gnlex : (nat * nat) -> nat.
  assert (sct:=size_change_termination 2 T_rel T_graphs). forward sct.
  intros f; depelim f. apply approximates_T_l. depelim f. apply approximates_T_r. depelim f.
  specialize (sct T_trans_clos). forward sct. apply (compute_transitive_closure_spec 10). reflexivity.
  forward sct.
  intros. simpl in H.
  intuition; subst G;
    solve [exists 1; (exists fz ; reflexivity) || (exists (fs fz) ; reflexivity) ].
  set (rel :=(Wf.MR (fin_union T_rel) (fun x => (fst x, (snd x, tt))))).
  assert (WellFounded rel).
  apply Wf.measure_wf. apply sct.
  refine (Subterm.FixWf (WF:=H) (fun x => nat) _).
  refine (fun x =>
            match x as w return ((forall y, rel y w -> nat) -> nat) with
              | (0, _) => fun _ => 1
              | (_, 0) => fun _ => 1
              | (S x, S y) => fun frec =>
                                frec (S y, y) _ +
                                frec (S y, x) _
            end).
  red. simpl. red. compute. simpl. intuition lia. red. simpl. compute. intuition lia.
Defined.

Require Import ExtrOcamlBasic.
(* Extraction gnlex.
Print Assumptions gnlex. *)

(* Eval native_compute in gnlex (4, 3). *)

Lemma gnlex_0_l y : gnlex (0, y) = 1.
Admitted.

Lemma gnlex_0_r x : gnlex (x, 0) = 1.
Admitted.

Lemma gnlex_S x y : gnlex (S x, S y) = gnlex (S y, y) + gnlex (S y, x).
Admitted.

Lemma gnlex_S_test x y : exists foo, gnlex (S x, S y) = foo.
  eexists. rewrite gnlex_S. destruct y. rewrite gnlex_0_r.
  destruct x. rewrite gnlex_0_r. reflexivity.
  rewrite gnlex_S. rewrite gnlex_0_r. destruct x. admit. rewrite gnlex_S.
Admitted.


(* same application area as "bitblast", but a bit more complex and a bit more powerful *)

Require Import Coq.ZArith.ZArith.
Require Import coqutil.Z.Lia.
Require Import coqutil.Z.BitOps.
Require Export Coq.setoid_ring.ZArithRing.
Require Import Coq.btauto.Btauto.

Local Open Scope bool_scope.
Local Open Scope Z_scope.

Tactic Notation "safe_ring_simplify" constr(i) "in" ident(C) :=
  first [ring_simplify i in C |
         let t := type of i in fail 1000 "No ring structure found for" t ].

Lemma testbit_minus1: forall i,
    0 <= i ->
    Z.testbit (-1) i = true.
Proof.
  intros. rewrite (Z.bits_opp 1) by assumption.
  simpl. rewrite Z.bits_0. reflexivity.
Qed.

Lemma testbit_above: forall {p n},
    0 <= n < 2 ^ p ->
    0 <= p ->
    forall i,
    p <= i ->
    Z.testbit n i = false.
Proof.
  intros.
  rewrite <- (Z.mod_small n (2 ^ p)) by assumption.
  apply Z.mod_pow2_bits_high.
  auto.
Qed.

Lemma if_same: forall (A: Type) (b: bool) (a: A),
    (if b then a else a) = a.
Proof.
  intros. destruct b; reflexivity.
Qed.

Lemma then_true_else_false: forall (b: bool),
    (if b then true else false) = b.
Proof.
  intros. destruct b; reflexivity.
Qed.

#[global] Hint Rewrite
     if_same
     then_true_else_false
     Bool.andb_false_r
     Bool.andb_true_r
     Bool.andb_false_l
     Bool.andb_true_l
     Bool.orb_false_r
     Bool.orb_true_r
     Bool.orb_false_l
     Bool.orb_true_l
     Bool.xorb_false_r
     Bool.xorb_true_r
     Bool.xorb_false_l
     Bool.xorb_true_l
  : bool_rewriting.

Ltac discard_contradictory_or t :=
  match goal with
  | |- ?P \/ ?Q => (assert (~P) as _ by t; right) || (assert (~Q) as _ by t; left)
  end.

Lemma testbit_if: forall (b: bool) n m i,
    Z.testbit (if b then n else m) i = if b then (Z.testbit n i) else (Z.testbit m i).
Proof.
  intros. destruct b; reflexivity.
Qed.

Lemma Zdiv_small_neg: forall a b,
    - b <= a < 0 ->
    a / b = -1.
Proof.
  intros. Z.div_mod_to_equations. Lia.nia.
Qed.

Lemma testbit_above_signed: forall l a i,
    - 2 ^ l <= a < 2 ^ l ->
    0 < l ->
    l < i ->
    Z.testbit a i = Z.testbit a l.
Proof.
  intros. destruct (Z.testbit a l) eqn: E.
  - rewrite Z.testbit_true in E by blia.
    assert (a < -1 \/ a = -1 \/ 0 <= a) as C by blia. destruct C as [C | [C | C]].
    + apply Z.bits_above_log2_neg; [blia|].
      rewrite (Z.pow_lt_mono_r_iff 2) by blia.
      pose proof (Z.log2_spec (Z.pred (- a))) as P.
      pose proof (Z.pow_lt_mono_r 2 l i).
      blia.
    + subst. apply testbit_minus1. blia.
    + rewrite Z.div_small in E by blia.
      cbv in E. discriminate.
  - assert (a < 0 \/ 0 <= a) as C by blia. destruct C as [C | C].
    + exfalso.
      pose proof (Z.testbit_true a l) as P.
      destruct P as [_ P]; [blia|].
      rewrite P in E; [discriminate|clear P E].
      rewrite Zdiv_small_neg by blia.
      reflexivity.
    + assert (a / 2 ^ i = 0) as F. {
        pose proof (Z.pow_lt_mono_r 2 l i).
        apply Z.div_small. blia.
      }
      rewrite Z.testbit_false by blia.
      rewrite F.
      reflexivity.
Qed.

Lemma testbit_above': forall n b i,
    0 <= n ->
    n < b ->
    0 <= Z.log2_up b ->
    Z.log2_up b <= i ->
    Z.testbit n i = false.
Proof.
  intros.
  pose proof (Z.log2_log2_up_spec b).
  apply (@testbit_above (Z.log2_up b) n); blia.
Qed.

Lemma testbit_above_signed': forall a b i,
    - b <= a ->
    a < b ->
    0 < Z.log2_up b ->
    Z.log2_up b < i ->
    Z.testbit a i = Z.testbit a (Z.log2_up b).
Proof.
  intros.
  pose proof (Z.log2_log2_up_spec b).
  apply testbit_above_signed; blia.
Qed.

Lemma testbit_above_signed'': forall a b i,
    - b <= a ->
    a < b ->
    0 < Z.log2_up b ->
    Z.log2_up b <= i ->
    Z.testbit a i = Z.testbit a (Z.log2_up b).
Proof.
  intros.
  assert (i = Z.log2_up b \/ Z.log2_up b < i) as C by blia. destruct C.
  - subst i. reflexivity.
  - eauto using testbit_above_signed'.
Qed.

Lemma mod0_testbit: forall a i p,
    a mod 2 ^ p = 0 ->
    0 <= i < p ->
    Z.testbit a i = false.
Proof.
  intros.
  rewrite Z.testbit_false by blia.
  pose proof (Zdiv.Zmod_divides a (2 ^ p)) as P.
  destruct P as [P _].
  - apply Z.pow_nonzero; blia.
  - specialize (P H). destruct P as [c P]. subst a. clear H.
    rewrite Z.mul_comm.
    rewrite Z.divide_div_mul_exact.
    + replace p with ((1 + (p - i - 1)) + i) by blia.
      rewrite Z.pow_add_r by blia.
      rewrite Z.div_mul by (apply Z.pow_nonzero; blia).
      rewrite Zdiv.Zmult_mod.
      rewrite Z.pow_add_r by blia.
      rewrite (Zdiv.Zmult_mod (2 ^ 1)).
      change (2 ^ 1 mod 2) with 0.
      rewrite Z.mul_0_l.
      change (0 mod 2) with 0.
      rewrite Z.mul_0_r.
      reflexivity.
    + apply Z.pow_nonzero; blia.
    + replace p with ((p - i) + i) by blia.
      rewrite Z.pow_add_r by blia.
      apply Z.divide_factor_r.
Qed.

Lemma mod0_testbit': forall a i m,
    a mod m = 0 ->
    m = 2 ^ Z.log2_up m ->
    0 <= i < Z.log2_up m ->
    Z.testbit a i = false.
Proof.
  intros. rewrite H0 in H.
  apply (mod0_testbit a i (Z.log2_up m)); assumption.
Qed.

Lemma mod20_testbit': forall a i,
    a mod 2 = 0 ->
    i = 0 ->
    Z.testbit a i = false.
Proof.
  intros. eapply mod0_testbit'.
  - eassumption.
  - reflexivity.
  - subst. cbv. intuition congruence.
Qed.

#[global] Hint Rewrite
    Z.lxor_spec
    Z.ldiff_spec
    Z.testbit_neg_r
    Z.setbit_eq
    Z.setbit_neq
    Z.testbit_0_l
    Z.land_spec
    Z.lor_spec
    Z.shiftr_spec
    Z.lnot_spec
    Z.shiftl_spec
    testbit_minus1
    Z.ones_spec_high
    Z.ones_spec_low
    testbit_if
    using blia
: rew_testbit.

#[global] Hint Rewrite
     testbit_above'
     testbit_above_signed'
(*   testbit_above_signed''  <-- TODO why does this one make proofs run forever? *)
     mod0_testbit'
     mod20_testbit'
     using (try eassumption; try reflexivity; rewrite? Z.log2_up_pow2 by blia; blia)
: rew_testbit_expensive.

Ltac rewrite_testbit :=
  repeat
    ((autorewrite with bool_rewriting) ||
     (rewrite_strat (repeat (topdown (hints rew_testbit)))) ||
     ((rewrite_strat (repeat (topdown (hints rew_testbit_expensive)))))).

Ltac compare_cases cst i :=
  tryif (first [assert (cst <= i) by blia | assert (i < cst) by blia])
  then fail
  else (let C := fresh "C" in
        assert (i < cst \/ cst <= i) as C by blia;
        safe_ring_simplify i in C;
        destruct C as [C | C]).

Ltac solve_or_split_step :=
    rewrite_testbit;
    (* Note: it would be nice if we could insert "try btauto" here
       to decide quickly if we can stop destructing and rewriting,
       but there are goals such as those generated by
       riscv.Proofs.EncodeBound.encode_SB_bitSlice_idemp where
       btauto runs forever. See https://github.com/coq/coq/issues/9832 *)
    try solve [f_equal; (reflexivity || blia)];
    match goal with
    | |- context [Z.testbit _ ?i] => compare_cases 0 i
    | |- context [Z.testbit (Z.ones ?sz) ?i] => compare_cases sz i
    end.

Ltac solve_or_split := repeat solve_or_split_step.

Ltac Zbitwise :=
  apply Z.bits_inj'; intros ?i ?Hi;
  solve_or_split;
  rewrite_testbit;
  try btauto.

Ltac prove_Zeq_bitwise_pre :=
  rewrite ?signExtend_alt_bitwise by blia; unfold signExtend_bitwise, bitSlice in *;
  subst;
  repeat match goal with
         | H: _ /\ _ |- _ => destruct H
         end;
  repeat match goal with
         | |- _ /\ _ => split
         end;
  repeat (discard_contradictory_or ltac:(first [discriminate | blia ])).

Ltac prove_Zeq_bitwise := prove_Zeq_bitwise_pre; Zbitwise.


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

From CoqEAL Require Import ssrcomplements minor dvdring.

Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic.

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

Local Open Scope ring_scope.

(* First some general lemmas *)
Section prelude.

Variable R : comRingType.

Lemma bareiss_key_lemma m d l (c : 'cV[R]_m) M :
  d ^+ m * \det (block_mx d%:M l c M) = d * \det (d *: M - c *m l).
Proof.
rewrite -[d ^+ m]mul1r -det_scalar -(det1 _ 1) -(det_ublock _ 0) -det_mulmx.
rewrite mulmx_block ?(mul0mx,addr0,add0r,mul1mx,mul_scalar_mx) -2![LHS]mul1r.
rewrite -{1}(@det1 _ 1) -{2}(@det1 _ m) mulrA -(@det_lblock _ _ _ _ (- c)).
rewrite -det_mulmx mulmx_block ?(mul1mx,mul0mx,addr0) addrC mul_mx_scalar.
by rewrite scalerN subrr det_ublock det_scalar1 addrC mulNmx.
Qed.

(* The key lemma of our proof: after simplification, all the k-minors *)
(* (involving 1st line/column) can be divided by (M 0 0)^k *)
Lemma bareiss_key_lemma_sub m n k d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n))
  (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n):
  d * (minor f1 f2 (d *: M - c *m l)) =
  d ^+ k * (minor (lift_pred f1) (lift_pred f2) (block_mx d%:M l c M)).
Proof.
by rewrite /minor submatrix_lift_block bareiss_key_lemma
  submatrix_add submatrix_scale submatrix_opp submatrix_mul.
Qed.

Lemma bareiss_block_key_lemma_sub m n k (M : 'M[R]_(1 + m,1 + n))
  (f : 'I_k -> 'I_m) (g : 'I_k -> 'I_n) :
  M 0 0 * (minor f g (M 0 0 *: drsubmx M - dlsubmx M *m ursubmx M)) =
  M 0 0 ^+ k * (minor (lift_pred f) (lift_pred g) M).
Proof.
rewrite /minor -{7}[M]submxK submatrix_add submatrix_scale submatrix_opp.
have -> : ulsubmx M = (M 0 0)%:M by apply/rowP=> i; rewrite ord1 !mxE !lshift0.
by rewrite submatrix_lift_block bareiss_key_lemma submatrix_mul.
Qed.

End prelude.

Require Import polydvd.

Module poly.
Section bareiss.

Variable R : comRingType.

Fixpoint bareiss_rec m (a : {poly R}) :
   'M[{poly R}]_(1 + m, 1 + m) -> {poly R} :=
  if m is p.+1 then
    fun M =>
      let d   := M 0 0 in
      let l   := ursubmx M in
      let c   := dlsubmx M in
      let N   := drsubmx M in
      let M'  := d *: N - c *m l in
      let M'' := map_mx (fun x => rdivp x a) M' in
      bareiss_rec d M''
  else fun M => M 0 0.

Definition bareiss n (M : 'M_(1 + n, 1 + n)) : {poly R} := bareiss_rec 1 M.

Definition bareiss_char_poly n (M : 'M_(1 + n, 1 + n)) : {poly R} :=
  bareiss (char_poly_mx M).

(* The actual determinant function based on Bareiss *)
Definition bdet n (M : 'M_(1 + n, 1 + n)) : R :=
  (bareiss_char_poly (- M))`_0.

End bareiss.

Section bareiss_correctness.

Variable R : comRingType.

Lemma bareiss_recE : forall m a (M : 'M[{poly R}]_(1 + m)),
  a \is monic ->
  (forall p (h h' : p < 1 + m), pminor h h' M \is monic) ->
  (forall k (f g : 'I_k.+1 -> 'I_m.+1), rdvdp (a ^+ k) (minor f g M)) ->
  a ^+ m * (bareiss_rec a M) = \det M.
Proof.
elim=> [a M _ _ _|m ih a M am hpm hdvd] /=.
  by rewrite expr0 mul1r {2}[M]mx11_scalar det_scalar1.
have ak_monic k : a ^+ k \is monic by apply/monic_exp.
set d := M 0 0; set M' := (_ - _); set M'' := map_mx _ _; rewrite /= in M' M'' *.
have d_monic : d \is monic.
  have -> // : d = pminor (ltn0Sn _) (ltn0Sn _) M.
  have h : widen_ord (ltn0Sn m.+1) =1 (fun=> 0)
    by move=> x; apply/ord_inj; rewrite [x]ord1.
  by rewrite /pminor (minor_eq h h) minor1.
have dk_monic : forall k, d ^+ k \is monic by move=> k; apply/monic_exp.
have hM' : M' = a *: M''.
  pose f := fun m (i : 'I_m) (x : 'I_2) => if x == 0 then 0 else lift 0 i.
  apply/matrixP => i j.
  rewrite !mxE big_ord1 !rshift1 [a * _]mulrC rdivpK ?(eqP am,expr1n,mulr1) //.
  move: (hdvd 1%nat (f _ i) (f _ j)).
  by rewrite !minor2 /f /= expr1 !mxE !lshift0 !rshift1.
rewrite -[M]submxK; apply/(@lregX _ d m.+1 (monic_lreg d_monic)).
have -> : matrix.ulsubmx M = d%:M by apply/rowP=> i; rewrite !mxE ord1 lshift0.
rewrite bareiss_key_lemma -/M' hM' detZ mulrCA [_ * (a ^+ _ * _)]mulrCA !exprS -!mulrA.
rewrite ih // => [p h h'|k f g].
  rewrite -(@monicMl _ (a ^+ p.+1)) // -detZ -submatrix_scale -hM'.
  rewrite -(monicMl _ d_monic) bareiss_block_key_lemma_sub monicMr //.
  by rewrite (minor_eq (lift_pred_widen_ord h) (lift_pred_widen_ord h')) hpm.
case/rdvdpP: (hdvd _ (lift_pred f) (lift_pred g)) => // x hx.
apply/rdvdpP => //; exists x.
apply/(@lregX _ _ k.+1 (monic_lreg am))/(monic_lreg d_monic).
rewrite -detZ -submatrix_scale -hM' bareiss_block_key_lemma_sub.
by rewrite mulrA [x * _]mulrC mulrACA -exprS [_ * x]mulrC -hx.
Qed.

Lemma bareissE n (M : 'M[{poly R}]_(1 + n))
  (H : forall p (h h' : p < 1 + n), pminor h h' M \is monic) :
  bareiss M = \det M.
Proof.
rewrite /bareiss -(@bareiss_recE n 1 M) ?monic1 ?expr1n ?mul1r //.
by move=> k f g; rewrite expr1n rdvd1p.
Qed.

Lemma bareiss_char_polyE n (M : 'M[R]_(1 + n)) :
  bareiss_char_poly M = char_poly M.
Proof.
rewrite /bareiss_char_poly bareissE // => p h h'.
exact: pminor_char_poly_mx_monic.
Qed.

Lemma bdetE n (M : 'M[R]_(1 + n)) : bdet M = \det M.
Proof.
rewrite /bdet bareiss_char_polyE char_poly_det.
by rewrite -scaleN1r detZ mulrA -expr2 sqrr_sign mul1r.
Qed.

End bareiss_correctness.
End poly.

Module dvdring.
Section Bareiss2.
Variable R: dvdRingType.

Definition dvd_step (m n:nat) (d: R) (M: 'M[R]_(m,n)) : 'M[R]_(m,n) :=
  map_mx (fun x => odflt 0 (x %/? d)) M.

(*
  determinant equality for division step
*)
Lemma det_dvd_step: forall n a (M: 'M[R]_n),
  (forall i j, a %| M i j) ->
  a^+n * \det (dvd_step a M) = \det M.
Proof.
rewrite /dvd_step => n a M hj.
rewrite -detZ; f_equal.
apply/matrixP => i j; rewrite !mxE.
case: odivrP=>[d|h] /=; first by rewrite mulrC.
case/dvdrP: (hj i j) => d hd.
by move: (h d); rewrite hd eqxx.
Qed.

Lemma det_dvd_step_tool : forall m n a (M N: 'M[R]_(m,n)),
  M = a *: N -> forall i j, a %| M i j.
Proof.
move => m n a M N /matrixP h i j.
rewrite (h i j) !mxE mulrC.
by apply/dvdr_mull/dvdrr.
Qed.

Let lreg := GRing.lreg.

(*
  some rewriting lemmas to make the main proof more clear
*)
Lemma blockE00 m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)):
   (block_mx d%:M l c M) 0 0 = d.
Proof.
rewrite !mxE.
case: splitP => x //; rewrite [x]ord1 {x} !mxE => _.
by case: splitP => x //; rewrite [x]ord1 {x} !mxE => _.
Qed.

Lemma blockE0i m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i:
  (block_mx d%:M l c M) 0 (lift 0 i) = (l 0 i).
Proof.
rewrite !mxE.
case: splitP => x //; rewrite [x]ord1 {x} !mxE => _.
case: splitP => x; first by rewrite [x]ord1.
by rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->.
Qed.

Lemma blockEi0 m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i:
  (block_mx d%:M l c M) (lift 0 i) 0 = (c i 0).
Proof.
rewrite !mxE.
case: splitP => x; first by rewrite [x]ord1.
rewrite /= /bump /leq0n => /eqP; rewrite eqSS => /eqP/ord_inj->.
rewrite !mxE.
by case: splitP => y //; rewrite [y]ord1 {y} => _.
Qed.

Lemma blockEij m n d (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)) i j:
  (block_mx d%:M l c M) (lift 0 i) (lift 0 j) = (M i j).
Proof.
rewrite !mxE.
case: splitP => x; first by rewrite [x]ord1.
rewrite /= /bump /leq0n => /eqP; rewrite eqSS =>  /eqP/ord_inj->.
rewrite !mxE.
case: splitP => y; first by rewrite [y]ord1.
by rewrite /= /bump /leq0n => /eqP; rewrite eqSS =>  /eqP/ord_inj->.
Qed.

(*
  main step of the proof
*)
Lemma sketch m n (a d: R) (l: 'rV[R]_n) (c: 'cV[R]_m) (M: 'M[R]_(m,n)):
 lreg a ->
 (forall (k:nat) (f1: 'I_k.+1 -> 'I_(1 + m)) (f2: 'I_k.+1 -> 'I_(1 + n)),
     a ^+ k %| minor f1 f2 (block_mx d%:M l c M))->
 (forall p (h: p.+1 <= 1 + m) (h': p.+1 <= 1 + n),
   lreg (pminor h h' (block_mx d%:M l c M))) ->
   let M' := d *: M - c *m l in
   let M'':= dvd_step a M' in
     [/\ lreg d,
       (forall k (f1: 'I_k.+1 -> 'I_m) (f2: 'I_k.+1 -> 'I_n),
         d ^+ k %| minor f1 f2 M''),
       M' = a *: M'' &
  (forall p (h: p.+1 <= m) (h': p.+1 <= n),
   lreg (pminor h h' M''))].
Proof.
rewrite /pminor => ha hM hN.
set M0 := block_mx d%:M l c M.
(* d is the 1x1 principal minor of M0 *)
have hh : d = minor (widen_ord (ltn0Sn _)) (widen_ord (ltn0Sn _)) M0.
- rewrite (@minor_eq _ _ _ _ _ (fun _ => 0) _ (fun _ => 0)) ?minor1 //.
  + by rewrite /M0 blockE00.
  + by move => x; rewrite ord1; apply: val_inj.
  + by move => x; rewrite ord1; apply: val_inj.
(* all principal minors of M0 are lreg, so M 0 0 is *)
have h2 : lreg d.
- by rewrite hh /M0; apply hN.
set M' := d *: M - c *m l.
set M'' := dvd_step a M'.
set f : forall m, 'I_m -> 'I_2 -> 'I_(1 + m) :=
  fun m (i: 'I_m) (x: 'I_2) => if x == 0 then 0 else (lift 0 i).
(*
  all elements of M' can be expressed as 2x2 minors of M,
  so a divide all these
*)
have h4 : forall i j, a %| M' i j.
- move => i j; rewrite /M' !mxE big_ord_recl big_ord0 addr0.
  move: (hM 1%nat (f _ i) (f _ j)). (* (hstrict _ i)). *)
  by rewrite !minor2 /f /= expr1 blockE00 blockEi0 blockE0i blockEij.
(*
  since a divides all M' i j, all the divisions are exact,
  and thus M' = a * M''
*)
have h6 : forall i j, M' i j = a * M'' i j.
- move => i j; rewrite [(dvd_step _ _) i j]mxE.
  case: odivrP => [dv|h] /=; first by rewrite mulrC.
  case/dvdrP: (h4 i j) => dv hdv.
  by move: (h dv); rewrite hdv eqxx.
have h6' : M' = a *: M'' by apply/matrixP => i j; rewrite h6 !mxE.
(*
  from this equality, we can have more information about the minors
  of M' and M''
*)
have h7 : forall k (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n),
    minor f1 f2 M' = a ^+ k * minor f1 f2 M''.
- move => k f1 f2.
  by rewrite h6' /minor submatrix_scale detZ.
(*
  using all theses, we can now prove our goals
*)
have h8: forall k (f1: 'I_k -> 'I_m) (f2: 'I_k -> 'I_n),
  d * minor f1 f2 M' =
    d ^+ k * minor (lift_pred f1) (lift_pred f2) M0.
- move => k f1 f2.
  by rewrite /M0 /M' bareiss_key_lemma_sub.
have ak : forall k, lreg (a^+k).
- by move => k; apply/lregX.
have h10 : forall k (f1: 'I_k.+1 -> 'I_m) (f2: 'I_k.+1 -> 'I_n),
  d ^+ k %| minor f1 f2 M''.
- move => k f1 f2.
  move/lregP : (ak k.+1) => ak'.
  rewrite -(@dvdr_mul2l _ (a^+k.+1)) // -h7.
  have hM0 : d != 0 by apply/lregP.
  have hMk : d^+ k.+1 != 0 by apply/lregP/lregX.
  rewrite -(@dvdr_mul2l _ d) // mulrA h8 //.
  by rewrite mulrAC -exprS dvdr_mul2l //.
split=> //.
rewrite -/M'' => p h h'.
apply/(@lregMl _ (a ^+ p.+1)).
rewrite -h7.
apply/(@lregMl _ d).
rewrite h8.
apply/lregM; first by apply/lregX.
rewrite (@minor_eq _ _ _ _ _ (widen_ord (size_tool h)) _
                             (widen_ord (size_tool h'))) ?hN.
- by apply: hN.
- by move => x; apply: val_inj; rewrite lift_pred_widen_ord.
- by move => x; apply: val_inj; rewrite lift_pred_widen_ord.
Qed.

(*
  formal definition of bareiss algorithm
*)
Fixpoint bareiss_rec m a : 'M[R]_(1 + m) -> R :=
  if m is p.+1 return 'M[R]_(1 + m) -> R then
    fun (M: 'M[R]_(1 + _)) =>
      let d   := M 0 0 in
      let l   := ursubmx M in
      let c   := dlsubmx M in
      let N   := drsubmx M in
      let M'  := d *: N - c *m l in
      let M'' := dvd_step a M' in
      bareiss_rec d M''
  else fun M => M 0 0.

(*
  from sketch, we can express the properties of bareiss
*)
Lemma bareiss_recE : forall m a (M: 'M[R]_(1 + m)),
    lreg a  ->
 (forall (k:nat) (f1 f2: 'I_k.+1 -> 'I_m.+1), a ^+ k %| minor f1 f2 M) ->
 (forall p  (h h' :p.+1 <= 1 + m),
   lreg (minor (widen_ord h) (widen_ord h') M)) ->
    a ^+ m * (bareiss_rec a M) = \det M.
Proof.
elim => [ | m hi] //=.
- move => a M ha h1 h2.
  by rewrite expr0 {2}[M]mx11_scalar det_scalar1 mul1r.
rewrite [(1 + m.+1)%nat]/(1 + (1 + m))%nat => a M ha.
set d := M 0 0.
set l := ursubmx M.
set c := dlsubmx M.
set N := drsubmx M.
have heq : block_mx (M 0 0)%:M (ursubmx M) (dlsubmx M) (drsubmx M) = M.
- have -> : (M 0 0)%:M = ulsubmx M
  by apply/matrixP => i j; rewrite !mxE [i]ord1 [j]ord1 {i j} !lshift0.
  by rewrite submxK.
rewrite -{1 2}heq => hM hm.
have : forall p (h h': p.+1 <= 1 + (1 + m)),
  lreg (minor (widen_ord h) (widen_ord h') M).
- rewrite -heq => p h h'.
  rewrite (@minor_eq _ _ _ _ _ (widen_ord h) _ (widen_ord h)) ?hm//.
  by move => x; apply/ord_inj.
case: (@sketch _ _ a (M 0 0) (ursubmx M) (dlsubmx M) (drsubmx M) ha hM hm)
 => hM00 h1 h2 h3 hlreg.
have h3' : forall p (h h': p < 1 + m),
  lreg (pminor h h' (dvd_step a (d *: N - c *m l)))
 by  move => p h h'; apply/h3.
move: (hi d (dvd_step a (d *: N - c *m l)) hM00 h1 h3').
set r := bareiss_rec _ _ => hh.
have : a ^+ m.+1 *( d ^+m * r) =
       a ^+ m.+1 * \det (dvd_step a (d *: N - c *m l)) by rewrite hh.
rewrite det_dvd_step //; last by
  move => i j; apply (det_dvd_step_tool h2).
move => heq2.
have hX : lreg (M 0 0 ^+ (1 + m)) by apply/lregX.
apply/hX.
rewrite -{3}heq bareiss_key_lemma -heq2 [M 0 0 ^+ (1 + m)]exprS -mulrA.
congr(_ * _).
by rewrite mulrCA.
Qed.

(*
  we start the algorithm with a = 1
*)
Definition bareiss (n: nat) (M: 'M[R]_(1 + n)) :=
  bareiss_rec 1 M.

Lemma bareissE : forall n (M: 'M[R]_(1 + n)),
 (forall p (h h': p.+1 <= 1 + n), lreg (pminor h h' M)) ->
  bareiss M = \det M.
Proof.
rewrite /bareiss => n M h.
have h1 : lreg (1: R) by apply/lreg1.
have h2 : forall (k:nat) (f1 f2: 'I_k.+1 -> 'I_n.+1),
     1 ^+ k %| minor f1 f2 M.
- by move => k f1 f2; rewrite expr1n dvd1r.
move: (bareiss_recE h1 h2 h).
by rewrite expr1n mul1r.
Qed.

End Bareiss2.

(*
  In practice, we apply this algorithm to the characteristic matrix
  so we get the characteristic polynomial in polynomial time
*)
Import PolyDvdRing.

Section bareiss_det.
Variable R: dvdRingType.

(*
  all principal minor of the characteristic matrix are monic
*)
Lemma pminor_char_poly_mx_monic: forall m p (M: 'M[R]_m) (h h': p.+1 <= m),
  pminor h h' (char_poly_mx M) \is monic.
Proof.
rewrite /pminor => m p M h h'.
rewrite (@minor_eq _ _ _ _ _ (widen_ord h) _ (widen_ord h)); first last.
- by apply: widen_ord_eq.
- by move => x.
rewrite /minor submatrix_char_poly_mx; last by apply: inj_widen_ord.
by apply/char_poly_monic.
Qed.

Definition char_poly_alt n (M: 'M[R]_(1 + n)) :=
  bareiss (char_poly_mx M).

(*
  Here is our alternative definition of char_poly
*)
Lemma char_poly_altE : forall n (M: 'M[R]_(1 + n)),
  char_poly_alt M = char_poly M.
Proof.
rewrite /char_poly_alt /char_poly => n M.
by rewrite bareissE // => p h h'; exact/monic_lreg/pminor_char_poly_mx_monic.
Qed.

(* The actual determinant function based on bareiss *)
Definition bdet n (M : 'M[R]_(1 + n)) := (char_poly_alt (-M))`_0.

Lemma bdetE : forall n (M : 'M[R]_(1 + n)), bdet M = \det M.
Proof.
move=> n M.
rewrite /bdet char_poly_altE char_poly_det.
have -> : - M = -1 *: M by apply/matrixP => i j; rewrite !mxE mulN1r.
by rewrite detZ mulrA -expr2 sqrr_sign mul1r.
Qed.

End bareiss_det.
End dvdring.


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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem2: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem2. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (rev (append x y))) (append (rev (rev x)) (rev (rev y))).
Proof.
  intros. lfind.
Admitted.