(* -*- coding: utf-8 -*- *)
(*      This file is distributed under the terms of the      *)
(*       GNU Lesser General Public License Version 2.1       *)
(* Author: Sosuke Moriguchi *)
(* Extended implementation from MSetGenTree *)

(** * XSetGenTree : sets via generic trees *)
(** This file is extension of [MSetGenTree] to implement (a part of) extensions in XSetInterface. *)

Require Import Orders OrdersFacts XSetInterface NPeano.
Local Open Scope list_scope.
Local Open Scope lazy_bool_scope.

(* For nicer extraction, we create induction principles
   only when needed *)
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

Module Type InfoTyp.
 Parameter t : Set.
End InfoTyp.

(** * Ops : the pure functions *)

Module Type Ops (X:OrderedType)(Info:InfoTyp).

Definition elt := X.t.
Hint Transparent elt.

Inductive tree  : Type :=
| Leaf : tree
| Node : Info.t -> tree -> X.t -> tree -> tree.

(** ** The empty set and emptyness test *)

Definition empty := Leaf.

Definition is_empty t :=
 match t with
 | Leaf => true
 | _ => false
 end.

(** ** Membership test *)

(** The [mem] function is deciding membership. It exploits the
    binary search tree invariant to achieve logarithmic complexity. *)

Fixpoint mem x t :=
 match t with
 | Leaf => false
 | Node _ l k r =>
   match X.compare x k with
     | Lt => mem x l
     | Eq => true
     | Gt => mem x r
   end
 end.

(** ** Minimal, maximal, arbitrary elements *)

Fixpoint min_elt (t : tree) : option elt :=
 match t with
 | Leaf => None
 | Node _ Leaf x r => Some x
 | Node _ l x r => min_elt l
 end.

Fixpoint max_elt (t : tree) : option elt :=
  match t with
  | Leaf => None
  | Node _ l x Leaf => Some x
  | Node _ l x r => max_elt r
  end.

Definition choose := min_elt.

(** ** Iteration on elements *)

Fixpoint fold {A: Type} (f: elt -> A -> A) (t: tree) (base: A) : A :=
  match t with
  | Leaf => base
  | Node _ l x r => fold f r (f x (fold f l base))
 end.

Fixpoint elements_aux acc s :=
  match s with
   | Leaf => acc
   | Node _ l x r => elements_aux (x :: elements_aux acc r) l
  end.

Definition elements := elements_aux nil.

Fixpoint rev_elements_aux acc s :=
  match s with
   | Leaf => acc
   | Node _ l x r => rev_elements_aux (x :: rev_elements_aux acc l) r
  end.

Definition rev_elements := rev_elements_aux nil.

Fixpoint cardinal (s : tree) : nat :=
  match s with
   | Leaf => 0
   | Node _ l _ r => S (cardinal l + cardinal r)
  end.

Fixpoint maxdepth s :=
 match s with
 | Leaf => 0
 | Node _ l _ r => S (max (maxdepth l) (maxdepth r))
 end.

Fixpoint mindepth s :=
 match s with
 | Leaf => 0
 | Node _ l _ r => S (min (mindepth l) (mindepth r))
 end.

(** ** Testing universal or existential properties. *)

(** We do not use the standard boolean operators of Coq,
    but lazy ones. *)

Fixpoint for_all (f:elt->bool) s := match s with
  | Leaf => true
  | Node _ l x r => f x &&& for_all f l &&& for_all f r
end.

Fixpoint exists_ (f:elt->bool) s := match s with
  | Leaf => false
  | Node _ l x r => f x ||| exists_ f l ||| exists_ f r
end.

(** ** Comparison of trees *)

(** The algorithm here has been suggested by Xavier Leroy,
    and transformed into c.p.s. by Benjamin Grégoire.
    The original ocaml code (with non-structural recursive calls)
    has also been formalized (thanks to Function+measure), see
    [ocaml_compare] in [MSetFullAVL]. The following code with
    continuations computes dramatically faster in Coq, and
    should be almost as efficient after extraction.
*)

(** Enumeration of the elements of a tree. This corresponds
    to the "samefringe" notion in the litterature. *)

Inductive enumeration :=
 | End : enumeration
 | More : elt -> tree -> enumeration -> enumeration.

(** [cons t e] adds the elements of tree [t] on the head of
    enumeration [e]. *)

Fixpoint cons s e : enumeration :=
 match s with
  | Leaf => e
  | Node _ l x r => cons l (More x r e)
 end.

(** One step of comparison of elements *)

Definition compare_more x1 (cont:enumeration->comparison) e2 :=
 match e2 with
 | End => Gt
 | More x2 r2 e2 =>
     match X.compare x1 x2 with
      | Eq => cont (cons r2 e2)
      | Lt => Lt
      | Gt => Gt
     end
 end.

(** Comparison of left tree, middle element, then right tree *)

Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 :=
 match s1 with
  | Leaf => cont e2
  | Node _ l1 x1 r1 =>
     compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
  end.

(** Initial continuation *)

Definition compare_end e2 :=
 match e2 with End => Eq | _ => Lt end.

(** The complete comparison *)

Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).

Definition equal s1 s2 :=
 match compare s1 s2 with Eq => true | _ => false end.

(** ** Subset test *)

(** In ocaml, recursive calls are made on "half-trees" such as
   (Node _ l1 x1 Leaf) and (Node _ Leaf x1 r1). Instead of these
   non-structural calls, we propose here two specialized functions
   for these situations. This version should be almost as efficient
   as the one of ocaml (closures as arguments may slow things a bit),
   it is simply less compact. The exact ocaml version has also been
   formalized (thanks to Function+measure), see [ocaml_subset] in
   [MSetFullAVL].
*)

Fixpoint subsetl (subset_l1 : tree -> bool) x1 s2 : bool :=
 match s2 with
  | Leaf => false
  | Node _ l2 x2 r2 =>
     match X.compare x1 x2 with
      | Eq => subset_l1 l2
      | Lt => subsetl subset_l1 x1 l2
      | Gt => mem x1 r2 &&& subset_l1 s2
     end
 end.

Fixpoint subsetr (subset_r1 : tree -> bool) x1 s2 : bool :=
 match s2 with
  | Leaf => false
  | Node _ l2 x2 r2 =>
     match X.compare x1 x2 with
      | Eq => subset_r1 r2
      | Lt => mem x1 l2 &&& subset_r1 s2
      | Gt => subsetr subset_r1 x1 r2
     end
 end.

Fixpoint subset s1 s2 : bool := match s1, s2 with
  | Leaf, _ => true
  | Node _ _ _ _, Leaf => false
  | Node _ l1 x1 r1, Node _ l2 x2 r2 =>
     match X.compare x1 x2 with
      | Eq => subset l1 l2 &&& subset r1 r2
      | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2
      | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2
     end
 end.

End Ops.

(** * Props : correctness proofs of these generic operations *)

Module Type Props (X:OrderedType)(Info:InfoTyp)(Import M:Ops X Info).

(** ** Occurrence in a tree *)

Inductive InT (x : elt) : tree -> Prop :=
  | IsRoot : forall c l r y, X.eq x y -> InT x (Node c l y r)
  | InLeft : forall c l r y, InT x l -> InT x (Node c l y r)
  | InRight : forall c l r y, InT x r -> InT x (Node c l y r).

Definition In := InT.

(** ** Some shortcuts *)

Definition Equal s s' := forall a : elt, InT a s <-> InT a s'.
Definition Subset s s' := forall a : elt, InT a s -> InT a s'.
Definition Empty s := forall a : elt, ~ InT a s.
Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x.
Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x.

(** ** Binary search trees *)

(** [lt_tree x s]: all elements in [s] are smaller than [x]
   (resp. greater for [gt_tree]) *)

Definition lt_tree x s := forall y, InT y s -> X.lt y x.
Definition gt_tree x s := forall y, InT y s -> X.lt x y.

(** [bst t] : [t] is a binary search tree *)

Inductive bst : tree -> Prop :=
  | BSLeaf : bst Leaf
  | BSNode : forall c x l r, bst l -> bst r ->
     lt_tree x l -> gt_tree x r -> bst (Node c l x r).

(** [bst] is the (decidable) invariant our trees will have to satisfy. *)

Definition IsOk := bst.

Class Ok (s:tree) : Prop := ok : bst s.

Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }.

Fixpoint ltb_tree x s :=
 match s with
  | Leaf => true
  | Node _ l y r =>
     match X.compare x y with
      | Gt => ltb_tree x l && ltb_tree x r
      | _ => false
     end
 end.

Fixpoint gtb_tree x s :=
 match s with
  | Leaf => true
  | Node _ l y r =>
     match X.compare x y with
      | Lt => gtb_tree x l && gtb_tree x r
      | _ => false
     end
 end.

Fixpoint isok s :=
 match s with
  | Leaf => true
  | Node _  l x r => isok l && isok r && ltb_tree x l && gtb_tree x r
 end.

(** ** Known facts about ordered types *)

Module Import MX := OrderedTypeFacts X.

(** ** Automation and dedicated tactics *)

Scheme tree_ind := Induction for tree Sort Prop.
Scheme bst_ind := Induction for bst Sort Prop.

Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
Local Hint Immediate MX.eq_sym.
Local Hint Unfold In lt_tree gt_tree.
Local Hint Constructors InT bst.
Local Hint Unfold Ok.

(** Automatic treatment of [Ok] hypothesis *)

Ltac clear_inversion H := inversion H; clear H; subst.

Ltac inv_ok := match goal with
 | H:Ok (Node _ _ _ _) |- _ => clear_inversion H; inv_ok
 | H:Ok Leaf |- _ => clear H; inv_ok
 | H:bst ?x |- _ => change (Ok x) in H; inv_ok
 | _ => idtac
end.

(** A tactic to repeat [inversion_clear] on all hyps of the
    form [(f (Node _ _ _ _))] *)

Ltac is_tree_constr c :=
  match c with
   | Leaf => idtac
   | Node _ _ _ _ => idtac
   | _ => fail
  end.

Ltac invtree f :=
  match goal with
     | H:f ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
     | H:f _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
     | H:f _ _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
     | _ => idtac
  end.

Ltac inv := inv_ok; invtree InT.

Ltac intuition_in := repeat progress (intuition; inv).

(** Helper tactic concerning order of elements. *)

Ltac order := match goal with
 | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
 | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
 | _ => MX.order
end.

(** [isok] is indeed a decision procedure for [Ok] *)

Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true.
Proof.
 induction s as [|c l IHl y r IHr]; simpl.
 unfold lt_tree; intuition_in.
 elim_compare x y.
 split; intros; try discriminate. assert (X.lt y x) by auto. order.
 split; intros; try discriminate. assert (X.lt y x) by auto. order.
 rewrite !andb_true_iff, <-IHl, <-IHr.
  unfold lt_tree; intuition_in; order.
Qed.

Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true.
Proof.
 induction s as [|c l IHl y r IHr]; simpl.
 unfold gt_tree; intuition_in.
 elim_compare x y.
 split; intros; try discriminate. assert (X.lt x y) by auto. order.
 rewrite !andb_true_iff, <-IHl, <-IHr.
  unfold gt_tree; intuition_in; order.
 split; intros; try discriminate. assert (X.lt x y) by auto. order.
Qed.

Lemma isok_iff : forall s, Ok s <-> isok s = true.
Proof.
 induction s as [|c l IHl y r IHr]; simpl.
 intuition_in.
 rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff.
 intuition_in.
Qed.

Instance isok_Ok s : isok s = true -> Ok s | 10.
Proof. intros; apply <- isok_iff; auto. Qed.

(** ** Basic results about [In] *)

Lemma In_1 :
 forall s x y, X.eq x y -> InT x s -> InT y s.
Proof.
 induction s; simpl; intuition_in; eauto.
Qed.
Local Hint Immediate In_1.

Instance In_compat : Proper (X.eq==>eq==>iff) InT.
Proof.
apply proper_sym_impl_iff_2; auto with *.
repeat red; intros; subst. apply In_1 with x; auto.
Qed.

Lemma In_node_iff :
 forall c l x r y,
  InT y (Node c l x r) <-> InT y l \/ X.eq y x \/ InT y r.
Proof.
 intuition_in.
Qed.

Lemma In_leaf_iff : forall x, InT x Leaf <-> False.
Proof.
 intuition_in.
Qed.

(** Results about [lt_tree] and [gt_tree] *)

Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
Proof.
 red; inversion 1.
Qed.

Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
Proof.
 red; inversion 1.
Qed.

Lemma lt_tree_node :
 forall (x y : elt) (l r : tree) (i : Info.t),
 lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node i l y r).
Proof.
 unfold lt_tree; intuition_in; order.
Qed.

Lemma gt_tree_node :
 forall (x y : elt) (l r : tree) (i : Info.t),
 gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node i l y r).
Proof.
 unfold gt_tree; intuition_in; order.
Qed.

Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.

Lemma lt_tree_not_in :
 forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t.
Proof.
 intros; intro; order.
Qed.

Lemma lt_tree_trans :
 forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
Proof.
 eauto.
Qed.

Lemma gt_tree_not_in :
 forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t.
Proof.
 intros; intro; order.
Qed.

Lemma gt_tree_trans :
 forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
Proof.
 eauto.
Qed.

Instance lt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) lt_tree.
Proof.
 apply proper_sym_impl_iff_2; auto.
 intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto.
Qed.

Instance gt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) gt_tree.
Proof.
 apply proper_sym_impl_iff_2; auto.
 intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto.
Qed.

Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.

Ltac induct s x :=
 induction s as [|i l IHl x' r IHr]; simpl; intros;
 [|elim_compare x x'; intros; inv].

Ltac auto_tc := auto with typeclass_instances.

Ltac ok :=
 inv; change bst with Ok in *;
 match goal with
   | |- Ok (Node _ _ _ _) => constructor; auto_tc; ok
   | |- lt_tree _ (Node _ _ _ _) => apply lt_tree_node; ok
   | |- gt_tree _ (Node _ _ _ _) => apply gt_tree_node; ok
   | _ => eauto with typeclass_instances
 end.

(** ** Empty set *)

Lemma empty_spec : Empty empty.
Proof.
 intros x H. inversion H.
Qed.

Instance empty_ok : Ok empty.
Proof.
 auto.
Qed.

(** ** Emptyness test *)

Lemma is_empty_spec : forall s `{Ok s}, is_empty s = true <-> Empty s.
Proof.
  intros s _; destruct s as [|c r x l]; simpl; auto.
 - split; auto. intros _ x H. inv.
 - split; auto. try discriminate. intro H; elim (H x); auto.
Qed.

(** ** Membership *)

Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s.
Proof.
 split.
 - induct s x; now auto.
 - induct s x; intuition_in; order.
Qed.

(** ** Minimal and maximal elements *)

Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.

Lemma min_elt_spec1 s x `{H : Ok s} : min_elt s = Some x -> InT x s.
Proof.
 clear H; functional induction (min_elt s); auto; inversion 1; auto.
Qed.

Lemma min_elt_spec2 s x y `{Ok s} :
 min_elt s = Some x -> InT y s -> ~ X.lt y x.
Proof.
 revert y.
 functional induction (min_elt s);
 try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1.
 - discriminate.
 - intros y V W.
   inversion V; clear V; subst.
   inv; order.
 - intros; inv; auto.
   * assert (X.lt x x0) by (apply H8; apply min_elt_spec1; auto).
     order.
   * assert (X.lt x1 x0) by auto.
     assert (~X.lt x1 x) by auto.
     order.
Qed.

Lemma min_elt_spec3 s `{H : Ok s} : min_elt s = None -> Empty s.
Proof.
 clear H.
 functional induction (min_elt s).
 red; red; inversion 2.
 inversion 1.
 intro H0.
 destruct (IHo H0 _x3); auto.
Qed.

Lemma max_elt_spec1 s x `{H : Ok s} : max_elt s = Some x -> InT x s.
Proof.
 clear H; functional induction (max_elt s); auto; inversion 1; auto.
Qed.

Lemma max_elt_spec2 s x y `{Ok s} :
 max_elt s = Some x -> InT y s -> ~ X.lt x y.
Proof.
 revert y.
 functional induction (max_elt s);
 try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1.
 - discriminate.
 - intros y V W.
   inversion V; clear V; subst.
   inv; order.
 - intros; inv; auto.
   * assert (X.lt x0 x) by (apply H9; apply max_elt_spec1; auto).
     order.
   * assert (X.lt x0 x1) by auto.
     assert (~X.lt x x1) by auto.
     order.
Qed.

Lemma max_elt_spec3 s `{H : Ok s} : max_elt s = None -> Empty s.
Proof.
 clear H.
 functional induction (max_elt s).
 red; red; inversion 2.
 inversion 1.
 intro H0.
 destruct (IHo H0 _x3); auto.
Qed.

Lemma choose_spec1 : forall s x `{Ok s}, choose s = Some x -> InT x s.
Proof.
 exact min_elt_spec1.
Qed.

Lemma choose_spec2 : forall s `{Ok s}, choose s = None -> Empty s.
Proof.
 exact min_elt_spec3.
Qed.

Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'},
  choose s = Some x -> choose s' = Some x' ->
  Equal s s' -> X.eq x x'.
Proof.
 unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H.
 assert (~X.lt x x').
  apply min_elt_spec2 with s'; auto.
  rewrite <-H; auto using min_elt_spec1.
 assert (~X.lt x' x).
  apply min_elt_spec2 with s; auto.
  rewrite H; auto using min_elt_spec1.
 elim_compare x x'; intuition.
Qed.

(** ** Elements *)

Lemma elements_spec1' : forall s acc x,
 InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc.
Proof.
 induction s as [ | c l Hl x r Hr ]; simpl; auto.
 intuition.
 inversion H0.
 intros.
 rewrite Hl.
 destruct (Hr acc x0); clear Hl Hr.
 intuition; inversion_clear H3; intuition.
Qed.

Lemma elements_spec1_w : forall s x, InA X.eq x (elements s) <-> InT x s.
Proof.
 intros s x; generalize (elements_spec1' s nil x); intuition.
 inversion_clear H0.
Qed.

Lemma elements_spec1 : forall s x `{Ok s}, InA X.eq x (elements s) <-> InT x s.
Proof. intros s x _. exact (elements_spec1_w _ _). Qed.

Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc ->
 (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) ->
 sort X.lt (elements_aux acc s).
Proof.
 induction s as [ | c l Hl y r Hr]; simpl; intuition.
 inv.
 apply Hl; auto.
 constructor.
 apply Hr; auto.
 eapply InA_InfA; eauto with *.
 intros.
 destruct (elements_spec1' r acc y0); intuition.
 intros.
 inversion_clear H.
 order.
 destruct (elements_spec1' r acc x); intuition eauto.
Qed.

Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s).
Proof.
 intros; unfold elements; apply elements_spec2'; auto.
 intros; inversion H0.
Qed.
Local Hint Resolve elements_spec2.

Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s).
Proof.
 intros. eapply SortA_NoDupA; eauto with *.
Qed.

Lemma elements_aux_cardinal :
 forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
Proof.
 simple induction s; simpl; intuition.
 rewrite <- H.
 simpl.
 rewrite <- H0. rewrite (Nat.add_comm (cardinal t0)).
 now rewrite <- Nat.add_succ_r, Nat.add_assoc.
Qed.

Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
Proof.
 exact (fun s => elements_aux_cardinal s nil).
Qed.

Definition cardinal_spec (s:tree)(Hs:Ok s) := elements_cardinal s.

Lemma elements_app :
 forall s acc, elements_aux acc s = elements s ++ acc.
Proof.
 induction s; simpl; intros; auto.
 rewrite IHs1, IHs2.
 unfold elements; simpl.
 rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
Qed.

Lemma elements_node c l x r :
 elements (Node c l x r) = elements l ++ x :: elements r.
Proof.
 unfold elements; simpl.
 now rewrite !elements_app, !app_nil_r.
Qed.

Lemma rev_elements_app :
 forall s acc, rev_elements_aux acc s = rev_elements s ++ acc.
Proof.
 induction s; simpl; intros; auto.
 rewrite IHs1, IHs2.
 unfold rev_elements; simpl.
 rewrite IHs1, 2 IHs2, !app_nil_r, !app_ass; auto.
Qed.

Lemma rev_elements_node c l x r :
 rev_elements (Node c l x r) = rev_elements r ++ x :: rev_elements l.
Proof.
 unfold rev_elements; simpl.
 now rewrite !rev_elements_app, !app_nil_r.
Qed.

Lemma rev_elements_rev s : rev_elements s = rev (elements s).
Proof.
 induction s as [|c l IHl x r IHr]; trivial.
 rewrite elements_node, rev_elements_node, IHl, IHr, rev_app_distr.
 simpl. now rewrite !app_ass.
Qed.

(** The converse of [elements_spec2], used in XSetRBT *)

(* TODO: TO MIGRATE ELSEWHERE... *)

Lemma sorted_app_inv l1 l2 :
 sort X.lt (l1++l2) ->
 sort X.lt l1 /\ sort X.lt l2 /\
 forall x1 x2, InA X.eq x1 l1 -> InA X.eq x2 l2 -> X.lt x1 x2.
Proof.
 induction l1 as [|a1 l1 IHl1].
 - simpl; repeat split; auto.
   intros. now rewrite InA_nil in *.
 - simpl. inversion_clear 1 as [ | ? ? Hs Hhd ].
   destruct (IHl1 Hs) as (H1 & H2 & H3).
   repeat split.
   * constructor; auto.
     destruct l1; simpl in *; auto; inversion_clear Hhd; auto.
   * trivial.
   * intros x1 x2 Hx1 Hx2. rewrite InA_cons in Hx1. destruct Hx1.
     + rewrite H.
       apply SortA_InfA_InA with (eqA:=X.eq)(l:=l1++l2); auto_tc.
       rewrite InA_app_iff; auto_tc.
     + auto.
Qed.

Lemma elements_sort_ok s : sort X.lt (elements s) -> Ok s.
Proof.
 induction s as [|c l IHl x r IHr].
 - auto.
 - rewrite elements_node.
   intros H. destruct (sorted_app_inv _ _ H) as (H1 & H2 & H3).
   inversion_clear H2.
   constructor; ok.
   * intros y Hy. apply H3.
     + now rewrite elements_spec1_w.
     + rewrite InA_cons. now left.
   * intros y Hy.
     apply SortA_InfA_InA with (eqA:=X.eq)(l:=elements r); auto_tc.
     now rewrite elements_spec1_w.
Qed.

(** ** [for_all] and [exists] *)

Lemma for_all_spec s f {H : Ok s} : Proper (X.eq==>eq) f ->
 (for_all f s = true <-> For_all (fun x => f x = true) s).
Proof.
 clear H; intros Hf; unfold For_all.
 induction s as [|i l IHl x r IHr]; simpl; auto.
 - split; intros; inv; auto.
 - rewrite <- !andb_lazy_alt, !andb_true_iff, IHl, IHr. clear IHl IHr.
   intuition_in. eauto.
Qed.

Lemma exists_spec s f `{H : Ok s} : Proper (X.eq==>eq) f ->
 (exists_ f s = true <-> Exists (fun x => f x = true) s).
Proof.
 clear H; intros Hf; unfold Exists.
 induction s as [|i l IHl x r IHr]; simpl; auto.
 - split.
   * discriminate.
   * intros (y,(H,_)); inv.
 - rewrite <- !orb_lazy_alt, !orb_true_iff, IHl, IHr. clear IHl IHr.
   split; [intros [[H|(y,(H,H'))]|(y,(H,H'))]|intros (y,(H,H'))].
   * exists x; auto.
   * exists y; auto.
   * exists y; auto.
   * inv; [left;left|left;right|right]; try (exists y); eauto.
Qed.

(** ** Fold *)

Lemma fold_spec' {A} (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt) :
 fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i).
Proof.
 revert i acc.
 induction s as [|c l IHl x r IHr]; simpl; intros; auto.
 rewrite IHl.
 simpl. unfold flip at 2.
 apply IHr.
Qed.

Lemma fold_spec_w (s:tree) {A} (i : A) (f : elt -> A -> A) :
 fold f s i = fold_left (flip f) (elements s) i.
Proof.
 revert i. unfold elements.
 induction s as [|c l IHl x r IHr]; simpl; intros; auto.
 rewrite fold_spec'.
 rewrite IHr.
 simpl; auto.
Qed.

Lemma fold_spec (s:tree) `{H : Ok s} {A} (i : A) (f : elt -> A -> A) :
 fold f s i = fold_left (flip f) (elements s) i.
Proof. exact (fold_spec_w _ _ _). Qed.

(** ** Subset *)

Lemma subsetl_spec : forall subset_l1 l1 x1 c1 s2
 `{Ok (Node c1 l1 x1 Leaf), Ok s2},
 (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) ->
 (subsetl subset_l1 x1 s2 = true <-> Subset (Node c1 l1 x1 Leaf) s2 ).
Proof.
 induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros.
 unfold Subset; intuition; try discriminate.
 assert (H': InT x1 Leaf) by auto; inversion H'.
 specialize (IHl2 H).
 specialize (IHr2 H).
 inv.
 elim_compare x1 x2.

 rewrite H1 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 assert (X.eq a x2) by order; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite IHl2 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
 rewrite mem_spec; auto.
 assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order.
Qed.

Lemma subsetr_spec : forall subset_r1 r1 x1 c1 s2,
 bst (Node c1 Leaf x1 r1) -> bst s2 ->
 (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) ->
 (subsetr subset_r1 x1 s2 = true <-> Subset (Node c1 Leaf x1 r1) s2).
Proof.
 induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros.
 unfold Subset; intuition; try discriminate.
 assert (H': InT x1 Leaf) by auto; inversion H'.
 specialize (IHl2 H).
 specialize (IHr2 H).
 inv.
 elim_compare x1 x2.

 rewrite H1 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 assert (X.eq a x2) by order; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto;  clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
 rewrite mem_spec; auto.
 assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite IHr2 by auto; clear H1 IHl2 IHr2.
 unfold Subset. intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
Qed.

Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2},
 (subset s1 s2 = true <-> Subset s1 s2).
Proof.
 induction s1 as [|c1 l1 IHl1 x1 r1 IHr1]; simpl; intros.
 unfold Subset; intuition_in.
 destruct s2 as [|c2 l2 x2 r2]; simpl; intros.
 unfold Subset; intuition_in; try discriminate.
 assert (H': InT x1 Leaf) by auto; inversion H'.
 inv.
 elim_compare x1 x2.

 rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
 clear IHl1 IHr1.
 unfold Subset; intuition_in.
 assert (X.eq a x2) by order; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
 rewrite (@subsetl_spec (subset l1) l1 x1 c1) by auto.
 clear IHl1 IHr1.
 unfold Subset; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.

 rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
 rewrite (@subsetr_spec (subset r1) r1 x1 c1) by auto.
 clear IHl1 IHr1.
 unfold Subset; intuition_in.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
 assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
Qed.

(** ** Comparison *)

(** Relations [eq] and [lt] over trees *)

Module L := XSetInterface.MakeListOrdering X.

Definition eq := Equal.
Instance eq_equiv : Equivalence eq.
Proof. firstorder. Qed.

Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s').
Proof.
 unfold eq, Equal, L.eq; intros.
 setoid_rewrite elements_spec1_w; firstorder.
Qed.

Definition lt (s1 s2 : tree) : Prop :=
 exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
   /\ L.lt (elements s1') (elements s2').

Instance lt_strorder : StrictOrder lt.
Proof.
 split.
 intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
 assert (eqlistA X.eq (elements s1) (elements s2)).
  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
  rewrite <- eq_Leq. transitivity s; auto. symmetry; auto.
 rewrite H in L.
 apply (StrictOrder_Irreflexive (elements s2)); auto.
 intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
                 (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
 exists s1', s3'; do 4 (split; trivial).
 assert (eqlistA X.eq (elements s2') (elements s2'')).
  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
  rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto.
 transitivity (elements s2'); auto.
 rewrite H; auto.
Qed.

Instance lt_compat : Proper (eq==>eq==>iff) lt.
Proof.
 intros s1 s2 E12 s3 s4 E34. split.
 intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
 exists s1', s3'; do 2 (split; trivial).
  split. transitivity s1; auto. symmetry; auto.
  split; auto. transitivity s3; auto. symmetry; auto.
 intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
 exists s1', s3'; do 2 (split; trivial).
  split. transitivity s2; auto.
  split; auto. transitivity s4; auto.
Qed.

(** Proof of the comparison algorithm *)

(** [flatten_e e] returns the list of elements of [e] i.e. the list
    of elements actually compared *)

Fixpoint flatten_e (e : enumeration) : list elt := match e with
  | End => nil
  | More x t r => x :: elements t ++ flatten_e r
 end.

Lemma flatten_e_elements :
 forall l x r c e,
 elements l ++ flatten_e (More x r e) = elements (Node c l x r) ++ flatten_e e.
Proof.
 intros; simpl. now rewrite elements_node, app_ass.
Qed.

Lemma cons_1 : forall s e,
  flatten_e (cons s e) = elements s ++ flatten_e e.
Proof.
 induction s; simpl; auto; intros.
 rewrite IHs1; apply flatten_e_elements.
Qed.

(** Correctness of this comparison *)

Definition Cmp c x y := CompSpec L.eq L.lt x y c.

Local Hint Unfold Cmp flip.

Lemma compare_end_Cmp :
 forall e2, Cmp (compare_end e2) nil (flatten_e e2).
Proof.
 destruct e2; simpl; constructor; auto. reflexivity.
Qed.

Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l,
  Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
   Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l)
      (flatten_e (More x2 r2 e2)).
Proof.
 simpl; intros; elim_compare x1 x2; simpl; red; auto.
Qed.

Lemma compare_cont_Cmp : forall s1 cont e2 l,
 (forall e, Cmp (cont e) l (flatten_e e)) ->
 Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
Proof.
 induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; simpl; intros; auto.
 rewrite elements_node, app_ass; simpl.
 apply Hl1; auto. clear e2. intros [|x2 r2 e2].
 simpl; auto.
 apply compare_more_Cmp.
 rewrite <- cons_1; auto.
Qed.

Lemma compare_Cmp : forall s1 s2,
 Cmp (compare s1 s2) (elements s1) (elements s2).
Proof.
 intros; unfold compare.
 rewrite (app_nil_end (elements s1)).
 replace (elements s2) with (flatten_e (cons s2 End)) by
  (rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
 apply compare_cont_Cmp; auto.
 intros.
 apply compare_end_Cmp; auto.
Qed.

Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2},
 CompSpec eq lt s1 s2 (compare s1 s2).
Proof.
 intros.
 destruct (compare_Cmp s1 s2); constructor.
 rewrite eq_Leq; auto.
 intros; exists s1, s2; repeat split; auto.
 intros; exists s2, s1; repeat split; auto.
Qed.

(** ** Equality test *)

Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2},
 equal s1 s2 = true <-> eq s1 s2.
Proof.
unfold equal; intros s1 s2 B1 B2.
destruct (@compare_spec s1 s2 B1 B2) as [H|H|H];
 split; intros H'; auto; try discriminate.
rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
Qed.

(** ** A few results about [mindepth] and [maxdepth] *)

Lemma mindepth_maxdepth s : mindepth s <= maxdepth s.
Proof.
 induction s; simpl; auto.
 rewrite <- Nat.succ_le_mono.
 transitivity (mindepth s1). apply Nat.le_min_l.
 transitivity (maxdepth s1). trivial. apply Nat.le_max_l.
Qed.

Lemma maxdepth_cardinal s : cardinal s < 2^(maxdepth s).
Proof.
 unfold Peano.lt.
 induction s as [|c l IHl x r IHr].
 - auto.
 - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
   apply Nat.add_le_mono; etransitivity;
   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
   * apply Nat.le_max_l.
   * apply Nat.le_max_r.
Qed.

Lemma mindepth_cardinal s : 2^(mindepth s) <= S (cardinal s).
Proof.
 unfold Peano.lt.
 induction s as [|c l IHl x r IHr].
 - auto.
 - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
   apply Nat.add_le_mono; etransitivity;
   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
   * apply Nat.le_min_l.
   * apply Nat.le_min_r.
Qed.

Lemma maxdepth_log_cardinal s : s <> Leaf ->
 log2 (cardinal s) < maxdepth s.
Proof.
 intros H.
 apply Nat.log2_lt_pow2. destruct s; simpl; intuition.
 apply maxdepth_cardinal.
Qed.

Lemma mindepth_log_cardinal s : mindepth s <= log2 (S (cardinal s)).
Proof.
 apply Nat.log2_le_pow2. auto with arith.
 apply mindepth_cardinal.
Qed.

End Props.


Require Import List.

Theorem Closure : forall ( X : Type ) ( l1 l2 : list X ) , exists ( l3 : list X ),
   l1 ++ l2 = l3.
Proof.
 intros X l1 l2. exists ( l1 ++ l2) .
 reflexivity.
Qed.

Theorem Association : forall ( X : Type ) ( l1 l2 l3 : list X ) ,
  l1 ++ ( l2 ++ l3 ) = l1 ++ ( l2 ++ l3 ).
Proof.
  intros X l1 l2 l3.
  simpl. reflexivity.
Qed.

Theorem Existence_identity_left : forall ( X : Type ) ( l : list X ), exists e,
 e ++ l = l.
Proof.
 intros X l. exists nil. simpl.
 reflexivity.
Qed.

Theorem Existence_identify_right : forall ( X : Type ) ( l : list X ) , exists e,
  l ++ e = l.
Proof.
 intros X l. exists nil.
 apply app_nil_r.
Qed.


(** Lemmas and tactics for working with and solving goals related to
    non-membership in finite sets.  The main tactic of interest here
    is [notin_solve].

    Authors: Arthur Charguéraud and Brian Aydemir. *)

Set Implicit Arguments.
Require Import FSetInterface.

(* *********************************************************************** *)
(** * Implementation *)

Module Notin (X : FSetInterface.S).

Import X.

(* *********************************************************************** *)
(** ** Facts about set (non-)membership *)

Lemma in_singleton : forall x,
  In x (singleton x).
Proof.
  intros x.
  apply singleton_2.
  apply E.eq_refl.
Qed.

Lemma notin_empty : forall x,
  ~ In x empty.
Proof.
  auto using empty_1.
Qed.

Lemma notin_union : forall x E F,
  ~ In x E -> ~ In x F -> ~ In x (union E F).
Proof.
  intros x E F H J K.
  destruct (union_1 K); intuition.
Qed.

Lemma elim_notin_union : forall x E F,
  ~ In x (union E F) -> (~ In x E) /\ (~ In x F).
Proof.
  intros x E F H. split; intros J; contradiction H.
  auto using union_2.
  auto using union_3.
Qed.

Lemma notin_singleton : forall x y,
  ~ E.eq x y -> ~ In x (singleton y).
Proof.
  intros x y H J. assert (K := singleton_1 J). intuition.
Qed.

Lemma elim_notin_singleton : forall x y,
  ~ In x (singleton y) -> ~ E.eq x y.
Proof.
  intros x y H J.
  contradiction H.
  apply singleton_2, E.eq_sym, J.
Qed.

Lemma elim_notin_singleton' : forall x y,
  ~ In x (singleton y) -> x <> y.
Proof.
  intros. assert (~ E.eq x y). auto using singleton_2.
  intros J. subst. intuition.
  intros x_eq_y.
  apply H0.
  rewrite x_eq_y.
  apply E.eq_refl.
Qed.

Lemma notin_singleton_swap : forall x y,
  ~ In x (singleton y) -> ~ In y (singleton x).
Proof.
  intros.
  assert (Q := elim_notin_singleton H).
  auto using singleton_1.
Qed.

(* *********************************************************************** *)
(** ** Rewriting non-membership facts *)

Lemma notin_singleton_rw : forall x y,
  ~ In x (singleton y) <-> ~ E.eq x y.
Proof.
  intros. split.
    auto using elim_notin_singleton.
    auto using notin_singleton.
Qed.

(* *********************************************************************** *)
(** ** Tactics *)

(** The tactic [notin_simpl_hyps] destructs all hypotheses of the form
    [(~ In x E)], where [E] is built using only [empty], [union], and
    [singleton]. *)

Ltac notin_simpl_hyps :=
  try match goal with
        | H: In ?x ?E -> False |- _ =>
          change (~ In x E) in H;
          notin_simpl_hyps
        | H: ~ In _ empty |- _ =>
          clear H;
          notin_simpl_hyps
        | H: ~ In ?x (singleton ?y) |- _ =>
          let F1 := fresh in
          let F2 := fresh in
          assert (F1 := @elim_notin_singleton x y H);
          assert (F2 := @elim_notin_singleton' x y H);
          clear H;
          notin_simpl_hyps
        | H: ~ In ?x (union ?E ?F) |- _ =>
          destruct (@elim_notin_union x E F H);
          clear H;
          notin_simpl_hyps
      end.

(** The tactic [notin_solve] solves goals of them form [(x <> y)] and
    [(~ In x E)] that are provable from hypotheses of the form
    destructed by [notin_simpl_hyps]. *)

Ltac notin_solve :=
  repeat notin_simpl_hyps;
  repeat (progress ( apply notin_empty
                  || apply notin_union
                  || apply notin_singleton ));
  solve [ trivial | congruence | intuition ].

(* *********************************************************************** *)
(** ** Examples and test cases *)

Lemma test_notin_solve_1 : forall x E F G,
  ~ In x (union E F) -> ~ In x G -> ~ In x (union E G).
Proof.
  intros. notin_solve.
Qed.

Lemma test_notin_solve_2 : forall x y E F G,
  ~ In x (union E (union (singleton y) F)) -> ~ In x G ->
  ~ In x (singleton y) /\ ~ In y (singleton x).
Proof.
  intros. split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_3 : forall x y,
  ~ E.eq x y -> ~ In x (singleton y) /\ ~ In y (singleton x).
Proof.
  intros. split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_4 : forall x y E F G,
  ~ In x (union E (union (singleton x) F)) -> ~ In y G.
Proof.
  intros. notin_solve.
Qed.

Lemma test_notin_solve_5 : forall x y E F,
  ~ In x (union E (union (singleton y) F)) -> ~ In y E ->
  ~ E.eq y x /\ ~ E.eq x y.
Proof.
  intros. split. notin_solve. notin_solve.
Qed.

End Notin.


(* DEPRECATED

   needs a cleanup and merge into LibRelation.v

*)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Partial equivalence relations                                           *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibBool LibLogic LibRelation LibContainer LibSet.
Module Rel := LibRelation.

(* ********************************************************************** *)
(** * Partial equivalence relations *)

(** [per R] captures the fact that [R] is symmetric and transitive
    relation, that is, a partial equivalence relation *)

Record per A (R:binary A) :=
 { per_sym : sym R;
   per_trans : trans R }.

(** The domain of a PER contains all the points that are related
    to themselves *)

Definition per_dom A (R:binary A) :=
  set_st (fun x => R x x).

(** The empty PER *)

Lemma per_empty:
  forall A,
  per (@LibRelation.empty A).
Proof using.
  unfold LibRelation.empty.
  constructor.
  unfold sym. eauto.
  unfold trans. eauto.
Qed.

Lemma per_dom_empty:
  forall A,
  per_dom (@LibRelation.empty A) = empty.
Proof using.
  reflexivity.
Qed.

(** A singleton PER *)

(* TEMPORARY this is a singleton RELATION and could be in LibRelation. *)
Definition per_single A (a b:A) :=
  fun x y => x = a /\ y = b.

(* TEMPORARY: move this as well to relations *)
Lemma inverse_per_single : forall A (a b:A),
  inverse (per_single a b) = per_single b a.
Proof using.
  intros. applys pred_ext_2. intros. unfold inverse, per_single. autos*.
Qed.

(** Extension of an per [B] with a node [z] *)

Definition per_add_node A (B:binary A) (z:A) :=
  Rel.union B (per_single z z).

(** Extension of an per [B] with an edge between [x] and [y] *)

Definition per_add_edge A (B:binary A) (x y:A) :=
  stclosure (Rel.union B (per_single x y)).

Lemma per_add_edge_le : forall A (B:binary A) a b,
  rel_incl B (per_add_edge B a b).
Proof using. introv. intros x y H. apply stclosure_once. left~. Qed.

Lemma add_edge_already : forall A (B:binary A) a b,
  per B -> B a b -> per_add_edge B a b = B.
Proof using.
  introv P H. extens. intros x y. iff M.
  induction M.
    destruct H0. auto. destruct H0. subst~.
    apply* per_sym.
    apply* per_trans.
  hnf in M.
  apply~ per_add_edge_le.
Qed.

Lemma per_add_edge_per : forall A (R : binary A) a b,
  per R -> per (per_add_edge R a b).
Proof using.
  introv [Rs Rt]. unfold per_add_edge. constructor.
  introv H. applys~ sym_stclosure. applys~ trans_stclosure.
Qed.

Lemma per_dom_add_edge : forall A (B:binary A) x y,
  per B -> x \in per_dom B -> y \in per_dom B ->
  per_dom (per_add_edge B x y) = per_dom B \u \{x} \u \{y}.
Proof using.
  introv [Sy Tr] Bx By. unfold per_add_edge. apply set_ext. intros z.
  unfold Rel.union. unfold per_dom. unfold per_single.
  do 2 rewrite in_union_eq, in_set_st_eq. do 2 rewrite in_single_eq.
  iff H.
  set (a:=z) in H at 1. set (b := z) in H.
  asserts~ K: (a = z \/ b = z). clearbody a b. gen K.
  induction H; introv E.
  left. destruct E; subst; destruct H as [M|[? ?]]; subst*.
  intuition.
  intuition.
  apply stclosure_once. destruct H as [E|[Zx|Zy]]; subst*.
Qed.

Lemma per_add_node_per : forall A (B:binary A) r,
  per B -> per (per_add_node B r).
Proof using.
  introv [Sy Tr]. unfold per_add_node, per_single, Rel.union.
  constructors.
  intros_all. hnf in Sy. intuition.
  intros_all. hnf in Tr. intuition; subst*.
Qed.

Lemma per_dom_add_node : forall A (B:binary A) x,
  per_dom (per_add_node B x) = per_dom B \u \{x}.
Proof using.
  intros. unfold per_add_node. apply set_ext. intros y.
  unfold Rel.union. unfold per_dom. unfold per_single.
  rewrite in_union_eq. rewrite in_single_eq. do 2 rewrite in_set_st_eq.
  intuition.
Qed.

(* --TODO: rename lemma *)
Lemma prove_per_single : forall A (x y : A),
  (per_single x y) x y.
Proof using.
  unfold per_single. eauto.
Qed.

(* --TODO: move instance *)
Global Instance binary_incl : forall A, BagIncl (binary A).
Proof using. constructor. rapply (@rel_incl A A). Defined.

Lemma per_add_edge_covariant : forall A (B1 B2 : binary A) x y,
  incl B1 B2 ->
  incl (per_add_edge B1 x y) (per_add_edge B2 x y).
Proof using.
  unfold binary_incl. unfold per_add_edge.
  (* --TODO: was     eauto using stclosure_le, union_covariant. *)
  introv M. applys covariant_stclosure. applys* covariant_union.
  applys refl_rel_incl.
Qed.

Lemma per_add_edge_symmetric : forall A (B : binary A) x y,
  per_add_edge B y x = per_add_edge B x y.
Proof using.
  unfold per_add_edge. intros.
  (* If two relations have the same symmetric closure, then
     they have the same symmetric-transitive closure. *)
  do 2 rewrite <- tclosure_sclosure_eq_stclosure. f_equal.
  apply pred_ext_2. intros a b. do 2 rewrite sclosure_eq.
  unfold Rel.union, per_single. tauto.
Qed.


(*Modélisation des énigmes de Smullyan de la princesse et du tigre en logique des propositions.
Utilisation de la tactique tauto pour la résolution des énigmes.
*)

Parameters PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8 PC9: Prop.
Parameters TC1 TC2 TC3 TC4 TC5 TC6 TC7 TC8 TC9: Prop.
Parameters VC1 VC2 VC3 VC4 VC5 VC6 VC7 VC8 VC9: Prop.

Definition A1 : Prop := PC1 /\ TC2.
Definition A2 : Prop := (PC1 /\ TC2) \/ (PC2 /\ TC1).
Definition HY1 : Prop := (A1 /\ ~A2) \/ (A2 /\ ~A1).
Definition HN2 : Prop := (PC1 \/ TC1) /\ ~(PC1 /\ TC1) /\ (PC2 \/ TC2) /\ ~(PC2 /\ TC2).

Lemma S1 : HY1 /\ HN2 -> ~PC1 /\ PC2.
Proof.
unfold HY1, HN2, A1, A2.
intros.
destruct H; destruct H0; destruct H1; destruct H2.
destruct H; destruct H.
  (*A1 vraie, A2 fausse*)
  destruct H4; left; assumption.

  (*A1 fausse, A2 vraie*)
  destruct H.
    destruct H4; assumption.
    destruct H; split.
      intro; destruct H1; split; assumption.
      assumption.
Qed.

Definition B1 : Prop := PC1 \/ PC2.
Definition B2 : Prop := TC2.
Definition HY2 : Prop := (B1 /\ B2) \/ (~B1 /\ ~B2).

Lemma S2 : HY2 /\ HN2 -> PC1 /\ ~PC2.
Proof.
unfold HY2, B1, B2, HN2.
tauto.
Qed.

Definition C1 : Prop := TC1 \/ PC2.
Definition C2 : Prop := PC1.
Definition HY3 : Prop := (C1 /\ C2) \/ (~C1 /\ ~C2).

Lemma S3 : HY3 /\ HN2 -> PC1 /\ PC2.
Proof.
unfold HY3, C1, C2, HN2.
tauto.
Qed.

Definition D1 : Prop := PC1 /\ PC2.
Definition D2 : Prop := PC1 /\ PC2.
Definition HY4 : Prop := (PC1 -> D1) /\ (PC2 -> ~D2) /\ (TC1 -> ~D1) /\ (TC2 -> D2).

Lemma S4 : HY4 /\ HN2 -> ~PC1 /\ PC2.
Proof.
unfold HY4, D1, D2, HN2.
intros.
destruct H; destruct H; destruct H1; destruct H2.
destruct H0; destruct H4; destruct H5.
split.
  intro.
  apply H in H7; destruct H7.
  apply H1 in H8; destruct H8.
  split.
    assumption.
    apply H in H7; destruct H7; assumption.

  destruct H5.
    assumption.
    apply H3 in H5; destruct H5; assumption.
Qed.

Definition E1 : Prop := PC1 \/ PC2.
Definition E2 : Prop := PC1.
Definition HY5 : Prop := (PC1 -> E1) /\ (PC2 -> ~E2) /\ (TC1 -> ~E1) /\ (TC2 -> E2).

Lemma S5 : HY5 /\ HN2 -> PC1 /\ ~PC2.
Proof.
unfold HY5, E1, E2, HN2.
tauto.
Qed.

Definition F1 : Prop := (PC1 /\ PC2) \/ (TC1 /\ TC2).
Definition F2 : Prop := PC1.
Definition HY6 : Prop := (PC1 -> F1) /\ (PC2 -> ~F2) /\ (TC1 -> ~F1) /\ (TC2 -> F2).

Lemma S6 : HY6 /\ HN2 -> ~PC1 /\ PC2.
Proof.
unfold HY6, F1, F2, HN2.
tauto.
Qed.

Definition G1 : Prop := (PC1 /\ TC2) \/ (TC1 /\ PC2).
Definition G2 : Prop := PC1 /\ TC2.
Definition HY7 : Prop := (PC1 -> G1) /\ (PC2 -> ~G2) /\ (TC1 -> ~G1) /\ (TC2 -> G2).

Lemma S7 : HY7 /\ HN2 -> PC1 /\ ~PC2.
Proof.
unfold HY7, G1, G2, HN2.
tauto.
Qed.

Definition I1 : Prop := TC1 /\ TC2.
Definition I2 : Prop := TC2.
Definition J1 : Prop := TC1.
Definition J2 : Prop := TC1 /\ TC2.
Definition HY8 : Prop := (PC1 -> I1) /\ (PC2 -> ~I2) /\ (TC1 -> ~I1) /\ (TC2 -> I2)
                         /\ (PC1 -> J1) /\ (PC2 -> ~J2) /\ (TC1 -> ~J1) /\ (TC2 -> J2).

Lemma S8 : HY8 /\ HN2 -> ~PC1 /\ PC2.
Proof.
unfold HY8, I1, I2, J1, J2, HN2.
tauto.
Qed.

Definition K1 : Prop := TC1.
Definition K2 : Prop := PC2.
Definition K3 : Prop := TC2.
Definition HD9 : Prop := (PC1 /\ TC2 /\ TC3) \/ (PC2 /\ TC1 /\ TC3) \/ (PC3 /\ TC2 /\ TC1).
Definition HY9 : Prop := (K1 /\ ~K2 /\ ~K3) \/ (~K1 /\ K2 /\ ~K3) \/ (~K1 /\ ~K2 /\ K3).
Definition HN3 : Prop := (PC1 \/ TC1) /\ ~(PC1 /\ TC1) /\ (PC2 \/ TC2) /\ ~(PC2 /\ TC2) /\ (PC3 \/ TC3) /\ ~(PC3 /\ TC3).

Lemma S9 : HY9 /\ HN3 /\ HD9 -> PC1 /\ ~PC2 /\ ~PC3.
Proof.
unfold HY9, K1, K2, K3, HN3, HD9.
tauto.
Qed.

Definition L1 : Prop := TC2.
Definition L2 : Prop := TC2.
Definition L3 : Prop := TC1.
Definition HD10 : Prop := (PC1 /\ TC2 /\ TC3) \/ (PC2 /\ TC1 /\ TC3) \/ (PC3 /\ TC2 /\ TC1).
Definition HY10 : Prop := (PC1 -> (L1 /\ (~L2 \/ ~L3)))
                       /\ (PC2 -> (L2 /\ (~L1 \/ ~L3)))
                       /\ (PC3 -> (L3 /\ (~L2 \/ ~L1))).

Lemma S10 : HY10 /\ HN3 /\ HD10 -> PC1 /\ ~PC2 /\ ~PC3.
Proof.
unfold HY10, L1, L2, L3, HN3, HD10.
tauto.
Qed.

Definition M1 : Prop := VC3.
Definition M2 : Prop := TC1.
Definition M3 : Prop := VC3.

Definition HD11 : Prop := (PC1 /\ TC2 /\ VC3) \/ (PC1 /\ TC3 /\ VC2)
                       \/ (PC2 /\ TC1 /\ VC3) \/ (PC2 /\ TC1 /\ VC1)
                       \/ (PC3 /\ TC2 /\ VC1) \/ (PC3 /\ TC3 /\ VC2).

Definition HY11 : Prop := (PC1 -> M1) /\ (TC1 -> ~M1) /\ (VC1 -> M1 \/ ~M1)
                       /\ (PC2 -> M2) /\ (TC2 -> ~M2) /\ (VC2 -> M2 \/ ~M2)
                       /\ (PC3 -> M3) /\ (TC3 -> ~M3) /\ (VC3 -> M3 \/ ~M3).

Definition HN3V : Prop := ((PC1 /\ ~TC1 /\ ~VC1) \/ (~PC1 /\ TC1 /\ ~VC1) \/ (~PC1 /\ ~TC1 /\ VC1))
                       /\ ((PC2 /\ ~TC2 /\ ~VC2) \/ (~PC2 /\ TC2 /\ ~VC2) \/ (~PC2 /\ ~TC2 /\ VC2))
                       /\ ((PC3 /\ ~TC3 /\ ~VC3) \/ (~PC3 /\ TC3 /\ ~VC3) \/ (~PC3 /\ ~TC3 /\ VC3)).

Lemma S11 : HY11 /\ HD11 /\ HN3V -> PC1 /\ ~PC2 /\ ~PC3.
Proof.
unfold HY11, M1, M2, M3, HN3V, HD11.
tauto.
Qed.

Definition N1 : Prop := PC1 \/ PC3 \/ PC5 \/ PC7 \/ PC9.
Definition N2 : Prop := VC2.
Definition N4 : Prop := ~N1.
Definition N5 : Prop := N2 \/ N4.
Definition N7 : Prop := ~PC1.
Definition N3 : Prop := N5 \/ ~N7.
Definition N6 : Prop := ~N3.
Definition N8 : Prop := TC8 /\ VC9.
Definition N9 : Prop := TC9 /\ ~N6.

Definition HD12 : Prop := (PC1 /\ ~PC2 /\ ~PC3 /\ ~PC4 /\ ~PC5 /\ ~PC6 /\ ~PC7 /\ ~PC8 /\ ~PC9)
                       \/ (~PC1 /\ PC2 /\ ~PC3 /\ ~PC4 /\ ~PC5 /\ ~PC6 /\ ~PC7 /\ ~PC8 /\ ~PC9)
                       \/ (~PC1 /\ ~PC2 /\ PC3 /\ ~PC4 /\ ~PC5 /\ ~PC6 /\ ~PC7 /\ ~PC8 /\ ~PC9)
                       \/ (~PC1 /\ ~PC2 /\ ~PC3 /\ PC4 /\ ~PC5 /\ ~PC6 /\ ~PC7 /\ ~PC8 /\ ~PC9)
                       \/ (~PC1 /\ ~PC2 /\ ~PC3 /\ ~PC4 /\ PC5 /\ ~PC6 /\ ~PC7 /\ ~PC8 /\ ~PC9)
                       \/ (~PC1 /\ ~PC2 /\ ~PC3 /\ ~PC4 /\ ~PC5 /\ PC6 /\ ~PC7 /\ ~PC8 /\ ~PC9)
                       \/ (~PC1 /\ ~PC2 /\ ~PC3 /\ ~PC4 /\ ~PC5 /\ ~PC6 /\ PC7 /\ ~PC8 /\ ~PC9)
                       \/ (~PC1 /\ ~PC2 /\ ~PC3 /\ ~PC4 /\ ~PC5 /\ ~PC6 /\ ~PC7 /\ PC8 /\ ~PC9)
                       \/ (~PC1 /\ ~PC2 /\ ~PC3 /\ ~PC4 /\ ~PC5 /\ ~PC6 /\ ~PC7 /\ ~PC8 /\ PC9).

Definition HY12 : Prop := (PC1 -> N1) /\ (TC1 -> ~N1) /\ (VC1 -> N1 \/ ~N1)
                      /\  (PC2 -> N2) /\ (TC2 -> ~N2) /\ (VC2 -> N2 \/ ~N2)
                      /\  (PC3 -> N3) /\ (TC3 -> ~N3) /\ (VC3 -> N3 \/ ~N3)
                      /\  (PC4 -> N4) /\ (TC4 -> ~N4) /\ (VC4 -> N4 \/ ~N4)
                      /\  (PC5 -> N5) /\ (TC5 -> ~N5) /\ (VC5 -> N5 \/ ~N5)
                      /\  (PC6 -> N6) /\ (TC6 -> ~N6) /\ (VC6 -> N6 \/ ~N6)
                      /\  (PC7 -> N7) /\ (TC7 -> ~N7) /\ (VC7 -> N7 \/ ~N7)
                      /\  (PC8 -> N8) /\ (TC8 -> ~N8) /\ (VC8 -> N8 \/ ~N8)
                      /\  (PC9 -> N9) /\ (TC9 -> ~N9) /\ (VC9 -> N9 \/ ~N9).

Definition HN9 : Prop := ((PC1 /\ ~TC1 /\ ~VC1) \/ (~PC1 /\ TC1 /\ ~VC1) \/ (~PC1 /\ ~TC1 /\ VC1))
                      /\ ((PC2 /\ ~TC2 /\ ~VC2) \/ (~PC2 /\ TC2 /\ ~VC2) \/ (~PC2 /\ ~TC2 /\ VC2))
                      /\ ((PC3 /\ ~TC3 /\ ~VC3) \/ (~PC3 /\ TC3 /\ ~VC3) \/ (~PC3 /\ ~TC3 /\ VC3))
                      /\ ((PC4 /\ ~TC4 /\ ~VC4) \/ (~PC4 /\ TC4 /\ ~VC4) \/ (~PC4 /\ ~TC4 /\ VC4))
                      /\ ((PC5 /\ ~TC5 /\ ~VC5) \/ (~PC5 /\ TC5 /\ ~VC5) \/ (~PC5 /\ ~TC5 /\ VC5))
                      /\ ((PC6 /\ ~TC6 /\ ~VC6) \/ (~PC6 /\ TC6 /\ ~VC6) \/ (~PC6 /\ ~TC6 /\ VC6))
                      /\ ((PC7 /\ ~TC7 /\ ~VC7) \/ (~PC7 /\ TC7 /\ ~VC7) \/ (~PC7 /\ ~TC7 /\ VC7))
                      /\ ((PC8 /\ ~TC8 /\ ~VC8) \/ (~PC8 /\ TC8 /\ ~VC8) \/ (~PC8 /\ ~TC8 /\ VC8))
                      /\ ((PC9 /\ ~TC9 /\ ~VC9) \/ (~PC9 /\ TC9 /\ ~VC9) \/ (~PC9 /\ ~TC9 /\ VC9)).

Lemma S12 : HY12 /\ HD12 /\ HN9 /\ ~VC8 -> ~PC1 /\ ~PC2 /\ ~PC3 /\ ~PC4 /\ ~PC5 /\ ~PC6 /\ PC7 /\ ~PC8 /\ ~PC9.
Proof.
unfold HY12, N9, N8, N6, N3, N7, N5, N4, N2, N1, HD12, HN9.
Timeout 10 tauto.


Require Import Lia.
Definition dec P := {P} + {~P}.
Definition EQ X := forall x y : X, {x = y} + {x <> y}.

Fixpoint fin n : Type :=
  match n with
    0 => False
  | S n' => option (fin n')
  end.

Fact EQ_option X :
  EQ X -> EQ (option X).
Proof. intros H [x|][y|]; decide equality. Defined.

Fact EQ_fin n : EQ (fin n).
Proof. induction n. {intros []. } now apply EQ_option. Defined.

Fact dec_exists {n} (p: fin n -> Prop) :
  (forall x, dec (p x)) ->  {x & p x} + (forall x, ~p x).
Proof.
  intros D. induction n as [|n IH]; auto.
  destruct (IH (fun x => p(Some x)) ltac:(firstorder)) as [[]|]; eauto.
  destruct (D None); eauto.
  right; intros []; auto.
Defined.

Definition r {X Y} (f : option X -> option (option Y)) x :=
  match f None, f(Some x) with
  | None    , None    => None
  | Some y0 , None    => y0
  | _       , Some y  => y
  end.

Lemma r_agree {X Y} f x x' (H : forall x, f(Some x) <> f None) :
let r := @r X Y f in
  r x = r x' -> f(Some x) = f(Some x').
Proof.
  unfold r.
  destruct  (f (Some x)) eqn:?,
            (f (Some x')) eqn:?,
            (f None) eqn:?; congruence.
Qed.

Fact trivial_Pigeonhole M (f : fin (S M) -> fin 1) :
  S M > 1 -> {a &{ b & a <> b /\ f a = f b}}.
Proof.
  intros ?. destruct M; try lia.
  exists None, (Some None).
  split; try congruence.
  now destruct (f None) as [[]|],
        (f (Some None)) as [[]|].
Qed.

Lemma Pigeonhole M N (f : fin M -> fin N) :
  M > N -> {a &{ b & a <> b /\ f a = f b}}.
Proof.
  revert M f. induction N.
  all: intros [|M] f MN; try lia.
  { destruct (f None). }
  destruct N as [|N].
  { now apply trivial_Pigeonhole. }
  destruct (dec_exists (fun x => f(Some x) = f None)) as [[x ]|H].
  { intros ?; apply EQ_fin. }
  - exists (Some x), None. split; congruence.
  - destruct (IHN M (r f) ltac:(lia)) as (x & x' &[]).
    exists (Some x), (Some x').
    split; try congruence.
    eapply r_agree; eauto.
Defined.


(** * INITIATION A COQ *)

(* TP 2 - Lilian Soler *)

(**
Le début de ce fichier a été présenté en cours.
Il est demandé de le réviser à la maison et de le terminer
en préparation du TD suivant.
- Lire attentivement les commentaires explicatifs
- sous emacs/Proof-general,
  - pour avancer d'une étape, faire C-c C-n
  - pour reculer, C-c C-p
  - pour aller d'un coup à la position du curseur, C-c RET.
  D'autres raccourcis sont disponibles, regarder les menus Proof-General et Coq.
*)

(** ** Généralités *)

(** Coq est primitivement un langage de programmation particulier.
    Comme OCaml, c'est un langage fonctionnel typé.
    Son système de types est beaucoup plus riche que celui de OCaml,
    ce qui permet en particulier d'énoncer des formules logiques,
    et éventuellement de les démontrer.

    Dans un premier temps, on se focalise sur l'aspect programmation,
    et les formules logiques considérées sont de simples égalités.
 *)

(** Un script Coq est une suite de déclarations de types, de valeurs,
    (très souvent : des fonctions), d'énoncés de théorèmes suivis
    de leur preuve.

    On a également des requêtes pour obtenir des informations,
    calculer des expressions.
*)

(** À RETENIR : EN COQ, TOUT FINIT PAR UN POINT '.' *)

(** ** Types énumérés *)

(** Le type qui s'écrirait en OCaml
type coulfeu =
  | Vert
  | Orange
  | Rouge

se définit en Coq presque de la même façon.
*)

Inductive coulfeu : Set :=
  | Vert : coulfeu
  | Orange : coulfeu
  | Rouge : coulfeu
.

(** Comme en OCaml, [blabla : machin] se lit "[blabla] a pour type [machin]".
    Ainsi la déclaration précédente indique que [Vert], [Orange] et [Rouge]
    sont de type coulfeu.
    Par ailleurs, en Coq tout a un type ; la déclaration ci-dessus indique que
    le type de [coulfeu] est [Set], cf. notes de cours.
*)

(** ** Définition d'une valeur fonctionnelle *)

Definition coul_suiv : coulfeu -> coulfeu :=
  fun c =>
    match c with
    | Vert => Orange
    | Orange => Rouge
    | Rouge => Vert
    end.

(** La commande Check permet d'obtenir le type d'une expression.
    Elle vérifie que l'expression est bien typée. *)

Check coul_suiv.
Check (coul_suiv Vert).

(** La commande Eval permet de calculer une expression. *)

Eval compute in (coul_suiv Vert).

(** Raccourci *)
Compute (coul_suiv Vert).

(** ** Premier théorème, tactiques cbn et reflexivity *)

Theorem ex1_coul_suiv : coul_suiv (coul_suiv Vert) = Rouge.
Proof. cbn [coul_suiv]. reflexivity. Qed. (** cbn = call by name *)

(** Remarque : on peut énoncer une théorème à prouver au moyen d'autres
mots-clé, notamment Lemma (pour un résultat auxiliaire) ou Example
(pour un théorème très simple servant à tester le résultat d'une fonction
sur une entrée particulière.
Ces mots-clé sont équivalents, le choix de l'un ou l'autre est affaire de
convention ou d'usage.
Ici on aurait donc plutôt utilisé  Example.
Example ex1_coul_suiv : coul_suiv (coul_suiv Vert) = Rouge.
*)

(** Une *tactique* est une commande permettant de faire progresser une preuve *)

(** On a utilisé ci-dessus les tactiques suivantes :
    - cbn [nom_de_fonction] : évaluation (partielle) de [nom_de_fonction]
    - reflexivity : reconnaissance que les deux membres de l'égalité
                    à prouver sont identiques (preuve de x = x).
 *)

(** ATTENTION À BIEN TERMINER PAR "Qed." *)

(** ** Variables *)

(** Les preuves par réflexivité fonctionnent non seulement
    entre des expressions constantes identiques, mais aussi
    entre des expressions comportant des variables. *)

(** On a la possibilité en Coq (mais pas en OCaml) de déclarer
    des variables :
    ce sont des noms dont on connaît simplement le type.
    Il faut que ces noms soient déclarés dans une portée
    (domaine de visibilité) définie par une section.
*)

(** Ouverture d'une section dans laquelle on va faire quelques
    preuves par réflexivité. *)

Section sec_refl.
  Variable c : coulfeu.
  (** Signification intuitive : "soit [c] une [coulfeu] inconnue". *)

  Theorem th1_refl_simple : c = c.
  (** Remarquer que le but contient un environnement comportant
      l'hypothèse [c : coulfeu]. *)
  Proof. reflexivity. Qed.

  Check c.

(** Fermeture de la section,
    ce qui clôt la portée des variables, ici [c : coulfeu]. *)
End sec_refl.

Fail Check c.
Fail Definition x := Vert + 2.

(* -------------------------------------------------------------------  *)
(** Vu jusqu'ici dans ls CM1 2020, en fait juste avant le End sec_refl. *)
(* -------------------------------------------------------------------  *)

(** ** Principe de Leibniz : tactique rewrite *)

Section sec_reec.
  Variable c : coulfeu.
  Hypothesis crou : c = Rouge.
  (** Signification intuitive, par analogie avec la ligne d'avant :
      "soit [crou] une preuve inconnue de [c = Rouge]". *)

  Theorem coul_suiv_Rouge : coul_suiv c = Vert.
  Proof.
    rewrite crou.
    cbn [coul_suiv].
    reflexivity.
  Qed.

End sec_reec.

(** ** Raisonnement par cas : tactique destruct *)

Section sec_cas.
  Variable c : coulfeu.

  Theorem th3_coul_suiv : coul_suiv (coul_suiv (coul_suiv c)) = c.
  Proof.
    (** reflexivity ne fonctionne pas. *)
    Fail reflexivity.
    (** Il faut raisonner par cas sur les trois valeurs de [c] possibles *)
    (** Cela va donner lieu à trois sous-buts, un pour chaque cas. *)
    destruct c as [ (*Vert*) | (*Orange*) | (*Rouge*) ].
    - cbn [coul_suiv]. reflexivity.
    - cbn. reflexivity.
    - reflexivity.
  Qed.

  Print Vert.
  Print th3_coul_suiv.

End sec_cas.

(** ** Raisonnement universel : tactique intro *)

(** Il est possible d'énoncer des formules quantifiées universellement.
    Par exemple : [forall c : coulfeu, c = c].
 *)

Theorem th_refl_gen : forall c : coulfeu, c = c.
Proof.
  (** Pour la démontrer, la première étape consiste à dire
      "soit [c0] une couleur arbitraire, démontrons [c0 = c0]." *)
  intro c0.
  (** Remarquer que intro a introduit l'hypothèse [c0 : coulfeu]. *)
  (** On a déjà vu que reflexivity fonctionne dans cette situation. *)
  reflexivity.
Qed.

(** La tactique intro sert également à démontrer une implication. *)
Theorem th_crou_gen : forall c : coulfeu, c = Rouge -> coul_suiv c = Vert.
Proof.
  intro c0.
  (** Pour démontrer [c0 = Rouge -> coul_suiv c0 = Vert],
      on suppose [c0 = Rouge]
      et on doit alors prouver [coul_suiv c0 = Vert]
      sous cette hypothèse supplémentaire ;
      lorsque l'on introduit une hypothèse, on lui donne un nom. *)
  intro c0rou.
  (** Le raisonnement sous-jacent est :
      soit c0rou une preuve arbitraire (inconnue) de [c0 = Rouge],
      on peut s'en servir pour démontrer coul_suiv [c0 = Vert]. *)
  rewrite c0rou. cbn [coul_suiv]. reflexivity.
Qed.

(** Remarque : on est souvent amené à effectuer plusieurs introductions
    successives. On emploie alors le raccourci intros (au pluriel).
    Sur l'exemple précédent cela donne ceci : *)
Theorem th_crou_gen_bis : forall c : coulfeu, c = Rouge -> coul_suiv c = Vert.
Proof.
  intros c0 c0rou.
  rewrite c0rou. cbn [coul_suiv]. reflexivity.
Qed.

(** * Début du travail à faire à la maison *)

(** *** Exercice: Variante du précédent avec section *)

Section sec_variante_th_crou_gen.
  Variable c : coulfeu.
  Hypothesis crou : c = Rouge.
  Theorem th_crou_demi_gen : c = Rouge -> coul_suiv c = Vert.
  Proof.
    rewrite crou.
    cbn [coul_suiv].
    reflexivity.
  Qed.
    (** à compléter *)

  (* Quand une démonstration est incomplète, on peut passer à la suite
   * à l'aide de Admitted  au lieu de Qed.
   * Ne pas oublier de remplacer Admitted par Qed quand on a réussi ! *)

End sec_variante_th_crou_gen.

(** *** Exercice: Preuve par cas d'un théorème avec forall *)

Lemma suivsuivsuiv_id : forall c:coulfeu, coul_suiv (coul_suiv (coul_suiv c))=c.
Proof.
  intros c.
  destruct c as [ (*Vert*) | (*Orange*) | (*Rouge*) ].
  - cbn [coul_suiv]. reflexivity.
  - cbn [coul_suiv]. reflexivity.
  - cbn [coul_suiv]. reflexivity.
Qed.
(** à compléter ici *)

(** ** Type inductif et récurrence structurelle : arbres binaires tricolores *)

Inductive arbin : Set :=
  | F : coulfeu -> arbin
  | N : arbin -> arbin -> arbin.

(**
Pour définir une fonction récursive (l'équivalent de let rec
en OCaml) on utilise le mot clé [Fixpoint].
 *)

Fixpoint renva a : arbin :=
  match a with
  | F c => F c
  | N g d => N (renva d) (renva g)
  end.

(** *** Exercice: prouver que renverser deux fois un arbre rend le même arbre *)
Theorem renva_renva : forall a, renva (renva a) = a.
Proof.
  intro a.
  (** Tentative de raisonnement par cas sur a *)
  (** Les noms mis dans chaque cas (c pour le premier, a2 a2 pour le second)
      désignent les composantes des constructeurs respectivement F puis N *)
  destruct a as [ (* F *) c
                | (* N *) a1 a2 ].
  - cbn [renva]. reflexivity.
  - cbn [renva].
    (** Il apparaît qu'un simple raisonnement par cas est insuffisant, *)
    (** donc on arrete tout... *)
 Abort.

(** ... et on recommence en raisonnant par récurrence structurelle *)
Theorem renva_renva : forall a, renva (renva a) = a.
Proof.
  intro a.
  (** récurrence structurelle sur le type inductif arbin *)
  (** Remarquer l'analogie avec l'utilisation de la tactique destruct :
      les noms mis dans chaque cas (c pour le premier, a2 a2 pour le second)
      désignent les composantes des constructeurs respectivement F puis N
      mais en complément, on ajoute deux noms pour les hypothèses de récurrence,
       Hrec_a1 pour celle sur a1 et Hrec_a2 pour celle sur a2 *)
  induction a as [ (* F *) c
                 | (* N *) a1 Hrec_a1 a2 Hrec_a2 ].
  - cbn [renva]. reflexivity.
  - cbn [renva]. rewrite Hrec_a2. rewrite Hrec_a1. reflexivity.
    (* à compléter *)
Qed.

(** Fin du travail à faire à la maison. *)


Require Export GeoCoq.Elements.OriginalProofs.proposition_37.

Section Euclid.

Context `{Ax:area}.

Lemma proposition_41 :
   forall A B C D E,
   PG A B C D -> Col A D E ->
   ET A B C E B C.
Proof.
intros.
assert (Par A B C D) by (conclude_def PG ).
assert (nCol A B C) by (forward_using lemma_parallelNC).
assert (Triangle A B C) by (conclude_def Triangle ).
assert (ET A B C E B C).
by cases on (eq A E \/ neq A E).
{
 assert (ET A B C A B C) by (conclude lemma_ETreflexive).
 assert (ET A B C E B C) by (conclude cn_equalitysub).
 close.
 }
{
 assert (Par A D B C) by (conclude_def PG ).
 assert (Col D A E) by (forward_using lemma_collinearorder).
 assert (Par B C A D) by (conclude lemma_parallelsymmetric).
 assert (Par B C D A) by (forward_using lemma_parallelflip).
 assert (neq E A) by (conclude lemma_inequalitysymmetric).
 assert (Par B C E A) by (conclude lemma_collinearparallel).
 assert (Par B C A E) by (forward_using lemma_parallelflip).
 assert (Par A E B C) by (conclude lemma_parallelsymmetric).
 assert (ET A B C E B C) by (conclude proposition_37).
 close.
 }
(** cases *)
close.
Qed.

End Euclid.


(** * Etude de cas : sémantiques opérationnelles *)

Require Import ZArith.

Open Scope Z_scope.

Inductive ArithExpr : Set :=
| aval : Z -> ArithExpr
| aplus : ArithExpr -> ArithExpr -> ArithExpr
| atimes: ArithExpr -> ArithExpr -> ArithExpr.

(** ** Exercice 1 : sémantique à grands pas *)

Inductive BigSem : ArithExpr -> Z -> Set :=
| aval_big: forall n : Z, BigSem (aval n) n
| aplus_big: forall a1 a2 : ArithExpr, forall v1 v2 : Z,
        BigSem a1 v1 -> BigSem a2 v2
        -> BigSem (aplus a1 a2) (v1 + v2)
| atimes_big: forall a1 a2 : ArithExpr, forall v1 v2 : Z,
        BigSem a1 v1 -> BigSem a2 v2
        -> BigSem (atimes a1 a2) (v1 * v2).

Check BigSem_ind.

(* <<<REPONDRE ICI>>> *)

(** *** Question 2 *)

Example big_ex1:
  BigSem (atimes (aplus (aval 2) (aval 3)) (aval 5))
         (* ==> *) 25.
Proof.
change (BigSem (atimes (aplus (aval 2) (aval 3)) (aval 5)) (5 * 5)) .
apply atimes_big.
- change (BigSem (aplus (aval 2) (aval 3)) (2 + 3)).
  apply aplus_big.
    + apply aval_big.
    + apply aval_big.
- apply aval_big.
Qed.

(** *** Question 3 *)

Theorem BigSem_determinist:
  forall a : ArithExpr, forall v1 v2 : Z,
    BigSem a v1
    -> BigSem a v2
    -> v1 = v2.
Proof.
intros a v1 v2 BS1 BS2.
inversion BS1.
-   inversion BS2.
    + rewrite <- H in H1.
      inversion H1.
      rewrite H4 in H2.
      rewrite H0 in H2.
      exact H2.
    + inversion H1.
      * inversion H2.
      { - inversion H3.
          + }
exact H4.
Qed.

(** ** Exercice 2 : sémantique à petits pas *)

Inductive SmallSem: ArithExpr -> ArithExpr -> Prop :=
| aplusl_small: forall a1 a1' a2: ArithExpr,
                  SmallSem a1 (* --> *) a1'
                  (*------------------------------------------*)
                  -> SmallSem (aplus a1 a2) (aplus a1' a2)
| aplusr_small: forall a1 a2 a2' : ArithExpr,
                  SmallSem a2 (* --> *) a2'
                  (*------------------------------------------*)
                  -> SmallSem (aplus a1 a2) (aplus a1 a2')
| aplusv_small: forall v1 v2 : Z,
                  (*----------------------------------------------------*)
                  SmallSem (aplus (aval v1) (aval v2)) (aval (v1 + v2)).

(** *** Question 1 *)

(* <<< Répondre sur papier >>> *)

(** *** Question 2 *)

(* <<< Répondre sur paper et ci-dessus >>> *)

(** *** Question 3 *)

Inductive value: ArithExpr -> Prop :=
| const_value: forall n, value (aval n).

Theorem Strong_Progress:
  forall a: ArithExpr,
    value a \/ exists a' : ArithExpr, SmallSem a a'.
Proof.
  (* <<< COMPLETER ICI >>> *)

(** ** Exercice 3 : formes normales *)

Definition NormalForm (a : ArithExpr) : Prop :=
  not (exists a' : ArithExpr, SmallSem a a').

(** *** Question 1 *)

Lemma value_is_NF:
  forall a : ArithExpr,
    value a -> NormalForm a.
Proof.
  (* <<< COMPLETER ICI >>> *)

Lemma NF_is_value:
  forall a : ArithExpr,
    NormalForm a -> value a.
Proof.
  (* <<< COMPLETER ICI >>> *)

(** *** Question 2 *)

(* <<< REPONDRE ICI >>> *)

(** *** Question 3 *)

Lemma Reduce_refl: forall a : ArithExpr,
  Reduce a a.
Proof.
  (* <<< COMPLETER ICI >>> *)

Lemma Reduce_Small: forall a a' : ArithExpr,
  SmallSem a a' -> Reduce a a'.
Proof.
  (* <<< COMPLETER ICI >>> *)

(** *** Question 4 *)

Lemma Reduce_trans: forall a a' a'' : ArithExpr,
  Reduce a a' -> Reduce a' a'' -> Reduce a a''.
Proof.
  (* <<< COMPLETER ICI >>> *)

(** ** Exercice 4 : correspondance des sémantiques  *)

(** *** Question 1 *)

Lemma Reduce_plus_congl: forall a1 a2 a1' : ArithExpr,
  Reduce a1 a1'
  -> Reduce (aplus a1 a2) (aplus a1' a2).
Proof.
  (* <<< COMPLETER ICI >>> *)

Lemma Reduce_plus_congr: forall a1 a2 a2' : ArithExpr,
  Reduce a2 a2'
  -> Reduce (aplus a1 a2) (aplus a1 a2').
Proof.
  (* <<< COMPLETER ICI >>> *)

Lemma Reduce_plus_congv:
  forall n1 n2 : Z, forall a1 a2 : ArithExpr,
    Reduce a1 (aval n1)
    -> Reduce a2 (aval n2)
    -> Reduce (aplus a1 a2) (aval (n1+n2)).
Proof.
  (* <<< COMPLETER ICI >>> *)

(** *** Question 2 *)

Lemma Reduce_times_congl: forall a1 a2 a1' : ArithExpr,
  Reduce a1 a1'
  -> Reduce (atimes a1 a2) (atimes a1' a2).
Proof.
    (* <<< COMPLETER ICI >>> *)

Lemma Reduce_times_congr: forall a1 a2 a2' : ArithExpr,
  Reduce a2 a2'
  -> Reduce (atimes a1 a2) (atimes a1 a2').
Proof.
    (* <<< COMPLETER ICI >>> *)

Lemma Reduce_times_congv:
  forall n1 n2 : Z, forall a1 a2 : ArithExpr,
    Reduce a1 (aval n1)
    -> Reduce a2 (aval n2)
    -> Reduce (atimes a1 a2) (aval (n1 * n2)).
Proof.
    (* <<< COMPLETER ICI >>> *)

(** *** Question 3 *)

Lemma Big_implies_Small:
  forall a : ArithExpr, forall v : Z,
    BigSem a v -> Reduce a (aval v).
Proof.
    (* <<< COMPLETER ICI >>> *)

(** *** Question 4 *)

Lemma Small1_Big_implies_Big_plus:
  forall a a' : ArithExpr, forall v : Z,
    SmallSem a a'
    -> BigSem a' v
    -> BigSem a v.
Proof.
    (* <<< COMPLETER ICI >>> *)

(** *** Question 5 *)

Lemma SmallNF_implies_Big:
  forall a a': ArithExpr,
    Reduce a a'
    -> NormalForm a'
    -> (exists v : Z, (a' = aval v)  /\ (BigSem a v)).
Proof.
  (* <<< COMPLETER ICI >>> *)

(** *** Question 6 *)

Lemma Small_implies_Big:
  forall a : ArithExpr, forall v : Z,
    Reduce a (aval v)
    -> BigSem a v.
Proof.
  (* <<< COMPLETER ICI >>> *)

(** *** Question 7 *)

Theorem Small_equiv_Big:
  forall a : ArithExpr, forall v : Z,
    Reduce a (aval v) <-> BigSem a v.
Proof.
    (* <<< COMPLETER ICI >>> *)