From mathcomp Require Import all_ssreflect.

Lemma exists_pred x :
  x > 0 ->
  exists y, x = S y.
Proof.
  case x => // n _. (* case: x と同じだが項が読みやすい*)
    by exists n.
Qed.
Print exists_pred.
(*
exists_pred =
  fun x : nat =>
    match x as n return (0 < n -> exists y : nat, n = y.+1) with
    | 0 =>
        fun H : 0 < 0 =>
        let H0 : False := eq_ind (0 < 0) (fun e : bool => if e then False else True) I true H in
        False_ind (exists y : nat, 0 = y.+1) H0
    | n.+1 =>
        fun=> ex_intro (fun y : nat => n.+1 = y.+1) n (erefl n.+1)
    end
       : forall x : nat, 0 < x -> exists y : nat, x = y.+1
*)

Require Extraction.
Extraction exists_pred.                     (* 何も抽出されない*)

Print sig.
(*
Inductive sig (A : Type) (P : A -> Prop) : Type :=
  exist : forall x : A, P x -> {x : A | P x}
*)

Definition safe_pred x :
  x > 0 -> {y | x = S y}.
Proof.
  case x => // n _.        (* exists_pred と同じ*)
    by exists n. (* こちらもexists を使う*)
Defined.         (* 定義を透明にし，計算に使えるようにする*)

Require Extraction.
Extraction safe_pred.
(*
let safe_pred = function
                | O   -> assert false (* absurd case *)
                | S n -> n
*)
(* 自己確認
let safe_pred = fun x ->
                  match x with
                  | O   -> assert false (* absurd case *)
                  | S n -> n
と同じことらしい。
*)

Section Sort.

  Variables (A : Set) (le : A -> A -> bool).    (* データ型A とのその順序le *)
  (* 既に整列されたリストl の中にa を挿入する*)

  Fixpoint insert a (l : list A) :=
    match l with
    | nil     => (a :: nil)
    | b :: l' => if le a b
                 then a :: l            (* a が l の先頭要素以下なら l の先頭にコンスする *)
                 else b :: insert a l'  (* a が l の先頭要素より大なら l の残りに関数を再帰的に適用した結果に l の先頭要素をコンスする *)
    end.
  (* 自己確認ここから *)
  (*
    insert は、第1引数 a を、第2引数のリスト l に挿入する。
    挿入する位置は、値が a 以上の要素の直前となる。
  *)
  (* 自己確認ここまで *)

  (* 繰り返しの挿入でリストl を整列する*)
  Fixpoint isort (l : list A) : list A :=
    match l with
    | nil     => nil
    | a :: l' => insert a (isort l')
    end.
  (* 自己確認ここから *)
  (*
    isort は、引数のリスト l が
    空リストなら、何もしない。
    空リストでないなら、l の先頭要素 a を l の残りのリスト l' を isort したリストに
    insert を使って挿入する。
    (insertion sort というものか？)
  *)
  (* 自己確認ここまで *)

  (* le は推移律と完全性をみたす*)
  Hypothesis le_trans : (* 推移律 *)
    forall x y z,
      le x y ->
      le y z ->
      le x z.
  Hypothesis le_total : (* 完全性 *)
    forall x y,
      ~~ le x y ->
      le y x.

  (* le_list x l : x はあるリストl の全ての要素以下である*)
  Inductive le_list x : list A -> Prop :=
  | le_nil  : le_list x nil
  | le_cons : forall y l,
                le x y ->
                le_list x l ->
                le_list x (y::l).
  (* 自己確認ここから *)
  Check le_list
        : A -> seq A -> Prop.
  Check le_nil
        : forall x : A,
            le_list x [::].
  Check le_cons
        : forall (x y : A) (l : seq A),
            le x y ->
            le_list x l ->
            le_list x (y :: l).
  (* 自己確認ここまで *)

  (* sorted l : リストl は整列されている*)
  Inductive sorted : list A -> Prop :=
  | sorted_nil  : sorted nil
  | sorted_cons : forall a l,
                    le_list a l ->
                    sorted l ->
                    sorted (a::l).
  (* 自己確認ここから *)
  Check sorted
        : seq A -> Prop.
  Check sorted_nil
        : sorted [::].
  Check sorted_cons
        : forall (a : A) (l : seq A),
            le_list a l ->
            sorted l ->
            sorted (a :: l).
  (* 自己確認ここまで *)

  Hint Constructors le_list sorted.         (* auto の候補にする*)

  Lemma le_list_insert a b l :
    le a b ->
    le_list a l ->
    le_list a (insert b l).
  (*
    要素 a が要素 b 以下であり、
    要素 a がリスト l の全要素以下であるなら、
    要素 a は、リスト l に要素 b を insert してできたリストの全要素以下である。
  *)
  Proof.
    move=> leab.
    (* 自己確認ここから *)
    (*
    Check le_list_ind
          : forall (x : A) (P : seq A -> Prop),
              P [::] -> (* 前提1 *)
              (forall (y : A) (l : seq A), le x y -> le_list x l -> P l -> P (y :: l)) -> (* 前提2 *)
              forall l : seq A, le_list x l -> P l. (* 結論 *)
    Check insert : A -> seq A -> seq A.
    Check insert b : seq A -> seq A.
    Check insert b l : seq A.
    Check le_list : A -> seq A -> Prop.
    Check le_list a : seq A -> Prop.
    Check le_list a (insert b l) : Prop.
    Check (fun l => le_list a (insert b l)) : seq A -> Prop.
    Check le_list_ind a (fun l => le_list a (insert b l))
          : le_list a (insert b [::]) -> (* これが、le_list_ind の前提1に該当 *) (* ★1 *)
            (forall (y : A) (l : seq A),
               le a y ->
               le_list a l ->
               le_list a (insert b l) ->
               le_list a (insert b (y :: l))) -> (* これば、le_list_ind の前提2に該当 *) (* ★2 *)
            forall l : seq A,
              le_list a l ->
              le_list a (insert b l). (* これが、le_list_ind の結論に該当 *)
    apply: (le_list_ind a (fun l => le_list a (insert b l))).
    以下のelimは、上記のapplyと同じ意味
    *)
    (* 自己確認ここまで *)
    elim.
    - (* le_list_ind に渡した (fun l => le_list a (insert b l)) に空リストが渡された場合 *)
      rewrite /=.
      info_auto.
      (*
        (* info auto: *)
        simple apply le_cons (in core).
         assumption.
         simple apply le_nil (in core).
      *)
    - (* le_list_ind に渡した (fun l => le_list a (insert b l)) に空リストでないリストが渡された場合 *)
      move=> {l}. (* 詳細不明だが、コンテキストから l を削除しているように見える。 *)
      move=> c l.
      rewrite /=. (* これにより、ゴールの insert の定義が展開される模様(第2引数のリストは明らかに空リストではないことがわかる)。 *)
      Check ifPn
            : forall (A : Type) (b : bool) (vT vF : A),
                if_spec b vT vF (~~ b) b (if b then vT else vF).
      case: ifPn.
      + info_auto.
        (*
          (* info auto: *)
          intro.
          intro.
          intro.
          intro.
          simple apply le_cons (in core).
           assumption.
           simple apply le_cons (in core).
            assumption.
            assumption.
        *)
      + info_auto.
        (*
          (* info auto: *)
          intro.
          intro.
          intro.
          intro.
          simple apply le_cons (in core).
           assumption.
           assumption.
        *)
    Restart.
    move=> leab; elim => {l} [|c l] /=. info_auto.
    case: ifPn. info_auto. info_auto.
  Qed.

  Lemma le_list_trans a b l :
    le a b ->
    le_list b l ->
    le_list a l.
  Proof.
    move=> leab; elim. info_auto.
    info_eauto using le_trans.              (* 推移律はeauto が必要*)
  Qed.

  Hint Resolve le_list_insert le_list_trans. (* 補題も候補に加える*)

  Theorem insert_ok a l :
    sorted l ->
    sorted (insert a l).
  Proof.
    (* 追加ここから *)
    Check sorted_ind
          : forall P : seq A -> Prop,
              P [::] ->
              (forall (a : A) (l : seq A),
                 le_list a l ->
                 sorted l ->
                 P l ->
                 P (a :: l)) ->
              forall l : seq A,
                sorted l ->
                P l.
    Check (fun l => sorted (insert a l)) : seq A -> Prop.
    Check sorted_ind (fun l => sorted (insert a l))
          : sorted (insert a [::]) -> (* ★1 *)
            (forall (a0 : A) (l : seq A),
               le_list a0 l ->
               sorted l ->
               sorted (insert a l) ->
               sorted (insert a (a0 :: l))) -> (* ★2 *)
            forall l : seq A,
              sorted l ->
              sorted (insert a l).
    elim.
    - (* ★1の場合 *)
      rewrite /=.
      by apply: sorted_cons.
    - (* ★2の場合 *)
      move=> a' l'.
      rewrite /=.
      case: ifPn.
      + (* le a a' が true の場合 *)
        info_eauto using le_trans.
      + (* le a a' が false の場合 *)
        info_eauto using le_trans.
    Restart.
    elim => /= {l} [| h l]. by apply: sorted_cons.
    case: ifPn. info_eauto using le_trans. info_eauto using le_trans.
    (* 追加ここまで *)
  Qed.

  Hint Resolve insert_ok.

  Theorem isort_ok l :
    sorted (isort l).
  Proof.
    (* 追加ここから *)
    elim: l => //= a l IH.
    by apply: insert_ok.
    Restart.
    elim: l => //= a l IH.
    info_auto.
    (*
      (* info auto: *)
      simple apply insert_ok (in core).
       assumption.
    *)
    (* 追加ここまで *)
  Qed.

  Hint Resolve isort_ok.

  (* Permutation l1 l2 : リストl2 はl1 の置換である*)
  Inductive Permutation : list A -> list A -> Prop :=
  | perm_nil   : Permutation nil nil
  | perm_skip  : forall x l l',
                   Permutation l l' ->
                   Permutation (x::l) (x::l')
  | perm_swap  : forall x y l,
                   Permutation (y::x::l) (x::y::l)
  | perm_trans : forall l l' l'',
                   Permutation l l' ->
                   Permutation l' l'' ->
                   Permutation l l''.

  Hint Constructors Permutation.

  Theorem Permutation_refl l :
    Permutation l l.
  Proof.
    (* 追加ここから *)
    elim: l => //= a l IH.
    by apply: perm_skip.
    Restart.
    elim: l => //= a l IH.
    info_auto.
    (*
      (* info auto: *)
      simple apply perm_skip (in core).
       assumption.
    *)
    (* 追加ここまで *)
  Qed.

  Hint Resolve Permutation_refl.

  Theorem insert_perm l a :
    Permutation (a :: l) (insert a l).
  Proof.
    (* 追加ここから *)
    elim: l => /=; first apply: Permutation_refl.
    move=> a' l' IH.
    case: ifPn => Haa'; first apply: Permutation_refl.
    apply: (perm_trans [:: a, a' & l'] [:: a', a & l'] (a' :: insert a l')); first apply: perm_swap.
    by apply/perm_skip/IH.
    Restart.
    elim: l => //= a' l' IH.
    case: ifPn => Haa'.
    - info_auto.
    - info_eauto using perm_trans.
    (*
      (* info eauto: *)
      simple eapply perm_trans.
       simple apply Permutation_refl.
       simple eapply perm_trans.
        simple apply Permutation_refl.
        simple eapply perm_trans.
         simple apply perm_swap.
         simple apply perm_skip.
          exact IH.
    *)
    (* 追加ここまで *)
  Qed.

  Hint Resolve insert_perm.

  Theorem isort_perm l :
    Permutation l (isort l).
  Proof.
    (* 追加ここから *)
    elim: l => //= a l IH.
    apply: (perm_trans (a :: l) (a :: isort l) (insert a (isort l))); last apply: insert_perm.
    by apply/perm_skip/IH.
    Restart.
    elim: l => //= a l IH.
    info_eauto using perm_trans.
    (*
      (* info eauto: *)
      simple eapply perm_trans.
       simple apply Permutation_refl.
       simple eapply perm_trans.
        simple apply Permutation_refl.
        simple eapply perm_trans.
         simple apply perm_skip.
          exact IH.
          simple apply insert_perm.
    *)
    (* 追加ここまで *)
  Qed.

  (* 証明付き整列関数*)
  Definition safe_isort l :
    {l'|sorted l' /\ Permutation l l'}.
  Proof.
    exists (isort l).
    auto using isort_ok, isort_perm.
  Defined.

  Print safe_isort.

End Sort.

Check safe_isort.           (* le と必要な補題を与えなければならない*)

Extraction leq.             (* mathcomp のeqType の抽出が汚ない*)

Definition leq' m n :=
  if m - n is 0
  then true
  else false.

Extraction leq'.                            (* こちらはすっきりする*)
(*
let leq' m n =
  match subn m n with
  | O   -> True
  | S _ -> False
*)

Lemma leq'E m n :
  leq' m n = (m <= n).
Proof.
  rewrite /leq' /leq.
  by case: (m-n).
Qed.

Lemma leq'_trans m n p :
  leq' m n ->
  leq' n p ->
  leq' m p.
Proof.
  rewrite !leq'E; apply leq_trans.
Qed.

Lemma leq'_total m n :
  ~~ leq' m n ->
  leq' n m.
Proof.
  (* 追加ここから *)
  rewrite !leq'E -ltnNge [n <= m]leq_eqVlt => Hnltm.
  by apply/orP; right.
  (* 追加ここまで *)
Qed.

Definition isort_leq :=
  safe_isort nat leq' leq'_trans leq'_total.

Eval compute in proj1_sig (isort_leq (3 :: 1 :: 2 :: 0 :: nil)).
(* = [:: 0; 1; 2; 3] : seq nat *)

Extraction "isort.ml" isort_leq.

Section Sort'.

  Variables (A : Set) (le : A -> A -> bool).    (* データ型A とのその順序le *)

  Inductive All (P : A -> Prop) : list A -> Prop :=
  | All_nil  : All P nil
  | All_cons : forall y l,
                 P y ->
                 All P l ->
                 All P (y::l).

  (*
  ``All (le a) l`` が ``le list a l`` と同じ意味になる．
  こちらを使うように証明を修正せよ．
   *)

  (* 追加ここから *)
  Check All_nil
        : forall P : A -> Prop,
            All P [::].

  Check All_cons
        : forall (P : A -> Prop) (y : A) (l : seq A),
            P y ->
            All P l ->
            All P (y :: l).

  Hint Constructors All.

  Check le : A -> A -> bool.
  Check insert : forall A : Set, (A -> A -> bool) -> A -> seq A -> seq A.

  Lemma le_list_insert' a b l :
    le a b ->
    All (le a) l ->
    All (le a) (insert A le b l).
  Proof.
    Check All_ind
          : forall (P : A -> Prop) (P0 : seq A -> Prop),
              P0 [::] ->
              (forall (y : A) (l : seq A),
                 P y -> All P l -> P0 l -> P0 (y :: l)) ->
              forall l : seq A,
                All P l -> P0 l.
    Check (fun x : A => le a x) : A -> bool.
    Check (fun l : seq A => All (fun x : A => le a x) (insert A le b l)) : seq A -> Prop.
    Check (All_ind (fun x : A => le a x) (fun l : seq A => All (fun x : A => le a x) (insert A le b l)))
          : All (fun x : A => le a x) (insert A le b [::]) -> (* ★1 *)
            (forall (y : A) (l : seq A),
               le a y ->
               All (fun x : A => le a x) l ->
               All (fun x : A => le a x) (insert A le b l) ->
               All (fun x : A => le a x) (insert A le b (y :: l))) -> (* ★2 *)
            forall l : seq A,
              All (fun x : A => le a x) l ->
              All (fun x : A => le a x) (insert A le b l).
    move=> Hab.
    elim => /=.
    - (* ★1 *)
      by apply: All_cons.
    -  (* ★1 *)
      move=> y l0.
      case: ifPn.
      + (* le b y = true *)
        move=> Hby Hay H0 H1.
        apply: All_cons; first done.
        by apply: All_cons.
      + (* le b y = false *)
        move=> Hby Hay H0 H1.
        by apply: All_cons.
    Restart.
    move=> Hab.
    elim => /=.
    - (* ★1 *)
      info_auto.
    -  (* ★1 *)
      move=> y l0.
      case: ifPn.
      + (* le b y = true *)
        info_auto.
      + (* le b y = false *)
        info_auto.
  Qed.

  (* le は推移律と完全性をみたす*)
  Hypothesis le_trans : (* 推移律 *)
    forall x y z,
      le x y ->
      le y z ->
      le x z.
  Hypothesis le_total : (* 完全性 *)
    forall x y,
      ~~ le x y ->
      le y x.

  Lemma le_list_trans' a b l :
    le a b ->
    All (le b) l ->
    All (le a) l.
  Proof.
    move=> Hab.
    elim => //=.
    move=> y l0 Hby H0 H1.
    apply: All_cons; last done.
    by apply: (le_trans a b y).
    Restart.
    move=> Hab.
    elim.
    - info_auto.
    - info_eauto using le_trans.
  Qed.

  Inductive sorted' : list A -> Prop :=
  | sorted'_nil  : sorted' nil
  | sorted'_cons : forall a l,
                     All (le a) l ->
                     sorted' l ->
                     sorted' (a::l).

  Hint Constructors sorted'.

  Hint Resolve le_list_insert' le_list_trans'.

  Theorem insert_ok' a l :
    sorted' l ->
    sorted' (insert A le a l).
  Proof.
    elim => /=.
    - (* ★1の場合 *)
      by apply: sorted'_cons.
    - (* ★2の場合 *)
      move=> a' l' H0 H1 H2.
      case: ifPn => Haa'.
      + (* le a a' が true の場合 *)
        apply: sorted'_cons.
        * (* All (le a) (a' :: l') の証明 *)
          apply: All_cons; first done.
          by apply: (le_list_trans' a a' l').
        * (* sorted' (a' :: l') の証明 *)
          by apply: sorted'_cons.
      + (* le a a' が false の場合 *)
        apply: sorted'_cons; last done.
        apply: (le_list_insert' a' a l'); last done.
        by apply: (le_total a a').
    Restart.
    elim => /=.
    - (* ★1の場合 *)
      info_auto.
    - (* ★2の場合 *)
      move=> a' l'.
      case: ifPn.
      + (* le a a' が true の場合 *)
        info_eauto using le_trans.
      + (* le a a' が false の場合 *)
        info_eauto using le_trans.
  Qed.

  Hint Resolve insert_ok'.

  Theorem isort_ok' l :
    sorted' (isort A le l).
  Proof.
    elim: l => //= a l IH.
    by apply: insert_ok'.
    Restart.
    elim: l => //= a l IH.
    info_auto.
  Qed.

  (* Permutation の定義に変更は必要ない模様 *)

  Hint Constructors Permutation.

  Theorem Permutation_refl' l :
    Permutation A l l.
  Proof.
    elim: l => /=; first apply: perm_nil.
    move=> a l IH.
    by apply: perm_skip.
    Restart.
    elim: l => /=.
    - (* l が空リストの場合 *)
      info_auto.
    - (* l が空リストでない場合 *)
      info_auto.
  Qed.

  Hint Resolve Permutation_refl'.

  Theorem insert_perm' l a :
    Permutation A (a :: l) (insert A le a l).
  Proof.
    elim: l => /=; first apply: Permutation_refl'.
    move=> a' l' IH.
    case: ifPn => Haa'; first apply: Permutation_refl'.
    apply: (perm_trans A [:: a, a' & l'] [:: a', a & l'] (a' :: insert A le a l')); first apply: perm_swap.
    by apply/perm_skip/IH.
    Restart.
    elim: l => /=.
    - (* l が空リストの場合 *)
      info_auto.
    - (* l が空リストでない場合 *)
      move=> a' l' IH.
      case: ifPn => Haa'.
      + (* le a a' の場合 *)
        info_auto.
      + (* ~~ le a a' の場合 *)
        info_eauto using perm_trans.
  Qed.

  Hint Resolve insert_perm'.

  Theorem isort_perm' l :
    Permutation A l (isort A le l).
  Proof.
    elim: l => /=; first apply: perm_nil.
    move=> a l IH.
    apply: (perm_trans A (a :: l) (a :: isort A le l) (insert A le a (isort A le l))); last apply: insert_perm.
    by apply/perm_skip/IH.
    Restart.
    elim: l.
    - (* l が空リストの場合 *)
      info_auto.
    - (* l が空リストでない場合 *)
      info_eauto using perm_trans.
  Qed.
  (* 追加ここまで *)

End Sort'.

(* Hintにするしないで証明が変わってくる。
   できるだけHintを増やして、なるべくautoを使って証明する。 *)

(* END *)


(* Examples.v *)

Require Import Maple.
Require Import Reals.
Open Scope R_scope.

Section MapleExamples.

Variable x y a b : R.

(**** Tactic Simplify ****)

Lemma simp0 : x <> 0 -> x / x = 1.
Proof.
  intros.
  simplify (x / x).
  reflexivity.
  assumption.
Qed.

Lemma simp1 : 1 + x <> 0 -> (1 + x) / (1 + x) * (1 + y) - (1 + y) >= 0.
Proof.
  intros.
  simplify ((1 + x) / (1 + x)).
  ring_simplify (1 * (1 + y) - (1 + y)).
  unfold Rge in |- *; right; reflexivity.
  assumption.
Qed.

Lemma simp2 :
 x <> 0 ->
 y <> 0 -> (x / y + y / x) * x * y - (x^2 + y^2) + 1 > 0.
Proof.
  intros.
  simplify ((x / y + y / x) * x * y - (x^2 + y^2) + 1).
  prove_sup0.
  split; assumption.
Qed.

Lemma simp3 : x + y <> 0 -> x / (x + y) + y / (x + y) = 1.
Proof.
  intros.
  simplify (x / (x + y) + y / (x + y)).
  reflexivity.
  assumption.
Qed.

(**** Tactic Factor ****)

Lemma fact0 : a^2 + 2*a*b + b^2 = (a+b)^2.
Proof.
  factor (a^2 + 2*a*b + b^2).
  reflexivity.
Qed.

Lemma fact1 : a^2 - 2*a*b + b^2 = (a-b)^2.
Proof.
  factor (a^2 - 2*a*b + b^2).
  reflexivity.
Qed.

Lemma fact2 : a^2 - b^2 = (a-b) * (a+b).
Proof.
  factor (a^2 - b^2).
  reflexivity.
Qed.

Lemma fact3 : a^3 + 3*a^2*b + 3*a*b^2 + b^3 = (a+b)^3.
Proof.
  factor (a^3 + 3*a^2*b + 3*a*b^2 + b^3).
  reflexivity.
Qed.

(**** Tactic Expand ****)

Lemma expd0 : (a+b)^2 = a^2 + 2*a*b + b^2.
Proof.
  expand ((a + b)^2).
  reflexivity.
Qed.

Lemma expd1 : (a-b)^2 = a^2 - 2*a*b + b^2.
Proof.
  expand ((a-b)^2).
  reflexivity.
Qed.

Lemma expd2 : (a-b) * (a+b) = a^2 - b^2.
Proof.
  expand ((a-b) * (a+b)).
  reflexivity.
Qed.

Lemma expd3 : (a+b)^3 = a^3 + 3*a^2*b + 3*a*b^2 + b^3.
Proof.
  expand ((a+b)^3).
  reflexivity.
Qed.

(**** Tactic Normal ****)

Lemma norm0 : x <> 0 -> y <> 0 -> x / y + y / x = (x^2 + y^2) * / y * / x.
Proof.
  intros.
  normal (x / y + y / x).
  reflexivity.
  split; assumption.
Qed.

Lemma norm1 :
 x <> 0 ->
 x + 1 <> 0 ->
 / x + x / (x + 1) = (x + 1 + x^2) * / x * / (x + 1).
Proof.
  intros.
  normal (/ x + x / (x + 1)).
  reflexivity.
  split; assumption.
Qed.

Lemma norm2 :
 x - y <> 0 ->
 x * (x / (x-y)^2) - y * (y / (x-y)^2) = (x + y) / (x - y).
Proof.
  intros H.
  normal (x * (x / (x-y)^2) - y * (y / (x-y)^2)).
  reflexivity.
  assumption.
Qed.

Lemma norm3 :
 x - y <> 0 ->
 x + y <> 0 ->
 x^2 - y^2 <> 0 ->
 x / (x - y) + y / (x + y) + 2 * y * (y / (x^2 - y^2)) =
 (x + y) / (x - y).
Proof.
  intros H H0 H1.
  normal (x / (x - y) + y / (x + y) + 2 * y * (y / (x^2 - y^2))).
  reflexivity.
  repeat split; assumption.
Qed.

(**** Eval <Maple Tactic> in ****)

Lemma eval_simp0 : x <> 0 -> y <> 0 -> x / x + y / y = 2.
Proof.
  intros.
  let t := eval simplify in (x / x + y / y) in
  replace (x / x + y / y)%R with t.
  reflexivity.
  cbn; field; auto.
Qed.

Lemma eval_fact0 : x <> 0 -> y <> 0 -> x / x + x / y = (x + y) / y.
Proof.
  intros.
  let t := eval factor in (x / x + x / y) in
  replace (x / x + x / y) with t.
  rewrite Rplus_comm; reflexivity.
  cbn; field; auto.
Qed.

Lemma eval_expd0 :
 (3 * x + 3) * (y - 5 / 3) = 3 * x * y + - (5 * x) + 3 * y + -5.
Proof.
  intros.
  let t := eval expand in ((3*x+3)*(y-5/3)) in
  replace ((3*x+3)*(y-5/3)) with t.
  reflexivity.
  cbn; field.
Qed.

Lemma eval_norm0 : x <> 0 -> y <> 0 -> y / (x * y) + y / x = (1 + y) / x.
Proof.
  intros.
  let t := eval normal in (y / (x * y) + y / x) in
  replace (y / (x * y) + y / x) with t.
  unfold Rdiv in |- *; reflexivity.
  cbn; field; auto.
Qed.

Definition def0 := Eval simplify in 1 / 1.

Definition def1 := Eval simplify in (x/y+y)*y.

Definition def2 := Eval factor in x*y+x.

Definition def3 := Eval factor in x*y-3*x+7*y-21.

Definition def4 := Eval expand in (x+y)*x.

Definition def5 := Eval expand in (x-7)*(y+4).

Definition def6 := Eval normal in /x+/y.

Definition def7 := Eval normal in x^2*y/(x+y)+y*x*y/(x+y).

End MapleExamples.


Require Import Bool Arith String List CpdtTactics.
Open Scope string_scope.

Definition var := string.

Inductive binop := Plus | Times | Minus.

Inductive aexp : Type :=
| Const : nat -> aexp
| Var : var -> aexp
| Binop : aexp -> binop -> aexp -> aexp.

Inductive bexp : Type :=
| Tt : bexp
| Ff : bexp
| Eq : aexp -> aexp -> bexp
| Lt : aexp -> aexp -> bexp
| And : bexp -> bexp -> bexp
| Or : bexp -> bexp -> bexp
| Not : bexp -> bexp.

Inductive com : Type :=
| Skip : com
| Assign : var -> aexp -> com
| Rand : var -> com
| Seq : com -> com -> com
| If : bexp -> com -> com -> com
| While : bexp -> com -> com.

Definition state := var -> nat.

Definition get (x:var) (s:state) : nat := s x.

Definition set (x:var) (n:nat) (s:state) : state :=
  fun y =>
    match string_dec x y with
        | left H => n
        | right H' => get y s
    end.

Definition eval_binop (b:binop) : nat -> nat -> nat :=
  match b with
    | Plus => plus
    | Times => mult
    | Minus => minus
  end.

Fixpoint eval_aexp (e:aexp) (s:state) : nat :=
  match e with
    | Const n => n
    | Var x => get x s
    | Binop e1 b e2 => (eval_binop b) (eval_aexp e1 s) (eval_aexp e2 s)
  end.

Fixpoint eval_bexp (b:bexp) (s:state) : bool :=
  match b with
    | Tt => true
    | Ff => false
    | Eq e1 e2 => Nat.eqb (eval_aexp e1 s) (eval_aexp e2 s)
    | Lt e1 e2 => Nat.ltb (eval_aexp e1 s) (eval_aexp e2 s)
    | And b1 b2 => eval_bexp b1 s && eval_bexp b2 s
    | Or b1 b2 => eval_bexp b1 s || eval_bexp b2 s
    | Not b => negb (eval_bexp b s)
  end.

(** thisis a partial function. data structure*)
Inductive eval_com : com -> state -> state -> Prop :=
| Eval_skip : forall s, eval_com Skip s s
| Eval_assign : forall s x e, eval_com (Assign x e) s (set x (eval_aexp e s) s)
| Eval_rand: forall s x n, eval_com (Rand x) s (set x n s)
| Eval_seq : forall c1 s0 s1 c2 s2,
               eval_com c1 s0 s1 -> eval_com c2 s1 s2 -> eval_com (Seq c1 c2) s0 s2
| Eval_if_true : forall b c1 c2 s s',
                   eval_bexp b s = true ->
                   eval_com c1 s s' -> eval_com (If b c1 c2) s s'
| Eval_if_false : forall b c1 c2 s s',
                   eval_bexp b s = false ->
                   eval_com c2 s s' -> eval_com (If b c1 c2) s s'
| Eval_while_false : forall b c s,
                       eval_bexp b s = false ->
                       eval_com (While b c) s s
| Eval_while_true : forall b c s1 s2 s3,
                      eval_bexp b s1 = true ->
                      eval_com c s1 s2 ->
                      eval_com (While b c) s2 s3 ->
                      eval_com (While b c) s1 s3.

(** Notation "âŸ¨ A , S âŸ© â‡“ T" := (eval_com A S T) (at level 100). *)

(* y := 1; x := 2; while 0 < x { y := y * 2; x := x - 1 } *)
Definition prog1 :=
  Seq (Assign "y" (Const 1))
  (Seq (Assign "x" (Const 2))
       (While (Lt (Const 0) (Var "x"))
              (Seq (Assign "y" (Binop (Var "y") Times (Const 2)))
                   (Assign "x" (Binop (Var "x") Minus (Const 1)))))).
Ltac myinv H:= inversion H; subst; simpl in *; clear H.

Theorem prog1_prop: forall s1 s2, eval_com prog1 s1 s2 -> get "x" s2 =0.
Proof.
unfold prog1; intros.
Ltac foo :=
match goal with
| [H: eval_com (Seq _ _) _ _ |- _] => myinv H
| [H: eval_com (Assign _ _) _ _ |- _] => myinv H
end.

Ltac bar :=
match goal with
| [H: eval_com (While _ _) _ _ |- _] => myinv H; try discriminate; repeat foo
end.
repeat foo.
bar.
bar. compute in H1. clear H1. myinv H7; simpl in *.
- compute . reflexivity.
- compute in H2. compute in H1. discriminate.
Qed.

Theorem seq_assoc :
  forall c1 c2 c3 s1 s2,
    eval_com (Seq (Seq c1 c2) c3) s1 s2 ->
    eval_com (Seq c1 (Seq c2 c3)) s1 s2.
Proof.
intros. repeat foo. apply Eval_seq with (s1:=s4).
- assumption.
- apply Eval_seq with (s1:=s3) ; assumption.

(**
Abhishek's proof
intros. repeat foo. eauto using Eval_seq.
*)
Qed.

Definition prog2 := While Tt Skip.

Lemma wtce: forall c s1 s2,
    eval_com c s1 s2 -> c = prog2 -> False.
Proof.
 intros c s1 s2 H. unfold prog2.
 induction H; repeat (intros; try discriminate).
- myinv H0. discriminate.
- myinv H2. apply IHeval_com2. reflexivity.
Qed.

Lemma while_true_cant_eval: forall s1 s2, ~ eval_com prog2 s1 s2.
Proof.
  unfold not, prog2. intros.
  apply (wtce _ s1 s2 H eq_refl).
Qed.

Ltac myinj H := injection H ; intros ; subst ; clear H.

Lemma while_true_imp_false : forall c s1 s2, eval_com c s1 s2 ->
                               forall b c', (forall s, eval_bexp b s = true) ->
                                             c = While b c' -> False.
Proof.
  intros c s1 s2 H. induction H; repeat (intros; try discriminate).
  - intros. myinv H1. congruence.
  - intros. apply IHeval_com2 with (b0:=b0)(c':=c'); assumption.

(** greg's proof
  Ltac foo' :=
  match goal with
    | [ H : ?x _ _ = ?x _ _ |- _ ] => myinj H
    | [ H : forall s, eval_bexp _ s = _,
        H' : eval_bexp _ ?s0 = _ |- _] =>
      specialize (H s0) ; congruence
    | [ H : forall b c, _ -> _ |- _ ] => eapply H ; eauto
  end.

  induction 1 ; intros ; try discriminate ; repeat foo'.
*)
Qed.

Lemma prog2_div : forall s1 s2, eval_com prog2 s1 s2 -> False.

  Lemma prog2_div' : forall c s1 s2, eval_com c s1 s2 -> c = prog2 -> False.
  Proof.
    unfold prog2 ; induction 1; crush.
  Qed.
  Show.
  intros. apply (prog2_div' _ _ _ H eq_refl).
Qed.

(** A simple chained tactic *)
Ltac myinv' H := inversion H ; subst ; clear H ; simpl in *.

(** This tactic applies when we have a hypothesis involving
   eval_com of either a Seq or an Assign.  It inverts the
   hypothesis, and performs substitution, simplifying things.
*)
Ltac eval_inv :=
  match goal with
    | [ H : eval_com (Seq _ _) _ _ |- _ ] => myinv H
    | [ H : eval_com (Assign _ _) _ _ |- _ ] => myinv H
  end.

(** This tactic inverts an eval_com of a While, producing
   two sub-goals.  It tries to eliminate one (or both) of the goals
   through discrimination on the hypotheses.
*)
Ltac eval_while_inv :=
  match goal with
    | [ H : eval_com (While _ _) _ _ |- _ ] => myinv H ; try discriminate
  end.

Theorem prog1_prop' : forall s1 s2, eval_com prog1 s1 s2 -> get "x" s2 = 0.
Proof.
  unfold prog1 ; intros.
  repeat ((repeat eval_inv) ; eval_while_inv).
  auto.
Qed.

Theorem seq_assoc' :
  forall c1 c2 c3 s1 s2,
    eval_com (Seq (Seq c1 c2) c3) s1 s2 ->
    eval_com (Seq c1 (Seq c2 c3)) s1 s2.
  Lemma seq_assoc'' :
    forall c s1 s2,
      eval_com c s1 s2 ->
      forall c1 c2 c3,
        c = Seq (Seq c1 c2) c3 ->
        eval_com (Seq c1 (Seq c2 c3)) s1 s2.
  Proof.
    (** Adds all of the eval_com constructors as hints for auto/crush *)
    Hint Constructors eval_com.
    induction 1 ; crush.
    inversion H ; clear H ; subst ;
    econstructor ; eauto.
  Qed.

  intros. eapply seq_assoc'' ; eauto.
Qed.

(** Returns true when the variable x occurs as a subexpression of a *)
Fixpoint contains (x:var) (a:aexp) : bool :=
  match a with
    | Const _ => false
    | Var y => if string_dec x y then true else false
    | Binop a1 _ a2 => contains x a1 || contains x a2
  end.

SearchAbout (or).
(** Changing a variable x that doesn't occur in a doesn't effect the
   value of a. *)
Lemma eval_exp_set :
  forall s x n a,
    contains x a = false ->
    eval_aexp a (set x n s) = eval_aexp a s.
Proof.
  induction a.
  - intros. simpl. reflexivity.
  - intros. simpl. myinv H. unfold set. unfold get. destruct (string_dec x v).
   + discriminate.
   + reflexivity.
  - intros. myinv H. SearchAbout (_ || _ = false).
    apply orb_false_elim in H1. destruct H1. apply IHa1 in H. rewrite H.
    apply IHa2 in H0. rewrite H0. reflexivity.

(** Greg'g Proof
destruct H1. eapply (or_introl ) in IHa1. destruct IHa1.
    + Print or_intror . apply (or_intror (contains x a1 = contains x a1)).
  induction a ; unfold set, get ; simpl ; unfold get ; crush.
  destruct (string_dec x v) ; crush.
  destruct (contains x a1) ; crush.
*)
Qed.

(**
Problem Set 3
In class we saw a relational small-step semantics for IMP.
Abhishek observed that the small-step semantics could be written
as a function instead, since there is no recursion in the 'while' case.
However, there is a loss of extensibility to some nondeterministic
 features like concurrency.) Are these semantics really equivalent?
Here is the relational semantics we saw in class:

*)

Inductive step_com : com -> state -> com -> state -> Prop :=
| Step_assign: forall s x e,
       step_com (Assign x e) s
                (Skip) (set x (eval_aexp e s) s)
| Step_rand: forall s x n, step_com (Rand x) s (Skip) (set x n s)
| Step_seqL: forall c1 c2 c1' s s', step_com c1 s c1' s' ->
                step_com (Seq c1 c2) s (Seq c1' c2) s'
| Step_seqR: forall c s, step_com (Seq Skip c) s c s
| Step_if_true: forall b c1 c2 s, eval_bexp b s = true ->
                 step_com (If b c1 c2) s c1 s
| Step_if_false: forall b c1 c2 s, eval_bexp b s = false ->
                 step_com (If b c1 c2) s c2 s
| Step_while: forall b c s,
                 step_com (While b c) s
                          (If b (Seq c (While b c)) Skip) s.

SearchAbout (Some ).
(** Problem1: Give a definition of the same small-step semantics,
 as a function.
*)

(*Fixpoint  step_com_fn  (c: com) (s: state) : option (com * state) :=
  match c with
    | Skip => None
    | Assign v a => Some (Skip, (set v (eval_aexp a s) s))
    | Seq c1 c2 => match (step_com_fn c1 s) with
                    | None => Some (c2, s) (** this is skip case*)
                    | Some (c3, s1) => Some ((Seq c3 c2), s1)
                   end
    | If b c1 c2  => match eval_bexp b s with
                        | true => Some (c1, s)
                        | false => Some (c2, s)
                       end
    | While b c1 => Some ((If b (Seq c1 (While b c1)) Skip), s)
   end.

(** Prove that only Skip fails to step: *)
Lemma progress : forall c s, step_com_fn c s = None -> c = Skip.
Proof.
  intro c.
  induction c.
(** ; intros; simpl in *; try( reflexivity); try (discriminate). *)
  - intros. reflexivity. (**skip case*)
  - intros. simpl in *. discriminate. (**Assign case*)
  (**Seq case*)
  - simpl in *. intros. destruct (step_com_fn c1 s) in H.
    + destruct p. discriminate.
    + discriminate.
  - simpl in *. intros. destruct (eval_bexp b s) in H; discriminate.
  - simpl in *. intros. remember ((eval_bexp b s)) as bb.
      destruct bb.
    + inversion H.
    + discriminate.
Qed.

Lemma ss {A:Type} : forall (a b:A), Some a= Some b -> a =b.
Proof using.
  intros. inversion H. reflexivity.
Qed.

(** Prove that all steps in the functional semantics work in the
   relational one.*)
Theorem forward_sim : forall c s c' s',
          step_com_fn c s = Some (c', s') -> step_com c s c' s'.
Proof.
 intro c. induction c.
 * intros. simpl in *. discriminate.
 * intros. simpl in *. myinv H. constructor.
 * intros. simpl in *. remember (step_com_fn c1 s) as ss.
   destruct ss.
  + destruct p. myinv H. constructor. apply IHc1.
    symmetry in Heqss. assumption.
  + inversion H. symmetry in Heqss.
    apply progress in Heqss. subst. constructor.
 * intros. simpl in H. remember (eval_bexp b s) as bb.
   destruct bb; myinv H; symmetry in Heqbb; constructor; apply Heqbb.
 * intros. simpl in H. Print step_com. remember (eval_bexp b s) as bb.
   destruct bb.
   + myinv H. symmetry in Heqbb. constructor.
   + myinv H. constructor.
Qed.

Theorem backward_sim : forall c s c' s',
  step_com c s c' s' -> step_com_fn c s = Some (c', s').
Proof.
intro c. induction c; intros; myinv H; try (reflexivity).
* remember (step_com_fn c1 s) as stf.
    destruct stf.
    - destruct p. apply IHc1 in H5.
      rewrite H5 in Heqstf. myinv Heqstf. reflexivity.
    - symmetry in Heqstf. apply progress in Heqstf.
      subst. myinv H5.
* rewrite H6; reflexivity.
* rewrite H6; reflexivity.
Qed.
**)
Require Import Coq.Logic.FunctionalExtensionality.

(** We can commute assignments x:=ax; y:=ay  as long as the
   variables don't overlap. *)
Lemma assign_comm :
  forall x ax y ay s1 s2,
    eval_com (Seq (Assign x ax) (Assign y ay)) s1 s2 ->
    contains x ay = false ->
    contains y ax = false ->
    x <> y ->
    forall s3, eval_com (Seq (Assign y ay) (Assign x ax)) s1 s3 -> s2 = s3.
(*
               forall z, get z s3 = get z s2.
*)
Proof.
  intros.
  repeat eval_inv.
  repeat unfold set, get.
  apply functional_extensionality. intro z.
  destruct (string_dec x z); destruct (string_dec y z); try congruence.
  (**
    Greg's proof
    specialize (eval_exp_set s1 y (eval_aexp ay s1) ax H1).
    unfold set. crush.
    specialize (eval_exp_set s1 x (eval_aexp ax s1) ay H0).
    unfold set. crush.
  *)
  - subst. pose proof (eval_exp_set s1 y (eval_aexp ay s1) ax H1).
    rewrite <- H.
    unfold set, get. reflexivity.
  - subst. pose proof (eval_exp_set s1 x (eval_aexp ax s1) ay H0).
    rewrite <- H. unfold set, get. reflexivity.
Qed.

Lemma assign_comm2 :
  forall x ax y ay s1 s2,
    eval_com (Seq (Assign x ax) (Assign y ay)) s1 s2 ->
    contains x ay = false ->
    contains y ax = false ->
    x <> y ->
    eval_com (Seq (Assign y ay) (Assign x ax)) s1 s2.
Proof.
  intros.
  remember (set x (eval_aexp ax (set y (eval_aexp ay s1) s1))
                (set y (eval_aexp ay s1) s1)) as s3.
  assert (eval_com (Seq (Assign y ay) (Assign x ax)) s1 s3).
  rewrite Heqs3.
  eauto.
  specialize (assign_comm x ax y ay s1 s2 H H0 H1 H2 _ H3).
  intro.
  assert (s3 = s2).
  Focus 2.
  rewrite <- H5.
  auto.
  symmetry in H4. apply H4.
  Qed.

Inductive steps_com : com -> state -> com -> state -> Prop :=
| Steps_none : forall c s, steps_com c s c s
| Steps_some : forall c s c' s' c'' s'', step_com c s c' s' ->
                steps_com c' s' c'' s'' -> steps_com c s c'' s''.

Hint Constructors steps_com step_com eval_com.
Lemma concat_seq : forall c1 c2 s1 s2 s3,
              steps_com c1 s1 Skip s2 ->
               steps_com c2 s2 Skip s3 ->
                steps_com (Seq c1 c2) s1 Skip s3.
Proof.
intros c1 c2 s1 s2 s3.
remember Skip as ss.
intros p. induction p; subst; eauto.
Qed.

Theorem big_to_small:
  forall c s s',
   eval_com c s s' -> steps_com c s Skip s'.
Proof.
intros c s s1 H.
induction H; eauto.
* eapply concat_seq; eauto.
* pose proof (concat_seq c (While b c) s1 s2 s3 IHeval_com1 IHeval_com2 ).
  apply (Steps_some (While b c) s1 (If b (Seq c (While b c)) Skip) s1 Skip s3); eauto.
  (** - auto. (** apply  Step_while.**)
  - eauto. pose proof (Step_if_true b (Seq c (While b c)) Skip s1 H). eauto. **)
Qed.

Lemma steps_com_skip: forall s1 s2, steps_com Skip s1 Skip s2 -> s1 = s2.
Proof.
intros.
myinv H.
- reflexivity.
- myinv H0.
Qed.

Theorem small_to_big:
  forall c s s',
   steps_com c s Skip s' -> eval_com c s s'.
Proof.
intros. remember Skip as ss. induction H;subst;auto.
  specialize (IHsteps_com (@eq_refl _ Skip)).
  revert dependent s''.
  induction H.
  - intros. inversion IHsteps_com; auto.
  - intros. inversion IHsteps_com; auto.
  - intros. rename s'' into f. myinv IHsteps_com. myinv H0.
    econstructor; [| apply H6].
    apply IHstep_com; eauto.
    apply  big_to_small. auto.
  - intros.
    pose proof (Eval_skip s). econstructor.
    + apply H.
    + apply IHsteps_com.
  - intros. auto.
  - intros. auto.
  - intros. myinv IHsteps_com; myinv H6; eauto.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (lf2 : natural) : natural :=
  Succ (plus lf3 lf2).


Fixpoint even (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => even n'
  end.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b eqn:E.
  - reflexivity.
  - reflexivity.  Qed.

Theorem even_S : forall n : nat,
  even (S n) = negb (even n).
Proof.
  intros n.
  induction n as [| n' IHn'].
  - simpl. reflexivity.
  - rewrite -> IHn'. simpl. rewrite -> negb_involutive. reflexivity.
Qed.


Require Import Relation_Definitions Setoid Omega.
Inductive mod_equiv : nat -> nat -> nat -> Prop :=
  | mod_intro_same : forall m n, mod_equiv m n n
  | mod_intro_plus_l : forall m n1 n2, mod_equiv m n1 n2 -> mod_equiv m (m + n1) n2
  | mod_intro_plus_r : forall m n1 n2, mod_equiv m n1 n2 -> mod_equiv m n1 (m + n2).

(* Analogous to the mathematical notation `x == y (mod z)` *)
Notation "x == y %% z" := (mod_equiv z x y) (at level 70).

Notation "'x==x'" := mod_intro_same.
Notation "'m+x==y'" := mod_intro_plus_l.
Notation "'x==m+y'" := mod_intro_plus_r.

Lemma silly : forall m n1 n2,  (m + n1) == n2 %% m -> n1 == n2 %% m.
Proof.
  intros. remember (m + n1) as n'. induction H;subst;try constructor.
  constructor. replace n1 with n0. auto. omega. apply IHmod_equiv. auto.
Qed.

Lemma mod_sym : forall m n1 n2, n1 == n2 %% m -> n2 == n1 %% m.
Proof.
  intros. induction H;simpl;constructor;auto. Qed.

Lemma mod_trans : forall m n1 n2 n3, n1 == n2 %% m -> n2 == n3 %% m -> n1 == n3 %% m.
Proof.
  intros. induction H. auto.
  constructor. apply IHmod_equiv. auto.
  apply silly in H0. apply IHmod_equiv. auto.
Qed.

Add Parametric Relation (m:nat) : nat (mod_equiv m)
  reflexivity proved by (mod_intro_same m)
  symmetry proved by (mod_sym m)
  transitivity proved by (mod_trans m) as mod_equiv_rel.

Lemma plus_one_side : forall m n1 n2 n', n1 == n2 %% m -> n' + n1 == n' + n2 %% m.
Proof.
  intros;induction H;try reflexivity;rewrite plus_assoc;rewrite (plus_comm n' m);
  rewrite <- plus_assoc;constructor;auto.
Qed.

Add Parametric Morphism (m: nat) : plus
  with signature (mod_equiv m) ==> (mod_equiv m) ==> (mod_equiv m) as plus_mor.
Proof.
  intros. induction H;try (apply plus_one_side;auto);
  try rewrite <- plus_assoc;constructor;apply IHmod_equiv;auto.
Qed.

Lemma mult_one_side : forall m n1 n2 n', n1 == n2 %% m -> n' * n1 == n' * n2 %% m.
Proof.
  assert (H' : forall m n1 n2 p, n1 == n2 %% m -> (p * m + n1) == n2 %% m).
  intros;induction p;auto;simpl. rewrite <- plus_assoc. constructor. auto.
  intros;induction H;try reflexivity. rewrite Nat.mul_add_distr_l.
  apply H'. auto. rewrite Nat.mul_add_distr_l. symmetry. apply H'. symmetry. auto.
Qed.

Add Parametric Morphism (m:nat) : mult
  with signature (mod_equiv m) ==> (mod_equiv m) ==> (mod_equiv m) as mult_mor.
Proof.
  assert (H' : forall m n1 n2 p, n1 == n2 %% m -> (p * m + n1) == n2 %% m).
  intros;induction p;auto;simpl. rewrite <- plus_assoc. constructor. auto.
  intros. induction H.
  - apply mult_one_side. auto.
  - rewrite Nat.mul_add_distr_r. rewrite mult_comm. apply H'. apply IHmod_equiv. auto.
  - symmetry. rewrite Nat.mul_add_distr_r. rewrite mult_comm. apply H'. symmetry.
    apply IHmod_equiv. auto.
Qed.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := nil : Lst | cons : Nat -> Lst -> Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Theorem theorem0 : forall (x : Lst) (y : Lst) (z : Nat), eq (append (append x y) (cons z nil)) (append x (append y (cons z nil))).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.


Require Import Reals.
Require Import Lra.
Require Import Rtopology.
Require Import Rminmax.
Require Import Ensembles.
Local Open Scope R_scope.

Ltac rabs_delta F Heqdelt :=
  unfold Rabs; destruct Rcase_abs;
  unfold Rabs in F; destruct Rcase_abs in F;
  unfold Rmin in Heqdelt; destruct Rle_dec in Heqdelt;
  try lra.

Theorem intersection_open_sets_is_open (A B : Ensemble R) :
  open_set A -> open_set B -> open_set (Intersection R A B).
Proof.
  intros H1 H2.
  unfold open_set in *.
  intros x G.
  destruct G as [x G1 G2]; unfold In in *.
  unfold included.
  specialize (H1 x G1); destruct H1 as [[delt1 delt1pos] H1].
  specialize (H2 x G2); destruct H2 as [[delt2 delt2pos] H2].
  unfold included, disc, included in H1; simpl in H1.
  unfold included, disc, included in H2; simpl in H2.
  remember (Rmin delt1 delt2) as delt; assert (deltpos : delt > 0).
  { rewrite Heqdelt.
    compute; destruct Rle_dec.
    - apply delt1pos.
    - apply delt2pos.
  }
  exists (mkposreal delt deltpos).
  unfold included, disc; intros x' F; simpl in F.

  apply Intersection_intro; unfold In.
  - apply H1; rabs_delta F Heqdelt.
  - apply H2; rabs_delta F Heqdelt.
Qed.


(* Coq' Art *)

(* A brief presentation of Coq *)

(* A sorting example :
   (C) Yves Bertot, Pierre Casteran
*)

Require Import List.
Require Import ZArith.
Open Scope Z_scope.

(* Sorted の公理 *)
Inductive sorted : list Z -> Prop :=
  | sorted0 : sorted nil
  | sorted1 : forall z:Z, sorted (z :: nil)
  | sorted2 :
      forall (z1 z2:Z) (l:list Z),
        z1 <= z2 -> sorted (z2 :: l) -> sorted (z1 :: z2 :: l).

Hint Resolve sorted0 sorted1 sorted2 : sort.

Lemma sort_2357 :
   sorted (2 :: 3 :: 5 :: 7 :: nil).
Proof.
  auto with sort zarith.
Qed.

(* Sortedの逆を証明する *)

Theorem sorted_inv :
  forall (z:Z) (l:list Z), sorted (z :: l) -> sorted l.
Proof.
  intros z l H.
  inversion H.                              (* sorted0とsorted1で分ける。 *)
  apply sorted0.                            (* auto with sort. *)
  apply H3.
Qed.

(* 出現回数を数える関数 *)
(* Number of occurrences of z in l *)

Fixpoint nb_occ (z:Z) (l:list Z) {struct l} : nat :=
  match l with
  | nil => 0%nat                            (* 0はZでなく、natであるとする。 *)
  | (z' :: l') =>
      match Z_eq_dec z z' with
      | left _ => S (nb_occ z l')
      | right _ => nb_occ z l'
      end
  end.

Eval compute in (nb_occ 3 (3 :: 7 :: 3 :: nil)). (* 2 *)
Eval compute in (nb_occ 36725 (3 :: 7 :: 3 :: nil)). (* 0 *)

(* ふたつのリストが、そのすべての要素の出現回数が同じであるとき、equivという。*)
(* list l' is a permutation of list l *)

Definition equiv (l l':list Z) :=
  forall z:Z, nb_occ z l = nb_occ z l'.

(* equiv is an equivalence ! *)
(* equiv についての定理を証明する。*)

Lemma equiv_refl : forall l:list Z, equiv l l.
Proof.
  unfold equiv.
  intros l z.                               (* trivial. *)
  reflexivity.
Qed.

Lemma equiv_sym : forall l l':list Z, equiv l l' -> equiv l' l.
Proof.
  unfold equiv.
  intros.                                   (* auto. *)
  rewrite H.
  reflexivity.
Qed.

Lemma equiv_trans :
  forall l l' l'' :
  list Z, equiv l l' -> equiv l' l'' -> equiv l l''.
Proof.
  intros l l' l'' H H0 z.
  eapply trans_eq.
  eauto.
  eauto.
Qed.

Lemma equiv_cons :
 forall (z:Z) (l l':list Z), equiv l l' -> equiv (z :: l) (z :: l').
Proof.
  intros z l l' H z'.
  simpl.
  case (Z_eq_dec z' z).
  intros e.                                 (* auto *)
  apply f_equal.
  apply H.

  intros.
  apply H.
Qed.

Lemma equiv_perm :
  forall (a b:Z) (l l':list Z),
    equiv l l' -> equiv (a :: b :: l) (b :: a :: l').
Proof.
  intros a b l l' H z.
  simpl.
  case (Z_eq_dec z a).

  intros.
  case (Z_eq_dec z b).
  intros.
  case (H z).
  auto.
  auto.

  intros.
  case (Z_eq_dec z b).
  intros.
  auto.

  auto.
Qed.

Hint Resolve equiv_cons equiv_refl equiv_perm : sort.

(* インサート関数 *)

(* insertion of z into l at the right place
   (assuming l is sorted)
*)

Fixpoint aux (z:Z) (l:list Z) {struct l} : list Z :=
  match l with
  | nil => z :: nil
  | cons a l' =>
      match Z_le_gt_dec z a with
      | left _ =>  z :: a :: l'
      | right _ => a :: (aux z l')
      end
  end.

Eval compute in (aux 4 (2 :: 5 :: nil)).    (* 2 :: 4 :: 5 :: nil *)
Eval compute in (aux 4 (24 :: 50 ::nil)).   (* 4 :: 24 :: 50 :: nil *)

(* the aux function seems to be a good tool for sorting ... *)

Lemma aux_equiv :
  forall (l:list Z) (x:Z), equiv (x :: l) (aux x l).
Proof.
  induction l as [ |a l H].                 (* as以降は省いてよい。 *)
  simpl.
  auto with sort.
  intros x.
  simpl.

  case (Z_le_gt_dec x a).
  simpl.
  auto with sort.

  intro.
  apply equiv_trans with (a :: x :: l).
  auto with sort.
  auto with sort.
Qed.

Lemma aux_sorted :
  forall (l:list Z) (x:Z), sorted l -> sorted (aux x l).
Proof.
  intros l x H.
  elim H; simpl.                            (* elim H. simpl. ではうまくいかない。 *)
  auto with sort.

  intro z.
  case (Z_le_gt_dec x z).
  simpl.
  auto with sort zarith.
  auto with sort zarith.

  intros z1 z2.
  case (Z_le_gt_dec x z2).

  intros.
  case (Z_le_gt_dec x z1).
  auto with sort zarith.
  auto with sort zarith.

  intros.
  case (Z_le_gt_dec x z1).
  auto with sort zarith.
  auto with sort zarith.
Qed.

(* the sorting function *)

Definition sort :
  forall l:list Z, {l' : list Z | equiv l l' /\ sorted l'}.

  induction l as [ | a l IHl].              (* as以降は省いてよい。 *)
  exists (nil (A := Z)).
  split.
  auto with sort.
  auto with sort.

  case IHl.
  intros l' [H0 H1].

  exists (aux a l').
  split.

  apply equiv_trans with (a :: l').
  auto with sort.
  apply aux_equiv.
  apply aux_sorted.
  auto.
Defined.

Eval compute in proj1_sig (sort (3::1::2::0::nil)).

Extraction "insert-sort" aux sort.

(* END *)


(** * Category **)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Generalizable All Variables.

Set Primitive Projections.
Set Universe Polymorphism.

Require Export COC.Base.Setoid.

Class IsCategory
      (obj: Type)
      (hom: obj -> obj -> Setoid)
      (comp: forall {X Y Z: obj}, hom X Y -> hom Y Z -> hom X Z)
      (id: forall (X: obj), hom X X) :=
  {
    cat_comp_proper:>
      forall (X Y Z: obj),
        Proper ((==) ==> (==) ==> (==)) (@comp X Y Z);

    cat_comp_assoc:
      forall X Y Z W (f: hom X Y)(g: hom Y Z)(h: hom Z W),
        comp f (comp g h) == comp (comp f g) h;

    cat_comp_id_dom:
      forall X Y (f: hom X Y),
        comp (id X) f == f;

    cat_comp_id_cod:
      forall X Y (f: hom X Y),
        comp f (id Y) == f
  }.
Hint Resolve cat_comp_assoc cat_comp_id_dom cat_comp_id_cod.

Structure Category :=
  {
    cat_obj:> Type;
    cat_hom:> cat_obj -> cat_obj -> Setoid;
    cat_comp:
      forall (X Y Z: cat_obj),
        cat_hom X Y -> cat_hom Y Z -> cat_hom X Z;
    cat_id: forall X: cat_obj, cat_hom X X;

    cat_prf:> IsCategory cat_comp cat_id
  }.
Existing Instance cat_prf.

Notation "[ 'Category' 'by' hom 'with' comp , id ]" :=
  (@Build_Category _ hom comp id _).
Notation "[ 'Category' 'by' hom 'with' 'comp' := comp 'with' 'id' := id ]" :=
  [Category by hom with comp , id].

Notation "g \o{ C } f" := (@cat_comp C _ _ _ f g) (at level 60, right associativity).
Notation "g \o f" := (g \o{_} f) (at level 60, right associativity) .
Notation "Id_{ C } X" := (@cat_id C X) (at level 20, no associativity).
Notation "'Id' X" := (Id_{_} X) (at level 30, right associativity).

Definition domain {C: Category}{X Y: C}(f: C X Y) := X.
Definition codomain {C: Category}{X Y: C}(f: C X Y) := Y.

Class Isomorphic (C: Category)(X Y: C)(f: C X Y)(g: C Y X) :=
  {
    isomorphic_iso: g \o f == Id X;
    isomorphic_inv: f \o g == Id Y
  }.

Definition isomorphic (C: Category)(X Y: C) :=
  exists (f: C X Y)(g: C Y X), Isomorphic f g.

Program Definition isomorphic_setoid (C: Category) :=
  [Setoid by isomorphic C on C].
Next Obligation.
  - intros X.
    exists (Id X), (Id X); split.
    + now rewrite cat_comp_id_dom.
    + now rewrite cat_comp_id_cod.
  - intros X Y [f [g [Heqfg Heqgf]]].
    now exists g, f.
  - intros X Y Z [f [f' [Heqf Heqf']]] [g [g' [Heqg Heqg']]].
    exists (g \o f), (f' \o g'); split.
    + rewrite cat_comp_assoc, <- (cat_comp_assoc f), Heqg.
      now rewrite cat_comp_id_cod, Heqf.
    + rewrite cat_comp_assoc, <- (cat_comp_assoc g'), Heqf'.
      now rewrite cat_comp_id_cod, Heqg'.
Qed.
Notation "X === Y 'in' C" := (X == Y in (isomorphic_setoid C)) (at level 70, no associativity, Y at next level).
Notation "X === Y" := (X === Y in _) (at level 70, no associativity).

(** Category of Type **)
Program Definition Types :=
  [Category by function
   with (fun X Y Z f g x => g (f x)),
        (fun X x => x)].
Next Obligation.
  intros f f' Heqf g g' Heqg x; simpl.
  now rewrite Heqf, Heqg.
Qed.
Canonical Structure Types.

(** Category of Setoid **)
Program Definition Setoids :=
  [Category by Map_setoid with Map_compose, Map_id].
Next Obligation.
  intros f f' Heqf g g' Heqg x; simpl.
  now rewrite (Heqf x), (Heqg (f' x)).
Qed.
Canonical Structure Setoids.

(** Discrete category **)
Program Definition Prop_setoid (P: Prop) :=
  [Setoid by (fun _ _ => True) on P].

Program Definition DiscreteCategory (X: Setoid): Category :=
  [Category by `(Prop_setoid (x == y)) with _,_].
Next Obligation.
  revert H H0.
  now apply transitivity.
Qed.

(** Dual category **)
Program Definition DualCategory (C: Category): Category :=
  [Category by (fun X Y => C Y X)
   with (fun X Y Z (f: C Y X)(g: C Z Y) => f \o g),
        (fun X => Id X)].
Next Obligation.
  - now intros f f' Heqf g g' Heqg; rewrite Heqf, Heqg.
  - now rewrite cat_comp_assoc.
  - now rewrite cat_comp_id_cod.
  - now rewrite cat_comp_id_dom.
Qed.
Notation "C ^op" := (DualCategory C) (at level 0, format "C ^op").


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

Require Import List Permutation.

Require Import list_perm list_in.
Require Import sublist.

Set Implicit Arguments.

Section list_power.

  Variable (X : Type).

  Implicit Type ll : list X.

  Fixpoint list_power ll :=
    match ll with
      | nil  => nil::nil
      | x::ll => map (cons x) (list_power ll) ++ list_power ll
    end.

  Fact list_power_spec ll m : In m (list_power ll) <-> m <sl ll.
  Proof.
    revert m; induction ll as [ | x l IHl ]; intros m; simpl; split.
    intros [ ? | [] ]; subst; apply sl_refl.
    intros H; apply sublist_nil_inv in H; subst; auto.

    intros H.
    apply in_app_or in H.
    rewrite in_map_iff in H.
    destruct H as [ (p & H1 & H2)  | H2 ];
       apply IHl in H2.
    subst; constructor 2; auto.
    constructor 3; auto.

    intros H.
    apply sublist_cons_inv_rt in H.
    destruct H as [ H2 | (p & H1 & H2) ];
      apply IHl in H2.
    apply in_or_app; right; auto.
    subst; apply in_or_app; left.
    apply in_map_iff; exists p; auto.
  Qed.

  Fact list_power_equiv ll l : incl l ll <-> exists m, In m (list_power ll) /\ eql l m.
  Proof.
    split.

    revert l; induction ll as [ | x ll ].

    intros [ | y l ] Hl.
    exists nil; simpl; repeat split; auto.
    exfalso; apply (Hl y); left; auto.

    intros l Hl.
    apply incl_cons_rinv in Hl.
    destruct Hl as (m1 & m2 & H1 & H2 & H3).
    apply IHll in H3.
    destruct H3 as (m3 & H3 & H4).

    destruct m1 as [ | a m1 ].

    exists m3; split.
    simpl; apply in_or_app; right; auto.
    simpl in H1.
    split; intros y Hy.
    apply H4, Permutation_in with (1 := H1); trivial.
    apply Permutation_in with (1 := Permutation_sym H1), H4; trivial.

    rewrite (H2 a) in H1.
    2: left; auto.
    exists (x::m3); split.
    simpl; apply in_or_app; left.
    apply in_map_iff.
    exists m3; auto.
    split.
    intros y Hy.
    apply Permutation_in with (1 := H1), in_app_or in Hy.
    destruct Hy as [ [ Hy | Hy ] | Hy ].
    subst; left; auto.
    left; symmetry; apply H2; right; auto.
    right; apply H4; auto.
    intros y [ Hy | Hy ].
    subst; apply Permutation_in with (1 := Permutation_sym H1).
    left; auto.
    apply Permutation_in with (1 := Permutation_sym H1).
    right; apply in_or_app; right; apply H4; auto.

    intros (m & H1 & H2 & H3).
    apply list_power_spec in H1.
    intros x Hx; apply H2 in Hx; revert Hx.
    apply sl_In; trivial.
  Qed.

End list_power.


(* Gabriel Braun February 2013 *)

Require Export GeoCoq.Tarski_dev.Annexes.quadrilaterals_inter_dec.

Section Vectors.

Context `{T2D:Tarski_2D}.
Context `{TE:@Tarski_euclidean Tn TnEQD}.

Lemma eqv_refl : forall A B, EqV A B A B.
Proof.
intros.
unfold EqV.
induction (eq_dec_points A B).
right.
split; auto.
left.
right.
apply plgf_trivial.
assumption.
Qed.

Lemma eqv_sym : forall A B C D, EqV A B C D -> EqV C D A B.
Proof.
intros.
unfold EqV in *.
induction H.
left.
apply plg_sym.
apply plg_comm2.
assumption.
right.
tauto.
Qed.

Lemma eqv_trans : forall A B C D E F, EqV A B C D -> EqV C D E F -> EqV A B E F.
Proof.
intros.
unfold EqV in *.

induction H; induction H0.
assert(Parallelogram A B F E \/ A = B /\ D = C /\ E = F /\ A = E).
apply (plg_pseudo_trans A B D C E F); auto.
apply plg_comm2.
assumption.
induction H1.
left.
auto.
right.
tauto.
spliter.
subst D.
subst F.
induction (eq_dec_points A B).
right.
tauto.
left.
induction H.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H3.
Col.
apply plgf_sym in H.
apply plgf_trivial_neq in H.
tauto.
spliter.
subst B.
subst D.
induction H0.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H.
Col.
apply plgf_trivial_neq in H.
right.
spliter.
subst F.
tauto.
right.
tauto.
Qed.

Lemma eqv_comm : forall A B C D, EqV A B C D -> EqV B A D C.
Proof.
intros.
unfold EqV in *.
induction H.
left.
apply plg_comm2.
assumption.
right.
spliter.
subst B.
subst D.
tauto.
Qed.

Lemma vector_construction : forall A B C, exists D, EqV A B C D.
Proof.
intros.
induction (eq_dec_points A B).
exists C.
right.
tauto.
assert(HH:= midpoint_existence B C).
ex_and HH M.
prolong A M D A M.
exists D.
left.
apply (mid_plg _ _ _ _ M).

induction(eq_dec_points A D).
subst D.
right.
intro.
subst C.
apply l7_3 in H0.
apply between_identity in H1.
subst M.
contradiction.
left.
assumption.
split; Cong.
assumption.
Qed.

Lemma vector_construction_uniqueness :
 forall A B C D D',
 EqV A B C D ->
 EqV A B C D' ->
 D = D'.
Proof.
intros.
unfold EqV in *.
induction H; induction H0.
apply plg_comm2 in H.
apply plg_comm2 in H0.
apply (plg_uniqueness B A C); auto.
spliter.
subst B.
subst D'.
induction H.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H.
Col.
apply (plgf_trivial_neq A D C ).
assumption.
spliter.
subst B.
subst D.
induction H0.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H.
Col.
apply plgf_comm2 in H.
apply (plgf_trivial_neq A C D').
assumption.
spliter.
subst C.
auto.
Qed.

Lemma null_vector : forall A B C, EqV A A B C -> B = C.
Proof.
intros.
unfold EqV in H.
induction H.
induction H.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H.
Col.
apply plgf_trivial_neq in H.
spliter.
subst C.
tauto.
tauto.
Qed.

Lemma vector_uniqueness : forall A B C, EqV A B A C -> B = C.
Proof.
intros.
unfold EqV in H.
induction H.
induction H.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H2.
Col.
apply plgf_permut in H.
apply plgf_sym in H.
apply (plgf_trivial_neq A B C ).
assumption.
spliter.
subst A.
auto.
Qed.

Lemma eqv_trivial : forall A B , EqV A A B B.
Proof.
intros.
unfold EqV.
right.
tauto.
Qed.

Lemma eqv_permut :
  forall A B C D,
  EqV A B C D ->
  EqV A C B D.
Proof.
intros.
induction (eq_dec_points A C).
subst C.
assert(B = D).
apply (vector_uniqueness A).
assumption.
subst D.
apply eqv_trivial.

unfold EqV in *.
induction H.
left.
apply plg_permut.
apply plg_comm2.
assumption.
left.
spliter.
subst B.
subst D.
apply plg_trivial.
assumption.
Qed.

Lemma eqv_par :
 forall A B C D,
  A <> B ->
  EqV A B C D ->
  Par A B C D.
Proof.
intros.
unfold EqV in H0.
induction H0.
unfold Parallelogram in H0.
induction H0.
unfold Parallelogram_strict in H0.
spliter.
apply par_right_comm.
assumption.
unfold Parallelogram_flat in H0.
spliter.
right.
spliter.
repeat split; Col.
intro.
subst D.
apply cong_identity in H2.
contradiction.
ColR.
ColR.

spliter.
contradiction.
Qed.

Lemma eqv_opp_null :
  forall A B,
  EqV A B B A ->
  A = B.
Proof.
intros.
unfold EqV in H.
induction H.
apply plg_irreflexive in H.
tauto.
tauto.
Qed.

Lemma eqv_sum :
  forall A B C A' B' C',
  EqV A B A' B' ->
  EqV B C B' C' ->
  EqV A C A' C'.
Proof.
intros.

unfold EqV in *.
induction H.
induction H0.
apply plg_comm2 in H.
apply plg_permut in H.
apply plg_permut in H0.
apply plg_sym in H0.
assert(HH:= plg_pseudo_trans A A' B' B C C' H H0).
induction HH.
left.
apply plg_permut.
apply plg_comm2.
assumption.
spliter.
right.
subst A'.
subst C'.
tauto.
spliter.
subst C.
subst C'.
left.
assumption.
spliter.
subst B.
subst B'.
assumption.
Qed.

Lemma null_sum :
 forall A B C,
  SumV A B B A C C.
Proof.
intros.
unfold SumV.
intros D H.
assert(A = D).
apply (vector_uniqueness B).
apply H.
subst D.
apply eqv_trivial.
Qed.

Lemma chasles :
 forall A B C,
  SumV A B B C A C.
Proof.
intros.
unfold SumV.
intros D H.
assert(C = D).
apply (vector_uniqueness B).
assumption.
subst D.
apply eqv_refl.
Qed.

Lemma eqv_mid :
 forall A B C,
  EqV A B B C ->
  Midpoint B A C.
Proof.
intros.
unfold EqV in H.
induction H.
apply plg_mid in H.
ex_and H M.
apply l7_3 in H0.
subst M.
assumption.
spliter.
subst C.
subst B.
apply l7_3_2.
Qed.

Lemma mid_eqv :
  forall A B C, Midpoint A B C ->
  EqV B A A C.
Proof.
intros.
unfold EqV.
induction(eq_dec_points A B).
subst B.
apply is_midpoint_id in H.
subst C.
right.
tauto.
left.

apply (mid_plg _ _ _ _ A).
left.
intro.
subst C.
apply l7_3 in H.
contradiction.
assumption.
Midpoint.
Qed.

Lemma sum_sym :
  forall A B C D E F,
  SumV A B C D E F ->
  SumV C D A B E F.
Proof.
intros.
unfold SumV in *.
assert(HH:=vector_construction C D B).
ex_and HH D'.

assert(HH:= (H D' H0)).
clear H.

assert(EqV C B D D').
apply eqv_permut.
assumption.

assert(EqV A D B D'0).
apply eqv_permut.
assumption.

induction (eq_dec_points A D'0).
subst D'0.

apply eqv_comm in H1.
assert(HP:= (eqv_mid B A D H1)).

unfold EqV in H0.
induction H0.
apply plg_mid in H0.
ex_and H0 M.
assert( A = M).
apply (l7_17 B D).
apply HP.
Midpoint.
subst M.

apply mid_eqv in H0.
apply (eqv_trans _ _ A D').
apply H0.
assumption.

spliter.
subst D.
subst D'.
apply (eqv_trans _ _ A B).
apply eqv_sym.
apply eqv_comm.
apply H1.
assumption.

induction H0; induction H1.
apply plg_mid in H0.
apply plg_mid in H1.
ex_and H0 M0.
ex_and H1 M1.

assert(M1 = M0).
apply (l7_17 B D).
apply H5.
Midpoint.
subst M1.
assert(Parallelogram A D' D'0 C).
apply (mid_plg _ _ _ _ M0).
left.
assumption.
assumption.
Midpoint.
assert(EqV C D'0 A D').
unfold EqV.
left.
apply plg_comm2.
apply plg_sym.
assumption.
apply (eqv_trans _ _ A D').
apply H7.
assumption.
spliter.
subst B.
subst D'0.
assert(EqV C D A D').
apply eqv_permut.
assumption.
apply (eqv_trans _ _ A D').
apply H1.
assumption.
spliter.
subst D.
subst D'.

assert(EqV A B C D'0).
apply eqv_permut.
assumption.
apply (eqv_trans _ _ A B).
apply eqv_sym.
apply H0.
assumption.
spliter.
subst D.
subst D'.
subst B.
subst D'0.
apply null_vector in HH.
subst F.
apply eqv_trivial.
Qed.

Lemma opposite_sum :
  forall A B C D E F,
  SumV A B C D E F ->
  SumV B A D C F E.
Proof.
intros.
unfold SumV in *.
intros D0 H0.
assert(HH:=vector_construction C D B).
ex_and HH D'.
assert(HH:= (H D' H1)).
clear H.

assert(EqV D' B A D0).
apply (eqv_trans _ _ D C).
apply eqv_sym.
apply eqv_comm.
apply H1.
assumption.
apply eqv_permut in H.
eapply (eqv_trans _ _ D' A).
apply eqv_sym.
apply H.
apply eqv_comm.
assumption.
Qed.

Lemma null_sum_eq :
  forall A B C D,
  SumV A B B C D D ->
  A = C.
Proof.
intros.
unfold SumV in H.
assert(HH:= vector_construction B C B).
ex_and HH D'.
assert(HH:= (H D' H0)).
assert(A = D').
apply (null_vector D).
apply eqv_sym.
apply HH.
subst D'.
apply vector_uniqueness in H0.
auto.
Qed.

Lemma is_to_ise :
  forall A B C D E F,
  SumV A B C D E F ->
  SumV_exists A B C D E F.
Proof.
intros.
unfold SumV in H.
unfold SumV_exists.
assert(HH:= (vector_construction C D B)).
ex_and HH D'.
assert(HH:=(H D' H0)).
exists D'.
split.

apply eqv_sym.
assumption.
assumption.
Qed.

Lemma ise_to_is :
 forall A B C D E F,
  SumV_exists A B C D E F ->
  SumV A B C D E F.
Proof.
intros.
ex_and H D'.
unfold SumV.
intros.
assert(D'= D'0).
apply (vector_construction_uniqueness C D B).
apply eqv_sym.
apply H.
assumption.
subst D'0.
assumption.
Qed.

Lemma sum_exists :
 forall A B C D, exists E, exists F, SumV A B C D E F.
intros.
assert(HH:= vector_construction C D B).
ex_and HH F.
exists A.
exists F.
unfold SumV.
intros.
assert(D' = F).
apply (vector_construction_uniqueness C D B); auto.
subst D'.
apply eqv_refl.
Qed.

Lemma sum_uniqueness :
 forall A B C D E F E' F',
 SumV A B C D E F ->
 SumV A B C D E' F' ->
 EqV E F E' F'.
Proof.
intros.
unfold SumV in *.
assert(HH:= vector_construction C D B).
ex_and HH D'.
assert(HH:= (H D' H1)).
assert(HP := (H0 D' H1)).
apply (eqv_trans _ _ A D').
apply eqv_sym.
auto.
auto.
Qed.

Lemma same_dir_refl : forall A B, Same_dir A B A B.
intros.
unfold Same_dir.
induction (eq_dec_points A B).
left.
tauto.
right.
exists B.
split.
apply out_trivial.
auto.
apply eqv_refl.
Qed.

Lemma same_dir_ts :
  forall A B C D,
  Same_dir A B C D ->
  exists M, Bet A M D /\ Bet B M C.
Proof.
intros.
induction H.
spliter.
subst B.
subst D.
exists A.
split; Between.

ex_and H D'.
induction H0.

assert(exists M : Tpoint, Midpoint M A D' /\ Midpoint M B C).
apply plg_mid.
assumption.
ex_and H1 M.
unfold Midpoint in *.
spliter.

induction H0.
assert(HH:=plgs_two_sides A B D' C H0).
spliter.

assert(B <> C).
intro.
subst C.
unfold TS in H6.
spliter.
Col.
assert(~ Col B C D').
intro.
unfold TS in H6.
spliter.
apply H9.
Col.

assert(OS B C D' D).
apply l6_6 in H.
apply (out_one_side_1 _ _ _ _ C); Col.

assert(TS B C A D).
apply l9_2.
apply (l9_8_2 _ _ D').
apply l9_2.
apply H6.
auto.

assert(~ Col A B C).
induction H10.
assumption.
induction H10.
spliter.
ex_and H13 T.

assert(OS A B D' C /\ OS D' C A B).
apply(plgs_one_side A B D' C).
assumption.
spliter.

assert(~Col A B C).
assumption.

assert(Par_strict A B D' C /\ Par_strict A C B D').

apply(plgs_par_strict A B D' C).
assumption.
spliter.

assert(A <> B).
intro.
subst B.
apply H18.
exists C.
split; Col.

assert(Par C D A B).
apply (par_col_par_2 _ D').
unfold Out in H.
spliter.
auto.
apply out_col in H.
Col.
apply par_symmetry.
apply par_right_comm.
left.
assumption.

assert(Par_strict A B C D).
apply par_strict_symmetry.
induction H21.
auto.
spliter.
apply False_ind.
apply H17.
Col.

induction(col_dec A B T).
apply False_ind.
assert(B = T).
apply (l6_21 A B C B); Col.
subst T.
apply H22.
exists D.
apply bet_col in H14.
split; Col.

induction(col_dec C D T).
apply False_ind.
assert(C = T).
apply (l6_21 C D B C); Col.
subst T.
apply H22.
exists A.
apply bet_col in H14.
split; Col.

induction H13.

assert(OS B A T D).
apply (out_one_side_1 _ _ _ _ A); Col.

unfold Out.
repeat split.
intro.
subst T.
apply H23.
Col.
intro.
subst D.
apply H22.
exists A.
split; Col.
left.
auto.

assert(OS B A T C).
apply (one_side_transitivity _ _ _ D).
apply H25.
apply (par_strict_one_side _ _ _ C).
apply par_strict_comm.
apply H22.
Col.

assert(TS B A T C).
unfold TS.
repeat split; Col.
exists B.
split; Col.
apply l9_9 in H26.
contradiction.
assumption.

induction H13.

assert(OS C D T A).
apply (out_one_side_1 _ _ _ _ D).
auto.
Col.
unfold Out.
repeat split.
intro.
subst T.
apply H24.
Col.
intro.
subst D.
apply H22.
exists A.
split; Col.
left.
Between.
assert(OS C D T B).
apply (one_side_transitivity _ _ _ A).
apply H25.
apply (par_strict_one_side _ _ _ B).
apply par_strict_symmetry.
apply H22.
Col.

assert(TS C D T B).
unfold TS.
repeat split.
unfold Out in H.
spliter.
auto.

intro.
apply H24.
Col.
intro.
apply H22.
exists B.
split; Col.
exists C.
split.
Col.
Between.
apply l9_9 in H27.
contradiction.
exists T.
split; Between.

assert(HH:= plgf_bet A B C D' H0).

induction (eq_dec_points A D').
subst D'.
unfold Parallelogram_flat in H0.
spliter.
assert(B = C \/ Midpoint A B C).
apply l7_20.
Col.
Cong.
induction H9.
subst C.
tauto.
exists A.
split.
Between.
apply midpoint_bet.
assumption.

induction (eq_dec_points B C).
subst C.
unfold Parallelogram_flat in H0.
spliter.
assert(A = D' \/ Midpoint B A D').
apply l7_20.
Col.
Cong.
induction H10.
subst D'.
tauto.
exists B.
split.
induction H10.
unfold Out in H.
spliter.
induction H13.
apply (between_inner_transitivity _ _ _ D').
apply H10.
auto.
apply (outer_transitivity_between _ _ D').
apply H10.
auto.
auto.
Between.

induction HH.
spliter.
exists A.
split.
Between.
apply (outer_transitivity_between _ _ D'); Between.

induction H7.
spliter.
exists A.
split.
Between.
apply between_symmetry.
apply (outer_transitivity_between _ _ D'); Between.

induction H7.
spliter.
exists C.
split.
induction H.
spliter.
induction H10.
assert(Bet C B D \/ Bet C D B).
apply (l5_3 _ _ _ D'); auto.
induction H11.
apply (outer_transitivity_between _ _ B); Between.
apply (between_inner_transitivity _ _ _ B).
apply H7.
auto.
apply (outer_transitivity_between _ _ B); Between.
apply (between_exchange4 _ _ D').
apply H8.
auto.
Between.
spliter.

exists B.
split.
unfold Out in H.
spliter.
induction H10.
assert(Bet B C D).
apply (between_inner_transitivity _ _ _ D').
apply H8.
assumption.
eBetween.

apply (outer_transitivity_between _ _ C).
apply H7.
apply (outer_transitivity_between _ _ D' ).
apply H8.
auto.
auto.
auto.
Between.
spliter.
subst B.
subst D'.
exists A.
split; Between.
Qed.

Lemma one_side_col_out :
 forall A B X Y,
  Col A X Y ->
  OS A B X Y ->
  Out A X Y.
Proof.
intros.
assert(A <> B /\ ~ Col X A B /\ ~ Col Y A B /\ X <> A /\ Y <> A).
unfold OS in H0.
ex_and H0 T.
unfold TS in *.
spliter.
repeat split; auto.
intro.
subst B.
Col.
intro.
subst X.
apply H0.
Col.
intro;
spliter.
subst Y.
apply H1.
Col.
spliter.

induction H.
repeat split; auto.
induction H.
repeat split; auto.
right.
Between.

assert(TS A B X Y).
unfold TS.
repeat split; auto.
exists A.
split.
Col.
Between.
apply l9_9 in H6.
contradiction.
Qed.

Lemma par_ts_same_dir :
 forall A B C D, Par_strict A B C D ->
 (exists M, Bet A M D /\ Bet B M C) ->
 Same_dir A B C D.
Proof.
intros.
ex_and H0 M.
unfold Same_dir.
right.

assert(HH:=vector_construction A B C).
ex_and HH D'.
exists D'.
split.
2: auto.

assert(A <> B /\ C <> D).
unfold Par in H.
unfold Par_strict in H.
tauto.
spliter.

assert(A <> M).
intro.
subst M.
apply False_ind.
apply H.
exists C.
apply bet_col in H1.
split; Col.

induction (eq_dec_points B D').
subst D'.
assert( A = C).
apply (vector_uniqueness B).
apply eqv_comm.
apply H2.
subst C.

assert(Bet A D B \/ Bet A B D).
apply (l5_1 _ M).
apply H5.
auto.
Between.
unfold Out.
repeat split; auto.
induction H2.

assert(Par A B D' C).
apply plg_par in H2; auto.
spliter.
auto.

assert(Col C D D').
apply col_permutation_1.
apply (parallel_uniqueness A B _ _ C _ C).
left.
apply H.
2: apply par_right_comm.
2: apply H7.
Col.
Col.

induction H2.

assert(HH := (plgs_two_sides A B D' C H2)).
spliter.

assert(TS B C A D).
unfold TS.
unfold TS in H10.
spliter.
repeat split;
auto.
intro.
apply H11.
ColR.
exists M.
split.
apply bet_col in H1.
Col.
auto.

assert(OS B C D D').
apply (l9_8_1 _ _ _ _ A).
apply l9_2.
apply H11.
apply l9_2.
auto.

apply (one_side_col_out _ B).
Col.
apply invert_one_side.
apply H12.

apply False_ind.
unfold Parallelogram_flat in H2.
spliter.
apply H.
exists C.
split; Col.

spliter.
subst D'.
subst B.
tauto.
Qed.

Lemma same_dir_out : forall A B C, Same_dir A B A C -> Out A B C \/ A = B /\ A = C.
intros.
unfold Same_dir in H.
induction H.
right.
auto.
ex_and H D'.
unfold EqV in H0.
induction H0.
induction H0.
apply plgs_par_strict in H0.
spliter.
apply False_ind.
apply H1.
exists B.
split; Col.
apply plgf_permut in H0.
apply plgf_sym in H0.
apply plgf_trivial_neq in H0.
spliter.
subst D'.
left.
apply l6_6.
assumption.
spliter.
subst D'.
subst B.
unfold Out in H.
tauto.
Qed.

Lemma same_dir_out1 : forall A B C, Same_dir A B B C -> Out A B C \/ A = B /\ A = C.
intros.
unfold Same_dir in H.
induction H.
right.
spliter.
subst B.
tauto.
ex_and H D'.
unfold EqV in H0.

induction H0.
induction H0.
apply plgs_par_strict in H0.
spliter.
apply False_ind.
apply H1.
exists B.
split; Col.
unfold Parallelogram_flat in H0.
spliter.
assert(A = D' \/ Midpoint B A D').
apply l7_20.
Col.
Cong.
induction H5.
subst D'.
tauto.
left.
unfold Midpoint in H5.
spliter.
unfold Out.
repeat split.
intro.
subst B.
apply cong_symmetry in H6.
apply cong_identity in H6.
induction H4; tauto.
intro.
subst C.
unfold Out in H.
spliter.
induction H8.
apply H.
apply (between_equality _ _ D');
Between.
apply H7.
apply (between_equality _ _ A);
Between.
induction H.
spliter.
induction H8.
left.
apply (between_inner_transitivity _ _ _ D').
apply H5.
apply H8.
left.
apply (outer_transitivity_between _ _  D').
apply H5.
auto.
auto.
spliter.
subst B.
subst D'.
unfold Out in H.
tauto.
Qed.

Lemma same_dir_null : forall A B C, Same_dir A A B C -> B = C.
intros.
unfold Same_dir in H.
induction H.
tauto.
ex_and H D.
apply null_vector in H0.
subst D.
unfold Out in H.
tauto.
Qed.

Lemma plgs_out_plgs :
 forall A B C D B' C',
 Parallelogram_strict A B C D ->
 Out A B B' ->
 Out D C C' ->
 Cong A B' D C' ->
 Parallelogram_strict A B' C' D.
Proof.
intros.
assert(OS A D C B /\ OS C B A D).
apply plgs_one_side.
apply plgs_permut.
apply plgs_comm2.
assumption.

assert( A <> B /\ A <> B' /\ D <> C /\ D <> C').
unfold Out in *.
spliter.
repeat split; auto.
spliter.

assert(Par_strict A B C D).
apply plgs_par_strict in H.
spliter.
auto.

assert(Par_strict A B' D C').
assert(Par A B' D C').
apply (par_col_par_2 _ B).
auto.
apply out_col.
auto.
apply par_symmetry.
apply (par_col_par_2 _ C).
auto.
apply out_col.
auto.
apply par_symmetry.
apply par_right_comm.
left.
auto.
induction H10.
auto.
spliter.
apply False_ind.
apply out_col in H0.
apply out_col in H1.

assert(~Col A C D).
intro.
apply H9.
exists A.
split; Col.
apply H14.
ColR.

assert(OS A D B B').
apply (out_one_side_1 A _ _ _ A).
intro.
apply H9.
exists D.
split; Col.
Col.
auto.

assert(OS A D C C').
apply (out_one_side_1 _ D _ _ D).
intro.
apply H9.
exists A.
split; Col.
Col.
auto.

assert(OS A D B' C').
apply (one_side_transitivity _ _ _ B).
apply one_side_symmetry.
apply H11.
apply (one_side_transitivity _ _ _ C).
apply one_side_symmetry.
apply H3.
assumption.

assert(HH:=par_cong_mid_os  A B' D C' H10 H2 H13).
ex_and HH M.

apply (mid_plgs _ _ _ _ M).
intro.
apply H10.
exists C'.
split; Col.
assumption.
assumption.
Qed.

Lemma plgs_plgs_bet :
 forall A B C D B' C',
 Parallelogram_strict A B C D ->
 Bet A B B' ->
 Parallelogram_strict A B' C' D ->
 Bet D C C'.
Proof.
intros.
assert(Col C' C D /\ Col D C D).
apply (parallel_uniqueness A B C D C' D D); Col.
left.
apply plgs_par_strict in H.
spliter.
assumption.
apply (par_col_par_2 _ B').
intro.
subst B.
apply plgs_par_strict in H.
spliter.
apply H.
exists C.
split; Col.
apply bet_col in H0.
Col.
apply plgs_par_strict in H1.
spliter.
left.
assumption.
spliter.
clear H3.
induction H2.
Between.
induction H2.
apply False_ind.

apply plgs_permut in H.
apply plgs_permut in H1.

assert(HH1:=plgs_one_side B C D A H).
assert(HH2:=plgs_one_side B' C' D A H1).
spliter.
assert(OS D A C C').
apply (one_side_transitivity _ _ _ B).
apply one_side_symmetry.
apply H6.
apply one_side_symmetry.
apply (one_side_transitivity _ _ _ B').
apply one_side_symmetry.
apply H4.
apply (out_one_side_1 _ _ _ _ A).
intro.
apply plgs_par_strict in H1.
spliter.
apply H1.
exists B'.
split; Col.
Col.
repeat split.
intro.
subst B'.
apply H1.
Col.
intro.
subst B.
apply H.
Col.
right.
assumption.
assert(TS D A C C').
repeat split.
intro.
apply plgs_par_strict in H.
spliter.
apply H.
exists C.
split; Col.
intro.
apply plgs_par_strict in H1.
spliter.
apply H1.
exists C'.
split; Col.
exists D.
split.
Col.
assumption.
apply l9_9 in H8.
contradiction.

assert(Parallelogram_strict B C D A).
apply plgs_permut.
assumption.
assert(Parallelogram_strict D A B' C').
apply plgs_permut.
apply plgs_sym.
assumption.

induction (eq_dec_points C C').
subst C'.
Between.

assert(HH:= plgs_pseudo_trans B C D A B' C' H3 H4).
assert(Parallelogram_strict B C C' B').
induction HH.
assumption.
unfold Parallelogram_flat in H6.
spliter.
apply False_ind.

apply plgs_par_strict in H.
apply plgs_par_strict in H1.
spliter.
apply H.
exists B.
split.
Col.
apply bet_col in H2.
ColR.

assert(HH1:=plgs_one_side B C C' B' H6).
assert(HH2:=plgs_one_side B C D A H3).
spliter.

(*******************************)

assert(TS B C A B').
unfold TS.
repeat split.
intro.
apply plgs_par_strict in H.
spliter.
apply H.
exists C.
split; Col.
intro.
apply plgs_par_strict in H6.
spliter.
apply H6.
exists B'.
split; Col.
exists B.
split.
Col.
assumption.

assert(OS B C C' D).
apply (out_one_side_1 _ _ _ _ C).
intro.
apply plgs_par_strict in H6.
spliter.
apply H6.
exists C'.
split; Col.
apply col_trivial_2.
repeat split.
auto.
intro.
subst D.
apply plgs_par_strict in H3.
spliter.
apply H3.
exists C.
split; Col.
left.
Between.

assert(OS B C A B').
apply (one_side_transitivity _ _ _ D).
apply one_side_symmetry.
apply H7.
apply (one_side_transitivity _ _ _ C').
apply one_side_symmetry.
apply H12.
assumption.
apply l9_9 in H11.
contradiction.
Qed.

Lemma plgf_plgf_bet :
 forall A B C D B' C',
 Parallelogram_flat A B C D ->
 Bet A B B' ->
 Parallelogram_flat A B' C' D ->
 Bet D C C'.
Proof.
intros.
induction (eq_dec_points A B).
subst B.
assert(C = D /\ A <> C).
apply plgf_trivial_neq.
auto.
spliter.
subst D.
Between.

assert(HH:=not_col_exists A B H2).
ex_and HH P.
assert(HH:=plg_existence A B P H2).
ex_and HH Q.

assert(Parallelogram_strict A B P Q).
induction H4.
assumption.
unfold Parallelogram_flat in H4.
spliter.
contradiction.

assert(Parallelogram_strict C D Q P).

apply(plgf_plgs_trans C D A B P Q).
intro.
subst D.
assert(A = B /\ C <> A).
apply plgf_trivial_neq.
apply plgf_sym.
assumption.
tauto.
apply plgf_sym.
assumption.
assumption.

assert(A <> B').
intro.
subst B'.
apply between_identity in H0.
contradiction.

assert(HH:=vector_construction A B' Q).
ex_and HH P'.

induction H8.
2 : tauto.

assert(B <> P).
intro.
subst P.
apply H3.
Col.

assert(B' <> P').
intro.
subst P'.

induction H8.
apply plgs_par_strict in H8.
spliter.
apply H10.
apply plgs_par_strict in H5.
exists A.
split; Col.
apply plgf_permut in H8.
assert(Q = A /\ B' <> Q).
apply plgf_trivial_neq.
auto.
spliter.
subst Q.
apply H5.
Col.

assert(Par A B' P Q).
apply plg_par in H8; auto.
spliter.
apply bet_col in H0.

apply (par_col_par_2 _ B); auto.
apply plg_par in H4; auto.
spliter.
assumption.

assert(Col P' P Q /\ Col Q P Q).
apply(parallel_uniqueness A B' P Q P' Q Q ); Col.
apply plg_par in H8; auto.
spliter.
auto.
spliter.
clear H13.

assert(Parallelogram_strict A B' P' Q).
induction H8.
auto.
unfold Parallelogram_flat in H8.
spliter.
apply False_ind.
unfold Parallelogram_flat in *.
spliter.
apply bet_col in H0.
assert(Col B' P' Q).
ColR.

apply plgs_par_strict in H5.
spliter.
apply H5.
exists Q.
split.
ColR.
Col.

assert(Parallelogram_strict D C' P' Q).
apply (plgf_plgs_trans _ _ B' A).
intro.
subst C'.
apply plgf_sym in H1.
apply plgf_trivial_neq in H1.
tauto.
apply plgf_comm2.
apply plgf_sym.
apply H1.
apply plgs_comm2.
assumption.

assert(Bet Q P P').
apply(plgs_plgs_bet A B P Q B' P'); auto.
apply(plgs_plgs_bet Q P C D P' C').
apply plgs_sym.
auto.
auto.
apply plgs_comm2.
apply plgs_sym.
auto.
Qed.

Lemma plg_plg_bet :
 forall A B C D B' C',
 Parallelogram A B C D ->
 Bet A B B' ->
 Parallelogram A B' C' D ->
 Bet D C C'.
Proof.
intros.

induction(eq_dec_points A B).
subst B.
induction H.
apply False_ind.
apply H.
apply plgs_sym in H.
apply False_ind.
apply H.
Col.
apply plgf_trivial_neq in H.
spliter.
subst D.
Between.

induction (eq_dec_points B C).
subst C.
induction H.
apply False_ind.
apply plgs_sym in H.
apply H.
Col.
apply plgf_permut in H.
apply plgf_trivial_neq in H.
spliter.
subst D.
induction H1.
apply False_ind.
apply H.
Col.
apply plgf_permut in H.
apply plgf_sym in H.
apply plgf_trivial_neq in H.
spliter.
subst C'.
Between.

assert(A <> B').
intro.
subst B'.
apply between_identity in H0.
contradiction.

assert(B' <> C').
intro.
subst C'.
apply plg_permut in H1.
induction H1.
apply plgs_par_strict in H1.
spliter.
apply H1.
exists A.
split; Col.
apply plgf_trivial_neq in H1.
spliter.
subst D.
apply plg_permut in H.
induction H.
apply plgs_par_strict in H.
spliter.
apply H1.
exists A.
split; Col.
apply plgf_sym in H.
apply plgf_trivial_neq in H.
tauto.

assert(HH:=H).
assert(HH1:=H1).

apply plg_par in H; auto.
apply plg_par in H1; auto.
spliter.

assert(Par A B C' D).
apply (par_col_par_2 _ B'); auto.
apply bet_col in H0.
Col.

assert(Col C' C D /\ Col D C D).

apply(parallel_uniqueness A B C D C' D D); Col.
spliter.
clear H10.

induction HH; induction HH1.
apply (plgs_plgs_bet A B _ _ B').
apply H10.
apply H0.
auto.

apply False_ind.
unfold Parallelogram_flat in H11.
spliter.
apply plgs_par_strict in H10.
spliter.
apply bet_col in H0.
apply H10.
assert(Col A B C').
ColR.
exists C'.
split; Col.

apply False_ind.
unfold Parallelogram_flat in H10.
spliter.
apply plgs_par_strict in H11.
spliter.
apply bet_col in H0.
apply H11.
assert(Col A B' C).
ColR.
exists C.
split; Col.

apply (plgf_plgf_bet A B _ _ B').
apply H10.
apply H0.
auto.
Qed.

Lemma plgf_out_plgf :
 forall A B C D B' C',
 Parallelogram_flat A B C D ->
 Out A B B' ->
 Out D C C' ->
 Cong A B' D C' ->
 Parallelogram_flat A B' C' D.
Proof.
intros.
assert( A <> B /\ A <> B' /\ D <> C /\ D <> C').
unfold Out in *.
spliter.
repeat split; auto.
spliter.

assert(HH:=not_col_exists A B H3).
ex_and HH P.
assert(HH:=plg_existence A B P H3).
ex_and HH Q.
assert(Parallelogram_strict A B P Q).
induction H8.
assumption.
unfold Parallelogram_flat in H8.
spliter.
contradiction.

assert(Parallelogram_strict C D Q P).

apply(plgf_plgs_trans C D A B P Q).
auto.
apply plgf_sym.
assumption.
assumption.

assert(HH:=vector_construction A B' Q).
ex_and HH P'.
induction H11.

assert(B <> P).
intro.
subst P.
apply plgs_par_strict in H9.
spliter.
apply H9.
exists B.
split; Col.

assert(B' <> P').
intro.
subst P'.
induction H11.
apply plgs_par_strict in H11.
spliter.
apply H11.
exists B'.
split; Col.
unfold Parallelogram_flat in H11.
spliter.
apply cong_identity in H15.
subst Q.
apply H9.
Col.

assert(Col Q P P').
apply plg_par in H8; auto.
apply plg_par in H11; auto.
spliter.

assert(Par A B' P Q).
apply (par_col_par_2 _ B).
auto.
apply out_col.
apply H0.
assumption.

assert(Col P' P Q /\ Col Q P Q).
apply(parallel_uniqueness A B' P Q P' Q Q); Col.
spliter.
Col.

assert(Parallelogram_strict A B' P' Q).
induction H11.
assumption.
unfold Parallelogram_flat in H11.
spliter.
apply False_ind.

apply plgs_par_strict in H9.
spliter.
apply H9.
exists Q.
split.

apply out_col in H0.
ColR.
Col.

assert(P <> Q).
intro.
subst Q.
apply H9.
Col.

assert(P' <> Q).
intro.
subst Q.
apply H15.
Col.

assert(Parallelogram_strict D C' P' Q).
apply (plgs_out_plgs _ C P).
apply plgs_comm2.
apply H10.
auto.
repeat split; auto.

unfold Out in H0.
spliter.
induction H19.
left.

apply (plgs_plgs_bet A B P Q B' P' H9); auto.
right.

apply(plgs_plgs_bet A B' P' Q B P); auto.

apply plg_cong in H11.
spliter.
eCong.

assert(Parallelogram A B' C' D).
apply (plgs_pseudo_trans _ _ P' Q).
apply H15.
apply plgs_sym.
assumption.
induction H19.
apply False_ind.
apply plgs_par_strict in H19.
spliter.
unfold Parallelogram_flat in H.
spliter.
apply out_col in H0.
apply out_col in H1.

apply H19.
exists B.
split.

Col.
assert(Col B C D).
ColR.
ColR.
assumption.
spliter.
subst B'.
tauto.
Qed.

Lemma plg_out_plg :
 forall A B C D B' C',
 Parallelogram A B C D ->
 Out A B B' ->
 Out D C C' ->
 Cong A B' D C' ->
 Parallelogram A B' C' D.
Proof.
intros.
induction H.
left.
apply (plgs_out_plgs _ B C).
apply H.
auto.
auto.
auto.
right.
apply (plgf_out_plgf _ B C).
apply H.
auto.
auto.
auto.
Qed.

Lemma same_dir_sym : forall A B C D, Same_dir A B C D -> Same_dir C D A B.
intros.

induction (eq_dec_points A B).
subst B.
apply same_dir_null in H.
subst D.
left.
tauto.

unfold Same_dir in *.
induction H.
left.
tauto.

ex_and H D'.
right.
assert(HH:=vector_construction C D A).
ex_and HH B'.
exists B'.
split.
unfold EqV in H1.
unfold EqV in H2.
unfold Out in *.
spliter.
induction H1; induction H2.

repeat split.
auto.
intro.
subst B'.
induction H2.
apply H2.
Col.
apply plgf_sym in H2.
apply plgf_trivial_neq in H2.
spliter.
auto.

induction H4.
right.
apply (plg_plg_bet C D _ _ D').
apply H2.
apply H4.
apply plg_sym.
apply plg_comm2.
assumption.

left.
apply (plg_plg_bet C D' _ _ D).
apply plg_sym.
apply plg_comm2.
apply H1.
apply H4.
assumption.

spliter.
subst D.
tauto.
spliter.
subst B.
tauto.
spliter.
subst D.
tauto.
assumption.
Qed.

Lemma same_dir_trans : forall A B C D E F, Same_dir A B C D -> Same_dir C D E F -> Same_dir A B E F.
intros.
unfold Same_dir in *.
induction H; induction H0; spliter.
left.
tauto.
ex_and H0 F'.
subst B.
subst D.
apply null_vector in H2.
subst F'.
unfold Out in H0.
tauto.
ex_and H D'.
subst D.
subst F.
unfold Out in H.
tauto.
ex_and H D'.
ex_and H0 F'.
right.

induction(eq_dec_points A B).
subst B.
apply null_vector in H1.
subst D'.
unfold Out in H.
tauto.

assert(HH:=vector_construction A B E).
ex_and HH F''.
exists F''.
split.

2: auto.
assert(C <> D /\ C <> D' /\ E <> F /\ E <> F').
unfold Out in *.
spliter.
repeat split;
auto.
spliter.

unfold EqV in *.
induction H1; induction H2; induction H4.
unfold Out in *.
spliter.
induction H10; induction H12.
repeat split.
auto.
intro.
subst F''.

induction H4.
apply H4.
Col.
apply plgf_sym in H4.
apply plgf_trivial_neq in H4.
tauto.

left.
assert(Bet E F' F'').

apply (plg_plg_bet C D _ _ D').
apply H2.
apply H12.

assert(Parallelogram C D' F'' E \/ C = D' /\ B = A /\ E = F'' /\ C = E).

apply(plg_pseudo_trans C D' B A E F'').
apply plg_sym.
apply plg_comm2.
auto.
apply plg_comm2.
auto.
induction H13.
2:tauto.
assumption.
apply (between_exchange4 _ _ F').
apply H10.
auto.

repeat split.
auto.
intro.
subst F''.
induction H4.
apply H4.
Col.
apply plgf_sym in H4.
apply plgf_trivial_neq in H4.
tauto.

assert(Bet E F'' F').
apply (plg_plg_bet C D' _ _ D).
3: apply H2.
2:apply H12.

assert(Parallelogram C D' F'' E \/ C = D' /\ B = A /\ E = F'' /\ C = E).
apply plg_pseudo_trans.
apply plg_sym.
apply plg_comm2.
auto.
apply plg_comm2.
auto.

induction H13.
assumption.
tauto.
apply (l5_3 _ _ _ F').
apply H10.
assumption.

repeat split.
auto.
intro.
subst F''.
induction H4.
apply H4.
Col.
apply plgf_sym in H4.
apply plgf_trivial_neq in H4.
tauto.

assert(Bet E F' F'').
apply (plg_plg_bet C D _ _ D').
apply H2.
apply H12.
assert(Parallelogram C D' F'' E \/ C = D' /\ B = A /\ E = F'' /\ C = E).
apply plg_pseudo_trans.
apply plg_sym.
apply plg_comm2.
auto.
apply plg_comm2.
auto.

induction H13.
assumption.
tauto.
apply (l5_1 _ F').
apply H8.
auto.
auto.

repeat split.
auto.
intro.
subst F''.
induction H4.
apply H4.
Col.
apply plgf_sym in H4.
apply plgf_trivial_neq in H4.
tauto.

assert(Bet E F'' F').
apply (plg_plg_bet C D' _ _ D).
3: apply H2.
2: apply H12.

assert(Parallelogram C D' F'' E \/ C = D' /\ B = A /\ E = F'' /\ C = E).
apply plg_pseudo_trans.
apply plg_sym.
apply plg_comm2.
auto.
apply plg_comm2.
auto.

induction H13.
auto.
tauto.
right.
apply (between_exchange4 _ _ F').
apply H13.
auto.
tauto.
tauto.
tauto.
tauto.
tauto.
tauto.
tauto.
Qed.

Lemma same_dir_comm : forall A B C D, Same_dir A B C D -> Same_dir B A D C.
intros.

unfold Same_dir in *.
induction H.
left.
auto.
spliter.
split; auto.

right.
ex_and H D'.
assert(A <> B).
intro.
subst B.
apply null_vector in H0.
unfold Out in H.
spliter.
auto.

assert(HH:=vector_construction B A D).
ex_and HH C'.
exists C'.
split.
2: auto.

unfold Out in *.
spliter.

unfold EqV in *.

induction H4.
repeat split.
auto.
intro.
subst C'.
apply eqv_sym in H2.
apply null_vector in H2.
subst B.
tauto.
left.

induction H0; induction H2;try tauto.

assert(Parallelogram C D' D C' \/ C = D' /\ B = A /\ C' = D /\ C = C').

apply(plg_pseudo_trans C D' B A C' D).
apply plg_sym.
apply plg_comm2.
assumption.
assumption.
induction H5.

assert(Parallelogram_flat C D' D C').
induction H5.
apply False_ind.
apply plgs_par_strict in H5.
spliter.
apply H5.
exists D.
apply bet_col in H4.
split; Col.
assumption.

unfold Parallelogram_flat in H6.
spliter.

apply (col_cong2_bet1 D').
2:Between.
Col.
Cong.
Cong.
spliter.
subst B.
tauto.
spliter.
subst B.
tauto.

repeat split.
auto.
intro.
subst C'.
induction H2.
induction H2.
apply H2.
Col.
apply plgf_sym in H2.
apply plgf_trivial_neq in H2.
spliter.
auto.
spliter.
auto.

induction H0; induction H2;try tauto.

induction(eq_dec_points C C').
subst C'.
left.
Between.

assert(Parallelogram C D' D C' \/ C = D' /\ B = A /\ C' = D /\ C = C').

apply(plg_pseudo_trans C D' B A C' D).
apply plg_sym.
apply plg_comm2.
assumption.
assumption.
induction H6.

assert(Parallelogram_flat C D' D C').
induction H6.
apply False_ind.
apply plgs_par_strict in H6.
spliter.
apply H6.
exists D.
apply bet_col in H4.
split; Col.
assumption.

right.

assert(HH:= H7).
unfold Parallelogram_flat in H7.
spliter.

apply plgf_bet in HH.
induction HH.
spliter.

apply False_ind.

apply H3.
apply (between_equality _ _ D).
apply between_symmetry.
apply H13.
assumption.
induction H12.
spliter.

assert(D = D').
apply (between_equality _ _ C).
Between.
Between.
subst D'.

apply cong_identity in H10.
contradiction.

induction H12.
spliter.
eBetween.

spliter.
eBetween.
spliter.
subst B.
tauto.
spliter.
subst B.
tauto.
Qed.

Lemma bet_same_dir1 : forall A B C, A <> B -> B <> C -> Bet A B C -> Same_dir A B A C.
intros.
unfold Same_dir.
right.
exists B.
split.
unfold Out.
repeat split.
intro.
subst C.
apply between_identity in H1.
tauto.
auto.
right.
assumption.
apply eqv_refl.
Qed.

Lemma bet_same_dir2 : forall A B C, A <> B -> B <> C -> Bet A B C -> Same_dir A B B C.
intros.
unfold Same_dir.
right.
assert(HH:=vector_construction A B B).
ex_and HH C'.
exists C'.
split.
2: auto.
unfold EqV in H2.
induction H2.
2:tauto.

induction H2.
apply plgs_par_strict in H2.
spliter.
apply False_ind.
apply H3.
exists B.
split; Col.
assert(HH:= H2).
unfold Parallelogram_flat in HH.
apply plgf_bet in H2.
spliter.

unfold Out.
repeat split.
auto.
intro.
subst C'.
apply cong_identity in H5.
contradiction.

induction H2.

assert(Bet B A B).
spliter.
apply (outer_transitivity_between2 _ C').
Between.
auto.
induction H7.
auto.
tauto.
apply between_identity in H8.
subst B.
tauto.
induction H2.

assert(Bet B A B).
spliter.
apply (outer_transitivity_between _ _ C').
apply H2.
auto.
induction H7.
auto.
tauto.
apply between_identity in H8.
subst B.
tauto.

induction H2.

assert( A = C' \/ Midpoint B A C').
apply l7_20.
Col.
Cong.
induction H8.
induction H7.
tauto.
tauto.
unfold Midpoint in H8.
spliter.
apply (l5_2 A); auto.

assert( A = C' \/ Midpoint B A C').
apply l7_20.
Col.
Cong.
induction H8.
induction H7.
tauto.
tauto.
unfold Midpoint in H8.
spliter.
apply (l5_2 A); auto.
Qed.

Lemma plg_opp_dir : forall A B C D, Parallelogram A B C D -> Same_dir A B D C.
intros.

induction(eq_dec_points A B).
subst B.
induction H.
apply False_ind.
apply plgs_sym in H.
apply H.
Col.
apply plgf_trivial_neq in H.
spliter.
subst D.
left.
tauto.

unfold Same_dir.
right.
exists C.
split.
apply out_trivial.
intro.
subst D.
induction H.
apply H.
Col.
apply plgf_sym in H.
apply plgf_trivial_neq in H.
tauto.
unfold EqV.
left.
assumption.
Qed.

Lemma same_dir_dec : forall A B C D,
  Same_dir A B C D \/ ~ Same_dir A B C D.
Proof.
intros.
unfold Same_dir.
unfold EqV.
elim (eq_dec_points A B); intro HAB;
elim (eq_dec_points C D); intro HCD; try tauto.

  right; intro HFalse.
  elim HFalse; clear HFalse; intro HFalse.

    spliter; intuition.

    destruct HFalse as [E [HFalse HElim]].
    elim HElim; clear HElim; intro HElim.

      subst.
      apply plg_cong in HElim.
      destruct HElim as [HCong1 HCong2].
      treat_equalities.
      apply out_diff2 in HFalse; intuition.

      destruct HElim as [Hclear HCE]; clear Hclear; subst.
      apply out_diff2 in HFalse; intuition.

  right; intro HFalse.

  elim HFalse; clear HFalse; intro HFalse.

    spliter; intuition.

    destruct HFalse as [E [HFalse Hclear]]; clear Hclear.
    subst.
    apply out_diff1 in HFalse; intuition.

  assert (H := plg_existence B A C).
  assert (HPar : B <> A) by finish.
  apply H in HPar; clear H.
  destruct HPar as [E HPar].
  elim (out_dec C D E); intro Hout.

    left.
    right.
    exists E.
    split; try assumption.
    left.
    apply plg_comm2 in HPar.
    assumption.

    right.
    intro H.
    elim H; clear H; intro H.

      spliter; subst; intuition.

      destruct H as [F [Hout' HElim]].
      elim HElim; clear HElim; intro HElim.

        apply plg_comm2 in HElim.
        assert (HEF := plg_uniqueness B A C E F HPar HElim).
        subst; intuition.

        spliter; intuition.
Qed.

Lemma same_or_opp_dir : forall A B C D, Par A B C D -> Same_dir A B C D \/ Opp_dir A B C D.
intros.
induction (same_dir_dec A B C D).
left.
assumption.
right.
unfold Opp_dir.

unfold Same_dir.
right.
assert(HH:= vector_construction A B D).
ex_and HH C'.
exists C'.
split.
2:auto.
unfold EqV in H1.

induction (eq_dec_points B C').
subst C'.
induction H1.

induction H1.
apply False_ind.
apply plgs_permut in H1.
apply plgs_sym in H1.
apply H1.
Col.
apply plgf_permut in H1.
apply plgf_trivial_neq in H1.
spliter.
subst D.
induction H.
apply False_ind.
apply H.
exists A.
split; Col.
spliter.
induction H4.
unfold Out.
repeat split; auto.
left.
Between.
induction H4.
unfold Out.
repeat split; auto.
apply False_ind.
apply H0.
apply same_dir_sym.
apply bet_same_dir2; auto.
unfold Out.
repeat split.
auto.
auto.
right.
assumption.
spliter.
subst A.
subst D.
apply par_distinct in H.
tauto.

induction H1.

assert(Col C' C D /\ Col D C D).
apply plg_par in H1.
spliter.

apply(parallel_uniqueness A B C D C' D D); Col.
apply par_distinct in H.
tauto.
assumption.
spliter.
clear H4.

unfold Out.
repeat split.
apply par_distinct in H.
tauto.
intro.
subst C'.
induction H1.
apply H1.
Col.
apply plgf_sym in H1.
apply plgf_trivial_neq in H1.
spliter.
apply par_distinct in H.
tauto.

induction H3.
left.
Between.
induction H3.
apply False_ind.

assert(Same_dir A B D C').
apply plg_opp_dir.
assumption.

assert(Same_dir C D D C').
apply bet_same_dir2.
apply par_distinct in H.
spliter.
auto.
intro.
subst C'.
induction H1.
apply H1.
Col.
apply plgf_sym in H1.
apply plgf_trivial_neq in H1.
spliter.
apply par_distinct in H.
tauto.
assumption.
apply False_ind.
apply H0.
apply (same_dir_trans _ _ D C').
apply H4.
apply same_dir_sym.
auto.
right.
assumption.
apply par_distinct in H.
tauto.
Qed.

Lemma same_dir_id : forall A B, Same_dir A B B A -> A = B.
intros.
unfold Same_dir in H.
induction H.
tauto.
ex_and H C.
apply eqv_mid in H0.
unfold Midpoint in H0.
unfold Out in H.
spliter.
induction H3.
apply (between_equality _ _ C).
apply H0.
assumption.
apply False_ind.
apply H2.
apply (between_equality _ _ A).
Between.
assumption.
Qed.

Lemma opp_dir_id : forall A B, Opp_dir A B A B -> A = B.
intros.
unfold Opp_dir in H.
apply same_dir_id in H.
auto.
Qed.

Lemma same_dir_to_null : forall A B C D, Same_dir A B C D -> Same_dir A B D C -> A = B /\ C = D.
intros.

assert(Same_dir C D D C).
apply (same_dir_trans _ _ A B).
apply same_dir_sym.
apply H.
assumption.
apply same_dir_id in H1.
subst D.
apply same_dir_sym in H.
apply same_dir_null in H.
subst B.
tauto.
Qed.

Lemma opp_dir_to_null : forall A B C D, Opp_dir A B C D -> Opp_dir A B D C -> A = B /\ C = D.
unfold Opp_dir.
intros.
apply same_dir_to_null; auto.
Qed.

Lemma same_not_opp_dir : forall A B C D, A <> B -> Same_dir A B C D -> ~ Opp_dir A B C D.
intros.
intro.
apply same_dir_to_null in H0.
tauto.
assumption.
Qed.

Lemma opp_not_same_dir : forall A B C D, A <> B -> Opp_dir A B C D -> ~ Same_dir A B C D.
unfold Opp_dir.
intros.
intro.
apply same_dir_to_null in H0.
tauto.
assumption.
Qed.

Lemma vector_same_dir_cong : forall A B C D, A <> B -> C <> D -> exists X, exists Y, Same_dir A B X Y /\ Cong X Y C D.
intros.
exists A.
assert(HH:=segment_construction_3 A B C D H H0).
ex_and HH P.
exists P.
split; auto.
unfold Same_dir.
right.
exists B.
split.
apply l6_6.
assumption.
apply eqv_refl.
Qed.

End Vectors.


(** DISCLAIMER: the current presentation of monoids uses typeclasses,
    but in fact it's not obvious that typeclasses are needed/useful here.
    Indeed, there is no overloading involved.
    Thus, the interface might change in the near future. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Mathematical structures                                                 *
**************************************************************************)

Set Implicit Arguments.
From SLF (* TLC *) Require Import LibTactics LibLogic LibOperation.
Generalizable Variables A B.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Monoids *)

(* --------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Structures *)

(** Monoid structure: binary operator and neutral element *)

Record monoid_op (A:Type) : Type := monoid_make {
   monoid_oper : A -> A -> A;
   monoid_neutral : A }.

(** Monoid properties
    Note that field names are suffixed by [_prop] because the corresponding
    properties are also available through typeclass instances. *)
(* -- LATER: factorize [let (o,n) := m] for the record definition *)

Class Monoid A (m:monoid_op A) : Prop := Monoid_make {
   monoid_assoc_prop : let (o,n) := m in assoc o;
   monoid_neutral_l_prop : let (o,n) := m in neutral_l o n;
   monoid_neutral_r_prop : let (o,n) := m in neutral_r o n }.

(** Commutative monoid *)

Class Comm_monoid A (m:monoid_op A) : Prop := Comm_monoid_make {
   comm_monoid_monoid : Monoid m;
   comm_monoid_comm : let (o,n) := m in comm o }.

(* --------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Examples *)

(** Example:

  Instance monoid_plus_zero:
    Monoid (monoid_make plus 0).
  Proof using.
    constructor; repeat intro; omega.
  Qed.

*)

(* --------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Properties *)

Section MonoidProp.
Context {A:Type}.

Class Monoid_assoc {m:monoid_op A} := {
  monoid_assoc : assoc (monoid_oper m) }.

Class Monoid_neutral_l {m:monoid_op A} := {
  monoid_neutral_l : neutral_l (monoid_oper m) (monoid_neutral m) }.

Class Monoid_neutral_r {m:monoid_op A} := {
  monoid_neutral_r : neutral_r (monoid_oper m) (monoid_neutral m) }.

Class Monoid_comm {m:monoid_op A} := {
  monoid_comm : comm (monoid_oper m) }.

End MonoidProp.

(* --------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Derived Properties *)

Section MonoidInst.
Variables (A:Type).
Implicit Types m : monoid_op A.

Global Instance Monoid_assoc_of_Monoid : forall m (M:Monoid m),
  Monoid_assoc (m:=m).
Proof using.
  introv M. constructor. destruct M as [U ? ?]. destruct m. simpl. apply U.
Qed.

Global Instance Monoid_neutral_l_of_Monoid : forall m (M:Monoid m),
  Monoid_neutral_l (m:=m).
Proof using.
  introv M. constructor. destruct M as [? U ?]. destruct m. simpl. apply U.
Qed.

Global Instance Monoid_neutral_r_of_Monoid : forall m (M:Monoid m),
  Monoid_neutral_r (m:=m).
Proof using.
  introv M. constructor. destruct M as [? ? U]. destruct m. simpl. apply U.
Qed.

Global Instance Monoid_of_Comm_monoid : forall m (M:Comm_monoid m),
  Monoid m.
Proof using.
  introv M. destruct M as [U ?]. destruct m. simpl. apply U.
Qed.

Global Instance Monoid_comm_of_Comm_Monoid : forall m (M:Comm_monoid m),
  Monoid_comm (m:=m).
Proof using.
  introv M. constructor. destruct M as [? U]. destruct m. simpl. apply U.
Qed.

End MonoidInst.

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