Require Import Datatypes.
Require Import ZArith.
Require Import Coq.Strings.String.
Require Import Lia.

From QuickChick Require Import QuickChick.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

Require Import Utils Labels.
Import LabelEqType.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* I'm ending the craziness. Label model is now fixed to be Lab4. *)
Inductive memframe A := Fr (lab : Label) : list A -> memframe A.

Derive Fuzzy for prod.
Derive Fuzzy for list.

Derive Fuzzy for Label.
Derive Fuzzy for memframe.

(* #[local] Instance Fuzzy_memframe {A} `{GenSized A} `{Fuzzy A}: Fuzzy (memframe A) :=
  {| fuzz n :=
    match n with
    | Fr la l => oneOf_ (ret n) (cons (bindGen (fuzz l) (fun l' => returnGen (Fr la l'))) (cons (bindGen (fuzz la) (fun la' => returnGen (Fr la' l))) (nil)))
    end
  |}.
 *)

Derive Arbitrary for memframe.
Derive Show for memframe.

Section FrameEqType.

Variables A : eqType.

Definition memframe_eq (fr1 fr2 : @memframe A) : bool :=
  let: Fr l1 xs1 := fr1 in
  let: Fr l2 xs2 := fr2 in
  [&& l1 == l2 & xs1 == xs2].

Lemma memframe_eqP : Equality.axiom memframe_eq.
Proof.
move=> [l1 xs1] [l2 xs2]; apply/(iffP andP).
  by move=> [/eqP -> /eqP ->].
by move => [-> ->]; rewrite !eqxx.
Qed.

Definition memframe_eqMixin := EqMixin memframe_eqP.

Canonical memframe_eqType := Eval hnf in EqType (memframe A) memframe_eqMixin.

End FrameEqType.

Require Import Coq.Structures.Equalities.
Require Import Coq.Structures.DecidableTypeEx.
(* From QuickChick Require Import FMapWeakListInstances.*)
Require Import Coq.FSets.FMapFacts.

Module Lab_as_MDT <: MiniDecidableType.
  Definition t := Label.
  Definition eq_dec : forall x y : t, {x=y}+{~x=y}.
  Proof. decide equality. Defined.
End Lab_as_MDT.

Module Lab_as_UDT := Make_UDT(Lab_as_MDT).

Definition block := (Z * Lab_as_UDT.t)%type.

Definition block_eq (b1 b2 : block) := b1 == b2.

Lemma block_eqP : Equality.axiom block_eq.
Proof. unfold Equality.axiom. intros. exact /eqP. Defined.

Definition block_eqMixin := EqMixin block_eqP.
Canonical block_eqType := EqType block block_eqMixin.

Definition stamp : block -> Label := @snd _ _.
Definition put_stamp (s : Label) (b : block) : block :=
    let (z,_) := b in (z,s).

Module Type S (X : DecidableType).
  Include FMapInterface.WSfun X.

  Section elt.
    Variable elt : Type.
    Parameter from_list : list (X.t * elt) -> t elt.

    Declare Instance genSizedMap `{GenSized X.t} `{GenSized elt} : GenSized (t elt).
    Declare Instance shrinkMap `{Shrink X.t} `{Shrink elt} : Shrink (t elt).

    Declare Instance showMap `{Show X.t} `{Show elt} : Show (t elt).

   Declare Instance fuzzyMap `{GenSized X.t} `{GenSized elt} `{Fuzzy X.t} `{Fuzzy elt} : Fuzzy (t elt).

  End elt.

End S.

Import MonadNotation.
Local Open Scope monad_scope.

Require FMapWeakList.
Module Make (X : DecidableType) <: S X.
  Include FMapWeakList.Make X.

  Section elt.
    Variable elt : Type.

    Definition from_list (l : list (X.t * elt)) : t elt :=
      List.fold_left (fun acc kv => add (fst kv) (snd kv) acc) l (empty elt).

    (* Generate two arbitrary vectors of the given sizefor keys and values,
       zip them together and build up into a map. *)
    Global Instance genSizedMap `{GenSized X.t} `{GenSized elt} : GenSized (t elt) :=
    {| arbitrarySized s :=
         keys <- vectorOf s (@arbitrarySized X.t _ s);;
         vals <- vectorOf s (@arbitrarySized elt _ s);;
         ret (from_list (combine keys vals))
    |}.

    (* The rest of the operations are derived from their list counterparts. *)
    Global Instance shrinkMap `{Shrink X.t} `{Shrink elt} : Shrink (t elt) :=
    {| shrink m := List.map from_list (shrink (elements m)) |}.

    Global Instance showMap `{Show X.t} `{Show elt} : Show (t elt) :=
    {| show m := show (elements m) |}.

    Global Instance fuzzyMap `{GenSized X.t} `{GenSized elt} `{Fuzzy X.t} `{Fuzzy elt} : Fuzzy (t elt) :=
    {| fuzz m :=
         m' <- fuzz (elements m);;
         ret (from_list m')
    |}.

  End elt.
End Make.

(* Memory is just a map from stamps to lists of data. *)
Module Lab_as_DT := UDT_to_DT (Lab_as_UDT).
Module Map := Make (Lab_as_DT).
Module MapFacts := WFacts_fun Map.E Map.
Definition mem A := Map.t (list (memframe A)).

Definition get_memframe {A} (m : mem A) (b : block) :=
    match Map.find (snd b) m with
    | Some bs => nth_error_Z bs (fst b)
    | None => None
    end.

Definition next {A} (m : mem A) (s : Label) : Z :=
    match Map.find s m with
    | Some bs => Z.of_nat (length bs)
    | None => Z0
    end.

Theorem get_memframe_next {A} : forall i s (m : mem A),
      (0 <= i < next m s)%Z <-> (exists fr, get_memframe m (i,s) = Some fr).
Proof.
    move => i s m; rewrite /next /get_memframe.
    simpl; destruct (Map.find s m) eqn:FindS.
    { split => Hyp.
    - apply nth_error_Z_valid2.
      destruct Hyp as [H1 H2].
      split; auto.
      apply /ltP.
      apply Z2Nat.inj_lt in H2; auto.
      { rewrite Nat2Z.id in H2; auto. }
      lia.
    - destruct Hyp as [fr Hfr].
      apply nth_error_Z_valid in Hfr.
      destruct Hfr as [H1 H2].
      split; auto.
      apply Z2Nat.inj_lt; auto.
      { apply Nat2Z.is_nonneg. }
      rewrite Nat2Z.id.
      apply /ltP.
      auto.
    }
    { split => Hyp.
      - lia.
      - destruct Hyp; congruence.
    }
Qed.

Theorem next_pos : forall {A} (m : mem A) s, (0 <= next m s)%Z.
Proof.
    intros A m s.
    rewrite /next.
    destruct (Map.find s m).
    - apply Nat2Z.is_nonneg.
    - lia.
Qed.

(* Only used in QuickChick proofs *)
Definition memory_extensionality {A} (m1 m2 : mem A)
           (H : forall b, get_memframe m1 b = get_memframe m2 b) : m1 = m2.
  (* I think this can actually be proved now *)
  admit.
Admitted.

Definition Z_seq z1 z2 := map Z.of_nat (iota (Z.to_nat z1) (Z.to_nat z2)).

Definition get_blocks_at_level {A} (m : mem A) s:=
    let max := next m s in
    let indices := Z_seq 0%Z max in
    map (fun ind => (ind,s)) indices.

Definition get_blocks {A} (ss : list Label) (m : mem A) : list block :=
    flatten (map (get_blocks_at_level m) ss).

Instance show_block : Show block :=
  {|
    show b :=
      let (z,s) := (b : block) in
      ("(" ++ show z ++ " @ " ++ show s ++ ")")%string
  |}.

Instance gen_block : GenSized block :=
  {|
    arbitrarySized := fun n => liftGen2 pair (arbitrarySized n) (arbitrarySized n)
  |}.

Definition map {A B} (f:memframe A -> memframe B) (m:mem A) : mem B :=
  Map.map (List.map f) m.

Lemma MapsTo_In : forall {A} m k {v : A}, Map.MapsTo k v m -> Map.In k m.
Proof. intros; exists v; auto. Qed.

Lemma map_spec : forall A B (f:memframe A -> memframe B) (m:mem A),
    forall b, get_memframe (map f m) b = omap f (get_memframe m b).
Proof.
  intros.
  rewrite /get_memframe /map /omap /obind /oapp.
  destruct (Map.find b.2 m) eqn:Find.
  - remember Find as Maps. clear HeqMaps. apply Map.find_2 in Maps.
    apply Map.map_1 with (f := List.map f) in Maps.
    apply Map.find_1 in Maps.
    rewrite Maps.
    apply nth_error_Z_map.
  - destruct (Map.find b.2 (Map.map (List.map f) m)) as [? | ?] eqn:Contra; auto.
    apply Map.find_2 in Contra.
    apply MapsTo_In in Contra.
    apply Map.map_2 in Contra.
    destruct Contra as [x Hx].
    apply Map.find_1 in Hx.
    congruence.
Qed.

Definition empty A : mem A := Map.empty _.

Lemma get_empty : forall A b, get_memframe (empty A)  b = None.
Proof. auto. Qed.

  (* Program Definition init A S {eqS : EqDec S eq} (am : alloc_mode) b f : t A S:= MEM *)
  (*   (fun b' : block S => if b' == b then Some f else None) *)
  (*   (fun s => if s == stamp _ b then fst b + 1 else 1)%Z *)
  (*   _.  *)
  (* Next Obligation. *)
  (*   simpl in *. *)
  (*   destruct (s == s0) as [EQ | NEQ]. *)
  (*   - compute in EQ. subst s0. *)
  (*     destruct (equiv_dec (i,s)) as [contra|]; trivial. *)
  (*     inv contra. *)
  (*     omega. *)
  (*   - destruct (equiv_dec (i,s)) as [E|E]; try congruence. *)
  (* Qed. *)

  (* Lemma get_init_eq : forall A S {eqS:EqDec S eq} *)
  (*                            mode (b : block S) (f : @memframe A S), *)
  (*                       get_memframe (init A S mode b f) b = Some f. *)
  (* Proof. *)
  (*   unfold init. simpl. *)
  (*   intros. *)
  (*   match goal with *)
  (*     | |- context [if ?b then _ else _] => *)
  (*       destruct b; congruence *)
  (*   end. *)
  (* Qed. *)

  (* Lemma get_init_neq : forall A S {eqS:EqDec S eq} *)
  (*                             mode (b b' : block S) (f : @memframe A S), *)
  (*                        b' <> b -> *)
  (*                        get_memframe (init A S mode b f) b' = None. *)
  (* Proof. *)
  (*   unfold init. simpl. *)
  (*   intros. *)
  (*   match goal with *)
  (*     | |- context [if ?b then _ else _] => *)
  (*       destruct b; congruence *)
  (*   end. *)
  (* Qed. *)

Definition upd_memframe {A} (m:mem A) (b:block) (fr:memframe A) : option (mem A) :=
  let (i,s) := b in
  match Map.find s m with
  | None => None
  | Some l =>
    match update_list_Z l i fr with
    | Some l' => Some (Map.add s l' m)
    | None => None
    end
  end.

Lemma eq_refl_false : forall (A : eqType) (x : A), x == x = false -> False.
Proof.
  move => A x H.
  pose proof (eq_refl x).
  congruence.
Qed.

Lemma eq_refl_false_2 : forall (A : eqType) (x y : A), x == y = false -> x <> y.
Proof.
  move => A x y H Contra; subst.
  eapply eq_refl_false; eauto.
Qed.

Lemma eq_refl_true : forall (A : eqType) (x y : A), x == y = true -> x = y.
Proof.
  move => A x y H.
  apply /eqP; auto.
Qed.

Hint Resolve
     update_list_Z_spec
     update_list_Z_spec3
     nth_error_Z_length_none
  : listZ.

Ltac solver :=
    simpl in *;
    match goal with
    (* Destruct across matches and equalities to simplify terms. *)
    | [ H : context [match ?X with | Some _ => _ | None => _ end] |- _ ]  =>
      let C := fresh "Case" in
      destruct X eqn:C
    | [ |- context [match ?X with | Some _ => _ | None => _ end] ]  =>
      let C := fresh "Case" in
      destruct X eqn:C
    | [ |- context [if @eq_op ?EqT ?X ?Y then _ else _] ] =>
      let C := fresh "Eq" in
      destruct (@eq_op EqT X Y) eqn:C
    | [ H : context[Map.E.eq_dec ?S1 ?S2] |- _ ] =>
      destruct (Map.E.eq_dec S1 S2); subst
    (* Reflect equalities for subst. *)
    | [ H : (?X == ?Y) = true |- _ ] => apply eq_refl_true in H; inv H
    (* Some is injective *)
    | [ H : Some ?X = Some ?Y |- _ ] => inv H
    | [ H : (_,_) = (_,_) |- _ ] => inv H
    (* Rewrite hypotheses with the same LHS. *)
    | [ H1 : ?X = Some ?Y1, H2 : ?X = Some ?Y2 |- _ ] =>
      rewrite H1 in H2; inv H2
    | [ H1 : ?X = Some ?Y1, H2 : ?X = None |- _ ] =>
      rewrite H1 in H2; inv H2
    (* Rewrite the find s (add s' m) pattern *)
    | [ H : context[Map.find ?S1 (Map.add ?S2 _ _)] |- _ ] =>
      rewrite MapFacts.add_o in H
    (* Discharge some easy contradictions. *)
    | [ H : (?X == ?X) = false |- _ ] => apply eq_refl_false in H; inv H
    | [ H : ?S <> ?S |- _ ] => exfalso; apply H; auto
    (* Lift inequality of pairs to inequality of first projection if possible. *)
    | [ H : (?I1, ?S) == (?I2, ?S) = false |- _ ] =>
      let N := fresh "NEq" in
      assert (N: I1 <> I2) by (move => ?; subst; apply eq_refl_false in H; inv H);
      clear H
    (* Resolve with spec2 to avoid infinite symmetry loop *)
    | [ H1 : update_list_Z ?L2 ?I ?Fr = Some ?L1
      , H2 : ?I1 <> ?I2
      |- nth_error_Z ?L1 ?I2 = nth_error_Z ?L2 ?I2 ] =>
      eapply update_list_Z_spec2 in H1; eauto
    (* Resolve contradiction using valid_update *)
    | [ H1 : nth_error_Z ?L ?I = Some _
      , H2 : update_list_Z ?L ?I ?Fr = None
      |- _ ] => apply valid_update with (x' := Fr) in H1; move: H1 => [? ?]
    end;
    (* Finish with eauto + list_Z hint database *)
    eauto with listZ.

Lemma upd_get_memframe : forall A (m:mem A) (b:block) fr fr',
    get_memframe m b = Some fr ->
    exists m', upd_memframe m b fr' = Some m'.
Proof.
  rewrite /upd_memframe /get_memframe => A m [i s] fr fr' HGet; simpl in *.
  repeat solver; try congruence.
Qed.

Lemma get_upd_memframe : forall A (m m':mem A) (b:block) fr,
    upd_memframe m b fr = Some m' ->
    forall b',
      get_memframe m' b' = if b == b' then Some fr else get_memframe m b'.
Proof.
  rewrite /upd_memframe /get_memframe => A m m' [i s] fr Hupd [i' s'] //=.
  repeat solver; try congruence.
Qed.

Lemma upd_memframe_defined : forall A (m m':mem A) (b:block) fr,
    upd_memframe m b fr = Some m' ->
    exists fr', get_memframe m b = Some fr'.
Proof.
  rewrite /upd_memframe /get_memframe => A m m' [i s] fr Upd.
  repeat solver; try congruence.
Qed.

Opaque Z.add.

Definition alloc {A} (m:mem A) (s:Label) (fr:memframe A)
  : (block * mem A) :=
  match Map.find s m with
  | Some l =>
    let i := Z.of_nat (length l) in
    ((i, s), Map.add s (l ++ [:: fr]) m)
  | None =>
    ((Z0, s), Map.add s [:: fr] m)
  end.

Lemma alloc_stamp : forall A (m m':mem A) s fr b,
    alloc m s fr = (b,m') -> stamp b = s.
Proof.
  rewrite /alloc => A m m' s fr b HAlloc.
  repeat solver.
Qed.

Lemma alloc_get_fresh : forall A (m m':mem A) s fr b,
    alloc m s fr = (b,m') -> get_memframe m b = None.
Proof.
  rewrite /alloc /get_memframe => A m m' s' fr [i s] HAlloc //=.
  repeat solver.
Qed.

Lemma alloc_get_memframe : forall A (m m':mem A) s0 fr b,
    alloc m s0 fr = (b,m') ->
    forall b', get_memframe m' b' = if b == b' then Some fr else get_memframe m b'.
Proof.
  rewrite /alloc /get_memframe => A m m' s0 fr [i s] HAlloc [i' s'] //=.
  repeat solver; try congruence.
  - apply nth_error_Z_app; auto.
  - move: (nth_error_Z_snoc l1 fr i') => [Contra | ?]; auto.
    rewrite -Contra in NEq.
    exfalso; eauto.
  - destruct i'; auto;
      try solve [exfalso; eauto].
    { (* Should be moved *)
          rewrite /nth_error_Z.
          destruct (Z.pos p <? 0)%Z; auto.
          destruct (Z.to_nat (Z.pos p)) eqn:Contra; simpl; auto.
          - rewrite Z2Nat.inj_pos in Contra.
            pose proof (Pos2Nat.is_pos p).
            lia.
          - destruct n; auto.
    }
Qed.

Lemma alloc_upd : forall A (m:mem A) b fr1 s fr2 m',
    upd_memframe m b fr1 = Some m' ->
    fst (alloc m' s fr2) = fst (alloc m s fr2).
Proof.
  rewrite /alloc /upd_memframe => A m [i s] fr1 s' fr2 m' H.
  repeat solver; try congruence.
  erewrite update_preserves_length_Z; eauto.
Qed.

Lemma alloc_local :
    forall A (m1 m2:mem A) s fr1 fr2,
      (forall b, stamp b = s -> get_memframe m1 b = get_memframe m2 b :> bool) ->
      (alloc m1 s fr1).1 = (alloc m2 s fr2).1.
Proof.
  rewrite /get_memframe /alloc => A m1 m2 s fr1 fr2 H.
  repeat solver; simpl.
  - f_equal. f_equal.
    apply nth_error_Z_length_ext => i.
    specialize (H (i,s)).
      simpl in *.
      rewrite Case in H.
      rewrite Case0 in H.
      apply H; auto.
  - specialize (H (0%Z,s)).
    simpl in *.
    rewrite Case Case0 in H.
    destruct l; simpl in *; simpl in *; auto.
    compute in H.
    specialize (H Coq.Init.Logic.eq_refl).
    congruence.
  - specialize (H (0%Z,s)).
    simpl in *.
    rewrite Case Case0 in H.
    destruct l; simpl in *; simpl in *; auto.
    compute in H.
    specialize (H Coq.Init.Logic.eq_refl).
    congruence.
Qed.

Lemma in_seq_Z:
  forall z start len,
    (0 <= start)%Z ->
      (0 <= len)%Z ->
      ((start <= z < len + start)%Z <->
       z \in (Z_seq start len)).
Proof.
    intros z s l. intros Hle1 Hle2. split.
    - intros [H1 H2]. unfold Z_seq.
      apply/mapP. exists (Z.to_nat z); last by rewrite Z2Nat.id; lia.
      apply Z2Nat.inj_lt in H2; try lia.
      rewrite Z2Nat.inj_add in H2; try lia.
      apply Z2Nat.inj_le in H1; try lia.
      apply Z2Nat.inj_le in Hle1; try lia.
      apply Z2Nat.inj_le in Hle2; try lia.
      simpl in *. remember (Z.to_nat s) as start.
      remember (Z.to_nat l) as len.
      remember (Z.to_nat z) as z'. clear Heqlen l Heqstart s Heqz' z Hle1.
      generalize dependent start. generalize dependent z'.
      induction len as [| l IHl]; intros s start Hle1 Hle3.
      + lia.
      + simpl in *. apply le_lt_or_eq in Hle1. destruct Hle1 as [H1 | H2].
        rewrite inE; apply/orP; right. apply IHl; try lia.
        rewrite inE; apply/orP; left; apply/eqP; congruence.
    - intros HIn. unfold Z_seq in HIn.
      move/mapP in HIn. destruct HIn as [z' HIn Heq]. subst.
      assert (H: Z.to_nat s <= z' < (Z.to_nat l) + (Z.to_nat s) ->
                 (s <= (Z.of_nat z') < l + s)%Z).
      { move=> /andP [H1 H2]. split.
        apply Z2Nat.inj_le; try lia. rewrite Nat2Z.id. apply/leP. assumption.
        apply Z2Nat.inj_lt; try lia. rewrite Nat2Z.id Z2Nat.inj_add;
         try lia. apply/ltP. assumption. }
      apply H.
      apply Z2Nat.inj_le in Hle1; try lia.
      apply Z2Nat.inj_le in Hle2; try lia.
      remember (Z.to_nat s) as start.
      remember (Z.to_nat l) as len.
      clear H Heqlen l Heqstart s.
      generalize dependent start. generalize dependent z'.
      induction len as [| len IHlen].
      + by [].
      + intros z' start Hle; rewrite /= inE => /orP HIn. simpl in *.
        case: HIn => [/eqP ?|HIn]; subst.
          rewrite addnE /addn_rec; apply/andP; split; [apply/leP|apply/ltP]; lia.
        * rewrite addSn -addnS.
        assert (H': S start <= z' < len + S start ->
                    start <= z' < len + S start).
        { rewrite addnE /addn_rec.
          move=> /andP [/leP H1 /ltP H2].
          apply/andP; split; [apply/leP| apply/ltP]; try lia. }
        apply H'. apply IHlen; try lia. assumption.
Qed.

Lemma get_blocks_spec :
    forall A (labs : list Label) (mem: mem A) b,
      (stamp b \in labs) && get_memframe mem b <->
      b \in get_blocks labs mem.
Proof.
  intros A labs mem b; split.
    - case/andP => HIn.
      case Hget: get_memframe => [fr|] //= _.
      unfold get_blocks; apply/flatten_mapP.
      eexists; [eassumption|].
      unfold get_blocks_at_level. apply/mapP. exists b.1;
      destruct b=> //.
      apply in_seq_Z; try lia; simpl in *.
      * apply next_pos.
      * rewrite Z.add_0_r.
        apply get_memframe_next. eexists. eassumption.
    - intros HIn. unfold get_blocks, get_blocks_at_level in *.
      move/flatten_mapP in HIn. destruct HIn as [l HInl HIn].
      move/mapP in HIn. destruct HIn as [z HIn Heq]. subst.
      rewrite HInl /=.
      unfold get_memframe.
      simpl in *.
      apply in_seq_Z in HIn; try lia.
      * rewrite Z.add_0_r in HIn. apply get_memframe_next in HIn.
        move: HIn => [fr H].
        rewrite /get_memframe in H.
        simpl in *.
        destruct (Map.find l mem).
        + rewrite H; auto.
        + congruence.
      * apply next_pos.
Qed.

Lemma alloc_get_memframe_old :
  forall T mem (stamp : Label) (f f' : memframe T) b b' mem'
         (ALLOC : alloc mem stamp f' = (b', mem'))
         (MEMFRAME : get_memframe mem b = Some f),
    get_memframe mem' b = Some f.
Proof.
  intros.
  erewrite alloc_get_memframe; eauto.
  have [e|//] := altP (b' =P b).
  exploit alloc_get_fresh; eauto.
  congruence.
Qed.

Lemma alloc_get_memframe_new :
  forall T mem (stamp : Label) (memframe : memframe T) b mem'
         (ALLOC : alloc mem stamp memframe = (b, mem')),
    get_memframe mem' b = Some memframe.
Proof.
  intros.
  erewrite alloc_get_memframe; eauto.
  by rewrite eqxx; simpl in *; auto.
Qed.

Lemma get_memframe_upd_memframe_eq :
  forall T
         (m : mem T) b f m'
         (UPD : upd_memframe m b f = Some m'),
    get_memframe m' b = Some f.
Proof.
  intros.
  erewrite get_upd_memframe; eauto.
  by rewrite eqxx.
Qed.

Lemma get_memframe_upd_memframe_neq :
  forall T
         (m : mem T) b b' f m'
         (UPD : upd_memframe m b f = Some m')
         (NEQ : b' <> b),
    get_memframe m' b' = get_memframe m b'.
Proof.
  intros.
  erewrite get_upd_memframe; eauto.
  have [?|?] := (b =P b'); simpl in *; congruence.
Qed.


(* This example (found by coqchk) checks that an inductive cannot be
   polymorphic if its constructors induce upper universe constraints.
   Here: I cannot be polymorphic because its type is less than the
   type of the argument of impl. *)

Definition Type1 := Type.
Definition Type3 : Type1 := Type.                       (* Type3 < Type1 *)
Definition Type4 := Type.
Definition impl (A B:Type3) : Type4 := A->B.           (* Type3 <= Type4 *)
Inductive I (B:Type (*6*)) := C : B -> impl Prop (I B).
    (* Type(6) <= Type(7)     because I contains, via C, elements in B
       Type(7) <=  Type3      because (I B) is argument of impl
       Type(4) <=  Type(7)    because type of C less than I (see remark below)

       where Type(7) is the auxiliary level used to infer the type of I
*)

(* We cannot enforce Type1 < Type(6) while we already have
   Type(6) <= Type(7) < Type3 < Type1 *)
Fail Definition J := I Type1.

(* Open question: should the type of an inductive be the max of the
   types of the _arguments_ of its constructors (here B and Prop,
   after unfolding of impl), or of the max of types of the
   constructors itself (here B -> impl Prop (I B)), as done above. *)


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Construction.Opposite.
Require Import Category.Functor.Opposite.

Generalizable All Variables.

Definition Opposite_Transform `{F : C ⟶ D} {G : C ⟶ D} `(N : F ⟹ G) :
  G^op ⟹ F^op :=
  @Build_Transform (C^op) (D^op) (G^op) (F^op) N
    (λ (x y : (C ^op)%category) (f : x ~{C^op}~> y),
      @naturality_sym C D F G N y x f)
    (λ (x y : (C ^op)%category) (f : x ~{C^op}~> y),
      @naturality C D F G N y x f).

Notation "N ^op" := (@Opposite_Transform _ _ _ _ N)
  (at level 7, format "N ^op", left associativity) : transform_scope.

Open Scope transform_scope.

Open Scope transform_scope.

Corollary Opposite_Transform_invol `{F : C ⟶ D} {G : C ⟶ D} `(N : F ⟹ G) :
  (N^op)^op = N.
Proof. reflexivity. Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Import ZArith.
Require Import Rbase.
Require Import Rbasic_fun.
Require int.Int.
Require real.Real.
Require real.Abs.
Require real.FromInt.
Require floating_point.Rounding.

Require Import Flocq.Core.Fcore.
Require Import Flocq.Appli.Fappli_IEEE.
Require Import int.Abs.

Section GenFloat.
Global Coercion B2R_coercion prec emax := @B2R prec emax.

Variable prec emax : Z.
Hypothesis Hprec : Zlt_bool 0 prec = true.
Hypothesis Hemax : Zlt_bool prec emax = true.
Let emin := (3 - emax - prec)%Z.
Notation fexp := (FLT_exp emin prec).

Lemma Hprec': (0 < prec)%Z. revert Hprec. now case Zlt_bool_spec. Qed.
Lemma Hemax': (prec < emax)%Z. revert Hemax. now case Zlt_bool_spec. Qed.

Instance Hprec'' : Prec_gt_0 prec := Hprec'.

Record t : Set := mk_fp {
  binary : binary_float prec emax;
  value := (binary : R);
  exact : R;
  model : R
}.

Lemma t_inv :
  forall x xe xm y ye ym,
  (x = y -> xe = ye -> xm = ym -> False) ->
  (mk_fp x xe xm <> mk_fp y ye ym).
Proof.
intros x xe xm y ye ym H H'.
apply H.
exact (f_equal binary H').
exact (f_equal exact H').
exact (f_equal model H').
Qed.

Lemma t_WhyType : WhyType t.
Proof with
match goal with
| _ => try ( right ; apply t_inv ; easy )
end.
split.
split.
apply Fappli_IEEE.B754_zero.
exact false.
exact R0.
exact R0.
intros x y.
destruct x as (x,xv,xe,xm).
destruct y as (y,yv,ye,ym).
destruct (Req_EM_T xe ye) as [He|He]...
destruct (Req_EM_T xm ym) as [Hm|Hm]...
rewrite He, Hm.
destruct x as [xs|xs|xs xm'|xs xm' xe' xH] ;
  destruct y as [ys|ys|ys ym'|ys ym' ye' yH]...
clear.
destruct (Bool.bool_dec xs ys) as [->|Hs].
now left.
right.
apply t_inv.
intros H _ _.
now injection H.
clear.
destruct (Bool.bool_dec xs ys) as [->|Hs].
now left.
right.
apply t_inv.
intros H _ _.
now injection H.
clear.
destruct (Bool.bool_dec xs ys) as [->|Hs].
destruct (Z_eq_dec (Zpos (proj1_sig xm')) (Zpos (proj1_sig ym'))) as [Hm'|Hm'].
left.
apply f_equal3 ; try easy.
apply f_equal2 ; try easy.
destruct xm' as [xm' pxm'].
destruct ym' as [ym' pym'].
simpl in Hm'.
injection Hm'.
intros ->.
now rewrite (eqbool_irrelevance _ pxm' pym').
right.
apply t_inv.
intros H _ _.
injection H.
contradict Hm'.
now rewrite Hm'.
right.
apply t_inv.
intros H _ _.
now injection H.
destruct (Req_EM_T xv yv) as [Hv|Hv].
left.
apply f_equal3 ; try easy.
now apply B2R_inj.
right.
apply t_inv.
intros H _ _.
apply Hv.
now apply f_equal.
Qed.

Record t_strict: Set := mk_fp_strict {
  datum :> t;
  finite : is_finite prec emax (binary datum) = true
}.

Import Rounding.
Definition rnd_of_mode (m:mode) :=
  match m with
  |  NearestTiesToEven => mode_NE
  |  ToZero            => mode_ZR
  |  Up                => mode_UP
  |  Down              => mode_DN
  |  NearestTiesToAway => mode_NA
  end.

Definition r_to_fp rnd x : binary_float prec emax :=
  let r := round radix2 fexp (round_mode rnd) x in
  let m := Ztrunc (scaled_mantissa radix2 fexp r) in
  let e := canonic_exp radix2 fexp r in
  binary_normalize prec emax Hprec' Hemax' rnd m e false.

Lemma is_finite_FF2B :
  forall f H,
  is_finite prec emax (FF2B prec emax f H) =
    match f with
    | F754_finite _ _ _ => true
    | F754_zero _ => true
    | _ => false
    end.
Proof.
now intros [| | |].
Qed.

Theorem r_to_fp_correct :
  forall rnd x,
  let r := round radix2 fexp (round_mode rnd) x in
  (Rabs r < bpow radix2 emax)%R ->
  is_finite prec emax (r_to_fp rnd x) = true /\
  r_to_fp rnd x = r :>R.
Proof with auto with typeclass_instances.
intros rnd x r Bx.
unfold r_to_fp. fold r.
generalize (binary_normalize_correct prec emax Hprec' Hemax' rnd (Ztrunc (scaled_mantissa radix2 fexp r)) (canonic_exp radix2 fexp r) false).
unfold r.
elim generic_format_round...
fold emin r.
rewrite round_generic...
rewrite Rlt_bool_true with (1 := Bx).
now split.
apply generic_format_round...
Qed.

Theorem r_to_fp_format :
  forall rnd x,
  FLT_format radix2 emin prec x ->
  (Rabs x < bpow radix2 emax)%R ->
  r_to_fp rnd x = x :>R.
Proof with auto with typeclass_instances.
intros rnd x Fx Bx.
assert (Gx: generic_format radix2 fexp x).
apply generic_format_FLT.
apply Fx.
pattern x at 2 ; rewrite <- round_generic with (rnd := round_mode rnd) (2 := Gx)...
refine (proj2 (r_to_fp_correct _ _ _)).
rewrite round_generic...
Qed.

Definition r_to_fp_aux (m:mode) (r r1 r2:R) :=
  mk_fp (r_to_fp (rnd_of_mode m) r) r1 r2.

(* Why3 goal *)
Definition round: floating_point.Rounding.mode -> R -> R.
exact (fun m => round radix2 fexp (round_mode (rnd_of_mode m))).
Defined.

(* Why3 assumption *)
Definition round_error(x:t): R := (Rabs ((value x) - (exact x))%R).

(* Why3 assumption *)
Definition total_error(x:t): R := (Rabs ((value x) - (model x))%R).

(* Why3 goal *)
Definition max: R.
exact (F2R (Float radix2 (Zpower 2 prec - 1) (emax - prec))).
Defined.

(* Why3 assumption *)
Definition no_overflow(m:floating_point.Rounding.mode) (x:R): Prop :=
  ((Rabs (round m x)) <= max)%R.

(* Why3 goal *)
Lemma Bounded_real_no_overflow : forall (m:floating_point.Rounding.mode)
  (x:R), ((Rabs x) <= max)%R -> (no_overflow m x).
Proof with auto with typeclass_instances.
intros m x Hx.
apply Rabs_le.
assert (generic_format radix2 fexp max).
apply generic_format_F2R.
intros H.
unfold canonic_exp.
rewrite ln_beta_F2R with (1 := H).
rewrite (ln_beta_unique _ _ prec).
ring_simplify (prec + (emax - prec))%Z.
unfold FLT_exp.
rewrite Zmax_l.
apply Zle_refl.
unfold emin.
generalize Hprec' Hemax' ; clear ; omega.
rewrite <- Z2R_abs, Zabs_eq, <- 2!Z2R_Zpower.
split.
apply Z2R_le.
apply Zlt_succ_le.
change (2 ^ prec - 1)%Z with (Zpred (2^prec))%Z.
rewrite <- Zsucc_pred.
apply lt_Z2R.
change 2%Z with (radix_val radix2).
rewrite 2!Z2R_Zpower.
apply bpow_lt.
apply Zlt_pred.
apply Zlt_le_weak.
exact Hprec'.
generalize Hprec' ; clear ; omega.
apply Z2R_lt.
apply Zlt_pred.
apply Zlt_le_weak.
exact Hprec'.
generalize Hprec' ; clear ; omega.
apply Zlt_succ_le.
change (2 ^ prec - 1)%Z with (Zpred (2^prec))%Z.
rewrite <- Zsucc_pred.
change 2%Z with (radix_val radix2).
apply Zpower_gt_0.
apply Zlt_le_weak.
exact Hprec'.
generalize (Rabs_le_inv _ _ Hx).
split.
apply round_ge_generic...
now apply generic_format_opp.
apply H0.
apply round_le_generic...
apply H0.
Qed.

(* Why3 goal *)
Lemma Round_monotonic : forall (m:floating_point.Rounding.mode) (x:R) (y:R),
  (x <= y)%R -> ((round m x) <= (round m y))%R.
Proof with auto with typeclass_instances.
intros m x y Hxy.
apply round_le with (3 := Hxy)...
Qed.

(* Why3 goal *)
Lemma Round_idempotent : forall (m1:floating_point.Rounding.mode)
  (m2:floating_point.Rounding.mode) (x:R), ((round m1 (round m2
  x)) = (round m2 x)).
Proof with auto with typeclass_instances.
intros m1 m2 x.
apply round_generic...
apply generic_format_round...
Qed.

(* Why3 goal *)
Lemma Round_value : forall (m:floating_point.Rounding.mode) (x:t), ((round m
  (value x)) = (value x)).
Proof with auto with typeclass_instances.
intros m x.
apply round_generic...
apply generic_format_B2R.
Qed.

(* Why3 goal *)
Lemma Bounded_value : forall (x:t), ((Rabs (value x)) <= max)%R.
Proof with auto with typeclass_instances.
intros x.
replace max with (pred radix2 fexp (bpow radix2 emax)).
apply le_pred_lt...
apply generic_format_abs.
apply generic_format_B2R.
apply generic_format_bpow.
unfold FLT_exp, emin.
zify ; generalize Hprec' Hemax' ; omega.
apply abs_B2R_lt_emax.
rewrite pred_eq_pos.
unfold pred_pos.
rewrite ln_beta_bpow.
ring_simplify (emax+1-1)%Z.
rewrite Req_bool_true by easy.
unfold FLT_exp, emin.
rewrite Zmax_l.
unfold max, F2R; simpl.
pattern emax at 1; replace emax with (prec+(emax-prec))%Z by ring.
rewrite bpow_plus.
change 2%Z with (radix_val radix2).
rewrite Z2R_minus, Z2R_Zpower.
simpl; ring.
apply Zlt_le_weak.
exact Hprec'.
generalize Hprec' Hemax' ; omega.
apply bpow_ge_0.
Qed.

(* Why3 goal *)
Definition max_representable_integer: Z.
exact (Zpower 2 prec).
Defined.

(* Why3 goal *)
Lemma Exact_rounding_for_integers : forall (m:floating_point.Rounding.mode)
  (i:Z), (((-max_representable_integer)%Z <= i)%Z /\
  (i <= max_representable_integer)%Z) -> ((round m (IZR i)) = (IZR i)).
Proof with auto with typeclass_instances.
intros m z Hz.
apply round_generic...
assert (Zabs z <= max_representable_integer)%Z.
apply Abs_le with (1:=Hz).
destruct (Zle_lt_or_eq _ _ H) as [Bz|Bz] ; clear H Hz.
apply generic_format_FLT.
exists (Float radix2 z 0).
unfold F2R ; simpl.
split.
rewrite Z2R_IZR.
now rewrite Rmult_1_r.
split. easy.
unfold emin; generalize Hprec' Hemax'; omega.
unfold max_representable_integer in Bz.
change 2%Z with (radix_val radix2) in Bz.
apply generic_format_abs_inv.
rewrite  <- Z2R_IZR, <- Z2R_abs, Bz, Z2R_Zpower.
apply generic_format_bpow.
unfold FLT_exp, emin.
clear Bz; generalize Hprec' Hemax'; zify.
omega.
apply Zlt_le_weak.
apply Hprec'.
Qed.

(* Why3 goal *)
Lemma Round_down_le : forall (x:R), ((round floating_point.Rounding.Down
  x) <= x)%R.
Proof with auto with typeclass_instances.
intros x.
apply round_DN_pt...
Qed.

(* Why3 goal *)
Lemma Round_up_ge : forall (x:R), (x <= (round floating_point.Rounding.Up
  x))%R.
Proof with auto with typeclass_instances.
intros x.
apply round_UP_pt...
Qed.

(* Why3 goal *)
Lemma Round_down_neg : forall (x:R), ((round floating_point.Rounding.Down
  (-x)%R) = (-(round floating_point.Rounding.Up x))%R).
Proof.
intros x.
apply round_opp.
Qed.

(* Why3 goal *)
Lemma Round_up_neg : forall (x:R), ((round floating_point.Rounding.Up
  (-x)%R) = (-(round floating_point.Rounding.Down x))%R).
Proof.
intros x.
pattern x at 2 ; rewrite <- Ropp_involutive.
rewrite Round_down_neg.
now rewrite Ropp_involutive.
Qed.

(* Why3 goal *)
Definition round_logic: floating_point.Rounding.mode -> R -> t.
exact (fun m r => r_to_fp_aux m r r r).
Defined.

(* Why3 goal *)
Lemma Round_logic_def : forall (m:floating_point.Rounding.mode) (x:R),
  (no_overflow m x) -> ((value (round_logic m x)) = (round m x)).
Proof.
intros m x h1.
unfold value, round_logic.
simpl.
apply r_to_fp_correct.
apply Rle_lt_trans with (1 := h1).
replace emax with (prec + (emax - prec))%Z by ring.
rewrite bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
simpl.
rewrite <- Z2R_Zpower.
apply Z2R_lt.
apply Zlt_pred.
apply Zlt_le_weak.
exact Hprec'.
Qed.

End GenFloat.


Inductive Two := C21 | C22.
Inductive Three := C31 | C32 | C33.

Definition task := Two <> Three.


(* Тріада: терм - тип - сорт, де сорт є або Set, або Prop, або Type.
   Все є терми, деякі з термів є типами.
   Сорти - це спеціальні типові константи Set, Prop та Type.
   Сорт Type насправді індексований натуральними числами
      Type_0, ..., Type_k, ..., але індекс завжди прихований.
   Кожний терм t населяє певний тип T, що позначається через t : T.
   Наприклад, Set : Type_0, Prop : Type_0, Type_k : Type_{k+1}.
   Наспроавді постулюється справедливість таких суджень:
      Set : Type_0
      Prop : Type_0
      Type_n : Type_m, якщо n < m
   та для будь-якого типу T
      T : Type_0, якщо T : Set
      T : Type_0, якщо T : Prop
      T : Type_m якщо T : T_n та n < m
*)

Check Set.
Check Prop.
Check Type.

Section SecName.
Variable T : Type.
Hypothesis tnd : forall P : Prop, P \/ ~P.
Check T.
End SecName.
Fail Check T.

Locate False.
Locate True.
Check False.
Print Term False.
Check False_ind.

Check True.
Print Term True.
Check True_ind.

Check bool.
Print Term bool.
Check bool_ind.

Section bool_and_Prop.
Variables X : Type.

Definition P (ch : X -> bool) : X -> Prop :=
  fun x => ch x = true.
Check P _.

Lemma P_ch_dec : forall ch x, (P ch x \/ ~ P ch x).
Proof.
  intros. unfold P.
  case (ch x).
  - (* case ch x = true *)
    left. reflexivity.
  - (* case ch x = false *)
    right. intro. discriminate.
Qed.
End bool_and_Prop.
Check P.
Check P_ch_dec.

Check and.
Print Term and.
Check and_ind.

Section andProperties.
Variables A B C : Prop.

Lemma and_comm : A /\ B <-> B /\ A.
Proof.
  split; intro.
  - elim H. intros HA HB.
(*    pose (HBA := conj HB HA). exact HBA.   *)
    split; assumption.
  - elim H. intros HB HA.
    split; assumption.
Qed.

Lemma and_comm' : A /\ B <-> B /\ A.
Proof. split; intro; elim H; intros; split; assumption. Qed.

Print Term and_comm.
Print Term and_comm'.

Lemma and_assoc : (A /\ B) /\ C <-> A /\ (B /\ C).
Proof.
  split; intro H.
  - elim H. intros. elim H0. intros. split; [ assumption | split; assumption ].
  - elim H. intros. elim H1. intros; split; [ split; assumption | assumption ].
Qed.

Lemma and_assoc' : (A /\ B) /\ C <-> A /\ (B /\ C).
Proof.
  split; intro H; elim H; intros; [elim H0 | elim H1];
  intros; repeat split; assumption.
Qed.

Print Term and_assoc.
Print Term and_assoc'.

End andProperties.

Check and_comm.
Check and_assoc.

Check or.
Print Term or.
Check or_ind.

Section orProperties.
Variables A B C : Prop.

Lemma or_comm : A \/ B <-> B \/ A.
Proof.
  split; intro; elim H; intro;
  (right; assumption) || (left; assumption).
Qed.

Lemma or_assoc: (A \/ B) \/ C <-> A \/ (B \/ C).
Proof.
  split; intro; elim H; intro; try (elim H0; intro);
  (repeat left; assumption) ||
    (repeat right; assumption) ||
    (right; left; assumption) ||
    (left; right; assumption).
Qed.

End orProperties.

Print Term or_comm.
Print Term or_assoc.

Section PLaxioms.
Variables A B C : Prop.

Lemma ax1 : A -> B -> A.
Admitted.

Lemma ax2 : (A -> B) -> (A -> B -> C) -> A -> C.
Proof.
  intros H1 H2 H3. apply H2.
  - assumption.
(*  - apply H1. assumption. *)
  - pose (H := H1 H3). assumption.
Qed.

Lemma ax3 : A /\ B -> A.
Admitted.

Lemma ax4 : A /\ B -> B.
Admitted.

Lemma ax5 : (A -> B) -> (A -> C) -> A -> (B /\ C).
Proof.
  intros H1 H2 H3. split.
  - apply H1. assumption.
  - apply H2. assumption.
Qed.

Lemma ax6 : A -> A \/ B.
Admitted.

Lemma ax7 : B -> A \/ B.
Admitted.

Lemma ax8 : (A -> C) -> (B -> C) -> (A \/ B) -> C.
Proof.
  intros H1 H2 H3.
  elim H3; intro H.
  - apply H1. assumption.
  - apply H2. assumption.
Qed.

Lemma ax9 : (A -> ~ B) -> B -> ~ A.
Admitted.

End PLaxioms.


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

(* Restrict a map by a set of keys *)
(* Fold over the set we are restricting with for better induction. *)
Definition restrict {A} (m : M.t A) s :=
  S.fold (fun k m' => match M.find k m with
                   | Some v => M.add k v m'
                   | None => m'
                   end) s (@M.empty _).

Lemma restrict_subset_keys {A} : forall (m : M.t A) s, S.Subset (Mdomain (restrict m s)) (Mdomain m).
Proof.
  intros m s.
  unfold restrict.
  apply SP.fold_rec_bis.
  - sauto lq: on.
  - hecrush.
  - intros x a s' H H0 H1.
    destruct (M.find x m) eqn:E.
    + intros i Hi.
      destruct (E.eq_dec x i).
      * subst. qauto use: Sin_domain unfold: PositiveMap.MapsTo, PositiveMap.In.
      * hauto lq: on use: WF.add_neq_in_iff, Sin_domain unfold: PositiveSet.elt, PositiveSet.Subset, PositiveMap.key.
    + assumption.
Qed.

Lemma restrict_incl {A} :
  forall s (f : M.t A) i, M.In i (restrict f s) -> M.In i f.
Proof.
  hauto lq: on use: @restrict_subset_keys, Sin_domain unfold: PositiveSet.Subset, PositiveSet.elt, PositiveMap.key.
Qed.

Lemma restrict_restricts {A} :
  forall s (f : M.t A) i, S.In i s -> M.In i f -> M.In i (restrict f s).
Proof.
  intros s f i Hi Hf.
  generalize dependent Hi.
  unfold restrict.
  apply SP.fold_rec_bis.
  - sfirstorder.
  - sauto q: on.
  - intros x a s' H H0 H1 Hi.
    destruct (E.eq_dec i x).
    + subst. hfcrush use: WF.in_find_iff, WF.add_in_iff unfold: PositiveSet.elt, PositiveMap.key inv: option.
    + qauto use: PositiveSet.add_3, WF.add_in_iff unfold: PositiveSet.elt, PositiveMap.key inv: option.
Qed.

(* extensive use of hammer *)
Lemma restrict_full {A} :
  forall s (f : M.t A) (v i : M.key),
    S.In i s ->
    M.In i f ->
    S.Subset (Mdomain (restrict f s)) (Mdomain f) ->
    S.In i (Mdomain (restrict f s)).
Proof.
  hfcrush use: @restrict_restricts, Sin_domain unfold: PositiveSet.elt, PositiveMap.key.
Qed.

(* Looking through restriction of a map, the values still agree *)
Lemma restrict_agree {A} : forall (m : M.t A) s k v,
    M.find k (restrict m s) = Some v ->
    M.find k m = Some v.
Proof.
  intros m s k v.
  unfold restrict.
  apply SP.fold_rec_bis.
  - sfirstorder.
  - sauto lq: on.
  - intros x a s' H H0 H1 H2.
    destruct (E.eq_dec k x).
    + subst. hauto use: PositiveMap.gss unfold: PositiveMap.key, PositiveSet.elt inv: option.
    + hauto use: PositiveMap.gso unfold: PositiveSet.elt, PositiveMap.key inv: option.
Qed.

Lemma restrict_agree_2 {A} : forall (m : M.t A) s k,
    S.In k s -> M.find k m = M.find k (restrict m s).
Proof.
  intros m s k H.
  destruct (M.find k m) eqn:E.
  - hfcrush use: @restrict_agree, @restrict_restricts, WF.in_find_iff unfold: PositiveMap.key, PositiveSet.elt inv: option.
  - apply not_not.
    {
      unfold decidable.
      remember (M.find k (restrict m s)) as y.
      destruct y; sfirstorder.
    }
    intros contra.
    destruct (M.find k (restrict m s)) eqn:E2.
    + qauto use: @restrict_agree unfold: PositiveSet.elt, PositiveMap.key.
    + contradiction.
Qed.

(* Being in the restriction is enough evidence to be in the set *)
Lemma restrict_in_set {A} : forall (m : M.t A) s k v,
    M.find k (restrict m s) = Some v ->
    S.In k s.
Proof.
  intros m s k v.
  unfold restrict.
  apply SP.fold_rec_bis.
  - sfirstorder.
  - sauto lq: on rew: off.
  - intros x a s' H H0 H1 H2.
    destruct (E.eq_dec k x).
    + subst. hauto l: on use: PositiveSet.add_1.
    + hauto use: PositiveSet.add_2, PositiveMap.gso unfold: PositiveMap.key, PositiveSet.elt inv: option.
Qed.

(* Same as above, rephrased with M.In *)
Lemma restrict_in_set2 {A} : forall (m : M.t A) s k,
    M.In k (restrict m s) ->
    S.In k s.
Proof.
  intros m s k [v].
  eapply restrict_in_set; eauto.
Qed.

Lemma restrict_m {A} : forall s s',
    S.Equal s s' ->
    forall k k' : M.t A, M.Equal k k' -> M.Equal (restrict k s) (restrict k' s').
Proof.
  intros s s' H k k' H0.
  apply WF.Equal_mapsto_iff.
  intros k0 e.
  unfold M.MapsTo.
  hauto lq: on use: @restrict_agree_2, @restrict_in_set unfold: PositiveSet.elt, PositiveMap.key, PositiveMap.Equal, PositiveSet.Equal.
Qed.

Lemma restrict_map_comm {A B} : forall (m : M.t A) (f : A -> B) s,
    M.Equal (M.map f (restrict m s)) (restrict (M.map f m) s).
Proof.
  intros m f s.
  apply WF.Equal_mapsto_iff.
  unfold M.MapsTo.
  intros k e.
  split; intros H.
  - rewrite WF.map_o in H.
    destruct (M.find k (restrict m s)) eqn:E; [|scongruence].
    simpl in H.
    rewrite <- H.
    pose proof (restrict_in_set m s k _ E).
    eapply restrict_agree in E.
    pose proof (restrict_agree_2 m _ _ H0).
    pose proof (restrict_agree_2 (M.map f m) s k H0).
    ssimpl.
    qauto use: WF.map_o unfold: PositiveMap.MapsTo, option_map.
  - hfcrush use: WF.map_o, @restrict_in_set, @restrict_agree_2 unfold: PositiveSet.elt, PositiveMap.key.
Qed.

Lemma restrict_spec : forall {A} (m : M.t A) s k,
    M.In k (restrict m s) <-> M.In k m /\ S.In k s.
Proof.
  intros A m s k.
  split; intros H.
  - split.
    + eauto using restrict_incl.
    + eauto using restrict_in_set2.
  - intuition auto using restrict_restricts.
Qed.

Lemma restrict_cardinal {A} : forall (m : M.t A) s,
    M.cardinal (restrict m s) = S.cardinal (S.inter (Mdomain m) s).
Proof.
  intros m s.
  apply Mcardinal_Scardinal.
  intros k.
  rewrite restrict_spec.
  rewrite S.inter_spec.
  rewrite Sin_domain.
  firstorder.
Qed.

Lemma adj_restrict : forall g s i j,
    S.In i (adj (restrict g s) j) <-> S.In i (adj g j) /\ S.In j s.
Proof.
  intros g s i j.
  split.
  - intros H.
    apply in_adj_exists in H.
    destruct H as [v [F I]].
    split; eauto using restrict_in_set.
    eauto using restrict_agree, find_in_adj.
  - intros [I J].
    apply in_adj_exists in I.
    destruct I as [v [F I]].
    eapply find_in_adj.
    rewrite <- restrict_agree_2 by auto.
    eauto.
    auto.
Qed.


(* Copyright (c) 2008-2012, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import Coq.Lists.List.
Require Import List.

Require Import CpdtTactics.

Set Implicit Arguments.

(* Extra definitions to get coqdoc to choose the right fonts. *)

(* begin thide *)
Inductive unit := tt.
Inductive Empty_set := .
Inductive bool := true | false.
Inductive sum := .
Inductive prod := .
Inductive and := conj.
Inductive or := or_introl | or_intror.
Inductive ex := ex_intro.
Inductive eq := eq_refl.
Reset unit.
(* end thide *)
(* end hide *)

(** %\chapter{Inductive Predicates}% *)

(** The so-called %\index{Curry-Howard correspondence}``%#"#Curry-Howard correspondence#"#%''~\cite{Curry,Howard}% states a formal connection between functional programs and mathematical proofs.  In the last chapter, we snuck in a first introduction to this subject in Coq.  Witness the close similarity between the types [unit] and [True] from the standard library: *)

Print unit.
(** %\vspace{-.15in}%[[
  Inductive unit : Set :=  tt : unit
]]
*)

Print True.
(** %\vspace{-.15in}%[[
  Inductive True : Prop :=  I : True
  ]]

Recall that [unit] is the type with only one value, and [True] is the proposition that always holds.  Despite this superficial difference between the two concepts, in both cases we can use the same inductive definition mechanism.  The connection goes further than this.  We see that we arrive at the definition of [True] by replacing [unit] by [True], [tt] by [I], and [Set] by [Prop].  The first two of these differences are superficial changes of names, while the third difference is the crucial one for separating programs from proofs.  A term [T] of type [Set] is a type of programs, and a term of type [T] is a program.  A term [T] of type [Prop] is a logical proposition, and its proofs are of type [T].  Chapter 12 goes into more detail about the theoretical differences between [Prop] and [Set].  For now, we will simply follow common intuitions about what a proof is.

The type [unit] has one value, [tt].  The type [True] has one proof, [I].  Why distinguish between these two types?  Many people who have read about Curry-Howard in an abstract context but who have not put it to use in proof engineering answer that the two types in fact _should not_ be distinguished.  There is a certain aesthetic appeal to this point of view, but I want to argue that it is best to treat Curry-Howard very loosely in practical proving.  There are Coq-specific reasons for preferring the distinction, involving efficient compilation and avoidance of paradoxes in the presence of classical math, but I will argue that there is a more general principle that should lead us to avoid conflating programming and proving.

The essence of the argument is roughly this: to an engineer, not all functions of type [A -> B] are created equal, but all proofs of a proposition [P -> Q] are.  This idea is known as%\index{proof irrelevance}% _proof irrelevance_, and its formalizations in logics prevent us from distinguishing between alternate proofs of the same proposition.  Proof irrelevance is compatible with, but not derivable in, Gallina.  Apart from this theoretical concern, I will argue that it is most effective to do engineering with Coq by employing different techniques for programs versus proofs.  Most of this book is organized around that distinction, describing how to program, by applying standard functional programming techniques in the presence of dependent types; and how to prove, by writing custom Ltac decision procedures.

With that perspective in mind, this chapter is sort of a mirror image of the last chapter, introducing how to define predicates with inductive definitions.  We will point out similarities in places, but much of the effective Coq user's bag of tricks is disjoint for predicates versus "datatypes."  This chapter is also a covert introduction to dependent types, which are the foundation on which interesting inductive predicates are built, though we will rely on tactics to build dependently typed proof terms for us for now.  A future chapter introduces more manual application of dependent types. *)

(** * Propositional Logic *)

(** Let us begin with a brief tour through the definitions of the connectives for propositional logic.  We will work within a Coq section that provides us with a set of propositional variables.  In Coq parlance, these are just variables of type [Prop]. *)

Section Propositional.
  Variables P Q R : Prop.

  (** In Coq, the most basic propositional connective is implication, written [->], which we have already used in almost every proof.  Rather than being defined inductively, implication is built into Coq as the function type constructor.

We have also already seen the definition of [True].  For a demonstration of a lower-level way of establishing proofs of inductive predicates, we turn to this trivial theorem. *)

  Theorem obvious : True.
(* begin thide *)
    apply I.
(* end thide *)
  Qed.

  (** We may always use the [apply] tactic to take a proof step based on applying a particular constructor of the inductive predicate that we are trying to establish.  Sometimes there is only one constructor that could possibly apply, in which case a shortcut is available:%\index{tactics!constructor}% *)

(* begin thide *)
  Theorem obvious' : True.
    constructor.
  Qed.

(* end thide *)

  (** There is also a predicate [False], which is the Curry-Howard mirror image of [Empty_set] from the last chapter. *)

  Print False.
  (** %\vspace{-.15in}%[[
  Inductive False : Prop :=
  ]]

  We can conclude anything from [False], doing case analysis on a proof of [False] in the same way we might do case analysis on, say, a natural number.  Since there are no cases to consider, any such case analysis succeeds immediately in proving the goal. *)

  Theorem False_imp : False -> 2 + 2 = 5.
(* begin thide *)
    destruct 1.
(* end thide *)
  Qed.

  (** In a consistent context, we can never build a proof of [False].  In inconsistent contexts that appear in the courses of proofs, it is usually easiest to proceed by demonstrating the inconsistency with an explicit proof of [False]. *)

  Theorem arith_neq : 2 + 2 = 5 -> 9 + 9 = 835.
(* begin thide *)
    intro.

    (** At this point, we have an inconsistent hypothesis [2 + 2 = 5], so the specific conclusion is not important.  We use the %\index{tactics!elimtype}%[elimtype] tactic.  For a full description of it, see the Coq manual.  For our purposes, we only need the variant [elimtype False], which lets us replace any conclusion formula with [False], because any fact follows from an inconsistent context. *)

    elimtype False.
    (** [[
  H : 2 + 2 = 5
  ============================
   False

   ]]

   For now, we will leave the details of this proof about arithmetic to [crush]. *)

    crush.
(* end thide *)
  Qed.

  (** A related notion to [False] is logical negation. *)

  (* begin hide *)
  Definition foo := not.
  (* end hide *)

  Print not.
  (** %\vspace{-.15in}% [[
    not = fun A : Prop => A -> False
      : Prop -> Prop
     ]]

     We see that [not] is just shorthand for implication of [False].  We can use that fact explicitly in proofs.  The syntax [~ P] %(written with a tilde in ASCII)% expands to [not P]. *)

  Theorem arith_neq' : ~ (2 + 2 = 5).
(* begin thide *)
    unfold not.
    (** [[
  ============================
   2 + 2 = 5 -> False
   ]]
   *)

    crush.
(* end thide *)
  Qed.

  (** We also have conjunction, which we introduced in the last chapter. *)

  Print and.
(** %\vspace{-.15in}%[[
    Inductive and (A : Prop) (B : Prop) : Prop :=  conj : A -> B -> A /\ B
  ]]

  The interested reader can check that [and] has a Curry-Howard equivalent called %\index{Gallina terms!prod}%[prod], the type of pairs.  However, it is generally most convenient to reason about conjunction using tactics.  An explicit proof of commutativity of [and] illustrates the usual suspects for such tasks.  The operator [/\] is an infix shorthand for [and]. *)

  Theorem and_comm : P /\ Q -> Q /\ P.

(* begin thide *)
    (** We start by case analysis on the proof of [P /\ Q]. *)

    destruct 1.
    (** [[
  H : P
  H0 : Q
  ============================
   Q /\ P

   ]]

    Every proof of a conjunction provides proofs for both conjuncts, so we get a single subgoal reflecting that.  We can proceed by splitting this subgoal into a case for each conjunct of [Q /\ P].%\index{tactics!split}% *)

    split.
(** [[
2 subgoals

  H : P
  H0 : Q
  ============================
   Q

subgoal 2 is

   P

 ]]

 In each case, the conclusion is among our hypotheses, so the %\index{tactics!assumption}%[assumption] tactic finishes the process. *)

    assumption.
    assumption.
(* end thide *)
  Qed.

  (** Coq disjunction is called %\index{Gallina terms!or}%[or] and abbreviated with the infix operator [\/]. *)

  Print or.
(** %\vspace{-.15in}%[[
  Inductive or (A : Prop) (B : Prop) : Prop :=
    or_introl : A -> A \/ B | or_intror : B -> A \/ B
]]

We see that there are two ways to prove a disjunction: prove the first disjunct or prove the second.  The Curry-Howard analogue of this is the Coq %\index{Gallina terms!sum}%[sum] type.  We can demonstrate the main tactics here with another proof of commutativity. *)

  Theorem or_comm : P \/ Q -> Q \/ P.

(* begin thide *)
    (** As in the proof for [and], we begin with case analysis, though this time we are met by two cases instead of one. *)

    destruct 1.
(** [[
2 subgoals

  H : P
  ============================
   Q \/ P

subgoal 2 is

 Q \/ P

 ]]

 We can see that, in the first subgoal, we want to prove the disjunction by proving its second disjunct.  The %\index{tactics!right}%[right] tactic telegraphs this intent. *)

    right; assumption.

    (** The second subgoal has a symmetric proof.%\index{tactics!left}%

       [[
1 subgoal

  H : Q
  ============================
   Q \/ P
   ]]
   *)

    left; assumption.

(* end thide *)
  Qed.

(* begin hide *)
(* In-class exercises *)

  Theorem contra : P -> ~P -> R.
(* begin thide *)
    unfold not.
    intros.
    elimtype False.
    apply H0.
    assumption.
(* end thide *)
  Admitted.

  Theorem and_assoc : (P /\ Q) /\ R -> P /\ (Q /\ R).
(* begin thide *)
    intros.
    destruct H.
    destruct H.
    split.
    assumption.
    split.
    assumption.
    assumption.
(* end thide *)
  Admitted.

  Theorem or_assoc : (P \/ Q) \/ R -> P \/ (Q \/ R).
(* begin thide *)
    intros.
    destruct H.
    destruct H.
    left.
    assumption.
    right.
    left.
    assumption.
    right.
    right.
    assumption.
(* end thide *)
  Admitted.

(* end hide *)

  (** It would be a shame to have to plod manually through all proofs about propositional logic.  Luckily, there is no need.  One of the most basic Coq automation tactics is %\index{tactics!tauto}%[tauto], which is a complete decision procedure for constructive propositional logic.  (More on what "constructive" means in the next section.)  We can use [tauto] to dispatch all of the purely propositional theorems we have proved so far. *)

  Theorem or_comm' : P \/ Q -> Q \/ P.
(* begin thide *)
    tauto.
(* end thide *)
  Qed.

  (** Sometimes propositional reasoning forms important plumbing for the proof of a theorem, but we still need to apply some other smarts about, say, arithmetic.  The tactic %\index{tactics!intuition}%[intuition] is a generalization of [tauto] that proves everything it can using propositional reasoning.  When some further facts must be established to finish the proof, [intuition] uses propositional laws to simplify them as far as possible.  Consider this example, which uses the list concatenation operator %\coqdocnotation{%#<tt>#++#</tt>#%}% from the standard library. *)

  Theorem arith_comm : forall ls1 ls2 : list nat,
    length ls1 = length ls2 \/ length ls1 + length ls2 = 6
    -> length (ls1 ++ ls2) = 6 \/ length ls1 = length ls2.
(* begin thide *)
    intuition.

    (** A lot of the proof structure has been generated for us by [intuition], but the final proof depends on a fact about lists.  The remaining subgoal hints at what cleverness we need to inject. *)

    (** [[
  ls1 : list nat
  ls2 : list nat
  H0 : length ls1 + length ls2 = 6
  ============================
   length (ls1 ++ ls2) = 6 \/ length ls1 = length ls2

   ]]

   We can see that we need a theorem about lengths of concatenated lists, which we proved last chapter and is also in the standard library. *)

    rewrite app_length.
    (** [[
  ls1 : list nat
  ls2 : list nat
  H0 : length ls1 + length ls2 = 6
  ============================
   length ls1 + length ls2 = 6 \/ length ls1 = length ls2

   ]]

   Now the subgoal follows by purely propositional reasoning.  That is, we could replace [length ls1 + length ls2 = 6] with [P] and [length ls1 = length ls2] with [Q] and arrive at a tautology of propositional logic. *)

    tauto.
(* end thide *)
  Qed.

  (** The [intuition] tactic is one of the main bits of glue in the implementation of [crush], so, with a little help, we can get a short automated proof of the theorem. *)

(* begin thide *)
  Theorem arith_comm' : forall ls1 ls2 : list nat,
    length ls1 = length ls2 \/ length ls1 + length ls2 = 6
    -> length (ls1 ++ ls2) = 6 \/ length ls1 = length ls2.
    Hint Rewrite app_length.

    crush.
  Qed.
(* end thide *)

End Propositional.

(** Ending the section here has the same effect as always.  Each of our propositional theorems becomes universally quantified over the propositional variables that we used. *)

(** * What Does It Mean to Be Constructive? *)

(** One potential point of confusion in the presentation so far is the distinction between [bool] and [Prop].  The datatype [bool] is built from two values [true] and [false], while [Prop] is a more primitive type that includes among its members [True] and [False].  Why not collapse these two concepts into one, and why must there be more than two states of mathematical truth, [True] and [False]?

The answer comes from the fact that Coq implements%\index{constructive logic}% _constructive_ or%\index{intuitionistic logic|see{constructive logic}}% _intuitionistic_ logic, in contrast to the%\index{classical logic}% _classical_ logic that you may be more familiar with.  In constructive logic, classical tautologies like [~ ~ P -> P] and [P \/ ~ P] do not always hold.  In general, we can only prove these tautologies when [P] is%\index{decidability}% _decidable_, in the sense of %\index{computability|see{decidability}}%computability theory.  The Curry-Howard encoding that Coq uses for [or] allows us to extract either a proof of [P] or a proof of [~ P] from any proof of [P \/ ~ P].  Since our proofs are just functional programs which we can run, a general %\index{law of the excluded middle}%law of the excluded middle would give us a decision procedure for the halting problem, where the instantiations of [P] would be formulas like "this particular Turing machine halts."

A similar paradoxical situation would result if every proposition evaluated to either [True] or [False].  Evaluation in Coq is decidable, so we would be limiting ourselves to decidable propositions only.

Hence the distinction between [bool] and [Prop].  Programs of type [bool] are computational by construction; we can always run them to determine their results.  Many [Prop]s are undecidable, and so we can write more expressive formulas with [Prop]s than with [bool]s, but the inevitable consequence is that we cannot simply "run a [Prop] to determine its truth."

Constructive logic lets us define all of the logical connectives in an aesthetically appealing way, with orthogonal inductive definitions.  That is, each connective is defined independently using a simple, shared mechanism.  Constructivity also enables a trick called%\index{program extraction}% _program extraction_, where we write programs by phrasing them as theorems to be proved.  Since our proofs are just functional programs, we can extract executable programs from our final proofs, which we could not do as naturally with classical proofs.

We will see more about Coq's program extraction facility in a later chapter.  However, I think it is worth interjecting another warning at this point, following up on the prior warning about taking the Curry-Howard correspondence too literally.  It is possible to write programs by theorem-proving methods in Coq, but hardly anyone does it.  It is almost always most useful to maintain the distinction between programs and proofs.  If you write a program by proving a theorem, you are likely to run into algorithmic inefficiencies that you introduced in your proof to make it easier to prove.  It is a shame to have to worry about such situations while proving tricky theorems, and it is a happy state of affairs that you almost certainly will not need to, with the ideal of extracting programs from proofs being confined mostly to theoretical studies. *)

(** * First-Order Logic *)

(** The %\index{Gallina terms!forall}%[forall] connective of first-order logic, which we have seen in many examples so far, is built into Coq.  Getting ahead of ourselves a bit, we can see it as the dependent function type constructor.  In fact, implication and universal quantification are just different syntactic shorthands for the same Coq mechanism.  A formula [P -> Q] is equivalent to [forall x : P, Q], where [x] does not appear in [Q].  That is, the "real" type of the implication says "for every proof of [P], there exists a proof of [Q]."

%\index{existential quantification}\index{Gallina terms!exists}\index{Gallina terms!ex}%Existential quantification is defined in the standard library. *)

  Print ex.
(** %\vspace{-.15in}%[[
  Inductive ex (A : Type) (P : A -> Prop) : Prop :=
    ex_intro : forall x : A, P x -> ex P
    ]]

  (Note that here, as always, each [forall] quantifier has the largest possible scope, so that the type of [ex_intro] could also be written [forall x : A, (P x -> ex P)].)

  The family [ex] is parameterized by the type [A] that we quantify over, and by a predicate [P] over [A]s.  We prove an existential by exhibiting some [x] of type [A], along with a proof of [P x].  As usual, there are tactics that save us from worrying about the low-level details most of the time.

  Here is an example of a theorem statement with existential quantification.  We use the equality operator [=], which, depending on the settings in which they learned logic, different people will say either is or is not part of first-order logic.  For our purposes, it is. *)

Theorem exist1 : exists x : nat, x + 1 = 2.
(* begin thide *)
  (** remove printing exists *)
  (** We can start this proof with a tactic %\index{tactics!exists}%[exists], which should not be confused with the formula constructor shorthand of the same name.  %In the version of this document that you are reading, the reverse ``E'' appears instead of the text ``exists'' in formulas.% *)

  exists 1.

  (** The conclusion is replaced with a version using the existential witness that we announced.

     [[
  ============================
   1 + 1 = 2
   ]]
   *)

  reflexivity.
(* end thide *)
Qed.

(** printing exists $\exists$ *)

(** We can also use tactics to reason about existential hypotheses. *)

Theorem exist2 : forall n m : nat, (exists x : nat, n + x = m) -> n <= m.
(* begin thide *)
  (** We start by case analysis on the proof of the existential fact. *)

  destruct 1.
  (** [[
  n : nat
  m : nat
  x : nat
  H : n + x = m
  ============================
   n <= m

   ]]

   The goal has been replaced by a form where there is a new free variable [x], and where we have a new hypothesis that the body of the existential holds with [x] substituted for the old bound variable.  From here, the proof is just about arithmetic and is easy to automate. *)

  crush.
(* end thide *)
Qed.

(* begin hide *)
(* In-class exercises *)

Theorem forall_exists_commute : forall (A B : Type) (P : A -> B -> Prop),
  (exists x : A, forall y : B, P x y) -> (forall y : B, exists x : A, P x y).
(* begin thide *)
  intros.
  destruct H.
  exists x.
  apply H.
(* end thide *)
Admitted.

(* end hide *)

(** The tactic [intuition] has a first-order cousin called %\index{tactics!firstorder}%[firstorder], which proves many formulas when only first-order reasoning is needed, and it tries to perform first-order simplifications in any case.  First-order reasoning is much harder than propositional reasoning, so [firstorder] is much more likely than [intuition] to get stuck in a way that makes it run for long enough to be useless. *)

(** * Predicates with Implicit Equality *)

(** We start our exploration of a more complicated class of predicates with a simple example: an alternative way of characterizing when a natural number is zero. *)

Inductive isZero : nat -> Prop :=
| IsZero : isZero 0.

Theorem isZero_zero : isZero 0.
(* begin thide *)
  constructor.
(* end thide *)
Qed.

(** We can call [isZero] a%\index{judgment}% _judgment_, in the sense often used in the semantics of programming languages.  Judgments are typically defined in the style of%\index{natural deduction}% _natural deduction_, where we write a number of%\index{inference rules}% _inference rules_ with premises appearing above a solid line and a conclusion appearing below the line.  In this example, the sole constructor [IsZero] of [isZero] can be thought of as the single inference rule for deducing [isZero], with nothing above the line and [isZero 0] below it.  The proof of [isZero_zero] demonstrates how we can apply an inference rule.  (Readers not familiar with formal semantics should not worry about not following this paragraph!)

The definition of [isZero] differs in an important way from all of the other inductive definitions that we have seen in this and the previous chapter.  Instead of writing just [Set] or [Prop] after the colon, here we write [nat -> Prop].  We saw examples of parameterized types like [list], but there the parameters appeared with names _before_ the colon.  Every constructor of a parameterized inductive type must have a range type that uses the same parameter, whereas the form we use here enables us to choose different arguments to the type for different constructors.

For instance, our definition [isZero] makes the predicate provable only when the argument is [0].  We can see that the concept of equality is somehow implicit in the inductive definition mechanism.  The way this is accomplished is similar to the way that logic variables are used in %\index{Prolog}%Prolog (but worry not if not familiar with Prolog), and it is a very powerful mechanism that forms a foundation for formalizing all of mathematics.  In fact, though it is natural to think of inductive types as folding in the functionality of equality, in Coq, the true situation is reversed, with equality defined as just another inductive type!%\index{Gallina terms!eq}\index{Gallina terms!refl\_equal}% *)

Print eq.
(** %\vspace{-.15in}%[[
  Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
  ]]

  Behind the scenes, uses of infix [=] are expanded to instances of [eq].  We see that [eq] has both a parameter [x] that is fixed and an extra unnamed argument of the same type.  The type of [eq] allows us to state any equalities, even those that are provably false.  However, examining the type of equality's sole constructor [eq_refl], we see that we can only _prove_ equality when its two arguments are syntactically equal.  This definition turns out to capture all of the basic properties of equality, and the equality-manipulating tactics that we have seen so far, like [reflexivity] and [rewrite], are implemented treating [eq] as just another inductive type with a well-chosen definition.  Another way of stating that definition is: equality is defined as the least reflexive relation.

Returning to the example of [isZero], we can see how to work with hypotheses that use this predicate. *)

Theorem isZero_plus : forall n m : nat, isZero m -> n + m = n.
(* begin thide *)
  (** We want to proceed by cases on the proof of the assumption about [isZero]. *)

  destruct 1.
  (** [[
  n : nat
  ============================
   n + 0 = n

   ]]

   Since [isZero] has only one constructor, we are presented with only one subgoal.  The argument [m] to [isZero] is replaced with that type's argument from the single constructor [IsZero].  From this point, the proof is trivial. *)

  crush.
(* end thide *)
Qed.

(** Another example seems at first like it should admit an analogous proof, but in fact provides a demonstration of one of the most basic gotchas of Coq proving. *)

Theorem isZero_contra : isZero 1 -> False.
(* begin thide *)
  (** Let us try a proof by cases on the assumption, as in the last proof. *)

  destruct 1.
  (** [[
  ============================
   False

   ]]

   It seems that case analysis has not helped us much at all!  Our sole hypothesis disappears, leaving us, if anything, worse off than we were before.  What went wrong?  We have met an important restriction in tactics like [destruct] and [induction] when applied to types with arguments.  If the arguments are not already free variables, they will be replaced by new free variables internally before doing the case analysis or induction.  Since the argument [1] to [isZero] is replaced by a fresh variable, we lose the crucial fact that it is not equal to [0].

     Why does Coq use this restriction?  We will discuss the issue in detail in a future chapter, when we see the dependently typed programming techniques that would allow us to write this proof term manually.  For now, we just say that the algorithmic problem of "logically complete case analysis" is undecidable when phrased in Coq's logic.  A few tactics and design patterns that we will present in this chapter suffice in almost all cases.  For the current example, what we want is a tactic called %\index{tactics!inversion}%[inversion], which corresponds to the concept of inversion that is frequently used with natural deduction proof systems.  (Again, worry not if the semantics-oriented terminology from this last sentence is unfamiliar.) *)

  Undo.
  inversion 1.
(* end thide *)
Qed.

(** What does [inversion] do?  Think of it as a version of [destruct] that does its best to take advantage of the structure of arguments to inductive types.  In this case, [inversion] completed the proof immediately, because it was able to detect that we were using [isZero] with an impossible argument.

Sometimes using [destruct] when you should have used [inversion] can lead to confusing results.  To illustrate, consider an alternate proof attempt for the last theorem. *)

Theorem isZero_contra' : isZero 1 -> 2 + 2 = 5.
  destruct 1.
  (** [[
  ============================
   1 + 1 = 4

   ]]

   What on earth happened here?  Internally, [destruct] replaced [1] with a fresh variable, and, trying to be helpful, it also replaced the occurrence of [1] within the unary representation of each number in the goal.  Then, within the [O] case of the proof, we replace the fresh variable with [O].  This has the net effect of decrementing each of these numbers. *)

Abort.

(** To see more clearly what is happening, we can consider the type of [isZero]'s induction principle. *)

Check isZero_ind.
(** %\vspace{-.15in}% [[
isZero_ind
     : forall P : nat -> Prop, P 0 -> forall n : nat, isZero n -> P n
   ]]

   In our last proof script, [destruct] chose to instantiate [P] as [fun n => S n + S n = S (S (S (S n)))].  You can verify for yourself that this specialization of the principle applies to the goal and that the hypothesis [P 0] then matches the subgoal we saw generated.  If you are doing a proof and encounter a strange transmutation like this, there is a good chance that you should go back and replace a use of [destruct] with [inversion]. *)

(* begin hide *)
(* In-class exercises *)

(* EX: Define an inductive type capturing when a list has exactly two elements.  Prove that your predicate does not hold of the empty list, and prove that, whenever it holds of a list, the length of that list is two. *)

(* begin thide *)
Section twoEls.
  Variable A : Type.

  Inductive twoEls : list A -> Prop :=
  | TwoEls : forall x y, twoEls (x :: y :: nil).

  Theorem twoEls_nil : twoEls nil -> False.
    inversion 1.
  Qed.

  Theorem twoEls_two : forall ls, twoEls ls -> length ls = 2.
    inversion 1.
    reflexivity.
  Qed.
End twoEls.
(* end thide *)

(* end hide *)

(** * Recursive Predicates *)

(** We have already seen all of the ingredients we need to build interesting recursive predicates, like this predicate capturing even-ness. *)

Inductive even : nat -> Prop :=
| EvenO : even O
| EvenSS : forall n, even n -> even (S (S n)).

(** Think of [even] as another judgment defined by natural deduction rules.  The rule [EvenO] has nothing above the line and [even O] below the line, and [EvenSS] is a rule with [even n] above the line and [even (S (S n))] below.

The proof techniques of the last section are easily adapted. *)

Theorem even_0 : even 0.
(* begin thide *)
  constructor.
(* end thide *)
Qed.

Theorem even_4 : even 4.
(* begin thide *)
  constructor; constructor; constructor.
(* end thide *)
Qed.

(** It is not hard to see that sequences of constructor applications like the above can get tedious.  We can avoid them using Coq's hint facility, with a new [Hint] variant that asks to consider all constructors of an inductive type during proof search.  The tactic %\index{tactics!auto}%[auto] performs exhaustive proof search up to a fixed depth, considering only the proof steps we have registered as hints. *)

(* begin thide *)
Hint Constructors even.

Theorem even_4' : even 4.
  auto.
Qed.

(* end thide *)

(** We may also use [inversion] with [even]. *)

Theorem even_1_contra : even 1 -> False.
(* begin thide *)
  inversion 1.
(* end thide *)
Qed.

Theorem even_3_contra : even 3 -> False.
(* begin thide *)
  inversion 1.
  (** [[
  H : even 3
  n : nat
  H1 : even 1
  H0 : n = 1
  ============================
   False

   ]]

   The [inversion] tactic can be a little overzealous at times, as we can see here with the introduction of the unused variable [n] and an equality hypothesis about it.  For more complicated predicates, though, adding such assumptions is critical to dealing with the undecidability of general inversion.  More complex inductive definitions and theorems can cause [inversion] to generate equalities where neither side is a variable. *)

  inversion H1.
(* end thide *)
Qed.

(** We can also do inductive proofs about [even]. *)

Theorem even_plus : forall n m, even n -> even m -> even (n + m).
(* begin thide *)
  (** It seems a reasonable first choice to proceed by induction on [n]. *)

  induction n; crush.
  (** [[
  n : nat
  IHn : forall m : nat, even n -> even m -> even (n + m)
  m : nat
  H : even (S n)
  H0 : even m
  ============================
   even (S (n + m))

   ]]

   We will need to use the hypotheses [H] and [H0] somehow.  The most natural choice is to invert [H]. *)

  inversion H.
  (** [[
  n : nat
  IHn : forall m : nat, even n -> even m -> even (n + m)
  m : nat
  H : even (S n)
  H0 : even m
  n0 : nat
  H2 : even n0
  H1 : S n0 = n
  ============================
   even (S (S n0 + m))

   ]]

  Simplifying the conclusion brings us to a point where we can apply a constructor. *)

  simpl.
  (** [[
  ============================
   even (S (S (n0 + m)))
   ]]
   *)

  constructor.

(** [[
  ============================
   even (n0 + m)

   ]]

   At this point, we would like to apply the inductive hypothesis, which is:

   [[
  IHn : forall m : nat, even n -> even m -> even (n + m)

  ]]

  Unfortunately, the goal mentions [n0] where it would need to mention [n] to match [IHn].  We could keep looking for a way to finish this proof from here, but it turns out that we can make our lives much easier by changing our basic strategy.  Instead of inducting on the structure of [n], we should induct _on the structure of one of the [even] proofs_.  This technique is commonly called%\index{rule induction}% _rule induction_ in programming language semantics.  In the setting of Coq, we have already seen how predicates are defined using the same inductive type mechanism as datatypes, so the fundamental unity of rule induction with "normal" induction is apparent.

  Recall that tactics like [induction] and [destruct] may be passed numbers to refer to unnamed lefthand sides of implications in the conclusion, where the argument [n] refers to the [n]th such hypothesis. *)

Restart.

  induction 1.
(** [[
  m : nat
  ============================
   even m -> even (0 + m)
]]

%\noindent \coqdockw{subgoal} 2 \coqdockw{is}:%#<tt>subgoal 2 is</tt>#
[[
 even m -> even (S (S n) + m)

 ]]

 The first case is easily discharged by [crush], based on the hint we added earlier to try the constructors of [even]. *)

  crush.

  (** Now we focus on the second case: *)

  intro.
  (** [[
  m : nat
  n : nat
  H : even n
  IHeven : even m -> even (n + m)
  H0 : even m
  ============================
   even (S (S n) + m)

   ]]

   We simplify and apply a constructor, as in our last proof attempt. *)

  simpl; constructor.

(** [[
  ============================
   even (n + m)

   ]]

   Now we have an exact match with our inductive hypothesis, and the remainder of the proof is trivial. *)

  apply IHeven; assumption.

  (** In fact, [crush] can handle all of the details of the proof once we declare the induction strategy. *)

Restart.

  induction 1; crush.
(* end thide *)
Qed.

(** Induction on recursive predicates has similar pitfalls to those we encountered with inversion in the last section. *)

Theorem even_contra : forall n, even (S (n + n)) -> False.
(* begin thide *)
  induction 1.
  (** [[
  n : nat
  ============================
   False
]]

%\noindent \coqdockw{subgoal} 2 \coqdockw{is}:%#<tt>subgoal 2 is</tt>#
[[
 False

 ]]

 We are already sunk trying to prove the first subgoal, since the argument to [even] was replaced by a fresh variable internally.  This time, we find it easier to prove this theorem by way of a lemma.  Instead of trusting [induction] to replace expressions with fresh variables, we do it ourselves, explicitly adding the appropriate equalities as new assumptions. *)

Abort.

Lemma even_contra' : forall n', even n' -> forall n, n' = S (n + n) -> False.
  induction 1; crush.

  (** At this point, it is useful to consider all cases of [n] and [n0] being zero or nonzero.  Only one of these cases has any trickiness to it. *)

  destruct n; destruct n0; crush.

  (** [[
  n : nat
  H : even (S n)
  IHeven : forall n0 : nat, S n = S (n0 + n0) -> False
  n0 : nat
  H0 : S n = n0 + S n0
  ============================
   False

   ]]

  At this point it is useful to use a theorem from the standard library, which we also proved with a different name in the last chapter.  We can search for a theorem that allows us to rewrite terms of the form [x + S y]. *)

  SearchRewrite (_ + S _).
(** %\vspace{-.15in}%[[
  plus_n_Sm : forall n m : nat, S (n + m) = n + S m
     ]]
     *)

  rewrite <- plus_n_Sm in H0.

  (** The induction hypothesis lets us complete the proof, if we use a variant of [apply] that has a %\index{tactics!with}%[with] clause to give instantiations of quantified variables. *)

  apply IHeven with n0; assumption.

  (** As usual, we can rewrite the proof to avoid referencing any locally generated names, which makes our proof script more readable and more robust to changes in the theorem statement.  We use the notation [<-] to request a hint that does right-to-left rewriting, just like we can with the [rewrite] tactic. *)

  Restart.

  Hint Rewrite <- plus_n_Sm.

  induction 1; crush;
    match goal with
      | [ H : S ?N = ?N0 + ?N0 |- _ ] => destruct N; destruct N0
    end; crush.
Qed.

(** We write the proof in a way that avoids the use of local variable or hypothesis names, using the %\index{tactics!match}%[match] tactic form to do pattern-matching on the goal.  We use unification variables prefixed by question marks in the pattern, and we take advantage of the possibility to mention a unification variable twice in one pattern, to enforce equality between occurrences.  The hint to rewrite with [plus_n_Sm] in a particular direction saves us from having to figure out the right place to apply that theorem.

The original theorem now follows trivially from our lemma, using a new tactic %\index{tactics!eauto}%[eauto], a fancier version of [auto] whose explanation we postpone to Chapter 13. *)

Theorem even_contra : forall n, even (S (n + n)) -> False.
  intros; eapply even_contra'; eauto.
Qed.

(** We use a variant %\index{tactics!apply}%[eapply] of [apply] which has the same relationship to [apply] as [eauto] has to [auto].  An invocation of [apply] only succeeds if all arguments to the rule being used can be determined from the form of the goal, whereas [eapply] will introduce unification variables for undetermined arguments.  In this case, [eauto] is able to determine the right values for those unification variables, using (unsurprisingly) a variant of the classic algorithm for _unification_ %\cite{unification}%.

By considering an alternate attempt at proving the lemma, we can see another common pitfall of inductive proofs in Coq.  Imagine that we had tried to prove [even_contra'] with all of the [forall] quantifiers moved to the front of the lemma statement. *)

Lemma even_contra'' : forall n' n, even n' -> n' = S (n + n) -> False.
  induction 1; crush;
    match goal with
      | [ H : S ?N = ?N0 + ?N0 |- _ ] => destruct N; destruct N0
    end; crush.

  (** One subgoal remains:

     [[
  n : nat
  H : even (S (n + n))
  IHeven : S (n + n) = S (S (S (n + n))) -> False
  ============================
   False

   ]]

   We are out of luck here.  The inductive hypothesis is trivially true, since its assumption is false.  In the version of this proof that succeeded, [IHeven] had an explicit quantification over [n].  This is because the quantification of [n] _appeared after the thing we are inducting on_ in the theorem statement.  In general, quantified variables and hypotheses that appear before the induction object in the theorem statement stay fixed throughout the inductive proof.  Variables and hypotheses that are quantified after the induction object may be varied explicitly in uses of inductive hypotheses. *)

Abort.

(** Why should Coq implement [induction] this way?  One answer is that it avoids burdening this basic tactic with additional heuristic smarts, but that is not the whole picture.  Imagine that [induction] analyzed dependencies among variables and reordered quantifiers to preserve as much freedom as possible in later uses of inductive hypotheses.  This could make the inductive hypotheses more complex, which could in turn cause particular automation machinery to fail when it would have succeeded before.  In general, we want to avoid quantifiers in our proofs whenever we can, and that goal is furthered by the refactoring that the [induction] tactic forces us to do. *)
(* end thide *)

(* begin hide *)
(* In-class exercises *)

(* EX: Define a type [prop] of simple Boolean formulas made up only of truth, falsehood, binary conjunction, and binary disjunction.  Define an inductive predicate [holds] that captures when [prop]s are valid, and define a predicate [falseFree] that captures when a [prop] does not contain the "false" formula.  Prove that every false-free [prop] is valid. *)

(* begin thide *)
Inductive prop : Set :=
| Tru : prop
| Fals : prop
| And : prop -> prop -> prop
| Or : prop -> prop -> prop.

Inductive holds : prop -> Prop :=
| HTru : holds Tru
| HAnd : forall p1 p2, holds p1 -> holds p2 -> holds (And p1 p2)
| HOr1 : forall p1 p2, holds p1 -> holds (Or p1 p2)
| HOr2 : forall p1 p2, holds p2 -> holds (Or p1 p2).

Inductive falseFree : prop -> Prop :=
| FFTru : falseFree Tru
| FFAnd : forall p1 p2, falseFree p1 -> falseFree p2 -> falseFree (And p1 p2)
| FFNot : forall p1 p2, falseFree p1 -> falseFree p2 -> falseFree (Or p1 p2).

Hint Constructors holds.

Theorem falseFree_holds : forall p, falseFree p -> holds p.
  induction 1; crush.
Qed.
(* end thide *)

(* EX: Define an inductive type [prop'] that is the same as [prop] but omits the possibility for falsehood.  Define a proposition [holds'] for [prop'] that is analogous to [holds].  Define a function [propify] for translating [prop']s to [prop]s.  Prove that, for any [prop'] [p], if [propify p] is valid, then so is [p]. *)

(* begin thide *)
Inductive prop' : Set :=
| Tru' : prop'
| And' : prop' -> prop' -> prop'
| Or' : prop' -> prop' -> prop'.

Inductive holds' : prop' -> Prop :=
| HTru' : holds' Tru'
| HAnd' : forall p1 p2, holds' p1 -> holds' p2 -> holds' (And' p1 p2)
| HOr1' : forall p1 p2, holds' p1 -> holds' (Or' p1 p2)
| HOr2' : forall p1 p2, holds' p2 -> holds' (Or' p1 p2).

Fixpoint propify (p : prop') : prop :=
  match p with
    | Tru' => Tru
    | And' p1 p2 => And (propify p1) (propify p2)
    | Or' p1 p2 => Or (propify p1) (propify p2)
  end.

Hint Constructors holds'.

Lemma propify_holds' : forall p', holds p' -> forall p, p' = propify p -> holds' p.
  induction 1; crush; destruct p; crush.
Qed.

Theorem propify_holds : forall p, holds (propify p) -> holds' p.
  intros; eapply propify_holds'; eauto.
Qed.
(* end thide *)

(* end hide *)


Require Setoid.
Require Import Morphisms.

(* Sets, a la Aczel *)
Inductive V : Type := V_const : forall {X : Type}, (X -> V) -> V.

(* Set membership *)
Inductive V_rel : V -> V -> Prop :=
 V_rel_def : forall {X : Type} (f : X -> V) (x : X), V_rel (f x) (V_const f).

Notation "x 'ε' y" := (V_rel x y) (at level 70).

Lemma V_rel_inv : forall X (f : X -> V) (P : V -> Prop),
  (forall x, P (f x)) -> forall y, V_rel y (V_const f) -> P y.
Proof.
 intros X f P H y H0.
 (* "inversion H0" can't quite handle the dependent types, so we
    roll our own inversion. *)
 revert H.
 refine (match H0 in (V_rel a b) return
           (match b return Prop with
            | V_const X' f' => (forall x:X', P (f' x)) -> P a
            end) with
         | V_rel_def X' f' _ => _
         end). trivial.
Qed.

Lemma wf_V_rel : well_founded V_rel.
Proof.
intros x; induction x as [X Xf].
constructor; intros [Y Yf]; apply V_rel_inv; assumption.
Qed.

CoInductive V_eq (x : V) (y : V) : Prop := {
  V_eq_l : forall xs, V_rel xs x -> exists ys, V_rel ys y /\ V_eq xs ys;
  V_eq_r : forall ys, V_rel ys y -> exists xs, V_rel xs x /\ V_eq xs ys
}.

Notation "x ≅ y" := (V_eq x y) (at level 70).

Instance V_eq_refl : Reflexive V_eq.
Proof.
cofix; intros [X Xf]; constructor; intros xs Hxs; exists xs; auto.
Qed.

Instance V_eq_sym : Symmetric V_eq.
Proof.
cofix; intros [X Xf] [Y Yf] [Hl Hr]; split.
  intros ys Hys; destruct (Hr ys Hys) as [xs Hxs]; exists xs; intuition.
  intros ys Hys; destruct (Hl ys Hys) as [xs Hxs]; exists xs; intuition.
Qed.

Instance V_eq_trans : Transitive V_eq.
Proof.
cofix IH; intros [X Xf] [Y Yf] [Z Zf] [H1l H1r] [H2l H2r]; split.
  { intros xs Hxs.
    destruct (H1l xs Hxs) as [ys [Hys Heql]].
    destruct (H2l ys Hys) as [zs [Hzs Heqr]].
    exists zs; split; [assumption|eapply IH; eassumption].
  }
  { intros xs Hxs.
    destruct (H2r xs Hxs) as [ys [Hys Heql]].
    destruct (H1r ys Hys) as [zs [Hzs Heqr]].
    exists zs; split; [assumption|eapply IH; eassumption].
  }
Qed.

Instance Equivalence_V_eq : Equivalence V_eq.
Proof.
split; auto with typeclass_instances.
Qed.

Record mem (x y : V) : Prop := {
  mem_set : V;
  mem_set_eq : mem_set ≅ x;
  mem_spec : V_rel mem_set y
}.

Notation "x ∈ y" := (mem x y) (at level 70).

Instance Proper_mem : Proper (V_eq ==> V_eq ==> iff) mem.
Proof.
apply proper_sym_impl_iff_2; try apply V_eq_sym.
intros x1 x2 Hx y1 y2 Hy [x3 Heq Hr].
destruct Hy as [Hyl Hyr]; specialize (Hyl _ Hr).
destruct Hyl as [x4 [Hi4 Hx4]].
exists x4; [|assumption].
symmetry; transitivity x3; [|assumption].
symmetry; transitivity x1; assumption.
Qed.

Lemma subrelation_mem_rel : subrelation V_rel mem.
Proof.
intros x y H; exists x; [reflexivity|assumption].
Qed.

Lemma wf_mem : well_founded mem.
Proof.
intros x; constructor; intros y H.
destruct H as [z Heq H]; apply (wf_V_rel) in H; clear x.
revert y Heq; induction H as [x H IH]; intros y Hy.
constructor; intros z [s Heq Hs].
destruct Hy as [_ Hy]; specialize (Hy _ Hs); destruct Hy as [u [? Hu]].
apply (IH u); [assumption|].
transitivity s; assumption.
Qed.

Definition included x y := forall e, e ε x -> e ∈ y.

Notation "x ⊆ y" := (included x y) (at level 70).

Definition extensional (f : V -> V) := Proper (V_eq ==> V_eq) f.

Lemma extensionality : forall x y, x ⊆ y -> y ⊆ x -> x ≅ y.
Proof.
cofix IH; intros x y Hl Hr; split.
  + intros xs Hx; specialize (Hl _ Hx); destruct Hl as [x' Heq Hin]; exists x'.
    split; [assumption|symmetry; assumption].
  + intros ys Hy; specialize (Hr _ Hy); destruct Hr as [y' Heq Hin]; exists y'.
    split; assumption.
Qed.

Lemma mem_included_compat : forall x y z, x ∈ y -> y ⊆ z -> x ∈ z.
Proof.
intros x y z [x' Heq H] Hi.
specialize (Hi _ H).
rewrite <- Heq; assumption.
Qed.

Lemma included_spec : forall x y, (x ⊆ y) <-> (forall z, z ∈ x -> z ∈ y).
Proof.
intros x y; split; intros H.
+ intros z Hz; eapply mem_included_compat; eassumption.
+ intros z Hz; apply subrelation_mem_rel in Hz; intuition.
Qed.

Instance Proper_included : Proper (V_eq ==> V_eq ==> iff) included.
Proof.
apply proper_sym_impl_iff_2; try apply V_eq_sym.
intros x1 x2 Hx y1 y2 Hy Hs z Hz.
rewrite <- Hy; eapply mem_included_compat; [|eassumption].
rewrite Hx; apply subrelation_mem_rel; assumption.
Qed.

Instance Transitive_included : Transitive included.
Proof.
intros x y z Hl Hr.
apply included_spec; intros a Ha.
apply (mem_included_compat _ y); [|assumption].
eapply (mem_included_compat); eassumption.
Qed.

Definition empty : V := V_const (fun f => False_rect _ f).
Definition singleton (x : V) := V_const (fun u => unit_rect _ x u).

Definition comprehension (x : V) (P : V -> Prop) : V.
Proof.
destruct x as [X Xf].
exists {x : X | P (Xf x)}.
intros [x _]; apply (Xf x).
Defined.

Definition powerset (x : V) : V.
Proof.
destruct x as [X Xf].
exists (X -> Prop); intros f.
exists {x : X | f x}.
exact (fun e => Xf (proj1_sig e)).
Defined.

Definition collection (x : V) (f : V -> V) : V.
Proof.
destruct x as [X Xf].
exists X; intros x; apply (f (Xf x)).
Defined.

Definition union (x : V) : V.
Proof.
destruct x as [X Xf].
exists {x : _ & match Xf x with V_const Y _ => Y end}.
intros [x y].
destruct (Xf x) as [Y Yf].
exact (Yf y).
Defined.

Definition pair (x y : V) : V :=
  @V_const bool (fun b => if b then x else y).

Lemma empty_spec : forall x : V, ~ x ∈ empty.
Proof.
intros x [z Heq H].
inversion H using V_rel_inv; tauto.
Qed.

Lemma singleton_spec : forall x y, x ∈ singleton y <-> x ≅ y.
Proof.
intros x y; split; intros H.
  + destruct H as [z Heq H].
    revert Heq; inversion H using V_rel_inv; intros []; simpl; symmetry; assumption.
  + exists y; [symmetry; assumption|].
    change y with (unit_rect (fun _ => V) y tt) at 1; now constructor.
Qed.

Lemma comprehension_spec : forall x y P, Proper (V_eq ==> iff) P ->
    y ∈ comprehension x P <-> (y ∈ x /\ P y).
Proof.
intros x y P HP; split; intros H.
  + destruct H as [z Heq H]; rewrite <- Heq; clear y Heq.
    destruct x as [X Xf]; inversion H using V_rel_inv; clear z H.
    intros [x Hx]; split; [apply subrelation_mem_rel; constructor|assumption].
  + destruct H as [[z Heq H] Hr]; exists z; [assumption|].
    assert (Hz : P z) by (rewrite Heq; assumption); clear y Heq Hr.
    destruct x as [X Xf]; revert Hz; inversion H using V_rel_inv; clear z H; intros z Hz.
    pose (p := exist (fun z => P (Xf z)) z Hz).
    change (Xf z) with ((fun p : {_ | _} => let (x, _) := p in Xf x) p).
    now constructor.
Qed.

Lemma collection_spec : forall x y f, extensional f ->
  y ∈ collection x f <-> (exists z, z ∈ x /\ y ≅ f z).
Proof.
intros x y f Hf; split.
  + intros [z Heq H]; revert Heq; destruct x as [X Xf].
    inversion H using V_rel_inv; clear z H; intros z H.
    exists (Xf z); split.
    - apply subrelation_mem_rel; constructor.
    - symmetry; assumption.
  + intros [z [[z' Heq' H] Heq]]; exists (f z').
    - rewrite Heq; apply Hf; assumption.
    - destruct x as [X Xf]; inversion H using V_rel_inv.
      clear; intros x; change (f (Xf x)) with ((fun x => f (Xf x)) x).
      now constructor.
Qed.

Lemma powerset_spec : forall x y, x ∈ powerset y <-> x ⊆ y.
Proof.
intros x y; split.
  + intros [z Heq H]; revert Heq; destruct y as [Y Yf].
    inversion H using V_rel_inv; clear z H; intros f Heq z Hz.
    destruct Heq as [_ Heq]; specialize (Heq _ Hz); destruct Heq as [zs [Hzl Hzr]].
    exists zs; [assumption|].
    clear - Hzl; inversion Hzl using V_rel_inv; clear.
    intros [x Hx]; simpl; constructor.
  + intros Hsub; destruct y as [Y Yf].
    pose (z := @V_const {y : Y | Yf y ∈ x} (fun y => Yf (proj1_sig y))); exists z.
    - apply extensionality.
      { intros s Hs; inversion Hs using V_rel_inv; clear s Hs; intros [? ?]; assumption. }
      {
        assert (Hrw : z ≅ x). {
          apply extensionality.
          + intros y Hy; inversion Hy using V_rel_inv; clear; intros [? ?]; assumption.
          + intros y Hy; specialize (Hsub _ Hy); destruct Hsub as [s Heq H].
            revert Hy Heq; inversion H using V_rel_inv; clear s H; intros s H Heq.
            exists (Yf s); [assumption|].
            assert (Hin : Yf s ∈ x) by (rewrite Heq; apply subrelation_mem_rel; assumption).
            pose (p := exist (fun y => Yf y ∈ x) s Hin).
            change (Yf s) with ((fun p => Yf (proj1_sig p)) p); constructor.
        }
        intros s Hs; rewrite Hrw; apply subrelation_mem_rel; assumption.
      }
    - change z with ((fun P => @V_const {y : Y | P y} (fun y => Yf (proj1_sig y))) (fun y => Yf y ∈ x)).
      now constructor.
Qed.

Lemma union_spec : forall x y, x ∈ union y <-> exists z, x ∈ z /\ z ∈ y.
Proof.
intros x y; split.
  + intros [z Heq H]; destruct y as [Y Yf].
    revert Heq; inversion H using V_rel_inv; clear z H.
    intros [y z]; remember (Yf y) as s; destruct s as [Z Zf]; simpl.
    intros Hrw; exists (V_const Zf); split.
    - exists (Zf z); [assumption|constructor].
    - exists (Yf y); [match goal with [ H : _ = Yf y |- _ ] => rewrite H end; reflexivity|constructor].
  + intros [z [Hzl Hzr]]; destruct Hzl as [l Heql Hl]; destruct Hzr as [r Heqr Hr].
    rewrite <- Heql; clear x Heql.
    destruct z as [Z Zf]; destruct y as [Y Yf].
    inversion Hl using V_rel_inv; clear l Hl; intros l.
    revert Heqr; inversion Hr using V_rel_inv; clear r Hr; intros r Heqr.
    destruct Heqr as [_ Heqr]; specialize (Heqr _ (V_rel_def Zf l)).
    destruct Heqr as [z [Hzl Hzr]]; exists z; [assumption|].
    clear Z Zf l Hzr; unfold union; match goal with [ |- ?t ε V_const ?f ] => set (F := f) end.
    assert (Hf : exists p, z = F p). {
      remember (Yf r) as m; destruct m as [M Mf].
      inversion Hzl using V_rel_inv; clear z Hzl; intros z.
      pose (cz := match Heqm in _ = u return match u with V_const Z _ => Z end with eq_refl => z end).
      pose (p := existT (fun y => match Yf y with V_const Z _ => Z end) r cz).
      exists p; simpl; clear; destruct Heqm; reflexivity.
    }
    destruct Hf as [p Hrw]; rewrite Hrw; constructor.
Qed.

Lemma pair_spec : forall x y z, z ∈ pair x y <-> z ≅ x \/ z ≅ y.
Proof.
intros [X Xf] [Y Yf] z; split.
  + intros [m Heq H]; rewrite <- Heq; clear z Heq.
    inversion H using V_rel_inv; clear m H; intros [|].
    - left; reflexivity.
    - right; reflexivity.
  + intros [H|H]; rewrite H; apply subrelation_mem_rel.
    - change (V_const Xf) with ((fun b : bool => (if b then V_const Xf else V_const Yf)) true); constructor.
    - change (V_const Yf) with ((fun b : bool => (if b then V_const Xf else V_const Yf)) false); constructor.
Qed.

Instance Proper_singleton : Proper (V_eq ==> V_eq) singleton.
Proof.
intros x1 x2 Hx; apply extensionality; intros z Hz; apply subrelation_mem_rel in Hz.
+ apply singleton_spec; apply singleton_spec in Hz; rewrite Hx in *; assumption.
+ apply singleton_spec; apply singleton_spec in Hz; rewrite Hx in *; assumption.
Qed.

Instance Proper_pair : Proper (V_eq ==> V_eq ==> V_eq) pair.
Proof.
intros x1 x2 Hx y1 y2 Hy; apply extensionality; intros z Hz; apply subrelation_mem_rel in Hz.
+ apply pair_spec; apply pair_spec in Hz; rewrite Hx, Hy in *; tauto.
+ apply pair_spec; apply pair_spec in Hz; rewrite Hx, Hy in *; tauto.
Qed.

Instance Proper_comprehension :
  Proper (V_eq ==> respectful V_eq iff ==> V_eq) comprehension.
Proof.
intros x1 x2 Hx P1 P2 HP.
assert (HP1 : Proper (V_eq ==> iff) P1).
{ clear - HP; intros x1 x2 Hx; rewrite (HP x1 x2 Hx); symmetry; apply HP; reflexivity. }
assert (HP2 : Proper (V_eq ==> iff) P2).
{ clear - HP; intros x1 x2 Hx; symmetry; rewrite <- (HP x1 x2 Hx); apply HP; reflexivity. }
apply extensionality; apply included_spec; intros z Hz.
+ apply comprehension_spec; [assumption|]; apply comprehension_spec in Hz; [|assumption].
  destruct Hz as [Hzl Hzr]; rewrite <- Hx; split; [assumption|].
  apply (HP z z); [reflexivity|assumption].
+ apply comprehension_spec; [assumption|]; apply comprehension_spec in Hz; [|assumption].
  destruct Hz as [Hzl Hzr]; rewrite Hx; split; [assumption|].
  apply <- (HP z z); [assumption|reflexivity].
Qed.

Instance Proper_collection :
  Proper (V_eq ==> respectful V_eq V_eq ==> V_eq) collection.
Proof.
intros x1 x2 Hx f1 f2 Hf.
assert (Hf1 : extensional f1).
{ clear - Hf; intros x1 x2 Hx; rewrite (Hf x1 x2 Hx); symmetry; apply Hf; reflexivity. }
assert (Hf2 : extensional f2).
{ clear - Hf; intros x1 x2 Hx; symmetry; rewrite <- (Hf x1 x2 Hx); apply Hf; reflexivity. }
apply extensionality; apply included_spec; intros z Hz.
+ apply collection_spec; [assumption|]; apply collection_spec in Hz; [|assumption].
  destruct Hz as [r [Hr Hz]]; exists r; rewrite <- Hx; split; [assumption|].
  rewrite Hz; apply Hf; reflexivity.
+ apply collection_spec; [assumption|]; apply collection_spec in Hz; [|assumption].
  destruct Hz as [r [Hr Hz]]; exists r; rewrite Hx; split; [assumption|].
  rewrite Hz; symmetry; apply Hf; reflexivity.
Qed.

Instance Proper_union : Proper (V_eq ==> V_eq) union.
Proof.
intros x1 x2 Hx.
apply extensionality; apply included_spec; intros z Hz; apply union_spec in Hz;
destruct Hz as [r [Hz Hr]]; apply union_spec; exists r; split;
solve [assumption|rewrite <- Hx; assumption|rewrite Hx; assumption].
Qed.

Instance Proper_powerset : Proper (V_eq ==> V_eq) powerset.
Proof.
intros x1 x2 Hx.
apply extensionality; apply included_spec; intros z Hz; apply powerset_spec in Hz;
apply powerset_spec; first [rewrite Hx|rewrite <- Hx]; assumption.
Qed.