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

open import HoTT
open import homotopy.SuspSmash

module homotopy.SuspSmashComm where

module Σ∧Σ-PathElim
  {i} {j} {k} {A : Type i} {B : Type j} {C : Type k}
  (f g : ⊙Susp A ∧ ⊙Susp B → C)
  (n-n : f (smin north north) == g (smin north north))
  (n-s : f (smin north south) == g (smin north south))
  (s-n : f (smin south north) == g (smin south north))
  (s-s : f (smin south south) == g (smin south south))
  (n-m : ∀ b → Square n-n (ap (λ sb → f (smin north sb)) (merid b))
                          (ap (λ sb → g (smin north sb)) (merid b)) n-s)
  (s-m : ∀ b → Square s-n (ap (λ sb → f (smin south sb)) (merid b))
                          (ap (λ sb → g (smin south sb)) (merid b)) s-s)
  (m-n : ∀ a → Square n-n (ap (λ sa → f (smin sa north)) (merid a))
                          (ap (λ sa → g (smin sa north)) (merid a)) s-n)
  (m-s : ∀ a → Square n-s (ap (λ sa → f (smin sa south)) (merid a))
                          (ap (λ sa → g (smin sa south)) (merid a)) s-s)
  (m-m : ∀ a b →
    Cube (m-n a)
         (m-s a)
         (n-m b)
         (natural-square (λ sb → ap (λ sa → f (smin sa sb)) (merid a)) (merid b))
         (natural-square (λ sb → ap (λ sa → g (smin sa sb)) (merid a)) (merid b))
         (s-m b))
  (basel : f smbasel == g smbasel)
  (baser : f smbaser == g smbaser)
  (gluel-north : Square n-n (ap f (smgluel north)) (ap g (smgluel north)) basel)
  (gluel-south : Square s-n (ap f (smgluel south)) (ap g (smgluel south)) basel)
  (gluel-merid : ∀ a →
    Cube gluel-north
         gluel-south
         (m-n a)
         (natural-square (λ sa → ap f (smgluel sa)) (merid a))
         (natural-square (λ sa → ap g (smgluel sa)) (merid a))
         (natural-square (λ sa → basel) (merid a)))
  (gluer-north : Square n-n (ap f (smgluer north)) (ap g (smgluer north)) baser)
  (gluer-south : Square n-s (ap f (smgluer south)) (ap g (smgluer south)) baser)
  (gluer-merid : ∀ b →
    Cube gluer-north
         gluer-south
         (n-m b)
         (natural-square (λ a → ap f (smgluer a)) (merid b))
         (natural-square (λ a → ap g (smgluer a)) (merid b))
         (natural-square (λ a → baser) (merid b))
  )
  where

  private
    module M =
      SuspDoublePathElim
        (λ sa sb → f (smin sa sb))
        (λ sa sb → g (smin sa sb))
        n-n n-s s-n s-s n-m s-m m-n m-s m-m
    module P =
      SmashElim
        {P = λ sa∧sb → f sa∧sb == g sa∧sb}
        M.p
        basel
        baser
        (λ sa → ↓-='-from-square $
          Susp-elim
            {P = λ sa → Square (M.p sa north) (ap f (smgluel sa)) (ap g (smgluel sa)) basel}
            gluel-north
            gluel-south
            (λ a → cube-to-↓-square $
                   cube-shift-back (! (M.merid-north-square-β a)) $
                   gluel-merid a)
            sa)
        (λ sb → ↓-='-from-square $
          Susp-elim
            {P = λ sb → Square (M.p north sb) (ap f (smgluer sb)) (ap g (smgluer sb)) baser}
            gluer-north
            gluer-south
            (λ b → cube-to-↓-square $
                   cube-shift-back (! (M.north-merid-square-β b)) $
                   gluer-merid b)
            sb)

  open P using (f) public

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  private
    f : ⊙Susp (de⊙ X) ∧ ⊙Susp (de⊙ Y) → Susp (Susp (X ∧ Y))
    f = Susp-fmap (∧Σ-out X Y) ∘ Σ∧-out X (⊙Susp (de⊙ Y))

    g : ⊙Susp (de⊙ X) ∧ ⊙Susp (de⊙ Y) → Susp (Susp (X ∧ Y))
    g = Susp-flip ∘ Susp-fmap (Σ∧-out X Y) ∘ ∧Σ-out (⊙Susp (de⊙ X)) Y

    f-merid-x : ∀ x sy →
      ap (λ sx → f (smin sx sy)) (merid x)
      =-=
      merid (Susp-fmap (smin x) sy)
    f-merid-x x sy =
      ap (Susp-fmap (∧Σ-out X Y) ∘ Susp-fmap (λ x' → smin x' sy)) (merid x)
        =⟪ ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' sy)) (merid x) ⟫
      ap (Susp-fmap (∧Σ-out X Y)) (ap (Susp-fmap (λ x' → smin x' sy)) (merid x))
        =⟪ ap (ap (Susp-fmap (∧Σ-out X Y)))
              (SuspFmap.merid-β (λ x' → smin x' sy) x) ⟫
      ap (Susp-fmap (∧Σ-out X Y)) (merid (smin x sy))
        =⟪ SuspFmap.merid-β (∧Σ-out X Y) (smin x sy) ⟫
      merid (Susp-fmap (smin x) sy) ∎∎

    g-merid-y : ∀ sx y →
      ap (g ∘ smin sx) (merid y)
      =-=
      ! (merid (Susp-fmap (λ x' → smin x' y) sx))
    g-merid-y sx y =
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y) ∘ Susp-fmap (smin sx)) (merid y)
        =⟪ ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin sx)) (merid y) ⟫
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (ap (Susp-fmap (smin sx)) (merid y))
        =⟪ ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
              (SuspFmap.merid-β (smin sx) y) ⟫
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin sx y))
        =⟪ ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) (merid (smin sx y)) ⟫
      ap Susp-flip (ap (Susp-fmap (Σ∧-out X Y)) (merid (smin sx y)))
        =⟪ ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) (smin sx y)) ⟫
      ap Susp-flip (merid (Susp-fmap (λ x' → smin x' y) sx))
        =⟪ SuspFlip.merid-β (Susp-fmap (λ x' → smin x' y) sx) ⟫
      ! (merid (Susp-fmap (λ x' → smin x' y) sx)) ∎∎

    n-n : f (smin north north) == g (smin north north)
    n-n = merid north

    n-s : f (smin north south) == g (smin north south)
    n-s = idp

    s-n : f (smin south north) == g (smin south north)
    s-n = idp

    s-s : f (smin south south) == g (smin south south)
    s-s = ! (merid south)

    n-m : ∀ y → Square n-n (ap (f ∘ smin north) (merid y))
                           (ap (g ∘ smin north) (merid y)) n-s
    n-m y = ap-cst north (merid y) ∙v⊡ (lb-square (merid north) ⊡v∙ ! (↯ (g-merid-y north y)))

    s-m : ∀ y → Square s-n (ap (f ∘ smin south) (merid y))
                           (ap (g ∘ smin south) (merid y)) s-s
    s-m y = ap-cst south (merid y) ∙v⊡ br-square (! (merid south)) ⊡v∙ ! (↯ (g-merid-y south y))

    m-n : ∀ x → Square n-n (ap (λ sx → f (smin sx north)) (merid x))
                           (ap (λ sx → g (smin sx north)) (merid x)) s-n
    m-n x = ↯ (f-merid-x x north) ∙v⊡ (lt-square (merid north) ⊡v∙ ! (ap-cst south (merid x)))

    m-s : ∀ x → Square n-s (ap (λ sx → f (smin sx south)) (merid x))
                           (ap (λ sx → g (smin sx south)) (merid x)) s-s
    m-s x = ↯ (f-merid-x x south) ∙v⊡ (tr-square (merid south) ⊡v∙ ! (ap-cst north (merid x)))

    m-m : ∀ x y →
      Cube (m-n x)
           (m-s x)
           (n-m y)
           (natural-square (λ sy → ap (λ sx → f (smin sx sy)) (merid x)) (merid y))
           (natural-square (λ sy → ap (λ sx → g (smin sx sy)) (merid x)) (merid y))
           (s-m y)
    m-m x y =
      custom-cube-∙v⊡
        (↯ (f-merid-x x north))
        (↯ (f-merid-x x south))
        (ap-cst north (merid y))
        (ap-cst south (merid y)) $
      cube-shift-top (! top-path) $
      custom-cube-⊡v∙
        (! (ap-cst south (merid x)))
        (ap-cst north (merid x))
        (! (↯ (g-merid-y north y)))
        (↯ (g-merid-y south y)) $
      cube-shift-bot (! bot-path) $
      custom-cube (merid north) (merid south) (ap merid (merid (smin x y)))
      where
      custom-cube-∙v⊡ : ∀ {i} {A : Type i} {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
        {p₀₋₀  : a₀₀₀ == a₀₁₀}
        {p₋₀₀ p₋₀₀' : a₀₀₀ == a₁₀₀} (q₋₀₀ : p₋₀₀ == p₋₀₀')
        {p₋₁₀ : a₀₁₀ == a₁₁₀}
        {p₁₋₀ : a₁₀₀ == a₁₁₀}
        {sq₋₋₀ : Square p₀₋₀ p₋₀₀' p₋₁₀ p₁₋₀} -- left
        {p₀₋₁ : a₀₀₁ == a₀₁₁}
        {p₋₀₁ p₋₀₁' : a₀₀₁ == a₁₀₁} (q₋₀₁ : p₋₀₁ == p₋₀₁')
        {p₋₁₁ : a₀₁₁ == a₁₁₁}
        {p₁₋₁ : a₁₀₁ == a₁₁₁}
        {sq₋₋₁ : Square p₀₋₁ p₋₀₁' p₋₁₁ p₁₋₁} -- right
        {p₀₀₋ p₀₀₋' : a₀₀₀ == a₀₀₁} (q₀₀₋ : p₀₀₋ == p₀₀₋')
        {p₀₁₋ : a₀₁₀ == a₀₁₁}
        {p₁₀₋ p₁₀₋' : a₁₀₀ == a₁₀₁} (q₁₀₋ : p₁₀₋ == p₁₀₋')
        {p₁₁₋ : a₁₁₀ == a₁₁₁}
        {sq₀₋₋ : Square p₀₋₀ p₀₀₋' p₀₁₋ p₀₋₁} -- back
        {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
        {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
        {sq₁₋₋ : Square p₁₋₀ p₁₀₋' p₁₁₋ p₁₋₁} -- front
        → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋ (! q₀₀₋ ∙v⊡ (! q₋₀₀ ∙h⊡ sq₋₀₋ ⊡h∙ q₋₀₁) ⊡v∙ q₁₀₋) sq₋₁₋ sq₁₋₋
        → Cube (q₋₀₀ ∙v⊡ sq₋₋₀) (q₋₀₁ ∙v⊡ sq₋₋₁) (q₀₀₋ ∙v⊡ sq₀₋₋) sq₋₀₋ sq₋₁₋ (q₁₀₋ ∙v⊡ sq₁₋₋)
      custom-cube-∙v⊡ idp idp idp idp c = c
      custom-cube-⊡v∙ : ∀ {i} {A : Type i} {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
        {p₀₋₀  : a₀₀₀ == a₀₁₀}
        {p₋₀₀ : a₀₀₀ == a₁₀₀}
        {p₋₁₀ p₋₁₀' : a₀₁₀ == a₁₁₀} (q₋₁₀ : p₋₁₀ == p₋₁₀')
        {p₁₋₀ : a₁₀₀ == a₁₁₀}
        {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left
        {p₀₋₁ : a₀₀₁ == a₀₁₁}
        {p₋₀₁ : a₀₀₁ == a₁₀₁}
        {p₋₁₁ p₋₁₁' : a₀₁₁ == a₁₁₁} (q₋₁₁ : p₋₁₁' == p₋₁₁)
        {p₁₋₁ : a₁₀₁ == a₁₁₁}
        {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right
        {p₀₀₋ : a₀₀₀ == a₀₀₁}
        {p₀₁₋ p₀₁₋' : a₀₁₀ == a₀₁₁} (q₀₁₋ : p₀₁₋ == p₀₁₋')
        {p₁₀₋ : a₁₀₀ == a₁₀₁}
        {p₁₁₋ p₁₁₋' : a₁₁₀ == a₁₁₁} (q₁₁₋ : p₁₁₋' == p₁₁₋)
        {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} -- back
        {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
        {sq₋₁₋ : Square p₋₁₀' p₀₁₋' p₁₁₋' p₋₁₁'} -- bottom
        {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front
        → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋ sq₋₀₋ (square-symmetry (q₋₁₀ ∙v⊡ (q₀₁₋ ∙h⊡ square-symmetry sq₋₁₋ ⊡h∙ q₁₁₋) ⊡v∙ q₋₁₁)) sq₁₋₋
        → Cube (sq₋₋₀ ⊡v∙ q₋₁₀) (sq₋₋₁ ⊡v∙ ! q₋₁₁) (sq₀₋₋ ⊡v∙ q₀₁₋) sq₋₀₋ sq₋₁₋ (sq₁₋₋ ⊡v∙ ! q₁₁₋)
      custom-cube-⊡v∙ idp idp idp idp {sq₋₁₋ = sq₋₁₋} c =
        cube-shift-bot (square-sym-inv sq₋₁₋) c
      custom-cube : ∀ {i} {S : Type i} {n s : S}
        (p q : n == s) (r : p == q)
        → Cube (lt-square p)
               (tr-square q)
               (lb-square p)
               (horiz-degen-square r)
               (vert-degen-square (ap ! r))
               (br-square (! q))
      custom-cube p@idp q@.idp r@idp = idc
      top-path :
        ! (ap-cst north (merid y)) ∙v⊡
        (! (↯ (f-merid-x x north)) ∙h⊡
         natural-square (λ sy → ap (λ sx → f (smin sx sy)) (merid x)) (merid y) ⊡h∙
         ↯ (f-merid-x x south)) ⊡v∙
        ap-cst south (merid y)
        ==
        horiz-degen-square (ap merid (merid (smin x y)))
      top-path =
        ! (ap-cst north (merid y)) ∙v⊡
        (! (↯ (f-merid-x x north)) ∙h⊡
         natural-square (λ sy → ap (λ sx → f (smin sx sy)) (merid x)) (merid y) ⊡h∙
         ↯ (f-merid-x x south)) ⊡v∙
        ap-cst south (merid y)
          =⟨ ap (λ u → ! (ap-cst north (merid y)) ∙v⊡ u ⊡v∙ ap-cst south (merid y)) $
             natural-square-path
               (λ sy → merid (Susp-fmap (smin x) sy))
               (λ sy → ap (λ sx → f (smin sx sy)) (merid x))
               (λ sy → ↯ (f-merid-x x sy))
               (merid y) ⟩
        ! (ap-cst north (merid y)) ∙v⊡
        natural-square (λ sy → merid (Susp-fmap (smin x) sy)) (merid y) ⊡v∙
        ap-cst south (merid y)
          =⟨ natural-square-cst
               north
               south
               (λ sy → merid (Susp-fmap (smin x) sy))
               (merid y) ⟩
        horiz-degen-square (ap (merid ∘ Susp-fmap (smin x)) (merid y))
          =⟨ ap horiz-degen-square (ap-∘ merid (Susp-fmap (smin x)) (merid y)) ⟩
        horiz-degen-square (ap merid (ap (Susp-fmap (smin x)) (merid y)))
          =⟨ ap (horiz-degen-square ∘ ap merid) (SuspFmap.merid-β (smin x) y) ⟩
        horiz-degen-square (ap merid (merid (smin x y))) =∎
      bot-path :
        square-symmetry
         (! (ap-cst south (merid x)) ∙v⊡
          (! (↯ (g-merid-y north y)) ∙h⊡
           square-symmetry (natural-square
             (λ sy → ap (λ sx → g (smin sx sy)) (merid x)) (merid y)) ⊡h∙
           ↯ (g-merid-y south y)) ⊡v∙
          ap-cst north (merid x))
        ==
        vert-degen-square (ap ! (ap merid (merid (smin x y))))
      bot-path =
        square-symmetry
         (! (ap-cst south (merid x)) ∙v⊡
          (! (↯ (g-merid-y north y)) ∙h⊡
           square-symmetry (natural-square
             (λ sy → ap (λ sx → g (smin sx sy)) (merid x)) (merid y)) ⊡h∙
           ↯ (g-merid-y south y)) ⊡v∙
          ap-cst north (merid x))
          =⟨ ap (λ u → square-symmetry
                        (! (ap-cst south (merid x)) ∙v⊡
                         (! (↯ (g-merid-y north y)) ∙h⊡
                          u ⊡h∙
                          ↯ (g-merid-y south y)) ⊡v∙
                         ap-cst north (merid x))) $
             natural-square-symmetry
               (λ sx sy → g (smin sx sy))
               (merid x)
               (merid y) ⟩
        square-symmetry
         (! (ap-cst south (merid x)) ∙v⊡
          (! (↯ (g-merid-y north y)) ∙h⊡
           natural-square (λ sx → ap (g ∘ smin sx) (merid y)) (merid x) ⊡h∙
           ↯ (g-merid-y south y)) ⊡v∙
          ap-cst north (merid x))
          =⟨ ap (λ u → square-symmetry
                         (! (ap-cst south (merid x)) ∙v⊡ u ⊡v∙ ap-cst north (merid x))) $
             natural-square-path
               (λ sx → ! (merid (Susp-fmap (λ x' → smin x' y) sx)))
               (λ sx → ap (g ∘ smin sx) (merid y))
               (λ sx → ↯ (g-merid-y sx y))
               (merid x) ⟩
        square-symmetry
         (! (ap-cst south (merid x)) ∙v⊡
          natural-square (λ sx → ! (merid (Susp-fmap (λ x' → smin x' y) sx))) (merid x) ⊡v∙
          ap-cst north (merid x))
          =⟨ ap square-symmetry $
             natural-square-cst
               south
               north
               (λ sx → ! (merid (Susp-fmap (λ x' → smin x' y) sx)))
               (merid x) ⟩
        square-symmetry
          (horiz-degen-square
            (ap (λ sx → ! (merid (Susp-fmap (λ x' → smin x' y) sx))) (merid x)))
          =⟨ horiz-degen-square-symmetry
               (ap (λ sx → ! (merid (Susp-fmap (λ x' → smin x' y) sx))) (merid x)) ⟩
        vert-degen-square (ap (! ∘ merid ∘ Susp-fmap (λ x' → smin x' y)) (merid x))
          =⟨ ap vert-degen-square (ap-∘ (! ∘ merid) (Susp-fmap (λ x' → smin x' y)) (merid x)) ⟩
        vert-degen-square (ap (! ∘ merid) (ap (Susp-fmap (λ x' → smin x' y)) (merid x)))
          =⟨ ap (vert-degen-square ∘ ap (! ∘ merid)) (SuspFmap.merid-β (λ x' → smin x' y) x) ⟩
        vert-degen-square (ap (! ∘ merid) (merid (smin x y)))
          =⟨ ap vert-degen-square (ap-∘ ! merid (merid (smin x y))) ⟩
        vert-degen-square (ap ! (ap merid (merid (smin x y)))) =∎

    basel : f smbasel == g smbasel
    basel = merid north

    baser : f smbaser == g smbaser
    baser = merid north

    f-smgluel : ∀ sx → ap f (smgluel sx) == ap (Susp-fmap (∧Σ-out X Y)) (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y)) sx)
    f-smgluel sx =
      ap f (smgluel sx)
        =⟨ ap-∘ (Susp-fmap (∧Σ-out X Y)) (Σ∧-out X (⊙Susp (de⊙ Y))) (smgluel sx) ⟩
      ap (Susp-fmap (∧Σ-out X Y)) (ap (Σ∧-out X (⊙Susp (de⊙ Y))) (smgluel sx))
        =⟨ ap (ap (Susp-fmap (∧Σ-out  X Y)))
              (Σ∧Out.smgluel-β X (⊙Susp (de⊙ Y)) sx) ⟩
      ap (Susp-fmap (∧Σ-out X Y)) (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y)) sx) =∎

    f-smgluel-north : ap f (smgluel north) == idp
    f-smgluel-north = f-smgluel north

    f-smgluel-south : ap f (smgluel south) =-= ! (merid north)
    f-smgluel-south =
      ap f (smgluel south)
        =⟪ f-smgluel south ⟫
      ap (Susp-fmap (∧Σ-out X Y)) (! (merid (smin (pt X) north)))
        =⟪ ap-! (Susp-fmap (∧Σ-out X Y)) (merid (smin (pt X) north)) ⟫
      ! (ap (Susp-fmap (∧Σ-out X Y)) (merid (smin (pt X) north)))
        =⟪ ap ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ⟫
      ! (merid north) ∎∎

    g-smgluel : ∀ sx → ap g (smgluel sx) == idp
    g-smgluel sx =
      ap g (smgluel sx)
        =⟨ ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (∧Σ-out (⊙Susp (de⊙ X)) Y) (smgluel sx) ⟩
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (ap (∧Σ-out (⊙Susp (de⊙ X)) Y) (smgluel sx))
        =⟨ ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
              (∧ΣOut.smgluel-β (⊙Susp (de⊙ X)) Y sx) ⟩
      idp =∎

    smgluel-north : Square n-n (ap f (smgluel north)) (ap g (smgluel north)) basel
    smgluel-north = f-smgluel-north ∙v⊡ hid-square ⊡v∙ ! (g-smgluel north)

    smgluel-south : Square s-n (ap f (smgluel south)) (ap g (smgluel south)) basel
    smgluel-south = ↯ f-smgluel-south ∙v⊡ rt-square (merid north) ⊡v∙ ! (g-smgluel south)

    custom-cube-⊡v∙ : ∀ {i} {A : Type i} {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
      {p₀₋₀  : a₀₀₀ == a₀₁₀}
      {p₋₀₀ : a₀₀₀ == a₁₀₀}
      {p₋₁₀ p₋₁₀' : a₀₁₀ == a₁₁₀} (q₋₁₀ : p₋₁₀ == p₋₁₀')
      {p₁₋₀ : a₁₀₀ == a₁₁₀}
      {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left
      {p₀₋₁ : a₀₀₁ == a₀₁₁}
      {p₋₀₁ : a₀₀₁ == a₁₀₁}
      {p₋₁₁ p₋₁₁' : a₀₁₁ == a₁₁₁} (q₋₁₁ : p₋₁₁' == p₋₁₁)
      {p₁₋₁ : a₁₀₁ == a₁₁₁}
      {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right
      {p₀₀₋ : a₀₀₀ == a₀₀₁}
      {p₀₁₋ p₀₁₋' : a₀₁₀ == a₀₁₁} (q₀₁₋ : p₀₁₋ == p₀₁₋')
      {p₁₀₋ : a₁₀₀ == a₁₀₁}
      {p₁₁₋ p₁₁₋' : a₁₁₀ == a₁₁₁} (q₁₁₋ : p₁₁₋ == p₁₁₋')
      {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} -- back
      {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
      {sq₋₁₋ : Square p₋₁₀' p₀₁₋' p₁₁₋ p₋₁₁'} -- bottom
      {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front
      → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋ sq₋₀₋ (q₀₁₋ ∙v⊡ (q₋₁₀ ∙h⊡ sq₋₁₋ ⊡h∙ q₋₁₁) ⊡v∙ q₁₁₋) (sq₁₋₋ ⊡v∙ q₁₁₋)
      → Cube (sq₋₋₀ ⊡v∙ q₋₁₀) (sq₋₋₁ ⊡v∙ ! q₋₁₁) (sq₀₋₋ ⊡v∙ q₀₁₋) sq₋₀₋ sq₋₁₋ sq₁₋₋
    custom-cube-⊡v∙ idp idp idp idp c = c

    smgluel-merid : ∀ x →
      Cube smgluel-north
           smgluel-south
           (m-n x)
           (natural-square (λ sx → ap f (smgluel sx)) (merid x))
           (natural-square (λ sx → ap g (smgluel sx)) (merid x))
           (natural-square (λ sx → basel) (merid x))
    smgluel-merid x =
      custom-cube-∙v⊡
        f-smgluel-north
        (f-smgluel south) (↯ (tail f-smgluel-south))
        (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x))
        (↯ (tail (f-merid-x x north)))
        (ap-cst north (merid x)) $
      cube-shift-top (! (top-path x)) $
      custom-cube-⊡v∙
        (! (g-smgluel north))
        (g-smgluel south)
        (! (ap-cst south (merid x)))
        (ap-cst south (merid x)) $
      cube-shift-front (! (front-path x)) $
      cube-shift-bot (! (bot-path x)) $
      custom-cube (merid north)
      where
      custom-cube-∙v⊡ : ∀ {i} {A : Type i} {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
        {p₀₋₀  : a₀₀₀ == a₀₁₀}
        {p₋₀₀ p₋₀₀' : a₀₀₀ == a₁₀₀} (q₋₀₀ : p₋₀₀ == p₋₀₀')
        {p₋₁₀ : a₀₁₀ == a₁₁₀}
        {p₁₋₀ : a₁₀₀ == a₁₁₀}
        {sq₋₋₀ : Square p₀₋₀ p₋₀₀' p₋₁₀ p₁₋₀} -- left
        {p₀₋₁ : a₀₀₁ == a₀₁₁}
        {p₋₀₁ p₋₀₁' p₋₀₁'' : a₀₀₁ == a₁₀₁} (q₋₀₁ : p₋₀₁ == p₋₀₁') (q₋₀₁' : p₋₀₁' == p₋₀₁'')
        {p₋₁₁ : a₀₁₁ == a₁₁₁}
        {p₁₋₁ : a₁₀₁ == a₁₁₁}
        {sq₋₋₁ : Square p₀₋₁ p₋₀₁'' p₋₁₁ p₁₋₁} -- right
        {p₀₀₋ p₀₀₋' p₀₀₋'' : a₀₀₀ == a₀₀₁} (q₀₀₋ : p₀₀₋ == p₀₀₋') (q₀₀₋' : p₀₀₋' == p₀₀₋'')
        {p₀₁₋ : a₀₁₀ == a₀₁₁}
        {p₁₀₋ p₁₀₋' : a₁₀₀ == a₁₀₁} (q₁₀₋ : p₁₀₋ == p₁₀₋')
        {p₁₁₋ : a₁₁₀ == a₁₁₁}
        {sq₀₋₋ : Square p₀₋₀ p₀₀₋'' p₀₁₋ p₀₋₁} -- back
        {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
        {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
        {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front
        → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋
               ((! q₀₀₋' ∙v⊡ (! q₀₀₋ ∙v⊡ (! q₋₀₀ ∙h⊡ sq₋₀₋ ⊡h∙ q₋₀₁)) ⊡v∙ q₁₀₋) ⊡h∙ q₋₀₁')
               sq₋₁₋ (! q₁₀₋ ∙v⊡ sq₁₋₋)
        → Cube (q₋₀₀ ∙v⊡ sq₋₋₀) ((q₋₀₁ ∙ q₋₀₁') ∙v⊡ sq₋₋₁) ((q₀₀₋ ∙ q₀₀₋') ∙v⊡ sq₀₋₋) sq₋₀₋ sq₋₁₋ sq₁₋₋
      custom-cube-∙v⊡ idp idp idp idp idp idp c = c
      custom-cube : ∀ {i} {S : Type i} {n s : S} (p : n == s)
        → Cube hid-square (rt-square p) (lt-square p) (tr-square p) ids hid-square
      custom-cube p@idp = idc
      top-path : ∀ x →
        (! (↯ (tail (f-merid-x x north))) ∙v⊡
         (! (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ∙v⊡
          (! f-smgluel-north ∙h⊡
           natural-square (λ sx → ap f (smgluel sx)) (merid x) ⊡h∙
           f-smgluel south)) ⊡v∙
         ap-cst north (merid x)) ⊡h∙
        ↯ (tail f-smgluel-south)
        ==
        tr-square (merid north)
      top-path x =
        (! (↯ (tail (f-merid-x x north))) ∙v⊡
         (! (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ∙v⊡
          (! f-smgluel-north ∙h⊡
           natural-square (λ sx → ap f (smgluel sx)) (merid x) ⊡h∙
           f-smgluel south)) ⊡v∙
         ap-cst north (merid x)) ⊡h∙
        ↯ (tail f-smgluel-south)
          =⟨ ap (λ u → (! (↯ (tail (f-merid-x x north))) ∙v⊡
                        (! (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ∙v⊡
                         u) ⊡v∙
                        ap-cst north (merid x)) ⊡h∙
                       ↯ (tail f-smgluel-south)) $
             natural-square-path
               (ap (Susp-fmap (∧Σ-out X Y)) ∘ Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y)))
               (λ sx → ap f (smgluel sx))
               f-smgluel
               (merid x) ⟩
        (! (↯ (tail (f-merid-x x north))) ∙v⊡
         (! (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ∙v⊡
          natural-square (ap (Susp-fmap (∧Σ-out X Y)) ∘ Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x)) ⊡v∙
         ap-cst north (merid x)) ⊡h∙
        ↯ (tail f-smgluel-south)
          =⟨ ap (λ v → (! (↯ (tail (f-merid-x x north))) ∙v⊡
                        v ⊡v∙
                        ap-cst north (merid x)) ⊡h∙
                       ↯ (tail f-smgluel-south)) $
             ! (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ∙v⊡
             natural-square (ap (Susp-fmap (∧Σ-out X Y)) ∘ Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x)
               =⟨ ap (! (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ∙v⊡_) $
                  natural-square-ap (Susp-fmap (∧Σ-out X Y)) (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x) ⟩
             ! (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ∙v⊡
             ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x) ∙v⊡
             ap-square (Susp-fmap (∧Σ-out X Y)) (natural-square (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x)) ⊡v∙
             ∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x)
               =⟨ ! $ ∙v⊡-assoc
                    (! (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)))
                    (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x))
                    (ap-square (Susp-fmap (∧Σ-out X Y)) (natural-square (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x)) ⊡v∙
                     ∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x)) ⟩
             (! (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ∙
              ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ∙v⊡
             ap-square (Susp-fmap (∧Σ-out X Y)) (natural-square (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x)) ⊡v∙
             ∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x)
               =⟨ ap (_∙v⊡ ap-square (Susp-fmap (∧Σ-out X Y)) (natural-square (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x)) ⊡v∙
                           ∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x)) $
                  !-inv-l (ap-∘ (Susp-fmap (∧Σ-out X Y)) (Susp-fmap (λ x' → smin x' north)) (merid x)) ⟩
             ap-square (Susp-fmap (∧Σ-out X Y)) (natural-square (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x)) ⊡v∙
             ∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x) =∎ ⟩
        (! (↯ (tail (f-merid-x x north))) ∙v⊡
         (ap-square (Susp-fmap (∧Σ-out X Y)) (natural-square (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x)) ⊡v∙
          ∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x)) ⊡v∙
         ap-cst north (merid x)) ⊡h∙
        ↯ (tail f-smgluel-south)
          =⟨ ap (λ u → (! (↯ (tail (f-merid-x x north))) ∙v⊡
                        u) ⊡h∙
                       ↯ (tail f-smgluel-south)) $
             (ap-square (Susp-fmap (∧Σ-out X Y)) (natural-square (Σ∧OutSmgluel.f X (⊙Susp (de⊙ Y))) (merid x)) ⊡v∙
              ∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x)) ⊡v∙
             ap-cst north (merid x)
               =⟨ ap (λ u → (ap-square (Susp-fmap (∧Σ-out X Y)) u ⊡v∙
                             ∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x)) ⊡v∙
                            ap-cst north (merid x)) $
                  Σ∧OutSmgluel.merid-square-β X (⊙Susp (de⊙ Y)) x ⟩
             (ap-square (Susp-fmap (∧Σ-out X Y)) (Σ∧-out-smgluel-merid X (⊙Susp (de⊙ Y)) x) ⊡v∙
              ∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x)) ⊡v∙
             ap-cst north (merid x)
               =⟨ ⊡v∙-assoc
                    (ap-square (Susp-fmap (∧Σ-out X Y)) (Σ∧-out-smgluel-merid X (⊙Susp (de⊙ Y)) x))
                    (∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x))
                    (ap-cst north (merid x)) ⟩
             ap-square (Susp-fmap (∧Σ-out X Y)) (Σ∧-out-smgluel-merid X (⊙Susp (de⊙ Y)) x) ⊡v∙
             (∘-ap (Susp-fmap (∧Σ-out X Y)) (λ _ → north) (merid x) ∙
              ap-cst north (merid x))
               =⟨ ap (ap-square (Susp-fmap (∧Σ-out X Y)) (Σ∧-out-smgluel-merid X (⊙Susp (de⊙ Y)) x) ⊡v∙_) $
                  =ₛ-out $ ap-∘-cst-coh (Susp-fmap (∧Σ-out X Y)) north (merid x) ⟩
             ap-square (Susp-fmap (∧Σ-out X Y)) (Σ∧-out-smgluel-merid X (⊙Susp (de⊙ Y)) x) ⊡v∙
             ap (ap (Susp-fmap (∧Σ-out X Y))) (ap-cst north (merid x))
               =⟨ ap-square-⊡v∙
                    (Susp-fmap (∧Σ-out X Y))
                    (Σ∧-out-smgluel-merid X (⊙Susp (de⊙ Y)) x)
                    (ap-cst north (merid x)) ⟩
             ap-square
               (Susp-fmap (∧Σ-out X Y))
               (Σ∧-out-smgluel-merid X (⊙Susp (de⊙ Y)) x ⊡v∙ ap-cst north (merid x))
               =⟨ ap (ap-square (Susp-fmap (∧Σ-out X Y))) $
                  ⊡v∙-assoc
                    ((SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x)) ∙v⊡
                     tr-square (merid (smin (pt X) north)))
                    (! (ap-cst north (merid x)))
                    (ap-cst north (merid x)) ⟩
             ap-square
               (Susp-fmap (∧Σ-out X Y))
               (((SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x)) ∙v⊡
                 tr-square (merid (smin (pt X) north))) ⊡v∙
                (! (ap-cst north (merid x)) ∙ ap-cst north (merid x)))
               =⟨ ap (λ u → ap-square (Susp-fmap (∧Σ-out X Y)) $
                            ((SuspFmap.merid-β (λ x' → smin x' north) x ∙
                              ap merid (∧-norm-l x)) ∙v⊡
                             tr-square (merid (smin (pt X) north))) ⊡v∙
                            u) $
                  !-inv-l (ap-cst north (merid x)) ⟩
             ap-square
               (Susp-fmap (∧Σ-out X Y))
               ((SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x)) ∙v⊡
                tr-square (merid (smin (pt X) north)))
               =⟨ ! $ ap-square-∙v⊡
                    (Susp-fmap (∧Σ-out X Y))
                    (SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x))
                    (tr-square (merid (smin (pt X) north))) ⟩
             ap (ap (Susp-fmap (∧Σ-out X Y)))
                (SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x)) ∙v⊡
             ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north))) =∎
           ⟩
        (! (↯ (tail (f-merid-x x north))) ∙v⊡
         ap (ap (Susp-fmap (∧Σ-out X Y)))
            (SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x)) ∙v⊡
         ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north)))) ⊡h∙
        ↯ (tail f-smgluel-south)
          =⟨ ! $ ap (_⊡h∙ ↯ (tail f-smgluel-south)) $
             ∙v⊡-assoc (! (↯ (tail (f-merid-x x north))))
                       (ap (ap (Susp-fmap (∧Σ-out X Y)))
                           (SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x)))
                       (ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north)))) ⟩
        ((! (↯ (tail (f-merid-x x north))) ∙
          ap (ap (Susp-fmap (∧Σ-out X Y)))
             (SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x))) ∙v⊡
         ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north)))) ⊡h∙
        ↯ (tail f-smgluel-south)
          =⟨ ap (λ u → (u ∙v⊡ ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north)))) ⊡h∙
                       ↯ (tail f-smgluel-south)) $ =ₛ-out $
             ! (↯ (tail (f-merid-x x north))) ◃∙
             ap (ap (Susp-fmap (∧Σ-out X Y)))
                (SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x)) ◃∎
               =ₛ⟨ 0 & 1 & !-∙-seq (tail (f-merid-x x north)) ⟩
             ! (SuspFmap.merid-β (∧Σ-out X Y) (smin x north)) ◃∙
             ! (ap (ap (Susp-fmap (∧Σ-out X Y))) (SuspFmap.merid-β (λ x' → smin x' north) x)) ◃∙
             ap (ap (Susp-fmap (∧Σ-out X Y)))
                (SuspFmap.merid-β (λ x' → smin x' north) x ∙ ap merid (∧-norm-l x)) ◃∎
               =ₛ⟨ 2 & 1 &
                   ap-seq-∙
                     (ap (Susp-fmap (∧Σ-out X Y)))
                     (SuspFmap.merid-β (λ x' → smin x' north) x ◃∙
                      ap merid (∧-norm-l x) ◃∎) ⟩
             ! (SuspFmap.merid-β (∧Σ-out X Y) (smin x north)) ◃∙
             ! (ap (ap (Susp-fmap (∧Σ-out X Y))) (SuspFmap.merid-β (λ x' → smin x' north) x)) ◃∙
             ap (ap (Susp-fmap (∧Σ-out X Y))) (SuspFmap.merid-β (λ x' → smin x' north) x) ◃∙
             ap (ap (Susp-fmap (∧Σ-out X Y))) (ap merid (∧-norm-l x)) ◃∎
               =ₛ⟨ 1 & 2 & seq-!-inv-l $
                   ap (ap (Susp-fmap (∧Σ-out X Y)))
                      (SuspFmap.merid-β (λ x' → smin x' north) x) ◃∎ ⟩
             ! (SuspFmap.merid-β (∧Σ-out X Y) (smin x north)) ◃∙
             ap (ap (Susp-fmap (∧Σ-out X Y))) (ap merid (∧-norm-l x)) ◃∎
               =ₛ₁⟨ 1 & 1 & ∘-ap (ap (Susp-fmap (∧Σ-out X Y))) merid (∧-norm-l x) ⟩
             ! (SuspFmap.merid-β (∧Σ-out X Y) (smin x north)) ◃∙
             ap (ap (Susp-fmap (∧Σ-out X Y)) ∘ merid) (∧-norm-l x) ◃∎
               =ₛ⟨ !ₛ $
                   homotopy-naturality
                     (merid ∘ ∧Σ-out X Y)
                     (ap (Susp-fmap (∧Σ-out X Y)) ∘ merid)
                     (! ∘ SuspFmap.merid-β (∧Σ-out X Y))
                     (∧-norm-l x) ⟩
             ap (merid ∘ ∧Σ-out X Y) (∧-norm-l x) ◃∙
             ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ◃∎
               =ₛ⟨ 0 & 1 & =ₛ-in {t = []} $
                   ap-∘ merid (∧Σ-out X Y) (∧-norm-l x) ∙
                   ap (ap merid) (∧Σ-out-∧-norm-l X Y x) ⟩
             ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ◃∎ ∎ₛ ⟩
        (! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ∙v⊡
         ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north)))) ⊡h∙
        ↯ (tail f-smgluel-south)
          =⟨ ∙v⊡-⊡h∙-comm
               (! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)))
               (ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north))))
               (↯ (tail f-smgluel-south)) ⟩
        ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ∙v⊡
        ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north))) ⊡h∙
        ↯ (tail f-smgluel-south)
          =⟨ ! $ ap (! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ∙v⊡_) $
             ⊡h∙-assoc
               (ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north))))
               (ap-! (Susp-fmap (∧Σ-out X Y)) (merid (smin (pt X) north)))
               (ap ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north))) ⟩
        ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ∙v⊡
        ap-square (Susp-fmap (∧Σ-out X Y)) (tr-square (merid (smin (pt X) north))) ⊡h∙
        ap-! (Susp-fmap (∧Σ-out X Y)) (merid (smin (pt X) north)) ⊡h∙
        ap ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north))
          =⟨ ap (λ u → ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ∙v⊡
                       u ⊡h∙
                       ap ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north))) $
             ap-tr-square (Susp-fmap (∧Σ-out X Y)) (merid (smin (pt X) north)) ⟩
        ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ∙v⊡
        tr-square (ap (Susp-fmap (∧Σ-out X Y)) (merid (smin (pt X) north))) ⊡h∙
        ap ! (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north))
          =⟨ tr-square-∙v⊡-⊡h∙ (SuspFmap.merid-β (∧Σ-out X Y) (smin (pt X) north)) ⟩
        tr-square (merid north) =∎
      front-path : ∀ (x : de⊙ X) →
        (! (ap-cst north (merid x)) ∙v⊡
         natural-square (λ sx → basel) (merid x)) ⊡v∙
        ap-cst south (merid x)
        ==
        hid-square
      front-path x =
        (! (ap-cst north (merid x)) ∙v⊡
         natural-square (λ sx → basel) (merid x)) ⊡v∙
        ap-cst south (merid x)
          =⟨ ∙v⊡-⊡v∙-comm
               (! (ap-cst north (merid x)))
               (natural-square (λ sx → basel) (merid x))
               (ap-cst south (merid x)) ⟩
        ! (ap-cst north (merid x)) ∙v⊡
        natural-square (λ sx → basel) (merid x) ⊡v∙
        ap-cst south (merid x)
          =⟨ natural-square-cst north south (λ sx → basel) (merid x) ⟩
        horiz-degen-square (ap (λ sx → basel) (merid x))
          =⟨ ap horiz-degen-square (ap-cst basel (merid x)) ⟩
        horiz-degen-square idp
          =⟨ horiz-degen-square-idp ⟩
        hid-square =∎
      bot-path : ∀ (x : de⊙ X) →
        ! (ap-cst south (merid x)) ∙v⊡
        (! (g-smgluel north) ∙h⊡
         natural-square (λ sx → ap g (smgluel sx)) (merid x) ⊡h∙
         g-smgluel south) ⊡v∙
        ap-cst south (merid x)
        ==
        ids
      bot-path x =
        ! (ap-cst south (merid x)) ∙v⊡
        (! (g-smgluel north) ∙h⊡
         natural-square (λ sx → ap g (smgluel sx)) (merid x) ⊡h∙
         g-smgluel south) ⊡v∙
        ap-cst south (merid x)
          =⟨ ap (λ u → ! (ap-cst south (merid x)) ∙v⊡ u ⊡v∙ ap-cst south (merid x)) $
             natural-square-path
               (λ sx → idp)
               (λ sx → ap g (smgluel sx))
               g-smgluel
               (merid x) ⟩
        ! (ap-cst south (merid x)) ∙v⊡
        natural-square (λ sx → idp) (merid x) ⊡v∙
        ap-cst south (merid x)
          =⟨ natural-square-cst
               south
               south
               (λ sx → idp)
               (merid x) ⟩
        disc-to-square (ap (λ sx → idp) (merid x))
          =⟨ ap disc-to-square (ap-cst idp (merid x)) ⟩
        ids =∎

    f-smgluer : ∀ sy → ap f (smgluer sy) == idp
    f-smgluer sy =
      ap f (smgluer sy)
        =⟨ ap-∘ (Susp-fmap (∧Σ-out X Y)) (Σ∧-out X (⊙Susp (de⊙ Y))) (smgluer sy) ⟩
      ap (Susp-fmap (∧Σ-out X Y)) (ap (Σ∧-out X (⊙Susp (de⊙ Y))) (smgluer sy))
        =⟨ ap (ap (Susp-fmap (∧Σ-out  X Y)))
              (Σ∧Out.smgluer-β X (⊙Susp (de⊙ Y)) sy) ⟩
      idp =∎

    g-smgluer : ∀ sy →
      ap g (smgluer sy)
      ==
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (∧ΣOutSmgluer.f (⊙Susp (de⊙ X)) Y sy)
    g-smgluer sy =
      ap g (smgluer sy)
        =⟨ ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (∧Σ-out (⊙Susp (de⊙ X)) Y) (smgluer sy) ⟩
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (ap (∧Σ-out (⊙Susp (de⊙ X)) Y) (smgluer sy))
        =⟨ ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
              (∧ΣOut.smgluer-β (⊙Susp (de⊙ X)) Y sy) ⟩
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (∧ΣOutSmgluer.f (⊙Susp (de⊙ X)) Y sy) =∎

    g-smgluer-north : ap g (smgluer north) == idp
    g-smgluer-north = g-smgluer north

    g-smgluer-south-step :
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))
      ==
      ! (merid north)
    g-smgluer-south-step = ↯ $
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))
        =⟪ ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y))) ⟫
      ap Susp-flip (ap (Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y))))
        =⟪ ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) (smin north (pt Y))) ⟫
      ap Susp-flip (merid north)
        =⟪ SuspFlip.merid-β north ⟫
      ! (merid north) ∎∎

    g-smgluer-south : ap g (smgluer south) =-= merid north
    g-smgluer-south =
      ap g (smgluer south)
        =⟪ g-smgluer south ⟫
      ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (! (merid (smin north (pt Y))))
        =⟪ ap-! (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y))) ⟫
      ! (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y))))
        =⟪ ap ! g-smgluer-south-step ⟫
      ! (! (merid north))
        =⟪ !-! (merid north) ⟫
      merid north ∎∎

    smgluer-north : Square n-n (ap f (smgluer north)) (ap g (smgluer north)) baser
    smgluer-north = f-smgluer north ∙v⊡ hid-square ⊡v∙ ! g-smgluer-north

    smgluer-south : Square n-s (ap f (smgluer south)) (ap g (smgluer south)) baser
    smgluer-south = f-smgluer south ∙v⊡ br-square (merid north) ⊡v∙ ! (↯ (g-smgluer-south))

    smgluer-merid : ∀ (y : de⊙ Y) →
      Cube smgluer-north
           smgluer-south
           (n-m y)
           (natural-square (λ a → ap f (smgluer a)) (merid y))
           (natural-square (λ a → ap g (smgluer a)) (merid y))
           (natural-square (λ a → baser) (merid y))
    smgluer-merid y =
      smgluer-merid-custom-cube-∙v⊡
        (f-smgluer north)
        (f-smgluer south)
        (ap-cst north (merid y))
        (ap-cst north (merid y)) $
      cube-shift-top (! top-path) $
      custom-cube-⊡v∙
        (! g-smgluer-north)
        (↯ g-smgluer-south)
        (! (↯ (g-merid-y north y)))
        (ap-cst south (merid y)) $
      cube-shift-front (! front-path) $
      cube-shift-bot (! bot-path) $
      custom-cube (merid north)
      where
      smgluer-merid-custom-cube-∙v⊡ :
        ∀ {i} {A : Type i} {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
        {p₀₋₀  : a₀₀₀ == a₀₁₀}
        {p₋₀₀ p₋₀₀' : a₀₀₀ == a₁₀₀} (q₋₀₀ : p₋₀₀' == p₋₀₀)
        {p₋₁₀ : a₀₁₀ == a₁₁₀}
        {p₁₋₀ : a₁₀₀ == a₁₁₀}
        {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left
        {p₀₋₁ : a₀₀₁ == a₀₁₁}
        {p₋₀₁ p₋₀₁' : a₀₀₁ == a₁₀₁} (q₋₀₁ : p₋₀₁' == p₋₀₁)
        {p₋₁₁ : a₀₁₁ == a₁₁₁}
        {p₁₋₁ : a₁₀₁ == a₁₁₁}
        {sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁} -- right
        {p₀₀₋ p₀₀₋' : a₀₀₀ == a₀₀₁} (q₀₀₋ : p₀₀₋' == p₀₀₋)
        {p₀₁₋ : a₀₁₀ == a₀₁₁}
        {p₁₀₋ p₁₀₋' : a₁₀₀ == a₁₀₁} (q₁₀₋ : p₁₀₋ == p₁₀₋')
        {p₁₁₋ : a₁₁₀ == a₁₁₁}
        {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ p₀₋₁} -- back
        {sq₋₀₋ : Square p₋₀₀' p₀₀₋' p₁₀₋ p₋₀₁'} -- top
        {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
        {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ p₁₋₁} -- front
        → Cube sq₋₋₀ sq₋₋₁ sq₀₋₋ (! q₀₀₋ ∙v⊡ (! q₋₀₀ ∙h⊡ sq₋₀₋ ⊡h∙ q₋₀₁) ⊡v∙ q₁₀₋) sq₋₁₋ (! q₁₀₋ ∙v⊡ sq₁₋₋)
        → Cube (q₋₀₀ ∙v⊡ sq₋₋₀) (q₋₀₁ ∙v⊡ sq₋₋₁) (q₀₀₋ ∙v⊡ sq₀₋₋) sq₋₀₋ sq₋₁₋ sq₁₋₋
      smgluer-merid-custom-cube-∙v⊡ idp idp idp idp c = c
      top-path :
        ! (ap-cst north (merid y)) ∙v⊡
        (! (f-smgluer north) ∙h⊡
         natural-square (λ sy → ap f (smgluer sy)) (merid y) ⊡h∙
         f-smgluer south) ⊡v∙
        ap-cst north (merid y)
        ==
        ids
      top-path =
        ! (ap-cst north (merid y)) ∙v⊡
        (! (f-smgluer north) ∙h⊡
         natural-square (λ sy → ap f (smgluer sy)) (merid y) ⊡h∙
         f-smgluer south) ⊡v∙
        ap-cst north (merid y)
          =⟨ ap (λ u → ! (ap-cst north (merid y)) ∙v⊡ u ⊡v∙ ap-cst north (merid y)) $
             natural-square-path
               (λ sy → idp)
               (λ sy → ap f (smgluer sy))
               f-smgluer
               (merid y) ⟩
        ! (ap-cst north (merid y)) ∙v⊡
        natural-square (λ sy → idp) (merid y) ⊡v∙
        ap-cst north (merid y)
          =⟨ natural-square-cst
               north
               north
               (λ sy → idp)
               (merid y) ⟩
        disc-to-square (ap (λ sy → idp) (merid y))
          =⟨ ap disc-to-square (ap-cst idp (merid y)) ⟩
        ids =∎
      front-path :
        (! (ap-cst north (merid y)) ∙v⊡
         natural-square (λ sy → baser) (merid y)) ⊡v∙
        ap-cst south (merid y)
        ==
        hid-square
      front-path =
        (! (ap-cst north (merid y)) ∙v⊡
         natural-square (λ sy → baser) (merid y)) ⊡v∙
        ap-cst south (merid y)
          =⟨ ∙v⊡-⊡v∙-comm (! (ap-cst north (merid y)))
                          (natural-square (λ sy → baser) (merid y))
                          (ap-cst south (merid y)) ⟩
        ! (ap-cst north (merid y)) ∙v⊡
        natural-square (λ sy → baser) (merid y) ⊡v∙
        ap-cst south (merid y)
          =⟨ natural-square-cst
               north
               south
               (λ sy → baser)
               (merid y) ⟩
        horiz-degen-square (ap (λ sy → baser) (merid y))
          =⟨ ap horiz-degen-square (ap-cst baser (merid y)) ⟩
        horiz-degen-square idp
          =⟨ horiz-degen-square-idp ⟩
        hid-square =∎
      bot-path :
        ! (↯ (g-merid-y north y)) ∙v⊡
        (! g-smgluer-north ∙h⊡
         natural-square (λ sy → ap g (smgluer sy)) (merid y) ⊡h∙
         ↯ g-smgluer-south) ⊡v∙
        ap-cst south (merid y)
        ==
        rt-square (merid north)
      bot-path =
        ! (↯ (g-merid-y north y)) ∙v⊡
        (! g-smgluer-north ∙h⊡
         natural-square (λ sy → ap g (smgluer sy)) (merid y) ⊡h∙
         ↯ g-smgluer-south) ⊡v∙
        ap-cst south (merid y)
          =⟨ ap (λ u → ! (↯ (g-merid-y north y)) ∙v⊡ u ⊡v∙ ap-cst south (merid y)) $
             ! g-smgluer-north ∙h⊡
             natural-square (λ sy → ap g (smgluer sy)) (merid y) ⊡h∙
             ↯ g-smgluer-south
               =⟨ ! $ ap (! g-smgluer-north ∙h⊡_) $
                  ⊡h∙-assoc
                    (natural-square (λ sy → ap g (smgluer sy)) (merid y))
                    (g-smgluer south)
                    (↯ (tail g-smgluer-south)) ⟩
             ! g-smgluer-north ∙h⊡
             natural-square (λ sy → ap g (smgluer sy)) (merid y) ⊡h∙
             g-smgluer south ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ! $ ∙h⊡-⊡h∙-comm
                    (! g-smgluer-north)
                    (natural-square (λ sy → ap g (smgluer sy)) (merid y) ⊡h∙ g-smgluer south)
                    (↯ (tail g-smgluer-south)) ⟩
             (! g-smgluer-north ∙h⊡
              natural-square (λ sy → ap g (smgluer sy)) (merid y) ⊡h∙
              g-smgluer south) ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ap (_⊡h∙ ↯ (tail g-smgluer-south)) $
                  natural-square-path
                    (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) ∘ ∧ΣOutSmgluer.f (⊙Susp (de⊙ X)) Y)
                    (λ sy → ap g (smgluer sy))
                    g-smgluer
                    (merid y) ⟩
             natural-square (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) ∘ ∧ΣOutSmgluer.f (⊙Susp (de⊙ X)) Y) (merid y) ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ap (_⊡h∙ ↯ (tail g-smgluer-south)) $
                  natural-square-ap
                    (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                    (∧ΣOutSmgluer.f (⊙Susp (de⊙ X)) Y)
                    (merid y) ⟩
             (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
              ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                        (natural-square (∧ΣOutSmgluer.f (⊙Susp (de⊙ X)) Y) (merid y)) ⊡v∙
              ∘-ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (λ _ → north) (merid y)) ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ap (λ u → (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
                             ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) u ⊡v∙
                             ∘-ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (λ _ → north) (merid y)) ⊡h∙
                            ↯ (tail g-smgluer-south)) $
                  ∧ΣOutSmgluer.merid-square-β (⊙Susp (de⊙ X)) Y y ⟩
             (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
              ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                        (∧Σ-out-smgluer-merid (⊙Susp (de⊙ X)) Y y) ⊡v∙
              ∘-ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (λ _ → north) (merid y)) ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ap (λ u → (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
                             u ⊡v∙
                             ∘-ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (λ _ → north) (merid y)) ⊡h∙
                            ↯ (tail g-smgluer-south)) $ ! $
                  ap-square-⊡v∙
                    (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                    ((SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ∙v⊡
                     tr-square (merid (smin north (pt Y))))
                    (! (ap-cst north (merid y))) ⟩
             (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
              ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                        ((SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ∙v⊡
                         tr-square (merid (smin north (pt Y)))) ⊡v∙
              ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (! (ap-cst north (merid y))) ⊡v∙
              ∘-ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (λ _ → north) (merid y)) ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ap (λ u → (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡ u) ⊡h∙
                            ↯ (tail g-smgluer-south)) $
                  ⊡v∙-assoc
                    (ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                       ((SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ∙v⊡
                        tr-square (merid (smin north (pt Y)))))
                    (ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (! (ap-cst north (merid y))))
                    (∘-ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (λ _ → north) (merid y)) ⟩
             (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
              ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                        ((SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ∙v⊡
                         tr-square (merid (smin north (pt Y)))) ⊡v∙
              (ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (! (ap-cst north (merid y))) ∙
               ∘-ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (λ _ → north) (merid y))) ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ap (λ u → (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
                             ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                                       ((SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ∙v⊡
                                        tr-square (merid (smin north (pt Y)))) ⊡v∙
                             u) ⊡h∙
                            ↯ (tail g-smgluer-south)) $ =ₛ-out $
                  ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (! (ap-cst north (merid y))) ◃∙
                  ∘-ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (λ _ → north) (merid y) ◃∎
                    =ₛ⟨ 1 & 1 &
                        post-rotate-in {p = _ ◃∎} $
                        ap-∘-cst-coh (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) north (merid y) ⟩
                  ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (! (ap-cst north (merid y))) ◃∙
                  ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (ap-cst north (merid y)) ◃∙
                  ! (ap-cst south (merid y)) ◃∎
                    =ₛ⟨ 0 & 2 & ap-seq-=ₛ (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) $
                                seq-!-inv-l (ap-cst north (merid y) ◃∎) ⟩
                  ! (ap-cst south (merid y)) ◃∎ ∎ₛ ⟩
             (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
              ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                        ((SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ∙v⊡
                         tr-square (merid (smin north (pt Y)))) ⊡v∙
              ! (ap-cst south (merid y))) ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ap (λ u → (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡ u ⊡v∙
                             (! (ap-cst south (merid y)))) ⊡h∙
                            ↯ (tail g-smgluer-south)) $ ! $
                  ap-square-∙v⊡
                    (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                    (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))
                    (tr-square (merid (smin north (pt Y)))) ⟩
             (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
              (ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                  (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ∙v⊡
               ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                         (tr-square (merid (smin north (pt Y))))) ⊡v∙
              ! (ap-cst south (merid y))) ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ! $ ap (_⊡h∙ ↯ (tail g-smgluer-south)) $
                  ∙v⊡-⊡v∙-comm
                    (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y))
                    (ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                        (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ∙v⊡
                     ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                               (tr-square (merid (smin north (pt Y)))))
                    (! (ap-cst south (merid y))) ⟩
             (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙v⊡
              ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                 (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ∙v⊡
              ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                        (tr-square (merid (smin north (pt Y))))) ⊡v∙
             ! (ap-cst south (merid y)) ⊡h∙
             ↯ (tail g-smgluer-south)
               =⟨ ! $ ap (λ u → u ⊡v∙ ! (ap-cst south (merid y)) ⊡h∙ ↯ (tail g-smgluer-south)) $
                  ∙v⊡-assoc
                    (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y))
                    (ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                        (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)))
                    (ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                               (tr-square (merid (smin north (pt Y))))) ⟩
             ((ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
               ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                  (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
              ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                        (tr-square (merid (smin north (pt Y))))) ⊡v∙
             ! (ap-cst south (merid y)) ⊡h∙
             ↯ (tail g-smgluer-south) =∎
           ⟩
        ! (↯ (g-merid-y north y)) ∙v⊡
        (((ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
           ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
              (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
          ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                    (tr-square (merid (smin north (pt Y))))) ⊡v∙
         ! (ap-cst south (merid y)) ⊡h∙
         ↯ (tail g-smgluer-south)) ⊡v∙
        ap-cst south (merid y)
          =⟨ ap (! (↯ (g-merid-y north y)) ∙v⊡_) $ ! $
             ⊡v∙-⊡h∙-comm
               (((ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
                  ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                     (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
                 ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                           (tr-square (merid (smin north (pt Y))))) ⊡v∙
                ! (ap-cst south (merid y)))
               (ap-cst south (merid y))
               (↯ (tail g-smgluer-south)) ⟩
        ! (↯ (g-merid-y north y)) ∙v⊡
        (((ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
           ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
              (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
          ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                    (tr-square (merid (smin north (pt Y))))) ⊡v∙
         ! (ap-cst south (merid y)) ⊡v∙
         ap-cst south (merid y)) ⊡h∙
        ↯ (tail g-smgluer-south)
          =⟨ ap (λ u → ! (↯ (g-merid-y north y)) ∙v⊡ u ⊡h∙ ↯ (tail g-smgluer-south)) $
             ⊡v∙-assoc
               ((ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
                 ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                    (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
                ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                          (tr-square (merid (smin north (pt Y)))))
               (! (ap-cst south (merid y)))
               (ap-cst south (merid y)) ⟩
        ! (↯ (g-merid-y north y)) ∙v⊡
        (((ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
           ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
              (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
          ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                    (tr-square (merid (smin north (pt Y))))) ⊡v∙
         (! (ap-cst south (merid y)) ∙ ap-cst south (merid y))) ⊡h∙
        ↯ (tail g-smgluer-south)
          =⟨ ap (λ u → ! (↯ (g-merid-y north y)) ∙v⊡
                       (((ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
                          ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                             (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
                         ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                                   (tr-square (merid (smin north (pt Y))))) ⊡v∙
                        u) ⊡h∙
                       ↯ (tail g-smgluer-south)) $
             !-inv-l (ap-cst south (merid y)) ⟩
        ! (↯ (g-merid-y north y)) ∙v⊡
        ((ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
          ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
             (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
         ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                   (tr-square (merid (smin north (pt Y))))) ⊡h∙
        ↯ (tail g-smgluer-south)
          =⟨ ap (! (↯ (g-merid-y north y)) ∙v⊡_) $
             ∙v⊡-⊡h∙-comm
               (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
                ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                   (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)))
               (ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                          (tr-square (merid (smin north (pt Y)))))
               (↯ (tail g-smgluer-south)) ⟩
        ! (↯ (g-merid-y north y)) ∙v⊡
        (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
         ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
            (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
        ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                  (tr-square (merid (smin north (pt Y)))) ⊡h∙
        ↯ (tail g-smgluer-south)
          =⟨ ! $
             ∙v⊡-assoc
               (! (↯ (g-merid-y north y)))
               (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
                ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                   (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)))
               (ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                          (tr-square (merid (smin north (pt Y)))) ⊡h∙
                ↯ (tail g-smgluer-south)) ⟩
        (! (↯ (g-merid-y north y)) ∙
         ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ∙
         ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
            (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y))) ∙v⊡
        ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                  (tr-square (merid (smin north (pt Y)))) ⊡h∙
        ↯ (tail g-smgluer-south)
          =⟨ ap (_∙v⊡ ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                                (tr-square (merid (smin north (pt Y)))) ⊡h∙
                      ↯ (tail g-smgluer-south)) $ =ₛ-out $
             ! (↯ (g-merid-y north y)) ◃∙
             ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ◃∙
             ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                (SuspFmap.merid-β (smin north) y ∙ ap merid (∧-norm-r y)) ◃∎
               =ₛ⟨ 2 & 1 & ap-seq-∙ (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) $
                     (SuspFmap.merid-β (smin north) y ◃∙
                      ap merid (∧-norm-r y) ◃∎) ⟩
             ! (↯ (g-merid-y north y)) ◃∙
             ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ◃∙
             ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (SuspFmap.merid-β (smin north) y) ◃∙
             ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (ap merid (∧-norm-r y)) ◃∎
               =ₛ⟨ 0 & 1 & !-∙-seq (g-merid-y north y) ⟩
             ! (SuspFlip.merid-β north) ◃∙
             ! (ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) (smin north y))) ◃∙
             ! (ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) (merid (smin north y))) ◃∙
             ! (ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (SuspFmap.merid-β (smin north) y)) ◃∙
             ! (ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y)) ◃∙
             ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ◃∙
             ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (SuspFmap.merid-β (smin north) y) ◃∙
             ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (ap merid (∧-norm-r y)) ◃∎
               =ₛ⟨ 3 & 4 & seq-!-inv-l $
                   ap-∘ (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (Susp-fmap (smin north)) (merid y) ◃∙
                   ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (SuspFmap.merid-β (smin north) y) ◃∎ ⟩
             ! (SuspFlip.merid-β north) ◃∙
             ! (ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) (smin north y))) ◃∙
             ! (ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) (merid (smin north y))) ◃∙
             ap (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))) (ap merid (∧-norm-r y)) ◃∎
               =ₛ⟨ 2 & 2 & !ₛ $
                   homotopy-naturality
                     (ap Susp-flip ∘ ap (Susp-fmap (Σ∧-out X Y)))
                     (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)))
                     (λ p → ! (ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) p))
                     (ap merid (∧-norm-r y)) ⟩
             ! (SuspFlip.merid-β north) ◃∙
             ! (ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) (smin north y))) ◃∙
             ap (ap Susp-flip ∘ ap (Susp-fmap (Σ∧-out X Y))) (ap merid (∧-norm-r y)) ◃∙
             ! (ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))) ◃∎
               =ₛ₁⟨ 2 & 1 &
                    ∘-ap (ap Susp-flip ∘ ap (Susp-fmap (Σ∧-out X Y))) merid (∧-norm-r y) ⟩
             ! (SuspFlip.merid-β north) ◃∙
             ! (ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) (smin north y))) ◃∙
             ap (ap Susp-flip ∘ ap (Susp-fmap (Σ∧-out X Y)) ∘ merid) (∧-norm-r y) ◃∙
             ! (ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))) ◃∎
               =ₛ⟨ 1 & 2 & !ₛ $
                   homotopy-naturality
                     (ap Susp-flip ∘ merid ∘ Σ∧Out.f X Y)
                     (ap Susp-flip ∘ ap (Susp-fmap (Σ∧-out X Y)) ∘ merid)
                     (λ w → ! (ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) w)))
                     (∧-norm-r y) ⟩
             ! (SuspFlip.merid-β north) ◃∙
             ap (ap Susp-flip ∘ merid ∘ Σ∧-out X Y) (∧-norm-r y) ◃∙
             ! (ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) (smin north (pt Y)))) ◃∙
             ! (ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))) ◃∎
               =ₛ⟨ 1 & 1 & =ₛ-in {t = []} $
                   ap-∘ (ap Susp-flip ∘ merid) (Σ∧-out X Y) (∧-norm-r y) ∙
                   ap (ap (ap Susp-flip ∘ merid)) (Σ∧-out-∧-norm-r X Y y) ⟩
             ! (SuspFlip.merid-β north) ◃∙
             ! (ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) (smin north (pt Y)))) ◃∙
             ! (ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))) ◃∎
               =ₛ⟨ ∙-!-seq $
                   ap-∘ Susp-flip (Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y))) ◃∙
                   ap (ap Susp-flip) (SuspFmap.merid-β (Σ∧-out X Y) (smin north (pt Y))) ◃∙
                   SuspFlip.merid-β north ◃∎ ⟩
             ! g-smgluer-south-step ◃∎ ∎ₛ
           ⟩
        ! g-smgluer-south-step ∙v⊡
        ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                  (tr-square (merid (smin north (pt Y)))) ⊡h∙
        ↯ (tail g-smgluer-south)
          =⟨ ! $ ap (! g-smgluer-south-step ∙v⊡_) $
             ⊡h∙-assoc
               (ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                          (tr-square (merid (smin north (pt Y)))))
               (ap-! (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y))))
               (ap ! g-smgluer-south-step ∙ !-! (merid north)) ⟩
        ! g-smgluer-south-step ∙v⊡
        ap-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y))
                  (tr-square (merid (smin north (pt Y)))) ⊡h∙
        ap-! (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y))) ⊡h∙
        (ap ! g-smgluer-south-step ∙ !-! (merid north))
          =⟨ ap (λ u → ! g-smgluer-south-step ∙v⊡ u ⊡h∙
                       (ap ! g-smgluer-south-step ∙ !-! (merid north))) $
             ap-tr-square (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y))) ⟩
        ! g-smgluer-south-step ∙v⊡
        tr-square (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))) ⊡h∙
        (ap ! g-smgluer-south-step ∙ !-! (merid north))
          =⟨ ! $ ap (! g-smgluer-south-step ∙v⊡_) $
             ⊡h∙-assoc
               (tr-square (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))))
               (ap ! g-smgluer-south-step)
               (!-! (merid north)) ⟩
        ! g-smgluer-south-step ∙v⊡
        tr-square (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))) ⊡h∙
        ap ! g-smgluer-south-step ⊡h∙
        !-! (merid north)
          =⟨ ! $ ∙v⊡-⊡h∙-comm
               (! g-smgluer-south-step)
               (tr-square (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))) ⊡h∙
                ap ! g-smgluer-south-step)
               (!-! (merid north)) ⟩
        (! g-smgluer-south-step ∙v⊡
         tr-square (ap (Susp-flip ∘ Susp-fmap (Σ∧-out X Y)) (merid (smin north (pt Y)))) ⊡h∙
         ap ! g-smgluer-south-step) ⊡h∙
        !-! (merid north)
          =⟨ ap (_⊡h∙ !-! (merid north)) $
             tr-square-∙v⊡-⊡h∙ g-smgluer-south-step ⟩
        tr-square (! (merid north)) ⊡h∙ !-! (merid north)
          =⟨ tr-square-! (merid north) ⟩
        rt-square (merid north) =∎
      custom-cube : ∀ {i} {S : Type i} {n s : S} (p : n == s)
        → Cube hid-square (br-square p) (lb-square p) ids (rt-square p) hid-square
      custom-cube p@idp = idc

  module ∧Σ-Σ∧-Out =
    Σ∧Σ-PathElim
      f g
      n-n n-s s-n s-s
      n-m s-m m-n m-s
      m-m
      basel
      baser
      smgluel-north
      smgluel-south
      smgluel-merid
      smgluer-north
      smgluer-south
      smgluer-merid

  ∧Σ-Σ∧-out : Susp-fmap (∧Σ-out X Y) ∘ Σ∧-out X (⊙Susp (de⊙ Y))
            ∼ Susp-flip ∘ Susp-fmap (Σ∧-out X Y) ∘ ∧Σ-out (⊙Susp (de⊙ X)) Y
  ∧Σ-Σ∧-out = ∧Σ-Σ∧-Out.f

  ⊙∧Σ-Σ∧-out : ⊙Susp-fmap (∧Σ-out X Y) ◃⊙∘
               ⊙Σ∧-out X (⊙Susp (de⊙ Y)) ◃⊙idf
               =⊙∘
               ⊙Susp-flip (⊙Susp (X ∧ Y)) ◃⊙∘
               ⊙Susp-fmap (Σ∧-out X Y) ◃⊙∘
               ⊙∧Σ-out (⊙Susp (de⊙ X)) Y ◃⊙idf
  ⊙∧Σ-Σ∧-out =
    ⊙seq-λ= ∧Σ-Σ∧-out $ !ₛ $
    merid north ◃∙
    idp ◃∙
    idp ◃∙
    ! (merid north) ◃∎
      =ₛ⟨ 1 & 1 & expand [] ⟩
    merid north ◃∙
    idp ◃∙
    ! (merid north) ◃∎
      =ₛ⟨ 1 & 1 & expand [] ⟩
    merid north ◃∙
    ! (merid north) ◃∎
      =ₛ₁⟨ !-inv-r (merid north) ⟩
    idp ◃∎
      =ₛ⟨ 0 & 0 & contract ⟩
    idp ◃∙
    idp ◃∎ ∎ₛ


------------------------------------------------------------------------
-- A sound, inductive approximation of stream equality
------------------------------------------------------------------------

-- The point of this module is to give a short (not entirely faithful)
-- illustration of the technique used to establish soundness of
-- RecursiveTypes.Subtyping.Axiomatic.Inductive._⊢_≤_ with respect to
-- RecursiveTypes.Subtyping.Axiomatic.Coinductive._≤_.

module InductiveStreamEquality {A : Set} where

open import Codata.Musical.Notation
open import Codata.Musical.Stream hiding (_∈_; lookup)
open import Data.List
open import Data.List.Membership.Propositional
open import Data.List.Relation.Unary.All as All
open import Data.List.Relation.Unary.Any using (here; there)
open import Data.Product
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

infixr 5 _∷_
infix  4 _⊢_≈_ _≈P_ _≈W_

------------------------------------------------------------------------
-- An approximation of stream equality

-- Streams do not need to be regular, so _⊢_≈_ is not complete with
-- respect to _≈_.

data _⊢_≈_ (H : List (Stream A × Stream A)) :
           Stream A → Stream A → Set where
  _∷_   : ∀ x {xs ys} →
          (x ∷ xs , x ∷ ys) ∷ H ⊢ ♭ xs ≈ ♭ ys →
          H ⊢ x ∷ xs ≈ x ∷ ys
  hyp   : ∀ {xs ys} → (xs , ys) ∈ H → H ⊢ xs ≈ ys
  trans : ∀ {xs ys zs} → H ⊢ xs ≈ ys → H ⊢ ys ≈ zs → H ⊢ xs ≈ zs

-- Example.

repeat-refl : (x : A) → [] ⊢ repeat x ≈ repeat x
repeat-refl x = x ∷ hyp (here refl)

------------------------------------------------------------------------
-- Soundness

Valid : (Stream A → Stream A → Set) → Stream A × Stream A → Set
Valid _R_ (xs , ys) = xs R ys

-- Programs and WHNFs.

mutual

  data _≈P_ : Stream A → Stream A → Set where
    sound : ∀ {A xs ys} → All (Valid _≈W_) A → A ⊢ xs ≈ ys → xs ≈P ys
    trans : ∀ {xs ys zs} → xs ≈P ys → ys ≈P zs → xs ≈P zs

  data _≈W_ : Stream A → Stream A → Set where
    _∷_ : ∀ x {xs ys} → ∞ (♭ xs ≈P ♭ ys) → x ∷ xs ≈W x ∷ ys

transW : ∀ {xs ys zs} → xs ≈W ys → ys ≈W zs → xs ≈W zs
transW (x ∷ xs≈ys) (.x ∷ ys≈zs) = x ∷ ♯ trans (♭ xs≈ys) (♭ ys≈zs)

soundW : ∀ {A xs ys} → All (Valid _≈W_) A → A ⊢ xs ≈ ys → xs ≈W ys
soundW valid (hyp h)             = All.lookup valid h
soundW valid (trans xs≈ys ys≈zs) = transW (soundW valid xs≈ys)
                                          (soundW valid ys≈zs)
soundW valid (x ∷ xs≈ys)         = proof
  where
  proof : _ ≈W _
  proof = x ∷ ♯ sound (proof ∷ valid) xs≈ys

whnf : ∀ {xs ys} → xs ≈P ys → xs ≈W ys
whnf (sound valid xs≈ys) = soundW valid xs≈ys
whnf (trans xs≈ys ys≈zs) = transW (whnf xs≈ys) (whnf ys≈zs)

-- The programs and WHNFs are sound with respect to _≈_.

mutual

  ⟦_⟧W : ∀ {xs ys} → xs ≈W ys → xs ≈ ys
  ⟦ x ∷ xs≈ys ⟧W = refl ∷ ♯ ⟦ ♭ xs≈ys ⟧P

  ⟦_⟧P : ∀ {xs ys} → xs ≈P ys → xs ≈ ys
  ⟦ xs≈ys ⟧P = ⟦ whnf xs≈ys ⟧W

-- The programs and WHNFs are also complete with respect to _≈_.

mutual

  completeP : ∀ {xs ys} → xs ≈ ys → xs ≈P ys
  completeP xs≈ys = sound (completeW xs≈ys ∷ []) (hyp (here refl))

  completeW : ∀ {xs ys} → xs ≈ ys → xs ≈W ys
  completeW (refl ∷ xs≈ys) = _ ∷ ♯ completeP (♭ xs≈ys)

-- Finally we get the intended soundness result for _⊢_≈_.

reallySound : ∀ {A xs ys} → All (Valid _≈_) A → A ⊢ xs ≈ ys → xs ≈ ys
reallySound valid xs≈ys =
  ⟦ sound (All.map (λ {p} → done p) valid) xs≈ys ⟧P
  where
  done : ∀ p → Valid _≈_ p → Valid _≈W_ p
  done (xs , ys) = completeW


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Terms that operate on changes with the Nehemiah plugin.
------------------------------------------------------------------------

module Nehemiah.Change.Term where

open import Data.Integer

open import Nehemiah.Syntax.Type public
open import Nehemiah.Syntax.Term public
open import Nehemiah.Change.Type public

import Parametric.Change.Term Const ΔBase as ChangeTerm

apply-base : ChangeTerm.ApplyStructure
apply-base {base-int} = absV 2 (λ Δx x → add x Δx)
apply-base {base-bag} = absV 2 (λ Δx x → union x Δx)

diff-base : ChangeTerm.DiffStructure
diff-base {base-int} = absV 2 (λ x y → add x (minus y))
diff-base {base-bag} = absV 2 (λ x y → union x (negate y))

nil-base : ChangeTerm.NilStructure
nil-base {base-int} = absV 1 (λ x → intlit (+ 0))
nil-base {base-bag} = absV 1 (λ x → empty)

open ChangeTerm.Structure apply-base diff-base nil-base public


module EtaBug where

record ⊤ : Set where
data ⊥ : Set where

data Bool : Set where
  true  : Bool
  false : Bool

T : Bool → Set
T true  = ⊤
T false = ⊥

record ∃ {A : Set} (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

postulate
  G : Set → Set
  D : ∀ {A} → G A → A → Set

P : {A : Set} → G A → Set
P g = ∀ x → D g x

postulate
  f : ∀ {A} {g : G A} → P g → P g
  g : (p : ⊥ → Bool) → G (∃ λ t → T (p t))
  h : ∀ {p : ⊥ → Bool} {t pt} → D (g p) (t , pt)
  p : ⊥ → Bool

works : P (g p)
works = f (λ _ → h {p = p})

fails : P (g p)
fails = f (λ _ → h)


module WithApp where

f
  : {A : Set}
  → A
  → A
f x
  with x
... | y
  = y

g
  : {A : Set}
  → A
  → A
  → A
g x y
  with x
... | _
  with y
... | _
  = x


{-# OPTIONS --universe-polymorphism #-}

module Categories.Support.SetoidPi where

open import Level
open import Function as Fun using (_on_)
open import Relation.Binary as B using () renaming (_=[_]⇒_ to _=[_]⇒₀_; _⇒_ to _⊆_)
open import Relation.Binary.PropositionalEquality as PE using (_≡_)
open import Relation.Binary.HeterogeneousEquality using (_≅_) renaming (refl to ≅-refl)
open import Relation.Binary.Indexed.Heterogeneous as I using (_=[_]⇒_)
open import Categories.Support.Equivalence
open import Categories.Support.SetoidFunctions as SF using (_⟶_) renaming (_⟨$⟩_ to _⟨$⟩₀_; cong to cong₀)
open Setoid using () renaming (Carrier to Carrier₀; _≈_ to _[_≈_])

_⟶[_,_] : ∀ {cf ℓf} (From : Setoid cf ℓf) (ct ℓt : Level) → Set (cf ⊔ ℓf ⊔ suc (ct ⊔ ℓt))
From ⟶[ ct , ℓt ] = From ⟶ set→setoid (Setoid ct ℓt)

------------------------------------------------------------------------
-- Indexed binary relations
------------------------------------------------------------------------

record IndexedSetoid {i iℓ} (I : Set i) (_∼_ : B.Rel I iℓ) c ℓ : Set (suc (i ⊔ iℓ ⊔ c ⊔ ℓ)) where
  infix 4 _≈_
  field
    Carrier       : I → Set c
    _≈_           : I.IRel Carrier ℓ
    .isEquivalence : I.IsIndexedEquivalence Carrier _≈_
    -- NOTE one more field, see resp below

  -- no irrelevant opens ☹
  -- .open I.IsEquivalence isEquivalence public
  private
    module E = I.IsIndexedEquivalence
  .refl : I.Reflexive Carrier _≈_
  refl = E.refl isEquivalence
  .sym : I.Symmetric Carrier _≈_
  sym = E.sym isEquivalence
  .trans : I.Transitive Carrier _≈_
  trans = E.trans isEquivalence

  .reflexive : ∀ {i} → _≡_ ⊆ (_≈_ {i})
  reflexive = E.reflexive isEquivalence

  -- conversion to regular setoids by evaluating at an index
  _at_ : I → Setoid c ℓ
  _at_ i = record
    { Carrier = Carrier i
    ; _≈_ = _≈_
    ; isEquivalence = record
      { refl = E.refl isEquivalence
      ; sym = E.sym isEquivalence
      ; trans = E.trans isEquivalence
      }
    }

  -- XXX ideally i should redo the resp stuff and promotion and everything
  -- with the proper setoid of setoids under equivalence, but first i didn't
  -- make it yet and second OH MY GOD                         ─xplat
  Resp-Type = _∼_ =[ _at_ ]⇒₀ _≡_ {A = Setoid c ℓ}
  field
    .resp          : Resp-Type

resp-per : ∀ {c ℓ} {C₁ C₂ : Set c} {_≈₁_ : B.Rel C₁ ℓ} {_≈₂_ : B.Rel C₂ ℓ} {equiv₁ : B.IsEquivalence _≈₁_} {equiv₂ : B.IsEquivalence _≈₂_} → C₁ ≡ C₂ → _≈₁_ ≅ _≈₂_ → _≡_ {A = Setoid c ℓ} record {Carrier = C₁; _≈_ = _≈₁_; isEquivalence = equiv₁} record {Carrier = C₂; _≈_ = _≈₂_; isEquivalence = equiv₂}
resp-per _≡_.refl ≅-refl = _≡_.refl

.resp-per′ : ∀ {c ℓ} (S T : Setoid c ℓ) → (Carrier₀ S ≡ Carrier₀ T) → (Setoid._≈_ S ≅ Setoid._≈_ T) → S ≡ T
resp-per′ S T = resp-per {equiv₁ = Setoid.isEquivalence S} {equiv₂ = Setoid.isEquivalence T}

open IndexedSetoid using (_at_)

weaken : ∀ {c ℓ} → Setoid c ℓ → ∀ {i iℓ} {I : Set i} {_∼_ : B.Rel I iℓ} → IndexedSetoid I _∼_ c ℓ
weaken S {I = I} {_∼_} = record
  { Carrier = Fun.const S.Carrier
  ; _≈_ = S._≈_
  ; isEquivalence = record { refl = S.refl; sym = S.sym; trans = S.trans }
  ; resp = Fun.const _≡_.refl
  }
  where module S = Setoid S

{-
-- this definition is unusable because agda spins in circles trying to infer
-- ct and ℓt before it will extract any information from f's type, but f's
-- type is the only thing it can infer them from... test is below ☹
_[$]_ : ∀ {cf ℓf ct ℓt} {From : Setoid cf ℓf} → (From ⟶[ ct , ℓt ]) → Carrier From → Set ct
f [$] x = Carrier (f ⟨$⟩₀ x)

.test : ∀ {cf ℓf ct ℓt} {From : Setoid cf ℓf} (To : From ⟶[ ct , ℓt ]) (x : Carrier From) → (_[$]_ {ct = ct}{ℓt = ℓt} To x) → Set ℓt
test = {!!}
-}

-- i think this approach would work beautifully with regular setoids, but
-- with irrelevant setoids the type of cong can't depend on localize
--                                                          ─ xplat

-- .localize : ∀ {cf ℓf ct ℓt} {From : Setoid cf ℓf} (To : From ⟶[ ct , ℓt ]) {x y : Carrier₀ From} → From [ x ≈ y ] → B.REL (Carrier₀ (To ⟨$⟩₀ x)) (Carrier₀ (To ⟨$⟩₀ y)) ℓt
-- localize To {x} x≈y with To ⟨$⟩₀ x | cong₀ To x≈y
-- localize To x≈y | ._ | _≡_.refl = Setoid._≈_ (To ⟨$⟩₀ _)

-- ... so it's on to yet another annoying heterogeneous equality type
module SetoidHetero {cf ℓf} (From : Setoid cf ℓf) (ct ℓt : Level) (To : From ⟶[ ct , ℓt ]) where
  I = Carrier₀ From
  To$ = _⟨$⟩₀_ To
  To$C = Fun._∘_ Carrier₀ (_⟨$⟩₀_ To)

  localize′ : ∀ {S T : Setoid ct ℓt} → (S ≡ T) → B.REL (Carrier₀ S) (Carrier₀ T) ℓt
  -- localize′ {S} {T} S≡T
  localize′ {S} _≡_.refl = Setoid._≈_ S

  localize : ∀ {x y : I} → (To$ x ≡ To$ y) → B.REL (To$C x) (To$C y) ℓt
  localize {x} {y} To$x≡To$y with To$ y
  localize {x} _≡_.refl | ._ = Setoid._≈_ (To$ x)

  data _≈∗_ {S T : Setoid ct ℓt} (x : Carrier₀ S) : (y : Carrier₀ T) → Set (suc (ct ⊔ ℓt)) where
    locally : (S≡T : S ≡ T)
      {y : Carrier₀ T} (x≈y : localize′ S≡T x y) →
      _≈∗_ {S} {T} x y

  _≈⋆_ : {iˣ iʸ : I} → B.REL (To$C iˣ) (To$C iʸ) (suc (ct ⊔ ℓt))
  _≈⋆_ {iˣ} {iʸ} = _≈∗_ {To$ iˣ} {To$ iʸ}

asIndexed : ∀ {cf ℓf} ct ℓt {From : Setoid cf ℓf} → (From ⟶[ ct , ℓt ]) → IndexedSetoid (Carrier₀ From) (Setoid._≈_ From) ct (suc (ct ⊔ ℓt))
asIndexed ct ℓt {From} To = record
  { Carrier = To$C
  ; _≈_ = _≈⋆_
  ; isEquivalence = record
    { refl = my-refl
    ; sym = my-sym
    ; trans = my-trans
    }
  ; resp = λ {i j} i∼j → resp-per′ (fake-at i) (fake-at j) (resp-helper i∼j) (resp-helper₂ i∼j)
  }
  where
  open SetoidHetero _ ct ℓt To

  .my-refl : I.Reflexive To$C _≈⋆_
  my-refl {i} {x} = locally {To$ i} _≡_.refl ((Setoid.refl (To$ i)))

  .sym-helper : ∀ i j (To$i≡To$j : To$ i ≡ To$ j) (x : To$C i) (y : To$C j) (x≈y : localize′ To$i≡To$j x y) → localize′ (PE.sym To$i≡To$j) y x
  sym-helper i j To$i≡To$j x y with To$ j
  sym-helper i j _≡_.refl x y | ._ = Setoid.sym (To$ i)

  .my-sym : I.Symmetric To$C _≈⋆_
  my-sym {i} {j} {x} {y} (locally To$i≡To$j x≈y) = locally (PE.sym To$i≡To$j) (sym-helper i j To$i≡To$j x y x≈y)

  .trans-helper : ∀ i j k (To$i≡To$j : To$ i ≡ To$ j) (To$j≡To$k : To$ j ≡ To$ k) (x : To$C i) (y : To$C j) (z : To$C k) (x≈y : localize′ To$i≡To$j x y) (y≈z : localize′ To$j≡To$k y z) → localize′ (PE.trans To$i≡To$j To$j≡To$k) x z
  trans-helper i j k To$i≡To$j To$j≡To$k x y z with To$ j | To$ k
  trans-helper i j k _≡_.refl _≡_.refl x y z | ._ | ._ = Setoid.trans (To$ i)

  .my-trans : I.Transitive To$C _≈⋆_
  my-trans (locally To$i≡To$j x≈y) (locally To$j≡To$k y≈z) = locally (PE.trans To$i≡To$j To$j≡To$k) (trans-helper _ _ _ To$i≡To$j To$j≡To$k _ _ _ x≈y y≈z)

  .resp-helper : ∀ {i j} → From [ i ≈ j ] → To$C i ≡ To$C j
  resp-helper i∼j = PE.cong Carrier₀ (cong₀ To i∼j)

  .resp-helper₃ : (S T : Setoid ct ℓt) → S ≡ T → _≈∗_ {S} {S} ≅ _≈∗_ {T} {T}
  resp-helper₃ S .S _≡_.refl = ≅-refl

  .resp-helper₂ : ∀ {i j} → From [ i ≈ j ] → _≈⋆_ {i} {i} ≅ _≈⋆_ {j} {j}
  resp-helper₂ {i} {j} i∼j = resp-helper₃ (To$ i) (To$ j) (cong₀ To i∼j)

  fake-at : ∀ i → Setoid ct (suc (ct ⊔ ℓt))
  fake-at i = record
    { Carrier = To$C i
    ; _≈_ = _≈⋆_ {i} {i}
    ; isEquivalence = record
      { refl = my-refl
      ; sym = my-sym
      ; trans = my-trans
      }
    }

------------------------------------------------------------------------
-- Functions which preserve equality

record Π {f₁ f₂ t₁ t₂}
         (From : Setoid f₁ f₂)
         (To : IndexedSetoid (Carrier₀ From) (Setoid._≈_ From) t₁ t₂) :
         Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
  open I using (_=[_]⇒_)
  infixl 5 _⟨$⟩_
  field
    _⟨$⟩_ : (x : Carrier₀ From) → IndexedSetoid.Carrier To x
    .cong : Setoid._≈_ From =[ _⟨$⟩_ ]⇒ IndexedSetoid._≈_ To

open Π public

Π′ : ∀ {cf ℓf} (ct ℓt : Level) (From : Setoid cf ℓf) (To : From ⟶[ ct , ℓt ]) → Set (cf ⊔ ℓf ⊔ suc (ct ⊔ ℓt))
Π′ ct ℓt From To = Π From (asIndexed ct ℓt To)

-- Pis that 'just happen' to be independent, instead of being necessarily so.

infixr 0 _⟶Π_

_⟶Π_ : ∀ {f₁ f₂ t₁ t₂} → Setoid f₁ f₂ → Setoid t₁ t₂ → Set _
From ⟶Π To = Π From (weaken To)

-- Identity and composition.

id : ∀ {a₁ a₂} {A : Setoid a₁ a₂} → A ⟶Π A
id = record { _⟨$⟩_ = Fun.id; cong = Fun.id }

infixr 9 _∙′_

_∙′_ : ∀ {a₁ a₂} {A : Setoid a₁ a₂}
        {b₁ b₂} {B : Setoid b₁ b₂}
        {c₁ c₂} {C : Setoid c₁ c₂} →
      B ⟶Π C → A ⟶Π B → A ⟶Π C
f ∙′ g = record
  { _⟨$⟩_ = Fun._∘_ (_⟨$⟩_ f) (_⟨$⟩_ g)
  ; cong  = Fun._∘_ (cong  f) (cong  g)
  }

infixr 9 _[_○_]

-- XXX this shouldn't need B, but it can't be inferred from f's type
_[_○_] : ∀ {a₁ a₂} {A : Setoid a₁ a₂}
           {b₁ b₂} (B : Setoid b₁ b₂)
           {c₁ c₂} (C : IndexedSetoid _ (Setoid._≈_ B) c₁ c₂) →
         (A ⟶Π B) → IndexedSetoid _ _ c₁ c₂
B [ C ○ f ] = record
  { Carrier = Fun._∘_ C.Carrier (_⟨$⟩_ f)
  ; _≈_ = C._≈_
  ; isEquivalence = record { refl = C.refl; sym = C.sym; trans = C.trans }
  ; resp = Fun._∘_ C.resp (cong f)
  }
  where module C = IndexedSetoid C

-- PROPER.  well, halfway.
infixr 9 _∙_

_∙_ : ∀ {a₁ a₂} {A : Setoid a₁ a₂}
        {b₁ b₂} {B : Setoid b₁ b₂}
        {c₁ c₂} {C : IndexedSetoid _ _ c₁ c₂} →
      (f : Π B C) → (g : A ⟶Π B) → Π A (B [ C ○ g ])
f ∙ g = record
  { _⟨$⟩_ = Fun._∘_ (_⟨$⟩_ f) (_⟨$⟩_ g)
  ; cong  = Fun._∘_ (cong  f) (cong  g)
  }

-- Constant equality-preserving function.

const : ∀ {a₁ a₂} {A : Setoid a₁ a₂}
          {b₁ b₂} {B : Setoid b₁ b₂} →
        Carrier₀ B → A ⟶Π B
const {B = B} b = record
  { _⟨$⟩_ = Fun.const b
  ; cong  = Fun.const (Setoid.refl B)
  }

------------------------------------------------------------------------
-- Function setoids

-- Dependent.

setoid : ∀ {f₁ f₂ t₁ t₂}
         (From : Setoid f₁ f₂) →
         IndexedSetoid (Carrier₀ From) (Setoid._≈_ From) t₁ t₂ →
         Setoid _ _
setoid From To = record
  { Carrier       = Π From To
  ; _≈_           = λ f g → ∀ {x y} → x ≈₁ y → f ⟨$⟩ x ≈₂ g ⟨$⟩ y
  ; isEquivalence = record
    { refl  = λ {f} → cong f
    ; sym   = λ f∼g x∼y → To.sym (f∼g (From.sym x∼y))
    ; trans = λ f∼g g∼h x∼y → To.trans (f∼g From.refl) (g∼h x∼y)
    }
  }
  where
  open module From = Setoid      From using () renaming (_≈_ to _≈₁_)
  open module To = IndexedSetoid To   using () renaming (_≈_ to _≈₂_)


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

open import lib.Basics
open import lib.types.Sigma
open import lib.types.Bool
open import lib.types.Int

module lib.types.List where

infixr 60 _::_

data List {i} (A : Type i) : Type i where
  nil : List A
  _::_ : A → List A → List A

module _ {i} {A : Type i} where
  infixr 80 _++_
  _++_ : List A → List A → List A
  nil ++ l = l
  (x :: l₁) ++ l₂ = x :: (l₁ ++ l₂)

  snoc : List A → A → List A
  snoc l a = l ++ (a :: nil)

  ++-unit-r : ∀ l → l ++ nil == l
  ++-unit-r nil      = idp
  ++-unit-r (a :: l) = ap (a ::_) $ ++-unit-r l

  ++-assoc : ∀ l₁ l₂ l₃ → (l₁ ++ l₂) ++ l₃ == l₁ ++ (l₂ ++ l₃)
  ++-assoc nil l₂ l₃ = idp
  ++-assoc (x :: l₁) l₂ l₃ = ap (x ::_) (++-assoc l₁ l₂ l₃)

  -- properties
  module _ {j} (P : A → Type j) where
    data Any : List A → Type (lmax i j) where
      here : ∀ {a} {l} → P a → Any (a :: l)
      there : ∀ {a} {l} → Any l → Any (a :: l)

    data All : List A → Type (lmax i j) where
      nil : All nil
      _::_ : ∀ {a} {l} → P a → All l → All (a :: l)

    Any-dec : (∀ a → Dec (P a)) → (∀ l → Dec (Any l))
    Any-dec _   nil       = inr λ{()}
    Any-dec dec (a :: l) with dec a
    ... | inl p = inl $ here p
    ... | inr ¬p with Any-dec dec l
    ...   | inl ∃p = inl $ there ∃p
    ...   | inr ¬∃p = inr λ{(here p) → ¬p p; (there ∃p) → ¬∃p ∃p}

    Any-++-l : ∀ l₁ l₂ → Any l₁ → Any (l₁ ++ l₂)
    Any-++-l _ _ (here p)   = here p
    Any-++-l _ _ (there ∃p) = there (Any-++-l _ _ ∃p)

    Any-++-r : ∀ l₁ l₂ → Any l₂ → Any (l₁ ++ l₂)
    Any-++-r nil      _ ∃p = ∃p
    Any-++-r (a :: l) _ ∃p = there (Any-++-r l _ ∃p)

    Any-++ : ∀ l₁ l₂ → Any (l₁ ++ l₂) → Any l₁ ⊔ Any l₂
    Any-++ nil       l₂ ∃p         = inr ∃p
    Any-++ (a :: l₁) l₂ (here p)   = inl (here p)
    Any-++ (a :: l₁) l₂ (there ∃p) with Any-++ l₁ l₂ ∃p
    ... | inl ∃p₁ = inl (there ∃p₁)
    ... | inr ∃p₂ = inr ∃p₂

  infix 80 _∈_
  _∈_ : A → List A → Type i
  a ∈ l = Any (_== a) l

  ∈-dec : has-dec-eq A → ∀ a l → Dec (a ∈ l)
  ∈-dec dec a l = Any-dec (_== a) (λ a' → dec a' a) l

  ∈-++-l : ∀ a l₁ l₂ → a ∈ l₁ → a ∈ (l₁ ++ l₂)
  ∈-++-l a = Any-++-l (_== a)

  ∈-++-r : ∀ a l₁ l₂ → a ∈ l₂ → a ∈ (l₁ ++ l₂)
  ∈-++-r a = Any-++-r (_== a)

  ∈-++ : ∀ a l₁ l₂ → a ∈ (l₁ ++ l₂) → (a ∈ l₁) ⊔ (a ∈ l₂)
  ∈-++ a = Any-++ (_== a)

  -- [foldr] in Haskell
  foldr : ∀ {j} {B : Type j} → (A → B → B) → B → List A → B
  foldr f b nil = b
  foldr f b (a :: l) = f a (foldr f b l)

  -- [length] in Haskell
  length : List A → ℕ
  length = foldr (λ _ n → S n) 0

  -- [filter] in Haskell
  -- Note that [Bool] is currently defined as a coproduct.
  filter : ∀ {j k} {Keep : A → Type j} {Drop : A → Type k}
    → ((a : A) → Keep a ⊔ Drop a) → List A → List A
  filter p nil = nil
  filter p (a :: l) with p a
  ... | inl _ = a :: filter p l
  ... | inr _ = filter p l

  -- [reverse] in Haskell
  reverse : List A → List A
  reverse nil = nil
  reverse (x :: l) = snoc (reverse l) x

  reverse-snoc : ∀ a l → reverse (snoc l a) == a :: reverse l
  reverse-snoc a nil = idp
  reverse-snoc a (b :: l) = ap (λ l → snoc l b) (reverse-snoc a l)

  reverse-reverse : ∀ l → reverse (reverse l) == l
  reverse-reverse nil = idp
  reverse-reverse (a :: l) = reverse-snoc a (reverse l) ∙ ap  (a ::_) (reverse-reverse l)

  -- Reasoning about identifications
  List= : ∀ (l₁ l₂ : List A) → Type i
  List= nil       nil       = Lift ⊤
  List= nil       (y :: l₂) = Lift ⊥
  List= (x :: l₁) nil       = Lift ⊥
  List= (x :: l₁) (y :: l₂) = (x == y) × (l₁ == l₂)

  List=-in : ∀ {l₁ l₂ : List A} → l₁ == l₂ → List= l₁ l₂
  List=-in {l₁ = nil} idp = lift unit
  List=-in {l₁ = x :: l} idp = idp , idp

  List=-out : ∀ {l₁ l₂ : List A} → List= l₁ l₂ → l₁ == l₂
  List=-out {l₁ = nil} {l₂ = nil} _ = idp
  List=-out {l₁ = nil} {l₂ = y :: l₂} (lift ())
  List=-out {l₁ = x :: l₁} {l₂ = nil} (lift ())
  List=-out {l₁ = x :: l₁} {l₂ = y :: l₂} (x=y , l₁=l₂) = ap2 _::_ x=y l₁=l₂

module _ {i j} {A : Type i} {B : Type j} (f : A → B) where

  -- [map] in Haskell
  map : List A → List B
  map nil = nil
  map (a :: l) = f a :: map l

  map-++ : ∀ l₁ l₂ → map (l₁ ++ l₂) == map l₁ ++ map l₂
  map-++ nil l₂ = idp
  map-++ (x :: l₁) l₂ = ap (f x ::_) (map-++ l₁ l₂)
{-
  reverse-map : ∀ l → reverse (map l) == map (reverse l)
  reverse-map nil = idp
  reverse-map (x :: l) = {! ! (map-++ (reverse l) (x :: nil)) !}
-}
-- These functions use different [A], [B] or [f].
module _ {i} {A : Type i} where
  -- [concat] in Haskell
  concat : List (List A) → List A
  concat l = foldr _++_ nil l


open import Signature
import Program

module Observations (Σ : Sig) (V : Set) (P : Program.Program Σ V) where

open import Terms Σ
open import Program Σ V
open import Rewrite Σ V P
open import Function
open import Relation.Nullary
open import Relation.Unary
open import Data.Product as Prod renaming (Σ to ⨿)
open import Streams hiding (_↓_)

-- | We will need _properly refining_ substitutions: σ properly refines t ∈ T V,
-- if ∀ v ∈ fv(t). σ(v) = f(α) for f ∈ Σ.
-- Then an observation step must go along a properly refining substitution,
-- which in turn allows us to construct a converging sequence of terms.

{- |
We can make an observation according to the following rule.

t ↓ s   fv(s) ≠ ∅    ∃ k, σ. s ~[σ]~ Pₕ(k)
--------------------------------------------
              t ----> t[σ]
-}
data _↦_ (t : T V) : T V → Set where
  obs-step : {s : T V} → t ↓ s → -- ¬ Empty (fv s) →
             (cl : dom P) {σ : Subst V V} →
             ProperlyRefining t σ → mgu s (geth P cl) σ →
             t ↦ app σ t

reduct : ∀{t s} → t ↦ s → T V
reduct (obs-step {s} _ _ _ _ ) = s

refining : ∀{t s} → t ↦ s → Subst V V
refining (obs-step _ _ {σ} _ _) = σ

is-refining : ∀{t s} (o : t ↦ s) → ProperlyRefining t (refining o)
is-refining (obs-step _ _ r _) = r

GroundTerm : Pred (T V) _
GroundTerm t = Empty (fv t)

--------
-- FLAW: This does not allow us to distinguish between inductive
-- and coinductive definitions on the clause level.
-- The following definitions are _global_ for a derivation!
-------

data IndDerivable (t : T V) : Set where
  ground : GroundTerm t → Valid t → IndDerivable t
  der-step : (s : T V) → t ↦ s → IndDerivable s → IndDerivable t

record CoindDerivable (t : T V) : Set where
  coinductive
  field
    term-SN : SN t
    der-obs : ⨿ (T V) λ s → t ↦ s × CoindDerivable s
open CoindDerivable public

obs-result : ∀{t} → CoindDerivable t → T V
obs-result = proj₁ ∘ der-obs

get-obs : ∀{t} (d : CoindDerivable t) → t ↦ (obs-result d)
get-obs = proj₁ ∘ proj₂ ∘ der-obs

-- | This should give us convergence to a term in T∞ V, see Terms.agda
coind-deriv-seq : (t : T V) → CoindDerivable t → ProperlyRefiningSeq t
hd-ref (coind-deriv-seq t d) = refining (get-obs d)
hd-is-ref (coind-deriv-seq t d) = is-refining (get-obs d)
tl-ref (coind-deriv-seq t d) with (der-obs d)
tl-ref (coind-deriv-seq t d) | ._ , obs-step red cl {σ} ref _ , d' =
  coind-deriv-seq (app σ t) d'


{-# OPTIONS --cubical --safe #-}

module Data.Finite where

open import Prelude
open import Data.Fin

𝒞 : Type a → Type a
𝒞 A = ∃ n × ∥ A ≃ Fin n ∥

ℂ : Type _
ℂ = Σ[ T ⦂ Type ] × 𝒞 T


{-# OPTIONS --type-in-type #-}

module NoUniverseCheck where

data M : Set -> Set where
  return : forall {a}   -> a -> M a
  _>>=_  : forall {a b} -> M a -> (a -> M b) -> M b

record Cat : Set where
  field
    Obj : Set
    Mor : Obj -> Obj -> Set

data _≡_ {a : Set} (x : a) : a -> Set where
  refl : x ≡ x

CatOfCat : Cat
CatOfCat = record
  { Obj = Cat
  ; Mor = _≡_
  }


-- Andreas, 2011-10-04
-- I'd like to infer the type of a even though it is irrelevant
-- E.g. when pressing C-c C-.
module InferIrrelevant where

f : (A : Set)(g : .A → A).(a : A) → A
f A g a = {!a!}


{-# OPTIONS --cubical --safe #-}

module Data.List.Sugar where

open import Data.List.Base
open import Prelude

[_] : A → List A
[ x ] = x ∷ []

pure : A → List A
pure = [_]

_>>=_ : List A → (A → List B) → List B
_>>=_ = flip concatMap

_>>_ : List A → List B → List B
xs >> ys = xs >>= const ys

_<*>_ : List (A → B) → List A → List B
fs <*> xs = do
  f ← fs
  x ← xs
  [ f x ]

guard : Bool → List ⊤
guard false = []
guard true  = [ tt ]

liftA2 : (A → B → C) → List A → List B → List C
liftA2 {A = A} {B = B} {C = C} f xs ys = go xs
  where
  go′ : A → List A → List B → List C
  go : List A → List C

  go′ x xs [] = go xs
  go′ x xs (y ∷ ys) = f x y ∷ go′ x xs ys

  go [] = []
  go (x ∷ xs) = go′ x xs ys


-- A memoised implementation of the Fibonacci sequence, following
-- Hinze's "Memo functions, polytypically!".

module Issue2918 where

open import Agda.Builtin.IO
open import Agda.Builtin.Nat renaming (Nat to ℕ)
open import Agda.Builtin.Size
open import Agda.Builtin.Unit

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B

open _×_ public

mutual

  data Nat (i : Size) : Set where
    zero : Nat i
    suc  : Nat′ i → Nat i

  data Nat′ (i : Size) : Set where
    [_] : {j : Size< i} → Nat j → Nat′ i

mutual

  ℕ→Nat : ℕ → Nat ∞
  ℕ→Nat zero    = zero
  ℕ→Nat (suc n) = suc (ℕ→Nat′ n)

  ℕ→Nat′ : ℕ → Nat′ ∞
  ℕ→Nat′ n = [ ℕ→Nat n ]

mutual

  Nat′[_]→ : Size → Set → Set
  Nat′[ i ]→ A = A × Nat′[ i ]→′ A

  record Nat′[_]→′ (i : Size) (A : Set) : Set where
    coinductive
    field
      force : {j : Size< i} → Nat′[ j ]→ A

open Nat′[_]→′ public

tabulate : ∀ {i} {A : Set} → (Nat′ i → A) → Nat′[ i ]→′ A
force (tabulate f) = f [ zero ] , tabulate (λ n → f [ suc n ])

lookup : ∀ {i} {A : Set} → Nat′[ i ]→′ A → Nat′ i → A
lookup t [ zero  ] = proj₁ (force t)
lookup t [ suc n ] = lookup (proj₂ (force t)) n

memo-fix :
  {A : Set} →
  (∀ {i} → (Nat′ i → A) → (Nat i → A)) →
  ∀ {i} → Nat′ i → A
memo-fix f =
  wrapper λ { [ n ] → f (lookup (tabulate (memo-fix f))) n }
  where
  wrapper : ∀ {i} {A : Set} → (Nat′ i → A) → (Nat′ i → A)
  wrapper f [ n ] = f [ n ]

fib-step : ∀ {i} → (Nat′ i → ℕ) → (Nat i → ℕ)
fib-step fib zero            = 0
fib-step fib (suc [ zero ])  = 1
fib-step fib (suc [ suc n ]) = fib n + fib [ suc n ]

fib : ℕ → ℕ
fib n = memo-fix fib-step [ ℕ→Nat n ]

postulate
  crash-after-ten-seconds : ℕ → IO ⊤

{-# FOREIGN GHC
  import qualified Control.Exception
  import qualified System.Timeout

  crashAfterTenSeconds c = do
    r <- System.Timeout.timeout (10 * 10^6)
                                (Control.Exception.evaluate c)
    case r of
      Nothing -> error "The computation timed out"
      Just _  -> return ()
  #-}

{-# COMPILE GHC crash-after-ten-seconds = crashAfterTenSeconds #-}

main : IO ⊤
main = crash-after-ten-seconds (fib 300)


-- Andreas, 2011-09-11
module Issue392 where

import Common.Irrelevance

-- Create an irrelevant record R1 (all fields irrelevant).
record R1 : Set1 where
  field
    .f1 : Set

{- module R1 .(r : R1) where
     .f1 : Set -- = R1.f1 r
-}

-- Create an irrelevant instance f2 of R1.
record R2 : Set2 where
  field
    .f2 : R1
    f3  : Set

-- This succeeds even though f2 is irrelevant.
  open R1 f2 public

{- A more realistic use would be s.th. like

  record IsEquivalence {a ℓ} {A : Set a}
                       (_≈_ : Rel A ℓ) : Set (a ⊔ ℓ) where
    field
      .refl  : Reflexive _≈_
      .sym   : Symmetric _≈_
      .trans : Transitive _≈_

  record Setoid c ℓ : Set (suc (c ⊔ ℓ)) where
    infix 4 _≈_
    field
      Carrier       : Set c
      _≈_           : Rel Carrier ℓ
      .isEquivalence : IsEquivalence _≈_

    open IsEquivalence isEquivalence public
-}