(** Copyright (c) 2018 by Swirlds, Inc.
   Implemented by Karl Crary.
*)

Require Import Nat.
Require Import Omega.

Require Import Tact.
Require Import Decide.
Require Import Majority.
Require Import Relation.
Require Import HashgraphFacts.
Require Import Sees.

(** We differ from the technical report by making the first round 0, instead of 1.

   Also, we advance to round n+1 when an event strongly-sees an event in round n
   on 2/3 of the peers.  This differs from the technical report, which requires
   that the strongly-seen event be a witness.  The two formulations are equivalent
   because you can strongly-see a round-n witness on peer a iff you can strongly-see
   any round-n event on peer a.  Formulating it this way allows us to untangle the
   circularity between the definitions of round and witness.
*)

Inductive round : nat -> event -> Prop :=
| round_initial {x} :
    initial x
    -> round 0 x

| round_nadvance {x y z m n A} :
    parents y z x
    -> round m y
    -> round n z
    -> superminority stake A every
    -> (forall a w,
          A a
          -> creator w = a
          -> stsees w x
          -> exists i, i < max m n /\ round i w)
    -> round (max m n) x

| round_advance {x y z m n A} :
    parents y z x
    -> round m y
    -> round n z
    -> supermajority stake A every
    -> (forall a,
          A a
          -> exists w,
               creator w = a
               /\ stsees w x
               /\ round (max m n) w)
    -> round (S (max m n)) x
.

(** The definition of nonterminating only says that a hashgraph
   receives events from a round >= n (for all n), but it is a consequence
   (all_rounds_inhabited) that it receives events from every round.
*)
Definition nonterminating (G : world) :=
  forall m, exists n x,
     m <= n
     /\ round n x
     /\ member G x.

(** Lemma 5.13 *)
Lemma round_fun :
  forall x m n,
    round m x
    -> round n x
    -> m = n.
Proof.
intros x m n Hm Hn.
revert m n Hm Hn.
wfinduct x using strict_ancestor_well_founded.
intros x IH m n Hm Hn.
invertc Hm.

(** initial *)
{
intros Hinit <-.
invertc Hn.
  (** initial *)
  {
  intros; subst; auto.
  }

  (** nwitness *)
  {
  intros.
  destruct Hinit.
  eauto.
  }

  (** witness *)
  {
  intros.
  destruct Hinit.
  eauto.
  }
}

(** nwitness *)
{
intros y z m1 m2 A Hparents Hroundy Hroundz Hmin Hnwit <-.
invertc Hn.
  (** initial *)
  {
  intros Hinit _.
  destruct Hinit; eauto.
  }

  (** nwitness *)
  {
  intros y' z' n1 n2 _ Hparents' Hn1 Hn2 _ _ <-.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  f_equal.
    {
    eapply IH; eauto.
    apply plus_one.
    eapply parent1; eauto.
    }

    {
    eapply IH; eauto.
    apply plus_one.
    eapply parent2; eauto.
    }
  }

  (** witness *)
  {
  intros y' z' m1' m2' B Hparents' Hroundy' Hroundz' Hmaj Hwit _.
  exfalso.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  so (IH _ (plus_one _#4 (parent1 Hparents)) _ _ Hroundy Hroundy'); subst m1'.
  so (IH _ (plus_one _#4 (parent2 Hparents)) _ _ Hroundz Hroundz'); subst m2'.
  so (superminority_supermajority_intersect _#5 eq_peer_decide Hmin Hmaj) as (a & HA & HB).
  so (Hwit a HB) as (w & Hcreator & Hss & Hround).
  so (Hnwit a w HA Hcreator Hss) as (i & Hlt & Hround').
  so (IH _ (stsees_impl_strict_ancestor _ _ Hss) _ _ Hround Hround').
  omega.
  }
}

(** witness *)
{
intros y z m1 m2 A Hparents Hroundy Hroundz Hmaj Hwit <-.
invertc Hn.
  (** initial *)
  {
  intros Hinit _.
  destruct Hinit; eauto.
  }

  (** nwitness *)
  {
  intros y' z' m1' m2' B Hparents' Hroundy' Hroundz' Hmin Hnwit <-.
  exfalso.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  so (IH _ (plus_one _#4 (parent1 Hparents)) _ _ Hroundy Hroundy'); subst m1'.
  so (IH _ (plus_one _#4 (parent2 Hparents)) _ _ Hroundz Hroundz'); subst m2'.
  so (superminority_supermajority_intersect _#5 eq_peer_decide Hmin Hmaj) as (a & HA & HB).
  so (Hwit a HB) as (w & Hcreator & Hss & Hround).
  so (Hnwit a w HA Hcreator Hss) as (i & Hlt & Hround').
  so (IH _ (stsees_impl_strict_ancestor _ _ Hss) _ _ Hround Hround').
  omega.
  }

  (** witness *)
  {
  intros y' z' m1' m2' B Hparents' Hroundy' Hroundz' _ _ <-.
  so (parents_fun _#5 Hparents Hparents') as (<- & <-).
  so (IH _ (plus_one _#4 (parent1 Hparents)) _ _ Hroundy Hroundy'); subst m1'.
  so (IH _ (plus_one _#4 (parent2 Hparents)) _ _ Hroundz Hroundz'); subst m2'.
  reflexivity.
  }
}
Qed.

Lemma round_mono :
  forall x y m n,
    x @= y
    -> round m x
    -> round n y
    -> m <= n.
Proof.
intros x y m n Hxy Hroundx Hroundy.
revert n Hxy Hroundy.
wfinduct y using parent_well_founded.
intros y IH n Hxy Hroundy.
so (star_plus _#4 Hxy) as [Heq | H].
  {
  subst y.
  so (round_fun _#3 Hroundx Hroundy).
  subst n.
  auto.
  }
fold (x @ y) in H.
renameover H into Hxy.
invert Hroundy.

(** initial *)
{
intros Hinit <-.
exfalso.
eapply strict_ancestor_initial; eauto.
}

(** nwitness *)
{
intros u v p q A Hparents Hroundu Hroundv Hmin Hnwit <-.
so (strict_ancestor_parents _#4 Hparents Hxy) as [Hxu | Hxv].
  {
  so (IH _ (parent1 Hparents) _ Hxu Hroundu).
  so (Nat.le_max_l p q).
  omega.
  }

  {
  so (IH _ (parent2 Hparents) _ Hxv Hroundv).
  so (Nat.le_max_r p q).
  omega.
  }
}

(** witness *)
{
intros u v p q A Hparents Hroundu Hroundv Hmaj Hwit <-.
so (strict_ancestor_parents _#4 Hparents Hxy) as [Hxu | Hxv].
  {
  so (IH _ (parent1 Hparents) _ Hxu Hroundu).
  so (Nat.le_max_l p q).
  omega.
  }

  {
  so (IH _ (parent2 Hparents) _ Hxv Hroundv).
  so (Nat.le_max_r p q).
  omega.
  }
}
Qed.

Lemma round_defined :
  forall x, exists n, round n x.
Proof.
intros x.
wfinduct x using strict_ancestor_well_founded.
intros x IH.
so (initial_decide x) as [Hinit | H].
  {
  exists 0.
  apply round_initial; auto.
  }
destruct H as (y & z & Hparents).
so (IH y (plus_one _#4 (parent1 Hparents))) as (m & Hroundy).
so (IH z (plus_one _#4 (parent2 Hparents))) as (n & Hroundz).
assert (forall a,
          decidable
          (exists w,
             creator w = a
             /\ stsees w x
             /\ round (max m n) w)) as Hdec.
  {
  intro a.
  apply (dec_exists_finite _ _ (fun y => y @ x)).
    {
    intros v Hv.
    destruct Hv as (_ & Hv & _).
    apply stsees_impl_strict_ancestor; auto.
    }

    {
    apply strict_ancestor_finite.
    }
  intros w.
  apply dec_and.
    { apply eq_peer_decide. }
  apply dec_and_dep.
    {
    apply stsees_decide.
    }
  intro Hss.
  so (IH _ (stsees_impl_strict_ancestor _ _ Hss)) as (l & Hround).
  so (dec_eq_nat l (max m n)) as [Heq | Hneq].
    {
    subst l.
    left; auto.
    }
  right.
  intros Hround'.
  so (round_fun _#3 Hround Hround').
  contradiction.
  }
eassert (_) as H; [refine (supermajority_decide _#5 Hdec _ the_total_stake) |].
  { unfold incl, every; auto. }
destruct H as [Hmaj | Hnmaj].
  {
  exists (S (max m n)).
  eapply round_advance; eauto.
  }

  {
  exists (max m n).
  so (not_supermajority_every _#4 Hdec the_total_stake Hnmaj) as Hmin.
  eapply round_nadvance; eauto.
  cbn.
  intros a w Hnwit <- Hss.
  so (stsees_impl_strict_ancestor _ _ Hss) as Hwx.
  so (IH _ Hwx) as (i & Hround).
  exists i.
  split; auto.
  so (lt_eq_lt_dec i (max m n)) as [[Hlt | Heq]| Hlt]; auto.
    {
    subst i.
    destruct Hnwit.
    exists w.
    do2 2 split; auto.
    }
  exfalso.
  so (Nat.max_lub_lt_iff _#3 andel Hlt) as (Hltm & Hltn).
  so (strict_ancestor_parents _#4 Hparents Hwx) as [Hwy | Hwz].
    {
    so (round_mono _#4 Hwy Hround Hroundy).
    omega.
    }

    {
    so (round_mono _#4 Hwz Hround Hroundz).
    omega.
    }
  }
Qed.

Lemma round_decide :
  forall r x,
    decidable (round r x).
Proof.
intros r x.
so (round_defined x) as (r' & Hround).
so (dec_eq_nat r r') as [Heq | Hneq].
  {
  subst r'.
  left; auto.
  }
right.
contradict Hneq.
eapply round_fun; eauto.
Qed.

Definition earlier (x y : event) : Prop :=
  exists m n,
    round m x
    /\ round n y
    /\ m < n.

Notation "x << y" := (earlier x y)
  (at level 70, right associativity) : event_scope.

Lemma rounds_earlier :
  forall x y m n,
    round m x
    -> round n y
    -> m < n
    -> x << y.
Proof.
intros x y m n Hx Hy Hlt.
exists m, n.
auto.
Qed.

Lemma earlier_rounds :
  forall x y m n,
    x << y
    -> round m x
    -> round n y
    -> m < n.
Proof.
intros x y m n Hxy Hx Hy.
destruct Hxy as (m' & n' & Hx' & Hy' & Hlt).
so (round_fun _#3 Hx Hx'); subst m'.
so (round_fun _#3 Hy Hy'); subst n'.
exact Hlt.
Qed.

Lemma earlier_trans :
  forall x y z,
    x << y
    -> y << z
    -> x << z.
Proof.
intros x y z Hxy Hyz.
destruct Hxy as (m & n & Hx & Hy & Hmn).
destruct Hyz as (n' & p & Hy' & Hz & Hnp).
so (round_fun _#3 Hy Hy'); subst n'.
clear Hy Hy'.
eapply rounds_earlier; eauto.
omega.
Qed.

Definition witness (x : event) : Prop :=
  initial x
  \/ exists y, self_parent y x /\ y << x.

Lemma strict_self_ancestor_witness :
  forall x y m n,
    witness y
    -> x $ y
    -> round m x
    -> round n y
    -> m < n.
Proof.
intros x y m n Hwit Hxy Hroundx Hroundy.
destruct Hwit as [Hinit | H].
  {
  exfalso.
  eapply strict_ancestor_initial; eauto.
  apply strict_self_ancestor_impl_strict_ancestor; eauto.
  }
destruct H as (z & Hparent & Hzy).
destruct Hzy as (p & n' & Hroundz & Hroundy' & Hlt).
so (round_fun _#3 Hroundy Hroundy'); subst n'.
so (strict_self_ancestor_parent _#3 Hparent Hxy) as Hxz.
so (round_mono _#4 (self_ancestor_impl_ancestor _ _ Hxz) Hroundx Hroundz).
omega.
Qed.

Lemma witness_decide :
  forall x, decidable (witness x).
Proof.
intros x.
so (initial_decide x) as [Hinit | (y & z & Hparents)].
  {
  left.
  left; auto.
  }
assert (self_parent y x) as Hparent.
  {
  exists z; auto.
  }
so (round_defined y) as (m & Hroundy).
so (round_defined x) as (n & Hroundx).
so (lt_dec m n) as [Hlt | Hnlt].
  {
  left.
  right.
  do 3 eexists; eauto.
  }
right.
intro Hwitness.
so (strict_self_ancestor_witness _#4 Hwitness (plus_one _#4 Hparent) Hroundy Hroundx).
omega.
Qed.

Definition rwitness (n : nat) (x : event) : Prop :=
  round n x /\ witness x.

Lemma rwitness_witness :
  forall n x,
    rwitness n x
    -> witness x.
Proof.
intros n x H.
destruct H; auto.
Qed.

Lemma rwitness_fun :
  forall x m n,
    rwitness m x
    -> rwitness n x
    -> m = n.
Proof.
intros x m n (H & _) (H' & _).
eapply round_fun; eauto.
Qed.

Lemma rwitness_earlier :
  forall x y m n,
    rwitness m x
    -> rwitness n y
    -> m < n
    -> x << y.
Proof.
intros x y m n Hx Hy Hlt.
destruct Hx as (Hx & _).
destruct Hy as (Hy & _).
exists m, n.
auto.
Qed.

Lemma rwitness_decide :
  forall r x,
    decidable (rwitness r x).
Proof.
intros r x.
unfold rwitness.
apply dec_and.
  { apply round_decide. }

  { apply witness_decide. }
Qed.

(** Key corollary of the strongly-seeing lemma. *)
Lemma stseen_witness_unique :
  forall W n x y z z',
    member W z
    -> member W z'
    -> creator x = creator y
    -> rwitness n x
    -> rwitness n y
    -> stsees x z
    -> stsees y z'
    -> x = y.
Proof.
intros W n x y z z' Wz Wz' Heqcr Hwitx Hwity Hxz Hyz.
destruct Hwitx as (Hroundx & Hwitx).
destruct Hwity as (Hroundy & Hwity).
so (event_eq_dec x y) as [Heq | Hneq]; auto.
exfalso.
so (self_ancestor_decide x y) as [Hxy | Hnxy].
  {
  so (strict_self_ancestor_witness _#4 Hwity (star_neq_plus _#4 Hxy Hneq) Hroundx Hroundy).
  omega.
  }
so (self_ancestor_decide y x) as [Hyx | Hnyx].
  {
  assert (y <> x) as Hneq' by (contradict Hneq; auto).
  so (strict_self_ancestor_witness _#4 Hwitx (star_neq_plus _#4 Hyx Hneq') Hroundy Hroundx).
  omega.
  }
exfalso.
assert (fork x y) as Hfork.
  {
  do2 2 split; auto.
  }
eapply (strongly_seeing _#3 z z'); eauto.
Qed.

Lemma self_ancestor_witness :
  forall n x,
    round n x
    -> exists y,
        y $= x
        /\ rwitness n y.
Proof.
intros n x.
wfinduct x using self_parent_well_founded.
intros x IH Hround.
invert Hround.

(** initial *)
{
intros Hinit <-.
exists x.
split.
  { apply star_refl. }
split; auto.
left; auto.
}

(** nwitness *)
{
intros y z l m _ Hparents Hroundy _ _ _ <-.
so (Nat.max_spec l m) as [(Hlt & Heq) | (_ & Heq)].
  {
  rewrite -> Heq in *.
  exists x.
  split; [apply star_refl |].
  split; auto.
  right.
  exists y.
  split; eauto using parents_self_parent.
  exists l, m.
  auto.
  }

  {
  rewrite -> Heq in *.
  so (IH y (parents_self_parent _#3 Hparents) Hroundy) as (w & Hwy & Hwit).
  exists w.
  split; auto.
  eapply star_trans; eauto.
  apply star_one.
  eapply parents_self_parent; eauto.
  }
}

(** witness *)
{
intros y z l m _ Hparents Hroundy _ _ _ <-.
exists x.
split; [apply star_refl |].
split; auto.
right.
exists y.
split.
  { eapply parents_self_parent; eauto. }
exists l, (S (max l m)).
do2 2 split; auto.
so (Nat.le_max_l l m).
omega.
}
Qed.

Lemma stsees_many_witnesses :
  forall n x,
    round (S n) x
    -> supermajority
         stake
         (fun a =>
            exists w,
              creator w = a
              /\ stsees w x
              /\ rwitness n w)
         every.
Proof.
intros n x Hround.
revert Hround.
wfinduct x using parent_well_founded.
intros x IH Hround.
assert (forall a, decidable (exists w, creator w = a /\ stsees w x /\ rwitness n w)) as Hdec.
  {
  intro a.
  apply (dec_exists_finite _ _ (fun w => w @= x)).
    {
    intros w H.
    destruct H as (_ & H & _).
    apply stsees_impl_ancestor; auto.
    }

    {
    apply ancestor_finite.
    }
  intro w.
  apply dec_and.
    { apply eq_peer_decide. }
  apply dec_and.
    { apply stsees_decide. }

    { apply rwitness_decide. }
  }
invert Hround.

(** nwitness *)
{
intros y z l m _ Hparents Hroundy Hroundz _ _ Heq.
so (Nat.max_spec l m) as [(_ & Heqm) | (_ & Heql)].
  {
  rewrite -> Heqm in Heq.
  subst m.
  so (IH z (parent2 Hparents) Hroundz) as Hmaj.
  eapply supermajority_enlarge; eauto.
  intros a Ha.
  destruct Ha as (w & Heqcr & Hss & Hrwit).
  exists w.
  do2 2 split; auto.
  eapply stsees_ancestor_trans; eauto.
  apply star_one.
  eapply parent2; eauto.
  }

  {
  rewrite -> Heql in Heq.
  subst l.
  so (IH y (parent1 Hparents) Hroundy) as Hmaj.
  eapply supermajority_enlarge; eauto.
  intros a Ha.
  destruct Ha as (w & Heqcr & Hss & Hrwit).
  exists w.
  do2 2 split; auto.
  eapply stsees_ancestor_trans; eauto.
  apply star_one.
  eapply parent1; eauto.
  }
}

(** witness *)
{
intros _ _ l m A _ _ _ Hmaj HA Heq.
eapply supermajority_enlarge; eauto.
intros a Ha.
so (HA a Ha) as (w & Heqcr & Hss & Hwitw).
rewrite -> Heq in Hwitw.
so (self_ancestor_witness _ _ Hwitw) as (u & Huw & Hwitu).
exists u.
do2 2 split; auto.
  {
  transitivity (creator w); eauto.
  apply self_ancestor_creator; auto.
  }

  {
  eapply self_ancestor_stsees_trans; eauto.
  }
}
Qed.

Lemma ancestor_witness :
  forall m n x,
    m <= n
    -> round n x
    -> exists y, y @= x /\ rwitness m y.
Proof.
intros m n x Hle Hroundx.
revert n Hle Hroundx.
wfinduct x using strict_ancestor_well_founded.
intros x IH n Hle Hroundx.
so (self_ancestor_witness _ _ Hroundx) as (y & Hyx & Hwit).
so (le_lt_eq_dec _ _ Hle) as [Hlt | Heq].

(** succ *)
{
so (Hwit andel) as Hroundy.
invert Hroundy.
  (** initial *)
  {
  intros _ <-.
  omega.
  }

  (** nadvance *)
  {
  intros u w j k _ Hparents Hroundu Hroundw _ _ <-.
  so (Nat.max_spec j k) as [(_ & Heq) | (_ & Heq)].
    {
    rewrite -> Heq in *.
    assert (w @ x) as Hwx.
      {
      exists y.
      split.
        { eapply parent2; eauto. }

        { apply self_ancestor_impl_ancestor; auto. }
      }
    exploit (fun H => IH w H k) as H; auto.
    destruct H as (z & Hzw & Hwitz).
    exists z; split; auto.
    apply plus_star.
    eapply star_plus_trans; eauto.
    }

    {
    rewrite -> Heq in *.
    assert (u @ x) as Hux.
      {
      exists y.
      split.
        { eapply parent1; eauto. }

        { apply self_ancestor_impl_ancestor; auto. }
      }
    exploit (fun H => IH u H j) as H; auto.
    destruct H as (z & Hzu & Hwitz).
    exists z; split; auto.
    apply plus_star.
    eapply star_plus_trans; eauto.
    }
  }

  (** advance *)
  {
  intros u w j k _ Hparents Hroundu Hroundw _ _ <-.
  so (Nat.max_spec j k) as [(_ & Heq) | (_ & Heq)].
    {
    rewrite -> Heq in *.
    assert (w @ x) as Hwx.
      {
      exists y.
      split.
        { eapply parent2; eauto. }

        { apply self_ancestor_impl_ancestor; auto. }
      }
    exploit (fun H => IH w H k) as H; auto.
      { omega. }
    destruct H as (z & Hzw & Hwitz).
    exists z; split; auto.
    apply plus_star.
    eapply star_plus_trans; eauto.
    }

    {
    rewrite -> Heq in *.
    assert (u @ x) as Hux.
      {
      exists y.
      split.
        { eapply parent1; eauto. }

        { apply self_ancestor_impl_ancestor; auto. }
      }
    exploit (fun H => IH u H j) as H; auto.
      { omega. }
    destruct H as (z & Hzu & Hwitz).
    exists z; split; auto.
    apply plus_star.
    eapply star_plus_trans; eauto.
    }
  }
}

(** eq *)
{
subst n.
exists y; split; auto.
apply self_ancestor_impl_ancestor; auto.
}
Qed.

Lemma all_rounds_inhabited :
  forall W n,
    nonterminating W
    -> exists x, rwitness n x /\ member W x.
Proof.
intros W n Hnt.
so (Hnt n) as (m & x & Hle & Hroundx & HGx).
so (ancestor_witness _#3 Hle Hroundx) as (y & Hxy & Hwity).
exists y.
split; auto.
eapply world_closed; eauto.
Qed.

Lemma honest_witness_unique :
  forall W n x y,
    member W x
    -> member W y
    -> honest (creator x)
    -> creator x = creator y
    -> rwitness n x
    -> rwitness n y
    -> x = y.
Proof.
intros W n x y Wx Wy Hhonest Heqcr Hwitx Hwity.
so (eq_event_decide x y) as [| Hneq]; auto.
exfalso.
destruct (world_forks W _ Hhonest).
destruct Hwitx as (Hroundx & Hwitx).
destruct Hwity as (Hroundy & Hwity).
exists x, y.
do2 3 split; auto.
do2 2 split; auto.
  {
  intros Hxy.
  so (star_neq_plus _#4 Hxy Hneq) as Hxy'.
  so (strict_self_ancestor_witness _#4 Hwity Hxy' Hroundx Hroundy).
  omega.
  }

  {
  intros Hxy.
  eassert _ as Hxy'; [refine (star_neq_plus _#4 Hxy _) |].
    {
    contradict Hneq; auto.
    }
  so (strict_self_ancestor_witness _#4 Hwitx Hxy' Hroundy Hroundx).
  omega.
  }
Qed.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Definitions from Section 3.5.1 *)
(* Brian Milnes *)

Set Implicit Arguments.
Require Export TLC.LibLN TLC.LibNat TLC.LibEnv.
Require Import LibVarPathEnv.

(* Question: can var be the same for types and programming variables? He does so in ML. *)
(* Arthur uses Set not type, switching. I wonder if it matters. *)

Inductive Kappa : Set :=
 | B                         (* 'boxed' kind. *)
 | A.                        (* 'any'   kind. *)

Inductive Phi : Set :=
 | witnesschanges  : Phi     (* Allowing witness changes. \delta *)
 | aliases        : Phi.     (* Allowing aliases as the opened type. \amp *)

Inductive Tau : Set :=
 | btvar  : nat -> Tau                   (* A bound type variable, a de Bruijn index. *)
 | ftvar  : var -> Tau                   (* A free type variable. *)
 | cint   : Tau                          (* Cyclone's Integers. *)
 | cross  : Tau -> Tau -> Tau            (* Pairs. *)
 | arrow  : Tau -> Tau -> Tau            (* Function    type. *)
 | ptype  : Tau -> Tau                   (* Pointer     type. *)
 | utype  : Kappa -> Tau -> Tau          (* Universal   type. *)
 | etype  : Phi -> Kappa -> Tau -> Tau.  (* Existential type. *)

Inductive IPE: Set :=
 | zero_pe
 | one_pe.

Inductive PE : Set :=
 | i_pe      : IPE -> PE
 | u_pe      : PE.

(* Question: will list PE work as paths in TLC? *)
Definition Path : Set := list PE.

Inductive I  : Set :=
 | i_i       : nat -> I.                 (* An integer value in an expression or statement. *)
Inductive St : Set :=                    (* Terms for statements. *)
 | e_s       : E   -> St                 (* An expression in a statement. *)
 | retn      : E   -> St                 (* Returns are required in this syntax. *)
 | seq       : St  -> St -> St           (* Statement sequencing. *)
 | if_s      : E   -> St -> St   -> St   (* if expression in a statement. *)
 | while     : E   -> St -> St           (* A while statement. *)
 | letx      : E   -> St -> St           (* A let expression. *)
 | open      : E   -> St -> St           (* open an existential package (elimination) to a value. *)
 | openstar  : E   -> St -> St           (* open an existential package (elimination) with a pointer to the value. *)
with V : Set :=
 | bevar      : nat -> V                 (* A bound expression variable, a de Bruijn index. *)
 | fevar      : var -> V                 (* A free expression variable. *)
with E : Set :=                          (* Terms for expressions. *)
 | v_e        : V -> E                   (* Put a variable into an expression, either bound or free. *)
 | i_e        : I -> E                   (* An integer value in an expression. *)
 | p_e        : V -> list PE -> E        (* This is a term that derefences a path into the value of the variable. *)
 | f_e        : F -> E                   (* A function identifier in an expression or statement. *)
 | amp        : E -> E                   (* Take the address of an expression. *)
 | star       : E -> E                   (* Derefence an expression of a pointer type. *)
 | cpair      : E -> E -> E              (* A pair in an expression. *)
 | dot        : E -> IPE -> E            (* A deference of a pair. *)
 | assign     : E -> E -> E              (* Assignment. *)
 | appl       : E -> E -> E              (* Application expression. app is append. *)
 | call       : St -> E                  (* A call expression for the semantics use. *)
 | inst       : E -> Tau -> E            (* Type instantiation, e[\tau]. *)
 | pack       : Tau -> E -> Tau -> E     (* Existential type introduction. *)
with F : Set :=
 | dfun       : Tau -> Tau -> St -> F    (* Function definition. *)
 | ufun       : Kappa -> F -> F.         (* Univerally quantified polymorphic function definition.  *)

Inductive Term : Set :=
  | term_st : St -> Term
  | term_e :  E -> Term
  | term_f :  F -> Term.

(* Question: what about an inductive schema? *)

Scheme St_ind_mutual := Induction for St Sort Prop
with    E_ind_mutual := Induction for E Sort Prop
with    F_ind_mutual := Induction for F Sort Prop.
Combined Scheme Term_ind_mutual from St_ind_mutual, E_ind_mutual, F_ind_mutual.

(* Question: do I need lc? Yes I think so. So this has to move also. *)

Inductive Value : E -> Prop :=
 | IIsAValue    : forall (i : I),              Value (i_e i)

 | AmpIsAValue  : forall (v : V) (p : Path),   Value (amp (p_e v p))

 | DfunIsAValue : forall (t1 t2 : Tau) (s : St),
                        Value (f_e (dfun t1 t2 s))
 | UfunIsAValue :
     forall (k : Kappa) (f : F),
       Value (f_e (ufun k f))
 | PairIsAValue :
     forall (v0 v1 : E),
       Value v0 ->
       Value v1 ->
       Value (cpair v0 v1)
 | PackIsAValue :
     forall (tau tau': Tau) (v : E),
       Value v ->
       Value (pack tau v tau').

(* Problem: With pathing contexts and heaps we may run into problems with TLC, as it
really must map a variable path pair to a Type.

  TLC has 200 lines of definitions and 1000 lines of theorems in LibEnv that
 may need to be rebuilt or generalized.

  Additionally, Heap is defined as mapping free variables to values so this Heap is overly
 general for the thesis.

  Finally, should these be free variables or LibLN style variables?
*)

Definition Heap  := env E.
Definition State := prod Heap St.
Definition Delta := env Kappa.
Definition Gamma := env Tau.
Definition Upsilon := LVPE.varpathenv E.


Require Export GeoCoq.Elements.OriginalProofs.proposition_31.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_31short :
   forall A B C D,
   BetS B D C -> nCol B C A ->
   exists X Y Z, BetS X A Y /\ CongA X A D A D C /\ Par X Y B C /\ BetS X Z C /\ BetS A Z D.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists E F S, (BetS E A F /\ CongA F A D A D B /\ CongA F A D B D A /\ CongA D A F B D A /\ CongA E A D A D C /\ CongA E A D C D A /\ CongA D A E C D A /\ Par E F B C /\ Cong E A D C /\ Cong A F B D /\ Cong A S S D /\ Cong E S S C /\ Cong B S S F /\ BetS E S C /\ BetS B S F /\ BetS A S D)) by (conclude proposition_31);destruct Tf as [E[F[S]]];spliter.
close.
Qed.

End Euclid.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.
Require Import MirrorCore.SymI.
Require Import MirrorCore.EProverI.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.ExprVariables.
Require MirrorCore.Lambda.ExprUnify_simul.
Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.Subst.FMapSubst.
Require Import MirrorCore.RTac.Auto.
Require Import McExamples.Simple.Simple.
Require Import McExamples.Simple.SimpleReify.

Set Implicit Arguments.
Set Strict Implicit.

Inductive Even : nat -> Prop :=
| Even_0 : Even 0
| Even_SS : forall n, Even n -> Even (S (S n)).

Theorem Even_plus : forall n m,
                      Even n -> Even m ->
                      Even (n + m).
Proof.
  induction 1; simpl; intros; auto.
  apply Even_SS. auto.
Qed.

Theorem Even_minus : forall n m,
                       Even n -> Even m ->
                       Even (n - m).
Proof.
  intros n m H. revert m.
  induction H; simpl; intros; auto.
  { constructor. }
  { destruct H0.
    { constructor. specialize (IHEven 0 Even_0).
      rewrite <- Minus.minus_n_O in IHEven. auto. }
    { eauto. } }
Qed.

Definition fs : @functions typ _ :=
  Eval simpl in from_list
                  ((@F typ _ (tyArr tyNat tyProp) (Even)) ::
                   (@F typ _ tyNat (O)) ::
                   (@F typ _  (tyArr tyNat tyNat) (S)) ::
                   (@F typ _  (tyArr tyNat (tyArr tyNat tyNat)) (plus)) ::
                   (@F typ _  (tyArr tyNat (tyArr tyNat tyNat)) (minus)) ::
                   nil).

Let func := SymEnv.func.

Reify Declare Patterns patterns_even : (expr typ func).
Reify Declare Syntax reify_even :=
  (Patterns.CFirst ((Patterns.CPatterns patterns_even) ::
                    (Patterns.CApp (@ExprCore.App typ func)) ::
                    (Patterns.CAbs reify_simple_typ (@ExprCore.Abs typ func)) ::
                    (Patterns.CVar (@ExprCore.Var typ func)) :: nil)).

Reify Pattern patterns_even += (@RExact _ Even) => (Inj (typ:=typ) 1%positive).
Reify Pattern patterns_even += (@RExact _ O) => (Inj (typ:=typ) 2%positive).
Reify Pattern patterns_even += (@RExact _ S) => (Inj (typ:=typ) 3%positive).
Reify Pattern patterns_even += (@RExact _ plus) => (Inj (typ:=typ) 4%positive).
Reify Pattern patterns_even += (@RExact _ minus) => (Inj (typ:=typ) 5%positive).

Fixpoint makeNat (n : nat) : expr typ func :=
  match n with
    | O => Inj (2)
    | S n => App (Inj 3) (makeNat n)
  end%positive.

Let RSym_func : @RSym typ _ func := SymEnv.RSym_func fs.
Local Existing Instance RSym_func.

Let Expr_expr : @ExprI.Expr typ _ (expr typ func) := @Expr_expr _ _ _ _ _.
Local Existing Instance Expr_expr.

Reify BuildLemma < SimpleReify.reify_simple_typ reify_even reify_even >
      lem_0 : Even_0.

Reify BuildLemma < SimpleReify.reify_simple_typ reify_even reify_even >
      lem_SS : Even_SS.

Reify BuildLemma < SimpleReify.reify_simple_typ reify_even reify_even >
      lem_plus : Even_plus.

Reify BuildLemma < SimpleReify.reify_simple_typ reify_even reify_even >
      lem_minus : Even_minus.

Definition evenHints : Hints typ (expr typ func) :=
{| Lemmas := lem_SS :: lem_0 :: lem_plus :: lem_minus :: nil
 ; Extern := AsuASSUMPTION :: nil
 |}.

Instance ExprOk_expr : ExprI.ExprOk Expr_expr :=
  @ExprOk_expr _ _ _ _ _ _ _ _.

Theorem evenHintsOk : @HintsOk _ _ RType_typ _ _ evenHints.
Proof.
  constructor.
  { unfold evenHints; simpl.
    repeat first [ apply Forall_cons | apply Forall_nil ].
    exact Even_SS.
    exact Even_0.
    exact Even_plus.
    exact Even_minus. }
  { unfold evenHints; simpl.
    eapply from_ProverT_correct; eauto with typeclass_instances.
    apply (@assumptionProver_correct typ _ (expr typ func) _ _ _ _ _). }
Defined.

Let subst := FMapSubst.SUBST.raw (expr typ func).
Local Instance Subst_subst : SubstI.Subst subst (expr typ func) :=
  FMapSubst.SUBST.Subst_subst _.
Local Instance SubstUpdate_subst : SubstI.SubstUpdate subst (expr typ func) :=
  @FMapSubst.SUBST.SubstUpdate_subst _ _ _ _.

Local Instance SubstOk_fmap_subst : SubstI.SubstOk subst typ (expr typ func) :=
  @FMapSubst.SUBST.SubstOk_subst _ _ _ _.
Local Instance SubstUpdateOk_fmap_subst : SubstI.SubstUpdateOk subst typ (expr typ func).
eapply (@FMapSubst.SUBST.SubstUpdateOk_subst _ _ _ _ _).
Qed.

Definition the_auto hints :=
  @auto_prove typ (expr typ func) _ _ _ _ subst _ (SUBST.SubstOpen_subst _)
                hints
                (fun tus tvs under el er (t : typ) (sub : subst) =>
                   @ExprUnify_simul.exprUnify _ _ _ _ _ _ _ _ 10 tus tvs under el er t sub).

Existing Instance SUBST.SubstOpen_subst.
Existing Instance SUBST.SubstOpenOk_subst.
Arguments ExprUnify_simul.exprUnify_sound {_ _ _ _ _ _ _ _ _ _ _ _ _} _%nat _ _ _ _ _ _ _ _ _ _.

(* TODO(gmalecha): Why is there not a lemma that says this already? *)
Theorem Apply_auto_prove (fuel : nat) hints (Hok : HintsOk hints)
: forall facts (us vs : EnvI.env) goal s',
    @the_auto hints fuel facts
              (EnvI.typeof_env us) (EnvI.typeof_env vs) goal
              (SUBST.raw_empty _) = Some s' ->
    (let (tus,us) := EnvI.split_env us in
     let (tvs,vs) := EnvI.split_env vs in
     match factsD (ExternOk Hok) tus tvs facts
         , @SubstI.substD _ _ _ _ _ _ _ tus tvs s' with
       | Some fD , Some P => fD us vs /\ P us vs
       | None , _
       | _ , None => False
     end) ->
    match @ExprI.exprD _ RType_typ _ _ us vs goal tyProp return Prop with
      | None => True
      | Some P => P
    end.
Proof.
  intros.
  generalize (@auto_prove_sound
                typ (expr typ func) _ _ _ _ _ _ _ _ Subst_subst _ _ _ _ _ hints Hok
                (ExprUnify_simul.exprUnify 10)
                (ExprUnify_simul.exprUnify_sound _) fuel).
  intro XXX; eapply XXX in H; clear XXX.
  Arguments SUBST.WellFormed_empty {_ _ _ _} _ _ _ _ _ _.
  destruct (H SUBST.WellFormed_empty); clear H.
  unfold ExprI.exprD. simpl.
  do 2 rewrite split_env_eta in *.
  edestruct (SUBST.substD_empty (expr:=expr typ func)) as [ ? [ ? ? ] ].
  erewrite H in H2.
  unfold ExprDAs.exprD'_typ0 in *. simpl in *.
  forward.
  specialize (H5 _ _ _ H0 eq_refl eq_refl); clear H0.
  destruct H5 as [ ? [ ? ? ] ].
  inv_all; subst.
  destruct H6; eapply H5; eauto.
Qed.

Definition fuel := 103.

Definition seven : expr typ func -> expr typ func :=
  App (Inj 1%positive).
Definition splus (l r : expr typ func) : expr typ func := App (App (Inj 4%positive) l) r.

Ltac run_auto := idtac;
  let rec reify X :=
      match X with
      | ?A + ?B =>
        let A := reify A in
        let B := reify B in
        uconstr:(splus A B)
      | _ => uconstr:(makeNat X)
      end
  in
  match goal with
    | |- Even ?X =>
      let rX := reify X in
      let G := constr:(App (Inj 1%positive) rX) in
      pose (g := G) ;
      let result :=
          constr:(the_auto evenHints fuel nil nil nil g (@SUBST.raw_empty (expr typ func)))
      in
      let resultV := eval vm_compute in result in
      match resultV with
        | None => fail
        | Some ?sV =>
          pose (s := sV) ;
          cut (let (tus,us) := EnvI.split_env nil in
               let (tvs,vs) := EnvI.split_env nil in
               match factsD (ExternOk evenHintsOk) tus tvs nil
                   , @SubstI.substD _ _ _ _ _ _ _ tus tvs s with
                 | Some fD , Some P => fD us vs /\ P us vs
                 | None , _
                 | _ , None => False
               end) ;
            [ cut (result = resultV) ;
              [ set (pf := @Apply_auto_prove fuel _ evenHintsOk nil nil nil g s) ;
                exact pf
              | vm_cast_no_check (@eq_refl _ (Some s))]
            | compute; split; constructor ]
      end
  end.

Goal Even 4.
Proof.
  Time run_auto.
Qed.

Goal Even 200.
Proof.
  Time run_auto.
Qed.

Goal Even 200.
Proof.
  Time eauto 700 using Even_0, Even_SS.
Qed.

Goal Even (10 + 10).
Proof.
  Time run_auto.
Qed.

Goal Even 200.
Proof.
  Time run_auto.
Qed.
(** vm_compute is still *very* slow for this!
 ** - Some optimizations might be possible
 **   - Make unification faster, e.g. special-case fully instantiated terms
 **     so you don't keep instantiating them.
 **   - eliminate fully instantiated unification variables
 **)

Goal Even 200.
Proof.
  Time eauto 200 using Even_0, Even_SS.
Qed.

Goal Even ((200 + 200) + 200).
Proof.
  Time eauto 400 using Even_0, Even_SS, Even_plus.
Qed.

Goal Even (0 + 0).
Proof.
  run_auto.
Qed.

Goal Even ((200 + 200) + 200).
Proof.
  Time run_auto.
Qed.


(** * The induction principle for the half line. *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.NullHomotopies.
Require Import UniMath.MoreFoundations.Nat.
Require Import UniMath.MoreFoundations.Notations.
Require Import UniMath.MoreFoundations.PartA.

Notation ℕ := nat.

Definition target_paths {Y} (f:ℕ->Y) := ∏ n, f n=f(S n).

Definition gHomotopy {Y} (f:ℕ->Y) (s:target_paths f) := fun
     y:Y => ∑ (h:nullHomotopyFrom f y), ∏ n, h(S n) = h n @ s n.

Definition GuidedHomotopy {Y} (f:ℕ->Y) (s:target_paths f) :=
  total2 (gHomotopy f s).

Theorem iscontrGuidedHomotopy {Y} {f:ℕ->Y} (s:target_paths f) :
  iscontr (GuidedHomotopy f s).
Proof.
  intros. unfold GuidedHomotopy, nullHomotopyFrom.
  refine (@iscontrweqb _ (∑ y, y=f 0) _ _).
  { apply weqfibtototal. intro y.
    exact (Nat.Uniqueness.hNatRecursion_weq
             (λ n, y = f n) (λ n hn, hn @ s n)). }
  { apply iscontrcoconustot. }
Defined.

Definition halfline := ∥ ℕ ∥.

Definition makeNullHomotopy {Y} {f:ℕ->Y} (s:target_paths f) {y:Y} (h0:y=f 0) :
  nullHomotopyFrom f y.
Proof.
  intros. intro n. induction n as [|n IHn]. { exact (h0). } { exact (IHn @ s _). }
Defined.

Definition map {Y} {f:ℕ->Y} (s:target_paths f) :
  halfline -> GuidedHomotopy f s.
Proof.
  intros r. apply (squash_to_prop r).
  { apply isapropifcontr. apply iscontrGuidedHomotopy. }
  { intro n. exists (f n). induction n as [|n IHn].
    { exists (makeNullHomotopy s (idpath _)). intro n. reflexivity. }
    { exact (transportf (gHomotopy f s) (s n) IHn). } }
Defined.

Definition map_path {Y} {f:ℕ->Y} (s:target_paths f) :
  ∏ n, map s (squash_element n) = map s (squash_element (S n)).
Proof.
  intros. apply (two_arg_paths_f (s n)).
  simpl. reflexivity.
Defined.

Definition map_path_check {Y} {f:ℕ->Y} (s:target_paths f) (n:ℕ) :
  ∏ p : map s (squash_element n) = map s (squash_element (S n)),
    maponpaths pr1 p = s n.
Proof.
  intros. set (q := map_path s n).
  assert (path_inverse_to_right : q=p).
  { apply (hlevelntosn 1). apply (hlevelntosn 0). apply iscontrGuidedHomotopy. }
  destruct path_inverse_to_right. apply total2_paths2_comp1.
Defined.

(** ** universal property for the half line *)

Definition halfline_map {Y} {target_points:ℕ->Y} (s:target_paths target_points) :
  halfline -> Y.
Proof.
  intros r. exact (pr1 (map s r)).
Defined.

Definition check_values {Y} {target_points:ℕ->Y}
           (s:target_paths target_points) (n:ℕ) :
  halfline_map s (squash_element n) = target_points n.
Proof.
  reflexivity.
Defined.

Definition check_paths {Y} {target_points:ℕ->Y}
           (s:target_paths target_points) (n:ℕ) :
  maponpaths (halfline_map s) (squash_path n (S n)) = s n.
Proof.
  intros. refine (_ @ map_path_check s n _).
  apply pathsinv0. apply maponpathscomp.
Defined.

(*
Local Variables:
compile-command: "make -C ../.. UniMath/SyntheticHomotopyTheory/Halfline.vo"
End:
*)


Set Warnings "-notation-overridden,-parsing".
(*Require Export Lists.*)
Require Import Coq.Unicode.Utf8.
Require Import Basics.

(* TODO: why wasn't oddb imported with Basics moduel? *)
Fixpoint evenb (n : nat) : bool :=
  match n with
  | O => true
  | (S O) => false
  | (S (S k)) => evenb k
  end.

Definition oddb (n : nat) : bool :=
  negb (evenb n).

Inductive list (X : Type) : Type :=
| nil : list X
| cons : X → list X → list X.

Arguments nil {X}.

Arguments cons {X} _ _.

Fixpoint app {X : Type} (l1 l2 : list X) : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X : Type} (l : list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Check (cons 1 (cons 2 (cons 3 nil))).

Notation "x :: y" := (cons x y) (at level 60, right associativity).

Notation "[ ]" := nil.

Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).

Notation "x ++ y" := (app x y) (at level 60, right associativity).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat X x count')
  end.

Example test_repeat1 :
  repeat nat 4 2 = cons 4 (cons 4 nil).
Proof.
  reflexivity.
Qed.

Definition list123 :=
  cons 1 (cons 2 (cons 3 nil)).

Definition list123' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat' x count')
  end.

Inductive prod (X Y : Type) : Type :=
  | pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * X) : X :=
  match p with
  | (x, _) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (_, y) => y
  end.

Fixpoint combine {X Y : Type} (xs : list X) (ys : list Y) : list (X * Y) :=
  match (xs, ys) with
  | ([], _) => []
  | (_, []) => []
  | (x :: xs', y :: ys') => (x, y) :: (combine xs' ys')
  end.

Compute (combine [1;2] [false;false;true;true]).

Fixpoint map {X Y : Type} (f : X → Y) (l : list X) : list Y :=
  match l with
  | [] => []
  | (x :: xs) => (f x) :: map (*X Y*) f xs
  end.

(*Arguments map {X} {Y} _ _.*)

Inductive option (X : Type) : Type :=
  | Some : X → option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | (x :: xs) => Some x
  end.

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof.
  reflexivity.
Qed.

Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof.
  reflexivity.
Qed.

Fixpoint filter {X : Type} (test : X → bool) (l : list X) : (list X) :=
  match l with
  | [] => []
  | (h :: t) => if test h then h :: (filter test t) else filter test t
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Fixpoint gtb (x : nat) (y : nat) : bool :=
  match (x, y) with
  | (_, 0) => false
  | (0, _) => true
  | ((S n), (S m)) => gtb n m
  end.

Definition notb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun x => andb (gtb 7 x) (evenb x)) l.

Compute filter_even_gt7 [1;2;3;4;5;6;7;8;9].

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof.
  reflexivity.
Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof.
  reflexivity.
Qed.

Definition partition {X : Type} (test : X → bool) (l : list X) : list X * list X :=
  (filter test l, filter (fun x => notb (test x)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof.
  reflexivity.
Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof.
  reflexivity.
Qed.

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Definition id {X : Type} (x : X) := x.

Theorem map_id : ∀ (X : Type) (l : list X),
    map id l = l.
Proof.
  intros X l.
  induction l as [|n l' IHl'].
  - reflexivity.
  - simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

Lemma distrib_map : ∀ (X Y : Type) (f : X → Y) (l : list X) (h : list X),
  map f (l ++ h) = (map f l) ++ (map f h).
  intros.
  induction l.
  reflexivity.
  simpl.
  rewrite <- IHl.
  reflexivity.
Qed.

Theorem map_rev : ∀ (X Y : Type) (f : X → Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros.
  induction l.
  - reflexivity.
  - simpl.
    rewrite <- IHl.
    apply distrib_map.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * This module proves some logical properties of the axiomatics of Reals

1. Decidablity of arithmetical statements from
   the axiom that the order of the real numbers is decidable.

2. Derivability of the archimedean "axiom"
*)

(** 1- Proof of the decidablity of arithmetical statements from
excluded middle and the axiom that the order of the real numbers is
decidable. *)

(** Assuming a decidable predicate [P n], A series is constructed whose
[n]th term is 1/2^n if [P n] holds and 0 otherwise.  This sum reaches 2
only if [P n] holds for all [n], otherwise the sum is less than 2.
Comparing the sum to 2 decides if [forall n, P n] or [~forall n, P n] *)

(** One can iterate this lemma and use classical logic to decide any
statement in the arithmetical hierarchy. *)

(** Contributed by Cezary Kaliszyk and Russell O'Connor *)

Require Import ConstructiveEpsilon.
Require Import Rfunctions.
Require Import PartSum.
Require Import SeqSeries.
Require Import RiemannInt.
Require Import Fourier.

Section Arithmetical_dec.

Variable P : nat -> Prop.
Hypothesis HP : forall n, {P n} + {~P n}.

Let ge_fun_sums_ge_lemma : (forall (m n : nat) (f : nat -> R), (lt m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n).
intros m n f mn fpos.
replace (sum_f_R0 f m) with (sum_f_R0 f m + 0) by ring.
rewrite (tech2 f m n mn).
apply Rplus_le_compat_l.
 induction (n - S m)%nat; simpl in *.
 apply fpos.
replace 0 with (0 + 0) by ring.
apply (Rplus_le_compat _ _ _ _ IHn0 (fpos (S (m + S n0)%nat))).
Qed.

Let ge_fun_sums_ge : (forall (m n : nat) (f : nat -> R), (le m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n).
intros m n f mn pos.
 elim (le_lt_or_eq _ _ mn).
 intro; apply ge_fun_sums_ge_lemma; assumption.
intro H; rewrite H; auto with *.
Qed.

Let f:=fun n => (if HP n then (1/2)^n else 0)%R.

Lemma cauchy_crit_geometric_dec_fun : Cauchy_crit_series f.
intros e He.
assert (X:(Pser (fun n:nat => 1) (1/2) (/ (1 - (1/2))))%R).
 apply GP_infinite.
 apply Rabs_def1; fourier.
assert (He':e/2 > 0) by fourier.
destruct (X _ He') as [N HN].
clear X.
exists N.
intros n m Hn Hm.
replace e with (e/2 + e/2)%R by field.
set (g:=(fun n0 : nat => 1 * (1 / 2) ^ n0)) in *.
assert (R_dist (sum_f_R0 g n) (sum_f_R0 g m) < e / 2 + e / 2).
 apply Rle_lt_trans with (R_dist (sum_f_R0 g n) 2+R_dist 2 (sum_f_R0 g m))%R.
  apply R_dist_tri.
 replace (/(1 - 1/2)) with 2 in HN by field.
 cut (forall n, (n >= N)%nat -> R_dist (sum_f_R0 g n) 2 < e/2)%R.
  intros Z.
  apply Rplus_lt_compat.
   apply Z; assumption.
  rewrite R_dist_sym.
  apply Z; assumption.
 clear - HN He.
 intros n Hn.
 apply HN.
 auto.
eapply Rle_lt_trans;[|apply H].
clear -ge_fun_sums_ge n.
cut (forall n m, (m <= n)%nat -> R_dist (sum_f_R0 f n) (sum_f_R0 f m) <= R_dist (sum_f_R0 g n) (sum_f_R0 g m)).
 intros H.
 destruct (le_lt_dec m n).
  apply H; assumption.
 rewrite R_dist_sym.
 rewrite (R_dist_sym (sum_f_R0 g n)).
 apply H; auto with *.
clear n m.
intros n m Hnm.
unfold R_dist.
cut (forall i : nat, (1 / 2) ^ i >= 0). intro RPosPow.
rewrite Rabs_pos_eq.
 rewrite Rabs_pos_eq.
  cut (sum_f_R0 g m - sum_f_R0 f m <=  sum_f_R0 g n - sum_f_R0 f n).
   intros; fourier.
   do 2 rewrite <- minus_sum.
   apply (ge_fun_sums_ge m n (fun i : nat => g i - f i) Hnm).
   intro i.
   unfold f, g.
   elim (HP i); intro; ring_simplify; auto with *.
  cut (sum_f_R0 g m <= sum_f_R0 g n).
   intro; fourier.
  apply (ge_fun_sums_ge m n g Hnm).
  intro. unfold g.
  ring_simplify.
  apply Rge_le.
  apply RPosPow.
 cut (sum_f_R0 f m <= sum_f_R0 f n).
  intro; fourier.
 apply (ge_fun_sums_ge m n f Hnm).
 intro; unfold f.
 elim (HP i); intro; simpl.
  apply Rge_le.
  apply RPosPow.
 auto with *.
intro i.
apply Rle_ge.
apply pow_le.
fourier.
Qed.

Lemma forall_dec : {forall n, P n} + {~forall n, P n}.
Proof.
destruct (cv_cauchy_2 _ cauchy_crit_geometric_dec_fun).
 cut (2 <= x <-> forall n : nat, P n).
 intro H.
 elim (Rle_dec 2 x); intro X.
 left; tauto.
 right; tauto.
assert (A:Rabs(1/2) < 1) by (apply Rabs_def1; fourier).
assert (A0:=(GP_infinite (1/2) A)).
symmetry.
 split; intro.
 replace 2 with (/ (1 - (1 / 2))) by field.
 unfold Pser, infinite_sum in A0.
 eapply Rle_cv_lim;[|unfold Un_cv; apply A0 |apply u].
 intros n.
 clear -n H.
  induction n; unfold f;simpl.
  destruct (HP 0); auto with *.
  elim n; auto.
 apply Rplus_le_compat; auto.
 destruct (HP (S n)); auto with *.
 elim n0; auto.
intros n.
destruct (HP n); auto.
elim (RIneq.Rle_not_lt _ _ H).
assert (B:0< (1/2)^n).
 apply pow_lt.
 fourier.
apply Rle_lt_trans with (2-(1/2)^n);[|fourier].
replace (/(1-1/2))%R with 2 in A0 by field.
set (g:= fun m => if (eq_nat_dec m n) then (1/2)^n else 0).
assert (Z:  Un_cv (fun N : nat => sum_f_R0 g N) ((1/2)^n)).
 intros e He.
 exists n.
 intros a Ha.
 replace (sum_f_R0 g a) with ((1/2)^n).
  rewrite (R_dist_eq); assumption.
 symmetry.
 cut (forall a : nat, ((a >= n)%nat -> sum_f_R0 g a = (1 / 2) ^ n) /\ ((a < n)%nat -> sum_f_R0 g a = 0))%R.
  intros H0.
  destruct (H0 a).
  auto.
 clear - g.
 induction a.
  split;
   intros H;
   simpl; unfold g;
   destruct (eq_nat_dec 0 n) as [t|f]; try reflexivity.
   elim f; auto with *.
  exfalso; omega.
 destruct IHa as [IHa0 IHa1].
 split;
  intros H;
  simpl; unfold g at 2;
  destruct (eq_nat_dec (S a) n).
    rewrite IHa1.
     ring.
    omega.
   ring_simplify.
   apply IHa0.
   omega.
  exfalso; omega.
 ring_simplify.
 apply IHa1.
 omega.
assert (C:=CV_minus _ _ _ _ A0 Z).
eapply Rle_cv_lim;[|apply u |apply C].
clear - n0 B.
intros m.
simpl.
induction m.
 simpl.
 unfold f, g.
 destruct (eq_nat_dec 0 n).
  destruct (HP 0).
   elim n0.
   congruence.
  clear -n.
  induction n; simpl; fourier.
 destruct (HP); simpl; fourier.
cut (f (S m) <= 1 * ((1 / 2) ^ (S m)) - g (S m)).
 intros L.
 eapply Rle_trans.
  simpl.
  apply Rplus_le_compat.
   apply IHm.
  apply L.
 simpl; fourier.
unfold f, g.
destruct (eq_nat_dec (S m) n).
 destruct (HP (S m)).
  elim n0.
  congruence.
 rewrite e.
 fourier.
destruct (HP (S m)).
 fourier.
ring_simplify.
apply pow_le.
fourier.
Qed.

Lemma sig_forall_dec :  {n | ~P n}+{forall n, P n}.
destruct forall_dec.
 right; assumption.
left.
apply constructive_indefinite_description_nat; auto.
 clear - HP.
 firstorder.
apply Classical_Pred_Type.not_all_ex_not.
assumption.
Qed.

End Arithmetical_dec.

(** 2- Derivability of the Archimedean axiom *)

(* This is a standard proof (it has been taken from PlanetMath). It is
formulated negatively so as to avoid the need for classical
logic. Using a proof of {n | ~P n}+{forall n, P n} (the one above or a
variant of it that does not need classical axioms) , we can in
principle also derive [up] and its [specification] *)

Theorem not_not_archimedean :
  forall r : R, ~ (forall n : nat, (INR n <= r)%R).
intros r H.
set (E := fun r => exists n : nat, r = INR n).
assert (exists x : R, E x) by
  (exists 0%R; simpl; red; exists 0%nat; reflexivity).
assert (bound E) by (exists r; intros x (m,H2); rewrite H2; apply H).
destruct (completeness E) as (M,(H3,H4)); try assumption.
set (M' := (M + -1)%R).
assert (H2 : ~ is_upper_bound E M').
  intro H5.
  assert (M <= M')%R by (apply H4; exact H5).
  apply (Rlt_not_le M M').
    unfold M' in |- *.
    pattern M at 2 in |- *.
    rewrite <- Rplus_0_l.
    pattern (0 + M)%R in |- *.
    rewrite Rplus_comm.
    rewrite <- (Rplus_opp_r 1).
    apply Rplus_lt_compat_l.
    rewrite Rplus_comm.
    apply Rlt_plus_1.
  assumption.
apply H2.
intros N (n,H7).
rewrite H7.
unfold M' in |- *.
assert (H5 : (INR (S n) <= M)%R) by (apply H3; exists (S n); reflexivity).
rewrite S_INR in H5.
assert (H6 : (INR n + 1 + -1 <= M + -1)%R).
  apply Rplus_le_compat_r.
  assumption.
rewrite Rplus_assoc in H6.
rewrite Rplus_opp_r in H6.
rewrite (Rplus_comm (INR n) 0) in H6.
rewrite Rplus_0_l in H6.
assumption.
Qed.


From Hammer Require Import Hammer.

From Coq Require Import Omega List Syntax Relations RelationClasses.

Local Obligation Tactic := intros.

Class Comparable (A:Type) := {
compare : A -> A -> comparison;
compare_antisym : forall x y, CompOpp (compare x y) = compare y x;
compare_trans :  forall x y z c,
(compare x y) = c -> (compare y z) = c -> (compare x z) = c
}.

Theorem compare_refl {A:Type} (C: Comparable A) :
forall x, compare x x = Eq.
Proof. hammer_hook "Alphabet" "Alphabet.compare_refl".
intros.
pose proof (compare_antisym x x).
destruct (compare x x); intuition; try discriminate.
Qed.

Definition comparableLt {A:Type} (C: Comparable A) : relation A :=
fun x y => compare x y = Lt.

Instance ComparableLtStrictOrder {A:Type} (C: Comparable A) :
StrictOrder (comparableLt C).
Proof. hammer_hook "Alphabet" "Alphabet.ComparableLtStrictOrder".
apply Build_StrictOrder.
unfold Irreflexive, Reflexive, complement, comparableLt.
intros.
pose proof H.
rewrite <- compare_antisym in H.
rewrite H0 in H.
discriminate H.
unfold Transitive, comparableLt.
intros x y z.
apply compare_trans.
Qed.

Program Instance natComparable : Comparable nat :=
{ compare := Nat.compare }.
Next Obligation.
symmetry.
destruct (Nat.compare x y)  as [] eqn:?.
rewrite Nat.compare_eq_iff in Heqc.
destruct Heqc.
rewrite Nat.compare_eq_iff.
trivial.
rewrite <- nat_compare_lt in *.
rewrite <- nat_compare_gt in *.
trivial.
rewrite <- nat_compare_lt in *.
rewrite <- nat_compare_gt in *.
trivial.
Qed.
Next Obligation.
destruct c.
rewrite Nat.compare_eq_iff in *; destruct H; assumption.
rewrite <- nat_compare_lt in *.
apply (Nat.lt_trans _ _ _ H H0).
rewrite <- nat_compare_gt in *.
apply (gt_trans _ _ _ H H0).
Qed.

Program Instance PairComparable {A:Type} (CA:Comparable A) {B:Type} (CB:Comparable B) :
Comparable (A*B) :=
{ compare := fun x y =>
let (xa, xb) := x in let (ya, yb) := y in
match compare xa ya return comparison with
| Eq => compare xb yb
| x => x
end }.
Next Obligation.
destruct x, y.
rewrite <- (compare_antisym a a0).
rewrite <- (compare_antisym b b0).
destruct (compare a a0); intuition.
Qed.
Next Obligation.
destruct x, y, z.
destruct (compare a a0) as [] eqn:?, (compare a0 a1) as [] eqn:?;
try (rewrite <- H0 in H; discriminate);
try (destruct (compare a a1) as [] eqn:?;
try (rewrite <- compare_antisym in Heqc0;
rewrite CompOpp_iff in Heqc0;
rewrite (compare_trans _ _ _  _ Heqc0 Heqc2) in Heqc1;
discriminate);
try (rewrite <- compare_antisym in Heqc1;
rewrite CompOpp_iff in Heqc1;
rewrite (compare_trans _ _ _ _ Heqc2 Heqc1) in Heqc0;
discriminate);
assumption);
rewrite (compare_trans _ _ _ _ Heqc0 Heqc1);
try assumption.
apply (compare_trans _ _ _ _ H H0).
Qed.

Class ComparableLeibnizEq {A:Type} (C: Comparable A) :=
compare_eq : forall x y, compare x y = Eq -> x = y.

Definition compare_eqb {A:Type} {C:Comparable A} (x y:A) :=
match compare x y with
| Eq => true
| _ => false
end.

Theorem compare_eqb_iff {A:Type} {C:Comparable A} {U:ComparableLeibnizEq C} :
forall x y, compare_eqb x y = true <-> x = y.
Proof. hammer_hook "Alphabet" "Alphabet.compare_eqb_iff".
unfold compare_eqb.
intuition.
apply compare_eq.
destruct (compare x y); intuition; discriminate.
destruct H.
rewrite compare_refl; intuition.
Qed.

Instance NComparableLeibnizEq : ComparableLeibnizEq natComparable := Nat.compare_eq.

Instance PairComparableLeibnizEq
{A:Type} {CA:Comparable A} (UA:ComparableLeibnizEq CA)
{B:Type} {CB:Comparable B} (UB:ComparableLeibnizEq CB) :
ComparableLeibnizEq (PairComparable CA CB).
Proof. hammer_hook "Alphabet" "Alphabet.PairComparableLeibnizEq".
intros x y; destruct x, y; simpl.
pose proof (compare_eq a a0); pose proof (compare_eq b b0).
destruct (compare a a0); try discriminate.
intuition.
destruct H2, H0.
reflexivity.
Qed.

Class Finite (A:Type) := {
all_list : list A;
all_list_forall : forall x:A, In x all_list
}.

Class Alphabet (A:Type) := {
AlphabetComparable :> Comparable A;
AlphabetComparableLeibnizEq :> ComparableLeibnizEq AlphabetComparable;
AlphabetFinite :> Finite A
}.

Class Numbered (A:Type) := {
inj : A -> positive;
surj : positive -> A;
surj_inj_compat : forall x, surj (inj x) = x;
inj_bound : positive;
inj_bound_spec : forall x, (inj x < Pos.succ inj_bound)%positive
}.

Program Instance NumberedAlphabet {A:Type} (N:Numbered A) : Alphabet A :=
{ AlphabetComparable := {| compare := fun x y => Pos.compare (inj x) (inj y) |};
AlphabetFinite :=
{| all_list := fst (Pos.iter
(fun '(l, p) => (surj p::l, Pos.succ p))
([], 1%positive) inj_bound) |} }.
Next Obligation. simpl. now rewrite <- Pos.compare_antisym. Qed.
Next Obligation.
match goal with c : comparison |- _ => destruct c end.
- rewrite Pos.compare_eq_iff in *. congruence.
- rewrite Pos.compare_lt_iff in *. eauto using Pos.lt_trans.
- rewrite Pos.compare_gt_iff in *. eauto using Pos.lt_trans.
Qed.
Next Obligation.
intros x y. unfold compare. intros Hxy.
assert (Hxy' : inj x = inj y).

{ destruct (Pos.eq_dec (inj x) (inj y)) as [|[]]; [now auto|].
now apply Pos.compare_eq_iff. }

transitivity (surj (inj x)).
{ apply eq_sym, surj_inj_compat. }
transitivity (surj (inj y)); cycle 1.
{ apply surj_inj_compat. }
apply f_equal, Hxy'.
Defined.
Next Obligation.
rewrite <-(surj_inj_compat x).
generalize (inj_bound_spec x). generalize (inj x). clear x. intros x.
match goal with |- ?Hx -> In ?s (fst ?p) =>
assert ((Hx -> In s (fst p)) /\ snd p = Pos.succ inj_bound); [|now intuition] end.
rewrite Pos.lt_succ_r.
induction inj_bound as [|y [IH1 IH2]] using Pos.peano_ind;
(split; [intros Hx|]); simpl.
- rewrite (Pos.le_antisym _ _ Hx); auto using Pos.le_1_l.
- auto.
- rewrite Pos.iter_succ. destruct Pos.iter; simpl in *. subst.
rewrite Pos.le_lteq in Hx. destruct Hx as [?%Pos.lt_succ_r| ->]; now auto.
- rewrite Pos.iter_succ. destruct Pos.iter. simpl in IH2. subst. reflexivity.
Qed.

Require Import OrderedTypeAlt.
Require FSetAVL.
Require FMapAVL.
Import OrderedType.

Module Type ComparableM.
Parameter t : Type.
Declare Instance tComparable : Comparable t.
End ComparableM.

Module OrderedTypeAlt_from_ComparableM (C:ComparableM) <: OrderedTypeAlt.
Definition t := C.t.
Definition compare : t -> t -> comparison := compare.

Infix "?=" := compare (at level 70, no associativity).

Lemma compare_sym x y : (y?=x) = CompOpp (x?=y).
Proof. hammer_hook "Alphabet" "Alphabet.OrderedTypeAlt_from_ComparableM.compare_sym". exact (Logic.eq_sym (compare_antisym x y)). Qed.
Lemma compare_trans c x y z :
(x?=y) = c -> (y?=z) = c -> (x?=z) = c.
Proof. hammer_hook "Alphabet" "Alphabet.compare_trans".
apply compare_trans.
Qed.
End OrderedTypeAlt_from_ComparableM.

Module OrderedType_from_ComparableM (C:ComparableM) <: OrderedType.
Module Alt := OrderedTypeAlt_from_ComparableM C.
Include (OrderedType_from_Alt Alt).
End OrderedType_from_ComparableM.


Require Export Complex.

Lemma Cmod_n1 : Cmod (-(1)) = R1.
Proof.
rewrite Cmod_opp.
rewrite Cmod_1.
easy.
Qed.

Lemma Cmult_m1_r (x : C) : x * -1 = -x.
Proof. lca. Qed.

Lemma Cmult_m1_l (x : C) : -1 * x = -x.
Proof. lca. Qed.

Lemma Copp_1 : Copp 1 = -1.
Proof. lca. Qed.

Lemma Copp_involutive_1 : - (-1) = C1 .
Proof. lca. Qed.

Lemma Cconj_Ci : Ci^* = -Ci.
Proof. lca. Qed.

(* '/' to C *)
(* '√' to R *)
Lemma Cconj_inv2 :  (/ 2)^* = / 2.
Proof. lca. Qed.

Lemma Cplus_opp : 1 + -1 = 0.
Proof. lca. Qed.

Lemma C2_sqrt2_inv : 2 * / √ 2 = √ 2.
Proof.
 eapply c_proj_eq; simpl; try lra.
 autorewrite with R_db.
  rewrite <- Rmult_assoc.
  rewrite Rmult_comm.
  rewrite <- Rmult_assoc.
  lra.
Qed.

Hint Rewrite Cconj_0 Cconj_Ci Cconj_inv2 Cplus_opp
     (* Csqrt2_sqrt *) (* Csqrt2_sqrt2_inv *) Csqrt2_inv_sqrt2 Csqrt2_inv_sqrt2_inv
          Copp_1  Cconj_involutive Cconj_plus_distr Cconj_mult_distr Copp_involutive_1
         Cmult_m1_l Cmult_m1_r : C_db.

Hint Rewrite  Cmod_0 Cmod_1 Cmod_opp Cmod_mult Cmod_m1  : C_db.

Hint Rewrite Csqrt_sqrt_inv using Psatz.lra : C_db.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Definition(s):
    Deterministic, Length-preserving Stack Machines
  Problems(s):
    Uniform Boundedness of Deterministic, Length-preserving Stack Machines (SMNdl_UB)
*)

Require Import Relation_Operators List.
Import ListNotations.

Definition State := nat.
Definition Symbol := bool.

Definition Stack : Set := list Symbol.

(* configuration: state, (left stack, right stack) *)
Definition Config : Set := Stack * Stack * State.

(* instruction: vXw -> rYs *)
Definition Instruction : Set := Config * Config.

(* stack machine: list of instructions *)
Definition SMN : Set := list Instruction.

Inductive step (M : SMN) : Config -> Config -> Prop :=
  | transition (v w r s r' s': Stack) (x y: State) :
    In ((r, s, x), (r', s', y)) M ->
    step M (r ++ v, s ++ w, x) (r' ++ v, s' ++ w, y).

(* step is functional *)
Definition deterministic (M: SMN) := forall (X Y Z: Config), step M X Y -> step M X Z -> Y = Z.

(* reflexive transitive closure of step *)
Definition reachable (M: SMN) : Config -> Config -> Prop := clos_refl_trans Config (step M).

(* step is confluent *)
Definition confluent (M: SMN) := forall (X Y1 Y2: Config), reachable M X Y1 -> reachable M X Y2 ->
  exists (Z: Config), reachable M Y1 Z /\ reachable M Y2 Z.

(* uniform bound for the number of reachable configurations *)
Definition bounded (M: SMN) (n: nat) : Prop :=
  forall (X: Config), exists (L: list Config), (forall (Y: Config), reachable M X Y -> In Y L) /\ length L <= n.

(* sum of stack sizes is invariant under step *)
Definition length_preserving (M: SMN) : Prop :=
  forall s t X s' t' Y, In ((s, t, X), (s', t', Y)) M -> length (s ++ t) = length (s' ++ t') /\ 1 <= length (s ++ t).

(* given a deterministic, length-preserving stack machine M,
  is M uniformly bounded by some n? *)
Definition SMNdl_UB : { M : SMN | deterministic M /\ length_preserving M } -> Prop :=
  fun '(exist _ M _) => exists (n: nat), bounded M n.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Bool.

Require Import tacs rel square cl cl_eq cl_confluent.

Set Implicit Arguments.

(* The notation of reduction in combinatory logic *)

Reserved Notation "x '-b->' y" (at level 70).

Inductive cl_beta : clterm -> clterm -> Prop :=

  | in_cl_beta_I   : forall x,     I o x          -b-> x

  | in_cl_beta_K   : forall x y,   K o x o y      -b-> x

  | in_cl_beta_S   : forall x y z, S o x o y o z  -b-> x o z o (y o z)

  | in_cl_beta_lft : forall f g a,          f     -b-> g
                                         -> f o a -b-> g o a

  | in_cl_beta_rt  : forall f a b,              a -b->     b
                                         -> f o a -b-> f o b

where "x -b-> y" := (cl_beta x y).

Notation "x '-b>>' y" := (crt cl_beta x y) (at level 70).
Notation "x '~b' y" := (crst cl_beta x y) (at level 70).

Fact cl_beta_rt_beta_eq f g : f -b>> g -> f ~b g.
Proof. apply crt_inc_crst. Qed.

Fact cl_beta_cl_eq f g : f -b-> g -> f ~cl g.
Proof.
  induction 1.
  constructor.
Admitted.

Fact cl_beta_rt_cl_eq f g : f -b>> g -> f ~cl g.
Proof.
  induction 1 as [ | | f g h ].
Admitted.

Fact cl_beta_rt_app f g a b : f -b>> g -> a -b>> b -> f o a -b>> g o b.
Proof.
  intros H1 H2.
  constructor 3 with (f o b).
  induction H2 as [ | | a y b ].
  constructor 1; constructor 5; auto.
  constructor 2.
  constructor 3 with (f o y); auto.
  induction H1 as [ | | f h g ].
  constructor 1; constructor 4; auto.
  constructor 2.
  constructor 3 with (h o b); auto.
Qed.

Fact cl_beta_eq_cl_eq f g : f ~b g -> f ~cl g.
Proof.
  induction 1 as [ | | | f g h ].
Admitted.

Fact cl_beta_eq_app f g a b : f ~b g -> a ~b b -> f o a ~b g o b.
Proof.
Admitted.

Fact cl_beta_equiv_cl_eq f g : f ~b g <-> f ~cl g.
Proof.
  split.
  apply cl_beta_eq_cl_eq.
  induction 1 as [ | | | | x y | | | ].
Admitted.

(* See the definition of cl_rho in file cl_confluent *)

Local Notation "x '-r->' y" := (cl_rho x y) (at level 70).
Local Notation "x '-r>>' y" := (crt cl_rho x y) (at level 70).

Fact cl_beta_rho f g : f -b-> g -> f -r-> g.
Proof.
  induction 1.
Admitted.

Fact cl_rho_beta_rt f g : f -r-> g -> f -b>> g.
Proof.
  induction 1.
Admitted.

Lemma cl_rho_rt_beta_rt_eq f g : f -r>> g <-> f -b>> g.
Proof.
  split.

  induction 1 as [ | | x y ]; admit.

  induction 1 as [ | | x y ]; admit.
Admitted.

Corollary cl_rho_cl_eq f g : f -r-> g -> f ~cl g.
Proof.
  intro; apply cl_beta_rt_cl_eq, cl_rho_beta_rt; auto.
Qed.

(* Since (crt cl_rho) and (crt cl_beta) are equivalent
   and since cl_rho is confluent then so is cl_beta *)

Theorem cl_beta_confluent : confluent cl_beta.
Proof.
  intros f a b.
  do 2 rewrite <- cl_rho_rt_beta_rt_eq.
  intros H2 H3.
  destruct (cl_rho_confluent H2 H3) as (g & H4 & H5).
  exists g; do 2 rewrite <- cl_rho_rt_beta_rt_eq; auto.
Qed.

Fact cl_beta_cr f g : f ~b g <-> exists h, f -b>> h /\ g -b>> h.
Proof.
  apply confluent_church_rosser, cl_beta_confluent.
Qed.


(**

  In this file we formalize the approach of Marc Bezem and Ulrik Buchholtz for proving that the type
  of Z-torsors has the induction principle that the circle should have.  In my older approach, (see
  the file Circle.v), I managed to show only the recursion principle for the circle (where the
  family of types is constant), and the computations were complicated and onerous.  Their approach
  follows the same basic idea, goes further, and is simpler.  It is described in the file
  https://github.com/UniMath/SymmetryBook/blob/master/ZTors.tex, commit
  1ba615fa7625516ad79fe3ad9ef68e1fc001d485.

  *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Propositions.
Require Import UniMath.MoreFoundations.Equivalences.
Require Import UniMath.MoreFoundations.PathsOver.
  Import PathsOverNotations.
Require Import UniMath.Algebra.Monoids.
  Import AddNotation.
Require Import UniMath.SyntheticHomotopyTheory.AffineLine.
Require Import UniMath.NumberSystems.Integers.
Require Import UniMath.Algebra.BinaryOperations.
Require Import UniMath.Algebra.GroupAction.
Require Import UniMath.Algebra.Groups.

Local Set Implicit Arguments.
Local Unset Strict Implicit.
Declare Scope circle.
Delimit Scope circle with circle.
Local Open Scope hz.
Local Open Scope addoperation.
Local Open Scope abgr.
Local Open Scope action_scope.
Local Open Scope pathsover.
Local Open Scope circle.
Local Notation "0" := (toℤ 0).
Local Notation "1" := (toℤ 1).
Local Definition elem (G:gr) (X:Torsor G) : Type := X.
Arguments elem {_} _.
Local Notation "ℤ¹" := (trivialTorsor ℤ) : circle.

(** Statements of circle recursion and induction *)

(* Circle "recursion" is the non-dependent induction principle  *)

Definition CircleRecursion (circle : Type) (pt : circle) (loop : pt = pt) :=
  ∏ (X:Type) (x:X) (p:x=x),
    ∑ (f:circle -> X) (r : f pt = x),
      PathOver (Y := λ t:X, t = t) r (maponpaths f loop) p.

Arguments CircleRecursion : clear implicits.

Definition CircleInduction (circle : Type) (pt : circle) (loop : pt = pt) :=
  ∏ (X:circle->Type) (x:X pt) (p:PathOver loop x x),
    ∑ (f:∏ t:circle, X t) (r : f pt = x),
      PathOver (Y := λ t:X pt, PathOver loop t t) r (apd f loop) p.

Arguments CircleInduction : clear implicits.

(* the alternative definitions of recursion and induction used earlier: *)

Definition CircleRecursion' (circle : Type) (pt : circle) (loop : pt = pt) :=
  ∏ (X:Type) (x:X) (p:x=x),
    ∑ (f:circle -> X) (r : x = f pt), r @ maponpaths f loop = p @ r.

Arguments CircleRecursion' : clear implicits.

Definition CircleInduction' (circle : Type) (pt : circle) (loop : pt = pt) :=
  ∏ (X:circle->Type) (x:X pt) (p:PathOver loop x x),
    ∑ (f:∏ t:circle, X t) (r : x = f pt), r ⟤ apd f loop = p ⟥ r.

Arguments CircleInduction' : clear implicits.

(* the equivalence of the new definitions with the old *)

Lemma CircleRecursionEquiv (circle : Type) (pt : circle) (loop : pt = pt)
  : CircleRecursion circle pt loop ≃ CircleRecursion' circle pt loop.
Proof.
  unfold CircleRecursion', CircleRecursion.
  apply weqonsecfibers; intro X. apply weqonsecfibers; intro x.
  apply weqonsecfibers; intro p. apply weqfibtototal; intro f.
  intermediate_weq (∑ r : f pt = x, maponpaths f loop @ r = r @ p).
  - apply weqfibtototal; intro r. apply eqweqmap. induction r. cbn.
    apply (maponpaths (λ k, k=p)). rewrite pathscomp0rid. reflexivity.
  - intermediate_weq (∑ r : f pt = x, (!r) @ maponpaths f loop = p @ (!r)).
    + apply weqfibtototal; intro r. induction r. cbn.
      rewrite 2 pathscomp0rid. apply idweq.
    + exact (weqfp (make_weq _ (isweqpathsinv0 (f pt) x)) _).
Defined.

Lemma CircleInductionEquiv (circle : Type) (pt : circle) (loop : pt = pt)
  : CircleInduction circle pt loop ≃ CircleInduction' circle pt loop.
Proof.
  unfold CircleInduction', CircleInduction.
  apply weqonsecfibers; intro X. apply weqonsecfibers; intro x.
  apply weqonsecfibers; intro p. apply weqfibtototal; intro f.
  intermediate_weq (∑ r : f pt = x, !r ⟤ apd f loop = p ⟥ !r).
  - apply weqfibtototal; intro r.
    intermediate_weq (PathOver (Y := λ t:X pt, PathOver loop t t) (!r) p (apd f loop)).
    + apply inversePathOverWeq.
    + induction r. cbn. apply weqpathsinv0.
  - exact (weqfp (make_weq _ (isweqpathsinv0 _ _)) _).
Defined.

Lemma CircleInduction_isaprop (circle : Type) (pt : circle) (loop : pt = pt) :
  isaprop (CircleInduction circle pt loop).
Proof.
Abort.

Lemma CircleInductionToRecursion' (circle : Type) (pt : circle) (loop : pt = pt) :
  CircleInduction' circle pt loop -> CircleRecursion' circle pt loop.
Proof.
  intros I. unfold CircleRecursion'. intros X x p.
  set (w := I (λ _, X) x (PathOverConstant_map1 _ p)). simpl in w.
  exists (pr1 w). exists (pr12 w).
  refine (_ @ maponpaths PathOverConstant_map2 (pr22 w) @ _).
  { apply pathsinv0. refine (PathOverConstant_map2_eq2 _ _ @ _).
    apply maponpaths. apply PathOverConstant_map2_apd. }
  { refine (PathOverConstant_map2_eq1 _ _ @ _).
    apply (maponpaths (λ t, t @ _)). apply PathOverConstant_map1_map2. }
Defined.

(** A "circle" is a type with a point and a loop at that point that satisfies the
    induction principle of the circle.  The type of all circles is called "Circle".  *)

Definition Circle  := ∑ (circle : Type) (pt : circle) (loop : pt = pt), CircleInduction circle pt loop.

Definition Circle' := ∑ (circle : Type) (pt : circle) (loop : pt = pt), CircleInduction' circle pt loop.

Definition CircleEquiv : Circle ≃ Circle'.
Proof.
  apply weqfibtototal; intro circle; apply weqfibtototal; intro pt;
    apply weqfibtototal; intro loop.
  apply CircleInductionEquiv.
Defined.

Definition CircleInductionMatch (C C' : Type) (pt : C) (pt' : C') (loop : pt = pt) (loop' : pt' = pt')
           (I : CircleInduction' C pt loop) (I' : CircleInduction' C' pt' loop')
           (g : C -> C')
           (r0 : g pt = pt')
           (r : r0 @ loop' = maponpaths g loop @ r0)
  : ∏ (X' : C' → Type) (x' : X' pt') (p' : PathOver loop' x' x'), Type.
Proof.
  intros.
  set (X := X' ∘ g); cbn beta in X.
  set (x := pullBackPointOver g r0 x'). change (X' ∘ g) with X in x.
  set (p := pullBackPathOver g r p'). fold x in p.
  (* set (J := I X x p). *)
  set (typeofJ := ∑ (f : ∏ t : C, X t) (r : x = f pt), r ⟤ apd f loop = p ⟥ r).
  (* Check ( J : typeofJ ). *)
  assert (J'' : typeofJ).
  {
    unfold typeofJ. clear typeofJ.
    set (J' := I' X' x' p').
    set (s' := pr1 J').
    set (s := s' ∘ g); change (∏ x, X x) in (type of s).
    set (k := pr12 J'); change (pr1 J') with (s') in (type of k).
    set (ρ := pr22 J'); cbn beta in ρ; fold s k s' in ρ.
    exists s.
    exists (pullBackPointOverWithSection' _ _ k).
    set (kk := pullBackPathOver g r (apd s' loop')).

Abort.

Lemma Circle_isaprop : isaprop Circle.
Proof.
  apply (isofhlevelweqb 1 CircleEquiv).
  apply invproofirrelevance.
  intros [C [pt [loop I]]] [C' [pt' [loop' I']]].
  set (R  := CircleInductionToRecursion' I ). set (R' := CircleInductionToRecursion' I').
  set (gre  := R  C' pt' loop').
  set (g := pr1 gre). set (r := pr12 gre). set (e := pr22 gre).
  set (gre' := R' C  pt  loop ).
  set (g' := pr1 gre'). set (r' := pr12 gre'). set (e' := pr22 gre').
  fold g in r, e; fold g' in r', e'; fold r in e; fold r' in e'.
  cbn beta in e, e'.
  set (fib := (pt ,, pathsinv0 r) : hfiber g pt').
  transparent assert (v : (pt = g' (g pt))).
  { refine (r' @ _). apply maponpaths. assumption. }
  transparent assert (v' : (pt' = g (g' pt'))).
  { refine (r  @ _). apply maponpaths. assumption. }
  assert (ie : isweq g).
  { apply (isweq_iso _ g').
    { intros x. apply pathsinv0. generalize x; clear x.
      simple refine (pr1 (I _ _ _)).
      - simpl. exact v.
      - set (Q := ! pathOverEquations (f := idfun _) (g := funcomp g g') v v loop).
        apply (cast Q); clear Q.
        intermediate_path (v @ maponpaths g' (maponpaths g loop)).
        + apply (maponpaths (λ k, v @ k)). apply pathsinv0, maponpathscomp.
        + rewrite maponpathsidfun. unfold v. rewrite <- path_assoc.
          rewrite <- maponpathscomp0. intermediate_path (r' @ maponpaths g' (loop' @ r)).
          * apply maponpaths. apply maponpaths. exact e.
          * rewrite maponpathscomp0. rewrite path_assoc.
            rewrite e'. rewrite path_assoc. reflexivity. }
    { intros x. apply pathsinv0. generalize x; clear x.
      simple refine (pr1 (I' _ _ _)).
      - simpl. exact v'.
      - set (Q := ! pathOverEquations (f := idfun _) (g := funcomp g' g) v' v' loop').
        apply (cast Q); clear Q.
        intermediate_path (v' @ maponpaths g (maponpaths g' loop')).
        + apply (maponpaths (λ k, v' @ k)). apply pathsinv0, maponpathscomp.
        + rewrite maponpathsidfun. unfold v'. rewrite <- path_assoc.
          rewrite <- maponpathscomp0.
          intermediate_path (r @ maponpaths g (loop @ r')).
          * apply maponpaths. apply maponpaths. exact e'.
          * rewrite maponpathscomp0. rewrite path_assoc.
            rewrite e. rewrite path_assoc. reflexivity. } }
  (* We'll use univalence on g to identify C with C'.
     Then r will provide the match between pt and pt',
     and e will provide the corresponding match between loop and loop'.
     The question remains, how will we define matching I with I'?
   *)
  unfold CircleInduction' in I, I'.

Abort.

(** now start the formalization, following Marc and Ulrik *)

Definition circle := B ℤ.

Lemma loops_circle : ℤ ≃ Ω circle.
Proof.
  apply loopsBG.
Defined.

Definition loop := loops_circle 1 : Ω circle.

Definition loop' (X : Torsor ℤ) : X = X
  := invmap torsor_univalence (left_mult_Iso X 1).

Definition pt := basepoint circle.

Definition pt_0 : underlyingAction pt := 0.
Definition pt_1 : underlyingAction pt := 1.

Definition loop_loop' : loop = loop' pt.
Proof.
  change (
      invmap torsor_univalence (trivialTorsorAuto ℤ 1) =
      invmap torsor_univalence (left_mult_Iso pt 1)).
  apply maponpaths.
  apply underlyingIso_injectivity, pr1weq_injectivity, funextsec; intros n.
  change (n + 1 = 1 + n)%addmonoid.
  apply commax.
Defined.

Definition s {Z : Torsor ℤ} (x : Z) : pt = Z
(* 0.5.6 *)
  := invmap torsor_univalence (triviality_isomorphism Z x).

Section RelatedFacts.

  Definition fact0 (X Y : Torsor ℤ) (e : X = Y) (x : X) :
    s (transportf elem e x) = s x @ e.
  Proof.
    induction e. apply pathsinv0, pathscomp0rid.
  Defined.

  Lemma fact1 (X Y:Torsor ℤ) (e : X=Y) : loop' X @ e = e @ loop' Y.
  Proof.
    induction e.
    apply pathscomp0rid.
  Defined.

  Lemma fact2 (X: Torsor ℤ) (x:X) : s (transportf elem (loop' X) x) = s x @ loop' X.
  Proof.
    exact (fact0 (loop' X) x).
  Defined.

  Lemma fact3 (X: Torsor ℤ) (x:X) : loop' pt @ s x = s x @ loop' X.
  Proof.
    apply fact1.
  Defined.

  Lemma fact4 (X: Torsor ℤ) (x:X) : loop @ s x = s x @ loop' X.
  Proof.
    refine (_ @ fact3 x).
    apply (maponpaths (λ l, l @ s x)).
    apply loop_loop'.
  Defined.

  Lemma fact5 (X: Torsor ℤ) (x:X) : loop @ s x = s (transportf elem (loop' X) x).
  Proof.
    refine (_ @ !fact2 x).
    exact (fact4 x).
  Defined.

End RelatedFacts.

Definition ε' (X Y : Torsor ℤ) (e : X = Y) (x : X) :
  ! s x @ s (transportf elem e x) = e.
Proof.                          (* 0.5.10 *)
  induction e. apply pathsinv0l.
Defined.

Lemma s_compute_0 : s pt_0 = idpath pt.
Proof.
  intermediate_path (invmap torsor_univalence (idActionIso ℤ¹)).
  - change (s pt_0) with (invmap torsor_univalence (triviality_isomorphism ℤ¹ 0)).
    apply maponpaths.
    exact (triviality_isomorphism_compute ℤ). (* too slow *)
  - apply torsor_univalence_id.
Defined.

Definition ε {X : Torsor ℤ} (x : X) : loop @ s x = s (1 + x).
(* 0.5.7 *)
Proof.
  change ((invmap torsor_univalence (trivialTorsorRightMultiplication ℤ one)) @ s x = s (1 + x)).
  refine (invUnivalenceCompose _ _ @ _). unfold s. apply maponpaths.
  apply underlyingIso_injectivity, pr1weq_injectivity, funextsec; intros n.
  change (((n + 1)%addoperation + x) = (n + (1 + x))). apply ac_assoc.
Defined.

Definition ε1 {X : Torsor ℤ} (x : X) : s x @ loop' X = s (1 + x).
Proof.
  unfold loop'.
  refine (invUnivalenceCompose _ _ @ _). unfold s. apply maponpaths.
  apply underlyingIso_injectivity, pr1weq_injectivity, funextsec; intros n.
  change (1 + (n + x) = n + (1 + x)).
  refine (! ac_assoc _ _ _ _ @ _ @ ac_assoc _ _ _ _).
  apply (maponpaths (right_mult x)). apply commax.
Defined.

Definition ε'' (x : underlyingAction pt) : ! s x @ s (1 + x) = loop.
Proof.
  apply path_inv_rotate_ll, pathsinv0. refine (_ @ ε1 x).
  apply maponpaths; clear x. apply loop_loop'.
Defined.

Definition cp_irrelevance_circle
           (A:=circle) (B:circle->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α β: p=q)
           (v : PathOver p b1 b2) :
  cp α v = cp β v.
Proof.
  apply (maponpaths (λ f, pr1weq f v)). apply cp_irrelevance. apply torsor_hlevel.
Defined.

Opaque PathOver.                (* see the discussion at https://github.com/UniMath/UniMath/pull/1329 *)
Section A.

  Context (A : circle -> Type) (a : A pt) (p : PathOver loop a a).

  Definition Q (X: Torsor ℤ) : Type                 (* 0.5.8 *)
    := ∑ (a' : A X),
        ∑ (h : ∏ (x:X), PathOver (s x) a a'),
         ∏ (x:X), h (1 + x) = cp (ε x) (p * h x).

  Lemma iscontr_Q (X: Torsor ℤ) (* 0.5.9 *) :
    iscontr_hProp (Q X).
  Proof.
    use (hinhuniv _ (torsor_nonempty X)). intros x.
    use (iscontrweqb (Y := ∑ a', PathOver (s x) a a')).
    2 : { apply PathOverUniqueness. }
    apply weqfibtototal; intros a'.
    exact (ℤTorsorRecursion_weq
             (λ x, weqcomp (composePathOver_weq a' (s x) p) (cp (ε x)))
             x).
  Qed.

  Definition cQ (X:Torsor ℤ) := iscontrpr1 (iscontr_Q X).

  Definition c (X:Torsor ℤ)
    : A X
    := pr1 (cQ X).

  Definition c_tilde (X:Torsor ℤ) (x : X)
    : PathOver (s x) a (c X)
    := pr12 (cQ X) x.
  Arguments c_tilde : clear implicits.

  Definition c_hat (X:Torsor ℤ) (x : X)
    : c_tilde X (1 + x) = cp (ε x) (p * c_tilde X x)
    := pr22 (cQ X) x.
  Arguments c_hat : clear implicits.

  Definition apd_comparison (X Y : Torsor ℤ) (e : X = Y) (x : X) : (* 0.5.11 *)
    apd c e = cp (ε' e x) ((c_tilde X x)^-1 * c_tilde Y (transportf elem e x)).
  Proof.
    induction e.
    change (transportf elem (idpath X) x) with x.
    change (apd c (idpath X)) with (identityPathOver (c X)).
    rewrite composePathOverLeftInverse.
    change (ε' (idpath X) x) with (pathsinv0l (s x)).
    rewrite cp_inverse_cp.
    reflexivity.
  Defined.

  (* illustrate how to work around Coq not finding the right coercions:  *)
  Local Goal ∏ (Y : B ℤ), Type.        Proof. intros. Fail exact Y. exact (underlyingAction Y). Defined.
  Local Goal ∏ (X : circle), Type.     Proof. intros. Fail exact X. exact (underlyingAction X). Defined.
End A.

Arguments c_tilde {_ _} _ _ _.
Arguments c_hat {_ _} _ _ _.

Theorem circle_induction : CircleInduction circle pt loop.
Proof.
  apply CircleInductionEquiv.
  unfold CircleInduction'. intros A a p.
  set (f := c p). exists f.
  set (h := c_tilde p pt); fold f in h.
  set (h0 := h pt_0).
  set (e := Δ (cp s_compute_0 h0)).
  exists e.
  assert (q := c_hat p pt); fold h in q.
  set (s0 := s pt_0); unfold pt_0 in s0.
  set (s1 := s pt_1); unfold pt_1 in s1.
  set (one' := transportf elem loop pt_0); fold pt in one'.
  assert (r := apd_comparison p loop pt_0). fold pt h h0 f one' in r; unfold pt_0 in r.
  apply (pr2 (composePathPathOverRotate _ _ _)).
  rewrite composePathPathOverPath.
  refine (r @ _); clear r.
  assert (ss : one' = pt_1).
  { unfold one'.
    refine (castTorsor_transportf (invmap torsor_univalence _) _ @ _).
    apply torsor_univalence_inv_comp_eval. }
  unfold pt_1 in ss.
  set (s0sm := λ m:ℤ¹, ! s0 @ s m).
  assert (b : cp (ε' loop 0) (h0^-1 * h one') =
              cp (ε'' 0) (h0^-1 * h (1 + pt_0))).
  { intermediate_path (cp (ε'' 0) (cp (maponpaths s0sm ss) (h0^-1 * h one'))).
    - intermediate_path (cp (maponpaths s0sm ss @ ε'' 0) (h0^-1 * h one')).
      + apply cp_irrelevance_circle.
      + apply cp_pathscomp0.
    - apply maponpaths. exact (cp_in_family _ (λ m, h0^-1 * h m)). }
  refine (b @ _); clear s0sm b. unfold pt_0. rewrite (q 0). fold h0. clear q ss one'.
  set (α0 := invrot' (s_compute_0 : s0 = ! idpath _)).
  transparent assert (α : (!s0 @ s1 = idpath pt @ (loop @ s0))).
  { exact (apstar α0 (!ε pt_0)). }
  transparent assert (β : (idpath pt @ (loop @ s0) = idpath pt @ (loop @ idpath pt))).
  { exact (apstar (idpath _) (apstar (idpath loop) s_compute_0)). }
  transparent assert (γ : (idpath pt @ (loop @ idpath pt) = idpath pt @ loop)).
  { exact (apstar (idpath _) (pathscomp0rid _)). }
  intermediate_path (cp (α@β@γ) (h0^-1 * cp (ε pt_0) (p * h0))). (* try to make do with just two factors *)
  { apply cp_irrelevance_circle. }
  rewrite cp_pathscomp0. unfold α. rewrite cp_apstar. rewrite inverse_cp_p.
  rewrite cp_pathscomp0. unfold β. rewrite cp_apstar.
  rewrite cp_idpath. unfold γ. rewrite cp_apstar.
  rewrite cp_idpath. rewrite cp_apstar.
  change (cp s_compute_0 h0) with (∇ e).
  change (cp (idpath loop) p) with p.
  rewrite composePathOverPath_compute, composePathPathOver_compute.
  intermediate_path (cp (pathscomp0rid loop) (cp α0 (h0^-1) * p * ∇ e)).
  { rewrite cp_left. apply (maponpaths (cp (pathscomp0rid loop))).
    exact (assocPathOver (cp α0 (h0^-1)) p (cp s_compute_0 h0)). }
  rewrite cp_apstar'; fold s0.
  unfold α0. rewrite invrotrot'. change (cp s_compute_0 h0) with (∇ e).
  rewrite inversePathOverIdpath'.
  reflexivity.
Defined.                        (* too slow *)

Arguments circle_induction : clear implicits.