(*First theorem play *)
(* parametrized by set , proposition (truth value) *)
Theorem frobenius (A : Set) (p : A -> Prop) (q : Prop) :
  (exists x: A, q /\ p x) <-> (q /\ exists x : A , p x).
  (*there exists x in A such that q /\ p of x  (is the same thing) <=> as q and exists in A such that p of x*)

Proof.
  split. (* if and only if  =  implication both ways -> split to 2 subgoals*)
  intros. (*for implication/forall take hypothesis H*)
  destruct H as [y [H1 H2]]. (*destruct the hypothesis*)
  split.
  assumption.
  exists y.
  assumption.
  intros [H1 [y H2]].
  exists y.
  split.
  assumption.
  assumption.
  Qed.

(**)
Theorem frobenius2 (A : Set) (p : A -> Prop) (q : Prop) :
  (exists x: A, q /\ p x) <-> (q /\ exists x : A , p x).

Proof.
  split.
  intros.
  destruct H as [y [H1 H2]].
  split.
  assumption.
  exists y.
  assumption.
  intros [H1 [y H2]].
  exists y.
  auto.
  Qed.

Theorem frobenius3 (A : Set) (p : A -> Prop) (q : Prop) :
  (exists x: A, q /\ p x) <-> (q /\ exists x : A , p x).
  (*there exists x in A such that q /\ p of x  (is the same thing) <=> as q and exists in A such that p of x*)
Proof.
  split. (* if and only if  =  implication both ways -> split to 2 subgoals*)
  intros [y [H1 H2]]. (*for implication/forall take hypothesis H*)
  split.
  assumption.
  exists y.
  assumption.
  intros [H1 [y H2]].
  exists y.
  split; assumption.
  Qed.

(*First order logic*)
Theorem frobenius4 (A : Set) (p : A -> Prop) (q : Prop) :
  (exists x: A, q /\ p x) <-> (q /\ exists x : A , p x).
  (*there exists x in A such that q /\ p of x  (is the same thing) <=> as q and exists in A such that p of x*)
Proof.
  firstorder.
  Qed.

Check frobenius.
Print frobenius2.
Check frobenius4.

Save.


Require Import Bool PeanoNat Compare_dec Ascii List Lia.
Require Import Common.

Local Open Scope list.

Definition IdxT := list nat.

Definition ii: IdxT := nil.
Definition natToIdx (n: nat): IdxT := n :: nil.
Coercion natToIdx: nat >-> IdxT.

Definition idx_dec: forall (idx1 idx2: IdxT), {idx1 = idx2} + {idx1 <> idx2}.
Proof.
  intros.
  decide equality.
  apply Nat.eq_dec.
Defined.
Arguments idx_dec: simpl never.

Fixpoint idx_lt (idx1 idx2: IdxT): Prop :=
  match idx1 with
  | nil => match idx2 with
           | nil => False
           | _ => True
           end
  | e1 :: t1 =>
    match idx2 with
    | nil => False
    | e2 :: t2 =>
      if lt_dec e1 e2 then True
      else if lt_dec e2 e1 then False
           else idx_lt t1 t2
    end
  end.

Fixpoint idx_lt_dec (idx1 idx2: IdxT): {idx_lt idx1 idx2} + {~ idx_lt idx1 idx2}.
Proof.
  destruct idx1.
  - destruct idx2.
    + right; auto.
    + left; simpl; auto.
  - destruct idx2.
    + right; auto.
    + simpl.
      destruct (lt_dec n n0); auto.
      destruct (lt_dec n0 n); auto.
Defined.

Definition idx_total:
  forall idx1 idx2, idx1 <> idx2 -> idx_lt idx1 idx2 \/ idx_lt idx2 idx1.
Proof.
  induction idx1 as [|n1 idx1]; simpl; intros;
    [destruct idx2; [exfalso; auto|auto]|].

  destruct idx2 as [|n2 idx2]; [right; simpl; auto|].
  simpl; destruct (lt_dec n2 n1); [right; simpl; auto|].
  pose proof (Nat.lt_total n2 n1) as Ht.
  destruct Ht as [|[|]].
  - exfalso; auto.
  - subst.
    destruct (lt_dec n1 n1); [exfalso; lia|clear n0].
    apply IHidx1.
    intro Hx; subst; auto.
  - destruct (lt_dec n1 n2); auto.
Qed.

Definition idx_lt_trans:
  forall idx1 idx2 idx3: IdxT,
    idx_lt idx1 idx2 -> idx_lt idx2 idx3 -> idx_lt idx1 idx3.
Proof.
  induction idx1 as [|n1 idx1]; simpl; intros.
  - destruct idx2 as [|n2 idx2]; [exfalso; auto|].
    destruct idx3 as [|n3 idx3]; [inv H0|].
    auto.
  - destruct idx2 as [|n2 idx2]; [exfalso; auto|].
    destruct idx3 as [|n3 idx3]; [inv H0|].
    simpl in H0.
    destruct (lt_dec n1 n2).
    + destruct (lt_dec n2 n3).
      * destruct (lt_dec n1 n3); auto.
        exfalso; lia.
      * destruct (lt_dec n3 n2); [exfalso; auto|].
        destruct (lt_dec n1 n3); auto.
        exfalso; lia.
    + destruct (lt_dec n2 n3).
      * destruct (lt_dec n2 n1); [exfalso; auto|].
        destruct (lt_dec n1 n3); auto.
        exfalso; lia.
      * destruct (lt_dec n2 n1); [exfalso; auto|].
        destruct (lt_dec n3 n2); [exfalso; auto|].
        destruct (lt_dec n1 n3); auto.
        destruct (lt_dec n3 n1); [lia|].
        eapply IHidx1; eassumption.
Qed.

Definition idx_lt_not_eq:
  forall idx1 idx2: IdxT, idx_lt idx1 idx2 -> idx1 <> idx2.
Proof.
  intros.
  intro Hx; subst.
  induction idx2 as [|n2 idx2]; [inv H|].
  simpl in H.
  destruct (lt_dec n2 n2); [lia|auto].
Qed.

Definition Id (A: Type) := (IdxT * A)%type.

Definition idOf {A} (ida: Id A) := fst ida.
Definition valOf {A} (ida: Id A) := snd ida.
Definition idsOf {A} (ias: list (Id A)) := List.map fst ias.
Definition valsOf {A} (ias: list (Id A)) := List.map snd ias.

Definition liftI {A B: Type} (f: A -> B) (ida: Id A): Id B :=
  (idOf ida, f (valOf ida)).

Definition imap {A B: Type} (f: A -> B) (ias: list (Id A)): list (Id B) :=
  List.map (liftI f) ias.
Definition ifilterI {A} (ias: list (Id A)) (f: IdxT -> bool): list (Id A) :=
  filter (fun ia => f (idOf ia)) ias.
Definition ifilterV {A} (ias: list (Id A)) (f: A -> bool): list (Id A) :=
  filter (fun ia => f (valOf ia)) ias.

Definition id_dec {A} (a_dec: forall (a1 a2: A), {a1 = a2} + {a1 <> a2}):
  forall (ida1 ida2: Id A), {ida1 = ida2} + {ida1 <> ida2}.
Proof.
  intros.
  decide equality.
  apply idx_dec.
Defined.

Definition extendIdx (ext: nat) (idx: IdxT): IdxT :=
  ext :: idx.

Notation "i ~> e" :=
  (extendIdx e i) (at level 7, left associativity, format "i '~>' e").
Notation "i1 ~~ i2" :=
  (i2 ++ i1) (at level 8, right associativity, only parsing).

Definition extendInds (ext: nat) (inds: list IdxT): list IdxT :=
  map (extendIdx ext) inds.

Definition liftInds (ns: list nat): list IdxT :=
  map natToIdx ns.

Definition idxHd (idx: IdxT): nat :=
  List.hd 0 idx.
Definition idxTl (idx: IdxT): IdxT :=
  List.tl idx.

Definition IdxPrefix (i1 i2: IdxT) :=
  exists ri, i2 = ri ++ i1.
Infix "~<" := IdxPrefix (at level 8).

Definition IdxDisj (i1 i2: IdxT) :=
  ~ IdxPrefix i1 i2 /\ ~ IdxPrefix i2 i1.
Infix "~*~" := IdxDisj (at level 8).

Definition IndsDisj (is1 is2: list IdxT) :=
  forall i1 i2, In i1 is1 -> In i2 is2 -> i1 ~*~ i2.

Fixpoint idxPrefixR (i1 i2: IdxT): bool :=
  match i1 with
  | nil => true
  | n1 :: ti1 =>
    match i2 with
    | nil => false
    | n2 :: ti2 =>
      if Nat.eq_dec n1 n2 then idxPrefixR ti1 ti2 else false
    end
  end.

Definition idxPrefix (i1 i2: IdxT): bool :=
  idxPrefixR (rev i1) (rev i2).

Definition NoPrefix (il: list IdxT) :=
  forall n1 i1 n2 i2,
    n1 <> n2 ->
    nth_error il n1 = Some i1 ->
    nth_error il n2 = Some i2 ->
    i1 ~*~ i2.


From Hammer Require Import Hammer.

Require Import BinInt.

Open Scope Z_scope.

Definition Zeven (z:Z) :=
match z with
| Z0 => True
| Zpos (xO _) => True
| Zneg (xO _) => True
| _ => False
end.

Definition Zodd (z:Z) :=
match z with
| Zpos xH => True
| Zneg xH => True
| Zpos (xI _) => True
| Zneg (xI _) => True
| _ => False
end.

Lemma Zeven_equiv z : Zeven z <-> Z.Even z.
Proof. hammer_hook "Zeven" "Zeven.Zeven_equiv".
rewrite <- Z.even_spec.
destruct z as [|p|p]; try destruct p; simpl; intuition.
Qed.

Lemma Zodd_equiv z : Zodd z <-> Z.Odd z.
Proof. hammer_hook "Zeven" "Zeven.Zodd_equiv".
rewrite <- Z.odd_spec.
destruct z as [|p|p]; try destruct p; simpl; intuition.
Qed.

Theorem Zeven_ex_iff n : Zeven n <-> exists m, n = 2*m.
Proof. hammer_hook "Zeven" "Zeven.Zeven_ex_iff".  exact ((Zeven_equiv n)). Qed.

Theorem Zodd_ex_iff n : Zodd n <-> exists m, n = 2*m + 1.
Proof. hammer_hook "Zeven" "Zeven.Zodd_ex_iff".  exact ((Zodd_equiv n)). Qed.

Notation Zeven_bool := Z.even (compat "8.3").
Notation Zodd_bool := Z.odd (compat "8.3").

Lemma Zeven_bool_iff n : Z.even n = true <-> Zeven n.
Proof. hammer_hook "Zeven" "Zeven.Zeven_bool_iff".
now rewrite Z.even_spec, Zeven_equiv.
Qed.

Lemma Zodd_bool_iff n : Z.odd n = true <-> Zodd n.
Proof. hammer_hook "Zeven" "Zeven.Zodd_bool_iff".
now rewrite Z.odd_spec, Zodd_equiv.
Qed.

Ltac boolify_even_odd := rewrite <- ?Zeven_bool_iff, <- ?Zodd_bool_iff.

Lemma Zodd_even_bool n : Z.odd n = negb (Z.even n).
Proof. hammer_hook "Zeven" "Zeven.Zodd_even_bool".
symmetry. apply Z.negb_even.
Qed.

Lemma Zeven_odd_bool n : Z.even n = negb (Z.odd n).
Proof. hammer_hook "Zeven" "Zeven.Zeven_odd_bool".
symmetry. apply Z.negb_odd.
Qed.

Definition Zeven_odd_dec n : {Zeven n} + {Zodd n}.
Proof. hammer_hook "Zeven" "Zeven.Zeven_odd_dec".
destruct n as [|p|p]; try destruct p; simpl; (now left) || (now right).
Defined.

Definition Zeven_dec n : {Zeven n} + {~ Zeven n}.
Proof. hammer_hook "Zeven" "Zeven.Zeven_dec".
destruct n as [|p|p]; try destruct p; simpl; (now left) || (now right).
Defined.

Definition Zodd_dec n : {Zodd n} + {~ Zodd n}.
Proof. hammer_hook "Zeven" "Zeven.Zodd_dec".
destruct n as [|p|p]; try destruct p; simpl; (now left) || (now right).
Defined.

Lemma Zeven_not_Zodd n : Zeven n -> ~ Zodd n.
Proof. hammer_hook "Zeven" "Zeven.Zeven_not_Zodd".
boolify_even_odd. rewrite <- Z.negb_odd. destruct Z.odd; intuition.
Qed.

Lemma Zodd_not_Zeven n : Zodd n -> ~ Zeven n.
Proof. hammer_hook "Zeven" "Zeven.Zodd_not_Zeven".
boolify_even_odd. rewrite <- Z.negb_odd. destruct Z.odd; intuition.
Qed.

Lemma Zeven_Sn n : Zodd n -> Zeven (Z.succ n).
Proof. hammer_hook "Zeven" "Zeven.Zeven_Sn".
boolify_even_odd. now rewrite Z.even_succ.
Qed.

Lemma Zodd_Sn n : Zeven n -> Zodd (Z.succ n).
Proof. hammer_hook "Zeven" "Zeven.Zodd_Sn".
boolify_even_odd. now rewrite Z.odd_succ.
Qed.

Lemma Zeven_pred n : Zodd n -> Zeven (Z.pred n).
Proof. hammer_hook "Zeven" "Zeven.Zeven_pred".
boolify_even_odd. now rewrite Z.even_pred.
Qed.

Lemma Zodd_pred n : Zeven n -> Zodd (Z.pred n).
Proof. hammer_hook "Zeven" "Zeven.Zodd_pred".
boolify_even_odd. now rewrite Z.odd_pred.
Qed.

Hint Unfold Zeven Zodd: zarith.

Notation Zeven_bool_succ := Z.even_succ (compat "8.3").
Notation Zeven_bool_pred := Z.even_pred (compat "8.3").
Notation Zodd_bool_succ := Z.odd_succ (compat "8.3").
Notation Zodd_bool_pred := Z.odd_pred (compat "8.3").

Notation Zdiv2 := Z.div2 (compat "8.3").
Notation Zquot2 := Z.quot2 (compat "8.3").

Lemma Zdiv2_odd_eqn n : n = 2*(Z.div2 n) + if Z.odd n then 1 else 0.
Proof. hammer_hook "Zeven" "Zeven.Zdiv2_odd_eqn".  exact ((Z.div2_odd n)). Qed.

Lemma Zeven_div2 n : Zeven n -> n = 2 * Z.div2 n.
Proof. hammer_hook "Zeven" "Zeven.Zeven_div2".
boolify_even_odd. rewrite <- Z.negb_odd, Bool.negb_true_iff.
intros Hn. rewrite (Zdiv2_odd_eqn n) at 1. now rewrite Hn, Z.add_0_r.
Qed.

Lemma Zodd_div2 n : Zodd n -> n = 2 * Z.div2 n + 1.
Proof. hammer_hook "Zeven" "Zeven.Zodd_div2".
boolify_even_odd.
intros Hn. rewrite (Zdiv2_odd_eqn n) at 1. now rewrite Hn.
Qed.

Lemma Zquot2_odd_eqn n : n = 2*(Z.quot2 n) + if Z.odd n then Z.sgn n else 0.
Proof. hammer_hook "Zeven" "Zeven.Zquot2_odd_eqn".
now destruct n as [ |[p|p| ]|[p|p| ]].
Qed.

Lemma Zeven_quot2 n : Zeven n -> n = 2 * Z.quot2 n.
Proof. hammer_hook "Zeven" "Zeven.Zeven_quot2".
intros Hn. apply Zeven_bool_iff in Hn.
rewrite (Zquot2_odd_eqn n) at 1.
now rewrite Zodd_even_bool, Hn, Z.add_0_r.
Qed.

Lemma Zodd_quot2 n : n >= 0 -> Zodd n -> n = 2 * Z.quot2 n + 1.
Proof. hammer_hook "Zeven" "Zeven.Zodd_quot2".
intros Hn Hn'. apply Zodd_bool_iff in Hn'.
rewrite (Zquot2_odd_eqn n) at 1. rewrite Hn'. f_equal.
destruct n; (now destruct Hn) || easy.
Qed.

Lemma Zodd_quot2_neg n : n <= 0 -> Zodd n -> n = 2 * Z.quot2 n - 1.
Proof. hammer_hook "Zeven" "Zeven.Zodd_quot2_neg".
intros Hn Hn'. apply Zodd_bool_iff in Hn'.
rewrite (Zquot2_odd_eqn n) at 1; rewrite Hn'. unfold Z.sub. f_equal.
destruct n; (now destruct Hn) || easy.
Qed.

Lemma Zquot2_opp n : Z.quot2 (-n) = - Z.quot2 n.
Proof. hammer_hook "Zeven" "Zeven.Zquot2_opp".
now destruct n as [ |[p|p| ]|[p|p| ]].
Qed.

Lemma Zquot2_quot n : Z.quot2 n = n ÷ 2.
Proof. hammer_hook "Zeven" "Zeven.Zquot2_quot".
assert (AUX : forall m, 0 < m -> Z.quot2 m = m ÷ 2).
{
intros m Hm.
apply Z.quot_unique with (if Z.odd m then Z.sgn m else 0).
now apply Z.lt_le_incl.
rewrite Z.sgn_pos by trivial.
destruct (Z.odd m); now split.
apply Zquot2_odd_eqn.
}
destruct (Z.lt_trichotomy 0 n) as [POS|[NUL|NEG]].
- now apply AUX.
- now subst.
- apply Z.opp_inj. rewrite <- Z.quot_opp_l, <- Zquot2_opp.
apply AUX. now destruct n. easy.
Qed.

Lemma Z_modulo_2 n : {y | n = 2 * y} + {y | n = 2 * y + 1}.
Proof. hammer_hook "Zeven" "Zeven.Z_modulo_2".
destruct (Zeven_odd_dec n) as [Hn|Hn].
- left. exists (Z.div2 n). exact (Zeven_div2 n Hn).
- right. exists (Z.div2 n). exact (Zodd_div2 n Hn).
Qed.

Lemma Zsplit2 n :
{p : Z * Z | let (x1, x2) := p in n = x1 + x2 /\ (x1 = x2 \/ x2 = x1 + 1)}.
Proof. hammer_hook "Zeven" "Zeven.Zsplit2".
destruct (Z_modulo_2 n) as [(y,Hy)|(y,Hy)];
rewrite <- Z.add_diag in Hy.
- exists (y, y). split. assumption. now left.
- exists (y, y + 1). split. now rewrite Z.add_assoc. now right.
Qed.

Theorem Zeven_ex n : Zeven n -> exists m, n = 2 * m.
Proof. hammer_hook "Zeven" "Zeven.Zeven_ex".
exists (Z.div2 n); apply Zeven_div2; auto.
Qed.

Theorem Zodd_ex n : Zodd n -> exists m, n = 2 * m + 1.
Proof. hammer_hook "Zeven" "Zeven.Zodd_ex".
exists (Z.div2 n); apply Zodd_div2; auto.
Qed.

Theorem Zeven_2p p : Zeven (2 * p).
Proof. hammer_hook "Zeven" "Zeven.Zeven_2p".
now destruct p.
Qed.

Theorem Zodd_2p_plus_1 p : Zodd (2 * p + 1).
Proof. hammer_hook "Zeven" "Zeven.Zodd_2p_plus_1".
destruct p as [|p|p]; now try destruct p.
Qed.

Theorem Zeven_plus_Zodd a b : Zeven a -> Zodd b -> Zodd (a + b).
Proof. hammer_hook "Zeven" "Zeven.Zeven_plus_Zodd".
boolify_even_odd. rewrite <- Z.negb_odd, Bool.negb_true_iff.
intros Ha Hb. now rewrite Z.odd_add, Ha, Hb.
Qed.

Theorem Zeven_plus_Zeven a b : Zeven a -> Zeven b -> Zeven (a + b).
Proof. hammer_hook "Zeven" "Zeven.Zeven_plus_Zeven".
boolify_even_odd. intros Ha Hb. now rewrite Z.even_add, Ha, Hb.
Qed.

Theorem Zodd_plus_Zeven a b : Zodd a -> Zeven b -> Zodd (a + b).
Proof. hammer_hook "Zeven" "Zeven.Zodd_plus_Zeven".
intros. rewrite Z.add_comm. now apply Zeven_plus_Zodd.
Qed.

Theorem Zodd_plus_Zodd a b : Zodd a -> Zodd b -> Zeven (a + b).
Proof. hammer_hook "Zeven" "Zeven.Zodd_plus_Zodd".
boolify_even_odd. rewrite <- 2 Z.negb_even, 2 Bool.negb_true_iff.
intros Ha Hb. now rewrite Z.even_add, Ha, Hb.
Qed.

Theorem Zeven_mult_Zeven_l a b : Zeven a -> Zeven (a * b).
Proof. hammer_hook "Zeven" "Zeven.Zeven_mult_Zeven_l".
boolify_even_odd. intros Ha. now rewrite Z.even_mul, Ha.
Qed.

Theorem Zeven_mult_Zeven_r a b : Zeven b -> Zeven (a * b).
Proof. hammer_hook "Zeven" "Zeven.Zeven_mult_Zeven_r".
intros. rewrite Z.mul_comm. now apply Zeven_mult_Zeven_l.
Qed.

Theorem Zodd_mult_Zodd a b : Zodd a -> Zodd b -> Zodd (a * b).
Proof. hammer_hook "Zeven" "Zeven.Zodd_mult_Zodd".
boolify_even_odd. intros Ha Hb. now rewrite Z.odd_mul, Ha, Hb.
Qed.

Close Scope Z_scope.


Require Import Coq.Lists.List.
Require Import Coq.Lists.ListSet.

Definition DecidableEquality A :=
  forall (x y : A), {x = y} + {x <> y}.

Definition
  all_Type A (A_eq_dec : DecidableEquality A) (P : A -> Type) (xs:set A)
  := forall (x:A),  set_In x xs -> P x.

Lemma all_nil_Type:
  forall A eq_dec P,
    all_Type A eq_dec P nil.
Proof.
 unfold all_Type.
 intros.
 simpl in H.
 contradiction.
Qed.

Lemma all_Type_cons_fwd:
  forall A eq_dec P (a:A) xs,
    (P a * all_Type _ eq_dec P xs)%type
    -> all_Type _ eq_dec P (a :: xs).
Proof.
 intros A eq_dec P a xs X.
 destruct X.
 unfold all_Type in *.
 intros x H.
 simpl in H.
 destruct (eq_dec a x).
  congruence.
 apply a0.
 destruct H; easy.
Qed.

(* Add LoadPath "../Listkit" as Listkit. *)

Require Import Sets. (* Consider NOT doing this. *)

Lemma all_Type_incl:
  forall A eq_dec f smaller bigger,
    incl_sets A smaller bigger ->
    all_Type _ eq_dec f bigger ->
    all_Type _ eq_dec f smaller.
Proof.
 unfold all_Type.
 unfold incl_sets.
 intuition.
Qed.

Lemma all_map_Type:
  forall A eq_dec P f (xs : set A),
    (all_Type _ eq_dec P (set_map eq_dec f xs))
    -> (all_Type _ eq_dec (fun x => P (f x)) xs).
Proof.
 intros ? ? ? ? ? H.
 unfold all_Type in *.
 intros.
 pose (H1:=H (f x)).
 apply H1.
 apply set_map_intro; auto.
Qed.

Lemma all_cut_Type :
  forall A eq_dec P Q xs,
    (forall x, set_In x xs -> P x -> Q x) ->
    all_Type A eq_dec P xs ->
    all_Type A eq_dec Q xs.
Proof.
 unfold all_Type in *.
 intros.
 apply X; auto.
Qed.

Lemma In_add_intro:
  forall A eq_dec (x y:A) xs,
  ({x = y}+{In x xs}) -> In x (set_add eq_dec y xs).
Proof.
 intros.
 induction xs.
  destruct H.
   subst y.
   apply in_eq.
  elimtype False.
  auto.
 simpl.
 destruct (eq_dec y a); subst.
  destruct H; subst.
   apply in_eq.
  auto.
 destruct H; subst.
 apply in_cons.
 auto.
 apply in_inv in i.
 destruct i.
  subst; apply in_eq.
 apply in_cons.
 apply IHxs.
 right; auto.
Qed.

(* Fucking classical Prop!!! *)
Lemma In_add_elim:
  forall A eq_dec (x y:A) xs,
    In x (set_add eq_dec y xs) ->
    (* ({x = y}+{In x xs}). *)
    (x = y \/ In x xs).
Proof.
 intros.
 induction xs.
  simpl in *.
  intuition.
 simpl in *.
 destruct (eq_dec y a); subst.
  intuition.
 destruct H; subst; intuition.
Qed.

Lemma all_Type_add_fwd:
  forall A eq_dec P (a:A) xs,
    (P a * all_Type _ eq_dec P xs)%type
    -> all_Type _ eq_dec P (set_add eq_dec a xs).
Proof.
 intuition.
 unfold all_Type.
 intros.
 apply Lists.ListSet.set_add_elim in H.
 destruct (eq_dec x a).
 subst; auto.
 assert (set_In x xs) by tauto.
 auto.
Qed.

(* Lemma all_Type_add_rev: *)
(*   forall A eq_dec P (a:A) xs, *)
(*     all_Type _ eq_dec P (set_add eq_dec a xs) *)
(*     -> (P a * all_Type _ eq_dec P xs)%type. *)
(* Proof. *)
(*  unfold all_Type. *)
(*  intros. *)
(*  (* TODO: It seems strange that I have to declare this intermediate result. *)
(*     I want to just throw all_Type_set_In_bwd at X and be done. *) *)
(*  assert (X0 : forall x, set_In x (set_add eq_dec a xs) -> P x). *)
(*   apply all_Type_set_In_bwd with eq_dec; auto. *)
(*  split. *)
(*   apply X0. *)
(*   apply set_add_intro. *)
(*   auto. *)
(*  apply all_Type_set_In_fwd. *)
(*  intros. *)
(*  apply X0. *)
(*  apply set_add_intro1; auto. *)
(* Qed. *)

Lemma all_Type_nil:
  forall A eq_dec P, all_Type A eq_dec P nil.
Proof.
 unfold all_Type.
 simpl.
 easy.
Qed.

Hint Resolve all_Type_nil.

Lemma Interesting_Lemma:
  forall A (eq_dec : DecidableEquality A) (x:A) xs,
    {set_In x xs} + {~set_In x xs}.
Proof.
 induction xs.
  intuition.
 destruct IHxs.
 left.
 simpl.
 auto.
 simpl.
 destruct (eq_dec a x).
  intuition.
 intuition.
Qed.

Lemma all_Type_union_fwd:
  forall A eq_dec pred xs ys,
    (all_Type A eq_dec pred xs * all_Type A eq_dec pred ys) ->
    all_Type A eq_dec pred (set_union eq_dec xs ys) .
Proof.
 intros ? ? ? ? ? [H0 H1].
 unfold all_Type in *.
 intros.
 apply set_union_elim in H.
 pose (Interesting_Lemma _ eq_dec x xs).
 destruct s.
 auto.
 assert (set_In x ys) by tauto.
 auto.
Qed.

Ltac sufficient H :=
  cut H; [solve[auto] | ].

Lemma all_Type_union_rev:
  forall A eq_dec pred xs ys,
    all_Type A eq_dec pred (set_union eq_dec xs ys) ->
    (all_Type A eq_dec pred xs * all_Type A eq_dec pred ys).
Proof.
 unfold all_Type.
 intros ? ? ? ? ? H.
 sufficient (forall x, (set_In x xs \/ set_In x ys) -> pred x).
 intros.
 auto.
Qed.

(* Lemma all_Type_union: *)
(*   forall A eq_dec P xs ys, *)
(*     all_Type A eq_dec P xs -> *)
(*     all_Type A eq_dec P ys -> *)
(*     all_Type A eq_dec P (set_union eq_dec xs ys). *)
(* Admitted. *)

(* Lemma all_Type_remove: *)
(*   forall A dec_eq (pred:A->Type) x xs, *)
(*     all_Type A dec_eq (fun y => sumor (y = x) (~ notT(pred y))) xs *)
(*     -> all_Type A dec_eq pred (set_remove _ dec_eq x xs). *)
(* Proof. *)
(*  induction xs; simpl; intros. *)
(*   unfold all_Type; simpl. *)
(*   intros. *)
(*   discriminate. *)
(*  unfold all_Type in X. *)
(* unfold set_mem in X. *)
(*  pose (H := X a). *)
(*  destruct (dec_eq x a). *)
(* Admitted. *)

Lemma all_Type_universal:
  forall A eq_dec pred xs,
    (forall x, pred x) -> all_Type A eq_dec pred xs.
Proof.
 induction xs; unfold all_Type; simpl; intros; auto.
Qed.

Lemma all_Type_filter : forall A eq_dec P P' xs,
                (forall x:A, true = P' x -> P x) ->
                all_Type _ eq_dec P (set_filter _ P' xs).
 intros.
 unfold all_Type.
 intros x H0.
 apply set_filter_elim in H0.
 intuition.
Qed.


(** * RandomList.v : pick uniformely an element in a list *)
(** Contributed by David Baelde, 2011 *)

(* begin hide *)
Add Rec LoadPath "." as ALEA.

Set Implicit Arguments.
Require Export Prog.
Require Export List.

Open Scope U_scope.
(* end hide *)

Fixpoint choose A (l : list A) : distr A :=
  match l with
    | nil => distr_null A
    | cons hd tl => Mchoice ([1/](length l)) (Munit hd) (choose tl)
  end.

Lemma choose_uniform : forall A (d : A) (l : list A) f,
  mu (choose l) f == sigma (fun i => ([1/](length l)) * f (nth i l d)) (length l).
Proof.
  intros A d l f; induction l.
  reflexivity.
  simpl choose; rewrite Mchoice_simpl.
  rewrite Munit_simpl.
  simpl nth; simpl length; rewrite sigma_S_lift.
  apply Uplus_eq_compat; auto.
  rewrite IHl.
  rewrite <- sigma_mult; auto.
  apply sigma_eq_compat; intros.
  rewrite Umult_assoc; apply Umult_eq_compat; auto.
  rewrite <- Nmult_n_Unth.
  rewrite <- Nmult_Umult_assoc_left; auto.
  rewrite Nmult_Umult_assoc_right; auto.
  rewrite Nmult_n_Unthp; try omega.
  auto.
Qed.

Lemma In_nth : forall A (x:A) l, In x l -> exists i, (i < length l)%nat /\ nth i l x = x.
Proof.
  induction l; intros.
  destruct H.
  destruct (in_inv H).
  exists 0%nat; split.
  simpl; auto with arith.
  rewrite H0; reflexivity.
  destruct (IHl H0) as (j,(H1,H2)).
  exists (S j); split.
  simpl; auto with arith.
  auto.
Qed.

Lemma choose_le_Nnth :
  forall A (l:list A) x f alpha,
    In x l ->
    alpha <= f x ->
    [1/](length l) * alpha <= mu (choose l) f.
Proof.
  intros.
  rewrite (choose_uniform x).
  destruct (In_nth x l H) as (i,(H1,H2)).
  transitivity ([1/](length l) * f (nth i l x)).
  rewrite H2; auto.
  pose (F := fun i0 : nat => [1/]length l * f (nth i0 l x)).
  change (F i <= sigma F (length l)).
  apply sigma_le.
  assumption.
Qed.

(** ** List containing elements from [0] to [n] *)

Fixpoint lrange n := match n with
  | O => cons O nil
  | S m => cons (S m) (lrange m)
end.

Lemma range_len : forall n, length (lrange n) = S n.
Proof.
  intro n; induction n.
  reflexivity.
  simpl.
  rewrite IHn; reflexivity.
Qed.

Lemma leq_in_range : forall n x, (x<=n)%nat -> In x (lrange n).
Proof.
  intro n; induction n; intros.
  assert (x=O) by omega.
  rewrite H0; simpl; auto.
  assert (x = S n \/ x <= n)%nat by omega.
  destruct H0.
  rewrite H0; simpl; auto.
  change (lrange (S n)) with (cons (S n) (lrange n)).
  apply in_cons.
  apply IHn.
  assumption.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.

Variable defparallelogram_1 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_2 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable lemma_parallelsymmetric_3 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).
Variable lemma_parallelflip_4 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).

Theorem lemma_PGrotate_5 : (forall A B C D : Universe, (pG_ A B C D -> pG_ B C D A)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                                                                          *)
(*   Computation of the BDT of the function defined by a boolean expression *)
(*                                                                          *)
(*                                                                          *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                             Formula_to_BDT.v                             *)
(****************************************************************************)

Require Import Prelude_BDT.
Require Import CanonBDDs.rauzy.algorithme1.Boolean_functions.
Require Import CanonBDDs.rauzy.algorithme1.BDTs.
Require Import Inductions.

(*-------------- Boolean expressions ---------------*)

Inductive Bool_exp : Set :=
  | Tr : Bool_exp
  | Fa : Bool_exp
  | Var : forall i : nat, i > 0 -> Bool_exp
  | ANd : Bool_exp -> Bool_exp -> Bool_exp
  | Or : Bool_exp -> Bool_exp -> Bool_exp
  | Not : Bool_exp -> Bool_exp.

(*-----------  Boolean function defined by a boolean expression  ---------*)

Definition Fun_Bexp (E : Bool_exp) : BF :=
  (fix F (b : Bool_exp) : BF :=
     match b with
     | Tr => TRUE
     | Fa => FALSE
     | Var i _ => Boolean_functions.F i
     | ANd b0 b1 => AND (F b0) (F b1)
     | Or b0 b1 => OR (F b0) (F b1)
     | Not b0 => NOT (F b0)
     end) E.
(* Tr *)
(* Fa *)
(* Var(i,p)   *)
(* And(e1,e2) *)
(* Or(e1,e2)  *)
(* Not(e)     *)

(*-----------     Shannon tree of a boolean expression *)

Definition Sh_tree_of (E : Bool_exp) (bdt : BDT) : Prop :=
  OBDT bdt /\ BF_eq (Fun_Bexp E) (Fun bdt).

(*                 Binary boolean operators on BDTs                    *)

Lemma Op2_BDT_overloaded :
 forall Op : BF -> BF -> BF,
 Boolean Op ->
 forall b1 : BDT,
 OBDT b1 ->
 forall b2 : BDT,
 OBDT b2 ->
 Dim b1 > 0 ->
 Dim b2 > 0 ->
 forall i : nat,
 i = Maxdim b1 b2 ->
 (forall b : bool,
  {bb : BDT |
  OBDT bb /\
  Dim bb <= Maxdim (Choice b1 i b) (Choice b2 i b) /\
  BF_eq (Fun bb) (Op (Fun (Choice b1 i b)) (Fun (Choice b2 i b)))}) ->
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Maxdim b1 b2 /\ BF_eq (Fun b3) (Op (Fun b1) (Fun b2))}.
Proof.
intros Op H_Op b1 H1 b2 H2 Hdim1 Hdim2 i Def_i H.
elim (H true).
intro bh; simple induction 1; intro bh_ordered; simple induction 1;
 intros Sup_dimh Fbh_correct.
elim (H false).
intro bl; simple induction 1; intro bl_ordered; simple induction 1;
 intros Sup_diml Fbl_correct.
clear H3 H0 H.
(* Elimination of non dependent variables in the BDT *)
elim (eq_BDT_decidable bh bl).
   (* Case bh = bl *)
intro bh_eq_bl.
exists bh.
split; try assumption.
split.
apply gt_le_weak.
apply gt_le_trans with (m := Maxdim (Choice b1 i true) (Choice b2 i true));
 [ elim Def_i; apply Measure_decrease; assumption | assumption ].
apply BF_eq_trans with (f2 := IF F i then Fun bh else Fun bh);
 try apply eq_f_iff.
pattern bh at 2 in |- *.
replace bh with bl.
apply Corr_hl_Corr_node; assumption.
   (* Case bh =/= bl *)
intro bh_neq_bl.
exists (Node i bh bl).
split.
apply order_node; try assumption; rewrite Def_i.
apply gt_le_trans with (Maxdim (Choice b1 i true) (Choice b2 i true));
 try assumption; elim Def_i; apply Measure_decrease;
 assumption.
apply gt_le_trans with (Maxdim (Choice b1 i false) (Choice b2 i false));
 try assumption; elim Def_i; apply Measure_decrease;
 assumption.
split; simpl in |- *.
rewrite Def_i; auto with arith.
apply Corr_hl_Corr_node; assumption.
Qed.

Lemma And_BDT_Zero_b2 :
 forall b2 : BDT,
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Dim b2 /\ BF_eq (Fun b3) (AND (Fun Zero) (Fun b2))}.
Proof.
intro b2.
exists Zero; auto with arith.
Qed.

Lemma And_BDT_One_b2 :
 forall b2 : BDT,
 OBDT b2 ->
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Dim b2 /\ BF_eq (Fun b3) (AND (Fun One) (Fun b2))}.
Proof.
intros b2 H2.
exists b2; auto with arith.
Qed.

Lemma And_BDT_b1_Zero :
 forall b1 : BDT,
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Dim b1 /\ BF_eq (Fun b3) (AND (Fun b1) (Fun Zero))}.
Proof.
intro b1.
exists Zero.
split; try split; auto with arith.
apply BF_eq_trans with (f2 := AND FALSE (Fun b1)); try apply Commutative_AND;
 auto with arith.
Qed.

Lemma And_BDT_b1_One :
 forall b1 : BDT,
 OBDT b1 ->
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Dim b1 /\ BF_eq (Fun b3) (AND (Fun b1) (Fun One))}.
Proof.
intros b1 H1.
exists b1.
split; try split; auto with arith.
simpl in |- *.
apply BF_eq_trans with (f2 := AND TRUE (Fun b1)); try apply Commutative_AND;
 auto with arith.
Qed.

Lemma And_BDT_overloaded :
 forall b1 : BDT,
 OBDT b1 ->
 forall b2 : BDT,
 OBDT b2 ->
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Maxdim b1 b2 /\ BF_eq (Fun b3) (AND (Fun b1) (Fun b2))}.
Proof.
intros b1 H1 b2 H2.
pattern b1, b2 in |- *; apply Induction1 with (b1 := b1) (b2 := b2);
 try assumption.
clear H1 b1 H2 b2; intros b2 H2.
unfold Maxdim in |- *; elim (le_Max (Dim Zero) (Dim b2));
 [ exact (And_BDT_Zero_b2 b2) | auto with arith ].
clear H1 b1 H2 b2; intros b2 H2.
unfold Maxdim in |- *; elim (le_Max (Dim One) (Dim b2));
 [ exact (And_BDT_One_b2 b2 H2) | auto with arith ].
clear H1 b1 H2 b2; intros b1 H1.
unfold Maxdim in |- *; elim Max_sym; elim (le_Max (Dim Zero) (Dim b1));
 [ exact (And_BDT_b1_Zero b1) | auto with arith ].
clear H1 b1 H2 b2; intros b1 H1.
unfold Maxdim in |- *; elim Max_sym; elim (le_Max (Dim One) (Dim b1));
 [ exact (And_BDT_b1_One b1 H1) | auto with arith ].
clear H1 b1 H2 b2; intros b1 b2 HO1 HD1 HO2 HD2.
intros i Def_i Htrue Hfalse.
apply Op2_BDT_overloaded with i; auto with arith.
simple induction b; assumption.
Qed.

Lemma And_BDT :
 forall b1 : BDT,
 OBDT b1 ->
 forall b2 : BDT,
 OBDT b2 -> {b3 : BDT | OBDT b3 /\ BF_eq (Fun b3) (AND (Fun b1) (Fun b2))}.
Proof.
intros b1 H1 b2 H2.
elim (And_BDT_overloaded b1 H1 b2 H2).
intro b3.
intro H; elim H; intro H3.
simple induction 1.
exists b3; auto with arith.
Qed.

Lemma Or_BDT_Zero_b2 :
 forall b2 : BDT,
 OBDT b2 ->
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Dim b2 /\ BF_eq (Fun b3) (OR (Fun Zero) (Fun b2))}.
Proof.
intros b2 H2.
exists b2; auto with arith.
Qed.

Lemma Or_BDT_One_b2 :
 forall b2 : BDT,
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Dim b2 /\ BF_eq (Fun b3) (OR (Fun One) (Fun b2))}.
Proof.
intros b2.
exists One; auto with arith.
Qed.

Lemma Or_BDT_b1_Zero :
 forall b1 : BDT,
 OBDT b1 ->
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Dim b1 /\ BF_eq (Fun b3) (OR (Fun b1) (Fun Zero))}.
Proof.
intros b1 H1.
exists b1.
split; try split; auto with arith.
simpl in |- *.
apply BF_eq_trans with (f2 := OR FALSE (Fun b1)); try apply Commutative_OR;
 auto with arith.
Qed.

Lemma Or_BDT_b1_One :
 forall b1 : BDT,
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Dim b1 /\ BF_eq (Fun b3) (OR (Fun b1) (Fun One))}.
Proof.
intro b1.
exists One.
split; try split; auto with arith.
apply BF_eq_trans with (f2 := OR TRUE (Fun b1)); try apply Commutative_OR;
 auto with arith.
Qed.

Lemma Or_BDT_overloaded :
 forall b1 : BDT,
 OBDT b1 ->
 forall b2 : BDT,
 OBDT b2 ->
 {b3 : BDT |
 OBDT b3 /\ Dim b3 <= Maxdim b1 b2 /\ BF_eq (Fun b3) (OR (Fun b1) (Fun b2))}.
Proof.
intros b1 H1 b2 H2.
pattern b1, b2 in |- *; apply Induction1 with (b1 := b1) (b2 := b2);
 try assumption.
clear H1 b1 H2 b2; intros b2 H2.
unfold Maxdim in |- *; elim (le_Max (Dim Zero) (Dim b2));
 [ exact (Or_BDT_Zero_b2 b2 H2) | auto with arith ].
clear H1 b1 H2 b2; intros b2 H2.
unfold Maxdim in |- *; elim (le_Max (Dim One) (Dim b2));
 [ exact (Or_BDT_One_b2 b2) | auto with arith ].
clear H1 b1 H2 b2; intros b1 H1.
unfold Maxdim in |- *; elim Max_sym; elim (le_Max (Dim Zero) (Dim b1));
 [ exact (Or_BDT_b1_Zero b1 H1) | auto with arith ].
clear H1 b1 H2 b2; intros b1 H1.
unfold Maxdim in |- *; elim Max_sym; elim (le_Max (Dim One) (Dim b1));
 [ exact (Or_BDT_b1_One b1) | auto with arith ].
clear H1 b1 H2 b2; intros b1 b2 HO1 HD1 HO2 HD2.
intros i Def_i Htrue Hfalse.
apply Op2_BDT_overloaded with i; auto with arith.
simple induction b; assumption.
Qed.

Lemma Or_BDT :
 forall b1 : BDT,
 OBDT b1 ->
 forall b2 : BDT,
 OBDT b2 -> {b3 : BDT | OBDT b3 /\ BF_eq (Fun b3) (OR (Fun b1) (Fun b2))}.
Proof.
intros b1 H1 b2 H2.
elim (Or_BDT_overloaded b1 H1 b2 H2).
intro b3.
intro H; elim H; intro H3.
simple induction 1.
exists b3; auto with arith.
Qed.

(*                The single unary boolean operator on BDTs           *)

Lemma Existence_Not_BDT :
 forall t : BDT,
 OBDT t ->
 {t' : BDT | OBDT t' /\ Dim t' <= Dim t /\ BF_eq (Fun t') (NOT (Fun t))}.
Proof.
simple induction t.
(*  t = Zero *)
intro Zero_ordered.
exists One; simpl in |- *; auto with arith.
(*  t = One *)
intro One_ordered.
exists Zero; simpl in |- *; auto with arith.
(*  t = Node(i,bh,bl) *)
intros i bh Hrec_bh bl Hrec_bl Node_ordered.
elim Hrec_bl;
 [ idtac | elim (ordered_node_ordered_sons i bh bl); auto with arith ].
intro tnot_l.
simple induction 1; intro tnot_l_ordered; simple induction 1;
 intros H_dimtnot_l H_Funtnot_l.
elim Hrec_bh;
 [ idtac | elim (ordered_node_ordered_sons i bh bl); auto with arith ].
intro tnot_h.
simple induction 1; intro tnot_h_ordered; simple induction 1;
 intros H_dimtnot_h H_Funtnot_h.
clear H0 p0 H p Hrec_bl Hrec_bh.
(* Two cases: Not left = Not right or not *)
elim (eq_BDT_decidable tnot_h tnot_l).
  (* Case Not left= Not right *)
intro tnot_h_eq_tnot_l.
exists tnot_h.
split; try trivial with arith.
split; simpl in |- *.
apply gt_le_weak.
apply gt_le_trans with (m := Dim bh); auto with arith.
elim (dim_node_dim_sons i bh bl Node_ordered); auto with arith.
apply BF_eq_sym.
apply BF_eq_trans with (f2 := IF F i then NOT (Fun bh) else NOT (Fun bl));
 try apply Commute_if_not.
unfold BF_eq in |- *; intro A.
unfold BF_eq in H_Funtnot_h.
unfold BF_eq in H_Funtnot_l.
unfold IF_ in |- *; elim (F i A); auto with arith.
rewrite tnot_h_eq_tnot_l; auto with arith.
  (* Case Not left =/= right *)
intro tnot_h_neq_tnot_l.
exists (Node i tnot_h tnot_l).
split.
apply order_node; try assumption.
apply gt_le_trans with (m := Dim bh); try assumption.
elim (dim_node_dim_sons i bh bl Node_ordered); auto with arith.
apply gt_le_trans with (m := Dim bl); try assumption.
elim (dim_node_dim_sons i bh bl Node_ordered); auto with arith.
simpl in |- *; split; try apply le_n.
apply BF_eq_sym.
apply BF_eq_trans with (f2 := IF F i then NOT (Fun bh) else NOT (Fun bl));
 try apply Commute_if_not.
apply BF_eq_congruence_op3; auto with arith.
Qed.

Lemma Not_BDT :
 forall t : BDT,
 OBDT t -> {t' : BDT | OBDT t' /\ BF_eq (Fun t') (NOT (Fun t))}.
Proof.
intros t Ht.
elim (Existence_Not_BDT t Ht).
intro nt.
simple induction 1; intro nt_ordered; simple induction 1; intros.
exists nt; auto with arith.
Qed.

Lemma Shtree_Tr : {T : BDT | Sh_tree_of Tr T}.
Proof.
exists One.
unfold Sh_tree_of in |- *; auto with arith.
Qed.

Lemma Shtree_Fa : {T : BDT | Sh_tree_of Fa T}.
Proof.
exists Zero.
unfold Sh_tree_of in |- *; auto with arith.
Qed.

Lemma Shtree_Var :
 forall (i : nat) (p : i > 0), {T : BDT | Sh_tree_of (Var i p) T}.
Proof.
intros i Hi.
exists (Node i One Zero).
unfold Sh_tree_of in |- *; simpl in |- *; auto with arith.
(* Use: def OBDT and eq_Fi_if_i *)
Qed.

Lemma Shtree_And :
 forall e1 : Bool_exp,
 {T : BDT | Sh_tree_of e1 T} ->
 forall e2 : Bool_exp,
 {T : BDT | Sh_tree_of e2 T} -> {T : BDT | Sh_tree_of (ANd e1 e2) T}.
Proof.
intros e1 H_e1 e2 H_e2.
elim H_e1; intros t1 Def_t1.
unfold Sh_tree_of in Def_t1.
elim Def_t1; intros t1_ordered Funt1_correct.
elim H_e2; intros t2 Def_t2.
unfold Sh_tree_of in Def_t2.
elim Def_t2; intros t2_ordered Funt2_correct.
elim (And_BDT t1 t1_ordered t2 t2_ordered); intros t3 Def_t3.
exists t3.
unfold Sh_tree_of in |- *; simpl in |- *.
elim Def_t3; intros t3_ordered Funt3_correct.
split; auto with arith.
apply BF_eq_trans with (f2 := AND (Fun t1) (Fun t2)); auto with arith.
apply BF_eq_congruence_op2; auto with arith.
Qed.

Lemma Shtree_Or :
 forall e1 : Bool_exp,
 {T : BDT | Sh_tree_of e1 T} ->
 forall e2 : Bool_exp,
 {T : BDT | Sh_tree_of e2 T} -> {T : BDT | Sh_tree_of (Or e1 e2) T}.
Proof.
intros e1 H_e1 e2 H_e2.
elim H_e1; intros t1 Def_t1.
unfold Sh_tree_of in Def_t1.
elim Def_t1; intros t1_ordered Funt1_correct.
elim H_e2; intros t2 Def_t2.
unfold Sh_tree_of in Def_t2.
elim Def_t2; intros t2_ordered Funt2_correct.
elim (Or_BDT t1 t1_ordered t2 t2_ordered); intros t3 Def_t3.
exists t3.
unfold Sh_tree_of in |- *; simpl in |- *.
elim Def_t3; intros t3_ordered Funt3_correct.
split; auto with arith.
apply BF_eq_trans with (f2 := OR (Fun t1) (Fun t2)); auto with arith.
apply BF_eq_congruence_op2; auto with arith.
Qed.

Lemma Shtree_Not :
 forall e : Bool_exp,
 {T : BDT | Sh_tree_of e T} -> {T : BDT | Sh_tree_of (Not e) T}.
Proof.
simple induction 1.
intro Te.
simple induction 1.
intros Te_ordered FunTe_correct.
elim (Not_BDT Te Te_ordered).
intros TNot_e.
simple induction 1.
intros TNot_e_ordered FunTNot_e_correct.
exists TNot_e.
unfold Sh_tree_of in |- *; simpl in |- *.
split; try apply BF_eq_trans with (NOT (Fun Te)); auto with arith.
apply BF_eq_congruence_op1; auto with arith.
Qed.

(* Development of a program computing
   the Shannon Tree of a Boolean Expression  *)

Theorem Existence : forall e : Bool_exp, {t : BDT | Sh_tree_of e t}.

Proof.
simple induction e.
exact Shtree_Tr.
exact Shtree_Fa.
exact Shtree_Var.
exact Shtree_And.
exact Shtree_Or.
exact Shtree_Not.
Qed.


From Paco Require Import paco.
From sflib Require Import sflib.
From ITree Require Import ITree.
From Fairness Require Import ITreeLib.
From Coq Require Import Program.

Set Implicit Arguments.

Module Event.

  Definition hom (E1 E2 : Type -> Type) := forall X, E1 X -> E2 X.

  Definition id E : hom E E := fun X e => e.

  Definition compose {E1 E2 E3} : hom E2 E3 -> hom E1 E2 -> hom E1 E3 :=
    fun f g X => f X ∘ g X.

  Lemma identity_l E1 E2 (f : hom E1 E2) : compose (id E2) f = f.
  Proof. reflexivity. Qed.

  Lemma identity_r E1 E2 (f : hom E1 E2) : compose f (id E1) = f.
  Proof. reflexivity. Qed.

  Lemma assoc E1 E2 E3 E4 (f : hom E1 E2) (g : hom E2 E3) (h : hom E3 E4) :
    compose (compose h g) f = compose h (compose g f).
  Proof. reflexivity. Qed.

End Event.

Declare Scope event_scope.
Delimit Scope event_scope with event.
Infix "∘" := (Event.compose) (at level 40, left associativity) : event_scope.

Section SUM.

  Definition embed_left {E1 E2} (embed : forall X, E1 X -> E2 X) {E} X (e : (E1 +' E) X) : (E2 +' E) X :=
    match e with
    | inl1 e => inl1 (embed _ e)
    | inr1 e => inr1 e
    end.

  Definition embed_right {E1 E2} (embed : forall X, E1 X -> E2 X) {E} X (e : (E +' E1) X) : (E +' E2) X :=
    match e with
    | inl1 e => inl1 e
    | inr1 e => inr1 (embed _ e)
    end.

End SUM.

Section MAP_EVENT.

  CoFixpoint map_event {E1 E2} (embed : forall X, E1 X -> E2 X) {R} : itree E1 R -> itree E2 R :=
    fun itr =>
      match observe itr with
      | RetF r => Ret r
      | TauF itr => Tau (map_event embed itr)
      | VisF e ktr => Vis (embed _ e) (fun x => map_event embed (ktr x))
      end.

  Lemma map_event_ret E1 E2 (embed : forall X, E1 X -> E2 X) R (r : R) :
    map_event embed (Ret r) = Ret r.
  Proof. eapply observe_eta. ss. Qed.

  Lemma map_event_tau E1 E2 (embed : forall X, E1 X -> E2 X) R (itr : itree E1 R) :
    map_event embed (Tau itr) = Tau (map_event embed itr).
  Proof. eapply observe_eta. ss. Qed.

  Lemma map_event_vis E1 E2 (embed : forall X, E1 X -> E2 X) R X (e : E1 X) (ktr : ktree E1 X R) :
    map_event embed (Vis e ktr) = Vis (embed _ e) (fun x => map_event embed (ktr x)).
  Proof. eapply observe_eta. ss. Qed.

  Lemma map_event_trigger E1 E2 (embed : forall X, E1 X -> E2 X) E' `[E' -< E1] R X (e : E' X) (ktr : ktree E1 X R) :
    map_event embed (x <- trigger e;; ktr x) = x <- trigger (embed _ (subevent X e));; map_event embed (ktr x).
  Proof. rewrite 2 bind_trigger. apply map_event_vis. Qed.

  Lemma map_event_bind E1 E2 (embed : forall X, E1 X -> E2 X) A B (itr : itree E1 A) (ktr : A -> itree E1 B) :
    map_event embed (itr >>= ktr) = map_event embed itr >>= fun x => map_event embed (ktr x).
  Proof.
    eapply bisim_is_eq.
    revert itr ktr. pcofix CIH. i.
    destruct_itree itr.
    - rewrite ! map_event_ret. grind.
      eapply paco2_mon. eapply eq_is_bisim. reflexivity. ss.
    - grind. rewrite ! map_event_tau. grind.
      pfold. econs. right. eapply CIH.
    - grind. rewrite ! map_event_vis. grind.
      pfold. econs. i. right. eapply CIH.
  Qed.

  Lemma map_event_id E R (itr : itree E R) : map_event (Event.id E) itr = itr.
  Proof.
    eapply bisim_is_eq.
    revert itr. pcofix CIH. i.
    destruct_itree itr.
    - rewrite map_event_ret. pfold. econs. ss.
    - rewrite map_event_tau. pfold. econs. right. eapply CIH.
    - rewrite map_event_vis. pfold. econs. i. right. eapply CIH.
  Qed.

  Lemma map_event_compose
    E1 E2 E3 (f : Event.hom E1 E2) (g : Event.hom E2 E3) R (itr : itree E1 R)
    : map_event (g ∘ f)%event itr = map_event g (map_event f itr).
  Proof.
    eapply bisim_is_eq.
    revert itr. pcofix CIH. i.
    destruct_itree itr.
    - rewrite ! map_event_ret. pfold. econs. ss.
    - rewrite ! map_event_tau. pfold. econs. right. eapply CIH.
    - rewrite ! map_event_vis. pfold. econs. i. right. eapply CIH.
  Qed.

End MAP_EVENT.

Global Opaque map_event.


(** This file collects theorems, definitions, tactics, related to propositions
with a decidable equality. Such propositions are collected by the [Decision]
type class. *)
From stdpp Require Export proof_irrel.
From stdpp Require Import options.

(* Pick up extra assumptions from section parameters. *)
Set Default Proof Using "Type*".

Lemma dec_stable `{Decision P} : ¬¬P → P.
Proof. firstorder. Qed.

Lemma Is_true_reflect (b : bool) : reflect b b.
Proof. destruct b; [left; constructor | right; intros []]. Qed.
Global Instance: Inj (=) (↔) Is_true.
Proof. intros [] []; simpl; intuition. Qed.

Lemma decide_True {A} `{Decision P} (x y : A) :
  P → (if decide P then x else y) = x.
Proof. destruct (decide P); tauto. Qed.
Lemma decide_False {A} `{Decision P} (x y : A) :
  ¬P → (if decide P then x else y) = y.
Proof. destruct (decide P); tauto. Qed.
Lemma decide_ext {A} P Q `{Decision P, Decision Q} (x y : A) :
  (P ↔ Q) → (if decide P then x else y) = (if decide Q then x else y).
Proof. intros [??]. destruct (decide P), (decide Q); tauto. Qed.

Lemma decide_True_pi `{Decision P, !ProofIrrel P} (HP : P) : decide P = left HP.
Proof. destruct (decide P); [|contradiction]. f_equal. apply proof_irrel. Qed.
Lemma decide_False_pi `{Decision P, !ProofIrrel (¬ P)} (HP : ¬ P) : decide P = right HP.
Proof. destruct (decide P); [contradiction|]. f_equal. apply proof_irrel. Qed.

(** The tactic [destruct_decide] destructs a sumbool [dec]. If one of the
components is double negated, it will try to remove the double negation. *)
Tactic Notation "destruct_decide" constr(dec) "as" ident(H) :=
  destruct dec as [H|H];
  try match type of H with
  | ¬¬_ => apply dec_stable in H
  end.
Tactic Notation "destruct_decide" constr(dec) :=
  let H := fresh in destruct_decide dec as H.

(** The tactic [case_decide] performs case analysis on an arbitrary occurrence
of [decide] or [decide_rel] in the conclusion or hypotheses. *)
Tactic Notation "case_decide" "as" ident(Hd) :=
  match goal with
  | H : context [@decide ?P ?dec] |- _ =>
    destruct_decide (@decide P dec) as Hd
  | H : context [@decide_rel _ _ ?R ?x ?y ?dec] |- _ =>
    destruct_decide (@decide_rel _ _ R x y dec) as Hd
  | |- context [@decide ?P ?dec] =>
    destruct_decide (@decide P dec) as Hd
  | |- context [@decide_rel _ _ ?R ?x ?y ?dec] =>
    destruct_decide (@decide_rel _ _ R x y dec) as Hd
  end.
Tactic Notation "case_decide" :=
  let H := fresh in case_decide as H.

(** The tactic [solve_decision] uses Coq's [decide equality] tactic together
with instance resolution to automatically generate decision procedures. *)
Ltac solve_trivial_decision :=
  match goal with
  | |- Decision (?P) => apply _
  | |- sumbool ?P (¬?P) => change (Decision P); apply _
  end.
Ltac solve_decision :=
  unfold EqDecision; intros; first
    [ solve_trivial_decision
    | unfold Decision; decide equality; solve_trivial_decision ].

(** The following combinators are useful to create Decision proofs in
combination with the [refine] tactic. *)
Notation swap_if S := (match S with left H => right H | right H => left H end).
Notation cast_if S := (if S then left _ else right _).
Notation cast_if_and S1 S2 := (if S1 then cast_if S2 else right _).
Notation cast_if_and3 S1 S2 S3 := (if S1 then cast_if_and S2 S3 else right _).
Notation cast_if_and4 S1 S2 S3 S4 :=
  (if S1 then cast_if_and3 S2 S3 S4 else right _).
Notation cast_if_and5 S1 S2 S3 S4 S5 :=
  (if S1 then cast_if_and4 S2 S3 S4 S5 else right _).
Notation cast_if_and6 S1 S2 S3 S4 S5 S6 :=
  (if S1 then cast_if_and5 S2 S3 S4 S5 S6 else right _).
Notation cast_if_or S1 S2 := (if S1 then left _ else cast_if S2).
Notation cast_if_or3 S1 S2 S3 := (if S1 then left _ else cast_if_or S2 S3).
Notation cast_if_not_or S1 S2 := (if S1 then cast_if S2 else left _).
Notation cast_if_not S := (if S then right _ else left _).

(** * Instances of [Decision] *)
(** Instances of [Decision] for operators of propositional logic. *)
Global Instance True_dec: Decision True := left I.
Global Instance False_dec: Decision False := right (False_rect False).
Global Instance Is_true_dec b : Decision (Is_true b).
Proof. destruct b; simpl; apply _. Defined.

Section prop_dec.
  Context `(P_dec : Decision P) `(Q_dec : Decision Q).

  Global Instance not_dec: Decision (¬P).
  Proof. refine (cast_if_not P_dec); intuition. Defined.
  Global Instance and_dec: Decision (P ∧ Q).
  Proof. refine (cast_if_and P_dec Q_dec); intuition. Defined.
  Global Instance or_dec: Decision (P ∨ Q).
  Proof. refine (cast_if_or P_dec Q_dec); intuition. Defined.
  Global Instance impl_dec: Decision (P → Q).
  Proof. refine (if P_dec then cast_if Q_dec else left _); intuition. Defined.
End prop_dec.
Global Instance iff_dec `(P_dec : Decision P) `(Q_dec : Decision Q) :
  Decision (P ↔ Q) := and_dec _ _.

(** Instances of [Decision] for common data types. *)
Global Instance bool_eq_dec : EqDecision bool.
Proof. solve_decision. Defined.
Global Instance unit_eq_dec : EqDecision unit.
Proof. solve_decision. Defined.
Global Instance Empty_set_eq_dec : EqDecision Empty_set.
Proof. solve_decision. Defined.
Global Instance prod_eq_dec `{EqDecision A, EqDecision B} : EqDecision (A * B).
Proof. solve_decision. Defined.
Global Instance sum_eq_dec `{EqDecision A, EqDecision B} : EqDecision (A + B).
Proof. solve_decision. Defined.

Global Instance uncurry_dec `(P_dec : ∀ (x : A) (y : B), Decision (P x y)) p :
    Decision (uncurry P p) :=
  match p as p return Decision (uncurry P p) with
  | (x,y) => P_dec x y
  end.

Global Instance sig_eq_dec `(P : A → Prop) `{∀ x, ProofIrrel (P x), EqDecision A} :
  EqDecision (sig P).
Proof.
 refine (λ x y, cast_if (decide (`x = `y))); rewrite sig_eq_pi; trivial.
Defined.

(** Some laws for decidable propositions *)
Lemma not_and_l {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q.
Proof. destruct (decide P); tauto. Qed.
Lemma not_and_r {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q.
Proof. destruct (decide Q); tauto. Qed.
Lemma not_and_l_alt {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ (¬Q ∧ P).
Proof. destruct (decide P); tauto. Qed.
Lemma not_and_r_alt {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ (¬P ∧ Q) ∨ ¬Q.
Proof. destruct (decide Q); tauto. Qed.

Program Definition inj_eq_dec `{EqDecision A} {B} (f : B → A)
  `{!Inj (=) (=) f} : EqDecision B := λ x y, cast_if (decide (f x = f y)).
Solve Obligations with firstorder congruence.

(** * Instances of [RelDecision] *)
Definition flip_dec {A} (R : relation A) `{!RelDecision R} :
  RelDecision (flip R) := λ x y, decide_rel R y x.
(** We do not declare this as an actual instance since Coq can unify [flip ?R]
with any relation. Coq's standard library is carrying out the same approach for
the [Reflexive], [Transitive], etc, instance of [flip]. *)
Global Hint Extern 3 (RelDecision (flip _)) => apply flip_dec : typeclass_instances.

(** We can convert decidable propositions to booleans. *)
Definition bool_decide (P : Prop) {dec : Decision P} : bool :=
  if dec then true else false.

Lemma bool_decide_reflect P `{dec : Decision P} : reflect P (bool_decide P).
Proof. unfold bool_decide. destruct dec; [left|right]; assumption. Qed.

Lemma bool_decide_decide P `{!Decision P} :
  bool_decide P = if decide P then true else false.
Proof. reflexivity. Qed.
Lemma decide_bool_decide P {Hdec: Decision P} {X : Type} (x1 x2 : X):
  (if decide P then x1 else x2) = (if bool_decide P then x1 else x2).
Proof. unfold bool_decide, decide. destruct Hdec; reflexivity. Qed.

Tactic Notation "case_bool_decide" "as" ident(Hd) :=
  match goal with
  | H : context [@bool_decide ?P ?dec] |- _ =>
    destruct_decide (@bool_decide_reflect P dec) as Hd
  | |- context [@bool_decide ?P ?dec] =>
    destruct_decide (@bool_decide_reflect P dec) as Hd
  end.
Tactic Notation "case_bool_decide" :=
  let H := fresh in case_bool_decide as H.

Lemma bool_decide_spec (P : Prop) {dec : Decision P} : bool_decide P ↔ P.
Proof. unfold bool_decide. destruct dec; simpl; tauto. Qed.
Lemma bool_decide_unpack (P : Prop) {dec : Decision P} : bool_decide P → P.
Proof. rewrite bool_decide_spec; trivial. Qed.
Lemma bool_decide_pack (P : Prop) {dec : Decision P} : P → bool_decide P.
Proof. rewrite bool_decide_spec; trivial. Qed.
Global Hint Resolve bool_decide_pack : core.

Lemma bool_decide_eq_true (P : Prop) `{Decision P} : bool_decide P = true ↔ P.
Proof. case_bool_decide; intuition discriminate. Qed.
Lemma bool_decide_eq_false (P : Prop) `{Decision P} : bool_decide P = false ↔ ¬P.
Proof. case_bool_decide; intuition discriminate. Qed.
Lemma bool_decide_ext (P Q : Prop) `{Decision P, Decision Q} :
  (P ↔ Q) → bool_decide P = bool_decide Q.
Proof. apply decide_ext. Qed.

Lemma bool_decide_eq_true_1 P `{!Decision P}: bool_decide P = true → P.
Proof. apply bool_decide_eq_true. Qed.
Lemma bool_decide_eq_true_2 P `{!Decision P}: P → bool_decide P = true.
Proof. apply bool_decide_eq_true. Qed.

Lemma bool_decide_eq_false_1 P `{!Decision P}: bool_decide P = false → ¬P.
Proof. apply bool_decide_eq_false. Qed.
Lemma bool_decide_eq_false_2 P `{!Decision P}: ¬P → bool_decide P = false.
Proof. apply bool_decide_eq_false. Qed.

Lemma bool_decide_True : bool_decide True = true.
Proof. reflexivity. Qed.
Lemma bool_decide_False : bool_decide False = false.
Proof. reflexivity. Qed.
Lemma bool_decide_not P `{Decision P} :
  bool_decide (¬ P) = negb (bool_decide P).
Proof. repeat case_bool_decide; intuition. Qed.
Lemma bool_decide_or P Q `{Decision P, Decision Q} :
  bool_decide (P ∨ Q) = bool_decide P || bool_decide Q.
Proof. repeat case_bool_decide; intuition. Qed.
Lemma bool_decide_and P Q `{Decision P, Decision Q} :
  bool_decide (P ∧ Q) = bool_decide P && bool_decide Q.
Proof. repeat case_bool_decide; intuition. Qed.
Lemma bool_decide_impl P Q `{Decision P, Decision Q} :
  bool_decide (P → Q) = implb (bool_decide P) (bool_decide Q).
Proof. repeat case_bool_decide; intuition. Qed.
Lemma bool_decide_iff P Q `{Decision P, Decision Q} :
  bool_decide (P ↔ Q) = eqb (bool_decide P) (bool_decide Q).
Proof. repeat case_bool_decide; intuition. Qed.

(** The tactic [compute_done] solves the following kinds of goals:
- Goals [P] where [Decidable P] can be derived.
- Goals that compute to [True] or [x = x].

The goal must be a ground term for this, i.e., not contain variables (that do
not compute away). The goal is solved by using [vm_compute] and then using a
trivial proof term ([I]/[eq_refl]). *)
Tactic Notation "compute_done" :=
  try apply (bool_decide_unpack _);
  vm_compute;
  first [ exact I | exact eq_refl ].
Tactic Notation "compute_by" tactic(tac) :=
  tac; compute_done.

(** Backwards compatibility notations. *)
Notation bool_decide_true := bool_decide_eq_true_2.
Notation bool_decide_false := bool_decide_eq_false_2.

(** * Decidable Sigma types *)
(** Leibniz equality on Sigma types requires the equipped proofs to be
equal as Coq does not support proof irrelevance. For decidable we
propositions we define the type [dsig P] whose Leibniz equality is proof
irrelevant. That is [∀ x y : dsig P, x = y ↔ `x = `y]. *)
Definition dsig `(P : A → Prop) `{∀ x : A, Decision (P x)} :=
  { x | bool_decide (P x) }.

Definition proj2_dsig `{∀ x : A, Decision (P x)} (x : dsig P) : P (`x) :=
  bool_decide_unpack _ (proj2_sig x).
Definition dexist `{∀ x : A, Decision (P x)} (x : A) (p : P x) : dsig P :=
  x↾bool_decide_pack _ p.
Lemma dsig_eq `(P : A → Prop) `{∀ x, Decision (P x)}
  (x y : dsig P) : x = y ↔ `x = `y.
Proof. apply (sig_eq_pi _). Qed.
Lemma dexists_proj1 `(P : A → Prop) `{∀ x, Decision (P x)} (x : dsig P) p :
  dexist (`x) p = x.
Proof. apply dsig_eq; reflexivity. Qed.


(* --------------------------------------------------------------------
 * (c) Copyright 2014--2015 IMDEA Software Institute.
 *
 * You may distribute this file under the terms of the CeCILL-B license
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import choice fintype tuple finfun bigop finset order.
From mathcomp Require Import ssralg.

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

Import Order.Theory GRing.Theory.

(* -------------------------------------------------------------------- *)
Lemma lreg_prod (T : eqType) (R : ringType) (r : seq T) (P : pred T) (F : T -> R):
      (forall x, x \in r -> P x -> GRing.lreg (F x))
   -> GRing.lreg (\prod_(x <- r | P x) F x).
Proof.
  elim: r => [|x r ih] h; first by rewrite !big_nil; apply/lreg1.
  rewrite big_cons; set X := (\prod_(_ <- _ | _) _)%R.
  have lreg_X: GRing.lreg X by apply/ih=> y ? /h; apply; rewrite mem_behead.
  by case: ifP => // Px; apply/lregM/lreg_X/h/Px/mem_head.
Qed.

(* -------------------------------------------------------------------- *)
Lemma sumn_range (k1 k2 : nat) (c : nat -> nat): k1 <= k2 ->
     (forall i j, i <= j < (k2 - k1).+1 -> c (j + k1) <= c (i + k1))
  -> \sum_(k1 <= i < k2) (c i - c i.+1) = c k1 - c k2.
Proof.
  rewrite leq_eqVlt => /predU1P[<- h|]; first by rewrite big_geq // subnn.
  rewrite -subn_gt0=> gt0_k2Bk1 h; rewrite -{1}[k1]add0n big_addn.
  case k1Bk2E: (k2 - k1)  gt0_k2Bk1 h => [|n] // _ h.
  rewrite big_nat sumnB -?big_nat; last first.
    move=> i /andP[_]; rewrite ltnS -addSn => le_in.
    by apply/h; rewrite leqnSn /= !ltnS.
  rewrite big_nat_recl ?big_nat_recr //= subnDA addnK.
  rewrite add0n -addSn -k1Bk2E subnK // leqNgt; apply/negP.
  by move/ltnW; rewrite -subn_eq0 k1Bk2E.
Qed.

Lemma sum0n_range (k : nat) (c : nat -> nat):
     (forall i j, i <= j < k.+1 -> c j <= c i)
  -> \sum_(0 <= i < k) (c i - c i.+1) = c 0 - c k.
Proof.
  move=> h; apply/sumn_range; rewrite ?subn0=> // i j le.
  by rewrite !addn0; apply/h.
Qed.

(* -------------------------------------------------------------------- *)
Lemma sumn_wgt_range (k : nat) (c : nat -> nat):
     (forall i j, i <= j < k.+1 -> c j <= c i)
  -> \sum_(i < k) (c i - c i.+1) * i.+1 = \sum_(i < k) c i - k * c k.
Proof.
  pose F i := c i * i.+1 - c i.+1 * i.+1.
  rewrite (eq_bigr (F \o val)) /=; first last.
    by move=> i _; rewrite mulnBl.
  rewrite [k * _]mulnC; elim: k=> [|k ih] h.
    by rewrite !big_ord0 muln0 subn0.
  rewrite !big_ord_recr /= ih; last first.
    by move=> i j /andP[le_ij lt_jSk]; rewrite h // le_ij leqW.
  rewrite {ih}/F addnBA ?leq_mul //; last by apply/h; rewrite leqnn ltnW.
  congr subn; rewrite addnC addnBA 1?addnC -?addnBA.
  + by rewrite -mulnBr subSnn muln1.
  + by rewrite leq_mul.
  elim: k h => [|k ih] h; first by rewrite muln0.
  rewrite big_ord_recr //= mulnS addnC leq_add //; last first.
    by apply/h; rewrite !ltnS !leqnSn.
  apply/leq_trans/ih; first by apply/leq_mul/leqnn/h; rewrite !ltnS leqnSn.
  by move=> i j /andP[le_ij lt_jSSk]; apply/h; rewrite le_ij !ltnS ltnW.
Qed.

(* -------------------------------------------------------------------- *)
Lemma psumn_eq k (F1 F2 : nat -> nat):
     (forall j, j <= k -> \sum_(i < k | i < j) F1 i = \sum_(i < k | i < j) F2 i)
  -> forall j, j < k -> F1 j = F2 j.
Proof.
  pose rw := (big_ord_narrow, big_ord_recr).
  move=> h j; elim: j {-2}j (leqnn j)=> [|j ih] l.
    rewrite leqn0=> /eqP-> lt; have := h 1 lt.
    by rewrite !rw !big_ord0 /= !add0n=> ->.
  rewrite leq_eqVlt ltnS => /predU1P[->|]; last by apply/ih.
  move: {-2}j.+1 (leqnn j.+1)=> x le_xSj lt; have := h _ lt.
  rewrite !rw /=; set S1 := bigop _ _ _; set S2 := bigop _ _ _.
  suff <-: S1 = S2 by move/addnI. apply/eq_bigr=> /=.
  case=> /= i lt_ix _; apply/ih; last by apply/(ltn_trans lt_ix).
  by rewrite -ltnS; apply/(leq_trans lt_ix).
Qed.

(* -------------------------------------------------------------------- *)
Section BigMkSub.
  Context  {S   : Type}.
  Context  {idx : S}.
  Context  {op  : Monoid.com_law idx}.

  Context {T  : choiceType}.
  Context {sT : pred T}.
  Context {rT : pred T}.
  Context (I  : subFinType sT).
  Context (J  : subFinType rT).

  Lemma big_mksub_cond {P : pred T} {F : T -> S} (r : seq T):
      uniq r
   -> (forall x, x \in r -> P x -> sT x)
   -> \big[op/idx]_(x <- r | P x) (F x)
    = \big[op/idx]_(x : I | P (val x) && (val x \in r)) (F (val x)).
  Proof.
    move=> uniq_r h; rewrite -big_filter; apply/esym.
    pose Q x := P x && (x \in r); rewrite -(big_map val Q).
    rewrite -big_filter; apply/perm_big/uniq_perm;
      try rewrite filter_uniq // (map_inj_uniq val_inj).
      by rewrite /index_enum -enumT enum_uniq.
    move=> x; rewrite !mem_filter {}/Q; apply/andb_idr.
    rewrite andbC; case/andP=> /h {}h /h sT_x.
    apply/mapP; exists (Sub x sT_x).
      by rewrite /index_enum -enumT mem_enum.
    by rewrite SubK.
  Qed.

  Lemma big_mksub {F : T -> S} (r : seq T):
      uniq r
   -> (forall x, x \in r -> sT x)
   -> \big[op/idx]_(x <- r) F x = \big[op/idx]_(x : I | val x \in r) F (val x).
  Proof. by move=> uniq_r h; apply/big_mksub_cond=> // x /h. Qed.

  Lemma big_sub_widen {P : pred T} {F : T -> S}:
         (forall x, sT x -> rT x)
    ->   \big[op/idx]_(x : I | P (val x)) (F (val x))
       = \big[op/idx]_(x : J | P (val x) && sT (val x)) (F (val x)).
  Proof.
    move=> h; pose Q := [pred x | P x && sT x].
    rewrite -big_map -(big_map val Q F).
    rewrite -big_filter -[X in _=X]big_filter; apply/perm_big.
    apply/uniq_perm; rewrite ?(filter_uniq, map_inj_uniq val_inj) //;
      try by rewrite /index_enum -enumT enum_uniq.
    move=> x; rewrite !mem_filter {}/Q inE -andbA; congr (_ && _).
    apply/idP/andP; last first.
      by case=> sTx _; apply/mapP; exists (Sub x sTx); rewrite ?SubK.
    case/mapP=> y _ ->; split; first by apply valP.
    apply/mapP; exists (Sub (val y) (h _ (valP y))).
      by rewrite /index_enum -enumT mem_enum.
      by rewrite SubK.
  Qed.

  Lemma eq_big_widen {P : pred T} {F : T -> S}:
         (forall x, sT x -> rT x)
    ->   (forall x, ~~ sT x -> F x = idx)
    ->   \big[op/idx]_(x : I | P (val x)) (F (val x))
       = \big[op/idx]_(x : J | P (val x)) (F (val x)).
  Proof.
    move=> h1 h2; rewrite big_sub_widen //; apply/esym.
    rewrite (bigID (sT \o val)) [X in op _ X]big1 ?Monoid.simpm //.
    by move=> j /andP [_ /h2].
  Qed.
End BigMkSub.

Arguments big_sub_widen [S idx op T sT rT].
Arguments big_sub_widen [S idx op T sT rT].

(* add to mathcomp *)
Lemma prod_inj A B : injective (uncurry (@pair A B)).
Proof. by move=> [? ?] [? ?]. Qed.
#[global] Hint Resolve prod_inj : core.

(* add to mathcomp *)
Lemma in_allpairs (S T R : eqType) (f : S -> T -> R)
  (s : seq S) (t : seq T) x y :
  injective (uncurry f) ->
  f x y \in [seq f x0 y0 | x0 <- s, y0 <- t] =
  (x \in s) && (y \in t).
Proof.
move=> f_inj; apply/allpairsP/andP => [|[]]; last by exists (x, y).
by case=> -[/= x' y'] [x's y't] /(f_inj (x, y) (x',y')) [-> ->].
Qed.

(* -------------------------------------------------------------------- *)
Section BigOpPair.
  Variables I J : finType.
  Variables R : Type.

  Variable idx : R.
  Variable op  : Monoid.com_law idx.

  Lemma big_pair_dep (P : pred I) (Q : pred (I * J)) (F : I * J -> R) :
    \big[op/idx]_(p | P p.1 && Q p) F p =
     \big[op/idx]_(i | P i) \big[op/idx]_(j | Q (i, j)) F (i, j).
  Proof. by rewrite pair_big_dep; apply: eq_big => -[]. Qed.

  Lemma big_pair (P : pred I) (Q : pred J) (F : I * J -> R) :
    \big[op/idx]_(p | P p.1 && Q p.2) F p =
    \big[op/idx]_(i | P i) \big[op/idx]_(j | Q j) F (i, j).
  Proof. exact: big_pair_dep. Qed.

  Lemma big_pairA (F : I * J -> R):
    \big[op/idx]_p F p = \big[op/idx]_i \big[op/idx]_j F (i, j).
  Proof. exact: (big_pair_dep xpredT xpredT). Qed.

End BigOpPair.

(* -------------------------------------------------------------------- *)
Section BigOpMulrn.
  Variable I : Type.
  Variable R : ringType.

  Variable F : I -> R.
  Variable P : pred I.

  Lemma big_cond_mulrn r:
    (\sum_(i <- r | P i) F i = \sum_(i <- r) F i *+ P i)%R.
  Proof. by rewrite big_mkcond; apply: eq_bigr => i; rewrite mulrb. Qed.

End BigOpMulrn.

(* -------------------------------------------------------------------- *)
Lemma tval_tcast (T : Type) (n m : nat) (e : n = m) (t : n.-tuple T):
  tval (tcast e t) = tval t.
Proof. by case: m / e. Qed.

(* -------------------------------------------------------------------- *)
Local Open Scope order_scope.

Lemma lePseqprod d d' (T : porderType d) (s1 s2 : seqprod_with d' T) :
  reflect ((size s1 <= size s2)%N /\
             (forall x i, i < size s1 -> nth x s1 i <= nth x s2 i))
    (s1 <= s2).
Proof.
elim: s1 s2 => [|x s1 IHs] [|y s2] //=; try by constructor; try case.
rewrite ltnS leEseq; apply: (iffP idP) => [/andP[lexy /IHs [-> Hs12]]|[? Hs12]].
  by split => // ? [] //= i /Hs12.
by rewrite (Hs12 x 0%N) //=; apply/IHs; split => // ? i; apply: (Hs12 _ i.+1).
Qed.

(* -------------------------------------------------------------------- *)
Section LatticeMisc.
Context {T : eqType} {disp : unit} {U : bDistrLatticeType disp}.
Context (P : pred T) (F : T -> U).

Implicit Type (r : seq T).

(* FIXME: introducing bOrderType improves the statement of the lemmas below. *)
Hypothesis letot : @total U <=%O.

Variant bigjoin_spec r : U -> Type :=
  | BigJoinEmpty : nilp r -> bigjoin_spec r 0%O
  | BigJoinNonempty i : i \in r -> bigjoin_spec r (F i).

Lemma bigjoinP r : bigjoin_spec r (\join_(i <- r) F i).
Proof.
elim: r => [|i r]; first by rewrite big_nil; constructor.
rewrite big_cons; case=> [|j jr].
  by case: r => // _; rewrite joinx0; constructor; rewrite mem_head.
by case: lcomparableP (letot (F i) (F j)) => //= _ _;
  constructor; rewrite ?mem_head // in_cons jr orbT.
Qed.

Lemma eq_bigjoin r :
  r != [::] -> {x : T | x \in r & (\join_(i <- r) F i)%O == F x}.
Proof. by case: r => // x r _; case: bigjoinP => // y y_in_r; exists y. Qed.

Variant bigjoin_cond_spec r : U -> Type :=
  | BigJoinCondEmpty : all (xpredC P) r -> bigjoin_cond_spec r 0%O
  | BigJoinCondNonempty i : i \in r -> P i -> bigjoin_cond_spec r (F i).

Lemma bigjoinPcond r : bigjoin_cond_spec r (\join_(i <- r | P i) F i).
Proof.
rewrite -big_filter; case: bigjoinP => [nilPr|i].
  by constructor; rewrite all_predC has_filter negbK; case: filter nilPr.
by rewrite mem_filter => /andP[? ?]; constructor.
Qed.

End LatticeMisc.

(* -------------------------------------------------------------------- *)
Section WF.
Context {disp : unit} {T : porderType disp}.

Hypothesis wf: forall (P : T -> Type),
     (forall x, (forall y, y < x -> P y) -> P x)
  -> forall x, P x.

Section WFTuple.
Context {n : nat} (P : n.-tuple T -> Type).

Implicit Types t : n.-tuplelexi T.

Hypothesis ih: forall t1, (forall t2, t2 < t1 -> P t2) -> P t1.

Lemma ltxwf t : P t.
Proof.
elim: n P ih t => [|k wih] Pn kih t; last have [a {}t] := tupleP t.
  by rewrite tuple0; apply/kih=> t2; rewrite tuple0.
elim/wf: a t => a iha t; elim/wih: t => t iht.
apply/kih => t'; have [a' {}t'] := tupleP t'; rewrite [_ < _]ltxi_cons.
by case: (comparableP a a') => //= [/iha/(_ t')|<- /iht].
Qed.

End WFTuple.
End WF.