(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Finite sets library *)

(** This functor derives additional properties from [MSetInterface.S].
    Contrary to the functor in [MSetEqProperties] it uses
    predicates over sets instead of sets operations, i.e.
    [In x s] instead of [mem x s=true],
    [Equal s s'] instead of [equal s s'=true], etc. *)

Require Export MSetInterface.
Require Import DecidableTypeEx OrdersLists MSetFacts MSetDecide.
Set Implicit Arguments.
Unset Strict Implicit.

Hint Unfold transpose.

(** First, a functor for Weak Sets in functorial version. *)

Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E).
  Module Import Dec := WDecideOn E M.
  Module Import FM := Dec.F (* MSetFacts.WFactsOn E M *).
  Import M.

  Lemma In_dec : forall x s, {In x s} + {~ In x s}.
  Proof.
  intros; generalize (mem_iff s x); case (mem x s); intuition.
  Qed.

  Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s.

  Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s.
  Proof.
  unfold Add.
  split; intros.
  red; intros.
  rewrite H; clear H.
  fsetdec.
  fsetdec.
  Qed.

  Ltac expAdd := repeat rewrite Add_Equal.

  Section BasicProperties.

  Variable s s' s'' s1 s2 s3 : t.
  Variable x x' : elt.

  Lemma equal_refl : s[=]s.
  Proof. fsetdec. Qed.

  Lemma equal_sym : s[=]s' -> s'[=]s.
  Proof. fsetdec. Qed.

  Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
  Proof. fsetdec. Qed.

  Lemma subset_refl : s[<=]s.
  Proof. fsetdec. Qed.

  Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
  Proof. fsetdec. Qed.

  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
  Proof. fsetdec. Qed.

  Lemma subset_equal : s[=]s' -> s[<=]s'.
  Proof. fsetdec. Qed.

  Lemma subset_empty : empty[<=]s.
  Proof. fsetdec. Qed.

  Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
  Proof. fsetdec. Qed.

  Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
  Proof. fsetdec. Qed.

  Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
  Proof. fsetdec. Qed.

  Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
  Proof. fsetdec. Qed.

  Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
  Proof. fsetdec. Qed.

  Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
  Proof. intuition fsetdec. Qed.

  Lemma empty_is_empty_1 : Empty s -> s[=]empty.
  Proof. fsetdec. Qed.

  Lemma empty_is_empty_2 : s[=]empty -> Empty s.
  Proof. fsetdec. Qed.

  Lemma add_equal : In x s -> add x s [=] s.
  Proof. fsetdec. Qed.

  Lemma add_add : add x (add x' s) [=] add x' (add x s).
  Proof. fsetdec. Qed.

  Lemma remove_equal : ~ In x s -> remove x s [=] s.
  Proof. fsetdec. Qed.

  Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
  Proof. fsetdec. Qed.

  Lemma add_remove : In x s -> add x (remove x s) [=] s.
  Proof. fsetdec. Qed.

  Lemma remove_add : ~In x s -> remove x (add x s) [=] s.
  Proof. fsetdec. Qed.

  Lemma singleton_equal_add : singleton x [=] add x empty.
  Proof. fsetdec. Qed.

  Lemma remove_singleton_empty :
   In x s -> remove x s [=] empty -> singleton x [=] s.
  Proof. fsetdec. Qed.

  Lemma union_sym : union s s' [=] union s' s.
  Proof. fsetdec. Qed.

  Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
  Proof. fsetdec. Qed.

  Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
  Proof. fsetdec. Qed.

  Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
  Proof. fsetdec. Qed.

  Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
  Proof. fsetdec. Qed.

  Lemma add_union_singleton : add x s [=] union (singleton x) s.
  Proof. fsetdec. Qed.

  Lemma union_add : union (add x s) s' [=] add x (union s s').
  Proof. fsetdec. Qed.

  Lemma union_remove_add_1 :
   union (remove x s) (add x s') [=] union (add x s) (remove x s').
  Proof. fsetdec. Qed.

  Lemma union_remove_add_2 : In x s ->
   union (remove x s) (add x s') [=] union s s'.
  Proof. fsetdec. Qed.

  Lemma union_subset_1 : s [<=] union s s'.
  Proof. fsetdec. Qed.

  Lemma union_subset_2 : s' [<=] union s s'.
  Proof. fsetdec. Qed.

  Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
  Proof. fsetdec. Qed.

  Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
  Proof. fsetdec. Qed.

  Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
  Proof. fsetdec. Qed.

  Lemma empty_union_1 : Empty s -> union s s' [=] s'.
  Proof. fsetdec. Qed.

  Lemma empty_union_2 : Empty s -> union s' s [=] s'.
  Proof. fsetdec. Qed.

  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s').
  Proof. fsetdec. Qed.

  Lemma inter_sym : inter s s' [=] inter s' s.
  Proof. fsetdec. Qed.

  Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s.
  Proof. fsetdec. Qed.

  Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
  Proof. fsetdec. Qed.

  Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
  Proof. fsetdec. Qed.

  Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
  Proof. fsetdec. Qed.

  Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s'').
  Proof. fsetdec. Qed.

  Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s'').
  Proof. fsetdec. Qed.

  Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s').
  Proof. fsetdec. Qed.

  Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'.
  Proof. fsetdec. Qed.

  Lemma empty_inter_1 : Empty s -> Empty (inter s s').
  Proof. fsetdec. Qed.

  Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
  Proof. fsetdec. Qed.

  Lemma inter_subset_1 : inter s s' [<=] s.
  Proof. fsetdec. Qed.

  Lemma inter_subset_2 : inter s s' [<=] s'.
  Proof. fsetdec. Qed.

  Lemma inter_subset_3 :
   s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
  Proof. fsetdec. Qed.

  Lemma empty_diff_1 : Empty s -> Empty (diff s s').
  Proof. fsetdec. Qed.

  Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
  Proof. fsetdec. Qed.

  Lemma diff_subset : diff s s' [<=] s.
  Proof. fsetdec. Qed.

  Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty.
  Proof. fsetdec. Qed.

  Lemma remove_diff_singleton :
   remove x s [=] diff s (singleton x).
  Proof. fsetdec. Qed.

  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty.
  Proof. fsetdec. Qed.

  Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
  Proof. fsetdec. Qed.

  Lemma Add_add : Add x s (add x s).
  Proof. expAdd; fsetdec. Qed.

  Lemma Add_remove : In x s -> Add x (remove x s) s.
  Proof. expAdd; fsetdec. Qed.

  Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
  Proof. expAdd; fsetdec. Qed.

  Lemma inter_Add :
   In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
  Proof. expAdd; fsetdec. Qed.

  Lemma union_Equal :
   In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
  Proof. expAdd; fsetdec. Qed.

  Lemma inter_Add_2 :
   ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
  Proof. expAdd; fsetdec. Qed.

  End BasicProperties.

  Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set.
  Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym
    subset_trans subset_empty subset_remove_3 subset_diff subset_add_3
    subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal
    remove_equal singleton_equal_add union_subset_equal union_equal_1
    union_equal_2 union_assoc add_union_singleton union_add union_subset_1
    union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2
    inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2
    empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1
    empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union
    inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal
    remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
    Equal_remove add_add : set.

  (** * Properties of elements *)

  Lemma elements_Empty : forall s, Empty s <-> elements s = nil.
  Proof.
  intros.
  unfold Empty.
  split; intros.
  assert (forall a, ~ List.In a (elements s)).
   red; intros.
   apply (H a).
   rewrite elements_iff.
   rewrite InA_alt; exists a; auto with relations.
  destruct (elements s); auto.
  elim (H0 e); simpl; auto.
  red; intros.
  rewrite elements_iff in H0.
  rewrite InA_alt in H0; destruct H0.
  rewrite H in H0; destruct H0 as (_,H0); inversion H0.
  Qed.

  Lemma elements_empty : elements empty = nil.
  Proof.
  rewrite <-elements_Empty; auto with set.
  Qed.

  (** * Conversions between lists and sets *)

  Definition of_list (l : list elt) := List.fold_right add empty l.

  Definition to_list := elements.

  Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l.
  Proof.
  induction l; simpl; intro x.
  rewrite empty_iff, InA_nil. intuition.
  rewrite add_iff, InA_cons, IHl. intuition.
  Qed.

  Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l.
  Proof.
  unfold to_list; red; intros.
  rewrite <- elements_iff; apply of_list_1.
  Qed.

  Lemma of_list_3 : forall s, of_list (to_list s) [=] s.
  Proof.
  unfold to_list; red; intros.
  rewrite of_list_1; symmetry; apply elements_iff.
  Qed.

  (** * Fold *)

  Section Fold.

  Notation NoDup := (NoDupA E.eq).
  Notation InA := (InA E.eq).

  (** Alternative specification via [fold_right] *)

  Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) :
    fold f s i = List.fold_right f i (rev (elements s)).
  Proof.
   rewrite fold_spec. symmetry. apply fold_left_rev_right.
  Qed.

  (** ** Induction principles for fold (contributed by S. Lescuyer) *)

  (** In the following lemma, the step hypothesis is deliberately restricted
      to the precise set s we are considering. *)

  Theorem fold_rec :
    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
     (forall s', Empty s' -> P s' i) ->
     (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' ->
       P s' a -> P s'' (f x a)) ->
     P s (fold f s i).
  Proof.
  intros A P f i s Pempty Pstep.
  rewrite fold_spec_right. set (l:=rev (elements s)).
  assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' ->
           P s' a -> P s'' (f x a)).
   intros; eapply Pstep; eauto.
   rewrite elements_iff, <- InA_rev; auto with *.
  assert (Hdup : NoDup l) by
    (unfold l; eauto using elements_3w, NoDupA_rev with *).
  assert (Hsame : forall x, In x s <-> InA x l) by
    (unfold l; intros; rewrite elements_iff, InA_rev; intuition).
  clear Pstep; clearbody l; revert s Hsame; induction l.
  (* empty *)
  intros s Hsame; simpl.
  apply Pempty. intro x. rewrite Hsame, InA_nil; intuition.
  (* step *)
  intros s Hsame; simpl.
  apply Pstep' with (of_list l); auto with relations.
   inversion_clear Hdup; rewrite of_list_1; auto.
   red. intros. rewrite Hsame, of_list_1, InA_cons; intuition.
  apply IHl.
   intros; eapply Pstep'; eauto.
   inversion_clear Hdup; auto.
   exact (of_list_1 l).
  Qed.

  (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this
      case, [P] must be compatible with equality of sets *)

  Theorem fold_rec_bis :
    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
     (forall s s' a, s[=]s' -> P s a -> P s' a) ->
     (P empty i) ->
     (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) ->
     P s (fold f s i).
  Proof.
  intros A P f i s Pmorphism Pempty Pstep.
  apply fold_rec; intros.
  apply Pmorphism with empty; auto with set.
  rewrite Add_Equal in H1; auto with set.
  apply Pmorphism with (add x s'); auto with set.
  Qed.

  Lemma fold_rec_nodep :
    forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t),
     P i -> (forall x a, In x s -> P a -> P (f x a)) ->
     P (fold f s i).
  Proof.
  intros; apply fold_rec_bis with (P:=fun _ => P); auto.
  Qed.

  (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] :
      the step hypothesis must here be applicable to any [x].
      At the same time, it looks more like an induction principle,
      and hence can be easier to use. *)

  Lemma fold_rec_weak :
    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A),
    (forall s s' a, s[=]s' -> P s a -> P s' a) ->
    P empty i ->
    (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) ->
    forall s, P s (fold f s i).
  Proof.
  intros; apply fold_rec_bis; auto.
  Qed.

  Lemma fold_rel :
    forall (A B:Type)(R : A -> B -> Type)
     (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t),
     R i j ->
     (forall x a b, In x s -> R a b -> R (f x a) (g x b)) ->
     R (fold f s i) (fold g s j).
  Proof.
  intros A B R f g i j s Rempty Rstep.
  rewrite 2 fold_spec_right. set (l:=rev (elements s)).
  assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by
    (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *).
  clearbody l; clear Rstep s.
  induction l; simpl; auto with relations.
  Qed.

  (** From the induction principle on [fold], we can deduce some general
      induction principles on sets. *)

  Lemma set_induction :
   forall P : t -> Type,
   (forall s, Empty s -> P s) ->
   (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') ->
   forall s, P s.
  Proof.
  intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
  Qed.

  Lemma set_induction_bis :
   forall P : t -> Type,
   (forall s s', s [=] s' -> P s -> P s') ->
   P empty ->
   (forall x s, ~In x s -> P s -> P (add x s)) ->
   forall s, P s.
  Proof.
  intros.
  apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
  Qed.

  (** [fold] can be used to reconstruct the same initial set. *)

  Lemma fold_identity : forall s, fold add s empty [=] s.
  Proof.
  intros.
  apply fold_rec with (P:=fun s acc => acc[=]s); auto with set.
  intros. rewrite H2; rewrite Add_Equal in H1; auto with set.
  Qed.

  (** ** Alternative (weaker) specifications for [fold] *)

  (** When [MSets] was first designed, the order in which Ocaml's [Set.fold]
      takes the set elements was unspecified. This specification reflects
      this fact:
  *)

  Lemma fold_0 :
      forall s (A : Type) (i : A) (f : elt -> A -> A),
      exists l : list elt,
        NoDup l /\
        (forall x : elt, In x s <-> InA x l) /\
        fold f s i = fold_right f i l.
  Proof.
  intros; exists (rev (elements s)); split.
  apply NoDupA_rev; auto with *.
  split; intros.
  rewrite elements_iff; do 2 rewrite InA_alt.
  split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition.
  apply fold_spec_right.
  Qed.

  (** An alternate (and previous) specification for [fold] was based on
      the recursive structure of a set. It is now lemmas [fold_1] and
      [fold_2]. *)

  Lemma fold_1 :
   forall s (A : Type) (eqA : A -> A -> Prop)
     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
   Empty s -> eqA (fold f s i) i.
  Proof.
  unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))).
  rewrite H3; clear H3.
  generalize H H2; clear H H2; case l; simpl; intros.
  reflexivity.
  elim (H e).
  elim (H2 e); intuition.
  Qed.

  Lemma fold_2 :
   forall s s' x (A : Type) (eqA : A -> A -> Prop)
     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
   Proper (E.eq==>eqA==>eqA) f ->
   transpose eqA f ->
   ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
  Proof.
  intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2)));
    destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
  rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto.
  eauto with *.
  rewrite <- Hl1; auto.
  intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1;
   rewrite (H2 a); intuition.
  Qed.

  (** In fact, [fold] on empty sets is more than equivalent to
      the initial element, it is Leibniz-equal to it. *)

  Lemma fold_1b :
   forall s (A : Type)(i : A) (f : elt -> A -> A),
   Empty s -> (fold f s i) = i.
  Proof.
  intros.
  rewrite FM.fold_1.
  rewrite elements_Empty in H; rewrite H; simpl; auto.
  Qed.

  Section Fold_More.

  Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
  Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f).

  Lemma fold_commutes : forall i s x,
   eqA (fold f s (f x i)) (f x (fold f s i)).
  Proof.
  intros.
  apply fold_rel with (R:=fun u v => eqA u (f x v)); intros.
  reflexivity.
  transitivity (f x0 (f x b)); auto.
  apply Comp; auto with relations.
  Qed.

  (** ** Fold is a morphism *)

  Lemma fold_init : forall i i' s, eqA i i' ->
   eqA (fold f s i) (fold f s i').
  Proof.
  intros. apply fold_rel with (R:=eqA); auto.
  intros; apply Comp; auto with relations.
  Qed.

  Lemma fold_equal :
   forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
  Proof.
  intros i s; pattern s; apply set_induction; clear s; intros.
  transitivity i.
  apply fold_1; auto.
  symmetry; apply fold_1; auto.
  rewrite <- H0; auto.
  transitivity (f x (fold f s i)).
  apply fold_2 with (eqA := eqA); auto.
  symmetry; apply fold_2 with (eqA := eqA); auto.
  unfold Add in *; intros.
  rewrite <- H2; auto.
  Qed.

  (** ** Fold and other set operators *)

  Lemma fold_empty : forall i, fold f empty i = i.
  Proof.
  intros i; apply fold_1b; auto with set.
  Qed.

  Lemma fold_add : forall i s x, ~In x s ->
   eqA (fold f (add x s) i) (f x (fold f s i)).
  Proof.
  intros; apply fold_2 with (eqA := eqA); auto with set.
  Qed.

  Lemma add_fold : forall i s x, In x s ->
   eqA (fold f (add x s) i) (fold f s i).
  Proof.
  intros; apply fold_equal; auto with set.
  Qed.

  Lemma remove_fold_1: forall i s x, In x s ->
   eqA (f x (fold f (remove x s) i)) (fold f s i).
  Proof.
  intros.
  symmetry.
  apply fold_2 with (eqA:=eqA); auto with set relations.
  Qed.

  Lemma remove_fold_2: forall i s x, ~In x s ->
   eqA (fold f (remove x s) i) (fold f s i).
  Proof.
  intros.
  apply fold_equal; auto with set.
  Qed.

  Lemma fold_union_inter : forall i s s',
   eqA (fold f (union s s') (fold f (inter s s') i))
       (fold f s (fold f s' i)).
  Proof.
  intros; pattern s; apply set_induction; clear s; intros.
  transitivity (fold f s' (fold f (inter s s') i)).
  apply fold_equal; auto with set.
  transitivity (fold f s' i).
  apply fold_init; auto.
  apply fold_1; auto with set.
  symmetry; apply fold_1; auto.
  rename s'0 into s''.
  destruct (In_dec x s').
  (* In x s' *)
  transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set.
  apply fold_init; auto.
  apply fold_2 with (eqA:=eqA); auto with set.
  rewrite inter_iff; intuition.
  transitivity (f x (fold f s (fold f s' i))).
  transitivity (fold f (union s s') (f x (fold f (inter s s') i))).
  apply fold_equal; auto.
  apply equal_sym; apply union_Equal with x; auto with set.
  transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
  apply fold_commutes; auto.
  apply Comp; auto with relations.
  symmetry; apply fold_2 with (eqA:=eqA); auto.
  (* ~(In x s') *)
  transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))).
  apply fold_2 with (eqA:=eqA); auto with set.
  transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
  apply Comp;auto with relations.
  apply fold_init;auto.
  apply fold_equal;auto.
  apply equal_sym; apply inter_Add_2 with x; auto with set.
  transitivity (f x (fold f s (fold f s' i))).
  apply Comp; auto with relations.
  symmetry; apply fold_2 with (eqA:=eqA); auto.
  Qed.

  Lemma fold_diff_inter : forall i s s',
   eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
  Proof.
  intros.
  transitivity (fold f (union (diff s s') (inter s s'))
               (fold f (inter (diff s s') (inter s s')) i)).
  symmetry; apply fold_union_inter; auto.
  transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)).
  apply fold_equal; auto with set.
  apply fold_init; auto.
  apply fold_1; auto with set.
  Qed.

  Lemma fold_union: forall i s s',
   (forall x, ~(In x s/\In x s')) ->
   eqA (fold f (union s s') i) (fold f s (fold f s' i)).
  Proof.
  intros.
  transitivity (fold f (union s s') (fold f (inter s s') i)).
  apply fold_init; auto.
  symmetry; apply fold_1; auto with set.
  unfold Empty; intro a; generalize (H a); set_iff; tauto.
  apply fold_union_inter; auto.
  Qed.

  End Fold_More.

  Lemma fold_plus :
   forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
  Proof.
  intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto.
  Qed.

  End Fold.

  (** * Cardinal *)

  (** ** Characterization of cardinal in terms of fold *)

  Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0.
  Proof.
  intros; rewrite cardinal_1; rewrite FM.fold_1.
  symmetry; apply fold_left_length; auto.
  Qed.

  (** ** Old specifications for [cardinal]. *)

  Lemma cardinal_0 :
     forall s, exists l : list elt,
        NoDupA E.eq l /\
        (forall x : elt, In x s <-> InA E.eq x l) /\
        cardinal s = length l.
  Proof.
  intros; exists (elements s); intuition; apply cardinal_1.
  Qed.

  Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0.
  Proof.
  intros; rewrite cardinal_fold; apply fold_1; auto with *.
  Qed.

  Lemma cardinal_2 :
    forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s).
  Proof.
  intros; do 2 rewrite cardinal_fold.
  change S with ((fun _ => S) x).
  apply fold_2; auto.
  split; congruence.
  congruence.
  Qed.

  (** ** Cardinal and (non-)emptiness *)

  Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0.
  Proof.
  intros.
  rewrite elements_Empty, FM.cardinal_1.
  destruct (elements s); intuition; discriminate.
  Qed.

  Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s.
  Proof.
  intros; rewrite cardinal_Empty; auto.
  Qed.
  Hint Resolve cardinal_inv_1.

  Lemma cardinal_inv_2 :
   forall s n, cardinal s = S n -> { x : elt | In x s }.
  Proof.
  intros; rewrite FM.cardinal_1 in H.
  generalize (elements_2 (s:=s)).
  destruct (elements s); try discriminate.
  exists e; auto with relations.
  Qed.

  Lemma cardinal_inv_2b :
   forall s, cardinal s <> 0 -> { x : elt | In x s }.
  Proof.
  intro; generalize (@cardinal_inv_2 s); destruct cardinal;
   [intuition|eauto].
  Qed.

  (** ** Cardinal is a morphism *)

  Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'.
  Proof.
  symmetry.
  remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H.
  induction n; intros.
  apply cardinal_1; rewrite <- H; auto.
  destruct (cardinal_inv_2 Heqn) as (x,H2).
  revert Heqn.
  rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x));
   auto with set relations.
  rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x));
   eauto with set relations.
  Qed.

  Instance cardinal_m : Proper (Equal==>Logic.eq) cardinal.
  Proof.
  exact Equal_cardinal.
  Qed.

  Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal.

  (** ** Cardinal and set operators *)

  Lemma empty_cardinal : cardinal empty = 0.
  Proof.
  rewrite cardinal_fold; apply fold_1; auto with *.
  Qed.

  Hint Immediate empty_cardinal cardinal_1 : set.

  Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1.
  Proof.
  intros.
  rewrite (singleton_equal_add x).
  replace 0 with (cardinal empty); auto with set.
  apply cardinal_2 with x; auto with set.
  Qed.

  Hint Resolve singleton_cardinal: set.

  Lemma diff_inter_cardinal :
   forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s .
  Proof.
  intros; do 3 rewrite cardinal_fold.
  rewrite <- fold_plus.
  apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with *.
  congruence.
  Qed.

  Lemma union_cardinal:
   forall s s', (forall x, ~(In x s/\In x s')) ->
   cardinal (union s s')=cardinal s+cardinal s'.
  Proof.
  intros; do 3 rewrite cardinal_fold.
  rewrite <- fold_plus.
  apply fold_union; auto.
  split; congruence.
  congruence.
  Qed.

  Lemma subset_cardinal :
   forall s s', s[<=]s' -> cardinal s <= cardinal s' .
  Proof.
  intros.
  rewrite <- (diff_inter_cardinal s' s).
  rewrite (inter_sym s' s).
  rewrite (inter_subset_equal H); auto with arith.
  Qed.

  Lemma subset_cardinal_lt :
   forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
  Proof.
  intros.
  rewrite <- (diff_inter_cardinal s' s).
  rewrite (inter_sym s' s).
  rewrite (inter_subset_equal H).
  generalize (@cardinal_inv_1 (diff s' s)).
  destruct (cardinal (diff s' s)).
  intro H2; destruct (H2 (eq_refl _) x).
  set_iff; auto.
  intros _.
  change (0 + cardinal s < S n + cardinal s).
  apply Plus.plus_lt_le_compat; auto with arith.
  Qed.

  Theorem union_inter_cardinal :
   forall s s', cardinal (union s s') + cardinal (inter s s')  = cardinal s  + cardinal s' .
  Proof.
  intros.
  do 4 rewrite cardinal_fold.
  do 2 rewrite <- fold_plus.
  apply fold_union_inter with (eqA:=@Logic.eq nat); auto with *.
  congruence.
  Qed.

  Lemma union_cardinal_inter :
   forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s').
  Proof.
  intros.
  rewrite <- union_inter_cardinal.
  rewrite Plus.plus_comm.
  auto with arith.
  Qed.

  Lemma union_cardinal_le :
   forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
  Proof.
   intros; generalize (union_inter_cardinal s s').
   intros; rewrite <- H; auto with arith.
  Qed.

  Lemma add_cardinal_1 :
   forall s x, In x s -> cardinal (add x s) = cardinal s.
  Proof.
  auto with set.
  Qed.

  Lemma add_cardinal_2 :
   forall s x, ~In x s -> cardinal (add x s) = S (cardinal s).
  Proof.
  intros.
  do 2 rewrite cardinal_fold.
  change S with ((fun _ => S) x);
   apply fold_add with (eqA:=@Logic.eq nat); auto with *.
  congruence.
  Qed.

  Lemma remove_cardinal_1 :
   forall s x, In x s -> S (cardinal (remove x s)) = cardinal s.
  Proof.
  intros.
  do 2 rewrite cardinal_fold.
  change S with ((fun _ =>S) x).
  apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with *.
  congruence.
  Qed.

  Lemma remove_cardinal_2 :
   forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
  Proof.
  auto with set.
  Qed.

  Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2.

End WPropertiesOn.

(** Now comes variants for self-contained weak sets and for full sets.
    For these variants, only one argument is necessary. Thanks to
    the subtyping [WS<=S], the [Properties] functor which is meant to be
    used on modules [(M:S)] can simply be an alias of [WProperties]. *)

Module WProperties (M:WSets) := WPropertiesOn M.E M.
Module Properties := WProperties.

(** Now comes some properties specific to the element ordering,
    invalid for Weak Sets. *)

Module OrdProperties (M:Sets).
  Module Import ME:=OrderedTypeFacts(M.E).
  Module Import ML:=OrderedTypeLists(M.E).
  Module Import P := Properties M.
  Import FM.
  Import M.E.
  Import M.

  Hint Resolve elements_spec2.
  Hint Immediate
    min_elt_spec1 min_elt_spec2 min_elt_spec3
    max_elt_spec1 max_elt_spec2 max_elt_spec3 : set.

  (** First, a specialized version of SortA_equivlistA_eqlistA: *)
  Lemma sort_equivlistA_eqlistA : forall l l' : list elt,
   sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'.
  Proof.
  apply SortA_equivlistA_eqlistA; eauto with *.
  Qed.

  Definition gtb x y := match E.compare x y with Gt => true | _ => false end.
  Definition leb x := fun y => negb (gtb x y).

  Definition elements_lt x s := List.filter (gtb x) (elements s).
  Definition elements_ge x s := List.filter (leb x) (elements s).

  Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x.
  Proof.
   intros; rewrite <- compare_gt_iff. unfold gtb.
   destruct E.compare; intuition; try discriminate.
  Qed.

  Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x.
  Proof.
   intros; rewrite <- compare_gt_iff. unfold leb, gtb.
   destruct E.compare; intuition; try discriminate.
  Qed.

  Instance gtb_compat x : Proper (E.eq==>Logic.eq) (gtb x).
  Proof.
   intros a b H. unfold gtb. rewrite H; auto.
  Qed.

  Instance leb_compat x : Proper (E.eq==>Logic.eq) (leb x).
  Proof.
   intros a b H; unfold leb. rewrite H; auto.
  Qed.
  Hint Resolve gtb_compat leb_compat.

  Lemma elements_split : forall x s,
   elements s = elements_lt x s ++ elements_ge x s.
  Proof.
  unfold elements_lt, elements_ge, leb; intros.
  eapply (@filter_split _ E.eq); eauto with *.
  intros.
  rewrite gtb_1 in H.
  assert (~E.lt y x).
   unfold gtb in *; elim_compare x y; intuition;
   try discriminate; order.
  order.
  Qed.

  Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' ->
    eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s).
  Proof.
  intros; unfold elements_ge, elements_lt.
  apply sort_equivlistA_eqlistA; auto with set.
  apply (@SortA_app _ E.eq); auto with *.
  apply (@filter_sort _ E.eq); auto with *; eauto with *.
  constructor; auto.
  apply (@filter_sort _ E.eq); auto with *; eauto with *.
  rewrite Inf_alt by (apply (@filter_sort _ E.eq); eauto with *).
  intros.
  rewrite filter_InA in H1; auto with *; destruct H1.
  rewrite leb_1 in H2.
  rewrite <- elements_iff in H1.
  assert (~E.eq x y).
   contradict H; rewrite H; auto.
  order.
  intros.
  rewrite filter_InA in H1; auto with *; destruct H1.
  rewrite gtb_1 in H3.
  inversion_clear H2.
  order.
  rewrite filter_InA in H4; auto with *; destruct H4.
  rewrite leb_1 in H4.
  order.
  red; intros a.
  rewrite InA_app_iff, InA_cons, !filter_InA, <-!elements_iff,
   leb_1, gtb_1, (H0 a) by (auto with *).
  intuition.
  elim_compare a x; intuition.
  right; right; split; auto.
  order.
  Qed.

  Definition Above x s := forall y, In y s -> E.lt y x.
  Definition Below x s := forall y, In y s -> E.lt x y.

  Lemma elements_Add_Above : forall s s' x,
   Above x s -> Add x s s' ->
     eqlistA E.eq (elements s') (elements s ++ x::nil).
  Proof.
  intros.
  apply sort_equivlistA_eqlistA; auto with set.
  apply (@SortA_app _ E.eq); auto with *.
  intros.
  invlist InA.
  rewrite <- elements_iff in H1.
  setoid_replace y with x; auto.
  red; intros a.
  rewrite InA_app_iff, InA_cons, InA_nil, <-!elements_iff, (H0 a)
   by (auto with *).
  intuition.
  Qed.

  Lemma elements_Add_Below : forall s s' x,
   Below x s -> Add x s s' ->
     eqlistA E.eq (elements s') (x::elements s).
  Proof.
  intros.
  apply sort_equivlistA_eqlistA; auto with set.
  change (sort E.lt ((x::nil) ++ elements s)).
  apply (@SortA_app _ E.eq); auto with *.
  intros.
  invlist InA.
  rewrite <- elements_iff in H2.
  setoid_replace x0 with x; auto.
  red; intros a.
  rewrite InA_cons, <- !elements_iff, (H0 a); intuition.
  Qed.

  (** Two other induction principles on sets: we can be more restrictive
      on the element we add at each step.  *)

  Lemma set_induction_max :
   forall P : t -> Type,
   (forall s : t, Empty s -> P s) ->
   (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') ->
   forall s : t, P s.
  Proof.
  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
  case_eq (max_elt s); intros.
  apply X0 with (remove e s) e; auto with set.
  apply IHn.
  assert (S n = S (cardinal (remove e s))).
   rewrite Heqn; apply cardinal_2 with e; auto with set relations.
  inversion H0; auto.
  red; intros.
  rewrite remove_iff in H0; destruct H0.
  generalize (@max_elt_spec2 s e y H H0); order.

  assert (H0:=max_elt_spec3 H).
  rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn.
  Qed.

  Lemma set_induction_min :
   forall P : t -> Type,
   (forall s : t, Empty s -> P s) ->
   (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') ->
   forall s : t, P s.
  Proof.
  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
  case_eq (min_elt s); intros.
  apply X0 with (remove e s) e; auto with set.
  apply IHn.
  assert (S n = S (cardinal (remove e s))).
   rewrite Heqn; apply cardinal_2 with e; auto with set relations.
  inversion H0; auto.
  red; intros.
  rewrite remove_iff in H0; destruct H0.
  generalize (@min_elt_spec2 s e y H H0); order.

  assert (H0:=min_elt_spec3 H).
  rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn.
  Qed.

  (** More properties of [fold] : behavior with respect to Above/Below *)

  Lemma fold_3 :
   forall s s' x (A : Type) (eqA : A -> A -> Prop)
     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
   Proper (E.eq==>eqA==>eqA) f ->
   Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
  Proof.
  intros.
  rewrite 2 fold_spec_right.
  change (f x (fold_right f i (rev (elements s)))) with
    (fold_right f i (rev (x::nil)++rev (elements s))).
  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto with *.
  rewrite <- distr_rev.
  apply eqlistA_rev.
  apply elements_Add_Above; auto.
  Qed.

  Lemma fold_4 :
   forall s s' x (A : Type) (eqA : A -> A -> Prop)
     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
   Proper (E.eq==>eqA==>eqA) f ->
   Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
  Proof.
  intros.
  rewrite !fold_spec.
  change (eqA (fold_left (flip f) (elements s') i)
              (fold_left (flip f) (x::elements s) i)).
  unfold flip; rewrite <-!fold_left_rev_right.
  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
  apply eqlistA_rev.
  apply elements_Add_Below; auto.
  Qed.

  (** The following results have already been proved earlier,
    but we can now prove them with one hypothesis less:
    no need for [(transpose eqA f)]. *)

  Section FoldOpt.
  Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
  Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f).

  Lemma fold_equal :
   forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
  Proof.
  intros.
  rewrite 2 fold_spec_right.
  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
  apply eqlistA_rev.
  apply sort_equivlistA_eqlistA; auto with set.
  red; intro a; do 2 rewrite <- elements_iff; auto.
  Qed.

  Lemma add_fold : forall i s x, In x s ->
   eqA (fold f (add x s) i) (fold f s i).
  Proof.
  intros; apply fold_equal; auto with set.
  Qed.

  Lemma remove_fold_2: forall i s x, ~In x s ->
   eqA (fold f (remove x s) i) (fold f s i).
  Proof.
  intros.
  apply fold_equal; auto with set.
  Qed.

  End FoldOpt.

  (** An alternative version of [choose_3] *)

  Lemma choose_equal : forall s s', Equal s s' ->
    match choose s, choose s' with
      | Some x, Some x' => E.eq x x'
      | None, None => True
      | _, _ => False
     end.
  Proof.
  intros s s' H;
  generalize (@choose_spec1 s)(@choose_spec2 s)
             (@choose_spec1 s')(@choose_spec2 s')(@choose_spec3 s s');
  destruct (choose s); destruct (choose s'); simpl; intuition.
  apply H5 with e; rewrite <-H; auto.
  apply H5 with e; rewrite H; auto.
  Qed.

End OrdProperties.


Require Export BasicDefinitions.
Require Import Shared.Bijection.

(** ** Formalisation of finite types using canonical structures and type classes *)

(** * Definition of finite Types *)

Class finTypeC  (type:eqType) : Type :=
  FinTypeC {
      enum: list type;
      enum_ok: forall x: type, count enum x = 1
    }.

Structure finType : Type :=
  FinType
    {
      type:> eqType;
      class: finTypeC type
    }.

Arguments FinType type {class}.
Existing Instance class | 0.

(* This is a hack to work-around a problem with a class of hacks *)
Hint Extern 5 (finTypeC (EqType ?x)) => unfold x : typeclass_instances.

Canonical Structure finType_CS (X : Type) {p : eq_dec X} {class : finTypeC (EqType X)} : finType := FinType (EqType X).

(** Print the base type of [finType] in the Canonical Structure. *)
Arguments finType_CS (X) {_ _}.

Definition elem (F: finType) := @enum (type F) (class F).
Hint Unfold elem.
Hint Unfold class.

Lemma elem_spec (X: finType) (x:X) : x el (elem X).
Proof.
  apply countIn.  pose proof (enum_ok x) as H. unfold elem. omega.
Qed.

Hint Resolve elem_spec.
Hint Resolve enum_ok.

Lemma allSub (X: finType) (A:list X) : A <<= elem X.
Proof.
  intros x _. apply elem_spec.
Qed.
Hint Resolve allSub.

(** A properties that hold on every element of (elem X) hold for every element of the finType X *)
Theorem Equivalence_property_all (X: finType) (p: X -> Prop) :
  (forall x, p x) <-> forall x, x el (elem X) -> p x.
Proof.
  split; auto.
Qed.

Theorem Equivalence_property_exists (X: finType) (p:X -> Prop):
  (exists x, p x) <-> exists x, x el (elem X) /\ p x.
Proof.
  split.
  - intros [x P]. eauto.
  - intros [x [E P]]. eauto.
Qed.

Instance finType_forall_dec (X: finType) (p: X -> Prop): (forall x, dec (p x)) -> dec (forall x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_all p).
  - auto.
Qed.

Instance finType_exists_dec (X:finType) (p: X -> Prop) : (forall x, dec (p x)) -> dec (exists x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_exists p).
  - auto.
Qed.

Definition finType_cc (X: finType) (p: X -> Prop) (D: forall x, dec (p x)) : (exists x, p x) -> {x | p x}.
Proof.
  intro H.
  assert(exists x, x el (elem X) /\ p x) as E by firstorder.
  pose proof (list_cc D E) as [x G].
  now exists x.
Defined.

Definition pickx (X: finType): X + (X -> False).
Proof.
  destruct X as [X [enum ok]]. induction enum.
  - right. intro x. discriminate (ok x).
  - tauto.
Defined.

(** * Properties of decidable Propositions *)

Lemma DM_notAll (X: finType) (p: X -> Prop) (D:forall x, dec (p x)): (~ (forall x, p x)) <-> exists x, ~ (p x).
Proof.
  decide (exists x,~ p x); firstorder.
Qed.

Lemma DM_exists (X: finType) (p: X -> Prop) (D: forall x, dec (p x)):
  (exists x, p x) <->  ~(forall x, ~ p x).
Proof.
  split.
  - firstorder.
  - decide (exists x, p x); firstorder.
Qed.

(* Index is an injective function *)

Fixpoint  getPosition {E: eqType} (A: list E) x := match A with
                                                   | nil => 0
                                                   | cons x' A' => if Dec (x=x') then 0 else 1 + getPosition A' x end.

Lemma getPosition_correct {E: eqType} (x:E) A: if Dec (x el A) then forall z, (nth (getPosition A x) A z) = x else getPosition A x = |A |.
Proof.
  induction A;cbn.
  -repeat destruct Dec;tauto.
  -repeat destruct Dec;intuition; congruence.
Qed.

Definition pos_def (X : eqType) (x : X) A n :=  match pos x A with None => n | Some n => n end.

Definition index {F: finType} (x:F) := getPosition (elem F) x.

Lemma index_nth {F : finType} (x:F) y: nth (index x) (elem F) y = x.
  unfold index, elem, enum.
  destruct F as [[X E] [A all_A]];cbn.
  pose proof (getPosition_correct x A) as H.
  destruct Dec. auto. apply notInZero in n. now setoid_rewrite all_A in n.
Qed.

Lemma injective_index (A: finType) (x1 x2 : A) : index x1 = index x2 -> x1 = x2.
Proof.
  destruct (elem A) eqn:E.
  - hnf. intros. assert (x1 el elem A) by eauto using elem_spec. rewrite E in H0. auto.
  - clear E. eapply (left_inv_inj (g := (fun y => nth y (elem A) e))).
    hnf. intros. now rewrite index_nth.
Qed.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                      Fieska_Terms                                  *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max Bool List.
Require Import IntensionalLib.Fieska_calculus.Test.
Require Import IntensionalLib.Fieska_calculus.General.

(* Fieska-terms using de Bruijn's indices *)

Inductive operator := | Sop | Fop | Aop | Kop | Iop | Eop .

Inductive Fieska:  Set :=
  | Ref : nat -> Fieska
  | Op  : operator -> Fieska
  | App : Fieska -> Fieska -> Fieska
.


(** * Mapping predicates over [StringLike] things *)

Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.StringLike.ForallChars.
Require Import Fiat.Parsers.StringLike.FirstChar.
Require Import Fiat.Common.
Require Import Fiat.Common.NatFacts.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section is_first_char_such_that.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  Definition is_first_char_such_that
             (might_be_empty : Prop)
             (str : String)
             (n : nat)
             P
    := forall_chars (take n str) (fun ch => ~P ch)
       /\ ((for_first_char (drop n str) P /\ n < length str)
           \/ (might_be_empty /\ length str <= n)).

  Lemma first_char_such_that_past_end
        (might_be_empty : Prop)
        (str : String)
        (n : nat)
        P
        (H : length str <= n)
        (H' : is_first_char_such_that might_be_empty str n P)
  : might_be_empty.
  Proof.
    destruct_head_hnf and.
    destruct_head_hnf or;
      destruct_head_hnf and; trivial.
    exfalso; omega.
  Qed.

  Lemma first_char_such_that_0
        {might_be_empty : Prop}
        {str : String}
        {P}
  : is_first_char_such_that might_be_empty str 0 P
    <-> (for_first_char str P /\ (might_be_empty \/ length str > 0)).
  Proof.
    unfold is_first_char_such_that.
    rewrite drop_0.
    split; intro;
    destruct_head_hnf and;
    destruct_head_hnf or;
      destruct_head_hnf and; repeat split; trivial;
    try solve [ left; assumption
              | right; omega
              | apply for_first_char_nil; omega
              | apply forall_chars_nil; rewrite ?take_length; try apply Min.min_case_strong; intros; omega
              | destruct (length str);
                try solve [ left; repeat split; eauto; omega
                          | right; repeat split; eauto; omega ] ].
  Qed.

  Lemma is_first_char_such_that_drop
        (might_be_empty : Prop)
        (str : String)
        (n : nat)
        P
  : is_first_char_such_that might_be_empty str (S n) P
    <-> (is_first_char_such_that might_be_empty (drop 1 str) n P /\ for_first_char str (fun ch => ~P ch)).
  Proof.
    generalize dependent str; induction n; intros;
    unfold is_first_char_such_that in *;
    [
    | specialize (IHn (drop 1 str));
      rewrite (forall_chars__split _ _ 1) ];
    repeat match goal with
             | _ => assumption
             | _ => intro
             | _ => progress destruct_head and
             | _ => progress destruct_head iff
             | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
             | _ => progress simpl in *
             | [ H : _ |- _ ] => apply forall_chars__impl__for_first_char, for_first_char__take in H; assumption
             | [ H : for_first_char (take (S _) _) _ |- _ ] => apply for_first_char__take in H
             | [ H : for_first_char ?str ?P, H' : for_first_char ?str ?P' |- _ ]
               => destruct (fun H0 => for_first_char_combine (T := False) H0 H H'); cbv beta; [ tauto | clear H H' | tauto ]
             | [ H : ?x = 0 |- context[?x] ] => rewrite H
             | _ => apply forall_chars_nil; [ (rewrite ?take_length, ?drop_length; reflexivity).. ]
             | _ => omega
             | [ H : ?A /\ ?B -> ?C |- _ ] => specialize (fun x y => H (conj x y))
             | [ H : _ -> ?A /\ ?B -> ?C |- _ ] => specialize (fun a x y => H a (conj x y))
             | [ H : _ |- _ ] => progress rewrite ?drop_0, ?drop_drop, ?take_take, ?drop_length, ?take_length, ?drop_take, ?Nat.add_1_r, ?Nat.le_sub_le_add_r, <- ?(Plus.plus_comm 2), <- ?Nat.lt_add_lt_sub_r in H
             | _ => progress rewrite ?drop_0, ?drop_drop, ?take_take, ?drop_length, ?take_length, ?drop_take, ?Nat.add_1_r, ?Nat.le_sub_le_add_r, <- ?(Plus.plus_comm 2), <- ?Nat.lt_add_lt_sub_r
             | _ => progress destruct_head or
             | [ |- _ /\ _ ] => split
             | [ |- _ <-> _ ] => split
             | _ => left; repeat split; trivial; omega
             | _ => right; repeat split; trivial; omega
             | _ => apply for_first_char__for_first_char__iff_short;
                   [ rewrite take_length; destruct (length str); simpl in *; omega
                   | apply -> (for_first_char__take 0); assumption ]
           end.
  Qed.

  Global Instance is_first_char_such_that_Proper
  : Proper (impl ==> beq ==> eq ==> pointwise_relation _ iff ==> impl) is_first_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_first_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel impl.
    setoid_subst_rel (pointwise_relation Char iff).
    assumption.
  Qed.

  Global Instance is_first_char_such_that_Proper_flip
  : Proper (flip impl ==> beq ==> eq ==> pointwise_relation _ iff ==> flip impl) is_first_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_first_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel (pointwise_relation Char iff).
    unfold flip in *.
    setoid_subst_rel impl.
    assumption.
  Qed.

  Global Instance is_first_char_such_that_Proper_iff
  : Proper (iff ==> beq ==> eq ==> pointwise_relation _ iff ==> iff) is_first_char_such_that.
  Proof.
    repeat intro; subst.
    unfold is_first_char_such_that in *.
    setoid_subst_rel beq.
    setoid_subst_rel iff.
    setoid_subst_rel (pointwise_relation Char iff).
    reflexivity.
  Qed.

  Lemma is_first_char_such_that_eq_nat_iff
        (might_be_empty : Prop)
        (str : String)
        (n n' : nat)
        P
        (H0 : is_first_char_such_that might_be_empty str n P)
        (H1 : is_first_char_such_that might_be_empty str n' P)
  : n = n' \/ (n >= length str /\ n' >= length str /\ might_be_empty).
  Proof.
    generalize dependent n'; generalize dependent str; induction n; intros.
    { destruct n'; intros.
      { left; reflexivity. }
      { right.
        unfold is_first_char_such_that in *.
        repeat match goal with
                 | _ => assumption
                 | [ H : and _ _ |- _ ] => destruct H
                 | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
                 | [ H : _ |- _ ] => rewrite drop_0 in H
                 | [ H : _ |- _ ] => apply forall_chars__impl__for_first_char in H
                 | [ H : for_first_char (take (S _) _) _ |- _ ] => apply for_first_char__take in H
                 | [ H : for_first_char ?str ?P, H' : for_first_char ?str ?P' |- _ ]
                   => destruct (fun H0 => for_first_char_combine (T := False) H0 H H'); cbv beta; [ tauto | clear H H' | tauto ]
                 | [ H : ?x = 0 |- context[?x] ] => rewrite H
                 | _ => omega
                 | _ => progress destruct_head and
                 | _ => progress destruct_head or
                 | [ |- _ /\ _ ] => split
               end. } }
    { specialize (IHn (drop 1 str)).
      destruct n'; [ right; case_eq (length str) | ];
      repeat match goal with
               | [ H : is_first_char_such_that _ _ (S _) _ |- _ ] => apply is_first_char_such_that_drop in H
               | _ => progress destruct_head and
               | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
               | _ => intro
               | [ H : _ |- _ ] => progress rewrite ?drop_length, ?Nat.le_sub_le_add_r in H
               | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H'
               | _ => progress simpl in *
               | [ |- _ /\ _ ] => split; try omega; []
               | _ => eapply first_char_such_that_past_end; [ | eassumption ]; omega
               | [ H : _ |- _ ] => unique pose proof (proj1 (proj1 first_char_such_that_0 H))
               | [ H : for_first_char ?str ?P, H' : for_first_char ?str ?P' |- _ ]
                 => destruct (fun H_new => for_first_char_combine (T := False) H_new H H'); cbv beta; [ tauto | clear H H' | tauto ]
               | _ => omega
               | _ => progress unfold ge in *
               | [ H : forall n', is_first_char_such_that ?P ?str n' ?P' -> _, H' : is_first_char_such_that ?P ?str _ ?P' |- _ ]
                 => specialize (H _ H')
               | _ => progress subst
               | _ => left; reflexivity
               | _ => right; repeat split; trivial; omega
               | _ => progress destruct_head or
             end. }
  Qed.
End is_first_char_such_that.

Global Opaque is_first_char_such_that.

Definition find_first_char_such_that' {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
           (P : Char -> bool)
           (len : nat)
           (str : String)
: nat
  := nat_rect
       (fun _ => nat)
       0
       (fun len' find_first_char_such_that'
        => let otherwise := S find_first_char_such_that' in
           match get (length str - S len') str with
             | Some ch => if P ch
                          then 0
                          else otherwise
             | None => otherwise
           end)
       len.

Lemma find_first_char_such_that'_S {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
      (P : Char -> bool)
      (len : nat)
      (str : String)
: find_first_char_such_that' P (S len) str
  = let otherwise := S (find_first_char_such_that' P len str) in
    match get (length str - S len) str with
      | Some ch => if P ch
                   then 0
                   else otherwise
      | None => otherwise
    end.
Proof.
  reflexivity.
Qed.

Definition find_first_char_such_that {Char} {HSLM} {HSL} str P
  := @find_first_char_such_that' Char HSLM HSL P (length str) str.

Global Instance find_first_char_such_that'_Proper
       {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
       {HSLP : StringLikeProperties Char}
  : Proper (pointwise_relation _ eq ==> eq ==> beq ==> eq)
           find_first_char_such_that'.
Proof.
  intros ?? Hfg n n' ? s s' H; subst n'.
  unfold find_first_char_such_that'.
  apply nat_rect_Proper_nondep; [ reflexivity | repeat intro ].
  setoid_subst_rel beq.
  edestruct get; try reflexivity.
  rewrite Hfg; reflexivity.
Qed.

Global Instance find_first_char_such_that_Proper
       {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
       {HSLP : StringLikeProperties Char}
  : Proper (beq ==> pointwise_relation _ eq ==> eq)
           find_first_char_such_that.
Proof.
  repeat intro; unfold find_first_char_such_that.
  setoid_subst_rel beq.
  setoid_subst_rel (pointwise_relation Char (@eq bool)).
  reflexivity.
Qed.


(** Experiments around temporal logic. *)
Require Import Io.All.

Import C.Notations.

(*
(** Compilation to automata. *)
Module Automata.
  Definition t (S : Type) := S -> S -> Prop.

  Definition empty {S : Type} : t S :=
    fun _ _ =>
      False.

  Definition call {S : Type} (s1 s2 : S) : t S :=
    fun s'1 s'2 =>
      s1 = s'1 /\ s2 = s'2.

  Definition union {S : Type} (a1 a2 : t S) : t S :=
    fun s1 s2 =>
      a1 s1 s2 \/ a2 s1 s2.
End Automata.

Fixpoint run {E : Effect.t} {S A : Type}
  (update : forall (c : Effect.command E), S -> Effect.answer E c * S)
  (x : C.t E A) (s : S) : A * S * Automata.t S :=
  match x with
  | C.Ret _ x => (x, s, Automata.empty)
  | C.Call c =>
    let (x, s') := update c s in
    (x, s', Automata.call s s')
  | C.Let _ _ x f =>
    match run update x s with
    | (x, s, a_x) =>
      match run update (f x) s with
      | (y, s, a_y) => (y, s, Automata.union a_x a_y)
      end
    end
  (* | C.Join _ _ x y => *)
  end.*)

(** CCS and compilation to computations. *)
Module CCS.
  Module Action.
    Record t (A : Type) := New {
      eqb : A -> A -> bool }.
    Arguments eqb {A} _ _ _.

    Definition rename {A : Type} (action : t A) (b a a' : A) : A :=
      if eqb action b a then
        a'
      else
        a.
  End Action.

  Module Trace.
    Inductive t (A : Type) :=
    | Empty : t A
    | Do : A -> t A -> t A
    | Join : t A -> t A -> t A
    | First : t A -> t A -> t A.
    Arguments Empty {A}.
    Arguments Do {A} _ _.
    Arguments Join {A} _ _.
    Arguments First {A} _ _.
  End Trace.

  Inductive t {A : Type} (action : Action.t A) : Type :=
  | Empty : t action
  | Do : A -> t action -> t action
  | Join : t action -> t action -> t action
  | First : t action -> t action -> t action.
  Arguments Empty {A action}.
  Arguments Do {A action} _ _.
  Arguments Join {A action} _ _.
  Arguments First {A action} _ _.

  Fixpoint rename {A : Type} {action : Action.t A} (x : t action) (a a' : A)
    : t action :=
    match x with
    | Empty => x
    | Do b x => Do (Action.rename action b a a') (rename x a a')
    | Join x y => Join (rename x a a') (rename y a a')
    | First x y => First (rename x a a') (rename y a a')
    end.

  Fixpoint restrict {A : Type} {action : Action.t A} (x : t action) (a : A)
    : t action :=
    match x with
    | Empty => x
    | Do b x =>
      let x := restrict x a in
      if Action.eqb action a b then
        x
      else
        Do b x
    | Join x y => Join (restrict x a) (restrict y a)
    | First x y => First (restrict x a) (restrict y a)
    end.

  Fixpoint run {A : Type} {action : Action.t A} (x : t action) : Trace.t A :=
    match x with
    | Empty => Trace.Empty
    | Do a x => Trace.Do a (run x)
    | Join x y => Trace.Join (run x) (run y)
    | First x y => Trace.First (run x) (run y)
    end.

  Definition effect (A : Type) : Effect.t :=
    Effect.New A (fun _ => unit).

  Fixpoint compile {A : Type} {action : Action.t A} (x : t action)
    : C.t (effect A) unit :=
    match x with
    | Empty => ret tt
    | Do a x =>
      do! call (effect A) a in
      compile x
    | Join x y =>
      let! _ := join (compile x) (compile y) in
      ret tt
    | First x y =>
      let! _ := choose (compile x) (compile y) in
      ret tt
    end.
End CCS.

(** Definition of the LTL logic for the computations. *)
Module LTL.
  Definition t {E : Effect.t} {A : Type} :=
    C.t E A -> Prop.

  Module Event.
    Record t (E : Effect.t) := New {
      command : Effect.command E;
      answer : Effect.answer E command }.
    Arguments command {E} _.
    Arguments answer {E} _.
  End Event.
End LTL.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.

(* Why3 assumption *)
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

Parameter pow2: Z -> Z.

Axiom Power_0 : ((pow2 0%Z) = 1%Z).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%Z * (pow2 n))%Z).

Axiom Power_1 : ((pow2 1%Z) = 2%Z).

Axiom Power_sum : forall (n:Z) (m:Z), ((0%Z <= n)%Z /\ (0%Z <= m)%Z) ->
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%Z).

Axiom pow2_0 : ((pow2 0%Z) = 1%Z).

Axiom pow2_1 : ((pow2 1%Z) = 2%Z).

Axiom pow2_2 : ((pow2 2%Z) = 4%Z).

Axiom pow2_3 : ((pow2 3%Z) = 8%Z).

Axiom pow2_4 : ((pow2 4%Z) = 16%Z).

Axiom pow2_5 : ((pow2 5%Z) = 32%Z).

Axiom pow2_6 : ((pow2 6%Z) = 64%Z).

Axiom pow2_7 : ((pow2 7%Z) = 128%Z).

Axiom pow2_8 : ((pow2 8%Z) = 256%Z).

Axiom pow2_9 : ((pow2 9%Z) = 512%Z).

Axiom pow2_10 : ((pow2 10%Z) = 1024%Z).

Axiom pow2_11 : ((pow2 11%Z) = 2048%Z).

Axiom pow2_12 : ((pow2 12%Z) = 4096%Z).

Axiom pow2_13 : ((pow2 13%Z) = 8192%Z).

Axiom pow2_14 : ((pow2 14%Z) = 16384%Z).

Axiom pow2_15 : ((pow2 15%Z) = 32768%Z).

Axiom pow2_16 : ((pow2 16%Z) = 65536%Z).

Axiom pow2_17 : ((pow2 17%Z) = 131072%Z).

Axiom pow2_18 : ((pow2 18%Z) = 262144%Z).

Axiom pow2_19 : ((pow2 19%Z) = 524288%Z).

Axiom pow2_20 : ((pow2 20%Z) = 1048576%Z).

Axiom pow2_21 : ((pow2 21%Z) = 2097152%Z).

Axiom pow2_22 : ((pow2 22%Z) = 4194304%Z).

Axiom pow2_23 : ((pow2 23%Z) = 8388608%Z).

Axiom pow2_24 : ((pow2 24%Z) = 16777216%Z).

Axiom pow2_25 : ((pow2 25%Z) = 33554432%Z).

Axiom pow2_26 : ((pow2 26%Z) = 67108864%Z).

Axiom pow2_27 : ((pow2 27%Z) = 134217728%Z).

Axiom pow2_28 : ((pow2 28%Z) = 268435456%Z).

Axiom pow2_29 : ((pow2 29%Z) = 536870912%Z).

Axiom pow2_30 : ((pow2 30%Z) = 1073741824%Z).

Axiom pow2_31 : ((pow2 31%Z) = 2147483648%Z).

Axiom pow2_32 : ((pow2 32%Z) = 4294967296%Z).

Axiom pow2_33 : ((pow2 33%Z) = 8589934592%Z).

Axiom pow2_34 : ((pow2 34%Z) = 17179869184%Z).

Axiom pow2_35 : ((pow2 35%Z) = 34359738368%Z).

Axiom pow2_36 : ((pow2 36%Z) = 68719476736%Z).

Axiom pow2_37 : ((pow2 37%Z) = 137438953472%Z).

Axiom pow2_38 : ((pow2 38%Z) = 274877906944%Z).

Axiom pow2_39 : ((pow2 39%Z) = 549755813888%Z).

Axiom pow2_40 : ((pow2 40%Z) = 1099511627776%Z).

Axiom pow2_41 : ((pow2 41%Z) = 2199023255552%Z).

Axiom pow2_42 : ((pow2 42%Z) = 4398046511104%Z).

Axiom pow2_43 : ((pow2 43%Z) = 8796093022208%Z).

Axiom pow2_44 : ((pow2 44%Z) = 17592186044416%Z).

Axiom pow2_45 : ((pow2 45%Z) = 35184372088832%Z).

Axiom pow2_46 : ((pow2 46%Z) = 70368744177664%Z).

Axiom pow2_47 : ((pow2 47%Z) = 140737488355328%Z).

Axiom pow2_48 : ((pow2 48%Z) = 281474976710656%Z).

Axiom pow2_49 : ((pow2 49%Z) = 562949953421312%Z).

Axiom pow2_50 : ((pow2 50%Z) = 1125899906842624%Z).

Axiom pow2_51 : ((pow2 51%Z) = 2251799813685248%Z).

Axiom pow2_52 : ((pow2 52%Z) = 4503599627370496%Z).

Axiom pow2_53 : ((pow2 53%Z) = 9007199254740992%Z).

Axiom pow2_54 : ((pow2 54%Z) = 18014398509481984%Z).

Axiom pow2_55 : ((pow2 55%Z) = 36028797018963968%Z).

Axiom pow2_56 : ((pow2 56%Z) = 72057594037927936%Z).

Axiom pow2_57 : ((pow2 57%Z) = 144115188075855872%Z).

Axiom pow2_58 : ((pow2 58%Z) = 288230376151711744%Z).

Axiom pow2_59 : ((pow2 59%Z) = 576460752303423488%Z).

Axiom pow2_60 : ((pow2 60%Z) = 1152921504606846976%Z).

Axiom pow2_61 : ((pow2 61%Z) = 2305843009213693952%Z).

Axiom pow2_62 : ((pow2 62%Z) = 4611686018427387904%Z).

Axiom pow2_63 : ((pow2 63%Z) = 9223372036854775808%Z).

Parameter size: Z.

Parameter bv : Type.

Axiom size_positive : (1%Z <  size)%Z.

Parameter nth: bv -> Z -> bool.

Parameter bvzero: bv.

Axiom Nth_zero : forall (n:Z), ((0%Z <= n)%Z /\ (n <  size)%Z) ->
  ((nth bvzero n) = false).

Parameter bvone: bv.

Axiom Nth_one : forall (n:Z), ((0%Z <= n)%Z /\ (n <  size)%Z) -> ((nth bvone
  n) = true).

(* Why3 assumption *)
Definition eq(v1:bv) (v2:bv): Prop := forall (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth v1 n) = (nth v2 n)).

Axiom extensionality : forall (v1:bv) (v2:bv), (eq v1 v2) -> (v1 = v2).

Parameter bw_and: bv -> bv -> bv.

Axiom Nth_bw_and : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth (bw_and v1 v2) n) = (andb (nth v1 n) (nth v2 n))).

Parameter bw_or: bv -> bv -> bv.

Axiom Nth_bw_or : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth (bw_or v1 v2) n) = (orb (nth v1 n) (nth v2 n))).

Parameter bw_xor: bv -> bv -> bv.

Axiom Nth_bw_xor : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth (bw_xor v1 v2) n) = (xorb (nth v1 n) (nth v2 n))).

Axiom Nth_bw_xor_v1true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v1 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v2 n))).

Axiom Nth_bw_xor_v1false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v1 n) = false)) -> ((nth (bw_xor v1 v2)
  n) = (nth v2 n)).

Axiom Nth_bw_xor_v2true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v2 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v1 n))).

Axiom Nth_bw_xor_v2false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v2 n) = false)) -> ((nth (bw_xor v1 v2)
  n) = (nth v1 n)).

Parameter bw_not: bv -> bv.

Axiom Nth_bw_not : forall (v:bv) (n:Z), ((0%Z <= n)%Z /\ (n <  size)%Z) ->
  ((nth (bw_not v) n) = (negb (nth v n))).

Parameter lsr: bv -> Z -> bv.

Axiom lsr_nth_low : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ (((0%Z <= s)%Z /\ (s <  size)%Z) /\
  ((n + s)%Z <  size)%Z)) -> ((nth (lsr b s) n) = (nth b (n + s)%Z)).

Axiom lsr_nth_high : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ (((0%Z <= s)%Z /\ (s <  size)%Z) /\
  (size <= (n + s)%Z)%Z)) -> ((nth (lsr b s) n) = false).

Parameter asr: bv -> Z -> bv.

Axiom asr_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> (((n + s)%Z <  size)%Z -> ((nth (asr b
  s) n) = (nth b (n + s)%Z)))).

Axiom asr_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> ((size <= (n + s)%Z)%Z -> ((nth (asr b
  s) n) = (nth b (size - 1%Z)%Z)))).

Parameter lsl: bv -> Z -> bv.

Axiom lsl_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> ((0%Z <= (n - s)%Z)%Z -> ((nth (lsl b s)
  n) = (nth b (n - s)%Z)))).

Axiom lsl_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> (((n - s)%Z <  0%Z)%Z -> ((nth (lsl b s)
  n) = false))).

Parameter to_nat_sub: bv -> Z -> Z -> Z.

Axiom to_nat_sub_zero : forall (b:bv) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j <  size)%Z) -> (((nth b j) = false) -> ((to_nat_sub b j
  i) = (to_nat_sub b (j - 1%Z)%Z i))).

Axiom to_nat_sub_one : forall (b:bv) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j <  size)%Z) -> (((nth b j) = true) -> ((to_nat_sub b j
  i) = ((pow2 (j - i)%Z) + (to_nat_sub b (j - 1%Z)%Z i))%Z)).

Axiom to_nat_sub_high : forall (b:bv) (j:Z) (i:Z), (j <  i)%Z ->
  ((to_nat_sub b j i) = 0%Z).

Axiom to_nat_of_zero2 : forall (b:bv) (i:Z) (j:Z), (((j <  size)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i <  k)%Z) -> ((nth b k) = false)) -> ((to_nat_sub b j
  0%Z) = (to_nat_sub b i 0%Z))).

Axiom to_nat_of_zero : forall (b:bv) (i:Z) (j:Z), ((j <  size)%Z /\
  (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\ (i <= k)%Z) -> ((nth b
  k) = false)) -> ((to_nat_sub b j i) = 0%Z)).

Axiom to_nat_of_one : forall (b:bv) (i:Z) (j:Z), (((j <  size)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i <= k)%Z) -> ((nth b k) = true)) -> ((to_nat_sub b j
  i) = ((pow2 ((j - i)%Z + 1%Z)%Z) - 1%Z)%Z)).

Axiom to_nat_sub_footprint : forall (b1:bv) (b2:bv) (j:Z) (i:Z),
  ((j <  size)%Z /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((i <= k)%Z /\
  (k <= j)%Z) -> ((nth b1 k) = (nth b2 k))) -> ((to_nat_sub b1 j
  i) = (to_nat_sub b2 j i))).

Parameter from_int: Z -> bv.

Axiom nth_from_int_high_even : forall (n:Z) (i:Z), (((i <  size)%Z /\
  (0%Z <= i)%Z) /\ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n
  (pow2 i)) 2%Z) = 0%Z)) -> ((nth (from_int n) i) = false).

Axiom nth_from_int_high_odd : forall (n:Z) (i:Z), (((i <  size)%Z /\
  (0%Z <= i)%Z) /\
  ~ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth (from_int n) i) = true).

Axiom nth_from_int_low_even : forall (n:Z), ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z) -> ((nth (from_int n) 0%Z) = false).

Axiom nth_from_int_low_odd : forall (n:Z), (~ ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z)) -> ((nth (from_int n) 0%Z) = true).

Open Scope Z_scope.

(* Why3 goal *)
Theorem pow2i : forall (i:Z), (0%Z <= i)%Z -> ~ ((pow2 i) = 0%Z).
(* YOU MAY EDIT THE PROOF BELOW *)
intros i Hi.
cut (0 <= i); auto with zarith.
apply Z_lt_induction with
  (P:= fun i =>
       0 <= i -> pow2 i <> 0);auto with zarith.
intros x Hind Hxpos.
assert (hx:x = 0 \/ x >0) by omega.
destruct hx.
subst x.
rewrite Power_0;auto with zarith.

replace (x) with (x-1+1) by omega.
rewrite Power_s;auto with *.
Require Export ZArith Classical_Prop.
Open Scope Z_scope.

Lemma Zmult_neq_0_compat : forall (x y : Z), x <> 0 -> y <> 0 -> x * y <> 0.
Proof.
  intros x y Hx Hy Hxy.
  apply (@absurd (x = 0 \/ y = 0)).
  apply Zmult_integral, Hxy.
  apply and_not_or ; intuition.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A C I Cprime Aprime : Universe, ((wd_ I C /\ (wd_ A I /\ (wd_ A C /\ (wd_ I Cprime /\ (wd_ I Aprime /\ (wd_ A Cprime /\ (wd_ C Aprime /\ (wd_ Aprime Cprime /\ (col_ I C Aprime /\ (col_ I A Cprime /\ col_ I Aprime Cprime)))))))))) -> col_ A I C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* generated by Ott 0.30, locally-nameless lngen from: ../ott/rules.ott *)
Require Import Bool.
Require Import Metalib.Metatheory.
Require Import List.
(** syntax *)
Definition i : Set := nat.
Definition b : Set := bool.

Inductive typ : Set :=  (*r types *)
 | t_int : typ (*r int *)
 | t_arrow (A:typ) (B:typ) (*r function types *)
 | t_dyn : typ (*r dynamic type *).

Inductive st : Set :=  (*r input type or projection label *)
 | st_ty (A:typ).

 Inductive term : Set :=  (*r terms *)
 | trm_var_b (_:nat) (*r variables *)
 | trm_var_f (x:var) (*r variables *)
 | trm_lit (i5:i) (*r lit *)
 | trm_abs (A:typ) (t:term) (*r abstractions *)
 | trm_app (t1:term) (t2:term) (*r applications *)
 | trm_cast (t:term) (p:var) (b:bool) (A:typ) (B:typ) (*r annotation *)
 | trm_add : term (*r addition *)
 | trm_addl (i5:i) (*r addl *).

 Definition ctx : Set := list ( atom * typ ).

 Definition ls : Set := list st.

 (* EXPERIMENTAL *)
 (** auxiliary functions on the new list types *)
 (** library functions *)
 (** subrules *)
 (** arities *)
 (** opening up abstractions *)
 Fixpoint open_term_wrt_term_rec (k:nat) (t_5:term) (t__6:term) {struct t__6}: term :=
   match t__6 with
   | (trm_var_b nat) =>
       match lt_eq_lt_dec nat k with
         | inleft (left _) => trm_var_b nat
         | inleft (right _) => t_5
         | inright _ => trm_var_b (nat - 1)
       end
   | (trm_var_f x) => trm_var_f x
   | (trm_lit i5) => trm_lit i5
   | (trm_abs A t) => trm_abs A (open_term_wrt_term_rec (S k) t_5 t)
   | (trm_app t1 t2) => trm_app (open_term_wrt_term_rec k t_5 t1) (open_term_wrt_term_rec k t_5 t2)
   | (trm_cast t p b A B) => trm_cast (open_term_wrt_term_rec k t_5 t) p b A B
   | trm_add => trm_add
   | (trm_addl i5) => trm_addl i5
 end.

 Definition open_term_wrt_term t_5 t__6 := open_term_wrt_term_rec 0 t__6 t_5.

 (** terms are locally-closed pre-terms *)
 (** definitions *)

 (* defns LC_term *)
 Inductive lc_term : term -> Prop :=    (* defn lc_term *)
  | lc_trm_var_f : forall (x:var),
      (lc_term (trm_var_f x))
  | lc_trm_lit : forall (i5:i),
      (lc_term (trm_lit i5))
  | lc_trm_abs : forall (A:typ) (t:term),
       ( forall x , lc_term  ( open_term_wrt_term t (trm_var_f x) )  )  ->
      (lc_term (trm_abs A t))
  | lc_trm_app : forall (t1 t2:term),
      (lc_term t1) ->
      (lc_term t2) ->
      (lc_term (trm_app t1 t2))
  | lc_trm_cast : forall (t:term) (A B:typ) b (p:var),
      (lc_term t) ->
      (lc_term (trm_cast t p b A B))
  | lc_trm_add :
      (lc_term trm_add)
  | lc_trm_addl : forall (i5:i),
      (lc_term (trm_addl i5)).
 (** free variables *)
 Fixpoint fv_term (t_5:term) : vars :=
   match t_5 with
   | (trm_var_b nat) => {}
   | (trm_var_f x) => {{x}}
   | (trm_lit i5) => {}
   | (trm_abs A t) => (fv_term t)
   | (trm_app t1 t2) => (fv_term t1) \u (fv_term t2)
   | (trm_cast t p b A B) => (fv_term t)
   | trm_add => {}
   | (trm_addl i5) => {}
 end.

 (** substitutions *)
 Fixpoint subst_term (t_5:term) (x5:var) (t__6:term) {struct t__6} : term :=
   match t__6 with
   | (trm_var_b nat) => trm_var_b nat
   | (trm_var_f x) => (if eq_var x x5 then t_5 else (trm_var_f x))
   | (trm_lit i5) => trm_lit i5
   | (trm_abs A t) => trm_abs A (subst_term t_5 x5 t)
   | (trm_app t1 t2) => trm_app (subst_term t_5 x5 t1) (subst_term t_5 x5 t2)
   | (trm_cast t p b A B) => trm_cast (subst_term t_5 x5 t) p b A B
   | trm_add => trm_add
   | (trm_addl i5) => trm_addl i5
 end.

 (** definitions *)

 (* defns Grounds *)
 Inductive Ground : typ -> Prop :=    (* defn Ground *)
  | Ground_lit :
      Ground t_int
  | Ground_dyn :
      Ground  (t_arrow t_dyn t_dyn) .

 (* defns Values *)
 Inductive valueb : term -> Prop :=    (* defn valueb *)
  | valueb_lit : forall (i5:i),
      valueb (trm_lit i5)
  | valueb_add :
      valueb trm_add
  | valueb_addl : forall (i5:i),
      valueb  ( (trm_addl i5) )
  | valueb_anno : forall (A:typ) (t:term),
      lc_term (trm_abs A t) ->
      valueb (trm_abs A t)
  | valueb_fanno : forall (v:term) (A B C D:typ) (p:var) b,
      valueb v ->
      valueb  ( (trm_cast v  p b (t_arrow A B)  (t_arrow C D) ) )
  | valueb_dyn : forall (v:term) (B:typ) (p:var) b,
      valueb v ->
      Ground B ->
      valueb  ( (trm_cast v p b B t_dyn) ) .

 (* defns Consistency *)
 Inductive sim : typ -> typ -> Prop :=    (* defn sim *)
  | S_i :
      sim t_int t_int
  | S_arr : forall (A B C D:typ),
      sim C A ->
      sim B D ->
      sim (t_arrow A B) (t_arrow C D)
  | S_dynl : forall (A:typ),
      sim t_dyn A
  | S_dynr : forall (A:typ),
      sim A t_dyn.

      (* defns Btyping *)
Inductive Btyping : ctx -> term -> typ -> Prop :=    (* defn Btyping *)
 | Btyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     Btyping G (trm_lit i5) t_int
 | Btyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     Btyping G (trm_var_f x) A
 | Btyp_abs : forall (L:vars) (G:ctx) (A:typ) (t:term) (B:typ),
      ( forall x , x \notin  L  -> Btyping  (cons ( x , A )  G )   ( open_term_wrt_term t (trm_var_f x) )  B )  ->
     Btyping G (trm_abs A t) (t_arrow A B)
 | Btyp_app : forall (G:ctx) (t1 t2:term) (B A:typ),
     Btyping G t1 (t_arrow A B) ->
     Btyping G t2 A ->
     Btyping G (trm_app t1 t2) B
 | Btyp_add : forall (G:ctx),
     uniq  G  ->
     Btyping G trm_add (t_arrow t_int  (t_arrow t_int t_int) )
 | Btyp_addl : forall (G:ctx) (i1:i),
    uniq  G  ->
     Btyping G (trm_addl i1) (t_arrow t_int t_int)
 | Btyp_cast : forall (G:ctx) (t:term) (A B:typ) (p:var) b,
     Btyping G t A ->
     sim A B ->
     Btyping G  ( (trm_cast t p b A B) )  B.

Inductive ctx_itemb : Type :=
  | appCtxLb : term -> ctx_itemb
  | appCtxRb : term -> ctx_itemb
  | castCtxb : var -> bool-> typ -> typ -> ctx_itemb.

Inductive wellformedb : ctx_itemb -> Prop :=
  | wf_appCtxLb : forall (e : term),
                 lc_term e ->
                 wellformedb (appCtxLb e)
  | wf_appCtxRb : forall (v : term),
                 valueb v ->
                 wellformedb (appCtxRb v)
  | wf_castCtxb : forall (A B: typ) p b,
                 wellformedb (castCtxb p b A B).

Definition fillb (E : ctx_itemb) (e : term) : term :=
  match E with
  | appCtxLb e2 => trm_app e e2
  | appCtxRb v1 => trm_app v1 e
  | castCtxb p b A B => trm_cast e p b A B
  end.

Inductive resb : Type :=
  | t_term  : term -> resb
  | t_blame :  var -> bool -> resb.

(* defns Semantics *)
Inductive bstep : term -> resb -> Prop :=    (* defn step *)
  | do_stepb E e1 e2 :
     wellformedb E ->
     bstep e1 ( t_term e2 ) ->
     bstep (fillb E e1) (t_term (fillb E e2))
  | blame_stepb E e1 p b:
     wellformedb E ->
     bstep e1 (t_blame p b) ->
     bstep (fillb E e1) (t_blame p b)
 | bStep_beta : forall (A:typ) (t v:term),
     lc_term (trm_abs A t) ->
     valueb v ->
     bstep (trm_app  ( (trm_abs A t) )  v)  (t_term  (open_term_wrt_term  t v )  )
 | bStep_lit : forall (i5:i) (p:var) b,
     bstep (trm_cast (trm_lit i5) p b t_int t_int) (t_term (trm_lit i5))
 | bStep_abeta : forall (v1:term) (A B C D:typ) (v2:term) (p:var) b,
     valueb  ( (trm_cast v1 p b (t_arrow A B) (t_arrow C D)) )  ->
     valueb v2 ->
     bstep (trm_app  ( (trm_cast v1 p b (t_arrow A B) (t_arrow C D)) )  v2) (t_term (trm_cast  ( (trm_app v1  ( (trm_cast v2 p (negb b) C A) ) ) ) p b B D))
 | bStep_dd : forall (v:term) (p:var) b,
     valueb v ->
     bstep  ( (trm_cast v p b t_dyn t_dyn) )  (t_term v)
 | bStep_anyd : forall (v:term) (A:typ) (p:var) b,
     valueb v ->
      not (   A  =  t_dyn   )  ->
      not (   A  =  (t_arrow t_dyn t_dyn)   )  ->
     sim A (t_arrow t_dyn t_dyn) ->
     bstep  ( (trm_cast v p b A t_dyn) )   (t_term (trm_cast  ( (trm_cast v p b A (t_arrow t_dyn t_dyn)) ) p b (t_arrow t_dyn t_dyn) t_dyn) )
 (* | bStep_dyna : forall (v:term) (A:typ),
     valueb v ->
      not (   A  =  t_dyn   )  ->
      not (   A  =  (t_arrow t_dyn t_dyn)   )  ->
     sim A (t_arrow t_dyn t_dyn) ->
     bstep  ( (trm_cast v t_dyn A) )   (t_term (trm_cast  ( (trm_cast v t_dyn (t_arrow t_dyn t_dyn)) )  (t_arrow t_dyn t_dyn) A) )  *)
 | bStep_dyna : forall (v:term) (A:typ) (p:var) b ,
     valueb v ->
      not (   A  =  t_dyn   )  ->
      not (   A  =  (t_arrow t_dyn t_dyn)   )  ->
     sim A (t_arrow t_dyn t_dyn) ->
     bstep  ( (trm_cast v p b t_dyn A) )   (t_term  (trm_cast (trm_cast v p b t_dyn (t_arrow t_dyn t_dyn)) p b (t_arrow t_dyn t_dyn) A) )
 | bStep_vany : forall (v:term) (A:typ) (p:var) (q:var) b1 b2,
     Ground A ->
     valueb v ->
     bstep  ( (trm_cast  ( (trm_cast v q b1 A t_dyn) ) p b2 t_dyn A) )  (t_term v)
 | bStep_vanyp : forall (v:term) (A B:typ) (p:var) (q:var) b1 b2,
     Ground A ->
     Ground B ->
     not (A = B) ->
     valueb v ->
     bstep  ( (trm_cast  ( (trm_cast v q b1 A t_dyn) ) p b2 t_dyn B) )  (t_blame p b2)
 | bStep_add : forall (i1:i),
     bstep (trm_app trm_add (trm_lit i1)) (t_term (trm_addl i1))
 | bStep_addl : forall (i1 i2:i),
     bstep (trm_app  ( (trm_addl i1) )  (trm_lit i2))  (t_term (trm_lit ( i1  +  i2 ))).
(*
(* defns Semantics *)
Inductive bstep : term -> resb -> Prop :=    (* defn step *)
  | do_stepb E e1 e2 :
     wellformedb E ->
     bstep e1 ( t_term e2 ) ->
     bstep (fillb E e1) (t_term (fillb E e2))
  | blame_stepb E e1 :
     wellformedb E ->
     bstep e1 (t_blame) ->
     bstep (fillb E e1) (t_blame)
 | bStep_beta : forall (A:typ) (t v:term),
     lc_term (trm_abs A t) ->
     valueb v ->
     bstep (trm_app  ( (trm_abs A t) )  v)  (t_term  (open_term_wrt_term  t v )  )
 | bStep_lit : forall (i5:i),
     bstep (trm_cast (trm_lit i5) t_int t_int) (t_term (trm_lit i5))
 | bStep_abeta : forall (v1:term) (A B C D:typ) (v2:term),
     valueb  ( (trm_cast v1 (t_arrow A B) (t_arrow C D)) )  ->
     valueb v2 ->
     bstep (trm_app  ( (trm_cast v1 (t_arrow A B) (t_arrow C D)) )  v2) (t_term (trm_cast  ( (trm_app v1  ( (trm_cast v2 C A) ) ) )  B D))
 | bStep_dd : forall (v:term),
     valueb v ->
     bstep  ( (trm_cast v t_dyn t_dyn) )  (t_term v)
 | bStep_anyd : forall (v:term) (A:typ),
     valueb v ->
      not (   A  =  t_dyn   )  ->
      not (   A  =  (t_arrow t_dyn t_dyn)   )  ->
     sim A (t_arrow t_dyn t_dyn) ->
     bstep  ( (trm_cast v A t_dyn) )   (t_term (trm_cast  ( (trm_cast v A (t_arrow t_dyn t_dyn)) )  (t_arrow t_dyn t_dyn) t_dyn) )
 | bStep_dyna : forall (v:term) (A:typ),
     valueb v ->
      not (   A  =  t_dyn   )  ->
      not (   A  =  (t_arrow t_dyn t_dyn)   )  ->
     sim A (t_arrow t_dyn t_dyn) ->
     bstep  ( (trm_cast v t_dyn A) )   (t_term (trm_cast  ( (trm_cast v t_dyn (t_arrow t_dyn t_dyn)) )  (t_arrow t_dyn t_dyn) A) )
 | bStep_vany : forall (v:term) (A:typ),
     Ground A ->
     valueb v ->
     bstep  ( (trm_cast  ( (trm_cast v A t_dyn) )  t_dyn A) )  (t_term v)
 | bStep_vanyp : forall (v:term) (A B:typ),
     Ground A ->
     Ground B ->
     not (A = B) ->
     valueb v ->
     bstep  ( (trm_cast  ( (trm_cast v A t_dyn) )  t_dyn B) )  t_blame
 | bStep_add : forall (i1:i),
     bstep (trm_app trm_add (trm_lit i1)) (t_term (trm_addl i1))
 | bStep_addl : forall (i1 i2:i),
     bstep (trm_app  ( (trm_addl i1) )  (trm_lit i2))  (t_term (trm_lit ( i1  +  i2 ))). *)

(* defns Semantics *)
(* Inductive bstep : term -> resb -> Prop :=    (* defn step *)
  | do_stepb E e1 e2 :
     wellformedb E ->
     bstep e1 ( t_term e2 ) ->
     bstep (fillb E e1) (t_term (fillb E e2))
  | blame_stepb E e1 p b:
     wellformedb E ->
     bstep e1 (t_blame p b) ->
     bstep (fillb E e1) (t_blame p b)
 | bStep_beta : forall (A:typ) (t v:term),
     lc_term (trm_abs A t) ->
     valueb v ->
     bstep (trm_app  ( (trm_abs A t) )  v)  (t_term  (open_term_wrt_term  t v )  )
 | bStep_lit : forall (i5:i) (p:var) b,
     bstep (trm_cast (trm_lit i5) p b t_int t_int) (t_term (trm_lit i5))
 | bStep_abeta : forall (v1:term) (A B C D:typ) (v2:term) (p:var) b,
     valueb  ( (trm_cast v1 p b (t_arrow A B) (t_arrow C D)) )  ->
     valueb v2 ->
     bstep (trm_app  ( (trm_cast v1 p b (t_arrow A B) (t_arrow C D)) )  v2) (t_term (trm_cast  ( (trm_app v1  ( (trm_cast v2 p (negb b) C A) ) ) ) p b B D))
 | bStep_dd : forall (v:term) (p:var) b,
     valueb v ->
     bstep  ( (trm_cast v p b t_dyn t_dyn) )  (t_term v)
 | bStep_anyd : forall (v:term) (A:typ) (p:var) b,
     valueb v ->
      not (   A  =  t_dyn   )  ->
      not (   A  =  (t_arrow t_dyn t_dyn)   )  ->
     sim A (t_arrow t_dyn t_dyn) ->
     bstep  ( (trm_cast v p b A t_dyn) )   (t_term (trm_cast  ( (trm_cast v p b A (t_arrow t_dyn t_dyn)) ) p b (t_arrow t_dyn t_dyn) t_dyn) )
 | bStep_dyna : forall (v:term) (A:typ) (p:var) b p0 b0 ,
     valueb v ->
      not (   A  =  t_dyn   )  ->
      not (   A  =  (t_arrow t_dyn t_dyn)   )  ->
     sim A (t_arrow t_dyn t_dyn) ->
     bstep  ( (trm_cast (trm_cast v p0 b0 (t_arrow t_dyn t_dyn) t_dyn) p b t_dyn A) )   (t_term  (trm_cast v p b (t_arrow t_dyn t_dyn) A) )
 | bStep_vany : forall (v:term) (A:typ) (p:var) (q:var) b1 b2,
     Ground A ->
     valueb v ->
     bstep  ( (trm_cast  ( (trm_cast v q b1 A t_dyn) ) p b2 t_dyn A) )  (t_term v)
 | bStep_vanyp : forall (v:term) (A B:typ) (p:var) (q:var) b1 b2,
     Ground A ->
     not (sim A B) ->
     valueb v ->
     bstep  ( (trm_cast  ( (trm_cast v q b1 A t_dyn) ) p b2 t_dyn B) )  (t_blame p b2)
 | bStep_add : forall (i1:i),
     bstep (trm_app trm_add (trm_lit i1)) (t_term (trm_addl i1))
 | bStep_addl : forall (i1 i2:i),
     bstep (trm_app  ( (trm_addl i1) )  (trm_lit i2))  (t_term (trm_lit ( i1  +  i2 ))). *)

Inductive bsteps : term -> resb -> Prop :=
  | bstep_refl e:
    bsteps e (t_term e)

  | bstep_n e t' e':
    bstep e (t_term e') ->
    bsteps e' (t_term t') ->
    bsteps e  (t_term t')

  | bstep_nb e e' p b:
    bstep e (t_term e') ->
    bsteps e' (t_blame p b) ->
    bsteps e  (t_blame p b)

  | bstep_b e p b:
    bstep e (t_blame p b) ->
    bsteps e (t_blame p b).

Inductive bbsteps : term -> resb -> nat -> Prop :=
  | bbstep_refl e:
    bbsteps e (t_term e) 0

  | bbstep_n e t' e':  forall n,
    bstep e (t_term e') ->
    bbsteps e' (t_term t') n ->
    bbsteps e  (t_term t') (1+n)

  | bbstep_nb e e' p b:forall n,
    bstep e (t_term e') ->
    bbsteps e' (t_blame p b) n ->
    bbsteps e  (t_blame p b) (1+n)

  | bbstep_b e p b:
    bstep e (t_blame p b) ->
    bbsteps e (t_blame p b) 1.

(** infrastructure *)
Hint Constructors Ground valueb sim  bbsteps wellformedb bstep bsteps Btyping lc_term : core.


From Coq Require Import Lists.List.
Import ListNotations.

Lemma app_suf_eq : forall {A : Type} (xs : list A) ys zs,
  xs = ys -> xs ++ zs = ys ++ zs.
Proof.
  intros A xs ys zs.
  intros H.
  rewrite H.
  reflexivity.
Qed.

Lemma app_pref_eq : forall {A : Type} (l l' pref : list A),
  pref ++ l = pref ++ l' -> l = l'.
Proof.
  intros A l l' pref.
  induction pref as [|h t].
  - simpl. intros H. apply H.
  - intros H. rewrite <- app_comm_cons in H. rewrite <- app_comm_cons in H.
    injection H as H. apply IHt in H. apply H.
Qed.

Lemma app_pref_eq' : forall {A : Type} (l l' pref : list A),
  l = l' -> pref ++ l = pref ++ l'.
Proof.
  intros A l l' pref.
  intros H.
  rewrite H.
  reflexivity.
Qed.

Lemma app_pref_eq_r' : forall {A : Type} (l l' pref : list A),
  l = l' -> l ++ pref = l' ++ pref.
Proof.
  intros A l l' pref.
  intros H.
  rewrite H.
  reflexivity.
Qed.


(** * The Structure Identity Principle

A short proof of the SIP (HoTT book, chapter 9.8)

*)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Local Open Scope cat.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Local Open Scope mor_disp_scope.

(** * The Structure Identity Principle *)

Section SIP.

(** ** The data and properties according to HoTT book, chapter 9.8 *)

Variable C : category.
Variable univC : is_univalent C.
Variable P : ob C -> UU.
Variable Pisset : ∏ x, isaset (P x).
Variable H : ∏ (x y : C), P x → P y → C⟦x,y⟧ → UU.
Arguments H {_ _} _ _ _ .
Variable Hisprop : ∏ x y a b (f : C⟦x,y⟧), isaprop (H a b f).
Variable Hid : ∏ (x : C) (a : P x), H a a (identity _ ).
Variable Hcomp : ∏ (x y z : C) a b c (f : C⟦x,y⟧) (g : C⟦y,z⟧),
                 H a b f → H b c g → H a c (f · g).
Variable Hstandard : ∏ (x : C) (a a' : P x),
                     H a a' (identity _ ) → H a' a (identity _ ) → a = a'.

(** ** A displayed precategory from the data *)

Definition disp_cat_from_SIP_data : disp_cat C
  := disp_struct C P (@H) Hisprop Hid Hcomp.

(** ** Displayed category from SIP data is univalent *)

Lemma is_univalent_disp_from_SIP_data : is_univalent_disp disp_cat_from_SIP_data.
Proof.
  apply is_univalent_disp_from_fibers.
  intros x a b.
  apply isweqimplimpl.
  - intro i. apply Hstandard.
    * apply i.
    * apply (inv_mor_disp_from_z_iso i).
  - apply Pisset.
  - apply isofhleveltotal2.
    + apply Hisprop.
    + intro. apply (@isaprop_is_z_iso_disp _ disp_cat_from_SIP_data).
Defined.

(** ** The conclusion of SIP: total category is univalent *)

Definition SIP : is_univalent (total_category disp_cat_from_SIP_data).
Proof.
  apply is_univalent_total_category.
  - apply univC.
  - apply is_univalent_disp_from_SIP_data.
Defined.

End SIP.

(** TODO: add some examples *)


(** Generalization of [Forall_inf] to dependent product *)

From Coq Require Export Eqdep_dec.
From Coq Require Import PeanoNat List.
From OLlibs Require Import List_Type.

Set Implicit Arguments.
Set Default Proof Using "Type".

(** * [In_Forall_inf] *)

Section In_Forall_inf.
  Variable A : Type.
  Variable P : A -> Type.

  Fixpoint In_Forall_inf l (a : A) (Pa : P a) (Fl : Forall_inf P l) : Type :=
    match Fl with
    | Forall_inf_nil _ => False
    | Forall_inf_cons b Pb Fl => ((existT P a Pa) = (existT P b Pb)) + In_Forall_inf Pa Fl
    end.

  Lemma In_Forall_inf_elt l1 l2 a (Fl : Forall_inf P (l1 ++ a :: l2)) : { Pa : P a & In_Forall_inf Pa Fl }.
  Proof.
  induction l1 as [|b l1 IHl1] in l2, a, Fl |- *.
  - simpl in Fl.
    remember (a :: l2) eqn:Heql.
    destruct Fl as [|? ? p Fl]; inversion Heql; subst.
    exists p. left. reflexivity.
  - remember ((b :: l1) ++ a :: l2) eqn:Heql.
    destruct Fl as [|? ? p Fl]; inversion Heql; subst.
    destruct IHl1 with l2 a Fl as [Pa Hin].
    exists Pa. right. assumption.
  Qed.

  Lemma In_Forall_inf_in l a (Fl : Forall_inf P l) : In_inf a l -> { Pa : P a & In_Forall_inf Pa Fl }.
  Proof.
  induction l as [|b l IHl] in a, Fl |- *; intros Hin; inversion Hin; subst.
  - remember (a :: l) as l' eqn:Heql'.
    destruct Fl as [|? ? p Fl]; inversion Heql'; subst.
    exists p. left. reflexivity.
  - remember (b :: l) as l' eqn:Heql'.
    destruct Fl as [|? ? p Fl]; inversion Heql'; subst.
    destruct IHl with a Fl as [Pa Hin']; [ assumption | ].
    exists Pa. right. assumption.
  Qed.

  Fixpoint Forall_inf_sum (f : forall a, P a -> nat) (l : list A) (Pl : Forall_inf P l) :=
    match Pl with
    | Forall_inf_nil _ => 0
    | Forall_inf_cons x Px Pl => (f x Px) + (Forall_inf_sum f Pl)
    end.

  Fixpoint Forall_inf_App l1 l2 Pl1 Pl2 :=
    match Pl1 with
    | Forall_inf_nil _ => Pl2
    | @Forall_inf_cons _ _ x l Px Pl => @Forall_inf_cons _ P x (l ++ l2) Px
                                                         (Forall_inf_App l l2 Pl Pl2)
    end.

  Lemma Forall_inf_sum_app f l1 l2 (Pl1 : Forall_inf P l1) (Pl2 : Forall_inf P l2) :
      Forall_inf_sum f (Forall_inf_App Pl1 Pl2)
    = Forall_inf_sum f Pl1 + Forall_inf_sum f Pl2.
  Proof. induction Pl1 as [| ? ? ? ? IHPl1]; [ reflexivity | ]. simpl. rewrite IHPl1. apply Nat.add_assoc. Qed.

  Lemma In_Forall_inf_to_In_inf l (L : list A) (p : P l) (PL : Forall_inf P L) : In_Forall_inf p PL -> In_inf l L.
  Proof.
  intros Hin. induction PL; [ inversion Hin | inversion Hin as [He|]]; [ left | right; auto ].
  injection He as [= ->]. reflexivity.
  Qed.

End In_Forall_inf.

(** * [Dependent_Forall_inf] *)

Inductive Dependent_Forall_inf A (P : A -> Type) (Pred : forall a, P a -> Type) :
   forall l, Forall_inf P l -> Type :=
| Dependent_Forall_inf_nil : Dependent_Forall_inf Pred (Forall_inf_nil P)
| Dependent_Forall_inf_cons a l Pa (Fl : Forall_inf P l) : (Pred a Pa) ->
           Dependent_Forall_inf Pred Fl -> Dependent_Forall_inf Pred (Forall_inf_cons a Pa Fl).

Section Eq_Dec.

  Variable A : Type.
  Hypothesis eq_dec : forall (x y : A), {x = y} + {x <> y}.

  Lemma Dependent_Forall_inf_forall (P : A -> Type) Pred l a Pa (Fl : Forall_inf P l) :
    Dependent_Forall_inf Pred Fl -> In_Forall_inf a Pa Fl -> Pred a Pa.
  Proof using eq_dec.
  intros DFl. revert a Pa; induction DFl as [|? ? ? ? ? ? IH]; intros a' Pa' Hin;
    [ inversion Hin | inversion Hin as [He|Heq] ].
  - injection He as [= -> He].
    apply inj_pair2_eq_dec in He as ->; assumption.
  - apply IH. assumption.
  Qed.

  Lemma forall_Dependent_Forall_inf (P : A -> Type) Pred l (Fl : Forall_inf P l) :
    (forall a Pa, In_Forall_inf a Pa Fl -> Pred a Pa) ->
    Dependent_Forall_inf Pred Fl.
  Proof.
  induction Fl as [|? ? ? ? IH]; intros f; constructor.
  - apply f. left. reflexivity.
  - apply IH. intros a Pa Hin.
    apply f. right. assumption.
  Qed.

  Lemma Dependent_Forall_inf_inv (P : A -> Type) Pred a l Pa : forall (Pl : Forall_inf P l),
    Dependent_Forall_inf Pred (Forall_inf_cons a Pa Pl) -> Pred a Pa.
  Proof using eq_dec.
  intros Pl DPl. inversion DPl as [| ? ? Pb]. subst.
  replace Pa with Pb; [ assumption | ].
  apply inj_pair2_eq_dec; assumption.
  Qed.

  Lemma Dependent_Forall_inf_dec (P :A -> Type) Pred (dec_Pred : forall a Pa, Pred a Pa + notT (Pred a Pa)) l
    (Fl : Forall_inf P l) : Dependent_Forall_inf Pred Fl + (Dependent_Forall_inf Pred Fl -> False).
  Proof using eq_dec.
  induction Fl as [|x l p ? [HFl|HFl]].
  - left. apply Dependent_Forall_inf_nil.
  - destruct dec_Pred with x p as [HPa | HnPa].
    + left. apply Dependent_Forall_inf_cons; assumption.
    + right. intro DFl. inversion DFl as [|? ? Pb].
      apply HnPa.
      replace p with Pb; [ assumption | ].
      apply inj_pair2_eq_dec; assumption.
  - right. intro DFl. inversion DFl as [|? ? ? ? ? ? Heq [He1 He2]].
    apply inj_pair2_eq_dec in He2; [ subst | apply list_eq_dec, eq_dec ].
    apply HFl. assumption.
  Qed.

  Lemma Dependent_Forall_inf_arrow (P : A -> Type) Pred1 Pred2 :
    (forall a Pa, Pred1 a Pa -> Pred2 a Pa) ->
    forall l (Fl : Forall_inf P l), Dependent_Forall_inf Pred1 Fl -> Dependent_Forall_inf Pred2 Fl.
  Proof. intros f l Fl DFl. induction DFl; constructor; auto. Qed.

  Lemma Dependent_Forall_inf_app (P : A -> Type) Pred l1 l2 (Fl1 : Forall_inf P l1) (Fl2 : Forall_inf P l2) :
    Dependent_Forall_inf Pred Fl1 -> Dependent_Forall_inf Pred Fl2 ->
    { Fl : Forall_inf P (l1 ++ l2) & Dependent_Forall_inf Pred Fl }.
  Proof.
  intros DFl1. induction DFl1 as [|a l Pa ? ? ? IH] in Fl2 |- *; intros DFl2.
  - exists Fl2. assumption.
  - destruct IH with Fl2 as [Fl0 DFl]; [ assumption | ].
    exists (Forall_inf_cons a Pa Fl0).
    apply Dependent_Forall_inf_cons; assumption.
  Qed.

  Lemma Dependent_Forall_inf_app_inv (P : A -> Type) Pred l1 l2 (Fl : Forall_inf P (l1 ++ l2)) :
     Dependent_Forall_inf Pred Fl ->
       { Fl1 : Forall_inf P l1 & Dependent_Forall_inf Pred Fl1 }
     * { Fl2 : Forall_inf P l2 & Dependent_Forall_inf Pred Fl2 }.
  Proof.
  induction l1 as [|a l1 IHl1]; intro DFl.
  - split.
    + exists (Forall_inf_nil P). apply Dependent_Forall_inf_nil.
    + exists Fl. assumption.
  - inversion DFl as [|b lb Pa Fl0].
    destruct IHl1 with Fl0 as [[Fl1 DFl1] [Fl2 DFl2]]; [ assumption | ].
    split.
    + exists (Forall_inf_cons a Pa Fl1).
      apply Dependent_Forall_inf_cons; assumption.
    + exists Fl2. assumption.
  Qed.

  Lemma Dependent_Forall_inf_elt_inv (P : A -> Type) Pred l1 l2 a (Fl : Forall_inf P (l1 ++ a :: l2)) :
    Dependent_Forall_inf Pred Fl -> { Pa : P a & Pred a Pa }.
  Proof.
  intros DFl. apply Dependent_Forall_inf_app_inv in DFl as [_ [Fl2 DFl2]].
  inversion_clear DFl2 as [|b l Pa]. exists Pa. assumption.
  Qed.

End Eq_Dec.

From OLlibs Require Import dectype.
From OLlibs Require issue12394. (* TODO remove when issue #12394 solved *)

(* TODO dealing with issue coq/coq#12394 *)
(* Example:
  [ old code
         apply inj_pair2_eq_dec in H2; [ | apply list_eq_dec, (@eq_dt_dec Hdec)].
         apply inj_pair2_eq_dec in H3; [ | apply list_eq_dec, list_eq_dec (@eq_dt_dec Hdec)].
         subst.
    new code should be cbnified or old code back once coq/coq#12394 solved
         apply inj_pair2_eq_dec in H2;
           [ | apply (@list_eq_dec _ (@eqb (list_dectype Hdec))); apply eqb_eq ].
         assert (Pa = p) as Heq; subst.
         { apply issue12394.injection_list_Forall_inf_cons in H2 as [-> _]; [ reflexivity | ].
           apply (@list_eq_dec _ (@eqb Hdec)); apply eqb_eq. } *)
Ltac Dependent_Forall_inversion Hdec H :=
  match type of H with
  | Dependent_Forall_inf _ _ =>
    let a := fresh in
    let b := fresh in
    let L := fresh "L" in
    let H1 := fresh H in
    let H2 := fresh H in
    let H3 := fresh H in
    let Heq1 := fresh in
    let Heq2 := fresh in
    let Heq := fresh "HeqD" in
    inversion H as [|a b L H1 H2 H3 [Heq1 Heq2] Heq]; subst a; subst b;
    apply inj_pair2_eq_dec in Heq;
      [ | apply (@list_eq_dec _ (@eqb (list_dectype Hdec))); apply eqb_eq ];
    apply issue12394.injection_list_Forall_inf_cons in Heq as [-> ->];
      [ | apply (@list_eq_dec _ (@eqb Hdec)); apply eqb_eq ]
  end.