(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * CCMisc.v: Extensions to the Coq Standard Library *)

Set Implicit Arguments.

Require Import Bool.
Require Export BoolEquality.
Require Export List.
Require Import Heap.
Require Export Sorting.
Require Export Permutation.
Require Export NArith.
Require Export Ndec.
Require Export ZArith.
Require Export Arith.

Open Scope nat_scope.

(* List *)
Definition is_nil (A:Type) (l:list A) : bool :=
 match l with
  | nil => true
  | _ => false
 end.

Lemma find_In : forall (A:Type) (f:A -> bool) l a,
 find f l = Some a -> In a l /\ f a.
Proof.
 induction l; simpl; intro; try (intros; discriminate).
 case_eq (f a); intros.
 inversion H0; subst; auto.
 destruct (IHl _ H0); intuition.
Qed.

Lemma find_notIn : forall (A:Type) (f:A -> bool) l,
 find f l = None ->
 forall a, In a l -> f a = false.
Proof.
 induction l; simpl; intros.
 elim H0.
 destruct H0; subst.
 destruct (f a0); try discriminate; trivial.
 destruct (f a); try discriminate; auto.
Qed.

Lemma length_nil : forall A (l:list A), length l = O -> l = nil.
Proof.
 destruct l; intros; [trivial | discriminate].
Qed.

Lemma fold_right_rev_left: forall (A B:Type) (f:B -> A -> B) (l:list A) (i:B),
 fold_left f (rev l) i = fold_right (fun (x:A) (y:B) => f y x) i l.
Proof.
 intros.
 induction l; simpl; trivial.
 rewrite fold_left_app, IHl; simpl; trivial.
Qed.

Fixpoint lfalse (n:nat) :=
 match n with
  | O => nil
  | S n => false :: lfalse n
 end.

Lemma length_lfalse : forall n, length (lfalse n) = n.
Proof.
 induction n; simpl; intros; trivial.
 rewrite IHn; trivial.
Qed.

Lemma list_prod_nil t1 t2 (l1 : list t1) (l2 : list t2) :
  l1 <> nil -> l2 <> nil -> list_prod l1 l2 <> nil.
Proof.
 intros t1 t2 l1 l2 H1 H2 H.
 assert (length (list_prod l1 l2) = 0%nat).
 rewrite H; trivial.
 rewrite prod_length in H0.
 apply mult_is_O in H0; destruct H0;
   apply length_nil in H0; subst; tauto.
Qed.

Hint Constructors NoDup.

Lemma NoDup_dec: forall A,
 (forall x y:A, sumbool (x = y) (x <> y)) ->
 forall l:list A, sumbool (NoDup l) (~ NoDup l).
Proof.
 intros A eq_dec; induction l.
 left; constructor.
 destruct (in_dec eq_dec a l).
 right; intro H; inversion_clear H; tauto.
 destruct IHl.
 left; constructor; assumption.
 right; intro H; inversion_clear H; tauto.
Qed.

Lemma NoDup_snd : forall A B (l:list (A * B)),
 NoDup (map (@snd _ _) l) ->
 forall a1 a2 b,
  In (a1,b) l ->
  In (a2,b) l ->
  a1 = a2.
Proof.
 induction l; simpl; intros.
 elim H1.
 inversion_clear H.
 destruct H0; destruct H1; subst.
 injection H0; trivial.
 apply (in_map (@snd _ _)) in H0; tauto.
 apply (in_map (@snd _ _)) in H; tauto.
 apply IHl with b; trivial.
Qed.

Lemma NoDup_map_inj : forall A B (f:A -> B) l,
 (forall x y, In x l -> In y l -> f x = f y -> x = y) ->
 NoDup l ->
 NoDup (map f l).
Proof.
 clear.
 induction l; simpl; intros; constructor.
 intro H1; apply in_map_iff in H1.
 destruct H1 as [y [H3 H4] ].
 apply H in H3; [ | right; trivial | left; trivial].
 inversion_clear H0; subst; tauto.
 apply IHl.
 intros; apply H; auto.
 inversion H0; trivial.
Qed.

Lemma NoDup_app : forall A (l1 l2:list A),
 NoDup l1 ->
 NoDup l2 ->
 (forall x, In x l2 -> ~In x l1) ->
 NoDup (l1 ++ l2).
Proof.
 induction l1; simpl; intros; trivial.
 inversion_clear H.
 constructor; auto.
 intro H4; apply in_app_or in H4; destruct H4; auto.
 elim (H1 a); auto.
 apply IHl1; auto.
 firstorder.
Qed.

Lemma NoDup_app_inv : forall A (l1 l2:list A),
 NoDup (l1 ++ l2) -> NoDup l1 /\ NoDup l2.
Proof.
 induction l1; simpl; intros.
 split; [constructor | trivial].
 inversion_clear H.
 destruct (IHl1 _ H1); split; [ constructor; trivial | trivial].
 intro; apply H0; apply in_or_app; auto.
Qed.

Lemma NoDup_rev : forall A (l:list A),
 NoDup l ->
 NoDup (rev l).
Proof.
 induction l; intros.
 constructor.
 inversion_clear H.
 simpl; apply NoDup_app.
 auto.
 auto.
 intros x Hx Hin.
 apply In_rev in Hin.
 destruct Hx; subst; auto.
Qed.

Lemma NoDup_list_prod : forall A B (l1:list A) (l2:list B),
 NoDup l1 -> NoDup l2 -> NoDup (list_prod l1 l2).
Proof.
 induction l1.
 constructor.

 intros; simpl.
 apply NoDup_app.
 apply NoDup_map_inj; trivial.
 intros ? ? _ _ H3; injection H3; trivial.
 apply IHl1; trivial.
 inversion H; trivial.

 intros (x,y) H3 Hin.
 apply in_prod_iff in H3; destruct H3.
 apply in_map_iff in Hin; destruct Hin as [x' [? ?] ].
 injection H3; intros; subst.
 contradict H; intro; inversion H; subst.
 absurd (In x l1); trivial.
Qed.

Lemma Permutation_NoDup : forall A (l l': list A),
 Permutation l l' -> NoDup l -> NoDup l'.
Proof.
 induction 1; intros; trivial.
 inversion_clear H0; constructor; auto.
 intro; apply H1.
 apply Permutation_in with l'; trivial.
 apply Permutation_sym; trivial.
 inversion_clear H.
 inversion_clear H1.
 simpl in H0; constructor.
 simpl; intros [H1 | H1]; auto.
 constructor; auto.
 auto.
Qed.

Lemma NoDup_app_comm: forall A (l1 l2 :list A),
 NoDup (l1 ++ l2) -> NoDup (l2 ++ l1).
Proof.
 intros.
 refine (@Permutation_NoDup _ (l1 ++ l2) _ _ H).
 apply Permutation_app_swap.
Qed.

Lemma NoDup_app_cons_r : forall A (l l' : list A) (x':A),
 NoDup (l ++ x'::l') ->
 NoDup l /\ NoDup l' /\ not (In x' l) /\ not (In x' l').
Proof.
 intros.
 destruct (NoDup_app_inv _ _ H) as [H1 H2].
 inversion_clear H2.
 repeat split; try assumption.
 apply NoDup_app_comm in H.
 rewrite <- app_comm_cons in H.
 inversion_clear H; clear H4.
 intro H4; elim H2.
 apply in_or_app; auto.
Qed.

Lemma Sorted_le_lt : forall l,
 NoDup l ->
 Sorted le l ->
 Sorted lt l.
Proof.
 induction l; intros.
 trivial.
 constructor.
 inversion_clear H0; subst.
 apply IHl in H1; trivial.
 inversion H; trivial.
 inversion H0; subst.
 apply IHl in H3; trivial.
 inversion H; subst.
 destruct l.
 trivial.
 constructor.
 assert (a <> n).
 intro; subst; elim H5; simpl; auto.
 inversion H4; subst; omega.
 inversion H; trivial.
Qed.

Lemma Forall2_eq : forall A (l1 l2:list A), Forall2 eq l1 l2 -> l1 = l2.
Proof.
 intros; induction H; subst; trivial.
Qed.

Lemma Sorted_lt_NoDup : forall l,
 NoDup l ->
 exists l', Sorted lt l' /\ Permutation l l'.
Proof.
 intros.
 destruct (treesort nat le eq le_ge_dec eq_nat_dec le_trans l) as (l',H0,H1).
 apply PermutSetoid.permutation_Permutation in H1.
 destruct H1 as [l1 [ ? ? ] ].
 apply Forall2_eq in H2; subst.
 exists l'; split; trivial.
 apply Permutation_NoDup in H1; trivial.
 apply Sorted_le_lt; trivial.
 apply eq_equivalence.
Qed.

Lemma nth_cons : forall A (l:list A) a b n i,
 Compare_dec.leb (S n) i ->
 nth (i - S n) l b = nth (i - n) (a :: l) b.
Proof.
 intros.
 change (b :: l) with (b :: nil ++ l).
 rewrite (app_nth2 (a :: nil) l); [ | apply leb_complete in H; simpl; omega].
 simpl; replace (i - S n) with (i - n - 1) by omega; trivial.
Qed.

Lemma nth_app : forall A (l:list A) a b,
 nth (length l) (l ++ a :: nil) b = a.
Proof.
 intros; rewrite app_nth2, minus_diag; auto.
Qed.

Lemma In_nth_inv : forall A (a b:A) l,
 In a l ->
 exists n, (n < length l)%nat /\ a = nth n l b.
Proof.
 induction l; destruct 1.
 subst; exists O; split; simpl; auto with arith.
 destruct (IHl H) as [j [? ?] ]; exists (S j); split.
 simpl; omega.
 trivial.
Qed.

Fixpoint cexistsb (A:Type) (f:A->bool*nat) (l:list A) (n:nat) {struct l} :
 bool * nat :=
 match l with
  | nil => (false, n)
  | a::l0 => let (b, n0) := f a in
    if b then (true, n + n0) else cexistsb f l0 (n + n0)
 end.

Lemma existsb_cexistsb : forall A f g,
 (forall x, f x = fst (g x)) ->
 forall (l:list A) n, existsb f l = fst (cexistsb g l n).
Proof.
 intros A f g Hfg; induction l.
 trivial.
 simpl; generalize (Hfg a).
 case (f a); case (g a); intros b n H n0; simpl in H; rewrite <- H; trivial.
Qed.

Lemma existsb_app : forall A (f:A -> bool) l1 l2,
 existsb f (l1 ++ l2) = orb (existsb f l1) (existsb f l2).
Proof.
 induction l1; simpl; intros; trivial.
 rewrite IHl1, orb_assoc; trivial.
Qed.

Fixpoint cforallb (A:Type)(f:A->bool*nat)(l:list A)(n:nat) {struct l} : bool * nat :=
 match l with
 | nil => (true, n)
 | a::l0 => let (b, n0) := f a in
  if b then cforallb f l0 (n + n0) else (false, n + n0)
 end.

Lemma forallb_cforallb : forall A f g,
 (forall x, f x = fst (g x)) ->
 forall (l:list A) n, forallb f l = fst (cforallb g l n).
Proof.
 intros A f g Hfg; induction l.
 trivial.
 simpl; generalize (Hfg a).
 case (f a); case (g a); intros b n H n0; simpl in H; rewrite <- H; trivial.
Qed.

Definition find_default (A:Type) (f:A->bool) l default :=
  match List.find f l with
  | Some a => a
  | None => default
  end.

Fixpoint cfind (A:Type) (f:A->bool*nat) l n {struct l} : option A * nat :=
  match l with
  | nil => (None, n)
  | a :: tl => let (b, n0) := f a in
    if b then (Some a, n + n0) else cfind f tl (n + n0)
  end.

Definition cfind_default (A:Type) (f:A->bool*nat) l n default :=
  match cfind f l n with
  | (Some a, n0) => (a, n0)
  | (None, n0) => (default, n0)
  end.

Lemma find_cfind : forall A f g,
 (forall x, f x = fst (g x)) ->
 forall (l:list A) n, find f l = fst (cfind g l n).
Proof.
 intros A f g Hfg; induction l.
 trivial.
 simpl; generalize (Hfg a).
 case (f a); case (g a); intros b n H n0; simpl in H; rewrite <- H; trivial.
Qed.

Lemma find_cfind_default : forall A f g default,
 (forall x, f x = fst (g x)) ->
 forall (l:list A) n, find_default f l default = fst (cfind_default g l n default).
Proof.
 unfold find_default, cfind_default; intros.
 rewrite (find_cfind f g H l n).
 destruct (cfind g l n).
 destruct o; trivial.
Qed.

Section FOLD.

  Definition opt_app (A B:Type) (f : A -> option B) (a:option A) : option B :=
   match a with
   | Some a => f a
   | None => None
   end.

  Variable A B : Type.
  Variable f : A -> B -> option A.

  Fixpoint fold_left_opt  (l : list B) (a0 : A) {struct l} : option A :=
   match l with
   | nil => Some a0
   | b :: t => opt_app (fold_left_opt t) (f a0 b)
   end.

  Definition spec_opt (P:A->Prop) (a:option A) : Prop :=
   match a with
   | Some a => P a
   | None => True
   end.

End FOLD.

(* Nat *)
Fixpoint pow (n m:nat) {struct m} : nat :=
 match m with
 | O => S O
 | S m' => n * (pow n m')
 end.

Infix "^" := pow : nat_scope.

Definition pow_N (n m:N) : N :=
 Nnat.N_of_nat (pow (Nnat.nat_of_N n) (Nnat.nat_of_N m)).

Lemma pow_lt_0 : forall n c, 0 < n -> 0 < n ^ c.
Proof.
 intros; induction c.
 auto.
 apply lt_le_trans with (1:=IHc).
 rewrite <- (mult_1_l (n ^ c)).
 simpl pow; apply mult_le_compat_r; trivial.
Qed.

Lemma pow_2_le : forall c, exists k, c <= 2 ^ k.
Proof.
 induction c; intros.
 exists 0; simpl; auto.
 destruct IHc as [k Hle].
 exists (S k).
 apply le_trans with (1 + (2 ^ k)).
 apply le_n_S; trivial.
 simpl pow; rewrite plus_0_r.
 apply plus_le_compat.
 apply pow_lt_0; auto.
 trivial.
Qed.

Lemma pow_monotone_1 : forall k n m, n <= m -> n ^ k <= m ^ k.
Proof.
 induction k; intros; simpl.
 trivial.
 apply mult_le_compat; auto.
Qed.

Lemma pow_monotone_2 : forall k1 k2 n, 0 < n -> k1 <= k2 -> n ^ k1 <= n ^ k2.
Proof.
 induction k1; intros; simpl.
 apply le_trans with (1 ^ k2).
 apply pow_lt_0; auto.
 apply pow_monotone_1; trivial.
 inversion H0; subst.
 trivial.
 simpl; apply mult_le_compat.
 trivial.
 apply IHk1.
 trivial.
 auto with arith.
Qed.

Lemma pow_mult_plus : forall k1 k2 n, n ^ k1 * n ^ k2 = n ^ (k1 + k2).
Proof.
 induction k1; destruct k2; simpl; intros.
 trivial.
 ring.
 rewrite plus_0_r, mult_1_r; trivial.
 rewrite <- plus_n_Sm.
 simpl; rewrite <- IHk1; ring.
Qed.

Definition Nminus n1 n2 :=
 match n1, n2 with
 | N0, _ => N0
 | _, N0 =>  n1
 | Npos p1, Npos p2 =>
   match Pminus_mask p1 p2 with
   | IsPos p1 => Npos p1
   | _ => N0
   end
 end.

(* REMARK: There exist a [beq_nat] in EqNat *)
Fixpoint nat_eqb (n1 n2:nat) {struct n1} : bool :=
 match n1, n2 with
  | O, O => true
  | O, S _ => false
  | S _, O => false
  | S n1, S n2 => nat_eqb n1 n2
 end.

Lemma nat_eqb_spec : forall n1 n2, if nat_eqb n1 n2 then n1 = n2 else n1 <> n2.
Proof.
 induction n1; destruct n2; simpl; trivial; try (intro; discriminate).
 generalize (IHn1 n2); destruct (nat_eqb n1 n2); auto.
Qed.

Lemma nat_eqb_true : forall n1 n2, nat_eqb n1 n2 = true -> n1 = n2.
Proof.
 induction n1; destruct n2; simpl; trivial; try (intro; discriminate).
 auto.
Qed.

Implicit Arguments nat_eqb_true [n1 n2].

Lemma nat_eqb_refl : forall n, nat_eqb n n = true.
Proof.
 induction n; trivial.
Qed.

Lemma nat_eqb_sym : forall n m, nat_eqb n m = nat_eqb m n.
Proof.
 induction n; destruct m; simpl; trivial.
Qed.

Lemma nat_eqb_trans: forall (n m p: nat),
 nat_eqb n m -> nat_eqb m p -> nat_eqb n p.
Proof.
 intros.
 apply nat_eqb_true in H.
 apply nat_eqb_true in H0.
 subst; apply nat_eqb_refl.
Qed.

Lemma eqb_sym : forall x y, eqb x y = eqb y x.
Proof.
 intros; case x; case y; trivial.
Qed.

Lemma eqb_spec : forall (x y:bool), if eqb x y then x = y else x <> y.
Proof.
 intros.
 case_eq (eqb x y).
 apply eqb_prop.
 intros H1 H2; subst.
 rewrite eqb_reflx in H1.
 inversion H1.
Qed.

Definition eq_dec_nat (n m:nat) : sumbool (n = m) True :=
 match eq_nat_dec n m with
  | left i => left _ i
  | right _ => right _ I
 end.

Lemma eq_dec_nat_r : forall n m i, eq_dec_nat n m = right _ i -> n <> m.
Proof.
 intros n m; simpl; intro i.
 unfold eq_dec_nat; case (eq_nat_dec n m); intros.
 discriminate.
 trivial.
Qed.

(* Sum of the first [p] natural numbers *)

Fixpoint sum_k_p (k p:nat) {struct p} : nat :=
 if Compare_dec.leb k p then
  match p with
   | O => O
   | S p' => sum_k_p k p' + p
  end
  else 0.

Lemma sum_k_p_plus : forall p1 p2 p3,
 p1 <= p2 ->
 p2 <= p3 ->
 sum_k_p p1 p2 + sum_k_p (S p2) p3 = sum_k_p p1 p3.
Proof.
 induction p3; simpl; intros.
 assert (W:p2 = 0) by omega; rewrite W, plus_0_r; trivial.
 assert (W:p1 <= S p3) by apply le_trans with (1:=H) (2:=H0).
 rewrite (leb_correct _ _ W).
 case_eq (Compare_dec.leb p2 p3); intros.
 rewrite plus_assoc, IHp3; auto using leb_complete.
 apply leb_complete_conv in H1.
 assert (W1:p2 = S p3) by omega; rewrite plus_0_r, W1; simpl.
 rewrite (leb_correct _ _ W); trivial.
Qed.

Lemma sum_k_p_lt : forall k p, p < k -> sum_k_p k p = 0.
Proof.
 destruct p; simpl; intros.
 destruct (Compare_dec.leb k 0); trivial.
 rewrite leb_correct_conv; auto with arith.
Qed.

Lemma sum_k_p_eq : forall k, sum_k_p k k = k.
Proof.
 destruct k; trivial.
 simpl.
 rewrite leb_correct; auto with arith.
 rewrite sum_k_p_lt; auto with arith.
Qed.

Lemma sum_Sk_p : forall k p,
 k <= p ->
 sum_k_p k p = k + sum_k_p (S k) p.
Proof.
 intros k p H; destruct (le_lt_dec (S k) p).
 assert (W:k <= S k) by auto with arith.
 rewrite <- (@sum_k_p_plus k k p); trivial.
 rewrite sum_k_p_eq; trivial.
 assert (W: k = p) by omega.
 rewrite (sum_k_p_lt l), plus_0_r, W; apply sum_k_p_eq.
Qed.

Lemma sum_k_Sp : forall k p,
 k <= S p ->
 sum_k_p k (S p) = sum_k_p k p + S p.
Proof.
 intros; simpl; rewrite leb_correct; trivial.
Qed.

Lemma sum_0_n : forall n, 2 * sum_k_p 0 n = n * (n + 1).
Proof.
 induction n; trivial.
 rewrite sum_k_Sp; [ | auto with arith].
 rewrite mult_plus_distr_l, IHn; ring.
Qed.

(* New Datatypes *)

Inductive triple (A B C:Type) : Type :=
| Triple : A -> B -> C -> triple A B C.

Inductive quadruple (A B C D:Type) : Type :=
| Quad : A -> B -> C -> D -> quadruple A B C D.

Section PERMUTATION.

 Variables A B : Type.
 Variable  P : A -> B -> Prop.

 Inductive PermutP : list A -> list B -> Prop :=
 | permP_nil : PermutP nil nil
 | permP_swap : forall x x' l l1' l2',
    P x x' -> PermutP l (l1' ++ l2') -> PermutP (x :: l) (l1' ++ x' :: l2').

 Lemma PermutP_length : forall l1 l2,
  PermutP l1 l2 -> length l1 = length l2.
 Proof.
  induction 1; simpl; intros; trivial.
  rewrite IHPermutP; repeat rewrite app_length; simpl; auto with arith.
 Qed.

 Lemma PermutP_app : forall l1 l1',
  PermutP l1 l1' ->
  forall l2 l2',
   PermutP l2 l2' -> PermutP (l1++l2) (l1'++l2').
 Proof.
  induction 1; intros; simpl; trivial.
  rewrite app_ass; simpl; constructor; trivial.
  rewrite <- app_ass; auto.
 Qed.

 Lemma PermutP_cons : forall a b la lb,
  P a b ->
  PermutP la lb ->
  PermutP (a::la) (b::lb).
 Proof.
  intros; change (b::lb) with (nil++b::lb); constructor; trivial.
 Qed.

 Lemma PermutP_cons_r_inv : forall x l1 l2,
  PermutP l1 (x::l2) ->
  exists x', exists l, exists l',
   l1 = l ++ x' :: l' /\
   P x' x /\
   PermutP (l++l') l2.
 Proof.
  induction l1; intros l2 H; inversion H; clear H; subst.
  destruct l1'; simpl in *.
  injection H2; clear H2; intros; subst.
  exists a; exists nil; exists l1; repeat split; trivial.
  injection H2; clear H2; intros; subst.
  destruct (IHl1 _ H4) as (x'' , (l, (l', (W1,(W2,W3))))); clear H4; subst.
  exists x''; exists (a::l); exists l'; repeat split; trivial.
  simpl; constructor; trivial.
 Qed.

 Lemma PermutP_cons_r : forall a b l l' l2,
  PermutP (l++l') l2 ->
  P a b ->
  PermutP (l ++ a :: l') (b::l2).
 Proof.
  induction l; simpl; intros l' l2 H Hp.
  apply PermutP_cons; trivial.
  inversion H; clear H; subst.
  change (b :: l1' ++ x' :: l2') with ((b :: l1') ++ x' :: l2');
   constructor; simpl; auto.
 Qed.

 Lemma PermutP_app_cons_inv : forall x l2 l1 l3,
  PermutP (l1 ++ x :: l2) l3 ->
  exists l4, exists l5, exists x',
   l3 = l4 ++ (x'::l5) /\
   P x x' /\
   PermutP (l1++l2) (l4++l5) .
 Proof.
  induction l1; simpl; intros.
  inversion H.
  exists l1'; exists l2'; exists x'; auto.
  inversion H; clear H; subst.
  destruct (IHl1 _ H4) as (l4, (l5, (x'', (Heq, (HP, HPr))))).
  clear IHl1 H4.
  generalize l1' l2' l1 l2 l4 l5 Heq HPr.
  clear HPr Heq l1' l2' l4 l5 l1 l2.
  induction l1'; simpl; intros.
  rewrite Heq; exists (x'::l4); exists l5; exists x''; repeat split; trivial.
  simpl; apply PermutP_cons; trivial.
  destruct l4; simpl in Heq; injection Heq; clear Heq; intros; subst; simpl in *.
  exists nil; exists (l1' ++ x' :: l2'); exists x''; repeat split; trivial.
  simpl; constructor; trivial.
  destruct (PermutP_cons_r_inv HPr) as (b', (l6, (l7, (W1,(W2,W3))))).
  destruct (IHl1' _ _ _ _ _ H W3) as (l8, (l9, (y, (W4, (W5,W6))))).
  rewrite W4, W1.
  exists (b::l8); exists l9; exists y; repeat split; trivial.
  simpl; inversion W6; clear W6; subst.
  change (b :: l1'0 ++ x'0 :: l2'0) with ((b:: l1'0) ++ x'0 :: l2'0).
  constructor; trivial.
  simpl; apply PermutP_cons_r; trivial.
 Qed.

End PERMUTATION.

Section PERMUTATION_PROP.

 Lemma PermutP_trans : forall (A B:Type) (P:A -> B -> Prop) l1 l2,
  PermutP P l1 l2 ->
  forall l3, PermutP (@eq _) l2 l3 -> PermutP P l1 l3.
 Proof.
  induction 1; simpl; intros.
  inversion H; constructor.
  destruct (PermutP_app_cons_inv (B:= B) (P:= @eq B) _ _ _ H1) as
   (l4, (l5, (x'', (W1, (W2, W3))))); clear H1; subst.
  constructor; auto.
 Qed.

 Lemma PermutP_refl : forall A (R:A -> A -> Prop) (l:list A),
  (forall x, In x l -> R x x) ->
  PermutP R l l.
 Proof.
  induction l; intros.
  constructor.
  apply PermutP_cons.
  apply H; apply in_eq.
  apply IHl; intros x Hx; exact (H x (in_cons  a _ _  Hx)).
 Qed.

 Lemma PermutP_sym : forall A B R (la:list A) (lb:list B),
  PermutP (fun b a => R a b) lb la ->
  PermutP R la lb.
 Proof.
  induction 1.
  constructor.
  apply PermutP_cons_r; trivial.
 Qed.

 Lemma PermutP_eq : forall A (l:list A), PermutP (@eq A) l l.
 Proof.
  induction l.
  constructor.
  apply PermutP_cons; trivial.
 Qed.

 Lemma PermutP_app_comm : forall A (l1 l2:list A),
  PermutP (@eq _) (l1++l2) (l2++l1).
 Proof.
  induction l1; simpl; intros.
  rewrite <- app_nil_end; apply PermutP_refl; unfold reflexive; trivial.
  constructor; trivial.
 Qed.

 Lemma PermutP_In : forall (A:Type) (d1 d2:list A) (x:A),
  PermutP (@eq _) d1 d2 -> In x d1 -> In x d2.
 Proof.
  intros A d1 d2 x Hperm.
  induction Hperm.
  tauto.
  intro Hx; simpl in Hx; destruct Hx as [Hx | Hx].
  rewrite <- Hx; rewrite H.
  apply in_or_app; right; simpl; tauto.
  apply in_or_app.
  destruct (@in_app_or _ _ _ _ (IHHperm Hx)).
  left; assumption.
  right; simpl; right; assumption.
 Qed.

 Lemma PermutP_rev : forall (A:Type) (l:list A),
  PermutP (@eq _) l (rev l).
 Proof.
  induction l; simpl; try constructor; auto.
  rewrite <- app_nil_end; trivial.
 Qed.

 Lemma PermutP_map : forall A B C (R:A -> C -> Prop) (f:B -> C) la lb,
  PermutP (fun a b => R a (f b)) la lb <->
  PermutP R la (map f lb).
 Proof.
  intros A B C R f la lb; split.
  induction 1; simpl.
  constructor.
  rewrite map_app; simpl; constructor; trivial.
  rewrite <- map_app; trivial.
  generalize la; clear la.
  induction lb; intros la H; simpl in H; inversion H; subst.
  constructor.
  destruct l1'; discriminate.
  destruct (PermutP_cons_r_inv H) as [b [lla [llb [W1 [W2 W3] ] ] ] ]; subst.
  rewrite W1.
  apply PermutP_sym; constructor; trivial.
  apply PermutP_sym; auto.
 Qed.

 Lemma PermutP_weaken : forall A B (R1 R2:A -> B -> Prop) la lb,
  (forall a b, In a la -> In b lb -> R1 a b -> R2 a b) ->
  PermutP R1 la lb -> PermutP R2 la lb.
 Proof.
  induction la; intros.
  (* base case *)
  inversion H0; constructor.
  (* inductive case *)
  induction lb; inversion H0; subst.
  elim (app_cons_not_nil l1' l2' x' (eq_sym H3)).
  apply permP_swap.
  apply H; auto using in_eq.
  rewrite <-H3; apply in_or_app; right; apply in_eq.
  apply IHla.
  intros; apply H; auto using in_cons, in_eq.
  rewrite <-H3; destruct (in_app_or _ _ _  H2);
  auto using in_or_app, in_cons.
  trivial.
 Qed.

 Lemma Permut_seq_R : forall (R:nat -> nat -> Prop) k a b,
  (forall i, 0 <= i < k -> R (i + a) (i + b)) ->
  PermutP R (seq a k) (seq b k).
 Proof.
  induction k; simpl; intros.
  constructor.
  apply PermutP_cons.
  refine (H 0 _); auto with arith.
  apply IHk; intros.
  repeat rewrite <- plus_n_Sm.
  refine (H (S i) _); omega.
 Qed.

 Lemma PermutP_seq_shift : forall n i1 i2 g ,
  PermutP (fun v1 v2 => v1 = g v2) (seq (S i1)  n) (seq (S i2) n) ->
  PermutP (fun v1 v2 => S v1 = g (S v2)) (seq i1 n) (seq i2 n).
 Proof.
  intros.
  rewrite (PermutP_map (fun v1 v2 => S v1 = g v2) S).
  apply PermutP_sym.
  apply PermutP_weaken with (fun v1 v2 => g v1 = S v2); [ auto | ].
  rewrite (PermutP_map (fun v1 v2 => g v1 = v2) S).
  rewrite seq_shift, seq_shift.
  apply PermutP_sym.
  apply PermutP_weaken with (fun v1 v2 => v1 = g v2); auto.
 Qed.

End PERMUTATION_PROP.

Section PERMUTP_BIJECTION.

 Variable T : Type.

 Variables f f_inv : T -> T.

 Lemma PermutP_NoDup : forall (l1:list T) (l2:list T),
  NoDup l1 ->
  NoDup l2 ->
  (forall x, In x l1 -> f (f_inv x) = x) ->
  (forall x, In x l2 -> f_inv (f x) = x) ->
  (forall x, In x l2 -> In (f x) l1) ->
  (forall x, In x l1 -> In (f_inv x) l2) ->
  PermutP (fun v1 v2 => v1 = f v2) l1 l2.
 Proof.
  induction l1; intros l2 H H0 f_inv_spec f_spec H1 H2.
  destruct l2.
  constructor.
  elim (H1 t); simpl; auto.
  destruct (In_split (f_inv a) l2) as (hd, (tl, H3)).
  apply H2; simpl; auto.

  subst; constructor.
  rewrite f_inv_spec; simpl; auto.

  inversion_clear H.
  apply IHl1; clear IHl1; trivial; intros.
  apply NoDup_remove_1 with (f_inv a); trivial.
  intros; apply f_inv_spec; simpl; auto.
  intros; apply f_spec.
  apply in_app_or in H; destruct H; apply in_or_app; simpl; auto.

  assert (In (f x) (a::l1)).
   apply H1; apply in_app_or in H; apply in_or_app; simpl; destruct H; auto.
  simpl in H5; destruct H5; trivial.
  elim (@NoDup_remove_2 _ _ _ _ H0); rewrite H5; rewrite f_spec; trivial.
  apply in_app_or in H.
  apply in_or_app; simpl; destruct H; auto.

  assert (H6:In (f_inv x) (hd ++ f_inv a :: tl)) by (apply H2; simpl; auto).
  apply in_or_app.
  destruct (in_app_or _ _ _ H6).
  auto.
  destruct H5; [ | auto].
  elim H3; clear H3.

  apply (f_equal f) in H5.
  rewrite f_inv_spec in H5; [ | simpl; auto].
  rewrite H5, f_inv_spec; simpl; auto.
 Qed.

End PERMUTP_BIJECTION.

(** Sequences *)

Lemma seq_append : forall k1 k2 n,
 seq n (k1 + k2) = seq n k1 ++ seq (n + k1) k2.
Proof.
 induction k1; simpl; intros.
 rewrite plus_0_r; trivial.
 rewrite <- plus_n_Sm, IHk1; trivial.
Qed.

Lemma seq_S : forall m n,
 seq n (S m) = seq n m ++ (n + m :: nil).
Proof.
 induction m; intros.
 rewrite plus_0_r; trivial.
 change (S (S m)) with (1 + (S m)).
 rewrite seq_append, IHm.
 replace (seq n (S m)) with (seq n 1 ++ seq (n + 1) m)
  by (rewrite IHm, <- seq_append, IHm; trivial).
 rewrite app_ass, <- plus_assoc; trivial.
Qed.

Lemma le_In_seq : forall n m i,
 m <= i < n + m ->
 In i (seq m n).
Proof.
 induction n; intros m i [Hge Hle].
 elimtype False; omega.

 case (le_lt_or_eq _ _ Hle); clear Hle; intro.
 change (S n) with (1 + n).
 rewrite seq_append.
 apply in_or_app.
 case (le_lt_or_eq _ _ Hge); clear Hge; intro.
 right.
 rewrite plus_comm.
 change (1 + m) with (S m).
 rewrite <- seq_shift.
 destruct i; [elim (lt_n_O _ H0) | ].
 apply in_map; apply IHn; omega.

 simpl; auto.

 simpl in H; injection H; intro.
 clear H Hge; subst.
 destruct n.
 simpl; auto.

 simpl plus.
 change (S (S n)) with (1 + (S n)).
 rewrite seq_append.
 rewrite (plus_comm m 1).
 change (1 + m) with (S m).
 rewrite <- seq_shift.
 apply in_or_app.

 right; simpl plus.
 apply in_map.
 apply IHn; omega.
Qed.

Lemma In_seq_le : forall n m i,
 In i (seq m n) ->
 m <= i < n + m.
Proof.
 induction n; intros m i Hi.
 elim Hi.
 simpl in Hi.
 case Hi; clear Hi; intro Hi.
 rewrite <- Hi; omega.
 rewrite <- seq_shift in Hi.
 rewrite in_map_iff in Hi.
 destruct Hi as [i0 [H1 H2] ].
 rewrite <- H1.
 generalize (IHn _ _ H2); omega.
Qed.

Lemma seq_PermutP : forall k p,
 p <= k ->
 PermutP (@eq _) (seq 0 k) (seq p (k - p) ++ seq 0 p).
Proof.
 intros k p H.
 pattern k at 1; replace k with (p + (k - p)); auto with arith.
 rewrite seq_append, plus_0_l.
 apply PermutP_app_comm.
Qed.

(** Sorted lists *)

Definition monotone (A B:Type) (R1:A -> A -> Prop) (R2:B -> B -> Prop) (f:A -> B) :=
 forall a1 a2, R1 a1 a2 -> R2 (f a1) (f a2).

Hint Unfold monotone.

Lemma sorted_map : forall (A B:Type) (R1:A -> A -> Prop) (R2:B -> B -> Prop) (f:A -> B)
 (l:list A),
 monotone R1 R2 f ->
 sort R1 l ->
 sort R2 (map f l).
Proof.
 induction l; intros; simpl.
 constructor.
 apply sort_inv in H0.
 constructor.
 firstorder.
 induction l; constructor.
 apply H.
 destruct H0 as [? H1].
 apply lelistA_inv in H1; trivial.
Qed.

Lemma lelistA_filter : forall (A:Type) (R:A -> A -> Prop) (P:A -> bool)
 (a:A) (l:list A),
 transitive A R ->
 sort R l ->
 lelistA R a l ->
 lelistA R a (filter P l).
Proof.
 induction l; intros.
 constructor.
 apply sort_inv in H0.
 apply lelistA_inv in H1.
 simpl; case (P a0).
 constructor; trivial.
 apply IHl.
 trivial.
 firstorder.
 destruct l.
 constructor.
 destruct H0.
 apply lelistA_inv in H2.
 constructor.
 apply H with a0; trivial.
Qed.

Lemma sorted_filter : forall (A:Type) (R:A -> A -> Prop) (P:A -> bool)
 (l:list A),
 transitive A R ->
 sort R l ->
 sort R (filter P l).
Proof.
 induction l; intros.
 constructor.
 apply sort_inv in H0; simpl; firstorder.
 case (P a); [ | trivial].
 constructor; trivial.
 apply lelistA_filter; trivial.
Qed.

Lemma sorted_cons : forall l a,
 sort lt l ->
 (forall b, In b l -> a < b) ->
 sort lt (a :: l).
Proof.
 induction l; intros; constructor.
 trivial.
 constructor.
 trivial.
 constructor.
 apply H0.
 apply in_eq.
Qed.

Lemma sorted_seq : forall n a, sort lt (seq a n).
Proof.
 induction n; simpl; intros.
 constructor.
 apply sorted_cons.
 trivial.
 intros.
 apply In_seq_le in H.
 omega.
Qed.

Lemma NoDup_seq : forall a b, NoDup (seq a b).
Proof.
 induction b.
 constructor.
 rewrite seq_S.
 apply NoDup_app with (1:=IHb).
 constructor; [intro H; elim H | constructor].
 intros x [H | H] Hin.
 subst; apply In_seq_le in Hin; omega.
 elim H.
Qed.

Lemma eqb_spec_beg A (a_beq : A -> A -> bool):
  (forall x : A,
    (fun x0 : A => forall y : A, a_beq x0 y = true -> x0 = y) x) ->
  (forall x : A,
    (fun x0 : A => forall y : A, x0 = y -> a_beq x0 y = true) x) ->
  (forall (x y : A), if a_beq x y then x = y else x <> y).
Proof.
 intros.
 case_eq (a_beq x y); intros.
 apply H; trivial.
 intro.
 rewrite (H0 x y H2) in H1.
 discriminate.
Qed.


Require Export Shared.FiniteTypes.FinTypes Shared.FiniteTypes.BasicFinTypes Shared.FiniteTypes.CompoundFinTypes Shared.FiniteTypes.VectorFin.
Require Export Shared.Vectors.FinNotation.
Require Export Shared.Retracts.
Require Export Shared.Inhabited.
Require Export Shared.Base.
Require Export Shared.Vectors.Vectors Shared.Vectors.VectorDupfree.

(* Require Export smpl.Smpl. *)

Global Open Scope vector_scope.

Section Loop.
  Variable (A : Type) (f : A -> A) (p : A -> bool).

  Fixpoint loop (a : A) (k : nat) {struct k} :=
    if p a then Some a else
      match k with
      | O => None
      | S k' => loop (f a) k'
      end.

  Lemma loop_step k a :
    p a = false ->
    loop a (S k) = loop (f a) k.
  Proof. intros HHalt. destruct k; cbn; rewrite HHalt; auto. Qed.

  Lemma loop_injective k1 k2 a b b' :
    loop a k1 = Some b ->
    loop a k2 = Some b' ->
    b = b'.
  Proof.
    revert k2 b b' a. induction k1; intros; cbn in *.
    - destruct (p a) eqn:E; inv H.
      destruct k2; cbn in H0; rewrite E in H0; now inv H0.
    - destruct (p a) eqn:E.
      + inv H. destruct k2; cbn in H0; rewrite E in H0; now inv H0.
      + destruct k2; cbn in H0; rewrite E in H0; try now inv H0.
        eauto.
  Qed.

  Lemma loop_fulfills k a b :
    loop a k = Some b ->
    p b = true.
  Proof.
    revert a; induction k; intros; cbn in *.
    - now destruct (p a) eqn:E; inv H.
    - destruct (p a) eqn:E.
      + now inv H.
      + eapply IHk; eauto.
  Qed.

  Lemma loop_0 k a :
    p a = true ->
    loop a k = Some a.
  Proof. intros. destruct k; cbn; now rewrite H. Qed.

  Lemma loop_eq_0 k a b :
    p a = true ->
    loop a k = Some b ->
    b = a.
  Proof. intros H1 H2. eapply (loop_0 k) in H1. congruence. Qed.

  Lemma loop_monotone (k1 k2 : nat) (a b : A) : loop a k1 = Some b -> k1 <= k2 -> loop a k2 = Some b.
  Proof.
    revert a k2; induction k1 as [ | k1' IH]; intros a k2 HLoop Hk; cbn in *.
    - destruct k2; cbn; destruct (p a); now inv HLoop.
    - destruct (p a) eqn:E.
      + inv HLoop. now apply loop_0.
      + destruct k2 as [ | k2']; cbn in *; rewrite E.
        * exfalso. omega.
        * apply IH. assumption. omega.
  Qed.

End Loop.

Section LoopLift.

  Variable A B : Type. (** Abstract states *)
  Variable lift : A -> B. (** Lifting function between states *)
  Variable (f : A -> A) (f' : B -> B). (** Abstract steps *)
  Variable (h : A -> bool) (h' : B -> bool). (** Abstract halting states *)

  Hypothesis halt_lift_comp : forall x:A, h' (lift x) = h x.
  Hypothesis step_lift_comp : forall x:A, h x = false -> f' (lift x) = lift (f x).

  Lemma loop_lift (k : nat) (a a' : A) :
    loop (A := A) f  h  a        k = Some a' ->
    loop (A := B) f' h' (lift a) k = Some (lift a').
  Proof.
    revert a. induction k as [ | k']; intros; cbn in *.
    - rewrite halt_lift_comp. destruct (h a); now inv H.
    - rewrite halt_lift_comp. destruct (h a) eqn:E.
      + now inv H.
      + rewrite step_lift_comp by auto. now apply IHk'.
  Qed.

  Lemma loop_unlift (k : nat) (a : A) (b' : B) :
    loop f' h' (lift a) k = Some b' ->
    exists a' : A, loop f h a k = Some a' /\ b' = lift a'.
  Proof.
    revert a b'. induction k as [ | k']; intros; cbn in *.
    - rewrite halt_lift_comp in H.
      exists a. destruct (h a) eqn:E; now inv H.
    - rewrite halt_lift_comp in H.
      destruct (h a) eqn:E.
      + exists a. now inv H.
      + rewrite step_lift_comp in H by assumption.
        specialize IHk' with (1 := H) as (x&IH&->). now exists x.
  Qed.

End LoopLift.

Section LoopMerge.

  Variable A : Type. (** abstract states *)
  Variable f : A -> A. (** abstract step function *)
  Variable (h h' : A -> bool). (** abstract halting functions *)

  (** Every non-halting state w.r.t. [h] is also a non-halting state w.r.t. [h'] *)
  Hypothesis halt_comp : forall a, h a = false -> h' a = false.

  Lemma loop_merge (k1 k2 : nat) (a1 a2 a3 : A) :
    loop f h  a1 k1      = Some a2 ->
    loop f h' a2 k2      = Some a3 ->
    loop f h' a1 (k1+k2) = Some a3.
  Proof.
    revert a1 a2 a3. induction k1 as [ | k1' IH]; intros a1 a2 a3 HLoop1 HLoop2; cbn in HLoop1.
    - now destruct (h a1); inv HLoop1.
    - destruct (h a1) eqn:E.
      + inv HLoop1. eapply loop_monotone; eauto. omega.
      + cbn. rewrite (halt_comp E). eapply IH; eauto.
  Qed.

  Lemma loop_split (k : nat) (a1 a3 : A) :
    loop f h' a1 k = Some a3 ->
    exists k1 a2 k2,
      loop f h  a1 k1 = Some a2 /\
      loop f h' a2 k2 = Some a3 /\
      k1 + k2 <= k.
  Proof.
    revert a1 a3. revert k; refine (size_recursion id _); intros k IH. intros a1 a3 HLoop. cbv [id] in *.
    destruct k as [ | k']; cbn in *.
    - destruct (h' a1) eqn:E; inv HLoop.
      exists 0, a3, 0. cbn. rewrite E.
      destruct (h a3) eqn:E'.
      + auto.
      + apply halt_comp in E'. congruence.
    - destruct (h a1) eqn:E.
      + exists 0, a1, (S k'). cbn. rewrite E. auto.
      + rewrite (halt_comp E) in HLoop.
        apply IH in HLoop as (k1&c2&k2&IH1&IH2&IH3); [ | omega].
        exists (S k1), c2, k2. cbn. rewrite E. repeat split; auto. omega.
  Qed.

End LoopMerge.

(** Apply functions in tuples, options, etc. *)
Section Map.
  Variable X Y Z : Type.

  Definition map_opt : (X -> Y) -> option X -> option Y :=
    fun f a =>
      match a with
      | Some x => Some (f x)
      | None => None
      end.

  Definition map_inl : (X -> Y) -> X + Z -> Y + Z :=
    fun f a =>
      match a with
      | inl x => inl (f x)
      | inr y => inr y
      end.

  Definition map_inr : (Y -> Z) -> X + Y -> X + Z :=
    fun f a =>
      match a with
      | inl y => inl y
      | inr x => inr (f x)
      end.

  Definition map_fst : (X -> Z) -> X * Y -> Z * Y := fun f '(x,y) => (f x, y).
  Definition map_snd : (Y -> Z) -> X * Y -> X * Z := fun f '(x,y) => (x, f y).

End Map.

(** We often use the vernacular commands
<<
Local Arguments plus : simpl never.
Local Arguments mult : simpl never.
>>
to avoid unfolding [*] and [+] in running time polynoms. However, this can break proofs that use [Fin.R], since the [plus] in the type of [Fin.R] doesn't simplify with [cbn] any more. To work around this problem, we have a copy of [Fin.R] and [plus], that isn't affected by these commands. *)

Fixpoint plus' (n m : nat) { struct n } : nat :=
  match n with
  | 0 => m
  | S p => S (plus' p m)
  end.

Fixpoint FinR {m} n (p : Fin.t m) : Fin.t (plus' n m) :=
  match n with
  | 0 => p
  | S n' => Fin.FS (FinR n' p)
  end.


Require Import Setoid.
Require Import Coq.Lists.List.
Require Import Bool.
Import ListNotations.
Import PeanoNat.Nat.
Require Import Lia.

Require Import Lib.EqDec.
Require Import Lib.LinearOrder.
Require Import Lib.Sorted.
Require Import Extras.Permutations.

Inductive Deduplicated {A: Type} : list A -> Prop :=
| DedupNil  : Deduplicated []
| DedupCons : forall (x: A) (l: list A), ~ In x l -> Deduplicated l -> Deduplicated (x::l).

Fixpoint any {A: Type} (p : A -> bool) (l: list A) : bool :=
  match l with
  | [] => false
  | (x::l') => if p x then true else any p l'
  end.

Definition CountDeduplicated {A: Type} `{EqDec A} (t: list A) : Prop :=
  forall x : A, In x t -> count (eqf x) t = 1.

Definition Elem_eq {A: Type} (l l' : list A) : Prop :=
  forall p : A -> bool, any p l = any p l'.

Definition Same_elements {A: Type} (l l' : list A) : Prop :=
  forall x : A, In x l <-> In x l'.

Lemma Elem_eq_sym {A: Type} (l l' : list A) : Elem_eq l l' <-> Elem_eq l' l.
Proof.
  split; intros H p; symmetry; auto.
Qed.

Lemma Elem_eq_trans {A: Type} (y x z : list A) :
  Elem_eq x y -> Elem_eq y z -> Elem_eq x z.
Proof.
  intros H H' p. rewrite H. auto.
Qed.

Theorem any_in_eq_dec (A: Type) `{E: EqDec A} (l: list A) (x: A) :
  reflect (In x l) (any (eqf x) l).
Proof.
  destruct (any (eqf x) l) eqn:H; constructor.
  - induction l.
    + cbn in *. inversion H.
    + destruct (eqf_leibniz x a); cbn in *.
      * left. symmetry. assumption.
      * right. apply IHl. rewrite (not_eqf_iff x a) in n.
        rewrite n in H. assumption.
  - induction l; auto. intro H0. cbn in *. destruct H0.
    + subst. rewrite eqf_refl in H. inversion H.
    + destruct (eqf x a) eqn:H1; [inversion H|].
      specialize (IHl H H0). auto.
Qed.

Theorem any_in_eq_dec_iff (A: Type) `{E: EqDec A} (l: list A) (x: A) :
  (In x l <-> any (eqf x) l = true).
Proof.
  apply reflect_iff. apply any_in_eq_dec.
Qed.

Lemma in_any_true (A: Type) (l: list A) (x: A) (p : A -> bool) :
  p x = true -> In x l -> any p l = true.
Proof.
  intros P I. induction l; [auto|].
  cbn in I; destruct I.
  - subst; cbn; rewrite P; auto.
  - cbn. destruct (p a); auto.
Qed.

Lemma exist_in_any (A: Type) (l: list A) (p : A -> bool) :
  any p l = true -> exists x: A, p x = true /\ In x l.
Proof.
  intros H. induction l; [inversion H|].
  cbn in *. destruct (p a) eqn:H0.
  - exists a. split; [assumption| left; auto].
  - specialize (IHl H). destruct IHl as (x & (P & I)). exists x.
    split; [| right]; auto.
Qed.

Lemma forall_in_any (A: Type) (l: list A) (p : A -> bool) :
  any p l = false -> forall x: A, In x l -> p x = false.
Proof.
  induction l.
  - cbn in *. intros _ x [].
  - intros H x I. cbn in *. destruct (p a) eqn:H0; [inversion H|].
    destruct I; [subst| apply IHl]; auto.
Qed.

Theorem elem_eq_for_eq_dec (A: Type) `{E: EqDec A} (l l': list A) :
  Elem_eq l l' <-> Same_elements l l'.
Proof.
  unfold Elem_eq, Same_elements. split.
  - intros H x. specialize (H (eqf x)).
    rewrite any_in_eq_dec_iff, any_in_eq_dec_iff, H.
    split; intro H0; apply H0.
  - intros H p. destruct (any p l) eqn:e1; destruct (any p l') eqn:e2; auto.
    + destruct (exist_in_any A l p) as (x & (P & H0)); auto.
      rewrite H in H0. assert (p x = false) by (apply (forall_in_any _ l'); auto).
      rewrite P in H1. auto.
    + destruct (exist_in_any A l' p) as (x & (P & H0)); auto.
      rewrite <- H in H0. assert (p x = false) by (apply (forall_in_any _ l); auto).
      rewrite P in H1. auto.
Qed.

Lemma any_concat {A: Type} (l l': list A) (p: A -> bool): any p (l ++ l') = any p l || any p l'.
Proof.
  induction l; auto. cbn. destruct (p a); auto.
Qed.

(* Uniquness *)

Lemma count_for_not_satisfied_pred {A: Type} (l: list A) (p: A->bool) :
  (forall x : A, In x l -> p x = false) -> count p l = 0.
Proof.
  intros N. induction l; auto. cbn. rewrite IHl.
  - rewrite (N a); auto. cbn. left. auto.
  - intros x I. apply (N x). cbn. right. assumption.
Qed.

Lemma count_existing {A: Type} (l: list A) (p: A->bool) (x: A) :
  p x = true -> In x l -> count p l <> O.
Proof.
  intros pred I. induction l; cbn in *; [inversion I|].
  destruct I.
  - subst. rewrite pred. apply neq_succ_0.
  - destruct (p a); auto.
Qed.

Theorem dup_def_eq {A: Type} `{LinearOrder A} (l : list A) :
  Deduplicated l <-> CountDeduplicated l.
Proof.
  unfold CountDeduplicated. split.
  - intros D x I. induction D; cbn in I; [inversion I|].
    destruct I.
    + subst. cbn [count]. rewrite eqf_refl, count_for_not_satisfied_pred; auto.
      intros y I. rewrite <- not_eqf_iff. intros e. subst. apply H0. auto.
    + cbn [count]. rewrite (IHD H1). assert (x <> x0) by (intro e; subst; auto).
      rewrite not_eqf_iff in H2. rewrite H2. auto.
  - intro D. induction l; constructor.
    + intro I. specialize (D a (or_intror I)). cbn [count] in D.
      rewrite eqf_refl in D.
      assert (count (eqf a) l <> O) by (apply count_existing with (x := a); auto; apply eqf_refl).
      apply H0. inversion D; auto.
    + apply IHl. intros x I. cbn [count] in *. specialize (D x (or_intror I)).
      destruct (eqf x a) eqn:e; [| auto].
      rewrite <- eqf_iff in e. subst.
      assert (count (eqf a) l <> O) by (apply count_existing with (x := a); auto; apply eqf_refl).
      exfalso. apply H0. inversion D; auto.
Qed.

Lemma any_count_true {A: Type} (l: list A) (p: A -> bool) :
  (count p l <> 0) <-> (any p l = true).
Proof.
  split; intro H.
  - induction l.
    + cbn in *. contradiction.
    + cbn in *. destruct (p a) eqn: e; auto.
  - intro C. induction l.
    + cbn in *. discriminate.
    + cbn in *. destruct (p a) eqn: e; try discriminate. apply IHl; auto.
Qed.

Lemma any_count_false {A: Type} (l: list A) (p: A -> bool) :
  (count p l = 0) <-> (any p l = false).
Proof.
  split; intro H.
  - induction l; auto. cbn in *. destruct (p a) eqn: e; auto; try discriminate.
  - induction l; auto. cbn in *. destruct (p a) eqn: e; auto; try discriminate.
Qed.

Theorem unique_dedup_perm {A: Type} `{LinearOrder A} (l l': list A) :
  Elem_eq l l' -> Deduplicated l -> Deduplicated l' -> permutation l l'.
Proof.
  rewrite dup_def_eq, dup_def_eq. rewrite <-PredPerm_is_perm, pred_elem_prem_equiv.
  unfold Elem_eq, CountDeduplicated. intros eq d1 d2 x.
  specialize (eq (eqf x)). destruct (any (eqf x) l) eqn:I1; destruct (any (eqf x) l') eqn:I2; try discriminate.
  - rewrite <- any_count_true in I1. rewrite <- any_count_true in I2.
    rewrite <- in_count_not_O in I1. rewrite <- in_count_not_O in I2. rewrite d1, d2; auto.
  - rewrite <- any_count_false in I1. rewrite <- any_count_false in I2. rewrite I1, I2. auto.
Qed.

Theorem dedupsorted_unique_representation {A: Type} `{LinearOrder A} (l l': list A) : Elem_eq l l' ->
  Sorted l -> Sorted l' -> Deduplicated l -> Deduplicated l' -> l = l'.
Proof.
  intros e_eq s1 s2 d1 d2. apply sorted_unique_representation; auto. apply unique_dedup_perm; auto.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Axioms                                                                  *
**************************************************************************)

Set Implicit Arguments.

(** This file is used to extend Coq with standard axioms from classical,
    non-constructive higher-order logic. (Such axioms are provided by
    default in other theorem provers like Isabelle/HOL or HOL4.) *)

(** Three axioms taken are: functional extensionality, and propositional
    extensionality and indefinite description.

    All other comomn axioms are derivable, including: the excluded middle,
    the strong excluded middle, propositional degenerency, proof irrelevance,
    injectivity of equality on dependent pairs, predicate extensionality,
    definite description, and all the versions of the axiom of choice. *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Functional extensionality *)

(** Two functions that yield equal results on equal arguments are equal. *)

Axiom fun_ext_dep : forall (A : Type) (B : A->Type) (f g : forall x, B x),
  (forall x, f x = g x) ->
  f = g.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Propositional extensionality *)

(** Two propositions that are equivalent can be considered to be equal. *)

Axiom prop_ext : forall (P Q : Prop),
  (P <-> Q) ->
  P = Q.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Indefinite description *)

(** Proofs of existence can be reified from [Prop] to [Type]. The lemma
    below is a concise statement for [(exists x, P x) -> { x : A | P x }]. *)

Axiom indefinite_description : forall (A : Type) (P : A->Prop),
  ex P ->
  sig P.

(* 2020-03-09 15:04:10 (UTC+01) *)


Require Import HoTT.
From GR Require Import heterogeneous_equality.

(** The type of paths over path defined as an inductive type.
    The goal is to represent paths in dependent families.
 *)
Inductive path_over {A : Type} (C : A -> Type)
  : forall {a₁ a₂ : A} (p : a₁ = a₂) (c₁ : C a₁) (c₂ : C a₂), Type
  := path_over_id : forall {a : A} (c : C a), path_over C idpath c c.

Arguments path_over_id {A C a} c.

(** Alternatively, we can define it using path induction. *)
Definition path_over_pi
           {A : Type} (C : A -> Type)
           {a₁ a₂ : A} (p : a₁ = a₂)
  : forall (c₁ : C a₁) (c₂ : C a₂), Type
  := match p with
     | idpath => fun c₁ c₂ => c₁ = c₂
     end.

Section equivalences.
  (** Paths in dependent families are equivalent to heterogeneous equalities. *)
  Definition path_over_to_heq
             {A : Type} {C : A -> Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
             {c₁ : C a₁} {c₂ : C a₂}
             (q : path_over C p c₁ c₂)
    : heq (ap C p) c₁ c₂
    := match q with
       | path_over_id _ _ => heq_refl _
       end.

  Definition heq_to_path_over
             {A : Type} {C : A -> Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
    : forall {c₁ : C a₁} {c₂ : C a₂} (q : heq (ap C p) c₁ c₂),
      path_over C p c₁ c₂
    := match p with
       | idpath =>
         fun c₁ c₂ q =>
           transport (path_over C idpath c₁) (heq_to_heq_pi q) (path_over_id _)
       end.

  Global Instance path_over_to_heq_isequiv
         {A : Type} {C : A -> Type}
         {a₁ a₂ : A} {p : a₁ = a₂}
         {c₁ : C a₁} {c₂ : C a₂}
    : IsEquiv (@path_over_to_heq A C a₁ a₂ p c₁ c₂).
  Proof.
    simple refine (isequiv_adjointify _ (@heq_to_path_over A C a₁ a₂ p c₁ c₂) _ _).
    - intros x ; induction p ; cbn in *.
      refine (_ @ eissect heq_to_heq_pi x).
      induction (heq_to_heq_pi x).
      reflexivity.
    - intros x ; induction x.
      reflexivity.
  Defined.

  (** Also, paths in path families are equivalent to paths in both [C a₁]. *)
  Definition path_over_to_path
             {A : Type} {C : A -> Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
             {c₁ : C a₁} {c₂ : C a₂}
             (q : path_over C p c₁ c₂)
    : transport C p c₁ = c₂
    := match q with
       | path_over_id _ _ => idpath
       end.

  Definition path_to_path_over
             {A : Type} {C : A -> Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
    : forall {c₁ : C a₁} {c₂ : C a₂} (q : transport C p c₁ = c₂),
      path_over C p c₁ c₂
    := match p with
       | idpath =>
         fun c₁ c₂ q => transport (path_over C idpath c₁) q (path_over_id _)
       end.

  Global Instance path_over_to_path_is_equiv
         {A : Type} {C : A -> Type}
         {a₁ a₂ : A} {p : a₁ = a₂}
         {c₁ : C a₁} {c₂ : C a₂}
    : IsEquiv (@path_over_to_path A C a₁ a₂ p c₁ c₂).
  Proof.
    simple refine (isequiv_adjointify _ (@path_to_path_over A C a₁ a₂ p c₁ c₂) _ _).
    - intros q ; induction p, q ; cbn in *.
      reflexivity.
    - intros x ; induction x.
      reflexivity.
  Defined.

  (** Also, paths in path families are equivalent to paths in both [C a₂]. *)
  Definition path_over_to_path_V
             {A : Type} {C : A -> Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
             {c₁ : C a₁} {c₂ : C a₂}
             (q : path_over C p c₁ c₂)
    : c₁ = transport C p^ c₂
    := match q with
       | path_over_id _ _ => idpath
       end.

  Definition path_V_to_path_over
             {A : Type} {C : A -> Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
    : forall {c₁ : C a₁} {c₂ : C a₂} (q : c₁ = transport C p^ c₂),
      path_over C p c₁ c₂
    := match p with
       | idpath =>
         fun c₁ c₂ q => transport (path_over C idpath c₁) q (path_over_id _)
       end.

  Global Instance path_over_to_path_V_is_equiv
         {A : Type} {C : A -> Type}
         {a₁ a₂ : A} {p : a₁ = a₂}
         {c₁ : C a₁} {c₂ : C a₂}
    : IsEquiv (@path_over_to_path_V A C a₁ a₂ p c₁ c₂).
  Proof.
    simple refine (isequiv_adjointify _ (@path_V_to_path_over A C a₁ a₂ p c₁ c₂) _ _).
    - intros q ; induction p ; cbn in * ; induction q.
      reflexivity.
    - intros x ; induction x.
      reflexivity.
  Defined.

  (** The definitions of paths in dependent families using inductive types and path induction, are equivalent. *)
  Definition path_over_to_path_over_pi
             {A : Type} {C : A -> Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
             {c₁ : C a₁} {c₂ : C a₂}
             (q : path_over C p c₁ c₂)
    : path_over_pi C p c₁ c₂
    := match q with
       | path_over_id _ _ => idpath
       end.

  Definition path_over_pi_to_path_over
             {A : Type} {C : A -> Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
    : forall {c₁ : C a₁} {c₂ : C a₂} (q : path_over_pi C p c₁ c₂),
      path_over C p c₁ c₂
    := match p with
       | idpath =>
         fun c₁ c₂ q => transport (path_over C 1 c₁) q (path_over_id _)
       end.

  Global Instance path_over_to_path_over_pi_is_equiv
         {A : Type} {C : A -> Type}
         {a₁ a₂ : A} {p : a₁ = a₂}
         {c₁ : C a₁} {c₂ : C a₂}
    : IsEquiv (@path_over_to_path_over_pi A C a₁ a₂ p c₁ c₂).
  Proof.
    simple refine (isequiv_adjointify _ (@path_over_pi_to_path_over A C a₁ a₂ p c₁ c₂) _ _).
    - intros x.
      induction p, x.
      reflexivity.
    - intros x ; induction x.
      reflexivity.
  Defined.
End equivalences.

Section operations.
  (** Dependent maps can be applied to paths.
      This gives a path in a dependent family.
   *)
  Definition apd_po
             {A : Type} {C : A -> Type}
             (f : forall (a : A), C a)
             {a₁ a₂ : A} (p : a₁ = a₂)
    : path_over C p (f a₁) (f a₂)
    := match p with
       | idpath => path_over_id _
       end.

  (** A path in a dependent family gives a path in a sigma type. *)
  Definition path_prod_po
             {A : Type} {C : A -> Type}
             {a₁ a₂ : A} (p : a₁ = a₂)
             {c₁ : C a₁} {c₂ : C a₂}
             (q : path_over C p c₁ c₂)
    : (a₁;c₁) = (a₂;c₂)
    := match q with
       | path_over_id _ _ => idpath
       end.

  (** If we look at a path over the identity path, then it is just a path in a certain fiber. *)
  Definition path_over_single_fiber
             {A : Type} {C : A -> Type}
             {a : A}
             {c₁ : C a} {c₂ : C a}
             (q : path_over C idpath c₁ c₂)
    : c₁ = c₂
    := path_over_to_path q.

  Global Instance path_over_single_fiber_is_equiv
         {A : Type} {C : A -> Type}
         {a : A}
         {c₁ : C a} {c₂ : C a}
    : IsEquiv (@path_over_single_fiber A C a c₁ c₂)
    := _.

  (** If the fiber is constant, then it is just a path in that fiber. *)
  Definition path_over_const
             {A C : Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
             {c₁ c₂ : C}
             (q : path_over (fun _ => C) p c₁ c₂)
    : c₁ = c₂
    := match q with
       | path_over_id _ _ => idpath
       end.

  Definition const_path_over
             {A C : Type}
             {a₁ a₂ : A} {p : a₁ = a₂}
             {c₁ c₂ : C}
             (q : c₁ = c₂)
    : path_over (fun _ => C) p c₁ c₂
    := match p, q with
       | idpath, idpath => path_over_id _
       end.

  Global Instance path_over_const_isequiv
         {A C : Type}
         {a₁ a₂ : A} {p : a₁ = a₂}
         {c₁ c₂ : C}
    : IsEquiv (@const_path_over A C a₁ a₂ p c₁ c₂).
  Proof.
    simple refine (isequiv_adjointify _ path_over_const _ _).
    - intros q ; induction q.
      reflexivity.
    - intros q ; induction p, q.
      reflexivity.
  Defined.

  (** Composing the fibration with a map [f] gives a path over [ap f p]. *)
  Definition path_over_compose
             {A B : Type} {C : B -> Type} (f : A -> B)
             {a₁ a₂ : A} {p : a₁ = a₂}
             {c₁ : C (f a₁)} {c₂ : C (f a₂)}
             (q : path_over (C o f) p c₁ c₂)
    : path_over C (ap f p) c₁ c₂
    := match q with
       | path_over_id _ _ => path_over_id _
       end.

  Definition compose_path_over
             {A B : Type} {C : B -> Type} (f : A -> B)
             {a₁ a₂ : A} {p : a₁ = a₂}
    : forall {c₁ : C (f a₁)} {c₂ : C (f a₂)} (q : path_over C (ap f p) c₁ c₂),
      path_over (C o f) p c₁ c₂
    := match p with
       | idpath =>
         fun c₁ c₂ q => transport (path_over _ idpath c₁)
                                  (path_over_to_path q)
                                  (path_over_id c₁)
       end.

  Global Instance path_over_compose_isequiv
         {A B : Type} {C : B -> Type} (f : A -> B)
         {a₁ a₂ : A} {p : a₁ = a₂}
         {c₁ : C (f a₁)} {c₂ : C (f a₂)}
    : IsEquiv (@path_over_compose A B C f a₁ a₂ p c₁ c₂).
  Proof.
    simple refine (isequiv_adjointify _ (@compose_path_over A B C f a₁ a₂ p c₁ c₂) _ _).
    - intros x ; induction p ; cbn in *.
      refine (_ @ eissect path_over_to_path x).
      induction (path_over_to_path x).
      reflexivity.
    - intros q ; induction q.
      reflexivity.
  Defined.
End operations.

(* Groupoid operations for `path_over`. *)
Section groupoid.
  Variable (A : Type)
           (C : A -> Type).

  (* The inverse. *)
  Definition path_over_inv
             {a₁ a₂ : A}
             {p : a₁ = a₂}
             {c₁ : C a₁} {c₂ : C a₂}
             (q : path_over C p c₁ c₂)
    : path_over C p^ c₂ c₁
    := match q with
       | path_over_id _ _ => path_over_id _
       end.

  (* Concatenation. *)
  Definition path_over_concat
             {a₁ a₂ a₃ : A}
             {p₁ : a₁ = a₂} {p₂ : a₂ = a₃}
             {c₁ : C a₁} {c₂ : C a₂} {c₃ : C a₃}
             (q₁ : path_over C p₁ c₁ c₂) (q₂ : path_over C p₂ c₂ c₃)
    : path_over C (p₁ @ p₂) c₁ c₃.
  Proof.
    induction q₁, q₂.
    exact (path_over_id _).
  Defined.
End groupoid.

Arguments path_over_inv {A C a₁ a₂ p c₁ c₂} q.
Arguments path_over_concat {A C a₁ a₂ a₃ p₁ p₂ c₁ c₂ c₃} q₁ q₂.

(** `const_path_over` applied to an inverse, gives the inverse in `path_over`.*)
Definition const_path_over_inv
           {A C : Type}
           {a₁ a₂ : A} {p : a₁ = a₂}
           {c₁ c₂ : C}
           (q : c₁ = c₂)
  : (const_path_over q^ : path_over (fun _ => C) p^ c₂ c₁)
    =
    path_over_inv (const_path_over q)
  := match q, p with
     | idpath, idpath => idpath
     end.

(** `const_path_over` applied to a concatanation, gives the concatanation in `path_over`. *)
Definition const_path_over_concat
           {A C : Type}
           {a₁ a₂ a₃ : A}
           {p₁ : a₁ = a₂} {p₂ : a₂ = a₃}
           {c₁ c₂ c₃ : C}
           (q₁ : c₁ = c₂) (q₂ : c₂ = c₃)
  : (const_path_over (q₁ @ q₂) : path_over (fun _ => C) (p₁ @ p₂) c₁ c₃)
    =
    path_over_concat (const_path_over q₁) (const_path_over q₂).
Proof.
  induction p₁, p₂, q₁, q₂.
  reflexivity.
Defined.

(** `apd` on a section of a constant fibration. *)
Definition apd_po_const
           {A C : Type}
           (f : A -> C)
           {a₁ a₂ : A} (p : a₁ = a₂)
  : apd_po f p = const_path_over (ap f p)
  := match p with
     | idpath => idpath
     end.

(** `const_path_over` is injective. *)
Definition const_path_over_inj
           {A C : Type}
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           {c₁ c₂ : C}
           (q₁ q₂ : c₁ = c₂)
           (h : (const_path_over q₁ : path_over (fun _ => C) p c₁ c₂)
                = const_path_over q₂)
  : q₁ = q₂.
Proof.
  pose (ap const_path_over^-1 h) as s.
  rewrite !eissect in s.
  exact s.
Defined.

(** `path_over` in a family of sets. *)
Global Instance path_over_hprop
       {A : Type}
       (Y : A -> Type)
       `{forall (a : A), IsHSet (Y a)}
       {a₁ a₂ : A}
       (p : a₁ = a₂)
       (c₁ : Y a₁) (c₂ : Y a₂)
  : IsHProp (path_over Y p c₁ c₂).
Proof.
  apply hprop_allpath.
  intros x y.
  refine ((eissect path_over_to_path x)^ @ _ @ eissect path_over_to_path y).
  apply (ap path_to_path_over).
  apply path_ishprop.
Defined.

(** `path_over` in a family of propositions. *)
Definition path_over_path_hprop
       {A : Type}
       (Y : A -> Type)
       `{forall (a : A), IsHProp (Y a)}
       {a₁ a₂ : A}
       (p : a₁ = a₂)
       (c₁ : Y a₁) (c₂ : Y a₂)
  : path_over Y p c₁ c₂.
Proof.
  apply path_to_path_over.
  apply path_ishprop.
Defined.

(** `path_over` in a family of arrows. *)
Definition path_over_arrow
           {A : Type}
           (Y₁ Y₂ : A -> Type)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           (f₁ : Y₁ a₁ -> Y₂ a₁) (f₂ : Y₁ a₂ -> Y₂ a₂)
           (q : forall (x : Y₁ a₂), path_over Y₂ p (f₁ (p^ # x)) (f₂ x))
           `{Funext}
  : path_over (fun a => Y₁ a -> Y₂ a) p f₁ f₂.
Proof.
  apply path_to_path_over.
  funext x.
  refine (transport_arrow _ _ _ @ _).
  apply path_over_to_path.
  apply q.
Defined.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch13_1.

Section alternate_interior_angles_playfair_bis.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma alternate_interior__playfair_aux : alternate_interior_angles_postulate ->
   forall A1 A2 B1 B2 C1 C2 P,
   Perp2 A1 A2 B1 B2 P -> ~ Col A1 A2 P -> Col P B1 B2 -> Coplanar A1 A2 B1 B2 ->
   Par A1 A2 C1 C2 -> Col P C1 C2 ->
   Col C1 B1 B2. (** "half" of playfair_bis *)
Proof.
  intros aip A1 A2 B1 B2 C1 C2 P HPerp2 HNC1 HPB HCop HParAC HPC.
  elim(eq_dec_points P C1).
    intro; subst C1; auto.
  intro.
  assert(HParAB : Par_strict A1 A2 B1 B2)
    by (apply (col_cop_perp2__pars_bis P); Col).
  apply (par_not_col_strict _ _ _ _ P) in HParAC; Col.
  destruct HPerp2 as [P1 [P2 [HP [HPerpAP HPerpBP]]]].
  assert(HQ := HPerpAP); auto.
  destruct HQ as [Q [_ [_ [HQP[HQL _]]]]].
  assert(HP' := HPerpBP); auto.
  destruct HP' as [P' HPerpP].
  assert(P'=P) by (apply (l8_14_2_1b _ P1 P2 B1 B2); Col).
  subst P'.
  destruct HPerpP as [_ [_ [HPP _]]].
  assert(P<>Q) by (intro; subst Q; Col).
  apply (perp_col0 _ _ _ _ P Q) in HPerpAP; Col.
  apply (perp_col0 _ _ _ _ P Q) in HPerpBP; Col.
  clear dependent P1.
  clear dependent P2.

  assert (HNC2 : ~ Col Q C1 P)
    by (apply (par_not_col A1 A2); auto;
        apply (par_strict_col_par_strict _ _ _ C2); Col).
  assert_diffs.
  assert(HB3 : exists B3, Col B1 B2 B3 /\ B3 <> P).
  { elim(eq_dec_points B1 P).
    intro; subst B1; exists B2; Col.
    intro; exists B1; Col.
  }
  destruct HB3 as [B3 []].
  assert(Col P C1 B3); [|ColR].
  assert_diffs.
  apply (cop_perp2__col _ _ _ P Q); [clear HNC2; CopR| |apply (perp_col2 B1 B2); Col].
  apply perp_left_comm.
  apply per_perp; auto.

  assert(HA3 : exists A3, Col A1 A2 A3 /\ TS P Q C1 A3).
  { elim(col_dec P Q A1);
    [|intro; apply (cop_not_par_other_side _ _ _ _ Q); Col; clear HNC2; CopR].
    intro.
    assert(HA3 := cop_not_par_other_side P Q A2 A1 Q C1).
    destruct HA3 as [A3 []]; Col; [intro; apply HNC1; ColR|clear HNC2; CopR|].
    exists A3; Col.
  }

  destruct HA3 as [A3 [HA3 Hts]].
  assert(~ Col A3 P Q) by (destruct Hts as [_ []]; auto).
  assert_diffs.
  apply (l11_17 A3 Q P).
    apply perp_per_1, (perp_col2 A1 A2); Col.
  apply conga_sym.
  apply aip; auto.
  apply (par_col4__par C1 C2 A1 A2); Col.
  apply par_strict_par; Par.
Qed.

Lemma alternate_interior__playfair_bis : alternate_interior_angles_postulate -> alternative_playfair_s_postulate.
Proof.
intros aia.
intros A1 A2 B1 B2 C1 C2 P HPerp2 HPB HCop HParAC HPC.
split.
apply (alternate_interior__playfair_aux aia A1 A2 _ _ _ C2 P); auto.
apply (alternate_interior__playfair_aux aia A1 A2 _ _ _ C1 P); Col; Par.
Qed.

End alternate_interior_angles_playfair_bis.


(*The definition of Category in the Monoid Hell (aka categotry with morphism equiality) *)

Class Category := cat_mk {
  Obj : Type;

  uHom := Type : Type;

  Hom : Obj -> Obj -> uHom;

  Id : forall x, Hom x x;

  Dom {x y} (f: Hom x y) := x;

  CoDom {x y} (f: Hom x y) := y;

  Compose : forall {x y z}, (Hom y z)->(Hom x y)->(Hom x z);

  EqMor : forall {x y}, (Hom x y) -> (Hom x y) -> Prop;

  Eq_ref : forall {x y} (f : Hom x y), EqMor f f;

  Eq_trans : forall {x y} (f g h : Hom x y), EqMor f g -> EqMor g h
         -> EqMor f h;
  Eq_sim : forall {x y} (f g : Hom x y), EqMor f g -> EqMor g f;

  assoc : forall x y z w (f : (Hom z w)) (g:(Hom y z)) (h:(Hom x y)),
        EqMor (Compose f (Compose g h) ) (Compose (Compose f g) h);

  id_1 : forall x y (f : (Hom x y)), EqMor (Compose f (Id x)) f ;

  id_2 : forall x y (f : (Hom x y)), EqMor (Compose (Id y) f) f ;

  eq_1 : forall {x y z} (f: Hom y z) (g h : Hom x y), EqMor g h ->
        EqMor (Compose f g) (Compose f h);
  eq_2 : forall {x y z} (f: Hom x y) (g h : Hom y z), EqMor g h ->
        EqMor (Compose g f) (Compose h f);

}.

Notation "x → y" := (Hom x y) (at level 90, right associativity) :
type_scope.

Notation "f ∘ g" := (Compose f g) (at level 40, left associativity) :
type_scope.

Notation "f ≡ g" := (EqMor f g) (at level 40, left associativity) :
type_scope.

Context {C : Category}.

Class EndoFunctor {C : Category} := {

EF_obj : @Obj C -> @Obj C;

EF_mor : forall {x y}, (Hom x y) -> (Hom (EF_obj x) (EF_obj y));

EF_id_ax : forall {x}, EF_mor (Id x) = Id (EF_obj x);

EF_comp_ax : forall {x y z : @Obj C} {f g},
      @EF_mor x z (f ∘ g) = (@EF_mor y z f) ∘ (@EF_mor x y g)
}.

Class F_algebra {C : Category} (F : @EndoFunctor C) := {

Carr_F_alg : @Obj C;

Mor_F_alg : Hom ((@EF_obj C F) Carr_F_alg) Carr_F_alg
}.

Ltac Kitten :=
  repeat match goal with
           | [ H : ?P |- ?P ] => exact H
           | [ |- (?P ∘ (Id ?Q)) ≡ ?P  ] => apply id_1
           | [ |- ((Id ?Q) ∘ ?P) ≡ ?P  ] => apply id_2
           | [ |- ?P ≡ ?P  ] => apply Eq_ref
           | [ H : ?P ≡ ?Q |- ?Q ≡ ?P ] => apply Eq_sim
           | [ |- (?P ∘ ?Q) ≡ (?P ∘ ?R) ] => apply eq_1
           | [ |- ( ?Q ∘ ?P ) ≡ (?R ∘ ?P) ] => apply eq_1
         end.

Definition F_algebras_Obj {C : Category} (F : @EndoFunctor C) := (@sigT (@Obj C) (fun (x:@Obj C) => Hom (@EF_obj C F x) x) ) : Type.

Definition F_algebras_Hom {C : Category} (F : @EndoFunctor C) (x : F_algebras_Obj F) (y : F_algebras_Obj F)
:= (sig (fun (f : @Hom C (projT1 x) (projT1 y) ) =>  ((projT2 y) ∘ (EF_mor f )) ≡ (f ∘ (projT2 x) ) )).

Definition F_algebras_EqMor {C : Category} (F : @EndoFunctor C) (x y : F_algebras_Obj F) (f g : F_algebras_Hom F x y) := (proj1_sig f) ≡ (proj1_sig g).

Definition F_algebras_Id {C : Category} (F : @EndoFunctor C) (x : F_algebras_Obj F) : @F_algebras_Hom C F x x.
unfold F_algebras_Hom.
exists (@Id C (projT1 x)).
rewrite EF_id_ax.
assert (H: (projT2 x ∘ Id (EF_obj (projT1 x))) ≡ projT2 x).
Kitten.
(*apply id_1.*)
assert (H1: (projT2 x ) ≡ (projT2 x ∘ Id (EF_obj (projT1 x)))).
Kitten.
(*apply Eq_sim.
exact H.*)
Kitten.
apply Eq_trans with (g:=(projT2 x)).
2 : {
assert (K: ((Id (projT1 x) ∘ projT2 x) ≡ projT2 x)).
all: Kitten. }
apply Eq_trans with (g:=(projT2 x)).
2 : { Kitten. }
Kitten.
Defined.

Definition F_algebras_Comp {C : Category} (F : @EndoFunctor C) (x y z : F_algebras_Obj F)
(h : F_algebras_Hom F y z ) (k : F_algebras_Hom F x y ) : F_algebras_Hom F x z.
unfold F_algebras_Hom.
unfold F_algebras_Hom in h, k.
exists ((proj1_sig h) ∘ (proj1_sig k)).
assert (H : (projT2 z ∘ EF_mor (proj1_sig h)) ≡ ((proj1_sig h) ∘ projT2 y)).
exact (proj2_sig h).
assert (K : (projT2 y ∘ EF_mor (proj1_sig k)) ≡ ((proj1_sig k) ∘ projT2 x)).
exact (proj2_sig k).
rewrite EF_comp_ax.
assert (L : (projT2 z ∘ (EF_mor (proj1_sig h) ∘ EF_mor (proj1_sig k))
) ≡ ((projT2 z ∘ EF_mor (proj1_sig h) ∘ EF_mor (proj1_sig k)))).
apply assoc.
apply Eq_sim.
apply Eq_trans with (g:=projT2 z ∘ EF_mor (proj1_sig h) ∘ EF_mor (proj1_sig k)).
2 : {
Kitten. }
apply Eq_sim.
assert (M1 : (projT2 z ∘ EF_mor (proj1_sig h) ∘ EF_mor (proj1_sig k) ) ≡ ((proj1_sig h ∘ projT2 y) ∘ EF_mor (proj1_sig k))).
apply eq_2 with (g:=projT2 z ∘ EF_mor (proj1_sig h)) (h:= proj1_sig h ∘ projT2 y) (f:=EF_mor (proj1_sig k)).
auto.
apply Eq_sim.
apply Eq_trans with (g:=(proj1_sig h ∘ projT2 y ∘ EF_mor (proj1_sig k))).
2: {
Kitten. }
assert (M2 : (projT2 y ∘ EF_mor (proj1_sig k)) ≡ (proj1_sig k ∘ projT2 x)).
exact (proj2_sig k).
assert (L1 : (proj1_sig h ∘ projT2 y ∘ EF_mor (proj1_sig k))
 ≡ (proj1_sig h ∘ (projT2 y ∘ EF_mor (proj1_sig k)))).
apply Eq_sim.
apply assoc.
apply Eq_trans with (g:=((proj1_sig h ∘ (projT2 y ∘ EF_mor (proj1_sig k))))).
2 : {
apply Eq_sim.
apply L1. }
assert (L2 : (proj1_sig h ∘ proj1_sig k ∘ projT2 x)
 ≡ (proj1_sig h ∘ (proj1_sig k ∘ projT2 x))).
apply Eq_sim.
apply assoc.
apply Eq_trans with (g:=(proj1_sig h ∘ (proj1_sig k ∘ projT2 x))).
2: {
Kitten. }
auto.
Defined.

Theorem F_algebras_form_a_Cat {C : Category} (F : @EndoFunctor C) : Category.
Proof.
apply (cat_mk (@F_algebras_Obj C F) (@F_algebras_Hom C F) (@F_algebras_Id C F) (@F_algebras_Comp C F) (@F_algebras_EqMor C F) ).
intros.
apply Eq_ref.
intros.
unfold F_algebras_EqMor.
unfold F_algebras_EqMor in H, H0.
apply Eq_trans with (g:=proj1_sig g).
all: auto.
intros.
unfold F_algebras_EqMor.
unfold F_algebras_EqMor in H.
apply Eq_sim.
auto.
intros.
unfold F_algebras_EqMor.
unfold F_algebras_Hom in f, g, h.
apply assoc.
intros.
unfold F_algebras_EqMor.
apply id_1.
intros.
unfold F_algebras_EqMor.
apply id_2.
intros.
unfold F_algebras_EqMor.
apply eq_1.
unfold F_algebras_EqMor in H.
auto.
intros.
unfold F_algebras_EqMor.
apply eq_2.
unfold F_algebras_EqMor in H.
auto.
Qed.


(* compute the dependencies between instructions *)
Require Import Errors.
Require Import Polyhedra.
Require Import Loops.
Require Import Memory.
Require Import ArithClasses.
Require Import Permutation.
Require Import Sorted.
Require Import PLang.
Require Import Psatz.
Require Import Axioms.
Require Import Instructions.
Require Import Bounds.
Require Import Libs.
Require Import Do_notation.
Open Scope string_scope.
(*Set Implicit Arguments.*)
Open Scope Z_scope.

(*
Lemma Vcons_prod `{Numerical Num} n (v1 v2: Vector Num n) (a1 a2: Num):
  〈 a1 ::: v1, a2 ::: v2〉= (a1 * a2 + 〈v1, v2〉)%numerical.
Proof.
  reflexivity.
Qed.

Lemma Vcons_prod_Z n (v1 v2: ZVector n) (a1 a2: Z):
  〈 a1 ::: v1, a2 ::: v2〉= a1 * a2 + 〈v1, v2〉.
Proof.
  reflexivity.
Qed.

Hint Rewrite Vcons_prod Vcons_prod_Z: vect. *)

(*
Definition extend_matrix {n p} (M: ZMatrix n (S p)): ZMatrix (S n) (S p) :=
  (1 ::: V0 p) ::: M.

Lemma extend_matrix_correct n p (M: ZMatrix n (S p)) (v : ZVector p):
  (extend_matrix M) × (1:::v) = 1 ::: (M × (1:::v)).
Proof.
  intros.
  unfold extend_matrix, Matrix, Matrix in *.
  apply PVeq_Veq.
  unfold Mprod_vect. simpl.
  f_equal. simpl_vect. reflexivity.
Qed.

Definition extend_polyhedron {n} (p:Polyhedron n) : Polyhedron (S n) :=
  {| constr_vect := 1 ::: V0 n;
     constr_comp := EQ;
     constr_val := 1 |} ::
  map
    (fun constr =>
      {| constr_vect := 0 ::: constr.(constr_vect);
         constr_comp := constr.(constr_comp);
         constr_val := constr.(constr_val) |}
      ) p.

Lemma extend_polyhedron_correct_1 n (p: Polyhedron n) (v: ZVector n):
  v ∈ p -> 1:::v ∈ (extend_polyhedron p).
Proof.
  unfold Pol_In.
  intro IN.
  unfold extend_polyhedron.
  constructor'.
  NCase "Head".
    red. simpl. simpl_vect. reflexivity.
  NCase "Tail".
  eapply list_forall_list_forall_map; eauto.
  intros.
  clear IN.
  destruct a; unfold satisfy_constraint in *; simpl in *.
  simpl_vect. simpl. auto.
Qed.

Lemma extend_polyhedron_Vhd  n (p: Polyhedron n) (v: ZVector (S n)):
  v ∈ (extend_polyhedron p) -> Vhd v = 1.
Proof.
  intro IN.
  unfold Pol_In in IN. unfold extend_polyhedron in IN.
  inv IN. clear H2. red in H1. simpl in H1.
  dest_vect v. unfold Vhd.
  destruct v; simpl in *. inv Lv.
  unfold Vprod, Vcons in H1. simpl in H1.
  rewrite PVprod_repeat_0 in H1.
  destruct z; lia.
Qed.

(*Lemma Vcase `{Numerical Num} n (v: Vector Num (S n)) :
  exists x v', v = x ::: v'.
Proof.
  exists (Vhd v). exists (Vtail v).*)

Tactic Notation "remember_no_eq" constr(X) "as" ident(id) :=
  remember X as id;
  match goal with
    | H: id = X |- _ => clear H
  end.

Tactic Notation "Vdestruct" constr(v) "as" ident(hd) ident(tl) :=
  let H := fresh in
  let v' := fresh v in
  rename v into v';
  pose proof (Vcons_hd_tail v') as H;
  remember_no_eq (Vhd v') as hd;
  remember_no_eq (Vtail v') as tl;
  rewrite <- H in *;
  clear H; clear v'.

Lemma extend_polyhedron_Vtl  n (p: Polyhedron n) (v: ZVector (S n)):
  v ∈ (extend_polyhedron p) -> Vtail v ∈ p.
Proof.
  intro IN.
  Vdestruct v as a v.
  unfold Pol_In in *.
  unfold extend_polyhedron in IN.
  inv IN. clear H1.
  eapply list_forall_map_list_forall; eauto.
  clear. intros. destruct a0; unfold satisfy_constraint in *; simpl in *.
  simpl_vect in H. simpl in H. assumption.
Qed.

Definition Mmul_transp `{Numerical Num} {n m p} (m1: Matrix Num n m)
  (m2: Matrix Num p m) : Matrix Num n p :=
  Vmap (fun l1 => Vmap (fun c2 => 〈l1, c2〉) m2) m1.

Definition Mmul `{Numerical Num} {n m p} (m1: Matrix Num n m)
  (m2: Matrix Num m p) : Matrix Num n p :=
  Mmul_transp m1 (Mtranspose m2).

Lemma Vnth_Vmap `{Inhabited A} `{Inhabited B} n (f:A -> B) (v: Vector A n) i:
  (i < n)%nat ->
  Vnth (Vmap f v) i = f (Vnth v i).
Proof.
  unfold Vnth, Vmap. simpl.
  dest_vect v. unalias in *. simpl.
  revert dependent n. revert v.
  induction' i as [|i]; simpl; intros * LENGTH INF.
  Case "O".
    destruct v; simpl in *; auto. omegaContradiction.
  Case "S i".
    destruct v; simpl in *; auto. omegaContradiction.
    destruct n; auto. assert (length v = n) by omega.
    eapply IHi; eauto. omega.
Qed.

Lemma Vmap_cons A B n (f: A -> B) a (v : Vector A n):
  Vmap f (a ::: v) = f a ::: Vmap f v.
Proof.
  apply PVeq_Veq. unfold Vmap. simpl. auto.
Qed.

Lemma Mprod_vect_cons `{Numerical Num} n p (fst_row: Vector Num p) (m: Matrix Num n p)
  (v:Vector Num p):
  (fst_row ::: m) × v = 〈fst_row, v〉::: (m × v).
Proof.
  unfold Matrix, Mprod_vect, Vprod in *.
  dest_vects. reflexivity.
Qed.

Hint Rewrite Vmap_cons Mprod_vect_cons: vect.

Lemma Vect_0 {A} (v : Vector A 0):
  v = (exist (fun l : Pseudo_Vector A => length l = 0%nat)
              [] eq_refl).
Proof.
  intros. apply PVeq_Veq. dest_vects.
  destruct v; simpl in *; clean.
Qed.

(* let's go for a triple induction proof \o/ *)
Lemma Mmul_prod_assoc: forall n m p (m1: ZMatrix n m)
  (m2: ZMatrix m p) (v: ZVector p),
  (Mmul m1 m2) × v = m1 × (m2 × v).
Proof.
  induction' n as [|n].
  Case "O".
    intros. unfold Matrix in *. dest_vects.
    destruct m1; simpl in *; clean.
  Case "S n".
    intros.
    Vdestruct m1 as hd1 m1.
    subst.
    specialize (IHn _ _ m1 m2 v).
    unfold Mmul, Mmul_transp in *.
    simpl_vect. rewrite Mprod_vect_cons.
    rewrite Mprod_vect_cons. f_equal; auto.

    clear'.
    revert dependent p.
    induction' p as [|p]; intros.
    SCase "O".
      rewrite (Vect_0 v). unfold Vprod. simpl.
      unfold Matrix in *. clear'.
      dest_vects. simpl. clear'. revert m2.
      induction' hd1 as [|v hd1]; destruct m2; simpl; auto.
      rewrite <- IHhd1. dest_vects. destruct v0; simpl in *; auto. lia.
    SCase "S p".
      simpl.
      rewrite Vmap_cons.
      Vdestruct v as z v.
      simpl_vect. simpl.
      rewrite IHp.
      clear'.
      induction' m as [|m].
      SSCase "O".
        rewrite (Vect_0 m2). clear'.
        unfold Vprod, Vmap. simpl.
        dest_vects. destruct hd1; simpl; reflexivity.
      SSCase "S m".
        Vdestruct hd1 as z1 hd1.
        Vdestruct m2 as vm2 m2.
        specialize (IHm hd1 m2).
        simpl_vect.
        rewrite Mprod_vect_cons.
        rewrite Mprod_vect_cons. simpl_vect. simpl in *.
        unfold ZNum.Numerical_Num in *.
        match goal with
          | |- (?A + ?B ) * z + (?C + ?D) = _ =>
            replace ((A + B) * z + (C + D)) with
              ((A*z + C) + (B *z + D)) by lia
        end.
        f_equal; auto.
        rewrite <- Zmult_assoc.
        rewrite <- Zmult_plus_distr_r.
        f_equal.
        Vdestruct vm2 as hdvm2 vm2.
        simpl_vect. reflexivity.
  Qed.

Module PDependencies (Import M:BASEMEM(ZNum))
  (I:INSTRS(ZNum) with Definition Value := M.Value).
  Module T := Tools(ZNum).
  Import T.

  (* find better name *)
  Definition make_poly_containing_things {dim1 dim2} {num_args1 num_args2}
    (transf1: ZMatrix num_args1 (S dim1)) (transf2: ZMatrix num_args2 (S dim2))
    (pol1: Polyhedron (S dim1)) (pol2: Polyhedron (S dim2))
    (def_access1: list (ZVector (S (num_args1))))
    (def_access2: list (ZVector (S (num_args2)))):
    res (Polyhedron (S dim1 + S dim2)) :=
    let n := length def_access1 in
    match make_vector n def_access1 with
    | None => Err "Make vector is broken"
    | Some access1 =>
    match make_vector n def_access2 with
    | None =>
      Err "make_poly_containing_things has been called with two accesses of different size"
    | Some access2 =>
    let etransf1 := extend_matrix transf1 in
    let etransf2 := extend_matrix transf2 in
    let M1 := Mmul access1 etransf1 in
    let M2 := Mmul access2 etransf2 in
    OK (Pol_same_image_two_matrices M1 M2 ∩ Pol_prod pol1 pol2)
    end
    end.

  Hint Unfold ZNum.Num: aliases.

  (* I really need to find better names... *)
  Lemma it_works {dim1 dim2} {num_args1 num_args2}
    (transf1: ZMatrix num_args1 (S dim1)) (transf2: ZMatrix num_args2 (S dim2))
    (pol1: Polyhedron (S dim1)) (pol2: Polyhedron (S dim2))
    (def_access1: list (ZVector (S (num_args1))))
    (def_access2: list (ZVector (S (num_args2))))
    (v1: ZVector dim1) (v2: ZVector dim2) pol (id:Array_Id):
    make_poly_containing_things transf1 transf2 pol1 pol2 def_access1 def_access2 =
      OK pol ->
    (1:::v1) ∈ pol1 -> (1:::v2) ∈ pol2 ->
    (1 ::: v1) +++ (1::: v2) ∉ pol ->
    translate_locs (1::: (transf1 × (1:::v1))) (id, def_access1) <>
    translate_locs (1::: (transf2 × (1:::v2))) (id, def_access2).
  Proof.
    intros * MAKE_OK IN1 IN2 NOTIN. intro EQ. apply NOTIN; clear NOTIN.
    unfold make_poly_containing_things in MAKE_OK.
    repeat prog_match_option; clean.
    apply Pol_Included_intersertion;[| apply Pol_In_In_prod; auto].
    apply Pol_same_image_In_SI2.
    repeat (rewrite Mmul_prod_assoc).

    unfold translate_locs in EQ. inv EQ.
    repeat match goal with
             | H: _ |- _ => apply make_vector_open in H
           end.
    rewrite <- Heqo0 in *. clear Heqo0. clear def_access2.
    repeat rewrite extend_matrix_correct.
    unfold Mprod_vect at 1. unfold Mprod_vect at 3.
    apply PVeq_Veq. simpl.  unalias in *.  rewrite <- H0.
    f_equal. assumption.
  Qed.

*)


Require Import Program.Basics.
Require Import Strings.String.
Require Import FunctionalExtensionality.

Open Scope program_scope.

(***************)
(* Typeclasses *)
(***************)

(* Functor *)

Class Functor (f : Type -> Type) : Type :=
{ fmap {A B : Type} (g : A -> B) : f A -> f B }.

Class FunctorLaws (f : Type -> Type) `{Functor f} :=
{ functor_id   : forall A (fa : f A), fmap id fa = fa
; functor_comp : forall A B C (h : A -> B) (g : B -> C) (fa : f A),
                        (fmap g ∘ fmap h) fa = fmap (g ∘ h) fa
}.

(* Natural Transformation *)

Class natTrans f g `{Functor f, Functor g} : Type := mkNatTrans
{ runNatTrans : forall X, f X -> g X }.
Arguments mkNatTrans [f g _ _].
Arguments runNatTrans [f g _ _] _ [X].
Notation "f ~> g" := (natTrans f g) (at level 50, left associativity).

Class natTransLaws f g `{Functor f, Functor g} (φ : f ~> g) :=
{ natTrans_comm : forall A B (fa : f A) (g : A -> B),
                         runNatTrans φ (fmap g fa) = fmap g (runNatTrans φ fa)
}.

Definition composeNT {f g h : Type -> Type} `{Functor f, Functor g, Functor h}
                     (φ : g ~> h) (ψ : f ~> g) : f ~> h :=
  mkNatTrans (fun _ fx => runNatTrans φ (runNatTrans ψ fx)).
Notation "φ • ψ" := (composeNT φ ψ) (at level 40, left associativity).

(* Monad *)

Class Monad (m : Type -> Type) `{Functor m} : Type :=
{ ret : forall {X}, X -> m X
; bind : forall {A B}, m A -> (A -> m B) -> m B
}.
Notation "ma >>= f" := (bind ma f) (at level 50, left associativity).
Notation "ma >> mb" := (ma >>= fun _ => mb) (at level 50, left associativity).

Class MonadLaws (m : Type -> Type) `{Monad m} :=
{ left_id : forall {A B} (a : A) (f : A -> m B), ret a >>= f = f a
; right_id : forall {A} (ma : m A), ma >>= ret = ma
; assoc : forall {A B C} (ma : m A) (f : A -> m B) (g : B -> m C),
                 ma >>= f >>= g = ma >>= (fun x => f x >>= g)
; functor_rel : forall {A B} (ma : m A) (f : A -> B), fmap f ma = ma >>= ret ∘ f
}.

Definition monad_morphism {f g : Type -> Type}
                         `{Monad f, Monad g}
                          (φ : f ~> g) : Prop :=
  (forall X (x : X), runNatTrans φ (ret x) = ret x) /\
  (forall A B (fa : f A) (f : A -> f B),
    runNatTrans φ (fa >>= f) =
    runNatTrans φ fa >>= (fun a => runNatTrans φ (f a))).

Lemma reta_gtgt_retb_is_retb :
    forall m `{MonadLaws m},
    (forall A B (a : A) (b : B), ret a >> ret b = ret b).
Proof.
  intros.
  destruct H1.
  apply left_id0.
Qed.

Ltac functional_extensionality_i := apply functional_extensionality; intros.

Lemma functional_extensionality_1 :
    forall {A B}
           (f : A -> B)
           (g : A -> B),
    (forall (a : A), f a = g a) -> (fun a => f a) = (fun a => g a).
Proof.
  intros.
  functional_extensionality_i.
  now rewrite H.
Qed.

Ltac unwrap_layer :=
  apply f_equal;
  apply functional_extensionality;
  intros.

Lemma monadic_extensionality_1 :
    forall {m A B} `{Monad m}
           {ma : m A}
           (f : A -> m B)
           (g : A -> m B),
    (forall (a : A), f a = g a) -> (ma >>= f = ma >>= g).
Proof.
  intros.
  unwrap_layer.
  auto.
Qed.

Lemma monadic_extensionality_2 :
    forall {m A B C} `{Monad m}
           {ma : m A} {f : A -> m B}
           (k1 : A * B -> m C)
           (k2 : A * B -> m C),
    (forall (a : A) (b : B), k1 (a, b) = k2 (a, b)) ->
    (ma >>= (fun a => f a >>= (fun b => k1 (a, b))) =
     ma >>= (fun a => f a >>= (fun b => k2 (a, b)))).
Proof.
  intros.
  repeat unwrap_layer.
  auto.
Qed.

(* MonadState *)

Class MonadState (A : Type) (m : Type -> Type) `{Monad m} :=
{ get : m A
; put : A -> m unit
; mod : (A -> A) -> m unit := fun f => get >>= (put ∘ f)
}.

Class MonadStateLaws (A : Type) (m : Type -> Type) `{MonadState A m} :=
{ get_get : get >>= (fun s1 => get >>= (fun s2 => ret (s1, s2))) =
            get >>= (fun s => ret (s, s))
; get_put : get >>= put = ret tt
; put_get : forall s, put s >> get = put s >> ret s
; put_put : forall s1 s2, put s1 >> put s2 = put s2
}.

Lemma general_getget :
    forall {M : Type -> Type} {A : Type}
          `{MSL : MonadStateLaws A M} {ML : MonadLaws M} {X : Type}
           (p : A * A -> M X),
           get >>= (fun x1 => get >>= (fun x2 => p (x1, x2))) =
           get >>= (fun x1 => p (x1, x1)).
Proof.
  intros.
  destruct ML.
  destruct MSL.
  assert (G : get >>= (fun x1 : A => p (x1, x1)) =
              get >>= (fun x1 : A => ret (x1, x1) >>= p)).
  { unwrap_layer. now rewrite left_id0. }
  rewrite G.
  rewrite <- assoc0.
  rewrite <- get_get0.
  rewrite -> assoc0.
  unwrap_layer.
  rewrite -> assoc0.
  unwrap_layer.
  now rewrite left_id0.
Qed.

Lemma non_eff_get :
    forall  {m : Type -> Type} {A : Type}
           `{M : Monad m}
            {ML : @MonadLaws m _ M}
            {MS : @MonadState A m _ M}
            {MSL : @MonadStateLaws A m _ M MS} {X : Type} (p : m X),
    get >> p = p.
Proof.
  intros.
  pose proof (@general_getget m A _ M MS MSL ML) as J.
  destruct ML.
  destruct MSL.
  rewrite <- (left_id0 unit _ tt (fun _ => p)).
  rewrite <- get_put0.
  repeat rewrite assoc0.
  now rewrite (J X (fun pair => put (snd pair) >> p)).
Qed.

(*********)
(* State *)
(*********)

Record state (S Out : Type) := mkState
{ runState : S -> Out * S }.
Arguments mkState [S Out].
Arguments runState [S Out].

Definition evalState {S Out} (st : state S Out) (s : S) : Out :=
  fst (runState st s).

Definition execState {S Out} (st : state S Out) (s : S) : S :=
  snd (runState st s).

Ltac state_reason :=
  match goal with
  | [ |- context [bind _]] => unfold bind
  | [ |- context [execState] ] => unfold execState
  | [ |- context [evalState] ] => unfold evalState
  | [ |- {| runState := _ |} = {| runState := _ |} ] => apply f_equal
  | [ |- (fun _ => _) = _ ] => apply functional_extensionality; intros
  | [ |- {| runState := _ |} = ?x ] => destruct x as [rs]
  | [ |- context [ let (_, _) := ?rs ?x in _ ] ] => destruct (rs x)
  end; simpl; auto.

Ltac i_state_reason := intros; repeat state_reason.

Instance Functor_state {S : Type} : Functor (state S) :=
{ fmap _ _ f sa := mkState (fun s => let (a, s') := runState sa s in (f a, s'))
}.

Instance Functor_laws {S : Type} : FunctorLaws (state S).
Proof.
  constructor; unfold fmap; unfold compose; simpl; i_state_reason.
Qed.

Definition state_get {S} : state S S := mkState (fun s => (s, s)).

Definition state_put {S} (s' : S) : state S unit := mkState (fun _ => (tt, s')).

Instance Monad_state {S : Type} : Monad (state S) :=
{ ret := fun X x => mkState (fun s => (x, s))
; bind := fun A B m f => mkState (fun s => let (a, s') := runState m s
                                           in runState (f a) s')
}.

Instance MonadLaws_state {S : Type} : MonadLaws (state S).
Proof.
  constructor; intros; repeat state_reason.
Qed.

Instance MonadState_state {S : Type} : MonadState S (state S) :=
{ get := mkState (fun s => (s, s))
; put := fun s => mkState (fun _ => (tt, s))
}.

Instance MonadStateLaws_state {S : Type} : MonadStateLaws S (state S).
Proof. constructor; auto. Qed.

Lemma execexec_is_execgtgt :
    forall {S A B} (s : S) (st1 : state S A) (st2 : state S B),
           execState st2 (execState st1 s) = execState (st1 >> st2) s.
Proof. i_state_reason. Qed.

Lemma execeval_is_evalgtgt :
    forall {S A B} (s : S) (st1 : state S A) (st2 : state S B),
           evalState st2 (execState st1 s) = evalState (st1 >> st2) s.
Proof. i_state_reason. Qed.

Lemma execevalexec_is_execbind :
    forall {S A B} (s : S) (st1 : state S A) (f : A -> state S B),
           execState (f (evalState st1 s)) (execState st1 s) =
           execState (st1 >>= f) s.
Proof. i_state_reason. Qed.

Lemma eval_ma_gtgt_retx_is_x :
    forall {S A X} (m : state S A) (s : S) (x : X),
           evalState (m >> ret x) s = x.
Proof. i_state_reason. Qed.

Lemma exec_ma_gtgt_retx_is_exec_ma :
    forall {S A X} (m : state S A) (s : S) (x : X),
           execState (m >> ret x) s = execState m s.
Proof. i_state_reason. Qed.

Lemma exec_ret_is_s :
    forall {S X} (s : S) (x : X),
           execState (ret x) s = s.
Proof. i_state_reason. Qed.

Lemma get_leaves_s_as_is :
    forall {S A}
           {ms : MonadState A (state S)}
           {msl : @MonadStateLaws A (state S) _ _ ms} (s : S),
           execState get s = s.
Proof.
  intros.
  rewrite <- (exec_ret_is_s s tt).
  assert (G : execState get (execState (ret tt) s) =
              execState get s).
  { now rewrite (exec_ret_is_s s tt). }
  rewrite G.
  rewrite <- (non_eff_get (ret tt)).
  now rewrite exec_ma_gtgt_retx_is_exec_ma.
Qed.

(**********)
(* Optics *)
(**********)

(* Lens datatype and definitions *)

Record lens (S A : Type) : Type := mkLens
{ view : S -> A
; update : S -> A -> S
; modify (f : A -> A) : S -> S := fun s => update s (f (view s))
}.
Arguments mkLens [S A].
Arguments view [S A].
Arguments update [S A].
Arguments modify [S A].
Notation "ln %~ f" := (modify ln f) (at level 40, no associativity).

Record lensLaws {S A} (ln : lens S A) : Type :=
{ view_update : forall s, update ln s (view ln s) = s
; update_view : forall s a, view ln (update ln s a) = a
; update_update : forall s a1 a2, update ln (update ln s a1) a2 = update ln s a2
}.

Definition composeLn {S A B} (ln1 : lens S A) (ln2 : lens A B) : lens S B :=
  mkLens ((view ln2) ∘ (view ln1))
         (fun s => update ln1 s ∘ update ln2 (view ln1 s)).
Notation "ln1 ▷ ln2" := (composeLn ln1 ln2) (at level 40, left associativity).

Definition identityLn A : lens A A :=
  mkLens id (fun _ => id).

(* Alternative lens definition *)

Definition lens' S A : Type := state A ~> state S.

Definition lens_2_lens' {S A} (ln : lens S A) : lens' S A :=
  mkNatTrans (fun X sax => mkState (fun s =>
    let (x, a') := runState sax (view ln s)
    in (x, update ln s a'))).

Definition composeLn' {S A B} (ln1 : lens' S A) (ln2 : lens' A B): lens' S B :=
  ln1 • ln2.


Require Import Reals.

Open Scope R_scope.

Definition Real := R.

(* function parameter *)
Variable s : Real.

(* constant *)
Parameter Kt Bm Ke : Real.

(* variables *)
Parameter Rm Lm Jm : Real.

(* functions from s to real. *)
Variables Um Im Om Tm : Real -> Real.

Definition tm1 := (Um s) - Rm * (Im s) - Lm * s * (Im s) - Ke * (Om s).
Definition tm2 := Kt * (Im s) - Jm * s * (Om s) - Bm * (Om s) - (Tm s).
Definition tm3 := (Tm s) * (Lm *s + Rm).
Definition tm4 := (Um s) * Kt - Kt * Ke * (Om s) - (Lm * s + Rm) * (Jm * s + Bm) * (Om s).

(* assumptions of this deduction. *)
Axiom e1 : tm1 = 0.
Axiom e2 : tm2 = 0.

Definition tm5 :=  ((Um s) - Rm * (Im s) - (Lm * s) * (Im s)).

Lemma eq0_eq : forall y z, y-z = 0 -> y = z.
intros.
apply sym_eq.
apply Rminus_diag_uniq_sym.
assumption.
Qed.

(* move Ke * (Om s) in tm1 to the  right of  = *)
Lemma tm5_eq : tm5  = Ke * (Om s).
apply eq0_eq.
apply e1.
Qed.

Definition tm6 :=  ((Um s) - (Rm + Lm * s) * (Im s)).

Lemma  tm6_eq_tm5 : tm6 = tm5.
unfold tm5; unfold tm6.
ring.
Qed.

Lemma tm6_eq : tm6 = Ke * (Om s).
rewrite tm6_eq_tm5.
apply tm5_eq.
Qed.

Lemma tm3_eq_tm4 : tm3 = tm4.
apply nsatz.


(* unordered pairs  *)

Require Import DecidableType.
Require Import DecidableTypeEx Extraction.

Module Upair (M: DecidableType)  <: DecidableType
with  Definition t := (M.t * M.t)%type.

Definition t := (M.t * M.t)%type.

Definition eq(p p':t) : Prop :=
  let (x,y) := p in
  let (x',y') := p' in
       M.eq x x' /\ M.eq y y' \/
       M.eq x y' /\ M.eq y x'.

Lemma  eq_refl : forall x : t, eq x x.
Proof.
  destruct x ;left;simpl;auto.
Qed.

Lemma  eq_sym : forall x y : t, eq x y -> eq y x.
Proof.
 intros (x0,x1) (y0,y1) [(H1,H2)|(H1,H2)]; simpl in H1,H2;
 [left|right];split;auto.
Qed.

Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof.
 intros (x0,x1) (y0,y1) (z0,z1) [(H1,H2)|(H1,H2)] [(H3,H4)|(H3,H4)];
 simpl in * ;
 [left|right|right|left];eauto.
Qed.

Definition eq_dec :forall x y : t, { eq x y } + { ~ eq x y }.
Proof.
 destruct x as (t0, t1);destruct y as (t2,t3).
 case (M.eq_dec t0 t2).
 - intro e; case (M.eq_dec t1 t3).
   +  left;red; left; simpl;auto.
   +  intro n; right;red.
      intros [(H1,H2)|(H1,H2)];simpl in *.
      contradiction H2.
      destruct n.
      apply M.eq_trans with t2;auto.
      apply M.eq_trans with t0;auto.
  -  intro n.
     case (M.eq_dec t0 t3);intro H.
     +  case (M.eq_dec t1 t2);intro H1.
        *  left; right;simpl; auto.
        *  right; intros [(H2,H3)|(H2,H3)]; simpl in *; firstorder.
     +  right; intros [(H2,H3)|(H2,H3)]; simpl in *; firstorder.

Defined.

End Upair.

(**  example

*)
Require Import ZArith.

Module Zpair := Upair Z_as_DT.
Recursive Extraction Zpair.eq_dec.
Open Scope Z_scope.

Lemma test :
 is_true (if Zpair.eq_dec  (5,6) (4+2,5) then true else false).
Proof. reflexivity. Qed.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2020 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

Require Import Equations.Prop.Equations.

Ltac find_noCycle_proof H :=
  let rec aux t ty :=
      match ty with
      | ?x <> ?x => apply (t eq_refl)
      | (?A * ?B)%type =>
        aux (fst t) A || aux (snd t) B
      end
  in simpl in H; let t := type of H in aux H t.

Inductive tree : Set :=
| leaf | node (l r : tree).

Derive NoConfusion for tree.
Derive DependentElimination for tree.
Derive Below for tree.

Local Definition nlt x y := Below_tree (fun y => x <> y) y.
Local Definition nle (x y : tree) := ((x <> y) * nlt x y)%type.

Notation  "x ¬< y " := (nlt x y) (at level 80).
Notation  "x ¬≤ y " := (nle x y) (at level 80).
Lemma noCycle_tree : forall x y : tree, x = y -> nlt x y.
Proof with trivial.
  intros x y <-. induction x as [|l Hl r Hr].
  * now simpl.
  * split.
    { change (nle (node l r) r).
      revert Hr. generalize r at 2 4 as r'.
      induction r'; intros Hr.

      split... intro H; noconf H.
      split.
      + intro Heq; noconf Heq.
        now apply (fst (fst Hr)).
      + firstorder. }
    { change (nle (node l r) l).
      revert Hl. generalize l at 2 4 as l'.
      induction l'; intros Hl'.
      split...
      - now intro H; noconf H.
      - split.
        + intro Heq; noconf Heq;
          firstorder.
        + firstorder. }
Qed.

Require Import CRelationClasses.

#[export]
Instance nlt_refl : Reflexive nlt.
Proof. intros x. now apply noCycle_tree. Defined.
(* Neither transivite nor symmetric *)

Lemma noCycle_test l r : node l r <> r.
Proof.
  intros H; pose proof (noCycle_tree r (node l r) (eq_sym H)). simpl in X.
  find_noCycle_proof X.
Qed.

Lemma noCycle_test2 l r : node (node l l) r <> r.
Proof.
  intros H; pose proof (noCycle_tree _ _ (eq_sym H)).
  find_noCycle_proof X.
Qed.

Lemma noCycle_test3 l r k u : node (node k (node l l)) (node u r) <> r.
Proof.
  intros H; pose proof (noCycle_tree _ _ (eq_sym H)).
  find_noCycle_proof X.
Qed.

Equations build_tree (l r : tree) (n : nat) : tree :=
build_tree l r 0 := node r r;
build_tree l r (S n) := node l (build_tree l r n).
Transparent build_tree.

Lemma noCycle_bigtest l r : build_tree l r 10 <> r.
Proof.
  intros H; pose proof (noCycle_tree _ _ (eq_sym H)).
  find_noCycle_proof X.
Qed.


Require Import Automate.

Require Import Coq.Structures.Orders.

(* The Syntax of CPL in NNF. For simplicity, we restrict the type of
   variables to totally ordered things with Leibniz equality *)
Module MakeNNF (var_type : UsualOrderedType) <: UsualOrderedType.

Inductive Formula : Type :=
  | PosVar : var_type.t -> Formula
  | NegVar : var_type.t -> Formula
  | And : Formula -> Formula -> Formula
  | Or : Formula -> Formula -> Formula.
Hint Constructors Formula.

Lemma Formula_eq_dec : forall (f1 f2 : Formula), {f1=f2} + {f1 <> f2}.
decide equality; solve [apply var_type.eq_dec].
Defined.
Hint Resolve Formula_eq_dec.

(* The shapes of Formulae - these are needed to specify rules, and also
   in our ordering *)

Inductive isPosVar : Formula -> Prop := IsPosVar : forall v, isPosVar (PosVar v).
Inductive isNegVar : Formula -> Prop := IsNegVar : forall v, isNegVar (NegVar v).
Inductive isAnd : Formula -> Prop := IsAnd : forall f1 f2, isAnd (And f1 f2).
Inductive isOr : Formula -> Prop := IsOr : forall f1 f2, isOr (Or f1 f2).
Hint Constructors isPosVar isNegVar isAnd isOr.

(* And these are all decidable *)

Ltac isShape_dec shape := intro f; destruct f; crush_dec false shape.

Definition isPosVar_dec : forall f, {isPosVar f} + {~isPosVar f}.
isShape_dec isPosVar. Defined.
Definition isNegVar_dec : forall f, {isNegVar f} + {~isNegVar f}.
isShape_dec isNegVar. Defined.
Definition isAnd_dec : forall f, {isAnd f} + {~isAnd f}.
isShape_dec isAnd. Defined.
Definition isOr_dec : forall f, {isOr f} + {~isOr f}.
isShape_dec isOr. Defined.

Notation "X <v Y" := (var_type.lt X Y) (at level 80).
Reserved Notation "X <f Y" (at level 80).

Inductive flt : Formula -> Formula -> Prop :=
  | PVar_fltS : forall v v', v <v v' -> PosVar v <f PosVar v'
  | PVar_fltD : forall v f, isNegVar f \/ isAnd f \/ isOr f -> PosVar v <f f
  | NVar_fltS : forall v v', v <v v' -> NegVar v <f NegVar v'
  | NVar_fltD : forall v f, isAnd f \/ isOr f -> NegVar v <f f
  | And_fltS1 : forall f1 f2 f3 f4, f1 <f f3 -> (And f1 f2) <f (And f3 f4)
  | And_fltS2 : forall f1 f2 f3, f2 <f f3 -> (And f1 f2) <f (And f1 f3)
  | And_fltD : forall f1 f2 f3, isOr f3 -> (And f1 f2) <f f3
  | Or_fltS1 : forall f1 f2 f3 f4, f1 <f f3 -> (Or f1 f2) <f (Or f3 f4)
  | Or_fltS2 : forall f1 f2 f3, f2 <f f3 -> (Or f1 f2) <f (Or f1 f3)
  where "X <f Y" := (flt X Y).
Hint Constructors flt.

Lemma var_type_irrefl : forall v, ~(v <v v). apply irreflexivity. Defined.

Lemma fltPosVar_irrefl : forall (v : var_type.t), ~(PosVar v <f PosVar v).
intros; inversion 1; crush' var_type_irrefl ((isOr, isAnd), isNegVar).
Defined.

Lemma fltNegVar_irrefl : forall (v : var_type.t), ~(NegVar v <f NegVar v).
intros; inversion 1; crush' var_type_irrefl (isOr, isAnd).
Defined.

Lemma flt_irrefl : forall (f : Formula), ~(f <f f).
induction f; inversion 1; crush' (fltPosVar_irrefl, fltNegVar_irrefl) isOr.
Defined.

Lemma var_type_trans : forall (v1 v2 v3 : var_type.t), v1 <v v2 -> v2 <v v3 -> v1 <v v3.
eapply transitivity.
Defined.

Lemma flt_trans : forall (f1 f2 f3 : Formula), f1 <f f2 -> f2 <f f3 -> f1 <f f3.
induction f1; destruct f2; destruct f3; try solve [crush' false (((isOr, isAnd), isNegVar), flt)];
repeat inversion 1; crush' var_type_trans (((isOr, isAnd), isNegVar), flt).
Defined.

Instance flt_strorder : StrictOrder flt := Build_StrictOrder flt flt_irrefl flt_trans.

Fixpoint compare (f1 f2 : Formula) : comparison := match f1 with
  | PosVar v => match f2 with
    | PosVar v' => var_type.compare v v'
    | _ => Lt
    end
  | NegVar v => match f2 with
    | PosVar _ => Gt
    | NegVar v' => var_type.compare v v'
    | _ => Lt
    end
 | And x y => match f2 with
    | PosVar _ | NegVar _ => Gt
    | And x' y' => match compare x x' with
      | Eq => compare y y'
      | res => res
      end
    | _ => Lt
    end
  | Or x y => match f2 with
    | Or x' y' => match compare x x' with
      | Eq => compare y y'
      | res => res
      end
    | _ => Gt
    end
  end.

Definition compare_spec : forall (f1 f2 : Formula),
  CompareSpec (f1 = f2) (f1 <f f2) (f2 <f f1) (compare f1 f2).
induction f1; destruct f2; crush; try solve [introvert (var_type.compare_spec t t0); crush];
repeat destruct_match;
repeat match goal with
  [|- context[compare ?x ?y]] => let H := fresh "H" in
    destruct (compare x y) eqn:H
  end; crush;
(* A little bit fragile, but it does the job. We just instantiate the induction
   hypotheses with the correct subtree, at which point inversion should provide 0 or
   1 constructors, which crush will discharge
   TODO clean, or at least fix to handle unary operators *)
set (X1:=IHf1_1 f2_1); rewrite H in X1; try (set (X2:= IHf1_2 f2_2); rewrite H0 in X2);
crush' false CompareSpec.
Defined.

Fixpoint component_count (f : Formula) : nat := match f with
  | PosVar _ | NegVar _ => 0
  | And x y | Or x y => S (component_count x + component_count y)
  end.

Lemma component_count_wf : well_founded (fun f1 f2 => component_count f1 < component_count f2).
Proof.
unfold well_founded; intro f; constructor;
induction (component_count f); crush; constructor; crush.
Defined.

Lemma shrinking : forall (f1 f2 : Formula), component_count (And f1 f2) = component_count (Or f1 f2) /\ component_count f1 + component_count f2 < component_count (And f1 f2).
Proof.
crush.
Defined.

(* Renamings and trivial definition so this module exports an OrderedType *)
Definition t := Formula.
Definition eq := @eq Formula.
Definition eq_dec := Formula_eq_dec.
Definition eq_equiv : Equivalence eq. unfold eq; constructor; crush. Defined.
Definition lt := flt.
Definition lt_strorder := flt_strorder.
Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. intuition. Defined.

End MakeNNF.