Notation "( x & y )" := (@existS _ _ x y) : core_scope.
Unset Printing All.
Require Import Coq.Arith.Compare_dec.

Require Import Coq.subtac.Utils.

Ltac one_simpl_hyp :=
 match goal with
 | [H : (`exist _ _ _) = _ |- _] => simpl in H
 | [H : _ = (`exist _ _ _) |- _] => simpl in H
 | [H : (`exist _ _ _) < _ |- _] => simpl in H
 | [H : _ < (`exist _ _ _) |- _] => simpl in H
 | [H : (`exist _ _ _) <= _ |- _] => simpl in H
 | [H : _ <= (`exist _ _ _) |- _] => simpl in H
 | [H : (`exist _ _ _) > _ |- _] => simpl in H
 | [H : _ > (`exist _ _ _) |- _] => simpl in H
 | [H : (`exist _ _ _) >= _ |- _] => simpl in H
 | [H : _ >= (`exist _ _ _) |- _] => simpl in H
 end.

Ltac one_simpl_subtac :=
  destruct_exists ;
  repeat one_simpl_hyp ; simpl.

Ltac simpl_subtac :=  do 3 one_simpl_subtac ; simpl.

Require Import Omega.
Require Import Wf_nat.

Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt}  :
  { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
  if le_lt_dec b a then let (q', r) := euclid (a - b) b in
  (S q' & r)
  else (O & a).
destruct b ; simpl_subtac.
omega.
simpl_subtac.
assert(x0 * S q' = x0 + x0 * q').
rewrite <- mult_n_Sm.
omega.
rewrite H2 ; omega.
simpl_subtac.
split ; auto with arith.
omega.
apply lt_wf.
Defined.

Check euclid_evars_proof.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
Set Implicit Arguments.

Require Import Bvector.
Require Import List.
Require Import Arith.

Definition Blist := list bool.

Fixpoint splitVector(A : Set)(n m : nat) : Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
    | 0 =>
      fun (v : Vector.t A (O + m)) => (@Vector.nil A, v)
    | S n' =>
      fun (v : Vector.t A (S n' + m)) =>
        let (v1, v2) := splitVector _ _ (Vector.tl v) in
          (Vector.cons _ (Vector.hd v) _ v1, v2)
  end.

Section HMAC.

  Variable c p : nat.
  Definition b := c + p.

  (* The compression function *)
  Variable h : Bvector c -> Bvector b -> Bvector c.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Bvector c.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : list (Bvector b)) :=
    fold_left h m k.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  Variable Message : Set.
  Variable splitAndPad : Message -> list (Bvector b).
  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  Variable fpad : Bvector c -> Bvector p.
  Definition app_fpad (x : Bvector c) : Bvector b :=
    (Vector.append x (fpad x)).

  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitVector c c k in
    h k_Out (app_fpad (h_star k_In m)).

  (* The "two-key" version of GHMAC and HMAC. *)
  Definition GHMAC_2K (k : Bvector (b + b)) m :=
    let (k_Out, k_In) := splitVector b b k in
      let h_in := (hash_words (k_In :: m)) in
        hash_words (k_Out :: (app_fpad h_in) :: nil).

  Definition HMAC_2K (k : Bvector (b + b)) (m : Message) :=
    GHMAC_2K k (splitAndPad m).

  (* opad and ipad are constants defined in the HMAC spec. *)
  Variable opad ipad : Bvector b.
  Hypothesis opad_ne_ipad : opad <> ipad.

  Definition GHMAC (k : Bvector b) :=
    GHMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

  Definition HMAC (k : Bvector b) :=
    HMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

End HMAC.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype fintype seq fingroup perm.

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

(** Each house is represented as a number, starting with 0 on the left.  The
    [Ordinal] constructor is used to represent natural numbers bounded by 5; the
    corresponding type is noted ['I_5]. *)

Definition o0 : 'I_5 := @Ordinal 5 0 erefl.
Definition o1 : 'I_5 := @Ordinal 5 1 erefl.
Definition o2 : 'I_5 := @Ordinal 5 2 erefl.
Definition o3 : 'I_5 := @Ordinal 5 3 erefl.
Definition o4 : 'I_5 := @Ordinal 5 4 erefl.

Lemma aux : enum 'I_5 = [:: o0; o1; o2; o3; o4].
Proof. by apply: (inj_map val_inj); rewrite val_enum_ord. Qed.

(** We represent each property of the house as a number on the same range. *)

(* Colors *)
Definition Red := o0.
Definition White := o1.
Definition Green := o2.
Definition Blue := o3.
Definition Yellow := o4.

(* Countries *)
Definition Britain := o0.
Definition Sweden := o1.
Definition Denmark := o2.
Definition Germany := o3.
Definition Norway := o4.

(* Beverages *)
Definition Tea := o0.
Definition Coffee := o1.
Definition Milk := o2.
Definition Beer := o3.
Definition Water := o4.

(* Cigars *)
Definition PallMall := o0.
Definition Dunhill := o1.
Definition Blends := o2.
Definition BlueMaster:= o3.
Definition Prince := o4.

(* Pets *)
Definition Fish := o0.
Definition Dogs := o1.
Definition Birds := o2.
Definition Cats := o3.
Definition Horses := o4.

Section Puzzle.

(** ['S_5] is the type of permutations of the type ['I_5].  Each one of the
    variables below is used to map an attribute to the corresponding house
    number; e.g. [country Britain] represents the house number where the British
    lives, [color Green] represents the number of the green house, etc.  Since
    these are permutations, we guarantee that each house number corresponds to
    one unique attribute of each kind.  *)

Variables color country beverage cigar pet : 'S_5.

(** The following predicate states that two houses are next to each other.
    Here, [val] denotes the conversion function from ['I_5] into [nat]. *)
Definition next_to (n1 n2 : 'I_5) :=
  (val n1 == (val n2).+1) || (val n2 == (val n1).+1).

(** The constraints of the problem translated as Coq hypothesis.  Note that:

    - [h3] states that the green house is to the left of the white house;

    - [h8] means that the owner of the middle house drinks milk, and

    - [h9] states that the Norwegian man owns the first (left-most) house. *)

Hypothesis h1 : country Britain = color Red.
Hypothesis h2 : country Sweden = pet Dogs.
Hypothesis h3 : country Denmark = beverage Tea.
Hypothesis h4 : color White = (color Green).+1 :> nat.
Hypothesis h5 : color Green = beverage Coffee.
Hypothesis h6 : cigar PallMall = pet Birds.
Hypothesis h7 : color Yellow = cigar Dunhill.
Hypothesis h8 : beverage Milk = o2.
Hypothesis h9 : country Norway = o0.
Hypothesis h10 : next_to (cigar Blends) (pet Cats).
Hypothesis h11 : next_to (pet Horses) (cigar Dunhill).
Hypothesis h12 : cigar BlueMaster = beverage Beer.
Hypothesis h13 : country Germany = cigar Prince.
Hypothesis h14 : next_to (country Norway) (color Blue).
Hypothesis h15 : next_to (cigar Blends) (beverage Water).

Open Scope group_scope.

(** Using these hypotheses, we can prove a series of lemmas describing the
    properties of each house.  Most of them follow by excluding all the other
    possibilities; e.g., in [f2], we conclude that the first house is yellow by
    arguing that it cannot be red, white, green or blue. Similarly for [f4],
    [f6], [f7], [f8], [f10] and [f12].

    [f1], [f3], [f5] and [f14] do the same thing, but using the [next_to]
    hypotheses to reduce the number of cases to rule out from 4 to 1.

    [f11], [f13] and [f15] reason by exclusion in a slightly different way; e.g,
    [f11] says that since the Norwegian lives in [o0], the Dane lives in [o1],
    the Brit lives in [o2] and the Swede lives in [o4], only the German can live
    in [o3].

    [f15] is the solution of the puzzle.*)

Fact f1 : color Blue = o1.
Proof.
by move: h14; rewrite h9 /next_to /= => /eqP e; apply: val_inj.
Qed.

Fact f2 : color Yellow = o0.
Proof.
have : color^-1 o0 \in enum 'I_5 by rewrite mem_enum.
rewrite aux -[[:: o0; o1; o2; o3; o4]]/([:: Red; White; Green; Blue; Yellow]) !inE.
rewrite !(canF_eq (@permKV _ _)).
rewrite -{1}h9 -h1 (inj_eq (@perm_inj _ _)) /=.
rewrite -(inj_eq val_inj o0) /= h4 /=.
case: (o0 =P color Green) => [e _|_] /=.
  suff: color White = o1 by rewrite -f1=> /perm_inj.
  by apply/val_inj; rewrite /= h4 -e.
by rewrite f1 /= => /eqP <-.
Qed.

Fact f3 : pet Horses = o1.
Proof.
apply/val_inj; move: h11; rewrite -h7 f2 /next_to /= orbF.
by move/eqP.
Qed.

Fact f4 : beverage Water = o0.
Proof.
have : beverage^-1 o0 \in enum 'I_5 by rewrite mem_enum.
rewrite aux -[[:: o0; o1; o2; o3; o4]]/([:: Tea; Coffee; Milk; Beer; Water]) !inE.
rewrite !(canF_eq (@permKV _ _)).
rewrite -h3 -{1}h9 (inj_eq (@perm_inj _ _)) /=.
rewrite -h5 -{1}f2 (inj_eq (@perm_inj _ _)) /=.
rewrite h8 /=.
rewrite -h12 -{1}f2 h7 (inj_eq (@perm_inj _ _)) /=.
by move/eqP=> ->.
Qed.

Fact f5 : cigar Blends = o1.
Proof.
apply/val_inj; move: h15; rewrite f4 /next_to /= orbF.
by move/eqP.
Qed.

Fact f6 : beverage Tea = o1.
Proof.
have : beverage^-1 o1 \in enum 'I_5 by rewrite mem_enum.
rewrite aux -[[:: o0; o1; o2; o3; o4]]/([:: Tea; Coffee; Milk; Beer; Water]) !inE.
rewrite !(canF_eq (@permKV _ _)).
rewrite f4 -h12 -{4}f5 (inj_eq (@perm_inj _ _)) h8 -h5 -{2}f1 (inj_eq (@perm_inj _ _)).
by rewrite !orbF => /eqP ->.
Qed.

Fact f7 : beverage Beer = o4.
Proof.
have : beverage^-1 o4 \in enum 'I_5 by rewrite mem_enum.
rewrite aux -[[:: o0; o1; o2; o3; o4]]/([:: Tea; Coffee; Milk; Beer; Water]) !inE.
rewrite !(canF_eq (@permKV _ _)).
rewrite f4 orbF /= f6 h8 /=.
case/orP=> [/eqP e|/eqP -> //].
move: h4; rewrite h5 -{}e => e.
by move: (valP (color White)); rewrite /= e.
Qed.

Fact f8 : beverage Coffee = o3.
Proof.
have : beverage^-1 o3 \in enum 'I_5 by rewrite mem_enum.
rewrite aux -[[:: o0; o1; o2; o3; o4]]/([:: Tea; Coffee; Milk; Beer; Water]) !inE.
by rewrite !(canF_eq (@permKV _ _)) f4 h8 f6 f7 !orbF /= => /eqP ->.
Qed.

Fact f9 : color White = o4.
Proof. by apply/val_inj=> /=; rewrite h4 h5 f8. Qed.

Fact f10 : color Red = o2.
Proof.
have : color^-1 o2 \in enum 'I_5 by rewrite mem_enum.
rewrite aux -[[:: o0; o1; o2; o3; o4]]/([:: Red; White; Green; Blue; Yellow]) !inE.
by rewrite !(canF_eq (@permKV _ _)) f2 h5 f8 f9 f1 !orbF => /eqP ->.
Qed.

Fact f11 : country Germany = o3.
Proof.
have : country Germany \in enum 'I_5 by rewrite mem_enum.
rewrite aux !inE -h9 (inj_eq (@perm_inj _ _)) /=.
rewrite -f6 -h3 (inj_eq (@perm_inj _ _)) /=.
rewrite -f10 -h1 (inj_eq (@perm_inj _ _)) /=.
by rewrite {2}h13 -f7 -h12 (inj_eq (@perm_inj _ _)) orbF => /eqP ->.
Qed.

Fact f12 : country Sweden = o4.
Proof.
have : country^-1 o4 \in enum 'I_5 by rewrite mem_enum.
rewrite aux -[[:: o0; o1; o2; o3; o4]]/([:: Britain; Sweden; Denmark; Germany; Norway]) !inE.
by rewrite !(canF_eq (@permKV _ _)) h1 f10 h3 f6 f11 h9 !orbF /= => /eqP ->.
Qed.

Fact f13 : cigar PallMall = o2.
have : cigar PallMall \in enum 'I_5 by rewrite mem_enum.
rewrite aux !inE -f2 h7 -f5 -f11 -f7 -h12 h13 !(inj_eq (@perm_inj _ _)) !orbF /=.
by move/eqP=> ->.
Qed.

Fact f14 : pet Cats = o0.
Proof.
apply/val_inj; move: h10; rewrite /next_to f5 /=.
case/orP=> [/eqP [<-]//|].
by rewrite (inj_eq val_inj (pet Cats) o2) -f13 h6 (inj_eq (@perm_inj _ _)).
Qed.

Fact f15 : pet Fish = o3.
Proof.
have : pet Fish \in enum 'I_5 by rewrite mem_enum.
rewrite aux !inE -f14 -f3 -f13 h6 -f12 h2 !(inj_eq (@perm_inj _ _)) orbF /=.
by move/eqP=> ->.
Qed.

End Puzzle.


Require Import Coq.Lists.List.
Require Import Coq.Unicode.Utf8.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ClassicalFacts.

Section Topology.
Axiom EquivThenEqual: prop_extensionality.
Definition set{N:Type}:Type := N -> Prop.
Definition elem_set {N:Type} (n:N) (s:set):= s n.
Definition subset_set {N:Type}(s s':@set N):= forall k, s k -> s' k.
Definition equals_set {N:Type} (s s':@set N):= subset_set s s' /\ subset_set s' s.
Definition closed_containment {N:Type} (s:@set(@set N)) :=
    forall s', elem_set s' s → forall s'', subset_set s'' s' → elem_set s'' s.
Definition uni_covering {N:Type} (s:@set N) (s': @set (@set N)) :=
    forall n, elem_set n s → ∃ singleton, elem_set singleton s' /\
    forall n', singleton n' <-> n'=n.

Record complex{N:Type} := {
    V: @set N;
    C: @set (@set N);
    C_built_from_V: forall s, elem_set s C→ forall v, elem_set v s→ elem_set v V;
    prop1: closed_containment C;
    prop2: uni_covering V C
}.

Record simplicial_map{A B:Type} {from:@complex A} {to:@complex B}:={
    func: A->B;
    prop: forall s, elem_set s from.(C) → ∃ s', elem_set s' to.(C)/\
    (forall a, elem_set a s -> elem_set ( func a) s') /\
    (forall a', elem_set a' s'-> exists a, elem_set a s /\ a' = func a)
}.
Program Definition self_identity {N:Type} (c:@complex N):simplicial_map:= {|
    func:= λ n:N, n
|}.
Next Obligation. exists s. split; auto. split; eauto.
Qed.

Definition isomorphic_complex{A B:Type} (c:@complex A) (c':@complex B) :=
    ∃ (f:@simplicial_map A B c c') (g:@simplicial_map B A c' c),
    forall a, elem_set a c.(V) → g.(func) (f.(func) a) = a /\
    forall b, elem_set b c'.(V) → f.(func) (g.(func) b) = b.

Theorem complex_isomorphic_with_itself: forall (N:Type) (c:@complex N), isomorphic_complex c c.
Proof.
    intros.
    exists (self_identity c), (self_identity c).
    intros.
    split; reflexivity.
Qed.

Program Definition simplicial_map_transitive {A1 A2 A3:Type}
{C1:@complex A1} {C2:@complex A2} {C3:@complex A3}
(m1: @simplicial_map A1 A2 C1 C2) (m2: @simplicial_map A2 A3 C2 C3): @simplicial_map A1 A3 C1 C3:=
{|
    func:= λ a, m2.(func) (m1.(func) a)
|}.
Next Obligation.
exists (λ x, ∃ a, elem_set a s /\ x = m2.(func) (m1.(func) a)).
split;destruct m1, m2,C1,C2,C3; simpl in *.
apply prop0 in H as H1. destruct H1. destruct H0.
apply prop3 in H0 as H2. destruct H2. destruct H2.
assert (x0 = (λ x1 : A3, ∃ a : A1, elem_set a s ∧ x1 = func1 (func0 a))).
apply functional_extensionality_dep; intros.
unfold elem_set in *.
destruct H1, H3.
apply EquivThenEqual. split; intros.
apply H5 in H6 as H7.
destruct H7, H7.
 apply H4 in H7 as H9.
 destruct H9, H9.
 exists x3; split;eauto.
 rewrite H8, H10. reflexivity.
 destruct H6, H6.
 rewrite H7.
 apply H1 in H6.
 apply H3 in H6. auto.
unfold elem_set. unfold elem_set in *.
rewrite <- H4.
auto.
intros. split; intros.
unfold elem_set.
exists a. eauto.
unfold elem_set in H0.
destruct H0, H0.
exists x.
split. unfold elem_set.
eauto. eauto.
Qed.

(* **chromatic*)

Record chromatic_complex{N:Type} := {
    comp: @complex N;
    n:nat;
    f:N->nat;
    chro_prop1: forall x:N, elem_set x comp.(V) → f x < n ;
    chro_prop2: forall s, elem_set s comp.(C) → forall v v',
        (elem_set v s /\ elem_set v' s /\ f v = f v') → v =v'
}.

Record chromatic_simplicial_map {A B:Type}{from:@chromatic_complex A} {to:@chromatic_complex B}:=
    {
        smap : @simplicial_map A B from.(comp) to.(comp) ;
        chro_map_prop: (forall x:A, elem_set x from.(comp).(V) →  from.(f) x = to.(f) (smap.(func) x))
    }.

Program Definition chromatic_self_identity {N:Type} (c:@chromatic_complex N):chromatic_simplicial_map:=
{|
    smap:=self_identity c.(comp);
    chro_map_prop:=_
|}.

Definition isomorphic_chromatic_complex{A B:Type} (c:@chromatic_complex A) (c':@chromatic_complex B) :=
    ∃ (f:@chromatic_simplicial_map A B c c') (g:@chromatic_simplicial_map B A c' c),
    forall a, elem_set a c.(comp).(V) → g.(smap).(func) (f.(smap).(func) a) = a /\
    forall b, elem_set b c'.(comp).(V) → f.(smap).(func) (g.(smap).(func) b) = b.

Theorem chromatic_complex_isomorphic_with_itself: forall (N:Type) (c:@chromatic_complex N), isomorphic_chromatic_complex c c.
Proof.
    intros.
    unfold isomorphic_chromatic_complex.
    exists (chromatic_self_identity c), (chromatic_self_identity c).
    intros; split; reflexivity.
Qed.

Program Definition chromatic_simplicial_map_transitive {A1 A2 A3:Type}
{C1:@chromatic_complex A1} {C2:@chromatic_complex A2} {C3:@chromatic_complex A3}
(m1: @chromatic_simplicial_map A1 A2 C1 C2) (m2: @chromatic_simplicial_map A2 A3 C2 C3): @chromatic_simplicial_map A1 A3 C1 C3:=
{|
    smap:= @simplicial_map_transitive A1 A2 A3 C1.(comp) C2.(comp) C3.(comp) m1.(smap) m2.(smap)
|}.
Next Obligation.
destruct m1, m2; simpl.
apply chro_map_prop0 in H as H2.
destruct smap0, smap1.
rewrite H2.
apply chro_map_prop1.
destruct C1, C2, C3.
destruct comp0, comp1, comp2; simpl in *; simpl.
apply C_built_from_V1 with (λ l, l= func0 x).
assert (elem_set (λ l, l=x) C0).
unfold uni_covering in prop5.
unfold elem_set; unfold elem_set in *.
apply prop5 in H.
destruct H.
destruct H.
assert (x0 = (λ l : A1, l = x)).
apply functional_extensionality_dep.
intros.
apply EquivThenEqual; split; intros.
rewrite H0 in H1; auto.
subst.
rewrite H0.
reflexivity.
rewrite <- H1; auto.
apply prop0 in H0 as lem1.
destruct lem1.
destruct H1.
destruct H3.
assert (x0 = (λ l : A2, l = func0 x)).
apply functional_extensionality_dep.
intros.
apply EquivThenEqual.
split; intros.
apply H4 in H5.
 destruct H5.
 destruct H5.
 unfold elem_set in H5.
 subst; reflexivity.
 subst.
 apply H3.
 unfold elem_set.
 reflexivity.
 rewrite <-H5.
 auto.
 unfold elem_set.
 reflexivity.
 Qed.

Definition subd_well_colored{N:Type} (s:@set (@set N * N)) :=
    forall k l, elem_set k s /\ elem_set l s /\ snd(k)= snd(l)→k=l.

Definition subd_ordered {N:Type} (s:@set (@set N * N)) :=
    forall k l, elem_set k s /\ elem_set l s → (subset_set (fst k) (fst l) \/ subset_set (fst l) (fst k)).

Definition subd_transitive {N:Type} (s:@set (@set N * N)) :=
    forall k l, elem_set k s /\ elem_set l s /\ elem_set (snd l) (fst k)→ subset_set (fst l) (fst k).

Program Definition chromatic_subdivision_complex {N:Type} {c:@chromatic_complex N}: (@chromatic_complex (((@set  N)*N))):=
let V_set :=
    (λ p, elem_set (fst p) c.(comp).(C)/\ elem_set (snd p) (fst p)) in
{|
    comp := {|
        V:= V_set;
        C:= (λ s, (forall v, elem_set v s → elem_set v V_set) /\
        subd_well_colored s /\ subd_ordered s /\ subd_transitive s)
    |};
    n:= c.(n);
    f:= (λ p, c.(f) (snd p))
|}.
Next Obligation. destruct H as [H1 [H2 [H3 H4]] ]. eauto.
Qed.
Next Obligation. unfold closed_containment.
intros.
unfold elem_set.
unfold subset_set, elem_set in *.
split.
intros.
apply H0 in H1 as H2.
apply H in H2 as H3.
auto. destruct H.
split.
unfold subd_well_colored.
intros.
destruct H1. unfold subd_well_colored in H1. apply H1.
unfold elem_set.
split.
destruct H2.
destruct H4.
eauto.
split.
unfold elem_set in *.
destruct H2 as [_ [? ?]].
eauto.
destruct H2 as [_ [ _ ?]].
auto.
split.
unfold subd_ordered.
intros.
destruct H1 as [_[? _]].
unfold subd_ordered in *.
apply H1.
split;
destruct H2; unfold elem_set; unfold elem_set in *;eauto.
unfold subd_transitive.
intros.
destruct H1 as [_[_ ?]].
unfold subd_transitive in H1.
apply H1.
split; unfold elem_set in *; unfold elem_set; destruct H2 as [?[? ?]].
eauto.
split;eauto.
Qed.
Next Obligation.
unfold uni_covering.
intros.
exists (λ v,v=n0).
unfold elem_set.
unfold elem_set in *.
split.
split.
intros; subst; auto.
split. unfold subd_well_colored.
intros. destruct k.
destruct l. unfold elem_set in *. destruct n0. destruct H0 as [?[? ?]].
rewrite H0, H1. reflexivity.
split. unfold subd_ordered.
unfold subset_set. unfold elem_set.
intros.
destruct H0; subst. left. eauto.
unfold subd_transitive.
unfold elem_set, subset_set.
intros; destruct H0. destruct H2. subst. auto.
intros;split;auto.
Qed.
Next Obligation.
destruct c; simpl in *;simpl.
apply chro_prop3.
simpl in H.
destruct comp0; simpl in *; simpl.
unfold elem_set in *; unfold elem_set.
simpl in H.
apply C_built_from_V0 with s.
destruct H. auto. destruct H. auto.
Qed.
Next Obligation.

simpl in *.
destruct c;simpl; simpl in*.
destruct H as [?[?[? ?]]].
unfold subd_ordered in H4.
unfold subd_well_colored in H3.
apply H3.
split.
auto.
split.
auto.
simpl.
unfold subd_transitive in H5; unfold subset_set in *; unfold elem_set in *.
assert (s (s1, n1) /\ s (s0,n0)).
split;auto.
apply H4 in H6.
destruct H6.
simpl in H6.
apply chro_prop4 with s0.
apply H in H1.
destruct H1; simpl in *.
auto.
split.
apply H6.
apply H in H0.
destruct H0; simpl in *.
auto.
split.
apply H in H1.
destruct H1 as [_ ?].
simpl in H1; auto.
auto.
simpl in H6.
apply chro_prop4 with s1.
apply H in H0.
destruct H0.
simpl in *.
auto.
split.
apply H in H0. destruct H0.
auto.
split.
apply H in H1.
destruct H1. auto.
auto.
Qed.


Load Common.

Require Import Bool.

(*used for free variables*)
Definition label : Set := nat * nat.

Module Label.
Lemma eq_dec : forall (a b : label), {a = b} + {a <> b}.
Proof.
case => a1 a2; case => b1 b2.
have := Nat.eq_dec a1 b1; have := Nat.eq_dec a2 b2.
case => ?; case => ?; first auto.
all : right; case; auto.
Qed.

Definition eqb (a : label) (b : label) : bool :=
  match a, b with
  | (a1, a2), (b1, b2) => (a1 =? b1) && (a2 =? b2)
  end.

Lemma eqb_eq : forall (a b : label), (eqb a b = true) <-> a = b.
Proof.
move => a b.
constructor.
rewrite -> (surjective_pairing a), (surjective_pairing b); cbn.
case /andb_true_iff.
by move /Nat.eqb_eq => -> /Nat.eqb_eq => ->.

move => ->.
rewrite -> (surjective_pairing b); cbn.
by rewrite <- ? beq_nat_refl.
Qed.

Lemma neq_neqb : forall (a b : label), a <> b -> (eqb a b = false).
Proof.
case => a1 a2; case => b1 b2; cbn.
have := Nat.eq_dec a1 b1; have := Nat.eq_dec a2 b2.
case => ?; case => ?; first (by subst); move => _.
all : match goal with [H : _ <> _ |- _] => move /Nat.eqb_neq : H => -> end.
all : auto using Bool.andb_false_r.
Qed.
End Label.

Inductive formula : Set :=
    | var : nat -> formula
    | atom : label -> formula
    | arr : formula -> formula -> formula
    | quant : formula -> formula.

Definition get_label (s : formula) : label :=
  match s with
  | atom a => a
  | _ => (0,0) (*to be replaced by some inhabitant of label or make function partial*)
  end.

Fixpoint substitute_label (a b : label) (t : formula) : formula :=
  match t with
    | (atom c) => if Label.eqb a c then (atom b) else t
    | (var _) => t
    | (arr s' t') => arr (substitute_label a b s') (substitute_label a b t')
    | (quant t') => quant (substitute_label a b t')
  end.

(*a is bindable in t if it does not appear free in t*)
Inductive fresh_in (a: label) : formula -> Prop :=
  | fresh_in_var : forall (n : nat), fresh_in a (var n)
  | fresh_in_atom : forall (b: label), a ≠ b -> fresh_in a (atom b)
  | fresh_in_arr : forall (s t: formula), fresh_in a s -> fresh_in a t -> fresh_in a (arr s t)
  | fresh_in_quant : forall (s: formula), fresh_in a s -> fresh_in a (quant s).

(*
(*replace free occurrences of a in t by index n*)
Fixpoint bind (a: label) (n : nat) (t : formula) : formula :=
  match t with
    | (atom b) => if Label.eqb a b then var n else t
    | (var _) => t
    | (arr s t) => arr (bind a n s) (bind a n t)
    | (quant t) => quant (bind a (S n) t)
  end.

(*replace all occurrences of atom a by s in t*)
Fixpoint substitute (a : label) (s t : formula) : formula :=
  match t with
    | (atom c) => if Label.eqb a c then s else t
    | (var _) => t
    | (arr s' t') => arr (substitute a s s') (substitute a s t')
    | (quant t') => quant (substitute a s t')
  end.
*)

(*instantiate s 0 t replaces the outermost bound variable in t by s, i.e. t[0/s]*)
Fixpoint instantiate (s: formula) (n : nat) (t : formula) : formula :=
  match t with
    | (atom _) => t
    | (var m) => if n =? m then s else t
    | (arr s' t') => arr (instantiate s n s') (instantiate s n t')
    | (quant t') => quant (instantiate s (S n) t')
  end.

Fixpoint instantiate_prenex (f : nat -> option formula) (t : formula) : formula :=
  match t with
    | (atom _) => t
    | (var m) => match f m with | Some s => s | None => t end
    | (arr s' t') => arr (instantiate_prenex f s') (instantiate_prenex f t')
    | (quant t') => quant (instantiate_prenex (fun n => match n with | 0 => None | S n' => f n' end) t')
  end.

(*locally closed up to n, lc 0 are well-formed formulae*)
Inductive lc : nat -> formula -> Prop :=
    | lc_var : forall (m n: nat), n < m -> lc m (var n)
    | lc_atom : forall (n: nat) (a: label), lc n (atom a)
    | lc_arr : forall (n: nat) (s t: formula), lc n s -> lc n t -> lc n (arr s t)
    | lc_quant : forall (n: nat) (t: formula), lc (S n) t -> lc n (quant t).

(*repeated instantiation by locally closed formulae*)
Inductive contains : formula -> formula -> Prop :=
  | contains_rfl : forall (s: formula), contains s s
  | contains_trans : forall (s t u: formula), lc 0 s -> contains (instantiate s 0 u) t -> contains (quant u) t.

(*chain s a params morally means that s can be instanciated as p1 -> ... -> pn -> a*)
Inductive chain (s : formula) (a : label) : list formula -> Prop :=
  | chain_nil : contains s (atom a) -> chain s a List.nil
  | chain_cons : forall (t u: formula) (ts: list formula), contains s (arr t u) -> chain u a ts -> chain s a (t :: ts).

(*prepends n quantifiers to a given formula*)
Fixpoint quantify_formula n t : formula :=
  match n with
  | 0 => t
  | Datatypes.S n' => quant (quantify_formula n' t)
  end.


Require Import HoTT.Basics HoTT.Types.

(** * The law of excluded middle *)

Monomorphic Axiom ExcludedMiddle : Type0.
Existing Class ExcludedMiddle.

(** Mark this axiom as a "global axiom", which some of our tactics will automatically handle. *)
Global Instance is_global_axiom_excludedmiddle : IsGlobalAxiom ExcludedMiddle := {}.

Axiom LEM : forall `{ExcludedMiddle} (P : Type), IsHProp P -> P + ~P.

Definition ExcludedMiddle_type := forall (P : Type), IsHProp P -> P + ~P.

(** ** LEM means that all propositions are decidable *)

Global Instance decidable_lem `{ExcludedMiddle} (P : Type) `{IsHProp P} : Decidable P
  := LEM P _.

(** ** Double-negation elimination *)

Definition DNE_type := forall P, IsHProp P -> ~~P -> P.

Definition LEM_to_DNE : ExcludedMiddle -> DNE_type.
Proof.
  intros lem P hp nnp.
  case (LEM P _).
  - auto.
  - intros np; elim (nnp np).
Defined.

(** This direction requires Funext. *)
Definition DNE_to_LEM `{Funext} :
  DNE_type -> ExcludedMiddle_type.
Proof.
  intros dn P hp.
  refine (dn (P + ~P) _ _).
  - apply ishprop_sum.
    + exact _.
    + exact _.
    + intros p np; exact (np p).
  - intros nlem.
    apply nlem.
    apply inr.
    intros p.
    apply nlem.
    apply inl.
    apply p.
Defined.

(** DNE is equivalent to "every proposition is a negation". *)
Definition allneg_from_DNE (H : DNE_type) (P : Type) `{IsHProp P}
  : {Q : Type & P <-> ~Q}.
Proof.
  exists (~P); split.
  - intros p np; exact (np p).
  - apply H; exact _.
Defined.

Definition DNE_from_allneg (H : forall P, IsHProp P -> {Q : Type & P <-> ~Q})
  : DNE_type.
Proof.
  intros P ? nnp.
  destruct (H P _) as [Q e].
  apply e.
  intros q.
  apply nnp.
  intros p.
  exact (fst e p q).
Defined.


Require Import ZArith Lia.
Local Open Scope Z_scope.
Require Import compcert.lib.Integers.

Fixpoint repeat_op_nat{T: Type}(n: nat)(start: T)(op: T -> T): T := match n with
| O => start
| S m => op (repeat_op_nat m start op)
end.

Definition repeat_op{T: Type}(n: Z)(start: T)(op: T -> T): T := repeat_op_nat (Z.to_nat n) start op.

Lemma repeat_op_step: forall {T: Type} (i: Z) (start: T) (op: T -> T),
  0 <= i ->
  repeat_op (i + 1) start op = op (repeat_op i start op).
Proof.
  intros. unfold repeat_op. rewrite Z2Nat.inj_add by lia.
  rewrite Nat.add_1_r. simpl. reflexivity.
Qed.

Definition times2(x: int): int :=
  Int.and
    (Int.xor (Int.shl x (Int.repr 1))
             (if Int.eq (Int.and x (Int.repr 128)) Int.zero then Int.zero else Int.repr 27))
    (Int.repr 255).

Definition pow2(e: Z): int := repeat_op e (Int.repr 1) times2.

Definition times3(x: int): int :=
  Int.and
    (Int.xor x (Int.xor (Int.shl x (Int.repr 1))
                        (if Int.eq (Int.and x (Int.repr 128)) Int.zero then Int.zero else Int.repr 27)))
    (Int.repr 255).

Definition pow3(e: Z): int := repeat_op e (Int.repr 1) times3.

Fixpoint log3_nat(p: int)(n: nat): Z :=
  if Int.eq p (pow3 (Z.of_nat n)) then Z.of_nat n
  else match n with
  | O => -1 (* illegal argument *)
  | S m => log3_nat p m
  end.

(* Note: For (log3 1), we have two possible return values: 0 and 255.
   We choose 255, because then both the domain and the codomain of log3 are 1..255. *)
Definition log3(p: int): Z := log3_nat p 255.

Definition mul(x y: int): int :=
  if Int.eq x Int.zero then Int.zero else
  if Int.eq y Int.zero then Int.zero else
  pow3 (Int.unsigned (Int.mods (Int.repr (log3 x + log3 y)) (Int.repr 255))).

Lemma pow3_not0: forall i, pow3 i <> Int.zero.
Admitted.

Lemma pow3log3: forall j,
  1 <= j < 256 ->
  Int.unsigned (pow3 (log3 (Int.repr j))) = j.
Admitted.

Lemma log3range: forall j,
  1 <= j < 256 ->
  1 <= log3 (Int.repr j) < 256.
Admitted.

Lemma mod_range: forall i m,
  0 <= i ->
  0 < m ->
  0 <= Int.unsigned (Int.mods (Int.repr i) (Int.repr m)) < m.
Admitted.

Lemma pow2_range: forall e,
  0 <= e ->
  0 <= Int.unsigned (pow2 e) < 256.
Admitted.

Lemma pow3_range: forall e,
  0 <= e ->
  0 <= Int.unsigned (pow3 e) < 256.
Admitted.

Lemma pow3_inj: forall (i j : Z),
  pow3 i = pow3 j -> Zbits.eqmod 255 i j.
Admitted.

Lemma invert_pow3: forall i,
  1 <= i < 256 ->
  exists j, 1 <= j < 256 /\ i = (Int.unsigned (pow3 j)).
Admitted.


Require Import HoTT.Basics Types.Universe Types.Paths Types.Unit FunextVarieties.

Generalizable All Variables.

(** * Univalence Implies Functional Extensionality *)

(** Here we prove that univalence implies function extensionality. *)
Set Printing Universes.
(** We define an axiom-free variant of [Univalence] *)
Definition Univalence_type := forall (A B : Type@{i}), IsEquiv (equiv_path A B).

(** Univalence is a property of a single universe; its statement lives in a higher universe *)
Check Univalence_type@{i iplusone} : Type@{iplusone}.

Section UnivalenceImpliesFunext.
  Context `{ua : Univalence_type}.

  (** Exponentiation preserves equivalences, i.e., if [e] is an equivalence then so is post-composition by [e]. *)

  (* Should this go somewhere else? *)

  Theorem univalence_isequiv_postcompose `{H0 : IsEquiv A B w} C : IsEquiv (fun (g:C->A) => w o g).
  Proof.
    unfold Univalence_type in *.
    refine (isequiv_adjointify
              (fun (g:C->A) => w o g)
              (fun (g:C->B) => w^-1 o g)
              _
              _);
    intro;
    pose (Build_Equiv _ _ w _) as w';
    change H0 with (@equiv_isequiv _ _ w');
    change w with (@equiv_fun _ _ w');
    clearbody w'; clear H0 w;
    rewrite <- (@eisretr _ _ (@equiv_path A B) (ua A B) w');
    generalize ((@equiv_inv _ _ (equiv_path A B) (ua A B)) w');
    intro p;
    clear w';
    destruct p;
    reflexivity.
  Defined.

  (** We are ready to prove functional extensionality, starting with the naive non-dependent version. *)

  Local Instance isequiv_src_compose A B
  : @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
             (A -> B)
             (fun g => (fst o pr1) o g).
  Proof.
    rapply @univalence_isequiv_postcompose.
    refine (isequiv_adjointify
              (fst o pr1) (fun x => ((x, x); idpath))
              (fun _ => idpath)
              _);
      let p := fresh in
      intros [[? ?] p];
        simpl in p; destruct p;
        reflexivity.
  Defined.

  Local Instance isequiv_tgt_compose A B
  : @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
             (A -> B)
             (fun g => (snd o pr1) o g).
  Proof.
    rapply @univalence_isequiv_postcompose.
    refine (isequiv_adjointify
              (snd o pr1) (fun x => ((x, x); idpath))
              (fun _ => idpath)
              _);
      let p := fresh in
      intros [[? ?] p];
        simpl in p; destruct p;
        reflexivity.
  Defined.

  Theorem Univalence_implies_FunextNondep : NaiveNondepFunext.
  Proof.
    intros A B f g p.
    (** Consider the following maps. *)
    pose (d := fun x : A => existT (fun xy => fst xy = snd xy) (f x, f x) (idpath (f x))).
    pose (e := fun x : A => existT (fun xy => fst xy = snd xy) (f x, g x) (p x)).
    (** If we compose [d] and [e] with [free_path_target], we get [f] and [g], respectively. So, if we had a path from [d] to [e], we would get one from [f] to [g]. *)
    change f with ((snd o pr1) o d).
    change g with ((snd o pr1) o e).
    erapply (ap (fun g => snd o pr1 o g)).
    (** Since composition with [src] is an equivalence, we can freely compose with [src]. *)
    pose (fun A B x y=> @equiv_inv _ _ _ (@isequiv_ap _ _ _ (@isequiv_src_compose A B) x y)) as H'.
    apply H'.
    reflexivity.
  Defined.

End UnivalenceImpliesFunext.

(** Note that only the codomain universe of [NaiveNondepFunext] is required to be univalent. *)
Check @Univalence_implies_FunextNondep@{j jplusone i max j max}
  : Univalence_type@{j jplusone} -> NaiveNondepFunext@{i j max}.

(** Now we use this to prove strong dependent funext.  Again only the codomain universe must be univalent, but the domain universe must be no larger than it is.  Thus practically speaking this means that a univalent universe satisfies funext only for functions between two types in that same universe. *)

Definition Univalence_implies_WeakFunext : Univalence_type -> WeakFunext
  := NaiveNondepFunext_implies_WeakFunext o @Univalence_implies_FunextNondep.

Definition Univalence_type_implies_Funext_type
           `{ua : Univalence_type@{j jplusone} }
  : Funext_type@{i j j}
  := NaiveNondepFunext_implies_Funext
       (@Univalence_implies_FunextNondep ua).

(** As justified by the above proof, we may assume [Univalence -> Funext]. *)
Global Instance Univalence_implies_Funext `{Univalence} : Funext.
Admitted.


Require Import CRtrans Compress.
Require Import ARtrans ARbigD.

Definition eval (n:positive) (r : CR) :=
 let m := iter_pos n _ (Pmult 10) 1%positive in let _ := approximate r (1#m)%Qpos in tt.

Definition deval (n:positive) (r : ARbigD) :=
 let m := iter_pos n _ (Pmult 10) 1%positive in let _ := approximate r (1#m)%Qpos in tt.

Definition P01 : CR := sin (compress (sin (compress (rational_sin 1)))).
Definition dP01 : ARbigD := ARsin (ARsin (AQsin 1)).

Definition P02 : CR := CRsqrt (compress CRpi).
Definition dP02 : ARbigD := ARsqrt (ARcompress ARpi).

Definition P03 : CR := sin (compress (rational_exp 1)).
Definition dP03 : ARbigD := ARsin (AQexp 1).

Definition P04 : CR := exp (compress (CRpi * rational_sqrt ('163%Z))).
Definition dP04 : ARbigD := ARexp (ARcompress (ARpi * AQsqrt ('163%Z))).

Definition P05 : CR := exp (compress (exp (compress (rational_exp 1)))).
Definition dP05 : ARbigD := ARexp (ARexp (AQexp 1)).

Definition P07 : CR := rational_exp ('1000%Z).
Definition dP07 : ARbigD := AQexp ('1000%Z).

Definition P08 : CR := cos (cast Q CR (cast Z Q (10^50)%Z)).
Definition dP08 : ARbigD := AQcos ('(10^50)%Z).

Require Import String.

Eval compute in "old"%string.
Time Eval vm_compute in (eval 25 P01).
Time Eval vm_compute in (eval 25 P02).
Time Eval vm_compute in (eval 25 P03).
Time Eval vm_compute in (eval 10 P04).
Time Eval vm_compute in (eval 10 P05).
Time Eval vm_compute in (eval 10 P07).
Time Eval vm_compute in (eval 25 P08).

Eval compute in "new"%string.
Time Eval vm_compute in (deval 25 dP01).
Time Eval vm_compute in (deval 25 dP02).
Time Eval vm_compute in (deval 25 dP03).
Time Eval vm_compute in (deval 10 dP04).
Time Eval vm_compute in (deval 10 dP05).
Time Eval vm_compute in (deval 10 dP07).
Time Eval vm_compute in (deval 25 dP08).

Eval compute in "new bigger"%string.
Time Eval vm_compute in (deval 500 dP01).
Time Eval vm_compute in (deval 500 dP02).
Time Eval vm_compute in (deval 500 dP03).
Time Eval vm_compute in (deval 500 dP04).
Time Eval vm_compute in (deval 500 dP05).
Time Eval vm_compute in (deval 2000 dP07).
Time Eval vm_compute in (deval 2000 dP08).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable tP_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable sQ_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable rT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable perp_at_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_3_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defoppositeside_1 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_2 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_8_2_3 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Variable lemma_rightangleNC_4 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable lemma_NCdistinct_5 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable deftriangle_6 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_7 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable defsquare_8 : (forall A B C D : Universe, (sQ_ A B C D -> (cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))))).
Variable defsquare2_9 : (forall A B C D : Universe, ((cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))) -> sQ_ A B C D)).
Variable axiom_nocollapse_10 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
Variable lemma_inequalitysymmetric_11 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_squareparallelogram_12 : (forall A B C D : Universe, (sQ_ A B C D -> pG_ A B C D)).
Variable defparallelogram_13 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_14 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable defparallel_15 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_16 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).
Variable defcollinear_17 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_18 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_19 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_20 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_21 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_22 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_23 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_24 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable defmeet_25 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_26 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).
Variable lemma_betweennotequal_27 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_collinear4_28 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable proposition_12_29 : (forall A B C : Universe, (exists X : Universe, ((A <> B /\ ~(col_ A B C)) -> perp_at_ C X A B X))).
Variable defperpat_30 : (forall P Q A B C : Universe, (exists X : Universe, (perp_at_ P Q A B C -> (col_ P Q C /\ (col_ A B C /\ (col_ A B X /\ per_ X C P)))))).
Variable defperpat2_31 : (forall P Q A B C X : Universe, ((col_ P Q C /\ (col_ A B C /\ (col_ A B X /\ per_ X C P))) -> perp_at_ P Q A B C)).
Variable lemma_collinearright_32 : (forall A B C D : Universe, ((per_ A B D /\ (col_ A B C /\ C <> B)) -> per_ C B D)).
Variable lemma_8_7_33 : (forall A B C : Universe, (per_ C B A -> ~(per_ A C B))).
Variable lemma_parallelflip_34 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable lemma_parallelsymmetric_35 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).
Variable lemma_collinearparallel_36 : (forall A B C Xc Xd : Universe, ((par_ A B Xc Xd /\ (col_ Xc Xd C /\ C <> Xd)) -> par_ A B C Xd)).
Variable lemma_paralleldef2B_37 : (forall A B C D : Universe, (par_ A B C D -> tP_ A B C D)).
Variable deftarski_parallel_38 : (forall A B C D : Universe, (tP_ A B C D -> (A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))))).
Variable deftarski_parallel2_39 : (forall A B C D : Universe, ((A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))) -> tP_ A B C D)).
Variable lemma_ray4_1_40 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_41 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_42 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_sameside2_43 : (forall A B C E F G : Universe, ((oS_ E F A C /\ (col_ A B C /\ out_ B F G)) -> oS_ E G A C)).
Variable lemma_samesideflip_44 : (forall A B P Q : Universe, (oS_ P Q A B -> oS_ P Q B A)).
Variable lemma_samesidesymmetric_45 : (forall A B P Q : Universe, (oS_ P Q A B -> (oS_ Q P A B /\ (oS_ P Q B A /\ oS_ Q P B A)))).
Variable lemma_erectedperpendicularunique_46 : (forall A B C E : Universe, ((per_ A B C /\ (per_ A B E /\ oS_ C E A B)) -> out_ B C E)).
Variable lemma_rayimpliescollinear_47 : (forall A B C : Universe, (out_ A B C -> col_ A B C)).
Variable lemma_NCorder_48 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable lemma_parallelNC_49 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Variable lemma_planeseparation_50 : (forall A B C D E : Universe, ((oS_ C D A B /\ tS_ D A B E) -> tS_ C A B E)).
Variable lemma_ray5_51 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_8_3_52 : (forall A B C D : Universe, ((per_ A B C /\ out_ B C D) -> per_ A B D)).
Variable lemma_twoperpsparallel_53 : (forall A B C D : Universe, ((per_ A B C /\ (per_ B C D /\ oS_ A D B C)) -> par_ A B C D)).
Variable axiom_betweennesssymmetry_54 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable proposition_29C_55 : (forall B D E G H : Universe, ((par_ G B H D /\ (oS_ B D G H /\ betS_ E G H)) -> (congA_ E G B G H D /\ rT_ B G H G H D))).
Variable lemma_equaltorightisright_56 : (forall A B C Xa Xb Xc : Universe, ((per_ A B C /\ congA_ Xa Xb Xc A B C) -> per_ Xa Xb Xc)).
Variable lemma_altitudeofrighttriangle_57 : (forall A B C M Xp : Universe, ((per_ B A C /\ (per_ A M Xp /\ (col_ B C Xp /\ col_ B C M))) -> betS_ B M C)).
Variable lemma_Playfair_58 : (forall A B C D E : Universe, ((par_ A B C D /\ par_ A B C E) -> col_ C D E)).
Variable proposition_34_59 : (forall A B C D : Universe, (pG_ A C D B -> (cong_ A B C D /\ (cong_ A C B D /\ (congA_ C A B B D C /\ (congA_ A B D D C A /\ cong_3_ C A B B D C)))))).
Variable lemma_betweennesspreserved_60 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (cong_ B C Xb Xc /\ betS_ A B C))) -> betS_ Xa Xb Xc)).

Theorem proposition_47A_61 : (forall A B C D E : Universe, (exists X Y : Universe, ((triangle_ A B C /\ (per_ B A C /\ (sQ_ B C E D /\ tS_ D C B A))) -> (pG_ B X Y D /\ (betS_ B X C /\ (pG_ X C E Y /\ (betS_ D Y E /\ (betS_ Y X A /\ per_ D Y A)))))))).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import
        String
        Coq.ZArith.ZArith
        Coq.ZArith.BinIntDef
        Coq.Init.Datatypes
        Coq.FSets.FMapList
        Coq.Structures.OrderedTypeEx.

Print Z.
Locate of_nat.
Open Scope Z_scope.

Module L := Coq.Lists.List.
Module M := FMapList.Make(String_as_OT).

Open Scope string_scope.
Set Implicit Arguments.

Definition Env := M.t Z.
Definition Clean := M.empty Z.

Section R1C.
  (** Finite field modulo prime P *)
  Parameter P: Z.
  Parameter (H: forall n: Z, Z.modulo P n = 0).

  (** ADT for R1Constraint *)
  Inductive R1C :=
  | Const (n: Z)
  | Mult (n: Z) (v: string)
  | Neg (inner: R1C)
  | Plus (left: R1C) (right: R1C).

  Definition R1CS := list R1C.

  (** Syntax *)
  Declare Scope r1c_scope.
  Bind Scope r1c_scope with R1C.
  Open Scope r1c_scope.
  Coercion Const : Z >-> R1C.
  Definition string_to_r1c(s: string) := Mult 1 s.
  Coercion string_to_r1c: string >-> R1C.

  Notation "a * e" := (Mult a e) (at level 40, left associativity): r1c_scope.
  Notation "e1 + e2" := (Plus e1 e2) (at level 50, left associativity): r1c_scope.
  Notation "- e" := (Neg e) (at level 35, right associativity): r1c_scope.
  Notation "e1 == e2" := (Plus e1 (Neg e2)) (at level 55, left associativity): r1c_scope.

  (** Let's try it out *)
  Definition ex1_equation := "r0"  == 0 + 1.

  Fixpoint substitute(env: Env)(constr: R1C) : option Z :=
    match constr with
    | Mult n v => match M.find v env with
                 | None => None
                 | Some v' => Some (Z.mul n v')
                 end
    | Plus l r => match substitute env l, substitute env r with
                 | Some a, Some b => Some (Z.add a b)
                 | _, _ => None
                 end
    | Neg i => option_map Z.opp (substitute env i)
    | Const n => Some n
    end.

  (** Check a valuation satisfies an R1CS *)
  Definition check(env: Env)(C: R1CS): Prop := L.Forall (fun r1c => substitute env r1c = Some 0) C.

End R1C.

Section Expr.
  Declare Scope asm_scope.
  Open Scope asm_scope.

  (** AST of small assembly language *)
  Inductive AsmExpr :=
  | AAdd (dst: string) (src: string)
  | ASub (dst: string) (src: string)
  | AMult (dst: string) (src: string)
  | AMov (dst: string) (const: Z)
  | ASeq (head: AsmExpr) (tail: AsmExpr).

  Infix ";;" := ASeq (at level 55): asm_scope.
  Bind Scope asm_scope with AsmExpr.

  (** Program: r0 <- 0 + 1 *)
  Definition ex1_prog :=
    AMov "%r0" 0 ;;
    AMov "%r1" 1 ;;
    AAdd "%r0" "%r1".

  Fixpoint eval(env: Env)(p: AsmExpr): Env :=
    match p with
    | AAdd l r => match M.find l env, M.find r env with
                 | Some lv, Some rv => M.add l (lv + rv) env
                 | None, Some rv => M.add l rv env
                 | _, _ => env
                 end
    | ASub l r => match M.find l env, M.find r env with
                 | Some lv, Some rv => M.add l (lv - rv) env
                 | _, _ => env
                 end
    | AMult l r => match M.find l env, M.find r env with
                  | Some lv, Some rv => M.add l (lv * rv) env
                  | _, _ => env
                  end
    | AMov reg v => M.add reg v env
    | ASeq a b => eval (eval env a) b
    end.

End Expr.

Require Import Coq.FSets.FMapFacts.

Module P := WProperties_fun String_as_OT M.
Module F := P.F.

Section AbstrInterp.

  Definition simulation_correct(P: AsmExpr)(C: R1CS) := forall (env: Env),
    let endState := eval env P in check endState C.

  Theorem some_example_correct:
    simulation_correct ex1_prog (L.cons ex1_equation L.nil).
  Proof.
    unfold simulation_correct.
    intros.
    simpl.
    replace (
    rewrite F.add_eq_o.
  Admitted.

    rewrite F.add_eq_o.
    F.map_iff
End AbstrInterp.


Require Export euclidean__axioms.
Require Export lemma__NCorder.
Require Export lemma__collinearorder.
Require Export logic.
Definition lemma__oppositesideflip : forall A B P Q, (euclidean__axioms.TS P A B Q) -> (euclidean__axioms.TS P B A Q).
Proof.
intro A.
intro B.
intro P.
intro Q.
intro H.
assert (exists r, (euclidean__axioms.BetS P r Q) /\ ((euclidean__axioms.Col A B r) /\ (euclidean__axioms.nCol A B P))) as H0 by exact H.
destruct H0 as [r H1].
destruct H1 as [H2 H3].
destruct H3 as [H4 H5].
assert (* Cut *) (euclidean__axioms.nCol B A P) as H6.
- assert (* Cut *) ((euclidean__axioms.nCol B A P) /\ ((euclidean__axioms.nCol B P A) /\ ((euclidean__axioms.nCol P A B) /\ ((euclidean__axioms.nCol A P B) /\ (euclidean__axioms.nCol P B A))))) as H6.
-- apply (@lemma__NCorder.lemma__NCorder A B P H5).
-- destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H7.
- assert (* Cut *) (euclidean__axioms.Col B A r) as H7.
-- assert (* Cut *) ((euclidean__axioms.Col B A r) /\ ((euclidean__axioms.Col B r A) /\ ((euclidean__axioms.Col r A B) /\ ((euclidean__axioms.Col A r B) /\ (euclidean__axioms.Col r B A))))) as H7.
--- apply (@lemma__collinearorder.lemma__collinearorder A B r H4).
--- destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H8.
-- assert (* Cut *) (euclidean__axioms.TS P B A Q) as H8.
--- exists r.
split.
---- exact H2.
---- split.
----- exact H7.
----- exact H6.
--- exact H8.
Qed.


From Hammer Require Import Hammer.

From Topology Require Export TopologicalSpaces.
From Topology Require Export OrderTopology.
From Topology Require Export Completeness.
Require Import Lra.
From Topology Require Import FiniteIntersectionLemmas.
From Topology Require Export MetricSpaces.
From Topology Require Import RationalsInReals.
From Topology Require Export Compactness.
From Topology Require Export Connectedness.

Definition RTop := OrderTopology Rle.
Definition R_metric (x y:R) : R := Rabs (y-x).

Lemma R_metric_is_metric: metric R_metric.
Proof. hammer_hook "RTopology" "RTopology.R_metric_is_metric".
constructor;
intros;
unfold R_metric in *.
- pose proof (Rabs_pos (y-x)).
auto with real.
- replace (y-x) with (-(x-y)) by ring.
apply Rabs_Ropp.
- replace (z-x) with ((y-x) + (z-y)) by ring.
apply Rabs_triang.
- replace (x-x) with 0 by ring.
exact Rabs_R0.
- apply NNPP.
intro.
assert (y - x <> 0) by lra.
apply Rabs_no_R0 in H1.
contradiction.
Qed.

Lemma Rmetric_bound: forall x y z:R, R_metric x z < y - x ->
z < y.
Proof. hammer_hook "RTopology" "RTopology.Rmetric_bound".
intros.
replace z with (x + (z-x)) by ring.
apply Rle_lt_trans with (x + R_metric x z);
[ assert (z - x <= R_metric x z) by apply Rle_abs |
replace y with (x + (y-x)) by ring];
lra.
Qed.

Lemma Rmetric_bound2: forall x y z:R, R_metric y z < y - x ->
x < z.
Proof. hammer_hook "RTopology" "RTopology.Rmetric_bound2".
intros.
replace z with (y + (z-y)) by ring.
assert (y - z <= R_metric y z).
rewrite (metric_sym _ _ R_metric_is_metric).
apply Rle_abs.
lra.
Qed.

Lemma family_union_singleton
{X : Type}
(S : Ensemble X) :
FamilyUnion (Singleton S) = S.
Proof. hammer_hook "RTopology" "RTopology.family_union_singleton".
now extensionality_ensembles;
try econstructor.
Qed.

Lemma R_lower_beam_open : forall p,
@open RTop [r : R | r < p].
Proof. hammer_hook "RTopology" "RTopology.R_lower_beam_open".
intro.
replace [r : R | r < p] with
[y : R | y <= p /\ y <> p] by (extensionality_ensembles; constructor; lra).
rewrite <- family_union_singleton.
repeat (constructor + destruct H).
Qed.

Lemma R_upper_beam_open : forall p,
@open RTop [r : R | r > p].
Proof. hammer_hook "RTopology" "RTopology.R_upper_beam_open".
intro.
replace [r : R | r > p] with
[y : R | p <= y /\ y <> p] by (extensionality_ensembles; constructor; lra).
rewrite <- family_union_singleton.
repeat (constructor + destruct H).
Qed.

Lemma R_interval_open : forall p q,
@open RTop [r : R | p < r < q].
Proof. hammer_hook "RTopology" "RTopology.R_interval_open".
intros p q.
replace [r : R | p < r < q] with
(Intersection [y : R | y < q] [y : R | y > p]) by (extensionality_ensembles; repeat constructor; lra).
eapply (@open_intersection2 RTop).
- apply R_lower_beam_open.
- apply R_upper_beam_open.
Qed.

Lemma RTop_neighborhood_is_neighbourhood
(U : Ensemble R)
(r : R) :
@neighborhood RTop U r <-> neighbourhood U r.
Proof. hammer_hook "RTopology" "RTopology.RTop_neighborhood_is_neighbourhood".
split.
- intros [H1 [[[F H2] [V x H4 H5]] H6]].

eapply (neighbourhood_P1 V).
intros x' H'.
apply H6.
econstructor.
exact H4.
exact H'.
apply H2 in H4.
clear H2 H6 F H1.
induction H4.
+ exists (RinvN 1).
now intros ? ?.
+ destruct H as [y|y];
destruct H5 as [[H5 H6]];
[ refine (ex_intro _ (mkposreal (y - x) _) _) |
refine (ex_intro _ (mkposreal (x - y) _) _) ];
intros ? H;
apply Rabs_def2 in H;
simpl in H;
destruct H;
repeat constructor; lra.
Unshelve.
lra. lra.
+ destruct H5 as [x H2 H3],
(IHfinite_intersections H2) as [[p Hp] H4],
(IHfinite_intersections0 H3) as [[q Hq] H5],
(Rlt_or_le p q);
[ exists (mkposreal p Hp) |
exists (mkposreal q Hq) ];
intros x' H';
apply Rabs_def2 in H';
simpl in H';
destruct H';
constructor;
apply H4 + apply H5;
apply Rabs_def1; simpl;
try assumption;
(try now (eapply Rlt_trans; try exact H7);
eapply Rlt_trans;
try exact H8); lra.
- intros [[p Hp] H].
exists [x : R | r - p < x < r + p].
repeat split; try lra.
+ apply R_interval_open.
+ intros y [[H1 H2]].
apply H, Rabs_def1; simpl; lra.
Qed.

Lemma RTop_metrization: metrizes RTop R_metric.
Proof. hammer_hook "RTopology" "RTopology.RTop_metrization".
refine (let Hsubbasis := Build_TopologicalSpace_from_subbasis_subbasis
_ (order_topology_subbasis _ Rle) in _).
clearbody Hsubbasis.
red; intros.
constructor;
intros.
- destruct H.
replace (open_ball (point_set RTop) R_metric x r) with
(Intersection
[ y:R | x-r <= y /\ y <> x-r ]
[ y:R | y <= x+r /\ y <> x+r ]).
constructor.
+ apply (@open_intersection2 RTop);
apply Hsubbasis; constructor.
+ repeat constructor; lra.
+ extensionality_ensembles;
repeat constructor;
try apply Rabs_def2 in H0;
destruct H0;
try lra.
destruct H1.
apply Rabs_def1; lra.
- intros.
apply open_neighborhood_is_neighborhood, RTop_neighborhood_is_neighbourhood in H.
destruct H.
exists (open_ball (point_set RTop) R_metric x x0).
split.
+ now destruct x0.
+ intros r [H0].
now apply H.
Qed.

Corollary RTop_metrizable: metrizable RTop.
Proof. hammer_hook "RTopology" "RTopology.RTop_metrizable".
exists R_metric.
exact R_metric_is_metric.
exact RTop_metrization.
Qed.

Lemma bounded_real_net_has_cluster_point: forall (I:DirectedSet)
(x:Net I RTop) (a b:R), (forall i:DS_set I, a <= x i <= b) ->
exists x0:point_set RTop, net_cluster_point x x0.
Proof. hammer_hook "RTopology" "RTopology.bounded_real_net_has_cluster_point".

intros.
destruct (classic (inhabited (DS_set I))) as [Hinh|Hempty].
assert (forall i:DS_set I, { y:R | is_glb
(Im [ j:DS_set I | DS_ord i j ] x) y }).
intro.
apply inf.
exists a.
red; intros.
destruct H0.
destruct (H x0).
rewrite H1.
auto with real.
exists (x i).
exists i; trivial.
constructor.
apply preord_refl.
apply DS_ord_cond.

assert ({ x0:R | is_lub (Im Full_set (fun i:DS_set I => proj1_sig (X i)))
x0 }).
apply sup.
exists b.
red; intros.
destruct H0 as [i].
destruct (X i).
simpl in H1.
rewrite H1.
destruct i0.
cut (b >= x0).
auto with real.
apply Rge_trans with (x i).
destruct (H i).
auto with real.
apply H2.
exists i; trivial.
constructor.
apply preord_refl.
apply DS_ord_cond.

destruct Hinh as [i0].
exists (proj1_sig (X i0)).
exists i0; trivial.
constructor.

destruct H0 as [x0].
exists x0.
assert (forall i j:DS_set I, DS_ord i j ->
proj1_sig (X i) <= proj1_sig (X j)).
intros.
destruct (X i0).
destruct (X j).
simpl.
destruct i1.
destruct i2.
apply H4.
red; intros.
destruct H5.
destruct H5.
apply H1.
exists x3; trivial.
constructor.
apply preord_trans with j; trivial.
apply DS_ord_cond.

red; intros.
destruct (RTop_metrization x0).
destruct (open_neighborhood_basis_cond U).
split; trivial.
destruct H3.
destruct H3.
destruct (lub_approx _ _ r i).
trivial.
destruct H5.
destruct H5.
destruct H6.
red; intros.
destruct (DS_join_cond x1 i0).
destruct H9.
remember (X x2) as y2.
destruct y2.
destruct (glb_approx _ _ r i1).
trivial.
destruct H11.
destruct H11.
destruct H11.
destruct H12.
exists x4.
split.
apply preord_trans with x2; trivial.
apply DS_ord_cond.
apply H4.
constructor.
assert (y <= proj1_sig (X x2)).
rewrite H7.
apply H0; trivial.
rewrite <- Heqy2 in H15.
simpl in H15.
assert (proj1_sig (X x2) <= x0).
apply i.
exists x2; trivial.
constructor.
rewrite <- Heqy2 in H16.
simpl in H16.
rewrite <- H13.
apply Rabs_def1.

cut (y0 < x0 + r).
intro.
apply Rlt_minus in H17.
apply Rminus_lt.
replace (y0 - x0 - r) with (y0-(x0+r)); trivial; ring.
apply Rlt_le_trans with (x3 + r).
trivial.
auto with real.

cut (y0 > x0 - r).
intro.
apply Rlt_minus in H17.
apply Rminus_lt.
replace (-r - (y0-x0)) with (x0-r-y0); trivial; ring.
apply Rge_gt_trans with y.
apply Rge_trans with x3; auto with real.
trivial.

exists a.
red; intros.
red; intros.
contradiction Hempty.
exists; exact i.
Qed.

Lemma R_closed_interval_compact: forall a b:R, a <= b ->
compact (SubspaceTopology ([x:point_set RTop | a <= x <= b])).
Proof. hammer_hook "RTopology" "RTopology.R_closed_interval_compact".
intros a b Hbound.
apply net_cluster_point_impl_compact.
intros.
pose (y := fun i:DS_set I => proj1_sig (x i)).
destruct (bounded_real_net_has_cluster_point _ y a b).
intros.
unfold y.
destruct (x i).
destruct i0.
simpl.
trivial.

assert (closed [x:point_set RTop | a <= x <= b]).
replace [x:point_set RTop | a <= x <= b] with
(Intersection
[ x:point_set RTop | a <= x ]
[ x:point_set RTop | x <= b ]) by
(extensionality_ensembles;
do 2 constructor; lra).
apply closed_intersection2.
apply upper_closed_interval_closed.
constructor; red; intros; auto with real.
apply Rle_trans with y0; trivial.
intros.
destruct (total_order_T x1 y0) as [[|]|]; auto with real.
apply lower_closed_interval_closed.
constructor; red; intros; auto with real.
apply Rle_trans with y0; trivial.
intros.
destruct (total_order_T x1 y0) as [[|]|]; auto with real.

assert (Ensembles.In [x:point_set RTop | a <= x <= b] x0).
rewrite <- (closure_fixes_closed _ H1).
apply net_cluster_point_in_closure with y.
destruct H as [i0].
exists i0.
intros.
constructor.
unfold y.
destruct (x j).
simpl.
destruct i.
trivial.
trivial.

exists (exist _ x0 H2).
red; intros.
destruct (subspace_topology_topology _ _ _ H3) as [V].
destruct H5.
red; intros.
assert (Ensembles.In V x0).
rewrite H6 in H4.
destruct H4.
simpl in H4.
trivial.

destruct (H0 V H5 H7 i) as [j []].
exists j.
split; trivial.
rewrite H6.
constructor.
simpl.
exact H9.
Qed.

Lemma R_compact_subset_bounded: forall A:Ensemble (point_set RTop),
compact (SubspaceTopology A) -> bound A.
Proof. hammer_hook "RTopology" "RTopology.R_compact_subset_bounded".
intros.
destruct (H (Im Full_set (fun y => inverse_image (subspace_inc _)
[ x:point_set RTop | y - 1 < x < y + 1 ]))).
- intros U [H0].
subst.
apply subspace_inc_continuous, R_interval_open.

- extensionality_ensembles;
econstructor.
+ now exists (proj1_sig x).
+ do 2 constructor.
destruct x.
simpl.
lra.

- destruct H0, H1.
assert (exists a:R, forall S:Ensemble (point_set (SubspaceTopology A)),
forall b:point_set (SubspaceTopology A),
Ensembles.In x S -> Ensembles.In S b -> proj1_sig b < a).
clear H2.
induction H0.
exists 0.
intros.
destruct H0.
destruct IHFinite.
cut (Included A0 (Add A0 x)); auto with sets.
assert (Ensembles.In (Add A0 x) x).
right.
constructor.
apply H1 in H4.
destruct H4.
exists (Rmax x0 (x+1)).
intros.
destruct H6.
apply Rlt_le_trans with x0.
apply H3 with x1; trivial.
unfold Rmax.
destruct Rle_dec; auto with real.
destruct H6.
rewrite H5 in H7.
destruct H7.
destruct H6.
apply Rlt_le_trans with (x+1).
apply H6.
unfold Rmax; destruct Rle_dec; auto with real.

destruct H3 as [a].
exists a.
red; intros.
assert (Ensembles.In (FamilyUnion x)
(exist (fun x:R => Ensembles.In A x) x0 H4)).
rewrite H2; constructor.
inversion H5.
pose proof (H3 _ _ H6 H7).
simpl in H9.
auto with real.
Qed.

Lemma Ropp_continuous: continuous Ropp (X:=RTop) (Y:=RTop).
Proof. hammer_hook "RTopology" "RTopology.Ropp_continuous".
apply pointwise_continuity.
intro.
apply metric_space_fun_continuity with R_metric R_metric;
try apply RTop_metrization.
intros.
exists eps.
split; trivial.
intros.
unfold R_metric.
replace (-x' - -x) with (x-x'); try ring.
rewrite Rabs_minus_sym; trivial.
Qed.

Lemma R_connected: connected RTop.
Proof. hammer_hook "RTopology" "RTopology.R_connected".
cut (forall S:Ensemble (point_set RTop),
clopen S -> Ensembles.In S 0 -> S = Full_set).
intro.
red; intros.
destruct (classic (Ensembles.In S 0)).
right.
apply H; trivial.
left.
assert (Complement S = Full_set).
apply H; trivial.
destruct H0; split; trivial.
red; now rewrite Complement_Complement.
rewrite <- (Complement_Complement _ S), H2.
now extensionality_ensembles.

cut (forall S:Ensemble (point_set RTop),
clopen S -> Ensembles.In S 0 -> forall x:R, x > 0 ->
Ensembles.In S x).
intro.
assert (forall S:Ensemble (point_set RTop),
clopen S -> Ensembles.In S 0 -> forall x:R, x < 0 ->
Ensembles.In S x).
intros.
pose (T := inverse_image Ropp S).

assert (Ensembles.In T (-x)).
apply H.
destruct H0; split.
apply Ropp_continuous; trivial.
red.
subst T.
rewrite <- inverse_image_complement.
apply Ropp_continuous; trivial.
constructor.
replace (-0) with 0; trivial; ring.
cut (0 < -x); auto with real.
destruct H3.
rewrite Ropp_involutive in H3; trivial.

intros.
extensionality_ensembles.
constructor.
destruct (total_order_T x 0) as [[|]|].
now apply H0.
congruence.
now apply H.

intros.
apply NNPP; intro.
pose (T := [ y:R | forall z:R, 0 <= z <= y -> Ensembles.In S z ]).
assert (Ensembles.In T 0).
constructor.
intros.
assert (z = 0).
destruct H3; auto with real.
rewrite H4; trivial.

destruct (sup T).
exists x.
red; intros.
cut (~ x0>x).
apply Rnot_lt_le; auto with real.
intro.
destruct H4.
apply H2.
apply H4.
split; auto with real.
exists 0.
exact H3.

assert (0 <= x0).
apply i.
exact H3.

destruct (RTop_metrization x0).
assert (Ensembles.In S x0).
rewrite <- (closure_fixes_closed S); try apply H.
apply meets_every_open_neighborhood_impl_closure.
intros.
destruct (open_neighborhood_basis_cond U).
split; trivial.
destruct H7.
destruct H7.
destruct (lub_approx _ _ r i).
trivial.
destruct H9.
exists (Rmax x1 0).
constructor.
unfold Rmax.
destruct Rle_dec.
trivial.
apply H9.
auto with real.

apply H8.
constructor.
unfold Rmax.
destruct Rle_dec.
unfold R_metric.
rewrite Rabs_minus_sym.
replace (x0-0) with x0; try ring.
apply Rabs_def1.
apply Rminus_lt.
destruct H10.
apply Rlt_le_trans with x1; trivial.
apply Rlt_le_trans with 0; auto with real.

apply Rabs_def1.
apply Rle_lt_trans with 0; auto with real.
destruct H10.
apply Rle_minus; trivial.
destruct H10.
apply Rminus_lt.
apply Rlt_minus in H10.
replace (-r - (x1-x0)) with (x0-r-x1); trivial; ring.

destruct (open_neighborhood_basis_cond S).
split; trivial.
apply H.
destruct H6.
destruct H6.

destruct (lub_approx _ _ r i).
trivial.
destruct H8.

assert (Ensembles.In T (x0+r/2)).
constructor.
intros.
destruct H10.
destruct (total_order_T z x1) as [[|]|].
apply H8.
split; auto with real.
apply H8.
split; auto with real.
apply H7.
constructor.
apply Rabs_def1.
apply Rle_lt_trans with (r/2).
apply Rminus_le.
apply Rle_minus in H11.
replace (z-x0-r/2) with (z-(x0+r/2)); trivial; ring.
apply Rminus_gt.
replace (r-r/2) with (r/2); try field.
apply Rmult_gt_0_compat; auto with real.
auto with *.
apply Rlt_trans with (x1 - x0).
destruct H9.
apply Rlt_minus in H9.
apply Rminus_lt.
replace (-r - (x1-x0)) with (x0-r-x1); trivial; ring.
cut (x1<z); trivial.
intro.
unfold Rminus.
auto with real.

assert (x0 + r/2 <= x0).
apply i.
exact H10.

absurd (x0 + r/2 > x0).
apply Rge_not_gt; auto with real.
apply Rminus_gt.
ring_simplify.
apply Rmult_gt_0_compat; auto with real.
apply Rinv_0_lt_compat.
auto with real.
Qed.

Lemma R_cauchy_sequence_bounded: forall x:nat->R,
cauchy R_metric x -> bound (Im Full_set x).
Proof. hammer_hook "RTopology" "RTopology.R_cauchy_sequence_bounded".
intros.
destruct (H 1) as [N].
red; auto with real.
assert (exists y:R, forall n:nat, (n<N)%nat -> x n <= y).
clear H0; induction N.
exists 0.
intros.
contradict H0.
auto with arith.
destruct IHN as [y].
exists (Rmax y (x N)).
intros.
apply lt_n_Sm_le in H1.
destruct (le_lt_or_eq _ _ H1).
apply Rle_trans with y.
apply H0; trivial.
apply Rmax_l.
rewrite H2.
apply Rmax_r.

destruct H1 as [y].
exists (Rmax y (x N + 1)).
red; intros.
destruct H2 as [n].
rewrite H3; clear y0 H3.
destruct (le_or_lt N n).
apply Rle_trans with (x N + 1).
assert (R_metric (x n) (x N) < 1).
apply H0; auto with arith.
apply Rabs_def2 in H4.
destruct H4.
lra.
apply Rmax_r.
apply Rle_trans with y; auto.
apply Rmax_l.
Qed.

Lemma R_cauchy_sequence_lower_bound: forall x:nat->R,
cauchy R_metric x -> lower_bound (Im Full_set x).
Proof. hammer_hook "RTopology" "RTopology.R_cauchy_sequence_lower_bound".
intros.
assert (cauchy R_metric (fun n:nat => - x n)).
red; intros.
destruct (H eps H0) as [N].
exists N.
intros.
replace (R_metric (- x m) (- x n)) with (R_metric (x m) (x n)).
now apply H1.
unfold R_metric.
replace (x n - x m) with (- (- x n - - x m)) by ring.
apply Rabs_Ropp.
destruct (R_cauchy_sequence_bounded _ H0) as [m].
exists (-m).
red; intros.
cut (-x0 <= m).
intros; lra.
apply H1.
destruct H2 as [n].
exists n; trivial.
now f_equal.
Qed.

Lemma R_metric_complete: complete R_metric R_metric_is_metric.
Proof. hammer_hook "RTopology" "RTopology.R_metric_complete".
red; intros.
destruct (R_cauchy_sequence_bounded _ H) as [b].
destruct (R_cauchy_sequence_lower_bound _ H) as [a].
destruct (bounded_real_net_has_cluster_point nat_DS x a b) as [x0].
intros; split; [ cut (x i >= a); auto with real; apply H1 | apply H0 ];
exists i; trivial; constructor.
exists x0.
apply cauchy_sequence_with_cluster_point_converges; trivial.
apply metric_space_net_cluster_point with R_metric;
try apply MetricTopology_metrizable.
intros.
apply metric_space_net_cluster_point_converse with RTop; trivial.
apply RTop_metrization.
Qed.

Lemma countable_union2
{X : Type}
{U V : Ensemble X} :
Countable U ->
Countable V ->
Countable (Union U V).
Proof. hammer_hook "RTopology" "RTopology.countable_union2".
intros Hf Hg.
replace (Union U V) with (IndexedUnion (fun b : bool => if b then U else V)).
- apply countable_union.
+ apply (intro_nat_injection _ (fun b : bool => if b then 1 else 0)%nat).
now intros [|] [|] eq.
+ now intros [|].
- extensionality_ensembles.
+ destruct a;
now (left + right).
+ now apply indexed_union_intro with true.
+ now apply indexed_union_intro with false.
Qed.

Lemma RTop_second_countable : second_countable RTop.
Proof. hammer_hook "RTopology" "RTopology.RTop_second_countable".
apply intro_ctbl_basis with
(finite_intersections (Union
(ImageFamily (fun q => [r : R | r < Q2R q]))
(ImageFamily (fun q => [r : R | r > Q2R q])))).
- constructor.
+ intros S H.
induction H.
* apply open_full.
* destruct H as [S [[q Hq] H]| S [[q Hq] H]];
subst.
apply R_lower_beam_open.
apply R_upper_beam_open.
* now apply (@open_intersection2 RTop).
+ intros r U H1 H2.
assert (neighborhood U r) as H by now exists U.
apply RTop_neighborhood_is_neighbourhood in H.
destruct H as [[d ?] H],
(rationals_dense_in_reals (r - d) r) as [p ?],
(rationals_dense_in_reals r (r + d)) as [q ?];
exists (Intersection [x : R | x > Q2R p] [x : R | x < Q2R q]) + lra.
repeat split;
simpl; try lra.
* do 2 constructor;
[ right | left ];
repeat econstructor.
* intros ? [y [?] [?]].
apply H, Rabs_def1;
simpl; lra.
- apply finite_intersections_countable, countable_union2;
now apply countable_img, countable_type_ensemble, Q_countable.
Qed.

Lemma RTop_separable: separable RTop.
Proof. hammer_hook "RTopology" "RTopology.RTop_separable".
apply second_countable_impl_separable, RTop_second_countable.
Qed.


(* These proofs are normal: no further reduction is possible                    *)

Definition L1 (X:Prop)   : X -> X      := fun x => x.
Definition L2 (X Y:Prop) : X -> Y -> X := fun x y => x.
Definition L3 (X Y:Prop) : X -> Y -> Y := fun x y => y.

Definition L4 (X Y Z:Prop) : (X -> Y -> Z) -> (Y -> X -> Z) := fun f y x => f x y.
Definition L5 (X Y:Prop) : X -> Y -> X /\ Y := fun x y => conj x y.

Definition L6 (X Y:Prop) : X /\ Y -> X := fun p => match p with conj x y => x end.
Definition L7 (X Y:Prop) : X /\ Y -> Y := fun p => match p with conj x y => y end.
Definition L8 (X Y:Prop) : X /\ Y -> Y /\ X := fun p => match p with conj x y => conj y x end.
Definition L9 (X Y:Prop) : X -> X \/ Y := @or_introl X Y.
Definition L10 (X Y:Prop): Y -> X \/ Y := @or_intror X Y.
Definition L11 (X Y:Prop): X \/ Y -> Y \/ X := fun p =>
    match p with
    | or_introl x => or_intror x
    | or_intror y => or_introl y
    end.

(* Nested pattern matching is a notational convenience and can be desugared     *)
Definition L12 (X Y Z:Prop): (X /\ Y) /\ Z -> X /\ (Y /\ Z) := fun p =>
    match p with
    | conj (conj x y) z => conj x (conj y z)
    end.

Definition L13 (X Y Z:Prop): (X /\ Y) /\ Z -> X /\ (Y /\ Z) := fun p =>
    match p with
    | conj xy z =>
        match xy with
        | conj x y => conj x (conj y z)
        end
    end.

Definition L14 (X Y:Prop) : X /\ Y <-> Y /\ X := conj
    (fun p => match p with conj x y => conj y x end)
    (fun p => match p with conj y x => conj x y end).

Definition L15 (X Y Z:Prop) : X /\ (Y /\ Z) <-> (X /\ Y) /\ Z := conj
    (fun p => match p with conj x (conj y z) => conj (conj x y) z end)
    (fun p => match p with conj (conj x y) z => conj x (conj y z) end).

Definition L16 (X Y Z:Prop) : X /\ (Y \/ Z) <-> X /\ Y \/ X /\ Z := conj
    (fun p =>
        match p with conj x yz =>
            match yz with
            | or_introl y   => or_introl (conj x y)
            | or_intror z   => or_intror (conj x z)
            end
        end)
    (fun p =>
        match p with
        | or_introl (conj x y)  => conj x (or_introl y)
        | or_intror (conj x z)  => conj x (or_intror z)
        end).

Definition L17 (X Y:Prop) : X /\ (X \/ Y) <-> X := conj
    (fun p => match p with conj x _ => x end)
    (fun x => conj x (or_introl x)).

Definition L18 (X Y:Prop) : X \/ Y <-> Y \/ X := conj
    (fun p => match p with
        | or_introl x   => or_intror x
        | or_intror y   => or_introl y
        end)
    (fun p => match p with
        | or_introl y   => or_intror y
        | or_intror x   => or_introl x
        end).

Definition L19 (X Y Z:Prop) : X \/ (Y \/ Z) <-> (X \/ Y) \/ Z := conj
    (fun p =>
        match p with
        | or_introl x   => or_introl (or_introl x)
        | or_intror q   =>
            match q with
            | or_introl y   => or_introl (or_intror y)
            | or_intror z   => or_intror z
            end
        end)
    (fun p =>
        match p with
        | or_introl q =>
            match q with
            | or_introl x   => or_introl x
            | or_intror y   => or_intror (or_introl y)
            end
        | or_intror z       => or_intror (or_intror z)
        end).

Definition L20 (X Y Z:Prop) : X \/ (Y /\ Z) <-> (X \/ Y) /\ (X \/ Z) := conj
    (fun p => match p with
        | or_introl x           => conj (or_introl x) (or_introl x)
        | or_intror (conj y z)  => conj (or_intror y) (or_intror z)
        end)
    (fun p =>
        match p with conj py pz =>
            match py with
            | or_introl x   => or_introl x
            | or_intror y   =>
                match pz with
                | or_introl x => or_introl x
                | or_intror z => or_intror (conj y z)
                end
            end
        end).

Definition L21 (X Y:Prop) : X \/ (X /\ Y) <-> X := conj
    (fun p  =>
        match p with
        | or_introl x           => x
        | or_intror (conj x y)  => x
        end)
    (fun x => or_introl x).

Definition L22 (X:Prop) : X <-> X := conj
    (fun x => x)
    (fun x => x).

Definition L23 (X Y:Prop) : X <-> Y -> Y <-> X :=
    fun p => match p with conj xy yx => conj yx xy end.

Definition L24 (X Y Z:Prop) : X <-> Y -> Y <-> Z -> X <-> Z :=
    fun p q =>
        match p with conj xy yx =>
            match q with conj yz zy => conj
                (fun x => yz (xy x))
                (fun z => yx (zy z))
            end
        end.

Definition L25 (X X' Y Y':Prop) : X <-> X' -> Y <-> Y' -> X /\ Y <-> X' /\ Y' :=
    fun p q =>
        match p with
            conj xx' x'x =>
                match q with
                    conj yy' y'y => conj
                        (fun r =>
                            match r with
                                conj x y    => conj (xx' x) (yy' y)
                            end)
                        (fun r =>
                            match r with
                                conj x' y'  => conj (x'x x') (y'y y')
                            end)
                end
        end.

Definition L26 (X X' Y Y':Prop) : X <-> X' -> Y <-> Y' -> X \/ Y <-> X' \/ Y' :=
    fun p q =>
        match p with
            conj xx' x'x =>
                match q with
                    conj yy' y'y => conj
                        (fun r =>
                            match r with
                            | or_introl x => or_introl (xx' x)
                            | or_intror y => or_intror (yy' y)
                            end)
                        (fun r =>
                            match r with
                            | or_introl x' => or_introl (x'x x')
                            | or_intror y' => or_intror (y'y y')
                            end)
                end
        end.

Definition L27 (X X' Y Y':Prop) : X <-> X' -> Y <-> Y' -> (X -> Y) <-> (X' -> Y') :=
    fun p q =>
        match p with
            conj xx' x'x =>
                match q with
                    conj yy' y'y => conj
                        (fun r x' => yy' (r (x'x x')))
                        (fun r x  => y'y (r (xx' x )))
                end
        end.


Require Import Coq.Structures.Orders.
Require Import Coq.micromega.Lia.
Require Import Coq.Bool.Bool.
Require Import Coq.Sorting.Mergesort.
Require Export Coq.Lists.List.
Require Export Coq.ZArith.ZArith.
Export ListNotations.

Global Set Printing Width 1000.
Global Open Scope Z_scope.
Global Open Scope nat_scope.
Global Open Scope list_scope.

(** divisions should be roughly:
- The [Sanity] tests should be just enough to ensure that the code compiles and runs.
- All [SuperFast] tests in a file should finish in under 10 seconds total
- The [Fast] test files should take about a minute each
- The [Medium] tests should go up to about a minute each
- The [Slow] tests should go up to about 10 minutes each
- The [VerySlow] tests may take longer than 10 minutes each *)

Inductive size := Sanity | SuperFast | Fast | Medium | Slow | VerySlow.

Definition nat_of_size (sz : size) : nat
  := match sz with
     | Sanity => 0
     | SuperFast => 1
     | Fast => 2
     | Medium => 3
     | Slow => 4
     | VerySlow => 5
     end%nat.

Definition smaller_sizes (sz : size) : list size
  := match sz with
     | Sanity => []
     | SuperFast => [Sanity]
     | Fast => [Sanity; SuperFast]
     | Medium => [Sanity; SuperFast; Fast]
     | Slow => [Sanity; SuperFast; Fast; Medium]
     | VerySlow => [Sanity; SuperFast; Fast; Medium; Slow]
     end.

Definition size_pred (sz : size) : option size
  := match sz with
     | Sanity => None
     | SuperFast => Some Sanity
     | Fast => Some SuperFast
     | Medium => Some Fast
     | Slow => Some Medium
     | VerySlow => Some Slow
     end.

Fixpoint uniquify {T} (T_beq : T -> T -> bool) (ls : list T) : list T
  := match ls with
     | nil => nil
     | cons x xs
       => x :: filter (fun y => negb (T_beq x y)) (uniquify T_beq xs)
     end.

Definition remove_smaller_args_of_size {T} (T_beq : T -> T -> bool) (sz : size)
           (args_of_size : size -> list T)
  : list T
  := let args := uniquify T_beq (args_of_size sz) in
     let smaller_args := flat_map args_of_size (smaller_sizes sz) in
     filter (fun v => negb (existsb (T_beq v) smaller_args)) args.

Module NatProdOrder <: TotalLeBool.
  Definition t := (nat * nat)%type.
  Definition t_to_Z (v : t) : Z := (Z.of_nat (fst v) * Z.of_nat (snd v))%Z.
  Definition ltb (x y : t) : bool
    := (t_to_Z x <? t_to_Z y)%Z
       || (((t_to_Z x =? t_to_Z y)%Z)
             && ((fst x <? fst y)
                 || ((fst x =? fst y) && (snd x <? snd y)))).
  Definition leb (x y : t) : bool
    := ltb x y || ((fst x =? fst y) && (snd x =? snd y)).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Nat.eqb_eq
                 | rewrite !Z.eqb_eq
                 | rewrite !Z.ltb_lt
                 | rewrite !Nat.ltb_lt ].
    destruct (Z.lt_total (t_to_Z a1) (t_to_Z a2)) as [?|[?|?]];
      try solve [ auto ]; [].
    destruct (Nat.lt_total (fst a1) (fst a2)) as [?|[?|?]];
      try solve [ auto 6 ]; [].
    destruct (Nat.lt_total (snd a1) (snd a2)) as [?|[?|?]];
      solve [ auto 7 ].
  Qed.
End NatProdOrder.

Module NatProdSort := Sort NatProdOrder.
Notation sort_by_prod := NatProdSort.sort.

Module NatFstOrder <: TotalLeBool.
  Definition t := (nat * nat)%type.
  Definition ltb (x y : t) : bool
    := (fst x <? fst y)
       || ((fst x =? fst y)
             && (snd x <? snd y)).
  Definition leb (x y : t) : bool
    := ltb x y || ((fst x =? fst y) && (snd x =? snd y)).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Nat.eqb_eq
                 | rewrite !Nat.ltb_lt ].
    destruct (Nat.lt_total (fst a1) (fst a2)) as [?|[?|?]];
      try solve [ auto 6 ]; [].
    destruct (Nat.lt_total (snd a1) (snd a2)) as [?|[?|?]];
      solve [ auto 7 ].
  Qed.
End NatFstOrder.

Module NatFstSort := Sort NatFstOrder.
Notation sort_by_fst := NatFstSort.sort.

Module ZProdOrder <: TotalLeBool.
  Local Open Scope Z_scope.
  Definition t := (Z * Z)%type.
  Definition t_to_Z (v : t) : Z := (fst v * snd v)%Z.
  Definition ltb (x y : t) : bool
    := (t_to_Z x <? t_to_Z y)%Z
       || (((t_to_Z x =? t_to_Z y)%Z)
             && ((fst x <? fst y)
                 || ((fst x =? fst y) && (snd x <? snd y)))).
  Definition leb (x y : t) : bool
    := ltb x y || ((fst x =? fst y) && (snd x =? snd y)).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Z.eqb_eq
                 | rewrite !Z.ltb_lt
                 | rewrite !Z.ltb_lt ].
    destruct (Z.lt_total (t_to_Z a1) (t_to_Z a2)) as [?|[?|?]];
      try solve [ auto ]; [].
    destruct (Z.lt_total (fst a1) (fst a2)) as [?|[?|?]];
      try solve [ auto 6 ]; [].
    destruct (Z.lt_total (snd a1) (snd a2)) as [?|[?|?]];
      solve [ auto 7 ].
  Qed.
End ZProdOrder.

Module ZProdSort := Sort ZProdOrder.
Notation Zsort_by_prod := ZProdSort.sort.

Module ZFstOrder <: TotalLeBool.
  Local Open Scope Z_scope.
  Definition t := (Z * Z)%type.
  Definition ltb (x y : t) : bool
    := (fst x <? fst y)
       || ((fst x =? fst y)
             && (snd x <? snd y)).
  Definition leb (x y : t) : bool
    := ltb x y || ((fst x =? fst y) && (snd x =? snd y)).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Z.eqb_eq
                 | rewrite !Z.ltb_lt ].
    destruct (Z.lt_total (fst a1) (fst a2)) as [?|[?|?]];
      try solve [ auto 6 ]; [].
    destruct (Z.lt_total (snd a1) (snd a2)) as [?|[?|?]];
      solve [ auto 7 ].
  Qed.
End ZFstOrder.

Module ZFstSort := Sort ZFstOrder.
Notation Zsort_by_fst := ZFstSort.sort.

Module ZOrder <: TotalLeBool.
  Local Open Scope Z_scope.
  Definition t := Z.
  Definition ltb := Z.ltb.
  Definition leb := Z.leb.
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    cbv [leb ltb]; intros a1 a2.
    repeat first [ rewrite !Bool.andb_true_iff
                 | rewrite !Bool.orb_true_iff
                 | rewrite !Z.eqb_eq
                 | rewrite !Z.ltb_lt
                 | rewrite !Z.leb_le ].
    lia.
  Qed.
End ZOrder.

Module ZSort := Sort ZOrder.

Existing Class reflect.
Notation reflect_rel R1 R2 := (forall x y, reflect (R1 x y) (R2 x y)).

Lemma reflect_of_beq {beq : bool} {R : Prop}
      (bp : beq = true -> R)
      (pb : R -> beq = true)
  : reflect R beq.
Proof.
  destruct beq; constructor; intuition (discriminate || auto).
Qed.

Definition reflect_rel_of_beq {T} {beq : T -> T -> bool} {R : T -> T -> Prop}
      (bp : forall x y, beq x y = true -> R x y)
      (pb : forall x y, R x y -> beq x y = true)
  : reflect_rel R beq
  := fun x y => reflect_of_beq (bp x y) (pb x y).

Definition reflect_rel_of_beq_iff {T} {beq : T -> T -> bool} {R : T -> T -> Prop}
      (bp : forall x y, beq x y = true <-> R x y)
  : reflect_rel R beq
  := reflect_rel_of_beq (fun x y => proj1 (bp x y)) (fun x y => proj2 (bp x y)).

Global Instance reflect_eq_nat : reflect_rel (@eq nat) Nat.eqb
  := reflect_rel_of_beq_iff Nat.eqb_eq.

Global Instance reflect_eq_Z : reflect_rel (@eq Z) Z.eqb
  := reflect_rel_of_beq_iff Z.eqb_eq.

Class has_sub T := sub : T -> T -> T.
Global Instance: has_sub nat := Nat.sub.
Global Instance: has_sub Z := Z.sub.

Class has_succ T := succ : T -> T.
Global Instance: has_succ nat := S.
Global Instance: has_succ Z := Z.succ.

Class has_zero T := zero : T.
Global Instance: has_zero nat := O.
Global Instance: has_zero Z := Z0.

Class has_sort T := sort : list T -> list T.
Global Instance: has_sort nat := NatSort.sort.
Global Instance: has_sort Z := ZSort.sort.

Definition remove_smaller_args_of_size_by_reflect
           {T} {T_beq : T -> T -> bool}
           {T_reflect : reflect_rel (@eq T) T_beq}
           (sz : size)
           (args_of_size : size -> list T)
  : list T
  := let args := uniquify T_beq (args_of_size sz) in
     let smaller_args := flat_map args_of_size (smaller_sizes sz) in
     filter (fun v => negb (existsb (T_beq v) smaller_args)) args.

Ltac default_describe_goal x :=
  idtac "Params: n=" x.

Ltac runtests args_of_size describe_goal mkgoal redgoal time_solve_goal sz :=
  let args := (eval vm_compute in (remove_smaller_args_of_size_by_reflect sz args_of_size)) in
  let rec iter ls :=
      lazymatch ls with
      | [] => idtac
      | ?x :: ?xs
        => describe_goal x;
           let T := mkgoal x in
           try (solve [ assert T by (redgoal x; once (time_solve_goal x + fail 2 "time_solve_goal failed!")) ]; []);
           iter xs
      end in
  iter args.

Ltac step_goal_from_to_constr step_goal cur_n target_n G :=
  let test := match constr:(Set) with
              | _ => let __ := match constr:(Set) with _ => constr_eq cur_n target_n end in
                     true
              | _ => false
              end in
  lazymatch test with
  | true => G
  | false
    => let next_n := (eval cbv in (succ cur_n)) in
       let G := step_goal next_n G in
       step_goal_from_to_constr step_goal next_n target_n G
  end.

Ltac runtests_step_arg_constr args_of_size describe_goal step_goal redgoal_constr redgoal time_solve_goal sz G extra_args :=
  let args := (eval vm_compute in (remove_smaller_args_of_size_by_reflect sz args_of_size)) in
  let T := lazymatch type of args with list ?T => T end in
  let rec iter cur ls G :=
      lazymatch ls with
      | [] => idtac
      | ?x :: ?xs
        => let G := step_goal_from_to_constr step_goal cur x G in
           let G := redgoal_constr x G in
           describe_goal x;
           try (solve [ redgoal x; once (time_solve_goal x G extra_args + fail 2 "time_solve_goal failed!") ]; []);
           iter x xs G
      end in
  let zero := (eval cbv in (@zero T _)) in
  iter zero args G.

Ltac runtests_step_constr args_of_size describe_goal step_goal redgoal_constr time_solve_goal sz G :=
  runtests_step_arg_constr args_of_size describe_goal step_goal redgoal_constr ltac:(fun _ => idtac) ltac:(fun n G args => time_solve_goal n G) sz G ().

Ltac constr_run_tac f x :=
  lazymatch goal with
  | _ => f x
  end.

Ltac runtests_step args_of_size describe_goal step_goal redgoal time_solve_goal sz :=
  runtests_step_arg_constr args_of_size describe_goal ltac:(fun n G => constr_run_tac step_goal n) ltac:(fun _ G => G) redgoal ltac:(fun n G args => time_solve_goal n) sz () ().


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
Require Import maps.
Require Import smallstep.

(*
       t ::= x variable
           | \x:T1.t2 abstraction
           | t1 t2 application
           | tru constant true
           | fls constant false
           | test t1 then t2 else t3 conditional

 *)

Module STLC.

Inductive ty : Type :=
  | Bool : ty
  | Arrow : ty -> ty -> ty.

Inductive tm : Type :=
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm.

Open Scope string_scope.

Definition x := "x".
Definition y := "y".
Definition z := "z".

Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Notation idB :=
  (abs x Bool (var x)).

Notation idBB :=
  (abs x (Arrow Bool Bool) (var x)).

Notation idBBBB :=
  (abs x (Arrow (Arrow Bool Bool)
                      (Arrow Bool Bool))
    (var x)).

Notation k := (abs x Bool (abs y Bool (var x))).

Notation notB := (abs x Bool (test (var x) fls tru)).

(*
簡約は関数抽象で止まる。
一般的な関数型言語と同じ。適用する時に評価される
Coqは逆。関数抽象の段階で評価する
*)
Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (abs x T t)
  | v_tru :
      value tru
  | v_fls :
      value fls.

Hint Constructors value.

(*
       [x:=s]x = s
       [x:=s]y = y if x <> y
       [x:=s](\x:T11. t12) = \x:T11. t12
       [x:=s](\y:T11. t12) = \y:T11. [x:=s]t12 if x <> y
       [x:=s](t1 t2) = ([x:=s]t1) ([x:=s]t2)
       [x:=s]tru = tru
       [x:=s]fls = fls
       [x:=s](test t1 then t2 else t3) =
              test [x:=s]t1 then [x:=s]t2 else [x:=s]t3

 *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | var x' =>
      if eqb_string x x' then s else t
  | abs x' T t1 =>
      abs x' T (if eqb_string x x' then t1 else ([x:=s] t1))
  | app t1 t2 =>
      app ([x:=s] t1) ([x:=s] t2)
  | tru =>
      tru
  | fls =>
      fls
  | test t1 t2 t3 =>
      test ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

Inductive substi (s : tm) (x : string) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (var x) s
  | s_var2 : forall y: string,
      x <> y -> substi s x (var y) (var y)
  | s_abs1 : forall T t,
      substi s x (abs x T t) (abs x T t)
  | s_abs2 : forall y T t t',
      x <> y -> substi s x t t' ->
      substi s x (abs y T t) (abs y T t')
  | s_app : forall t1 t2 t1' t2',
      substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x (app t1 t2) (app t1' t2')
  | s_tru : substi s x tru tru
  | s_fls : substi s x fls fls
  | s_test : forall t1 t1' t2 t2' t3 t3',
      substi s x t1 t1' ->
      substi s x t2 t2' ->
      substi s x t3 t3' ->
      substi s x (test t1 t2 t3) (test t1' t2' t3').

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
  split; generalize dependent t'.
  - induction t.
    + unfold subst. intros. destruct (eqb_string x0 s0) eqn: IH; subst.
      apply eqb_string_true_iff in IH; subst.  apply s_var1. apply s_var2. apply eqb_string_false_iff; assumption.
    + intros.
      replace ([x0 := s]app t1 t2) with (app ([x0 := s]t1) ([x0 := s] t2)) in H by reflexivity.
      rewrite <- H. constructor. apply IHt1. reflexivity. apply IHt2. reflexivity.
    + intros. rewrite <- H.  destruct (eqb_string x0 s0) eqn: IH.
      unfold subst. rewrite IH. apply eqb_string_true_iff in IH. rewrite IH. apply s_abs1.
      unfold subst. rewrite IH. apply eqb_string_false_iff in IH. constructor. assumption. apply IHt. reflexivity.
    + intros. rewrite <- H. unfold subst. apply s_tru.
    + intros. rewrite <- H. unfold subst. apply s_fls.
    + intros. rewrite <- H. apply s_test. apply IHt1. reflexivity. apply IHt2. reflexivity. apply IHt3. reflexivity.
  - induction t; intros.
    + inversion H. subst. simpl. rewrite <- eqb_string_refl. reflexivity.
      subst. simpl. apply eqb_string_false_iff in H1. rewrite H1. reflexivity.
    + inversion H; subst. simpl. apply IHt1 in H2. apply IHt2 in H4. subst. reflexivity.
    + inversion H. simpl. subst. rewrite <- eqb_string_refl. reflexivity.
      simpl. subst. apply eqb_string_false_iff in H4. rewrite H4. apply IHt in H5. rewrite H5. reflexivity.
    + inversion H. reflexivity.
    + inversion H; reflexivity.
    + inversion H; subst. apply IHt1 in H3. apply IHt2 in H5. apply IHt3 in H6. subst. reflexivity.
Qed.

(*
ベータ簡約
 *)
(*
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 --> [x:=v2]t12

                              t1 --> t1'
                           ----------------                           (ST_App1)
                           t1 t2 --> t1' t2

                              value v1
                              t2 --> t2'
                           ----------------                           (ST_App2)
                           v1 t2 --> v1 t2'

     -------------------------------------------------------------------------------

                    --------------------------------               (ST_TestTru)
                    (test tru then t1 else t2) --> t1

                    ---------------------------------              (ST_TestFls)
                    (test fls then t1 else t2) --> t2

                             t1 --> t1'
      --------------------------------------------------------     (ST_Test)
      (test t1 then t2 else t3) --> (test t1' then t2 else t3)
 *)

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (app (abs x T t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         app t1 t2 --> app t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         app v1 t2 --> app v1 t2'
  | ST_TestTru : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFls : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)

where "t1 '-->' t2" := (step t1 t2).

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Lemma step_example1 :
  (app idBB idB) -->* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl. Qed.

Lemma step_example2 :
  (app idBB (app idBB idB)) -->* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl. Qed.

Lemma step_example3 :
  app (app idBB notB) tru -->* fls.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_TestTru. apply multi_refl. Qed.

Lemma step_example4 :
  app idBB (app notB tru) -->* fls.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_TestTru.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl. Qed.

Lemma step_example1' :
  app idBB idB -->* idB.
Proof. normalize. Qed.

Lemma step_example2' :
  app idBB (app idBB idB) -->* idB.
Proof. normalize. Qed.

Lemma step_example3' :
  app (app idBB notB) tru -->* fls.
Proof. normalize. Qed.

Lemma step_example4' :
  app idBB (app notB tru) -->* fls.
Proof. normalize. Qed.

Lemma step_example5 :
       app (app idBBBB idBB) idB
  -->* idB.
Proof. normalize. Qed.

Definition context := partial_map ty.

(*型付け

                              Gamma x = T
                            ----------------                            (T_Var)
                            Gamma |- x \in T

                   (x |-> T11 ; Gamma) |- t12 \in T12
                   ----------------------------------                   (T_Abs)
                    Gamma |- \x:T11.t12 \in T11->T12

                        Gamma |- t1 \in T11->T12
                          Gamma |- t2 \in T11
                         ----------------------                         (T_App)
                         Gamma |- t1 t2 \in T12

                         ---------------------                          (T_Tru)
                         Gamma |- tru \in Bool

                         ---------------------                          (T_Fls)
                         Gamma |- fls \in Bool

       Gamma |- t1 \in Bool    Gamma |- t2 \in T    Gamma |- t3 \in T
       --------------------------------------------------------------   (T_Test)
                  Gamma |- test t1 then t2 else t3 \in T

 *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- var x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      (x |-> T11 ; Gamma) |- t12 \in T12 ->
      Gamma |- abs x T11 t12 \in Arrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in Arrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- app t1 t2 \in T12
  | T_Tru : forall Gamma,
       Gamma |- tru \in Bool
  | T_Fls : forall Gamma,
       Gamma |- fls \in Bool
  | T_Test : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in Bool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- test t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

Example typing_example_1 :
  empty |- abs x Bool (var x) \in Arrow Bool Bool.
Proof.
  apply T_Abs. apply T_Var. reflexivity. Qed.

Example typing_example_1' :
  empty |- abs x Bool (var x) \in Arrow Bool Bool.
Proof. auto. Qed.

Example typing_example_2 :
  empty |-
    (abs x Bool
       (abs y (Arrow Bool Bool)
          (app (var y) (app (var y) (var x))))) \in
    (Arrow Bool (Arrow (Arrow Bool Bool) Bool)).
Proof with auto using update_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

Example typing_example_3 :
  exists T,
    empty |-
      (abs x (Arrow Bool Bool)
         (abs y (Arrow Bool Bool)
            (abs z Bool
               (app (var y) (app (var x) (var z)))))) \in
      T.
Proof with auto.
  exists (Arrow (Arrow Bool Bool) (Arrow (Arrow Bool Bool) (Arrow Bool Bool ) ) ).
  apply T_Abs. apply T_Abs.
  apply T_Abs. eapply T_App. apply T_Var. reflexivity.
  eapply T_App. apply T_Var. reflexivity. apply T_Var. reflexivity.
Qed.

Example typing_nonexample_1 :
  ~ exists T,
      empty |-
        (abs x Bool
            (abs y Bool
               (app (var x) (var y)))) \in
        T.
Proof.
  intros Hc. inversion Hc.
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  inversion H1. Qed.

Lemma no_infinite_nested_type :
  ~ (exists T, exists S, T = Arrow T S).
Proof.
  intros Hc. inversion Hc as [T H]. clear Hc. induction T.
  inversion H. inversion H0.
  inversion H. inversion H0. apply IHT1. exists T2. assumption.
Qed.

Example typing_nonexample_3 :
  (exists S T,
        empty |-
          (abs x S
             (app (var x) (var x))) \in
          T) -> False.
Proof.
 intros Hc. inversion Hc as [S H]. clear Hc.
  inversion H as [T H1]. subst.
  inversion H1. subst. clear H1.
  inversion H6. subst. clear H6.
  inversion H3. subst. clear H3.
  inversion H2. subst. inversion H5. subst. rewrite H2 in H3. inversion H3.
  symmetry in H1. apply no_infinite_nested_type. exists T11. exists T12. assumption.
Qed.

End STLC.