(** Operations, lemmas, and tactics for working with environments,
    association lists whose keys are atoms.  Unless stated otherwise,
    implicit arguments will not be declared by default.

    Authors: Brian Aydemir and Arthur Charguéraud, with help from
    Aaron Bohannon, Benjamin Pierce, Jeffrey Vaughan, Dimitrios
    Vytiniotis, Stephanie Weirich, and Steve Zdancewic.

    Table of contents:
      - #Overview#
      - #Functions on environments#
      - #Relations on environments#
      - #Properties of operations#
      - #Automation and tactics (I)#
      - #Properties of well-formedness and freshness#
      - #Properties of binds#
      - #Automation and tactics (II)#
      - #Additional properties of binds#
      - #Automation and tactics (III)# *)

Require Export List.
Require Export ListFacts.
Require Import Atom.

Import AtomSet.F.
Hint Unfold E.eq.

(* ********************************************************************** *)
(** * ## Overview *)

(** An environment is a list of pairs, where the first component of
    each pair is an [atom].  We view the second component of each pair
    as being bound to the first component.  In a well-formed
    environment, there is at most one binding for any given atom.
    Bindings at the head of the list are "more recent" than bindings
    toward the tail of the list, and we view an environment as growing
    on the left, i.e., at its head.

    We normally work only with environments built up from the
    following: the empty list, one element lists, and concatenations
    of two lists.  This seems to be more convenient in practice.  For
    example, we don't need to distinguish between consing on a binding
    and concatenating a binding, a difference that Coq's tactics can
    be sensitive to.

    However, basic definitions are by induction on the usual structure
    of lists ([nil] and [cons]).

    To make it convenient to write one element lists, we define a
    special notation.  Note that this notation is local to this
    particular library, to allow users to use alternate notations if
    they desire. *)

Notation "[ x ]" := (cons x nil).

(** In the remainder of this library, we define a number of
    operations, lemmas, and tactics that simplify working with
    environments. *)

(* ********************************************************************** *)
(** * ## Functions on environments *)

(** Implicit arguments will be declared by default for the definitions
    in this section. *)

Set Implicit Arguments.

Section Definitions.

Variables A B : Type.

(** The domain of an environment is the set of atoms that it maps. *)

Fixpoint dom (E : list (atom * A)) : atoms :=
  match E with
  | nil => empty
  | (x, _) :: E' => union (singleton x) (dom E')
  end.

(** [map] applies a function to all bindings in the environment. *)

Fixpoint map (f : A -> B) (E : list (atom * A)) : list (atom * B) :=
  match E with
  | nil => nil
  | (x, V) :: E' => (x, f V) :: map f E'
  end.

(** [get] returns the value bound to the given atom in an environment
    or [None] if the given atom is not bound.  If the atom has
    multiple bindings, the one nearest to the head of the environment
    is returned. *)

Fixpoint get (x : atom) (E : list (atom * A)) : option A :=
  match E with
  | nil => None
  | (y,a) :: E' => if eq_atom_dec x y then Some a else get x E'
  end.

End Definitions.

Unset Implicit Arguments.

(* ********************************************************************** *)
(** * ## Relations on environments *)

(** Implicit arguments will be declared by default for the definitions
    in this section. *)

Set Implicit Arguments.

Section Relations.

Variable A : Type.

(** An environment is well-formed if and only if each atom is bound at
    most once. *)

Inductive ok : list (atom * A) -> Prop :=
  | ok_nil :
      ok nil
  | ok_cons : forall (E : list (atom * A)) (x : atom) (a : A),
      ok E -> ~ In x (dom E) -> ok ((x, a) :: E).

(** ## An environment [E] contains a binding
    from [x] to [b], denoted [(binds x b E)], if and only if the most
    recent binding for [x] is mapped to [b]. *)

Definition binds x b (E : list (atom * A)) :=
  get x E = Some b.

End Relations.

Unset Implicit Arguments.

(* ********************************************************************** *)
(** * ## Properties of operations *)

Section OpProperties.
Variable A B : Type.
Implicit Types E F : list (atom * A).
Implicit Types a b : A.

(** ** Facts about concatenation *)

Lemma concat_nil : forall E,
  E ++ nil = E.
Proof.
  auto using List.app_nil_end.
Qed.

Lemma nil_concat : forall E,
  nil ++ E = E.
Proof.
  reflexivity.
Qed.

Lemma concat_assoc : forall E F G,
  (G ++ F) ++ E = G ++ (F ++ E).
Proof.
  auto using List.app_ass.
Qed.

(** ** [map] commutes with environment-building operations *)

Lemma map_nil : forall (f : A -> B),
  map f nil = nil.
Proof.
  reflexivity.
Qed.

Lemma map_single : forall (f : A -> B) y b,
  map f [(y,b)] = [(y, f b)].
Proof.
  reflexivity.
Qed.

Lemma map_push : forall (f : A -> B) y b E,
  map f ([(y,b)] ++ E) = [(y, f b)] ++ map f E.
Proof.
  reflexivity.
Qed.

Lemma map_concat : forall (f : A -> B) E F,
  map f (F ++ E) = (map f F) ++ (map f E).
Proof.
  induction F as [|(x,a)]; simpl; congruence.
Qed.

(** ** Facts about the domain of an environment *)

Lemma dom_nil :
  @dom A nil = empty.
Proof.
  reflexivity.
Qed.

Lemma dom_single : forall x a,
  dom [(x,a)] = singleton x.
Proof.
  simpl. intros. fsetdec.
Qed.

Lemma dom_push : forall x a E,
  dom ([(x,a)] ++ E) = union (singleton x) (dom E).
Proof.
  simpl. intros. reflexivity.
Qed.

Lemma dom_concat : forall E F,
  dom (F ++ E) = union (dom F) (dom E).
Proof.
  induction F as [|(x,a) F IH]; simpl.
  fsetdec.
  rewrite IH. fsetdec.
Qed.

Lemma dom_map : forall (f : A -> B) E,
  dom (map f E) = dom E.
Proof.
  induction E as [|(x,a)]; simpl; congruence.
Qed.

(** ** Other trivial rewrites *)

Lemma cons_concat_assoc : forall x a E F,
   ((x, a) :: E) ++ F = (x, a) :: (E ++ F).
Proof.
  reflexivity.
Qed.

End OpProperties.

(* ********************************************************************** *)
(** * ## Automation and tactics (I) *)

(** ** [simpl_env] *)

(** The [simpl_env] tactic can be used to put environments in the
    standardized form described above, with the additional properties
    that concatenation is associated to the right and empty
    environments are removed.  Similar to the [simpl] tactic, we
    define "[in *]" and "[in H]" variants of [simpl_env]. *)

Definition singleton_list (A : Type) (x : atom * A) := x :: nil.

Lemma cons_concat : forall (A : Type) (E : list (atom * A)) x a,
  (x, a) :: E = singleton_list A (x, a) ++ E.
Proof.
  reflexivity.
Qed.

Lemma map_singleton_list : forall (A B : Type) (f : A -> B) y b,
  map f (singleton_list A (y,b)) = [(y, f b)].
Proof.
  reflexivity.
Qed.

Lemma dom_singleton_list : forall (A : Type) (x : atom) (a : A),
  dom (singleton_list A (x,a)) = singleton x.
Proof.
  simpl. intros. fsetdec.
Qed.

Hint Rewrite
  cons_concat map_singleton_list dom_singleton_list
  concat_nil nil_concat concat_assoc
  map_nil map_single map_push map_concat
  dom_nil dom_single dom_push dom_concat dom_map : rew_env.

Ltac simpl_env_change_aux :=
  match goal with
    | H : context[?x :: nil] |- _ =>
      progress (change (x :: nil) with (singleton_list x) in H);
      simpl_env_change_aux
    | |- context[?x :: nil] =>
      progress (change (x :: nil) with (singleton_list x));
      simpl_env_change_aux
    | _ =>
      idtac
  end.

Ltac simpl_env :=
  simpl_env_change_aux;
  autorewrite with rew_env;
  unfold singleton_list in *.

Tactic Notation "simpl_env" "in" hyp(H) :=
  simpl_env_change_aux;
  autorewrite with rew_env in H;
  unfold singleton_list in *.

Tactic Notation "simpl_env" "in" "*" :=
  simpl_env_change_aux;
  autorewrite with rew_env in *;
  unfold singleton_list in *.

(** ** [rewrite_env] *)

(** The tactic [(rewrite_env E)] replaces an environment in the
    conclusion of the goal with [E].  Suitability for replacement is
    determined by whether [simpl_env] can put [E] and the chosen
    environment in the same normal form, up to convertability in Coq.
    We also define a "[in H]" variant that performs the replacement in
    a hypothesis [H]. *)

Tactic Notation "rewrite_env" constr(E) :=
  match goal with
    | |- context[?x] =>
      change x with E
    | |- context[?x] =>
      replace x with E; [ | try reflexivity; simpl_env; reflexivity ]
  end.

Tactic Notation "rewrite_env" constr(E) "in" hyp(H) :=
  match type of H with
    | context[?x] =>
      change x with E in H
    | context[?x] =>
      replace x with E in H; [ | try reflexivity; simpl_env; reflexivity ]
  end.

(** ** Hints *)

Hint Constructors ok.

Hint Extern 1 (~ In _ _) => simpl_env in *; fsetdec.

(* ********************************************************************** *)
(** * ## Properties of well-formedness and freshness *)

Section OkProperties.
Variable A B : Type.
Implicit Types E F : list (atom * A).
Implicit Types a b : A.

(** Facts about when an environment is well-formed. *)

Lemma ok_push :  forall (E : list (atom * A)) (x : atom) (a : A),
      ok E -> ~ In x (dom E) -> ok ([(x, a)] ++ E).
Proof.
  exact (@ok_cons A).
Qed.

Lemma ok_singleton : forall x a,
  ok [(x,a)].
Proof.
  auto.
Qed.

Lemma ok_remove_mid : forall F E G,
  ok (G ++ F ++ E) -> ok (G ++ E).
Proof with auto.
  induction G as [|(y,a)]; intros Ok.
    induction F as [|(y,a)]; simpl... inversion Ok...
    inversion Ok. simpl...
Qed.

Lemma ok_remove_mid_cons : forall x a E G,
  ok (G ++ (x, a) :: E) ->
  ok (G ++ E).
Proof.
  intros. simpl_env in *. eauto using ok_remove_mid.
Qed.

Lemma ok_map : forall E (f : A -> B),
  ok E -> ok (map f E).
Proof with auto.
  intros.
  induction E as [ | (y,b) E ] ; simpl...
  inversion H...
Qed.

Lemma ok_map_app_l : forall E F (f : A -> A),
  ok (F ++ E) -> ok (map f F ++ E).
Proof with auto.
  intros. induction F as [|(y,a)]; simpl...
  inversion H...
Qed.

(** A binding in the middle of an environment has an atom fresh from
    all bindings before and after it. *)

Lemma fresh_mid_tail : forall E F x a,
  ok (F ++ [(x,a)] ++ E) -> ~ In x (dom E).
Proof with auto.
  induction F as [|(y,b)]; intros x c Ok; simpl_env in *.
    inversion Ok...
    inversion Ok; subst. simpl_env in *. apply (IHF _ _ H1).
Qed.

Lemma fresh_mid_head : forall E F x a,
  ok (F ++ [(x,a)] ++ E) -> ~ In x (dom F).
Proof with auto.
  induction F as [|(y,b)]; intros x c Ok; simpl_env in *.
    inversion Ok...
    inversion Ok; subst. simpl_env in *. pose proof (IHF _ _ H1)...
Qed.

End OkProperties.

(* ********************************************************************** *)
(** * ## Properties of [binds] *)

Section BindsProperties.
Variable A B : Type.
Implicit Types E F : list (atom * A).
Implicit Types a b : A.

(** ** Introduction forms for [binds] *)

(** The following properties allow one to view [binds] as an
    inductively defined predicate.  This is the preferred way of
    working with the relation. *)

Lemma binds_singleton : forall x a,
  binds x a [(x,a)].
Proof.
  intros x a. unfold binds. simpl. destruct (eq_atom_dec x x); intuition.
Qed.

Lemma binds_tail : forall x a E F,
  binds x a E -> ~ In x (dom F) -> binds x a (F ++ E).
Proof with auto.
  unfold binds. induction F as [|(y,b)]; simpl...
  destruct (eq_atom_dec x y)... intros _ J. destruct J. fsetdec.
Qed.

Lemma binds_head : forall x a E F,
  binds x a F -> binds x a (F ++ E).
Proof.
  unfold binds. induction F as [|(y,b)]; simpl; intros H.
  discriminate.
  destruct (eq_atom_dec x y); intuition.
Qed.

(** ** Case analysis on [binds] *)

Lemma binds_concat_inv : forall x a E F,
  binds x a (F ++ E) -> (~ In x (dom F) /\ binds x a E) \/ (binds x a F).
Proof with auto.
  unfold binds. induction F as [|(y,b)]; simpl; intros H...
  destruct (eq_atom_dec x y).
    right...
    destruct (IHF H) as [[? ?] | ?]. left... right...
Qed.

Lemma binds_singleton_inv : forall x y a b,
  binds x a [(y,b)] -> x = y /\ a = b.
Proof.
  unfold binds. simpl. intros. destruct (eq_atom_dec x y).
    split; congruence.
    discriminate.
Qed.

(** ** Retrieving bindings from an environment *)

Lemma binds_mid : forall x a E F,
  ok (F ++ [(x,a)] ++ E) -> binds x a (F ++ [(x,a)] ++ E).
Proof with auto.
  unfold binds. induction F as [|(z,b)]; simpl; intros Ok.
  destruct (eq_atom_dec x x); intuition.
  inversion Ok; subst. destruct (eq_atom_dec x z)...
    destruct H3. simpl_env. fsetdec.
Qed.

Lemma binds_mid_eq : forall z a b E F,
  binds z a (F ++ [(z,b)] ++ E) -> ok (F ++ [(z,b)] ++ E) -> a = b.
Proof with auto.
  unfold binds. induction F as [|(x,c)]; simpl; intros H Ok.
  destruct (eq_atom_dec z z). congruence. intuition.
  inversion Ok; subst. destruct (eq_atom_dec z x)...
    destruct H4. simpl_env. fsetdec.
Qed.

Lemma binds_mid_eq_cons : forall x a b E F,
  binds x a (F ++ (x,b) :: E) ->
  ok (F ++ (x,b) :: E) ->
  a = b.
Proof.
  intros. simpl_env in *. eauto using binds_mid_eq.
Qed.

End BindsProperties.

(* ********************************************************************** *)
(** * ## Automation and tactics (II) *)

(** ** Hints *)

Hint Immediate ok_remove_mid ok_remove_mid_cons.

Hint Resolve
  ok_push ok_singleton ok_map ok_map_app_l
  binds_singleton binds_head binds_tail.

(** ** [binds_get] *)

(** The tactic [(binds_get H)] takes a hypothesis [H] of the form
    [(binds x a (F ++ [(x,b)] ++ E))] and introduces the equality
    [a=b] into the context.  Then, the tactic checks if the equality
    is discriminable and otherwise tries substituting [b] for [a].
    The [auto] tactic is used to show that [(ok (F ++ [(x,b)] ++ E))],
    which is needed to prove the equality [a=b] from [H]. *)

Ltac binds_get H :=
  match type of H with
    | binds ?z ?a (?F ++ [(?z,?b)] ++ ?E) =>
        let K := fresh in
          assert (K : ok (F ++ [(z,b)] ++ E));
          [ auto
          | let J := fresh in
              assert (J := @binds_mid_eq _ _ _ _ _ _ H K);
              clear K;
              try discriminate;
              try match type of J with
                    | ?a = ?b => subst a
                  end
          ]
  end.

(** ** [binds_cases] *)

(** The tactic [(binds_case H)] performs a case analysis on an
    hypothesis [H] of the form [(binds x a E)].  There will be one
    subgoal for each component of [E] that [x] could be bound in, and
    each subgoal will have appropriate freshness conditions on [x].
    Some attempts are made to automatically discharge contradictory
    cases. *)

Ltac binds_cases H :=
  let Fr := fresh "Fr" in
  let J1 := fresh in
  let J2 := fresh in
    match type of H with
      | binds _ _ nil =>
          inversion H
      | binds ?x ?a [(?y,?b)] =>
          destruct (@binds_singleton_inv _ _ _ _ _ H);
          clear H;
          try discriminate;
          try subst y;
          try match goal with
                | _ : ?z <> ?z |- _ => intuition
              end
      | binds ?x ?a (?F ++ ?E) =>
          destruct (@binds_concat_inv _ _ _ _ _ H) as [[Fr J1] | J2];
          clear H;
          [ binds_cases J1 | binds_cases J2 ]
      | _ => idtac
  end.

(* *********************************************************************** *)
(** * ## Additional properties of [binds] *)

(** The following lemmas are proven in manner that should be
    independent of the concrete definition of [binds]. *)

Section AdditionalBindsProperties.
Variable A B : Type.
Implicit Types E F : list (atom * A).
Implicit Types a b : A.

(** Lemmas about the relationship between [binds] and the domain of an
    environment. *)

Lemma binds_In : forall a x E,
  binds x a E -> In x (dom E).
Proof.
  induction E as [|(y,b)]; simpl_env; intros H.
  binds_cases H.
  binds_cases H; subst. auto using union_3. fsetdec.
Qed.

Lemma binds_fresh : forall x a E,
  ~ In x (dom E) -> ~ binds x a E.
Proof.
  induction E as [|(y,b)]; simpl_env; intros Fresh H.
  binds_cases H.
  binds_cases H. intuition. fsetdec.
Qed.

(** Additional lemmas for showing that a binding is in an
    environment. *)

Lemma binds_map : forall x a (f : A -> B) E,
  binds x a E -> binds x (f a) (map f E).
Proof.
  induction E as [|(y,b)]; simpl_env; intros H.
  binds_cases H.
  binds_cases H; auto. subst; auto.
Qed.

Lemma binds_concat_ok : forall x a E F,
  binds x a E -> ok (F ++ E) -> binds x a (F ++ E).
Proof.
  induction F as [|(y,b)]; simpl_env; intros H Ok.
  auto.
  inversion Ok; subst. destruct (eq_atom_dec x y); subst; auto.
    assert (In y (dom (F ++ E))) by eauto using binds_In.
    intuition.
Qed.

Lemma binds_weaken : forall x a E F G,
  binds x a (G ++ E) ->
  ok (G ++ F ++ E) ->
  binds x a (G ++ F ++ E).
Proof.
  induction G as [|(y,b)]; simpl_env; intros H Ok.
  auto using binds_concat_ok.
  inversion Ok; subst. binds_cases H; subst; auto.
Qed.

Lemma binds_weaken_at_head : forall x a F G,
  binds x a G ->
  ok (F ++ G) ->
  binds x a (F ++ G).
Proof.
  intros x a F G H J.
  rewrite_env (nil ++ F ++ G).
  apply binds_weaken; simpl_env; trivial.
Qed.

Lemma binds_remove_mid : forall x y a b F G,
  binds x a (F ++ [(y,b)] ++ G) ->
  x <> y ->
  binds x a (F ++ G).
Proof.
  intros x y a b F G H J.
  binds_cases H; auto.
Qed.

Lemma binds_remove_mid_cons : forall x y a b E G,
  binds x a (G ++ (y, b) :: E) ->
  x <> y ->
  binds x a (G ++ E).
Proof.
  intros. simpl_env in *. eauto using binds_remove_mid.
Qed.

End AdditionalBindsProperties.

(* *********************************************************************** *)
(** * ## Automation and tactics (III) *)

Hint Resolve binds_map binds_concat_ok binds_weaken binds_weaken_at_head.

Hint Immediate binds_remove_mid binds_remove_mid_cons : core.


Require Import VST.msl.msl_direct.
Require Import RamifyCoq.msl_ext.ramify_tactics.
Require Import RamifyCoq.msl_ext.overlapping_direct.
Require Import VST.msl.predicates_sa.

Lemma precise_left_sepcon_andp_distr {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CA : Canc_alg A}:
  forall P P1 P2 Q R, precise P -> P1 |-- P -> P2 |-- P -> (P1 * Q) && (P2 * R) |-- (P1 && P2) * (Q && R).
Proof.
  intros.
  unfold sepcon, andp, derives; simpl.
  intros.
  destruct H2 as [[?y [?z [? [? ?]]]] [?y [?z [? [? ?]]]]].
  exists y, z.
  assert (P y) by auto.
  assert (P y0) by auto.
  equate_precise_direct y y0.
  equate_canc z z0.
  repeat split; auto.
Qed.

(* derives_precise, precise_emp is in predicates_sa.v. *)

Lemma precise_sepcon {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A}:
  forall P Q, precise Q -> precise P -> precise (P * Q).
Proof.
  repeat intro; destruct H1 as [w11 [w12 [? [? ?]]]], H2 as [w21 [w22 [? [? ?]]]].
  assert (w11 = w21) by (apply join_join_sub in H1; generalize (join_sub_trans H1 H3); intro;
                         apply join_join_sub in H2; generalize (join_sub_trans H2 H4); intro;
                         hnf in H0; apply H0 with (w := w); trivial).
  assert (w12 = w22) by (apply join_join_sub' in H1; generalize (join_sub_trans H1 H3); intro;
                         apply join_join_sub' in H2; generalize (join_sub_trans H2 H4); intro;
                         hnf in H; apply H with (w := w); trivial).
  rewrite H9 in *; rewrite H10 in *; equate_join w1 w2; auto.
Qed.

Lemma precise_wand_ewand {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CA : Canc_alg A}:
  forall R P Q R', precise P -> R |-- P * (Q -* R') -> Q * (ewand P R) |-- R'.
Proof.
  intros. intro w. intros. destruct_sepcon H1 h. destruct H3 as [h3 [h4 [? [? ?]]]].
  specialize (H0 h4 H5). destruct_sepcon H0 h. equate_precise_direct h3 h0.
  equate_canc h2 h5. apply (H7 h1); auto.
Qed.

(*
Lemma overlapping_precise_emp {A} {JA : Join A} {PA : Perm_alg A} {SA : Sep_alg A} {CA : Canc_alg A} {DA : Disj_alg A} {AG : ageable A} {AA: Age_alg A}:
  forall w1 w2 w3 w12 w23 w (P Q : pred A),
    join w1 w2 w12 -> join w2 w3 w23 -> join w12 w3 w -> P w12 -> Q w23 -> precise P -> precise Q -> (P * Q)%pred w -> emp w2.
Proof.
  intros. destruct_sepcon H6 k. try_join w2 w3 w23'; equate_join w23 w23'. equate_precise w12 k1. equate_precise w23 k2.
  apply join_sub_joins_identity with w23. exists w3; auto. try_join w2 w23 w223; exists w223; auto.
Qed.

Lemma precise_andp_left {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {AG : ageable A} {AA: Age_alg A} :
  forall P Q, precise P -> precise (P && Q).
Proof. intros; intro; intros; destruct H0; destruct H1; generalize (H w w1 w2 H0 H1 H2 H3); tauto. Qed.

Lemma precise_andp_right {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {AG : ageable A} {AA: Age_alg A} :
  forall P Q, precise Q -> precise (P && Q).
Proof. intros; intro; intros; destruct H0; destruct H1; generalize (H w w1 w2 H4 H5 H2 H3); tauto. Qed.
*)

(*
Lemma precise_exp_sepcon {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {AG : ageable A} {AA: Age_alg A} B:
  forall P Q: B -> pred A, precise (exp P) -> precise (exp Q) -> precise (EX x : B, P x * Q x).
Proof.
  repeat intro.
  destruct H1 as [x [w11 [w12 [? [? ?]]]]]; destruct H2 as [y [w21 [w22 [? [? ?]]]]].
  specialize (H w w11 w21); specialize (H0 w w12 w22).
  assert (w11 = w21) by (apply H; [exists x; auto | exists y; auto |
                                   apply join_sub_trans with (b := w1); apply join_join_sub in H1; auto |
                                   apply join_sub_trans with (b := w2); apply join_join_sub in H2; auto]).
  assert (w12 = w22) by (apply H0; [exists x; auto | exists y; auto |
                                    apply join_sub_trans with (b := w1); apply join_join_sub' in H1; auto |
                                    apply join_sub_trans with (b := w2); apply join_join_sub' in H2; auto]).
  rewrite H9 in *; rewrite H10 in *; equate_join w1 w2; auto.
Qed.

Lemma precise_tri_exp_andp_right {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {AG : ageable A} {AA: Age_alg A} B:
  forall (P Q: B -> B -> B -> pred A),
    precise (EX x : B, EX y : B, EX z : B, Q x y z) ->
    precise (EX x : B, EX y : B, EX z : B, P x y z && Q x y z).
Proof.
  repeat intro; destruct H0 as [x1 [y1 [z1 [? ?]]]], H1 as [x2 [y2 [z2 [? ?]]]];
  hnf in H; apply H with (w := w); [exists x1, y1, z1 | exists x2, y2, z2 | | ]; auto.
Qed.

Lemma precise_tri_exp_andp_left {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {AG : ageable A} {AA: Age_alg A} B:
  forall (P Q: B -> B -> B -> pred A),
    precise (EX x : B, EX y : B, EX z : B, P x y z) ->
    precise (EX x : B, EX y : B, EX z : B, P x y z && Q x y z).
Proof.
  repeat intro; destruct H0 as [x1 [y1 [z1 [? ?]]]], H1 as [x2 [y2 [z2 [? ?]]]];
  hnf in H; apply H with (w := w); [exists x1, y1, z1 | exists x2, y2, z2 | | ]; auto.
Qed.

Lemma precise_tri_exp_sepcon {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {AG : ageable A} {AA: Age_alg A} B:
  forall (P Q R: B -> pred A),
    precise (exp P) -> precise (exp Q) -> precise (exp R) -> precise (EX x : B, EX y : B, EX z : B, P x * Q y * R z).
Proof.
  repeat intro; destruct H2 as [x1 [y1 [z1 [h1 [h2 [? [[i1 [i2 [? [? ?]]]] ?]]]]]]];
  destruct H3 as [x2 [y2 [z2 [j1 [j2 [? [[k1 [k2 [? [? ?]]]] ?]]]]]]].
  assert (i1 = k1) by (hnf in H; apply H with (w := w);
                       [exists x1 | exists x2; auto | assertSub i1 w Hsub | assertSub k1 w Hsub]; auto).
  assert (i2 = k2) by (hnf in H0; apply H0 with (w := w);
                       [exists y1 | exists y2; auto | assertSub i2 w Hsub | assertSub k2 w Hsub]; auto).
  rewrite H14 in *; rewrite H15 in *; equate_join h1 j1.
  assert (h2 = j2) by (hnf in H1; apply H1 with (w := w);
                       [exists z1 | exists z2; auto | assertSub h2 w Hsub | assertSub j2 w Hsub]; auto).
  rewrite H10 in *; equate_join w1 w2; auto.
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                                                     *)

Require Export isocele.
Set Implicit Arguments.
Unset Strict Implicit.

Definition cercle (O : PO) (r : R) (M : PO) : Prop := distance O M = r.

Lemma cercle_isocele :
 forall (O A B : PO) (r : R), cercle O r A -> cercle O r B -> isocele O A B.
unfold cercle, isocele in |- *; intros.
rewrite H; rewrite H0; auto.
Qed.

Lemma existence_rayon : forall O A : PO, cercle O (distance O A) A.
unfold cercle in |- *; intros; auto.
Qed.

Lemma isocele_cercle :
 forall O A B : PO, isocele O A B -> cercle O (distance O A) B.
unfold cercle, isocele in |- *; intros; auto.
Qed.

Definition circonscrit (O A B C : PO) : Prop :=
  isocele O A B /\ isocele O A C.

Lemma circonscrit_isocele :
 forall O A B C : PO, circonscrit O A B C -> isocele O B C.
unfold circonscrit, isocele in |- *; intros; auto.
elim H; intros; auto.
rewrite <- H0; rewrite <- H1; auto.
Qed.

Lemma circonscrit_permute :
 forall O A B C : PO, circonscrit O B C A -> circonscrit O A B C.
unfold circonscrit in |- *; intros.
elim H; intros; split; auto with geo.
lapply (circonscrit_isocele (O:=O) (A:=B) (B:=C) (C:=A)); auto with geo.
Qed.

Lemma circonscrit_distinct1 :
 forall O A B C : PO, O <> A -> circonscrit O A B C -> O <> B.
unfold circonscrit, isocele in |- *; intros.
elim H0; [ intros H1 H2; try clear H0; try exact H2 ].
apply isometrie_distinct with (2 := H1); auto.
Qed.

Lemma circonscrit_distinct2 :
 forall O A B C : PO, O <> A -> circonscrit O A B C -> O <> C.
unfold circonscrit, isocele in |- *; intros.
elim H0; [ intros H1 H2; try clear H0; try exact H2 ].
apply isometrie_distinct with (2 := H2); auto.
Qed.

Lemma circonscrit_distinct3 :
 forall O A B C : PO, O <> B -> circonscrit O A B C -> O <> A.
intros.
assert (circonscrit O B C A).
apply circonscrit_permute.
apply circonscrit_permute; auto.
apply circonscrit_distinct2 with (2 := H1); auto.
Qed.

Definition cercle_rayon (O A M : PO) := isocele O A M.

Definition tangente_cercle (O A T M : PO) :=
  cercle_rayon O A T /\ orthogonal (vec T M) (vec T O).

Definition cercle_diametre (A B M : PO) :=
  exists O : PO, circonscrit O A B M /\ O = milieu A B.

Definition sont_cocycliques (A B C D : PO) :=
  ex (fun O : PO => circonscrit O A B C /\ circonscrit O A B D).

Ltac hcercle H :=
  generalize H;
   unfold cercle_diametre, tangente_cercle, cercle_rayon, cercle,
    sont_cocycliques, circonscrit, isocele in |- *;
   intros; repeat applatit_and; try split; auto with geo.

Ltac icercle :=
  unfold cercle_diametre, tangente_cercle, cercle_rayon, cercle,
   sont_cocycliques, circonscrit, isocele in |- *;
   intros; repeat applatit_and; try split; auto with geo.

Lemma cercle_diametre_permute :
 forall A B C : PO, cercle_diametre A B C -> cercle_diametre B A C.
icercle.
elim H;
 [ intros O H0; elim H0;
    [ intros H1 H2; elim H1;
       [ intros H3 H4; try clear H1 H0 H; try exact H4 ] ] ].
exists O; split; auto with geo.
split; [ auto | idtac ].
rewrite <- H3; auto.
Qed.
#[export] Hint Immediate cercle_diametre_permute: geo.

Lemma cercle_diametre_trivial : forall A B : PO, cercle_diametre A B A.
icercle.
discrimine A B.
exists B; split; auto with geo.
soit_milieu A B M.
exists M.
split; auto.
split; auto with geo.
Qed.

Lemma cercle_diametre_trivial2 : forall A B : PO, cercle_diametre A B B.
icercle.
discrimine A B.
exists B; split; auto with geo.
soit_milieu A B M.
exists M.
split; auto.
split; auto with geo.
Qed.
#[export] Hint Resolve cercle_diametre_trivial2 cercle_diametre_trivial: geo.

Lemma circonscrit_diametre :
 forall A B C D O : PO,
 circonscrit O A B C -> O = milieu A D -> cercle_diametre A D B.
icercle.
exists O.
split; [ split; [ auto with geo | try assumption ] | try assumption ].
Qed.

Lemma cercle_trivial :
 forall A B C D O : PO,
 circonscrit O A B C -> O = milieu A D -> sont_cocycliques A B C D.
icercle.
exists O.
split; [ split; [ try assumption | try assumption ] | try assumption ].
split; [ try assumption | auto with geo ].
Qed.

Lemma cercle_diametre_degenere :
 forall A B M : PO, A = B -> cercle_diametre A B M -> A = M.
intros A B M H; try assumption.
rewrite H; icercle.
elim H0;
 [ intros O' H1; elim H1;
    [ intros H2 H3; elim H2;
       [ intros H4 H5; try clear H2 H1 H0; try exact H5 ] ] ].
assert (O' = B).
rewrite (milieu_trivial B); auto.
rewrite <- H0.
apply distance_refl1.
rewrite <- H5; rewrite <- H0; auto with geo.
Qed.
Require Export dilatations.

Lemma existence_rayon_diametre :
 forall A B O : PO,
 cercle_rayon O A B -> exists C : PO, cercle_diametre A C B.
unfold cercle_rayon, isocele in |- *; intros.
symetrique O A M.
exists M.
icercle.
exists O.
auto with geo.
Qed.

Lemma existence_point_cercle : forall O A : PO,
exists C, cercle_rayon O A C.
Proof.
intros.
exists A.
unfold cercle_rayon.
unfold isocele.
auto with geo.
Qed.

Lemma alignes_diametre :
 forall A B A' : PO,
 alignes A A' B -> cercle_diametre A A' B -> B = A \/ B = A'.
unfold cercle_diametre in |- *; intros.
elim H0;
 [ intros O H1; elim H1; [ intros H2 H3; try clear H1 H0; try exact H3 ] ].
hcercle H2.
discrimine A A'.
assert (O = A).
rewrite H3; rewrite <- H0; rewrite <- milieu_trivial; auto.
rewrite <- H0.
right; try assumption.
rewrite <- H5.
symmetry  in |- *.
assert (distance O B = 0); auto with geo.
rewrite <- H4; rewrite <- H5; auto with geo.
halignes H k.
elim (classic (k = 0)); intros.
left; symmetry  in |- *.
apply (produit_zero_conf H5); auto.
discrimine O A.
left; symmetry  in |- *.
assert (distance O B = 0); auto with geo.
rewrite <- H4; rewrite <- H7; auto with geo.
right; try assumption.
assert (vec A B = mult_PP (2 * k) (vec A O)).
rewrite H5.
rewrite (milieu_vecteur_double H3); auto.
Ringvec.
assert (k = 1).
assert (vec O B = mult_PP (1 + - (2 * k)) (vec O A)).
VReplace (vec O B) (add_PP (vec A B) (vec O A)).
rewrite H8; Ringvec.
assert (Rsqr (1 + - (2 * k)) = 1).
assert (Rsqr (distance O A) = Rsqr (1 + - (2 * k)) * Rsqr (distance O A)).
pattern (distance O A) at 1 in |- *.
rewrite H4.
unfold Rsqr in |- *; repeat rewrite <- carre_scalaire_distance.
rewrite H9.
Simplscal.
apply Rmult_eq_reg_l with (Rsqr (distance O A)).
pattern (Rsqr (distance O A)) at 2 in |- *; rewrite H10 in |- *;  ring.
unfold Rsqr in |- *; apply Rmult_integral_contrapositive.
split; auto with geo.
assert (Rsqr (1 + - (2 * k)) + - Rsqr 1 = 0).
rewrite H10; unfold Rsqr in |- *; ring.
assert (2 * (1 + - k) * - (2 * k) = 0).
RReplace (- (2 * k)) (1 + - (2 * k) + -1).
RReplace (2 * (1 + - k)) (1 + - (2 * k) + 1).
rewrite <- H11; unfold Rsqr in |- *; ring.
assert (1 + - k = 0).
apply Rmult_eq_reg_l with (- (2 * k)); auto with real.
RReplace (- (2 * k) * 0) 0.
apply Rmult_eq_reg_l with 2; auto with real.
RReplace (2 * 0) 0.
rewrite <- H12; ring.
RReplace k (k + 0).
rewrite <- H13; ring.
apply egalite_vecteur_point with A.
rewrite H5; rewrite H9; Ringvec.
Qed.


From Undecidability.L Require Import Util.L_facts.
Require Import ListTactics.
From Undecidability.L.Tactics Require Import Lproc Reflection.

(* *** Lbeta: symbolic beta reduction *)

(* This module procides tactics to simlify L-term w.r.t beta reduction in L.
It does so by the reflective tactic simplify_L' using the module Reflextion. *)

Lemma eval_helper s t u: s >* u -> eval u t -> eval s t.
  intros R H. now rewrite R.
Defined.

Ltac addToList a l := AddFvTail a l.

Ltac has_no_evar s := try (has_evar s;fail 1).

Ltac reflexivity' :=
  match goal with
    | |- ?G => has_no_evar G;reflexivity
  end.

Lemma evalIn_refl n s : proc s -> s ⇓(<=n) s.
Proof.
  intros. split.
  -exists 0;split.
   +lia.
   +reflexivity.
  -Lproc.
Defined.

Lemma eval_refl s : lambda s -> s ⇓ s.
Proof.
  intros. split. reflexivity. Lproc.
Defined.

(*make all variables to coq-variables in the context *)
Ltac allVarsPrep _s :=
lazymatch _s with
| var ?_n => idtac
| app ?_s ?_t =>
  allVarsPrep _s;
  allVarsPrep _t
| lam ?_s => allVarsPrep _s
| rho ?_s => allVarsPrep _s
| _ => let x := fresh "__x" in set (x:= _s)
end.

Ltac allVarsSubstL vars :=
lazymatch vars with
| [] => idtac
| ?x::?vars'' => try subst x;allVarsSubstL vars''
end.

Ltac allVars' vars _s :=
lazymatch _s with
| var ?_n => vars
| app ?_s ?_t =>
  let vars := allVars' vars _s in
  allVars' vars _t
| lam ?_s => allVars' vars _s
| rho ?_s => allVars' vars _s
| _ => addToList (_s:term) (* cast is for coersions to work *) vars
end.

Ltac allVars _s := allVars' (@nil term) _s.

Ltac Find_at' a l :=
  lazymatch l with
  | (cons a _) => constr:(0)
  | (cons _ ?l) =>
    let n := Find_at' a l in
    constr:(S n)
  end.

Ltac reifyTerm vars _s :=
  lazymatch _s with
    | var ?_n => constr:(rVar _n)
    | app ?_s ?_t =>
      let _s := reifyTerm vars _s in
      let _t := reifyTerm vars _t in
      constr:(rApp _s _t)
    | lam ?_s =>
      let _s := reifyTerm vars _s in
      constr:(rLam _s)
    | rho ?_s =>
      let _s := reifyTerm vars _s in
      constr:(rRho _s)
    | _ =>
      let vars' := eval hnf in vars in
          let _n := (Find_at' (_s:term) (* cast is for coersions to work *) vars') in
          constr:(rConst (_n))
  end.

Ltac vm_hypo :=
  match goal with
    | H: ?s == ?t |- _ => revert H;try vm_hypo;intros H; vm_compute in H
  end.

Ltac ProcPhi vars :=
  let H := fresh "H" in
  let s := fresh "s" in
  apply liftPhi_correct,Forall_forall;allVarsSubstL vars;
  repeat
    once lazymatch goal with
    | |- Forall _ (@nil _) => solve [simple apply Forall_nil]
    | |- _ => simple apply Forall_cons;[Lproc| ]
    end .

(* solve goals of shape s >(?l) ?t for evars ?l, ?t!*)
Ltac simplify_L' n:=
  once lazymatch goal with
    |- ?s >(_) _ =>
    allVarsPrep s;
    once lazymatch goal with
      |- ?s >(_) _ =>
      let vars:= allVars s in
  (*    let vars' := fresh "vars'" in
     pose (vars':=vars); *)
      let s' := reifyTerm vars s in
      let phi := fresh "phi" in
      pose (phi := Reflection.liftPhi vars);
      let pp := fresh "pp" in
      let cs := fresh "cs" in
      assert (pp:Reflection.Proc phi) by (ProcPhi vars;shelve);
      assert (cs :Reflection.rClosed phi s') by (simple apply Reflection.rClosed_decb_correct;[exact pp|vm_cast_no_check (@eq_refl bool true) ]);
      let R := fresh "R" in
      assert (R:= Reflection.rStandardizeUsePow n pp cs);
      let eq := fresh "eq" in
      let s'' := fresh "s''" in
      set (s'':= Reflection.rCompSeval n (0, Reflection.rCompClos (s') [])) in R;
      vm_compute in (value of s'');
      subst s''; lazy -[rho pow phi Reflection.liftPhi] in R;
      lazy [phi Reflection.liftPhi nth] in R;
      (*repeat allVarsSubstL vars';*)
      clear (*vars' eq *) cs phi pp; exact  R
    end
  end.

Lemma pow_trans_eq: forall (s t u : term) (i j k: nat), s >(i) t -> t >(j) u -> i+j=k -> s >(k) u.
  intros. subst. eapply pow_trans;eauto.
Qed.

Ltac Lreflexivity :=
  once lazymatch goal with
  | |- _ ⇓(<=_) _ => solve [apply (@evalIn_refl 0);Lproc | apply evalIn_refl;Lproc ]
  | |- _ >(<= _ ) _ => apply redLe_refl
  | |- _ ⇓(?i) _ => unify i 0;split;[reflexivity|Lproc]
  | |- _ ⇓ _ => solve [apply eval_refl;Lproc]
  | |- _ >* _ => reflexivity
  | |- _ >(_) _ => now apply pow0_refl
  | |- ?t => fail "not supported by Lreflexivity:" t
  end.

Ltac Lbeta' n :=
  once lazymatch goal with
    |- ?rel ?s _ =>
    once lazymatch goal with
    | |- _ >(?i) _ => tryif is_evar i
      then eapply pow_trans;[simplify_L' n|]
      else (eapply pow_trans_eq;[simplify_L' n| |try reflexivity])
    | |- _ >(<=?i) _ => tryif is_evar i
      then eapply redLe_trans;[apply pow_redLe_subrelation;simplify_L' n|]
      else ((eapply redLe_trans_eq;[ | apply pow_redLe_subrelation;simplify_L' n| ]);[try reflexivity | ..])

    | |- _ ⇓(<= _) _ => eapply evalLe_trans;[apply pow_redLe_subrelation;simplify_L' n|]
    | |- _ ⇓(_) _ => eapply evalIn_trans;[Lbeta' n|]
    | |- _ ⇓ _ => eapply eval_helper;[eapply pow_star_subrelation;simplify_L' n|]
    | |- _ >* _ => etransitivity;[eapply pow_star_subrelation;simplify_L' n|]
    | |- ?G => fail "Not supported for LSimpl (or other failed):" G
    end;
    once lazymatch goal with
      |- ?rel s _ => fail "No Progress (progress in indexes are not currently noticed...)"
    | |- _ => idtac
    (* don;t change evars if you did not make progress!*)
    end
  end.

Tactic Notation "Lbeta" := once(Lbeta' 50).

(* test, approx. 2+1 seconds (proof + qed) on w550s
Lemma test : (lam 0) (lam 0) >(1 ) (lam 0).
Proof.
  do 300 (assert ((lam 0) (lam 0) >(1 ) (lam 0)) by (unfold I;simplify_L' 50);clear H);
    simplify_L' 50.
Qed.*)

(* legacy: asserts R:= s >* ?t for some reduction of ?t *)
Tactic Notation "standardize" ident(R) constr(n) constr(s) :=
  has_no_evar s;
  let l := fresh "l" in
  let t := fresh "t" in
  evar (l : nat);
  evar (t : term);
  assert (R : s >(l) t) by simplify_L' n;subst l t;apply pow_star in R.

(* Goal I I >* I. *)
(* Proof.  *)
(*   standardize R 100 ((lam 0) (lam 0)); exact R.  *)
(* Qed. *)

Ltac standardizeGoal' _n:=
  let R:= fresh "R" in
  once lazymatch goal with (* try etransitivity is for debugging, so we can disable ProcPhi iff needed*)
    | |- ?s == _ => let R:= fresh "R" in standardize R _n s;try (etransitivity;[exact (star_equiv R)|];clear R)
    | |- ?s >* _ => let R:= fresh "R" in standardize R _n s;try (etransitivity;[exact R|];clear R)
  end.

Ltac standardizeGoal _n :=
  try progress Lbeta' _n;
  try progress standardizeGoal' _n;
    try progress (symmetry;standardizeGoal' _n;symmetry).

Lemma stHypo s s' t : s >* s' -> s == t -> s' == t.
Proof.
  intros R R'. rewrite R in R'. exact R'.
Qed.

Ltac standardizeHypo _n:=
match goal with
  | eq_new_name : ?s == ?t |- _=>
    revert eq_new_name;try standardizeHypo _n; intros eq_new_name;
    try (progress (let R:= fresh "R" in
                   standardize R _n s;apply (stHypo R) in eq_new_name;clear R ));
      try (progress (let R':= fresh "R'" in
                     symmetry;standardize R' _n s;
                     apply (stHypo R') in eq_new_name;symmetry;clear R' ))
end.


(* 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                                                     *)

(** * alt_build_vecsp.v *)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export vecspaces_verybasic.
Require Export Map2.

(** - It is very tedious to build up a vectorspace from scratch every time:
 One must build a setoid, then a semigroup, an abelian semigroup, a monoid,
 etc. etc. - hence this file: it provides a uniform way of building a
 vectorspace is one has proved the eight vectorspace axioms. *)

Section MAIN.
Variable V : Setoid.
Variable F : field.
Variable add : Map2 V V V.
Variable mlt : Map2 F V V.
Variable zer : V.
Variable mns : Map V V.
Definition VS1 := forall x y : V, add x y =' add y x in _.
Definition VS2 := forall x y z : V, add (add x y) z =' add x (add y z) in _.
Definition VS3 := forall x : V, add x zer =' x in _.
Definition VS4 := forall x : V, add x (mns x) =' zer in _.
Definition VS5 := forall x : V, mlt one x =' x in _.
Definition VS6 :=
  forall (a b : F) (x : V), mlt (a rX b) x =' mlt a (mlt b x) in _.
Definition VS7 :=
  forall (a : F) (x y : V), mlt a (add x y) =' add (mlt a x) (mlt a y) in _.
Definition VS8 :=
  forall (a b : F) (x : V), mlt (a +' b) x =' add (mlt a x) (mlt b x) in _.

Let Vsg_on : VS2 -> sgroup_on V.
intro VS2p.
apply (Build_sgroup_on (sgroup_law_map:=Map2_Mapcart add)).
red in |- *.
intros.
simpl in |- *.
auto with algebra.
Defined.

Let Vsg : VS2 -> sgroup.
intro VS2p.
apply (Build_sgroup (Vsg_on VS2p)).
Defined.

Let Vmon_on : VS1 -> forall VS2p : VS2, VS3 -> monoid_on (Vsg VS2p).
intros VS1p VS2p VS3p.
apply (Build_monoid_on (monoid_unit:=zer:Vsg VS2p)).
red in |- *; simpl in |- *.
auto.
red in |- *; simpl in |- *; intro.
apply Trans with (add x (zer:Vsg VS2p)); auto with algebra.
Defined.

Let Vmon : VS1 -> VS2 -> VS3 -> monoid.
intros VS1p VS2p VS3p.
apply (Build_monoid (Vmon_on VS1p VS2p VS3p)).
Defined.

Let Vgp_on :
  forall (VS1p : VS1) (VS2p : VS2) (VS3p : VS3),
  VS4 -> group_on (Vmon VS1p VS2p VS3p).
intros.
set (VMON := Vmon VS1p VS2p VS3p) in *.
apply (Build_group_on (group_inverse_map:=mns:Map VMON VMON)).
red in |- *; simpl in |- *.
auto with algebra.
red in |- *; simpl in |- *.
intro.
apply Trans with (add x (mns x)); auto with algebra.
Defined.

Let Vgp : VS1 -> VS2 -> VS3 -> VS4 -> group.
intros VS1p VS2p VS3p VS4p.
apply (Build_group (Vgp_on VS1p VS2p VS3p VS4p)).
Defined.

Let Vabgp_on :
  forall (VS1p : VS1) (VS2p : VS2) (VS3p : VS3) (VS4p : VS4),
  abelian_group_on (Vgp VS1p VS2p VS3p VS4p).
intros.
apply Build_abelian_group_on.
apply Build_abelian_monoid_on.
apply Build_abelian_sgroup_on.
red in |- *; simpl in |- *.
auto.
Defined.

Let Vabgp : VS1 -> VS2 -> VS3 -> VS4 -> abelian_group.
intros VS1p VS2p VS3p VS4p.
apply (Build_abelian_group (Vabgp_on VS1p VS2p VS3p VS4p)).
Defined.

Let F_act_map :
  forall (VS1p : VS1) (VS2p : VS2) (VS3p : VS3) (VS4p : VS4),
  Map (Build_monoid (ring_monoid F)) (Endo_SET (Vabgp VS1p VS2p VS3p VS4p)).
intros VS1p VS2p VS3p VS4p.
simpl in |- *.
apply (Build_Map (Ap:=fun c : F => Ap2_Map mlt c)).
red in |- *.
intros; destruct mlt; simpl in |- *.
red in |- *; simpl in |- *.
intro; auto with algebra.
Defined.

Let F_sgp_hom :
  forall (VS1p : VS1) (VS2p : VS2) (VS3p : VS3) (VS4p : VS4),
  VS6 ->
  sgroup_hom (Build_monoid (ring_monoid F))
    (Endo_SET (Vabgp VS1p VS2p VS3p VS4p)).
intros VS1p VS2p VS3p VS4p VS6p.
apply (Build_sgroup_hom (sgroup_map:=F_act_map VS1p VS2p VS3p VS4p)).
red in |- *.
intros; simpl in |- *.
red in |- *; simpl in |- *.
intro.
apply Trans with (mlt (x rX y) x0); auto with algebra.
Defined.

Let F_op :
  forall (VS1p : VS1) (VS2p : VS2) (VS3p : VS3) (VS4p : VS4),
  VS5 ->
  VS6 -> operation (Build_monoid (ring_monoid F)) (Vabgp VS1p VS2p VS3p VS4p).
intros VS1p VS2p VS3p VS4p VS5p VS6p.
apply
 (Build_monoid_hom (monoid_sgroup_hom:=F_sgp_hom VS1p VS2p VS3p VS4p VS6p)).
red in |- *.
simpl in |- *.
red in |- *.
intro; simpl in |- *.
apply Trans with (mlt one x); auto with algebra.
Defined.

Let Vmod_on :
  forall (VS1p : VS1) (VS2p : VS2) (VS3p : VS3) (VS4p : VS4),
  VS5 -> VS6 -> VS7 -> VS8 -> module_on F (Vabgp VS1p VS2p VS3p VS4p).
intros VS1p VS2p VS3p VS4p VS5p VS6p VS7p VS8p.
apply (Build_module_on (module_op:=F_op VS1p VS2p VS3p VS4p VS5p VS6p)).
red in |- *; simpl in |- *.
auto with algebra.
red in |- *.
intros.
simpl in |- *.
red in VS7p.
apply Trans with (mlt a (add x y)); auto with algebra.
apply Trans with (add (mlt a x) (mlt a y)); auto with algebra.
Defined.

Definition alt_Build_vectorspace :
  VS1 -> VS2 -> VS3 -> VS4 -> VS5 -> VS6 -> VS7 -> VS8 -> vectorspace F.
intros VS1p VS2p VS3p VS4p VS5p VS6p VS7p VS8p.
red in |- *.
simpl in |- *.
apply (Build_module (Vmod_on VS1p VS2p VS3p VS4p VS5p VS6p VS7p VS8p)).
Defined.

Definition vectorspace_construction :
  VS1 ->
  VS2 ->
  VS3 ->
  VS4 ->
  VS5 -> VS6 -> VS7 -> VS8 -> sigT (fun VV : vectorspace F => Carrier VV = V).
intros.
exists (alt_Build_vectorspace H H0 H1 H2 H3 H4 H5 H6).
simpl in |- *.
auto.
Defined.
End MAIN.


Require Import ProofIrrelevance.

Lemma proof_irrelevance_set : forall (P : Set) (p1 p2 : P), p1 = p2.
  exact proof_irrelevance.
Qed.

Lemma paradox : False.
  assert (H : 0 <> 1) by discriminate.
  apply H.
  Fail apply proof_irrelevance. (* inlined version is rejected *)
  apply proof_irrelevance_set.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal79.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (y:lst):@eq lst (rev (append (append (rev x) (Cons n Nil)) y))
  (append (rev y) (Cons n x)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal79_theorem0_43_append_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) (y:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x y.
QuickChick collect_data.
Success.


Require Import Contractive Env Free FreeFacts Map Msg Sty Shape
  Subst SubstFacts Tac TL Var.
Require Import FunctionalExtensionality.

(******************************************************************************)
(* Facts about Tl_bisim *)

Inductive R_Tl_bisim_reflexive : Tl -> Tl -> Prop :=
| R_Tl_bisim_reflexive_intro :
    forall l,
    R_Tl_bisim_reflexive l l
.

Lemma Tl_bisim_reflexive :
  forall l,
  Tl_bisim l l.
Proof.
  intros. apply Tl_bisim_coind with (R := R_Tl_bisim_reflexive);
    [|constructor; auto].
  clear. introv H. inverts H. rename l' into l. destruct l; constructor;
    constructor.
Qed.

Inductive R_Tl_bisim_symmetric : Tl -> Tl -> Prop :=
| R_Tl_bisim_symmetric_intro :
    forall l l',
    Tl_bisim l l' ->
    R_Tl_bisim_symmetric l' l
.

Lemma Tl_bisim_symmetric :
  forall l l',
  Tl_bisim l l' ->
  Tl_bisim l' l.
Proof.
  intros. apply Tl_bisim_coind with (R := R_Tl_bisim_symmetric);
    [|constructor; auto].
  clear. introv H. inverts1 H. inverts2 H; constructor; constructor; auto.
Qed.

Inductive R_Tl_bisim_transitive : Tl -> Tl -> Prop :=
| R_Tl_bisim_transitive_intro :
    forall l1 l2 l3,
    Tl_bisim l1 l2 ->
    Tl_bisim l2 l3 ->
    R_Tl_bisim_transitive l1 l3
.

Lemma Tl_bisim_transitive :
  forall l1 l2 l3,
  Tl_bisim l1 l2 ->
  Tl_bisim l2 l3 ->
  Tl_bisim l1 l3.
Proof.
  intros. apply Tl_bisim_coind with (R := R_Tl_bisim_transitive);
    [|econstructor; eauto].
  clear. introv H. inversion_clear H as [l1 l2 l3 H1 H2]. subst.
  inverts2 H1; inverts2 H2; constructor; econstructor; eauto.
Qed.

Add Relation Tl Tl_bisim
  reflexivity proved by Tl_bisim_reflexive
  symmetry proved by Tl_bisim_symmetric
  transitivity proved by Tl_bisim_transitive
  as Tl_bisim_rel.

(******************************************************************************)
(* Facts about tl *)

Lemma tl_contractive_irrelevant :
  forall eta S contr contr',
  tl eta S contr = tl eta S contr'.
Proof.
  intros eta S. gen eta. induction S; intros; simpl; try solve [fequal; auto].
  - fequal. extensionality lx. auto.
Qed.

Lemma eta_irrelevance' :
  forall S eta eta' Hcontractive,
  (forall X, Free X S -> eta X = eta' X) ->
  tl eta S Hcontractive = tl eta' S Hcontractive.
Proof.
  induction S; introv Heq; simpl in *; try solve
    [ reflexivity
    | first [erewrite IHS | erewrite IHS1, IHS2]; eauto with free
    ].
  - fequal. extensionality lx. apply IHS.
    * introv Hfree. destruct (eq_Var_dec v X).
      + subst. rewrite_all eta_override_same. reflexivity.
      + rewrite_all eta_override_different; [|assumption..]. apply Heq.
        auto with free.
  - apply Heq. auto with free.
Qed.

Lemma eta_irrelevance :
  forall S eta eta' Hcontractive,
  Closed S ->
  tl eta S Hcontractive = tl eta' S Hcontractive.
Proof.
  introv Hwf. apply eta_irrelevance'.
  - introv Hfree. contradict Hfree. auto with free.
Qed.

Lemma tl_subst :
  forall S T X eta HcontractiveS HcontractiveT HcontractiveST,
  Closed T ->
  tl (eta_override eta X (tl eta T HcontractiveT)) S HcontractiveS =
  tl eta (subst X T S) HcontractiveST.
Proof.
  intros. gen eta T. induction S; intros; simpl.
  - reflexivity.
  - erewrite IHS; trivial.
  - erewrite IHS; trivial.
  - erewrite IHS1; trivial; erewrite IHS2; trivial.
  - erewrite IHS1; trivial; erewrite IHS2; trivial.
  - simpl in *; destruct (eq_Var_dec X v); simpl; fequal; extensionality x.
    * subst. rewrite eta_override_overwrite;
      auto using tl_contractive_irrelevant.
    * rewrite eta_override_exchange; [|auto].
      erewrite eta_irrelevance with (S := T); trivial. eapply IHS; trivial.
  - simpl in *. destruct (eq_Var_dec X v).
    * subst. rewrite override_same. apply tl_contractive_irrelevant.
    * simpl. auto using override_different.
Qed.

Lemma tl_mu_unfold :
  forall S eta X Hcontractive Hcontractive',
  tl eta (mu X S) Hcontractive =
  tl (eta_override eta X (tl eta (mu X S) Hcontractive)) S Hcontractive'.
Proof.
  intros. simpl. rewrite tl_fix_fix at 1. apply tl_contractive_irrelevant.
Qed.

Lemma tl_mu_subst :
  forall S eta X Hcontractive Hcontractive',
  Closed (mu X S) ->
  tl eta (mu X S) Hcontractive = tl eta (subst X (mu X S) S) Hcontractive'.
Proof.
  introv Hclosed. erewrite tl_mu_unfold. erewrite tl_subst; eauto.
Unshelve.
  inversion Hcontractive. assumption.
Qed.


From QuickChick Require Import QuickChick.

Require Import TestingCommon.
Require Import Reachability.
Require Import SSNI.
Require Import SanityChecks.
Require Import ZArith.
(* Require Import Generation. *)
From mathcomp Require Import ssreflect eqtype seq.
Import LabelEqType.

#[local] Instance FuzzyZ : Fuzzy Z :=
  {| fuzz n := choose (n - 5, n + 5)%Z |}.

Derive (Arbitrary, Fuzzy) for BinOpT.
Derive (Arbitrary, Fuzzy) for Instr.
Derive (Arbitrary, Fuzzy) for Pointer.
Derive (Arbitrary, Fuzzy) for Value.
Derive (Arbitrary, Fuzzy) for Atom.
Derive (Arbitrary, Fuzzy) for Ptr_atom.
Derive (Arbitrary, Fuzzy) for StackFrame.
Derive (Arbitrary, Fuzzy) for Stack.
Derive (Arbitrary, Fuzzy) for SState.
Derive (Arbitrary, Fuzzy) for Variation.

(*
ManualExtract BinOpT.
ManualExtract Instr.
ManualExtract Pointer.
ManualExtract Value.
ManualExtract Atom.
ManualExtract Ptr_atom.
ManualExtract StackFrame.
ManualExtract Stack.
ManualExtract SState.
ManualExtract Variation. *)

Definition test_propSSNI_smart (v: @Variation SState) :=
    propSSNI_smart default_table v.

Axiom num_tests : nat. Extract Constant num_tests => "max_int".

Definition gen_variation_copy : G (@Variation SState) :=
  bindGen arbitrary (fun l  =>
  bindGen arbitrary (fun st =>
  returnGen (Var l st st))).

Definition test_propSSNI_smart_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) gen_variation_copy fuzz show test_propSSNI_smart.

(*! FuzzChick test_propSSNI_smart (test_propSSNI_smart_fuzzer tt). *)

  (* gen_variation_SState
  gen_variation_copy: fuzzy
  gen_variation_naive == arbitrary/random
  gen_variation_naive: fuzzy *)


(** * A: Wstęp *)

(** * Cel *)

(** Celem tego kursu jest zapoznanie czytelnika z kilkoma rzeczami:
    - programowaniem funkcyjnym w duchu Haskella i rodziny ML,
      przeciwstawionym programowaniu imperatywnemu
    - dowodzeniem twierdzeń, które jest:
      - formalne, gdzie "formalny" znaczy "zweryfikowany przez komputer"
      - interaktywne, czyli umożliwiające dowolne wykonywanie i cofanie
        kroków dowodu oraz sprawdzenie jego stanu po każdym kroku
      - (pół)automatyczne, czyli takie, w którym komputer może wyręczyć
        użytkownika w wykonywaniu trywialnych i żmudnych, ale koniecznych
        kroków dowodu
    - matematyką opartą na logice konstruktywnej, teorii typów i teorii
      kategorii oraz na ich zastosowaniach do dowodzenia poprawności
      programów funkcyjnych i w szeroko pojętej informatyce *)

(** W tym krótkim wstępie postaramy się spojrzeć na powyższe cele z
    perspektywy historycznej, a nie dydaktycznej. Nie przejmuj się
    zatem, jeżeli nie rozumiesz jakiegoś pojęcia lub terminu — czas
    na dogłębne wyjaśnienia przyjdzie w kolejnych rozdziałach. *)

(** * Wybór *)

(** Istnieje wiele środków, które pozwoliłyby nam osiągnąć postawione
    cele, a jako że nie sposób poznać ich wszystkich, musimy dokonać
    wyboru.

    Wśród dostępnych języków programowania jest wymieniony już
    Haskell, ale nie pozwala on na dowodzenie twierdzeń (a poza tym jest
    sprzeczny, jeżeli zinterpretujemy go jako system logiczny), a także
    jego silniejsze potomstwo, jak Idris czy Agda, w których możemy
    dowodzić, ale ich wsparcie dla interaktywności oraz automatyzacji
    jest marne.

    Wśród asystentów dowodzenia (ang. proof assistants) mamy do wyboru
    takich zawodników, jak polski system Mizar, który nie jest jednak
    oparty na teorii typów, Lean, który niestety jest jeszcze w fazie
    rozwoju, oraz Coq. Nasz wybór padnie właśnie na ten ostatni język. *)

(** * Programowanie i dowodzenie *)

(** ** Alan Turing i jego maszyna *)

(** Teoretyczna nauka o obliczeniach powstała niedługo przed wynalezieniem
    pierwszych komputerów. Od samego początku definicji obliczalności
    oraz modeli obliczeń było wiele. Choć pokazano później, że wszystkie
    są równoważne, z konkurencji między nimi wyłonił się niekwestionowany
    zwycięzca — maszyna Turinga, wynaleziona przez Alana... (zgadnij
    jak miał na nazwisko).

    Maszyna Turinga nazywa się maszyną nieprzypadkowo — jest mocno
    "hardware'owym" modelem obliczeń. Idea jest dość prosta: maszyna
    ma nieskończenie długą taśmę, przy pomocy której może odczytywać
    i zapisywać symbole oraz manipulować nimi według pewnych reguł.

    W czasach pierwszych komputerów taki "sprzętowy" sposób myślenia
    przeważył i wyznaczył kierunek rozwoju języków programowania,
    który dominuje do dziś. Kierunek ten jest imperatywny; program
    to w jego wyobrażeniu ciąg instrukcji, których rolą jest zmiana
    obecnego stanu pamięci na inny.

    Ten styl programowania sprawdził się w tym sensie, że istnieje na
    świecie cała masa różnych systemów informatycznych zaprogramowanych
    w językach imperatywnych, które jakoś działają... Nie jest on jednak
    doskonały. Wprost przeciwnie — jest:
    - trudny w analizie (trudno przewidzieć, co robi program, jeżeli
      na jego zachowanie wpływ ma cały stan programu)
    - trudny w urównoleglaniu (trudno wykonywać jednocześnie różne
      części programu, jeżeli wszystkie mogą modyfikować wspólny
      globalny stan) *)

(** ** Alonzo Church i rachunek λ *)

(** Innym modelem obliczeń, nieco bardziej abstrakcyjnym czy też
    "software'owym" jest rachunek λ, wymyślony przez Alonzo Churcha.
    Nie stał się tak wpływowy jak maszyny Turinga, mimo że jest równie
    prosty — opiera się jedynie na dwóch operacjach:
    - λ-abstrakcji, czyli związaniu zmiennej wolnej w wyrażeniu, co
      czyni z niego funkcję
    - aplikacji funkcji do argumentu, która jest realizowana przez
      podstawienie argumentu za zmienną związaną *)

(** Nie bój się, jeśli nie rozumiesz; jestem marnym bajkopisarzem i
    postaram się wyjaśnić wszystko później, przy użyciu odpowiednich
    przykładów.

    Oryginalny rachunek λ nie był typowany, tzn. każdą funkcję można
    "wywołać" z każdym argumentem, co może prowadzić do bezsensownych
    pomyłek. Jakiś czas później wymyślono typowany rachunek λ, w którym
    każdy term (wyrażenie) miał swój "typ", czyli metkę, która mówiła,
    jakiego jest rodzaju (liczba, funkcja etc.).

    Następnie odkryto, że przy pomocy typowanego rachunku λ można wyrazić
    intuicjonistyczny rachunek zdań oraz reprezentować dowody przeprowadzone
    przy użyciu dedukcji naturalnej. Tak narodziła się "korespondencja
    Curry'ego-Howarda", która stwierdza między innymi, że pewne systemy
    logiczne odpowiadają pewnym rodzajom typowanego rachunku λ, że
    zdania logiczne odpowiadają typom, a dowody — programom. *)

(** ** Martin-Löf, Coquand, CoC, CIC i Coq *)

(** Kolejnego kroku dokonał Jean-Yves Girard, tworząc System F —
    typowany, polimorficzny rachunek λ, który umożliwia reprezentację
    funkcji generycznych, działających na argumentach dowolnego typu
    w ten sam sposób (przykładem niech będzie funkcja identycznościowa).
    System ten został również odkryty niezależnie przez Johna Reynoldsa.

    Następna gałąź badań, która przyczyniła się do obecnego kształtu
    języka Coq, została zapoczątkowana przez szwedzkiego matematyka
    imieniem Per Martin-Löf. W swojej intuicjonistycznej teorii
    typów (blisko spokrewnionej z rachunkiem λ) wprowadził on pojęcie
    typu zależnego. Typy zależne, jak się okazało, odpowiadają
    intuicjonistycznemu rachunkowi predykatów — i tak korespondencja
    Curry'ego-Howarda rozrastała się...

    Innymi rozszerzeniami typowanego rachunku λ były operatory typów
    (ang. type operators), czyli funkcje biorące i zwracające typy.
    Te trzy ścieżki rozwoju (polimorfizm, operatory typów i typy
    zależne) połączył w rachunku konstrukcji (ang. Calculus of
    Constructions, w skrócie CoC) Thierry Coquand, jeden z twórców
    języka Coq, którego pierwsza wersja była oparta właśnie o rachunek
    konstrukcji.

    Zwieńczeniem tej ścieżki rozwoju były typy induktywne, również
    obecne w teorii typów Martina-Löfa. Połączenie rachunku konstrukcji
    i typów induktywnych dało rachunek induktywnych konstrukcji (ang.
    Calculus of Inductive Constructions, w skrócie CIC), który jest
    obecną podstawą teoretyczną języka Coq (po drobnych rozszerzeniach,
    takich jak dodanie typów koinduktywnych oraz hierarchii uniwersów,
    również pożyczonej od Martina-Löfa). *)

(** * Filozofia i matematyka *)

(** ** Konstruktywizm *)

(* begin hide *)

(** Wersja poniższego dowodu z sqrt zamiast symbolu pierwiastka kwadratowego, bo Latex marudzi.
    Może kiedyś się do czegoś przyda.

    Dowód: niech sqrt(n) oznacza pierwiastek kwadratowy z n. Jeżeli
    sqrt(2) ^ sqrt(2) jest niewymierny, to niech a = sqrt(2) ^ sqrt(2), b = sqrt(2).
    Wtedy a ^ b = (sqrt(2) ^ sqrt(2)) ^ sqrt(2) = sqrt(2) ^ (sqrt(2) * sqrt(2)) = sqrt(2) ^ 2 = 2.
    W przeciwnym wypadku (czyli gdy sqrt(2) ^ sqrt(2) jest wymierny) niech
    a = b = sqrt(2). Wtedy a ^ b = sqrt(2) ^ sqrt(2) jest wymierny na mocy założenia. *)

(* end hide *)

(** Po co to wszystko, zapytasz? Czy te rzeczy istnieją tylko dlatego, że
    kilku dziwnym ludziom się nudziło? Nie do końca. Przyjrzyjmy się pewnemu
    wesołemu twierdzeniu i jego smutnemu dowodowi.

    Twierdzenie: istnieją takie dwie liczby niewymierne a i b, że a ^ b
    (a podniesione do potęgi b) jest liczbą wymierną.

    Dowód: rozważmy, czy √2 ^ √2 jest liczba niewymierną.

    Jeśli tak, to niech a = √2 ^ √2, b = √2. Wtedy a jest niewymierne na mocy
    założenia, b jest niewymierne bo √2 jest niewymierny, zaś
    a ^ b = (√2 ^ √2) ^ √2 = √2 ^ (√2 * √2) = √2 ^ 2 = 2,
    czyli a ^ b jest liczbą wymierną.

    W przeciwnym wypadku (czyli gdy √2 ^ √2 jest wymierny) niech
    a = b = √2. Wtedy a i b są niewymierne, bo √2 jest niewymierny, zaś
    a ^ b = √2 ^ √2
    jest wymierne na mocy założenia.

    Jako, że rozważane przez nas przypadki wyczerpują wszystkie możliwości
    (bo √2 ^ √2 może być albo liczbą wymierną, albo niewymierną), to możemy
    ostatecznie skonkludować, że faktycznie istnieją takie niewymierne liczby
    a i b, że a ^ b jest liczbą wymierną.

    Fajny dowód, co? To teraz dam ci zagadkę: podaj mi dwie niewymierne
    liczby a i b takie, że a ^ b jest wymierne. Pewnie zerkasz teraz do
    dowodu, ale zaraz... cóż to? Jak to możliwe, że ten wredny dowód
    udowadnia istnienie takich liczb, mimo że nie mówi wprost, co to za
    liczby?

    Tym właśnie jest niekonstruktywizm - możesz pokazać, że coś istnieje,
    ale bez wskazywania konkretnego obiektu. Możesz np. pokazać, że równanie
    ma rozwiązanie i wciąż nie wiedzieć, co to za rozwiązanie. Niewesoło,
    prawda?

    Podobnego zdania był dawno temu holenderski matematyk L. E. J. Brouwer.
    Obraził się on więc na tego typu dowody i postanowił zrobić swoją własną
    logikę i oprzeć na niej swoją własną, lepszą matematykę. Powstała w ten
    sposób logika konstruktywna okazała się być mniej więcej tym samym, co
    wspomniany wyżej rachunek lambda, choć Brouwer jeszcze o tym nie
    wiedział. Co ciekawe, Brouwer był przeciwnikiem formalizacji, a jego
    idee sformalizował dopiero jego uczeń, Arend Heyting.

    Ciekawostka: po polsku L. E. J. Brouwer można czytać jako "lej browar". *)

(** ** Praktyka *)

(** W międzyczasie na osiągnięciach wymienionych wyżej panów zaczęto budować
    wieżę z kości słoniowej. Chociaż nigdy nie dosięgnie ona nieba (można
    pokazać, że niektóre problemy są niemożliwe do rozwiązania matematycznie
    ani za pomocą komputerów), to po jakimś czasie zaczęła być przydatna.

    W połowie XIX wieku postawiono problem, który można krótko podsumować
    tak: czy każdą mapę polityczną świata da się pomalować czterema kolorami
    w taki sposób, aby sąsiednie kraje miały inne kolory?

    Przez bardzo długi czas próbowano go rozwiązywać na różne sposoby, ale
    wszystkie one zawodziły. Po ponad stu latach prób problem rozwiązali
    Appel i Haken pokazując, że każdą mapę da się pomalować czterema kolorami.
    Popełnili oni jednak grzech bardzo ciężki, gdyż w swoim dowodzie używali
    komputerów.

    Programy, które napisali, by udowodnić twierdzenie, wiele razy okazały
    się błędne i musiały być wielokrotnie poprawiane. Sprawiło to, że część
    matematyków nie uznała ich dowodu, gdyż nie umieli oni ręcznie sprawdzić
    poprawności wszystkich tych pomocniczych programów.

    Po upływie kolejnych 30 lat dowód udało się sformalizować w Coqu,
    co ostatecznie zamknęło sprawę. Morał płynący z tej historii jest dość
    prosty:
    - niektóre twierdzenia można udowodnić jedynie sprawdzając dużą ilość
      przypadków, co jest trudne dla ludzi
    - można przy dowodzeniu korzystać z komputerów i nie musi to wcale
      podważać wiary w słuszność dowodu, a może ją wręcz wzmocnić *)

(** ** Homofobia... ekhm, homotopia, czyli quo vadimus? *)

(** To jednak nie koniec niebezpiecznych związków matematyków z komputerami.

    Nie tak dawno temu w odległej galaktyce (a konkretniej w Rosji, a potem
    w USA) był sobie matematyk nazwiskiem Voevodsky (czyt. "wojewódzki").
    Zajmował się on takimi dziwnymi rzeczami, jak teoria homotopii czy
    kohomologia motywiczna (nie pytaj co to, bo nawet najstarsi górale
    tego nie wiedzą). Za swoje osiągnięcia w tych dziedzinach otrzymał
    medal Fieldsa, czyli najbardziej prestiżową nagrodę dla matematyków.
    Musiał być więc raczej zdolny.

    Jego historia jest jednak historią popełniania błędu na błędzie błędem
    poprawianym. Dla przykładu, w jednej ze swoich prac popełnił błąd,
    którego znalezienie zajęło 7 lat, a poprawienie - kolejne 6 lat. W
    innym, nieco hardkorowszym przypadku, w jego pracy z 1989 roku inny
    ekspert błąd znalazł w roku 1998, ale Voevodsky nie wierzył, że
    faktycznie jest tam błąd - obu panom po prostu ciężko się było dogadać.
    Ostatecznie Voevodsky o swym błędzie przekonał się dopiero w roku 2013.

    Czy powyższe perypetie świadczą o tym, że Voevodsky jest krętaczem (lub
    po prostu idiotą)? Oczywiście nie. Świadczą one o tym, że matematyka
    uprawiana na wysokim poziomie abstrakcji jest bardzo trudna do ogarnięcia
    przez ludzi. Ludzie, w tym matematycy, mają ograniczoną ilość pamięci
    oraz umiejętności rozumowania, a na dodatek ślepo ufają autorytetom -
    bardzo skomplikowanych i nudnych twierdzeń z dziedzin, którymi mało kto
    się zajmuje, po prostu (prawie) nikt nie sprawdza.

    Powyższe skłoniło Voevodskyego do porzucenia swych dziwnych zainteresowań
    i zajęcia się czymś równie dziwnym (przynajmniej dla matematyków), czyli
    formalną weryfikacją rozumowań matematycznych przez komputery. Po długich
    przemyśleniach związał on swe nadzieje właśnie z Coqiem. Jednak duchy
    przeszłości nie przestawały go nawiedzać i to aż do tego stopnia, że
    wymyślił on (do spółki z takimi ludźmi jak Awodey, Warren czy van den
    Berg) homotopiczną interpretację teorii typów.

    O co chodzi? W skrócie: typy zamiast programów reprezentują przestrzenie,
    zaś programy to punkty w tych przestrzeniach. Programy, które dają takie
    same wyniki są połączone ścieżkami. Programowanie (i robienie matematyki)
    staje się więc w takim układzie niczym innym jak rzeźbieniem figurek w
    bardzo abstrakcyjnych przestrzeniach.

    Jakkolwiek powyższe brzmi dość groźnie, to jest bardzo użyteczne i
    pozwala zarówno załatać różne praktyczne braki teorii typów (np.
    brak typów ilorazowych, cokolwiek to jest) jak i ułatwia czysto
    teoretyczne rozumowania w wielu aspektach.

    Homotopia to przyszłość! *)

(** * Literatura *)

(** ** Książki *)

(** Mimo, iż Coq liczy sobie dobre 27 lat, książek na jego temat zaczęło
    przybywać dopiero od kilku. Z dostępnych pozycji polecenia
    godne są:
    - #
      Software Foundations# — sześciotomowa seria, w której skład wchodzą:
      - #
        Logical Foundations# — bardzo przystępne acz niekompletne
        wprowadzenie docCoqa. Omawia podstawy programowania funkcyjnego,
        rekursję i indukcję strukturalną, polimorfizm, podstawy logiki i
        prostą automatyzację.
      - #
        Programming Language Foundations# — wprowadzenie do teorii języków
        programowania. Omawia definiowanie ich składni i semantyki, dowodzenie
        ich właściwości oraz podstawy systemów typów i proste optymalizacje.
        Zawiera też kilka rozdziałów na temat bardziej zaawansowanej automatyzacji.
      - #
        Verified Functional Algorithms # — jak sama nazwa wskazuje, skupia
        się ona na algorytmach, adaptowaniu ich do realiów języków funkcyjnych
        oraz weryfikacji poprawności ich działania. Nie jest ona jeszcze zbyt
        dopracowana, ale pewnie zmieni się to w przyszłości.
      - #
        QuickChick: Property-Based Testing in Coq # — ten tom traktuje o
        bibliotece QuickChick, służącej do testowania poprawności programów.
        Mogłoby się wydawać, że skoro w Coqu można dowodzić poprawności, to
        testowanie nie jest potrzebne, ale nic bardziej mylnego - narzędzia
        takie jak QuickChick bardzo często potrafią znaleźć kontrprzykład
        dla nieprawdziwego "twierdzenia" zanim człowiek zdąży się zastanowić,
        czy jest ono poprawne, czy nie, a co dopiero je udowodnić.
      - Pozostałe dwa tomy z tej serii nie są moim zdaniem warte uwagi.
    - #Coq'Art# —
      książka nieco szerzej opisująca język Coq, poświęca sporo
      miejsca rachunkowi konstrukcji i aspektom teoretycznym. Zawiera
      także rozdziały dotyczące automatyzacji, silnej specyfikacji,
      koindukcji, zaawansowanej rekurencji i reflekcji. Zalinkowałem
      wersję francuską, która jest dostępna za darmo. Wersję angielską
      można za darmo pobrać z ruskich stronek z pirackimi książkami, ale
      broń Boże tego nie rób! Piractwo to grzech.
    - #
      Certified Programming with Dependent Types# (w skrócie CPDT) - książka
      dla zaawansowanych, traktująca o praktycznym użyciu typów zależnych oraz
      kładąca bardzo mocny nacisk na automatyzację.
    - #Programs and Proofs# —
      notatki do wykładów z załączonymi ćwiczeniami. Omawiają podstawy Coqa
      podstawy Coqa, po czym poruszają takie tematy, jak reflekcja boolowska,
      język taktyk Ssreflect oraz reprezentowanie struktur matematycznych.
      Uwaga: czytelnik powinien już umieć programować i znać podstawy matematyki.
    - #
      Mathematical Components Book# to książka dotycząca biblioteki o nazwie
      Mathematical Components. Zawiera ona wprowadzenie do Coqa, ale poza tym
      opisuje też dwie inne rzeczy:
      - Metodologię dowodzenia zwaną _small scale reflection_
        (pol. reflekcja na małą skalę), która pozwala wykorzystać
        w dowodach maksimum możliwości obliczeniowych Coqa, a dzięki
        temu uprościć dowody i zorganizować twierdzenia w logiczny
        sposób
      - Język taktyk Ssreflect, którego bazą jest [Ltac], a który
        wprowadza w stosunku do niego wiele ulepszeń i udogodnień,
        umożliwiając między innymi sprawne zastosowanie metodologii
        _small scale reflection_ w praktyce
    - #Manual#
      nie jest wprawdzie zbyt przyjazny do czytania ciurkiem, ale
      to chyba jedyny dokument, który opisuje najgłębsze zakamarki Coqa.
      Można tu znaleźć wiele wartościowych informacji, których brakuje
      gdzie indziej.
    - #
      Formal Reasoning About Programs# — ta książka jest jeszcze w trakcie
      pisania. Nie wiem o czym jest i nie polecam czytać dopóki jest oznaczona
      jako draft.  *)

(** Zalecana kolejność czytania:
    SF, część 1 -> (Coq'Art) -> (MCB) -> SF, część 2 i 3 -> CPDT -> (FRAP) ->
    Manual *)

(** ** Blogi *)

(** W Internecie można też dokopać się do blogów, na których przynajmniej
    część postów dotyczy Coqa. Póki co nie miałem czasu wszystkich przeczytać
    i wobec tego większość linków wrzucam w ciemno:
    - #poleiro.info#
      (znajdziesz tu posty na temat parsowania, kombinatorycznej teorii gier,
      czytelnego strukturyzowania dowodu, unikania automatycznego generowania
      nazw, przeszukiwania, algorytmów sortowania oraz dowodzenia przez reflekcję).
    - #coq-blog.clarus.me#
    - #gmalecha.github.io#
    - #seb.mondet.org/blog#
      (znajdziesz tu 3 posty na temat silnych specyfikacji)
    - #gallium.inria.fr/blog#
      (znajdziesz tu posty na temat mechanizmu ewaluacji, inwersji, weryfikacji parserów
      oraz pisania pluginów do Coqa; większość materiału jest już dość leciwa)
    - #
      homes.cs.washington.edu/~jrw12/##blog#
    - #osa1.net/tags/coq#
    - #
      coqhott.gforge.inria.fr/blog# *)

(** ** Inne *)

(** Coq ma też swój subreddit na Reddicie (można tu znaleźć różne rzeczy, w
    tym linki do prac naukowych) oraz tag na StackOverflow, gdzie można
    zadawać i odpowiadać na pytania:
    - #
      Gigantyczna lista wszystkich Coqowych zasobów (książek, blogów, forów, etc.)#
    - #Strona domowa#
    - #GitHub#
    - #Forum#
    - #Czat#
    - #Stack Overflow#
    - #Reddit#
    - #
      Proof Assistants Stack Exchange# — kolejne miejsce, gdzie można zadawać
      pytania nie tylko dotyczące Coqa, ale także innych podobnych języków oraz
      teorii typów *)

(** * Sprawy techniczne *)

(** Kurs ten tworzę z myślą o osobach, które potrafią programować w
    jakimś języku imperatywnym oraz znają podstawy logiki klasycznej,
    ale będę się starał uczynić go jak najbardziej zrozumiałym dla
    każdego. Polecam nie folgować sobie i wykonywać wszystkie ćwiczenia
    w miarę czytania, a cały kod koniecznie przepisywać ręcznie, bez
    kopiowania i wklejania. Poza ćwiczeniami składającymi się z
    pojedynczych twierdzeń powinny się też pojawić miniprojekty, które
    będą polegać na formalizacji jakiejś drobnej teorii lub zastosowaniu
    nabytej wiedzy do rozwiązania jakiegoś typowego problemu.

    Język Coq można pobrać z
    #jego strony domowej#.

    Z tej samej strony można pobrać CoqIDE, darmowe IDE stworzone
    specjalnie dla języka Coq. Wprawdzie z Coqa można korzystać
    w konsoli lub przy użyciu edytora Proof General, zintegrowanego
    z Emacsem, ale w dalszej części tekstu będę zakładał, że użytkownik
    korzysta właśnie z CoqIDE.

    Gdyby ktoś miał problemy z CoqIDE, lekką alternatywą jest
    #jsCoq#,
    działający bezpośrednio w przeglądarce.

    Uwaga: kurs powstaje w czasie rzeczywistym, więc w niektórych miejscach
    możesz natknąć się na znacznik TODO, który informuje, że dany fragment
    nie został jeszcze skończony. *)


Require Omega.

Ltac termination_by_omega :=
  Coq.Program.Tactics.program_simpl;
  simpl;Omega.omega.

Fixpoint map_size {a} {b} (s : Map a b) : nat :=
  match s with
  | Tip => 0
  | Bin _ _ _ s1 s2 => 1 + map_size s1 + map_size s2
  end.

Require Import HsToCoq.Err.

Instance Map_Default {k}{v} : Default (Map k v) :=
  Build_Default _ Tip.
Instance AlteredDefault {k}{v} : Default (Altered k v) :=
  Build_Default _ AltSame.

(* This doesn't translate automatically for two reasons:
   it should be a fixpoint.
   it reuses the variable a as both a term and type variable. *)
Fixpoint functor__Map_op_zlzd__ {inst_k} {a} {b} (f: a) (m:(Map inst_k) b):
  (Map inst_k) a :=
      match f, m with
      | _, Tip => Tip
      | f, Bin sx kx _ l r => Bin sx kx f
                                 (functor__Map_op_zlzd__ f l)
                                 (functor__Map_op_zlzd__ f r)
      end.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export sequents_useful.
Require Export per_props_equality.
Require Export per_props_pertype.
Require Export sequents_equality.
Require Export list. (* why *)

(* [21] ============ PERTYPE ELIMINATION 3 ============ *)

(**

  We state yet another pertype elimination rule.  This one is similar
  to the second one presented above but does not require us to provide
  a level for [R x x]:

<<
   H, x : pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : pertype(R), [z : R x x], J |- C ext e
     H, x : pertype(R) |- (R x x) is a type
>>
 *)

Definition rule_pertype_elimination3 {o}
           (R C e : NTerm)
           (x z : NVar)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent (snoc H (mk_hyp x (mk_pertype R)) ++ J)
                   (mk_concl C e))
    [ mk_baresequent (snoc (snoc H (mk_hyp x (mk_pertype R)))
                          (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x)))
                          ++ J)
                   (mk_concl C e),
      mk_baresequent (snoc H (mk_hyp x (mk_pertype R)))
                    (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x)))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination3_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination3
                 R C e
                 x z
                 H J).
Proof.
  unfold rule_pertype_elimination3, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent
                      (snoc (snoc H (mk_hyp x (mk_pertype R)))
                            (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x))) ++ J)
                      (mk_concl C e))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      (snoc H (mk_hyp x (mk_pertype R)))
                      (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_pertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (vars_hyps H)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nizc vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_pertype in sim2; repnd.
  rw @equality_in_mkc_pertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 ((snoc (snoc s1a0 (x, t1)) (z, t')) ++ s1b)
                   ((snoc (snoc s2a0 (x, t2)) (z, t')) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim12; simpl in sim12; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim8; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t4)) (z, t0))
         s1b
         (snoc (snoc s2a1 (x, t5)) (z, t3))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s2a1 (x, t5)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw @dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t4)) (snoc s2a1 (x, t5)) t0 t3 wfct0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac; sp.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (z, t'))
         s1b
         (snoc (snoc s2a0 (x, t2)) (z, t'))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R (mk_var x) (mk_var x)))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x, t1)))
         as cvap
         by (rw @cover_vars_apply2; sp;
             try (complete (apply cover_vars_snoc_weak; sp));
             apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t2)) t' t' wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t1) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t2) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

Lemma rule_pertype_elimination3_true_ex {o} :
  forall lib z R C e x H J,
    rule_true_if lib (@rule_pertype_elimination3 o
                 R C e
                 x z
                 H J).
Proof.
  intros.
  generalize (rule_pertype_elimination3_true lib R C e x z H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Relations.Relation_Definitions.

  Ltac thegoal:= match goal with |- ?G => constr:G end.

  Ltac idtac1 x:= idtac.
  Ltac idtac2 x y:= idtac.

  Definition rel_disj {A B :Type} (R1 R2: A->B->Prop) : A->B->Prop :=
    fun x y => R1 x y \/ R2 x y.

  Arguments rel_disj {_ _} _ _ _ _ /.
  Arguments flip {_ _ _} _ _ _ /.

Ltac dup:= match goal with |- ?g => cut g; [ intros _ | ] end.

Tactic Notation "if_ltac_sucess_then_else_fail" tactic(tac1) tactic(tac2):=
  first [ first [ dup; [tac1; fail 1 | fail 1] | fail 2 ] | tac2 ].

(* only performs eassumption if there is exactly one hypoothesis that is able to solve the goal *)
Ltac eassumption_unique := idtac; match goal with
| _ => assumption
| H1: ?P |- _ =>
  match type of P with Prop =>
  (* fail if there is more than one way to discharge the goal by assumption *)
  if_ltac_sucess_then_else_fail
    solve[exact H1]
    (clear H1; if_ltac_sucess_then_else_fail eassumption (fail 3))
  end
| _ => eassumption
end.

  Ltac solve_relation:=
    solve [
    intros;
    match goal with
    | |- exists _, _ => eexists; try solve [solve_relation]
    | |- _/\_ =>
      first
      [ split; solve[solve_relation]
      | split; [ | solve[solve_relation]]; solve[solve_relation]
      ]
    | |- _\/_ =>
      first
      [ left; solve[solve_relation]
      | right; solve[solve_relation]
      ]
    | _ => apply eq_refl
    | _ => eassumption_unique
    | _ => symmetry; eassumption_unique
    | _ => reflexivity
    | _ => eassumption
    | _ => solve[auto]
    | _ => congruence
    | _ => progress red; solve_relation
    end].

  Class CoIndRelation (T: Prop) := { coind_rel : Prop }.
  Arguments coind_rel _ {_}.
  Ltac coind_rel_match_Prop T := match eval cbv beta in T with
     | ?A -> ?B => refine {| coind_rel := A /\ coind_rel B |}
     | forall x : ?A, @?B x => refine {| coind_rel := exists x : A, coind_rel (B x) |}
     | exists x : ?A, @?B x => refine {| coind_rel := forall x : A, coind_rel (B x) |}
     | ?A /\ ?B => refine {| coind_rel := coind_rel A \/ coind_rel B |}
     | ?A \/ ?B => refine {| coind_rel := coind_rel A /\ coind_rel B |}
     | ?T' => refine {| coind_rel := T' |}
   end .
  Global Hint Extern 100 (CoIndRelation ?T) => coind_rel_match_Prop T : typeclass_instances.

  Class CoRelation (T:Type) := {coind_co_rel (x:T): Prop}.
  Arguments coind_co_rel {_} {_} _.

  Definition coind_rel_singleton {A} x : @CoRelation A :=
    {|coind_co_rel x' := x=x' |}.
  Definition coind_rel_1 {A} x : @CoRelation A :=
    {|coind_co_rel x' := x=x' |}.
  Definition coind_rel_2 {A B} x y : @CoRelation (A*B) :=
    {|coind_co_rel a := let '(x',y'):= a in x=x' /\ y=y' |}.
  Definition coind_rel_3 {A B C} x y z : @CoRelation (A*B*C) :=
    {|coind_co_rel a := let '(x',y',z'):= a in x=x' /\ y=y' /\ z=z'|}.

Ltac infer_coind_relation G R :=
  (let t := (eval simpl in (fun x y z => let co_rel:= coind_rel_3 x y z in coind_rel G)) in
    pose t as R)
  ||
  (let t := (eval simpl in (fun x y => let co_rel:= coind_rel_2 x y in coind_rel G)) in pose t as R)
  ||
  (let t := (eval simpl in (fun x => let co_rel:= coind_rel_1 x in coind_rel G)) in pose t as R).

  Class CoIndPrinciple {A} (coind_relation:A) (T:Prop) :=
  { coind_principle_type: Type
  ; coind_principle: coind_principle_type
  }.

  Arguments coind_principle {_} _ _ {_}.

  Ltac intro_names cont' :=
    let nil_name tac1 tac2 :=
      idtac
      in
    let intro_name a x renames tac1 tac2 :=
      tac1 a x; renames tac1 tac2; tac2 a x
      in
    let rec helper renames cont:=
      lazymatch goal with
      | |- forall a:?A, _ =>
        let x:=fresh "XX" in intro x;
        helper ltac:(intro_name a x renames) cont
      | |- ?g =>
        cont renames
      end in
    helper ltac:nil_name cont'.

  Ltac eval_replace a b C :=
    match C with
    | context A[a] =>
       let C':= context A[b] in
       eval_replace a b C'
    | _ =>
      constr:C
    end.

  Class NormalizeProp (T: Prop) := { norm_Prop : Prop }.
  Arguments norm_Prop _ {_}.
  Ltac norm_Prop_match_Prop T := match eval cbv iota zeta beta delta [norm_Prop] in T with
     | (exists x:?C, ?A) -> ?B => refine {| norm_Prop:= norm_Prop (A -> B) |}
     | (exists x:?C, @?A x) -> ?B => refine {| norm_Prop:= forall x:C, norm_Prop (A x -> B) |}
     | ?A /\ ?B -> ?C => refine {| norm_Prop := norm_Prop (A -> norm_Prop (B -> C)) |}
     | ?a = ?b -> ?B =>
       is_var a; let B':= eval_replace a b B in
       refine {| norm_Prop := B' |}
     | ?a = ?b -> ?B =>
       is_var b; let B':= eval_replace b a B in
       refine {| norm_Prop := B' |}
     | ?A -> ?B => refine {| norm_Prop:= norm_Prop A -> norm_Prop B |}
     | forall x : ?A, @?B x =>
       let B':= eval cbv beta iota delta [norm_Prop] in (forall x : A, norm_Prop (B x)) in
       match B' with
       | _ -> ?C => refine {| norm_Prop := C |}
       | forall _, _ => refine {| norm_Prop := B' |}
       end
     | ?T' => refine {| norm_Prop := T' |}
   end.
  Global Hint Extern 100 (NormalizeProp ?T) => norm_Prop_match_Prop T : typeclass_instances.

  Ltac norm_Prop_ H :=
    let T:= type of H in
    let t:= eval cbv beta iota delta [norm_Prop] in (norm_Prop T) in
    cut (t);
    [ clear H; intro H
    | clear -H;
      intros; apply H;
      solve_relation
    ].
  Tactic Notation "norm_Prop" "in" hyp(H) :=
    norm_Prop_ H.

  Ltac intros_norm_Prop:=
    cbv beta;
    repeat match goal with
    | |- ?A -> ?B =>
      let H1:= fresh "H" in
      intro H1;
      norm_Prop in H1
    | |- forall _, _ =>
      intro
    end.

  Ltac coind_ naming_cont:=
    let R2 := fresh "R" in
    infer_coind_relation thegoal R2;
    let apply_coind_principle R:=
      let G:= thegoal in
      (let t := eval simpl in (coind_principle R G) in eapply t)
    in
    intro_names ltac:(fun names =>
      apply_coind_principle R2;
      try match goal with
      | |- appcontext[R2 _] =>
        subst R2;
        cbv beta;
        solve_relation
      | _ =>
        names ltac:(fun a x => try clear x) idtac2;
        subst R2;
        intros_norm_Prop;
        naming_cont names
      end).
  Tactic Notation "coind":=
    coind_ ltac:(fun names => idtac).
  Tactic Notation "coind" "naming" tactic(naming_cont):=
    coind_ naming_cont.

  Tactic Notation "coind" "using" constr(principle) "naming" tactic(naming_cont):=
    refine (let _ := principle in _);
    match goal with
    | P:= _ |- _ =>
      coind_ naming_cont;
      subst P
    end.
  Tactic Notation "coind" "using" constr(principle):=
    coind using principle naming idtac1.

  Class SubstConclusion (T: Prop) := { subst_conclusion : Prop }.
  Arguments subst_conclusion _ {_}.
  Ltac subst_conclusion_match_Prop T := match eval cbv beta in T with
     | ?A -> ?B => refine {| subst_conclusion:= A -> subst_conclusion B |}
     | forall x : ?A, @?B x => refine {| subst_conclusion := forall x : A, subst_conclusion (B x) |}
     | ?T' => refine {| subst_conclusion := T' |}
   end .
  Global Hint Extern 100 (SubstConclusion ?T) => subst_conclusion_match_Prop T : typeclass_instances.

  Ltac intro_relation_with_names names:=
      let p := fresh "p__" in
      let q := fresh "q__" in
      let HH := fresh "HH__" in
      intros p q HH;
      names ltac:idtac2 ltac:(fun a x => destruct HH as [a HH] || destruct HH as [? HH]);
      destruct HH as [??];
      subst p q.

Definition impred_gfp {A B:Type} (RR: (A->B->Prop)->Prop) p q : Prop:=
  exists R: A->B->Prop, R p q /\ RR R.

Lemma subrelation_impred_gfp: forall {A:Type} (RR: relation A->Prop) (R: relation A),
  RR R ->
  subrelation R (impred_gfp RR).
Proof.
  firstorder auto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj29synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv0) lv2) (plus (mult lv1 lv3) lv3)).
Admitted.
QuickChick conj29synthconj5.


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 B C Aprime Bprime Cprime M Aprimeprime Cprimeprime : Universe, ((wd_ Aprime Bprime /\ (wd_ Cprime Bprime /\ (wd_ B Aprimeprime /\ (wd_ B Cprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Aprimeprime Cprimeprime /\ (wd_ C Cprimeprime /\ (wd_ Aprime Cprime /\ (col_ Aprimeprime B A /\ (col_ A Aprimeprime Cprimeprime /\ (col_ C Aprimeprime Cprimeprime /\ (col_ Cprimeprime B C /\ (col_ Cprime M Cprimeprime /\ (col_ Aprime M Aprimeprime /\ col_ M B Bprime)))))))))))))))) -> col_ A C Cprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.