(* Storing finite maps as unbalanced binary trees. *)

From CGT Require Import A1_setup.
Require Import RelationClasses.

(***
Operations on positive numbers
*)

(* Reverse append i to an accumulator. *)
Fixpoint lifo (i acc : positive) :=
  match i with
  | xH => acc
  | xO i' => lifo i' (xO acc)
  | xI i' => lifo i' (xI acc)
  end.

Notation mirror i := (lifo i xH).

(***
:: Unbalanced binary tree ::

In this project we need lookup maps for several purposes such as storing
permutations and storing indexed tables with fast lookups. The most logical way
to do this in Coq is to build a radix-2 lookup tree, since a single iteration
through the key is enough to retrieve an element (a O(n) lookup). Note that the
permutations, vectors, and tables we implement using this datastructure could be
implemented using fixed arrays in a non-functional language, this would make the
whole algorithm significantly faster, but not by orders of magnitude. Also note
that existing Coq libraries such as std++ already provide radix-2 lookup trees,
I just decided to construct them from scratch.
*)
Section Unbalanced_binary_tree.

Variable V : Type.

Inductive fmap := Leaf | Node (val : option V) (fO fI : fmap).

(***
Generic operations
*)

(* Count the number of entries. *)
Fixpoint size (f : fmap) :=
  match f with
  | Leaf => O
  | Node None fO fI => (size fO + size fI)%nat
  | Node (Some v) fO fI => S (size fO + size fI)%nat
  end.

(* Create a map that only maps key to val. *)
Fixpoint create (key : positive) (val : V) :=
  match key with
  | xH => Node (Some val) Leaf Leaf
  | xO k => Node None (create k val) Leaf
  | xI k => Node None Leaf (create k val)
  end.

(* Insert val at key. *)
Fixpoint insert (f : fmap) (key : positive) (val : V) :=
  match f with
  | Leaf => create key val
  | Node v fO fI =>
    match key with
    | xH => Node (Some val) fO fI
    | xO k => Node v (insert fO k val) fI
    | xI k => Node v fO (insert fI k val)
    end
  end.

(* Get the value at key. *)
Fixpoint lookup (f : fmap) (key : positive) :=
  match f with
  | Leaf => None
  | Node val fO fI =>
    match key with
    | xH => val
    | xO k => lookup fO k
    | xI k => lookup fI k
    end
  end.

(* Retrieve all values. *)
Fixpoint values (f : fmap) :=
  match f with
  | Leaf => []
  | Node None fO fI => values fO ++ values fI
  | Node (Some v) fO fI => v :: values fO ++ values fI
  end.

(* Retrieve all entries. *)
Fixpoint entries (f : fmap) (r : positive) :=
  match f with
  | Leaf => []
  | Node None fO fI => entries fO r~0 ++ entries fI r~1
  | Node (Some v) fO fI => (mirror r, v) :: entries fO r~0 ++ entries fI r~1
  end.

(* Apply a transformation to all values. *)
Fixpoint mapval (t : V -> V) (f : fmap) :=
  match f with
  | Leaf => Leaf
  | Node (Some v) fO fI => Node (Some (t v)) (mapval t fO) (mapval t fI)
  | Node None fO fI => Node None (mapval t fO) (mapval t fI)
  end.

End Unbalanced_binary_tree.

Arguments Leaf {_}.
Arguments Node {_}.
Arguments size {_}.
Arguments create {_}.
Arguments insert {_}.
Arguments lookup {_}.
Arguments values {_}.
Arguments entries {_}.
Arguments mapval {_}.

Notation Defined f key := (lookup f key ≠ None).
Notation ffun := (fmap positive).

(***
Function application
*)

Definition apply (f : ffun) i :=
  match lookup f i with
  | Some j => j
  | None => i
  end.

Notation "f ⋅ i" := (apply f i) (at level 5, format "f ⋅ i").
Definition Equivalent f g := ∀i, f⋅i = g⋅i.
Notation "f == g" := (Equivalent f g) (at level 60).

(***
Function composition
*)

(* Apply g after f. The initial input for g must be copied as g0. *)
Fixpoint compose (g0 g f : ffun) {struct f} :=
  let map_apply g f := mapval (apply g) f in
  match f with
  | Leaf => g
  | Node (Some i) fO fI =>
    match g with
    | Leaf => Node (Some g0⋅i) (map_apply g0 fO) (map_apply g0 fI)
    | Node jO gO gI => Node (Some g0⋅i) (compose g0 gO fO) (compose g0 gI fI)
    end
  | Node None fO fI =>
    match g with
    | Leaf => Node None (map_apply g0 fO) (map_apply g0 fI)
    | Node jO gO gI => Node jO (compose g0 gO fO) (compose g0 gI fI)
    end
  end.

Notation "g ∘ f" := (compose g g f) (at level 50).

(***
Function inversion
*)

Definition inv f :=
  fold_left (λ f_inv e, insert f_inv (snd e) (fst e)) (entries f xH) Leaf.

(***
Union of the range of a list of functions.
*)

Definition put i f := insert f i i.
Definition union_range fs := fold_right put Leaf (flat_map values fs).

(***
:: Pruning ::

There are several advantages of pruning (removing identity mappings) trees after
composition. There is a slight advantage for lookups, but more importantly;
future compositions will be faster. The inversion function we define later will
also benefit from pruning. But, this optimization is more tricky than it seems,
because pruning is quite expensive. We have to compare every mapping to its key
path, and, when recursively iterating the tree, we have to keep track of the
position of every node which requires appending bits to the end of a `positive`.

Because we will be working with permutations on the same finite domain, I think
this pruning procedure can be optimized a little by pre-computing the tree of
all identity mappings. Hence I have implemented a sifting function that removes
the mappings that are present in a given sieve. We will have to determine in
practice if pruning actually provides a net speed-up.

Note that pruning is a straightforward method to determine if a given map is an
identity function. This is used in the Sims filter, which is therefore a natural
point for pruning. For theorem proving we use slower pruning (without a sieve)
since it turns every function into a canonical form.
*)

(* A pruned function tree contains no explicit identity mappings. *)
Fixpoint Pruned (r : positive) (f : ffun) :=
  match f with
  | Leaf => True
  | Node i_opt fO fI =>
    Pruned r~0 fO /\
    Pruned r~1 fI /\
    match i_opt with
    | Some i => i ≠ mirror r
    | None => True
    end
  end.

(* Remove identity mappings from f. *)
Fixpoint prune (r : positive) (f : ffun) :=
  let collapse := λ (fO fI : ffun),
    match fO, fI with
    | Leaf, Leaf => Leaf
    | fO', fI' => Node None fO' fI'
    end
  in match f with
  | Leaf => Leaf
  | Node None fO fI => collapse (prune r~0 fO) (prune r~1 fI)
  | Node (Some i) fO fI =>
    if i =? mirror r
    then collapse (prune r~0 fO) (prune r~1 fI)
    else Node (Some i) (prune r~0 fO) (prune r~1 fI)
  end.

(* Remove mappings in f that are also in s. *)
Fixpoint sift (sieve f : ffun) :=
  let collapse := λ (fO fI : ffun),
    match fO, fI with
    | Leaf, Leaf => Leaf
    | fO', fI' => Node None fO' fI'
    end
  in match sieve with
  | Leaf => f
  | Node i_opt sO sI =>
    match f with
    | Leaf => Leaf
    | Node None fO fI => collapse (sift sO fO) (sift sI fI)
    | Node (Some j) fO fI =>
      match i_opt with
      | Some i =>
        if i =? j
        then collapse (sift sO fO) (sift sI fI)
        else Node (Some j) (sift sO fO) (sift sI fI)
      | None => Node (Some j) (sift sO fO) (sift sI fI)
      end
    end
  end.

(* Create identity sieve of depth n. *)
Fixpoint identity_sieve (n : nat) (r : positive) :=
  match n with
  | O => Leaf
  | S m => Node (Some (mirror r)) (identity_sieve m r~0) (identity_sieve m r~1)
  end.

(***
Theorems
*)

Local Ltac fmap_ind f :=
  induction f as [|j_opt fO IHfO fI IHfI]; simpl; intros.

(* Equality is decidable. *)

Theorem fmap_eq_dec {V} :
  (∀v w : V, {v = w} + {v ≠ w}) ->
  ∀f g : fmap V, {f = g} + {f ≠ g}.
Proof.
intros V_dec f; induction f; destruct g; [left|right|right|]; try easy.
destruct (IHf1 g1); [subst|right; intros H; inv H].
destruct (IHf2 g2); [subst|right; intros H; inv H].
destruct val, val0; [|right|right|left]; try easy.
destruct (V_dec v v0); [left; subst; easy|right; intros H; inv H].
Qed.

Definition ffun_eq_dec := fmap_eq_dec Pos.eq_dec.

(* Theorems about lookup. *)

Lemma lookup_create_eq {V} i (v : V) : lookup (create i v) i = Some v.
Proof. induction i; easy. Qed.

Lemma lookup_create_neq {V} i j (v : V) :
  i ≠ j -> lookup (create i v) j = None.
Proof.
revert j; induction i; simpl; intros; destruct j.
all: try easy; apply IHi; congruence.
Qed.

Theorem lookup_insert_eq {V} f i (v : V) :
  lookup (insert f i v) i = Some v.
Proof.
revert i; fmap_ind f.
apply lookup_create_eq.
destruct i; simpl; easy.
Qed.

Theorem lookup_insert_neq {V} f i j (v : V) :
  i ≠ j -> lookup (insert f i v) j = lookup f j.
Proof.
revert i j; fmap_ind f.
apply lookup_create_neq, H.
destruct i, j; simpl; try easy.
apply IHfI; congruence.
apply IHfO; congruence.
Qed.

Theorem lookup_insert {V} f i j (v : V) :
  lookup (insert f i v) j = if i =? j then Some v else lookup f j.
Proof.
destruct (i =? j) eqn:E; [apply Pos.eqb_eq in E|apply Pos.eqb_neq in E].
subst; apply lookup_insert_eq. apply lookup_insert_neq, E.
Qed.

Theorem defined_dec {V} (f : fmap V) i :
  {Defined f i} + {¬Defined f i}.
Proof.
destruct (lookup f i); [left|right]; easy.
Qed.

Theorem defined_before_insert {V} f i j (v : V) :
  Defined f i -> Defined (insert f j v) i.
Proof.
rewrite lookup_insert; destruct (_ =? _); easy.
Qed.

Theorem lookup_mapval_none {V} t (f : fmap V) i :
  lookup f i = None -> lookup (mapval t f) i = None.
Proof.
revert i; fmap_ind f. easy.
destruct i, j_opt as [j|]; simpl; try easy.
all: try apply IHfO; try apply IHfI; easy.
Qed.

Theorem lookup_mapval_some {V} t f i (v : V) :
  lookup f i = Some v -> lookup (mapval t f) i = Some (t v).
Proof.
revert i; fmap_ind f. easy.
destruct j_opt as [j'|], i; simpl; try congruence.
all: try apply IHfO; try apply IHfI; easy.
Qed.

(* Theorems about size. *)

Theorem size_eq_length_values {V} (f : fmap V) :
  size f = length (values f).
Proof.
fmap_ind f. easy. destruct j_opt; simpl;
rewrite IHfO, IHfI, app_length; easy.
Qed.

(* Theorems about values. *)

Theorem in_values_create {V} i (v : V) :
  In v (values (create i v)).
Proof.
induction i; simpl; try rewrite app_nil_r; auto.
Qed.

Theorem in_values_insert {V} f i (v : V) :
  In v (values (insert f i v)).
Proof.
revert f; induction i; destruct f; simpl; auto.
1,3: try rewrite app_nil_r; apply in_values_create.
all: destruct val; try rewrite app_comm_cons; apply in_app_iff; auto.
left; apply in_cons, IHi.
Qed.

Theorem lookup_in_values {V} f i (v : V) :
  lookup f i = Some v -> In v (values f).
Proof.
revert i; fmap_ind f; [easy|intros]. destruct i, j_opt.
all: try rewrite app_comm_cons; apply in_app_iff.
1,2: right; eapply IHfI, H.
1,2: left; try apply in_cons; eapply IHfO, H.
left; inv H; apply in_eq. easy.
Qed.

Theorem in_values_lookup {V} f (v : V) :
  In v (values f) -> ∃i, lookup f i = Some v.
Proof.
fmap_ind f; [easy|destruct j_opt].
inv H. exists 1; easy. rename H0 into H.
all: apply in_app_or in H; destruct H.
all: try apply IHfO in H as [i ?]; try apply IHfI in H as [i ?].
1,3: exists i~0; easy. all: exists i~1; easy.
Qed.

Theorem apply_in_values f i :
  f⋅i ≠ i -> In f⋅i (values f).
Proof.
unfold apply; destruct (lookup f i) eqn:E; [|easy].
intros; eapply lookup_in_values, E.
Qed.

Theorem lookup_after_put f i j :
  lookup f i = Some i -> lookup (put j f) i = Some i.
Proof.
unfold put; rewrite lookup_insert.
destruct (_ =? _) eqn:E; convert_bool; subst; easy.
Qed.

Lemma lookup_fold_right_put range i f :
  In i range -> lookup (fold_right put f range) i = Some i.
Proof.
revert f; simple_ind range. destruct H; subst.
apply lookup_insert_eq. apply lookup_after_put, IHrange, H.
Qed.

Theorem lookup_union_range i f fs :
  In i (values f) -> In f fs -> lookup (union_range fs) i = Some i.
Proof.
intros; apply lookup_fold_right_put.
apply in_flat_map; exists f; easy.
Qed.

(* Theorems about apply and compose. *)

Corollary apply_insert f i j :
  (insert f i j)⋅i = j.
Proof.
unfold apply; rewrite lookup_insert.
rewrite Pos.eqb_refl; reflexivity.
Qed.

Lemma lookup_compose_none g0 g f i :
  lookup f i = None -> lookup (compose g0 g f) i = lookup g i.
Proof.
revert g i; fmap_ind f. easy.
destruct j_opt as [j|], g, i; simpl; try easy.
1,2,5,6: apply lookup_mapval_none, H.
all: try rewrite IHfI; try rewrite IHfO; easy.
Qed.

Lemma lookup_compose_some g0 g f i j :
  lookup f i = Some j -> lookup (compose g0 g f) i = Some g0⋅j.
Proof.
revert g i; fmap_ind f. easy.
destruct j_opt as [j'|], g, i; simpl; try congruence.
all: try apply lookup_mapval_some; try apply IHfO; try apply IHfI; easy.
Qed.

Theorem apply_compose g f i :
  (g ∘ f)⋅i = g⋅(f⋅i).
Proof.
unfold apply; destruct (lookup f i) as [j|] eqn:H.
erewrite lookup_compose_some; easy.
erewrite lookup_compose_none; easy.
Qed.

Corollary compose_assoc f g h :
  (f ∘ g) ∘ h == f ∘ (g ∘ h).
Proof.
intros i; rewrite ?apply_compose; easy.
Qed.

Global Instance fmap_equivalence :
  Equivalence Equivalent.
Proof.
split; try easy. intros f g h Hf Hg i.
etransitivity; [apply Hf|apply Hg].
Qed.

Lemma mapval_apply_leaf f :
  mapval (apply Leaf) f = f.
Proof.
fmap_ind f; [easy|destruct j_opt].
all: rewrite IHfO, IHfI; easy.
Qed.

Theorem leaf_compose f :
  Leaf ∘ f = f.
Proof.
fmap_ind f; [easy|destruct j_opt].
all: rewrite ?mapval_apply_leaf; easy.
Qed.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Bool Psatz.
From Bignums Require Import BigN BigZ.
From Flocq Require Import Raux Digits.

Require Import Basic.
Require Import Generic.
Require Import Generic_proof.
Require Import Specific_sig.

Module BigIntRadix2 <: FloatCarrier.

Definition radix := radix2.
Definition radix_correct := refl_equal Lt.
Definition smantissa_type := BigZ.t.
Definition mantissa_type := BigN.t.
Definition exponent_type := BigZ.t.

Definition MtoZ := BigZ.to_Z.
Definition ZtoM := BigZ.of_Z.
Definition MtoP v := match BigN.to_Z v with Zpos w => w | _ => xH end.
Definition PtoM := BigN.of_pos.
Definition EtoZ := BigZ.to_Z.
Definition ZtoE := BigZ.of_Z.

Definition valid_mantissa v := exists p, BigN.to_Z v = Zpos p.

Definition exponent_zero := 0%bigZ.
Definition exponent_one := 1%bigZ.
Definition exponent_neg := BigZ.opp.
Definition exponent_add := BigZ.add.
Definition exponent_sub := BigZ.sub.
Definition exponent_cmp := BigZ.compare.
Definition mantissa_zero := 0%bigZ.
Definition mantissa_one := 1%bigN.
Definition mantissa_add := BigN.add.
Definition mantissa_sub := BigN.sub.
Definition mantissa_mul := BigN.mul.
Definition mantissa_cmp := BigN.compare.
Definition mantissa_pos := BigZ.Pos.
Definition mantissa_neg := BigZ.Neg.

Definition mantissa_sign m :=
  if BigZ.eqb m 0%bigZ then Mzero
  else
    match m with
    | BigZ.Pos p => Mnumber false p
    | BigZ.Neg p => Mnumber true p
    end.

Definition mantissa_shl m d :=
  BigN.shiftl m (BigZ.to_N d).

Definition mantissa_scale2 (m : mantissa_type) (d : exponent_type) := (m, d).

Definition mantissa_digits m :=
  BigZ.Pos (BigN.Ndigits m - BigN.head0 m)%bigN.

Definition mantissa_even m := BigN.even m.

Definition mantissa_split_div m d pos :=
  let (q, r) := BigN.div_eucl m d in (q,
  if BigN.eqb r 0%bigN then
    match pos with pos_Eq => pos_Eq | _ => pos_Lo end
  else
    match BigN.compare (BigN.shiftl r 1%bigN) d with
    | Lt => pos_Lo
    | Eq => match pos with pos_Eq => pos_Mi | _ => pos_Up end
    | Gt => pos_Up
    end).

Definition mantissa_div :=
  fun m d => mantissa_split_div m d pos_Eq.

(*
Definition mantissa_shr m d pos :=
  mantissa_split_div m (mantissa_shl 1%bigN d) pos.
*)

Definition mantissa_shr m d pos :=
  let dd := BigZ.to_N d in
  (BigN.shiftr m dd,
  let d1 := BigN.pred dd in
  match BigN.compare (BigN.tail0 m) d1 with
  | Gt => match pos with pos_Eq => pos_Eq | _ => pos_Lo end
  | Eq => match pos with pos_Eq => pos_Mi | _ => pos_Up end
  | Lt =>
    if BigN.even (BigN.shiftr m d1) then pos_Lo
    else pos_Up
  end).

(*
Definition mantissa_shr m d pos :=
  let dd := BigZ.to_N d in
  let d1 := BigN.pred dd in
  (BigN.shiftr dd m,
  let p1 := BigN.is_even (BigN.shiftr d1 m) in
  let p2 := BigN.is_even (BigN.shiftr d1 (BigN.pred m)) in
  if p1 then
    if p2 then (* 00 *)
      pos_Lo
    else       (* 01 *)
      match pos with pos_Eq => pos_Eq | _ => pos_Lo end
  else
    if p2 then (* 10 *)
      match pos with pos_Eq => pos_Mi | _ => pos_Up end
    else       (* 11 *)
      pos_Up).
*)

Definition mantissa_shrp m d pos :=
  match pos with
  | pos_Eq =>
        let dd := BigZ.to_N d in
         match BigN.compare (BigN.shiftl m 1) (BigN.shiftl 1 dd) with
        | Eq  => pos_Mi
        |  _  => pos_Up
        end
  | _ => pos_Up
  end.

Definition exponent_div2_floor e :=
  match e with
  | BigZ.Pos p =>
    (BigZ.Pos (BigN.shiftr p 1%bigN), negb (BigN.even p))
  | BigZ.Neg p =>
    let q := BigN.shiftr p 1%bigN in
    if BigN.even p then (BigZ.Neg q, false)
    else (BigZ.Neg (BigN.succ q), true)
  end.

Definition mantissa_sqrt m :=
  let s := BigN.sqrt m in
  let r := BigN.sub m (BigN.square s) in (s,
  if BigN.eqb r 0%bigN then pos_Eq
  else match BigN.compare r s with Gt => pos_Up | _ => pos_Lo end).

Definition exponent_zero_correct := refl_equal Z0.
Definition exponent_one_correct := refl_equal 1%Z.
Definition mantissa_zero_correct := refl_equal Z0.

Definition ZtoM_correct := BigZ.spec_of_Z.
Definition ZtoE_correct := BigZ.spec_of_Z.
Definition exponent_neg_correct := BigZ.spec_opp.
Definition exponent_add_correct := BigZ.spec_add.
Definition exponent_sub_correct := BigZ.spec_sub.

Lemma exponent_div2_floor_correct :
  forall e, let (e',b) := exponent_div2_floor e in
  EtoZ e = (2 * EtoZ e' + if b then 1 else 0)%Z.
Proof.
unfold exponent_div2_floor.
intros [e|e].
unfold EtoZ.
simpl BigZ.to_Z.
rewrite BigN.spec_shiftr.
rewrite <- Z.div2_spec.
rewrite BigN.spec_even.
rewrite <- Zodd_even_bool.
apply Zdiv2_odd_eqn.
rewrite BigN.spec_even.
case_eq (Z.even [e]%bigN).
unfold EtoZ.
simpl BigZ.to_Z.
rewrite BigN.spec_shiftr.
rewrite <- Z.div2_spec.
rewrite (Zdiv2_odd_eqn [e]%bigN) at 2.
rewrite Zodd_even_bool.
intros ->.
simpl negb ; cbv iota.
ring.
unfold EtoZ.
simpl BigZ.to_Z.
rewrite BigN.spec_succ.
rewrite BigN.spec_shiftr.
rewrite <- Z.div2_spec.
rewrite (Zdiv2_odd_eqn [e]%bigN) at 2.
rewrite Zodd_even_bool.
intros ->.
simpl negb ; cbv iota.
ring.
Qed.

Lemma PtoM_correct :
  forall n, MtoP (PtoM n) = n.
intros.
unfold MtoP, PtoM.
rewrite BigN.spec_of_pos.
apply refl_equal.
Qed.

Lemma mantissa_pos_correct :
  forall x, valid_mantissa x ->
  MtoZ (mantissa_pos x) = Zpos (MtoP x).
intros x (p, H).
unfold MtoZ, MtoP.
simpl.
rewrite H.
apply refl_equal.
Qed.

Lemma mantissa_neg_correct :
  forall x, valid_mantissa x ->
  MtoZ (mantissa_neg x) = Zneg (MtoP x).
intros x (p, H).
unfold MtoZ, MtoP.
simpl.
rewrite H.
apply refl_equal.
Qed.

Lemma mantissa_even_correct :
  forall x, valid_mantissa x ->
  mantissa_even x = Z.even (Zpos (MtoP x)).
Proof.
intros x (px, Hx).
unfold mantissa_even, Zeven, MtoP.
generalize (BigN.spec_even x).
rewrite Hx.
case (BigN.even x) ;
  destruct px as [px|px|] ; try easy.
Qed.

Lemma mantissa_one_correct :
  MtoP mantissa_one = xH /\ valid_mantissa mantissa_one.
Proof.
repeat split.
now exists xH.
Qed.

Lemma mantissa_add_correct :
  forall x y, valid_mantissa x -> valid_mantissa y ->
  MtoP (mantissa_add x y) = (MtoP x + MtoP y)%positive /\
  valid_mantissa (mantissa_add x y).
Proof.
intros x y (px, Hx) (py, Hy).
unfold mantissa_add, valid_mantissa, MtoP.
rewrite BigN.spec_add.
rewrite Hx, Hy.
repeat split.
now exists (px + py)%positive.
Qed.

Lemma mantissa_sub_correct :
  forall x y, valid_mantissa x -> valid_mantissa y ->
  (MtoP y < MtoP x)%positive ->
  MtoP (mantissa_sub x y) = (MtoP x - MtoP y)%positive /\
  valid_mantissa (mantissa_sub x y).
Proof.
intros x y (px, Hx) (py, Hy).
unfold mantissa_sub, valid_mantissa, MtoP.
rewrite BigN.spec_sub.
rewrite Hx, Hy.
simpl.
rewrite Z.pos_sub_spec.
case Pos.compare_spec.
intros H1 H2.
elim (Pos.lt_irrefl py).
now rewrite H1 in H2.
intros H1 H2.
elim (Pos.lt_irrefl py).
now apply Pos.lt_trans with px.
intros H _.
repeat split.
now exists (px - py)%positive.
Qed.

Lemma mantissa_mul_correct :
  forall x y, valid_mantissa x -> valid_mantissa y ->
  MtoP (mantissa_mul x y) = (MtoP x * MtoP y)%positive /\
  valid_mantissa (mantissa_mul x y).
intros x y (px, Hx) (py, Hy).
unfold mantissa_mul, valid_mantissa, MtoP.
rewrite BigN.spec_mul.
rewrite Hx, Hy.
simpl.
split.
apply refl_equal.
exists (px * py)%positive.
apply refl_equal.
Qed.

Lemma mantissa_cmp_correct :
  forall x y, valid_mantissa x -> valid_mantissa y ->
  mantissa_cmp x y = Z.compare (Zpos (MtoP x)) (Zpos (MtoP y)).
intros x y (px, Hx) (py, Hy).
unfold mantissa_cmp, MtoP.
rewrite Hx, Hy, <- Hx, <- Hy.
apply BigN.spec_compare.
Qed.

Lemma exponent_cmp_correct :
  forall x y, exponent_cmp x y = Z.compare (MtoZ x) (MtoZ y).
intros.
unfold exponent_cmp, MtoZ.
apply sym_eq.
generalize (BigZ.spec_compare x y).
unfold Z.lt, Z.gt.
case (x ?= y)%bigZ ; intro H ; rewrite H ;
 first [ apply Zcompare_refl | apply refl_equal ].
Qed.

Lemma mantissa_digits_correct :
  forall x, valid_mantissa x ->
  EtoZ (mantissa_digits x) = Zpos (count_digits radix (MtoP x)).
Proof.
intros x (px, Vx).
unfold mantissa_digits, EtoZ.
simpl.
rewrite BigN.spec_sub_pos.
rewrite BigN.spec_Ndigits.
rewrite <- digits_conversion.
rewrite <- Zplus_0_r.
rewrite <- (Zplus_opp_r [BigN.head0 x]%bigN)%Z.
rewrite Zplus_assoc.
apply (f_equal (fun v => v + _)%Z).
rewrite <- Zdigits_mult_Zpower.
2: now apply Zgt_not_eq.
2: apply BigN.spec_pos.
refine (_ (BigN.spec_head0 x _)).
2: now rewrite Vx.
intros (H1,H2).
unfold MtoP.
rewrite Vx.
set (d := Zdigits radix (Zpos px * radix ^ [BigN.head0 x]%bigN)).
cut (d <= Zpos (BigN.digits x) /\ Zpos (BigN.digits x) - 1 < d)%Z. omega.
unfold d ; clear d.
split.
apply Zdigits_le_Zpower.
rewrite Zabs_Zmult, Zmult_comm.
rewrite Z.abs_eq.
simpl Z.abs.
now rewrite <- Vx.
apply Zpower_ge_0.
apply Zdigits_gt_Zpower.
rewrite Zabs_Zmult, Zmult_comm.
rewrite Z.abs_eq.
simpl Z.abs.
now rewrite <- Vx.
apply Zpower_ge_0.
rewrite BigN.spec_Ndigits.
assert (Zpower 2 [BigN.head0 x]%bigN * 1 < Zpower 2 (Zpos (BigN.digits x)))%Z.
apply Z.le_lt_trans with (Zpower 2 [BigN.head0 x]%bigN * Zpos px)%Z.
apply Zmult_le_compat_l.
now case px.
apply (Zpower_ge_0 radix2).
rewrite <- Vx.
apply BigN.spec_head0.
now rewrite Vx.
change (~ ([BigN.head0 x]%bigN > Zpos (BigN.digits x))%Z).
intros H'.
apply (Zlt_not_le _ _ H).
rewrite Zmult_1_r.
apply (Zpower_le radix2).
apply Zlt_le_weak.
now apply Z.gt_lt.
Qed.

Lemma mantissa_scale2_correct :
  forall x d, valid_mantissa x ->
  let (x',d') := mantissa_scale2 x d in
  (IZR (Zpos (MtoP x')) * bpow radix (EtoZ d') = IZR (Zpos (MtoP x)) * bpow radix2 (EtoZ d))%R /\
  valid_mantissa x'.
Proof.
intros x d Vx.
repeat split.
exact Vx.
Qed.

Lemma mantissa_shl_correct :
  forall x y z, valid_mantissa y ->
  EtoZ z = Zpos x ->
  MtoP (mantissa_shl y z) = shift radix (MtoP y) x /\ valid_mantissa (mantissa_shl y z).
Proof.
intros x y z (py, Vy) Hz.
unfold mantissa_shl, MtoP, valid_mantissa.
rewrite BigN.spec_shiftl, Vy.
cutrewrite (Z.shiftl (Zpos py) [BigZ.to_N z]%bigN = Zpos (shift radix py x))%Z.
repeat split.
refl_exists.
unfold EtoZ in Hz.
rewrite spec_to_Z, Hz.
rewrite Z.shiftl_mul_pow2 by easy.
rewrite shift_correct.
now rewrite Z.pow_pos_fold.
Qed.

Lemma mantissa_sign_correct :
  forall x,
  match mantissa_sign x with
  | Mzero => MtoZ x = Z0
  | Mnumber s p => MtoZ x = (if s then Zneg else Zpos) (MtoP p) /\ valid_mantissa p
  end.
intros.
unfold mantissa_sign.
rewrite BigZ.spec_eqb.
case Z.eqb_spec.
easy.
change (BigZ.to_Z 0%bigZ) with Z0.
case x ; unfold valid_mantissa ; simpl ; intros ; rename n into H.
(* + *)
assert (BigN.to_Z t = Zpos (MtoP t)).
generalize H. clear.
unfold MtoP.
generalize (BigN.spec_pos t).
case (BigN.to_Z t) ; intros.
elim H0.
apply refl_equal.
apply refl_equal.
elim H.
apply refl_equal.
split.
exact H0.
exists (MtoP t).
exact H0.
(* - *)
assert (- BigN.to_Z t = Zneg (MtoP t))%Z.
generalize H. clear.
unfold MtoP.
generalize (BigN.spec_pos t).
case (BigN.to_Z t) ; intros.
elim H0.
apply refl_equal.
apply refl_equal.
elim H.
apply refl_equal.
split.
exact H0.
exists (MtoP t).
exact (BinInt.Z.opp_inj _ (Zpos _) H0).
Qed.

Lemma mantissa_shr_correct :
  forall x y z k, valid_mantissa y -> EtoZ z = Zpos x ->
  (Zpos (shift radix 1 x) <= Zpos (MtoP y))%Z ->
  let (sq,l) := mantissa_shr y z k in
  let (q,r) := Z.div_eucl (Zpos (MtoP y)) (Zpos (shift radix 1 x)) in
  Zpos (MtoP sq) = q /\
  l = adjust_pos r (shift radix 1 x) k /\
  valid_mantissa sq.
Proof.
intros x y z k [y' Vy] Ezx.
unfold mantissa_shr, MtoP.
unfold EtoZ in Ezx.
rewrite Vy.
intros Hy.
unfold valid_mantissa.
rewrite BigN.spec_shiftr_pow2.
rewrite spec_to_Z_pos by now rewrite Ezx.
rewrite Vy, Ezx.
generalize (Z.div_str_pos _ _ (conj (refl_equal Lt : (0 < Zpos _)%Z) Hy)).
generalize (Z_div_mod (Z.pos y') (Z.pos (shift radix 1 x)) (eq_refl Gt)).
rewrite shift_correct, Zmult_1_l.
change (Zpower 2 (Zpos x)) with (Z.pow_pos radix x).
unfold Z.div.
case Z.div_eucl.
intros q r.
revert Hy.
change (adjust_pos r (shift radix 1 x) k) with
  (match Z.pos (shift radix 1 x) with Zpos v => adjust_pos r v k | _ => pos_Eq end).
rewrite shift_correct, Zmult_1_l.
intros Hy [H2 H3].
destruct q as [|q|q] ; try easy.
intros _.
refine (conj (eq_refl _) (conj _ (ex_intro _ q (eq_refl _)))).
generalize (BigN.spec_tail0 y).
rewrite Vy.
intros H.
specialize (H (eq_refl Lt)).
destruct H as [yn [Hy1 Hy2]].
rewrite BigN.spec_compare.
rewrite BigN.spec_even.
rewrite BigN.spec_shiftr_pow2.
rewrite Vy.
rewrite BigN.spec_pred_pos ; rewrite BigZ.spec_to_Z_pos ; rewrite Ezx ; try easy.
unfold adjust_pos.
change (Z.pow_pos radix x) with (Z.pow_pos (Zpos 2) x).
rewrite <- Pos2Z.inj_pow_pos.
assert (Hp : (0 <= Zpos x - 1)%Z).
  now apply (Zlt_0_le_0_pred (Zpos x)).
assert (H2x : (2^x)%positive = xO (Z.to_pos (2 ^ (Zpos x - 1)))).
  clear -Hp.
  rewrite <- (Z2Pos.inj_pow_pos 2) by easy.
  change (Z.pow_pos 2 x) with (Zpower 2 (Zpos x)).
  pattern (Zpos x) at 1 ; replace (Zpos x) with (1 + (Zpos x - 1))%Z by ring.
  rewrite Zpower_plus by easy.
  rewrite Z2Pos.inj_mul ; try easy.
  now apply (Zpower_gt_0 radix2).
rewrite H2x.
case Zcompare_spec ; intros Hc.
- rewrite Zeven_mod.
  assert (Hy': (Zpos y' / Zpower 2 (Zpos x - 1) = Zpos q * 2 + r / Zpower 2 (Zpos x - 1))%Z).
    rewrite H2.
    rewrite Zplus_comm, Zmult_comm.
    change (Z.pow_pos radix x) with (Zpower 2 (Zpos x)).
    pattern (Zpos x) at 1 ; replace (Zpos x) with (1 + (Zpos x - 1))%Z by ring.
    rewrite Zpower_plus by easy.
    rewrite Zmult_assoc.
    rewrite (Zplus_comm (Zpos q * 2)).
    apply Z_div_plus_full.
    now apply Zgt_not_eq, (Zpower_gt_0 radix2).
  rewrite Hy'.
  rewrite Zplus_comm, Z_mod_plus_full.
  case Zcompare_spec ; intros Hr.
  + rewrite Zeq_bool_true.
    destruct r as [|r|r] ; [|easy|].
    2: now elim (proj1 H3).
    destruct k ; try easy.
    contradict H2.
    rewrite Hy2, Zplus_0_r.
    change (Z.pow_pos radix x) with (Zpower 2 (Zpos x)).
    replace (Zpos x) with (Zpos x - 1 - [BigN.tail0 y]%bigN + 1 + [BigN.tail0 y]%bigN)%Z by ring.
    rewrite <- (Zmult_comm (Zpos q)).
    rewrite Zpower_plus.
    2: clear -Hc ; omega.
    2: apply BigN.spec_pos.
    rewrite Zmult_assoc.
    intros H.
    apply Z.mul_reg_r in H.
    2: apply Zgt_not_eq, (Zpower_gt_0 radix2), BigN.spec_pos.
    revert H.
    rewrite Zpower_plus ; try easy.
    2: clear -Hc ; omega.
    change (2 ^ 1)%Z with 2%Z.
    clear ; intros.
    apply (f_equal Z.even) in H.
    revert H.
    rewrite Zplus_comm, Z.even_add_mul_2.
    rewrite Zmult_assoc, Z.even_mul.
    now rewrite orb_comm.
    rewrite Zdiv_small.
    easy.
    split.
    apply H3.
    rewrite Z2Pos.id in Hr.
    exact Hr.
    now apply (Zpower_gt_0 radix2).
  + contradict H2.
    rewrite Hy2, Hr.
    rewrite Z2Pos.id.
    2: apply (Zpower_gt_0 radix2) ; clear ; zify ; omega.
    change (Z.pow_pos radix x) with (Zpower 2 (Zpos x)).
    pattern (Zpos x) at 1 ; replace (Zpos x) with (1 + (Zpos x - 1))%Z by ring.
    rewrite Zpower_plus by easy.
    change (2 ^ 1)%Z with 2%Z.
    replace (2 * 2 ^ (Zpos x - 1) * Zpos q + 2 ^ (Zpos x - 1))%Z with ((1 + Zpos q * 2) * 2 ^ (Zpos x - 1))%Z by ring.
    replace (Zpos x - 1)%Z with (Zpos x - 2 - [BigN.tail0 y]%bigN + ([BigN.tail0 y]%bigN + 1))%Z by ring.
    rewrite Zpower_plus.
    2: clear -Hc ; omega.
    2: apply Z.le_le_succ_r, BigN.spec_pos.
    intros H2.
    apply (f_equal (fun v => Zmod v (2 ^ ([BigN.tail0 y]%bigN + 1)))) in H2.
    revert H2.
    rewrite Zmult_assoc, Z_mod_mult.
    rewrite Zmult_plus_distr_l.
    rewrite (Zmult_comm 2), <- Zmult_assoc, Zmult_1_l.
    rewrite Zplus_comm, (Zmult_comm 2).
    rewrite <- (Zpower_plus 2 _ 1).
    2: apply BigN.spec_pos.
    2: easy.
    rewrite Z_mod_plus_full.
    rewrite Zmod_small.
    apply Zgt_not_eq.
    apply (Zpower_gt_0 radix2).
    apply BigN.spec_pos.
    split.
    apply (Zpower_ge_0 radix2).
    apply (Zpower_lt radix2).
    apply Z.le_le_succ_r, BigN.spec_pos.
    apply Z.lt_succ_diag_r.
  + rewrite Zeq_bool_false.
    clear -Hr.
    now destruct r as [|r|r].
    rewrite Zmod_small.
    apply Zgt_not_eq.
    apply Z.gt_lt, Zle_succ_gt.
    apply Z.div_le_lower_bound.
    now apply (Zpower_gt_0 radix2).
    rewrite Zmult_1_r.
    rewrite Z2Pos.id in Hr.
    now apply Zlt_le_weak.
    now apply (Zpower_gt_0 radix2).
    split.
    now apply BigNumPrelude.div_le_0.
    apply Z.div_lt_upper_bound.
    now apply (Zpower_gt_0 radix2).
    rewrite <- (Zpower_plus 2 _ 1) by easy.
    now ring_simplify (Zpos x - 1 + 1)%Z.
- replace r with (Zpos (Z.to_pos (2^(Zpos x - 1)))).
  now rewrite Z.compare_refl.
  rewrite Z2Pos.id.
  2: apply (Zpower_gt_0 radix2) ; clear ; zify ; omega.
  replace (Zpower 2 (Zpos x - 1)) with (Zmod (Zpos y') (Zpower 2 (Zpos x))).
  apply sym_eq.
  apply Z.mod_unique_pos with (1 := H3) (2 := H2).
  rewrite Hy2, Hc.
  rewrite Zmult_plus_distr_l, (Zmult_comm 2), Zmult_1_l.
  rewrite <- Zmult_assoc.
  rewrite <- (Zpower_plus 2 1).
  ring_simplify (1 + (Zpos x - 1))%Z.
  rewrite Zplus_comm, Z_mod_plus_full.
  apply Zmod_small.
  split.
  apply (Zpower_ge_0 radix2).
  apply (Zpower_lt radix2).
  easy.
  apply (Z.lt_pred_l (Zpos x)).
  easy.
  now case x.
- replace r with Z0.
  reflexivity.
  apply sym_eq.
  replace Z0 with (Zmod (Zpos y') (Zpower 2 (Zpos x))).
  apply Z.mod_unique_pos with (1 := H3) (2 := H2).
  rewrite Hy2.
  replace [BigN.tail0 y]%bigN with ([BigN.tail0 y]%bigN - Zpos x + Zpos x)%Z by ring.
  rewrite Zpower_plus.
  rewrite Zmult_assoc.
  apply Z_mod_mult.
  clear -Hc ; omega.
  easy.
Qed.

Lemma mantissa_shrp_correct :
  forall x y z k, valid_mantissa y -> EtoZ z = Zpos x ->
  (Zpower radix (Zpos x - 1) <= Zpos (MtoP y) < Zpos (shift radix 1 x))%Z ->
  let l := mantissa_shrp y z k in
  l = adjust_pos (Zpos (MtoP y)) (shift radix 1 x) k.
Proof.
intros x y z k [v Hv] Ezx.
unfold mantissa_shrp.
case (Pos.succ_pred_or x); intro Hx.
  rewrite Hx.
  intros Hl; simpl in Hl.
  assert (MtoP y = 1%positive) by lia.
  rewrite H.
  unfold MtoP in H; rewrite Hv in H.
  destruct k; simpl; try easy.
  unfold EtoZ in Ezx.
  case BigN.compare_spec; try easy;
  intro H1; red in H1;
  rewrite !BigN.spec_shiftl, spec_to_Z, Ezx in H1;
  simpl Z.sgn in H1;
  rewrite Hx, Hv,H in H1; cbv in H1; inversion H1.
rewrite <- Hx at 1.
rewrite Pos2Z.inj_succ.
replace (Z.succ (Z.pos (Pos.pred x)) - 1)%Z  with (Z.pos (Pos.pred x)) by lia.
intros [Hl _].
unfold mantissa_shrp.
replace  (shift radix 1 x) with (xO ((Z.to_pos radix) ^ (Pos.pred x))); last first.
  apply Pos2Z.inj.
  rewrite <- (Pos.mul_1_r (_ ^ _)), <- (Pos.mul_xO_r _ xH).
  rewrite Pos.mul_comm, <- Pos.pow_succ_r, Hx, shift_correct.
  rewrite !Z.pow_pos_fold, Pos2Z.inj_pow, radix_to_pos; lia.
simpl.
replace
  (BigN.shiftl y 1 ?= BigN.shiftl 1 (BigZ.to_N z))%bigN
with
   (MtoP y ?= 2 ^ Pos.pred x)%positive.
  revert Hl.
  rewrite <-Z.pow_pos_fold, <- radix_to_pos, <- Pos2Z.inj_pow_pos.
  simpl.
  case Pos.compare_spec; try easy.
    intro H; lia.
  now destruct k.
rewrite BigN.spec_compare, !BigN.spec_shiftl.
rewrite Z.shiftl_1_l.
unfold EtoZ in Ezx.
rewrite spec_to_Z, Ezx.
unfold MtoP; rewrite Hv.
rewrite Z.mul_1_l.
rewrite <- Hx at 2.
rewrite Pos2Z.inj_succ.
rewrite Z.pow_succ_r, Z.mul_comm; try lia.
replace (Z.shiftl (Z.pos v) [1]%bigN)  with
   (Zpos v * 2)%Z by (cbn; lia).
rewrite <- Pos2Z.inj_pow; try easy.
now rewrite <- Zmult_compare_compat_r.
Qed.

Lemma mantissa_div_correct :
  forall x y, valid_mantissa x -> valid_mantissa y ->
  (Zpos (MtoP y) <= Zpos (MtoP x))%Z ->
  let (q,l) := mantissa_div x y in
  Zpos (MtoP q) = (Zpos (MtoP x) / Zpos (MtoP y))%Z /\
  Bracket.inbetween_int (Zpos (MtoP q)) (IZR (Zpos (MtoP x)) / IZR (Zpos (MtoP y)))%R (convert_location_inv l) /\
  valid_mantissa q.
Proof.
intros x y [x' Vx] [y' Vy].
unfold MtoP.
rewrite Vx, Vy.
unfold mantissa_div, mantissa_split_div.
generalize (BigN.spec_div_eucl x y).
generalize (Z_div_mod (Z.pos (MtoP x)) (Z.pos (MtoP y)) (eq_refl Gt)).
unfold MtoP.
rewrite Vx, Vy.
destruct BigN.div_eucl as [q r].
destruct Z.div_eucl as [q' r'].
intros [H1 H2] H.
injection H.
clear H.
intros Hr' Vq Hxy.
assert (H: (0 < q')%Z).
  apply Zmult_lt_reg_r with (Zpos y').
  easy.
  rewrite Zmult_0_l, Zmult_comm.
  apply Zplus_lt_reg_r with r'.
  rewrite Zplus_0_l.
  rewrite <- H1.
  now apply Z.lt_le_trans with (2 := Hxy).
destruct q' as [|q'|q'] ; try easy.
rewrite Vq.
clear H Hxy.
assert (Hq := Zdiv_unique _ _ _ _ H2 H1).
refine (conj Hq (conj _ (ex_intro _ _ Vq))).
unfold Bracket.inbetween_int.
rewrite BigN.spec_eqb.
rewrite BigN.spec_compare.
rewrite BigN.spec_shiftl_pow2.
rewrite Hr', Vy.
change (BigN.to_Z 0) with Z0.
change (2 ^ [1]%bigN)%Z with 2%Z.
destruct (Z.eqb_spec r' 0) as [Hr|Hr].
- apply Bracket.inbetween_Exact.
  rewrite H1, Hq, Hr, Zplus_0_r.
  rewrite mult_IZR.
  field.
  now apply IZR_neq.
- replace (convert_location_inv _) with (Bracket.loc_Inexact (Z.compare (r' * 2) (Zpos y'))).
  2: now case Z.compare.
  apply Bracket.inbetween_Inexact.
  unfold Rdiv.
  rewrite H1, Zmult_comm.
  split ;
    apply Rmult_lt_reg_r with (IZR (Zpos y')) ;
    (try now apply IZR_lt) ;
    rewrite Rmult_assoc, Rinv_l, Rmult_1_r, <- mult_IZR ;
    (try now apply IZR_neq) ;
    apply IZR_lt.
  clear -H2 Hr ; omega.
  rewrite Zmult_plus_distr_l.
  clear -H2 ; omega.
  rewrite H1, 2!plus_IZR, mult_IZR.
  destruct (Z.compare_spec (r' * 2) (Zpos y')) as [H|H|H].
  + apply Rcompare_Eq.
    rewrite <- H.
    rewrite mult_IZR.
    field.
    now apply IZR_neq.
  + apply Rcompare_Lt.
    apply Rminus_gt.
    match goal with |- (?a > 0)%R => replace a with ((IZR (Zpos y') - IZR r' * 2) / (2 * IZR (Zpos y')))%R end.
    apply Fourier_util.Rlt_mult_inv_pos.
    apply Rgt_minus.
    rewrite <- mult_IZR.
    now apply IZR_lt.
    apply Rmult_lt_0_compat.
    apply Rlt_0_2.
    now apply IZR_lt.
    field.
    now apply IZR_neq.
  + apply Rcompare_Gt.
    apply Rminus_lt.
    match goal with |- (?a < 0)%R => replace a with (- ((IZR r' * 2 - IZR (Zpos y')) / (2 * IZR (Zpos y'))))%R end.
    apply Ropp_lt_gt_0_contravar.
    apply Fourier_util.Rlt_mult_inv_pos.
    apply Rgt_minus.
    rewrite <- mult_IZR.
    now apply IZR_lt.
    apply Rmult_lt_0_compat.
    apply Rlt_0_2.
    now apply IZR_lt.
    field.
    now apply IZR_neq.
Qed.

Lemma mantissa_sqrt_correct :
  forall x, valid_mantissa x ->
  let (q,l) := mantissa_sqrt x in
  let (s,r) := Z.sqrtrem (Zpos (MtoP x)) in
  Zpos (MtoP q) = s /\
  match l with pos_Eq => r = Z0 | pos_Lo => (0 < r <= s)%Z | pos_Mi => False | pos_Up => (s < r)%Z end /\
  valid_mantissa q.
Proof.
intros x [x' Vx].
unfold mantissa_sqrt, MtoP.
rewrite BigN.spec_eqb.
rewrite BigN.spec_compare.
rewrite BigN.spec_sub.
rewrite BigN.spec_square.
rewrite BigN.spec_sqrt.
rewrite <- Z.sqrtrem_sqrt.
refine (_ (Z.sqrtrem_spec (Zpos x') _)).
2: easy.
rewrite Vx.
case_eq (Z.sqrtrem (Zpos x')).
intros s r Hsr.
simpl fst.
intros [H1 H2].
refine ((fun H => conj (proj1 H) (conj _ (proj2 H))) _).
clear H.
rewrite H1.
replace (s * s + r - s * s)%Z with r by ring.
rewrite Zmax_right by easy.
change [0]%bigN with Z0.
case Z.eqb_spec.
easy.
intros H.
assert (H3: (0 < r)%Z) by omega.
case Zcompare_spec ; intros H4.
apply (conj H3).
now apply Zlt_le_weak.
apply (conj H3).
now apply Zeq_le.
exact H4.
destruct s as [|s|s].
simpl in H1.
rewrite <- H1 in H2.
now elim (proj2 H2).
split.
apply eq_refl.
exists s.
rewrite BigN.spec_sqrt.
rewrite <- Z.sqrtrem_sqrt.
now rewrite Vx, Hsr.
now elim (Z.le_trans _ _ _ (proj1 H2) (proj2 H2)).
Qed.

End BigIntRadix2.


From algebra Require Export cofe.

Structure language := Language {
  expr : Type;
  val : Type;
  state : Type;
  of_val : val → expr;
  to_val : expr → option val;
  atomic : expr → Prop;
  prim_step : expr → state → expr → state → option expr → Prop;
  to_of_val v : to_val (of_val v) = Some v;
  of_to_val e v : to_val e = Some v → of_val v = e;
  val_stuck e σ e' σ' ef : prim_step e σ e' σ' ef → to_val e = None;
  atomic_not_val e : atomic e → to_val e = None;
  atomic_step e1 σ1 e2 σ2 ef :
    atomic e1 →
    prim_step e1 σ1 e2 σ2 ef →
    is_Some (to_val e2)
}.
Arguments of_val {_} _.
Arguments to_val {_} _.
Arguments atomic {_} _.
Arguments prim_step {_} _ _ _ _ _.
Arguments to_of_val {_} _.
Arguments of_to_val {_} _ _ _.
Arguments val_stuck {_} _ _ _ _ _ _.
Arguments atomic_not_val {_} _ _.
Arguments atomic_step {_} _ _ _ _ _ _ _.

Canonical Structure stateC Σ := leibnizC (state Σ).

Definition cfg (Λ : language) := (list (expr Λ) * state Λ)%type.

Section language.
  Context {Λ : language}.
  Implicit Types v : val Λ.

  Definition reducible (e : expr Λ) (σ : state Λ) :=
    ∃ e' σ' ef, prim_step e σ e' σ' ef.
  Inductive step (ρ1 ρ2 : cfg Λ) : Prop :=
    | step_atomic e1 σ1 e2 σ2 ef t1 t2 :
       ρ1 = (t1 ++ e1 :: t2, σ1) →
       ρ2 = (t1 ++ e2 :: t2 ++ option_list ef, σ2) →
       prim_step e1 σ1 e2 σ2 ef →
       step ρ1 ρ2.

  Lemma reducible_not_val e σ : reducible e σ → to_val e = None.
  Proof. intros (?&?&?&?); eauto using val_stuck. Qed.
  Lemma atomic_of_val v : ¬atomic (of_val v).
  Proof. by intros Hat%atomic_not_val; rewrite to_of_val in Hat. Qed.
  Global Instance: Inj (=) (=) (@of_val Λ).
  Proof. by intros v v' Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.
End language.

Class LanguageCtx (Λ : language) (K : expr Λ → expr Λ) := {
  fill_not_val e :
    to_val e = None → to_val (K e) = None;
  fill_step e1 σ1 e2 σ2 ef :
    prim_step e1 σ1 e2 σ2 ef →
    prim_step (K e1) σ1 (K e2) σ2 ef;
  fill_step_inv e1' σ1 e2 σ2 ef :
    to_val e1' = None → prim_step (K e1') σ1 e2 σ2 ef →
    ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 e2' σ2 ef
}.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_upp_upp_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_upp x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_upp L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.


Require Import
        Coq.Vectors.Vector
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.BoundedLookup.

Import Vectors.Vector.VectorNotations.
Local Open Scope vector_scope.
Local Open Scope string_scope.

Fixpoint SumType {n} (v : Vector.t Type n) {struct v} : Type :=
  match v with
  | Vector.nil => (False : Type)
  | Vector.cons T _ Vector.nil => T
  | Vector.cons T _ v' => T + (SumType v')
  end%type.

Arguments SumType : simpl never.

Fixpoint inj_SumType {n}
         (v : Vector.t Type n)
         (tag : Fin.t n)
         (el : Vector.nth v tag)
         {struct v} : SumType v.
  refine (match v in Vector.t _ n return
                forall
                  (tag : Fin.t n)
                  (el : Vector.nth v tag),
                  SumType v
          with
          | Vector.nil => fun tag el => Fin.case0 _ tag
          | Vector.cons T n' v' => fun tag0 el1 => _
          end tag el).
  generalize v' (inj_SumType n' v') el1; pattern n', tag0.
  eapply Fin.caseS; simpl.
  - intros ? v'0 ? ?; destruct v'0; simpl.
    + eapply el0.
    + exact (inl el0).
  - intros ? p v'0 ? ?; destruct v'0; simpl.
    + exact (Fin.case0 _ p).
    + exact (inr (X p el0)).
Defined.

Fixpoint SumType_index {n}
         (v : Vector.t Type n)
         (el : SumType v)
         {struct v} : Fin.t n.
  refine (match v in Vector.t _ n return
                SumType v -> Fin.t n
          with
          | Vector.nil => fun el' => match el' with end
          | Vector.cons T _ v' => fun el' => _
          end el).
  generalize (SumType_index _ v'); clear SumType_index; intros.
  destruct v'; simpl.
  - exact Fin.F1.
  - destruct el' as [|s].
    + exact Fin.F1.
    + exact (Fin.FS (X s)).
Defined.

Fixpoint SumType_proj {n}
         (v : Vector.t Type n)
         (el : SumType v)
         {struct v} : v[@SumType_index v el].
  refine (match v in Vector.t _ n return
                forall el : SumType v, v[@SumType_index v el]
          with
          | Vector.nil => fun el' => match el' with end
          | Vector.cons T _ v' => fun el' => _
          end el).
  generalize (SumType_proj _ v'); clear SumType_proj; intros.
  destruct v'; simpl.
  - exact el'.
  - destruct el' as [|s].
    + exact t.
    + exact (X s).
Defined.

Lemma inj_SumType_proj_inverse {n}
  : forall (v : Vector.t Type n)
           (el : SumType v),
    inj_SumType v _ (SumType_proj v el) = el.
Proof.
  induction v; simpl; intros.
  - destruct el.
  - destruct v.
    + simpl; reflexivity.
    + destruct el; simpl; eauto.
      f_equal; apply IHv.
Qed.

Lemma index_SumType_inj_inverse {n}
  : forall  (tag : Fin.t n)
            (v : Vector.t Type n)
            (el : Vector.nth v tag),
    SumType_index v (inj_SumType v tag el) = tag.
Proof.
  induction tag.
  - intro; pattern n, v; eapply Vector.caseS; simpl.
    clear; intros; destruct t; eauto.
  - intro; revert tag IHtag; pattern n, v; eapply Vector.caseS; simpl; intros.
    destruct t.
    + inversion tag.
    + f_equal.
      eapply IHtag.
Qed.

Lemma SumType_proj_inj {n} (v : Vector.t Type n):
  forall tag (P : forall (tag : Fin.t n),
                 Vector.nth v tag -> Type),
  forall el,
    P tag el ->
    P (SumType_index v (inj_SumType v tag el))
      (SumType_proj v (inj_SumType v tag el)).
  induction v.
  - simpl; inversion tag.
  - intro; revert v IHv; pattern n, tag;
      apply Fin.caseS.
    + intros.
      revert X.
      destruct v; simpl; eauto.
    + intros.
      eapply (IHv _ (fun tag => P (Fin.FS tag))) in X.
      simpl; destruct v.
      * inversion p.
      * apply X.
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_7.

Coq < Goal forall h c t f:Prop, ((h /\ (c /\ t)) /\ ~(~f /\ t)) -> f.
1 subgoal

  ============================
   forall h c t f : Prop, (h /\ c /\ t) /\ ~ (~ f /\ t) -> f

Unnamed_thm < intros.
1 subgoal

  h : Prop
  c : Prop
  t : Prop
  f : Prop
  H : (h /\ c /\ t) /\ ~ (~ f /\ t)
  ============================
   f

Unnamed_thm < induction H.
1 subgoal

  h : Prop
  c : Prop
  t : Prop
  f : Prop
  H : h /\ c /\ t
  H0 : ~ (~ f /\ t)
  ============================
   f

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
induction H.
tauto.

Unnamed_thm is defined

Coq <

*)

Require Import Classical.
Section Exercise_7.
Goal forall h c t f:Prop, ((h /\ (c /\ t)) /\ ~(~f /\ t)) -> f.
intros.
induction H.
tauto.
Qed.


Require Import common.

Definition R_Fun {A1 A2 :Type} (A_R: A1 -> A2 -> Type)
  {B1 B2: Type}
  (B_R: B1 -> B2 -> Type)
  (f1: A1->B1) (f2: A2->B2) : Type
  :=
  @R_Pi A1 A2 A_R (fun _ => B1) (fun _ => B2)
  (fun _ _ _ => B_R) f1 f2.

(* the case of non-dependent functions is interesting because no extra
[irrel] hypothesis is needed.*)
Lemma totalFun (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  {B1 B2: Type}
  (B_R: B1 -> B2 -> Type)
  (trp : TotalHeteroRel A_R)
  (trb: TotalHeteroRel B_R)
  (oneToOneA_R: oneToOne A_R)
:
  TotalHeteroRel (R_Fun A_R B_R).
Proof.
  split.
- intros f1. apply snd in trp.
  eexists.
  Unshelve.
    Focus 2.
    intros a2. specialize (trp a2).
     destruct trp as [a11 ar].
    apply fst in trb.
    specialize (trb (f1 a11)).
    exact (projT1  trb).

  simpl.
  intros ? ? ?.
  destruct (trp a2) as [a1r ar].
  destruct (trb) as [b2 br].
  simpl.
  destruct (b2 (f1 a1r)). simpl.
  pose proof (proj2 oneToOneA_R _  _ _ p ar).
  (* it may be possible to acheive this using univalence ase well
    A_R composed with A_R inv will be an isomorphism, thuse we can show a1=a1r. *)

  subst.
  assumption.
- intros f1. apply fst in trp.
  eexists.
  Unshelve.
    Focus 2.
    intros a2. specialize (trp a2).
     destruct trp as [a11 ar].
    apply snd in trb.
    specialize (trb (f1 a11)).
    exact (projT1  trb).

  simpl.
  intros a2 ? p.
  destruct (trp a2) as [a1r ar].
  destruct (trb) as [b2 br].
  simpl.
  destruct (br (f1 a1r)). simpl.
  pose proof (proj1 oneToOneA_R _ _ _ p ar).
  subst.
  assumption.
Qed.

Require Import Coq.Logic.FunctionalExtensionality.

(* will be used in oneOne for inductive types *)
Lemma oneToOnePiHalf (A1 A2 :Set) (A_R: A1 -> A2 -> Prop)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (* extras *)
  (tra : TotalHeteroRel A_R)
  (oneToOneB_R: forall a1 a2 (a_r : A_R a1 a2), oneToOneHalf ((B_R a1 a2 a_r)))
:
  oneToOneHalf (R_PiS B_R).
Proof.
  intros f1 f2 g2 H1r H2r;
  unfold R_Fun, R_Pi in *; subst; apply functional_extensionality_dep.
- intros a2.
  destruct (snd tra a2) as [a1 a1r].
  specialize (H2r _ _ a1r).
  specialize (H1r _ _ a1r).
  apply ((oneToOneB_R _ _ a1r) _ _ _ H1r H2r).
Defined. (* because all the assumptions here are in use, making it transparent wont benefit the unused var analysis, but can make it slow. What about univerese? *)

(* will be used in oneOne for inductive types *)
Lemma oneToOnePiHalf21 (A1 A2 :Set) (A_R: A1 -> A2 -> Prop)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (* extras *)
  (tra : TotalHeteroRel A_R)
  (oneToOneB_R: forall a1 a2 (a_r : A_R a1 a2), oneToOneHalf (rInvSP ((B_R a1 a2 a_r))))
:
  oneToOneHalf (rInvSP (R_PiS B_R)).
Proof.
  intros f1 f2 g2 H1r H2r;
  unfold R_Fun, R_Pi in *; subst; apply functional_extensionality_dep.
- intros a2.
  destruct (fst tra a2) as [a1 a1r].
  specialize (H2r _ _ a1r).
  specialize (H1r _ _ a1r).
  apply ((oneToOneB_R _ _ a1r) _ _ _ H1r H2r).
Defined. (* see above (non 21 version) *)

Lemma oneToOnePi (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Type)
  (B2: A2 -> Type)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (* extras *)
  (tra : TotalHeteroRel A_R)
  (oneToOneB_R: forall a1 a2 (a_r : A_R a1 a2), oneToOne (B_R a1 a2 a_r))
:
  oneToOne (R_Pi B_R).
Proof.
  split;intros f1 f2 g2 H1r H2r;
  unfold R_Fun, R_Pi in *; subst; apply functional_extensionality_dep.
- intros a2.
  destruct (snd tra a2) as [a1 a1r].
  specialize (H2r _ _ a1r).
  specialize (H1r _ _ a1r).
  pose proof (proj1 (oneToOneB_R _ _ _) _ _ _ H2r H1r).
  auto.
- intros a2.
  destruct (fst tra a2) as [a1 a1r].
  specialize (H2r _ _ a1r).
  specialize (H1r _ _ a1r).
  pose proof (proj2 (oneToOneB_R _ _ _) _ _ _ H2r H1r).
  auto.
Qed.

Print Assumptions oneToOnePi.
(*
Axioms:
functional_extensionality_dep : forall (A : Type) (B : A -> Type) (f g : forall x : A, B x),
                                (forall x : A, f x = g x) -> f = g
 *)

Lemma totalPiHalfAux (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (trp : TotalHeteroRelHalf (rInv A_R))
  (B1: A1 -> Type)
  (B2: A2 -> Type)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (trb: forall a1 a2 (p:A_R a1 a2), TotalHeteroRelHalf (B_R _ _ p))
  (oneToOneA_R: oneToOne A_R)
  (irrel : relIrrUptoEq A_R)
:
  TotalHeteroRelHalf (R_Pi B_R).
Proof.
  intros f1.
  eexists.
  Unshelve.
    Focus 2.
    intros a2. specialize (trp a2).
    destruct trp as [a1 ar]. (* this step fails with TotalHeteroRelP *)
    specialize (trb _ _ ar).
    specialize (trb (f1 a1)).
    exact (projT1 trb).

  simpl.
  intros ? ? par. (** [par] comes from intros in the Totality proof *)
  destruct (trp a2) as [a11 far].
  unfold rInv in far.
  (** [far] was obtained by destructing [trb] in the exhibited function.
     Right now, the types of [par] and [dar] are not even same ([a11] vs [a1]).*)
  pose proof (proj2 oneToOneA_R _ _ _ par far) as Heq.
  (* it may be possible to acheive this using univalence ase well
    A_R composed with A_R inv will be an isomorphism, thuse we can show a1=a1r. *)

  symmetry in Heq. subst.
  simpl.
  destruct (trb a1 a2 far (f1 a1)). simpl.
  (* now the types of [far] and [par] are same.
  Why would they be same, though?

  In Nuprl2Coq,
  pers were into Prop. So, this issue didnt arise.
  Even the predicative version, there was a global invariant that for
  same types, equalities were iff. In Nuprl, becuause the types of B_R a1 a2 far and
  B_R a1 a2 par are same, the global invariant 1) uniquely valued (<=2=>) will imply this
  subgoal.

  Unlike Nuprl, where each pair of equal types had ONE unque PER, parametricity, by design, allows
  different relations between types denoting related implementations. Even in this isorel translation,
  we want to allow different isomorphisms.
  NEW: consider A:=Type, B:=(fun A:Type => A). clearly, B A1 A2 AR depends on AR, because it IS AR

  Doesn't make sense anymore: We can change the translation of Prod to be a record, with a new element which is a
  proof that B_R is independent of the proof on A.
  oneToOne will be needed anyway and that would force us to used the univalent
  interpretation.

  *)
  specialize (irrel _ _ par far).
  subst. assumption.
Defined.

Lemma totalPiHalfAux21 (A1 A2 :Set) (A_R: A1 -> A2 -> Prop)
  (trp : TotalHeteroRel A_R)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trb: forall a1 a2 (p:A_R a1 a2), TotalHeteroRelHalf (rInvSP (B_R _ _ p)))
  (oneToOneA_R: oneToOne A_R)
  (irrel : relIrrUptoEq A_R)
:
  TotalHeteroRelHalf (rInvSP (R_PiS B_R)).
Proof.
  intros f1.
  eexists.
  Unshelve.
    Focus 2.
    intros a2. pose proof (fst trp a2) as a1r.
    destruct a1r as [a1 ar]. (* this step fails with TotalHeteroRelP *)
    specialize (trb _ _ ar).
    specialize (trb (f1 a1)).
    exact (projT1 trb).

  simpl.
  intros ? ? par.
  destruct (fst trp a1) as [a11 far].
  pose proof (proj1 oneToOneA_R _ _ _ par far) as Heq.

  symmetry in Heq. subst.
  simpl.
  destruct (trb a1 a2 far (f1 a2)). simpl.

  specialize (irrel _ _ par far).
  subst. assumption.
Defined.

Lemma totalPiHalf (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (trp : TotalHeteroRel A_R)
  (B1: A1 -> Type)
  (B2: A2 -> Type)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (* extras *)
  (trb: forall a1 a2 (p:A_R a1 a2), TotalHeteroRel (B_R _ _ p))
  (oneToOneA_R: oneToOne A_R)
  (irrel : relIrrUptoEq A_R)
:
  TotalHeteroRelHalf (R_Pi B_R).
Proof.
  apply totalPiHalfAux; auto.
  - apply trp.
  - apply trb.
Defined.

Print Assumptions totalPiHalf.
Require Import Coq.Setoids.Setoid.

Lemma totalPi (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Type)
  (B2: A2 -> Type)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (* extras *)
  (trp : TotalHeteroRel A_R)
  (trb: forall a1 a2 (p:A_R a1 a2), TotalHeteroRel (B_R _ _ p))
  (oneToOneA_R: oneToOne A_R)
  (irrel : relIrrUptoEq A_R)
:
  TotalHeteroRel (R_Pi B_R).
Proof.
  split.
- apply totalPiHalf; auto.
- pose proof (@totalPiHalf _ _ (rInv A_R) ltac:(rInv) B2 B1 (rPiInv B_R)
     ltac:(rInv) ltac:(rInv) ltac:(rInv)).
  unfold R_Pi, rPiInv, rInv in *.
  intros ?.
  unfold TotalHeteroRelHalf in X.
  intros.
  destruct X with (t1:=t1).
  eexists; intros; eauto.
Qed.

Print Assumptions totalPi.
(*
Closed under the global context
 *)

Lemma irrelEqPi (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (trp : TotalHeteroRel A_R)
  (B1: A1 -> Type)
  (B2: A2 -> Type)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (* extras *)
  (irrelB: forall a1 a2 (a_r : A_R a1 a2), relIrrUptoEq (B_R a1 a2 a_r))
:
  relIrrUptoEq (R_Pi B_R).
Proof.
  intros f1 f2 ? ?.
  unfold R_Pi in *.
  apply functional_extensionality_dep.
  intros a1.
  apply functional_extensionality_dep.
  intros a2.
  apply functional_extensionality_dep.
  intros ar.
  apply irrelB.
Qed.

Print Assumptions irrelEqPi.

(* The same holds for IWT -- see PIW.v *)

Require Import Trecord.

(* does not use proof irrelevance. This mentions a universe. Fix *)
Lemma PiGoodSet :
  forall (A1 A2 :Set) (A_R: BestRel A1 A2)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, BestR A_R a1 a2 -> BestRel (B1 a1) (B2 a2)),
  BestRel (forall a : A1, B1 a) (forall a : A2, B2 a).
Proof using.
  intros.
  exists  (fun (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) =>
forall (a1 : A1) (a2 : A2) (p : BestR A_R a1 a2), BestR  (B_R a1 a2 p) (f1 a1) (f2 a2)
); simpl in *;
  destruct A_R; simpl in *;
  rename R into A_R.
- apply totalPi; (* needs all 3 on A *) eauto;[|].
  + intros a1 a2 ar. destruct (B_R a1 a2 ar). (* needs totality on B_R*) assumption.
  + intros ? ?. apply ProofIrrelevance.PI.proof_irrelevance.
- apply oneToOnePi; eauto.
  intros a1 a2 ar. destruct (B_R a1 a2 ar). (* needs oneToOne on B_R *) assumption.
(*- apply irrelEqPi; eauto; (* needs totality and irrel on B_R *)
  intros a1 a2 ar; destruct (B_R a1 a2 ar); assumption. *)
Defined.
Require Import List.
Import ListNotations.

Lemma totalPiHalfGood (A1 A2 :Set) (A_R: BestRel A1 A2)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, BestR A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trb: forall a1 a2 (p:BestR A_R a1 a2), TotalHeteroRelHalf (B_R _ _ p))
:
  TotalHeteroRelHalf (R_PiS B_R).
Proof.
  apply totalPiHalfAux; auto.
  - apply (Rtot A_R).
  - apply (Rone A_R).
  - intros ? ? ? ?. apply ProofIrrelevance.PI.proof_irrelevance. (*apply (Rirrel A_R). *)
Defined. (* this must be Defined for unused var analysis to work *)

Lemma totalPiHalfGood21 (A1 A2 :Set) (A_R: BestRel A1 A2)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, BestR A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trb: forall a1 a2 (p:BestR A_R a1 a2), TotalHeteroRelHalf (rInvSP (B_R a1 a2 p)))
:
  TotalHeteroRelHalf (rInvSP (R_PiS B_R)).
Proof.
  unfold TotalHeteroRelHalf, rInvSP in *.
  simpl in *.
  apply totalPiHalfAux21; try assumption.
  - apply (Rtot A_R).
  - apply (Rone A_R).
  - intros ? ? ? ?. apply ProofIrrelevance.PI.proof_irrelevance. (*apply (Rirrel A_R). *)
Defined.

Lemma onePiHalfGood (A1 A2 :Set) (A_R: BestRel A1 A2)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, BestR A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trb: forall a1 a2 (p:BestR A_R a1 a2), oneToOneHalf (B_R _ _ p))
:
  oneToOneHalf (R_PiS B_R).
Proof.
  apply oneToOnePiHalf;[| assumption].
  apply (Rtot A_R).
Defined. (* this must be Defined for unused var analysis to work *)

Lemma onePiHalfGood21 (A1 A2 :Set) (A_R: BestRel A1 A2)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, BestR A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trb: forall a1 a2 (p:BestR A_R a1 a2), oneToOneHalf (rInv (B_R _ _ p)))
:
  oneToOneHalf (rInv (R_PiS B_R)).
Proof.
  apply oneToOnePiHalf21;[| assumption].
  apply (Rtot A_R).
Defined. (* this must be Defined for unused var analysis to work *)

Definition totalPiHalfGood2 :=
Eval compute in totalPiHalfGood.
Print totalPiHalfGood2. (* No universes *)

Definition PiGoodSet2 :=
Eval compute in PiGoodSet.

Print PiGoodSet2. (* No universes *)

Require Import ProofIrrelevance.

(*
This works when R in GoodRel has sort Prop.
Lemma PiTSummary
  (A1 A2 :Set) (A_R: BestRel A1 A2)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, BestR A_R a1 a2 -> BestRel (B1 a1) (B2 a2))
  :
  BestRel (forall a : A1, B1 a) (forall a : A2, B2 a).
Proof using.
  exists  (fun (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) =>
forall (a1 : A1) (a2 : A2) (p : BestR A_R a1 a2), BestR (B_R a1 a2 p) (f1 a1) (f2 a2)
); simpl;
  destruct A_R; simpl in *;
  rename R into A_R.
- apply totalPi; (* needs all 3 on A *) eauto.
  + intros a1 a2 ar. destruct (B_R a1 a2 ar). (* needs totality on B_R*) assumption.
  + intros ? ? ? ?. apply proof_irrelevance.
- apply oneToOnePi; eauto.
  intros a1 a2 ar. destruct (B_R a1 a2 ar). (* needs oneToOne on B_R *) assumption.
- exact I.
Defined.
*)

(** Now the Prop verion *)

Lemma oneToOnePiProp (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
(* Not needed for the Prop version
  (tra : TotalHeteroRel A_R)
  (oneToOneB_R: forall a1 a2 (a_r : A_R a1 a2), oneToOne (B_R a1 a2 a_r))
*)
:
  oneToOne (R_Pi B_R).
Proof.
  Check (forall a:A1, B1 a):Prop.
  split; intros f1 f2 g2  H2r;
  unfold R_Fun, R_Pi in *;
  intros H; apply proof_irrelevance.
Qed.

Lemma propForalClosedP {A₁ A₂ : Type} (B₁: A₁ -> Prop) (B₂: A₂ -> Prop)
(A_R : A₁ -> A₂ -> Type) (tra: TotalHeteroRel A_R)
  (trb: forall
       a₁ a₂,
          A_R a₁ a₂ -> (B₁ a₁ <-> B₂ a₂)):
(forall a : A₁, B₁ a) <-> (forall a : A₂, B₂ a).
Proof using.
  simpl. intros.
  split; intros Hyp; intros a.
- destruct (snd tra a) as [ap]. unfold rInv in r.
  specialize (Hyp ap). eapply trb in r; eauto.
  tauto.
- destruct (fst tra a) as [ap]. rename a0 into r. unfold rInv in r.
  specialize (Hyp ap). eapply trb in r; eauto.
  tauto.
Qed.

Lemma propForalClosedP2 {A₁ A₂ : Type} (B₁: A₁ -> Prop) (B₂: A₂ -> Prop)
(A_R : A₁ -> A₂ -> Type) (tra: TotalHeteroRel A_R)
  (trb: forall
       a₁ a₂,
          A_R a₁ a₂ -> (B₁ a₁ <=> B₂ a₂)):
(forall a : A₁, B₁ a) <=> (forall a : A₂, B₂ a).
Proof using.
  simpl. intros.
  split; intros Hyp; intros a.
- destruct (snd tra a) as [ap]. unfold rInv in r.
  specialize (Hyp ap). eapply trb in r. (* this need proof that the ARs are related *)
  tauto.
- destruct (fst tra a) as [ap]. rename a0 into r. unfold rInv in r.
  specialize (Hyp ap). eapply trb in r; eauto.
  tauto.
Qed.

Lemma propForalClosedP3 (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (* extras *)
  (trp : TotalHeteroRel A_R)
  (trb: forall a1 a2 (p:A_R a1 a2), IffRel (B_R _ _ p))
:
  IffRel (R_Pi B_R).
Proof.
  apply propForalClosedP2 with (A_R0 := A_R); auto.
Defined.

Lemma propForalClosedP4 (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (* extras *)
  (tra : IffRel A_R)
  (trb: forall a1 a2 (p:A_R a1 a2), IffRel (B_R _ _ p))
:
  IffRel (R_Pi B_R).
Proof.
  unfold IffRel in *.
  simpl in *. intros.
  split; intros Hyp; intros a.
  Fail tauto.
  Fail (firstorder; fail).
  (* Because the iff part of B is only accessible AFTER providing the ar argument,
    this is not provable. we need totality of A_R, not just iff *)
- set (a1:=snd tra a).
  specialize (Hyp a1). eapply trb in Hyp.
Abort.

Lemma propForalClosedP5 (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Type)
  (B2: A2 -> Type)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (* extras *)
  (tra : TotalHeteroRel A_R)
  (trb: forall a1 a2 (p:A_R a1 a2), IffRel (B_R _ _ p))
:
  IffRel (R_Pi B_R).
Proof.
  unfold IffRel in *.
  simpl in *. intros.
  simpl. intros.
  split; intros Hyp; intros a.
- destruct (snd tra a) as [ap]. unfold rInv in r.
  specialize (Hyp ap). eapply trb in r. (* this need proof that the ARs are related *)
  tauto.
- destruct (fst tra a) as [ap]. rename a0 into r. unfold rInv in r.
  specialize (Hyp ap). eapply trb in r; eauto.
  tauto.
Defined.

Print Assumptions propForalClosedP5.
(* Closed under the global context *)

Print Prop_R.

  Lemma piCompleteRel (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trb: forall a1 a2 (p:A_R a1 a2), CompleteRel (B_R _ _ p))
(*  (oneToOneA_R: oneToOne A_R)
  (irrel : relIrrUptoEq A_R) *)
:
  CompleteRel (R_Pi B_R).
  Proof.
    intros  f1 f2. intros ? ? ?.
    apply trb.
  Qed.

  Print Assumptions piCompleteRel.
Lemma piIffCompleteRelAux (A1 A2 :Set) (A_R: A1 -> A2 -> Prop)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (* extras *)
  (trb: forall a1 a2 (p:A_R a1 a2) b, IffCompleteHalf (B_R _ _ p) b)
  (tra : TotalHeteroRel A_R)
:
  forall f1, IffCompleteHalf (R_PiP B_R) f1.
  Proof.
    intros  f1.
    split.
    -  intros a2. pose proof (snd tra a2) as ar.
       destruct ar as [a1 ar]. (* this step fails with TotalHeteroRelP *)
       specialize (trb _ _ ar).
       specialize (trb (f1 a1)).
       exact (proj1 trb).
    - intros  ? ? ? ? . apply trb.
  Defined.

Lemma piIffCompleteRelAux21 (A1 A2 :Set) (A_R: A1 -> A2 -> Prop)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (* extras *)
  (trb: forall a1 a2 (p:A_R a1 a2) b, IffCompleteHalf (rInvSP (B_R _ _ p)) b)
  (tra : TotalHeteroRel A_R)
:
  forall f1, IffCompleteHalf (rInvSP (R_PiP B_R)) f1.
  Proof.
    intros  f1.
    split.
    -  intros a2. pose proof (fst tra a2) as ar.
       destruct ar as [a1 ar]. (* this step fails with TotalHeteroRelP *)
       specialize (trb _ _ ar).
       specialize (trb (f1 a1)).
       exact (proj1 trb).
    - intros  ? ? ? ? . apply trb.
  Defined.

Lemma piIffCompleteRel (A1 A2 :Set) (A_R: BestRel A1 A2) (* oneToOne is not needed *)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, BestR A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trb: forall a1 a2 (p:BestR A_R a1 a2) b, IffCompleteHalf (B_R _ _ p) b) :
  forall f, IffCompleteHalf (R_PiS B_R) f.
Proof.
  apply piIffCompleteRelAux; auto.
  apply (Rtot A_R).
Defined. (* this must be Defined for unused var analysis to work *)

Lemma piIffCompleteRel21 (A1 A2 :Set) (A_R: BestRel A1 A2) (* oneToOne is not needed *)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, BestR A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trb: forall a1 a2 (p:BestR A_R a1 a2) b, IffCompleteHalf (rInvSP(B_R _ _ p)) b) :
  forall f, IffCompleteHalf (rInvSP (R_PiS B_R)) f.
Proof.
  apply piIffCompleteRelAux21; auto.
  apply (Rtot A_R).
Defined. (* this must be Defined for unused var analysis to work *)

Lemma totalPiProp (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trp : TotalHeteroRel A_R)
  (trb: forall a1 a2 (p:A_R a1 a2), TotalHeteroRel (B_R _ _ p))
(*
These were needed in the version where the function type was not a Prop.
 (oneToOneA_R: oneToOne A_R)
  (irrel : relIrrUptoEq A_R) *)
:
  TotalHeteroRel (R_Pi B_R).
Proof.
  unfold R_Pi.
  apply ((fun A B R => snd (@Prop_RSpec A B R))).
  unfold Prop_R,  IffRel, CompleteRel.
  split.
  - apply tiffIff.
    apply propForalClosedP with (A_R0 := A_R);[assumption|].
    intros ? ? p.
    specialize (trb _ _ p).
    intros. apply tiffIff.
    apply ((fst (@Prop_RSpec _ _ _) trb)).
  - intros f g ? ? p.
    specialize (trb _ _ p).
    pose proof ((fst (@Prop_RSpec _ _ _) trb)) as Hp.
    apply Hp.
Qed.

Lemma PiGoodPropAux :
  forall (A1 A2 :Set) (A_R:  @GoodRel [Total] A1 A2)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, @R _ _ _ A_R a1 a2 ->  @GoodRel [Total] (B1 a1) (B2 a2)),
  BestRel (forall a : A1, B1 a) (forall a : A2, B2 a).
Proof using.
  intros.
  exists  (fun (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) =>
forall (a1 : A1) (a2 : A2) (p : @R _ _ _ A_R a1 a2), @R _ _ _ (B_R a1 a2 p) (f1 a1) (f2 a2)
); simpl in *;
  destruct A_R; simpl in *;
  rename R into A_R.
- apply totalPiProp; try assumption.
  intros a1 a2 ar. destruct (B_R a1 a2 ar). (* needs totality on B_R*) assumption.
- apply oneToOnePiProp.
(* - intros ? ? ? ?. apply proof_irrelevance. *)
Defined.

Lemma PiGoodProp :
  forall (A1 A2 :Set) (A_R:  BestRel A1 A2)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, @R _ _ _ A_R a1 a2 ->  BestRel (B1 a1) (B2 a2)),
    BestRel (forall a : A1, B1 a) (forall a : A2, B2 a).
Proof using.
  intros.
  apply PiGoodPropAux with (A_R := cast_Good_onlyTotal A_R).
  intros ? ? ar. simpl in ar.
  specialize (B_R _ _ ar).
  apply cast_Good_onlyTotal.
  exact B_R.
Defined.

Lemma totalPiHalfDirect (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trp : TotalHeteroRel A_R)
  (trb: forall a1 a2 (p:A_R a1 a2), TotalHeteroRel (B_R _ _ p))
(*
These were needed in the version where the function type was not a Prop.
 (oneToOneA_R: oneToOne A_R)
  (irrel : relIrrUptoEq A_R) *)
:
  TotalHeteroRelHalf (R_Pi B_R).
Proof.
  unfold R_Pi.
  intros f1.
  eexists.
  Unshelve.
    Focus 2.
    intros a2.
    destruct (snd trp a2) as [a1 ar]. (* this step fails with TotalHeteroRelP *)
    specialize (trb _ _ ar).
    destruct (fst trb (f1 a1)).
(*
    exact (projT1 b).

  simpl.
  intros ? ? par. (** [par] comes from intros in the Totality proof *)
  destruct (trp a2) as [a11 far].
  unfold rInv in far.
  (** [far] was obtained by destructing [trb] in the exhibited function.
     Right now, the types of [par] and [dar] are not even same ([a11] vs [a1]).*)
  pose proof (proj2 oneToOneA_R _ _ _ _ par far eq_refl) as Heq.
  (* it may be possible to acheive this using univalence ase well
    A_R composed with A_R inv will be an isomorphism, thuse we can show a1=a1r. *)

  intros ?.
  apply ((fun A B R => snd (@Prop_RSpec A B R))).
  unfold Prop_R.
  split.
  - apply propForalClosedP with (A_R0 := A_R);[assumption|].
    intros ? ? p.
    specialize (trb _ _ p).
    apply ((fst (@Prop_RSpec _ _ _) trb)).
  - intros f g ? ? p.
    specialize (trb _ _ p).
    pose proof ((fst (@Prop_RSpec _ _ _) trb)) as Hp.
    apply Hp.
Qed.
 *)
    Abort.

Print Assumptions totalPiProp.
(*
Axioms:
proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2
 *)

Print Assumptions propForalClosedP.
Print Assumptions Prop_RSpec.

(*
Definition PiABTypeProp
  (A1 A2 :Set) (A_R: A1 -> A2 -> Prop)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2,  A_R a1 a2 ->  (B1 a1) -> (B2 a2) -> Prop)
   (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) : Prop :=
forall (a1 : A1) (a2 : A2) (p : A_R a1 a2), B_R a1 a2 p (f1 a1) (f2 a2).
*)

Definition PiATypeBSet (* A higher. A's higher/lower is taken care of in [translate] *)
  (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2,  A_R a1 a2 -> BestRel (B1 a1) (B2 a2))
  := (fun (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) =>
forall (a1 : A1) (a2 : A2) (p : A_R a1 a2), BestR (B_R a1 a2 p) (f1 a1) (f2 a2)).

(* Not Allowed
PiATypeBProp (* A higher. A's higher/lower is taken care of in [translate] *)
  (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2,  A_R a1 a2 -> BestRel (B1 a1) (B2 a2))
  := (fun (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) =>
forall (a1 : A1) (a2 : A2) (p : A_R a1 a2), BestR (B_R a1 a2 p) (f1 a1) (f2 a2)).
*)

(* a special case of the above, which is allowed. a.k.a impredicative polymorphism
A= Prop:Type
B:Prop
What if A = nat -> Prop?
Any predicate over sets should be allowed?
In Lasson's theory, A  would be in Set_1
*)
Definition PiAEqPropBProp
(*  let A1:Type := Prop in
  let A2:Type := Prop in
  let A_R := BestRelP in *)
  (B1: Prop -> Prop)
  (B2: Prop -> Prop)
  (B_R: forall a1 a2,  BestRelP a1 a2 -> BestRelP (B1 a1) (B2 a2))
  : BestRelP (forall a : Prop, B1 a) (forall a : Prop, B2 a).
Proof.
  unfold BestRelP in *.
  split; intros.
- rewrite <- (B_R a);[eauto | reflexivity].
- rewrite (B_R a);[eauto | reflexivity].
Qed.

Lemma TotalBestp:
TotalHeteroRel (fun x x0 : Prop => BestRel x x0).
Proof.
split; intros t; exists t; unfold rInv; simpl; apply GoodPropAsSet; unfold BestRelP;
    reflexivity.
Qed.

Definition PiAEqPropBPropNoErasure
(*  let A1:Type := Prop in
  let A2:Type := Prop in
  let A_R := BestRelP in *)
  (B1: Prop -> Prop)
  (B2: Prop -> Prop)
  (B_R: forall (a1 a2 : Prop),  BestRel a1 a2 -> BestRel (B1 a1) (B2 a2))
  : BestRel (forall a : Prop, B1 a) (forall a : Prop, B2 a).
Proof.
  exists
  (fun f1 f2 =>
  forall (a1 : Prop) (a2 : Prop) (p : BestRel a1 a2), BestR (B_R a1 a2 p) (f1 a1) (f2 a2));
  simpl.
- pose proof (totalPiProp Prop Prop BestRel B1 B2) as Hp. simpl in Hp.
  specialize (Hp (fun a1 a2 ar => BestR (B_R a1 a2 ar))).
  simpl in Hp. apply Hp.
  + apply TotalBestp.
  + intros. destruct (B_R a1 a2 p). simpl in *. assumption.
- split; intros  ? ? ?  ? ?; apply proof_irrelevance.
(* - intros  ? ? ? ?; apply proof_irrelevance. *)
Defined.

Definition PiASetBType
  (A1 A2 :Set) (A_R: BestRel A1 A2)
  (B1: A1 -> Type)
  (B2: A2 -> Type)
  (B_R: forall a1 a2,  BestR A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  := (fun (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) =>
forall (a1 : A1) (a2 : A2) (p : BestR A_R a1 a2), B_R a1 a2 p (f1 a1) (f2 a2)).

Definition PiASetBProp (A1 A2 : Set)
  (A_R : BestRel A1 A2 (* just totality suffices *))
  (B1 : A1 -> Prop) (B2 : A2 -> Prop)
  (B_R : forall (a1 : A1) (a2 : A2), @BestR A1 A2 A_R a1 a2 -> BestRelP (B1 a1) (B2 a2))
   :  BestRelP (forall a : A1, B1 a) (forall a : A2, B2 a).
Proof using.
  destruct A_R. simpl in *.
  eapply propForalClosedP;[apply Rtot|].
  assumption.
Qed.

(* BestRelP can be problematic because it will force erasure *)

Section BestRelPForcesEraureOfLambda.
Variable A:Set.
Variable A_R : A->A-> Prop.
Let B: A -> Prop := fun  _ => True.
Let f : forall a, B a := fun _ => I.
Definition f_R : @BestRP (forall a, B a) (forall a, B a) (*Pi_R *) f f.
unfold BestRP.
(* f is a lambda. So f_R must be 3 lambdas *)
Fail exact (fun (a1:A) (a2:A) (arp: A_R a1 a2) => I).
simpl.
Abort.
End BestRelPForcesEraureOfLambda.

(* What is the translation of (A1 -> Prop) ? *)
Definition PiAEq2PropBProp
  (A1 A2 :Set) (A_R: BestRel A1 A2)
(*  let A1:Type := Prop in
  let A2:Type := Prop in
  let A_R := BestRelP in *)
  (B1: (A1 -> Prop) -> Prop)
  (B2: (A2 -> Prop) -> Prop)
  (B_R: forall (a1: A1->Prop) (a2 : A2->Prop),
     R_Fun (BestR A_R) BestRel a1 a2 -> BestRel (B1 a1) (B2 a2))
  : BestRel (forall a, B1 a) (forall a, B2 a).
Proof using.
  exists
  (fun f1 f2 =>
  forall (a1: A1->Prop) (a2 : A2->Prop) (p : R_Fun (BestR A_R) BestRel a1 a2),
    BestR (B_R a1 a2 p) (f1 a1) (f2 a2));
  simpl.
- pose proof (totalPiProp (A1 -> Prop) (A2 -> Prop)
    (R_Fun (BestR A_R) BestRel) B1 B2) as Hp. simpl in Hp.
  specialize (Hp (fun a1 a2 ar => BestR (B_R a1 a2 ar))).
  simpl in Hp. apply Hp.
  + pose proof (@totalFun A1 A2 (BestR A_R) Prop Prop BestRel).
    simpl in *.
    replace ((fun x x0 : Prop => BestRel x x0)) with (BestRel:(Prop->Prop->Type)) in X;
      [| reflexivity].
    unfold R_Fun in *. simpl in *. unfold R_Pi in *.
    destruct A_R; simpl in *.
    apply X; auto.
    apply TotalBestp.
  + intros. destruct (B_R a1 a2 p). simpl in *. assumption.
- split; intros  ? ? ? ? ?; apply proof_irrelevance.
(* - intros  ? ? ? ?; apply proof_irrelevance. *)
Defined.

Definition PiAPropBType
  (A1 A2 :Prop) (A_R: BestRelP A1 A2)
  (B1: A1 -> Type)
  (B2: A2 -> Type)
  (B_R: forall a1 a2,  BestRP a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  := (fun (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) =>
forall (a1 : A1) (a2 : A2) (p : BestRP a1 a2), B_R a1 a2 p (f1 a1) (f2 a2)).

Definition PiAPropBSet
 (A1 A2 : Prop)
  (A_R : BestRelP A1 A2)
  (B1 : A1 -> Set) (B2 : A2 -> Set)
  (B_R : forall (a1 : A1) (a2 : A2), (@BestRP A1 A2) a1 a2 -> BestRel (B1 a1) (B2 a2))
   :  BestRel (forall a : A1, B1 a) (forall a : A2, B2 a).
Proof.
  eapply  PiGoodSet with (A_R:= GoodPropAsSet A_R).
  simpl. exact B_R.
Defined.

Definition PiAPropBProp
 (A1 A2 : Prop)
  (A_R : BestRelP A1 A2)
  (B1 : A1 -> Prop) (B2 : A2 -> Prop)
  (B_R : forall (a1 : A1) (a2 : A2), (@BestRP A1 A2) a1 a2 -> BestRelP (B1 a1) (B2 a2))
   :  BestRelP (forall a : A1, B1 a) (forall a : A2, B2 a).
Proof.
  unfold BestRelP, BestRP in *.
  firstorder;
  eauto.
Qed.

(*
Lemma counter:
not (forall
(A1 A2 :Set) (A_R: A1 -> A2 -> Prop)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, BestR A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Prop)
  (trb: forall a1 a2 (p:BestR A_R a1 a2), TotalHeteroRel (B_R _ _ p))))
*)


Require Import SystemF.
Require Import List.
Require Import Utils.

Section Evaluation.

  Variable Delta : nat -> Term.
  Variable Xi : nat -> Ty.
  Variable Prog : forall n l m, Derivation Xi [n ; l |= F m @ Xi m] -> Derivation Xi [n ; l |= Delta m @ Xi m].
  Variable ProgTy : forall m, valid (Xi m) 0.

  Inductive Ev : Term -> Term -> Set :=
  | ev_f : forall n, Ev (F n) (Delta n)
  | ev_app : forall t t' s, Ev t t' -> Ev (App t s) (App t' s)
  | ev_abs : forall t s ty, Ev (App (Abs ty t) s) (sub t 0 s)
  | ev_tapp : forall t t' ty, Ev t t' -> Ev (TApp t ty) (TApp t' ty)
  | ev_lam : forall t ty, Ev (TApp (Lam t) ty) (tysubt t 0 ty).

Theorem ev_preservation : forall t t' n l ty, Derivation Xi [n ; l |= t @ ty] ->  Ev t t' -> Derivation Xi [n ; l |= t' @ ty].
Proof.
  refine (fix ev_preservation t t' n l ty (D : Derivation Xi [n ; l |= t @ ty]) (EvH : Ev t t') : Derivation Xi [n ; l |= t' @ ty] := _)
    ; case_eq t ; intros; subst.
  (* F *)
  inversion EvH ; subst.
  inversion D ; subst. apply Prog ; auto.
  (* V *)
  inversion EvH.
  (* App *)
  inversion EvH ; subst.
  inversion D ; subst.
  apply ImpElim with (xty:=xty). auto.
  apply ev_preservation with (t:=t0) ; auto.
  inversion D ; subst.
  inversion H5 ; subst.
  apply sub_preservation_basic with (xty:=xty) ; auto.
  (* TApp *)
  inversion EvH ; subst.
  inversion D ; subst.
  apply AllElim ; auto.
  apply ev_preservation with (t:=t0) ; auto.
  inversion D ; subst.
  inversion H5 ; subst.
  apply tysub_derivation_simple. auto. auto. auto.
  (* Abs *)
  inversion EvH.
  (* Lam *)
  inversion EvH.
Defined.

Inductive Evplus : Term -> Term -> Set :=
| Evplus_base : forall t t', Ev t t' -> Evplus t t'
| Evplus_next : forall t t' t'', Evplus t t' -> Ev t' t'' -> Evplus t t''.

(*
Inductive Evplus : Term -> Term -> Set :=
| Evplus_base : forall t t', Ev t t' -> Evplus t t'
| Evplus_next : forall t t' t'', Ev t t' -> Evplus t' t'' -> Evplus t t''.
*)

Inductive Evstar : Term -> Term -> Set :=
| Evstar_refl : forall t t', t = t' -> Evstar t t'
| Evstar_plus : forall t t', Evplus t t' -> Evstar t t'.

Notation "t ~> t'" := (Ev t t') (at level 60).
Notation "t ~>+ t'" := (Evplus t t') (at level 60).
Notation "t ~>* t'" := (Evstar t t') (at level 60).

Theorem evplus_preservation : forall t t' n l ty, Derivation Xi [n ; l |= t @ ty] ->  t ~>+ t' -> Derivation Xi [n ; l |= t' @ ty].
Proof.
  intros t t' n l ty Hty. induction 1.
  apply ev_preservation with (t:=t) ; auto.
  apply ev_preservation with (t:=t') ; auto.
Defined.

Theorem evstar_preservation : forall t t' n l ty, Derivation Xi [n ; l |= t @ ty] ->  t ~>* t' -> Derivation Xi [n ; l |= t' @ ty].
Proof.
  intros t t' n l ty Hty. induction 1.
  subst. auto.
  apply evplus_preservation with (t:=t) ; auto.
Defined.

Theorem evplus_trans : forall r s t, r ~>+ s -> s ~>+ t -> r ~>+ t.
Proof.
  intros r s t; induction 2. subst. auto.
  apply Evplus_next with (t':=t). auto. auto.
  apply IHEvplus in H.
  apply Evplus_next with (t':=t'). auto. auto.
Defined.

Theorem evstar_trans : forall r s t, r ~>* s -> s ~>* t -> r ~>* t.
  intros r s t Hrs Hst.
  inversion Hrs ; subst. auto.
  inversion Hst ; subst. auto.
  apply Evstar_plus. apply evplus_trans with (s:=s) ; auto.
Defined.

Inductive Value : Term -> Set :=
| Value_Lam : forall t, Value (Lam t)
| Value_Abs : forall t ty, Value (Abs ty t).

Lemma evstar_evplus_or_eq : forall t t', t ~>* t' -> (t ~>+ t') + {t = t'}.
Proof.
  induction 1.
  subst. right. auto.
  left. auto.
Defined.

Lemma evplus_app : forall t t' s, t ~>+ t' -> App t s ~>+ App t' s.
Proof.
  induction 1.
  apply Evplus_base ; apply ev_app ; auto.
  apply Evplus_next with (t':=App t' s). auto.
  apply ev_app. auto.
Defined.

Lemma evstar_app : forall t t' s, t ~>* t' -> App t s ~>* App t' s.
Proof.
  intros t t' s Hevstar.
  inversion Hevstar ; subst ; [ apply Evstar_refl ; auto | idtac ].
  apply Evstar_plus. apply evplus_app. auto.
Defined.

Lemma evplus_tapp : forall t t' ty, t ~>+ t' -> TApp t ty ~>+ TApp t' ty.
Proof.
  induction 1.
  apply Evplus_base ; apply ev_tapp ; auto.
  apply Evplus_next with (t':=TApp t' ty). auto.
  apply ev_tapp. auto.
Defined.

Lemma evstar_tapp : forall t t' ty, t ~>* t' -> TApp t ty ~>* TApp t' ty.
Proof.
  intros t t' s Hevstar.
  inversion Hevstar ; subst ; [ apply Evstar_refl ; auto | idtac ].
  apply Evstar_plus. apply evplus_tapp. auto.
Defined.

Lemma evstar_lam : forall f r ty, f ~>* (Lam r) -> TApp f ty ~>* tysubt r 0 ty.
Proof.
  intros f r ty Hev.
  inversion Hev ; subst.
  apply Evstar_plus ; apply Evplus_base ; apply ev_lam ; auto.
  apply Evstar_plus ; apply Evplus_next with (t':=TApp (Lam r) ty).
  apply evplus_tapp. auto.
  apply ev_lam.
Defined.

Lemma evstar_abs : forall f r s ty, f ~>* (Abs ty r) -> App f s ~>* sub r 0 s.
Proof.
  intros f r s ty Hev.
  inversion Hev ; subst.
  apply Evstar_plus ; apply Evplus_base ; apply ev_abs.
  apply Evstar_plus ; apply Evplus_next with (t':=App (Abs ty r) s).
  apply evplus_app. auto.
  apply ev_abs.
Defined.

Definition eval : forall (bound : nat) (t : Term), { t' : Term & t ~>* t'}.
Proof.
  refine (fix eval (bound : nat) (t : Term) : { t' : Term & t ~>* t'} :=
    (match bound as bound0 return (bound = bound0 -> { t' : Term & t ~>* t'}) with
       | O => (fun _ => existT (fun t' : Term => t ~>* t') t (Evstar_refl t t (refl_equal t)))
       | S bound' =>
         (fun (Heq : bound = S bound') =>
           (match t as t0 return (t = t0 -> { t' : Term & t0 ~>* t'}) with
              | V n => (fun (Heq : t = V n) => existT (fun t' : Term => V n ~>* t') (V n) _)
              | F n =>
                (fun (Heq : t = F n) =>
                  match eval bound' (Delta n) with
                    | existT s P => existT (fun t' : Term => F n ~>* t') s _
                  end)
              | App f g =>
                (fun (Heq : t = App f g) =>
                  match eval bound' f with
                    | existT s P =>
                      (match s as s0 return (s = s0 -> {t' : Term & App f g ~>* t'}) with
                         | (Abs ty s') =>
                           (fun (Heq : s = Abs ty s') =>
                             match eval bound' (sub s' 0 g) with
                               | existT sub_ev P' =>
                                 existT (fun t' : Term => App f g ~>* t') sub_ev _
                             end)
                         | _ => (fun (Heq : _) => existT (fun t' : Term => App f g ~>* t') (App s g) _)
                       end) (refl_equal s)
                  end)
              | Abs ty r =>
                (fun (Heq : t = Abs ty r) =>
                  existT (fun t' : Term => Abs ty _ ~>* t' ) (Abs ty r) _)
              | TApp r ty =>
                (fun (Heq : t = TApp r ty) =>
                  match eval bound' r with
                    | existT s P =>
                      (match s as s0 return (s = s0 -> {t' : Term & TApp r ty ~>* t'}) with
                         | (Lam s') =>
                           (fun (Heq : s = Lam s') =>
                             match eval bound' (tysubt s' 0 ty) with
                               | existT sub_ev P' =>
                                 existT (fun t' : Term => TApp r ty ~>* t') sub_ev _
                             end)
                         | _ => (fun (Heq : _) => existT (fun t' : Term => TApp r ty ~>* t') (TApp s ty) _)
                       end) (refl_equal s)
                  end)
              | Lam r =>
                (fun (Heq : t = Lam r) =>
                  existT (fun t' : Term => Lam _  ~>* t') (Lam r) _)
            end) (refl_equal t))
     end) (refl_equal bound)); subst ; try (apply evstar_app ; auto) ; try (apply evstar_tapp ; auto).
  (* F *)
  apply evstar_trans with (s:=Delta n).
  apply Evstar_plus. apply Evplus_base. apply ev_f. auto.
  (* V *)
  apply Evstar_refl. auto.
  (* App *)
  apply evstar_trans with (s:=sub s' 0 g).
  apply evstar_abs with (ty:=ty). auto. auto.
  (* TApp *)
  apply evstar_trans with (s:=tysubt s' 0 ty).
  apply evstar_lam. auto. auto.
  (* Abs *)
  apply Evstar_refl ; auto.
  (* Lam *)
  apply Evstar_refl ; auto.
Defined.

Definition eval_weak : forall (bound : nat) (t : Term), Term.
Proof.
  refine
    (fix eval_weak (bound : nat) (t : Term) : Term :=
      match bound with
        | O => t
        | S bound' =>
          match t with
            | V n => (V n)
            | F n => match bound' with
                       | 0 => F n
                       | S bound'' => eval_weak bound'' (Delta n)
                     end
            | App f g =>
              match eval_weak bound' f with
                | (Abs ty s') =>
                  match bound' with
                    | 0 => App (Abs ty s') g
                    | S bound'' => eval_weak bound'' (sub s' 0 g)
                  end
                | s => (App s g)
              end
            | Abs ty r => Abs ty r
            | TApp r ty =>
              match eval_weak bound' r with
                | (Lam s') =>
                  match bound' with
                    | 0 => TApp (Lam s') ty
                    | S bound'' => eval_weak bound'' (tysubt s' 0 ty)
                  end
                | s => TApp s ty
              end
            | Lam r => Lam r
          end
      end).
Defined.

Theorem compute_eval : forall (bound : nat) (t t': Term), eval_weak bound t = t' -> t ~>* t'.
Proof.
  refine (fix compute_eval (bound : nat) (t t': Term) (Hevalw : eval_weak bound t = t') : t ~>* t' := _) ; destruct bound.
  (* zero *)
  simpl in Hevalw. subst. apply Evstar_refl. auto.
  (* next *)
  simpl in Hevalw.
  (* Term by Term *)
  destruct t.
  (* F *)
  destruct bound.
    (* Z *)
    subst. apply Evstar_refl. auto.
    (* S n *)
    simpl in Hevalw.
    apply compute_eval in Hevalw.
    apply evstar_trans with (s:=Delta n).
    apply Evstar_plus. apply Evplus_base. apply ev_f. auto.
  (* V *)
  subst. apply Evstar_refl. auto.
  (* App *)
  case_eq (eval_weak bound t1) ; intros ;
    try (rewrite H in Hevalw ; subst ; apply compute_eval in H ; apply evstar_app ; exact H).
    (* App *)
    rewrite H in Hevalw. apply compute_eval in H.
    destruct bound.
      (* Z *)
      subst. apply evstar_app. auto.
      (* S bound *)
      apply compute_eval in Hevalw.
      apply evstar_trans with (sub t0 0 t2).
      apply evstar_abs with (ty:=t). auto. auto.
  (* TApp *)
  case_eq (eval_weak bound t) ; intros ;
    try (rewrite H in Hevalw ; subst ; apply compute_eval in H ; apply evstar_tapp ; exact H).
    (* TApp *)
    rewrite H in Hevalw. apply compute_eval in H.
    destruct bound.
      (* eq *)
      subst. apply evstar_tapp. auto.
      (* neq *)
      apply compute_eval in Hevalw.
      apply evstar_trans with (tysubt t1 0 t0).
      apply evstar_lam. auto. auto.
  (* Abs *)
  subst.
  apply Evstar_refl ; auto.
  (* Lam *)
  subst.
  apply Evstar_refl ; auto.
Defined.

Theorem ev_progress : forall t A, Derivation Xi [0; nil |= t @ A] -> { s : Term & t ~> s} + (Value t).
Proof.
  induction t; intros A HD.
  (* F *)
  apply inl. exists (Delta n). apply ev_f.
  (* V *)
  inversion HD ; subst. simpl in H4. elimtype False. firstorder.
  (* App *)
  inversion HD as [ | |n l t f ty xty Ht Hf | | |] ; subst.
  apply IHt1 in Hf. apply IHt2 in Ht.
  apply inl.
  inversion Hf as [Hleft | Hright].
    (* Left *)
    inversion Hleft as [x P].
    exists (App x t2). apply ev_app. auto.
    (* Right *)
    inversion Hright as [tyabs | f ] ; subst.
     (* Lam *)
     inversion HD as [ | |n l t f ty xty' Ht' Hf' | | |] ; subst; inversion Hf'.
     (* Abs *)
     exists (sub f 0 t2). apply ev_abs.
  (* TApp *)
  inversion HD as [ | | | | n l t' ty xty Hv Hall |] ; subst.
  apply IHt in Hall.
  apply inl.
  inversion Hall as [Hleft | Hright].
    (* Left *)
    inversion Hleft as [x P].
    exists (TApp x t0). apply ev_tapp. auto.
    (* Right *)
    inversion Hright as [r | abs] ; subst.
      (* Lam *)
      exists (tysubt r 0 t0).
      apply ev_lam.
      (* Abs *)
      inversion HD as [ | | | | n l t' ty' xty Hv' Hall' |] ; subst ; inversion Hall'.
  (* Abs *)
  apply inr.
  apply Value_Abs.
  (* Lam *)
  apply inr.
  apply Value_Lam.
Defined.

Lemma evplus_progress_lemma : forall t, { s : Term & t ~> s} + (Value t) -> { s : Term & t ~>+ s} + (Value t).
Proof.
  intros t Hor.
  inversion Hor as [Hleft | Hright].
  apply inl.
  inversion Hleft as [x P].
  exists x. apply Evplus_base. auto.
  apply inr. auto.
Defined.

Theorem evplus_progress : forall t A, Derivation Xi [0; nil |= t @ A] -> { s : Term & t ~>+ s} + (Value t).
Proof.
  intros t A HD.
  apply evplus_progress_lemma. apply ev_progress with (A:=A). auto.
Defined.

Lemma evplus_value_stuck : forall t s A, Derivation Xi [0; nil |= t @ A] -> Value t -> notT (t ~>+ s).
Proof.
  unfold notT. induction 3.
  inversion H0 ; subst.
  (* Lam *)
  inversion e.
  inversion e.
  apply IHEvplus ; auto.
Defined.

Lemma stuck_imp_value : forall t A, Derivation Xi [0; nil |= t @ A] -> notT {s : Term & t ~>+ s} -> Value t.
Proof.
  unfold notT.
  induction t ; intros A HD Hnoreduce.
  (* F *)
  elimtype False ; apply Hnoreduce.
  exists (Delta n). apply Evplus_base ; apply ev_f.
  (* V *)
  clear Hnoreduce.
  inversion HD as [ | | | | | n0 l ty i Hv Hl Heq Hv] ; simpl in Hl ; elimtype False ; firstorder.
  (* App *)
  elimtype False. apply Hnoreduce.
  inversion HD as [ | | n0 l t f ty xty Hx Hf | | |] ; subst.
  apply IHt1 in Hf.
  inversion Hf ; subst.
    (* Lam *)
    inversion HD as [ | | n0 l t' f' ty xty' Hx' Hf' | | |] ; inversion Hf'.
    (* Abs *)
    exists (sub t 0 t2). apply Evplus_base. apply ev_abs.
    (* Ev *)
    intros H. apply Hnoreduce.
    inversion H as [x P].
    exists (App x t2). apply evplus_app. auto.
  (* TApp *)
  elimtype False. apply Hnoreduce.
  inversion HD as [ | | | | n0 l r ty xty Hv Ht | ] ; subst.
  apply IHt in Ht.
  inversion Ht; subst.
    (* Lam *)
    exists (tysubt t1 0 t0). apply Evplus_base. apply ev_lam.
    (* Abs *)
    inversion HD as [ | | | | n0 l r ty' xty Hv' Ht' | ] ; inversion Ht'.
    (* Ev *)
    intros H.
    apply Hnoreduce.
    inversion H as [x P].
    exists (TApp x t0). apply evplus_tapp. auto.
  (* Abs *)
  apply Value_Abs.
  (* Lam *)
  apply Value_Lam.
Defined.

Lemma Value_refl : forall t s A, Derivation Xi [0 ; nil |= t @ A] -> Value t -> t ~>* s -> t = s.
Proof.
  intros t s A Hd Hv Hev.
  inversion Hv ; inversion Hev ; subst ; auto.
  elimtype False. apply evplus_value_stuck with (s:=s) (A:=A) in Hv. apply Hv. auto.
  auto.
  elimtype False. apply evplus_value_stuck with (s:=s) (A:=A) in Hv. apply Hv. auto.
  auto.
Defined.

Lemma ev_det : forall a b c, a ~> b -> a ~> c -> b = c.
Proof.
  refine
    (fix ev_det a b c (Hab : a ~> b) (Hac : a ~> c) {struct Hab} : b = c :=
      (match Hab in (a0 ~> b0) return (a = a0 -> b = b0 -> b0 = c) with
         | ev_f n  => _
         | ev_app t t' s Hev' => _
         | ev_abs t s ty => _
         | ev_tapp t t' ty Hev' => _
         | ev_lam t ty => _
       end) (refl_equal a) (refl_equal b)) ; intros Heqa Heqb.

  (* F *)
  rewrite Heqa in Hac. inversion Hac. auto.
  (* App *)
  rewrite Heqa in Hac. inversion Hac.
  cut (t' = t'0). intros. subst. auto.
  apply ev_det with (a:=t) ; auto.
    (* Subcases *)

    subst. inversion Hab. inversion H0. auto.
    subst. inversion Hac. subst. inversion H2.
    auto.
 (* Tapp *)
  rewrite Heqa in Hac. inversion Hac.
  cut (t' = t'0). intros. rewrite H3. auto.
  apply ev_det with (a:=t) ; auto.
    (* subcases *)
    subst. inversion Hev'.
    subst. inversion Hac. subst. inversion H2.
    auto.
Defined.

Lemma ev_inter_evplus : forall a b c, a ~> b -> a ~>+ c -> b ~>* c.
Proof.
  induction 2.
  apply ev_det with (b:=t') in H. subst.
  apply Evstar_refl. auto. auto.
  cut (b ~>* t').
  intros. apply Evplus_base in e. apply Evstar_plus in e.
  apply evstar_trans with (r:=b) in e. auto. auto.
  apply IHEvplus. auto.
Defined.

Lemma evplus_det : forall a b c, a ~>+ b -> a ~>+ c -> (b ~>+ c) + (c ~>+ b) + (b = c).
Proof.
  induction 1.
  intros Htc.
  inversion Htc.
  (* Evplus_base *)
  subst.
  apply ev_det with (b:=t') in H.
  right. auto. auto.
  (* Evplus_next *)
  inversion H. subst.
  apply ev_inter_evplus with (c:=t'0) in e.
    inversion e.
    (* refl *)
    left. left. subst ; auto.
    apply Evplus_base. auto.
    (* next *)
    subst.
    left. left. apply Evplus_next with (t':=t'0). auto. auto. auto.
    (* base *)
    subst.
    apply ev_inter_evplus with (c:=c) in e.
    inversion e. subst.
    (* next *)
    right ; auto.
    subst.
    left. left. auto. auto.
  (* Ev 2 *)
  intros Htc.
  apply IHEvplus in Htc.
    inversion Htc.
    (* (t' ~>+ c) + (c ~>+ t') *)
    inversion H0.
    (* (t' ~>+ c) *)
      (* eq *)
      apply ev_inter_evplus with (b:=t'') in H1.
      inversion H1. subst.
      right. auto.
      (* plus *)
      subst.
      left. left. auto. auto.
    (* c ~>+ t' *)
    left. right. apply Evplus_next with (t':=t'). auto. auto.
    (* t' = c *)
    subst.
  (* Ev 3 *)
  left. right. apply Evplus_base. auto.
Defined.

Lemma evstar_det : forall a b c, a ~>* b -> a ~>* c -> (b ~>* c) + (c ~>* b).
Proof.
  intros a b c Hab Hac ; inversion Hab ; inversion Hac ; subst.
  left ; auto.
  left ; auto.
  right ; auto.
  apply evplus_det with (c:=c) in H.
  inversion H.
  inversion H0.
  (*  (b ~>+ c) *)
  left. apply Evstar_plus. auto.
  (*  (c ~>+ b) *)
  right. apply Evstar_plus. auto.
  (* b = c *)
  subst.
  left. apply Evstar_refl. auto. auto.
Defined.

Inductive EvDeep :=
| evdeep_base : forall t t', Ev t t' -> EvDeep t t'
| evdeep_app2 : forall t t' s, Ev s s' -> EvDeep (App t s) (App t s')
| evdeep_abs : forall t s ty, Ev t t' -> EvDeep (Abs ty t) (Abs ty t')
| evdeep_lam : forall t t' ty, Ev t t' -> EvDeep (Lam t) (Lam t').

Inductive StrongNormalisation :=

End Evaluation.


(** For better readability, one often constructs
  custom records with semantically aptly named projections
  instead of using the standard pair type.
  For example, consider Vector.Cart2D.

  However, it is tedious to redo common constructions, e.g.
  rings with pointwise operations,
  for each such record type constructor.
   This typeclass is an attempt to
  do such constructions generically once and forall.
 *)
Set Implicit Arguments.
Class PairLike {C A B : Type}
  (mkPair : A -> B -> C)
  (fst : C -> A)
  (snd : C -> B) :=
{
  pairLikeFst : forall  (a:A) (b:B),
    fst (mkPair a b) = a;
  pairLikeSnd : forall  (a:A) (b:B),
    snd (mkPair a b) = b
}.

Section ForgetTypeclassInstances.
Require Import MathClasses.interfaces.canonical_names.
Instance CastPairLikeSame
`{@PairLike Pair A A mkpair pfst psnd} : Cast A Pair :=
  fun p => mkpair p p.

Instance EquivPairLike
`{@PairLike Pair A B mkpair pfst psnd}
`{Equiv A} `{Equiv B}
  : Equiv (Pair) :=
  fun a b => pfst a = pfst b /\ psnd a = psnd b.

Instance EquivalencePairLike
`{@PairLike Pair A B mkpair pfst psnd}
`{Equiv A} `{Equiv B}
  `{Equivalence _ (@equiv A _)} `{Equivalence _ (@equiv B _)}
    : Equivalence (@equiv (Pair) _).
Proof.
  split.
- intros x.  split; auto with *.
- intros x y.  intros Hd; destruct Hd;
      split; auto with relations.

- intros x y z. intros h0 h1.
    destruct h0, h1. simpl in *.
    split; eauto 10
    with relations; simpl.
Qed.

Instance ProperPairLikeFst
`{@PairLike Pair A B mkpair pfst psnd}
{_ : Equiv A} {_: Equiv B} :
     Proper  (equiv ==> equiv) pfst.
Proof.
  intros a b Heq. destruct Heq; assumption.
Qed.

Instance ProperPairLikeSnd
`{@PairLike Pair A B mkpair pfst psnd}
`{Equiv A} `{Equiv B} :
     Proper  (equiv ==> equiv) psnd.
Proof.
  intros a b Heq. destruct Heq; assumption.
Qed.

Require Export MathClasses.theory.rings.
Require Export MathClasses.interfaces.abstract_algebra.
Instance ZeroPairLike
`{@PairLike Pair A B mkpair pfst psnd}
 `{Zero A} `{Zero B}
    : Zero (Pair)
    := mkpair 0 0.

Instance OnePairLike
`{@PairLike Pair A B mkpair pfst psnd}
 `{One A} `{One B}
    : One (Pair)
    := mkpair 1 1.

Instance PlusPairLike
`{@PairLike Pair A B mkpair pfst psnd}
`{Plus A} `{Plus B}
    : Plus (Pair)
    := λ a b, mkpair (pfst a + pfst b) (psnd a + psnd b).

Instance MultPairLike
`{@PairLike Pair A B mkpair pfst psnd}
 `{Mult A} `{Mult B}
    : Mult (Pair)
    := λ a b, mkpair (pfst a * pfst b) (psnd a * psnd b).

Instance NegatePairLike
`{@PairLike Pair A B mkpair pfst psnd}
 `{Negate A} `{Negate B}
    : Negate (Pair)
    := λ a , mkpair (-(pfst a)) (-(psnd a)).

Section PairLikeRing.
Context `{@PairLike Pair A B mkpair pfst psnd}.

Context `{Ring A}.
Context `{Ring B}.

Add Ring  tempA : (rings.stdlib_ring_theory A).
Add Ring  tempB : (rings.stdlib_ring_theory B).

Require Import Ring.
Typeclasses eauto :=3.

Instance RingPairLike : Ring Pair.
Typeclasses eauto :=30.

Proof.
  repeat(split);
  (repeat match goal with
  | [ H: equiv _ _ |- _ ] =>
      destruct H
  end);
  simpl; subst; eauto 4 with relations;
  compute;
  repeat rewrite (@pairLikeFst _ _ _ mkpair pfst psnd);
  repeat rewrite (@pairLikeSnd _ _ _ mkpair pfst psnd);
  fold (@equiv A _);
  fold (@plus A _);
  fold (@mult A _);
  fold (@zero A _);
  fold (@one A _);
  fold (@negate A _);
  fold (@equiv B _);
  fold (@plus B _);
  fold (@mult B _);
  fold (@zero B _);
  fold (@one B _);
  fold (@negate B _);
  subst;
  try ring; try assumption;
  (repeat match goal with
  | [ H: equiv _ _ |- _ ] =>
      repeat rewrite H; clear H
  end); try ring; try assumption.
Qed.

End PairLikeRing.

Instance ProperCastPairLikeSame
`{@PairLike Pair A A mkpair pfst psnd}
`{Equiv A}:
    Proper (equiv ==> equiv) (cast  A (Pair)).
Proof.
    intros ? ? ?. split; compute;
    [repeat rewrite pairLikeFst| repeat rewrite pairLikeSnd];
    assumption.
Qed.

Instance ProperPairLikeMkpair
`{@PairLike Pair A B mkpair pfst psnd}
`{Equiv A}
`{Equiv B}:
  Proper (equiv ==> equiv  ==> equiv) (mkpair).
Proof.
  intros ? ? h1  ? ? h2. split; simpl;
   repeat rewrite pairLikeFst; repeat rewrite pairLikeSnd;
  assumption.
Qed.

Lemma foldPlusPairLike
`{@PairLike Pair A B mkpair pfst psnd}
`{Ring A}
`{Ring B} : forall xa xb ya yb,
  mkpair (xa + xb) (ya + yb) = mkpair (xa) (ya)
    + mkpair (xb) (yb).
Proof.
    intros. split; compute;
   repeat rewrite pairLikeFst; repeat rewrite pairLikeSnd;
   reflexivity.
Qed.

Instance pair_instance_le
`{@PairLike Pair A B mkpair pfst psnd}
`{Le A}
`{Le B}
: Le (Pair) :=
  λ p1 p2, (pfst p1 ≤ pfst p2) ∧ (psnd p1 ≤ psnd p2).

(*
Instahce : SFmap Rigid2DState :=
fun _ _ f c => {|pos2D := sfmap f (pos2D c); θ2D := f (θ2D c)|}.
*)

Require Import StdlibMisc.

Instance LePairPreorder
`{@PairLike Pair A B mkpair pfst psnd}
{la: Le A}
{lb: Le B}
{_: @PreOrder A la}
{_: @PreOrder B lb}
  : PreOrder (pair_instance_le).
Proof.
  split; intros ?; unfold le, pair_instance_le;
  eauto with relations.
  intros. repnd. eauto with relations.
Qed.

Require Import MathClasses.interfaces.orders.

Instance LePairPartialOrder
`{@PairLike Pair A B mkpair pfst psnd}
`{Ring A}  `{Ring B}
`{Le A}
`{Le B}
`{@PartialOrder A _ _}
`{@PartialOrder B _ _}
  : PartialOrder (pair_instance_le).
Proof.
  split; eauto with typeclass_instances.
  - split; eauto with typeclass_instances.
  - intros ? ? H1e ? ? H2e; unfold le, pair_instance_le.
    rewrite H1e, H2e. tauto.
  - intros ? ?. unfold le, pair_instance_le. intros ? ?.
    repnd. split; simpl; eapply  po_antisym; eauto.
Qed.

Instance OrderPreservingLePlusPair
`{@PairLike Pair A B mkpair pfst psnd}
`{Ring A}  `{Ring B}
`{Le A}
`{Le B}
`{@PartialOrder A _ _}
`{@PartialOrder B _ _}
  {_:forall a:A, OrderPreserving (plus a)}
  {_:forall b:B, OrderPreserving (plus b)}
(z : Pair):
  OrderPreserving (plus z).
Proof.
  split; eauto  with typeclass_instances.
  - split; eauto with typeclass_instances;
    split; eauto with typeclass_instances;
    split; eauto with typeclass_instances;
    unfold plus,PlusPairLike;
    repeat rewrite pairLikeFst;
    repeat rewrite pairLikeSnd;
    rewrite H8;  auto.
  - intros ? ?. unfold le, pair_instance_le.
    intros. repnd;
    simpl.
    split;
    unfold plus,PlusPairLike;
    repeat rewrite pairLikeFst;
    repeat rewrite pairLikeSnd;
    eauto with typeclass_instances.
Qed.

Instance MultLeSemiRingOrderPair
`{@PairLike Pair A B mkpair pfst psnd}
`{Ring A}  `{Ring B}
`{Le A}
`{Le B}
  {Ha:∀ (x y :  A) , PropHolds (0 ≤ x) → PropHolds (0 ≤ y)
      → PropHolds (0 ≤ x * y) }
  {Hb:∀ (x y :  B) , PropHolds (0 ≤ x) → PropHolds (0 ≤ y)
      → PropHolds (0 ≤ x * y) }:
  ∀ x y : (Pair) , PropHolds (0 ≤ x) → PropHolds (0 ≤ y) → PropHolds (0 ≤ x * y) .
Proof.
    unfold le, pair_instance_le, PropHolds.
    unfold  PropHolds in Ha, Hb.
    simpl.
    intros.
    unfold zero, ZeroPairLike in *.
    rewrite pairLikeFst in H4, H5;
    rewrite pairLikeSnd in H4, H5;
    repnd;
    simpl;
    split;
    unfold mult,MultPairLike;
    repeat rewrite pairLikeFst in *;
    repeat rewrite pairLikeSnd in *;
    eauto with typeclass_instances.
Qed.

Require Import MathClasses.orders.rings.

Local Existing Instance RingPairLike.

Instance
PairSemiringOrder
`{@PairLike Pair A B mkpair pfst psnd}
`{Ring A}  `{Ring B}
`{Le A}
`{Le B}
    `{@orders.SemiRingOrder A equiv plus mult zero one le}
    `{@orders.SemiRingOrder B equiv plus mult zero one le}:
    `{orders.SemiRingOrder (@canonical_names.le Pair _)}.
Proof.
  apply from_ring_order;
  eauto with typeclass_instances;[].
  apply OrderPreservingLePlusPair.
Qed.

Require Import CoRN.logic.Stability.

Instance StableLePair
`{@PairLike Pair A B mkpair pfst psnd}
`{Le A}
`{Le B} :
  (forall x y : A, Stable (x≤y))
  -> (forall x y : B, Stable (x≤y))
  -> (forall a b : Pair, Stable (a≤b)).
Proof.
  intros Hca Hcb  a b.
  apply stable_conjunction; eauto.
Qed.

End ForgetTypeclassInstances.

(*
Lemma foldPlusLine `{Ring A} : forall xa xb ya yb: Cart2D A,
  {| minxy := xa + xb; maxxy :=ya + yb |} = {|minxy :=xa; maxxy :=ya|}
    + {|minxy:=xb; maxxy:=yb|}.
Proof.
    intros. reflexivity.
Qed.
*)