(* ** Arithmetical Hierarchy in Type Theory *)

Require Import Lia Vector Fin List Arith.Cantor.
Import Vector.VectorNotations.
From Undecidability.Synthetic Require Import Definitions.

Require Import PeanoNat (* Nat.eqb *) Bool.

From Equations Require Import Equations.
Require Import Equations.Prop.DepElim.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Local Notation vec := Vector.t.
Derive Signature for vec.

Lemma eqhd : forall (x:nat) n (v: vec nat n), (VectorDef.hd (x :: v)) = x. Proof. reflexivity. Qed.
Lemma eqtl : forall (x:nat) n (v: vec nat n), (VectorDef.tl (x :: v)) = v. Proof. reflexivity. Qed.

Notation "P ⪯ₘ Q" := (reduces P Q) (at level 70).

Section ArithmeticalHierarchySemantic.

  (* ((vec nat k) -> Prop) punktweise gleich -> gleich *)
  (* und äquivalente Prop sind gleich *)
  Lemma fun_ext_prop_ext:
    (forall {X Y} (f g : X -> Y), (forall x, f x = g x) -> f = g) ->
    (forall (p q : Prop), (p <-> q) -> p = q) ->
    forall {k} (f g:(vec nat k) -> Prop) , (forall v, f v <-> g v) -> f = g.
  Proof.
    intros Fext Pext k f g H.
    apply Fext. intros x. apply Pext. apply H.
  Qed.

  Axiom PredExt : forall (k : nat) (f g : vec nat k -> Prop), (forall v : vec nat k, f v <-> g v) -> f = g.

  Inductive isΣsem : nat -> forall (k: nat), ((vec nat k) -> Prop) -> Prop :=
  | isΣsem0 {k} (f: vec nat k -> bool) : isΣsem 0 (fun v => f v = true)
  | isΣsemS {n} {k} {p: vec nat (S k) -> Prop} : @isΠsem n (S k) p -> @isΣsem (S n) k (fun v => exists x, p (x::v))

  with isΠsem : nat -> forall (k: nat), ((vec nat k) -> Prop) -> Prop :=
  | isΠsem0 {k} (f: vec nat k -> bool) : isΠsem 0 (fun v => f v = true)
  | isΠsemS {n} {k} {p: vec nat (S k) -> Prop} : @isΣsem n (S k) p -> @isΠsem (S n) k (fun v => forall x, p (x::v)).

  Derive Signature for isΣsem.
  Derive Signature for isΠsem.
  #[local] Hint Constructors isΣsem : core.
  #[local] Hint Constructors isΠsem : core.

  (* generacte induction scheme *)
  Scheme isΣsem_isΠsem_ind := Induction for isΣsem Sort Prop
  with isΠsem_isΣsem_ind := Induction for isΠsem Sort Prop.
  (* https://coq.inria.fr/refman/proofs/writing-proofs/reasoning-inductives.html#combined-scheme *)
  Combined Scheme isΣsem_isΠsem_mutind from isΣsem_isΠsem_ind,isΠsem_isΣsem_ind.

  Lemma curry {k} t: (nat -> vec nat k -> t) -> vec nat (S k) -> t.
  Proof.
    intros P v.
    inversion v as [|n k' v' eq]. subst.
    exact (P n v').
  Defined.

  Lemma curry0 t : t -> vec nat 0 -> t.
  Proof.
    intros P v. apply P.
  Defined.

  Lemma curry1 t: (nat -> t) -> vec nat 1 -> t.
  Proof.
    intros P. apply curry. intros n. apply curry0. exact (P n).
  Defined.

  Lemma curry2 t: (nat -> nat -> t) -> vec nat 2 -> t.
  Proof.
    intros P. apply curry. intros n. apply curry1. exact (P n).
  Defined.

  Goal isΣsem 1 (curry1 (fun n => exists k, n = 2 * k)).
  Proof.
    erewrite PredExt.
    - eapply isΣsemS. unshelve apply isΠsem0.
      apply curry2. intros k n.
      exact (n =? (2*k)).
    - intros v.
      repeat dependent destruction v.
      cbn. unfold curry0.
      split.
      + intros [k H]. exists k. now apply Nat.eqb_eq.
      + intros [k H]. exists k. now apply Nat.eqb_eq.
  Qed.

  Lemma semi_dec_iff_Σ1 {k} (p : vec nat k -> Prop):
    semi_decidable p <-> isΣsem 1 p.
  Proof.
  unfold semi_decidable, semi_decider.
  split.
  - intros [f Hf].
    rewrite (PredExt Hf).
    unshelve erewrite PredExt. {
      exact (fun v => exists n, (fun v => (fun v => f (Vector.tl v) (Vector.hd v)) v = true) (n::v)).
    } 2: reflexivity. eapply isΣsemS, isΠsem0.
  - intros H. repeat dependent destruction H.
    now exists (fun v n => f (n::v)).
  Qed.

  Lemma isΣΠsem0 {k} (f: vec nat k -> bool) n :
    isΣsem n (fun v => f v = true) /\ isΠsem n (fun v => f v = true).
  Proof.
    induction n in k, f |-*.
    - split; apply isΣsem0 + apply isΠsem0.
    - split.
      + rewrite PredExt with (g := fun v => exists x, f (Vector.tl (x::v)) = true) by firstorder.
        change (isΣsem (S n) (fun v => exists x, (fun v => f (Vector.tl v) = true) (x::v))).
        apply isΣsemS. apply IHn.
      + rewrite PredExt with (g := fun v => forall x, f (Vector.tl (x::v)) = true) by firstorder.
        change (isΠsem (S n) (fun v => forall x, (fun v => f (Vector.tl v) = true) (x::v))).
        apply isΠsemS. apply IHn.
  Qed.

  Lemma isΣΠn_In_ΣΠSn l :
    (forall n k (p: vec nat k -> Prop), isΣsem n p -> isΣsem (l + n) p)
/\  (forall n k (p: vec nat k -> Prop), isΠsem n p -> isΠsem (l + n) p).
  Proof.
    apply isΣsem_isΠsem_mutind; intros.
    all: try apply isΣΠsem0.
    all: replace (l + S n) with (S l + n) by lia.
    all: now constructor.
  Qed.

  Lemma isΣsem_m_red_closed :
    (forall n k (q: vec nat k -> Prop), isΣsem n q -> forall k' (p : vec nat k' -> Prop), p ⪯ₘ q -> isΣsem n p)
/\  (forall n k (q: vec nat k -> Prop), isΠsem n q -> forall k' (p : vec nat k' -> Prop), p ⪯ₘ q -> isΠsem n p).
  Proof.
    apply isΣsem_isΠsem_mutind.
    - intros k f k' p [e He].
      erewrite PredExt. 2: apply He. apply isΣsem0.
    - intros n k q Πq IH k' p [e He].
      erewrite PredExt. 2: apply He.
      unshelve erewrite PredExt. 2: eapply isΣsemS, IH.
      + exists (fun v => (Vector.hd v)::(e (Vector.tl v))).
        intros x. split; intros H; apply H.
      + reflexivity.
    - intros k f k' p [e He].
      erewrite PredExt. 2: apply He. apply isΠsem0.
    - intros n k q Πq IH k' p [e He].
      erewrite PredExt. 2: apply He.
      unshelve erewrite PredExt. 2: eapply isΠsemS, IH.
      + exists (fun v => (Vector.hd v)::(e (Vector.tl v))).
        intros x. split; intros H; apply H.
      + reflexivity.
  Qed.

  Lemma isΣsemTwoEx k n (p : vec nat (S (S k)) -> Prop):
    isΠsem n p -> isΣsem (S n) (fun v => exists y x : nat, p (x :: y :: v)).
  Proof.
    intros H.
    unshelve eapply isΣsem_m_red_closed in H.
    2: exact (fun v => let (x, y) := of_nat (VectorDef.hd v) in p (x :: y :: VectorDef.tl v)).
    2: {
      exists (fun v => let (x, y) := of_nat (VectorDef.hd v) in x :: y :: Vector.tl v).
      intros v. destruct of_nat. reflexivity.
    }
    apply isΣsemS in H. erewrite PredExt. { apply H. }
    intros v. cbv beta. split.
    - intros [y [x Hp]]. exists (to_nat (x, y)).
      now rewrite eqhd, eqtl, cancel_of_to.
    - intros [m Hp]. destruct (of_nat m) as [x y] eqn:eq. exists y, x.
      now rewrite eqhd, eqtl, eq in Hp.
  Qed.

  Lemma isΣsemE k n (p : vec nat (S k) -> Prop):
    isΣsem (S n) p -> isΣsem (S n) (fun v => exists x : nat, p (x :: v)).
  Proof.
    intros H. dependent destruction H.
    now apply isΣsemTwoEx.
  Qed.

  Lemma isΠsemTwoAll k n (p : vec nat (S (S k)) -> Prop):
    isΣsem n p -> isΠsem (S n) (fun v => forall y x : nat, p (x :: y :: v)).
  Proof.
    intros H.
    unshelve eapply isΣsem_m_red_closed in H.
    2: exact (fun v => let (x, y) := of_nat (VectorDef.hd v) in p (x :: y :: VectorDef.tl v)).
    2: {
      exists (fun v => let (x, y) := of_nat (VectorDef.hd v) in x :: y :: Vector.tl v).
      intros v. destruct of_nat. reflexivity.
    }
    apply isΠsemS in H. erewrite PredExt. { apply H. }
    intros v. cbv beta. split.
    - intros Hp m. rewrite eqhd, eqtl.
      now destruct (of_nat m) as [x y] eqn:eq.
    - intros Hp y x. specialize (Hp (to_nat (x, y))).
      now rewrite eqhd, eqtl, cancel_of_to in Hp.
  Qed.

  Lemma isΠsemA k n (p : vec nat (S k) -> Prop):
    isΠsem (S n) p -> isΠsem (S n) (fun v => forall x : nat, p (x :: v)).
  Proof.
    intros H. dependent destruction H.
    now apply isΠsemTwoAll.
  Qed.

  Lemma isΣΠn_In_ΠΣSn :
    (forall n k (p: vec nat k -> Prop), isΣsem n p -> isΠsem (S n) p)
/\  (forall n k (p: vec nat k -> Prop), isΠsem n p -> isΣsem (S n) p).
  Proof.
    split; intros n k p H.
    - eapply isΣsem_m_red_closed in H.
      2: { exists (fun v => Vector.tl v). intros v. split; intros pv; apply pv. }
      apply isΠsemS in H. erewrite PredExt. 1: apply H. firstorder.
    - eapply isΣsem_m_red_closed in H.
      2: { exists (fun v => Vector.tl v). intros v. split; intros pv; apply pv. }
      apply isΣsemS in H. erewrite PredExt. 1: apply H. firstorder.
  Qed.

  Lemma isΣsem_and_closed n :
    (forall k (p: vec nat k -> Prop), isΣsem n p -> forall (q : vec nat k -> Prop), isΣsem n q -> isΣsem n (fun v => p v /\ q v))
/\  (forall k (p: vec nat k -> Prop), isΠsem n p -> forall (q : vec nat k -> Prop), isΠsem n q -> isΠsem n (fun v => p v /\ q v)).
  Proof.
    induction n as [|n IH].
    - split.
      + intros k p Hp q Hq. dependent destruction Hp. dependent destruction Hq.
        rewrite PredExt with (g := fun v => f0 v && f v = true) by now setoid_rewrite andb_true_iff.
        apply isΣsem0.
      + intros k p Hp q Hq. dependent destruction Hp. dependent destruction Hq.
        rewrite PredExt with (g := fun v => f0 v && f v = true) by now setoid_rewrite andb_true_iff.
        apply isΠsem0.
    - split; intros k p Hp q Hq; dependent destruction Hp; dependent destruction Hq.
      + unshelve erewrite PredExt; [exact (fun v => exists y x : nat, (fun v => p (Vector.hd v:: Vector.tl (Vector.tl v)) /\ p0 (Vector.hd (Vector.tl v)::Vector.tl (Vector.tl v))) (x::y::v))| | firstorder].
       apply isΣsemTwoEx. apply IH.
        * eapply isΣsem_m_red_closed. { apply H0. }
          now exists (fun v => (Vector.hd v :: Vector.tl (Vector.tl v))).
        * eapply isΣsem_m_red_closed. { apply H. }
          now exists (fun v => Vector.hd (Vector.tl v) :: Vector.tl (Vector.tl v)).
      + unshelve erewrite PredExt; [exact (fun v => forall y x : nat, (fun v => p (Vector.hd v:: Vector.tl (Vector.tl v)) /\ p0 (Vector.hd (Vector.tl v)::Vector.tl (Vector.tl v))) (x::y::v))| | firstorder].
        apply isΠsemTwoAll. apply IH.
        * eapply isΣsem_m_red_closed. { apply H0. }
          now exists (fun v => (Vector.hd v :: Vector.tl (Vector.tl v))).
        * eapply isΣsem_m_red_closed. { apply H. }
          now exists (fun v => Vector.hd (Vector.tl v) :: Vector.tl (Vector.tl v)).
  Qed.

  Variable vec_to_nat : forall k, vec nat k -> nat.
  Variable nat_to_vec : forall k, nat -> vec nat k.
  Variable vec_nat_inv : forall k v, nat_to_vec k (vec_to_nat v) = v.
  Variable nat_vec_inv : forall k n, vec_to_nat (nat_to_vec k n) = n.

  Variable list_vec_to_nat : forall k, list (vec nat k) -> nat.
  Variable nat_to_list_vec : forall k, nat -> list (vec nat k).
  Variable list_vec_nat_inv : forall k v, nat_to_list_vec k (list_vec_to_nat v) = v.
  Variable nat_list_vec_inv : forall k n, list_vec_to_nat (nat_to_list_vec k n) = n.

  Lemma isΣΠball n :
    (forall k (p : vec nat (S k) -> Prop), isΣsem n p -> isΣsem n (fun v => forall l, l < (Vector.hd v) -> p (l::(Vector.tl v))))
/\  (forall k (p : vec nat (S k) -> Prop), isΠsem n p -> isΠsem n (fun v => forall l, l < (Vector.hd v) -> p (l::(Vector.tl v)))).
  Proof.
    induction n as [|n [IH1 IH2]]; split; intros k p H; dependent destruction H.
    - unshelve erewrite PredExt with (g := fun v => (fix f' n v := match n with 0 => true | S n => f(n::v) && f' n v end)(Vector.hd v)(Vector.tl v) = true). 1: apply isΣsem0.
      intros v. dependent destruction v. clear.
      rewrite eqhd, eqtl. induction h as [|n IH].
      + split; lia.
      + split.
        * intros H. apply andb_true_iff. split; [apply H;lia|]. apply IH. intros l H'. apply H. lia.
        * intros [H H']%andb_true_iff. intros l le. assert (l = n \/ l < n) as [->|] by lia; [apply H | now apply IH].
    - unshelve erewrite PredExt with (g := fun v => (fix f' n v := match n with 0 => true | S n => f(n::v) && f' n v end)(Vector.hd v)(Vector.tl v) = true). 1: apply isΠsem0.
      intros v. dependent destruction v. clear.
      rewrite eqhd, eqtl. induction h as [|n IH].
      + split; lia.
      + split.
        * intros H. apply andb_true_iff. split; [apply H;lia|]. apply IH. intros l H'. apply H. lia.
        * intros [H H']%andb_true_iff. intros l le. assert (l = n \/ l < n) as [->|] by lia; [apply H | now apply IH].
    - unshelve erewrite PredExt.
        1: exact (fun v =>
        exists L : nat,
        (fun v => let L := Vector.hd v in let N := Vector.hd (Vector.tl v) in let v := Vector.tl (Vector.tl v) in
          (fun v =>
            forall (l : nat), l < Vector.hd v ->
              (fun v =>
                let l := Vector.hd v in
                let N := Vector.hd (Vector.tl v) in
                let L := Vector.hd (Vector.tl (Vector.tl v)) in
                let v := Vector.tl (Vector.tl (Vector.tl v)) in
                let L' := nat_to_vec N L in
                let xl := match Compare_dec.lt_dec l N with left lt => Vector.nth L' (of_nat_lt lt) | right _ => 42 end in
                  (fun v => p0 (Vector.tl v))(N::xl::l::v)
              )(l::v)
          )(N::L::v)
        )(L::v)).
      2: {
        clear n IH1 IH2 H. intros v. cbn. dependent destruction v. rewrite eqhd. rewrite eqtl.
        induction h as [|n [IH1 IH2]].
        - firstorder lia.
        - split.
          + intros H. specialize (IH1 ltac:(intros l leq; apply H; lia)) as [L Hl].
            remember (nat_to_vec n L) as L'. destruct (H n ltac:(lia)) as [x Hx].
            exists (vec_to_nat(Vector.shiftin x L')). intros l lt. rewrite vec_nat_inv.
            destruct Compare_dec.lt_dec as [lt'|]; [|contradiction].
            assert (l = n \/ l < n) as [->|lt''] by lia.
            * enough ((shiftin x L')[@of_nat_lt lt'] = x) as -> by assumption.
              clear. induction L' as [|y k' L' IH]; [reflexivity|apply IH].
            * enough ((shiftin x L')[@of_nat_lt lt'] = L'[@of_nat_lt lt'']) as ->. { specialize (Hl l lt''). destruct Compare_dec.lt_dec;[|contradiction]. erewrite of_nat_ext. eauto. }
              clear. induction L' in l, lt', lt'' |-*; induction l; try lia + reflexivity + apply IHL'.
          + intros [L H] l lt. eexists. now apply H.
      }
      remember (fun v =>
        let l := Vector.hd v in
        let N := Vector.hd (Vector.tl v) in
        let L := Vector.hd (Vector.tl (Vector.tl v)) in
        let v := Vector.tl (Vector.tl (Vector.tl v)) in
        let L' := nat_to_vec N L in
        let xl := match Compare_dec.lt_dec l N with left lt => Vector.nth L' (of_nat_lt lt) | right _ => 42 end in
          (fun v => p0 (Vector.tl v))(N::xl::l::v)
      ) as p'.
      remember (fun v => forall (l : nat), l < Vector.hd v -> p'(l::v)) as p''.
      apply isΣsemS.
      unshelve eapply isΣsem_m_red_closed. 2: apply p''. 2: {
        exists (fun v => let L := Vector.hd v in
        let N := Vector.hd (Vector.tl v) in
        let v := Vector.tl (Vector.tl v) in (N :: L :: v)).
        intros v. now do 2 dependent destruction v.
      }
      rewrite Heqp''. specialize (IH2 _ p'). cbn in IH2.
      eapply isΣsem_m_red_closed. 1: apply IH2. 2: {
        exists (fun v => (Vector.hd v)::(Vector.hd v)::(Vector.tl v)).
        intros v. now dependent destruction v.
      }
      rewrite Heqp'.
      eapply isΣsem_m_red_closed. apply H.
      exists (fun v : vec nat (S (S (S k))) =>
      let l := Vector.hd v in
      let N := Vector.hd (Vector.tl v) in
      let L := Vector.hd (Vector.tl (Vector.tl v)) in
      let v0 := Vector.tl (Vector.tl (Vector.tl v)) in
      let L' := nat_to_vec N L in
      let xl :=
        match Compare_dec.lt_dec l N with
        | left lt => L'[@of_nat_lt lt]
        | right _ => 42
        end in Vector.tl (N :: xl :: l :: v0)).
      now intros.
  - unshelve erewrite PredExt. {
      exact (fun v =>
      forall L : nat,
      (fun v => let L := Vector.hd v in let N := Vector.hd (Vector.tl v) in let v := Vector.tl (Vector.tl v) in
        (fun v =>
          forall (l : nat), l < Vector.hd v ->
            (fun v =>
              let l := Vector.hd v in
              let N := Vector.hd (Vector.tl v) in
              let L := Vector.hd (Vector.tl (Vector.tl v)) in
              let v := Vector.tl (Vector.tl (Vector.tl v)) in
              let L' := nat_to_vec N L in
              let xl := match Compare_dec.lt_dec l N with left lt => Vector.nth L' (of_nat_lt lt) | right _ => 42 end in
                (fun v => p0 (Vector.tl v))(N::xl::l::v)
            )(l::v)
        )(N::L::v)
      )(L::v)).
    } 2: {
      clear n IH1 IH2 H. intros v. cbn. dependent destruction v. rewrite eqhd, eqtl.
      induction h as [|n [IH1 IH2]].
      - firstorder lia.
      - split.
        + firstorder.
        + intros H l lt x.
          specialize (H (vec_to_nat (Vector.const x (S n))) l lt).
          rewrite vec_nat_inv in H. destruct Compare_dec.lt_dec; [|lia].
          now rewrite Vector.const_nth in H.
    }
    remember (fun v =>
      let l := Vector.hd v in
      let N := Vector.hd (Vector.tl v) in
      let L := Vector.hd (Vector.tl (Vector.tl v)) in
      let v := Vector.tl (Vector.tl (Vector.tl v)) in
      let L' := nat_to_vec N L in
      let xl := match Compare_dec.lt_dec l N with left lt => Vector.nth L' (of_nat_lt lt) | right _ => 42 end in
        (fun v => p0 (Vector.tl v))(N::xl::l::v)
    ) as p'.
    remember (fun v => forall (l : nat), l < Vector.hd v -> p'(l::v)) as p''.
    apply isΠsemS.
    unshelve eapply isΣsem_m_red_closed. 2: apply p''. 2: {
      exists (fun v => let L := Vector.hd v in
      let N := Vector.hd (Vector.tl v) in
      let v := Vector.tl (Vector.tl v) in (N :: L :: v)).
      intros v. now do 2 dependent destruction v.
    }
    rewrite Heqp''. specialize (IH1 _ p').
    eapply isΣsem_m_red_closed. 1: apply IH1. 2: {
      exists (fun v => (Vector.hd v)::(Vector.hd v)::(Vector.tl v)).
      intros v. now dependent destruction v.
    }
    rewrite Heqp'.
    eapply isΣsem_m_red_closed. apply H.
    exists (fun v : vec nat (S (S (S k))) =>
    let l := Vector.hd v in
    let N := Vector.hd (Vector.tl v) in
    let L := Vector.hd (Vector.tl (Vector.tl v)) in
    let v0 := Vector.tl (Vector.tl (Vector.tl v)) in
    let L' := nat_to_vec N L in
    let xl :=
      match Compare_dec.lt_dec l N with
      | left lt => L'[@of_nat_lt lt]
      | right _ => 42
      end in Vector.tl (N :: xl :: l :: v0)).
    now intros.
  Qed.

  Lemma isΣsemListΣ {k k'} (p : vec nat k -> Prop) n:
    (isΣsem n p -> isΣsem n
      (fun v : vec nat (S k') =>
        List.Forall p (nat_to_list_vec k (Vector.hd v))))
  /\
    (isΠsem n p -> isΠsem n
      (fun v : vec nat (S k') =>
        List.Forall p (nat_to_list_vec k (Vector.hd v)))).
  Proof.
    assert ((fun v : vec nat (S k') => Forall p (nat_to_list_vec k (Vector.hd v)))
    ⪯ₘ (fun v : vec nat (S (S k')) =>
        forall l : nat,
        l < Vector.hd v ->
        (fun v0 : vec nat (S (S k')) =>
         p (nth (Vector.hd v0) (nat_to_list_vec k (Vector.hd (Vector.tl v0))) (const 42 k)))
          (l :: Vector.tl v))) as mred. {
      exists (fun v => (length (nat_to_list_vec k (Vector.hd v)))::v).
      intros v. dependent destruction v. cbn.
      remember (nat_to_list_vec k h) as L. clear.
      rewrite List.Forall_forall. split.
      - intros H l lt. apply H. now apply List.nth_In.
      - intros H x i. eapply List.In_nth in i as [l [lt <-]]. now apply H.
    }
    split. all: intros H.
    all: unshelve eapply isΣsem_m_red_closed. 2, 4: exact (
      fun v : vec nat (S (S k')) =>
        forall l : nat,
        l < (Vector.hd v) ->
        (fun v =>
          p (List.nth (Vector.hd v) (nat_to_list_vec k (Vector.hd (Vector.tl v))) (const 42 k)))(l:: Vector.tl v)
    ).
    2, 4: apply mred.
    all: apply isΣΠball.
    all: eapply isΣsem_m_red_closed.
    1, 3: apply H.
    all: eexists; intros v; split; apply (fun x => x).
  Qed.

  (* Σ and Π are complements **)

  Definition DN := forall P, ~~P -> P.

  Definition Markov: Prop :=
    forall f: nat -> bool, ~(forall x, f x = false) -> exists n, f n = true.

  Lemma Markov_Forster:
    Markov <-> forall f : nat -> bool, ~~ (exists n, f n = true) -> exists n, f n = true.
  Proof.
    unfold Markov. split.
    - intros MP f nnE. apply MP. intros A. apply nnE. intros [n Hn]. congruence.
    - intros MP f nA. apply MP.
      intros nE. apply nA. intros x. destruct f eqn:eq.
      + exfalso. apply nE. now exists x.
      + reflexivity.
  Qed.

  Lemma DN_Markov : DN -> Markov.
  Proof.
    unfold DN, Markov.
    intros DN. intros f nA.
    assert (~(forall x, ~(f x = true))). {
      intros A. apply nA. intros x. specialize (A x). now destruct f.
    }
    apply DN. firstorder.
  Qed.

  Lemma Σ0sem_notΠ0_int :
    (forall k (p : vec nat k -> Prop), isΣsem 0 p -> isΠsem 0 (fun v => ~ (p v)))
 /\ (forall k (p : vec nat k -> Prop), isΠsem 0 p -> isΣsem 0 (fun v => ~ (p v))).
  Proof.
    split.
    all: intros k p H; inversion H.
    all: assert ((fun v : vec nat k => f v <> true) = (fun v : vec nat k => (fun v => if f v then false else true) v = true)) as -> by (apply PredExt; intros; now destruct f).
    all: constructor.
  Qed.

  Lemma int_notEx_Allnot {X} k (p: vec X (S k) -> Prop):
    forall v, (~(exists x, p (x::v)) <-> (forall x, ~p (x::v))).
  Proof. clear. firstorder. Qed.

  Lemma Σ1sem_notΠ1_int :
    forall k (p : vec nat k -> Prop), isΣsem 1 p -> isΠsem 1 (fun v => ~ (p v)).
  Proof.
    intros k p H.
    dependent destruction H.
    erewrite PredExt. 2: apply int_notEx_Allnot.
    change (isΠsem 1 (fun v : vec nat k => forall x : nat, (fun v => ~ p0 v )(x :: v))).
    apply isΠsemS.
    now apply Σ0sem_notΠ0_int.
  Qed.

  Lemma Π1sem_notΣ1_MP :
    Markov -> forall k (p : vec nat k -> Prop), isΠsem 1 p -> isΣsem 1 (fun v => ~ (p v)).
  Proof.
    unfold Markov. intros Markov k p H.
    dependent destruction H.
    dependent destruction H.
    replace (fun v : vec nat k => ~ (forall x : nat, f (x :: v) = true)) with (fun v : vec nat k => exists x : nat, (fun v => (if f v then false else true) = true)(x :: v)).
    - change (isΣsem 1 (fun v : vec nat k => exists x : nat, (fun v => (if f v then false else true) = true)(x :: v))). apply isΣsemS, isΠsem0.
    - apply PredExt. intros v. split.
      + intros [x H] nA. specialize (nA x). rewrite nA in H. discriminate.
      + intros nA. apply Markov. intros H. apply nA. intros x. specialize (H x). now destruct f.
  Qed.

  Lemma Π1sem_notΣ1_MP_inv :
    (forall k (p : vec nat k -> Prop), isΠsem 1 p -> isΣsem 1 (fun v => ~ (p v))) -> Markov.
  Proof.
    intros H f nA.
      specialize (H 0 (fun v => forall x, (fun v => (fun v => if f (Vector.hd v) then false else true) v = true) (x::v)) ltac:(apply isΠsemS, isΣsem0)).
      cbn in H. repeat dependent destruction H.
      assert ((fun (_:vec nat 0) => ~ (forall x : nat, (if f x then false else true) = true))(Vector.nil nat)) as H. {
        intros nA'. apply nA. intros x. specialize (nA' x). now destruct f.
      }
      rewrite H0 in H. destruct H as [x Hx]. rewrite <- Hx in H0.
      rewrite <- Hx.
      exists x. destruct f eqn:eqf; [easy|].
  Abort.

  Lemma equiv_DN_sdec :
    (forall k (p : vec nat k -> Prop), semi_decidable p -> semi_decidable (fun v => ~~p v))
    <->
    (forall k (p : vec nat k -> Prop), isΠsem 1 p -> isΣsem 1 (fun v => ~ (p v))).
  Proof.
    split.
    - intros Hsdec k p H. repeat dependent destruction H.
      assert (semi_decidable (fun v => (exists x, f(x::v) = false))) as sdec. {
        unfold semi_decidable, semi_decider.
        exists (fun v x => if f(x::v) then false else true).
        intros v. split.
        - intros [x Hx]. exists x. now destruct f.
        - intros [x Hx]. exists x. now destruct f.
      }
      specialize (Hsdec _ _ sdec) as [f' Hf']. unfold semi_decider in Hf'.
      assert (forall v, ~~(exists x, f (x::v) = false) <-> ~forall x, f(x::v) = true) as eq. {
        enough (forall v, f v = true <-> ~f v = false) as eq by (setoid_rewrite eq; firstorder).
        intros v. now destruct f.
      }
      setoid_rewrite eq in Hf'. apply PredExt in Hf' as ->.
      change (isΣsem 1 (fun v => exists x, (fun v => f' (Vector.tl v) (Vector.hd v) = true) (x::v))).
      apply isΣsemS, isΠsem0.
    - intros H k p [f Hf]. unfold semi_decidable, semi_decider in *.
      assert (isΠsem 1 (fun v => ~p v)) as HΠ. {
        assert (forall x, ~p x <-> forall n, ~f x n = true) as ->%PredExt by firstorder.
        change (isΠsem 1 (fun v => forall x, (fun v => f (Vector.tl v) (Vector.hd v) <> true) (x::v))).
        apply isΠsemS.
        enough (forall v, f (Vector.tl v) (Vector.hd v) <> true <-> (fun v => if f (Vector.tl v) (Vector.hd v) then false else true) v = true) as ->%PredExt by apply isΣsem0.
        intros v. now destruct f.
      }
      specialize (H _ _ HΠ). repeat dependent destruction H.
      exists (fun v x => f0 (x::v)). intros v.
      change ((fun v : vec nat k => ~ ~ p v) v <-> (fun v : vec nat k => exists x : nat, f0 (x :: v) = true) v).
      now rewrite H0.
  Qed.

  Lemma equiv_sdec_functions :
    (forall k alpha, exists beta, forall (x : vec nat k), ~ (forall (n : nat), alpha x n = false) <-> (exists (n : nat), beta x n = true))
    <->
    (forall k (p : vec nat k -> Prop), semi_decidable p -> semi_decidable (fun v => ~~p v)).
  Proof.
    unfold semi_decidable, semi_decider.
    split.
    - intros H k p [f Hf].
      specialize (H _ f) as [f' Hf'].
      exists f'.
      intros x. rewrite <- Hf'.
      rewrite Hf.
      assert (~ (forall n : nat, f x n <> true) <-> ~ ~ (exists n : nat, f x n = true)) as <- by firstorder.
      split. all: intros nA A; apply nA; intros n; specialize (A n); now destruct f.
    - intros H k f.
      specialize (H k (fun v => exists x, f v x = true) ltac:(firstorder)) as [f' Hf'].
      exists f'. setoid_rewrite <- Hf'.
      intros v. assert (~ (forall n : nat, f v n <> true) <-> ~ ~ (exists n : nat, f v n = true)) as <- by firstorder.
      split. all: intros nA A; apply nA; intros n; specialize (A n); now destruct f.
  Qed.

  Goal
    (forall k alpha, exists beta, forall (x : vec nat k), ~ (forall (n : nat), alpha x n = false) <-> (exists (n : nat), beta x n = true))
    <->
    (forall k (p : vec nat k -> Prop), isΠsem 1 p -> isΣsem 1 (fun v => ~ (p v))).
  Proof. rewrite equiv_sdec_functions. apply equiv_DN_sdec. Qed.

  Lemma negΣinΠsem:
    DN ->
     (forall n k (p: vec nat k -> Prop), isΣsem n p -> isΠsem n (fun v => ~(p v)))
  /\ (forall n k (p: vec nat k -> Prop), isΠsem n p -> isΣsem n (fun v => ~(p v))).
  Proof.
    intros DN.
    apply isΣsem_isΠsem_mutind.
    - intros. apply Σ0sem_notΠ0_int. constructor.
    - intros n k p H IH.
      erewrite PredExt.
      + eapply isΠsemS. apply IH.
      + intros v. split.
        * intros nE. intros x c. apply nE. eexists. apply c.
        * intros A [x nP]. now apply (A x).
    - intros. apply Σ0sem_notΠ0_int. constructor.
    - intros n k p H IH.
      erewrite PredExt.
      + eapply isΣsemS. apply IH.
      + intros v. split.
        * intros nA. apply DN. intros nE.
          apply nA. intros x. apply DN. intros nP.
          apply nE. now exists x.
        * intros [x nP] A. now apply nP.
  Qed.

End ArithmeticalHierarchySemantic.


(*|
#######################################################################
How to set defaults for implicit arguments when they can't be inferred?
#######################################################################

:Link: https://proofassistants.stackexchange.com/q/1013
|*)

(*|
Question
********

If I had a module declared as follows in file ``A.v``:
|*)

Section A.
  Context {X : Set}.
  Inductive abt := Abt_leaf (x : X) | Abt_node.
End A.

(*| And in another file, ``B.v``, I had: |*)

(* Require Import A. *)
Definition X := nat.
Inductive typ := Tpe_num | Typ_str.
Fail Definition typ_to_abt (t : typ) : abt (* @abt X *) := Abt_node. (* .fails .unfold *)

(*|
How could I let Coq know I **always** want ``abt`` to be ``@abt X`` in
``B.v``? The intent is to avoid explicitly specifying them using
``@``.
|*)

(*|
Answer
******

Not sure how robust that is, but you can do something quite nice using
`typeclasses
<https://coq.inria.fr/refman/addendum/type-classes.html>`__.
|*)

Reset Initial. (* .none *)
Section A.
  Class leaf_type := X : Type.
  Context `{L : leaf_type}.
  Inductive abt := Abt_leaf (x : X) | Abt_node.
End A.

Section B.
  #[local] Instance nat_leaf : leaf_type := nat.

  Inductive typ := Tpe_num | Typ_str.
  Definition typ_to_abt (t : typ) : abt := Abt_node.
End B.

(*|
To elaborate on what is happening here, we are first declaring a class
``leaf_type``, that Coq will try to infer on its own automatically
whenever it can, and ``abt`` makes use of that typeclass. In section
B, we put this to work: we declare ``nat`` as a ``#[local]`` instance,
so that whenever an implicit argument of type ``leaf_type`` is
encountered in that section, Coq will find the local instance ``nat``
and be happy with it. Once you close the section, the instance is gone
and you can declare another one later on.
|*)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e338m15_14limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import List.

Require Import Logic.Axiom.LEM.
Require Import Logic.List.Filter.

Require Import Logic.Set.Set.
Require Import Logic.Set.Incl.
Require Import Logic.Set.Elem.
Require Import Logic.Set.Equal.
Require Import Logic.Set.ToList.
Require Import Logic.Set.Functional.
Require Import Logic.Set.Compatible.
Require Import Logic.Set.Extensionality.

Require Import Logic.Set.Normal.Normal.

(* Axiom schema of replacement assuming LEM for our Coq meta-logic.             *)
Theorem replacementLEM : forall (p:set -> set -> Prop),
    LEM ->
    compatible2 p ->
    functional p  ->
    forall (x:set),
        exists (y:set), forall (z:set),
            z :: y <-> exists (u:set), u :: x /\ p u z.
Proof.
    intros p L C F x.
    remember (toList x) as xs eqn:H1.
    remember (fun x y => p x y /\ Normal y) as q eqn:Q.
    assert (forall (x:set) (y y':set), q x y -> q x y' -> y = y') as H2.
    { rewrite Q. intros u y y' [H3 H4] [H5 H6]. apply normalEqualSame.
        { assumption. }
        { assumption. }
        { apply (F u); assumption. } }
    assert (exists (ys:list set), forall (y:set),
        In y ys <-> exists (u:set), In u xs /\ q u y) as H3.
    { apply filterReplace; assumption. }
    destruct H3 as [ys H3]. exists (fromList ys). intros z. split; intros H4.
    - rewrite toListElem, toListFromList in H4. destruct H4 as [z' [H4 [H5 H6]]].
      apply H3 in H4. rewrite Q in H4. destruct H4 as [u [H7 [H8 H9]]].
      exists u. split.
        + apply toListElem. exists u. split.
            { rewrite <- H1. assumption. }
            { split; apply inclRefl. }
        + apply (C u u z' z).
            { apply equalRefl. }
            { apply doubleIncl. split; assumption. }
            { assumption. }
    - apply toListElem. rewrite toListFromList. remember (normal z) as z' eqn:Z.
      exists z'. destruct H4 as [u [H4 H5]]. apply toListElem in H4.
      destruct H4 as [u' [H4 [H6 H7]]]. split.
        + apply H3. exists u'. split.
            { rewrite H1. assumption. }
            { rewrite Q. split.
                { apply (C u u' z z').
                    { apply doubleIncl. split; assumption. }
                    { rewrite Z. apply equalSym, normalEqual. }
                    { assumption. }}
                { rewrite Z. apply normalNormal. }}
        + apply doubleIncl. rewrite Z. apply equalSym, normalEqual.
Qed.

(* Again, this is simply to demonstrate explicit dependency in x in not needed. *)
Corollary replacementLEM_ : forall (p:set -> set -> set -> Prop),
    LEM ->
    compatible3 p ->
    forall (x:set),
    functional (p x)  ->
        exists (y:set), forall (z:set),
            z :: y <-> exists (u:set), u :: x /\ p x u z.
Proof.
    intros p L C x F. apply replacementLEM.
    - assumption.
    - apply Comp3Comp2. assumption.
    - assumption.
Qed.

(* A proof of the axiom schema of specification based on replacement.           *)
Theorem specificationLEM : forall (p:set -> Prop),
    LEM ->
    compatible p ->
    forall (x:set), exists (y:set), forall (z:set),
        z :: y <-> z :: x /\ p z.
Proof.
    intros p L C. remember (fun x y => p x /\ (x == y)) as q eqn:Q.
    assert (compatible2 q) as Cq.
        { unfold compatible2. rewrite Q. intros x x' y y' H1 H2 [H3 H4]. split.
            { apply (C x x'); assumption. }
            { apply equalTrans with x.
                { apply equalSym. assumption. }
                { apply equalTrans with y; assumption. }}}
    assert (functional q) as Fq.
        { unfold functional. rewrite Q. intros x y y' [H1 H2] [H3 H4].
          apply equalTrans with x.
            { apply equalSym. assumption. }
            { assumption. }}
    intros x. remember (replacementLEM q L Cq Fq x) as R eqn:E. clear E.
    destruct R as [y R]. exists y. intros z. destruct (R z) as [H1 H2].
    rewrite Q in H1. split; intros H.
    -  apply H1 in H. clear H1 H2.
      destruct H as [u [H1 [H2 H3]]]. split.
        + apply elemCompatL with u; assumption.
        + apply (C u z); assumption.
    - apply H2. exists z. destruct H as [H3 H4]. split.
        + assumption.
        + rewrite Q. split.
            { assumption. }
            { apply equalRefl. }
Qed.


(** * The goldfish-piranha program. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import Streams Basics QArith String Lqa.
Local Open Scope program_scope.
Local Open Scope string_scope.

From ITree Require Import
  ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From cwp Require Import
  compile cotree cotcwp cpGCL cpo cwp equidistribution eR misc itree order tactics tree.
Local Open Scope cpGCL_scope.

Require Import prelude.

(** STATS:
  n:                   10000000
  # true:              6665372
  % true:              0.6665372
  time elapsed:        8.282017s
  avg time per sample: 8.282017e-07
  random bit total:    26663474
  avg bits per sample: 2.6663474
*)

(** The goldfish-piranha program. *)
Definition gp : cpGCL :=
  flip "f" (1#2);
  CChoice (const (1#2))
    (fun b => if b then
             "r" <-- (fun s => s "f")
           else
             "r" <-- const true);
  obs (fun s => s "r").

(** Goldfish-piranha is a well-formed program. *)
Lemma wf_gp : wf_cpGCL gp.
Proof. repeat constructor; unfold const; try lra; intros []; constructor. Qed.

(** Goldfish-piranha equidistribution theorem. *)
Section gp_equidistribution.
  Context (env : SamplingEnvironment) (P : St -> bool) (samples : nat -> St).
  Hypothesis bitstreams_samples :
    forall i, iproduces (eq (samples i)) (env.(bitstreams) i) (cpGCL_to_itree gp empty).

  Theorem gp_samples_equidistributed :
    converges (freq (is_true ∘ P) ∘ prefix samples)
      (cwp gp (fun s => if P s then 1 else 0) empty).
  Proof. eapply cpGCL_samples_equidistributed; eauto; apply wf_gp. Qed.
End gp_equidistribution.

(** Extracting the sampler. *)
From Coq Require Import ExtrOcamlBasic ExtrOcamlString.
Definition sampler : itree boolE bool :=
  ITree.map (fun s => as_bool (s "f")) (cpGCL_to_itree gp empty).
Extraction "extract/gp/gp.ml" sampler.

(* Definition gp_cotree : cotree bool bool := icotree sampler. *)
(* Definition gp_chain (n : nat) : atree bool bool := tprefix n gp_cotree. *)
(* Eval compute in (List.map (Qred ∘ btwpQ (fun b : bool => if b then 1%Q else 0%Q)) (misc.prefix gp_chain 30)). *)


Require Export GeoCoq.Elements.OriginalProofs.proposition_31.
Require Export GeoCoq.Elements.OriginalProofs.lemma_crossbar2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_supplementinequality.
Require Export GeoCoq.Elements.OriginalProofs.lemma_angletrichotomy2.
Require Export GeoCoq.Elements.OriginalProofs.lemma_supplementsymmetric.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma proposition_29 :
   forall A B C D E G H,
   Par A B C D -> BetS A G B -> BetS C H D -> BetS E G H -> TS A G H D ->
   CongA A G H G H D /\ CongA E G B G H D /\ RT B G H G H D.
Proof.
intros.
assert (Col C H D) by (conclude_def Col ).
assert (neq G H) by (forward_using lemma_betweennotequal).
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (neq C D) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists R, (BetS A R D /\ Col G H R /\ nCol G H A)) by (conclude_def TS );destruct Tf as [R];spliter.
assert (TS D G H A) by (conclude lemma_oppositesidesymmetric).
assert (nCol G H D) by (conclude_def TS ).
assert (nCol D H G) by (forward_using lemma_NCorder).
assert (Col D H C) by (forward_using lemma_collinearorder).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (Col D H H) by (conclude_def Col ).
assert (neq C H) by (forward_using lemma_betweennotequal).
assert (nCol C H G) by (conclude lemma_NChelper).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col C H C) by (conclude_def Col ).
assert (neq C D) by (forward_using lemma_betweennotequal).
assert (nCol C D G) by (conclude lemma_NChelper).
let Tf:=fresh in
assert (Tf:exists P Q S, (BetS P G Q /\ CongA Q G H G H C /\ CongA Q G H C H G /\ CongA H G Q C H G /\ CongA P G H G H D /\ CongA P G H D H G /\ CongA H G P D H G /\ Par P Q C D /\ Cong P G H D /\ Cong G Q C H /\ Cong G S S H /\ Cong P S S D /\ Cong C S S Q /\ BetS P S D /\ BetS C S Q /\ BetS G S H)) by (conclude proposition_31);destruct Tf as [P[Q[S]]];spliter.
assert (~ Meet A B C D) by (conclude_def Par ).
assert (eq P P) by (conclude cn_equalityreflexive).
assert (neq P G) by (forward_using lemma_betweennotequal).
assert (neq G P) by (conclude lemma_inequalitysymmetric).
assert (Out G P P) by (conclude lemma_ray4).
assert (Col G S H) by (conclude_def Col ).
assert (Col G H S) by (forward_using lemma_collinearorder).
assert (CongA G H D P G H) by (conclude lemma_equalanglessymmetric).
assert (nCol P G H) by (conclude lemma_equalanglesNC).
assert (nCol G H P) by (forward_using lemma_NCorder).
assert (OS A P G H) by (conclude_def OS ).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (neq G H) by (forward_using lemma_betweennotequal).
assert (Out G H H) by (conclude lemma_ray4).
assert (~ LtA H G A H G P).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists M, (BetS P M H /\ Out G A M)) by (conclude lemma_crossbar2);destruct Tf as [M];spliter.
 assert (Cong G S H S) by (forward_using lemma_congruenceflip).
 assert (Cong S P S D) by (forward_using lemma_congruenceflip).
 let Tf:=fresh in
 assert (Tf:exists K, (BetS G M K /\ BetS D H K)) by (conclude postulate_Euclid5);destruct Tf as [K];spliter.
 assert (Col G A M) by (conclude lemma_rayimpliescollinear).
 assert (Col G M K) by (conclude_def Col ).
 assert (Col M G A) by (forward_using lemma_collinearorder).
 assert (Col M G K) by (forward_using lemma_collinearorder).
 assert (neq G M) by (conclude lemma_raystrict).
 assert (neq M G) by (conclude lemma_inequalitysymmetric).
 assert (Col G A K) by (conclude lemma_collinear4).
 assert (Col A G B) by (conclude_def Col ).
 assert (Col A G K) by (forward_using lemma_collinearorder).
 assert (Col G A B) by (forward_using lemma_collinearorder).
 assert (Col G A K) by (forward_using lemma_collinearorder).
 assert (neq A G) by (forward_using lemma_betweennotequal).
 assert (neq G A) by (conclude lemma_inequalitysymmetric).
 assert (Col A B K) by (conclude lemma_collinear4).
 assert (Col H D K) by (conclude_def Col ).
 assert (Col H D C) by (forward_using lemma_collinearorder).
 assert (neq H D) by (forward_using lemma_betweennotequal).
 assert (Col D K C) by (conclude lemma_collinear4).
 assert (Col C D K) by (forward_using lemma_collinearorder).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ LtA H G P H G A).
 {
 intro.
 assert (nCol P G H) by (forward_using lemma_NCorder).
 assert (CongA P G H H G P) by (conclude lemma_ABCequalsCBA).
 assert (LtA P G H H G A) by (conclude lemma_angleorderrespectscongruence2).
 assert (~ Col H G A).
  {
  intro.
  assert (Col G H A) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (CongA H G A A G H) by (conclude lemma_ABCequalsCBA).
 assert (CongA A G H H G A) by (conclude lemma_equalanglessymmetric).
 assert (LtA P G H A G H) by (conclude lemma_angleorderrespectscongruence).
 assert (eq H H) by (conclude cn_equalityreflexive).
 assert (Out G H H) by (conclude lemma_ray4).
 assert (Supp P G H H Q) by (conclude_def Supp ).
 assert (BetS D H C) by (conclude axiom_betweennesssymmetry).
 assert (eq G G) by (conclude cn_equalityreflexive).
 assert (neq H G) by (conclude lemma_inequalitysymmetric).
 assert (Out H G G) by (conclude lemma_ray4).
 assert (Supp D H G G C) by (conclude_def Supp ).
 assert (CongA G H D D H G) by (conclude lemma_ABCequalsCBA).
 assert (CongA P G H D H G) by (conclude lemma_equalanglestransitive).
 assert (CongA H G Q G H C) by (conclude lemma_supplements).
 assert (Supp A G H H B) by (conclude_def Supp ).
 assert (LtA H G B H G Q) by (conclude lemma_supplementinequality).
 assert (BetS B G A) by (conclude axiom_betweennesssymmetry).
 assert (eq G G) by (conclude cn_equalityreflexive).
 assert (Col G H G) by (conclude_def Col ).
 assert (~ Col G H B).
  {
  intro.
  assert (Col A G B) by (conclude_def Col ).
  assert (Col B G A) by (forward_using lemma_collinearorder).
  assert (Col B G H) by (forward_using lemma_collinearorder).
  assert (neq G B) by (forward_using lemma_betweennotequal).
  assert (neq B G) by (conclude lemma_inequalitysymmetric).
  assert (Col G A H) by (conclude lemma_collinear4).
  assert (Col H G A) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (TS B G H A) by (conclude_def TS ).
 assert (TS A G H B) by (conclude lemma_oppositesidesymmetric).
 assert (OS A P G H) by (conclude_def OS ).
 assert (OS P A G H) by (forward_using lemma_samesidesymmetric).
 assert (TS P G H B) by (conclude lemma_planeseparation).
 let Tf:=fresh in
 assert (Tf:exists L, (BetS P L B /\ Col G H L /\ nCol G H P)) by (conclude_def TS );destruct Tf as [L];spliter.
 assert (BetS B L P) by (conclude axiom_betweennesssymmetry).
 assert (CongA G H C H G Q) by (conclude lemma_equalanglessymmetric).
 assert (nCol H G Q) by (conclude lemma_equalanglesNC).
 assert (~ Col G H Q).
  {
  intro.
  assert (Col H G Q) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (BetS Q G P) by (conclude axiom_betweennesssymmetry).
 assert (OS B Q G H) by (conclude_def OS ).
 assert (eq Q Q) by (conclude cn_equalityreflexive).
 assert (neq Q G) by (forward_using lemma_betweennotequal).
 assert (neq G Q) by (conclude lemma_inequalitysymmetric).
 assert (Out G Q Q) by (conclude lemma_ray4).
 let Tf:=fresh in
 assert (Tf:exists M, (BetS Q M H /\ Out G B M)) by (conclude lemma_crossbar2);destruct Tf as [M];spliter.
 assert (Cong G S H S) by (forward_using lemma_congruenceflip).
 assert (BetS Q S C) by (conclude axiom_betweennesssymmetry).
 assert (Cong S Q C S) by (conclude lemma_congruencesymmetric).
 assert (Cong S Q S C) by (forward_using lemma_congruenceflip).
 assert (nCol G H C) by (forward_using lemma_NCorder).
 let Tf:=fresh in
 assert (Tf:exists K, (BetS G M K /\ BetS C H K)) by (conclude postulate_Euclid5);destruct Tf as [K];spliter.
 assert (Col G B M) by (conclude lemma_rayimpliescollinear).
 assert (Col G M K) by (conclude_def Col ).
 assert (Col M G B) by (forward_using lemma_collinearorder).
 assert (Col M G K) by (forward_using lemma_collinearorder).
 assert (neq G M) by (conclude lemma_raystrict).
 assert (neq M G) by (conclude lemma_inequalitysymmetric).
 assert (Col G B K) by (conclude lemma_collinear4).
 assert (Col B G A) by (conclude_def Col ).
 assert (Col B G K) by (forward_using lemma_collinearorder).
 assert (Col G B A) by (forward_using lemma_collinearorder).
 assert (Col G B K) by (forward_using lemma_collinearorder).
 assert (neq B G) by (forward_using lemma_betweennotequal).
 assert (neq G B) by (conclude lemma_inequalitysymmetric).
 assert (Col B A K) by (conclude lemma_collinear4).
 assert (Col A B K) by (forward_using lemma_collinearorder).
 assert (Col H C K) by (conclude_def Col ).
 assert (Col H C D) by (forward_using lemma_collinearorder).
 assert (neq H C) by (forward_using lemma_betweennotequal).
 assert (Col C K D) by (conclude lemma_collinear4).
 assert (Col C D K) by (forward_using lemma_collinearorder).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ Col H G P).
 {
 intro.
 assert (Col G H P) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (~ Col H G A).
 {
 intro.
 assert (Col G H A) by (forward_using lemma_collinearorder).
 assert (nCol G H A) by (conclude_def TS ).
 contradict.
 }
assert (~ ~ CongA H G A H G P).
 {
 intro.
 assert (LtA H G A H G P) by (conclude lemma_angletrichotomy2).
 contradict.
 }
assert (CongA H G P P G H) by (conclude lemma_ABCequalsCBA).
assert (CongA H G P G H D) by (conclude lemma_equalanglestransitive).
assert (CongA G H D D H G) by (conclude lemma_ABCequalsCBA).
assert (CongA H G P D H G) by (conclude lemma_equalanglestransitive).
assert (CongA H G A D H G) by (conclude lemma_equalanglestransitive).
assert (~ Col A G H).
 {
 intro.
 assert (Col G H A) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA A G H H G A) by (conclude lemma_ABCequalsCBA).
assert (CongA A G H D H G) by (conclude lemma_equalanglestransitive).
assert (nCol D H G) by (conclude lemma_equalanglesNC).
assert (CongA D H G G H D) by (conclude lemma_ABCequalsCBA).
assert (CongA A G H G H D) by (conclude lemma_equalanglestransitive).
assert (BetS H G E) by (conclude axiom_betweennesssymmetry).
assert (CongA A G H E G B) by (conclude proposition_15a).
assert (CongA E G B A G H) by (conclude lemma_equalanglessymmetric).
assert (CongA E G B G H D) by (conclude lemma_equalanglestransitive).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (Out G H H) by (conclude lemma_ray4).
assert (Supp A G H H B) by (conclude_def Supp ).
assert (~ Col B G H).
 {
 intro.
 assert (Col A G B) by (conclude_def Col ).
 assert (Col B G A) by (forward_using lemma_collinearorder).
 assert (neq G B) by (forward_using lemma_betweennotequal).
 assert (neq B G) by (conclude lemma_inequalitysymmetric).
 assert (Col G H A) by (conclude lemma_collinear4).
 assert (Col A G H) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA B G H B G H) by (conclude lemma_equalanglesreflexive).
assert (CongA G H D A G H) by (conclude lemma_equalanglessymmetric).
assert (CongA A G H H G A) by (conclude lemma_ABCequalsCBA).
assert (CongA G H D H G A) by (conclude lemma_equalanglestransitive).
assert (Supp B G H H A) by (conclude lemma_supplementsymmetric).
assert (RT B G H G H D) by (conclude_def RT ).
close.
Qed.

End Euclid.


(* SPDX-License-Identifier: GPL-2.0 *)
Require Import List.
Require Import Bool.
Require Import NArith PArith ZArith.

Set Implicit Arguments.

Definition Value := nat.
Definition default : Value := 0.
Definition Address := nat.
Definition TID := nat.
Definition RegID := nat.
Definition View := nat.

Inductive Promise :=
| WRITE : TID -> Value -> Address -> Promise
| PUSH : TID -> Address -> Promise
| PULL : TID -> Address -> Promise
.

Inductive Expr :=
| CONST (val : Value) : Expr
| VAR (reg : RegID) : Expr
| ADD (e1 : Expr) (e2 : Expr) : Expr
.

Inductive InternalEvent :=
| MOV : RegID -> Expr -> InternalEvent
| BRANCH : RegID -> InternalEvent
.

Inductive Event :=
| INTERNAL : InternalEvent -> Event
| ORACLE : RegID -> Value -> Event
| LOAD : Address -> View -> RegID -> Event
| ACQ : View -> Address -> Event
| STORE : Address -> View -> RegID -> Event
| REL : View ->  Address -> Event
.

Definition RegState := RegID -> Value.
Definition MemState := Address -> Value.

Definition update {T : Type} s addr (val : T) :=
    (fun (x : nat) => if beq_nat x addr then val else s x).

(* Lemma about update *)
Lemma update_same :
    forall {T} s addr (val : T), update s addr val addr = val.
Proof.
    intros. unfold update. rewrite <- beq_nat_refl. reflexivity.
Qed.

Lemma update_not_same :
    forall {T} s addr (val : T) addr' (Hneq : addr <> addr'), update s addr val addr' = s addr'.
Proof.
    intros. unfold update. replace (beq_nat addr' addr) with false. easy.
    symmetry. rewrite beq_nat_false_iff. auto.
Qed.

Definition OwnershipMap := Address -> option TID.

Fixpoint eval (e : Expr) (st : RegState) : option Value :=
    match e with
    | CONST val => Some val
    | VAR reg => Some (st reg)
    | ADD e1 e2 =>
        match eval e1 st with
        | None => None
        | Some v1 =>
            match eval e2 st with
            | None => None
            | Some v2 => Some (v1 + v2)
            end
        end
    end.

Lemma eval_exists :
    forall e st, exists v, eval e st = Some v.
Proof.
    induction e; intro.
    -   esplit; simpl; auto.
    -   esplit; simpl; auto.
    -   specialize (IHe1 st). destruct IHe1 as (v1 & Hv1).
        specialize (IHe2 st). destruct IHe2 as (v2 & Hv2).
        esplit. simpl.
        rewrite Hv1. rewrite Hv2. reflexivity.
Qed.

Definition execute_internal (i : InternalEvent) (st : RegState) : option RegState :=
    match i with
    | MOV reg e =>
                match eval e st with
                | None => None
                | Some val => Some (update st reg val)
                end
    | _ => Some st
    end.

Lemma execute_internal_exists :
        forall i st, exists rs, execute_internal i st = Some rs.
Proof.
    destruct i.
    -   intros. induction e.
        +   simpl. eexists. reflexivity.
        +   simpl. eexists. reflexivity.
        +   simpl. destruct IHe1 as (rs1 & Hrs1).
            destruct IHe2 as (rs2 & Hrs2).
            simpl in *. destruct (eval e1 st); try discriminate.
            destruct (eval e2 st); try discriminate.
            esplit. reflexivity.
    -   intros. simpl. esplit. reflexivity.
Qed.


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(*    AtomicJl:
        Decidable, Tag-Based (Atomically) Semantic Subtyping
        for Nominal Types, Pairs, and Unions.  *)

(** * AtomicJl: Propositions about Matching Relation *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..". (* root directory of the repo *)

Require Import Mechanization.Aux.Identifier.

Require Import Mechanization.AtomicJl.BaseDefs.
Require Import Mechanization.AtomicJl.BaseProps.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.

Open  Scope btjm_scope.

(* ################################################################# *)
(** ** Basic Properties *)
(* ################################################################# *)

(** Only a _value_ type _matches a type. *)
Lemma match_ty__value_type : forall (v t : ty),
    |- v <$ t ->
    value_type v.
Proof.
  intros v t H; induction H;
    try solve [assumption | constructor; assumption].
Qed.

(** Any value type matches itself. *)
Lemma match_valty__rflxv : forall (v : ty),
    value_type v ->
    |- v <$ v.
Proof.
  intros v Hval; induction Hval; constructor; assumption.
Qed.

(** A value type matches only an eqivalent value type. *)
Lemma valty_match_valty__equal : forall (v1 v2 : ty),
    |- v1 <$ v2 ->
    value_type v2 ->
    v1 = v2.
Proof.
  intros v1 v2 Hm; induction Hm; intros Hval2;
    try solve [inversion Hval2].
  - (* CName, CName *)
    reflexivity.
  - (* Pair *)
    inversion Hval2; subst.
    apply IHHm1 in H1. apply IHHm2 in H2.
    subst; reflexivity.
Qed.

(* ################################################################# *)
(** ** Decidability *)
(* ################################################################# *)

(* DEP: cname_eq__decidable, valty_match_valty__equal,
        match_ty__value_type *)
Theorem match_ty__dcdbl : forall (v t : ty),
    Decidable.decidable (|- v <$ t).
Proof.
  intros v; induction v; intros t.
  - (* CName *)
    assert (Hval1: value_type (TCName c)) by constructor.
    induction t.
    + (* CName *)
      destruct (cname_eq__decidable c c0).
      * subst; left; constructor.
      * right; intros Hcontra.
        assert (Hval2: value_type (TCName c0)) by constructor.
        pose proof (valty_match_valty__equal _ _ Hcontra Hval2) as Heq.
        inversion Heq; contradiction.
    + (* AName *)
      destruct c; destruct a;
        try solve [
              left; constructor
            | right; intros Hcontra; inversion Hcontra ].
    + (* Pair *)
      right; intros Hcontra; inversion Hcontra.
    + (* Union *)
      destruct IHt1 as [IH1 | IH1]; destruct IHt2 as [IH2 | IH2];
        try solve [ left; apply MT_Union1; assumption
                  | left; apply MT_Union2; assumption ].
      right; intros Hcontra.
      inversion Hcontra; subst; contradiction.
  - (* AName *)
    right; intros Hcontra.
    apply match_ty__value_type in Hcontra; inversion Hcontra.
  - (* Pair *)
    induction t.
    + (* CName *)
      right; intros Hcontra; inversion Hcontra.
    + (* AName *)
      right; intros Hcontra; inversion Hcontra.
    + (* Pair *)
      destruct (IHv1 t1) as [IH1 | IH1];
        destruct (IHv2 t2) as [IH2 | IH2];
        try solve [right; intros Hcontra;
                   inversion Hcontra; subst; contradiction].
      left; constructor; assumption.
    + (* Union *)
      destruct IHt1 as [IH1 | IH1];
        destruct IHt2 as [IH2 | IH2];
        try solve [
              left; apply MT_Union1; assumption
            | left; apply MT_Union2; assumption ].
      right; intros Hcontra.
      inversion Hcontra; contradiction.
  - (* Union *)
    right; intros Hcontra.
    apply match_ty__value_type in Hcontra.
    inversion Hcontra.
Qed.


Section IW.

(* the type of indices *)
Variable I:Type.

(* selects the different constructors and the non-recursive arguments *)
Variable A:Type.

(* each member of B denotes one recursive occurrence in the constructor.
Only the cardinality matters *)
Variable B: A -> Type.

(* the index for the conclusion *)
Variable AI: A -> I.

(* the index for each recursive occurrence in B *)
Variable BI: forall a, B a -> I.

Inductive IWT : I ->Type :=
iwt : forall (a:A), (forall (b:B a), IWT (BI a b)) -> IWT (AI a).

Inductive IWP : I ->Prop :=
iwp : forall (a:A), (forall (b:B a), IWP (BI a b)) -> IWP (AI a).

Definition getA (i: I) (t : IWT i) : A :=
match t with
iwt a  _ => a
end.

End IW.

(* leAA := (unit + nat) *)
Definition leWB (b:(unit + nat)):= if b then False else True.

Definition leAI n (b:(unit + nat)):=
    (match b with
              | inl _ => n
              | inr m => S m
              end).

Definition leBI n (b:(unit + nat)):=
    (match b with
              | inl _ => n
              | inr m => m
              end).

Definition leW (n:nat): nat -> Prop :=
  IWP nat (unit + nat) leWB (leAI n) (fun b _ => leBI n b).

Lemma leW_iff : forall n m, le n m <-> leW n m.
Proof using.
split; intro H.
- unfold leW. induction H.
  + apply (@iwp nat (unit + nat) leWB (leAI n) (fun b _ => leBI n b) (inl tt)).
    simpl.
    tauto.
  + apply (@iwp nat (unit + nat) leWB (leAI n) (fun b _ => leBI n b) (inr m)).
    simpl. intros _. assumption.
- induction H.
  subst. clear H. rename H0 into H.
  destruct a; simpl in *.
  + clear H. constructor.
  + constructor. tauto.
Qed.

Require Import common.

(*
Parametricity Recursive IWT.
Print IWT_R.
Parametricity Recursive IWP.
Print IWP_R.
*)

Inductive IWT_R (I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type) (AI₁ : A₁ -> I₁)
(AI₂ : A₂ -> I₂) (AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
  : forall (H : I₁) (H0 : I₂), I_R H H0 -> IWT I₁ A₁ B₁ AI₁ BI₁ H -> IWT I₂ A₂ B₂ AI₂ BI₂ H0 -> Type :=
    iwt_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂)
                    (H : forall b : B₁ a₁, IWT I₁ A₁ B₁ AI₁ BI₁ (BI₁ a₁ b))
                    (H0 : forall b : B₂ a₂, IWT I₂ A₂ B₂ AI₂ BI₂ (BI₂ a₂ b)),
                  (forall (b₁ : B₁ a₁) (b₂ : B₂ a₂) (b_R : B_R a₁ a₂ a_R b₁ b₂),
                   IWT_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                     (BI₁ a₁ b₁) (BI₂ a₂ b₂) (BI_R a₁ a₂ a_R b₁ b₂ b_R)
                     (H b₁) (H0 b₂)) ->
                  IWT_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                    (AI₁ a₁) (AI₂ a₂) (AI_R a₁ a₂ a_R) (iwt I₁ A₁ B₁ AI₁ BI₁ a₁ H)
                    (iwt I₂ A₂ B₂ AI₂ BI₂ a₂ H0).

Inductive IWP_R (I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type) (AI₁ : A₁ -> I₁)
(AI₂ : A₂ -> I₂) (AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
  : forall (H : I₁) (H0 : I₂), I_R H H0 -> IWP I₁ A₁ B₁ AI₁ BI₁ H -> IWP I₂ A₂ B₂ AI₂ BI₂ H0 -> Prop :=
    iwp_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂)
                    (H : forall b : B₁ a₁, IWP I₁ A₁ B₁ AI₁ BI₁ (BI₁ a₁ b))
                    (H0 : forall b : B₂ a₂, IWP I₂ A₂ B₂ AI₂ BI₂ (BI₂ a₂ b)),
                  (forall (b₁ : B₁ a₁) (b₂ : B₂ a₂) (b_R : B_R a₁ a₂ a_R b₁ b₂),
                   IWP_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                     (BI₁ a₁ b₁) (BI₂ a₂ b₂) (BI_R a₁ a₂ a_R b₁ b₂ b_R)
                     (H b₁) (H0 b₂)) ->
                  IWP_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                    (AI₁ a₁) (AI₂ a₂) (AI_R a₁ a₂ a_R) (iwp I₁ A₁ B₁ AI₁ BI₁ a₁ H)
                    (iwp I₂ A₂ B₂ AI₂ BI₂ a₂ H0).
Require Import List.
Import ListNotations.

Require Import common.
Print IWP_R.

Scheme IRP_indd := Induction for IWP Sort Prop.

Require Import PiTypeR.

(* the statement and proof are independent of the parametricity translation *)
Lemma IWP_RPW_aux_half
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(A_R_tot : TotalHeteroRel A_R) (* TotalHeteroRel implies TotalHeteroRelP *)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))
:
(IWP I₁ A₁ B₁ AI₁ BI₁ H) -> (IWP I₂ A₂ B₂ AI₂ BI₂ H0).
Proof using.
  rename H into i₁.
  rename H0 into i₂.
  intros Hyp.
  revert i_R.
  revert i₂.
  induction Hyp as [a₁ Ha Hb].
(* replace i₂ with something of the form (AI₂ a₂), so that the constructor of IWP
    can be invoked *)
  pose proof (fst A_R_tot a₁) as Haa.
  Check iwt.
  intros.
  destruct Haa as [a₂ a_R].
  pose proof (AI_R _ _ a_R) as ir2.
  pose proof (proj1 I_R_iso _ _ _ i_R ir2) as Hir2.
  subst. clear ir2. constructor.
  intros b₂.
  pose proof (snd (B_R_tot _ _ a_R) b₂) as Hbr.
  destruct Hbr as [b₁ b_R].
  apply Hb with (b:=b₁).
  eapply BI_R. apply b_R.
Defined.

Lemma IWP_RPW_aux_half2
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(I_R_iso : oneToOne I_R)
(A_R_tot : TotalHeteroRel A_R)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), IffRel (B_R _ _ a_R)) (* iff is not sufficient. need totalit *)
:
(IWP I₁ A₁ B₁ AI₁ BI₁ H) -> (IWP I₂ A₂ B₂ AI₂ BI₂ H0).
Proof using.
  rename H into i₁.
  rename H0 into i₂.
  intros Hyp.
  revert i_R.
  revert i₂.
  induction Hyp as [a₁ Ha Hb].
(* replace i₂ with something of the form (AI₂ a₂), so that the constructor of IWP
    can be invoked *)
  pose proof (fst A_R_tot a₁) as Haa.
  Check iwt.
  intros.
  destruct Haa as [a₂ a_R].
  pose proof (AI_R _ _ a_R) as ir2. (* similarly, iff wont be sufficient for A_R *)
  pose proof (proj1 I_R_iso _ _ _ i_R ir2) as Hir2.
  subst. clear ir2. constructor.
  intros b₂.
  pose proof (snd (B_R_tot _ _ a_R) b₂) as b1.
  apply Hb with (b:=b1).
  (* we need br to be able to invoke BI_R *)
  apply BI_R with (a_R := a_R).
Abort.

Print Assumptions IWP_RPW_aux_half.

Require Import Trecord.
Require Import SquiggleEq.UsefulTypes.

Fixpoint IWP_RPW_aux_half2
(I₁ I₂ : Set) (I_R : BestRel I₁ I₂) (A₁ A₂ : Set) (A_R : BestRel A₁ A₂)
(B₁ : A₁ -> Set) (B₂ : A₂ -> Set)
(B_R : forall (H : A₁) (H0 : A₂), BestR A_R H H0 -> BestRel (B₁ H) (B₂ H0))
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), BestR A_R H H0 -> (BestR I_R) (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : BestR A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        BestR (B_R a₁ a₂ a_R) H H0 -> (BestR I_R) (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : BestR I_R H H0)
 (p1: IWP I₁ A₁ B₁ AI₁ BI₁ H) : (IWP I₂ A₂ B₂ AI₂ BI₂ H0) :=
(match p1 in IWP _ _ _ _ _ i1 return forall i2, BestR I_R i1 i2 -> IWP I₂ A₂ B₂ AI₂ BI₂ i2
with
| iwp _ _ _ _ _ a1 f1 =>
  let a2 := projT1 (fst (Rtot A_R) a1) in
  let ar := projT2 (fst (Rtot A_R) a1) in
  let f2 := (fun b2 =>
      let b1 := projT1 (snd (Rtot (B_R a1 a2 ar)) b2) in
      let br := projT2 (snd (Rtot (B_R a1 a2 ar)) b2) in
      (IWP_RPW_aux_half2  _ _ I_R _ _ A_R  _ _ B_R _ _  AI_R _ _ BI_R
        _ _ (BI_R _ _ ar _ _ br) (f1 b1))
        ) in
  let c2 := (iwp I₂ A₂ B₂ AI₂ BI₂ a2 f2) in
  fun i2 ir =>
    let peq := @BestOne12 I₁ I₂ I_R (AI₁ a1) i2 (AI₂ a2) ir (AI_R a1 a2 ar) in
    @transport I₂ (AI₂ a2) i2 (fun i : I₂ => IWP I₂ A₂ B₂ AI₂ BI₂ i) peq c2
  end) H0 i_R.

Require Import common.
Lemma IWP_RPW_aux
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(A_R_tot : TotalHeteroRel A_R)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))
:
(IWP I₁ A₁ B₁ AI₁ BI₁ H) <-> (IWP I₂ A₂ B₂ AI₂ BI₂ H0).
Proof using.
  intros.
  rename H into i₁.
  rename H0 into i₂. split.
- eapply IWP_RPW_aux_half; eauto.
- eapply IWP_RPW_aux_half with (I_R := rInv I_R) (A_R := rInv A_R)
  (B_R:=rPiInv B_R); try assumption; [ | | | | ]; rInv.
Qed.

Lemma IWP_R_complete
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(irrel : relIrrUptoEq I_R) (* automatic for Set *)
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(A_R_tot : TotalHeteroRel A_R) (* TotalHeteroRel implies TotalHeteroRelP *)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))
:
  CompleteRel (IWP_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof.
  intros x y.
  rename H into i₁.
  rename H0 into i₂.
  revert i_R.
  revert y.
  revert i₂.
  induction x  as [xa xb Hind]  using IRP_indd.
  intros ? ? ?.
  set (y2 := IWP_RPW_aux_half _ _ _ _ _ _ _ _ _ _  _ AI_R _ _ BI_R _ _ i_R
                              I_R_iso A_R_tot B_R_tot (iwp I₁ A₁ B₁ AI₁ BI₁ xa xb)).
  pose proof (ProofIrrelevance.proof_irrelevance _ y y2).
  subst y.
  unfold y2.
  simpl. clear y2.
  destruct (fst A_R_tot xa) as [a₂ ar].
  pose proof (AI_R _ _ ar) as ir2.
  pose proof (proj1 I_R_iso _ _ _ i_R ir2) as Hir2.
  subst i₂.
  unfold eq_ind_r, eq_ind.
  rewrite <- ProofIrrelevance.ProofIrrelevanceTheory.EqdepTheory.eq_rect_eq.
  simpl.
  specialize (irrel _ _ i_R (AI_R xa a₂ ar)). subst.
  constructor.
  intros. apply Hind.
Qed.

Lemma IWP_R_complete_simpl
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(irrel : relIrrUptoEq I_R) (* automatic for Set *)
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(A_R_tot : TotalHeteroRel A_R) (* TotalHeteroRel implies TotalHeteroRelP *)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))
(x : IWP I₁ A₁ B₁ AI₁ BI₁ H)
:
(IWP I₂ A₂ B₂ AI₂ BI₂ H0) * (forall y : IWP I₂ A₂ B₂ AI₂ BI₂ H0,
IWP_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R H H0 i_R x y).
Proof.
  rename H into i₁.
  rename H0 into i₂.
  revert i_R.
  revert i₂.
  induction x  as [a₁ b₁ Hb]  using IRP_indd.
  pose proof (fst A_R_tot a₁) as Haa.
  destruct Haa as [a₂ a_R].
  intros.
  pose proof (AI_R _ _ a_R) as ir2. (* similarly, iff wont be sufficient for A_R *)
  pose proof (proj1 I_R_iso _ _ _ i_R ir2) as Hir2.
  subst. clear ir2.
  evar ( c2 : IWP I₂ A₂ B₂ AI₂ BI₂ (AI₂ a₂)).
  Unshelve. Focus 2.
     constructor.
     intros b₂.
     pose proof (snd (B_R_tot _ _ a_R) b₂) as b1.
     destruct b1 as [b1 br].
     apply Hb with (b:=b1). apply BI_R with (a_R:=a_R). exact br.
  (* the above is the same as iff *)

  split;[exact c2|].
  intro.

  (* this is the only extra step vs iff/totality *)
  pose proof (ProofIrrelevance.proof_irrelevance _ y c2).
  subst y.
  unfold c2.
  simpl.

  (* the totality infrastructure already does this. it creates a proof
    of the equality of all the indices_Rs at once -- the generalized equality type.
    just matching on that proof should suffice here, perhaps the same way it already does
     *)
  specialize (irrel _ _ i_R (AI_R _ _ a_R)). subst.
  constructor.

  (* this step is trivial.can directly code. No need to use any Pi type combinator *)
  intros.
  exact (snd (Hb _  _ _) _).
Defined.

Lemma IWP_RPW_aux_total
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(A_R_tot : TotalHeteroRel A_R)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), IffRel (B_R _ _ a_R))
:
  TotalHeteroRel (IWP_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof using.
  intros.
  eapply Prop_RSpec.
  (* this route needs completeness which is too much to ask for *)
Abort.

(* iff implies TotalHeteroRel -- we should return the relation \r1 r2 => True.
We can also return IWP_R -- see below *)
Definition IWP_RP2
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(A_R_tot : TotalHeteroRel A_R)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))
:
{R: (IWP I₁ A₁ B₁ AI₁ BI₁ H) -> (IWP I₂ A₂ B₂ AI₂ BI₂ H0) -> Prop & TotalHeteroRel R}.
Proof using.
  exists (fun x y => True). simpl.
  split; intros a; unfold rInv.
- rewrite IWP_RPW_aux in a; eauto; try assumption.
- rewrite <-  IWP_RPW_aux in a; eauto; try assumption.
Defined.

(*
(* Check IWP_R_iwp_R, then replace IWP_R by proj1_sig IWP_RW *)
Lemma iwp_RW :
 forall (I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type)
         (A_R : A₁ -> A₂ -> Type) (B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
         (B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
         (AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
         (AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
         (BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
         (BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
                 B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
         (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂)
         (H : forall b : B₁ a₁, IWP I₁ A₁ B₁ AI₁ BI₁ (BI₁ a₁ b))
         (H0 : forall b : B₂ a₂, IWP I₂ A₂ B₂ AI₂ BI₂ (BI₂ a₂ b))
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(A_R_tot : TotalHeteroRelP A_R) (* TotalHeteroRel implies TotalHeteroRelP *)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRelP (B_R _ _ a_R)),
       (forall (b₁ : B₁ a₁) (b₂ : B₂ a₂) (b_R : B_R a₁ a₂ a_R b₁ b₂),
        proj1_sig
          (@IWP_RP I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
              (BI₁ a₁ b₁) (BI₂ a₂ b₂) (BI_R a₁ a₂ a_R b₁ b₂ b_R)
              I_R_iso A_R_tot B_R_tot)
          (H b₁)
          (H0 b₂)) ->
        proj1_sig
            (@IWP_RP I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
            (AI₁ a₁) (AI₂ a₂) (AI_R a₁ a₂ a_R) I_R_iso A_R_tot B_R_tot)
         (iwp I₁ A₁ B₁ AI₁ BI₁ a₁ H)
         (iwp I₂ A₂ B₂ AI₂ BI₂ a₂ H0).
Proof using.
  intros. simpl in *. exact I.
Qed.
 *)

Definition IWT_RR :=
     fix
       ReflParam_PIWNew_IWT_RR0 (I I₂ : Type) (I_R : I -> I₂ -> Type)
                                (A A₂ : Type) (A_R : A -> A₂ -> Type)
                                (B : A -> Type) (B₂ : A₂ -> Type)
                                (B_R : forall (H1 : A) (H2 : A₂),
                                       A_R H1 H2 -> B H1 -> B₂ H2 -> Type)
                                (AI : A -> I) (AI₂ : A₂ -> I₂)
                                (AI_R : forall (H1 : A) (H2 : A₂),
                                        A_R H1 H2 -> I_R (AI H1) (AI₂ H2))
                                (BI : forall a : A, B a -> I)
                                (BI₂ : forall a₂ : A₂, B₂ a₂ -> I₂)
                                (BI_R : forall (H1 : A) (H2 : A₂)
                                          (H3 : A_R H1 H2) (H6 : B H1)
                                          (H7 : B₂ H2),
                                        B_R H1 H2 H3 H6 H7 -> I_R (BI H1 H6) (BI₂ H2 H7))
                                (H : I) (H0 : I₂) (H1 : I_R H H0)
                                (H2 : IWT I A B AI BI H) (H3 : IWT I₂ A₂ B₂ AI₂ BI₂ H0)
                                {struct H2} : Type :=
          let reT i1 i2 := forall (ir : I_R i1 i2), Type in
         (match H2 as iwt1 in IWT _ _ _ _ _ i1 return reT i1 H0
         with
         | iwt _ _ _ _ _ a x =>
             match H3 as iwt2 in IWT _ _ _ _ _ i2 return reT (AI a) i2
             with
             | iwt _ _ _ _ _ a₂ x0 =>
              fun ir =>
                 {a_R : A_R a a₂ &
                 {_
                 : forall (a1 : B a) (a2 : B₂ a₂) (p : B_R a a₂ a_R a1 a2),
                   ReflParam_PIWNew_IWT_RR0 I I₂ I_R  A A₂ A_R B B₂ B_R AI AI₂ AI_R BI BI₂
                     BI_R (BI a a1) (BI₂ a₂ a2) (BI_R a a₂ a_R a1 a2 p)
                     (x a1) (x0 a2) & (ir=(AI_R a a₂ a_R))}}
             end
          end) H1.

Lemma IWT_RR_complete
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(irrel : relIrrUptoEq I_R)
(A_R_complete : CompleteRel A_R) (* this is a too strong assumption, especially
if A:Set even if the IWT/P is in Prop *)
:
  CompleteRel (IWT_RR _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof.
  intros x y.
  rename H into i₁.
  rename H0 into i₂.
  revert i_R.
  revert y.
  revert i₂.
  induction x as [xa xb Hind]. intros ? ?. destruct y as [ya yb].
  simpl. intros ?.
  exists (A_R_complete xa ya).
  eexists. intros. apply Hind.
  apply irrel.
Defined.

Lemma IWT_R_total_half
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(irrel : relIrrUptoEq I_R)
(A_R_tot : TotalHeteroRel A_R)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))
(B_R_iso : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), oneToOne (B_R _ _ a_R))
(B_R_irrel : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), relIrrUptoEq (B_R _ _ a_R))

:
  TotalHeteroRelHalf (IWT_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof using.
  intros.
  rename H into i₁.
  rename H0 into i₂.
  intros Hyp.
  revert i_R.
  revert i₂.
  induction Hyp as [a₁ Ha Hb].
  pose proof (fst A_R_tot a₁) as Haa.
  intros.
  destruct Haa as [a₂ a_R].
  pose proof (AI_R _ _ a_R) as ir2.
  pose proof (proj1 I_R_iso _ _ _ i_R ir2) as Hir2.
  subst.
  specialize (fun b₁ b₂ b_R => Hb b₁ (BI₂ a₂ b₂) (BI_R _ _ a_R _ _ b_R)).
  (* the i_R in the lemma may not be of the form cretIndices_R.
    So, irrel is needed *)
  specialize (irrel _ _ i_R (AI_R a₁ a₂ a_R)). subst.
  clear ir2.
  exists (iwt I₂ A₂ B₂ AI₂ BI₂ a₂
    (fun b₂ => let b1p := (snd (B_R_tot _ _ a_R) b₂)
    in (projT1 (Hb _ b₂ (projT2 b1p))))).
  constructor.
  intros. destruct (snd (B_R_tot a₁ a₂ a_R)).
  unfold rInv in *.
  simpl.
  destruct (Hb x b₂ r). simpl in *. clear Hb.
  pose proof (proj2 (B_R_iso  _ _ _) _ _ _ b_R r). subst.
  pose proof (B_R_irrel _ _ _ _ _ r b_R). subst.
  exact i.
Defined.

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

Set Implicit Arguments.

Lemma IWT_R_inv:
forall (I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type)
  (A_R : A₁ -> A₂ -> Type) (B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
  (B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
  (AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
  (AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
  (BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
  (BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
          B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0)) (H : I₁)
  (H0 : I₂) (i_R : I_R H H0) (t2 : IWT I₂ A₂ B₂ AI₂ BI₂ H0) (t1 : IWT I₁ A₁ B₁ AI₁ BI₁ H),
IWT_R I₂ I₁ (rInv I_R) A₂ A₁ (rInv A_R) B₂ B₁ (rPiInv B_R) AI₂ AI₁
  (fun (H1 : A₂) (H2 : A₁) (X : A_R H2 H1) => AI_R H2 H1 X) BI₂ BI₁
  (fun (a₁ : A₂) (a₂ : A₁) (a_R : A_R a₂ a₁) (H1 : B₂ a₁) (H2 : B₁ a₂)
     (X : rPiInv B_R a₁ a₂ a_R H1 H2) => BI_R a₂ a₁ a_R H2 H1 X) H0 H i_R t2 t1 ->
IWT_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R H H0 i_R t1 t2.
Proof using.
  unfold rPiInv, rInv.
  intros.
  induction X; constructor; eauto.
Qed.

(* we would need a way to invert (fun a b => R b a) relations of arbitrary type constuctors.
We have rInv and rPiInv for type vars and piTypes. But we would need to invert inductives
and to prove that the inversion preserves goodness *)

Lemma IWT_R_total
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(irrel : relIrrUptoEq I_R)
(A_R_tot : TotalHeteroRel A_R)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))
(B_R_iso : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), oneToOne (B_R _ _ a_R))
(B_R_irrel : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), relIrrUptoEq (B_R _ _ a_R))

:
  TotalHeteroRel (IWT_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof using.
  split.
- apply IWT_R_total_half; auto.
- pose proof (@IWT_R_total_half _ _ (rInv I_R) _ _ (rInv A_R) _ _ (rPiInv B_R)
   AI₂ AI₁ ltac:(rInv)
  BI₂ BI₁ ltac:(rInv) _ _ i_R
  ltac:(rInv) ltac:(rInv) ltac:(rInv)
  ltac:(rInv) ltac:(rInv) ltac:(rInv)
) as Hh.
  (*  unfold TotalHeteroRelHalf, R_Pi, rPiInv, rInv in *. *)
  revert Hh. clear.
  intros ? t2.
  specialize (Hh t2). destruct Hh as [t1 ?]; simpl in *.
  exists t1. apply IWT_R_inv. assumption.
Qed.

(*
Require Import Coq.Logic.JMeq.
 Require Import Coq.Program.Equality. *)
Require Import ProofIrrelevance.
Require Import Coq.Logic.FunctionalExtensionality.

Lemma IWT_R_iso_half
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(A_R_iso : oneToOne A_R)
(A_R_irrel : relIrrUptoEq A_R)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))

:
  oneToOneHalf (IWT_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof using.
  rename H into i₁.
  rename H0 into i₂. intros l1 r1 r2 ir1 ir2.
  revert r2 ir2. induction ir1 as [ ? ? ? ? ? ? Hind].
  intros.
  subst.
  inversion ir2. clear H4. subst. clear ir2.
  pose proof ((proj1 A_R_iso) _ _ _ a_R a_R0 ) as heq.
  symmetry in heq.
  subst.
  apply inj_pair2 in H14. subst.
    (* inj_pair2 depends on proof irrelevance, or at least UIP in I₂.
    In the global translation, in GoodRel, we can demand UIP on the sets on both sides.
    Proof irrelevance already implies it. is UIP weaker than PI?*)
  f_equal.
  apply functional_extensionality_dep.
  intros b₂.
  destruct (B_R_tot _ _ a_R) as [btl btr].
  specialize (btr b₂).
  destruct btr as [b₁ br].
  eapply (Hind b₁ _ br );[].
  clear Hind.
  apply inj_pair2 in H12. subst.
    (* inj_pair2 depends on proof irrelevance, or at least UIP in A₁.
    In the global translation, in GoodRel, we can demand UIP on the sets on both sides*)
  Fail apply X2.
  (* a_R1 came from inversion ir2 and a_R came from induction ir1.*)
  pose proof (A_R_irrel _ _ a_R a_R1).
  subst. auto.
Defined.

Print Assumptions IWT_R_iso_half.

Lemma IWT_R_iso
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(A_R_iso : oneToOne A_R)
(A_R_irrel : relIrrUptoEq A_R)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))

:
  oneToOne (IWT_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof using.
  split.
- apply IWT_R_iso_half; auto.
- pose proof (@IWT_R_iso_half _ _ (rInv I_R) _ _ (rInv A_R) _ _ (rPiInv B_R)
   AI₂ AI₁ ltac:(rInv)
  BI₂ BI₁ ltac:(rInv) _ _ i_R
  ltac:(rInv) ltac:(rInv) ltac:(rInv)
) as Hh.
  unfold TotalHeteroRelHalf, R_Pi, rPiInv, rInv in *.
  revert Hh. clear.
  intros ? ? ? ? p1 p2.
  unfold oneToOneHalf in Hh.
  specialize (Hh _ _ _ (IWT_R_inv _ _ p1) (IWT_R_inv _ _ p2)).
  assumption.
Qed.

Print Assumptions  IWT_R_iso.

Require Import Coq.Logic.JMeq.
Require Import Coq.Program.Equality.

Definition rellIrrUptoEq5  {A B : Type} (R : A -> B -> Type)  :=
 forall  a1 b1 a2 b2 (p1 : R a1 b1) (p2 : R a2 b2) (_:a1=a2) (_:b1=b2),
    @EqdepFacts.eq_dep _ (fun p => R (fst p) (snd p)) (a1,b1) p1 (a2,b2) p2 .

Lemma rellIrrUptoEq5_implies {A B : Type} (R : A -> B -> Type):
   rellIrrUptoEq5 R ->  relIrrUptoEq R .
Proof.
  intros H4 ? ? ? ?.
  specialize (H4 _ _ _ _ p1 p2 eq_refl eq_refl).
  apply eq_dep_eq in H4.
  auto.
Qed.

Unset Implicit Arguments.

Inductive unicity (A I:Type) (f: A-> I) : I-> Type :=
uni :  forall a, unicity A I f (f a).

Lemma  unicity_prove (A I:Type) (f: A-> I) i (p: unicity A I f i):
@sigT A (fun a => @sigT (i=f a) (fun e => uni _ _ _ a =@transport _ _ _ (unicity A I f) e p)).
Proof using.
  destruct p.
  exists a. exists eq_refl. reflexivity.
Qed.

Require Import Coq.Logic.EqdepFacts.

Lemma JMeq_eq_dep :
  forall U (P:U->Type) p q (x:P p) (y:P q),
  p = q -> JMeq x y -> eq_dep U P p x q y.
Proof.
  intros.
  destruct H.
  apply JMeq_eq in H0 as ->.
  reflexivity.
Qed.

Require Import SquiggleEq.tactics.
Require Import SquiggleEq.LibTactics.

Lemma IWT_R_irrel
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(A_R_irrel : relIrrUptoEq A_R) (* to prove irrel, we only need irred (and some axioms) *)
:
  relIrrUptoEq (IWT_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof using.
  intros ? ? ?.
  induction p1 as [ ? ? ? ? ? ? Hind].
  intros ?.
  dependent destruction p2.
  clear x2.

  pose proof (@JMeq_eq_dep _ (fun i => (IWT I₁ A₁ B₁ AI₁ BI₁ i)) _ _ _ _ x0 x3)
    as Heq.
  apply (@EqdepFacts.f_eq_dep _ _ _ _ _ _ _  (getA I₁ A₁ B₁ AI₁ BI₁)) in Heq.
  simpl in Heq.
  apply eq_dep_non_dep in Heq.
  subst. clear x0.
  apply JMeq_eq in x3.

  (* the same for a₂0 *)
  pose proof (@JMeq_eq_dep _ (fun i => (IWT I₂ A₂ B₂ AI₂ BI₂ i)) _ _ _ _ x1 x4)
    as Heq.
  apply (@EqdepFacts.f_eq_dep _ _ _ _ _ _ _  (getA I₂ A₂ B₂ AI₂ BI₂)) in Heq.
  simpl in Heq.
  apply eq_dep_non_dep in Heq.
  subst. clear x1.
  apply JMeq_eq in x4. subst.

  pose proof (A_R_irrel _ _ a_R0 a_R). subst.
  inverts x3 as x3.
  apply inj_pair2 in x3. subst.

  inverts x4 as x4.
  apply inj_pair2 in x4. subst.

  apply JMeq_eq in x. subst.
  f_equal.

  apply functional_extensionality_dep.
  intros b₁.
  apply functional_extensionality_dep.
  intros b₂.
  apply functional_extensionality_dep.
  intros b_R.
  apply Hind.
Qed.

Print Assumptions IWT_R_irrel.
(*
proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2
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
JMeq_eq : forall (A : Type) (x y : A), x ~= y -> x = y (* this may not be needed *)

*)

Definition IWP_ind2  : forall (I A : Type) (B : A -> Type) (AI : A -> I) (BI : forall a : A, B a -> I)
         (P : forall i : I, IWP I A B AI BI i -> Prop),
       (forall (a : A) (i : forall b : B a, IWP I A B AI BI (BI a b)),
        (forall b : B a, P (BI a b) (i b)) -> P (AI a) (iwp I A B AI BI a i)) ->
       forall (i : I) (i0 : IWP I A B AI BI i), P i i0
:=
fun (I A : Type) (B : A -> Type) (AI : A -> I) (BI : forall a : A, B a -> I)
  (P : forall i : I, IWP I A B AI BI i -> Prop)
  (f : forall (a : A) (i : forall b : B a, IWP I A B AI BI (BI a b)),
       (forall b : B a, P (BI a b) (i b)) -> P (AI a) (iwp I A B AI BI a i)) =>
fix F (i : I) (i0 : IWP I A B AI BI i) {struct i0} : P i i0 :=
  match i0 as i2 in (IWP _ _ _ _ _ i1) return (P i1 i2) with
  | iwp _ _ _ _ _ a i1 => f a i1 (fun b : B a => F (BI a b) (i1 b))
  end.

(*IWP_RP above was better because less extras were needed.
In particular A_R iso and B_R iso and irrel was not needed.
So, we should have the translation of [Prop] and [Type] be the same.
However, we should separately translate inductives in [Type] and inductives in [Prop].
Similarly, we should separately translate functions into Type and functions into Prop

Without Proof irrelevance, IWP_R is stronger than Prop_R2. It says
that the 2 proofs use the same constructors and those constructors "similar" arguments.
Prop_R2 says nothing about the 2 proofs, besides their existence.
However, with proof irrelevance, the difference is irrelevant.
However, as mentioned above, treating Prop specially, as in IWP_RP, results
in much fewer extrans, and this riddance may snowball upstream
and result in much stronger free theorems.*)
Lemma IWP_R_total
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra*)
(I_R_iso : oneToOne I_R) (*total Hetero not needed*)
(irrel : relIrrUptoEq I_R)
(A_R_tot : TotalHeteroRel A_R)
(B_R_tot : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), TotalHeteroRel (B_R _ _ a_R))
(B_R_iso : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), oneToOne (B_R _ _ a_R))
(B_R_irrel : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂), relIrrUptoEq (B_R _ _ a_R))

:
  TotalHeteroRelHalf (IWP_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof using.
  intros.
  rename H into i₁.
  rename H0 into i₂.
  intros Hyp.
  revert i_R.
  revert i₂.
  induction Hyp as [a₁ Ha Hb] using IWP_ind2.
  pose proof (fst A_R_tot a₁) as Haa.
  intros.
  destruct Haa as [a₂ a_R].
  pose proof (AI_R _ _ a_R) as ir2.
  pose proof ((proj1 I_R_iso) _ _ _ i_R ir2) as Hir2.
  subst.
  specialize (fun b₁ b₂ b_R => Hb b₁ (BI₂ a₂ b₂) (BI_R _ _ a_R _ _ b_R)).
  specialize (irrel _ _ i_R (AI_R a₁ a₂ a_R)). subst.
  clear ir2.
  exists (iwp I₂ A₂ B₂ AI₂ BI₂ a₂
    (fun b₂ => let b1p := (snd (B_R_tot _ _ a_R) b₂)
    in (projT1 (Hb _ b₂ (projT2 b1p))))).
  constructor.
  intros. destruct (snd (B_R_tot a₁ a₂ a_R)).
  unfold rInv in *.
  simpl.
  destruct (Hb x b₂ r). simpl in *. clear Hb.
  pose proof ((proj2 (B_R_iso  _ _ _)) _ _ _ b_R r). subst.
  pose proof (B_R_irrel _ _ _ _ _ r b_R). subst.
  exact i; fail.
  Fail idtac.
Abort. (* done but not needed. see comments at the beginning*)

(*
Require Import Coq.Logic.JMeq.
 Require Import Coq.Program.Equality. *)
Require Import Coq.Logic.FunctionalExtensionality.

Definition IWP_R_rect :=
fun (I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
  (B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
  (B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
  (AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
  (AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
  (BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
  (BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
          B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
  (P : forall (i : I₁) (i0 : I₂) (i1 : I_R i i0) (i2 : IWP I₁ A₁ B₁ AI₁ BI₁ i)
         (i3 : IWP I₂ A₂ B₂ AI₂ BI₂ i0),
       IWP_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R i i0 i1 i2 i3 -> Prop)
  (f : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂)
         (i : forall b : B₁ a₁, IWP I₁ A₁ B₁ AI₁ BI₁ (BI₁ a₁ b))
         (i0 : forall b : B₂ a₂, IWP I₂ A₂ B₂ AI₂ BI₂ (BI₂ a₂ b))
         (i1 : forall (b₁ : B₁ a₁) (b₂ : B₂ a₂) (b_R : B_R a₁ a₂ a_R b₁ b₂),
               IWP_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                 (BI₁ a₁ b₁) (BI₂ a₂ b₂) (BI_R a₁ a₂ a_R b₁ b₂ b_R)
                 (i b₁) (i0 b₂)),
       (forall (b₁ : B₁ a₁) (b₂ : B₂ a₂) (b_R : B_R a₁ a₂ a_R b₁ b₂),
        P (BI₁ a₁ b₁) (BI₂ a₂ b₂) (BI_R a₁ a₂ a_R b₁ b₂ b_R) (i b₁) (i0 b₂) (i1 b₁ b₂ b_R)) ->
       P (AI₁ a₁) (AI₂ a₂) (AI_R a₁ a₂ a_R) (iwp I₁ A₁ B₁ AI₁ BI₁ a₁ i)
         (iwp I₂ A₂ B₂ AI₂ BI₂ a₂ i0)
         (iwp_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R a₁ a₂ a_R i i0
            i1)) =>
fix
F (y : I₁) (y0 : I₂) (y1 : I_R y y0) (i : IWP I₁ A₁ B₁ AI₁ BI₁ y)
  (i0 : IWP I₂ A₂ B₂ AI₂ BI₂ y0)
  (i1 : IWP_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R y y0 y1 i i0) {struct
  i1} : P y y0 y1 i i0 i1 :=
  match
    i1 as i4 in (IWP_R _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ y2 y3 y4 i2 i3)
    return (P y2 y3 y4 i2 i3 i4)
  with
  | iwp_R _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ a₁ a₂ a_R i2 i3 i4 =>
      f a₁ a₂ a_R i2 i3 i4
        (fun (b₁ : B₁ a₁) (b₂ : B₂ a₂) (b_R : B_R a₁ a₂ a_R b₁ b₂) =>
         F (BI₁ a₁ b₁) (BI₂ a₂ b₂) (BI_R a₁ a₂ a_R b₁ b₂ b_R) (i2 b₁) (i3 b₂) (i4 b₁ b₂ b_R))
  end.

(* this should be a trivial consequence of proof irrelevance *)
Lemma IWP_R_iso
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
:
  oneToOne (IWP_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof using.
  split;intros ? ? ? ? ?; apply proof_irrelevance.
Qed.

Require Import Coq.Logic.JMeq.
Require Import Coq.Program.Equality.

Require Import Coq.Logic.EqdepFacts.

Require Import SquiggleEq.tactics.
Require Import SquiggleEq.LibTactics.

Lemma IWP_R_irrel
(I₁ I₂ : Type) (I_R : I₁ -> I₂ -> Type) (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type)
(B₁ : A₁ -> Type) (B₂ : A₂ -> Type)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Type)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
 (H : I₁) (H0 : I₂) (i_R : I_R H H0)
(* extra
(A_R_irrel : relIrrUptoEq A_R)
*)
:
  relIrrUptoEq (IWP_R _ _ I_R _ _ A_R _ _ B_R _ _ AI_R _ _ BI_R _ _ i_R).
Proof using.
  intros ? ? ? ?.
  apply proof_irrelevance; fail.
Qed.

Print Prop_R.


(* -*- eval: (load-file "../LiveVerif/live_verif_setup.el"); -*- *)
Require Import coqutil.Sorting.Permutation.
Require Import LiveVerif.LiveVerifLib.
Require Import List Lia.

Load LiveVerif.

(* Any implementation of `sort` works as long as it is correct. *)
(* Specifications copied from SF Vol 3 (VFA). *)
Inductive sorted : list Z -> Prop :=
| sorted_nil :
    sorted nil
| sorted_1 : forall x,
    sorted [| x |]
| sorted_cons : forall x y l,
    x <= y -> sorted (y :: l) -> sorted (x :: y :: l).

Parameter sort : list Z -> list Z.
Axiom sort_sorted : forall l l', sort l = l' -> sorted l'.
Axiom sort_perm : forall l l', sort l = l' -> Permutation l l'.
Axiom sort_nil : sort (@nil Z) = (@nil Z).
Axiom sort_preserves_length : forall l, len l = len (sort l).
Axiom sort_app_preserves_length : forall l1 l2,
  len (sort (l1 ++ l2)) = len (sort l1) + len (sort l2).

(* Insertion function for insertion sort *)
(* insert(p, n, i) assumes A[0..(i-1)] is sorted and try to insert A[i],
   so ultimately A[0..i] is sorted. *)

#[export] Instance spec_of_real_insert: fnspec :=                                   .**/
void real_insert(uintptr_t p, uintptr_t i) /**#
  ghost_args := (R: mem -> Prop) (l1 : list Z) (x : Z);
  requires t m := sep (array (uint 32) (\[i]+1) (sort l1 ++ [|x|]) p) R m;
  ensures t' m' := t' = t /\
                   sep (array (uint 32) (\[i]+1) (sort (l1 ++ [|x|])) p) R m'
            #**/ /**.
Parameter real_insert : function_with_callees.
Parameter real_insert_ok : program_logic_goal_for "real_insert" real_insert.

#[export] Instance spec_of_insert: fnspec :=                                   .**/
void insert(uintptr_t p, uintptr_t n, uintptr_t i) /**#
  ghost_args := (R: mem -> Prop) (l1 l2 : list Z) (x : Z);
  requires t m := len (sort l1) = \[i] /\
                sep (array (uint 32) \[n] ((sort l1 ++ [|x|]) ++ l2) p) R m;
  ensures t' m' := t' = t /\
                   sep (array (uint 32) \[n] (sort (l1 ++ [|x|]) ++ l2) p) R m' /\
                   len (sort (l1 ++ [|x|])) = \[i]+1
            #**/ /**.
Derive insert SuchThat (fun_correct! insert) As insert_ok.
.**/ { /**.
  assert (len (sort l1 ++ [|x|]) = \[i]+1) by (rewrite List.len_app; simpl; ZnWords).
  .**/ real_insert(p, i); /**.
  2: {
    replace (sort l1 ++ x :: l2) with ((sort l1 ++ [|x|]) ++ l2) by steps.
    rewrite List.upto_app_discard_r by steps.
    rewrite List.upto_pastend by steps.
    reflexivity.
  }
.**/ } /*?.
step. step. step. step. step. step. step. step. step. step. step. step.
step.
change (x :: l2) with ([|x|] ++ l2).
rewrite List.from_app_discard_l.
step. step. cbn. step.
Qed.

(* Insertion sort *)
#[export] Instance spec_of_insertion_sort: fnspec :=                                   .**/
void insertion_sort(uintptr_t p, uintptr_t n) /**#
  ghost_args := (R: mem -> Prop) (arr : list Z);
  requires t m := sep (array (uint 32) \[n] arr p) R m;
  ensures t' m' := t' = t /\
            sep (array (uint 32) \[n] (sort arr) p) R m' #**/ /**.
Derive insertion_sort SuchThat (fun_correct! insertion_sort) As insertion_sort_ok.
(* open function *)
.**/ { /**.

  .**/ uintptr_t i = 0; /**.

  (* invariants - true at the beginning of the loop *)
  assert (0 <= \[i] <= \[n]) by ZnWords.
  assert (len arr = \[n]-\[i]) as lenArrR by hwlia.
  assert (len (sort nil) = \[i]) as lenArrL by
      (bottom_up_simpl_in_goal; rewrite sort_nil; auto).
  lazymatch goal with
  | H: _ |= array (uint 32) _ ?arr _ |- _ =>
      replace arr with ((sort nil) ++ arr) in H by
        (rewrite sort_nil; rewrite List.app_nil_l; auto)
  end.

  (* assign some names so we can generalize *)
  set (arrL := nil) in * |-;
  set (arrR := arr) in * |-;
  assert (arr = arrL ++ arrR) as HarrSplit by (subst arrL arrR; auto).

  (* generalize *)
  loop invariant above arrL;
  clearbody i arrL arrR.

  .**/ while (i < n) /* decreases (n ^- i) */ { /**.

    (* claim: if we're in the loop, the array is not empty,
       so we can pull an element *)
    destruct arrR as [ | x arrR' ].
    { simpl in *; exfalso; ZnWords. }

    (* structure it so we can call insert *)
    rewrite List.assoc_app_cons in *.

    .**/ insert(p,n,i); /**.
    { (* Note: not proven automatically because evars are not yet determined
         when this equality is encountered. *)
      assumption. }

    .**/ i = i+1; /**.

  (* at this point we can now close the loop *)
  (* because the lengths of left side and right side have been established *)
  .**/ } /**. end while.

(* at the end of the loop now. arrR should be empty. *)
  assert (len arrR = 0) by ZnWords.
  assert (arrR = nil) by (destruct arrR; try discriminate; auto).
  subst.

(* close the function *)
.**/ } /**.
Qed.

End LiveVerif. Comments .**/ //.