Require Import A1_Plan A2_Orientation A7_Tactics .
Require Import B7_Tactics .
Require Import C1_Distance C5_TriangularInequality C7_Tactics .
Require Import D5_Tactics .
Require Import F5_Tactics .
Require Import G1_Angles G4_Tactics.

Section TRIANGLES.

Inductive Triangle : Set :=
	| Tr : Point -> Point -> Point -> Triangle.

Definition TCongruent (t1 t2 : Triangle) :=
	match t1 with (Tr A1 B1 C1) =>
	match t2 with (Tr A2 B2 C2) =>
	Distance A1 B1 = Distance A2 B2 /\ Distance B1 C1 = Distance B2 C2 /\ Distance C1 A1 = Distance C2 A2
end end.

Lemma TCongruentSym : forall t1 t2 : Triangle,
	TCongruent t1 t2 -> TCongruent t2 t1.
Proof.
	intros; destruct t1; destruct t2; simpl in *.
	intuition; immediate6.
Qed.

Lemma TCongruentTrans : forall t1 t2 t3: Triangle,
	TCongruent t1 t2 -> TCongruent t2 t3 -> TCongruent t1 t3.
Proof.
	intros; destruct t1; destruct t2; destruct t3; simpl in *.
	intuition.
	 step5 H1.
	 step5 H0.
	 step5 H4.
Qed.

Lemma TCongruentPerm : forall A1 B1 C1 A2 B2 C2 : Point,
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2) ->
	TCongruent (Tr B1 C1 A1) (Tr B2 C2 A2).
Proof.
	simpl in |- *; intuition.
Qed.

Lemma TCongruentSubst : forall A1 B1 C1 A2 B2 C2 : Point,
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2) ->
	TCongruent (Tr B1 A1 C1) (Tr B2 A2 C2).
Proof.
	simpl in |- *; intuition; immediate6.
Qed.

Lemma SSSTCongruent : forall A1 B1 C1 A2 B2 C2 : Point,
	Distance A1 B1 = Distance A2 B2 ->
	Distance B1 C1 = Distance B2 C2 ->
	Distance C1 A1 = Distance C2 A2 ->
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2).
Proof.
	simpl in |- *; intuition.
Qed.

Lemma TCongruentEqSidesAB : forall A1 B1 C1 A2 B2 C2 : Point,
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2) ->
	Distance A1 B1 = Distance A2 B2.
Proof.
	simpl in |- *; intuition.
Qed.

Lemma TCongruentEqSidesBC : forall A1 B1 C1 A2 B2 C2 : Point,
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2) ->
	Distance B1 C1 = Distance B2 C2.
Proof.
	simpl in |- *; intuition.
Qed.

Lemma TCongruentEqSidesCA : forall A1 B1 C1 A2 B2 C2 : Point,
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2) ->
	Distance C1 A1 = Distance C2 A2.
Proof.
	simpl in |- *; intuition.
Qed.

Lemma TCongruentAnglesA : forall A1 B1 C1 A2 B2 C2 : Point,
	A1 <> C1 ->
	A1 <> B1 ->
	A2 <> C2 ->
	A2 <> B2 ->
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2) ->
	CongruentAngle C1 A1 B1 C2 A2 B2.
Proof.
	simpl in |- *; intros.
	apply CongruentSSS; intuition; immediate6.
Qed.

Lemma TCongruentAnglesB : forall A1 B1 C1 A2 B2 C2 : Point,
	B1 <> A1 ->
	B1 <> C1 ->
	B2 <> A2 ->
	B2 <> C2 ->
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2) ->
	CongruentAngle A1 B1 C1 A2 B2 C2.
Proof.
	simpl in |- *; intros.
	apply CongruentSSS; intuition; immediate6.
Qed.

Lemma TCongruentAnglesC : forall A1 B1 C1 A2 B2 C2 : Point,
	C1 <> B1 ->
	C1 <> A1 ->
	C2 <> B2 ->
	 C2 <> A2 ->
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2) ->
	CongruentAngle B1 C1 A1 B2 C2 A2.
Proof.
	simpl in |- *; intros.
	apply CongruentSSS; intuition; immediate6.
Qed.

Lemma SASTCongruent : forall A1 B1 C1 A2 B2 C2 : Point,
	Distance A1 B1 = Distance A2 B2 ->
	Distance B1 C1 = Distance B2 C2 ->
	CongruentAngle A1 B1 C1 A2 B2 C2   ->
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2).
Proof.
	simpl in |- *; intuition.
	rewrite (DistanceSym C1 A1); rewrite (DistanceSym C2 A2); apply (CongruentSAS B1 A1 C1 B2 A2 C2); immediate6.
Qed.

Lemma ASATClockwiseCongruent : forall A1 B1 C1 A2 B2 C2 : Point,
	Clockwise A1 B1 C1 ->
	CongruentAngle C1 A1 B1 C2 A2 B2  ->
	CongruentAngle B1 C1 A1 B2 C2 A2  ->
	Distance C1 A1 = Distance C2 A2 ->
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2).
Proof.
	intros.
	setCircle0 A1 A2 B2 ipattern:(gamma1).
	setCircle0 C1 C2 B2 ipattern:(gamma2).
	setIntersectionCircles3 gamma1 gamma2 ipattern:(B3).
	 since6 (TriangleSpec A2 B2 C2 B2 A2 C2).
	  simplCircle2; step6 H3.
	 since6 (TCongruent (Tr A1 B3 C1) (Tr A2 B2 C2)).
	  apply SSSTCongruent; immediate6.
	  assert (Ha1b3 : A1 <> B3).
	   step6 H4; immediate6.
	   from6 H0 (CongruentAngle C1 A1 B1 C1 A1 B3).
	      apply TCongruentAnglesA.
	     immediate6.
	     immediate6.
	     immediate6.
	     immediate6.
	     apply TCongruentSym; exact H7.
	    from6 H1 (CongruentAngle B1 C1 A1 B3 C1 A1).
	       apply TCongruentAnglesC.
	      immediate6.
	      immediate6.
	      step6 H5; immediate6.
	      immediate6.
	      apply TCongruentSym; exact H7.
	     from6 H9 (OpenRay C1 B1 B3).
	      from6 H8 (OpenRay A1 B1 B3).
	       from6 H (B1 = B3).
	        subst; immediate6.
Qed.

Lemma ASATCongruent : forall A1 B1 C1 A2 B2 C2 : Point,
	~Collinear A1 B1 C1 ->
	CongruentAngle C1 A1 B1 C2 A2 B2  ->
	CongruentAngle B1 C1 A1 B2 C2 A2  ->
	Distance C1 A1 = Distance C2 A2 ->
	TCongruent (Tr A1 B1 C1) (Tr A2 B2 C2).
Proof.
	intros.
	by2Cases1 H.
	 apply (ASATClockwiseCongruent A1 B1 C1 A2 B2 C2); immediate6.
	 apply TCongruentSubst; apply TCongruentPerm.
	   apply (ASATClockwiseCongruent C1 B1 A1 C2 B2 A2); immediate6.
Qed.

End TRIANGLES.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal5.

Set Printing Depth 1000.
Definition lfind_eval  x:=
len (rev x).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).


Require Import graph.
Require Import List.
Require Import Setoid.  (* Generalized rewriting *)
Require Import FSets.   (* Efficient functional sets *)
Require Import FMaps.   (* Efficient functional maps *)
Require Import PArith.
From Hammer Require Import Hammer.
From Hammer Require Import Tactics.
Import Arith.
Import ListNotations.
Import Nat.

Local Open Scope positive_scope.

(* union of maps (left-heavy) *)
Definition Munion {A} (f g : M.t A) := M.fold (fun k v => M.add k v) f g.
(* Two maps are disjoint if their keys have no intersection. *)
(* Mkeys is just Mdomain *)
Definition Mdisjoint {A} (f g : M.t A) := S.Equal (S.inter (Mdomain f) (Mdomain g)) S.empty.

(* Test case for disjointness *)
Example Mdisjoint_test1 :
  Mdisjoint (fold_right (fun p m => M.add (fst p) (snd p) m) (@M.empty _) [(1,1);(2,2)])
            (fold_right (fun p m => M.add (fst p) (snd p) m) (@M.empty _) [(3,1);(4,2)]).
Proof. hauto l: on. Qed.

(* Note: since we're using equality on finite sets can we get for free
   that map disjointness is decidable *)
Lemma Mdisjoint_dec {A} (f g : M.t A) : {Mdisjoint f g} + {~ Mdisjoint f g}.
Proof. apply S.eq_dec. Qed.

Lemma Munion_case {A} : forall (c d : M.t A) i v,
    M.find i (Munion c d) = Some v -> M.find i c = Some v \/ M.find i d = Some v.
Proof.
  intros c d i.
  unfold Munion.
  apply WP.fold_rec_bis.
  - hauto unfold: PositiveMap.MapsTo, PositiveMap.In, PositiveMap.Equal.
  - hauto l: on.
  - intros k e a m' H H0 H1 v H2.
    destruct (E.eq_dec i k).
    + sfirstorder use: PositiveMap.gss.
    + hauto use: PositiveMapAdditionalFacts.gsident, WF.add_neq_o, PositiveMap.gss.
Qed.

Lemma Munion_in {A} : forall i (m1 m2 : M.t A),
    M.In i (Munion m1 m2) <-> M.In i m1 \/ M.In i m2.
Proof.
  intros i m1 m2.
  split.
  - hfcrush use: WP.F.not_find_mapsto_iff, @Munion_case unfold: PositiveMap.MapsTo, PositiveMap.In.
  - intros H.
    unfold Munion.
    destruct H.
    + destruct H as [e He].
      unfold M.MapsTo in He.
      revert He.
      apply WP.fold_rec_bis.
      * qauto l: on.
      * sauto lq: on rew: off.
      * intros k e0 a m' H H0 H1 He.
        destruct (E.eq_dec i k).
        ** hauto lq: on rew: off use: PositiveMap.gss unfold: PositiveMap.In, PositiveMap.MapsTo.
        ** hauto lq: on use: PositiveMap.gso, WF.add_neq_in_iff.
    + destruct H as [e He].
      unfold M.MapsTo in He.
      revert He.
      apply WP.fold_rec_bis.
      * qauto l: on.
      * sauto lq: on rew: off.
      * intros k e0 a m' H H0 H1 He.
        destruct (E.eq_dec i k).
        ** hauto lq: on rew: off use: PositiveMap.gss unfold: PositiveMap.In, PositiveMap.MapsTo.
        ** hauto lq: on use: PositiveMap.gso, WF.add_neq_in_iff.
Qed.


(* coqtop -lv filename -I LibDirectory *)

Require Import option.      (* personal *)
Require Import list.        (* personal *)
Require Import permute.     (* personal *)

Require Import List.
Require Import Arith.
Require Import Bool.

(******************************************************************************)
(*                               Assumptions                                  *)
(******************************************************************************)

Parameter A:Type.
Parameter R: A -> A -> Prop.
Parameter R_bool: A -> A -> bool.
Axiom R_refl:   forall x:A, R x x.
Axiom R_anti:   forall x y:A, R x y -> R y x -> x = y.
Axiom R_trans:  forall x y z:A, R x y -> R y z -> R x z.
Axiom R_total:  forall x y:A, R x y \/ R y x.
Axiom R_lem:    forall x y:A, R x y <-> R_bool x y = true.

Lemma R_or_not_R: forall x y:A, R x y \/ ~R x y.
Proof.
  intros x y.
  generalize (bool_dec (R_bool x y) true). intro H. elim H.
  clear H. intro H. left. rewrite R_lem. exact H.
  clear H. intro H. right. rewrite R_lem. exact H.
Qed.

Lemma A_dec: forall x y: A, x = y \/ x <> y.
Proof.
  intros x y. generalize (R_total x y). intro H. elim H.
  clear H. intro H. generalize (R_or_not_R y x). intro H'. elim H'.
  clear H'. intro H'. left. apply R_anti. exact H. exact H'.
  clear H'. intro H'. right. intro Eq. apply H'.
  rewrite Eq. rewrite Eq in H. exact H.
  clear H. intro H. generalize (R_or_not_R x y). intro H'. elim H'.
  clear H'. intro H'. left. apply R_anti. exact H'. exact H.
  clear H'. intro H'. right. intro Eq. apply H'.
  rewrite Eq. rewrite Eq in H. exact H.
Qed.

(******************************************************************************)
(*                                 Least                                      *)
(******************************************************************************)

Fixpoint least (l:list A) : option A :=
  match l with
    | nil     =>  None
    | (x::l') =>  let y' := least l' in
                  match y' with
                    | None    => Some x
                    | Some y  => match R_bool x y with
                                  | true  =>  Some x
                                  | false =>  Some y
                                 end
                  end
  end.

(* defining inductive predicate: Least a l <-> Some a = least l *)
Inductive  Least : A -> list A -> Prop :=
  | Least_single : forall a:A, Least a (a::nil)
  | Least_cons1  : forall (a b:A)(l:list A),
      Least a l -> R a b -> Least a (b::l)
  | Least_cons2  : forall (a b:A)(l:list A),
      Least a l -> R b a -> Least b (b::l).

Lemma least_none : forall (l:list A),
  least l = None <-> l = nil.
Proof.
  intro l. split. elim l. intro H. auto. clear l. intros a l.
  intros H H'. apply False_ind. simpl in H'. set (n:= least l) in H'.
  generalize H'. case n. intro b. set (v:= R_bool a b). case v.
  intro H0. discriminate H0. intro H0. discriminate H0.
  intro H0. discriminate H0.
  intro H. rewrite H. simpl. reflexivity.
Qed.

Lemma least_imp_Least: forall (a:A)(l:list A),
  least l = Some a -> Least a l.  Proof.
  (*induction on l *)
  intros a l. generalize a. clear a. elim l.
  (* l = nil *)
  simpl. intros a H. discriminate H.
  (* l = (a::l') *)
  clear l. intros a l IH b H. simpl in H.
  generalize H IH. set (ll := least l).
  elim ll. intros c H0 H1. elim (R_total a c).
  intro Rac. rewrite R_lem in Rac.
  rewrite Rac in H0.
  pose (g:= (fun o => match o with | None => a | Some x => x end)).
  fold (g (Some b)). rewrite <- H0. unfold g.
  apply Least_cons2 with (a:=c). apply H1. reflexivity.
  apply R_lem. exact Rac.
  intro Rca. apply Least_cons1. apply H1.
  cut ({R_bool a c = true} + { R_bool a c <> true}).
  intros Lac. elim Lac. intro Rac. rewrite Rac in H0.
  rewrite <- R_lem in Rac. cut (a = c). intro Eac.
  rewrite <- Eac. exact H0. apply R_anti. exact Rac. exact Rca.
  intro Rac. cut (R_bool a c = false). intro Rac'.
  rewrite Rac' in H0. exact H0. apply not_true_is_false.
  exact Rac. apply bool_dec.
  cut ({R_bool a c = true} + { R_bool a c <> true}).
  intros Lac. elim Lac. intro Rac. rewrite Rac in H0.
  injection H0. intro Eab. rewrite Eab. apply R_refl.
  intro Rac. cut (R_bool a c = false). intro Rac'.
  rewrite Rac' in H0. injection H0. intro Ecb.
  rewrite <- Ecb. exact Rca. apply not_true_is_false.
  exact Rac. apply bool_dec. intro Eab. intro H'. clear H'.
  injection Eab. clear Eab. intro Eab. rewrite <- Eab.
  rewrite <- Eab in H. clear Eab b. fold ll in H.
  fold ll in IH. cut (ll = None \/ ll <> None).
  intro Hll. elim Hll. intro Nonell. cut (l=nil).
  intro lnil. rewrite lnil. apply Least_single.
  apply least_none. exact Nonell. intro H'.
  cut (exists c:A, ll = Some c). intro H0.
  elim H0. intro c. intro Hc. rewrite Hc in H.
  cut (R a c \/ R c a). intro H1. elim H1.
  intro Rac. apply Least_cons2 with (a:=c).
  apply IH. exact Hc. exact Rac. intro Rca.
  cut ({R_bool a c = true} + {R_bool a c <> true}).
  intro H2. elim H2. intro Rac. cut (a = c).
  intro Eac. apply Least_cons1. rewrite Eac.
  apply IH. exact Hc. apply R_refl. apply R_anti.
  apply R_lem. exact Rac. exact Rca. intro Rac.
  cut (R_bool a c = false). intro Rac'.
  rewrite Rac' in H. injection H. intro Eca.
  apply Least_cons1. rewrite <- Eca. apply IH.
  exact Hc. apply R_refl. apply not_true_is_false.
  exact Rac. apply bool_dec. apply R_total.
  apply not_none_is_some. exact H'.
  apply none_or_not_none.
Qed.

Lemma Least_imp_least: forall (a:A)(l:list A),
  Least a l -> least l = Some a.
Proof.
  intros a l HL. generalize HL. elim HL.
  simpl. auto. clear a l HL. intros a b l H0 H1 H2 H3.
  simpl. rewrite H1. cut ({R_bool b a = true} + {R_bool b a <> true}).
  intro H4. elim H4. intro H5. rewrite H5. cut (a = b). intro Eab.
  rewrite <- Eab. reflexivity. apply R_anti. exact H2. apply R_lem.
  exact H5. intro H5. cut(R_bool b a = false). intro H6. rewrite H6.
  reflexivity. apply not_true_is_false. exact H5. apply bool_dec.
  exact H0. clear a l HL. intros a b l H0 H1 H2 H3. simpl.
  rewrite H1. rewrite R_lem in H2. rewrite H2. reflexivity. exact H0.
Qed.

Theorem Least_is_least: forall (a:A)(l:list A),
  Least a l <-> least l = Some a.
Proof.
  intros a l. split. apply Least_imp_least. apply least_imp_Least.
Qed.

(* We spent a fair amount of effort defining an inductive predicate Least
and proving the equivalence Least a l <-> least l= Some a. This effort is
now paying off, as proving properties of 'Least' is a lot easier than
dealing with 'least'. Try proving the following lemma in terms of 'least'
directly, and this will be plainly obvious *)

Lemma Least_imp_In: forall (a:A)(l:list A),
  Least a l -> In a l.
Proof.
  intros a l H. generalize H. elim H.
  simpl. auto.
  clear H a l. intros a b l H0 H1 H2 H3. simpl. right. apply H1. exact H0.
  clear H a l. intros a b l H0 H1 H2 H3. simpl. auto.
Qed.

Lemma Least_imp_smaller: forall (a b:A)(l: list A),
  Least a l -> In b l -> R a b.
Proof.
  intros a b l H. generalize H b. clear b. elim H.
  clear H a l. intros a H0 b H1.
  simpl in H1. elim H1. intro Eab. rewrite Eab. apply R_refl. apply False_ind.
  clear H a l. intros a b l H0 H1 H2 H3 c H4. simpl in H4. elim H4.
  intro Ebc. rewrite <- Ebc. exact H2. apply H1. exact H0.
  clear H a l. intros a b l H0 H1 H2 H3 c H4. simpl in H4. elim H4.
  intro Ebc. rewrite Ebc. apply R_refl. intro H5. apply R_trans with (y:= a).
  exact H2. apply H1. exact H0. exact H5.
Qed.

Lemma not_nil_exists_Least: forall (l:list A),
  l <> nil <-> exists a:A, Least a l.
Proof.
  intro l. split. intro H. cut (least l = None \/ least l <> None).
  intro H0. elim H0. intro H1. rewrite least_none in H1.
  apply False_ind. apply H. exact H1. intro H1.
  rewrite not_none_is_some in H1. elim H1.
  intros x Hx. exists x. rewrite Least_is_least. exact Hx.
  apply none_or_not_none. intro H. elim H. intros x Hx.
  rewrite Least_is_least in Hx. intro H0. rewrite <- least_none in H0.
  rewrite H0 in Hx. discriminate.
Qed.

Lemma smallest_imp_Least: forall (a:A)(l:list A),
  In a l -> (forall b:A, In b l -> R a b) -> Least a l.
Proof.
  intros a l. generalize a. clear a. elim l.
  simpl. intros a F. apply False_ind. exact F.
  clear l. intros b l IH a H0 H1. simpl.
  cut (l = nil \/ l <> nil). intro H2. elim H2. clear H2. intro H2.
  rewrite H2. simpl in H0. elim H0. intros Eba. rewrite Eba.
  apply Least_single. rewrite H2. clear H2. intro H2. simpl in H2.
  apply False_ind. exact H2. clear H2. intro H2.
  rewrite not_nil_exists_Least in H2. elim H2. intros a' Ha'.
  simpl in H0. elim H0. intro Eba. rewrite <- Eba.
  apply Least_cons2 with (a:=a'). exact Ha'. rewrite Eba.
  apply H1. simpl. right. apply Least_imp_In. exact Ha'.
  intro Ha. cut (a = a'). intro Ea. rewrite Ea. apply Least_cons1.
  exact Ha'. rewrite <- Ea. apply H1. simpl. left. reflexivity.
  apply R_anti. apply H1. simpl. right. apply Least_imp_In.
  exact Ha'. apply Least_imp_smaller with (l:=l). exact Ha'. exact Ha.
  apply nil_or_not_nil.
Qed.

(******************************************************************************)
(*                           Sorted list                                      *)
(******************************************************************************)

(* a possible definition as an inductive predicate *)
Inductive Sorted : list A -> Prop :=
  | SortedNil : Sorted nil
  | SortedCons: forall (a :A) (l:list A),
      Least a (a::l) -> Sorted l -> Sorted (a::l).

(* a possible definition as a boolean function *)
Fixpoint isSorted (l:list A) : bool :=
  match l with
    | nil     => true
    | (a::l') => match least l' with
                  | None    =>  true
                  | Some b  =>  match R_bool a b with
                                  | true   => isSorted l'
                                  | false  => false
                                end
                 end
  end.

(* before proceeding, we need to make sure the two notions are equivalent *)
Lemma Sorted_imp_isSorted: forall (l:list A),
  Sorted l -> isSorted l = true.
Proof.
  intros l H. generalize H. elim H.
  clear H l. simpl. auto.
  clear H l. intros a l H0 H1 H2 H3. simpl.
  set (L := least l). cut (L = least l ->
    match L with | Some b => if R_bool a b then isSorted l else false
                 | None => true
    end = true). eauto. generalize H0 H1 H2 H3. clear H0 H1 H2 H3.
  generalize a. clear a. elim L; auto. intros b a H0 H1 H2 H3 H4.
  cut (R_bool a b = true). intro H5. rewrite H5. apply H2. exact H1.
  rewrite <- R_lem. apply Least_imp_smaller with (l:= a::l). exact H0.
  simpl. right. apply Least_imp_In. apply Least_is_least. symmetry. exact H4.
Qed.

Lemma isSorted_a_b_Rab: forall (a b:A)(l:list A),
  isSorted (a::b::l) = true -> R a b.
Proof.
  intros a b l H. unfold isSorted in H. fold isSorted in H.
  set (L:= least (b::l)). cut (L = least (b::l) -> R a b). eauto.
  fold L in H. generalize H. clear H. generalize a. clear a. elim L.
  clear L. intros L a H0 H1. set (b1 := R_bool a L). fold b1 in H0.
  cut (b1 = R_bool a L -> R a b). eauto. generalize H0. clear H0.
  case b1. intros H0 H2. clear H0. apply R_trans with (y:= L).
  rewrite R_lem. symmetry. exact H2. apply Least_imp_smaller with (l:=b::l).
  rewrite Least_is_least. symmetry. exact H1. simpl. left. reflexivity.
  intros. discriminate.
  intros a H0 H1. symmetry in H1. rewrite least_none in H1. discriminate.
Qed.

Lemma isSorted_a_b_isSorted_a: forall (a b:A)(l: list A),
  isSorted(a::b::l) = true -> isSorted(a::l) = true.
Proof.
  intros a b l H. unfold isSorted in H. fold isSorted in H.
  set (L:= least (b::l)). cut (L = least (b::l) -> isSorted (a::l) = true). eauto.
  fold L in H. generalize H. clear H. generalize a. clear a. elim L.
  clear L. intros L a H0 H1. set (b1 := R_bool a L). fold b1 in H0.
  cut (b1 = R_bool a L -> isSorted (a :: l) = true). eauto. generalize H0. clear H0.
  case b1. intros H0 H2. unfold isSorted. fold isSorted.
  set (L':= least l). cut (L' = least l ->  match L' with
    | Some b0 => if R_bool a b0 then isSorted l else false
    | None => true
  end = true). eauto. fold L' in H0. generalize H0. clear H0. elim L'.
  clear L'. intros L' H0 H3.
  set (b2 := R_bool b L'). fold b2 in H0. generalize H0. clear H0. elim b2.
  intros H0. cut (R_bool a L' = true). intro H4. rewrite H4. exact H0.
  rewrite <- R_lem. apply R_trans with (y:=L).
  rewrite R_lem. symmetry. exact H2. apply Least_imp_smaller with (l:= b::l).
  apply Least_is_least. symmetry. exact H1. simpl. right. apply Least_imp_In.
  apply Least_is_least. symmetry. exact H3.
  intros. discriminate.
  intros. auto.
  intros. discriminate.
  intros a H0 H1. clear H0.
  symmetry in H1. rewrite least_none in H1. discriminate.
Qed.

Lemma isSorted_head_smallest: forall (a:A)(l:list A),
  isSorted (a::l) = true -> (forall b:A, In b l -> R a b).
Proof.
  intros a l. generalize a. clear a. elim l.
  clear l. intros a H0 b H1. simpl in H1. apply False_ind. exact H1.
  clear l. intros b l IH a H0 c H1.
  simpl in H1. elim H1.
  clear H1. intro H1. rewrite <- H1.
  apply isSorted_a_b_Rab with (l:=l). exact H0.
  clear H1. intro H1. apply IH.
  apply isSorted_a_b_isSorted_a with (b:=b). exact H0. exact H1.
Qed.

Lemma isSorted_tail: forall (a:A)(l:list A),
  isSorted (a::l) = true -> isSorted l = true.
Proof.
  intros a l H. simpl in H. set (L := least l). fold L in H.
  cut (L = least l -> isSorted l = true). eauto.
  generalize H. clear H. elim L.
  clear L. intros L H0 H1. set (b1 := R_bool a L). fold b1 in H0.
  generalize H0. clear H0. elim b1. auto. intros. discriminate.
  intros H0 H1. symmetry in H1. rewrite least_none in H1. rewrite H1.
  simpl. reflexivity.
Qed.

Lemma isSorted_imp_Sorted: forall (l:list A),
  isSorted l = true -> Sorted l.
Proof.
  intros l. elim l.
  clear l. intros. apply SortedNil.
  clear l. intros a l IH H. apply SortedCons.
  generalize H IH. clear H IH. generalize a. clear a. elim l.
  clear l. intros. apply Least_single.
  clear l. intros b l H0 a H1 H2. apply smallest_imp_Least.
  simpl. left. reflexivity.
  intros c Hc. simpl in Hc. elim Hc.
  clear Hc. intros Hc. rewrite Hc. apply R_refl.
  clear Hc. intro Hc. elim Hc.
  clear Hc. intro Hc. rewrite <- Hc.
  apply isSorted_head_smallest with (l:= b::l). exact H1.
  simpl. left. reflexivity.
  clear Hc. intro Hc. apply isSorted_head_smallest with (l:= b::l).
  exact H1. simpl. right. exact Hc.
  apply IH. apply isSorted_tail with (a:=a). exact H.
Qed.

Theorem  Sorted_is_isSorted: forall (l:list A),
  Sorted l <-> isSorted l = true.
Proof.
  intro l. split. apply Sorted_imp_isSorted. apply isSorted_imp_Sorted.
Qed.

(******************************************************************************)
(*                           The sort function                                *)
(******************************************************************************)

(* our definition of sort is based on insert *)
Fixpoint insert (a:A)(l:list A) : list A :=
  match l with
    | nil       => (a::nil)
    | (b::l')   => match R_bool a b with
                    | true      => (a::l)
                    | false     => (b::insert a l')
                  end
  end.

Fixpoint sort (l:list A) : list A :=
  match l with
    | nil       => nil
    | (a::l')   => insert a (sort l')
  end.

(******************************************************************************)
Fixpoint qsort (l:list A) : list A :=
  match l with
    | nil       => nil
    | (x::l')   => let lhs := l' in (* TODO *)
                   let rhs := l' in (* TODO *)
                      qsort lhs ++ (x::nil) ++ qsort rhs
  end.

(* is sort = qsort TODO *)
(* is sort idempotent TODO *)
(******************************************************************************)

Lemma In_insert_In: forall (l:list A)(a x:A),
  In x (insert a l) -> x = a \/ In x l.
Proof.
  intros l. elim l.
  clear l. simpl. intros a x H. elim H.
  clear H. intro H. left. symmetry. exact H.
  clear H. apply False_ind.
  clear l. intros b l IH a x H. set (b1:= R_bool a b).
  cut (b1 = R_bool a b ->  x = a \/ In x (b :: l)). eauto. elim b1.
  clear b1. intro H0. simpl in H. rewrite <- H0 in H. simpl in H. elim H.
  clear H. intro H. left. symmetry. exact H.
  clear H. intro H. elim H.
  clear H. intro H. right. simpl. left. exact H.
  clear H. intro H. right. simpl. right. exact H.
  clear b1. intro H0. simpl in H. rewrite <- H0 in H. simpl in H. elim H.
  clear H. intro H. right. simpl. left. exact H.
  clear H. intro H. apply IH in H. elim H.
  clear H. intro H. left. exact H.
  clear H. intro H. right. simpl. right. exact H.
Qed.

Lemma Sorted_insert: forall (l:list A)(a:A),
  Sorted l -> Sorted (insert a l).
Proof.
  intros l. elim l.
  clear l. simpl. intros. apply SortedCons. apply Least_single. apply SortedNil.
  clear l. intros a l IH b H0. set (b1:= R_bool b a).
  cut (b1 = R_bool b a -> Sorted (insert b (a :: l))). eauto. elim b1.
  clear b1. intro H1. simpl. rewrite <- H1. apply SortedCons.
  apply smallest_imp_Least. simpl. left. reflexivity. intros c Hc.
  simpl in Hc. elim Hc.
  clear Hc. intro Hc. rewrite Hc. apply R_refl.
  clear Hc. intro Hc. elim Hc. clear Hc. intro Hc. rewrite <- Hc.
  rewrite R_lem. symmetry. exact H1.
  clear Hc. intro Hc. apply R_trans with (y:=a). rewrite R_lem.
  symmetry. exact H1. apply isSorted_head_smallest with (l:=l).
  rewrite <- Sorted_is_isSorted. exact H0. exact Hc. exact H0.
  clear b1. intro H1. simpl. rewrite <- H1. apply SortedCons.
  apply smallest_imp_Least. simpl. left. reflexivity.
  intros c Hc. simpl in Hc. elim Hc.
  clear Hc. intro Hc. rewrite Hc. apply R_refl.
  clear Hc. intro Hc. apply In_insert_In in Hc. elim Hc.
  clear Hc. intro Hc. rewrite Hc. clear Hc. generalize (R_total a b).
  intro H2. elim H2. auto. clear H2. intro H2. rewrite R_lem in H2.
  rewrite H2 in H1. discriminate.
  clear Hc. intro Hc. apply isSorted_head_smallest with (l:=l).
  rewrite <- Sorted_is_isSorted. exact H0. exact Hc.
  apply IH. rewrite Sorted_is_isSorted. apply isSorted_tail with (a:=a).
  rewrite <- Sorted_is_isSorted. exact H0.
Qed.

(* This partially justifies our definition of sort *)
Theorem Sorted_sort: forall (l:list A), Sorted (sort l).
Proof.
  intro l. elim l.
  clear l. simpl. apply SortedNil.
  clear l. intros a l IH. simpl. apply Sorted_insert. exact IH.
Qed.

(* the lists (insert a l) and (a::l) are permutation of one another *)
Lemma Permute_insert: forall (l:list A)(a:A),
  Permute (insert a l) (a::l).
Proof.
  intros l. elim l.
  clear l. intros a. simpl. apply perm_self.
  clear l. intros b l IH a. set (b1:=R_bool a b).
  cut (b1 = R_bool a b ->  Permute (insert a (b :: l)) (a :: b :: l)).
  eauto. elim b1.
  clear b1. intro H. simpl. rewrite <- H. apply perm_self.
  clear b1. intro H. simpl. rewrite <- H.
  apply Permute_trans with (m:= (b::a::l)). apply Permute_cons. apply IH.
  apply (perm_next (b::a::l) (b::a::l) (a::b::l)). apply perm_self.
  cut (b::a::l = nil++(b::a::nil)++l).
  cut (a::b::l = nil++(a::b::nil)++l).
  intros H0 H1. rewrite H0, H1. apply transp_gen. apply transp_pair.
  rewrite app_nil_l, <- app_comm_cons, <- app_comm_cons, app_nil_l. reflexivity.
  rewrite app_nil_l, <- app_comm_cons, <- app_comm_cons, app_nil_l. reflexivity.
Qed.

(* This also partially justifies our definition of sort *)
Theorem Permute_sort: forall (l:list A), Permute (sort l) l.
Proof.
  intros l. elim l.
  clear l. simpl. apply perm_self.
  clear l. intros a l IH. simpl. apply Permute_trans with (m:=(a::(sort l))).
  apply Permute_insert. apply Permute_cons. exact IH.
Qed.

(* Permute l l' -> Sorted l -> Sorted l' -> l = l' ?? *)


Require Import Omega.
Require Import List.
Import ListNotations.

Inductive bit : Type := zero | one.

Inductive field : Type := Zero | One | Two | Three | Four | Five.

(* Knuth uses ':' but we depart from this and get similar aesthetics
   by squinting at Coq's pair syntax *)
Definition fieldspec : Type := field * field.

Notation " 0 " := Zero : fieldspec_scope.
Notation " 1 " := One : fieldspec_scope.
Notation " 2 " := Two : fieldspec_scope.
Notation " 3 " := Three : fieldspec_scope.
Notation " 4 " := Four : fieldspec_scope.
Notation " 5 " := Five : fieldspec_scope.

Definition fieldToNat (f : field) : nat :=
  match f with
  | Zero => 0
  | One => 1
  | Two => 2
  | Three => 3
  | Four => 4
  | Five => 5
  end.

Coercion fieldToNat : field >-> nat.
Import Nat.

Delimit Scope fieldspec_scope with fieldspec.

Inductive sign : Type := plus | minus.

Definition _word : nat -> nat -> Type := fun _ _ => Z.

Section withWidth.
  (* Parameterize operations on words over number of bits per byte and number of bytes per word. We will stay faithful to Knuth with 6-bit bytes and 5-byte words. *)
  Context (byteWidth wordWidth : nat).

  Let byteWrap := (2 ^ (Z.of_nat byteWidth))%Z.
  Let wordWrap :=  let (b,w) := (Z.of_nat byteWidth, Z.of_nat wordWidth) in
                   (2 ^ (b*w))%Z.

  Open Scope Z_scope.
  Definition word : Type := _word byteWidth wordWidth.
  (* Overflow doesn't change sign. Actually, Knuth is kind of vague
  about the semantics of overflow in TAOCP, I suppose leaving it as
  undefined behavior. *)
  Let signed (w : word) : Z :=
    match w with
    | Z0 => w
    | Zpos x => w mod wordWrap
    | Zneg x => - ((Zpos x) mod wordWrap)
    end.

  Let unsigned (w : word) : Z :=
    match w with
    | Z0 => w
    | Zpos x => w mod wordWrap
    | Zneg x => (Zpos x) mod wordWrap
    end.

  Let signOf (w : word) : sign :=
    match w with
      | Zneg _ => minus
      | _ => plus
    end.

  Definition of_Z (z : Z) : word := signed z.

  Let nthByte (w : word) (n : nat) : Z :=
    let w' := unsigned w in
    let fix do (left : word) (m : nat) :=
        match m with
        | O => left mod byteWrap
        | S m' => do (left / byteWrap) m'
        end
    in do w' n.

  Let bytesOf (w : word) : list Z :=
    let w' := unsigned w in
    let fix do (w : word) (n : nat) (acc : list Z) :=
        match n with
        | O => w mod byteWrap :: acc
        | S n' => do (w / byteWrap) n' (w mod byteWrap :: acc)
        end
    in do w' 4%nat [].

  Let of_bytes (bs : list Z) : word :=
    let fix do (bs : list Z) (acc : Z) (n : Z) :=
        match bs with
        | b :: bs => do bs (acc + (b * (byteWrap ^ n))) (n - 1)
        | [] => acc
        end
    in let n := Z.of_nat(length bs) in
       do bs 0 (n-1).

  Let slice {A} (l : list A) (L R : nat) : list A :=
    (* slice the list l, yielding a list containing the elements l[i] for i \in [L-1, R) *)
    let fix do (l : list A) (L R : nat) (acc : list A) :=
        match l with
        | l :: ls =>
          match L with
          | O =>
            match R with
            | O => List.rev acc
            | S R' => do ls L R' (l :: acc)
            end
          | S L' => do ls L' R acc
          end
        | [] => List.rev acc
        end
    in
    do l (L-1)%nat R [].

  Definition fieldOf (w : word) (F : fieldspec) : word :=
    let (L, R) := F in
    match (R ?= L)%nat with
    | Gt =>
      let (s,v) := (match L with
                    (* the field includes the sign bit *)
                    | Zero => (signOf w, unsigned w)
                    (* the field includes'nt the sign bit *)
                    | otherwise => (plus, unsigned w)
                    end) in
      (* Grab bytes L through R from the word w and treats them as a
         word of their own with sign s, where the rightmost byte of the
         selection occupying the rightmost position in the resulting
         word *)
      let bs := bytesOf w in
      let fieldSlice := slice bs L (R + 1) in
      let newWord := (unsigned (of_bytes fieldSlice)) in
      match s with
      | plus => newWord
      | minus => (- newWord)%Z
      end
    | otherwise => 0%Z (* when requesting a field of width 0 or less, just return the trivial word. *)
    end.
End withWidth.

Notation word5 := (word 6 5).
Notation word2 := (word 6 2).

Definition of_Z5 : Z -> word5 := of_Z 6 5.
Definition of_Z2 : Z -> word2 := of_Z 6 2.

Definition fieldOf5 : word5 -> fieldspec -> Z := fieldOf 6 5.
Definition fieldOf2 : word2 -> fieldspec -> Z := fieldOf 6 2.


Require Import Containers.OrderedTypeEx.
Require Export Index List Term Rational.
Require Import Nfix.Nfix Containers.Generate.

Require Import Eqdep_dec.
Module DomainDT <: DecidableType.
  Definition U := arith_domain.
  Lemma eq_dec : forall x y:U, {x = y} + {x <> y}.
    decide equality.
  Qed.
End DomainDT.
Module DomainEqDep := DecidableEqDep(DomainDT).

Section Symbol_as_UOT.
  Section ArithDomain_as_UOT.
    Generate OrderedType arith_domain.
    Property arith_domain_eq_iff : forall s s', arith_domain_eq s s' <-> s = s'.
    Proof.
      induction s; destruct s'; split; intro H; subst;
        try (inversion_clear H); try constructor; auto.
    Qed.
    Global Instance arith_domain_UOT : UsualOrderedType arith_domain := {
      SOT_lt := arith_domain_lt;
      SOT_cmp := arith_domain_cmp
    }.
    Proof.
    + constructor.
      - exact arith_domain_lt_trans.
      - intros; intro E; change (x = y) in E; rewrite <- arith_domain_eq_iff in E.
        exact (arith_domain_lt_irrefl _ _ H E).

    + intros; destruct (arith_domain_compare_spec x y); constructor; auto.
      exact (proj1 (arith_domain_eq_iff _ _) H).
    Defined.
  End ArithDomain_as_UOT.
  Definition arith_domain_OT : OrderedType arith_domain := SOT_as_OT.
  Existing Instance arith_domain_OT.

  Section Arithop_as_UOT.
    Generate OrderedType arithop.
    Property arithop_eq_iff : forall s s', arithop_eq s s' <-> s = s'.
    Proof.
      induction s; destruct s'; split; intro H; subst;
        try (inversion_clear H); try constructor; auto.
    Qed.

    Global Instance arithop_UOT : UsualOrderedType arithop := {
      SOT_lt := arithop_lt;
      SOT_cmp := arithop_cmp
    }.
    Proof.
    + constructor.
      - exact arithop_lt_trans.
      - intros; intro E; change (x = y) in E; rewrite <- arithop_eq_iff in E.
        exact (arithop_lt_irrefl _ _ H E).
    + intros; destruct (arithop_compare_spec x y); constructor; auto.
      exact (proj1 (arithop_eq_iff _ _) H).
    Defined.
  End Arithop_as_UOT.
  Definition arithop_OT : OrderedType arithop := SOT_as_OT.
  Existing Instance arithop_OT.

  Definition compare_cst (d d' : arith_domain)
    (c : dom_interp d) (c' : dom_interp d') : comparison :=
    match d as a, d' as b
      return dom_interp a -> dom_interp b -> comparison with
      | DomainNat, DomainNat => @compare nat _
      | DomainNat, _ => fun _ _ => Lt
      | _, DomainNat => fun _ _ => Gt
      | DomainN, DomainN => @compare N _
      | DomainN, _ => fun _ _ => Lt
      | _, DomainN => fun _ _ => Gt
      | DomainPos, DomainPos => @compare positive _
      | DomainPos, _ => fun _ _ => Lt
      | _, DomainPos => fun _ _ => Gt
      | DomainZ, DomainZ => @compare Z _
      | DomainZ, _ => fun _ _ => Lt
      | _, DomainZ => fun _ _ => Gt
      | DomainQ, DomainQ => @compare Qc _
    end c c'.

  Inductive symbol_lt : symbol -> symbol -> Prop :=
  | symbol_lt_Unint_1 :
    forall x y x' y', x <<< x' -> symbol_lt (Unint x y) (Unint x' y')
  | symbol_lt_Unint_2 :
    forall x y x' y', x === x' -> y <<< y' ->
      symbol_lt (Unint x y) (Unint x' y')
  | symbol_lt_Unint_Cst :
    forall x y d c, symbol_lt (Unint x y) (Cst d c)
  | symbol_lt_Unint_Op :
    forall x y d op, symbol_lt (Unint x y) (Op d op)
  | symbol_lt_Nat_1 :
    forall (c c' : nat), c <<< c'->
      symbol_lt (Cst DomainNat c) (Cst DomainNat c')
  | symbol_lt_Nat_N :
    forall c c', symbol_lt (Cst DomainNat c) (Cst DomainN c')
  | symbol_lt_Nat_Pos :
    forall c c', symbol_lt (Cst DomainNat c) (Cst DomainPos c')
  | symbol_lt_Nat_Z :
    forall c c', symbol_lt (Cst DomainNat c) (Cst DomainZ c')
  | symbol_lt_Nat_Q :
    forall c c', symbol_lt (Cst DomainNat c) (Cst DomainQ c')
  | symbol_lt_N_1 :
    forall (c c' : N), c <<< c'->
      symbol_lt (Cst DomainN c) (Cst DomainN c')
  | symbol_lt_N_Pos :
    forall c c', symbol_lt (Cst DomainN c) (Cst DomainPos c')
  | symbol_lt_N_Z :
    forall c c', symbol_lt (Cst DomainN c) (Cst DomainZ c')
  | symbol_lt_N_Q :
    forall c c', symbol_lt (Cst DomainN c) (Cst DomainQ c')
  | symbol_lt_Pos_1 :
    forall (c c' : positive), c <<< c'->
      symbol_lt (Cst DomainPos c) (Cst DomainPos c')
  | symbol_lt_Pos_Z :
    forall c c', symbol_lt (Cst DomainPos c) (Cst DomainZ c')
  | symbol_lt_Pos_Q :
    forall c c', symbol_lt (Cst DomainPos c) (Cst DomainQ c')
  | symbol_lt_Z_1 :
    forall (c c' : Z), c <<< c'->
      symbol_lt (Cst DomainZ c) (Cst DomainZ c')
  | symbol_lt_Z_Q :
    forall c c',
      symbol_lt (Cst DomainZ c) (Cst DomainQ c')
  | symbol_lt_Q_1 :
    forall (c c' : Qc), c <<< c'->
      symbol_lt (Cst DomainQ c) (Cst DomainQ c')
  (*   | symbol_lt_Cst_1 :  *)
(*     forall d c d' c', d <<< d' -> symbol_lt (Cst d c) (Cst d' c') *)
(*   | symbol_lt_Cst_2_Nat :  *)
(*     forall (c c' : nat), c <<< c'->  *)
(*       symbol_lt (Cst DomainNat c) (Cst DomainNat c') *)
(*   | symbol_lt_Cst_2_N :  *)
(*     forall (c c' : N), c <<< c'->  *)
(*       symbol_lt (Cst DomainN c) (Cst DomainN c') *)
(*   | symbol_lt_Cst_2_Pos :  *)
(*     forall (c c' : positive), c <<< c'->  *)
(*       symbol_lt (Cst DomainPos c) (Cst DomainPos c') *)
(*   | symbol_lt_Cst_2_Z :  *)
(*     forall (c c' : Z), c <<< c'->  *)
(*       symbol_lt (Cst DomainZ c) (Cst DomainZ c') *)
  | symbol_lt_Cst_Op :
    forall d c d' op', symbol_lt (Cst d c) (Op d' op')
  | symbol_lt_Op_1 :
    forall d d' op op', d <<< d' -> symbol_lt (Op d op) (Op d' op')
  | symbol_lt_Op_2 :
    forall d d' op op', d === d' -> op <<< op' ->
      symbol_lt (Op d op) (Op d' op').

  Lemma cst_eq_dep :
    forall d c d' c', Cst d c = Cst d' c' ->
      @EqdepFacts.eq_dep arith_domain dom_interp d c d' c'.
  Proof.
    intros.
    inversion H; simpl; reflexivity.
  Qed.
  Lemma inj_cst_2 :
    forall d c c', Cst d c = Cst d c' -> c = c'.
  Proof.
    intros; apply DomainEqDep.eq_dep_eq; apply cst_eq_dep; assumption.
  Qed.

  Ltac dep_invert :=
    match goal with
      | H : Cst ?X ?y = Cst ?X ?z |- _ =>
        let IH := fresh "IH" in
          assert (IH := inj_cst_2 X y z H); subst; clear H
      | _ => idtac
    end.
  Property symbol_lt_trans : Transitive symbol_lt.
  Proof.
    intros [ty t|d c|e op]
      [ty' t'|d' c'|e' op']
      [ty'' t''|d'' c''|e'' op''];
      try (intro; inversion_clear 0;
        intro; inversion_clear 0;
          constructor; solve_by_trans_modulo);
      intros;
        try solve [constructor];
          try solve [inversion H | inversion H0 |
            destruct d; inversion H | destruct d'; inversion H0].
    destruct d; destruct d'; destruct d''; try solve
      [constructor | inversion H | inversion H0].
    inversion_clear H; inversion_clear H0; repeat dep_invert;
      constructor; solve_by_trans_modulo.
    inversion_clear H; inversion_clear H0; repeat dep_invert;
      constructor; solve_by_trans_modulo.
    inversion_clear H; inversion_clear H0; repeat dep_invert;
      constructor; solve_by_trans_modulo.
    inversion_clear H; inversion_clear H0; repeat dep_invert;
      constructor; solve_by_trans_modulo.
    inversion_clear H; inversion_clear H0; repeat dep_invert;
      constructor; solve_by_trans_modulo.
  Qed.
  Property symbol_lt_irrefl :
    forall s s', symbol_lt s s' -> s = s' -> False.
  Proof.
    intros; subst; destruct s'; try (inversion_clear H; solve [order]).
    destruct dom; inversion_clear H; repeat dep_invert; order.
  Qed.
  Definition symbol_StrictOrder :=
    Build_StrictOrder _ _ _ _ symbol_lt_trans symbol_lt_irrefl.

  Definition symbol_cmp (s s' : symbol) : comparison :=
    match s, s' with
      | Unint x y, Unint x' y' =>
        match x =?= x' with
          | Eq => y =?= y'
          | k => k
        end
      | _, Unint _ _ => Gt
      | Unint _ _, _ => Lt
      | Cst d c, Cst d' c' => compare_cst d d' c c'
      | Cst _ _, _ => Lt
      | _, Cst _ _ => Gt
      | Op d c, Op d' c' =>
        match d =?= d' with
          | Eq => c =?= c'
          | k => k
        end
    end.
  Property symbol_cmp_spec :
    forall x y, compare_spec (@Logic.eq _) symbol_lt x y (symbol_cmp x y).
  Proof.
    destruct x; destruct y; simpl; try (constructor; constructor; auto).

    destruct (compare_dec ty_idx ty_idx0);
      try (constructor; constructor; auto).
    destruct (compare_dec t_idx t_idx0);
      try (constructor; ((constructor; solve [auto]) || congruence)).

    destruct dom; destruct dom0; simpl; try (constructor; constructor; auto);
      set (Hc := compare_dec z z0); inversion Hc;
        constructor; ((constructor; solve [auto]) || congruence).

    destruct (compare_dec dom dom0);
      try (constructor; constructor; auto).
    destruct (compare_dec op op0);
      try (constructor; ((constructor; solve [auto]) || congruence)).
  Qed.

  Global Instance symbol_UOT : UsualOrderedType symbol := {
    SOT_lt := symbol_lt;
    SOT_cmp := symbol_cmp;
    SOT_StrictOrder := symbol_StrictOrder;
    SOT_compare_spec := symbol_cmp_spec
  }.
End Symbol_as_UOT.

Definition symbol_OT : OrderedType symbol := SOT_as_OT.
Existing Instance symbol_OT.

Nested Fixpoint cmp_term (t u : term) : comparison :=
  match t, u with
    | app f l, app g l' =>
      match f =?= g with
        | Eq => cmp_terms l l'
        | Lt => Lt
        | Gt => Gt
      end
  end
  with cmp_terms (ts us : terms) : comparison :=
    match ts, us with
      | nil, nil => Eq
      | nil, cons _ _ => Lt
      | cons _ _, nil => Gt
      | cons t tq, cons u uq =>
        match cmp_term t u with
          | Eq => cmp_terms tq uq
          | Lt => Lt | Gt => Gt
        end
    end.

Section TermMutualInduction.
  Variable P : term -> Prop.
  Variable Pl : terms -> Prop.

  Variable Happ : forall (f : symbol) (lt : terms), Pl lt -> P (app f lt).
  Variable Hnil : Pl tnil.
  Variable Hcons : forall t, P t -> forall lt, Pl lt -> Pl (tcons t lt).

  Theorem term_mutual_ind : (forall t : term, P t) /\ (forall l : terms, Pl l).
  Proof.
    assert (I := term_terms_rect P Pl Happ Hnil Hcons);
      split; [exact I| induction l; auto].
  Qed.
End TermMutualInduction.
Definition term_terms_rect_default (P : term -> Prop)
  (H : forall (f : symbol) (lt : terms),
    (forall t : term, In t lt -> P t) -> P (app f lt)) :
  forall t, P t.
Proof.
  refine (term_terms_rect P (fun lt => forall t, List.In t lt -> P t) H _ _).
  intros; contradiction H0.
  intros; inversion_clear H2; subst; auto.
Qed.

Definition term_lt (t u : term) := cmp_term t u = Lt.
Definition terms_lt (lt lu : terms) := cmp_terms lt lu = Lt.

Theorem cmp_term_terms_eq :
  (forall t, (fun t => forall u, cmp_term t u = Eq <-> t = u) t) /\
  (forall lt, (fun lt => forall lu, cmp_terms lt lu = Eq <-> lt = lu) lt).
Proof.
  apply term_mutual_ind.
  (* - Happ *)
  intros f lt IH [g lu]; simpl; destruct (compare_dec f g).
  split; intro abs; try discriminate abs; inversion abs; order.
  rewrite IH, H; split; congruence.
  split; intro abs; try discriminate abs; inversion abs; order.
  (* - Hnil *)
  intros [|? ?]; simpl; split; intro; auto; discriminate.
  (* - Hcons *)
  intros t IH lt IHl [|u lu]; simpl.
  split; intro; discriminate.
  case_eq (cmp_term t u); intro Ht; rewrite ?IH in Ht; subst.
  rewrite IHl; split; congruence.
  split; intro abs; try discriminate;
    inversion abs; rewrite <-IH in *; congruence.
  split; intro abs; try discriminate;
    inversion abs; rewrite <-IH in *; congruence.
Qed.
Definition cmp_term_eq := Eval simpl in proj1 (cmp_term_terms_eq).
Definition cmp_terms_eq := Eval simpl in proj2 (cmp_term_terms_eq).

Corollary term_lt_not_eq : forall t u, term_lt t u -> t <> u.
Proof.
  intros t u; rewrite <- cmp_term_eq; unfold term_lt; congruence.
Qed.
Corollary terms_lt_not_eq : forall lt lu, terms_lt lt lu -> lt <> lu.
Proof.
  intros lt lu; rewrite <- cmp_terms_eq; unfold terms_lt; congruence.
Qed.

Theorem term_terms_lt_trans :
  (forall t, (fun t => forall u v,
    term_lt t u -> term_lt u v -> term_lt t v) t) /\
  (forall lt, (fun lt => forall lu lv,
    terms_lt lt lu -> terms_lt lu lv -> terms_lt lt lv) lt).
Proof.
  apply term_mutual_ind.
  (* - Happ *)
  intros f lt IH [g lu] [h lv]; unfold term_lt; simpl.
  destruct (compare_dec f g); destruct (compare_dec g h);
    intros E1 E2; try discriminate.
  rewrite elim_compare_lt; auto; transitivity g; assumption.
  rewrite elim_compare_lt; auto; apply lt_eq with g; assumption.
  rewrite elim_compare_lt; auto; apply eq_lt with g; auto using symmetry.
  rewrite elim_compare_eq.
    unfold terms_lt in IH; eauto. transitivity g; assumption.
  (* - Hnil *)
  intros [|u lu] [|v lv]; unfold terms_lt; simpl; intros; auto; discriminate.
  (* - Hcons *)
  intros t IH lt IHl [|u lu] [|v lv]; unfold terms_lt;
    simpl; try (intros; discriminate).
  case_eq (cmp_term t u); intro Ht.
  rewrite cmp_term_eq in Ht; subst.
  destruct (cmp_term u v); intros; auto; unfold terms_lt in IHl; eauto.
  case_eq (cmp_term u v); intro Hu.
  rewrite cmp_term_eq in Hu; subst; auto.
  rewrite Ht; auto.
  rewrite (IH _ _ Ht Hu); auto.
  intros; discriminate.
  intros; discriminate.
Qed.
Definition term_lt_trans := Eval simpl in proj1 (term_terms_lt_trans).
Definition terms_lt_trans := Eval simpl in proj2 (term_terms_lt_trans).

Theorem cmp_term_terms_sym :
  (forall t, (fun t => forall u,
    cmp_term t u = CompOpp (cmp_term u t)) t) /\
  (forall lt, (fun lt => forall lu,
    cmp_terms lt lu = CompOpp (cmp_terms lu lt)) lt).
Proof.
  apply term_mutual_ind.
  (* - Happ *)
  intros f lt IH [g lu]; simpl.
  destruct (compare_dec f g).
  rewrite (elim_compare_gt H); split; auto.
  rewrite (elim_compare_eq (symmetry H)); apply IH.
  rewrite (elim_compare_lt H); split; auto.
  (* - Hnil *)
  intros [|u lu]; simpl; intros; split; congruence.
  (* - Hcons *)
  intros t IH lt IHl [|u lu]; simpl; auto.
  rewrite IH, IHl; destruct (cmp_term u t); auto.
Qed.
Definition cmp_term_sym := Eval simpl in proj1 (cmp_term_terms_sym).
Definition cmp_terms_sym := Eval simpl in proj2 (cmp_term_terms_sym).

Corollary cmp_term_spec :
  forall t u, compare_spec (@Logic.eq _) term_lt t u (cmp_term t u).
Proof.
  intros; case_eq (cmp_term t u); intro Ht; constructor.
  rewrite cmp_term_eq in Ht; exact Ht.
  exact Ht.
  hnf; rewrite cmp_term_sym; rewrite Ht; reflexivity.
Qed.

Corollary cmp_terms_spec :
  forall lt lu, compare_spec (@Logic.eq _) terms_lt lt lu (cmp_terms lt lu).
Proof.
  intros; case_eq (cmp_terms lt lu); intro Hlt; constructor.
  rewrite cmp_terms_eq in Hlt; exact Hlt.
  exact Hlt.
  hnf; rewrite cmp_terms_sym; rewrite Hlt; reflexivity.
Qed.

Instance term_UOT : UsualOrderedType term := {
  SOT_lt := term_lt;
  SOT_StrictOrder := Build_StrictOrder _ _ _ _ term_lt_trans term_lt_not_eq;
  SOT_cmp := cmp_term;
  SOT_compare_spec := cmp_term_spec
}.
Definition term_OT : OrderedType term := SOT_as_OT.
Existing Instance term_OT.

Instance terms_UOT : UsualOrderedType terms := {
  SOT_lt := terms_lt;
  SOT_StrictOrder := Build_StrictOrder _ _ _ _ terms_lt_trans terms_lt_not_eq;
  SOT_cmp := cmp_terms;
  SOT_compare_spec := cmp_terms_spec
}.
Definition terms_OT : OrderedType terms := SOT_as_OT.
Existing Instance terms_OT.


   Theorem t71: forall (R : Set)
                       (b : R)
                       (A : R -> Prop)
                       (E : Prop),
              (exists x : R, E -> A x)
                         <-> (E -> exists x : R, A x).
   Proof.
      split. intros. elim H. intros. exists x. apply (H1 H0).
      Require Import Classical.
      intro. generalize (classic E). intro. elim H0.
             intro. cut (exists x : R, A x). intro. elim H2. intros.
                    exists x. easy.
                    apply H. apply H1.
      intro. exists b. intro. contradiction.
   Qed.

   Theorem t72: forall (R : Set)
                       (b : R)
                       (A : R -> Prop)
                       (E : Prop),
                   (exists x : R, A x -> E)
                            <-> ((forall x : R, A x) -> E).
   Proof.
      intros. split. intros. elim H. intros. apply H1. apply H0.
      Require Import Classical.
      intros. generalize (classic E). intros. elim H0.
          intros. exists b. intros. assumption.
      intros. apply NNPP. intro. apply H1. apply H. intros.
      apply NNPP. intro. elim H2. exists x. intros. contradiction.

   Theorem t73: forall (R : Set)
                       (b : R)
                       (A : R -> Prop)
                       (E : Prop),
                   (exists x : R, A x -> E)
                            <-> ((forall x : R, A x) -> E).
   Proof.
      intros. split. intros. elim H. intros. apply H1. apply H0.
      Require Import Classical.
      intros. apply NNPP. intro. apply H0. exists b.
      intros. apply H. intros. apply NNPP. intro.
      elim H0. exists x. intros. contradiction.

   Theorem t74: forall (R : Set)
                       (A : R -> Prop)
                       (E : Prop),
                 (forall x : R, A x -> E)
                           <-> ((exists x : R, A x) -> E).
   Proof.
      intros. split. intros. elim H0. intro.  apply H.
      intro. intros. apply H. exists x. assumption.
   Qed.

   Theorem t75: forall (R : Set)
                       (A : R -> Prop)
                       (E : Prop),
                 (forall x : R, E -> A x)
                           <-> (E -> (forall x : R, A x)).
   Proof.
      intros. split. intros. apply (H x). assumption.
      intros. apply (H H0).
   Qed.

   Theorem t75_1: forall (R : Set)
                       (A B : R -> Prop),
                 (forall x : R, A x -> B x)
                           -> ((forall x : R, A x) -> (forall x : R, B x)).
   Proof.
      intros. apply (H x). apply H0.
   Qed.

   Theorem t75_2: forall A B : Set -> Prop,
                   (forall x : Set, A x -> B x)
                     -> ((exists x : Set, A x) -> exists x : Set, B x).
   Proof.
      intros. elim H0. intros. exists x. apply (H x). assumption.
   Qed.

   Theorem t75_3: forall P Q : Set -> Prop,
                   (forall x : Set, P x -> ~(Q x))
                     <-> ~(exists x : Set, P x /\ Q x).
   Proof.
      intros. split. intros. intro. elim H0. intros. cut(P x -> ~ Q x). intros.
      elim H2. apply H1. apply H1. apply H.
      intros. intro. elim H. exists x. split. assumption. assumption.
   Qed.

   Theorem t75_4: forall (P Q : Set -> Prop)
                         (b : Set)
                         (E : Prop),
                   (forall x : Set, Q x -> P x -> E)
                     <-> ((exists x : Set, P x /\ Q x) -> E).
   Proof.
      intros. split. intros. cut(Q b -> P b -> E). intros.  elim H0. intros.
      elim H2. intros. revert H3. revert H4. apply H. apply H.
      intros. apply H. exists x. split. assumption. assumption.
    Qed.


Require Import Setoid.
Require Import QuantumLib.Pad.
Require Export QuantumLib.Proportional.
Require Export SQIR.

Local Open Scope matrix_scope.
Local Open Scope ucom_scope.

(* Note: all the definitions in this file are restricted to the base_ucom
   type. To define the semantics using other gate sets, you must define a
   conversion function. See VOQC/RzQGateSet.v for an example. *)

(** Denotation of Unitaries **)

Definition ueval_r (dim n : nat) (U : base_Unitary 1) : Square (2^dim) :=
  match U with
  | U_R θ ϕ λ => pad_u dim n (rotation θ ϕ λ)
  end.

Definition ueval_cnot (dim m n: nat) : Square (2^dim) := pad_ctrl dim m n σx.

(** Denotation of ucoms **)

Fixpoint uc_eval {dim} (c : base_ucom dim) : Matrix (2^dim) (2^dim) :=
  match c with
  | c1 ; c2      => uc_eval c2 × uc_eval c1
  | uapp1 U n    => ueval_r dim n U
  | uapp2 _ m n  => ueval_cnot dim m n
  | _            => Zero (* no 3-qubit gates in our denotation function *)
  end.

(** Well-formedness **)

Lemma WF_ueval_r : forall dim n U, WF_Matrix (ueval_r dim n U).
Proof. intros. dependent destruction U. apply WF_pad. apply WF_rotation. Qed.

Lemma WF_ueval_cnot : forall dim m n, WF_Matrix (ueval_cnot dim m n).
Proof. intros dim m n. apply WF_pad_ctrl. apply WF_σx. Qed.

Lemma WF_uc_eval : forall {dim} (c : base_ucom dim), WF_Matrix (uc_eval c).
Proof.
  intros dim c.
  induction c; simpl; auto with wf_db.
  apply WF_ueval_r.
  apply WF_ueval_cnot.
Qed.

#[export] Hint Resolve WF_ueval_r WF_ueval_cnot WF_uc_eval : wf_db.

(** Equivalence and Structural Rules **)

Definition uc_equiv {dim} (c1 c2 : base_ucom dim) :=
  uc_eval c1 = uc_eval c2.

Infix "≡" := uc_equiv : ucom_scope.

Lemma uc_equiv_refl : forall {dim} (c1 : base_ucom dim),
  c1 ≡ c1.
Proof. easy. Qed.

Lemma uc_equiv_sym : forall {dim} (c1 c2 : base_ucom dim),
  c1 ≡ c2 -> c2 ≡ c1.
Proof. easy. Qed.

Lemma uc_equiv_trans : forall {dim} (c1 c2 c3 : base_ucom dim),
  c1 ≡ c2 -> c2 ≡ c3 -> c1 ≡ c3.
Proof. intros dim c1 c2 c3 H12 H23. unfold uc_equiv. rewrite H12. easy. Qed.

Lemma useq_assoc : forall {dim} (c1 c2 c3 : base_ucom dim),
  ((c1 ; c2) ; c3) ≡ (c1 ; (c2 ; c3)).
Proof.
  intros dim c1 c2 c3.
  unfold uc_equiv. unfold uc_eval. simpl.
  rewrite Mmult_assoc.
  reflexivity.
Qed.

Lemma useq_congruence : forall {dim} (c1 c1' c2 c2' : base_ucom dim),
    c1 ≡ c1' ->
    c2 ≡ c2' ->
    c1 ; c2 ≡ c1' ; c2'.
Proof.
  intros dim c1 c1' c2 c2' Ec1 Ec2.
  unfold uc_equiv; simpl.
  rewrite Ec1, Ec2.
  reflexivity.
Qed.

Add Parametric Relation (dim : nat) : (base_ucom dim) (@uc_equiv dim)
  reflexivity proved by uc_equiv_refl
  symmetry proved by uc_equiv_sym
  transitivity proved by uc_equiv_trans
  as uc_equiv_rel.

Add Parametric Morphism (dim : nat) : (@useq base_Unitary dim)
  with signature (@uc_equiv dim) ==> (@uc_equiv dim) ==> (@uc_equiv dim) as useq_mor.
Proof. intros x y H x0 y0 H0. apply useq_congruence; easy. Qed.

Lemma test_rel : forall (dim : nat) (c1 c2 : base_ucom dim), c1 ≡ c2 -> c2 ≡ c1.
Proof. intros. rewrite H. reflexivity. Qed.

Lemma test_mor : forall (dim : nat) (c1 c2 : base_ucom dim), c1 ≡ c2 -> c2 ; c1 ≡ c1 ; c1.
Proof. intros. rewrite H. reflexivity. Qed.

(* Equivalence up to a phase. *)

Definition uc_cong {dim : nat} (c1 c2 : base_ucom dim) :=
  uc_eval c1 ∝ uc_eval c2.
Infix "≅" := uc_cong (at level 70).

Lemma uc_cong_refl : forall {dim : nat} (c1 : base_ucom dim),
  c1 ≅ c1.
Proof. intros. exists 0%R. rewrite Cexp_0. rewrite Mscale_1_l. reflexivity. Qed.

Lemma uc_cong_sym : forall {dim : nat} (c1 c2 : base_ucom dim),
  c1 ≅ c2 -> c2 ≅ c1.
Proof.
  intros. inversion H.
  exists (Ropp x). rewrite H0. rewrite Mscale_assoc. rewrite <- Cexp_add.
  rewrite Rplus_comm.
  rewrite Rplus_opp_r. rewrite Cexp_0. rewrite Mscale_1_l. reflexivity.
Qed.

Lemma uc_cong_trans : forall {dim : nat} (c1 c2 c3 : base_ucom dim),
  c1 ≅ c2 -> c2 ≅ c3 -> c1 ≅ c3.
Proof.
  intros. inversion H. inversion H0.
  exists (x + x0)%R. rewrite H1. rewrite H2.
  rewrite Mscale_assoc.
  rewrite Cexp_add. reflexivity.
Qed.

Lemma uc_seq_cong : forall {dim : nat} (c1 c1' c2 c2' : base_ucom dim),
    c1 ≅ c1' -> c2 ≅ c2' -> c1; c2 ≅ c1'; c2'.
Proof.
  intros dim c1 c1' c2 c2' Ec1 Ec2.
  inversion Ec1. inversion Ec2.
  exists (x + x0)%R. simpl.
  rewrite H. rewrite H0.
  rewrite Mscale_mult_dist_r.
  rewrite Mscale_mult_dist_l.
  rewrite Mscale_assoc.
  rewrite Cexp_add.
  reflexivity.
Qed.

Add Parametric Relation (dim : nat) : (base_ucom dim) (@uc_cong dim)
  reflexivity proved by uc_cong_refl
  symmetry proved by uc_cong_sym
  transitivity proved by uc_cong_trans
  as uc_cong_rel.

Add Parametric Morphism (dim : nat) : (@useq base_Unitary dim)
  with signature (@uc_cong dim) ==> (@uc_cong dim) ==> (@uc_cong dim) as useq_cong_mor.
Proof. intros. apply uc_seq_cong; assumption. Qed.

Lemma uc_equiv_cong : forall {dim : nat} (c c' : base_ucom dim),
  (c ≡ c')%ucom -> c ≅ c'.
Proof.
  intros.
  exists 0. rewrite Cexp_0, Mscale_1_l.
  apply H.
Qed.

Lemma uc_cong_assoc : forall {dim} (c1 c2 c3 : base_ucom dim),
  ((c1 ; c2) ; c3) ≅ (c1 ; (c2 ; c3)).
Proof.
  intros.
  apply uc_equiv_cong.
  apply useq_assoc.
Qed.

(** uc_eval is unitary iff well-typed **)

Lemma ueval_r_unitary : forall dim n U,
    (n < dim)%nat ->
    WF_Unitary (ueval_r dim n U).
Proof.
  intros. dependent destruction U. apply pad_u_unitary. auto. apply rotation_unitary.
Qed.

Lemma ueval_cnot_unitary : forall dim m n,
    m <> n ->
    (m < dim)%nat ->
    (n < dim)%nat ->
    WF_Unitary (ueval_cnot dim m n).
Proof. intros. apply pad_ctrl_unitary; auto. apply σx_unitary. Qed.

Lemma uc_eval_unitary : forall (dim : nat) (c : base_ucom dim),
    uc_well_typed c -> WF_Unitary (uc_eval c).
Proof.
  intros dim c H.
  unfold WF_Unitary.
  split. apply WF_uc_eval.
  induction c; try dependent destruction u.
  - inversion H; subst.
    simpl. Msimpl. rewrite <- Mmult_assoc. rewrite (Mmult_assoc (_)†).
    rewrite IHc2; trivial. Msimpl.
    rewrite IHc1; easy.
  - inversion H; subst.
    simpl. destruct (ueval_r_unitary dim n (U_R r r0 r1) H1) as [_ UU].
    assumption.
  - inversion H; subst.
    simpl. destruct (ueval_cnot_unitary dim n n0 H5 H3 H4) as [_ UU].
    assumption.
Qed.

Lemma WT_if_nonzero : forall (dim : nat) (c : base_ucom dim),
  uc_eval c <> Zero -> uc_well_typed c.
Proof.
  intros dim u.
  induction u; intros H; try dependent destruction u.
  - simpl in *.
    constructor.
    + apply IHu1.
      intros F. rewrite F in *.
      rewrite Mmult_0_r in H.
      contradiction.
    + apply IHu2.
      intros F. rewrite F in *.
      rewrite Mmult_0_l in H.
      contradiction.
  - simpl in *.
    unfold pad_u, pad in H.
    bdestruct (n + 1 <=? dim); try contradiction.
    constructor; lia.
  - simpl in *.
    unfold ueval_cnot, pad_ctrl, pad in H.
    bdestruct (n <? n0).
    + bdestruct (n + (1 + (n0 - n - 1) + 1) <=? dim); try contradiction.
      constructor; lia.
    + bdestruct (n0 <? n); try contradiction.
      bdestruct (n0 + (1 + (n - n0 - 1) + 1) <=? dim); try contradiction.
      constructor; lia.
Qed.

(* Now we get bidirectionality for free! *)

Lemma uc_eval_unitary_iff : forall (dim : nat) (c : base_ucom dim),
    uc_well_typed c <-> WF_Unitary (uc_eval c).
Proof.
  split.
  - apply uc_eval_unitary.
  - intros H.
    apply WT_if_nonzero.
    intros F.
    rewrite F in H.
    apply zero_not_unitary in H.
    easy.
Qed.

Lemma uc_eval_nonzero_iff : forall (dim : nat) (c : base_ucom dim),
  uc_eval c <> Zero <-> uc_well_typed c.
Proof.
  split.
  - apply WT_if_nonzero.
  - intros H.
    intros F.
    apply uc_eval_unitary in H.
    rewrite F in H.
    apply zero_not_unitary in H.
    easy.
Qed.

(* This alternate form is also useful. *)
Lemma uc_eval_zero_iff : forall (dim : nat) (c : base_ucom dim),
  uc_eval c = Zero <-> not (uc_well_typed c).
Proof.
  split; intros H.
  - (* easy direction, implied by previous lemma *)
    rewrite <- uc_eval_nonzero_iff.
    intros contra.
    contradict contra.
    assumption.
  - (* slightly more annoying direction, not implied by the previous lemma *)
    induction c.
    assert (HWT: not ((uc_well_typed c1) /\ (uc_well_typed c2))).
    { intro contra.
      destruct contra.
      assert (uc_well_typed (c1; c2)) by (constructor; assumption).
      contradict H. assumption. }
    apply Classical_Prop.not_and_or in HWT.
    simpl; destruct HWT as [HWT | HWT].
    apply IHc1 in HWT. rewrite HWT. Msimpl_light; reflexivity.
    apply IHc2 in HWT. rewrite HWT. Msimpl_light; reflexivity.
    assert (HWT: (not (n < dim)%nat)).
    { intro contra.
      assert (@uc_well_typed _ dim (uapp1 u n)) by (constructor; assumption).
      contradict H. assumption. }
    dependent destruction u.
    simpl; unfold pad_u, pad.
    bdestructΩ (n + 1 <=? dim); reflexivity.
    assert (HWT: (not ((n < dim) /\ (n0 < dim) /\ (n <> n0)))%nat).
    { intro contra.
      destruct contra. destruct H1.
      assert (@uc_well_typed _ dim (uapp2 u n n0)) by (constructor; assumption).
      contradict H. assumption. }
    dependent destruction u.
    simpl; unfold ueval_cnot, pad_ctrl, pad;
    bdestruct (n <? n0); bdestruct (n0 <? n); try lia; try reflexivity.
    apply Classical_Prop.not_and_or in HWT.
    destruct HWT as [HWT | HWT].
    bdestructΩ (n + (1 + (n0 - n - 1) + 1) <=? dim); reflexivity.
    apply Classical_Prop.not_and_or in HWT.
    destruct HWT as [HWT | HWT].
    bdestructΩ (n + (1 + (n0 - n - 1) + 1) <=? dim); reflexivity.
    bdestructΩ (n + (1 + (n0 - n - 1) + 1) <=? dim); reflexivity.
    bdestructΩ (n0 + (1 + (n - n0 - 1) + 1) <=? dim); reflexivity.
    inversion u.
Qed.

(** Proofs About Standard Gates **)

Local Close Scope R_scope.

Lemma uc_well_typed_H : forall dim n, n < dim <-> uc_well_typed (@H dim n).
Proof.
  intros. split; intros H.
  constructor; assumption.
  inversion H; subst; assumption.
Qed.

Lemma uc_well_typed_X : forall dim n, n < dim <-> uc_well_typed (@X dim n).
Proof.
  intros. split; intros H.
  constructor; assumption.
  inversion H; subst; assumption.
Qed.

Lemma uc_well_typed_Y : forall dim n, n < dim <-> uc_well_typed (@Y dim n).
Proof.
  intros. split; intros H.
  constructor; assumption.
  inversion H; subst; assumption.
Qed.

Lemma uc_well_typed_Z : forall dim n, n < dim <-> uc_well_typed (@Z dim n).
Proof.
  intros. split; intros H.
  constructor; assumption.
  inversion H; subst; assumption.
Qed.

Lemma uc_well_typed_ID : forall dim n, n < dim <-> uc_well_typed (@ID dim n).
Proof.
  intros. split; intros H.
  constructor; assumption.
  inversion H; subst; assumption.
Qed.

Lemma uc_well_typed_Rx : forall dim θ n, n < dim <-> uc_well_typed (@Rx dim θ n).
Proof.
  intros. split; intros H.
  constructor; assumption.
  inversion H; subst; assumption.
Qed.

Lemma uc_well_typed_Ry : forall dim θ n, n < dim <-> uc_well_typed (@Ry dim θ n).
Proof.
  intros. split; intros H.
  constructor; assumption.
  inversion H; subst; assumption.
Qed.

Lemma uc_well_typed_Rz : forall dim θ n, n < dim <-> uc_well_typed (@Rz dim θ n).
Proof.
  intros. split; intros H.
  constructor; assumption.
  inversion H; subst; assumption.
Qed.

Lemma uc_well_typed_CNOT : forall dim m n,
  (m < dim /\ n < dim /\ m <> n) <-> uc_well_typed (@CNOT dim m n).
Proof.
  intros. split; intros H.
  destruct H as [H1 [H2 H3]]. constructor; assumption.
  split; try split; inversion H; subst; assumption.
Qed.

Lemma uc_well_typed_SWAP : forall dim m n,
  (m < dim /\ n < dim /\ m <> n) <-> uc_well_typed (@SWAP dim m n).
Proof.
  intros. split; intros H.
  destruct H as [H1 [H2 H3]].
  repeat constructor; auto.
  inversion H; subst.
  inversion H2; subst.
  clear - H4 H5.
  apply uc_well_typed_CNOT in H4 as [? [? ?]].
  apply uc_well_typed_CNOT in H5 as [? [? ?]].
  auto.
Qed.

(* In general, we won't want to interact directly with the 'rotation' matrix. *)

Lemma denote_H : forall dim n, uc_eval (H n) = pad_u dim n hadamard.
Proof.
  intros. unfold uc_eval; simpl.
  rewrite hadamard_rotation.
  reflexivity.
Qed.

Lemma denote_X : forall dim n, uc_eval (X n) = pad_u dim n σx.
Proof.
  intros. unfold uc_eval; simpl.
  rewrite pauli_x_rotation.
  reflexivity.
Qed.

Lemma denote_Y : forall dim n, uc_eval (Y n) = pad_u dim n σy.
Proof.
  intros. unfold uc_eval; simpl.
  rewrite pauli_y_rotation.
  reflexivity.
Qed.

Lemma denote_Z : forall dim n, uc_eval (Z n) = pad_u dim n σz.
Proof.
  intros. unfold uc_eval; simpl.
  rewrite pauli_z_rotation.
  reflexivity.
Qed.

Lemma denote_ID : forall dim n, uc_eval (ID n) = pad_u dim n (I 2).
Proof.
  intros. unfold uc_eval; simpl.
  rewrite I_rotation.
  reflexivity.
Qed.

Lemma denote_SKIP : forall dim, dim > 0 -> uc_eval SKIP = I (2 ^ dim).
Proof.
  intros. unfold uc_eval; simpl.
  unfold pad_u, pad.
  rewrite I_rotation.
  gridify.
  reflexivity.
Qed.

Lemma denote_Rx : forall dim θ n, uc_eval (Rx θ n) = pad_u dim n (x_rotation θ).
Proof.
  intros. unfold uc_eval; simpl.
  rewrite <- Rx_rotation.
  unfold pad_u, pad.
  gridify.
  apply f_equal2; try reflexivity.
  apply f_equal2; try reflexivity.
  unfold rotation.
  solve_matrix.
  replace (-(PI/2))%R with (-(2*PI) + 3*PI/2)%R by lra.
  autorewrite with Cexp_db. lca.
  replace (-(PI/2))%R with (-(2*PI) + 3*PI/2)%R by lra.
  autorewrite with Cexp_db. lca.
Qed.

Lemma denote_Ry : forall dim θ n, uc_eval (Ry θ n) = pad_u dim n (y_rotation θ).
Proof.
  intros. unfold uc_eval; simpl.
  rewrite Ry_rotation.
  reflexivity.
Qed.

Lemma denote_Rz : forall dim θ n, uc_eval (Rz θ n) = pad_u dim n (phase_shift θ).
Proof.
  intros. unfold uc_eval; simpl.
  rewrite phase_shift_rotation.
  reflexivity.
Qed.

Lemma denote_cnot : forall dim m n,
  uc_eval (CNOT m n) = ueval_cnot dim m n.
Proof. easy. Qed.

Definition ueval_swap (dim m n: nat) : Square (2^dim) :=
  if (m <? n) then
      @pad (1+(n-m-1)+1) m dim
             ( ∣0⟩⟨0∣ ⊗ I (2^(n-m-1)) ⊗ ∣0⟩⟨0∣ .+
               ∣0⟩⟨1∣ ⊗ I (2^(n-m-1)) ⊗ ∣1⟩⟨0∣ .+
               ∣1⟩⟨0∣ ⊗ I (2^(n-m-1)) ⊗ ∣0⟩⟨1∣ .+
               ∣1⟩⟨1∣ ⊗ I (2^(n-m-1)) ⊗ ∣1⟩⟨1∣ )
  else if (n <? m) then
      @pad (1+(m-n-1)+1) n dim
             ( ∣0⟩⟨0∣ ⊗ I (2^(m-n-1)) ⊗ ∣0⟩⟨0∣ .+
               ∣0⟩⟨1∣ ⊗ I (2^(m-n-1)) ⊗ ∣1⟩⟨0∣ .+
               ∣1⟩⟨0∣ ⊗ I (2^(m-n-1)) ⊗ ∣0⟩⟨1∣ .+
               ∣1⟩⟨1∣ ⊗ I (2^(m-n-1)) ⊗ ∣1⟩⟨1∣ )
  else
      Zero.

(* auxiliary lemmas for denote_swap *)
Lemma Mplus_swap_first_and_last : forall {m n} (A B C D : Matrix m n),
  A .+ B .+ (C .+ D) = D .+ B .+ C .+ A.
Proof. intros. lma. Qed.

Lemma Mplus_swap_mid : forall {m n} (A B C D : Matrix m n),
  A .+ B .+ C .+ D = A .+ C .+ B .+ D.
Proof. intros. lma. Qed.

Lemma denote_swap : forall dim m n,
  @uc_eval dim (SWAP m n) = ueval_swap dim m n.
Proof.
  intros.
  simpl; unfold ueval_swap.
  unfold ueval_cnot, pad_ctrl, pad.
  gridify.
  - Qsimpl.
    rewrite Mplus_swap_first_and_last.
    reflexivity.
  - Qsimpl.
    rewrite Mplus_swap_first_and_last.
    rewrite Mplus_swap_mid.
    reflexivity.
Qed.

Lemma denote_swap_alt : forall dim a b, uc_eval (SQIR.SWAP a b) = pad_swap dim a b.
Proof.
  intros. simpl.
  repeat rewrite denote_cnot.
  rewrite <- Mmult_assoc.
  reflexivity.
Qed.

Lemma unfold_ueval_cnot : forall dim m n,
  ueval_cnot dim m n =
    if (m <? n) then
      @pad (1+(n-m-1)+1) m dim (∣1⟩⟨1∣ ⊗ I (2^(n-m-1)) ⊗ σx .+ ∣0⟩⟨0∣ ⊗ I (2^(n-m-1)) ⊗ I 2)
    else if (n <? m) then
      @pad (1+(m-n-1)+1) n dim (σx ⊗ I (2^(m-n-1)) ⊗ ∣1⟩⟨1∣ .+ I 2 ⊗ I (2^(m-n-1)) ⊗ ∣0⟩⟨0∣)
    else
      Zero.
Proof. easy. Qed.

Lemma unfold_ueval_r : forall dim n (U : base_Unitary 1),
  ueval_r dim n U = match U with
                    | U_R θ ϕ λ => pad_u dim n (rotation θ ϕ λ)
                    end.
Proof. easy. Qed.

Lemma unfold_pad : forall n start dim A,
  @pad n start dim A =
  if start + n <=? dim then I (2^start) ⊗ A ⊗ I (2^(dim - (start + n))) else Zero.
Proof. easy. Qed.

Lemma unfold_pad_u : forall dim n A,
  pad_u dim n A =
  if n + 1 <=? dim then I (2^n) ⊗ A ⊗ I (2^(dim - (n + 1))) else Zero.
Proof. easy. Qed.

Lemma unfold_ueval_swap : forall dim m n,
  ueval_swap dim m n =
    if (m <? n) then
      @pad (1+(n-m-1)+1) m dim
             ( ∣0⟩⟨0∣ ⊗ I (2^(n-m-1)) ⊗ ∣0⟩⟨0∣ .+
               ∣0⟩⟨1∣ ⊗ I (2^(n-m-1)) ⊗ ∣1⟩⟨0∣ .+
               ∣1⟩⟨0∣ ⊗ I (2^(n-m-1)) ⊗ ∣0⟩⟨1∣ .+
               ∣1⟩⟨1∣ ⊗ I (2^(n-m-1)) ⊗ ∣1⟩⟨1∣ )
    else if (n <? m) then
       @pad (1+(m-n-1)+1) n dim
             ( ∣0⟩⟨0∣ ⊗ I (2^(m-n-1)) ⊗ ∣0⟩⟨0∣ .+
               ∣0⟩⟨1∣ ⊗ I (2^(m-n-1)) ⊗ ∣1⟩⟨0∣ .+
               ∣1⟩⟨0∣ ⊗ I (2^(m-n-1)) ⊗ ∣0⟩⟨1∣ .+
               ∣1⟩⟨1∣ ⊗ I (2^(m-n-1)) ⊗ ∣1⟩⟨1∣ )
    else
      Zero.
Proof. easy. Qed.

Hint Rewrite denote_H denote_X denote_Y denote_Z denote_ID denote_SKIP
             denote_Rx denote_Ry denote_Rz denote_cnot denote_swap : eval_db.
Hint Rewrite unfold_ueval_r unfold_ueval_cnot unfold_ueval_swap unfold_pad unfold_pad_u : eval_db.

Global Opaque H X Y Z ID Rx Ry Rz CNOT SWAP.

(* Some unit tests *)

Lemma eval_H : uc_eval ((H 0) : base_ucom 1) = hadamard.
Proof.
  simpl. autorewrite with eval_db.
  simpl. Msimpl. reflexivity.
Qed.

Lemma eval_HHpar : uc_eval ((H 0; H 1) : base_ucom 2) = hadamard ⊗ hadamard.
Proof.
  simpl. autorewrite with eval_db.
  simpl. restore_dims. Msimpl.
  restore_dims. Msimpl.
  reflexivity.
Qed.

Lemma eval_HHseq : uc_eval ((H 0; H 0) : base_ucom 2) = I 4.
Proof.
  simpl. autorewrite with eval_db.
  simpl. Msimpl. solve_matrix.
Qed.

Lemma eval_CNOT : uc_eval ((CNOT 0 1) : base_ucom 2) = cnot.
Proof.
  simpl. autorewrite with eval_db.
  simpl. Msimpl. solve_matrix.
Qed.


Require Import Bool.
Require Import Arith.
Require Import JMeq.
Inductive FixInt:nat->Type:=
|zerobit:FixInt 0
|consbit:forall n,bool->FixInt n->FixInt (S n).

Definition cdrbits{n}(f:FixInt (S n)):FixInt n.
generalize (refl_equal(S n)).
pattern (S n) at 1.
refine match f in FixInt x return x=S n->FixInt n
with
|zerobit=>_
|consbit n' b l=>_
end.
discriminate.
intro.
injection H;intro.
rewrite H0 in l.
exact l.
Defined.

Definition carbit{n}(f:FixInt(S n)):bool.
generalize (refl_equal(S n)).
pattern (S n) at 1.
refine match f in FixInt x return x=S n->bool
with
|zerobit=>_
|consbit n' b l=>_
end.
discriminate.
intro.
exact b.
Defined.

Inductive eq_FixInt:forall n,FixInt n->FixInt n->Prop:=
|eqfi_zero:eq_FixInt 0 zerobit zerobit
|eqfi_cons:forall m,forall v w:FixInt m,forall b:bool,
eq_FixInt m v w->eq_FixInt (S m)(consbit m b v)(consbit m b w).

Theorem FixInt_case:forall n,
forall v:FixInt n,
(n=0->JMeq v zerobit)/\
forall m:nat,n=S m->exists b:bool,exists vv:FixInt m,
JMeq v(consbit m b vv).
intros.
split.
destruct v.
reflexivity.
intros.
discriminate H.
intros.
destruct v.
discriminate H.
exists b.
apply eq_add_S in H.
rewrite<-H.
exists v.
reflexivity.
Qed.

Theorem eq_FixInt_then_eq:forall n,
forall v w:FixInt n,
eq_FixInt n v w->v=w.
intro n.
elim n.
intros.
apply JMeq_eq.
generalize (FixInt_case 0);intro.
destruct (H0 v).
clear H2.
rewrite (H1(refl_equal 0)).
destruct(H0 w).
clear H3.
rewrite(H2(refl_equal 0)).
reflexivity.
intros.
generalize(refl_equal(S n0)).
generalize(JMeq_refl v)(JMeq_refl w).

refine match H0 in eq_FixInt x vv ww return JMeq v vv->JMeq w ww->x=S n0-> v=w
with
|eqfi_zero=>_
|eqfi_cons _ _ _ _ _=>_
end.
discriminate.
intros.
apply eq_add_S in H3.
rewrite<-H3 in H.
generalize(H v0 w0 e);intro.
rewrite H4 in H1.
rewrite<-H2 in H1.
exact (JMeq_eq H1).
Qed.

Fixpoint beq_FixInt{n}(a b:FixInt n):bool.
destruct n.
exact true.
generalize (FixInt_case(S n));intro.
generalize (proj2(H a) n(refl_equal(S n)));intro.
generalize (proj2(H b) n(refl_equal(S n)));intro.
generalize (refl_equal(S n)).
generalize (JMeq_refl b).
refine match b as bb in FixInt x  return JMeq b bb->S n=x->bool
with
|zerobit=>_
|consbit _ _ _=>_
end.
discriminate.
intros.
generalize (refl_equal(S n)).
generalize (JMeq_refl a).
refine match a as aa in FixInt x  return JMeq a aa->S n=x->bool
with
|zerobit=>_
|consbit _ _ _=>_
end.
discriminate.
intros.
apply eq_add_S in H3.
apply eq_add_S in H5.
clear H.
clear H4.
rewrite <-H5 in f0.
clear H2.
rewrite <-H3 in f.
exact (andb (eqb b0 b1)(beq_FixInt n f f0)).
Defined.

Theorem beq_FixInt_eq:
forall n:nat,
forall a b:FixInt n,
beq_FixInt a b=true->a=b.
fix 1.
intro n.
case n.
intros.
generalize ((proj1(FixInt_case 0 a))(refl_equal 0));intro.
generalize ((proj1(FixInt_case 0 b))(refl_equal 0));intro.
rewrite H0.
rewrite H1.
reflexivity.
intros n0 a b.
generalize ((proj2(FixInt_case (S n0) a))n0 (refl_equal (S n0)));intro.
generalize ((proj2(FixInt_case (S n0) b))n0 (refl_equal (S n0)));intro.
destruct H.
destruct H.
destruct H0.
destruct H0.
rewrite H.
rewrite H0.
intros.
simpl in H1.
apply andb_prop in H1.
destruct H1.
apply beq_FixInt_eq in H2.
apply eqb_prop in H1.
rewrite H1.
Guarded.
compute in H2.
change (x2=x0) in H2.
rewrite H2.
apply eqfi_cons.
unfold eq_rec_r in H2.
unfold eq_rec in H2.
unfold eq_rect in H2.
apply H2.

Theorem fix0_is_zerobit:(forall f0:FixInt 0,f0=zerobit).
intro.
generalize (JMeq_refl f0).
generalize (refl_equal 0).
pattern f0 at 1.
pattern 0 at 2.
refine match f0 as ff0 in FixInt x return x=0->JMeq ff0 f0->f0=zerobit
with
|zerobit=>_
|consbit n b l=>_
end.
intros.
rewrite H0.
auto.
discriminate.
Qed.
rewrite (fix0_is_zerobit a).
rewrite (fix0_is_zerobit b).
reflexivity.

intros.
apply JMeq_eq.
generalize (refl_equal (S n0)).
pattern (S n0) at 2.
refine match a as aa in FixInt x  return(S n0=x->JMeq aa b)
with
|zerobit=>_
|consbit n' b l=>_
end.
discriminate.
intro.
apply eq_add_S in H0.
unfold beq_FixInt in H.
generalize (refl_equal (S n0)).
pattern (S n0) at 1.
refine match b as bb in FixInt y  return(y=S n0->JMeq (consbit n' b0 l) bb)
with
|zerobit=>_
|consbit n' b l=>_
end.
discriminate.
intros.
apply eq_add_S in H1.

destruct H.

SearchAbout JMeq.

case a.
intro b.


Require Import chap13.

Section counter_example.
 Let A : Set := nat.
 Let P l := match l with (LCons 0 l') => True
                        | other       => False
                    end.
 Let u := omega_repeat 1.
 Let v := LCons 0 LNil.

 Lemma L1 : satisfies v (Eventually P).
 Proof.
  unfold v, P;  left ; trivial.
 Qed.

 Lemma L2 : u = (LCons 1 u).
 Proof.
  unfold u; apply omega_repeat_unfold.
 Qed.

 Lemma L3 : forall (w: LList nat), satisfies w (Eventually P) ->
                                   exists n : nat, LNth n w = Some 0.
 Proof.
  induction 1.
  -   generalize H; case a;  simpl in H.
      + now  exists 0.
      +  contradiction.
  -  case IHEventually; intros p Hp; exists (S p); cbn ; auto.
 Qed.

 Lemma L4 : bisimilar u (LAppend u v).
 Proof.
   apply LAppend_of_Infinite_eq.
   -    unfold u;  apply omega_repeat_infinite.
 Qed.

 Lemma L5 : forall n, LNth n u = Some 1.
 Proof.
  simple induction n.
  -   now rewrite L2.
  -   intros n0 H0; rewrite L2; simpl; auto.
 Qed.

 Lemma L6 : forall n, LNth n (LAppend u v) = Some 1.
 Proof.
  intro n;  transitivity (LNth n u).
  -  apply bisimilar_LNth.
     generalize (bisimilar_sym (A:=nat));intro H;apply H.
     apply L4.
  -  apply L5.
 Qed.

 Lemma L7 : ~ satisfies (LAppend u v) (Eventually P).
 Proof.
  intro H; case (L3  _ H);  intros n  H1.
  generalize (L6 n); rewrite  H1;  discriminate 1.
 Qed.

End counter_example.

(** Now we can prove that, if we remove the hypothesis (Finite u)
   from its statement, Eventually_of_Lappend is false *)

Definition Eventually_of_LAppend' :=
 forall (A:Type)(P:LList A -> Prop) (u v:LList A),
    satisfies v (Eventually P) -> satisfies (LAppend u v) (Eventually P).

Lemma Conclusion :
  ~ Eventually_of_LAppend'.
Proof.
 intro H; generalize L7;intro H0;apply H0.
 apply H.
 apply L1.
Qed.


Require Import XR_R.
Require Import XR_R0.
Require Import XR_Rsqr.
Require Import XR_Rlt.
Require Import XR_Rdichotomy.
Require Import XR_Ropp_involutive.
Require Import XR_Ropp_mult_distr_l.
Require Import XR_Ropp_mult_distr_r.
Require Import XR_Rmult_lt_0_compat.
Require Import XR_Ropp_0.
Require Import XR_Ropp_lt_contravar.

Local Open Scope R_scope.

Lemma Rsqr_pos_lt : forall x:R, x <> R0 -> R0 < Rsqr x.
Proof.
  intros x h.
  unfold Rsqr.
  assert (h' := h).
  apply Rdichotomy in h'.
  destruct h' as [ hl | hr ].
  {
    rewrite <- Ropp_involutive with (x*x).
    rewrite Ropp_mult_distr_l.
    rewrite Ropp_mult_distr_r.
    apply Rmult_lt_0_compat.
    {
      rewrite <- Ropp_0.
      apply Ropp_lt_contravar.
      exact hl.
    }
    {
      rewrite <- Ropp_0.
      apply Ropp_lt_contravar.
      exact hl.
    }
  }
  {
    apply Rmult_lt_0_compat.
    { exact hr. }
    { exact hr. }
  }
Qed.


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Vector theory of real numbers based on ListList
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. Use real numbers to represent components.
  2. it is based on VectorThySig

  ref:
  1. 《高等数学学习手册》徐小湛，p173
  2. Vector Calculus - Michael Corral
  3. https://github.com/coq/coq/blob/master/test-suite/success/Nsatz.v
     注意，这里有Coq库中定义的几何学形式化内容，包括点，平行，共线等。
*)

Require Export DepRec.VectorThy.
Require Export FieldStruct.
Require Export ListListExt RExt.

Export FieldR.
Module Export VectorThyR := VectorThy FieldR.FieldDefR.

Open Scope R.
Open Scope mat_scope.
Open Scope vec_scope.

(* ######################################################################### *)
(** * 向量理论在实数域上的扩充 *)

(* ==================================== *)
(** ** 任意维度上的通用向量操作 *)
Section DimAny.

  (** 向量的长度，模，范数（欧几里得范数）的平方。方便计算。*)
  Definition vlen_sqr {n} (v : V n) : R := vdot v v.

  (** 向量的长度，模，范数（欧几里得范数）。存在性的构造，适合证明 *)
  Definition vlen {n} (v : V n) : R := sqrt (vlen_sqr v).

  (** 非零向量的单位化 *)
  Definition vnormalize {n} (v : V n) (H : vnonzero v) : V n :=
    let k := 1 / (vlen v) in
      vcmul k v.

  (** 非零向量v的k倍等于0，则k必为0 *)
  Lemma vcmul_nonzero_eq_zero_imply_k0 : forall {n} (v : V n) k,
    vnonzero v -> k c* v = vec0 -> k = 0.
  Proof.
    intros. destruct v. unfold vnonzero in *. unfold vec0 in *.
    unfold mcmul in *.
    apply meq_iff in H0. apply meq_iff_not in H. simpl in *.
    unfold dmap in *.
    destruct (Xeqdec k 0); auto.
    rename mat_data into dl.
    generalize dependent n.
    generalize dependent dl. induction dl; intros.
    - simpl in *; subst; simpl in *. easy.
    - simpl in *. destruct n; simpl in *. easy.
      destruct mat_width. inversion mat_height.
      unfold dlzero in H. simpl in H.
      rewrite cons_neq_iff in H; try apply list_eq_dec.
      + destruct H.
        * (* a != [0] *)
          destruct a; try easy.
          assert (x <> 0 /\ a = []).
          { apply list_length1_neq. split; auto. }
          destruct H3.
          rewrite H5 in H0. simpl in H0. inversion H0.
  (*         assert ({k = 0} + {k != 0}). apply Aeqdec. *)
          destruct (Xeqdec k 0); auto.
          assert (k * x <> 0)%X; try easy.
          apply Rmult_integral_contrapositive_currified; auto.
        * (* dl != repeat [A0] n *)
          apply IHdl with (n:=n); auto.
          inversion H0. rewrite H6. rewrite H5. auto.
      + apply Xeqdec.
  Qed.

  (** 向量平行（共线）：零向量与任何向量平行，或者非零向量是k倍的关系
    定义：u和v中，一个是另一个的数乘。
    平行：parallel
    共线：colinear

    遗留问题：主流做法是零向量与任何向量都平行、都垂直。
    是否可以：仅考虑非零向量的平行，零向量不考虑。
    一个原因是：考虑零向量后，平行传递性不完美了。
    *)

  (* 关于零向量的平行？
    1. https://www.zhihu.com/question/489006373
    两个方面:
    a. “平行”或“不平行”是对两个可以被识别的方向的比较，对于零向量，“方向”是不可
      识别的，或说，是不确定的。从这个角度讲，“平行”这个概念不该被用到评价两个
      零向量的关系上的。
    b. 不过，两个零向量是“相等”的，对于向量而言，“相等”这件事包含了大小和方向
      的相等，这么说来，说两个零向量“方向”相等，也就是“平行”或也是说得通的。
  *)

  (* 定义1：v0是v1的k倍，或者 v1是v0的k倍。*)
  Definition vparallel_ver1 {n} (v0 v1 : V n) : Prop :=
    exists k, (v0 = k c* v1 \/ v1 = k c* v0).

  (* 定义2：v0 是 0，或者 v1 是 0，或者 v0 是 v1 的 k 倍 *)
  Definition vparallel_ver2 {n} (v0 v1 : V n) : Prop :=
    (vzero v0) \/ (vzero v1) \/ (exists k, v0 = k c* v1).

  (* 证明这两个定义等价 *)
  Lemma vparallel_ver1_eq_ver2 : forall {n} (v0 v1 : V n),
    vparallel_ver1 v0 v1 <-> vparallel_ver2 v0 v1.
  Proof.
    intros. unfold vparallel_ver1, vparallel_ver2.
    unfold vzero, vnonzero. split; intros.
    - assert ({v0 = vec0} + {v0 <> vec0}). apply meq_dec.
      assert ({v1 = vec0} + {v1 <> vec0}). apply meq_dec.
      destruct H0.
      + left. auto.
      + destruct H1.
        * right. left. auto.
        * right. right. destruct H. destruct H.
          { exists x. auto. }
          { exists (1/x). rewrite H.
            rewrite mcmul_assoc.
            replace ((1/x)%R * x)%X with 1.
            rewrite mcmul_1_l. easy.
            compute. field.
            apply (vec_eq_vcmul_imply_coef_neq0 v1 v0); auto. }
    - destruct H.
      + exists 0. left. rewrite mcmul_0_l. rewrite H. rewrite vec0_eq_mat0.
        easy.
      + destruct H.
        * exists 0. right. rewrite mcmul_0_l,H,vec0_eq_mat0. easy.
        * destruct H. exists x. left. auto.
  Qed.

  (** 向量平行谓词的定义 *)
  Definition vparallel {n} (v0 v1 : V n) : Prop :=
    vparallel_ver2 v0 v1.

  Notation "v0 // v1" := (vparallel (v0) (v1)) (at level 70) : vec_scope.

  (** * 向量平行的性质 *)

  (** 向量平行是等价关系 *)

  (** 自反性 *)
  Lemma vparallel_refl : forall {n} (v : V n), v // v.
  Proof.
    intros. unfold vparallel,vparallel_ver2. right. right. exists 1.
    rewrite mcmul_1_l. easy.
  Qed.

  (** 对称性 *)
  Lemma vparallel_sym : forall {n} (v0 v1 : V n), v0 // v1 -> v1 // v0.
  Proof.
    intros. unfold vparallel,vparallel_ver2 in *.
    assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
    assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
    destruct H0.
    - right; left; auto.
    - destruct H1.
      + left; auto.
      + destruct H; auto. destruct H; auto. destruct H.
        right; right. rewrite H.
        exists (1/x). rewrite mcmul_assoc.
        replace ((1/x)%R * x)%X with 1. rewrite mcmul_1_l; easy.
        compute. field. apply (vec_eq_vcmul_imply_coef_neq0 v0 v1); auto.
  Qed.

  (** 传递性 *)
  (* 要求v1是非零向量。因为若v1为0，v0//v1, v1//v2, 但 v0,v2 不平行 *)
  Lemma vparallel_trans : forall {n} (v0 v1 v2 : V n),
    vnonzero v1 -> v0 // v1 -> v1 // v2 -> v0 // v2.
  Proof.
    intros. unfold vparallel, vparallel_ver2 in *.
    assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
    assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
    assert ({vzero v2} + {vnonzero v2}). apply meq_dec.
    destruct H2.
    - left; auto.
    - destruct H4.
      + right; left; auto.
      + right; right.
        destruct H3.
        * destruct H0; try contradiction.
        * destruct H0,H1; try contradiction.
          destruct H0,H1; try contradiction.
          destruct H0,H1. rewrite H0,H1.
          exists (x*x0)%X. apply mcmul_assoc.
  Qed.

  (** 非零向量k倍相等，k唯一 *)
  Lemma vcmul_vnonzero_eq_iff_unique_k : forall {n} (v : V n) (H : vnonzero v),
    forall k1 k2, k1 c* v = k2 c* v -> k1 = k2.
  Proof.
    intros. destruct v. apply meq_iff in H0. simpl in *.
    rename mat_data into dl. unfold vnonzero in H. apply meq_iff_not in H.
    simpl in *.
    unfold dmap in *.
    (* hard part *)
    generalize dependent n.
    generalize dependent dl.
    induction dl; intros.
    - simpl in *; subst; simpl in *. easy.
    - simpl in *. inversion H0. clear H0. destruct mat_width.
      destruct n. easy. simpl in *.
      apply cons_neq_iff in H. destruct H.
      + (* a != [0] *)
        destruct a. easy.
        assert (a = []).
        { simpl in *. inversion H0. rewrite length_zero_iff_nil in H5; auto. }
        assert (x <> 0).
        { rewrite H4 in *. apply cons_neq_iff in H. destruct H; auto.
          apply Xeqdec. }
        subst. simpl in H2. inversion H2.
        apply Rmult_eq_reg_r with (r:=x); auto.
      + (* dl != ListAux.cvt_row2col (repeat 0 n) *)
        apply IHdl with (n:=n); auto.
      + apply list_eq_dec. apply Xeqdec.
  Qed.

  (** 非零向量平行，则存在唯一比例系数k *)
  Lemma vparallel_vnonezero_imply_unique_k : forall {n} (v0 v1 : V n)
    (H1 : vnonzero v0) (H2 : vnonzero v1),
    v0 // v1 -> (exists ! k, v0 = k c* v1).
  Proof.
    intros.
    destruct H; try contradiction.
    destruct H; try contradiction.
    destruct H. exists x. unfold unique. split; auto.
    intros. apply vcmul_vnonzero_eq_iff_unique_k with (v:=v1); auto.
    rewrite <- H,H0. easy.
  Qed.

  (** 非零向量v0，v1 与 v0 平行，iff，存在唯一实数 a 使得 v1 = a * v0 *)
  Lemma vparallel_iff1 : forall {n} (v0 v1 : V n) (H : vnonzero v0),
    (v1 // v0) <-> (exists ! a, v1 = a c* v0).
  Proof.
    intros. split; intros.
    - unfold vparallel, vparallel_ver2, vnonzero in *.
      assert ({vzero v0} + {vnonzero v0}). apply meq_dec.
      assert ({vzero v1} + {vnonzero v1}). apply meq_dec.
      destruct H1; try contradiction.
      destruct H2.
      + (* {vzero v1} *)
        exists 0. unfold unique. split.
        * rewrite v2. rewrite mcmul_0_l. apply vec0_eq_mat0.
        * rewrite v2. intros.
          symmetry. symmetry in H1.
          apply vcmul_nonzero_eq_zero_imply_k0 with (v:=v0); auto.
      + (* {vnonzero v1} *)
        destruct H0; try easy.
        destruct H0; try easy.
        destruct H0.
        (* vnonzero v0 -> vnonzero v1 -> v1 = x * v0 -> exists ! x *)
        exists x. unfold unique. split; auto.
        intros. rewrite H0 in H1.
        apply vcmul_vnonzero_eq_iff_unique_k in H1; auto.
    - destruct H0. destruct H0.
      unfold vparallel. unfold vparallel_ver2.
      right. right. exists x. auto.
  Qed.

End DimAny.

(* ==================================== *)
(** ** 3-dim vector operations *)
Section Dim3.

  (** 3阶方阵的行列式 *)
  Definition det3 (m : M 3 3) : X :=
    let '((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) :=
      m2t_3x3 m in
    let b1 := (a11 * a22 * a33)%X in
    let b2 := (a12 * a23 * a31)%X in
    let b3 := (a13 * a21 * a32)%X in
    let c1 := (a11 * a23 * a32)%X in
    let c2 := (a12 * a21 * a33)%X in
    let c3 := (a13 * a22 * a31)%X in
    let b := (b1 + b2 + b3)%X in
    let c := (c1 + c2 + c3)%X in
      (b - c)%X.

  (** V3斜对称矩阵 *)
  Definition skew_sym_mat_of_v3 (v : V 3) : M 3 3 :=
    let '(x,y,z) := v2t_3 v in
      (mk_mat_3_3
        X0    (-z)  y
        z     X0    (-x)
        (-y)  x     X0)%X.

  (** V3叉乘，向量积 *)
  Definition vcross3 (v1 v2 : V 3) : V 3 := (skew_sym_mat_of_v3 v1) * v2.

  (** 矩阵是否为SO3（李群，旋转群） *)
  Definition so3 (m : M 3 3) : Prop :=
    let so3_mul_unit : Prop := (m ᵀ) * m = mat1 3 in
    let so3_det : Prop := (det3 m) = X1 in
      so3_mul_unit /\ so3_det.

   (** 计算两个向量的夹角 *)
  Definition vangle3 (v0 v1 : V 3) : R :=
    acos (scalar_of_mat (v0 ᵀ * v1)).

  (** (1,0,0) 和 (1,1,0) 的夹角是 45度，即 π/4 *)
  Example vangle3_ex1 : vangle3 (l2v [1;0;0]) (l2v [1;1;0]) = PI/4.
  Proof.
    compute.
(*     Search acos. *)
    Abort. (* 暂不知哪里错了，要去查叉乘的意义 *)

  (** 根据两个向量来计算旋转轴 *)
  Definition rot_axis_by_twovec (v0 v1 : V 3) : V 3 :=
    let s : R := (vlen v0 * vlen v1)%R in
      (s c* (vcross3 v0 v1))%M.

  (* 谓词：两向量不共线（不平行的） *)
  (* Definition v3_non_colinear (v0 v1 : V3) : Prop :=
    v0 <> v1 /\ v0 <> (-v1)%M.
   *)

End Dim3.


Require Import HoTT.Basics.Decidable HoTT.Basics.Trunc.
Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.theory.apartness.

Generalizable Variables A.

Lemma irrefl_neq `{R : Relation A} `{!Irreflexive R}
  : forall x y, R x y -> ~ x = y.
Proof.
intros ?? E e;rewrite e in E. apply (irreflexivity _ _ E).
Qed.

Lemma le_flip `{Le A} `{!TotalRelation (≤)} x y : ~y ≤ x -> x ≤ y.
Proof.
intros nle.
destruct (total _ x y) as [?|le];auto.
destruct (nle le).
Qed.

Section partial_order.
  Context `{PartialOrder A}.

  Lemma eq_le x y : x = y -> x ≤ y.
  Proof.
  intros E.
  rewrite E.
  apply reflexivity.
  Qed.

  Lemma eq_le_flip x y : x = y -> y ≤ x.
  Proof.
  intros E.
  rewrite E.
  apply reflexivity.
  Qed.

  Lemma not_le_ne x y : ~x ≤ y -> x <> y.
  Proof.
  intros E1 E2.
  apply E1.
  rewrite E2.
  apply reflexivity.
  Qed.

  Lemma eq_iff_le x y : x = y <-> x ≤ y /\ y ≤ x.
  Proof.
  split; intros E.
  - rewrite E. split;apply reflexivity.
  - apply (antisymmetry (≤) x y);apply E.
  Qed.
End partial_order.

Section strict_order.
  Context `{StrictOrder A}.

  Lemma lt_flip x y : x < y -> ~y < x.
  Proof.
  intros E1 E2.
  apply (irreflexivity (<) x).
  transitivity y;assumption.
  Qed.

  Lemma lt_antisym x y : ~(x < y < x).
  Proof.
  intros [E1 E2].
  destruct (lt_flip x y);assumption.
  Qed.

  Lemma lt_ne x y : x < y -> x <> y.
  Proof.
  intros E1 E2.
  rewrite E2 in E1.
  apply (irreflexivity (<) y). assumption.
  Qed.

  Lemma lt_ne_flip x y : x < y -> y <> x.
  Proof.
  intro.
  apply symmetric_neq, lt_ne.
  assumption.
  Qed.

  Lemma eq_not_lt x y : x = y -> ~x < y.
  Proof.
  intros E.
  rewrite E.
  apply (irreflexivity (<)).
  Qed.
End strict_order.

Section pseudo_order.
  Context `{PseudoOrder A}.

  Local Existing Instance pseudo_order_apart.

  Lemma apart_total_lt x y : x ≶ y -> x < y |_| y < x.
  Proof.
  intros.
  apply apart_iff_total_lt.
  assumption.
  Qed.

  Lemma pseudo_order_lt_apart x y : x < y -> x ≶ y.
  Proof.
  intros.
  apply apart_iff_total_lt.
  auto.
  Qed.

  Lemma pseudo_order_lt_apart_flip x y : x < y -> y ≶ x.
  Proof.
  intros.
  apply apart_iff_total_lt.
  auto.
  Qed.

  Lemma not_lt_apart_lt_flip x y : ~x < y -> x ≶ y -> y < x.
  Proof.
  intros nlt neq. apply apart_iff_total_lt in neq.
  destruct neq.
  - destruct nlt;auto.
  - auto.
  Qed.

  Lemma pseudo_order_cotrans_twice x₁ y₁ x₂ y₂
    : x₁ < y₁ -> merely (x₂ < y₂ |_| x₁ < x₂ |_| y₂ < y₁).
  Proof.
  intros E1.
  apply (merely_destruct (cotransitive E1 x₂));intros [?|E2];
  try solve [apply tr;auto].
  apply (merely_destruct (cotransitive E2 y₂));intros [?|?];apply tr;auto.
  Qed.

  Lemma pseudo_order_lt_ext x₁ y₁ x₂ y₂ : x₁ < y₁ ->
    merely (x₂ < y₂ |_| x₁ ≶ x₂ |_| y₂ ≶ y₁).
  Proof.
  intros E.
  apply (merely_destruct (pseudo_order_cotrans_twice x₁ y₁ x₂ y₂ E));
  intros [?|[?|?]];apply tr;
  auto using pseudo_order_lt_apart.
  Qed.

  Global Instance pseudoorder_strictorder : StrictOrder (_ : Lt A).
  Proof.
  split.
  - apply _.
  - intros x E.
    destruct (pseudo_order_antisym x x); auto.
  - intros x y z E1 E2.
    apply (merely_destruct (cotransitive E1 z));intros [?|?]; trivial.
    destruct (pseudo_order_antisym y z); auto.
  Qed.

  Global Instance nlt_trans : Transitive (complement (<)).
  Proof.
  intros x y z.
  intros E1 E2 E3.
  apply (merely_destruct (cotransitive E3 y));
  intros [?|?]; contradiction.
  Qed.

  Global Instance nlt_antisymm : AntiSymmetric (complement (<)).
  Proof.
  intros x y H1 H2.
  apply tight_apart. intros nap. apply apart_iff_total_lt in nap.
  destruct nap;auto.
  Qed.

  Lemma ne_total_lt `{!TrivialApart A} x y : x <> y -> x < y |_| y < x.
  Proof.
  intros neq;apply trivial_apart in neq.
  apply apart_total_lt. assumption.
  Qed.

  Global Instance lt_trichotomy `{!TrivialApart A} `{DecidablePaths A}
    : Trichotomy (<).
  Proof.
  intros x y.
  destruct (dec (x = y)) as [?|?]; try auto.
  destruct (ne_total_lt x y); auto.
  Qed.
End pseudo_order.

Section full_partial_order.
  Context `{FullPartialOrder A}.

  Local Existing Instance strict_po_apart.

  (* Duplicate of strong_setoids.apart_ne. This is useful because a
    StrongSetoid is not defined as a substructure of a FullPartialOrder *)
  Instance strict_po_apart_ne x y : PropHolds (x ≶ y) -> PropHolds (x <> y).
  Proof.
  intros; apply _.
  Qed.

  Global Instance fullpartialorder_strictorder : StrictOrder (<).
  Proof.
  split; try apply _.
  - apply strict_po_mere_lt.
  - intros x. red. intros E;apply lt_iff_le_apart in E.
    destruct E as [_ ?].
    apply (irreflexivity (≶) x).
    assumption.
  Qed.

  Lemma lt_le x y : PropHolds (x < y) -> PropHolds (x ≤ y).
  Proof.
  intro.
  apply lt_iff_le_apart.
  assumption.
  Qed.

  Lemma not_le_not_lt x y : ~x ≤ y -> ~x < y.
  Proof.
  intros E1 E2.
  apply E1. apply lt_le. assumption.
  Qed.

  Lemma lt_apart x y : x < y -> x ≶ y.
  Proof.
  intro.
  apply lt_iff_le_apart.
  assumption.
  Qed.

  Lemma lt_apart_flip x y : x < y -> y ≶ x.
  Proof.
  intro.
  apply symmetry, lt_iff_le_apart.
  assumption.
  Qed.

  Lemma le_not_lt_flip x y : y ≤ x -> ~x < y.
  Proof.
  intros E1 E2;apply lt_iff_le_apart in E2.
  destruct E2 as [E2a E2b].
  revert E2b. apply tight_apart.
  apply (antisymmetry (≤));assumption.
  Qed.

  Lemma lt_not_le_flip x y : y < x -> ~x ≤ y.
  Proof.
  intros E1 E2.
  apply (le_not_lt_flip y x);assumption.
  Qed.

  Lemma lt_le_trans x y z : x < y -> y ≤ z -> x < z.
  Proof.
  intros E1 E2.
  apply lt_iff_le_apart. apply lt_iff_le_apart in E1.
  destruct E1 as [E1a E1b].
  split.
  - transitivity y;assumption.
  - apply (merely_destruct (cotransitive E1b z));intros [E3 | E3]; trivial.
    apply lt_apart. apply symmetry in E3.
    transitivity y;apply lt_iff_le_apart; auto.
  Qed.

  Lemma le_lt_trans x y z : x ≤ y -> y < z -> x < z.
  Proof.
  intros E2 E1.
  apply lt_iff_le_apart. apply lt_iff_le_apart in E1.
  destruct E1 as [E1a E1b].
  split.
  - transitivity y;auto.
  - apply (merely_destruct (cotransitive E1b x));intros [E3 | E3]; trivial.
    apply lt_apart. apply symmetry in E3.
    transitivity y; apply lt_iff_le_apart; auto.
  Qed.

  Lemma lt_iff_le_ne `{!TrivialApart A} x y : x < y <-> x ≤ y /\ x <> y.
  Proof.
   transitivity (x <= y /\ apart x y).
   - apply lt_iff_le_apart.
   - split;intros [E1 E2];split;trivial;apply trivial_apart;trivial.
  Qed.

  Lemma le_equiv_lt `{!TrivialApart A} `{forall x y : A, Decidable (x = y)} x y
    : x ≤ y -> x = y |_| x < y.
  Proof.
  intros.
  destruct (dec (x = y)); try auto.
  right.
  apply lt_iff_le_ne; auto.
  Qed.

  Instance dec_from_lt_dec `{!TrivialApart A} `{forall x y, Decidable (x ≤ y)}
    : DecidablePaths A.
  Proof.
  intros x y.
  destruct (decide_rel (<=) x y) as [E1|E1];
  [destruct (decide_rel (<=) y x) as [E2|E2]|].
  - left. apply (antisymmetry (<=));assumption.
  - right. intros E3;apply E2.
    pattern y. apply (transport _ E3).
    apply reflexivity.
  - right. intros E3;apply E1.
    pattern y; apply (transport _ E3).
    apply reflexivity.
  Defined.

  Definition lt_dec_slow `{!TrivialApart A} `{forall x y, Decidable (x ≤ y)} :
    forall x y, Decidable (x < y).
  Proof.
  intros x y.
  destruct (dec (x ≤ y));
  [destruct (dec (x = y))|].
  - right. apply eq_not_lt. assumption.
  - left. apply lt_iff_le_ne. auto.
  - right. apply not_le_not_lt. assumption.
  Defined.
End full_partial_order.

(* Due to bug #2528 *)
Hint Extern 5 (PropHolds (_ <> _)) =>
  eapply @strict_po_apart_ne :  typeclass_instances.
Hint Extern 10 (PropHolds (_ ≤ _)) =>
  eapply @lt_le : typeclass_instances.
Hint Extern 20 (Decidable (_ < _)) =>
  eapply @lt_dec_slow : typeclass_instances.

Section full_pseudo_order.
  Context `{FullPseudoOrder A}.

  Local Existing Instance pseudo_order_apart.

  Lemma not_lt_le_flip x y : ~y < x -> x ≤ y.
  Proof.
  intros.
  apply le_iff_not_lt_flip.
  assumption.
  Qed.

  Instance fullpseudo_partial : PartialOrder (≤) | 10.
  Proof.
  repeat split.
  - apply _.
  - apply _.
  - intros x. apply not_lt_le_flip, (irreflexivity (<)).
  - intros x y z E1 E2.
    apply le_iff_not_lt_flip;
    apply le_iff_not_lt_flip in E1;
    apply le_iff_not_lt_flip in E2.
    change (complement (<) z x).
    transitivity y;assumption.
  - intros x y E1 E2.
    apply le_iff_not_lt_flip in E1;
    apply le_iff_not_lt_flip in E2.
    apply (antisymmetry (complement (<)));assumption.
  Qed.

  Lemma fullpseudo_fullpartial' : FullPartialOrder Ale Alt.
  Proof.
  split; try apply _.
  intros x y.
  split.
  - intros E. split.
    + apply not_lt_le_flip. apply lt_flip;assumption.
    + apply pseudo_order_lt_apart. assumption.
  - intros [? E]. apply not_lt_apart_lt_flip;[|symmetry;trivial].
    apply le_iff_not_lt_flip. trivial.
  Qed.

  Global Instance fullpseudo_fullpartial@{i} : FullPartialOrder Ale Alt
    := ltac:(first [exact fullpseudo_fullpartial'@{i i Set Set Set}|
                    exact fullpseudo_fullpartial'@{i i}]).

  Global Instance le_stable : forall x y, Stable (x ≤ y).
  Proof.
  intros x y. unfold Stable.
  intros dn. apply le_iff_not_lt_flip.
  intros E. apply dn.
  intros E';apply le_iff_not_lt_flip in E';auto.
  Qed.

  Lemma le_or_lt `{!TrivialApart A} `{DecidablePaths A} x y : x ≤ y |_| y < x.
  Proof.
  destruct (trichotomy (<) x y) as [|[|]]; try auto.
  - left. apply lt_le;trivial.
  - left. apply eq_le;trivial.
  Qed.

  Global Instance le_total `{!TrivialApart A} `{DecidablePaths A}
    : TotalOrder (≤).
  Proof.
  split; try apply _.
  intros x y.
  destruct (le_or_lt x y); auto.
  right. apply lt_le.
  trivial.
  Qed.

  Lemma not_le_lt_flip `{!TrivialApart A} `{DecidablePaths A} x y
    : ~y ≤ x -> x < y.
  Proof.
  intros.
  destruct (le_or_lt y x); auto.
  contradiction.
  Qed.

  Existing Instance dec_from_lt_dec.

  Definition lt_dec `{!TrivialApart A} `{forall x y, Decidable (x ≤ y)}
    : forall x y, Decidable (x < y).
  Proof.
  intros.
  destruct (decide_rel (<=) y x).
  - right;apply le_not_lt_flip;assumption.
  - left; apply not_le_lt_flip;assumption.
  Defined.
End full_pseudo_order.

Hint Extern 8 (Decidable (_ < _)) => eapply @lt_dec : typeclass_instances.
(*
The following instances would be tempting, but turn out to be a bad idea.

Hint Extern 10 (PropHolds (_ <> _)) => eapply @le_ne : typeclass_instances.
Hint Extern 10 (PropHolds (_ <> _)) => eapply @le_ne_flip : typeclass_instances.

It will then loop like:

semirings.lt_0_1 -> lt_ne_flip -> ...
*)

Section dec_strict_setoid_order.
  Context `{StrictOrder A} `{Apart A} `{!TrivialApart A} `{DecidablePaths A}.

  Instance: IsApart A := dec_strong_setoid.

  Context `{!Trichotomy (<)}.

  Instance dec_strict_pseudo_order: PseudoOrder (<).
  Proof.
  split; try apply _.
  - intros x y [??].
    destruct (lt_antisym x y); auto.
  - intros x y Exy z.
    destruct (trichotomy (<) x z) as [? | [Exz | Exz]];apply tr; try auto.
    right. rewrite <-Exz. assumption.
  - intros x y. transitivity (~ x = y);[split;apply trivial_apart|].
    split.
    + destruct (trichotomy (<) x y) as [?|[?|?]]; auto.
      intros E;contradiction E.
    + intros [?|?];[apply lt_ne|apply lt_ne_flip];trivial.
  Qed.
End dec_strict_setoid_order.

Section dec_partial_order.
  Context `{PartialOrder A} `{DecidablePaths A}.

  Definition dec_lt: Lt A := fun x y => x ≤ y /\ x <> y.

  Context `{Alt : Lt A} `{is_mere_relation A lt}
    (lt_correct : forall x y, x < y <-> x ≤ y /\ x <> y).

  Instance dec_order: StrictOrder (<).
  Proof.
  split.
  - apply _.
  - intros x E. apply lt_correct in E. destruct E as [_ []];trivial.
  - intros x y z E1 E2.
    apply lt_correct;
    apply lt_correct in E1;
    apply lt_correct in E2.
    destruct E1 as [E1a E1b],E2 as [E2a E2b].
    split.
    + transitivity y;trivial.
    + intros E3. destruct E2b.
      apply (antisymmetry (≤)); trivial.
      rewrite <-E3. assumption.
  Qed.

  Context `{Apart A} `{!TrivialApart A}.

  Instance: IsApart A := dec_strong_setoid.

  Instance dec_full_partial_order: FullPartialOrder (≤) (<).
  Proof.
  split;try apply _.
  intros. transitivity (x <= y /\ ~ x = y);[|
  split;intros [? ?];split;trivial;apply trivial_apart;trivial].
  apply lt_correct.
  Qed.

  Context `{!TotalRelation (≤)}.

  Instance: Trichotomy (<).
  Proof.
  intros x y.
  destruct (dec (x = y)); try auto.
  destruct (total (≤) x y);[left|right;right];
  apply lt_correct;auto.
  split;auto.
  intro E;apply symmetry in E;auto.
  Qed.

  Instance dec_pseudo_order: PseudoOrder (<) := dec_strict_pseudo_order.

  Instance dec_full_pseudo_order: FullPseudoOrder (≤) (<).
  Proof.
  split; try apply _.
  intros x y.
  split.
  - intros ? E. apply lt_correct in E;destruct E as [? []].
    apply (antisymmetry (≤));assumption.
  - intros E1.
    destruct (total (≤) x y); trivial.
    destruct (dec (x = y)) as [E2|E2].
    + rewrite E2. apply reflexivity.
    + destruct E1. apply lt_correct;split;auto.
      apply symmetric_neq;assumption.
  Qed.
End dec_partial_order.

Lemma lt_eq_trans `{Lt A} : forall x y z, x < y -> y = z -> x < z.
Proof.
intros ???? [];trivial.
Qed.