{- Conatural number properties (Tesla Ice Zhang et al., Feb. 2019)

This file defines operations and properties on conatural numbers:

- Infinity (∞).

- Proof that ∞ + 1 is equivalent to ∞.

- Proof that conatural is an hSet.

- Bisimulation on conatural

- Proof that bisimulation is equivalent to equivalence (Coinductive Proof
  Principle).

- Proof that this bisimulation is prop valued

The standard library also defines bisimulation on conaturals:

https://github.com/agda/agda-stdlib/blob/master/src/Codata/Conat/Bisimilarity.agda
-}

{-# OPTIONS --safe --guardedness #-}
module Cubical.Codata.Conat.Properties where

open import Cubical.Data.Unit
open import Cubical.Data.Sum
open import Cubical.Data.Sigma
open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Bool
  renaming (Bool→Type to ⟨_⟩)

import Cubical.Data.Nat as Nat
import Cubical.Data.Nat.Order.Recursive as Nat

open import Cubical.Core.Everything

open import Cubical.Functions.Embedding

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Path
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.Relation.Nullary
open import Cubical.Codata.Conat.Base

import Cubical.Axiom.Omniscience as Omni

Unwrap-prev : Conat′ → Type₀
Unwrap-prev  zero   = Unit
Unwrap-prev (suc _) = Conat

unwrap-prev : (n : Conat′) -> Unwrap-prev n
unwrap-prev  zero   = _
unwrap-prev (suc x) = x

private -- tests
  𝟘 = conat zero
  𝟙  = succ 𝟘
  𝟚  = succ 𝟙

  succ𝟙≡𝟚 : succ 𝟙 ≡ 𝟚
  succ𝟙≡𝟚 i = 𝟚

  pred𝟚≡𝟙 : unwrap-prev (force 𝟚) ≡ 𝟙
  pred𝟚≡𝟙 i = 𝟙

∞ : Conat
force ∞ = suc ∞

∞+1≡∞ : succ ∞ ≡ ∞
force (∞+1≡∞ _) = suc ∞

∞+2≡∞ : succ (succ ∞) ≡ ∞
∞+2≡∞ = (cong succ ∞+1≡∞) ∙ ∞+1≡∞

_+_ : Conat → Conat → Conat
_+′_ : Conat′ → Conat → Conat′

force (x + y) = force x +′ y
zero +′ y = force y
suc x +′ y = suc (x + y)

n+∞≡∞ : ∀ n → n + ∞ ≡ ∞
n+′∞≡∞′ : ∀ n → n +′ ∞ ≡ suc ∞

force (n+∞≡∞ n i) = n+′∞≡∞′ (force n) i
n+′∞≡∞′ zero = refl
n+′∞≡∞′ (suc n) = λ i → suc (n+∞≡∞ n i)

∞+∞≡∞ : ∞ + ∞ ≡ ∞
force (∞+∞≡∞ i) = suc (∞+∞≡∞ i)

+-zeroˡ : ∀ n → 𝟘 + n ≡ n
force (+-zeroˡ n _) = force n

+-zeroʳ : ∀ n → n + 𝟘 ≡ n
+′-zeroʳ : ∀ n → n +′ 𝟘 ≡ n

force (+-zeroʳ n i) = +′-zeroʳ (force n) i
+′-zeroʳ zero _ = zero
+′-zeroʳ (suc n) i = suc (+-zeroʳ n i)

+-assoc : ∀ m n p → (m + n) + p ≡ m + (n + p)
+′-assoc : ∀ m n p → (m +′ n) +′ p ≡ m +′ (n + p)

force (+-assoc m n p i) = +′-assoc (force m) n p i
+′-assoc zero _ _ = refl
+′-assoc (suc m) n p i = suc (+-assoc m n p i)

conat-absurd : ∀ {y : Conat} {ℓ} {Whatever : Type ℓ} → zero ≡ suc y → Whatever
conat-absurd eq = ⊥.rec (transport (cong diag eq) tt)
  where
  diag : Conat′ → Type₀
  diag zero = Unit
  diag (suc _) = ⊥

embed : Nat.ℕ → Conat
embed Nat.zero .force = zero
embed (Nat.suc n) .force = suc (embed n)

embed-inj : ∀ m n → embed m ≡ embed n → m ≡ n
embed-inj m n p with ⊎Path.encode _ _ (cong force p)
embed-inj Nat.zero Nat.zero _ | _ = refl
embed-inj (Nat.suc m) (Nat.suc n) _ | lift q
  = cong Nat.suc (embed-inj m n q)

embed≢∞ : ∀ n → embed n ≡ ∞ → ⊥
embed≢∞ Nat.zero = lower ∘ ⊎Path.encode _ _ ∘ cong force
embed≢∞ (Nat.suc n) = embed≢∞ n ∘ lower ∘ ⊎Path.encode _ _ ∘ cong force

cover : Nat.ℕ → Conat
cover Nat.zero = ∞
cover (Nat.suc n) = embed n

cover-inj : ∀ m n → cover m ≡ cover n → m ≡ n
cover-inj Nat.zero Nat.zero _ = refl
cover-inj (Nat.suc m) (Nat.suc n) p = cong Nat.suc (embed-inj m n p)
cover-inj Nat.zero (Nat.suc n) = ⊥.rec ∘ embed≢∞ n ∘ sym
cover-inj (Nat.suc m) Nat.zero = ⊥.rec ∘ embed≢∞ m

module IsSet where
  ≡-stable  : {x y : Conat} → Stable (x ≡ y)
  ≡′-stable : {x y : Conat′} → Stable (x ≡ y)

  force (≡-stable ¬¬p i) = ≡′-stable (λ ¬p → ¬¬p (λ p → ¬p (cong force p))) i
  ≡′-stable {zero}  {zero}  ¬¬p′ = refl
  ≡′-stable {suc x} {suc y} ¬¬p′ =
     cong′ suc (≡-stable λ ¬p → ¬¬p′ λ p → ¬p (cong pred′′ p))
  ≡′-stable {zero}  {suc y} ¬¬p′ = ⊥.rec (¬¬p′ conat-absurd)
  ≡′-stable {suc x} {zero}  ¬¬p′ = ⊥.rec (¬¬p′ λ p → conat-absurd (sym p))

  isSetConat : isSet Conat
  isSetConat _ _ = Separated→isSet (λ _ _ → ≡-stable) _ _

  isSetConat′ : isSet Conat′
  isSetConat′ m n p′ q′ = cong (cong force) (isSetConat (conat m) (conat n) p q)
    where p = λ where i .force → p′ i
          q = λ where i .force → q′ i

module Bisimulation where
  open IsSet using (isSetConat)

  record _≈_ (x y : Conat) : Type₀
  data _≈′_ (x y : Conat′) : Type₀
  _≈′′_ : Conat′ → Conat′ → Type₀
  zero  ≈′′ zero  = Unit
  suc x ≈′′ suc y = x ≈ y
  -- So impossible proofs are preserved
  x ≈′′ y = ⊥

  record _≈_ x y where
    coinductive
    field prove : force x ≈′ force y

  data _≈′_  x y where
    con : x ≈′′ y → x ≈′ y

  open _≈_ public

  bisim : ∀ {x y} → x ≈ y → x ≡ y
  bisim′ : ∀ {x y} → x ≈′ y → x ≡ y

  bisim′ {zero} {zero} (con tt) = refl
  bisim′ {zero} {suc x} (con ())
  bisim′ {suc x} {zero} (con ())
  bisim′ {suc x} {suc y} (con eq) i = suc (bisim eq i)
  force (bisim eq i) = bisim′ (prove eq) i

  misib : ∀ {x y} → x ≡ y → x ≈ y
  misib′ : ∀ {x y} → x ≡ y → x ≈′ y

  misib′ {zero} {zero} _ = con tt
  misib′ {zero} {suc x} = conat-absurd
  misib′ {suc x} {zero} p = conat-absurd (sym p)
  -- misib′ {suc x} {suc y} p = con λ where .prove → misib′ (cong pred′ p)
  misib′ {suc x} {suc y} p = con (misib (cong pred′′ p))
  prove (misib x≡y) = misib′ (cong force x≡y)

  iso″ : ∀ {x y} → (p : x ≈ y) → misib (bisim p) ≡ p
  iso′ : ∀ {x y} → (p : x ≈′ y) → misib′ (bisim′ p) ≡ p

  iso′ {zero} {zero} (con p) = refl
  iso′ {zero} {suc x} (con ())
  iso′ {suc x} {zero} (con ())
  iso′ {suc x} {suc y} (con p) = cong con (iso″ p)
  prove (iso″ p i) = iso′ (prove p) i

  osi : ∀ {x y} → (p : x ≡ y) → bisim (misib p) ≡ p
  osi p = isSetConat _ _ _ p

  path≃bisim : ∀ {x y} → (x ≡ y) ≃ (x ≈ y)
  path≃bisim = isoToEquiv (iso misib bisim iso″ osi)

  path≡bisim : ∀ {x y} → (x ≡ y) ≡ (x ≈ y)
  path≡bisim = ua path≃bisim

  isProp≈ : ∀ {x y} → isProp (x ≈ y)
  isProp≈ = subst isProp path≡bisim (isSetConat _ _)

module WLPO where
  -- search a decidable predicate on ℕ for the first true
  search : (Nat.ℕ → Bool) → Conat
  search′ : (Nat.ℕ → Bool) → Bool → Conat′

  search f .force = search′ f (f 0)

  search′ _  true = zero
  search′ f false = suc (search (f ∘ Nat.suc))

  -- the constantly false predicate searches to ∞
  search-false : search (const false) ≡ ∞
  search-false i .force = suc (search-false i)

  wrap : Conat′ → Conat
  wrap zero = ∞
  wrap (suc m) = m

  search-lemma : ∀ α n → search α ≡ ∞ → α n ≡ false
  search-lemma α Nat.zero p with α 0 | cong force p
  ... | false | q = refl
  ... | true | q = ⊥.rec (⊎Path.encode zero (suc ∞) q .lower)
  search-lemma α (Nat.suc n) p with α 0 | cong force p
  ... | false | q = search-lemma (α ∘ Nat.suc) n (cong wrap q)
  ... |  true | q = ⊥.rec (⊎Path.encode zero (suc ∞) q .lower)

  search-n : ∀ α n → search α ≡ embed n → α n ≡ true
  search-n α Nat.zero p with α 0 | ⊎Path.encode _ _ (cong force p)
  ... |  true | _ = refl
  search-n α (Nat.suc n) p with α 0 | ⊎Path.encode _ _ (cong force p)
  ... | false | q = search-n (α ∘ Nat.suc) n (q .lower)

  module _ (f : Conat → Nat.ℕ) (emb : isEmbedding f) where
    discreteConat : Discrete Conat
    discreteConat
      = Embedding-into-Discrete→Discrete (f , emb) Nat.discreteℕ

    wlpo' : Omni.WLPO' Nat.ℕ
    wlpo' α with discreteConat (search α) ∞
    ... | yes p = yes λ i n → search-lemma α n p i
    ... | no ¬p = no (¬p ∘ _∙ search-false ∘ cong search)

module LPO where
  open WLPO using (search; search-lemma; search-n)

  module Un (uncover : Conat → Nat.ℕ) (sect : section cover uncover) where
    search-0 : ∀ α → uncover (search α) ≡ 0 → ∀ n → α n ≡ false
    search-0 α p n
      = search-lemma α n (sym (sect (search α)) ∙ cong cover p)

    search-n' : ∀ α n → uncover (search α) ≡ Nat.suc n → α n ≡ true
    search-n' α n p = search-n α n (sym (sect (search α)) ∙ cong cover p)

    -- So, surjectivity of `cover` implies LPO, since `cover` has
    -- already been shown injective, and surjectivity would make it an
    -- equivalence (as ℕ and Conat are sets).
    lpo' : Omni.LPO∞ Nat.ℕ
    lpo' α = disc (uncover (search α)) refl where
      disc : ∀ n → uncover (search α) ≡ n → _
      disc Nat.zero p = inl λ n → subst ⟨_⟩ (search-0 α p n)
      disc (Nat.suc n) p = inr (n , subst⁻ ⟨_⟩ (search-n' α n p) _)


-- Andreas, 2012-05-09
module DontPrune where

open import Common.Equality
open import Common.Product

data Bool : Set where
  true false : Bool

test : (A : Set) →
  let IF : Bool → A → A → A
      IF = _
  in  (a b : A) →
      (IF true a b ≡ a) × (IF false a b ≡ b)
test A a b = refl , refl

-- Expected result: unsolved metas
--
-- (unless someone implemented unification that produces definitions by case).
--
-- The test case should prevent overzealous pruning:
-- If the first equation pruned away the b, then the second
-- would have an unbound rhs.


{-# OPTIONS --without-K #-}

-- Exposes the core of hott
module hott.core where

-- The basic types of hott

open import hott.core.equality  public -- Equality type
open import hott.core.sigma     public -- Dependent pairs
open import hott.core.universe  public -- Universes
open import hott.core.universe.pointed public
                                       -- and the pointed ones.


open import slots.imports
open import slots.defs

module slots.bruteforce {cfg : config}(g : game cfg) where

open config cfg
open game g

total : ℕ
total = V.foldl _ (λ i r → i * L.length r) 1 reels

lineWin : Line → Win/Bet
lineWin [] = 0
lineWin (f₀ ∷ fs) = lineWin′ w ws fs where
  winLine = V.lookup f₀ winTable
  w = V.head winLine
  ws = V.tail winLine

  lineWin′ : ∀ {n} →
    Win/Bet → Vec Win/Bet n → Vec Fruit n → Win/Bet
  lineWin′ w [] [] = w
  lineWin′ w (w′ ∷ ws) (f ∷ fs) with f₀ F.≟ f
  ... | yes p = lineWin′ w′ ws fs
  ... | no ¬p = w

allLines : List Line
allLines = V.foldr (List ∘ Vec Fruit)
  (λ r → L.concatMap λ l → L.map (_∷ l) r)
  ([] ∷ []) reels

win : ℕ
win = L.sum ∘ L.map lineWin $ allLines

rtp : ℕ × ℕ
rtp = win , total


{-# OPTIONS --without-K --allow-unsolved-metas --exact-split #-}

module 17-cubical-diagrams where

import 16-pushouts
open 16-pushouts public

-- Section 15.1 Commuting cubes

-- Cubes

  {-
    We specify the type of the homotopy witnessing that a cube commutes.
    Imagine that the cube is presented as a lattice

            *
          / | \
         /  |  \
        /   |   \
       *    *    *
       |\ /   \ /|
       | \     / |
       |/ \   / \|
       *    *    *
        \   |   /
         \  |  /
          \ | /
            *

    with all maps pointing in the downwards direction. Presented in this way, a
    cube of maps has a top face, a back-left face, a back-right face, a
    front-left face, a front-right face, and a bottom face, all of which are
    homotopies.

    A term of type coherence-cube is a homotopy filling the cube.
  -}

coherence-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  UU _
coherence-cube
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom =
  (((h ·l back-left) ∙h (front-left ·r f')) ∙h (hD ·l top)) ~
  ((bottom ·r hA) ∙h ((k ·l back-right) ∙h (front-right ·r g')))

coherence-hexagon :
  {l : Level} {A : UU l} {x u u' v v' y : A}
  (α : Id x u) (β : Id u u') (γ : Id u' y)
  (δ : Id x v) (ε : Id v v') (ζ : Id v' y) → UU l
coherence-hexagon α β γ δ ε ζ = Id ((α ∙ β) ∙ γ) (δ ∙ (ε ∙ ζ))

hexagon-rotate-120 :
  {l : Level} {A : UU l} {x u u' v v' y : A}
  (α : Id x u) (β : Id u u') (γ : Id u' y)
  (δ : Id x v) (ε : Id v v') (ζ : Id v' y) →
  coherence-hexagon α β γ δ ε ζ →
  coherence-hexagon (inv ε) (inv δ) α ζ (inv γ) (inv β)
hexagon-rotate-120 refl refl refl refl refl .refl refl = refl

hexagon-rotate-240 :
  {l : Level} {A : UU l} {x u u' v v' y : A}
  (α : Id x u) (β : Id u u') (γ : Id u' y)
  (δ : Id x v) (ε : Id v v') (ζ : Id v' y) →
  coherence-hexagon α β γ δ ε ζ →
  coherence-hexagon γ (inv ζ) (inv ε) (inv β) (inv α) δ
hexagon-rotate-240 refl refl refl refl refl .refl refl = refl

hexagon-mirror-A :
  {l : Level} {A : UU l} {x u u' v v' y : A}
  (α : Id x u) (β : Id u u') (γ : Id u' y)
  (δ : Id x v) (ε : Id v v') (ζ : Id v' y) →
  coherence-hexagon α β γ δ ε ζ →
  coherence-hexagon ε ζ (inv γ) (inv δ) α β
hexagon-mirror-A refl refl refl refl refl .refl refl = refl

hexagon-mirror-B :
  {l : Level} {A : UU l} {x u u' v v' y : A}
  (α : Id x u) (β : Id u u') (γ : Id u' y)
  (δ : Id x v) (ε : Id v v') (ζ : Id v' y) →
  coherence-hexagon α β γ δ ε ζ →
  coherence-hexagon (inv α) δ ε β γ (inv ζ)
hexagon-mirror-B refl refl refl refl refl .refl refl = refl

hexagon-mirror-C :
  {l : Level} {A : UU l} {x u u' v v' y : A}
  (α : Id x u) (β : Id u u') (γ : Id u' y)
  (δ : Id x v) (ε : Id v v') (ζ : Id v' y) →
  coherence-hexagon α β γ δ ε ζ →
  coherence-hexagon (inv γ) (inv β) (inv α) (inv ζ) (inv ε) (inv δ)
hexagon-mirror-C refl refl refl refl refl .refl refl = refl

{- Since the specification of a cube is rather lengthy, we use Agda's
   parametrized module system in order to avoid having to specify the same
   variables multiple times.
-}

module Cubes
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g))
  (c : coherence-cube
    f g h k f' g' h' k' hA hB hC hD
    top back-left back-right front-left front-right bottom)
  where

  {-
    The symmetry group D_3 acts on a cube. However, the coherence filling a
    a cube needs to be modified to show that the rotated/reflected cube again
    commutes. In the following definitions we provide the homotopies witnessing
    that the rotated/reflected cubes again commute.

    Note: although in principle it ought to be enough to show this for the
    generators of the symmetry group D_3, in practice it is more
    straightforward to just do the work for each of the symmetries separately.
    One reason is that some of the homotopies witnessing that the faces
    commute will be inverted as the result of an application of a symmetry.
    Inverting a homotopy twice results in a new homotopy that is only
    homotopic to the original homotopy.

    We first provide some constructions involving homotopies that will help us
    manipulating coherences of cubes.
  -}

  -- We show that a rotation of a commuting cube again commutes.
  coherence-cube-rotate-120 :
    coherence-cube
      hC k' k hD hA f' f hB g' g h' h
      back-left
      (htpy-inv back-right) (htpy-inv top)
      (htpy-inv bottom) (htpy-inv front-left)
      front-right
  coherence-cube-rotate-120 a' =
    ( ap (λ t → t ∙ (ap h (back-left a')))
      ( ap (λ t' → t' ∙ inv (bottom (hA a')))
        ( ap-inv k (back-right a')))) ∙
    ( ( hexagon-rotate-120
        ( ap h (back-left a'))
        ( front-left (f' a'))
        ( ap hD (top a'))
        ( bottom (hA a'))
        ( ap k (back-right a'))
        ( front-right (g' a'))
        ( c a')) ∙
      ( inv
        ( ap (λ t → (front-right (g' a')) ∙ t)
          ( ap (λ t' → t' ∙ inv (front-left (f' a')))
            ( ap-inv hD (top a'))))))

  coherence-cube-rotate-240 :
    coherence-cube
      h' hB hD h g' hA hC g f' k' f k
      (htpy-inv back-right)
      top (htpy-inv back-left)
      (htpy-inv front-right) bottom
      (htpy-inv front-left)
  coherence-cube-rotate-240 a' =
    ( ap (λ t → _ ∙ t) (ap-inv k (back-right a'))) ∙
    ( ( hexagon-rotate-240
        ( ap h (back-left a'))
        ( front-left (f' a'))
        ( ap hD (top a'))
        ( bottom (hA a'))
        ( ap k (back-right a'))
        ( front-right (g' a'))
        ( c a')) ∙
      ( inv
        ( ap
          ( λ t → inv (front-left (f' a')) ∙ t)
          ( ap (λ t' → t' ∙ _) (ap-inv h (back-left a'))))))

  {-
    We show that a reflection through the plane spanned by the vertices
    A', A, and D of a commuting cube again commutes.

    Note: Since the vertices A' and D must always be fixed, the vertex A
    determines the mirror symmetry.
  -}

  coherence-cube-mirror-A :
    coherence-cube g f k h g' f' k' h' hA hC hB hD
      (htpy-inv top) back-right back-left front-right front-left (htpy-inv bottom)
  coherence-cube-mirror-A a' =
    ( ap (λ t → _ ∙ t) (ap-inv hD (top a'))) ∙
    ( hexagon-mirror-A
      ( ap h (back-left a'))
      ( front-left (f' a'))
      ( ap hD (top a'))
      ( bottom (hA a'))
      ( ap k (back-right a'))
      ( front-right (g' a'))
      ( c a'))

  coherence-cube-mirror-B :
    coherence-cube hB h' h hD hA g' g hC f' f k' k
    back-right (htpy-inv back-left) top bottom (htpy-inv front-right) front-left
  coherence-cube-mirror-B a' =
    ( ap (λ t → t ∙ (ap k (back-right a')))
      ( ap (λ t → t ∙ _) (ap-inv h (back-left a')))) ∙
    ( hexagon-mirror-B
      ( ap h (back-left a'))
      ( front-left (f' a'))
      ( ap hD (top a'))
      ( bottom (hA a'))
      ( ap k (back-right a'))
      ( front-right (g' a'))
      ( c a'))

  coherence-cube-mirror-C :
    coherence-cube k' hC hD k f' hA hB f g' h' g h
    (htpy-inv back-left) (htpy-inv top) (htpy-inv back-right)
    (htpy-inv front-left) (htpy-inv bottom) (htpy-inv front-right)
  coherence-cube-mirror-C a' =
    ( ap
      ( λ t → (t ∙ inv (front-left (f' a'))) ∙ (ap h (inv (back-left a'))))
      ( ap-inv hD (top a'))) ∙
    ( ( ap (λ t → _ ∙ t) (ap-inv h (back-left a'))) ∙
      ( ( hexagon-mirror-C
          ( ap h (back-left a'))
          ( front-left (f' a'))
          ( ap hD (top a'))
          ( bottom (hA a'))
          ( ap k (back-right a'))
          ( front-right (g' a'))
          ( c a')) ∙
        ( inv
          ( ap
            ( λ t → inv (front-right (g' a')) ∙ t)
            ( ap (λ t' → t' ∙ _) (ap-inv k (back-right a')))))))

open Cubes public

rectangle-back-left-front-left-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  ((h ∘ f) ∘ hA) ~ (hD ∘ (h' ∘ f'))
rectangle-back-left-front-left-cube f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom =
  (h ·l back-left) ∙h (front-left ·r f')

rectangle-back-right-front-right-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  ((k ∘ g) ∘ hA) ~ (hD ∘ (k' ∘ g'))
rectangle-back-right-front-right-cube f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom =
  (k ·l back-right) ∙h (front-right ·r g')

coherence-htpy-square-rectangle-bl-fl-rectangle-br-fr-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g))
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
    top back-left back-right front-left front-right bottom) →
  coherence-htpy-square
    ( bottom)
    ( htpy-refl' hD)
    ( pair hA
      ( pair
        ( h' ∘ f')
        ( rectangle-back-left-front-left-cube
          f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom)))
    ( pair hA
      ( pair
        ( k' ∘ g')
        ( rectangle-back-right-front-right-cube
          f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom)))
    ( htpy-refl' hA)
    ( top)
coherence-htpy-square-rectangle-bl-fl-rectangle-br-fr-cube
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom c =
  ( λ a' →
    ( ap
      ( concat
        ( rectangle-back-left-front-left-cube
          f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom a')
        ( hD (k' (g' a'))))
      ( right-unit))) ∙h
  ( c)

rectangle-top-front-left-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  ((h ∘ hB) ∘ f') ~ ((hD ∘ k') ∘ g')
rectangle-top-front-left-cube
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom =
  (front-left ·r f') ∙h (hD ·l top)

rectangle-back-right-bottom-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  ((h ∘ f) ∘ hA) ~ ((k ∘ hC) ∘ g')
rectangle-back-right-bottom-cube
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom =
  ( bottom ·r hA) ∙h (k ·l back-right)

{-
coherence-htpy-square-rectangle-top-fl-rectangle-br-bot-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g))
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
    top back-left back-right front-left front-right bottom) →
  coherence-htpy-square
    ( htpy-inv front-right)
    ( htpy-refl' h)
    ( pair g' (pair (hB ∘ f')
      ( htpy-inv (rectangle-top-front-left-cube f g h k f' g' h' k' hA hB hC hD
        top back-left back-right front-left front-right bottom))))
    ( pair g' (pair (f ∘ hA)
      ( htpy-inv
        ( rectangle-back-right-bottom-cube f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom))))
    ( htpy-refl' g')
    ( htpy-inv back-left)
coherence-htpy-square-rectangle-top-fl-rectangle-br-bot-cube = {!!}
-}

rectangle-top-front-right-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  ((hD ∘ h') ∘ f') ~ ((k ∘ hC) ∘ g')
rectangle-top-front-right-cube
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom =
  (hD ·l top) ∙h (htpy-inv (front-right) ·r g')

rectangle-back-left-bottom-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g))→
  ((h ∘ hB) ∘ f') ~ ((k ∘ g) ∘ hA)
rectangle-back-left-bottom-cube
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom =
  (h ·l (htpy-inv back-left)) ∙h (bottom ·r hA)

is-pullback-back-left-is-pullback-back-right-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  {f : A → B} {g : A → C} {h : B → D} {k : C → D}
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  {f' : A' → B'} {g' : A' → C'} {h' : B' → D'} {k' : C' → D'}
  {hA : A' → A} {hB : B' → B} {hC : C' → C} {hD : D' → D}
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
    top back-left back-right front-left front-right bottom) →
  is-pullback h hD (pair hB (pair h' front-left)) →
  is-pullback k hD (pair hC (pair k' front-right)) →
  is-pullback g hC (pair hA (pair g' back-right)) →
  is-pullback f hB (pair hA (pair f' back-left))
is-pullback-back-left-is-pullback-back-right-cube
  {f = f} {g} {h} {k} {f' = f'} {g'} {h'} {k'} {hA = hA} {hB} {hC} {hD}
  top back-left back-right front-left front-right bottom c
  is-pb-front-left is-pb-front-right is-pb-back-right =
  is-pullback-left-square-is-pullback-rectangle f h hD
    ( pair hB (pair h' front-left))
    ( pair hA (pair f' back-left))
    ( is-pb-front-left)
    ( is-pullback-htpy
      { f = h ∘ f}
      ( k ∘ g)
      ( bottom)
      { g = hD}
      ( hD)
      ( htpy-refl)
      { c = pair hA (pair (h' ∘ f')
        ( rectangle-back-left-front-left-cube
          f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom))}
      ( pair hA (pair (k' ∘ g')
        ( rectangle-back-right-front-right-cube
          f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom)))
      ( pair
        ( htpy-refl)
        ( pair top
          ( coherence-htpy-square-rectangle-bl-fl-rectangle-br-fr-cube
            f g h k f' g' h' k' hA hB hC hD
            top back-left back-right front-left front-right bottom c)))
      ( is-pullback-rectangle-is-pullback-left-square g k hD
        ( pair hC (pair k' front-right))
        ( pair hA (pair g' back-right))
        ( is-pb-front-right)
        ( is-pb-back-right)))

is-pullback-back-right-is-pullback-back-left-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  {f : A → B} {g : A → C} {h : B → D} {k : C → D}
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  {f' : A' → B'} {g' : A' → C'} {h' : B' → D'} {k' : C' → D'}
  {hA : A' → A} {hB : B' → B} {hC : C' → C} {hD : D' → D}
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
    top back-left back-right front-left front-right bottom) →
  is-pullback h hD (pair hB (pair h' front-left)) →
  is-pullback k hD (pair hC (pair k' front-right)) →
  is-pullback f hB (pair hA (pair f' back-left)) →
  is-pullback g hC (pair hA (pair g' back-right))
is-pullback-back-right-is-pullback-back-left-cube
  {f = f} {g} {h} {k} {f' = f'} {g'} {h'} {k'} {hA = hA} {hB} {hC} {hD}
  top back-left back-right front-left front-right bottom c
  is-pb-front-left is-pb-front-right is-pb-back-left =
  is-pullback-left-square-is-pullback-rectangle g k hD
    ( pair hC (pair k' front-right))
    ( pair hA (pair g' back-right))
    ( is-pb-front-right)
    ( is-pullback-htpy'
      ( h ∘ f)
      { f' = k ∘ g}
      ( bottom)
      ( hD)
      { g' = hD}
      ( htpy-refl)
      ( pair hA (pair (h' ∘ f')
        ( rectangle-back-left-front-left-cube
          f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom)))
      { c' = pair hA (pair (k' ∘ g')
        ( rectangle-back-right-front-right-cube
          f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom))}
      ( pair
        ( htpy-refl)
        ( pair top
          ( coherence-htpy-square-rectangle-bl-fl-rectangle-br-fr-cube
            f g h k f' g' h' k' hA hB hC hD
            top back-left back-right front-left front-right bottom c)))
      ( is-pullback-rectangle-is-pullback-left-square f h hD
        ( pair hB (pair h' front-left))
        ( pair hA (pair f' back-left))
        ( is-pb-front-left)
        ( is-pb-back-left)))

descent-is-equiv :
  {l1 l2 l3 l4 l5 l6 : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {X : UU l4} {Y : UU l5} {Z : UU l6}
  (i : X → Y) (j : Y → Z) (h : C → Z)
  (c : cone j h B) (d : cone i (pr1 c) A) →
  is-equiv i → is-equiv (pr1 (pr2 d)) →
  is-pullback (j ∘ i) h (cone-comp-horizontal i j h c d) →
  is-pullback j h c
descent-is-equiv i j h c d
  is-equiv-i is-equiv-k is-pb-rectangle =
  is-pullback-is-fiberwise-equiv-fib-square j h c
    ( ind-is-equiv
      ( λ y → is-equiv (fib-square j h c y))
      ( i)
      ( is-equiv-i)
      ( λ x → is-equiv-left-factor
        ( fib-square (j ∘ i) h
          ( cone-comp-horizontal i j h c d) x)
        ( fib-square j h c (i x))
        ( fib-square i (pr1 c) d x)
        ( fib-square-comp-horizontal i j h c d x)
        ( is-fiberwise-equiv-fib-square-is-pullback (j ∘ i) h
          ( cone-comp-horizontal i j h c d)
          ( is-pb-rectangle)
          ( x))
        ( is-fiberwise-equiv-fib-square-is-pullback i (pr1 c) d
          ( is-pullback-is-equiv' i (pr1 c) d is-equiv-i is-equiv-k) x)))

coherence-htpy-square-is-pullback-bottom-is-pullback-top-cube-is-equiv :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
       top back-left back-right front-left front-right bottom) →
  coherence-htpy-square
    ( front-left)
    ( htpy-refl' k)
    ( pair f'
      ( pair
        ( g ∘ hA)
        ( rectangle-back-left-bottom-cube
          f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom)))
    ( pair f'
      ( pair
        ( hC ∘ g')
        ( rectangle-top-front-right-cube
          f g h k f' g' h' k' hA hB hC hD
          top back-left back-right front-left front-right bottom)))
    ( htpy-refl' f')
    ( back-right)
coherence-htpy-square-is-pullback-bottom-is-pullback-top-cube-is-equiv
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom c =
  ( htpy-inv
    ( htpy-inv
      ( htpy-assoc
        ( h ·l (htpy-inv back-left))
        ( bottom ·r hA)
        ( (k ·l back-right) ∙h (htpy-refl' (k ∘ (hC ∘ g'))))))) ∙h
  ( ( htpy-ap-concat'
      ( h ·l (htpy-inv back-left))
      ( htpy-inv (h ·l back-left))
      ( _)
      ( htpy-left-whisk-htpy-inv h back-left)) ∙h
      ( htpy-inv (htpy-inv-con (h ·l back-left) _ _
        ( ( ( htpy-inv (htpy-assoc (h ·l back-left) (front-left ·r f') _)) ∙h
            ( ( htpy-inv
                ( htpy-assoc
                  ( (h ·l back-left) ∙h (front-left ·r f'))
                  ( hD ·l top)
                  ( (htpy-inv front-right) ·r g'))) ∙h
              htpy-inv
              ( htpy-con-inv _ (front-right ·r g') _
                ( (htpy-assoc (bottom ·r hA) _ _) ∙h (htpy-inv (c)))))) ∙h
          ( htpy-inv
            ( htpy-ap-concat (bottom ·r hA) _ _ htpy-right-unit))))))

is-pullback-bottom-is-pullback-top-cube-is-equiv :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
       top back-left back-right front-left front-right bottom) →
  is-equiv hA → is-equiv hB → is-equiv hC → is-equiv hD →
  is-pullback h' k' (pair f' (pair g' top)) →
  is-pullback h k (pair f (pair g bottom))
is-pullback-bottom-is-pullback-top-cube-is-equiv
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom c
  is-equiv-hA is-equiv-hB is-equiv-hC is-equiv-hD is-pb-top =
  descent-is-equiv hB h k
    ( pair f (pair g bottom))
    ( pair f' (pair hA (htpy-inv (back-left))))
    ( is-equiv-hB)
    ( is-equiv-hA)
    ( is-pullback-htpy
      {f = h ∘ hB}
      ( hD ∘ h')
      ( front-left)
      {g = k}
      ( k)
      ( htpy-refl' k)
      { c = pair f'
        ( pair
          ( g ∘ hA)
          ( rectangle-back-left-bottom-cube
            f g h k f' g' h' k' hA hB hC hD
            top back-left back-right front-left front-right bottom))}
       ( pair
        ( f')
        ( pair
          ( hC ∘ g')
          ( rectangle-top-front-right-cube
            f g h k f' g' h' k' hA hB hC hD
            top back-left back-right front-left front-right bottom)))
      ( pair
        ( htpy-refl' f')
        ( pair
          ( back-right)
          ( coherence-htpy-square-is-pullback-bottom-is-pullback-top-cube-is-equiv
            f g h k f' g' h' k' hA hB hC hD
            top back-left back-right front-left front-right bottom c)))
      ( is-pullback-rectangle-is-pullback-left-square
        ( h')
        ( hD)
        ( k)
        ( pair k' (pair hC (htpy-inv front-right)))
        ( pair f' (pair g' top))
        ( is-pullback-is-equiv' hD k
          ( pair k' (pair hC (htpy-inv front-right)))
          ( is-equiv-hD)
          ( is-equiv-hC))
        ( is-pb-top)))

is-pullback-top-is-pullback-bottom-cube-is-equiv :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
       top back-left back-right front-left front-right bottom) →
  is-equiv hA → is-equiv hB → is-equiv hC → is-equiv hD →
  is-pullback h k (pair f (pair g bottom)) →
  is-pullback h' k' (pair f' (pair g' top))
is-pullback-top-is-pullback-bottom-cube-is-equiv
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom c
  is-equiv-hA is-equiv-hB is-equiv-hC is-equiv-hD is-pb-bottom =
  is-pullback-top-is-pullback-rectangle h hD k'
    ( pair hB (pair h' front-left))
    ( pair f' (pair g' top))
    ( is-pullback-is-equiv h hD
      ( pair hB (pair h' front-left))
      is-equiv-hD is-equiv-hB)
    ( is-pullback-htpy' h htpy-refl (k ∘ hC) front-right
      ( cone-comp-vertical h k hC
        ( pair f (pair g bottom))
        ( pair hA (pair g' back-right)))
      { c' = cone-comp-vertical h hD k'
        ( pair hB (pair h' front-left))
        ( pair f' (pair g' top))}
      ( pair back-left
        ( pair
          ( htpy-refl)
          ( ( ( ( htpy-assoc
                    ( bottom ·r hA) (k ·l back-right) (front-right ·r g')) ∙h
                ( htpy-inv c)) ∙h
              ( htpy-assoc
                  ( h ·l back-left) (front-left ·r f') (hD ·l top))) ∙h
            ( htpy-ap-concat'
              ( h ·l back-left)
              ( (h ·l back-left) ∙h htpy-refl)
              ( (front-left ·r f') ∙h (hD ·l top))
              ( htpy-inv htpy-right-unit)))))
      ( is-pullback-rectangle-is-pullback-top h k hC
        ( pair f (pair g bottom))
        ( pair hA (pair g' back-right))
        ( is-pb-bottom)
        ( is-pullback-is-equiv g hC
          ( pair hA (pair g' back-right))
          is-equiv-hC is-equiv-hA)))

is-pullback-front-left-is-pullback-back-right-cube-is-equiv :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
       top back-left back-right front-left front-right bottom) →
  is-equiv f' → is-equiv f → is-equiv k' → is-equiv k →
  is-pullback g hC (pair hA (pair g' back-right)) →
  is-pullback h hD (pair hB (pair h' front-left))
is-pullback-front-left-is-pullback-back-right-cube-is-equiv
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom c
  is-equiv-f' is-equiv-f is-equiv-k' is-equiv-k is-pb-back-right =
  is-pullback-bottom-is-pullback-top-cube-is-equiv
    hB h' h hD hA g' g hC f' f k' k
    back-right (htpy-inv back-left) top bottom (htpy-inv front-right) front-left
    ( coherence-cube-mirror-B f g h k f' g' h' k' hA hB hC hD top
      back-left back-right front-left front-right bottom c)
    is-equiv-f' is-equiv-f is-equiv-k' is-equiv-k is-pb-back-right

is-pullback-front-right-is-pullback-back-left-cube-is-equiv :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
       top back-left back-right front-left front-right bottom) →
  is-equiv g' → is-equiv h' → is-equiv g → is-equiv h →
  is-pullback f hB (pair hA (pair f' back-left)) →
  is-pullback k hD (pair hC (pair k' front-right))
is-pullback-front-right-is-pullback-back-left-cube-is-equiv
  f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom c
  is-equiv-g' is-equiv-h' is-equiv-g is-equiv-h is-pb-back-left =
  is-pullback-bottom-is-pullback-top-cube-is-equiv
    hC k' k hD hA f' f hB g' g h' h
    back-left (htpy-inv back-right) (htpy-inv top)
    ( htpy-inv bottom) (htpy-inv front-left) front-right
    ( coherence-cube-rotate-120 f g h k f' g' h' k' hA hB hC hD
      top back-left back-right front-left front-right bottom c)
    is-equiv-g' is-equiv-g is-equiv-h' is-equiv-h is-pb-back-left

-- Section 15.2 Fiberwise pullbacks.

{- We show that if we have a square of families, such that the base square is
   a pullback square, then each square of fibers is a pullback square if and
   only if the square of total spaces is a pullback square. -}

cone-family :
  {l1 l2 l3 l4 l5 l6 l7 l8 : Level}
  {X : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (PX : X → UU l5) {PA : A → UU l6} {PB : B → UU l7}
  {f : A → X} {g : B → X} →
  (f' : (a : A) → PA a → PX (f a)) (g' : (b : B) → PB b → PX (g b)) →
  cone f g C → (C → UU l8) → UU (l4 ⊔ (l5 ⊔ (l6 ⊔ (l7 ⊔ l8))))
cone-family {C = C} PX f' g' c PC =
  (x : C) →
  cone ((tr PX (pr2 (pr2 c) x)) ∘ (f' (pr1 c x))) (g' (pr1 (pr2 c) x)) (PC x)

htpy-toto :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {P : A → UU l3} (Q : B → UU l4)
  {f f' : A → B} (H : f ~ f') (g : (x : A) → P x → Q (f x)) {g' : (x : A) → P x → Q (f' x)} (K : (x : A) → ((tr Q (H x)) ∘ (g x)) ~ (g' x)) →
  (toto Q f g) ~ (toto Q f' g')
htpy-toto Q H g K t = eq-pair (H (pr1 t)) (K (pr1 t) (pr2 t))

tot-cone-cone-family :
  {l1 l2 l3 l4 l5 l6 l7 l8 : Level}
  {X : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (PX : X → UU l5) {PA : A → UU l6} {PB : B → UU l7} {PC : C → UU l8}
  {f : A → X} {g : B → X} →
  (f' : (a : A) → PA a → PX (f a)) (g' : (b : B) → PB b → PX (g b)) →
  (c : cone f g C) → cone-family PX f' g' c PC →
  cone (toto PX f f') (toto PX g g') (Σ C PC)
tot-cone-cone-family PX f' g' c c' =
  pair
    ( toto _ (pr1 c) (λ x → pr1 (c' x)))
    ( pair
      ( toto _ (pr1 (pr2 c)) (λ x → (pr1 (pr2 (c' x)))))
      ( htpy-toto PX
        ( pr2 (pr2 c))
        ( λ z → (f' (pr1 c z)) ∘ (pr1 (c' z)))
        ( λ z → pr2 (pr2 (c' z)))))

map-canpb-tot-cone-cone-fam-right-factor :
  {l1 l2 l3 l4 l5 l6 l7 l8 : Level}
  {X : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (PX : X → UU l5) {PA : A → UU l6} {PB : B → UU l7} {PC : C → UU l8}
  {f : A → X} {g : B → X} →
  (f' : (a : A) → PA a → PX (f a)) (g' : (b : B) → PB b → PX (g b)) →
  (c : cone f g C) (c' : cone-family PX f' g' c PC) →
  Σ ( canonical-pullback f g)
    ( λ t → canonical-pullback ((tr PX (π₃ t)) ∘ (f' (π₁ t))) (g' (π₂ t))) →
  Σ ( Σ A PA)
    ( λ aa' → Σ (Σ B (λ b → Id (f (pr1 aa')) (g b)))
      ( λ bα → Σ (PB (pr1 bα))
        ( λ b' → Id
          ( tr PX (pr2 bα) (f' (pr1 aa') (pr2 aa')))
          ( g' (pr1 bα) b'))))
map-canpb-tot-cone-cone-fam-right-factor
  {X = X} {A} {B} {C} PX {PA} {PB} {PC} {f} {g} f' g' c c' =
  swap-total-Eq-structure
    ( λ a → Σ B (λ b → Id (f a) (g b)))
    ( PA)
    ( λ a bα a' → Σ (PB (pr1 bα))
      ( λ b' → Id (tr PX (pr2 bα) (f' a a')) (g' (pr1 bα) b')))

map-canpb-tot-cone-cone-fam-left-factor :
  {l1 l2 l3 l4 l5 l6 l7 l8 : Level}
  {X : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (PX : X → UU l5) {PA : A → UU l6} {PB : B → UU l7} {PC : C → UU l8}
  {f : A → X} {g : B → X} →
  (f' : (a : A) → PA a → PX (f a)) (g' : (b : B) → PB b → PX (g b)) →
  (c : cone f g C) (c' : cone-family PX f' g' c PC) → (aa' : Σ A PA) →
  Σ (Σ B (λ b → Id (f (pr1 aa')) (g b)))
    ( λ bα → Σ (PB (pr1 bα))
      ( λ b' → Id
        ( tr PX (pr2 bα) (f' (pr1 aa') (pr2 aa')))
        ( g' (pr1 bα) b'))) →
  Σ ( Σ B PB)
    ( λ bb' → Σ (Id (f (pr1 aa')) (g (pr1 bb')))
      ( λ α → Id (tr PX α (f' (pr1 aa') (pr2 aa'))) (g' (pr1 bb') (pr2 bb'))))
map-canpb-tot-cone-cone-fam-left-factor
  {X = X} {A} {B} {C} PX {PA} {PB} {PC} {f} {g} f' g' c c' aa' =
  ( swap-total-Eq-structure
    ( λ b → Id (f (pr1 aa')) (g b))
      ( PB)
      ( λ b α b' → Id (tr PX α (f' (pr1 aa') (pr2 aa'))) (g' b b')))

map-canonical-pullback-tot-cone-cone-family :
  {l1 l2 l3 l4 l5 l6 l7 l8 : Level}
  {X : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (PX : X → UU l5) {PA : A → UU l6} {PB : B → UU l7} {PC : C → UU l8}
  {f : A → X} {g : B → X} →
  (f' : (a : A) → PA a → PX (f a)) (g' : (b : B) → PB b → PX (g b)) →
  (c : cone f g C) (c' : cone-family PX f' g' c PC) →
  Σ ( canonical-pullback f g)
    ( λ t → canonical-pullback ((tr PX (π₃ t)) ∘ (f' (π₁ t))) (g' (π₂ t))) →
  canonical-pullback (toto PX f f') (toto PX g g')
map-canonical-pullback-tot-cone-cone-family
  {X = X} {A} {B} {C} PX {PA} {PB} {PC} {f} {g} f' g' c c' =
  ( tot (λ aa' →
    ( tot (λ bb' → eq-pair')) ∘
    ( map-canpb-tot-cone-cone-fam-left-factor PX f' g' c c' aa'))) ∘
  ( map-canpb-tot-cone-cone-fam-right-factor PX f' g' c c')

is-equiv-map-canonical-pullback-tot-cone-cone-family :
  {l1 l2 l3 l4 l5 l6 l7 l8 : Level}
  {X : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (PX : X → UU l5) {PA : A → UU l6} {PB : B → UU l7} {PC : C → UU l8}
  {f : A → X} {g : B → X} →
  (f' : (a : A) → PA a → PX (f a)) (g' : (b : B) → PB b → PX (g b)) →
  (c : cone f g C) (c' : cone-family PX f' g' c PC) →
  is-equiv (map-canonical-pullback-tot-cone-cone-family PX f' g' c c')
is-equiv-map-canonical-pullback-tot-cone-cone-family
  {X = X} {A} {B} {C} PX {PA} {PB} {PC} {f} {g} f' g' c c' =
  is-equiv-comp
    ( map-canonical-pullback-tot-cone-cone-family PX f' g' c c')
    ( tot (λ aa' →
      ( tot (λ bb' → eq-pair')) ∘
      ( map-canpb-tot-cone-cone-fam-left-factor PX f' g' c c' aa')))
    ( map-canpb-tot-cone-cone-fam-right-factor PX f' g' c c')
    ( htpy-refl)
    ( is-equiv-swap-total-Eq-structure
      ( λ a → Σ B (λ b → Id (f a) (g b)))
      ( PA)
      ( λ a bα a' → Σ (PB (pr1 bα))
        ( λ b' → Id (tr PX (pr2 bα) (f' a a')) (g' (pr1 bα) b'))))
    ( is-equiv-tot-is-fiberwise-equiv (λ aa' → is-equiv-comp
      ( ( tot (λ bb' → eq-pair')) ∘
        ( map-canpb-tot-cone-cone-fam-left-factor PX f' g' c c' aa'))
      ( tot (λ bb' → eq-pair'))
      ( map-canpb-tot-cone-cone-fam-left-factor PX f' g' c c' aa')
      ( htpy-refl)
      ( is-equiv-swap-total-Eq-structure _ _ _)
      ( is-equiv-tot-is-fiberwise-equiv (λ bb' → is-equiv-eq-pair
        ( pair (f (pr1 aa')) (f' (pr1 aa') (pr2 aa')))
        ( pair (g (pr1 bb')) (g' (pr1 bb') (pr2 bb')))))))

triangle-canonical-pullback-tot-cone-cone-family :
  {l1 l2 l3 l4 l5 l6 l7 l8 : Level}
  {X : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (PX : X → UU l5) {PA : A → UU l6} {PB : B → UU l7} {PC : C → UU l8}
  {f : A → X} {g : B → X} →
  (f' : (a : A) → PA a → PX (f a)) (g' : (b : B) → PB b → PX (g b)) →
  (c : cone f g C) (c' : cone-family PX f' g' c PC) →
  ( gap (toto PX f f') (toto PX g g') (tot-cone-cone-family PX f' g' c c')) ~
  ( ( map-canonical-pullback-tot-cone-cone-family PX f' g' c c') ∘
    ( toto _
      ( gap f g c)
      ( λ x → gap
        ( (tr PX (pr2 (pr2 c) x)) ∘ (f' (pr1 c x)))
        ( g' (pr1 (pr2 c) x))
        ( c' x))))
triangle-canonical-pullback-tot-cone-cone-family PX f' g' c c' (pair x y) =
  refl

is-pullback-family-is-pullback-tot :
  {l1 l2 l3 l4 l5 l6 l7 l8 : Level}
  {X : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (PX : X → UU l5) {PA : A → UU l6} {PB : B → UU l7} {PC : C → UU l8}
  {f : A → X} {g : B → X} →
  (f' : (a : A) → PA a → PX (f a)) (g' : (b : B) → PB b → PX (g b)) →
  (c : cone f g C) (c' : cone-family PX f' g' c PC) →
  is-pullback f g c →
  is-pullback
    (toto PX f f') (toto PX g g') (tot-cone-cone-family PX f' g' c c') →
  (x : C) →
  is-pullback
    ( (tr PX (pr2 (pr2 c) x)) ∘ (f' (pr1 c x)))
    ( g' (pr1 (pr2 c) x))
    ( c' x)
is-pullback-family-is-pullback-tot
  PX {PA} {PB} {PC} {f} {g} f' g' c c' is-pb-c is-pb-tot =
  is-fiberwise-equiv-is-equiv-toto-is-equiv-base-map _
    ( gap f g c)
    ( λ x → gap
      ( (tr PX (pr2 (pr2 c) x)) ∘ (f' (pr1 c x)))
      ( g' (pr1 (pr2 c) x))
      ( c' x))
    ( is-pb-c)
    ( is-equiv-right-factor
      ( gap (toto PX f f') (toto PX g g') (tot-cone-cone-family PX f' g' c c'))
      ( map-canonical-pullback-tot-cone-cone-family PX f' g' c c')
      ( toto _
        ( gap f g c)
        ( λ x → gap
          ( (tr PX (pr2 (pr2 c) x)) ∘ (f' (pr1 c x)))
          ( g' (pr1 (pr2 c) x))
          ( c' x)))
      ( triangle-canonical-pullback-tot-cone-cone-family PX f' g' c c')
      ( is-equiv-map-canonical-pullback-tot-cone-cone-family PX f' g' c c')
      ( is-pb-tot))

is-pullback-tot-is-pullback-family :
  {l1 l2 l3 l4 l5 l6 l7 l8 : Level}
  {X : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (PX : X → UU l5) {PA : A → UU l6} {PB : B → UU l7} {PC : C → UU l8}
  {f : A → X} {g : B → X} →
  (f' : (a : A) → PA a → PX (f a)) (g' : (b : B) → PB b → PX (g b)) →
  (c : cone f g C) (c' : cone-family PX f' g' c PC) →
  is-pullback f g c →
  ( (x : C) →
    is-pullback
      ( (tr PX (pr2 (pr2 c) x)) ∘ (f' (pr1 c x)))
      ( g' (pr1 (pr2 c) x))
      ( c' x)) →
  is-pullback
    (toto PX f f') (toto PX g g') (tot-cone-cone-family PX f' g' c c')
is-pullback-tot-is-pullback-family
  PX {PA} {PB} {PC} {f} {g} f' g' c c' is-pb-c is-pb-c' =
  is-equiv-comp
    ( gap (toto PX f f') (toto PX g g') (tot-cone-cone-family PX f' g' c c'))
    ( map-canonical-pullback-tot-cone-cone-family PX f' g' c c')
    ( toto _
      ( gap f g c)
      ( λ x → gap
        ( (tr PX (pr2 (pr2 c) x)) ∘ (f' (pr1 c x)))
        ( g' (pr1 (pr2 c) x))
        ( c' x)))
    ( triangle-canonical-pullback-tot-cone-cone-family PX f' g' c c')
    ( is-equiv-toto-is-fiberwise-equiv-is-equiv-base-map _
      ( gap f g c)
      ( λ x → gap
        ( (tr PX (pr2 (pr2 c) x)) ∘ (f' (pr1 c x)))
        ( g' (pr1 (pr2 c) x))
        ( c' x))
        ( is-pb-c)
        ( is-pb-c'))
    ( is-equiv-map-canonical-pullback-tot-cone-cone-family PX f' g' c c')

{- We show that identity types commute with pullbacks. -}

cone-ap :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} {C : UU l4}
  (f : A → X) (g : B → X) (c : cone f g C) (c1 c2 : C) →
  let p = pr1 c
      q = pr1 (pr2 c)
      H = pr2 (pr2 c)
  in
  cone
    ( λ (α : Id (p c1) (p c2)) → (ap f α) ∙ (H c2))
    ( λ (β : Id (q c1) (q c2)) → (H c1) ∙ (ap g β))
    ( Id c1 c2)
cone-ap f g (pair p (pair q H)) c1 c2 =
  pair
    ( ap p)
    ( pair
      ( ap q)
      ( λ γ →
        ( ap (λ t → t ∙ (H c2)) (inv (ap-comp f p γ))) ∙
        ( ( inv (htpy-nat H γ)) ∙
          ( ap (λ t → (H c1) ∙ t) (ap-comp g q γ)))))

tr-id-right :
  {l1 : Level} {A : UU l1} {a b c : A} (q : Id b c) (p : Id a b) →
  Id (tr (λ y → Id a y) q p) (p ∙ q)
tr-id-right refl refl = refl

cone-ap' :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} {C : UU l4}
  (f : A → X) (g : B → X) (c : cone f g C) (c1 c2 : C) →
  let p = pr1 c
      q = pr1 (pr2 c)
      H = pr2 (pr2 c)
  in
  cone
    ( λ (α : Id (p c1) (p c2)) → tr (λ t → Id (f (p c1)) t) (H c2) (ap f α))
    ( λ (β : Id (q c1) (q c2)) → (H c1) ∙ (ap g β))
    ( Id c1 c2)
cone-ap' f g (pair p (pair q H)) c1 c2 =
  pair
    ( ap p)
    ( pair
      ( ap q)
      ( λ γ →
        ( tr-id-right (H c2) (ap f (ap p γ))) ∙
        ( ( ap (λ t → t ∙ (H c2)) (inv (ap-comp f p γ))) ∙
          ( ( inv (htpy-nat H γ)) ∙
            ( ap (λ t → (H c1) ∙ t) (ap-comp g q γ))))))

is-pullback-cone-ap :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} {C : UU l4}
  (f : A → X) (g : B → X) (c : cone f g C) → is-pullback f g c →
  (c1 c2 : C) →
  let p = pr1 c
      q = pr1 (pr2 c)
      H = pr2 (pr2 c)
  in
  is-pullback
    ( λ (α : Id (p c1) (p c2)) → (ap f α) ∙ (H c2))
    ( λ (β : Id (q c1) (q c2)) → (H c1) ∙ (ap g β))
    ( cone-ap f g c c1 c2)
is-pullback-cone-ap f g (pair p (pair q H)) is-pb-c c1 c2 =
  is-pullback-htpy'
    ( λ α → tr (λ x → Id (f (p c1)) x) (H c2) (ap f α))
    ( λ α → tr-id-right (H c2) (ap f α))
    ( λ β → (H c1) ∙ (ap g β))
    ( htpy-refl)
    ( cone-ap' f g (pair p (pair q H)) c1 c2)
    { c' = cone-ap f g (pair p (pair q H)) c1 c2}
    ( pair htpy-refl (pair htpy-refl htpy-right-unit))
    ( is-pullback-family-is-pullback-tot
      ( λ x → Id (f (p c1)) x)
      ( λ a → ap f {x = p c1} {y = a})
      ( λ b β → (H c1) ∙ (ap g β))
      ( pair p (pair q H))
      ( cone-ap' f g (pair p (pair q H)) c1)
      ( is-pb-c)
      ( is-pullback-is-equiv
        ( toto _ f (λ a α → ap f α))
        ( toto _ g (λ b β → (H c1) ∙ (ap g β)))
        ( tot-cone-cone-family
          ( Id (f (p c1)))
          ( λ a → ap f)
          ( λ b β → (H c1) ∙ (ap g β))
          ( pair p (pair q H))
          ( cone-ap' f g (pair p (pair q H)) c1))
        ( is-equiv-is-contr _
          ( is-contr-total-path (q c1))
          ( is-contr-total-path (f (p c1))))
        ( is-equiv-is-contr _
          ( is-contr-total-path c1)
          ( is-contr-total-path (p c1))))
      ( c2))

{- Next we show that for any commuting cube, if the bottom and top squares are
   pullback squares, then so is the square of fibers of the vertical maps in
   cube. -}

{-

square-fib-cube :
  {l1 l2 l3 l4 l1' l2' l3' l4' : Level}
  {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4}
  (f : A → B) (g : A → C) (h : B → D) (k : C → D)
  {A' : UU l1'} {B' : UU l2'} {C' : UU l3'} {D' : UU l4'}
  (f' : A' → B') (g' : A' → C') (h' : B' → D') (k' : C' → D')
  (hA : A' → A) (hB : B' → B) (hC : C' → C) (hD : D' → D)
  (top : (h' ∘ f') ~ (k' ∘ g'))
  (back-left : (f ∘ hA) ~ (hB ∘ f'))
  (back-right : (g ∘ hA) ~ (hC ∘ g'))
  (front-left : (h ∘ hB) ~ (hD ∘ h'))
  (front-right : (k ∘ hC) ~ (hD ∘ k'))
  (bottom : (h ∘ f) ~ (k ∘ g)) →
  (c : coherence-cube f g h k f' g' h' k' hA hB hC hD
       top back-left back-right front-left front-right bottom) →
  (a : A) →
  ( ( tot (λ d' p → p ∙ (bottom a)) ∘
      ( fib-square h hD (pair hB (pair h' front-left)) (f a))) ∘
    ( fib-square f hB (pair hA (pair f' back-left)) a)) ~
  ( ( fib-square k hD (pair hC (pair k' front-right)) (g a)) ∘
    ( fib-square g hC (pair hA (pair g' back-right)) a))
square-fib-cube f g h k f' g' h' k' hA hB hC hD
  top back-left back-right front-left front-right bottom c
  .(hA a') (pair a' refl) =
  eq-pair
    ( pair
      ( top a')
      ( ( tr-id-left-subst
          ( top a')
          ( k (g (hA a')))
          ( ( ( inv (front-left (f' a'))) ∙
              ( ap h ((inv (back-left a')) ∙ refl))) ∙
            ( bottom (hA a')))) ∙
        ( ( ( assoc (inv (ap hD (top a'))) _ (bottom (hA a'))) ∙
            {!!}) ∙
          ( distributive-inv-concat (ap k (back-right a')) (front-right (g' a')) ∙
            ( ( ap
                ( concat (inv (front-right (g' a'))) ?)
                ( inv (ap-inv k (back-right a')))) ∙
              ( ap
                ( concat (inv (front-right (g' a'))) ?)
                ( ap (ap k) (inv right-unit))))))))
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Vectors where all elements satisfy a given property
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module Data.Vec.Relation.Unary.All where

open import Data.Nat using (zero; suc)
open import Data.Fin using (Fin; zero; suc)
open import Data.Product as Prod using (_,_)
open import Data.Vec as Vec using (Vec; []; _∷_)
open import Function using (_∘_)
open import Level using (_⊔_)
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec
open import Relation.Unary
open import Relation.Binary.PropositionalEquality as P using (subst)

------------------------------------------------------------------------
-- All P xs means that all elements in xs satisfy P.

infixr 5 _∷_

data All {a p} {A : Set a}
         (P : A → Set p) : ∀ {k} → Vec A k → Set (p ⊔ a) where
  []  : All P []
  _∷_ : ∀ {k x} {xs : Vec A k} (px : P x) (pxs : All P xs) → All P (x ∷ xs)

------------------------------------------------------------------------
-- Operations on All

head : ∀ {a p} {A : Set a} {P : A → Set p} {k x} {xs : Vec A k} →
       All P (x ∷ xs) → P x
head (px ∷ pxs) = px

tail : ∀ {a p} {A : Set a} {P : A → Set p} {k x} {xs : Vec A k} →
       All P (x ∷ xs) → All P xs
tail (px ∷ pxs) = pxs

lookup : ∀ {a p} {A : Set a} {P : A → Set p} {k} {xs : Vec A k} →
         (i : Fin k) → All P xs → P (Vec.lookup xs i)
lookup ()      []
lookup zero    (px ∷ pxs) = px
lookup (suc i) (px ∷ pxs) = lookup i pxs

tabulate : ∀ {a p} {A : Set a} {P : A → Set p} {k xs} →
           (∀ i → P (Vec.lookup xs i)) → All P {k} xs
tabulate {xs = []}    pxs = []
tabulate {xs = _ ∷ _} pxs = pxs zero ∷ tabulate (pxs ∘ suc)

map : ∀ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} {k} →
      P ⊆ Q → All P {k} ⊆ All Q {k}
map g []         = []
map g (px ∷ pxs) = g px ∷ map g pxs

zipWith : ∀ {a b c p q r} {A : Set a} {B : Set b} {C : Set c} {_⊕_ : A → B → C}
          {P : A → Set p} {Q : B → Set q} {R : C → Set r} →
          (∀ {x y} → P x → Q y → R (x ⊕ y)) →
          ∀ {k xs ys} → All P {k} xs → All Q {k} ys →
          All R {k} (Vec.zipWith _⊕_ xs ys)
zipWith _⊕_ {xs = []}     {[]}     []         []         = []
zipWith _⊕_ {xs = x ∷ xs} {y ∷ ys} (px ∷ pxs) (qy ∷ qys) =
  px ⊕ qy ∷ zipWith _⊕_ pxs qys

zip : ∀ {a p q k} {A : Set a} {P : A → Set p} {Q : A → Set q} →
      All P ∩ All Q ⊆ All (P ∩ Q) {k}
zip ([] , [])             = []
zip (px ∷ pxs , qx ∷ qxs) = (px , qx) ∷ zip (pxs , qxs)

unzip : ∀ {a p q k} {A : Set a} {P : A → Set p} {Q : A → Set q} →
        All (P ∩ Q) {k} ⊆ All P ∩ All Q
unzip []           = [] , []
unzip (pqx ∷ pqxs) = Prod.zip _∷_ _∷_ pqx (unzip pqxs)

------------------------------------------------------------------------
-- Properties of predicates preserved by All

module _ {a p} {A : Set a} {P : A → Set p} where

  all : ∀ {k} → Decidable P → Decidable (All P {k})
  all P? []       = yes []
  all P? (x ∷ xs) with P? x
  ... | yes px = Dec.map′ (px ∷_) tail (all P? xs)
  ... | no ¬px = no (¬px ∘ head)

  universal : Universal P → ∀ {k} → Universal (All P {k})
  universal u []       = []
  universal u (x ∷ xs) = u x ∷ universal u xs

  irrelevant : Irrelevant P → ∀ {k} → Irrelevant (All P {k})
  irrelevant irr []           []           = P.refl
  irrelevant irr (px₁ ∷ pxs₁) (px₂ ∷ pxs₂) =
    P.cong₂ _∷_ (irr px₁ px₂) (irrelevant irr pxs₁ pxs₂)

  satisfiable : Satisfiable P → ∀ {k} → Satisfiable (All P {k})
  satisfiable (x , p) {zero}  = [] , []
  satisfiable (x , p) {suc k} = Prod.map (x ∷_) (p ∷_) (satisfiable (x , p))


-- 2010-10-15

module Issue331 where

record ⊤ : Set where
  constructor tt

data Wrap (I : Set) : Set where
  wrap : I → Wrap I

data B (I : Set) : Wrap I → Set₁ where
  b₁ : ∀ i → B I (wrap i)
  b₂ : {w : Wrap I} → B I w → B I w
  b₃ : (X : Set){w : Wrap I}(f : X → B I w) → B I w

ok : B ⊤ (wrap tt)
ok = b₂ (b₁ _)

-- Issue 331 was: Unsolved meta: _45 : ⊤
bad : Set → B ⊤ (wrap tt)
bad X = b₃ X λ x → b₁ _


{-# OPTIONS --without-K #-}

open import HoTT
open import homotopy.elims.SuspSmash
open import homotopy.elims.CofPushoutSection

-- Σ(X∧Y) ≃ X * Y

module homotopy.SuspSmash {i j} (X : Ptd i) (Y : Ptd j) where

private

  {- path lemmas -}
  private
    reduce-x : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : z == y)
      → p ∙ ! q ∙ q ∙ ! p ∙ p == p
    reduce-x idp idp = idp

    reduce-y : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : x == z)
      → p ∙ ! p ∙ q ∙ ! q ∙ p == p
    reduce-y idp idp = idp

  module Into = SuspensionRec {A = Smash X Y}
    {C = fst (X ⊙* Y)}
    (left (snd X))
    (right (snd Y))
    (CofPushoutSection.rec (λ _ → tt) (λ _ → idp)
      (glue (snd X , snd Y))
      (λ {(x , y) →
        glue (snd X , snd Y) ∙ ! (glue (x , snd Y))
        ∙ glue (x , y)
        ∙ ! (glue (snd X , y)) ∙ glue (snd X , snd Y)})
      (λ x → ! (reduce-x (glue (snd X , snd Y)) (glue (x , snd Y))))
      (λ y → ! (reduce-y (glue (snd X , snd Y)) (glue (snd X , y)))))

  into = Into.f

  module Out = PushoutRec {d = ⊙span-out (*-⊙span X Y)}
    {D = Suspension (Smash X Y)}
    (λ _ → north)
    (λ _ → south)
    (λ {(x , y) → merid (cfcod (x , y))})

  out = Out.f

  into-out : (j : fst (X ⊙* Y)) → into (out j) == j
  into-out = Pushout-elim
    (λ x → glue (snd X , snd Y) ∙ ! (glue (x , snd Y)))
    (λ y → ! (glue (snd X , snd Y)) ∙ glue (snd X , y))
    (↓-∘=idf-from-square into out ∘ λ {(x , y) →
      (ap (ap into) (Out.glue-β (x , y))
       ∙ Into.merid-β (cfcod (x ,  y)))
      ∙v⊡ lemma (glue (snd X , snd Y)) (glue (x , snd Y))
                (glue (snd X , y)) (glue (x , y))})
    where
    lemma : ∀ {i} {A : Type i} {x y z w : A}
      (p : x == y) (q : z == y) (r : x == w) (s : z == w)
      → Square (p ∙ ! q) (p ∙ ! q ∙ s ∙ ! r ∙ p) s (! p ∙ r)
    lemma idp idp idp s =
      vert-degen-square (∙-unit-r s)

  out-into : (σ : Suspension (Smash X Y)) → out (into σ) == σ
  out-into = susp-smash-elim
    idp
    idp
    (↓-∘=idf-in out into ∘ λ {(x , y) →
      ap (ap out) (Into.merid-β (cfcod (x , y)))
      ∙ lemma₁ out (Out.glue-β (snd X , snd Y))
                   (Out.glue-β (x , snd Y))
                   (Out.glue-β (x , y))
                   (Out.glue-β (snd X , y))
                   (Out.glue-β (snd X , snd Y))
      ∙ lemma₂ {p = merid (cfcod (snd X , snd Y))}
               {q = merid (cfcod (x , snd Y))}
               {r = merid (cfcod (x , y))}
               {s = merid (cfcod (snd X , y))}
               {t = merid (cfcod (snd X , snd Y))}
          (ap merid (! (cfglue (winl (snd X))) ∙ cfglue (winl x)))
          (ap merid (! (cfglue (winr y)) ∙ cfglue (winr (snd Y))))})
    where
    lemma₁ : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
      {x y z u v w : A}
      {p : x == y} {q : z == y} {r : z == u} {s : v == u} {t : v == w}
      {p' : f x == f y} {q' : f z == f y} {r' : f z == f u}
      {s' : f v == f u} {t' : f v == f w}
      (α : ap f p == p') (β : ap f q == q') (γ : ap f r == r')
      (δ : ap f s == s') (ε : ap f t == t')
      → ap f (p ∙ ! q ∙ r ∙ ! s ∙ t) == p' ∙ ! q' ∙ r' ∙ ! s' ∙ t'
    lemma₁ f {p = idp} {q = idp} {r = idp} {s = idp} {t = idp}
          idp idp idp idp idp
      = idp

    lemma₂ : ∀ {i} {A : Type i} {x y z u : A}
      {p q : x == y} {r : x == z} {s t : u == z}
      (α : p == q) (β : s == t)
      → p ∙ ! q  ∙ r ∙ ! s ∙ t == r
    lemma₂ {p = idp} {r = idp} {s = idp} idp idp = idp

module SuspSmash where

  eq : Suspension (Smash X Y) ≃ fst (X ⊙* Y)
  eq = equiv into out into-out out-into

  path : Suspension (Smash X Y) == fst (X ⊙* Y)
  path = ua eq

  ⊙path : ⊙Susp (⊙Smash X Y) == (X ⊙* Y)
  ⊙path = ⊙ua (⊙≃-in eq idp)


{-# OPTIONS --sized-types #-}
open import Relation.Binary.Core

module BBHeap.Height.Convert {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)  where

open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import BBHeap _≤_
open import BBHeap.Properties _≤_
open import BBHeap.Height _≤_
open import BHeap _≤_ hiding (forget) renaming (height to heightₙ)
open import Data.List
open import Data.Nat renaming (_≤_ to _≤ₙ_)
open import Data.Nat.Properties
open import Data.Sum
open import Function using (_∘_)
open import OList _≤_
open import Relation.Binary
open import Relation.Binary.PropositionalEquality hiding (trans)
open import SNat

open DecTotalOrder decTotalOrder hiding (refl)

data _⊳_ : {b b' : Bound} → BHeap b → BHeap b' → Set where
  ⊳leaf : {b b' : Bound}
                   → lf {b} ⊳ lf {b'}
  ⊳left : {b b' : Bound}{x : A}{l r : BHeap (val x)}{l' : BHeap b'}
                   (b≤x : LeB b (val x))
                   → l ⊳ r → l ⊳ l'
                   → (nd b≤x l r) ⊳ l'
  ⊳both : {b b' : Bound}{x x' : A}{l r : BHeap (val x)}{l' r' : BHeap (val x')}
                   (b≤x : LeB b (val x))
                   (b'≤x' : LeB b' (val x'))
                   → l ⊳ r
                   → l ⊳ l'
                   → l ⊳ r'
                   → (nd b≤x l r) ⊳ (nd b'≤x' l' r')

lemma-≃-⊳ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ≃ r → relax l ⊳ relax r
lemma-≃-⊳ ≃lf = ⊳leaf
lemma-≃-⊳ (≃nd b≤x b'≤x' _ _ l≃r l'≃r' l≃l') = ⊳both b≤x b'≤x' (lemma-≃-⊳ l≃r) (lemma-≃-⊳ l≃l') (lemma-≃-⊳ (trans≃ l≃l' l'≃r'))

lemma-⋗-⊳ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋗ r → relax l ⊳ relax r
lemma-⋗-⊳ (⋗lf b≤x) = ⊳left b≤x ⊳leaf ⊳leaf
lemma-⋗-⊳ (⋗nd b≤x b'≤x' _ _ l≃r l'≃r' l⋗l') = ⊳both b≤x b'≤x' (lemma-≃-⊳ l≃r) (lemma-⋗-⊳ l⋗l') (lemma-⋗-⊳ (lemma⋗≃ l⋗l' l'≃r'))

lemma-⋙-⊳ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋙ r → relax l ⊳ relax r
lemma-⋙-⊳ (⋙lf b≤x) = ⊳left b≤x ⊳leaf ⊳leaf
lemma-⋙-⊳ (⋙rl b≤x b'≤x' _ l≃r l'⋘r' l⋗r') = ⊳both b≤x b'≤x' (lemma-≃-⊳ l≃r) (lemma-⋙-⊳ (lemma-⋘-⋗ l'⋘r' l⋗r')) (lemma-⋗-⊳ l⋗r')
lemma-⋙-⊳ (⋙rr b≤x b'≤x' _ l≃r l'⋙r' l≃l') =  ⊳both b≤x b'≤x' (lemma-≃-⊳ l≃r) (lemma-≃-⊳ l≃l') (lemma-⋙-⊳ (lemma-≃-⋙ l≃l' l'⋙r'))

lemma-⋘-⊳ : {b b' : Bound}{l : BBHeap b}{r : BBHeap b'} → l ⋘ r → relax l ⊳ relax r
lemma-⋘-⊳ lf⋘ = ⊳leaf
lemma-⋘-⊳ (ll⋘ b≤x b'≤x' l⋘r _ l'≃r' r≃l') = ⊳both b≤x b'≤x' (lemma-⋘-⊳ l⋘r) (lemma-⋘-⊳ (lemma-⋘-≃ l⋘r r≃l')) (lemma-⋘-⊳ (lemma-⋘-≃ l⋘r (trans≃ r≃l' l'≃r')))
lemma-⋘-⊳ (lr⋘ b≤x b'≤x' l⋙r _ l'≃r' l⋗l') = ⊳both b≤x b'≤x' (lemma-⋙-⊳ l⋙r) (lemma-⋗-⊳ l⋗l') (lemma-⋗-⊳ (lemma⋗≃ l⋗l' l'≃r'))

lemma-⊳-heightₙ : {b b' : Bound}{l : BHeap b}{r : BHeap b'} → l ⊳ r → heightₙ r ≤ₙ heightₙ l
lemma-⊳-heightₙ ⊳leaf = z≤n
lemma-⊳-heightₙ (⊳left {l = l} {r = r} b≤x l⊳r l⊳l')
    with total (heightₙ l) (heightₙ r)
... | inj₁ hl≤hr rewrite antisym (lemma-⊳-heightₙ l⊳r) hl≤hr = ≤-step (lemma-⊳-heightₙ l⊳l')
... | inj₂ hr≤hl = trans (lemma-⊳-heightₙ l⊳l') (≤-step (reflexive refl))
lemma-⊳-heightₙ (⊳both {l = l} {r = r} {l' = l'} {r' = r'} b≤x b'≤x' l⊳r l⊳l' l⊳r')
    with total (heightₙ l) (heightₙ r) | total (heightₙ l') (heightₙ r')
... | inj₁ hl≤hr | inj₁ hl'≤hr' rewrite antisym (lemma-⊳-heightₙ l⊳r) hl≤hr = s≤s (lemma-⊳-heightₙ l⊳r')
... | inj₁ hl≤hr | inj₂ hr'≤hl' rewrite antisym (lemma-⊳-heightₙ l⊳r) hl≤hr = s≤s (lemma-⊳-heightₙ l⊳l')
... | inj₂ hr≤hl | inj₁ hl'≤hr' = s≤s (lemma-⊳-heightₙ l⊳r')
... | inj₂ hr≤hl | inj₂ hr'≤hl' = s≤s (lemma-⊳-heightₙ l⊳l')

theorem-height-relax : {b : Bound}(h : BBHeap b) → toNat (height h) ≡ heightₙ (relax h)
theorem-height-relax leaf = refl
theorem-height-relax (left {l = l} {r = r} _ l⋘r)
    with total (heightₙ (relax l)) (heightₙ (relax r))
... | inj₁ hl≤hr rewrite antisym (lemma-⊳-heightₙ (lemma-⋘-⊳ l⋘r)) hl≤hr | theorem-height-relax l = refl
... | inj₂ hr≤hl rewrite theorem-height-relax l = refl
theorem-height-relax (right {l = l} {r = r} _ l⋙r)
    with total (heightₙ (relax l)) (heightₙ (relax r))
... | inj₁ hl≤hr rewrite antisym (lemma-⊳-heightₙ (lemma-⋙-⊳ l⋙r)) hl≤hr | theorem-height-relax l = refl
... | inj₂ hr≤hl rewrite theorem-height-relax l = refl


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Data.Vec.OperationsNat where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Nat renaming (_+_ to _+n_; _·_ to _·n_)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Vec.Base
open import Cubical.Data.Vec.Properties
open import Cubical.Data.Sigma
open import Cubical.Data.Sum

open import Cubical.Relation.Nullary

private variable
  ℓ : Level

-----------------------------------------------------------------------------
-- Generating Vector

genδℕ-Vec : {A : Type ℓ} → (m k : ℕ) → (a b : A) → Vec A m
genδℕ-Vec zero k a b = []
genδℕ-Vec (suc m) k a b  with (discreteℕ k m)
... | yes p = a ∷ replicate b
... | no ¬p = b ∷ (genδℕ-Vec m k a b)

-- some results are easier / false without general a and b
δℕ-Vec : (m : ℕ) → (k : ℕ) → Vec ℕ m
δℕ-Vec m k = genδℕ-Vec m k 1 0

δℕ-Vec-n≤k→≡ : (m k : ℕ) → (m ≤ k) → δℕ-Vec m k ≡ replicate 0
δℕ-Vec-n≤k→≡ zero k r = refl
δℕ-Vec-n≤k→≡ (suc m) k r with (discreteℕ k m)
... | yes p = ⊥.rec (<→≢ r (sym p))
... | no ¬p = cong (λ X → 0 ∷ X) (δℕ-Vec-n≤k→≡ m k (≤-trans ≤-sucℕ r))

δℕ-Vec-k<n→≢ : (m k : ℕ) → (k < m) → (δℕ-Vec m k ≡ replicate 0 → ⊥)
δℕ-Vec-k<n→≢ zero k r = ⊥.rec (¬-<-zero r)
δℕ-Vec-k<n→≢ (suc m) k r q with (discreteℕ k m) | (≤-split r)
... | yes p | z = compute-eqℕ 1 0 (fst (VecPath.encode _ _ q))
... | no ¬p | inl x = δℕ-Vec-k<n→≢ m k (pred-≤-pred x) (snd (VecPath.encode _ _ q))
... | no ¬p | inr x = ¬p (injSuc x)

-----------------------------------------------------------------------------
-- Point wise add
_+n-vec_ : {m : ℕ} → Vec ℕ m → Vec ℕ m → Vec ℕ m
_+n-vec_ {.zero} [] [] = []
_+n-vec_ {.(suc _)} (k ∷ v) (l ∷ v') = (k +n l) ∷ (v +n-vec v')

+n-vec-lid : {m : ℕ} → (v : Vec ℕ m) → replicate 0 +n-vec v ≡ v
+n-vec-lid {.zero} [] = refl
+n-vec-lid {.(suc _)} (k ∷ v) = cong (_∷_ k) (+n-vec-lid v)

+n-vec-rid : {m : ℕ} → (v : Vec ℕ m) → v +n-vec replicate 0 ≡ v
+n-vec-rid {.zero} [] = refl
+n-vec-rid {.(suc _)} (k ∷ v) = cong₂ _∷_ (+-zero k) (+n-vec-rid v)

+n-vec-assoc : {m : ℕ} → (v v' v'' : Vec ℕ m) → v +n-vec (v' +n-vec v'') ≡ (v +n-vec v') +n-vec v''
+n-vec-assoc [] [] [] = refl
+n-vec-assoc (k ∷ v) (l ∷ v') (p ∷ v'') = cong₂ _∷_ (+-assoc k l p) (+n-vec-assoc v v' v'')

+n-vec-comm : {m : ℕ} → (v v' : Vec ℕ m) → v +n-vec v' ≡ v' +n-vec v
+n-vec-comm {.zero} [] [] = refl
+n-vec-comm {.(suc _)} (k ∷ v) (l ∷ v') = cong₂ _∷_ (+-comm k l) (+n-vec-comm v v')

-----------------------------------------------------------------------------
-- Equlity on Vec ℕ
+n-vecSplitReplicate0 : {m : ℕ} → (v v' : Vec ℕ m) → (v +n-vec v') ≡ replicate 0
                        → (v ≡ replicate 0) × (v' ≡ replicate 0)
+n-vecSplitReplicate0 [] [] p = refl , refl
+n-vecSplitReplicate0 (k ∷ v) (l ∷ v') p with VecPath.encode ((k +n l) ∷ (v +n-vec v')) (replicate 0) p
... | pkl , pvv' = (cong₂ _∷_ (fst (m+n≡0→m≡0×n≡0 pkl)) (fst (+n-vecSplitReplicate0 v v' pvv'))) ,
                   (cong₂ _∷_ (snd (m+n≡0→m≡0×n≡0 pkl)) (snd (+n-vecSplitReplicate0 v v' pvv')))

pred-vec-≢0 : {m : ℕ} → (v : Vec ℕ m) → (v ≡ replicate 0 → ⊥)
              → Σ[ k ∈ ℕ ] (Σ[ v' ∈ Vec ℕ m ] ( Σ[ r ∈ (k < m) ] v ≡ v' +n-vec (δℕ-Vec m k)))
pred-vec-≢0 {zero} [] ¬q = ⊥.rec (¬q refl)
pred-vec-≢0 {(suc m)} (l ∷ v) ¬q with (discreteℕ l 0)
-- case l ≡ 0
pred-vec-≢0 {(suc m)} (l ∷ v) ¬q | yes p with pred-vec-≢0 v (λ r → ¬q (cong₂ _∷_ p r))
... | k , v' , infkm , eqvv' = k , ((0 ∷ v') , ((≤-trans infkm ≤-sucℕ) , helper))
  where
  helper : _
  helper with (discreteℕ k m)
  ... | yes pp = ⊥.rec (<→≢ (fst infkm , +-suc _ _ ∙ cong suc (snd infkm)) (cong suc pp))
  ... | no ¬pp = cong₂ _∷_ p eqvv'
-- case l ≢ 0
pred-vec-≢0 {(suc m)} (l ∷ v) ¬q | no ¬p = m , ((predℕ l ∷ v) , (≤-refl , helper))
  where
  helper : _
  helper with (discreteℕ m m)
  ... | yes pp = cong₂ _∷_ (sym (+-suc _ _ ∙ +-zero _ ∙ sym (suc-predℕ l ¬p)))
                      (sym (+n-vec-rid v))
  ... | no ¬pp = ⊥.rec (¬pp refl)

-- split + concat vec results
sep-vec : (k l : ℕ) → Vec ℕ (k +n l) → (Vec ℕ k) ×  (Vec ℕ l )
sep-vec zero l v = [] , v
sep-vec (suc k) l (x ∷ v) = (x ∷ fst (sep-vec k l v)) , (snd (sep-vec k l v))

sep-vec-fst : (k l : ℕ) → (v : Vec ℕ k) → (v' : Vec ℕ l) → fst (sep-vec k l (v ++ v')) ≡ v
sep-vec-fst zero l [] v' = refl
sep-vec-fst (suc k) l (x ∷ v) v' = cong (λ X → x ∷ X) (sep-vec-fst k l v v')

sep-vec-snd : (k l : ℕ) → (v : Vec ℕ k) → (v' : Vec ℕ l) → snd (sep-vec k l (v ++ v')) ≡ v'
sep-vec-snd zero l [] v' = refl
sep-vec-snd (suc k) l (x ∷ v) v' = sep-vec-snd k l v v'

sep-vec-id : (k l : ℕ) → (v : Vec ℕ (k +n l)) → fst (sep-vec k l v) ++ snd (sep-vec k l v) ≡ v
sep-vec-id zero l v = refl
sep-vec-id (suc k) l (x ∷ v) = cong (λ X → x ∷ X) (sep-vec-id k l v)

rep-concat : (k l : ℕ) → {B : Type ℓ} → (b : B) →
             replicate {_} {k} {B} b ++ replicate {_} {l} {B} b ≡ replicate {_} {k +n l} {B} b
rep-concat zero l b = refl
rep-concat (suc k) l b = cong (λ X → b ∷ X) (rep-concat k l b)

+n-vec-concat : (k l : ℕ) → (v w : Vec ℕ k) → (v' w' : Vec ℕ l)
                → (v +n-vec w) ++ (v' +n-vec w') ≡ (v ++ v') +n-vec (w ++ w')
+n-vec-concat zero l [] [] v' w' = refl
+n-vec-concat (suc k) l (x ∷ v) (y ∷ w) v' w' = cong (λ X → x +n y ∷ X) (+n-vec-concat k l v w v' w')


-- Andreas, 2014-05-17

open import Common.Prelude
open import Common.Equality

test : Nat
test rewrite refl = zero


module _ where

open import Agda.Builtin.Equality
open import Agda.Builtin.Nat

variable
  f : Nat → Nat

-- Drops the argument to f!
foo : (n : Nat) → f n ≡ n → f (f n) ≡ n
foo n eq rewrite eq = eq