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

module ForAmr where

open import Level using (Level)

open import Relation.Nullary.Core
open import Data.Vec
  using (Vec; tabulate; []; _∷_; lookup; allFin)
  renaming (_++_ to _++V_; map to mapV; concat to concatV)
open import  Data.Vec.Properties
  using (lookup-++-≥; lookup∘tabulate; tabulate-∘; tabulate∘lookup; map-cong)
open import Function using (id;_∘_)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; cong; cong₂; subst; proof-irrelevance;
             _≗_; module ≡-Reasoning)
open import Data.Nat using (ℕ; zero; suc; _+_; z≤n; _≟_)
open import Data.Nat.Properties.Simple using (+-comm)
open import Data.Nat.Properties using (m≤m+n)
open import Data.Fin using (Fin; zero; suc; inject+; raise; reduce≥; toℕ; fromℕ≤)
open import Data.Fin.Properties using (toℕ-injective; toℕ-raise; toℕ-fromℕ≤)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (proj₁)
open import Function using (flip)

open import Proofs
open import Equiv
open import FinEquiv
open import Cauchy
open import TypeEquiv using (swap₊; swapswap₊)

----------------------------------------------------

-- and now this is completely obvious.  But not actually needed!
swap+-idemp : {A B : Set} → {m n : ℕ} → (v : Vec (A ⊎ B) (m + n)) →
  swap+ {m} (swap+ {m} v) ≡ v
swap+-idemp v =
  begin (
    tabulate (λ i → swap₊ (tabulate (λ j → swap₊ (v !! j)) !! i))
        ≡⟨ denest-tab-!! swap₊ swap₊ v ⟩
    mapV (swap₊ ∘ swap₊) v
        ≡⟨ map-cong swapswap₊ v ⟩
    mapV id v
        ≡⟨ map-id v ⟩
    v ∎)
  where open ≡-Reasoning

-- because this is 'pointwise', no need for swap+-idemp.
pointwise-swap+v-idemp : {m n : ℕ} → ∀ i →
  lookup (lookup i (swap+v m n)) (swap+v n m) ≡ i
pointwise-swap+v-idemp {m} {n} i =
  let fnm = swapper n m in
  let fmn = swapper m n in
  begin (
    lookup (lookup i (swap+v m n)) (swap+v n m)
      ≡⟨ cong (λ x → lookup x (swap+v n m)) (lookup∘tabulate fmn i) ⟩
    lookup (fmn i) (swap+v n m)
      ≡⟨ lookup∘tabulate fnm (fmn i) ⟩
    fnm (fmn i) -- bingo!
      ≡⟨ cong (fwd ∘ swap₊) (bwd∘fwd~id (swap₊ (bwd {m} i))) ⟩
    fwd (swap₊ (swap₊ (bwd {m} i)))
      ≡⟨ cong fwd (swapswap₊ (bwd {m} i)) ⟩
    fwd (bwd {m} i)
      ≡⟨ fwd∘bwd~id {m} i ⟩
    i ∎ )
  where open ≡-Reasoning

-- this is true, but the above is what is used in practice.
swap+v-idemp : {m n : ℕ} →
  tabulate (λ i → lookup (lookup i (swap+v m n)) (swap+v n m)) ≡ tabulate id
swap+v-idemp {m} = finext (pointwise-swap+v-idemp {m})

---------------------------------------------------------------
-- Everything below here is based on Cauchy as Vec (Fin n) n
-- and might get tossed.  Comment it out for now.

{-
-- the Cauchy version.
swap+c : (m n : ℕ) → Cauchy (m + n)
swap+c m n = subst (λ x → Vec (Fin x) (m + n)) (+-comm n m) (swap+v m n)

-- the action of subst on swap+, pointwise
switch-swap+ : {m n : ℕ} → (i : Fin (m + n)) →
  subst Fin (+-comm n m) (swapper m n i) ≡
  swapper n m (subst Fin (+-comm m n) i)
switch-swap+ {m} {n} i with m ≟ n
switch-swap+ i | yes p = {!!}
switch-swap+ i | no ¬p = {!!}
{-
switch-swap+ {m} {n} i with (toℕ i <? m) | (toℕ (subst Fin (+-comm m n) i) <? n)
switch-swap+ {m} {n} i | yes p | yes q = {!!} {- toℕ-injective (
  begin (
    toℕ (subst Fin (+-comm n m) (raise n (fromℕ≤ p)))
      ≡⟨ toℕ-invariance (raise n (fromℕ≤ p)) (+-comm n m) ⟩
    toℕ (raise n (fromℕ≤ p))
      ≡⟨ toℕ-raise n (fromℕ≤ p) ⟩
    n + toℕ (fromℕ≤ p)
      ≡⟨ cong (_+_ n) (toℕ-fromℕ≤ p) ⟩
    n + toℕ i
      ≡⟨ {!!} ⟩
    m + toℕ (subst Fin (+-comm m n) i)
      ≡⟨ sym (cong (_+_ m) (toℕ-fromℕ≤ q)) ⟩
    m + toℕ (fromℕ≤ q)
      ≡⟨ sym (toℕ-raise m (fromℕ≤ q)) ⟩
    toℕ (raise m (fromℕ≤ q)) ∎))
  where open ≡-Reasoning -}
switch-swap+ i | yes p | no ¬q = {!!}
switch-swap+ i | no ¬p | yes q = {!!}
switch-swap+ i | no ¬p | no ¬q = {!!}
-}

-- the Cauchy version:
pcomp' : ∀ {m n} → Cauchy m → Cauchy n → Cauchy (m + n)
pcomp' α β = mapV fwd (pcomp α β)

-- the action of subst on swap+v
switch-swap : {m n : ℕ} → (i : Fin (m + n)) →
  subst Fin (+-comm n m) ((swap+v m n) !! i) ≡
  (swap+v n m) !! subst Fin (+-comm m n) i
switch-swap {m} {n} i =
  let fnm = swapper n m in
  let fmn = swapper m n in
  begin (
    subst Fin (+-comm n m) ((tabulate fmn) !! i)
      ≡⟨ cong (subst Fin (+-comm n m)) (lookup∘tabulate fmn i) ⟩
    subst Fin (+-comm n m) (fmn i)
      ≡⟨ switch-swap+ {m} i ⟩
    fnm (subst Fin (+-comm m n) i)
      ≡⟨ sym (lookup∘tabulate fnm (subst Fin (+-comm m n) i)) ⟩
    tabulate (fnm) !! subst Fin (+-comm m n) i ∎)
  where open ≡-Reasoning

-- the crucial part for the next theorem:
swap+-idemp' : {m n : ℕ} → ∀ (i : Fin (m + n)) → lookup
      (subst (λ x → Vec (Fin x) (m + n)) (+-comm n m) (swap+v m n) !! i)
      (subst (λ x → Vec (Fin x) (m + n)) (+-comm n m) (swap+v m n))
      ≡ i
swap+-idemp' {m} {n} i =
  let j = subst (λ x → Vec (Fin x) (m + n)) (+-comm n m) (swap+v m n) !! i in
  begin (
    lookup j (subst (λ x → Vec (Fin x) (m + n)) (+-comm n m) (swap+v m n))
      ≡⟨ lookup-subst j (swap+v m n) (+-comm n m) ⟩
    subst Fin (+-comm n m) ((swap+v m n) !! j)
      ≡⟨ cong (λ x → subst Fin (+-comm n m) ((swap+v m n) !! x))
                   (lookup-subst i (swap+v m n) (+-comm n m)) ⟩
    subst Fin (+-comm n m) ((swap+v m n) !! subst Fin (+-comm n m) (swap+v m n !! i))
      ≡⟨ cong (λ x → subst Fin (+-comm n m) ((swap+v m n) !! x))
                   (switch-swap {m} i) ⟩
    subst Fin (+-comm n m) ((swap+v m n) !! (swap+v n m !! subst Fin (+-comm m n) i))
      ≡⟨ cong (subst Fin (+-comm n m)) (pointwise-swap+v-idemp {n} (subst Fin (+-comm m n) i)) ⟩
    subst Fin (+-comm n m) (subst Fin (+-comm m n) i)
      ≡⟨ subst-subst (+-comm n m) (+-comm m n)
                              (proof-irrelevance (sym (+-comm n m)) (+-comm m n)) i ⟩
    i ∎)
  where open ≡-Reasoning

-- and let's see what that does to the Cauchy version:
swap+c-idemp : {m n : ℕ} → scompcauchy (swap+c m n) (swap+c m n) ≡ allFin (m + n)
swap+c-idemp  {m} {n} = finext (swap+-idemp' {m} {n})
-}


open import Nat
open import Prelude
open import core
open import checks
open import judgemental-erase

module structural where
  -- this module contains proofs that the judgements that mention contexts
  -- defined throughout the work enjoy the standard structural properties
  -- of contexts:
  --
  -- exchange
  --
  -- Γ, (x : t1), (y : t2) ⊢ A
  -- -------------------------
  -- Γ, (y : t2), (x : t1) ⊢ A
  --
  -- contraction
  --
  -- Γ, (x : t), (x : t) ⊢ A
  -- -----------------------
  --     Γ , (x : t) ⊢ A
  --
  -- weakening
  --
  --   Γ ⊢ A      x # Γ
  -- ----------------------
  --    Γ , (x : t) ⊢ A
  --
  -- proofs of the first two are generally easier: viewed as finite
  -- functions, the contexts on the top and bottom of both exchange answer
  -- every question the same, so an appeal to function extensionality is
  -- enough to treat them the same. weakening does not have this property,
  -- and there requires some induction to demonstrate.

  -- because of our choice to use barendrecht's convention, we need a quite
  -- strong form of freshness of a variable for weakening. specifically, we
  -- need to know not just that the variable we're using to extend the
  -- context doesn't appear in the context, as in a standard presentation,
  -- it can't appear anywhere in the term at all; it must be totally
  -- fresh. it's possible to drop this requirement with alpha-renaming to
  -- recover the standard description of these things, so we allow it here
  -- for convenience.
  fresh : Nat → ė → Set
  fresh x (e ·: t) = fresh x e
  fresh x (X y) = natEQp x y
  fresh x (·λ y e) = natEQp x y × fresh x e
  fresh x (N n) = ⊤
  fresh x (e1 ·+ e2) = fresh x e1 × fresh x e2
  fresh x ⦇-⦈ = ⊤
  fresh x ⦇⌜ e ⌟⦈ = fresh x e
  fresh x (e1 ∘ e2) = fresh x e1 × fresh x e2

  ---- lemmas

  -- freshness interacts with erasure as you'd expect. the proofs below mix
  -- and match between judgmental and functional erasure as usual, so this
  -- is needed enough times to pull it out.
  fresh-er-lem : ∀{ e e◆ x} → erase-e e e◆ → fresh x (e ◆e) → fresh x e◆
  fresh-er-lem er f = tr (λ q → fresh _ q) ( ! (erasee-det er (rel◆ _))) f

  --- a contracted context gives all the same responses as the
  --- non-contracted context
  lem-contract : (Γ : ·ctx) (x : Nat) (t : τ̇) (y : Nat) →
         ((Γ ,, (x , t)) ,, (x , t)) y == (Γ ,, (x , t)) y
  lem-contract Γ x t y with natEQ x y
  lem-contract Γ x t .x | Inl refl = refl
  ... | Inr qq with natEQ x y
  ... | Inl pp = abort (qq pp)
  ... | Inr pp = refl

  --- an exchanged context gives all the same responses as the
  --- non-exchanged context
  lem-swap : (Γ : ·ctx) (x y : Nat) (t1 t2 : τ̇) {x≠y : x == y → ⊥}  (z : Nat) →
         ((Γ ,, (x , t1)) ,, (y , t2)) z == ((Γ ,, (y , t2)) ,, (x , t1)) z
  lem-swap Γ x y t1 t2 z with natEQ x z | natEQ y z
  lem-swap Γ x y t1 t2 {x≠y} z | Inl p | Inl q = abort (x≠y (p · ! q))
  lem-swap Γ x y t1 t2 .x | Inl refl | Inr x₂ with natEQ x x
  lem-swap Γ x y t1 t2 .x | Inl refl | Inr x₂ | Inl refl = refl
  lem-swap Γ x y t1 t2 .x | Inl refl | Inr x₂ | Inr x₁ = abort (x₁ refl)
  lem-swap Γ x y t1 t2 .y | Inr x₁ | Inl refl with natEQ y y
  lem-swap Γ x₁ y t1 t2 .y | Inr x₂ | Inl refl | Inl refl = refl
  lem-swap Γ x₁ y t1 t2 .y | Inr x₂ | Inl refl | Inr x = abort (x refl)
  lem-swap Γ x y t1 t2 z | Inr x₁ | Inr x₂ with natEQ x z | natEQ y z
  lem-swap Γ x .x t1 t2 .x | Inr x₂ | Inr x₃ | Inl refl | Inl refl = abort (x₃ refl)
  lem-swap Γ x y t1 t2 .x | Inr x₂ | Inr x₃ | Inl refl | Inr x₁ = abort (x₂ refl)
  lem-swap Γ x y t1 t2 z | Inr x₃ | Inr x₄ | Inr x₁ | Inl x₂ = abort (x₄ x₂)
  lem-swap Γ x y t1 t2 z | Inr x₃ | Inr x₄ | Inr x₁ | Inr x₂ = refl

  -- extending a context with a new variable doesn't change anything under
  lem-extend : ∀{n x Γ t w} →
               (n == x → ⊥) → Γ n == w → (Γ ,, (x , t)) n == w
  lem-extend {n} {x} neq w with natEQ x n
  lem-extend neq w₁ | Inl refl = abort (neq refl)
  lem-extend neq w₁ | Inr x₁ = w₁

  ---- structural properties for the well-typedness jugements
  mutual
    wt-exchange-synth : {Γ : ·ctx} {x y : Nat} {t1 t2 t : τ̇} {e : ė} →
                        {x≠y : x == y → ⊥} →
                        ((Γ ,, (x , t1)) ,, (y , t2)) ⊢ e => t →
                        ((Γ ,, (y , t2)) ,, (x , t1)) ⊢ e => t
    wt-exchange-synth {Γ} {x} {y} {t1} {t2} {t} {e} {x≠y} d =
      tr (λ q → q ⊢ e => t) (funext (lem-swap Γ x y t1 t2 {x≠y = x≠y})) d

    wt-exchange-ana : {Γ : ·ctx} {x y : Nat} {t1 t2 t : τ̇} {e : ė} →
                        (x≠y : x == y → ⊥) →
                        ((Γ ,, (x , t1)) ,, (y , t2)) ⊢ e <= t →
                        ((Γ ,, (y , t2)) ,, (x , t1)) ⊢ e <= t
    wt-exchange-ana {Γ} {x} {y} {t1} {t2} {t} {e} x≠y d =
      tr (λ q → q ⊢ e <= t) (funext (lem-swap Γ x y t1 t2 {x≠y = x≠y})) d

  mutual
    wt-contract-synth : {Γ : ·ctx} {x : Nat} {t t' : τ̇} {e : ė} →
                    ((Γ ,, (x , t')) ,, (x , t')) ⊢ e => t →
                    (Γ ,, (x , t')) ⊢ e => t
    wt-contract-synth {Γ} {x} {t} {t'} {e}  wt =
         tr (λ q → q ⊢ e => t) (funext (lem-contract Γ x t')) wt

    wt-contract-ana : (Γ : ·ctx) (x : Nat) (t t' : τ̇) (e : ė) →
                    ((Γ ,, (x , t')) ,, (x , t')) ⊢ e <= t →
                    (Γ ,, (x , t')) ⊢ e <= t
    wt-contract-ana Γ x t t' e wt =
         tr (λ q → q ⊢ e <= t) (funext (lem-contract Γ x t')) wt

  mutual
    wt-weak-synth : {Γ : ·ctx} {x : Nat} {t t' : τ̇} {e : ė} →
                    x # Γ →
                    Γ ⊢ e => t →
                    fresh x e →
                    (Γ ,, (x , t')) ⊢ e => t
    wt-weak-synth apt (SAsc x₁) f = SAsc (wt-weak-ana apt x₁ f)
    wt-weak-synth {x = x} apt (SVar {n = n} x₁) f with natEQ n x
    wt-weak-synth apt (SVar x₂) f | Inl refl = abort (somenotnone (! x₂ · apt))
    wt-weak-synth apt (SVar x₂) f | Inr x₁ = SVar (lem-extend x₁ x₂)
    wt-weak-synth apt (SAp wt x₁ x₂) (f1 , f2) = SAp (wt-weak-synth apt wt f1) x₁ (wt-weak-ana apt x₂ f2)
    wt-weak-synth apt SNum f = SNum
    wt-weak-synth apt (SPlus x₁ x₂) (f1 , f2) = SPlus (wt-weak-ana apt x₁ f1) (wt-weak-ana apt x₂ f2)
    wt-weak-synth apt SEHole f = SEHole
    wt-weak-synth apt (SNEHole wt) f = SNEHole (wt-weak-synth apt wt f)

    wt-weak-ana : {Γ : ·ctx} {x : Nat} {t t' : τ̇} {e : ė} →
                    x # Γ →
                    Γ ⊢ e <= t →
                    fresh x e →
                    (Γ ,, (x , t')) ⊢ e <= t
    wt-weak-ana apt (ASubsume x₁ x₂) f = ASubsume (wt-weak-synth apt x₁ f) x₂
    wt-weak-ana {x = x} apt (ALam {x = x₁} x₂ x₃ wt) f with natEQ x x₁
    wt-weak-ana apt (ALam x₃ x₄ wt) (f1 , _) | Inl refl = abort f1
    wt-weak-ana apt (ALam x₃ m wt) (f1 , f2) | Inr x₂ = ALam (lem-extend (flip x₂) x₃) m (wt-exchange-ana (flip x₂) (wt-weak-ana (lem-extend x₂ apt) wt f2))

  ---- structural properties for the action jugements
  mutual
    act-exchange-synth : ∀{ Γ x y t1 t2 t t' e e' α } →
                         (x == y → ⊥) →
                         ((Γ ,, (x , t1)) ,, (y , t2)) ⊢ e => t ~ α ~> e' => t' →
                         ((Γ ,, (y , t2)) ,, (x , t1)) ⊢ e => t ~ α ~> e' => t'
    act-exchange-synth {Γ} {x} {y} {t1} {t2} {t} {t'} {e} {e'} {α} x≠y d = tr (λ q → q ⊢ e => t ~ α ~> e' => t') (funext (lem-swap Γ x y t1 t2 {x≠y})) d

    act-exchange-ana :  ∀{ Γ x y t1 t2 t e e' α } →
                         (x == y → ⊥) →
                         ((Γ ,, (x , t1)) ,, (y , t2)) ⊢ e ~ α ~> e' ⇐ t →
                         ((Γ ,, (y , t2)) ,, (x , t1)) ⊢ e ~ α ~> e' ⇐ t
    act-exchange-ana {Γ} {x} {y} {t1} {t2} {t} {e} {e'} {α} x≠y d = tr (λ q → q ⊢ e ~ α ~> e' ⇐ t) (funext (lem-swap Γ x y t1 t2 {x≠y})) d

  mutual
    act-contract-synth : ∀{ Γ x t t' t'' e e' α } →
                         ((Γ ,, (x , t'')) ,, (x , t'')) ⊢ e => t ~ α ~> e' => t' →
                         (Γ ,, (x , t'')) ⊢ e => t ~ α ~> e' => t'
    act-contract-synth {Γ} {x} {t} {t'} {t''} {e} {e'} {α} d = tr (λ q → q ⊢ e => t ~ α ~> e' => t') (funext (lem-contract Γ x t'')) d

    act-contract-ana : ∀{ Γ x t t' e e' α } →
                         ((Γ ,, (x , t')) ,, (x , t')) ⊢ e ~ α ~> e' ⇐ t →
                         (Γ ,, (x , t')) ⊢ e ~ α ~> e' ⇐ t
    act-contract-ana {Γ} {x} {t} {t'} {e} {e'} {α} d = tr (λ q → q ⊢ e ~ α ~> e' ⇐ t) (funext (lem-contract Γ x t')) d

  mutual
    act-weak-synth : ∀{ Γ x t t' t'' e e' α } →
                         x # Γ →
                         fresh x (e ◆e) →
                         fresh x (e' ◆e) →
                         (d : Γ ⊢ e => t ~ α ~> e' => t') →
                         (Γ ,, (x , t'')) ⊢ e => t ~ α ~> e' => t'
    act-weak-synth apt f f' (SAMove x₁) = SAMove x₁
    act-weak-synth apt f f' SADel = SADel
    act-weak-synth apt f f' SAConAsc = SAConAsc
    act-weak-synth {x = x} apt f f' (SAConVar {x = y} p) with natEQ x y
    act-weak-synth apt f f' (SAConVar p) | Inl refl = abort (somenotnone (! p · apt))
    act-weak-synth apt f f' (SAConVar p) | Inr x₂ = SAConVar (lem-extend (flip x₂) p)
    act-weak-synth {x = x} apt f f' (SAConLam {x = y} x₂) with natEQ x y
    act-weak-synth apt f f' (SAConLam x₃) | Inl refl = abort (π1 f')
    act-weak-synth apt f f' (SAConLam x₃) | Inr x₂ = SAConLam (lem-extend (flip x₂) x₃)
    act-weak-synth apt f f' (SAConApArr x₁) = SAConApArr x₁
    act-weak-synth apt f f' (SAConApOtw x₁) = SAConApOtw x₁
    act-weak-synth apt f f' SAConNumlit = SAConNumlit
    act-weak-synth apt f f' (SAConPlus1 x₁) = SAConPlus1 x₁
    act-weak-synth apt f f' (SAConPlus2 x₁) = SAConPlus2 x₁
    act-weak-synth apt f f' SAConNEHole = SAConNEHole
    act-weak-synth apt f f' (SAFinish x₁) = SAFinish (wt-weak-synth apt x₁ f')
    act-weak-synth apt f f' (SAZipAsc1 x₁) = SAZipAsc1 (act-weak-ana apt f f' x₁)
    act-weak-synth apt f f' (SAZipAsc2 x₁ x₂ x₃ x₄) = SAZipAsc2 x₁ x₂ x₃ (wt-weak-ana apt x₄ f')
    act-weak-synth apt f f' (SAZipApArr x₁ x₂ x₃ d x₄) = SAZipApArr x₁ x₂ (wt-weak-synth apt x₃ (fresh-er-lem x₂ (π1 f)))
                                                                          (act-weak-synth apt (π1 f) (π1 f') d)
                                                                          (wt-weak-ana apt x₄ (π2 f'))
    act-weak-synth apt f f' (SAZipApAna x₁ x₂ x₃) = SAZipApAna x₁ (wt-weak-synth apt x₂ (π1 f'))
                                                                  (act-weak-ana apt (π2 f) (π2 f') x₃)
    act-weak-synth apt f f' (SAZipPlus1 x₁) = SAZipPlus1 (act-weak-ana apt (π1 f) (π1 f') x₁)
    act-weak-synth apt f f' (SAZipPlus2 x₁) = SAZipPlus2 (act-weak-ana apt (π2 f) (π2 f') x₁)
    act-weak-synth apt f f' (SAZipHole x₁ x₂ d) = SAZipHole x₁ (wt-weak-synth apt x₂ (fresh-er-lem x₁ f))
                                                               (act-weak-synth apt f f' d)

    act-weak-ana : ∀{ Γ x t t' e e' α } →
                         x # Γ →
                         fresh x (e ◆e) →
                         fresh x (e' ◆e) →
                         (d : Γ ⊢ e ~ α ~> e' ⇐ t) →
                         (Γ ,, (x , t')) ⊢ e ~ α ~> e' ⇐ t
    act-weak-ana apt f f' (AASubsume x₁ x₂ x₃ x₄) = AASubsume x₁ (wt-weak-synth apt x₂ (fresh-er-lem x₁ f)) (act-weak-synth apt f f' x₃) x₄
    act-weak-ana apt f f' (AAMove x₁) = AAMove x₁
    act-weak-ana apt f f' AADel = AADel
    act-weak-ana apt f f' AAConAsc = AAConAsc
    act-weak-ana {x = x} apt f f' (AAConVar {x = y} x₂ p) with natEQ x y
    act-weak-ana apt f f' (AAConVar x₃ p) | Inl refl = abort (somenotnone (! p · apt))
    act-weak-ana apt f f' (AAConVar x₃ p) | Inr x₂ = AAConVar x₃ (lem-extend (flip x₂) p)
    act-weak-ana {x = x} apt f f' (AAConLam1 {x = y} x₂ x₃) with natEQ x y
    act-weak-ana apt f f' (AAConLam1 x₃ x₄) | Inl refl = abort (π1 f')
    act-weak-ana apt f f' (AAConLam1 x₃ x₄) | Inr x₂ = AAConLam1 (lem-extend (flip x₂) x₃) x₄
    act-weak-ana {x = x} apt f f' (AAConLam2 {x = y} x₂ x₃) with natEQ x y
    act-weak-ana apt f f' (AAConLam2 x₃ x₄) | Inl refl = abort (π1 f')
    act-weak-ana apt f f' (AAConLam2 x₃ x₄) | Inr x₂ = AAConLam2 (lem-extend (flip x₂) x₃) x₄
    act-weak-ana apt f f' (AAConNumlit x₁) = AAConNumlit x₁
    act-weak-ana apt f f' (AAFinish x₁) = AAFinish (wt-weak-ana apt x₁ f')
    act-weak-ana {x = x} apt f f' (AAZipLam {x = y} x₂ x₃ d) with natEQ x y
    act-weak-ana apt f f' (AAZipLam x₃ x₄ d) | Inl refl = abort (π1 f')
    act-weak-ana apt f f' (AAZipLam x₃ x₄ d) | Inr x₂ = AAZipLam (lem-extend (flip x₂) x₃) x₄ (act-exchange-ana (flip x₂) (act-weak-ana (lem-extend x₂ apt) (π2 f) (π2 f') d))


{-# OPTIONS --cubical #-}

module Integer.Univalence where

open import Cubical.Foundations.NTypes
open import Data.Empty
open import Data.Product as Σ
open import Data.Product.Relation.Pointwise.NonDependent
open import Data.Unit
open import Equality
open import Function
open import Integer.Difference as D
open import Integer.Signed as S
open import Natural as ℕ
open import Quotient as /
open import Syntax
open import Relation.Nullary

zero≢suc : ∀ {m} → ¬ (zero ≡ suc m)
zero≢suc p = case ⟪ p ⟫ of λ ()

⟦D→S⟧ : D.⟦ℤ⟧ → S.⟦ℤ⟧
⟦D→S⟧ (a – zero) = +1* a
⟦D→S⟧ (zero – b) = -1* b
⟦D→S⟧ (suc a – suc b) = ⟦D→S⟧ (a – b)

D→S : D.ℤ → S.ℤ
D→S = ⟦D→S⟧ // line
  where
    line : ∀ x y → x D.≈ y → ⟦D→S⟧ x S.≈ ⟦D→S⟧ y
    line (zero – zero) (zero – zero) p = refl
    line (zero – zero) (zero – suc d) p = refl , p
    line (zero – zero) (suc c – zero) p = compPath p (cong suc ⟨ +-identityʳ c ⟩)
    line (zero – b) (suc c – suc d) p = line (zero – b) (c – d) ⟨ suc-injective ⟪ p ⟫ ⟩
    line (suc a – suc b) (zero – d) p = line (a – b) (zero – d) ⟨ suc-injective ⟪ p ⟫ ⟩
    line (zero – suc b) (zero – zero) p = sym p , refl
    line (zero – suc b) (zero – suc d) p = sym p
    line (zero – suc b) (suc c – zero) p = case ⟪ p ⟫ of λ ()
    line (suc a – zero) (zero – d) p = case ⟪ p ⟫ of λ ()
    line (suc a – zero) (suc c – zero) p =
        suc a
      ≡⟨ cong suc (sym ⟨ +-identityʳ a ⟩) ⟩
        suc (a + 0)
      ≡⟨ p ⟩
        suc (c + 0)
      ≡⟨ cong suc ⟨ +-identityʳ c ⟩ ⟩
        suc c
      ∎
    line (suc a – b) (suc c – suc d) p =
      line (suc a – b) (c – d)
        ⟨ suc-injective ⟪ compPath (cong suc (sym (+-suc a d))) p ⟫ ⟩
    line (suc a – suc b) (suc c – d) p =
      line (a – b) (suc c – d)
        ⟨ suc-injective ⟪ compPath p (cong suc (+-suc c b)) ⟫ ⟩

⟦S→D⟧ : S.⟦ℤ⟧ → D.⟦ℤ⟧
⟦S→D⟧ (+1* a) = a – zero
⟦S→D⟧ (-1* a) = zero – a

⟦D→S→D⟧ : ∀ x → ⟦S→D⟧ (⟦D→S⟧ x) D.≈ x
⟦D→S→D⟧ (zero – zero) = refl
⟦D→S→D⟧ (zero – suc b) = refl
⟦D→S→D⟧ (suc a – zero) = refl
⟦D→S→D⟧ (suc a – suc b) =
  let m , n = ⟦S→D⟧ (⟦D→S⟧ (a – b)) in
      m + suc b
    ≡⟨ +-suc m b ⟩
      suc (m + b)
    ≡⟨ cong suc (⟦D→S→D⟧ (a – b)) ⟩
      suc (a + n)
    ∎

⟦S→D→S⟧ : ∀ x → ⟦D→S⟧ (⟦S→D⟧ x) S.≈ x
⟦S→D→S⟧ (+1* x) = refl
⟦S→D→S⟧ (-1* zero) = refl , refl
⟦S→D→S⟧ (-1* suc x) = refl

cong-⟦S→D⟧ : ∀ x y → x S.≈ y → ⟦S→D⟧ x D.≈ ⟦S→D⟧ y
cong-⟦S→D⟧ (+1* x) (+1* y) = cong (_+ zero)
cong-⟦S→D⟧ (-1* x) (-1* y) = sym
cong-⟦S→D⟧ (+1* x) (-1* y) = Σ.uncurry (cong₂ _+_)
cong-⟦S→D⟧ (-1* x) (+1* y) (p , q) = compPath (sym (cong₂ _+_ p q)) ⟨ +-comm x y ⟩

cong-⟦D→S⟧ : ∀ x y → x D.≈ y → ⟦D→S⟧ x S.≈ ⟦D→S⟧ y
cong-⟦D→S⟧ (zero – zero) (zero – zero) p = refl
cong-⟦D→S⟧ (zero – zero) (zero – suc d) p = refl , p
cong-⟦D→S⟧ (zero – zero) (suc c – zero) p = compPath p (cong suc ⟨ +-identityʳ c ⟩)
cong-⟦D→S⟧ (zero – b) (suc c – suc d) p = cong-⟦D→S⟧ (zero – b) (c – d) ⟨ suc-injective ⟪ p ⟫ ⟩
cong-⟦D→S⟧ (suc a – suc b) (zero – d) p = cong-⟦D→S⟧ (a – b) (zero – d) ⟨ suc-injective ⟪ p ⟫ ⟩
cong-⟦D→S⟧ (zero – suc b) (zero – zero) p = sym p , refl
cong-⟦D→S⟧ (zero – suc b) (zero – suc d) p = sym p
cong-⟦D→S⟧ (zero – suc b) (suc c – zero) p = case ⟪ p ⟫ of λ ()
cong-⟦D→S⟧ (suc a – zero) (zero – d) p = case ⟪ p ⟫ of λ ()
cong-⟦D→S⟧ (suc a – zero) (suc c – zero) p =
    suc a
  ≡⟨ cong suc (sym ⟨ +-identityʳ a ⟩) ⟩
    suc (a + 0)
  ≡⟨ p ⟩
    suc (c + 0)
  ≡⟨ cong suc ⟨ +-identityʳ c ⟩ ⟩
    suc c
  ∎
cong-⟦D→S⟧ (suc a – b) (suc c – suc d) p =
  cong-⟦D→S⟧ (suc a – b) (c – d)
    ⟨ suc-injective ⟪ compPath (cong suc (sym (+-suc a d))) p ⟫ ⟩
cong-⟦D→S⟧ (suc a – suc b) (suc c – d) p =
  cong-⟦D→S⟧ (a – b) (suc c – d)
    ⟨ suc-injective ⟪ compPath p (cong suc (+-suc c b)) ⟫ ⟩

Signed≡Difference : S.ℤ ≡ D.ℤ
Signed≡Difference = ua (isoToEquiv ⟦S→D⟧ ⟦D→S⟧ cong-⟦S→D⟧ cong-⟦D→S⟧ ⟦S→D→S⟧ ⟦D→S→D⟧)


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

module higher where

open import higher.circle public


module Zipper where

  import Derivative
  import Functor
  import Sets

  open Functor
  open Derivative
  open Semantics
  open Recursive
  open Sets

  Zipper : U -> Set
  Zipper F = List (⟦ ∂ F ⟧ (μ F))

  -- Plugging a zipper
  unzip : {F : U} -> Zipper F -> μ F -> μ F
  unzip	    []	     t = t
  unzip {F} (c :: γ) t = inn (plug-∂ F c (unzip γ t))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Coinductive vectors
------------------------------------------------------------------------

module Data.Covec where

open import Coinduction
open import Data.Nat using (ℕ; zero; suc)
open import Data.Conat as Coℕ using (Coℕ; zero; suc; _+_)
open import Data.Cofin using (Cofin; zero; suc)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Colist as Colist using (Colist; []; _∷_)
open import Data.Product using (_,_)
open import Relation.Binary

------------------------------------------------------------------------
-- The type

infixr 5 _∷_

data Covec (A : Set) : Coℕ → Set where
  []  : Covec A zero
  _∷_ : ∀ {n} (x : A) (xs : ∞ (Covec A (♭ n))) → Covec A (suc n)

------------------------------------------------------------------------
-- Some operations

map : ∀ {A B n} → (A → B) → Covec A n → Covec B n
map f []       = []
map f (x ∷ xs) = f x ∷ ♯ map f (♭ xs)

fromVec : ∀ {A n} → Vec A n → Covec A (Coℕ.fromℕ n)
fromVec []       = []
fromVec (x ∷ xs) = x ∷ ♯ fromVec xs

fromColist : ∀ {A} (xs : Colist A) → Covec A (Colist.length xs)
fromColist []       = []
fromColist (x ∷ xs) = x ∷ ♯ fromColist (♭ xs)

take : ∀ {A} m {n} → Covec A (m + n) → Covec A m
take zero    xs       = []
take (suc n) (x ∷ xs) = x ∷ ♯ take (♭ n) (♭ xs)

drop : ∀ {A} m {n} → Covec A (Coℕ.fromℕ m + n) → Covec A n
drop zero    xs       = xs
drop (suc n) (x ∷ xs) = drop n (♭ xs)

replicate : ∀ {A} n → A → Covec A n
replicate zero    x = []
replicate (suc n) x = x ∷ ♯ replicate (♭ n) x

lookup : ∀ {A n} → Cofin n → Covec A n → A
lookup zero    (x ∷ xs) = x
lookup (suc n) (x ∷ xs) = lookup n (♭ xs)

infixr 5 _++_

_++_ : ∀ {A m n} → Covec A m → Covec A n → Covec A (m + n)
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ ♯ (♭ xs ++ ys)

[_] : ∀ {A} → A → Covec A (suc (♯ zero))
[ x ] = x ∷ ♯ []

------------------------------------------------------------------------
-- Equality and other relations

-- xs ≈ ys means that xs and ys are equal.

infix 4 _≈_

data _≈_ {A} : ∀ {n} (xs ys : Covec A n) → Set where
  []  : [] ≈ []
  _∷_ : ∀ {n} x {xs ys}
        (xs≈ : ∞ (♭ xs ≈ ♭ ys)) → _≈_ {n = suc n} (x ∷ xs) (x ∷ ys)

-- x ∈ xs means that x is a member of xs.

infix 4 _∈_

data _∈_ {A} : ∀ {n} → A → Covec A n → Set where
  here  : ∀ {n x  } {xs}                   → _∈_ {n = suc n} x (x ∷ xs)
  there : ∀ {n x y} {xs} (x∈xs : x ∈ ♭ xs) → _∈_ {n = suc n} x (y ∷ xs)

-- xs ⊑ ys means that xs is a prefix of ys.

infix 4 _⊑_

data _⊑_ {A} : ∀ {m n} → Covec A m → Covec A n → Set where
  []  : ∀ {n} {ys : Covec A n} → [] ⊑ ys
  _∷_ : ∀ {m n} x {xs ys} (p : ∞ (♭ xs ⊑ ♭ ys)) →
        _⊑_ {m = suc m} {suc n} (x ∷ xs) (x ∷ ys)

------------------------------------------------------------------------
-- Some proofs

setoid : Set → Coℕ → Setoid _ _
setoid A n = record
  { Carrier       = Covec A n
  ; _≈_           = _≈_
  ; isEquivalence = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  }
  where
  refl : ∀ {A n} → Reflexive (_≈_ {A} {n})
  refl {x = []}     = []
  refl {x = x ∷ xs} = x ∷ ♯ refl

  sym : ∀ {A n} → Symmetric (_≈_ {A} {n})
  sym []        = []
  sym (x ∷ xs≈) = x ∷ ♯ sym (♭ xs≈)

  trans : ∀ {A n} → Transitive (_≈_ {A} {n})
  trans []        []         = []
  trans (x ∷ xs≈) (.x ∷ ys≈) = x ∷ ♯ trans (♭ xs≈) (♭ ys≈)

poset : Set → Coℕ → Poset _ _ _
poset A n = record
  { Carrier        = Covec A n
  ; _≈_            = _≈_
  ; _≤_            = _⊑_
  ; isPartialOrder = record
    { isPreorder = record
      { isEquivalence = Setoid.isEquivalence (setoid A n)
      ; reflexive     = reflexive
      ; trans         = trans
      }
    ; antisym  = antisym
    }
  }
  where
  reflexive : ∀ {A n} → _≈_ {A} {n} ⇒ _⊑_
  reflexive []        = []
  reflexive (x ∷ xs≈) = x ∷ ♯ reflexive (♭ xs≈)

  trans : ∀ {A n} → Transitive (_⊑_ {A} {n})
  trans []        _          = []
  trans (x ∷ xs≈) (.x ∷ ys≈) = x ∷ ♯ trans (♭ xs≈) (♭ ys≈)

  antisym : ∀ {A n} → Antisymmetric (_≈_ {A} {n}) _⊑_
  antisym []       []        = []
  antisym (x ∷ p₁) (.x ∷ p₂) = x ∷ ♯ antisym (♭ p₁) (♭ p₂)

map-cong : ∀ {A B n} (f : A → B) → _≈_ {n = n} =[ map f ]⇒ _≈_
map-cong f []        = []
map-cong f (x ∷ xs≈) = f x ∷ ♯ map-cong f (♭ xs≈)

take-⊑ : ∀ {A} m {n} (xs : Covec A (m + n)) → take m xs ⊑ xs
take-⊑ zero    xs       = []
take-⊑ (suc n) (x ∷ xs) = x ∷ ♯ take-⊑ (♭ n) (♭ xs)


{-# OPTIONS --without-K #-}
module overloading.core where

-- ## Coercions
--
-- The overloading system implemented in this module is based on
-- **coercions**. A coercion is simply a function converting a type into
-- another. In object-oriented parliance, a coercion embodies an *is-a*
-- relationship.  The two types involved in a coercions are called `Source` and
-- `Target` respectively, and the coercion itself is a function `Source →
-- Target`.
--
-- Coercions are implemented as terms of type `Coercion`, which is a record
-- parameterized over the `Source` and `Target` types, with a single field for
-- the actual coercion function.  Of course, the type `Coercion X Y` is
-- isomorphic to `X → Y`, but using a record prevents possible ambiguities when
-- using coercions as implicit parameters, and potentially makes instance
-- resolution faster.
--
-- The typical scenario where coercions are used is when defining a subtype
-- relationships between types.  Although Agda has no built-in support for
-- subtypes, it is possible to achieve a reasonable level of syntactical
-- convenience with the help of some boilerplace code that specifies the
-- subtyping relation explicitly.  See `category.graph.core` for a detailed
-- example.
--
-- This module also contains some functions to help reduce the amount of
-- boilerplate needed for defining all the coercions necessary for a given type.
-- See `coerce-self` and `coerce-parent` below.
--
-- ## Methods
--
-- The strategy employed by this library to implement overloading goes as
-- follows.  Every type (denoted by `Target` in the following) defines a set of
-- "methods" that constitute its interface, and are inherited by every subtype
-- of `Target`.  Methods are divided into 2 groups:
--
-- - **static methods** are functions that take an argument `X` of a type
-- convertible to `Target`. The typical example of a static method is an
-- explicit coercion function, like `∣_∣` below, which returns the "underlying
-- set" of `X`.  Another example of static method is the `total` function for
-- graphs (see `category.graph.core`).
--
-- - **instance methods** are functions that work without requiring an explicit
-- parameter of type `Target`.  A typical example of instance method is
-- composition in a category (`_∘_`): there's no need to pass the category
-- itself when composing two morphisms.  In order to use instance methods, they
-- have to be enabled explicitly for each instance for which they are used.
-- Every type defines a special module (whose name is by convention always
-- `as-target`, where `target` is replaced with the actual lowercase name of
-- type) which allows instance methods to be enabled.  For example, to use the
-- composition operator for morphisms of a category `C`, one can write:
--
--    open as-category C
--
-- The `as-target` module itself behaves like a *static* method, so it can be
-- used to enable instance methods for any superclass of a given instance.
-- Furthermore, enabling instance methods for `Target` enables instance methods
-- for all superclasses of it in its principal inheritance path (see
-- "Inheritance Model" below).
--
-- ## Implementation
--
-- The implementation of static methods is relatively straightforward.  A static
-- method is defined as a function taking a coercion to `Target` as an instance
-- argument, and uses the coercion to convert its argument to the correct type.
--
-- As for instance methods, they are implemented as functions that take a record
-- with the full interface of `Target` (called **instance record** below) as an
-- implicit argument (see "Alternative Notations" below for details), and just
-- return the appropriate field.  This can be accomplished very easily using
-- Agda's module system.
--
-- The `as-target` module, used to enable instance methods, is defined as a
-- static method, and works simply by putting the record above into scope.
--
-- ## Alternative Notations
--
-- Some types have an interface which supports alternative notations.  For
-- example, monoids have a "default" notation (`unit` and `_*_`), and an
-- additive notation (`zero` and `_+_`).
--
-- To implement multiple notations, a `Styled` record is used as the implicit
-- parameter for instance methods.  The `Styled` record is parameterized over a
-- `style` parameter (normally `default`), and contains the interface record as
-- its only field.
--
-- The `Styled` record thus serves two purposes:
--
-- - It prevents ambiguities in the resolution of instance arguments: if an
-- interface record is in scope for reasons unrelated to the overloading system,
-- then it will not be accidentally used as the argument of an instance methods,
-- as it's not wrapped in a `Styled` record.
--
-- - It allows instance methods to specify an alternative style parameter for
-- the record in which the interface record is wrapped.  Thus, multiple
-- `as-target` module can be defined, one per supported style, that put the
-- interface record in scope wrapped in the appropriate `Styled` record.  The
-- `styled` function can be used to wrap an interface record using a given
-- style.
--
-- ## Inheritance Model
--
-- Subtyping relations can form an arbitrary directed graph, with a
-- distinguished spanning forest, whose edges we call *principal*.
--
-- Coercions are defined for every pair of connected nodes in the full graph.
-- Exactly one coercion per pair should be defined, regardless of the number of
-- paths that connect it.  Static methods are inherited automatically through
-- paths in the full DAG, since the existence of a coercion is enough for static
-- methods to propagate.
--
-- The principal subgraph is used for inheritance of instance methods.  Namely,
-- the `as-target` record enables all instance methods for the ancestors of
-- `Target` in the principal subgraph.  This is accomplished by simply
-- re-exporting the `as-target` module for the immediate parent of
-- `Target`. Extra edges coming out of `Target` can optionally be added as well
-- for convenience.

open import level
open import overloading.bundle

record Coercion {i}{j}(Source : Set i)(Target : Set j) : Set (i ⊔ j) where
  constructor coercion
  field
    coerce : Source → Target
open Coercion public

data Style : Set where default : Style

record Styled {i}(style : Style)(X : Set i) : Set i where
  field value : X

styled : ∀ {i}{X : Set i} → (s : Style) → X → Styled s X
styled s x = record { value = x }

-- Trivial coercion: any type can be coerced into itself.
coerce-self : ∀ {i} (X : Set i) → Coercion X X
coerce-self {i} _ = record
  { coerce = λ x → x }

-- Transport a coercion to a `Bundle` subtype.  See `overloading.bundle` for
-- more details on bundles.
coerce-parent : ∀ {i j k}
                {X : Set i}
                {Y : Set j}
              → ⦃ c : Coercion X Y ⦄
              → {Struct : X → Set k}
              → Coercion (Bundle Struct) Y
coerce-parent ⦃ c ⦄ = record
  { coerce = λ x → coerce c (Bundle.parent x) }

instance
  set-is-set : ∀ {i} → Coercion (Set i) (Set i)
  set-is-set {i} = coerce-self _

∣_∣ : ∀ {i j}{Source : Set i} ⦃ o : Coercion Source (Set j) ⦄
    → Source → Set j
∣_∣ ⦃ c ⦄ = coerce c


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.DStructures.Meta.Isomorphism where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.Functions.FunExtEquiv

open import Cubical.Homotopy.Base

open import Cubical.Data.Sigma

open import Cubical.Relation.Binary

open import Cubical.Algebra.Group
open import Cubical.Structures.LeftAction

open import Cubical.DStructures.Base
open import Cubical.DStructures.Meta.Properties
open import Cubical.DStructures.Structures.Constant

open import Cubical.DStructures.Structures.Type
open import Cubical.DStructures.Structures.Group

private
  variable
    ℓ ℓ' ℓ'' ℓ₁ ℓ₁' ℓ₁'' ℓ₂ ℓA ℓA' ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C ℓ≅ᴰ ℓ≅ᴰ' : Level

open URGStr
open URGStrᴰ

----------------------------------------------
-- Pseudo-isomorphisms between URG structures
-- are relational isos of the underlying rel.
----------------------------------------------
𝒮-PIso : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
         {A' : Type ℓA'} (𝒮-A' : URGStr A' ℓ≅A')
         → Type (ℓ-max (ℓ-max ℓA ℓA') (ℓ-max ℓ≅A ℓ≅A'))
𝒮-PIso 𝒮-A 𝒮-A' = RelIso (URGStr._≅_ 𝒮-A) (URGStr._≅_ 𝒮-A')

----------------------------------------------
-- Since the relations are univalent,
-- a rel. iso induces an iso of the underlying
-- types.
----------------------------------------------
𝒮-PIso→Iso : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
             {A' : Type ℓA'} (𝒮-A' : URGStr A' ℓ≅A')
             (ℱ : 𝒮-PIso 𝒮-A 𝒮-A')
             → Iso A A'
𝒮-PIso→Iso 𝒮-A 𝒮-A' ℱ
  = RelIso→Iso (_≅_ 𝒮-A) (_≅_ 𝒮-A') (uni 𝒮-A) (uni 𝒮-A') ℱ

----------------------------------------------
-- From a DURG structure, extract the
-- relational family over the base type
----------------------------------------------
𝒮ᴰ→relFamily : {A : Type ℓA} {𝒮-A : URGStr A ℓ≅A}
               {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
               → RelFamily A ℓB ℓ≅B
-- define the type family, just B
𝒮ᴰ→relFamily {B = B} 𝒮ᴰ-B .fst = B
-- the binary relation is the displayed relation over ρ a
𝒮ᴰ→relFamily {𝒮-A = 𝒮-A} {B = B} 𝒮ᴰ-B .snd {a = a} b b'
  = 𝒮ᴰ-B ._≅ᴰ⟨_⟩_ b (𝒮-A .ρ a) b'

--------------------------------------------------------------
-- the type of relational isos between a DURG structure
-- and the pulled back relational family of another
--
-- ℱ will in applications always be an isomorphism,
-- but that's not needed for this definition.
--------------------------------------------------------------
𝒮ᴰ-♭PIso : {A : Type ℓA} {𝒮-A : URGStr A ℓ≅A}
           {A' : Type ℓA'} {𝒮-A' : URGStr A' ℓ≅A'}
           (ℱ : A → A')
           {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
           {B' : A' → Type ℓB'} (𝒮ᴰ-B' : URGStrᴰ 𝒮-A' B' ℓ≅B')
           → Type (ℓ-max ℓA (ℓ-max (ℓ-max ℓB ℓB') (ℓ-max ℓ≅B ℓ≅B')))
𝒮ᴰ-♭PIso ℱ 𝒮ᴰ-B 𝒮ᴰ-B'
  = ♭RelFiberIsoOver ℱ (𝒮ᴰ→relFamily 𝒮ᴰ-B) (𝒮ᴰ→relFamily 𝒮ᴰ-B')

---------------------------------------------------------
-- Given
-- - an isomorphism ℱ of underlying types A, A', and
-- - an 𝒮ᴰ-bPIso over ℱ
-- produce an iso of the underlying total spaces
---------------------------------------------------------
𝒮ᴰ-♭PIso-Over→TotalIso : {A : Type ℓA} {𝒮-A : URGStr A ℓ≅A}
                         {A' : Type ℓA'} {𝒮-A' : URGStr A' ℓ≅A'}
                         (ℱ : Iso A A')
                         {B : A → Type ℓB} (𝒮ᴰ-B : URGStrᴰ 𝒮-A B ℓ≅B)
                         {B' : A' → Type ℓB'} (𝒮ᴰ-B' : URGStrᴰ 𝒮-A' B' ℓ≅B')
                         (𝒢 : 𝒮ᴰ-♭PIso (Iso.fun ℱ) 𝒮ᴰ-B 𝒮ᴰ-B')
                         → Iso (Σ A B) (Σ A' B')
𝒮ᴰ-♭PIso-Over→TotalIso ℱ 𝒮ᴰ-B 𝒮ᴰ-B' 𝒢
  = RelFiberIsoOver→Iso ℱ
                        (𝒮ᴰ→relFamily 𝒮ᴰ-B) (𝒮ᴰ-B .uniᴰ)
                        (𝒮ᴰ→relFamily 𝒮ᴰ-B') (𝒮ᴰ-B' .uniᴰ)
                        𝒢


------------------------------------------------------------------------
-- The Agda standard library
--
-- Operations on nullary relations (like negation and decidability)
------------------------------------------------------------------------

-- Some operations on/properties of nullary relations, i.e. sets.

module Relation.Nullary where

import Relation.Nullary.Core as Core

------------------------------------------------------------------------
-- Negation

open Core public using (¬_)

------------------------------------------------------------------------
-- Decidable relations

open Core public using (Dec; yes; no)


-- | In this module, we proof that the 2-category of endofunctors
-- inherits locally all colimits from underlying category.
-- More precisely, for a functor F : C → C, we compute in Endo(F, F)
-- colimits point-wise from those in C.
module UpToColim where

open import Level
open import Relation.Binary using (Rel; IsEquivalence)
open import Data.Product
open import Categories.Support.Equivalence
open import Categories.Category
open import Categories.2-Category
open import Categories.Functor
open import Categories.NaturalTransformation
  renaming (id to natId; _≡_ to _≡N_; setoid to natSetoid)
  hiding (_∘ˡ_; _∘ʳ_)
open import Categories.Support.EqReasoning
open import Categories.Colimit
open import Categories.Cocones
open import Categories.Cocone
open import Categories.Object.Initial
open import Categories.Functor.Constant

open import NaturalTransFacts
open import UpTo

-- _⇒_ = NaturalTransformation

EndoDiagram : (C : Cat₀) → (F : EndoFunctor C) → (I : Cat₀) → Set
EndoDiagram C F I = Functor I (EndoMor (C , F) (C , F))

PW-Diagram : {C : Cat₀} → {F : EndoFunctor C} → {I : Cat₀} →
             EndoDiagram C F I → (X : Category.Obj C) →
             Functor I C
PW-Diagram {C} {F} {I} D X =
  record
  { F₀ = λ i → Functor.F₀ (Endo⇒.T (D.F₀ i)) X
  ; F₁ = λ h → NaturalTransformation.η (UpTo⇒.γ (D.F₁ h)) X
  ; identity = ≡U-proof D.identity
  ; homomorphism = ≡U-proof D.homomorphism
  ; F-resp-≡ = λ x → ≡U-proof (D.F-resp-≡ x)
  }
  where
    module C = Category C
    module D = Functor D
    module I = Category I
    open _≡U_

EndoMor-inherit-colim : {C : Cat₀} → (F : EndoFunctor C) →
                        {I : Cat₀} → (D : EndoDiagram C F I) →
                        ((X : Category.Obj C) → Colimit (PW-Diagram D X)) →
                        Colimit D
EndoMor-inherit-colim {C} F {I} D c =
  record
  { initial = record
    { ⊥ = colim-D
    ; ! = out
    ; !-unique = out-unique
    }
  }
  where
    -- Notations

    module C = Category C
    module I = Category I
    module CC-D = Category (Cocones D)

    -- Components of F
    F₀ = Functor.F₀ F
    F₁ = Functor.F₁ F

    -- Components of the diagram D
    D₀ = Functor.F₀ D
    D₁ = Functor.F₁ D

    -- Tᵢ = π₁(D(i))
    T : (i : I.Obj) → Functor C C
    T i = Endo⇒.T (D₀ i)

    -- Components of T
    T₀ = λ i → Functor.F₀ (T i)
    T₁ = λ i {A} {B} → Functor.F₁ (T i) {A} {B}

    -- ρ‌ᵢA = π₂(D(i))
    ρ : (i : I.Obj) → (T i ∘ F) ⇒ (F ∘ T i)
    ρ i = Endo⇒.ρ (D₀ i)

    ρη : (i : I.Obj) → (A : C.Obj) → C [ T₀ i (F₀ A) , F₀ (T₀ i A) ]
    ρη i A = NaturalTransformation.η (ρ i) A

    -- The natural transformation (w/o proof) D(f) : D(i) ⇒ D(i)
    D₁η : ∀ {i j} → (f : I [ i , j ]) →
          (A : C.Obj) → C [ T₀ i A , T₀ j A ]
    D₁η f A = NaturalTransformation.η (UpTo⇒.γ (D₁ f)) A

    ----- Construction of the colimit -----
    -- It is given by the cocone (colim-T, ρ).

    -- Action of colim-T on objects
    colim-T₀ : C.Obj → C.Obj
    colim-T₀ A = CL.∃F
      where
        module CL = Colimit (c A)

    -- Injection into colim DX
    κ : (i : I.Obj) → (X : C.Obj) → C [ T₀ i X , Colimit.∃F (c X) ]
    κ i X = Colimit.Ic.ψ (c X) i

    -- Given a morphism u : A → B in C, we construct a cocone DA ⇒ colim DB,
    -- which will give us then T(u) by the universal property of colim DA.
    -- The components of the cocone are given by κBᵢ ∘ Tᵢ(u) : T₁(A) → colim DB,
    -- where we use that Tᵢ(A) = DA(i).
    cocone-T₁ : {A B : C.Obj} →
                C [ A , B ] → Category.Obj (Cocones (PW-Diagram D A))
    cocone-T₁ {A} {B} u = record
      { N = colim-T₀ B
      ; ψ = λ i → C [ κB i ∘ T₁ i u ]
      ; commute = comm
      }
      where
        module CA = Colimit (c A)
        module PW-Cocones-A = Category (Cocones (PW-Diagram D A))
        module CB = Colimit (c B)
        DA = PW-Diagram D A
        module DA = Functor DA
        DB = PW-Diagram D B
        module DB = Functor DB

        -- Injection into colim DB
        κB : (i : I.Obj) → C [ T₀ i B , CB.∃F ]
        κB i = NaturalTransformation.η CB.ι i

        .comm : {i j : I.Obj} (f : I [ i , j ]) →
                C [ κB i ∘ T₁ i u ] C.≡ C [ κB j ∘ T₁ j u ] C.∘ DA.F₁ f
        comm {i} {j} f =
          begin
            C [ κB i ∘ T₁ i u ]
          ↓⟨ C.∘-resp-≡ˡ (Colimit.Ic.commute (c B) f) ⟩
            (κB j C.∘ DB.F₁ f) C.∘ T₁ i u
          ↓⟨ C.assoc ⟩
            κB j C.∘ (DB.F₁ f C.∘ T₁ i u)
          ↓⟨ C.∘-resp-≡ʳ
             (NaturalTransformation.commute (UpTo⇒.γ (D₁ f)) u)
          ⟩
            κB j C.∘ (T₁ j u C.∘ DA.F₁ f)
          ↑⟨ C.assoc ⟩
            C [ κB j ∘ T₁ j u ] C.∘ DA.F₁ f
          ∎
          where
            open SetoidReasoning (C.hom-setoid {DA.F₀ i} {colim-T₀ B})

    -- Action of colim-T on morphisms
    colim-T₁ : {A B : C.Obj} → C [ A , B ] → C [ colim-T₀ A , colim-T₀ B ]
    colim-T₁ {A} {B} u = CoconeMorphism.f (CA.I.! {cocone-T₁ u})
      where
        module CA = Colimit (c A)

    -- Proof that T(id_A) = id_{T(A)}
    .colim-T-id : ∀ {A : C.Obj} →
                 C [ colim-T₁ (C.id {A}) ≡ C.id {colim-T₀ A} ]
    colim-T-id {A} = CA.I.⊥-id (record
        { f = colim-T₁ (C.id {A})
        ; commute = λ {i} →
          let open SetoidReasoning (C.hom-setoid {DA.F₀ i} {colim-T₀ A})
          in begin
            C [ colim-T₁ (C.id {A}) ∘ κ i A ]
          -- colimit property of T(id) = [κ i A ∘ id]_{i ∈ I}
          ↓⟨ CoconeMorphism.commute (CA.I.! {cocone-T₁ (C.id {A})}) ⟩
            C [ κ i A ∘ T₁ i (C.id {A}) ]
          -- Functoriality of Tᵢ
          ↓⟨ C.∘-resp-≡ʳ (Functor.identity (T i)) ⟩
            C [ κ i A ∘ C.id {T₀ i A} ]
          ↓⟨ C.identityʳ ⟩
            κ i A
          ∎
        })
      where
        module CA = Colimit (c A)
        module DA = Functor (PW-Diagram D A)

    -- Proof that T(g ∘ f) = Tg ∘ Tf
    .colim-T-hom : {X Y Z : C.Obj} {f : C [ X , Y ]} {g : C [ Y , Z ]} →
                   colim-T₁ (C [ g ∘ f ]) C.≡ C [ colim-T₁ g ∘ colim-T₁ f ]
    colim-T-hom {X} {Y} {Z} {f} {g} = CX.I.!-unique CX⇒TgTf
      where
        module CX = Colimit (c X)
        module CY = Colimit (c Y)
        module DX = Functor (PW-Diagram D X)
        module CC-DX = Category (Cocones (PW-Diagram D X))

        -- Show that Tg ∘ Tf is a cocone for T(g ∘ f), which implies that
        -- Tg ∘ Tf = T(g ∘ f).
        -- To achieve this, we need to show that for each i ∈ I, we have
        -- Tg ∘ Tf ∘ κ i X = κ i Z ∘ Tᵢ (g ∘ f).
        CX⇒TgTf : Colimit.I.⊥ (c X) CC-DX.⇒ cocone-T₁ (C [ g ∘ f ])
        CX⇒TgTf = record
          { f = C [ colim-T₁ g ∘ colim-T₁ f ]
          ; commute = λ {i : I.Obj} →
            let open SetoidReasoning (C.hom-setoid {DX.F₀ i} {colim-T₀ Z})
            in begin
               C [ colim-T₁ g ∘ colim-T₁ f ] C.∘ κ i X
            ↓⟨ C.assoc ⟩
                colim-T₁ g C.∘ (colim-T₁ f C.∘ κ i X)
            ↓⟨ C.∘-resp-≡ʳ
               (CoconeMorphism.commute (CX.I.! {cocone-T₁ f}))
            ⟩
                colim-T₁ g C.∘ (κ i Y C.∘ T₁ i f)
            ↑⟨ C.assoc ⟩
                (colim-T₁ g C.∘ κ i Y) C.∘ T₁ i f
            ↓⟨ C.∘-resp-≡ˡ
               (CoconeMorphism.commute (CY.I.! {cocone-T₁ g}))
            ⟩
                (κ i Z C.∘ T₁ i g) C.∘ T₁ i f
            ↓⟨ C.assoc ⟩
                κ i Z C.∘ (T₁ i g C.∘ T₁ i f)
            ↑⟨ C.∘-resp-≡ʳ (Functor.homomorphism (T i)) ⟩
              C [ κ i Z ∘ T₁ i (g C.∘ f) ]
            ∎
          }

    -- Proof that T respects the equality of C.
    .colim-T-resp-≡ : {A B : C.Obj} {f : C [ A , B ]} {g : C [ A , B ]} →
                      C [ f ≡ g ] → C [ colim-T₁ f ≡ colim-T₁ g ]
    colim-T-resp-≡ {A} {B} {f} {g} f≡g = CA.I.!-unique CA⇒Tg
      where
        module CA = Colimit (c A)
        module DA = Functor (PW-Diagram D A)
        module CC-DA = Category (Cocones (PW-Diagram D A))

        -- That T respects ≡ is inherited point-wise from the fact that
        -- each Tᵢ respects ≡.
        CA⇒Tg : Colimit.I.⊥ (c A) CC-DA.⇒ cocone-T₁ f
        CA⇒Tg = record
          { f = colim-T₁ g
          ; commute = λ {i} →
            let open SetoidReasoning (C.hom-setoid {DA.F₀ i} {colim-T₀ B})
            in begin
              C [ colim-T₁ g ∘ κ i A ]
            ↓⟨ CoconeMorphism.commute (CA.I.! {cocone-T₁ g}) ⟩
              C [ κ i B ∘ T₁ i g ]
            ↑⟨ C.∘-resp-≡ʳ (Functor.F-resp-≡ (T i) f≡g) ⟩
              C [ κ i B ∘ T₁ i f ]
            ∎
          }

    -- The colimiting up-to technique
    colim-T : Functor C C
    colim-T = record
        { F₀ = colim-T₀
        ; F₁ = colim-T₁
        ; identity = colim-T-id
        ; homomorphism = colim-T-hom
        ; F-resp-≡ = colim-T-resp-≡
        }

    -- Cocone to construct ρ = [F₁ (κᵢ A) ∘ ρᵢ A]_{i ∈ I}
    cocone-ρ : {A : C.Obj} →
               Category.Obj (Cocones (PW-Diagram D (F₀ A)))
    cocone-ρ {A} = record
      { N = F₀ (colim-T₀ A)
      ; ψ = λ i → C [ F₁ (κ i A) ∘ ρη i A ]
      ; commute = λ {i} {j} f →
        let open SetoidReasoning (C.hom-setoid {T₀ i (F₀ A)} {F₀ (colim-T₀ A)})
        in begin
          C [ F₁ (κ i A) ∘ ρη i A ]
        ↓⟨ C.∘-resp-≡ˡ (Functor.F-resp-≡ F (CA.Ic.commute f)) ⟩
          C [ F₁ ((κ j A) C.∘ (DA.F₁ f)) ∘ ρη i A ]
        ↓⟨ C.∘-resp-≡ˡ (Functor.homomorphism F) ⟩
          C [ C [ F₁ (κ j A) ∘ F₁ (DA.F₁ f) ] ∘ ρη i A ]
        ↓⟨ C.assoc ⟩
          C [ F₁ (κ j A) ∘ C [ F₁ (DA.F₁ f) ∘ ρη i A ] ]
        ↓⟨ C.∘-resp-≡ʳ (lemma f) ⟩
          C [ F₁ (κ j A) ∘ C [ ρη j A ∘ DFA.F₁ f ] ]
        ↑⟨ C.assoc ⟩
          C [ F₁ (κ j A) ∘ ρη j A ] C.∘ DFA.F₁ f
        ∎
      }
      where
        module CA = Colimit (c A)
        module DA = Functor (PW-Diagram D A)
        module DFA = Functor (PW-Diagram D (F₀ A))

        -- Lemma to turn the commuting square for ρ into the equation we need
        .lemma : {i j : I.Obj} → (f : I [ i , j ]) →
                 C [ F₁ (DA.F₁ f) ∘ ρη i A ] C.≡ C [ ρη j A ∘ DFA.F₁ f ]
        lemma {i} {j} f =
          begin
            C [ F₁ (DA.F₁ f) ∘ ρη i A ]
          ↑⟨ C.∘-resp-≡ˡ C.identityʳ ⟩
            C [ C [ F₁ (DA.F₁ f) ∘ C.id {F₀ (DA.F₀ i)} ] ∘ ρη i A ]
          ↑⟨ UpTo⇒.square (D₁ f) {A} ⟩
            C [ ρη j A ∘ C [ T₁ j (C.id {F₀ A}) ∘ (DFA.F₁ f) ] ]
          ↓⟨ C.∘-resp-≡ʳ (C.∘-resp-≡ˡ
             (Functor.identity (T j)))
          ⟩
            C [ ρη j A ∘ C [ C.id {T₀ j (F₀ A)} ∘ (DFA.F₁ f) ] ]
          ↓⟨ C.∘-resp-≡ʳ C.identityˡ ⟩
            C [ ρη j A ∘ DFA.F₁ f ]
          ∎
          where
            open SetoidReasoning (C.hom-setoid {T₀ i (F₀ A)} {F₀ (T₀ j A)})

    colim-ρ-η : (A : C.Obj) → C [ colim-T₀ (F₀ A) , F₀ (colim-T₀ A) ]
    colim-ρ-η A = CoconeMorphism.f (CFA.I.! {cocone-ρ})
      where
        module CFA = Colimit (c (F₀ A))

    -- Natural transformation to make colim-T indeed an up-to technique
    colim-ρ : (colim-T ∘ F) ⇒ (F ∘ colim-T)
    colim-ρ = record
      { η = colim-ρ-η
      ; commute = λ {A} {B} f →
        let open SetoidReasoning
                 (C.hom-setoid {colim-T₀ (F₀ A)} {F₀ (colim-T₀ B)})
        in begin
          C [ colim-ρ-η B ∘ colim-T₁ (F₁ f) ]
        ↓⟨ {!!} ⟩
          C [ F₁ (colim-T₁ f) ∘ colim-ρ-η A ]
        ∎
      }
      where

    colim-Endo : Endo⇒ C F C F
    colim-Endo = record
      { T = colim-T
      ; ρ = colim-ρ
      }

    colim-ψ : (i : I.Obj) → UpTo⇒ (D₀ i) colim-Endo
    colim-ψ i = record
      { γ = record
        { η = λ X → κ i X
        ; commute = {!!}
        }
      ; square = {!!}
      }

    colim-D : CC-D.Obj
    colim-D =
      record
      { N = colim-Endo
      ; ψ = colim-ψ
      ; commute = {!!}
      }

    out : ∀ {A : CC-D.Obj} → colim-D CC-D.⇒ A
    out = {!!}

    out-unique : {A : CC-D.Obj} (f : colim-D CC-D.⇒ A) → out CC-D.≡ f
    out-unique = {!!}


open import Agda.Builtin.Bool
open import Agda.Builtin.Equality

record R : Set₁ where
  field
    fun  : (A : Set) → A → Bool → A ≡ Bool → Bool
    rule : ∀ x → fun Bool false x refl ≡ false
open R

test : R
fun test .Bool true true refl = true
fun test _     _    _    _    = false
rule test x = refl


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.Gysin where

open import Cubical.Foundations.Path
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Function
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Pointed.Homogeneous

open import Cubical.Functions.Embedding

open import Cubical.Relation.Nullary

open import Cubical.Data.Unit
open import Cubical.Data.Bool
open import Cubical.Data.Nat renaming (_+_ to _+ℕ_ ; _·_ to _·ℕ_)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Int hiding (_+'_)
open import Cubical.Data.Sigma
open import Cubical.Data.Sum
open import Cubical.Data.Fin

open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.ZAction
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Int

open import Cubical.HITs.Truncation as T
open import Cubical.HITs.SetTruncation as ST
open import Cubical.HITs.PropositionalTruncation as PT
open import Cubical.HITs.Pushout.Flattening
open import Cubical.HITs.Pushout
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.S1 renaming (_·_ to _*_)
open import Cubical.HITs.Join

open import Cubical.Homotopy.Connected
open import Cubical.Homotopy.Hopf
open import Cubical.Homotopy.Loopspace
open import Cubical.Homotopy.Group.Base

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Wedge
open import Cubical.ZCohomology.Groups.Sn
open import Cubical.ZCohomology.RingStructure.CupProduct
open import Cubical.ZCohomology.RingStructure.RingLaws
open import Cubical.ZCohomology.RingStructure.GradedCommutativity

open PlusBis

-- There seems to be some problems with the termination checker.
-- Spelling out integer induction with 3 base cases like this
-- solves the issue.
private
  Int-ind : ∀ {ℓ} (P : ℤ → Type ℓ)
          → P (pos zero) → P (pos 1)
          → P (negsuc zero)
          → ((x y : ℤ) → P x → P y → P (x + y)) → (x : ℤ) → P x
  Int-ind P z one min ind (pos zero) = z
  Int-ind P z one min ind (pos (suc zero)) = one
  Int-ind P z one min ind (pos (suc (suc n))) =
    ind (pos (suc n)) 1  (Int-ind P z one min ind (pos (suc n))) one
  Int-ind P z one min ind (negsuc zero) = min
  Int-ind P z one min ind (negsuc (suc n)) =
    ind (negsuc n) (negsuc zero) (Int-ind P z one min ind (negsuc n)) min

-- The untruncated version (coHomRed n (S₊ n)), i.e.
-- (S₊∙ n →∙ coHomK-ptd n) is in fact equal to
-- (coHomRed n (S₊ n)). Its useful to formulate
-- (S₊∙ n →∙ coHomK-ptd n) as a group in its own right
-- and prove it equivalent to (coHomRed n (S₊ n)).

-- We start with the addition
private
  _++_ : ∀ {ℓ} {A : Pointed ℓ} {n : ℕ} →
        (A →∙ coHomK-ptd n) → (A →∙ coHomK-ptd n) → (A →∙ coHomK-ptd n)
  fst (f ++ g) x = fst f x +ₖ fst g x
  snd (f ++ g) = cong₂ _+ₖ_ (snd f) (snd g) ∙ rUnitₖ _ (0ₖ _)

-- If we truncate the addition, we get back our usual
-- addition on (coHomRed n (S₊ n))
addAgree : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) (x y : A →∙ coHomK-ptd n)
         → Path (fst (coHomRedGrDir n A))
                 ∣ x ++ y ∣₂
                 (∣ x ∣₂ +ₕ∙ ∣ y ∣₂)
addAgree {A = A} zero f g =
  cong ∣_∣₂ (→∙Homogeneous≡ (isHomogeneousKn _) refl)
addAgree {A = A} (suc zero) f g =
  cong ∣_∣₂ (→∙Homogeneous≡ (isHomogeneousKn _) refl)
addAgree {A = A} (suc (suc n)) f g =
  cong ∣_∣₂ (→∙Homogeneous≡ (isHomogeneousKn _) refl)

-- We formulate (S₊∙ n →∙ coHomK-ptd n) as a group, πS.
module _ where
  open import Cubical.Algebra.Monoid
  open import Cubical.Algebra.Semigroup
  open GroupStr
  open IsGroup
  open IsMonoid
  open IsSemigroup
  πS : (n : ℕ) → Group ℓ-zero
  fst (πS n) = S₊∙ n →∙ coHomK-ptd n
  1g (snd (πS n)) = (λ _ → 0ₖ n) , refl
  GroupStr._·_ (snd (πS n)) f g = (λ x → fst f x +ₖ fst g x)
                                  , cong₂ _+ₖ_ (snd f) (snd g) ∙ rUnitₖ n (0ₖ n)
  inv (snd (πS n)) f = (λ x → -ₖ fst f x) , cong -ₖ_ (snd f) ∙ -0ₖ {n = n}
  isGroup (snd (πS n)) = makeIsGroup
                         (helper n)
                         (λ x y z → →∙Homogeneous≡
                                     (isHomogeneousKn n)
                                     (funExt λ w → assocₖ n (fst x w) (fst y w) (fst z w)))
                         (λ { (f , p) → →∙Homogeneous≡ (isHomogeneousKn n) (funExt λ x → rUnitₖ n (f x)) })
                         (λ { (f , p) → →∙Homogeneous≡ (isHomogeneousKn n) (funExt λ x → lUnitₖ n (f x)) })
                         (λ { (f , p) → →∙Homogeneous≡ (isHomogeneousKn n) (funExt λ x → rCancelₖ n (f x)) })
                         (λ { (f , p) → →∙Homogeneous≡ (isHomogeneousKn n) (funExt λ x → lCancelₖ n (f x)) })
          where
          helper : (n : ℕ) → isSet (S₊∙ n →∙ coHomK-ptd n)
          helper zero = isOfHLevelΣ 2 (isSetΠ (λ _ → isSetℤ))  λ _ → isOfHLevelPath 2 isSetℤ _ _
          helper (suc n) = isOfHLevel↑∙' 0 n

  isSetπS : (n : ℕ) → isSet (S₊∙ n →∙ coHomK-ptd n)
  isSetπS = λ n → is-set (snd (πS n))

-- πS is equivalent to (coHomRed n (S₊∙ n))
K : (n : ℕ) → GroupIso (coHomRedGrDir n (S₊∙ n)) (πS n)
fst (K n) = setTruncIdempotentIso (isSetπS n)
snd (K zero) =
  makeIsGroupHom
    (ST.elim2 (λ _ _ → isOfHLevelPath 2 (isSetπS 0) _ _)
      λ f g → →∙Homogeneous≡ (isHomogeneousKn 0) refl)
snd (K (suc zero)) =
    makeIsGroupHom
    (ST.elim2 (λ _ _ → isOfHLevelPath 2 (isSetπS 1) _ _)
      λ f g → →∙Homogeneous≡ (isHomogeneousKn 1) refl)
snd (K (suc (suc n))) =
    makeIsGroupHom
    (ST.elim2 (λ _ _ → isOfHLevelPath 2 (isSetπS _) _ _)
      λ f g → →∙Homogeneous≡ (isHomogeneousKn _) refl)

-- πS has the following generator
genFunSpace : (n : ℕ) → S₊∙ n →∙ coHomK-ptd n
fst (genFunSpace zero) false = 1
fst (genFunSpace zero) true = 0
snd (genFunSpace zero) = refl
fst (genFunSpace (suc n)) = ∣_∣
snd (genFunSpace (suc zero)) = refl
snd (genFunSpace (suc (suc n))) = refl

πS≅ℤ : (n : ℕ) → GroupIso (πS n) ℤGroup
fst (πS≅ℤ zero) = IsoBool→∙
snd (πS≅ℤ zero) = makeIsGroupHom λ _ _ → refl
πS≅ℤ (suc n) =
  compGroupIso
    (invGroupIso (K (suc n)))
    (compGroupIso
      (GroupEquiv→GroupIso (coHomGr≅coHomRedGr n (S₊∙ (suc n))))
      (Hⁿ-Sⁿ≅ℤ n))

Iso-πS-ℤ : (n : ℕ) → Iso (S₊∙ (suc n) →∙ coHomK-ptd (suc n)) ℤ
Iso-πS-ℤ n = compIso (invIso (setTruncIdempotentIso (isOfHLevel↑∙' 0 n)))
               (compIso (equivToIso (fst (coHomGr≅coHomRedGr n (S₊∙ (suc n)))))
               (fst (Hⁿ-Sⁿ≅ℤ n)))

Iso-πS-ℤ' : (n : ℕ) → Iso (S₊∙ n →∙ coHomK-ptd n) ℤ
Iso-πS-ℤ' n = fst (πS≅ℤ n)

Iso-πS-ℤPres1 : (n : ℕ) → Iso.fun (fst (πS≅ℤ (suc n))) (∣_∣ , refl) ≡ pos 1
Iso-πS-ℤPres1 zero = refl
Iso-πS-ℤPres1 (suc n) =
  cong (Iso.fun (fst (Hⁿ-Sⁿ≅ℤ n))) (lem n) ∙ Iso-πS-ℤPres1 n
  where
  lem : (n : ℕ) → Iso.fun (fst (suspensionAx-Sn n n)) ∣ ∣_∣ ∣₂ ≡ ∣ ∣_∣ ∣₂
  lem zero =
    cong ∣_∣₂ (funExt λ x → transportRefl (∣ x ∣ +ₖ (0ₖ 1)) ∙ rUnitₖ 1 ∣ x ∣)
  lem (suc n) = cong ∣_∣₂
    (funExt λ x → (λ i → transportRefl ((ΩKn+1→Kn (suc (suc n))
       (transp (λ j → 0ₖ (suc (suc (suc n))) ≡ ∣ merid north (~ j ∧ ~ i) ∣) i
        (λ z → ∣ compPath-filler
                  (merid (transportRefl (transportRefl x i) i))
                  (sym (merid north)) i z
           ∣)))) i)
    ∙ Iso.leftInv (Iso-Kn-ΩKn+1 (suc (suc n))) ∣ x ∣)

-- The first step of the Gysin sequence is to formulate
-- an equivalence g : Kᵢ ≃ (Sⁿ →∙ Kᵢ₊ₙ)
module g-base where
  g : (n : ℕ) (i : ℕ) → coHomK i → (S₊∙ n →∙ coHomK-ptd (i +' n))
  fst (g n i x) y = x ⌣ₖ (genFunSpace n) .fst y
  snd (g n i x) = cong (x ⌣ₖ_) ((genFunSpace n) .snd) ∙ ⌣ₖ-0ₖ i n x

  -- We give another version of g which will be easier to work with now
  G : (n : ℕ) (i : ℕ) → coHomK i → (S₊∙ n →∙ coHomK-ptd (n +' i))
  fst (G n i x) y = (genFunSpace n) .fst y ⌣ₖ x
  snd (G n i x) = cong (_⌣ₖ x) ((genFunSpace n) .snd) ∙ 0ₖ-⌣ₖ n i x

  -ₖ'^-Iso : (n : ℕ) (i : ℕ)
    → (S₊∙ n →∙ coHomK-ptd (i +' n)) ≃ (S₊∙ n →∙ coHomK-ptd (i +' n))
  -ₖ'^-Iso n i = isoToEquiv (iso F F FF FF)
    where
    lem : (i n : ℕ) → (-ₖ'^ i · n) (snd (coHomK-ptd (i +' n))) ≡ 0ₖ _
    lem zero zero = refl
    lem zero (suc zero) = refl
    lem zero (suc (suc n)) = refl
    lem (suc zero) zero = refl
    lem (suc (suc i)) zero = refl
    lem (suc i) (suc n) = refl

    F : S₊∙ n →∙ coHomK-ptd (i +' n) → S₊∙ n →∙ coHomK-ptd (i +' n)
    fst (F f) x = (-ₖ'^ i · n) (fst f x)
    snd (F f) = cong (-ₖ'^ i · n) (snd f) ∙ lem i n

    FF : (x : _) → F (F x) ≡ x
    FF x =
      →∙Homogeneous≡ (isHomogeneousKn _)
        (funExt λ y → -ₖ'-gen² i n _ _ (fst x y))

  transpPres0ₖ : ∀ {k m : ℕ} (p : k ≡ m) → subst coHomK p (0ₖ k) ≡ 0ₖ m
  transpPres0ₖ {k = k} =
    J (λ m p → subst coHomK p (0ₖ k) ≡ 0ₖ m) (transportRefl _)

  -- There will be some index swapping going on. We state this explicitly, since we will
  -- need to trace the maps later
  indexSwap : (n : ℕ) (i : ℕ)
    → (S₊∙ n →∙ coHomK-ptd (n +' i))
     ≃ (S₊∙ n →∙ coHomK-ptd (i +' n))
  indexSwap n i =
    isoToEquiv (iso (λ f → (λ x → subst coHomK (+'-comm n i) (fst f x)) ,
      cong (subst coHomK (+'-comm n i)) (snd f) ∙ transpPres0ₖ (+'-comm n i))
      (λ f → (λ x → subst coHomK (sym (+'-comm n i)) (fst f x))
            , (cong (subst coHomK (sym (+'-comm n i))) (snd f)
                    ∙ transpPres0ₖ (sym (+'-comm n i))))
      (λ f → →∙Homogeneous≡ (isHomogeneousKn _)
                (funExt λ x → transportTransport⁻ _ (f .fst x)))
      λ f → →∙Homogeneous≡ (isHomogeneousKn _)
                (funExt λ x → transportTransport⁻ _ (f .fst x)))

  -- g is a composition of G and our two previous equivs.
  g≡ : (n : ℕ) (i : ℕ) → g n i ≡ λ x
    → fst (compEquiv (indexSwap n i) (-ₖ'^-Iso n i)) ((G n i) x)
  g≡ n i = funExt (λ f → →∙Homogeneous≡ (isHomogeneousKn _)
             (funExt λ y → gradedComm'-⌣ₖ _ _ f (genFunSpace n .fst y)))

  -- We need a third Iso.

  suspKn-Iso-fun : (n m : ℕ) →
    (S₊∙ (suc n) →∙ coHomK-ptd (suc m))
        → (S₊ n → coHomK m)
  suspKn-Iso-fun zero m (f , p) false = ΩKn+1→Kn _ (sym p ∙∙ cong f loop ∙∙ p)
  suspKn-Iso-fun zero m (f , p) true = 0ₖ _
  suspKn-Iso-fun (suc n) m (f , p) x =
    ΩKn+1→Kn _ (sym p ∙∙ cong f (merid x ∙ sym (merid (ptSn _))) ∙∙ p)

  suspKn-Iso-fun∙ : (n m : ℕ) → (f : _) → suspKn-Iso-fun n m f (ptSn _) ≡ 0ₖ m
  suspKn-Iso-fun∙ zero m = λ _ → refl
  suspKn-Iso-fun∙ (suc n) m (f , p) =
    cong (ΩKn+1→Kn m)
      (cong (sym p ∙∙_∙∙ p) (cong (cong f) (rCancel (merid (ptSn _)))))
     ∙∙ cong (ΩKn+1→Kn m) (∙∙lCancel p)
     ∙∙ ΩKn+1→Kn-refl m

  suspKn-Iso-inv : (n m : ℕ) → (S₊∙ n →∙ coHomK-ptd m)
    → (S₊∙ (suc n) →∙ coHomK-ptd (suc m))
  fst (suspKn-Iso-inv zero m (f , p)) base = 0ₖ _
  fst (suspKn-Iso-inv zero m (f , p)) (loop i) = Kn→ΩKn+1 m (f false) i
  snd (suspKn-Iso-inv zero m (f , p)) = refl
  fst (suspKn-Iso-inv (suc n) m (f , p)) north = 0ₖ _
  fst (suspKn-Iso-inv (suc n) m (f , p)) south = 0ₖ _
  fst (suspKn-Iso-inv (suc n) m (f , p)) (merid a i) = Kn→ΩKn+1 m (f a) i
  snd (suspKn-Iso-inv (suc n) m (f , p)) = refl

  suspKn-Iso : (n m : ℕ) →
    Iso (S₊∙ (suc n) →∙ coHomK-ptd (suc m))
        (S₊∙ n →∙ coHomK-ptd m)
  Iso.fun (suspKn-Iso n m) f = (suspKn-Iso-fun n m f)
                             , (suspKn-Iso-fun∙ n m f)
  Iso.inv (suspKn-Iso n m) = suspKn-Iso-inv n m
  Iso.rightInv (suspKn-Iso zero m) (f , p) =
    →∙Homogeneous≡ (isHomogeneousKn _)
      (funExt λ { false → cong (ΩKn+1→Kn m) (sym (rUnit _))
                         ∙ Iso.leftInv (Iso-Kn-ΩKn+1 _) (f false)
                ; true → sym p})
  Iso.rightInv (suspKn-Iso (suc n) m) (f , p) =
    →∙Homogeneous≡ (isHomogeneousKn _)
      (funExt λ x →
         (λ i → ΩKn+1→Kn m
           (sym (rUnit
             (cong-∙
               (suspKn-Iso-inv (suc n) m (f , p) .fst)
                 (merid x) (sym (merid (ptSn _))) i)) i))
      ∙∙ cong (ΩKn+1→Kn m)
          (cong (Kn→ΩKn+1 m (f x) ∙_)
            (cong sym (cong (Kn→ΩKn+1 m) p ∙ Kn→ΩKn+10ₖ m))
             ∙ sym (rUnit _))
      ∙∙ Iso.leftInv (Iso-Kn-ΩKn+1 _)  (f x))
  Iso.leftInv (suspKn-Iso zero m) (f , p) = →∙Homogeneous≡ (isHomogeneousKn _)
    (funExt λ { base → sym p
              ; (loop i) j → lem j i})
    where
    lem : PathP (λ i → p (~ i) ≡ p (~ i))
               (Kn→ΩKn+1 m (ΩKn+1→Kn m (sym p ∙∙ cong f loop ∙∙ p)))
               (cong f loop)
    lem = Iso.rightInv (Iso-Kn-ΩKn+1 _) _
      ◁ λ i → doubleCompPath-filler (sym p) (cong f loop) p (~ i)
  Iso.leftInv (suspKn-Iso (suc n) m) (f , p) =
    →∙Homogeneous≡ (isHomogeneousKn _)
     (funExt λ { north → sym p
               ; south → sym p ∙ cong f (merid (ptSn _))
               ; (merid a i) j → lem a j i})
    where
    lem : (a : S₊ (suc n))
      → PathP (λ i → p (~ i) ≡ (sym p ∙ cong f (merid (ptSn (suc n)))) i)
               (Kn→ΩKn+1 m
                 (ΩKn+1→Kn m
                   (sym p ∙∙ cong f (merid a ∙ sym (merid (ptSn _))) ∙∙ p)))
               (cong f (merid a))
    lem a = Iso.rightInv (Iso-Kn-ΩKn+1 _) _
        ◁ λ i j → hcomp (λ k →
             λ { (i = i1) → (f (merid a j))
               ; (j = i0) → p (k ∧ ~ i)
               ; (j = i1) → compPath-filler'
                              (sym p) (cong f (merid (ptSn _))) k i })
               (f (compPath-filler (merid a) (sym (merid (ptSn _))) (~ i) j))

  glIsoInvHom : (n m : ℕ) (x y : coHomK n) (z : S₊ (suc m))
    → Iso.inv (suspKn-Iso _ _) (G m n (x +ₖ y)) .fst z
    ≡ Iso.inv (suspKn-Iso _ _) (G m n x) .fst z
    +ₖ Iso.inv (suspKn-Iso _ _) (G m n y) .fst z
  glIsoInvHom zero zero x y base = refl
  glIsoInvHom (suc n) zero x y base = refl
  glIsoInvHom zero zero x y (loop i) j = lem j i
    where
    lem : (cong (Iso.inv (suspKn-Iso _ _) (G zero zero (x + y)) .fst) loop)
        ≡ cong₂ _+ₖ_ (cong (Iso.inv (suspKn-Iso _ _) (G zero zero x) .fst) loop)
                     (cong (Iso.inv (suspKn-Iso _ _) (G zero zero y) .fst) loop)
    lem = Kn→ΩKn+1-hom 0 x y
     ∙ ∙≡+₁ (cong (Iso.inv (suspKn-Iso _ _) (G zero zero x) .fst) loop)
            (cong (Iso.inv (suspKn-Iso _ _) (G zero zero y) .fst) loop)
  glIsoInvHom (suc n) zero x y (loop i) j = lem j i
    where
    lem : Kn→ΩKn+1 (suc n) ((pos (suc zero)) ·₀ (x +ₖ y))
      ≡ cong₂ _+ₖ_ (cong (Iso.inv (suspKn-Iso zero (zero +' suc n))
                         (G zero (suc n) x) .fst) loop)
                   (cong (Iso.inv (suspKn-Iso zero (zero +' suc n))
                         (G zero (suc n) y) .fst) loop)
    lem = cong (Kn→ΩKn+1 (suc n)) (lUnit⌣ₖ _ (x +ₖ y))
     ∙∙ Kn→ΩKn+1-hom (suc n) x y
     ∙∙ (λ i → ∙≡+₂ n (Kn→ΩKn+1 (suc n) (lUnit⌣ₖ _ x (~ i)))
                       (Kn→ΩKn+1 (suc n) (lUnit⌣ₖ _ y (~ i))) i)
  glIsoInvHom zero (suc m) x y north = refl
  glIsoInvHom zero (suc m) x y south = refl
  glIsoInvHom zero (suc m) x y (merid a i) j = lem j i
    where
    lem : Kn→ΩKn+1 (suc m) (_⌣ₖ_ {n = suc m} {m = zero} ∣ a ∣ (x + y))
      ≡ cong₂ _+ₖ_ (Kn→ΩKn+1 (suc m) (_⌣ₖ_ {n = suc m} {m = zero} ∣ a ∣ x))
                   (Kn→ΩKn+1 (suc m) (_⌣ₖ_ {n = suc m} {m = zero} ∣ a ∣ y))
    lem = cong (Kn→ΩKn+1 (suc m)) (leftDistr-⌣ₖ (suc m) 0 ∣ a ∣ x y)
     ∙∙ Kn→ΩKn+1-hom (suc m) _ _
     ∙∙ ∙≡+₂ _ _ _
  glIsoInvHom (suc n) (suc m) x y north = refl
  glIsoInvHom (suc n) (suc m) x y south = refl
  glIsoInvHom (suc n) (suc m) x y (merid a i) j = lem j i
    where
    lem : Kn→ΩKn+1 (suc (suc (m +ℕ n)))
                   (_⌣ₖ_ {n = suc m} {m = suc n} ∣ a ∣ (x +ₖ y))
      ≡ cong₂ _+ₖ_ (Kn→ΩKn+1 (suc (suc (m +ℕ n)))
                     (_⌣ₖ_ {n = suc m} {m = suc n} ∣ a ∣ x))
                   (Kn→ΩKn+1 (suc (suc (m +ℕ n)))
                     (_⌣ₖ_ {n = suc m} {m = suc n} ∣ a ∣ y))
    lem = cong (Kn→ΩKn+1 (suc (suc (m +ℕ n))))
             (leftDistr-⌣ₖ (suc m) (suc n) ∣ a ∣ x y)
     ∙∙ Kn→ΩKn+1-hom _ _ _
     ∙∙ ∙≡+₂ _ _ _

  private
    +'-suc : (n m : ℕ) → suc n +' m ≡ suc (n +' m)
    +'-suc zero zero = refl
    +'-suc (suc n) zero = refl
    +'-suc zero (suc m) = refl
    +'-suc (suc n) (suc m) = refl

  decomposeG : (i n : ℕ) (x : coHomK i)
    → G (suc n) i x
     ≡ subst (λ x → S₊∙ (suc n) →∙ coHomK-ptd x)
              (sym (+'-suc n i))
              (Iso.inv (suspKn-Iso n _) (G n i x))
  decomposeG zero zero x =
    →∙Homogeneous≡ (isHomogeneousKn _)
      (funExt λ z → (λ i → x ·₀ ∣ z ∣) ∙ h3 x z ∙ sym (transportRefl _))
      where
      h3 : (x : ℤ) (z : S¹)
        → _·₀_ {n = 1} x ∣ z ∣
          ≡ fst (Iso.inv (suspKn-Iso 0 zero) (G zero zero x)) z
      h3 =
        Int-ind _
          (λ { base → refl ; (loop i) j → Kn→ΩKn+10ₖ zero (~ j) i})
          (λ { base → refl ; (loop i) j → rUnit (cong ∣_∣ₕ (lUnit loop j)) j i})
          (λ { base → refl ; (loop i) j → rUnit (cong ∣_∣ₕ (sym loop)) j i})
          λ x y inx iny z
            → rightDistr-⌣ₖ 0 1 x y ∣ z ∣
            ∙∙ cong₂ _+ₖ_ (inx z) (iny z)
            ∙∙ sym (glIsoInvHom zero zero x y z)
  decomposeG (suc i) zero x =
    →∙Homogeneous≡ (isHomogeneousKn _)
      (funExt λ z → lem z
            ∙ sym (transportRefl
               ((Iso.inv (suspKn-Iso zero (suc i)) (G zero (suc i) x)) .fst z)))
    where
    lem : (z : S₊ 1)
      → _ ≡ Iso.inv (suspKn-Iso zero (suc i)) (G zero (suc i) x) .fst z
    lem base = refl
    lem (loop k) j = Kn→ΩKn+1 (suc i) (lUnit⌣ₖ _ x (~ j)) k
  decomposeG zero (suc n) x =
    →∙Homogeneous≡ (isHomogeneousKn _)
      (funExt λ z → main x z
        ∙ λ i → transportRefl
                  (Iso.inv (suspKn-Iso (suc n) (suc n))
                           (G (suc n) zero x)) (~ i) .fst z)
      where
      +merid : rUnitₖ (suc (suc n)) ∣ south ∣ ≡ cong ∣_∣ₕ (merid (ptSn _))
      +merid = sym (lUnit _)
             ∙ cong (cong ∣_∣ₕ)
             λ j i → transp (λ _ → S₊ (suc (suc n))) (i ∨ j)
                             (merid (ptSn (suc n)) i)

      lem : (a : S₊ (suc n))
        → PathP (λ i → ∣ merid a i ∣ₕ
                       ≡ Kn→ΩKn+1 (suc n) (∣ a ∣ +ₖ (0ₖ _)) i)
                 refl (sym (rUnitₖ (suc (suc n)) ∣ south ∣))
      lem a =
        flipSquare ((λ i j → ∣ compPath-filler (merid a)
                                 (sym (merid (ptSn _))) i j ∣ₕ)
              ▷ cong (Kn→ΩKn+1 (suc n)) (sym (rUnitₖ (suc n) ∣ a ∣ₕ)))
            ▷ sym (cong sym +merid)

      lem₂ : (a : S₊ (suc n)) → (λ i → -ₖ ∣ merid a i ∣)
                               ≡ Kn→ΩKn+1 (suc n) (-ₖ ∣ a ∣)
      lem₂ a =
        cong (cong ∣_∣ₕ) (sym (symDistr (merid a)
                       (sym (merid (ptSn (suc n))))))
            ∙ sym (Kn→ΩKn+1-ₖ (suc n) ∣ a ∣)

      main : (x : ℤ) (z : S₊ (suc (suc n)))
       → _⌣ₖ_ {n = suc (suc n)} {m = 0} ∣ z ∣ x
        ≡ Iso.inv (suspKn-Iso (suc n) (suc n)) (G (suc n) zero x) .fst z
      main = Int-ind _
            (λ { north → refl ; south → refl
              ; (merid a i) j → Kn→ΩKn+10ₖ (suc n) (~ j) i})
            (λ { north → refl ; south → refl
               ; (merid a i) j →
                 hcomp (λ k →
                    λ { (i = i0) → ∣ north ∣
                      ; (i = i1) → rUnitₖ (suc (suc n)) ∣ south ∣ (~ k)
                      ; (j = i0) → rUnitₖ (suc (suc n)) ∣ merid a i ∣ (~ k)
                      ; (j = i1) → lem a i k})
                      ∣ merid a i ∣ₕ})
            (λ { north → refl
               ; south → refl
               ; (merid a i) j → lem₂ a j i})
            λ x y indx indy z → leftDistr-⌣ₖ _ _ ∣ z ∣ x y
                               ∙ cong₂ _+ₖ_ (indx z) (indy z)
                               ∙ sym (glIsoInvHom _ _ _ _ _)
  decomposeG (suc i) (suc n) x =
    →∙Homogeneous≡ (isHomogeneousKn _)
      (funExt λ z → lem z
         ∙ λ j →
           transportRefl ((Iso.inv (suspKn-Iso (suc n) (suc (suc (n +ℕ i))))
                     (G (suc n) (suc i) x))) (~ j) .fst z)
    where
    lem : (z : S₊ (suc (suc n))) → _
    lem north = refl
    lem south = refl
    lem (merid a i) = refl

  isEquivGzero : (i : ℕ) → isEquiv (G zero i)
  isEquivGzero i =
    isoToIsEquiv
      (iso _ (λ f → fst f false)
        (λ {(f , p) → →∙Homogeneous≡ (isHomogeneousKn _)
              (funExt λ { false → rUnitₖ _ (f false) ; true → sym p})})
        (lUnit⌣ₖ _))

  isEquivG : (n i : ℕ) → isEquiv (G n i)
  isEquivG zero i =
    isoToIsEquiv
      (iso _ (λ f → fst f false)
        (λ {(f , p) → →∙Homogeneous≡ (isHomogeneousKn _)
              (funExt λ { false → rUnitₖ _ (f false) ; true → sym p})})
        (lUnit⌣ₖ _))
  isEquivG (suc n) i =
    subst isEquiv (sym (funExt (decomposeG i n)))
      (compEquiv (compEquiv (G n i , isEquivG n i)
        (isoToEquiv (invIso (suspKn-Iso n (n +' i)))))
        (pathToEquiv (λ j → S₊∙ (suc n) →∙ coHomK-ptd (+'-suc n i (~ j)))) .snd)

  isEquiv-g : (n i : ℕ) → isEquiv (g n i)
  isEquiv-g n i =
    subst isEquiv (sym (g≡ n i))
      (compEquiv (G n i , isEquivG n i)
        (compEquiv (indexSwap n i) (-ₖ'^-Iso n i)) .snd)

-- We now generealise the equivalence g to also apply to arbitrary fibrations (Q : B → Type)
-- satisfying (Q * ≃∙ Sⁿ)
module _ {ℓ} (B : Pointed ℓ) (Q : typ B → Pointed ℓ-zero)
         (conB : (x y : typ B) → ∥ x ≡ y ∥₁)
         (n : ℕ) (Q-is : Iso (typ (Q (pt B))) (S₊ n))
         (Q-is-ptd : Iso.fun Q-is (pt (Q (pt B))) ≡ snd (S₊∙ n))
         (c : (b : typ B) → (Q b →∙ coHomK-ptd n))
         (c-pt : c (pt B) .fst ≡ ((λ x → genFunSpace n .fst (Iso.fun Q-is x))))
         where

  g : (b : typ B) (i : ℕ) → coHomK i → (Q b →∙ coHomK-ptd (i +' n))
  fst (g b i x) y = x ⌣ₖ c b .fst y
  snd (g b i x) = cong (x ⌣ₖ_) (c b .snd) ∙ ⌣ₖ-0ₖ i n x

  g-hom : (b : typ B) (i : ℕ) → (x y : coHomK i)
        → g b i (x +ₖ y) ≡ ((g b i x) ++ (g b i y))
  g-hom b i x y =
    →∙Homogeneous≡ (isHomogeneousKn _)
      (funExt λ z → rightDistr-⌣ₖ i n x y (c b .fst z))

  gPathP' : (i : ℕ)
    → PathP (λ j → coHomK i →
                 (isoToPath Q-is j , ua-gluePath (isoToEquiv Q-is) (Q-is-ptd) j)
              →∙ coHomK-ptd (i +' n))
       (g (pt B) i) (g-base.g n i)
  gPathP' i =
    toPathP
      (funExt
      λ x → →∙Homogeneous≡ (isHomogeneousKn _)
          (funExt λ y
         → (λ i → transportRefl (transportRefl x i ⌣ₖ c (pt B) .fst
                                     (Iso.inv Q-is (transportRefl y i))) i)
                  ∙ cong (x ⌣ₖ_)
                         (funExt⁻ c-pt (Iso.inv Q-is y)
                            ∙ cong (genFunSpace n .fst) (Iso.rightInv Q-is y))))

  g-base : (i : ℕ) → isEquiv (g (pt B) i)
  g-base i = transport (λ j → isEquiv (gPathP' i (~ j))) (g-base.isEquiv-g n i)

  g-equiv : (b : typ B) (i : ℕ) → isEquiv (g b i)
  g-equiv b i =
    PT.rec (isPropIsEquiv _)
         (J (λ b _ → isEquiv (g b i))
           (g-base i))
         (conB (pt B) b)

module _ {ℓ} (B : Pointed ℓ) (Q : typ B → Pointed ℓ-zero)
         (conB : (x y : typ B) → ∥ x ≡ y ∥₂)
         (n : ℕ) (Q-is : Iso (typ (Q (pt B))) (S₊ n))
         (Q-is-ptd : Iso.fun Q-is (pt (Q (pt B))) ≡ snd (S₊∙ n)) where

  is-setQ→K : (b : typ B) → isSet (Q b →∙ coHomK-ptd n)
  is-setQ→K b =
    ST.rec (isProp→isOfHLevelSuc 1 isPropIsSet)
          (J (λ b _ → isSet (Q b →∙ coHomK-ptd n))
            (subst isSet (cong (_→∙ coHomK-ptd n)
              (ua∙ (isoToEquiv (invIso Q-is))
                   (cong (Iso.inv Q-is) (sym Q-is-ptd) ∙ Iso.leftInv Q-is _)))
              (isOfHLevelRetractFromIso 2 (fst (πS≅ℤ n)) isSetℤ)))
          (conB (pt B) b)

  isConnB : isConnected 3 (typ B)
  fst isConnB = ∣ pt B ∣
  snd isConnB =
    T.elim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _)
           λ a → ST.rec (isOfHLevelTrunc 3 _ _) (cong ∣_∣ₕ) (conB (pt B) a)

  isPropPath : isProp (∥ pt B ≡ pt B ∥₂)
  isPropPath =
    isOfHLevelRetractFromIso 1 setTruncTrunc2Iso
      (isContr→isProp (isConnectedPath _ isConnB (pt B) (pt B)))

  -- We construct a term in c* : (b : B) → (Q b →∙ Kₙ)
  -- Which is equal to the generator of (Sⁿ →∙ Kₙ) over the base point.
  c* : Σ[ c ∈ ((b : typ B) → (Q b →∙ coHomK-ptd n)) ]
         (c (pt B) .fst ≡ ((λ x → genFunSpace n .fst (Iso.fun Q-is x))))
  fst c* b =
    ST.rec (is-setQ→K b)
          (J (λ b _ → Q b →∙ coHomK-ptd n)
            ((λ x → genFunSpace n .fst (Iso.fun Q-is x))
           , cong (genFunSpace n .fst) Q-is-ptd ∙ genFunSpace n .snd))
         (conB (pt B) b)
  snd c* =
    funExt λ x → (λ i → ST.rec (is-setQ→K (pt B))
                  (J (λ b _ → Q b →∙ coHomK-ptd n)
                   ((λ x₁ → genFunSpace n .fst (Iso.fun Q-is x₁)) ,
                    (λ i → genFunSpace n .fst (Q-is-ptd i))
                          ∙ genFunSpace n .snd))
                  (isPropPath (conB (pt B) (pt B)) ∣ refl ∣₂ i) .fst x)
      ∙ (λ i → transportRefl (genFunSpace n .fst
                               (Iso.fun Q-is (transportRefl x i))) i)

  p-help : {b : fst B} (p : pt B ≡ b)
        → (subst (fst ∘ Q) (sym p) (snd (Q b))) ≡ (snd (Q (pt B)))
  p-help {b = b} =
    J (λ b p → subst (fst ∘ Q) (sym p) (snd (Q b)) ≡ snd (Q (pt B)))
      (transportRefl _)

  -- This form of c* will make things somewhat easier to work with later on.
  c≡ : (b : fst B) (p : ∥ pt B ≡ b ∥₂)
    → (c* .fst b)
      ≡ ST.rec (is-setQ→K b)
             (λ pp → (λ qb →
               genFunSpace n .fst (Iso.fun Q-is (subst (fst ∘ Q) (sym pp) qb)))
             , cong (genFunSpace n .fst ∘ Iso.fun Q-is) (p-help pp)
             ∙ ((λ i → genFunSpace n .fst (Q-is-ptd i)) ∙ genFunSpace n .snd)) p
  c≡ b =
    ST.elim (λ _ → isOfHLevelPath 2 (is-setQ→K b) _ _)
          (J (λ b a → c* .fst b ≡
      ST.rec (is-setQ→K b) (λ pp →
         (λ qb →
            genFunSpace n .fst (Iso.fun Q-is (subst (fst ∘ Q) (sym pp) qb)))
         ,
         cong (genFunSpace n .fst ∘ Iso.fun Q-is) (p-help pp) ∙
         (λ i → genFunSpace n .fst (Q-is-ptd i)) ∙ genFunSpace n .snd) ∣ a ∣₂)
      ((λ i → ST.rec (is-setQ→K (pt B))
      (J (λ b₁ _ → Q b₁ →∙ coHomK-ptd n)
       ((λ x → genFunSpace n .fst (Iso.fun Q-is x)) ,
        (λ i → genFunSpace n .fst (Q-is-ptd i)) ∙ genFunSpace n .snd))
          (isPropPath (conB (pt B) (pt B)) ∣ refl ∣₂ i))
          ∙ →∙Homogeneous≡ (isHomogeneousKn n)
            (transportRefl ((λ x → genFunSpace n .fst (Iso.fun Q-is x)))
            ∙ funExt λ x → cong (genFunSpace n .fst ∘ Iso.fun Q-is)
                     (sym (transportRefl x)))))

-- We are now almost ready to define the Thom isomorphism.
-- The following module contains the types and functions occuring in it.
module preThom {ℓ ℓ'} (B : Pointed ℓ) (P : typ B → Type ℓ') where
  E : Type _
  E = Σ (typ B) P

  Ẽ : Type _
  Ẽ = Pushout {A = E} (λ _ → tt) fst

  i : (n : ℕ) → (P-base : Iso (P (pt B)) (S₊ n)) → S₊ (suc n) → Ẽ
  i zero P-base base = inr (pt B)
  i zero P-base (loop j) = (sym (push (pt B , Iso.inv P-base false))
                               ∙ push ((pt B) , Iso.inv P-base true)) j
  i (suc n) P-base north = inl tt
  i (suc n) P-base south = inr (pt B)
  i (suc n) P-base (merid a i₁) = push (pt B , Iso.inv P-base a) i₁

  Q : typ B → Pointed ℓ'
  Q x = Susp (P x) , north

  F : Type _
  F = Σ (typ B) λ x → Q x .fst

  F̃ : Type _
  F̃ = Pushout {A = typ B} {C = F} (λ _ → tt) λ b → b , north

  invFE : Ẽ → F̃
  invFE (inl x) = inl tt
  invFE (inr x) = inr (x , south)
  invFE (push (x , a) i₁) = ((push x) ∙ λ i → inr (x , merid a i)) i₁

  funFE : F̃ → Ẽ
  funFE (inl x) = inl tt
  funFE (inr (x , north)) = inl tt
  funFE (inr (x , south)) = inr x
  funFE (inr (x , merid a i₁)) = push (x , a) i₁
  funFE (push a i₁) = inl tt

  IsoFE : Iso F̃ Ẽ
  Iso.fun IsoFE = funFE
  Iso.inv IsoFE = invFE
  Iso.rightInv IsoFE (inl x) = refl
  Iso.rightInv IsoFE (inr x) = refl
  Iso.rightInv IsoFE (push (x , a) i₁) k = lem k i₁
    where
    lem : cong funFE (((push x) ∙ λ i → inr (x , merid a i)))
        ≡ push (x , a)
    lem = congFunct funFE (push x) (λ i → inr (x , merid a i))
     ∙ sym (lUnit (push (x , a)))
  Iso.leftInv IsoFE (inl x) = refl
  Iso.leftInv IsoFE (inr (x , north)) = push x
  Iso.leftInv IsoFE (inr (x , south)) = refl
  Iso.leftInv IsoFE (inr (x , merid a i)) j =
    compPath-filler' (push x) (λ i₁ → inr (x , merid a i₁)) (~ j) i
  Iso.leftInv IsoFE (push a i₁) k =  push a (i₁ ∧ k)

  F̃→Q : ∀ {ℓ} {A : Pointed ℓ} → (F̃ , inl tt) →∙ A → (b : typ B) → Q b →∙ A
  fst (F̃→Q {A = A , a} (f , p) b) north = f (inr (b , north))
  fst (F̃→Q {A = A , a} (f , p) b) south = f (inr (b , south))
  fst (F̃→Q {A = A , a} (f , p) b) (merid a₁ i₁) = f (inr (b , merid a₁ i₁))
  snd (F̃→Q {A = A , a} (f , p) b) = sym (cong f (push b)) ∙ p

  Q→F̃ : ∀ {ℓ} {A : Pointed ℓ} → ((b : typ B) → Q b →∙ A) → (F̃ , inl tt) →∙ A
  fst (Q→F̃ {A = A , a} f) (inl x) = a
  fst (Q→F̃ {A = A , a} f) (inr (x , north)) = f x .fst north
  fst (Q→F̃ {A = A , a} f) (inr (x , south)) = f x .fst south
  fst (Q→F̃ {A = A , a} f) (inr (x , merid a₁ i₁)) = f x .fst (merid a₁ i₁)
  fst (Q→F̃ {A = A , a} f) (push a₁ i₁) = snd (f a₁) (~ i₁)
  snd (Q→F̃ {A = A , a} f) = refl

  Q→F̃-hom : (n : ℕ) → (f g : ((b : typ B) → Q b →∙ coHomK-ptd n))
             → Q→F̃ (λ b → f b ++ g b) ≡ (Q→F̃ f ++ Q→F̃ g)
  Q→F̃-hom n f g =
    →∙Homogeneous≡ (isHomogeneousKn _)
      (funExt λ { (inl x) → sym (rUnitₖ _ (0ₖ _))
                ; (inr (x , north)) → refl
                ; (inr (x , south)) → refl
                ; (inr (x , merid a i₁)) → refl
                ; (push a j) i →
                  compPath-filler (cong₂ _+ₖ_ (snd (f a)) (snd (g a)))
                                  (rUnitₖ n (0ₖ n)) (~ i) (~ j)})

  Q→F̃→Q : ∀ {ℓ} {A : Pointed ℓ}
    → (x : (b : typ B) → Q b →∙ A) (b : typ B) (q : Q b .fst)
    → F̃→Q (Q→F̃ x) b .fst q ≡ x b .fst q
  Q→F̃→Q f b north = refl
  Q→F̃→Q f b south = refl
  Q→F̃→Q f b (merid a i₁) = refl

  F̃→Q→F̃ : ∀ {ℓ} {A : Pointed ℓ} (f : F̃ → typ A) (p : _)
    → (x : F̃) → fst (Q→F̃ {A = A} (F̃→Q (f , p))) x ≡ f x
  F̃→Q→F̃ f p (inl x) = sym p
  F̃→Q→F̃ f p (inr (x , north)) = refl
  F̃→Q→F̃ f p (inr (x , south)) = refl
  F̃→Q→F̃ f p (inr (x , merid a i₁)) = refl
  F̃→Q→F̃ f p (push a i₁) j =
    compPath-filler (sym (cong f (push a))) p (~ j) (~ i₁)

  IsoF̃Q : ∀ {ℓ} {A : Pointed ℓ}
    → Iso ((F̃ , inl tt) →∙ A)
          ((b : typ B) → Q b →∙ A)
  Iso.fun (IsoF̃Q {A = A , a}) = F̃→Q
  Iso.inv (IsoF̃Q {A = A , a}) = Q→F̃
  Iso.rightInv (IsoF̃Q {A = A , a}) f =
    funExt λ b → ΣPathP (funExt (Q→F̃→Q f b)
               , sym (rUnit (snd (f b))))
  Iso.leftInv (IsoF̃Q {A = A , a}) (f , p) =
    ΣPathP ((funExt (F̃→Q→F̃ f p))
         , λ i j → p (~ i ∨ j))

  -- The main result
  ι : (k : ℕ) → Iso ((b : typ B) → Q b →∙ coHomK-ptd k)
                      ((Ẽ , inl tt) →∙ coHomK-ptd k)
  ι k = compIso (invIso IsoF̃Q) IsoFE-extend
    where

    IsoFE-extend : Iso ((F̃ , inl tt) →∙ coHomK-ptd k)
             ((Ẽ , inl tt) →∙ coHomK-ptd k)
    Iso.fun IsoFE-extend G = (λ x → G .fst (Iso.inv IsoFE x))
                , (snd G)
    Iso.inv IsoFE-extend G = (λ x → G .fst (Iso.fun IsoFE x))
                , (snd G)
    Iso.rightInv IsoFE-extend G =
      →∙Homogeneous≡ (isHomogeneousKn _)
        (funExt λ x → cong (G .fst) (Iso.rightInv IsoFE x))
    Iso.leftInv IsoFE-extend G =
      →∙Homogeneous≡ (isHomogeneousKn _)
        (funExt λ x → cong (G .fst) (Iso.leftInv IsoFE x))

  ι-hom : (k : ℕ) → (f g : ((b : typ B) → Q b →∙ coHomK-ptd k))
                   → Iso.fun (ι k) (λ b → f b ++ g b)
                   ≡ (Iso.fun (ι k) f ++ Iso.fun (ι k) g)
  ι-hom k f g =
    →∙Homogeneous≡ (isHomogeneousKn _)
        (funExt λ x → funExt⁻ (cong fst (Q→F̃-hom _ f g)) (invFE x))

-- Packing everything up gives us the Thom Isomorphism between
-- the nᵗʰ cohomology of B and the (n+i)ᵗʰ reduced cohomology of Ẽ,
-- as defined above
module Thom {ℓ} (B : Pointed ℓ) (P : typ B → Type ℓ-zero)
         (conB : (x y : typ B) → ∥ x ≡ y ∥₁)
         (n : ℕ) (Q-is : Iso (typ (preThom.Q B P (pt B))) (S₊ n))
         (Q-is-ptd : Iso.fun Q-is (pt (preThom.Q B P (pt B))) ≡ snd (S₊∙ n))
         (c : (b : typ B) → (preThom.Q B P b →∙ coHomK-ptd n))
         (c-pt : c (pt B) .fst ≡ ((λ x → genFunSpace n .fst (Iso.fun Q-is x))))
         where

  ϕ : (i : ℕ)
    → GroupEquiv (coHomGr i (typ B))
                  (coHomRedGrDir (i +' n) (preThom.Ẽ B P , inl tt))
  fst (ϕ i) =
    isoToEquiv
      (setTruncIso
        (compIso
          (codomainIsoDep
            λ b →
              equivToIso ((g B (preThom.Q B P) conB n Q-is Q-is-ptd c c-pt b i)
                 , g-equiv B (preThom.Q B P) conB n Q-is Q-is-ptd c c-pt b i))
            (preThom.ι B P (i +' n))))
  snd (ϕ i) =
    makeIsGroupHom
    (ST.elim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _)
      λ F G →
        cong ∣_∣₂ (cong (Iso.fun (preThom.ι B P (i +' n)))
                       (funExt (λ a →
                         g-hom B (preThom.Q B P)
                               conB n Q-is Q-is-ptd c c-pt a i (F a) (G a)))
                     ∙ preThom.ι-hom B P (i +' n) _ _)
           ∙ addAgree (i +' n) _ _)

-- We finally get the Gysin sequence
module Gysin {ℓ} (B : Pointed ℓ) (P : typ B → Type ℓ-zero)
         (conB : (x y : typ B) → ∥ x ≡ y ∥₂)
         (n : ℕ) (Q-is : Iso (typ (preThom.Q B P (pt B))) (S₊ n))
         (Q-is-ptd : Iso.fun Q-is (pt (preThom.Q B P (pt B))) ≡ snd (S₊∙ n))
         where

  0-connB : (x y : typ B) → ∥ x ≡ y ∥₁
  0-connB x y = ST.rec (isProp→isSet squash₁) (∥_∥₁.∣_∣₁) (conB x y)

  c = (c* B (preThom.Q B P) conB n Q-is Q-is-ptd .fst)
  c-ptd = (c* B (preThom.Q B P) conB n Q-is Q-is-ptd .snd)
  cEq = c≡ B (preThom.Q B P) conB n Q-is Q-is-ptd

  module w = Thom B P 0-connB n Q-is Q-is-ptd c c-ptd

  ϕ = w.ϕ

  E' = preThom.E B P

  E'̃ = preThom.Ẽ B P

  -- The generator of coHom n (typ B)
  e : coHom n (typ B)
  e = ∣ (λ b → c b .fst south) ∣₂

  -- The maps of interest are ⌣, p, E-susp and j*. In reality, we are interested
  -- in the composition of ϕ and j* (which is just the cup product),
  -- but it's easier to first give an exact sequence involving p, E-susp and j*
  ⌣-hom : (i : ℕ) → GroupHom (coHomGr i (typ B)) (coHomGr (i +' n) (typ B))
  fst (⌣-hom i) x = x ⌣ e
  snd (⌣-hom i) =
    makeIsGroupHom λ f g → rightDistr-⌣ _ _ f g e

  p : E' → typ B
  p = fst

  p-hom : (i : ℕ) → GroupHom (coHomGr i (typ B)) (coHomGr i E')
  p-hom i = coHomMorph _ p

  E-susp : (i : ℕ) →
    GroupHom (coHomGr i E') (coHomRedGrDir (suc i) (E'̃ , inl tt))
  fst (E-susp i) =
    ST.map λ f → (λ { (inl x) → 0ₖ _
                   ; (inr x) → 0ₖ _
                   ; (push a j) → Kn→ΩKn+1 _ (f a) j}) , refl
  snd (E-susp zero) =
    makeIsGroupHom (ST.elim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _)
      λ f g →
        cong ∣_∣₂ (→∙Homogeneous≡ (isHomogeneousKn 1)
          (funExt λ { (inl x) → refl
                    ; (inr x) → refl
                    ; (push a j) k →
                      (Kn→ΩKn+1-hom zero (f a) (g a)
                     ∙ ∙≡+₁ (Kn→ΩKn+1 _ (f a)) (Kn→ΩKn+1 _ (g a))) k j})))
  snd (E-susp (suc i)) =
    makeIsGroupHom (ST.elim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _)
      λ f g →
        cong ∣_∣₂ (→∙Homogeneous≡ (isHomogeneousKn _)
          (funExt λ { (inl x) → refl
                    ; (inr x) → refl
                    ; (push a j) k → (Kn→ΩKn+1-hom _ (f a) (g a)
                                   ∙ ∙≡+₂ _ (Kn→ΩKn+1 _ (f a))
                                            (Kn→ΩKn+1 _ (g a))) k j})))

  module cofibSeq where
    j* : (i : ℕ) →
      GroupHom (coHomRedGrDir i (E'̃ , (inl tt))) (coHomGr i (typ B))
    fst (j* i) = ST.map λ f → λ x → fst f (inr x)
    snd (j* zero) =
      makeIsGroupHom
        (ST.elim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _) λ _ _ → refl)
    snd (j* (suc zero)) =
      makeIsGroupHom
        (ST.elim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _) λ _ _ → refl)
    snd (j* (suc (suc i₁))) =
      makeIsGroupHom
        (ST.elim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _) λ _ _ → refl)

    Im-j⊂Ker-p : (i : ℕ) (x : _) → isInIm (j* i) x → isInKer (p-hom i) x
    Im-j⊂Ker-p i =
      ST.elim (λ _ → isSetΠ (λ _ → isOfHLevelPath 2 squash₂ _ _))
        λ f → PT.rec (squash₂ _ _)
          (uncurry (ST.elim (λ _ → isSetΠ (λ _ → isOfHLevelPath 2 squash₂ _ _))
            λ g P → subst (isInKer (p-hom i)) P
              (cong ∣_∣₂ (funExt λ x →
                cong (g .fst) (sym (push x)) ∙ g .snd))))

    Ker-p⊂Im-j : (i : ℕ) (x : _) → isInKer (p-hom i) x → isInIm (j* i) x
    Ker-p⊂Im-j i =
      ST.elim (λ _ → isSetΠ (λ _ → isProp→isSet squash₁))
        λ f ker → PT.rec squash₁
          (λ id → ∣ ∣ (λ { (inl x) → 0ₖ _
                         ; (inr x) → f x
                         ; (push a i₁) → funExt⁻ id a (~ i₁)}) , refl ∣₂
                         , refl ∣₁)
                   (Iso.fun PathIdTrunc₀Iso ker)

  Im-p⊂Ker-Susp : (i : ℕ) (x : _)
                → isInIm (p-hom i) x → isInKer (E-susp i) x
  Im-p⊂Ker-Susp i =
    ST.elim (λ _ → isSetΠ (λ _ → isOfHLevelPath 2 squash₂ _ _))
      λ f → PT.rec (squash₂ _ _)
        (uncurry (ST.elim (λ _ → isSetΠ (λ _ → isOfHLevelPath 2 squash₂ _ _))
          λ g y → subst (isInKer (E-susp i)) y
            (cong ∣_∣₂ (→∙Homogeneous≡ (isHomogeneousKn _)
              (funExt λ { (inl x) → refl
                        ; (inr x) → sym (Kn→ΩKn+1 _ (g x))
                        ; (push a j) k → Kn→ΩKn+1 i (g (fst a)) (~ k ∧ j)})))))

  Ker-Susp⊂Im-p : (i : ℕ) (x : _)
                → isInKer (E-susp i) x → isInIm (p-hom i) x
  Ker-Susp⊂Im-p i =
    ST.elim (λ _ → isSetΠ (λ _ → isProp→isSet squash₁))
      λ f ker → PT.rec squash₁
        (λ id → ∣ ∣ (λ x → ΩKn+1→Kn i (sym (funExt⁻ (cong fst id) (inr x)))) ∣₂
                  , cong ∣_∣₂ (funExt (λ { (a , b) →
                         cong (ΩKn+1→Kn i)
                           (lUnit _
                          ∙ cong (_∙ sym (funExt⁻ (λ i₁ → fst (id i₁)) (inr a)))
                           (sym (flipSquare (cong snd id))
                       ∙∙ (PathP→compPathR
                            (cong (funExt⁻ (cong fst id)) (push (a , b))))
                       ∙∙ assoc _ _ _
                        ∙ sym (rUnit _))
                        ∙ (sym (assoc _ _ _)
                        ∙∙ cong (Kn→ΩKn+1 i (f (a , b)) ∙_) (rCancel _)
                        ∙∙ sym (rUnit _)))
                        ∙ Iso.leftInv (Iso-Kn-ΩKn+1 _) (f (a , b))})) ∣₁)
        (Iso.fun PathIdTrunc₀Iso ker)

  Im-Susp⊂Ker-j : (i : ℕ) (x : _)
               → isInIm (E-susp i) x → isInKer (cofibSeq.j* (suc i)) x
  Im-Susp⊂Ker-j i =
    ST.elim (λ _ → isSetΠ (λ _ → isOfHLevelPath 2 squash₂ _ _))
      λ g → PT.rec (squash₂ _ _)
        (uncurry (ST.elim (λ _ → isSetΠ (λ _ → isOfHLevelPath 2 squash₂ _ _))
          λ f id → PT.rec (squash₂ _ _)
            (λ P → subst (isInKer (cofibSeq.j* (suc i))) (cong ∣_∣₂ P)
              (cong ∣_∣₂ refl))
            (Iso.fun PathIdTrunc₀Iso id)))

  Ker-j⊂Im-Susp : (i : ℕ) (x : _)
                → isInKer (cofibSeq.j* (suc i)) x → isInIm (E-susp i) x
  Ker-j⊂Im-Susp i =
    ST.elim (λ _ → isSetΠ (λ _ → isProp→isSet squash₁))
      λ f ker
       → PT.rec squash₁
          (λ p → ∣ ∣ (λ x → ΩKn+1→Kn _ (sym (snd f)
                                     ∙∙ cong (fst f) (push x)
                                     ∙∙ funExt⁻ p (fst x))) ∣₂
                  , cong ∣_∣₂ (→∙Homogeneous≡ (isHomogeneousKn _)
                    (funExt (λ { (inl x) → sym (snd f)
                               ; (inr x) → sym (funExt⁻ p x)
                               ; (push a j) k → h3 f p a k j}))) ∣₁)
          (Iso.fun PathIdTrunc₀Iso ker)
          where
          h3 : (f : (E'̃ , inl tt) →∙ coHomK-ptd (suc i))
           → (p : (fst f ∘ inr) ≡ (λ _ → 0ₖ (suc i)))
           → (a : preThom.E B P)
           → PathP (λ i → snd f (~ i) ≡ p (~ i) (fst a))
                   (Kn→ΩKn+1 i (ΩKn+1→Kn i (sym (snd f)
                                          ∙∙ cong (fst f) (push a)
                                          ∙∙ funExt⁻ p (fst a))))
                   (cong (fst f) (push a))
          h3 f p a =
            Iso.rightInv (Iso-Kn-ΩKn+1 i) _
              ◁ λ i j →
                 doubleCompPath-filler (sym (snd f)) (cong (fst f) (push a))
                 (funExt⁻ p (fst a)) (~ i) j

  -- We compose ϕ and j*. The above exact sequence will induce another one for
  -- this composition. In fact, this group hom is definitionally equal to
  -- (λ x → x ⌣ e) modulo truncation elimination and snd fields.
  ϕ∘j : (i : ℕ) → GroupHom (coHomGr i (typ B)) (coHomGr (i +' n) (typ B))
  ϕ∘j i = compGroupHom (fst (fst (ϕ i)) , snd (ϕ i)) (cofibSeq.j* (i +' n))

  private
    +'-suc : (i n : ℕ) → (suc i +' n) ≡ suc (i +' n)
    +'-suc zero zero = refl
    +'-suc (suc i₁) zero = refl
    +'-suc zero (suc n) = refl
    +'-suc (suc i₁) (suc n) = refl

    Path→GroupPath : ∀ {ℓ ℓ'} {n m : ℕ} (G : ℕ → Group ℓ) (H : Group ℓ')
         (p : n ≡ m)
      → GroupEquiv (G n) H
      → GroupEquiv (G m) H
    Path→GroupPath {n = n} G H =
      J (λ m _ → GroupEquiv (G n) H → GroupEquiv (G m) H)
        λ p → p

    h-ret : ∀ {ℓ ℓ'} {n m : ℕ} (G : ℕ → Group ℓ) (H : Group ℓ')
      → (e : GroupEquiv (G n) H)
      → (p : n ≡ m)
      → (x : G m .fst)
      → invEq (fst e) (fst (fst (Path→GroupPath G H p e)) x)
       ≡ subst (λ x → G x .fst) (sym p) x
    h-ret G H e =
      J (λ m p → ((x : G m .fst)
               → invEq (fst e) (fst (fst (Path→GroupPath G H p e)) x)
                ≡ subst (λ x → G x .fst) (sym p) x))
        λ x → cong (invEq (fst e) )
              (λ i → transportRefl (transportRefl (fst (fst e)
                     (transportRefl (transportRefl x i) i)) i) i)
           ∙∙ retEq (fst e) x
           ∙∙ sym (transportRefl _)

  thomIso' : (i : ℕ) → GroupEquiv (coHomRedGrDir (suc (i +' n)) (E'̃ , inl tt))
                            (coHomGr (suc i) (typ B))
  thomIso' i = (Path→GroupPath
                (λ n → coHomRedGrDir n (E'̃ , inl tt)) _ (+'-suc i n)
                  (invGroupEquiv (ϕ (suc i))))

  ϕ' : (i : ℕ) → GroupHom (coHomRedGrDir (suc (i +' n)) (E'̃ , inl tt))
                            (coHomGr (suc i) (typ B))
  ϕ' i = fst (fst (thomIso' i)) , snd (thomIso' i)

  susp∘ϕ : (i : ℕ) → GroupHom (coHomGr (i +' n) E') (coHomGr (suc i) (typ B))
  susp∘ϕ i = compGroupHom (E-susp (i +' n)) (ϕ' i)

  Im-ϕ∘j⊂Ker-p : (i : ℕ) (x : _) → isInIm (ϕ∘j i) x → isInKer (p-hom _) x
  Im-ϕ∘j⊂Ker-p i x p =
    cofibSeq.Im-j⊂Ker-p _ x
      (PT.rec squash₁ (uncurry (λ f p → ∣ fst (fst (ϕ _)) f , p ∣₁)) p)

  Ker-p⊂Im-ϕ∘j : (i : ℕ) (x : _) → isInKer (p-hom _) x → isInIm (ϕ∘j i) x
  Ker-p⊂Im-ϕ∘j i x p =
    PT.rec squash₁
      (uncurry (λ f p →
          ∣ (invEq (fst (ϕ _)) f)
         , (cong (fst (cofibSeq.j* _)) (secEq (fst (ϕ _)) f) ∙ p) ∣₁))
        (cofibSeq.Ker-p⊂Im-j _ x p)

  Im-p⊂KerSusp∘ϕ : (i : ℕ) (x : _)
                 → isInIm (p-hom _) x → isInKer (susp∘ϕ i) x
  Im-p⊂KerSusp∘ϕ i x p =
    cong (fst (ϕ' _)) (Im-p⊂Ker-Susp _ x p) ∙ IsGroupHom.pres1 (snd (ϕ' _))

  KerSusp∘ϕ⊂Im-p : (i : ℕ) (x : _)
    → isInKer (susp∘ϕ i) x → isInIm (p-hom _) x
  KerSusp∘ϕ⊂Im-p i x p =
    Ker-Susp⊂Im-p _ x (sym (retEq (fst (thomIso' _)) _)
                    ∙ (cong (invEq (fst (thomIso' _))) p
                    ∙ IsGroupHom.pres1 (snd (invGroupEquiv (thomIso' _)))))

  Im-Susp∘ϕ⊂Ker-ϕ∘j : (i : ℕ) → (x : _)
                    → isInIm (susp∘ϕ i) x → isInKer (ϕ∘j (suc i)) x
  Im-Susp∘ϕ⊂Ker-ϕ∘j i x =
    PT.rec (squash₂ _ _)
      (uncurry λ f → J (λ x p → isInKer (ϕ∘j (suc i)) x)
        ((λ i → fst (cofibSeq.j* _) (fst (fst (ϕ _)) (fst (ϕ' _) (fst (E-susp _) f))))
             ∙∙ cong (fst (cofibSeq.j* _))
                     ((h-ret (λ n → coHomRedGrDir n (E'̃ , inl tt)) _
                             (invGroupEquiv (ϕ (suc i))) (+'-suc i n)) (fst (E-susp _) f))
             ∙∙ (natTranspLem _ (λ n → fst (cofibSeq.j* n)) (sym (+'-suc i n))
             ∙ cong (subst (λ z → coHomGr z (typ B) .fst) (sym (+'-suc i n)))
                    (Im-Susp⊂Ker-j _ (fst (E-susp (i +' n)) f) ∣ f , refl ∣₁)
              ∙ tLem i n)))
    where
    tLem : (i n : ℕ) → subst (λ z → coHomGr z (typ B) .fst) (sym (+'-suc i n))
                               (0ₕ _) ≡ 0ₕ _
    tLem zero zero = refl
    tLem zero (suc n) = refl
    tLem (suc i₁) zero = refl
    tLem (suc i₁) (suc n) = refl

  Ker-ϕ∘j⊂Im-Susp∘ϕ : (i : ℕ) (x : _)
    → isInKer (ϕ∘j (suc i)) x → isInIm (susp∘ϕ i) x
  Ker-ϕ∘j⊂Im-Susp∘ϕ i x p =
    PT.rec squash₁
      (uncurry (λ f p → ∣ f , cong (fst (fst (thomIso' i))) p
                        ∙ secEq (fst (thomIso' _)) x ∣₁))
      (Ker-j⊂Im-Susp _ (invEq (fst (thomIso' _)) x)
        ((cong (cofibSeq.j* (suc (i +' n)) .fst ) lem₁
        ∙ natTranspLem _ (λ n → cofibSeq.j* n .fst) (+'-suc i n))
        ∙∙ cong (transport (λ j → (coHomGr (+'-suc i n j) (typ B) .fst))) p
        ∙∙ lem₂ i n))
    where
    lem₁ : invEq (fst (thomIso' i)) x
         ≡ transport (λ j → coHomRed (+'-suc i n j)
                     (E'̃ , inl tt)) (fst (fst (ϕ _)) x)
    lem₁ = cong (transport (λ j → coHomRed (+'-suc i n j) (E'̃ , inl tt)))
                (transportRefl _ ∙ cong (fst (fst (ϕ _)))
                  λ i → transportRefl (transportRefl x i) i)

    lem₂ : (i n : ℕ)
         → transport (λ j → coHomGr (+'-suc i n j) (typ B) .fst)
                      (GroupStr.1g (coHomGr (suc i +' n) (typ B) .snd)) ≡ 0ₕ _
    lem₂ zero zero = refl
    lem₂ zero (suc n) = refl
    lem₂ (suc i₁) zero = refl
    lem₂ (suc i₁) (suc n) = refl

  -- Finally, we have that ϕ∘j is just the cup product, and we have arrived
  -- at an exact sequence involving it.
  ϕ∘j≡ : (i : ℕ) → ϕ∘j i ≡ ⌣-hom i
  ϕ∘j≡ i =
    Σ≡Prop (λ _ → isPropIsGroupHom _ _)
           (funExt (ST.elim (λ _ → isOfHLevelPath 2 squash₂ _ _)
           λ _ → refl))

  -- We can now restate the previous resluts for (λ x → x ⌣ e)
  Im-⌣e⊂Ker-p : (i : ℕ) (x : _)
              → isInIm (⌣-hom i) x → isInKer (p-hom _) x
  Im-⌣e⊂Ker-p i x p =
    Im-ϕ∘j⊂Ker-p i x (subst (λ p → isInIm p x) (sym (ϕ∘j≡ i)) p)

  Ker-p⊂Im-⌣e : (i : ℕ) (x : _)
              → isInKer (p-hom _) x → isInIm (⌣-hom i) x
  Ker-p⊂Im-⌣e i x p =
    subst (λ p → isInIm p x) (ϕ∘j≡ i) (Ker-p⊂Im-ϕ∘j i x p)

  Im-Susp∘ϕ⊂Ker-⌣e : (i : ℕ) (x : _)
                   → isInIm (susp∘ϕ i) x → isInKer (⌣-hom (suc i)) x
  Im-Susp∘ϕ⊂Ker-⌣e i x p =
    subst (λ p → isInKer p x) (ϕ∘j≡ (suc i)) (Im-Susp∘ϕ⊂Ker-ϕ∘j i x p)

  Ker-⌣e⊂Im-Susp∘ϕ : (i : ℕ) (x : _)
                   → isInKer (⌣-hom (suc i)) x → isInIm (susp∘ϕ i) x
  Ker-⌣e⊂Im-Susp∘ϕ i x p =
    Ker-ϕ∘j⊂Im-Susp∘ϕ i x (subst (λ p → isInKer p x) (sym (ϕ∘j≡ (suc i))) p)


-- Andreas, 2013-12-28
-- Reported by jesper.cockx, Dec 20, 2013

-- WAS:  In the following example, there is an unsolved instance
-- argument, but no part of the code is highlighted.

typeof : ∀ {{T : Set}} → T → Set
typeof {{T}} x = T

test : {A : Set} {B : Set} (y : A) → typeof y
test y = y

-- Should solve the instance argument, no constraint should remain.


{-# OPTIONS --guardedness #-}

open import Agda.Builtin.Coinduction
open import Agda.Builtin.IO
open import Agda.Builtin.List
open import Agda.Builtin.Nat
open import Agda.Builtin.String
open import Agda.Builtin.Unit

private
  variable
    A : Set

postulate
  putStrLn : String → IO ⊤

{-# FOREIGN GHC import qualified Data.Text.IO #-}
{-# COMPILE GHC putStrLn = Data.Text.IO.putStrLn #-}

record Stream₁ (A : Set) : Set where
  coinductive
  constructor _∷_
  field
    head : A
    tail : Stream₁ A

open Stream₁

repeat₁ : A → Stream₁ A
repeat₁ x .head = x
repeat₁ x .tail = repeat₁ x

take₁ : Nat → Stream₁ A → List A
take₁ zero    xs = []
take₁ (suc n) xs = xs .head ∷ take₁ n (xs .tail)

data List′ (A : Set) : Set where
  []  : List′ A
  _∷_ : A → List′ A → List′ A

to-list : List′ A → List A
to-list []       = []
to-list (x ∷ xs) = x ∷ to-list xs

data Stream₂ (A : Set) : Set where
  _∷_ : A → ∞ (Stream₂ A) → Stream₂ A

repeat₂ : A → Stream₂ A
repeat₂ x = x ∷ ♯ repeat₂ x

take₂ : Nat → Stream₂ A → List′ A
take₂ zero    _        = []
take₂ (suc n) (x ∷ xs) = x ∷ take₂ n (♭ xs)

_++_ : List A → List′ A → List A
[]       ++ ys = to-list ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

main : IO ⊤
main =
  putStrLn
    (primStringFromList
       (take₁ 3 (repeat₁ '(') ++ take₂ 3 (repeat₂ ')')))