open import Data.Empty

open import AEff
open import EffectAnnotations
open import Renamings
open import Types hiding (``)

open import Relation.Binary.PropositionalEquality hiding ([_])

module Substitutions where

-- PARALLEL SUBSTITUTIONS

data Sub : Ctx → Ctx → Set where

  ⟨_,_⟩ : {Γ Γ' : Ctx} {X : VType} →
          Sub Γ Γ' →
          Γ' ⊢V⦂ X →
          --------------------------
          Sub (Γ ∷ X) Γ'

  ε     : {Γ' : Ctx} →
          ------------
          Sub [] Γ'

  π     : {Γ Γ' : Ctx} {X : VType} →
          Sub Γ Γ' →
          --------------------------
          Sub Γ (Γ' ∷ X)

  φ     : {Γ Γ' : Ctx} →
          Sub Γ Γ' →
          ----------------
          Sub (Γ ■) (Γ' ■)

-- RENAMINGS AS SUBSTITUTIONS

sub-of-ren : {Γ Γ' : Ctx} →
             Ren Γ Γ' →
             --------------
             Sub Γ Γ'

sub-of-ren ε =
  ε
sub-of-ren ⟨ f , x ⟩ =
  ⟨ sub-of-ren f , ` x ⟩
sub-of-ren (π f) =
  π (sub-of-ren f)
sub-of-ren (φ f) =
  φ (sub-of-ren f)

-- IDENTITY SUBSTITUTION

sub-id : {Γ : Ctx} →
         -----------
         Sub Γ Γ

sub-id = sub-of-ren ren-id

-- SUBSTITUTION EXTENSION

_[_]s : {Γ Γ' : Ctx} {X : VType} →
        Sub Γ Γ' →
        Γ' ⊢V⦂ X →
        --------------------------
        Sub (Γ ∷ X) Γ'

s [ V ]s = ⟨ s , V ⟩

-- CONGRUENCE OF SUBSTITUTIONS

subst-cong : {Γ Γ' : Ctx} {X : VType} → Sub Γ Γ' → Sub (Γ ∷ X) (Γ' ∷ X)
subst-cong ⟨ s , x ⟩ =
  ⟨ π ⟨ s , x ⟩ , ` Hd ⟩
subst-cong ε =
  ⟨ ε , ` Hd ⟩
subst-cong (π s) =
  ⟨ π (π s) , ` Hd ⟩
subst-cong (φ s) =
  ⟨ π (φ s) , ` Hd ⟩

-- ACTION OF SUBSTITUTION ON WELL-TYPED VALUES AND COMPUTATIONS

val-of-sub : {Γ Γ' : Ctx} {X : VType} → Sub Γ Γ' → X ∈ Γ → Γ' ⊢V⦂ X
val-of-sub ⟨ s , V ⟩ Hd =
  V
val-of-sub ⟨ s , V ⟩ (Tl-v x) =
  val-of-sub s x
val-of-sub (π s) x =
  V-rename ren-wk (val-of-sub s x)
val-of-sub (φ s) (Tl-■ p x) =
  ■-wk p (val-of-sub s x)

mutual

  sub-var : {Γ Γ' : Ctx} {X : VType} →
            X ∈ Γ →
            Sub Γ Γ' →
            --------------------------
            Γ' ⊢V⦂ X

  sub-var Hd ⟨ s , V ⟩ =
    V
  sub-var Hd (π s) =
    V-rename ren-wk (val-of-sub s Hd)
  sub-var (Tl-v x) ⟨ s , V ⟩ =
    sub-var x s
  sub-var (Tl-v x) (π s) =
    V-rename ren-wk (val-of-sub s (Tl-v x))
  sub-var (Tl-■ p x) (π s) =
    V-rename ren-wk (val-of-sub s (Tl-■ p x))
  sub-var (Tl-■ p x) (φ s) =
    ■-wk p (val-of-sub s x)

  sub-comp : {Γ Γ' Γ'' : Ctx} →
             Sub Γ' Γ'' →
             Sub Γ Γ' →
             ------------------
             Sub Γ Γ''

  sub-comp t ⟨ s , V ⟩ =
    ⟨ sub-comp t s , V [ t ]v ⟩
  sub-comp t ε =
    ε
  sub-comp ⟨ t , x ⟩ (π s) =
    sub-comp t s
  sub-comp (π t) (π s) =
    π (sub-comp t (π s))
  sub-comp (π t) (φ s) =
    π (sub-comp t (φ s))
  sub-comp (φ t) (φ s) =
    φ (sub-comp t s)

  _[_]v : {Γ Γ' : Ctx} {X : VType} →
          Γ ⊢V⦂ X →
          Sub Γ Γ' →
          --------------------------
          Γ' ⊢V⦂ X

  (` x) [ s ]v =
    sub-var x s
  (´ c) [ s ]v =
    ´ c
  ⋆ [ s ]v =
    ⋆
  (ƛ M) [ s ]v =
    ƛ (M [ subst-cong s ]c)
  ⟨ V ⟩ [ s ]v =
    ⟨ V [ s ]v ⟩
  (□ V) [ s ]v =
    □ (V [ φ s ]v)

  _[_]c : {Γ Γ' : Ctx} {C : CType} →
          Γ ⊢C⦂ C →
          Sub Γ Γ' →
          --------------------------
          Γ' ⊢C⦂ C

  (return V) [ s ]c =
    return (V [ s ]v)
  (let= M `in N) [ s ]c =
    let= (M [ s ]c) `in (N [ subst-cong s ]c)
  (V · W) [ s ]c =
    (V [ s ]v) · (W [ s ]v)
  (↑ op p V M) [ s ]c =
    ↑ op p (V [ s ]v) (M [ s ]c)
  (↓ op V M) [ s ]c =
    ↓ op (V [ s ]v) (M [ s ]c)
  (promise op ∣ p ↦ M `in N) [ s ]c =
    promise op ∣ p ↦ (M [ subst-cong (subst-cong s) ]c) `in (N [ subst-cong s ]c)
  (await V until M) [ s ]c =
    await (V [ s ]v) until (M [ subst-cong s ]c)
  (unbox V `in M) [ s ]c =
    unbox (V [ s ]v) `in (M [ subst-cong s ]c)
  (spawn M N) [ s ]c =
    spawn (M [ φ s ]c) (N [ s ]c)
  (coerce p q M) [ s ]c =
    coerce p q (M [ s ]c)

  infix 40 _[_]v
  infix 40 _[_]c

-- ACTION OF SUBSTITUTION ON WELL-TYPED PROCESSES

_[_]p : {Γ Γ' : Ctx} {o : O} {PP : PType o} →
        Γ ⊢P⦂ PP →
        Sub Γ Γ' →
        -------------------------------------
        Γ' ⊢P⦂ PP

(run M) [ s ]p =
  run (M [ s ]c)
(P ∥ Q) [ s ]p =
  (P [ s ]p) ∥ (Q [ s ]p)
(↑ op p V P) [ s ]p =
  ↑ op p (V [ s ]v) (P [ s ]p)
(↓ op V P) [ s ]p =
  ↓ op (V [ s ]v) (P [ s ]p)

infix 40 _[_]p


module Common.Semantics where

open import Common.Context public

-- Special products for glueing.

infix 5 _⅋_
record Glue (Syn : Set) (Sem : Set) : Set where
  constructor _⅋_
  field
    syn : Syn
    sem : Sem

open Glue public

-- Contexts as concrete worlds.

module ConcreteWorlds (U : Set) where
  record World : Set where
    constructor wrap
    field
      Γ : Cx U

  unwrap : World → Cx U
  unwrap (wrap Γ) = Γ

  data _≤_ : World → World → Set where
    wrap : ∀ {Γ Γ′} → Γ ⊆ Γ′ → wrap Γ ≤ wrap Γ′

  unwrap≤ : ∀ {Γ Γ′} → wrap Γ ≤ wrap Γ′ → Γ ⊆ Γ′
  unwrap≤ (wrap η) = η

  refl≤ : ∀ {w} → w ≤ w
  refl≤ = wrap refl⊆

  trans≤ : ∀ {w w′ w″} → w ≤ w′ → w′ ≤ w″ → w ≤ w″
  trans≤ (wrap η) (wrap η′) = wrap (trans⊆ η η′)

  weak≤ : ∀ {A w} → w ≤ wrap (unwrap w , A)
  weak≤ = wrap weak⊆


------------------------------------------------------------------------
-- The Agda standard library
--
-- Arguments used in the reflection machinery
------------------------------------------------------------------------

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

module Reflection.Argument where

open import Data.List.Base as List using (List; []; _∷_)
open import Data.Product using (_×_; _,_; uncurry; <_,_>)
open import Data.Nat using (ℕ)
open import Reflection.Argument.Visibility
open import Reflection.Argument.Relevance
open import Reflection.Argument.Information as Information
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Level

private
  variable
    a b : Level
    A B : Set a

------------------------------------------------------------------------
-- Re-exporting the builtins publicly

open import Agda.Builtin.Reflection public using (Arg)
open Arg public

-- Pattern synonyms

pattern vArg ty = arg (arg-info visible relevant)   ty
pattern hArg ty = arg (arg-info hidden relevant)    ty
pattern iArg ty = arg (arg-info instance′ relevant) ty

------------------------------------------------------------------------
-- Lists of arguments

Args : {a : Level} (A : Set a) → Set a
Args A = List (Arg A)

infixr 5 _⟨∷⟩_ _⟅∷⟆_
pattern _⟨∷⟩_ x xs = vArg x ∷ xs
pattern _⟅∷⟆_ x xs = hArg x ∷ xs

------------------------------------------------------------------------
-- Operations

map : (A → B) → Arg A → Arg B
map f (arg i x) = arg i (f x)

map-Args : (A → B) → Args A → Args B
map-Args f xs = List.map (map f) xs

------------------------------------------------------------------------
-- Decidable equality

arg-injective₁ : ∀ {i i′} {a a′ : A} → arg i a ≡ arg i′ a′ → i ≡ i′
arg-injective₁ refl = refl

arg-injective₂ : ∀ {i i′} {a a′ : A} → arg i a ≡ arg i′ a′ → a ≡ a′
arg-injective₂ refl = refl

arg-injective : ∀ {i i′} {a a′ : A} → arg i a ≡ arg i′ a′ → i ≡ i′ × a ≡ a′
arg-injective = < arg-injective₁ , arg-injective₂ >

-- We often need decidability of equality for Arg A when implementing it
-- for A. Unfortunately ≡-dec makes the termination checker unhappy.
-- Instead, we can match on both Arg A and use unArg-dec for an obviously
-- decreasing recursive call.

unArg : Arg A → A
unArg (arg i a) = a

unArg-dec : {x y : Arg A} → Dec (unArg x ≡ unArg y) → Dec (x ≡ y)
unArg-dec {x = arg i a} {arg i′ a′} a≟a′ =
  Dec.map′ (uncurry (cong₂ arg)) arg-injective ((i Information.≟ i′) ×-dec a≟a′)

≡-dec : DecidableEquality A → DecidableEquality (Arg A)
≡-dec _≟_ x y = unArg-dec (unArg x ≟ unArg y)


module Allto where

f : Set → Set
f = {!!}

g : Set → Set
g x = f {!!}


------------------------------------------------------------------------------
-- Conversion rules for inequalities
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module LTC-PCF.Data.Nat.Inequalities.ConversionRules where

open import Common.FOL.Relation.Binary.EqReasoning

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat.Inequalities

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

private

  -- Before to prove some properties for lt it is convenient
  -- to descompose the behavior of the function step by step.

  -- Initially, we define the possible states (lt-s₁,
  -- lt-s₂, ...). Then we write down the proof for
  -- the execution step from the state p to the state q, e.g.
  --
  -- proof₁→proof₂ : ∀ m n → lt-s₂ m n → lt-s₃ m n.

  -- The terms lt-00, lt-0S, lt-S0 and lt-SS show the use of the
  -- states lt-s₁, lt-s₂, ..., and the proofs associated with the
  -- execution steps.

  ----------------------------------------------------------------------
  -- The steps of lt.

  -- Initially, the conversion rule fix-eq is applied.
  lt-s₁ : D → D → D
  lt-s₁ m n = lth (fix lth) · m · n

  -- First argument application.
  lt-s₂ : D → D
  lt-s₂ m = lam (λ n →
              if (iszero₁ n)
                then false
                else (if (iszero₁ m)
                        then true
                        else (fix lth · pred₁ m · pred₁ n)))

  -- Second argument application.
  lt-s₃ : D → D → D
  lt-s₃ m n = if (iszero₁ n)
                then false
                else (if (iszero₁ m)
                        then true
                        else (fix lth · pred₁ m · pred₁ n))

  -- Reduction iszero₁ n ≡ b.
  lt-s₄ : D → D → D → D
  lt-s₄ m n b = if b
                  then false
                  else (if (iszero₁ m)
                          then true
                          else (fix lth · pred₁ m · pred₁ n))

  -- Reduction iszero₁ n ≡ true.
  -- It should be
  -- lt-s₅ : D → D → D
  -- lt-s₅ m n = false
  -- but we do not give a name to this step.

  -- Reduction iszero₁ n ≡ false.
  lt-s₅ : D → D → D
  lt-s₅ m n = if (iszero₁ m) then true else (fix lth · pred₁ m · pred₁ n)

  -- Reduction iszero₁ m ≡ b.
  lt-s₆ : D → D → D → D
  lt-s₆ m n b = if b then true else (fix lth · pred₁ m · pred₁ n)

  -- Reduction iszero₁ m ≡ true.
  -- It should be
  -- lt-s₇ : D → D → D
  -- lt-s₇ m n = true
  -- but we do not give a name to this step.

   -- Reduction iszero₁ m ≡ false.
  lt-s₇ : D → D → D
  lt-s₇ m n = fix lth · pred₁ m · pred₁ n

  -- Reduction pred₁ (succ m) ≡ m.
  lt-s₈ : D → D → D
  lt-s₈ m n = fix lth · m · pred₁ n

  -- Reduction pred₁ (succ n) ≡ n.
  lt-s₉ : D → D → D
  lt-s₉ m n = fix lth · m · n

  ----------------------------------------------------------------------
  -- The execution steps

  {-

    To prove the execution steps, e.g.

    proof₃→proof₄ : ∀ m n → lt-s₃ m n → lt-s₄ m n)

    we usually need to prove that

                         C [m] ≡ C [n]    (1)

    given that
                             m ≡ n,       (2)

    where (2) is a conversion rule usually.

    We prove (1) using

    subst : ∀ {x y} (A : D → Set) → x ≡ y → A x → A y

    where
      • P is given by λ t → C [m] ≡ C [t],
      • x ≡ y is given m ≡ n and
      • P x is given by C [m] ≡ C [m] (i.e. refl).
  -}

  -- Application of the conversion rule fix-eq.
  proof₀₋₁ : ∀ m n → fix lth · m · n  ≡ lt-s₁ m n
  proof₀₋₁ m n = subst (λ x → x · m · n  ≡ lth (fix lth) · m · n)
                       (sym (fix-eq lth))
                       refl

  -- Application of the first argument.
  proof₁₋₂ : ∀ m n → lt-s₁ m n ≡ lt-s₂ m · n
  proof₁₋₂ m n = subst (λ x → x · n ≡ lt-s₂ m · n)
                       (sym (beta lt-s₂ m))
                       refl

  -- Application of the second argument.
  proof₂₋₃ : ∀ m n → lt-s₂ m · n ≡ lt-s₃ m n
  proof₂₋₃ m n = beta (lt-s₃ m) n

  -- Reduction iszero n ≡ b using that proof.
  proof₃₋₄ : ∀ m n b → iszero₁ n ≡ b → lt-s₃ m n ≡ lt-s₄ m n b
  proof₃₋₄ m n .(iszero₁ n) refl = refl

  -- Reduction of iszero₁ n ≡ true using the conversion rule if-true.
  proof₄₊ : ∀ m n → lt-s₄ m n true ≡ false
  proof₄₊ m n = if-true false

  -- Reduction of iszero₁ n ≡ false ... using the conversion rule
  -- if-false.
  proof₄₋₅ : ∀ m n → lt-s₄ m n false ≡ lt-s₅ m n
  proof₄₋₅ m n = if-false (lt-s₅ m n)

  -- Reduction iszero₁ m ≡ b using that proof.
  proof₅₋₆ : ∀ m n b → iszero₁ m ≡ b → lt-s₅ m n ≡ lt-s₆ m n b
  proof₅₋₆ m n .(iszero₁ m) refl = refl

  -- Reduction of iszero₁ m ≡ true using the conversion rule if-true.
  proof₆₊ : ∀ m n → lt-s₆ m n true ≡ true
  proof₆₊ m n = if-true true

  -- Reduction of iszero₁ m ≡ false ... using the conversion rule
  -- if-false.
  proof₆₋₇ : ∀ m n → lt-s₆ m n false ≡ lt-s₇ m n
  proof₆₋₇ m n = if-false (lt-s₇ m n)

  -- Reduction pred (succ m) ≡ m using the conversion rule pred-S.
  proof₇₋₈ : ∀ m n → lt-s₇ (succ₁ m) n ≡ lt-s₈ m n
  proof₇₋₈ m n = subst (λ x → lt-s₈ x n ≡ lt-s₈ m n)
                       (sym (pred-S m))
                       refl

  -- Reduction pred (succ n) ≡ n using the conversion rule pred-S.
  proof₈₋₉ : ∀ m n → lt-s₈ m (succ₁ n) ≡ lt-s₉ m n
  proof₈₋₉ m n = subst (λ x → lt-s₉ m x ≡ lt-s₉ m n)
                       (sym (pred-S n))
                       refl

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

private
  X≮0 : ∀ n → n ≮ zero
  X≮0 n = fix lth · n · zero  ≡⟨ proof₀₋₁ n zero ⟩
          lt-s₁ n zero        ≡⟨ proof₁₋₂ n zero ⟩
          lt-s₂ n · zero      ≡⟨ proof₂₋₃ n zero ⟩
          lt-s₃ n zero        ≡⟨ proof₃₋₄ n zero true iszero-0 ⟩
          lt-s₄ n zero true   ≡⟨ proof₄₊ n zero ⟩
          false              ∎

lt-00 : zero ≮ zero
lt-00 = X≮0 zero

lt-0S : ∀ n → zero < succ₁ n
lt-0S n =
  fix lth · zero · (succ₁ n)    ≡⟨ proof₀₋₁ zero (succ₁ n) ⟩
  lt-s₁ zero (succ₁ n)          ≡⟨ proof₁₋₂ zero (succ₁ n) ⟩
  lt-s₂ zero · (succ₁ n)        ≡⟨ proof₂₋₃ zero (succ₁ n) ⟩
  lt-s₃ zero (succ₁ n)          ≡⟨ proof₃₋₄ zero (succ₁ n) false (iszero-S n) ⟩
  lt-s₄ zero (succ₁ n) false    ≡⟨ proof₄₋₅ zero (succ₁ n) ⟩
  lt-s₅ zero (succ₁ n)          ≡⟨ proof₅₋₆ zero (succ₁ n) true iszero-0 ⟩
  lt-s₆ zero (succ₁ n) true     ≡⟨ proof₆₊  zero (succ₁ n) ⟩
  true                         ∎

lt-S0 : ∀ n → succ₁ n ≮ zero
lt-S0 n = X≮0 (succ₁ n)

lt-SS : ∀ m n → lt (succ₁ m) (succ₁ n) ≡ lt m n
lt-SS m n =
  fix lth · (succ₁ m) · (succ₁ n)  ≡⟨ proof₀₋₁ (succ₁ m) (succ₁ n) ⟩
  lt-s₁ (succ₁ m) (succ₁ n)        ≡⟨ proof₁₋₂ (succ₁ m) (succ₁ n) ⟩
  lt-s₂ (succ₁ m) · (succ₁ n)      ≡⟨ proof₂₋₃ (succ₁ m) (succ₁ n) ⟩
  lt-s₃ (succ₁ m) (succ₁ n)        ≡⟨ proof₃₋₄ (succ₁ m) (succ₁ n) false (iszero-S n) ⟩
  lt-s₄ (succ₁ m) (succ₁ n) false  ≡⟨ proof₄₋₅ (succ₁ m) (succ₁ n) ⟩
  lt-s₅ (succ₁ m) (succ₁ n)        ≡⟨ proof₅₋₆ (succ₁ m) (succ₁ n) false (iszero-S m) ⟩
  lt-s₆ (succ₁ m) (succ₁ n) false  ≡⟨ proof₆₋₇ (succ₁ m) (succ₁ n) ⟩
  lt-s₇ (succ₁ m) (succ₁ n)        ≡⟨ proof₇₋₈ m (succ₁ n) ⟩
  lt-s₈ m (succ₁ n)                ≡⟨ proof₈₋₉ m n ⟩
  lt-s₉ m n                        ∎


open import lib
open import sum

module grammar (form : Set)(_eq_ : form → form → 𝔹)(drop-form : (x y : form) → x ≡ y → x eq y ≡ tt)(rise-form : (x y : form) → x eq y ≡ tt → x ≡ y) where

infix 7 _⇒_

data production : Set where
  _⇒_ : form → 𝕃 (form ⊎ char) → production

record grammar {numprods : ℕ} : Set where
  constructor  _,_
  field
    start : form
    prods : 𝕍 production numprods

open grammar

splice : ℕ → 𝕃 (form ⊎ char) → form → 𝕃 (form ⊎ char) → 𝕃 (form ⊎ char)
splice x [] _ _ = []
splice 0 ((inj₁ s) :: ss) s' ss' with s eq s'
... | tt = ss' ++ ss
... | ff = (inj₁ s) :: ss
splice 0 (x :: ss) s' ss' = x :: ss
splice (suc n) (s :: ss) s' ss' = s :: splice n ss s' ss'

𝕃inj₂ : ∀{ℓ ℓ'}{B : Set ℓ}{A : Set ℓ'} → 𝕃 A → 𝕃 (B ⊎ A)
𝕃inj₂ (x :: xs) = (inj₂ x) :: 𝕃inj₂ xs
𝕃inj₂ [] = []

𝕃inj₁ : ∀{ℓ ℓ'}{B : Set ℓ}{A : Set ℓ'} → 𝕃 A → 𝕃 (A ⊎ B)
𝕃inj₁ (x :: xs) = (inj₁ x) :: 𝕃inj₁ xs
𝕃inj₁ [] = []

data derivation{numprods : ℕ} {g : grammar{numprods}} : 𝕃 (form ⊎ char) → 𝕃 char → Set where
  end : {ss : 𝕃 char} → derivation (𝕃inj₂ ss) ss
  step : ∀ {ss1 ss1' : 𝕃 (form ⊎ char)}{ss2 : 𝕃 char}{s : form}{ss : 𝕃 (form ⊎ char)} →
           (m n : ℕ) → (p : n < numprods ≡ tt) →
           nth𝕍 n p (prods g) ≡ (s ⇒ ss) →
           m < length ss1 ≡ tt →
           splice m ss1 s ss ≡ ss1' →
           derivation {g = g} ss1' ss2 →
           derivation ss1 ss2

splice-concat : ∀{l1 l2 target final : 𝕃 (form ⊎ char)}{n : ℕ}{slice : form} → splice n l1 slice target ≡ final → splice (n + (length l2)) (l2 ++ l1) slice target ≡ l2 ++ final
splice-concat{l2 = []}{n = n} pr rewrite +0 n = pr
splice-concat{l1}{x :: xs}{n = n} pr rewrite +suc n (length xs) | splice-concat{l1}{l2 = xs} pr = refl

_=form⊎char_ : (x y : form ⊎ char) → 𝔹
_=form⊎char_ = =⊎ _eq_ _=char_

form⊎char-drop : (x y : form ⊎ char) → x ≡ y → x =form⊎char y ≡ tt
form⊎char-drop = ≡⊎-to-= _eq_ _=char_ drop-form ≡char-to-=

form⊎char-rise : (x y : form ⊎ char) → x =form⊎char y ≡ tt → x ≡ y
form⊎char-rise = =⊎-to-≡ _eq_ _=char_ rise-form =char-to-≡

splice-concat2 : ∀{l1 l2 target final : 𝕃 (form ⊎ char)}{n : ℕ}{slice : form} → splice n l1 slice target ≡ final → n < length l1 ≡ tt → splice n (l1 ++ l2) slice target ≡ final ++ l2
splice-concat2{[]}{n = n} pr1 pr2 rewrite <-0 n = 𝔹-contra pr2
splice-concat2{inj₁ x :: xs}{l2}{target}{n = 0}{slice} pr1 pr2 with x eq slice
...| tt rewrite (sym pr1) | ++[] target | ++-assoc target xs l2 = refl
...| ff rewrite (sym pr1) = refl
splice-concat2{inj₂ x :: xs}{l2}{target}{n = 0}{slice} pr1 pr2 rewrite (sym pr1) = refl
splice-concat2{x :: xs}{l2}{target}{[]}{suc n} pr1 pr2 with pr1
...| ()
splice-concat2{x :: xs}{l2}{target}{f :: fs}{suc n}{slice} pr1 pr2 with =𝕃-from-≡ _=form⊎char_ form⊎char-drop pr1
...| s1 rewrite splice-concat2{xs}{l2}{target}{fs}{n}{slice} (≡𝕃-from-={l1 = splice n xs slice target}{fs} _=form⊎char_ form⊎char-rise (&&-snd{x =form⊎char f} s1)) pr2 | form⊎char-rise x f (&&-fst{x =form⊎char f} s1) = refl

length+ : ∀{ℓ}{A : Set ℓ}(l1 l2 : 𝕃 A) → length (l1 ++ l2) ≡ length l1 + length l2
length+ [] l2 = refl
length+ (x :: xs) l2 rewrite length+ xs l2 = refl

<-h1 : ∀{x y a : ℕ} → x < y ≡ tt → x + a < y + a ≡ tt
<-h1{x}{y}{0} p rewrite +0 x | +0 y = p
<-h1{x}{y}{suc n} p rewrite +suc y n | +suc x n = <-h1{x}{y}{n} p

<-h2 : ∀{a x y : ℕ} → a < x ≡ tt → a < x + y ≡ tt
<-h2{a}{x}{0} p rewrite +0 x = p
<-h2{a}{x}{suc y} p rewrite +suc x y with <-h2{a}{x}{y} p | <-suc (x + y)
...| pr1 | pr2 = <-trans{a}{x + y}{suc (x + y)} pr1 pr2

length𝕃inj₂ : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → (l : 𝕃 A) → length (𝕃inj₂{B = B} l) ≡ length l
length𝕃inj₂{B = B} (x :: xs) rewrite length𝕃inj₂{B = B} xs = refl
length𝕃inj₂ [] = refl

𝕃inj₂++ : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → (l1 l2 : 𝕃 A) → 𝕃inj₂{B = B} (l1 ++ l2) ≡ 𝕃inj₂ l1 ++ 𝕃inj₂ l2
𝕃inj₂++ [] l2 = refl
𝕃inj₂++{B = B} (x :: xs) l2 rewrite 𝕃inj₂++{B = B} xs l2 = refl

infixr 10 _deriv++_

_deriv++_ : {l2 l4 : 𝕃 char}{l1 l3 : 𝕃 (form ⊎ char)}{n : ℕ}{gr : grammar{n}} → derivation{g = gr} l1 l2 → derivation{g = gr} l3 l4 → derivation{g = gr} (l1 ++ l3) (l2 ++ l4)
_deriv++_{l2}{l4} end end rewrite sym (𝕃inj₂++{B = form} l2 l4) = end
_deriv++_{l2}{l4}{l1}{l3} f (step{ss1' = ss1'}{s = s}{ss} a b pr1 pr2 pr3 pr4 next) with <-h1{a}{length l3}{length l1} pr3
...| pr5 rewrite +comm (length l3) (length l1) | (sym (length+ l1 l3)) =  step{ss1 = l1 ++ l3}{l1 ++ ss1'}{l2 ++ l4} (a + (length l1)) b pr1 pr2 pr5 (splice-concat{l3}{l1} pr4) (_deriv++_ f next)
_deriv++_{l2}{l4}{l1} (step{ss1' = ss1'}{s = s}{ss} a b pr1 pr2 pr3 pr4 next) end with <-h2{a}{length l1}{length (𝕃inj₂{B = form} l4)} pr3
...| pr5 rewrite sym (length+ l1 (𝕃inj₂ l4)) = step{ss1 = l1 ++ 𝕃inj₂ l4}{ss1' ++ 𝕃inj₂ l4}{l2 ++ l4} a b pr1 pr2 pr5 (splice-concat2{l1}{𝕃inj₂ l4} pr4 pr3) (_deriv++_ next end)


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

open import HoTT

-- an attempt to speed up [QuotGroup (im-nprop ...)]
-- which removes most intermediate constructions

module groups.Cokernel {i j}
  {G : Group i} {H : Group j}
  (φ : G →ᴳ H) (H-ab : is-abelian H) where

  --  G ---φ--→ᴳ H

  private
    module G = Group G
    module H = AbGroup (H , H-ab)
    module φ = GroupHom φ

  coker-rel : Rel H.El (lmax i j)
  coker-rel h₁ h₂ = Trunc -1 (hfiber φ.f (H.diff h₁ h₂))

  private
    coker-El : Type (lmax i j)
    coker-El = SetQuot coker-rel

  coker-struct : GroupStructure coker-El
  coker-struct = record {M} where
    module M where
      ident : coker-El
      ident = q[ H.ident ]

      inv : coker-El → coker-El
      inv = SetQuot-rec SetQuot-level inv' inv-rel
        where
          inv' : H.El → coker-El
          inv' h = q[ H.inv h ]

          abstract
            inv-rel : ∀ {h₁ h₂} → coker-rel h₁ h₂ → inv' h₁ == inv' h₂
            inv-rel {h₁} {h₂} = Trunc-rec (SetQuot-level _ _)
              λ{(g , φg=h₁h₂⁻¹) → quot-rel
                [ G.inv g , φ.pres-inv g ∙ ap H.inv φg=h₁h₂⁻¹
                          ∙ H.inv-diff h₁ h₂ ∙ H.comm h₂ (H.inv h₁)
                          ∙ ap (H.comp (H.inv h₁)) (! (H.inv-inv h₂)) ]}

      comp : coker-El → coker-El → coker-El
      comp = SetQuot-rec level comp' comp-rel where
        abstract
          level : is-set (coker-El → coker-El)
          level = →-is-set SetQuot-level

        comp' : H.El → coker-El → coker-El
        comp' h₁ = SetQuot-rec SetQuot-level comp'' comp'-rel where

          comp'' : H.El → coker-El
          comp'' h₂ = q[ H.comp h₁ h₂ ]

          abstract
            comp'-rel : ∀ {h₂ h₂'} → coker-rel h₂ h₂' → comp'' h₂ == comp'' h₂'
            comp'-rel {h₂} {h₂'} = Trunc-rec (SetQuot-level _ _)
              λ{(g , φg=h₂h₂'⁻¹) → quot-rel
                [ g , ! ( ap (H.comp (H.comp h₁ h₂)) (H.inv-comp h₁ h₂')
                        ∙ H.assoc h₁ h₂ (H.comp (H.inv h₂') (H.inv h₁))
                        ∙ ap (H.comp h₁) (! $ H.assoc h₂ (H.inv h₂') (H.inv h₁))
                        ∙ H.comm h₁ (H.comp (H.comp h₂ (H.inv h₂')) (H.inv h₁))
                        ∙ H.assoc (H.comp h₂ (H.inv h₂')) (H.inv h₁) h₁
                        ∙ ap2 H.comp (! φg=h₂h₂'⁻¹) (H.inv-l h₁)
                        ∙ H.unit-r (φ.f g) )]}

        abstract
          comp-rel : ∀ {h₁ h₁'} → coker-rel h₁ h₁' → comp' h₁ == comp' h₁'
          comp-rel {h₁} {h₁'} = Trunc-rec (level _ _)
            λ{(g , φg=h₁h₁'⁻¹) → λ= $ SetQuot-elim (λ _ → =-preserves-set SetQuot-level)
              (λ h₂ → quot-rel
                  [ g , ! ( ap (H.comp (H.comp h₁ h₂)) (H.inv-comp h₁' h₂)
                          ∙ H.assoc h₁ h₂ (H.comp (H.inv h₂) (H.inv h₁'))
                          ∙ ap (H.comp h₁) ( ! (H.assoc h₂ (H.inv h₂) (H.inv h₁'))
                                          ∙ ap (λ h → H.comp h (H.inv h₁')) (H.inv-r h₂)
                                          ∙ H.unit-l (H.inv h₁'))
                          ∙ ! φg=h₁h₁'⁻¹ )])
              (λ _ → prop-has-all-paths-↓ (SetQuot-level _ _))}

      abstract
        unit-l : ∀ cok → comp ident cok == cok
        unit-l = SetQuot-elim
          (λ _ → =-preserves-set SetQuot-level)
          (λ h → ap q[_] $ H.unit-l h)
          (λ _ → prop-has-all-paths-↓ (SetQuot-level _ _))

        assoc : ∀ cok₁ cok₂ cok₃ → comp (comp cok₁ cok₂) cok₃ == comp cok₁ (comp cok₂ cok₃)
        assoc = SetQuot-elim
          (λ _ → Π-is-set λ _ → Π-is-set λ _ → =-preserves-set SetQuot-level)
          (λ h₁ → SetQuot-elim
            (λ _ → Π-is-set λ _ → =-preserves-set SetQuot-level)
            (λ h₂ → SetQuot-elim
              (λ _ → =-preserves-set SetQuot-level)
              (λ h₃ → ap q[_] $ H.assoc h₁ h₂ h₃)
              (λ _ → prop-has-all-paths-↓ (SetQuot-level _ _)))
            (λ _ → prop-has-all-paths-↓ (Π-is-prop λ _ → SetQuot-level _ _)))
          (λ _ → prop-has-all-paths-↓ (Π-is-prop λ _ → Π-is-prop λ _ → SetQuot-level _ _))

        inv-l : ∀ cok → comp (inv cok) cok == ident
        inv-l = SetQuot-elim
          (λ _ → =-preserves-set SetQuot-level)
          (λ h → ap q[_] $ H.inv-l h)
          (λ _ → prop-has-all-paths-↓ (SetQuot-level _ _))

  Coker : Group (lmax i j)
  Coker = group _ SetQuot-level coker-struct

  module Coker = Group Coker

  {- correctness -}

  Coker-β : Coker ≃ᴳ QuotGroup (im-npropᴳ φ H-ab)
  Coker-β = ≃-to-≃ᴳ (ide _) to-pres-comp where
    abstract
      to-pres-comp : preserves-comp Coker.comp
        (QuotGroup.comp (im-npropᴳ φ H-ab)) (idf _)
      to-pres-comp = SetQuot-elim
        (λ _ → Π-is-set λ _ → =-preserves-set SetQuot-level)
        (λ _ → SetQuot-elim
          (λ _ → =-preserves-set SetQuot-level)
          (λ _ → idp)
          (λ _ → prop-has-all-paths-↓ (SetQuot-level _ _)))
        (λ _ → prop-has-all-paths-↓ (Π-is-prop λ _ → SetQuot-level _ _))


------------------------------------------------------------------------------
-- Well-founded induction on the relation LTL
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOTC.Data.List.WF-Relation.LT-Length.Induction.Acc.WF-I where

open import FOTC.Base
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.List.WF-Relation.LT-Length
open import FOTC.Data.List.WF-Relation.LT-Length.PropertiesI

import FOTC.Data.Nat.Induction.Acc.WF-I
open FOTC.Data.Nat.Induction.Acc.WF-I.<-WF

open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Type
open import FOTC.Induction.WF

-- Parametrized modules
open module InvImg =
  FOTC.Induction.WF.InverseImage {List} {N} {_<_} lengthList-N

------------------------------------------------------------------------------
-- The relation LTL is well-founded (using the inverse image combinator).
LTL-wf : WellFounded LTL
LTL-wf Lxs = wellFounded <-wf Lxs

-- Well-founded induction on the relation LTL.
LTL-wfind : (A : D → Set) →
            (∀ {xs} → List xs → (∀ {ys} → List ys → LTL ys xs → A ys) → A xs) →
            ∀ {xs} → List xs → A xs
LTL-wfind A = WellFoundedInduction LTL-wf

------------------------------------------------------------------------------
-- The relation LTL is well-founded (a different proof).
-- Adapted from FOTC.Data.Nat.Induction.Acc.WellFoundedInduction.WF₁-LT.
module WF₁-LTL where

LTL-wf' : WellFounded LTL
LTL-wf' Lxs = acc (helper Lxs)
  where
  helper : ∀ {xs ys} → List xs → List ys → LTL ys xs → Acc List LTL ys
  helper lnil Lys ys<[] = ⊥-elim (xs<[]→⊥ Lys ys<[])
  helper (lcons x {xs} Lxs) lnil []<x∷xs =
    acc (λ Lys ys<[] → ⊥-elim (xs<[]→⊥ Lys ys<[]))
  helper (lcons x {xs} Lxs) (lcons y {ys} Lys) y∷ys<x∷xs =
    acc (λ {zs} Lzs zs<y∷ys →
           let ys<xs : LTL ys xs
               ys<xs = x∷xs<y∷ys→xs<ys Lys Lxs y∷ys<x∷xs

               zs<xs : LTL zs xs
               zs<xs = case (λ zs<ys → <-trans Lzs Lys Lxs zs<ys ys<xs)
                            (λ h → lg-xs≡lg-ys→ys<zx→xs<zs h ys<xs)
                            (xs<y∷ys→xs<ys∨lg-xs≡lg-ys Lzs Lys zs<y∷ys)

           in  helper Lxs Lzs zs<xs
        )


-- Andreas, 2018-10-27, issue #3324 reported by Guillaume Brunerie
-- Missing 'reduce' leads to arbitrary rejection of pattern matching on props

{-# OPTIONS --prop #-}

-- {-# OPTIONS -v tc.cover:60 #-}

data Unit : Prop where
  tt : Unit

-- Works
f : {A : Set} → Unit → Unit
f tt = tt

-- Should work
g : Unit → Unit
g tt = tt


-- Andreas, 2016-09-12
--
-- Underscores should also get meaningful names
-- (not just metas from omitted hidden arguments)

-- {-# OPTIONS -v tc.meta.name:100 #-}

postulate
  F : (A : Set) → Set
  G : {B : Set} → Set

test1 : Set
test1 = F _
  -- name of this meta should be _A_0

test2 : Set
test2 = G
  -- creates meta _B_1

test3 : Set
test3 = G {_}
  -- name of this meta should be _B_2


open import and-example public
open import ex-andreas-abel public


module E where
 t : Set -> Set
 t x = x


-- submitted by Nisse, 2011-06-21

-- {-# OPTIONS -v tc.lhs.unify:15 --show-implicit #-}

module Issue423 where

-- import Common.Level

------------------------------------------------------------------------
-- Prelude

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

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

curry : {A C : Set} {B : A → Set} →
        (Σ A B → C) → ((x : A) → B x → C)
curry f x y = f (x , y)

uncurry : {A C : Set} {B : A → Set} →
          ((x : A) → (y : B x) → C) → (Σ A B → C)
uncurry f (x , y) = f x y

------------------------------------------------------------------------
-- Preliminaries

postulate
  U  : Set
  El : U → Set

mutual

  data Ctxt : Set where
    _▻_ : (Γ : Ctxt) (σ : Type Γ) → Ctxt

  Type : Ctxt → Set
  Type Γ = Env Γ → U

  Env : Ctxt → Set
  Env (Γ ▻ σ) = Σ (Env Γ) λ γ → El (σ γ)

postulate
  Γ : Ctxt
  σ : Type Γ

------------------------------------------------------------------------
-- Problem

-- The following equalites hold definitionally.

curry∘uncurry : (τ : (γ : Env Γ) → El (σ γ) → U) →
                curry (uncurry τ) ≡ τ
curry∘uncurry τ = refl

uncurry∘curry : (τ : Env (Γ ▻ σ) → U) →
                uncurry (curry τ) ≡ τ
uncurry∘curry τ = refl

-- Bug was:
-- However, the two sides of curry∘uncurry behave differently.

works : (τ₁ τ₂ : (γ : Env Γ) → El (σ γ) → U) →
        τ₁ ≡ τ₂ → Set₁
works τ .τ refl = Set

works′ : (τ₁ τ₂ : (γ : Env Γ) → El (σ γ) → U) →
         curry (uncurry τ₁) ≡ τ₂ → Set₁
works′ τ .τ refl = Set

fails : (τ₁ τ₂ : (γ : Env Γ) → El (σ γ) → U) →
        τ₁ ≡ curry (uncurry τ₂) → Set₁
fails τ .τ refl = Set

fails′ : (τ₁ τ₂ : (γ : Env Γ) → El (σ γ) → U) →
         curry (uncurry τ₁) ≡ curry (uncurry τ₂) → Set₁
fails′ τ .τ refl = Set

-- Bug was:
-- I find it interesting that works′ works, whereas the symmetric
-- variant fails fails.


module Issue313 where

postulate
  QName : Set

{-# BUILTIN QNAME QName #-}

postulate
  X   : Set
  _+_ : QName → QName → Set

foo : Set
foo = quote X + quote X


{-# OPTIONS --without-K --exact-split #-}

module dn-sheaves where

import rings
open rings public

{- We postulate a propositional resizing axiom -}

raise-UU-Prop :
  (l : Level) → UU-Prop lzero → UU-Prop l
raise-UU-Prop l (pair P is-prop-P) =
  pair ( raise l P)
       ( is-prop-is-equiv' P
         ( map-raise l P)
         ( is-equiv-map-raise l P)
         ( is-prop-P))

postulate propositional-resizing : {l : Level} → is-equiv (raise-UU-Prop l)

lower-UU-Prop :
  {l : Level} → UU-Prop l → UU-Prop lzero
lower-UU-Prop = inv-is-equiv propositional-resizing

issec-lower-UU-Prop :
  {l : Level} (P : UU-Prop l) → Id (raise-UU-Prop l (lower-UU-Prop P)) P
issec-lower-UU-Prop = issec-inv-is-equiv propositional-resizing

isretr-lower-UU-Prop :
  {l : Level} (P : UU-Prop lzero) → Id (lower-UU-Prop (raise-UU-Prop l P)) P
isretr-lower-UU-Prop = isretr-inv-is-equiv propositional-resizing

{- We define what it means for a type to be a double-negation-sheaf -}

is-dn-sheaf :
  {l : Level} (X : UU l) → UU (l ⊔ (lsuc lzero))
is-dn-sheaf X =
  (P : UU-Prop lzero) → is-equiv (λ (f : ¬¬ (type-Prop P) → X) → f ∘ intro-dn)

universal-property-dn-sheafification :
  (l : Level) {l1 l2 : Level} {X : UU l1} {Y : UU l2} (f : X → Y) →
  is-dn-sheaf Y → UU ((lsuc l) ⊔ l1 ⊔ l2)
universal-property-dn-sheafification l {Y = Y} f is-dn-sheaf-Y =
  (Z : UU l) (H : is-dn-sheaf Z) → is-equiv (λ (h : Y → Z) → h ∘ f)

postulate dn-sheafification : {l : Level} → UU l → UU l

postulate unit-dn-sheafification : {l : Level} (X : UU l) → X → dn-sheafification X

postulate is-dn-sheaf-dn-sheafification : {l : Level} (X : UU l) → is-dn-sheaf (dn-sheafification X)

postulate is-dn-sheafification : {l1 l2 : Level} (X : UU l1) → universal-property-dn-sheafification l2 (unit-dn-sheafification X) (is-dn-sheaf-dn-sheafification X)

{- We show that on propositions, dn-sheafification agrees with double negation. -}

is-dn-sheaf-dn : {l : Level} (P : UU l) → is-dn-sheaf (¬¬ P)
is-dn-sheaf-dn P Q =
  is-equiv-is-prop
    ( is-prop-function-type (¬¬ (type-Prop Q)) (¬¬ P) is-prop-neg)
    ( is-prop-function-type (type-Prop Q) (¬¬ P) is-prop-neg)
    ( dn-extend)

is-dn-sheafification-intro-dn :
  (k : Level) {l : Level} (P : UU l) →
  universal-property-dn-sheafification k (intro-dn {P = P}) (is-dn-sheaf-dn P)
is-dn-sheafification-intro-dn k {l} P X is-dn-sheaf-X =
  is-equiv-top-is-equiv-bottom-square
    ( λ f → f ∘ ( functor-dn {!map-raise l ?!}))
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}


{-# OPTIONS --without-K #-}
open import Type using (Type₀; Type₁; Type_)
open import Type.Identities
open import Function.NP using (Π; _∘_; const)
open import Function.Extensionality using (FunExt)
open import Data.Zero using (𝟘)
open import Data.One using (𝟙; 0₁)
open import Data.Two.Base using (𝟚; 0₂; 1₂)
open import Data.Product.NP using (Σ; _×_; _,_; fst; snd)
open import Data.Sum.NP using (_⊎_; inl; inr)
open import Data.Nat.Base using (ℕ; zero; suc)
open import Data.Fin using (Fin)
open import Relation.Nullary.NP using (Dec)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; idp; ap; !_; _∙_; tr)
open import HoTT using (ua; UA; module Equivalences)
open        Equivalences using (_≃_; ≃-!; ≃-refl; _≃-∙_)

open import Explore.Core
open import Explore.Properties
open import Explore.Zero
open import Explore.One
open import Explore.Two
open import Explore.Product
open        Explore.Product.Operators
open import Explore.Sum
open import Explore.Explorable
open import Explore.Isomorphism
open import Explore.GuessingGameFlipping
import      Explore.Universe.Type
import      Explore.Universe.FromE

module Explore.Universe (X : Type₀) where

open Explore.Universe.Type {X}

module FromXᵉ = Explore.Universe.FromE X

open Adequacy _≡_
module FromKit
    {Xᵉ : ∀ {ℓ} → Explore ℓ X}
    (Xⁱ : ∀ {ℓ p} → ExploreInd p (Xᵉ {ℓ}))
    (let module Xᴱ = FromExploreInd Xⁱ)
    (Xˢ-ok : ∀{{_ : UA}}{{_ : FunExt}} → Adequate-sum Xᴱ.sum)
    (Xˡ : ∀ {ℓ} → Lookup {ℓ} Xᵉ)
    (Xᶠ : ∀ {ℓ} → Focus {ℓ} Xᵉ)
    (ΣᵉX-ok : ∀{{_ : UA}}{{_ : FunExt}}{ℓ} → Adequate-Σ {ℓ} (Σᵉ Xᵉ))
    (ΠᵉX-ok : ∀{{_ : UA}}{{_ : FunExt}}{ℓ} → Adequate-Π {ℓ} (Πᵉ Xᵉ))
    (⟦Xᵉ⟧≡ : ∀ {ℓ₀ ℓ₁} ℓᵣ → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ Xᵉ Xᵉ)
    (ΠX : (X → U) → U)
    (ΠX≃ : ∀{{_ : UA}}{{_ : FunExt}} v → El (ΠX v) ≃ Π X (El ∘ v))
    (u : U)
  where

  private
   module M where
    open FromXᵉ Xᵉ public
    open FromXⁱ Xⁱ public
    open FromXˡ Xˡ public
    open FromXᶠ Xᶠ public
    open FromΠX ΠX public

    module _ {{_ : FunExt}}{{_ : UA}} where
      open FromΣᵉX-ok ΣᵉX-ok public
      open FromΠᵉX-ok ΠᵉX-ok public
      open From⟦Xᵉ⟧≡  ⟦Xᵉ⟧≡  public
      open FromΠX≃   ΠX≃ public

  explore : ∀ {ℓ} → Explore ℓ (El u)
  explore = M.explore u

  explore-ind : ∀ {ℓ p} → ExploreInd {ℓ} p explore
  explore-ind = M.explore-ind u

  open FromExploreInd explore-ind public hiding (⟦explore⟧)
  -- TODO list what is exported here

  lookup : ∀ {ℓ} → Lookup {ℓ} explore
  lookup = M.lookup u

  open FromLookup {explore = explore} lookup public

  focus : ∀ {ℓ} → Focus {ℓ} explore
  focus = M.focus u

  Πᵁ : (v : El u → U) → U
  Πᵁ = M.Πᵁ u

  _→ᵁ_ : (v : U) → U
  _→ᵁ_ = M._→ᵁ_ u

  module _ {{_ : FunExt}}{{_ : UA}} where
    Σᵉ-ok : ∀ {ℓ} → Adequate-Σ {ℓ} (Σᵉ explore)
    Σᵉ-ok = M.Σᵉ-ok u

    Πᵉ-ok : ∀ {ℓ} → Adequate-Π {ℓ} (Πᵉ explore)
    Πᵉ-ok = M.Πᵉ-ok u

    ⟦explore⟧≡ : ∀ {ℓ₀ ℓ₁} ℓᵣ → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ explore explore
    ⟦explore⟧≡ ℓᵣ = M.⟦explore⟧≡ ℓᵣ u

    open From⟦Explore⟧ ⟦explore⟧≡ public
      using ( sum⇒Σᵉ
            ; product⇒Πᵉ
            ; ✓all-Πᵉ
            ; ✓any→Σᵉ
            ; module FromAdequate-Σᵉ
            ; module FromAdequate-Πᵉ
            )

    open FromAdequate-Σᵉ Σᵉ-ok public
      using ( sumStableUnder
            ; sumStableUnder′
            ; same-count→iso
            ; adequate-sum
            ; adequate-any
            )

    open FromAdequate-Πᵉ Πᵉ-ok public
      using ( adequate-product
            ; adequate-all
            ; check!
            )

    Dec-Σ : ∀ {p}{P : El u → Type p} → Π (El u) (Dec ∘ P) → Dec (Σ (El u) P)
    Dec-Σ = FromFocus.Dec-Σ focus

    Πᵁ-Π : ∀ v → El (Πᵁ v) ≡ Π (El u) (El ∘ v)
    Πᵁ-Π = M.Πᵁ-Π u

    →ᵁ-→ : ∀ v → El (_→ᵁ_ v) ≡ (El u → El v)
    →ᵁ-→ = M.→ᵁ-→ u

    Πᵁ→Π : ∀ v → El (Πᵁ v) → Π (El u) (El ∘ v)
    Πᵁ→Π = M.Πᵁ→Π u

    Π→Πᵁ : ∀ v → Π (El u) (El ∘ v) → El (Πᵁ v)
    Π→Πᵁ = M.Π→Πᵁ u

    →ᵁ→→ : ∀ v → El (_→ᵁ_ v) → (El u → El v)
    →ᵁ→→ = M.→ᵁ→→ u

    →→→ᵁ : ∀ v → (El u → El v) → El (_→ᵁ_ v)
    →→→ᵁ = M.→→→ᵁ u

    guessing-game-flipping = Explore.GuessingGameFlipping.thm (El u) sum sum-ind
-- -}
-- -}
-- -}
-- -}
-- -}


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

open import lib.Basics
open import lib.NType2
open import lib.types.Nat
open import lib.types.TLevel
open import lib.types.Empty
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.Truncation
open import lib.types.Pointed
open import lib.types.Group
open import lib.types.LoopSpace
open import lib.groups.TruncationGroup
open import lib.groups.GroupProduct
open import lib.groups.Homomorphisms
open import lib.groups.Unit

module lib.groups.HomotopyGroup where

{- Higher homotopy groups -}
module _ {i} where

  πS : (n : ℕ) (X : Ptd i) → Group i
  πS n X = Trunc-group (Ω^S-group-structure n X)

  fundamental-group : (X : Ptd i) → Group i
  fundamental-group X = πS 0 X

{- π_(n+1) of a space is π_n of its loop space -}
abstract
  πS-inner-iso : ∀ {i} (n : ℕ) (X : Ptd i)
    → πS (S n) X == πS n (⊙Ω X)
  πS-inner-iso n X = group-ua
    (record {
       f = Trunc-fmap (Ω^-inner-out (S n) X);
       pres-comp =
         Trunc-elim (λ _ → Π-level (λ _ → =-preserves-level _ Trunc-level))
           (λ p → Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
              (λ q → ap [_] (Ω^S-inner-out-conc^S n X p q)))} ,
     is-equiv-Trunc 0 (Ω^-inner-out (S n) X) (Ω^-inner-is-equiv (S n) X))

{- We can shift the truncation inside the loop in the definition of π -}
module _ {i} where

  private
    record Ω^STs-PreIso (m : ℕ₋₂) (n : ℕ) (k : ℕ₋₂) (X : Ptd i)
      : Type i where
      field
        F : fst (⊙Ω^ (S n) (⊙Trunc k X) ⊙→ ⊙Trunc m (⊙Ω^ (S n) X))
        pres-comp : ∀ (p q : Ω^ (S n) (⊙Trunc k X))
          → fst F (conc^S n p q) == Trunc-fmap2 (conc^S n) (fst F p) (fst F q)
        e : is-equiv (fst F)

    Ω^S-Trunc-shift-preiso : (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
      → Ω^STs-PreIso m n (⟨ S n ⟩₋₂ +2+ m) X
    Ω^S-Trunc-shift-preiso O m X =
      record { F = (–> (Trunc=-equiv [ snd X ] [ snd X ]) , idp);
               pres-comp = Trunc=-∙-comm;
               e = snd (Trunc=-equiv [ snd X ] [ snd X ]) }
    Ω^S-Trunc-shift-preiso (S n) m X =
      let
        r : Ω^STs-PreIso (S m) n (⟨ S n ⟩₋₂ +2+ S m) X
        r = Ω^S-Trunc-shift-preiso n (S m) X

        H = (–> (Trunc=-equiv [ idp^ (S n) ] [ idp^ (S n) ]) , idp)
        G = ap^ 1 (Ω^STs-PreIso.F r)
      in
      transport (λ k → Ω^STs-PreIso m (S n) k X)
        (+2+-βr ⟨ S n ⟩₋₂ m)
        (record {
           F = H ⊙∘ G;
           pres-comp = λ p q →
             ap (fst H) (ap^S-conc^S 0 (Ω^STs-PreIso.F r) p q)
             ∙ (Trunc=-∙-comm (fst G p) (fst G q));
           e = snd (Trunc=-equiv [ idp^ (S n) ] [ idp^ (S n) ]
                    ∘e equiv-ap^ 1 (Ω^STs-PreIso.F r) (Ω^STs-PreIso.e r))})

  πS-Trunc-shift-iso : (n : ℕ) (X : Ptd i)
    → Ω^S-group n (⊙Trunc ⟨ S n ⟩ X) Trunc-level == πS n X
  πS-Trunc-shift-iso n X = group-ua (group-hom (fst F) pres-comp , e)
    where
    n-eq : ∀ (n : ℕ) → ⟨ n ⟩₋₂ +2+ 0 == ⟨ n ⟩
    n-eq O = idp
    n-eq (S n) = ap S (n-eq n)

    r = transport (λ k → Ω^STs-PreIso 0 n k X)
                  (n-eq (S n)) (Ω^S-Trunc-shift-preiso n 0 X)
    open Ω^STs-PreIso r

abstract
  πS-below-trunc : ∀ {i} (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
    → (⟨ S n ⟩ ≤T m) → πS n (⊙Trunc m X) == πS n X
  πS-below-trunc n m X lte =
    πS n (⊙Trunc m X)
      =⟨ ! (πS-Trunc-shift-iso n (⊙Trunc m X)) ⟩
    Ω^S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X)) Trunc-level
      =⟨ lemma ⟩
    Ω^S-group n (⊙Trunc ⟨ S n ⟩ X) Trunc-level
      =⟨ πS-Trunc-shift-iso n X ⟩
    πS n X ∎
    where
    lemma : Ω^S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X)) Trunc-level
         ==  Ω^S-group n (⊙Trunc ⟨ S n ⟩ X) Trunc-level
    lemma = ap (uncurry $ Ω^S-group n) $
      pair=
        (⊙ua (⊙≃-in (fuse-Trunc (fst X) ⟨ S n ⟩ m) idp) ∙
         ap (λ k → ⊙Trunc k X) (minT-out-l lte))
        (prop-has-all-paths-↓ has-level-is-prop)

  πS-above-trunc : ∀ {i} (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
    → (m <T ⟨ S n ⟩) → πS n (⊙Trunc m X) == 0ᴳ
  πS-above-trunc n m X lt =
    πS n (⊙Trunc m X)
      =⟨ ! (πS-Trunc-shift-iso n (⊙Trunc m X)) ⟩
    Ω^S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X)) Trunc-level
      =⟨ contr-is-0ᴳ _ $ inhab-prop-is-contr
           (Group.ident (Ω^S-group n (⊙Trunc ⟨ S n ⟩ (⊙Trunc m X)) Trunc-level))
           (Ω^-level-in -1 (S n) _ $ Trunc-preserves-level ⟨ S n ⟩ $
             raise-level-≤T
               (transport (λ k → m ≤T k) (+2+-comm -1 ⟨ S n ⟩₋₂) (<T-to-≤T lt))
               (Trunc-level {n = m})) ⟩
    0ᴳ ∎

  πS-above-level : ∀ {i} (n : ℕ) (m : ℕ₋₂) (X : Ptd i)
    → (m <T ⟨ S n ⟩) → has-level m (fst X)
    → πS n X == 0ᴳ
  πS-above-level n m X lt pX =
    ap (πS n) (! (⊙ua (⊙≃-in (unTrunc-equiv _ pX) idp)))
    ∙ πS-above-trunc n m X lt

{- πₙ(X × Y) == πₙ(X) × πₙ(Y) -}
module _ {i j} (n : ℕ) (X : Ptd i) (Y : Ptd  j) where

  πS-× : πS n (X ⊙× Y) == πS n X ×ᴳ πS n Y
  πS-× =
    group-ua (Trunc-group-iso f pres-comp (is-eq f g f-g g-f))
    ∙ Trunc-group-× _ _
    where
    f : Ω^ (S n) (X ⊙× Y) → Ω^ (S n) X × Ω^ (S n) Y
    f r = (fst (ap^ (S n) ⊙fst) r , fst (ap^ (S n) ⊙snd) r)

    g : Ω^ (S n) X × Ω^ (S n) Y → Ω^ (S n) (X ⊙× Y)
    g = fst (ap2^ (S n) (⊙idf _))

    f-g : (s : Ω^ (S n) X × Ω^ (S n) Y) → f (g s) == s
    f-g (p , q) = pair×=
      (app= (ap fst (ap^-ap2^ (S n) ⊙fst (⊙idf _) ∙ ap2^-fst (S n))) (p , q))
      (app= (ap fst (ap^-ap2^ (S n) ⊙snd (⊙idf _) ∙ ap2^-snd (S n))) (p , q))

    g-f : (r : Ω^ (S n) (X ⊙× Y)) → g (f r) == r
    g-f = app= $ ap fst $
      ap (λ h → h ⊙∘ ⊙diag) (ap2^-ap^ (S n) (⊙idf _) ⊙fst ⊙snd)
      ∙ ap2^-diag (S n) (⊙idf _ ⊙∘ pair⊙→ ⊙fst ⊙snd)
      ∙ ap^-idf (S n)

    pres-comp : (p q : Ω^ (S n) (X ⊙× Y))
      → f (conc^S n p q) == (conc^S n (fst (f p)) (fst (f q)) ,
                             conc^S n (snd (f p)) (snd (f q)))
    pres-comp p q = pair×= (ap^S-conc^S n ⊙fst p q) (ap^S-conc^S n ⊙snd p q)

module _ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j} (f : fst (X ⊙→ Y)) where

  πS-fmap : πS n X →ᴳ πS n Y
  πS-fmap = Trunc-group-hom (fst (ap^ (S n) f)) (ap^S-conc^S n f)


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

open import HoTT
import homotopy.ConstantToSetExtendsToProp as ConstExt
open import homotopy.RibbonCover

module homotopy.GroupSetsRepresentCovers {i} (X : Ptd i)
  {{_ : is-connected 0 (de⊙ X)}} where

  open Cover

  private
    A : Type i
    A = de⊙ X
    a₁ : A
    a₁ = pt X

  -- A covering space constructed from a G-set.
  grpset-to-cover : ∀ {j} → GroupSet (πS 0 X) j → Cover A (lmax i j)
  grpset-to-cover gs = Ribbon-cover X gs

  -- Covering spaces to G-sets.
  cover-to-grpset-struct : ∀ {j} (cov : Cover A j)
    → GroupSetStructure (πS 0 X) (Fiber cov a₁)
  cover-to-grpset-struct cov = record
    { act = cover-trace cov
    ; unit-r = cover-trace-idp₀ cov
    ; assoc = cover-paste cov
    }

  cover-to-grpset : ∀ {j} → Cover A j → GroupSet (πS 0 X) j
  cover-to-grpset cov = record
    { El = Fiber cov a₁
    ; grpset-struct = cover-to-grpset-struct cov
    }

  -- This is derivable from connectedness condition.
  module _ where
    abstract
      [base-path] : ∀ {a₂ : A} → Trunc -1 (a₁ == a₂)
      [base-path] {a₂} =
        –> (Trunc=-equiv [ a₁ ] [ a₂ ]) (contr-has-all-paths [ a₁ ] [ a₂ ])

  -- Part 1: Show that the synthesized cover (ribbon) is fiberwisely
  --         equivalent to the original fiber.
  private
    module _ {j} (cov : Cover A j) where

      -- Suppose that we get the path, we can compute the ribbon easily.
      fiber+path-to-ribbon : ∀ {a₂} (a↑ : Fiber cov a₂) (p : a₁ == a₂)
        → Ribbon X (cover-to-grpset cov) a₂
      fiber+path-to-ribbon {a₂} a↑ p =
        trace (cover-trace cov a↑ [ ! p ]) [ p ]

      abstract
        -- Our construction is "constant" with respect to paths.
        fiber+path-to-ribbon-is-path-irrelevant :
          ∀ {a₂} (a↑ : Fiber cov a₂) (p₁ p₂ : a₁ == a₂)
          → fiber+path-to-ribbon a↑ p₁ == fiber+path-to-ribbon a↑ p₂
        fiber+path-to-ribbon-is-path-irrelevant a↑ p idp =
          trace (cover-trace cov a↑ [ ! p ]) [ p ]
            =⟨ paste a↑ [ ! p ] [ p ] ⟩
          trace a↑ [ ! p ∙ p ]
            =⟨ !₀-inv-l [ p ] |in-ctx trace a↑ ⟩
          trace a↑ idp₀
            ∎

      module FiberAndPathToRibbon {a₂} (a↑ : Fiber cov a₂)
        = ConstExt
          (fiber+path-to-ribbon a↑)
          (fiber+path-to-ribbon-is-path-irrelevant a↑)

      fiber+path₋₁-to-ribbon : ∀ {a₂} (a↑ : Cover.Fiber cov a₂)
        → Trunc -1 (a₁ == a₂) → Ribbon X (cover-to-grpset cov) a₂
      fiber+path₋₁-to-ribbon a↑ = FiberAndPathToRibbon.ext a↑

  -- So the conversion from fiber to ribbon is done.
  fiber-to-ribbon : ∀ {j} (cov : Cover A j)
    → {a₂ : A} (a↑ : Cover.Fiber cov a₂)
    → Ribbon X (cover-to-grpset cov) a₂
  fiber-to-ribbon cov a↑ = fiber+path₋₁-to-ribbon cov a↑ [base-path]

  -- The other direction is easy.
  ribbon-to-fiber : ∀ {j} (cov : Cover A j) {a₂}
    → Ribbon X (cover-to-grpset cov) a₂ → Cover.Fiber cov a₂
  ribbon-to-fiber cov {a₂} r =
    Ribbon-rec (cover-trace cov) (cover-paste cov) r

  private
    -- Some routine computations.
    abstract
      ribbon-to-fiber-to-ribbon : ∀ {j} (cov : Cover A j) {a₂}
        → (r : Ribbon X (cover-to-grpset cov) a₂)
        → fiber-to-ribbon cov (ribbon-to-fiber cov r) == r
      ribbon-to-fiber-to-ribbon cov {a₂} = Ribbon-elim
        {P = λ r → fiber-to-ribbon cov (ribbon-to-fiber cov r) == r}
        (λ a↑ p → Trunc-elim
          -- All ugly things will go away when bp = proj bp′
          {{λ bp → has-level-apply Ribbon-is-set
                    (fiber+path₋₁-to-ribbon cov (cover-trace cov a↑ p) bp)
                    (trace a↑ p)}}
          (lemma a↑ p)
          [base-path])
        (λ _ _ _ → prop-has-all-paths-↓)
        where
          abstract
            lemma : ∀ {a₂} (a↑ : Cover.Fiber cov a₁) (p : a₁ =₀ a₂) (bp : a₁ == a₂)
              → trace {X = X} {gs = cover-to-grpset cov}
                  (cover-trace cov (cover-trace cov a↑ p) [ ! bp ]) [ bp ]
              == trace {X = X} {gs = cover-to-grpset cov} a↑ p
            lemma a↑ p idp =
              trace (cover-trace cov a↑ p) idp₀
                =⟨ paste a↑ p idp₀ ⟩
              trace a↑ (p ∙₀ idp₀)
                =⟨ ap (trace a↑) $ ∙₀-unit-r p ⟩
              trace a↑ p
                ∎

      fiber-to-ribbon-to-fiber : ∀ {j} (cov : Cover A j) {a₂}
        → (a↑ : Cover.Fiber cov a₂)
        → ribbon-to-fiber cov (fiber-to-ribbon cov {a₂} a↑) == a↑
      fiber-to-ribbon-to-fiber cov {a₂} a↑ = Trunc-elim
        -- All ugly things will go away when bp = proj bp′
        {{λ bp → has-level-apply (Cover.Fiber-is-set cov)
                  (ribbon-to-fiber cov
                    (fiber+path₋₁-to-ribbon cov a↑ bp))
                  a↑}}
        (lemma a↑)
        [base-path]
        where
          abstract
            lemma : ∀ {a₂} (a↑ : Cover.Fiber cov a₂) (bp : a₁ == a₂)
              → cover-trace cov (cover-trace cov a↑ [ ! bp ]) [ bp ]
              == a↑
            lemma a↑ idp = idp

  cover-to-grpset-to-cover : ∀ {j} (cov : Cover A (lmax i j))
    → grpset-to-cover (cover-to-grpset cov) == cov
  cover-to-grpset-to-cover cov = cover= λ _ →
    ribbon-to-fiber cov , is-eq
      (ribbon-to-fiber cov)
      (fiber-to-ribbon cov)
      (fiber-to-ribbon-to-fiber cov)
      (ribbon-to-fiber-to-ribbon cov)

  -- The second direction : grpset -> covering -> grpset

  -- Part 2.1: The fiber over the point a is the carrier.
  ribbon-a₁-to-El : ∀ {j} {gs : GroupSet (πS 0 X) j}
    → Ribbon X gs a₁ → GroupSet.El gs
  ribbon-a₁-to-El {j} {gs} = let open GroupSet gs in
    Ribbon-rec act assoc

  ribbon-a₁-to-El-equiv : ∀ {j} {gs : GroupSet (πS 0 X) j}
    → Ribbon X gs a₁ ≃ GroupSet.El gs
  ribbon-a₁-to-El-equiv {j} {gs} = let open GroupSet gs in
    ribbon-a₁-to-El , is-eq _
      (λ r → trace r idp₀)
      (λ a↑ → unit-r a↑)
      (Ribbon-elim
        {P = λ r → trace (ribbon-a₁-to-El r) idp₀ == r}
        (λ y p →
          trace (act y p) idp₀
            =⟨ paste y p idp₀ ⟩
          trace y (p ∙₀ idp₀)
            =⟨ ap (trace y) $ ∙₀-unit-r p ⟩
          trace y p
            ∎)
        (λ _ _ _ → prop-has-all-paths-↓))

  grpset-to-cover-to-grpset : ∀ {j} (gs : GroupSet (πS 0 X) (lmax i j))
    → cover-to-grpset (grpset-to-cover gs) == gs
  grpset-to-cover-to-grpset gs =
    groupset=
      ribbon-a₁-to-El-equiv
      (λ {x₁}{x₂} x= → Trunc-elim λ g →
        ribbon-a₁-to-El (transport (Ribbon X gs) g x₁)
          =⟨ ap (λ x → ribbon-a₁-to-El (transport (Ribbon X gs) g x))
                $ ! $ <–-inv-l ribbon-a₁-to-El-equiv x₁ ⟩
        ribbon-a₁-to-El (transport (Ribbon X gs) g (trace (ribbon-a₁-to-El x₁) idp₀))
          =⟨ ap (λ x → ribbon-a₁-to-El (transport (Ribbon X gs) g (trace x idp₀))) x= ⟩
        ribbon-a₁-to-El (transport (Ribbon X gs) g (trace x₂ idp₀))
          =⟨ ap ribbon-a₁-to-El $ transp-trace g x₂ idp₀ ⟩
        GroupSet.act gs x₂ [ g ]
          ∎)

  -- Finally...
  grpset-equiv-cover : ∀ {j}
    → GroupSet (πS 0 X) (lmax i j) ≃ Cover A (lmax i j)
  grpset-equiv-cover {j} =
    grpset-to-cover , is-eq
      _
      (λ c → cover-to-grpset c)
      (λ c → cover-to-grpset-to-cover {lmax i j} c)
      (grpset-to-cover-to-grpset {lmax i j})

  -- The path-set cover is represented by the fundamental group itself
  path-set-repr-by-π1 : cover-to-grpset (path-set-cover X)
    == group-to-group-set (πS 0 X)
  path-set-repr-by-π1 = groupset= (ide _)
    (λ {x₁} p g → (transp₀-cst=₀idf g x₁ ∙ ∙₀'=∙₀ x₁ g) ∙' ap (_∙₀ g) p)


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

open import HoTT
open import homotopy.FinWedge

module homotopy.Bouquet where

Rose : ∀ {i} (I : Type i) → Type i
Rose I = BigWedge {A = I} (λ _ → ⊙S¹)

Bouquet-family : ∀ {i} (I : Type i) (m : ℕ) → (I → Ptd₀)
Bouquet-family I m _ = ⊙Sphere m

Bouquet : ∀ {i} (I : Type i) (m : ℕ) → Type i
Bouquet I m = BigWedge (Bouquet-family I m)

⊙Bouquet : ∀ {i} (I : Type i) (m : ℕ) → Ptd i
⊙Bouquet I m = ⊙BigWedge (Bouquet-family I m)

BouquetLift-family : ∀ {i} (I : Type i) (m : ℕ) → (I → Ptd i)
BouquetLift-family {i} I m _ = ⊙Lift {j = i} (⊙Sphere m)

BouquetLift : ∀ {i} (I : Type i) (m : ℕ) → Type i
BouquetLift {i} I m = BigWedge (BouquetLift-family I m)

⊙BouquetLift : ∀ {i} (I : Type i) (m : ℕ) → Ptd i
⊙BouquetLift {i} I m = ⊙BigWedge (BouquetLift-family I m)

FinBouquetLift-family : ∀ {i} (I m : ℕ) → (Fin I → Ptd i)
FinBouquetLift-family {i} I m _ = ⊙Lift {j = i} (⊙Sphere m)

⊙FinBouquetLift : ∀ {i} (I m : ℕ) → Ptd i
⊙FinBouquetLift I m = ⊙FinWedge (FinBouquetLift-family I m)

FinBouquet-family : (I m : ℕ) → (Fin I → Ptd₀)
FinBouquet-family I m _ = ⊙Sphere m

FinBouquet : (I m : ℕ) → Type₀
FinBouquet I m = FinWedge (FinBouquet-family I m)

⊙FinBouquet : (I m : ℕ) → Ptd₀
⊙FinBouquet I m = ⊙FinWedge (FinBouquet-family I m)


module OutsideIn.Prelude where

  open import Data.Nat public
  open import Relation.Binary.PropositionalEquality public renaming ([_] to iC)
  open import Relation.Nullary public
  open import Function public hiding (case_of_)

  cong₃ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
          (f : A → B → C → D) {x y u v x′ y′} → x ≡ y → u ≡ v → x′ ≡ y′
        → f x u x′ ≡ f y v y′
  cong₃ f refl refl refl = refl

  cong₄ : ∀ {a b c d e} {A : Set a} {B : Set b} {C : Set c} {D : Set d} {E : Set e}
          (f : A → B → C → D → E) {x y u v x′ y′ u′ v′} → x ≡ y → u ≡ v → x′ ≡ y′ → u′ ≡ v′
        → f x u x′ u′ ≡ f y v y′ v′
  cong₄ f refl refl refl refl = refl

  import Level

  postulate extensionality : Extensionality Level.zero Level.zero

  module Shapes where

    -- Used throughout to show structure preserving operations preserve structure,
    -- in order to maintain structural recursion.
    data Shape : Set where
      Nullary : Shape
      Unary : Shape → Shape
      Binary : Shape → Shape → Shape

  module Functors where

    import Data.Vec as V
    open V using (_∷_; Vec; [])

    isIdentity : ∀ {A} → (A → A) → Set
    isIdentity {A} f = ∀ {x} → f x ≡ x

    id-is-id : ∀ {A} → isIdentity {A} id
    id-is-id = refl
    record Functor (X : Set → Set) : Set₁ where
      field map : ∀ {A B} → (A → B) → X A → X B
      _<$>_ : ∀ {A B} → (A → B) → X A → X B
      _<$>_ = map
      field identity : ∀ {A : Set}{f : A → A} → isIdentity f → isIdentity (map f)
      field composite : ∀ {A B C : Set} {f : A → B} {g : B → C}
                      → {x : X A} → ( (g ∘ f) <$> x ≡ g <$> (f <$> x))

    Pointed :  (Set → Set) → Set₁
    Pointed X = ∀ {a} → a → X a

    id-is-functor : Functor id
    id-is-functor = record { map = id; identity = id; composite = refl }

    vec-is-functor : ∀ {n} → Functor (λ A → Vec A n)
    vec-is-functor {n} = record { map = V.map; identity = ident {n} ; composite = composite }
      where ident :  {n : ℕ}{A : Set} {f : A → A} → isIdentity f →{x : Vec A n} → V.map f x ≡ x
            ident isid {[]} = refl
            ident isid {x ∷ xs} = cong₂ _∷_ isid (ident isid)
            composite : {A B C : Set}{n : ℕ} {f : A → B} {g : B → C} {x : Vec A n}
                      → V.map (g ∘ f) x ≡ V.map g (V.map f x)
            composite {x = []} = refl
            composite {x = x ∷ xs} = cong₂ _∷_ refl composite
    private
      module F = Functor ⦃ ... ⦄

    combine-composite′ : {X Y : Set → Set}{A B C : Set} ⦃ F2 : Functor Y ⦄
                        {V : X (Y A)}{f : A → B}{g : B → C}
                      → (f1map  : ∀ {a b} → (a → b) → (X a → X b))
                      → (f1comp :  f1map (F.map g ∘ F.map f) V
                                ≡  f1map (F.map g) (f1map (F.map f) V))
                      → f1map (F.map ⦃ F2 ⦄ (g ∘ f)) V
                      ≡ f1map (F.map ⦃ F2 ⦄ g) (f1map (F.map ⦃ F2 ⦄ f) V)
    combine-composite′ ⦃ F2 ⦄ {V} f1map f1comp = trans (cong (λ t → f1map t V)
                                                      (extensionality (λ x → F.composite ⦃ F2 ⦄)))
                                                 f1comp

    combine-composite : {X Y : Set → Set}{A B C : Set} ⦃ F1 : Functor X ⦄ ⦃ F2 : Functor Y ⦄
                        {V : X (Y A)}{f : A → B}{g : B → C}
                      → F.map ⦃ F1 ⦄ (F.map ⦃ F2 ⦄ (g ∘ f)) V
                      ≡ F.map ⦃ F1 ⦄ (F.map ⦃ F2 ⦄ g) (F.map ⦃ F1 ⦄ (F.map ⦃ F2 ⦄ f) V)
    combine-composite {X}{Y} ⦃ F1 ⦄ ⦃ F2 ⦄ {V} = combine-composite′ {X}{Y}
                                                                    (F.map ⦃ F1 ⦄)
                                                                    (F.composite ⦃ F1 ⦄)
    infixr 6 _∘f_
    _∘f_ : {X Y : Set → Set} → ( F1 : Functor X )( F2 : Functor Y )
                                    → Functor (X ∘ Y)
    F1 ∘f F2 = record { map = F.map ⦃ F1 ⦄ ∘ F.map ⦃ F2 ⦄
                      ; composite = combine-composite ⦃ F1 ⦄ ⦃ F2 ⦄
                      ; identity = F.identity ⦃ F1 ⦄ ∘ F.identity ⦃ F2 ⦄
                      }

  module StupidEquality where
    open import Data.Bool public using (Bool; true; false)
    -- This equality doesn't place any proof demands
    -- because we don't actually care what equality is used.
    -- This is just for the initial base of type variables, where the user provides
    -- their own type equality relation. We don't care if it says Int ∼ Bool - this just
    -- provides a way for users to get some equality information threaded through the
    -- simplifier
    Eq : Set → Set
    Eq X = ∀ (a b : X) → Bool

  module Monads where
    open Functors

    record Monad (X : Set → Set) : Set₁ where
      field ⦃ is-functor ⦄ : Functor X
      field ⦃ point ⦄ : Pointed X
      open Functor is-functor
      field join : ∀ {a} → X (X a) → X a
      unit : ∀ {a} → a → X a
      unit = point
      _>>=_ : ∀ {a b} → X a → (a → X b) → X b
      _>>=_ a b = join (b <$> a)
      _>>_ : ∀ {a b} → X a → X b → X b
      _>>_ a b = a >>= λ _ → b
      _>=>_ : ∀ {a b c : Set} → (b → X c) → (a → X b) → (a → X c)
      _>=>_ a b = λ v → b v >>= a
      field is-left-ident : ∀ {a b}{x : a → X b}{v} → (point >=> x) v ≡ x v
      field is-right-ident : ∀ {a b}{x : a → X b}{v} → (x >=> point) v ≡ x v
      field >=>-assoc : ∀{p}{q}{r}{s}{a : r → X s}{b : q → X r} {c : p → X q}{v}
                      → (a >=> (b >=> c)) v ≡ ((a >=> b) >=> c) v

      abstract
        <$>-unit : ∀ {A B}{g : A → B}{x} → g <$> (unit x) ≡  unit (g x)
        <$>-unit {A}{B}{g}{x} = begin
          g <$> (unit x)                         ≡⟨ sym (is-left-ident {x = _<$>_ g}) ⟩
          join (unit <$> (g <$> (unit x)))       ≡⟨ cong join (sym (composite)) ⟩
          join ((λ x → unit (g x)) <$> (unit x)) ≡⟨ is-right-ident ⟩
          unit (g x)                             ∎
         where open ≡-Reasoning

      abstract
        <$>-bind : ∀ {A B C}{f : A → B}{g : B → X C}{x : X A}
                 → (f <$> x) >>= g ≡ x >>= (λ z → g (f z))
        <$>-bind = cong join (sym (composite))

        natural-trans : ∀ {A B}{f : A → B}{x : X( X A)} → f <$> (join x) ≡ join ((_<$>_ f) <$> x)
        natural-trans {A}{B}{f}{x} = begin
           f <$> (join x)                                  ≡⟨ sym (is-left-ident {x = _<$>_ f}) ⟩
           join (unit <$> (f <$> (join x)))                ≡⟨ † ⟩
           join (unit <$> (f <$> (join (id <$> x))))       ≡⟨ <$>-bind ⟩
           join ((λ v → unit (f v)) <$> (join (id <$> x))) ≡⟨ >=>-assoc { c = λ _ → x}{0} ⟩
           join ((λ x → join ((unit ∘ f) <$> x)) <$> x )   ≡⟨ sym (<$>-bind) ⟩
           ((_<$>_ (λ y → unit (f y))) <$> x ) >>= join    ≡⟨ <$>-bind ⟩
           x >>= (λ x → x >>= (λ y → unit (f y)))          ≡⟨ * ⟩
           join ((_<$>_ f) <$> x)                          ∎
          where open ≡-Reasoning
                † : join (unit <$> (f <$> (join x))) ≡ join (unit <$> (f <$> (join (id <$> x))))
                † = cong (λ t → join (unit <$> (f <$> join t))) (sym (identity id-is-id ))
                * : x >>= (λ x → x >>= (λ y → unit (f y))) ≡ join ((_<$>_ f) <$> x)
                * = cong (_>>=_ x)
                         (extensionality (λ y → trans (sym <$>-bind)
                                                      (is-left-ident {x = _<$>_ f}{v = y})))

    id-is-monad : Monad id
    id-is-monad = record { is-functor = id-is-functor
                         ; point = id
                         ; join = id
                         ; >=>-assoc = refl
                         ; is-left-ident = refl
                         ; is-right-ident = refl
                         }

    record MonadHomomorphism {M₁ M₂ : Set → Set}(h : ∀ {x : Set} → M₁ x → M₂ x)
                             ⦃ M₁-m : Monad M₁ ⦄ ⦃ M₂-m : Monad M₂ ⦄ : Set₁ where
      open Monad M₁-m using () renaming (unit to unit₁; join to join₁; is-functor to is-functor₁)
      open Monad M₂-m using () renaming (unit to unit₂; join to join₂; is-functor to is-functor₂)
      open Functor is-functor₁ using () renaming (map to map₁)
      open Functor is-functor₂ using () renaming (map to map₂)
      field h-return :  ∀ {A}{x : A} → h (unit₁ x) ≡ unit₂ x
      field h-fmap : {A B : Set} {f : A → B} {x : M₁ A}
                     → h (map₁ f x) ≡ map₂ f (h x)
      field h-join : ∀{τ}{x : M₁ (M₁ τ)} → h (join₁ x) ≡ join₂ (h (map₁ h x))

    record MonadTrans (X : (Set → Set) → Set → Set) : Set₁ where
      field produces-monad : ∀ {m} → Monad m → Monad (X m)
      field lift : ∀ {m}⦃ mm : Monad m ⦄{a} → m a → X m a
      field is-homomorphism : ∀ {m} → (mm : Monad m)
                            → MonadHomomorphism {m} {X m} (lift {m}) ⦃ mm ⦄ ⦃ produces-monad mm ⦄

  module Ⓢ-Type where
    open Functors
    open Monads
    open StupidEquality

    data Ⓢ (τ : Set) : Set where
      suc : τ → Ⓢ τ
      zero : Ⓢ τ

    cata-Ⓢ : {a b : Set} → b → (a → b) → Ⓢ a → b
    cata-Ⓢ nil something zero = nil
    cata-Ⓢ nil something (suc n) = something n

    sequence-Ⓢ : ∀ {m}{b} → ⦃ monad : Monad m ⦄ →  Ⓢ (m b) → m (Ⓢ b)
    sequence-Ⓢ ⦃ m ⦄ (suc n) = map suc n
      where open Functor (Monad.is-functor m)
    sequence-Ⓢ ⦃ m ⦄ (zero) = unit zero
      where open Monad (m)

    private
      fmap-Ⓢ : ∀ {a b} → (a → b) → Ⓢ a → Ⓢ b
      fmap-Ⓢ f zero = zero
      fmap-Ⓢ f (suc n) = suc (f n)
      abstract
        fmap-Ⓢ-id : ∀ {A} → {f : A → A}
                   → isIdentity f → isIdentity (fmap-Ⓢ f)
        fmap-Ⓢ-id isid {zero} = refl
        fmap-Ⓢ-id isid {suc x} = cong suc isid

        fmap-Ⓢ-comp : ∀ {A B C : Set} {f : A → B} {g : B → C} → ∀ {x}
                     → fmap-Ⓢ (g ∘ f) x ≡ fmap-Ⓢ g (fmap-Ⓢ f x)
        fmap-Ⓢ-comp {x = zero} = refl
        fmap-Ⓢ-comp {x = suc n} = refl

    Ⓢ-is-functor : Functor Ⓢ
    Ⓢ-is-functor = record { map = fmap-Ⓢ
                           ; identity = fmap-Ⓢ-id
                           ; composite = fmap-Ⓢ-comp
                           }

    Ⓢ-eq : ∀ {x} → Eq x → Eq (Ⓢ x)
    Ⓢ-eq x zero zero = true
    Ⓢ-eq x (suc n) zero = false
    Ⓢ-eq x zero (suc m) = false
    Ⓢ-eq x (suc n) (suc m) = x n m

    private
      join-Ⓢ : ∀ {x} → Ⓢ (Ⓢ x) → Ⓢ x
      join-Ⓢ (zero) = zero
      join-Ⓢ (suc τ) = τ

      test-join : ∀ {A B}{f : A → B}{x : Ⓢ( Ⓢ A)}
                → fmap-Ⓢ f (join-Ⓢ x) ≡ join-Ⓢ (fmap-Ⓢ (fmap-Ⓢ f) x)
      test-join {x = zero} = refl
      test-join {x = suc n} = refl

    Ⓢ-is-monad : Monad Ⓢ
    Ⓢ-is-monad = record { is-functor     = Ⓢ-is-functor
                         ; point          = suc
                         ; join           = join-Ⓢ
                         ; is-left-ident  = left-id
                         ; is-right-ident = refl
                         ; >=>-assoc        = λ { {c = c}{v} → assoc {τ = c v} }
                         }
        where
          left-id : ∀ {τ : Set}{v : Ⓢ τ} → join-Ⓢ (fmap-Ⓢ suc v) ≡ v
          left-id {v = zero } = refl
          left-id {v = suc v} = refl
          assoc : ∀ {q r s : Set} {a : r → Ⓢ s} {b : q → Ⓢ r}{τ : Ⓢ q}
                → join-Ⓢ (fmap-Ⓢ a (join-Ⓢ (fmap-Ⓢ b τ)))
                ≡ join-Ⓢ (fmap-Ⓢ (λ v′ → join-Ⓢ (fmap-Ⓢ  a (b v′))) τ)
          assoc {τ = zero} = refl
          assoc {τ = suc v} = refl

    Ⓢ-Trans : (Set → Set) → Set → Set
    Ⓢ-Trans m x = m (Ⓢ x)

    private
      lift : ∀ {m : Set → Set}⦃ mm : Monad m ⦄{x} → m x → m (Ⓢ x)
      lift {m}⦃ mm ⦄{x} v = suc <$> v
        where open Monad mm
              open Functor is-functor

      module MonadProofs {m : Set → Set}⦃ mm : Monad m ⦄ where
        open Monad mm
        open Functor is-functor
        functor : Functor (Ⓢ-Trans m)
        functor = record { map = λ f v → (fmap-Ⓢ f) <$> v
                         ; identity = λ p → identity (fmap-Ⓢ-id p)
                         ; composite = λ { {x = x} → trans (cong (λ t → t <$> x)
                                                           (extensionality ext)) composite }
                         }
          where open ≡-Reasoning
                ext : ∀ {A B C : Set} {f : A → B} {g : B → C} → (x' : Ⓢ A)
                    → fmap-Ⓢ (g ∘ f) x' ≡ (fmap-Ⓢ g ∘ fmap-Ⓢ f) x'
                ext (zero) = refl
                ext (suc n) = refl

        module Trans = Functor functor

        private
          cata-Ⓢ-u0 : ∀ {a b} → (a → m (Ⓢ b)) → Ⓢ a → m (Ⓢ b)
          cata-Ⓢ-u0 = cata-Ⓢ (unit zero)
        abstract
          right-id :  {a b : Set} {x : a → Ⓢ-Trans m b} {v : a}
                   → Trans.map x (lift {m} (unit v)) >>= cata-Ⓢ-u0 id ≡ x v
          right-id {a}{b}{x}{v} = begin
            Trans.map x (suc <$> (unit v)) >>= cata-Ⓢ-u0 id ≡⟨ * ⟩
            (fmap-Ⓢ x <$> (unit (suc v))) >>= cata-Ⓢ-u0 id ≡⟨ † ⟩
            join (cata-Ⓢ-u0 id <$> (unit (suc (x v))))      ≡⟨ cong join <$>-unit ⟩
            join (unit (x v))                                ≡⟨ cong join (sym(identity id-is-id)) ⟩
            join (id <$> unit (x v))                         ≡⟨ is-right-ident {x = id} ⟩
            x v                                              ∎
           where open ≡-Reasoning
                 * : Trans.map x (suc <$> (unit v)) >>= cata-Ⓢ-u0 id
                   ≡ (fmap-Ⓢ x <$> (unit (suc v))) >>= cata-Ⓢ-u0 id
                 * = cong (λ t → Trans.map x t >>= cata-Ⓢ-u0 id) <$>-unit
                 † : (fmap-Ⓢ x <$> (unit (suc v))) >>= cata-Ⓢ-u0 id
                   ≡ join (cata-Ⓢ-u0 id <$> (unit (suc (x v))))
                 † = cong (λ x → x >>= cata-Ⓢ-u0 id) <$>-unit

          left-id : {b : Set} {t : Ⓢ-Trans m b}
                  → Trans.map (λ x' → lift {m} (unit x')) t >>= cata-Ⓢ-u0 id ≡ t
          left-id {b}{t} = trans <$>-bind (subst (λ q → t >>= q ≡ t)
                                                 (sym (extensionality h≗unit))
                                                 (is-left-ident {x = λ _ → t} {v = 0}))
            where h : ∀ {A} → Ⓢ A → m (Ⓢ A)
                  h x = cata-Ⓢ-u0 id (fmap-Ⓢ (λ x' → suc <$> (unit x')) x)
                  h≗unit : ∀ {A} → h {A} ≗ unit
                  h≗unit zero = refl
                  h≗unit (suc y) = <$>-unit

          assoc : ∀ {p q r s : Set}
                    {a : r → Ⓢ-Trans m s}{b : q → Ⓢ-Trans m r}{c : p → Ⓢ-Trans m q}
                    {v : p}
                → Trans.map a (Trans.map b (c v) >>= cata-Ⓢ-u0 id) >>= cata-Ⓢ-u0 id
                ≡ Trans.map (λ v' → Trans.map a (b v') >>= cata-Ⓢ-u0 id) (c v) >>= cata-Ⓢ-u0 id
          assoc {p}{q}{r}{s}{a}{b}{c}{v}
            = let
                †₀ = cata-fmap
                †₁ = cong (λ x → x >>= cata-Ⓢ (unit zero) a) cata-fmap
                †₂ = >=>-assoc {c = λ _ → c v} {v = 0}
                †₃ = cong (_>>=_ (c v)) (extensionality ext)
                †₄ = cong (λ x → c v >>= cata-Ⓢ (unit zero) x)
                          (extensionality (λ x → sym cata-fmap))
                †₅ = sym (cata-fmap)
              in begin
                 Trans.map a (Trans.map b (c v) >>= cata-Ⓢ-u0 id) >>= cata-Ⓢ-u0 id ≡⟨ †₀ ⟩
                 ((fmap-Ⓢ b <$> c v) >>= cata-Ⓢ-u0 id) >>= cata-Ⓢ-u0 a            ≡⟨ †₁ ⟩
                 (c v >>= cata-Ⓢ-u0 b) >>= cata-Ⓢ-u0 a                             ≡⟨ †₂ ⟩
                 c v >>= (λ cv → cata-Ⓢ-u0 b cv >>= cata-Ⓢ-u0 a)                   ≡⟨ †₃ ⟩
                 c v >>= cata-Ⓢ-u0 (λ v' → b v' >>= cata-Ⓢ-u0 a)                   ≡⟨ †₄ ⟩
                 c v >>= cata-Ⓢ-u0 (λ v' → (fmap-Ⓢ a <$> b v') >>= cata-Ⓢ-u0 id)  ≡⟨ †₅ ⟩
                 Trans.map (λ v' → Trans.map a (b v') >>= cata-Ⓢ-u0 id) (c v) >>= cata-Ⓢ-u0 id ∎
           where open ≡-Reasoning
                 ext : (x : Ⓢ q) → cata-Ⓢ-u0 b x >>= cata-Ⓢ-u0 a
                                  ≡ cata-Ⓢ-u0 (λ v' → b v' >>= cata-Ⓢ-u0 a) x
                 ext zero = begin
                   join ((cata-Ⓢ-u0 a) <$> unit zero) ≡⟨ cong join <$>-unit ⟩
                   join (unit (unit zero))             ≡⟨ cong join (sym (identity id-is-id)) ⟩
                   join (id <$> unit (unit zero))      ≡⟨ is-right-ident ⟩
                   unit zero                           ∎
                 ext (suc n) = refl
                 cata-fmap : ∀{A B C}{a : A → B}{x : m (Ⓢ A)}{n : m C}{j : B → m C}
                           → (fmap-Ⓢ a <$> x) >>= cata-Ⓢ n j ≡ x >>= cata-Ⓢ n (λ x → j ( a x))
                 cata-fmap {A}{B}{C}{a}{x}{n}{j} = trans <$>-bind
                                                         (cong (_>>=_ x) (extensionality ext′))
                  where ext′ : (x' : Ⓢ A) → cata-Ⓢ n j (fmap-Ⓢ a x')
                                           ≡ cata-Ⓢ n (λ x0 → j (a x0)) x'
                        ext′ zero = refl
                        ext′ (suc n) = refl
        produces-monad = record { point = λ x → lift ⦃ mm ⦄ (unit x)
                                ; is-functor = functor
                                ; join = λ v → v >>= cata-Ⓢ (unit zero) id
                                ; is-left-ident = left-id
                                ; is-right-ident = right-id
                                ; >=>-assoc = λ {_}{_}{_}{_}{a}{b}{c}{v}
                                            → assoc {a = a}{b}{c}{v}
                                }

      module HomomorphismProofs {m : Set → Set}⦃ mm : Monad m ⦄ where
        open Monad mm
        open Functor is-functor
        open ≡-Reasoning

        cata-Ⓢ-u0 : ∀ {a b} → (a → m (Ⓢ b)) → Ⓢ a → m (Ⓢ b)
        cata-Ⓢ-u0 = cata-Ⓢ (unit zero)

        fmap-p : ∀ {A B : Set} {f : A → B} {x}
               → lift {m} (f <$> x) ≡ (fmap-Ⓢ f) <$> (lift {m} x)
        fmap-p {A}{B}{f}{x} =  begin
          suc <$> (f <$> x)               ≡⟨ sym (composite) ⟩
          (λ t → suc (f t)) <$> x         ≡⟨ refl ⟩
          (λ t → fmap-Ⓢ f (suc t)) <$> x ≡⟨ composite ⟩
          (fmap-Ⓢ f) <$> (suc <$> x)     ∎

        join-p : ∀{τ}{x : m (m (τ))}
               → suc <$> (join x) ≡ (suc <$> (_<$>_ suc <$> x)) >>= cata-Ⓢ-u0 id
        join-p {_}{x} = begin
          suc <$> (join x)                                  ≡⟨ natural-trans ⟩
          join ((_<$>_ suc) <$> x)                          ≡⟨ refl ⟩
          x >>= (λ z → cata-Ⓢ-u0 id (suc (suc <$> z)))     ≡⟨ sym (<$>-bind) ⟩
          ((λ z → suc (suc <$> z)) <$> x) >>= cata-Ⓢ-u0 id ≡⟨ † ⟩
          (suc <$> (_<$>_ suc <$> x)) >>= cata-Ⓢ-u0 id     ∎
         where † = cong (λ x → x >>= cata-Ⓢ-u0 id) (composite)

        is-homomorphism : MonadHomomorphism (lift {m}) ⦃ mm ⦄ ⦃ MonadProofs.produces-monad ⦃ mm ⦄ ⦄
        is-homomorphism = record { h-return = refl
                                 ; h-fmap = fmap-p
                                 ; h-join = join-p
                                 }

    Ⓢ-Trans-is-trans : MonadTrans (Ⓢ-Trans)
    Ⓢ-Trans-is-trans = record { produces-monad = λ mm → MonadProofs.produces-monad ⦃ mm ⦄
                               ; lift = λ{m} → lift {m}
                               ; is-homomorphism = λ mm → HomomorphismProofs.is-homomorphism ⦃ mm ⦄
                               }

  module PlusN-Type where

    open Ⓢ-Type
    open Monads
    open Functors
    open StupidEquality

    PlusN : (n : ℕ) → Set → Set
    PlusN zero = id
    PlusN (suc n) = Ⓢ-Trans (PlusN n)

    PlusN-eq : ∀ {n}{x} → Eq x → Eq (PlusN n x)
    PlusN-eq {zero} eq = eq
    PlusN-eq {suc n} eq = PlusN-eq {n} (Ⓢ-eq eq)

    PlusN-is-monad : ∀ {n} → Monad (PlusN n)
    PlusN-is-monad {zero} = id-is-monad
    PlusN-is-monad {suc n} = MonadTrans.produces-monad Ⓢ-Trans-is-trans (PlusN-is-monad {n})

    _⨁_ = flip PlusN

    sequence-PlusN : ∀ {m}{n}{b} → ⦃ monad : Monad m ⦄ → (m b) ⨁ n → m (b ⨁ n)
    sequence-PlusN {n = zero} x = x
    sequence-PlusN {n = suc n} ⦃ m ⦄ x = sequence-PlusN {n = n}⦃ m ⦄
                                                        (PlusN-f.map (sequence-Ⓢ ⦃ m ⦄) x)
      where module PlusN-f = Functor (Monad.is-functor (PlusN-is-monad {n}))

    PlusN-collect : ∀ {n}{a b} → n ⨁ (a + b) ≡ (n ⨁ a) ⨁ b
    PlusN-collect {n}{zero} = refl
    PlusN-collect {n}{suc a}{b} = PlusN-collect {Ⓢ n}{a}{b}

  open Ⓢ-Type public
  open PlusN-Type public
  open Functors public
  open Monads public
  open Shapes public
  open StupidEquality public


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Nat renaming (_+_ to _+n_ ; _·_ to _·n_)
open import Cubical.Data.Int
open import Cubical.Data.Vec
open import Cubical.Data.FinData

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Int renaming (ℤGroup to ℤG)
open import Cubical.Algebra.DirectSum.Base
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Instances.Int renaming (ℤCommRing to ℤCR)
open import Cubical.Algebra.CommRing.FGIdeal
open import Cubical.Algebra.CommRing.QuotientRing
open import Cubical.Algebra.Polynomials.Multivariate.Base renaming (base to baseP)
open import Cubical.Algebra.Polynomials.Multivariate.EquivCarac.A[X]X-A
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly-Quotient
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly-notationZ

open import Cubical.HITs.Truncation
open import Cubical.HITs.SetQuotients as SQ renaming (_/_ to _/sq_)
open import Cubical.HITs.PropositionalTruncation as PT

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.RingStructure.CupProduct
open import Cubical.ZCohomology.RingStructure.CohomologyRing
open import Cubical.ZCohomology.Groups.Unit

open Iso

module Equiv-Unit-Properties where

  open CommRingStr (snd ℤCR) using ()
    renaming
    ( 0r        to 0ℤ
    ; 1r        to 1ℤ
    ; _+_       to _+ℤ_
    ; -_        to -ℤ_
    ; _·_       to _·ℤ_
    ; +Assoc    to +ℤAssoc
    ; +Identity to +ℤIdentity
    ; +Lid      to +ℤLid
    ; +Rid      to +ℤRid
    ; +Inv      to +ℤInv
    ; +Linv     to +ℤLinv
    ; +Rinv     to +ℤRinv
    ; +Comm     to +ℤComm
    ; ·Assoc    to ·ℤAssoc
    ; ·Identity to ·ℤIdentity
    ; ·Lid      to ·ℤLid
    ; ·Rid      to ·ℤRid
    ; ·Rdist+   to ·ℤRdist+
    ; ·Ldist+   to ·ℤLdist+
    ; is-set    to isSetℤ     )

  open RingStr (snd (H*R Unit)) using ()
    renaming
    ( 0r        to 0H*
    ; 1r        to 1H*
    ; _+_       to _+H*_
    ; -_        to -H*_
    ; _·_       to _cup_
    ; +Assoc    to +H*Assoc
    ; +Identity to +H*Identity
    ; +Lid      to +H*Lid
    ; +Rid      to +H*Rid
    ; +Inv      to +H*Inv
    ; +Linv     to +H*Linv
    ; +Rinv     to +H*Rinv
    ; +Comm     to +H*Comm
    ; ·Assoc    to ·H*Assoc
    ; ·Identity to ·H*Identity
    ; ·Lid      to ·H*Lid
    ; ·Rid      to ·H*Rid
    ; ·Rdist+   to ·H*Rdist+
    ; ·Ldist+   to ·H*Ldist+
    ; is-set    to isSetH*     )

  open CommRingStr (snd ℤ[X]) using ()
    renaming
    ( 0r        to 0Pℤ
    ; 1r        to 1Pℤ
    ; _+_       to _+Pℤ_
    ; -_        to -Pℤ_
    ; _·_       to _·Pℤ_
    ; +Assoc    to +PℤAssoc
    ; +Identity to +PℤIdentity
    ; +Lid      to +PℤLid
    ; +Rid      to +PℤRid
    ; +Inv      to +PℤInv
    ; +Linv     to +PℤLinv
    ; +Rinv     to +PℤRinv
    ; +Comm     to +PℤComm
    ; ·Assoc    to ·PℤAssoc
    ; ·Identity to ·PℤIdentity
    ; ·Lid      to ·PℤLid
    ; ·Rid      to ·PℤRid
    ; ·Rdist+   to ·PℤRdist+
    ; ·Ldist+   to ·PℤLdist+
    ; is-set    to isSetPℤ     )

  open CommRingStr (snd ℤ[X]/X) using ()
    renaming
    ( 0r        to 0PℤI
    ; 1r        to 1PℤI
    ; _+_       to _+PℤI_
    ; -_        to -PℤI_
    ; _·_       to _·PℤI_
    ; +Assoc    to +PℤIAssoc
    ; +Identity to +PℤIIdentity
    ; +Lid      to +PℤILid
    ; +Rid      to +PℤIRid
    ; +Inv      to +PℤIInv
    ; +Linv     to +PℤILinv
    ; +Rinv     to +PℤIRinv
    ; +Comm     to +PℤIComm
    ; ·Assoc    to ·PℤIAssoc
    ; ·Identity to ·PℤIIdentity
    ; ·Lid      to ·PℤILid
    ; ·Rid      to ·PℤIRid
    ; ·Rdist+   to ·PℤIRdist+
    ; ·Ldist+   to ·PℤILdist+
    ; is-set    to isSetPℤI     )

-----------------------------------------------------------------------------
-- Direct Sens on ℤ[x]

  ℤ[x]→H*-Unit : ℤ[x] → H* Unit
  ℤ[x]→H*-Unit = Poly-Rec-Set.f _ _ _ isSetH*
                  0H*
                  base-trad
                  _+H*_
                  +H*Assoc
                  +H*Rid
                  +H*Comm
                  base-neutral-eq
                  base-add-eq
               where
               base-trad : _
               base-trad (zero ∷ []) a = base zero (inv (fst H⁰-Unit≅ℤ) a)
               base-trad (suc n ∷ []) a = 0H*

               base-neutral-eq :  _
               base-neutral-eq (zero ∷ []) = base-neutral _
               base-neutral-eq (suc n ∷ []) = refl

               base-add-eq : _
               base-add-eq (zero ∷ []) a b = base-add _ _ _
               base-add-eq (suc n ∷ []) a b = +H*Rid _

  ℤ[x]→H*-Unit-pres1Pℤ : ℤ[x]→H*-Unit (1Pℤ) ≡ 1H*
  ℤ[x]→H*-Unit-pres1Pℤ = refl

  ℤ[x]→H*-Unit-pres+ : (x y : ℤ[x]) → ℤ[x]→H*-Unit (x +Pℤ y) ≡ ℤ[x]→H*-Unit x +H* ℤ[x]→H*-Unit y
  ℤ[x]→H*-Unit-pres+ x y = refl

-- Proving the morphism on the cup product

  T0 : (z : ℤ) → coHom 0 Unit
  T0 = λ z → inv (fst H⁰-Unit≅ℤ) z

  T0g : IsGroupHom (ℤG .snd) (fst (invGroupIso H⁰-Unit≅ℤ) .fun) (coHomGr 0 Unit .snd)
  T0g = snd (invGroupIso H⁰-Unit≅ℤ)

    -- idea : control of the unfolding + simplification of T0 on the left
  pres·-base-case-00 : (a : ℤ) → (b : ℤ) →
                        T0 (a ·ℤ b) ≡ (T0 a) ⌣ (T0 b)
  pres·-base-case-00 (pos zero)       b = (IsGroupHom.pres1 T0g)
  pres·-base-case-00 (pos (suc n))    b = ((IsGroupHom.pres· T0g b (pos n ·ℤ b)))
                                          ∙ (cong (λ X → (T0 b) +ₕ X) (pres·-base-case-00 (pos n) b))
  pres·-base-case-00 (negsuc zero)    b = IsGroupHom.presinv T0g b
  pres·-base-case-00 (negsuc (suc n)) b = cong T0 (+ℤComm (-ℤ b) (negsuc n ·ℤ b)) -- ·ℤ and ·₀ are defined asymetrically !
                                          ∙ IsGroupHom.pres· T0g (negsuc n ·ℤ b) (-ℤ b)
                                          ∙ cong₂ _+ₕ_ (pres·-base-case-00 (negsuc n) b)
                                                         (IsGroupHom.presinv T0g b)

  pres·-base-case-int : (n : ℕ) → (a : ℤ) → (m : ℕ) → (b : ℤ) →
                ℤ[x]→H*-Unit (baseP (n ∷ []) a ·Pℤ baseP (m ∷ []) b)
              ≡ ℤ[x]→H*-Unit (baseP (n ∷ []) a) cup ℤ[x]→H*-Unit (baseP (m ∷ []) b)
  pres·-base-case-int zero    a zero    b = cong (base 0) (pres·-base-case-00 a b)
  pres·-base-case-int zero    a (suc m) b = refl
  pres·-base-case-int (suc n) a m       b = refl

  pres·-base-case-vec : (v : Vec ℕ 1) → (a : ℤ) → (v' : Vec ℕ 1) → (b : ℤ) →
                ℤ[x]→H*-Unit (baseP v a ·Pℤ baseP v' b)
              ≡ ℤ[x]→H*-Unit (baseP v a) cup ℤ[x]→H*-Unit (baseP v' b)
  pres·-base-case-vec (n ∷ []) a (m ∷ []) b = pres·-base-case-int n a m b

  ℤ[x]→H*-Unit-pres· : (x y : ℤ[x]) → ℤ[x]→H*-Unit (x ·Pℤ y) ≡ ℤ[x]→H*-Unit x cup ℤ[x]→H*-Unit y
  ℤ[x]→H*-Unit-pres· = Poly-Ind-Prop.f _ _ _
                         (λ x p q i y j → isSetH* _ _ (p y) (q y) i j)
                         (λ y → refl)
                         base-case
                         λ {U V} ind-U ind-V y → cong₂ _+H*_ (ind-U y) (ind-V y)
    where
    base-case : _
    base-case (n ∷ []) a = Poly-Ind-Prop.f _ _ _ (λ _ → isSetH* _ _)
                           (sym (RingTheory.0RightAnnihilates (H*R Unit) _))
                           (λ v' b → pres·-base-case-vec (n ∷ []) a v' b)
                           λ {U V} ind-U ind-V → (cong₂ _+H*_ ind-U ind-V) ∙ sym (·H*Rdist+ _ _ _)

    -- raising to the product
  ℤ[x]→H*-Unit-cancelX : (k : Fin 1) → ℤ[x]→H*-Unit (<X> k) ≡ 0H*
  ℤ[x]→H*-Unit-cancelX zero = refl

  ℤ[X]→H*-Unit : RingHom (CommRing→Ring ℤ[X]) (H*R Unit)
  fst ℤ[X]→H*-Unit = ℤ[x]→H*-Unit
  snd ℤ[X]→H*-Unit = makeIsRingHom ℤ[x]→H*-Unit-pres1Pℤ ℤ[x]→H*-Unit-pres+ ℤ[x]→H*-Unit-pres·

  ℤ[X]/X→H*R-Unit : RingHom (CommRing→Ring ℤ[X]/X) (H*R Unit)
  ℤ[X]/X→H*R-Unit = Quotient-FGideal-CommRing-Ring.f ℤ[X] (H*R Unit) ℤ[X]→H*-Unit <X> ℤ[x]→H*-Unit-cancelX

  ℤ[x]/x→H*-Unit : ℤ[x]/x → H* Unit
  ℤ[x]/x→H*-Unit = fst ℤ[X]/X→H*R-Unit

-----------------------------------------------------------------------------
-- Converse Sens on ℤ[X]

  H*-Unit→ℤ[x] : H* Unit → ℤ[x]
  H*-Unit→ℤ[x] = DS-Rec-Set.f _ _ _ _ isSetPℤ
                  0Pℤ
                  base-trad
                  _+Pℤ_
                  +PℤAssoc
                  +PℤRid
                  +PℤComm
                  base-neutral-eq
                  base-add-eq
               where
               base-trad : (n : ℕ) → coHom n Unit → ℤ[x]
               base-trad zero a = baseP (0 ∷ []) (fun (fst H⁰-Unit≅ℤ) a)
               base-trad (suc n) a = 0Pℤ

               base-neutral-eq : _
               base-neutral-eq zero = base-0P _
               base-neutral-eq (suc n) = refl

               base-add-eq : _
               base-add-eq zero a b = base-poly+ _ _ _
                                      ∙ cong (baseP (0 ∷ [])) (sym (IsGroupHom.pres· (snd H⁰-Unit≅ℤ) a b))
               base-add-eq (suc n) a b = +PℤRid _

  H*-Unit→ℤ[x]-pres+ : (x y : H* Unit) → H*-Unit→ℤ[x] ( x +H* y) ≡ H*-Unit→ℤ[x] x +Pℤ H*-Unit→ℤ[x] y
  H*-Unit→ℤ[x]-pres+ x y = refl

  H*-Unit→ℤ[x]/x : H* Unit → ℤ[x]/x
  H*-Unit→ℤ[x]/x = [_] ∘ H*-Unit→ℤ[x]

  H*-Unit→ℤ[x]/x-pres+ : (x y : H* Unit) → H*-Unit→ℤ[x]/x (x +H* y) ≡ (H*-Unit→ℤ[x]/x x) +PℤI (H*-Unit→ℤ[x]/x y)
  H*-Unit→ℤ[x]/x-pres+ x y = cong [_] (H*-Unit→ℤ[x]-pres+ x y)

-----------------------------------------------------------------------------
-- Section

  e-sect : (x : H* Unit) → ℤ[x]/x→H*-Unit (H*-Unit→ℤ[x]/x x) ≡ x
  e-sect = DS-Ind-Prop.f _ _ _ _ (λ _ → isSetH* _ _)
           refl
           base-case
           λ {U V} ind-U ind-V → cong ℤ[x]/x→H*-Unit (H*-Unit→ℤ[x]/x-pres+ U V)
                                  ∙ IsRingHom.pres+ (snd ℤ[X]/X→H*R-Unit) (H*-Unit→ℤ[x]/x U) (H*-Unit→ℤ[x]/x V)
                                  ∙ cong₂ _+H*_ ind-U ind-V
           where
           base-case : _
           base-case zero a = cong (base 0) (leftInv (fst H⁰-Unit≅ℤ) a)
           base-case (suc n) a = (sym (base-neutral (suc n)))
                                 ∙ (cong (base (suc n)) ((isContr→isProp (isContrHⁿ-Unit n) _ a)))

-----------------------------------------------------------------------------
-- Retraction

  e-retr : (x : ℤ[x]/x) → H*-Unit→ℤ[x]/x (ℤ[x]/x→H*-Unit x) ≡ x
  e-retr = SQ.elimProp (λ _ → isSetPℤI _ _)
           (Poly-Ind-Prop.f _ _ _ (λ _ → isSetPℤI _ _)
           refl
           base-case
           λ {U V} ind-U ind-V → cong₂ _+PℤI_ ind-U ind-V)
           where
           base-case : _
           base-case (zero ∷ []) a = refl
           base-case (suc n ∷ []) a = eq/ 0Pℤ (baseP (suc n ∷ []) a) ∣ ((λ x → baseP (n ∷ []) (-ℤ a)) , foo) ∣₁
             where
             foo : (0P poly+ baseP (suc n ∷ []) (- a)) ≡ (baseP (n +n 1 ∷ []) (- a · pos 1) poly+ 0P)
             foo = (0P poly+ baseP (suc n ∷ []) (- a)) ≡⟨ +PℤLid _ ⟩
                   baseP (suc n ∷ []) (- a) ≡⟨ cong₂ baseP (cong (λ X → X ∷ []) (sym ((+-suc n 0)
                                              ∙ (cong suc (+-zero n))))) (sym (·ℤRid _)) ⟩
                   baseP (n +n suc 0 ∷ []) (- a ·ℤ 1ℤ) ≡⟨ refl ⟩
                   baseP (n +n 1 ∷ []) (- a · pos 1) ≡⟨ sym (+PℤRid _) ⟩
                   (baseP (n +n 1 ∷ []) (- a · pos 1) poly+ 0P) ∎

-----------------------------------------------------------------------------
-- Computation of the Cohomology Ring

module _ where

  open Equiv-Unit-Properties
  open RingEquivs

  Unit-CohomologyRingP : RingEquiv (CommRing→Ring ℤ[X]/X) (H*R Unit)
  fst Unit-CohomologyRingP = isoToEquiv is
    where
    is : Iso ℤ[x]/x (H* Unit)
    fun is = ℤ[x]/x→H*-Unit
    inv is = H*-Unit→ℤ[x]/x
    rightInv is = e-sect
    leftInv is = e-retr
  snd Unit-CohomologyRingP = snd ℤ[X]/X→H*R-Unit

  CohomologyRing-UnitP : RingEquiv (H*R Unit) (CommRing→Ring ℤ[X]/X)
  CohomologyRing-UnitP = invEquivRing Unit-CohomologyRingP

  Unit-CohomologyRingℤ : RingEquiv (CommRing→Ring ℤCR) (H*R Unit)
  Unit-CohomologyRingℤ = compRingEquiv (invEquivRing Equiv-ℤ[X]/X-ℤ) Unit-CohomologyRingP

  CohomologyRing-Unitℤ : RingEquiv (H*R Unit) (CommRing→Ring ℤCR)
  CohomologyRing-Unitℤ = compRingEquiv CohomologyRing-UnitP Equiv-ℤ[X]/X-ℤ


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.ZCohomology.KcompPrelims where

open import Cubical.ZCohomology.Base
open import Cubical.Homotopy.Connected
open import Cubical.HITs.Hopf
open import Cubical.Homotopy.Freudenthal hiding (encode)
open import Cubical.HITs.Sn
open import Cubical.HITs.S1
open import Cubical.HITs.Truncation renaming (elim to trElim ; rec to trRec ; map to trMap)

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Equiv.HalfAdjoint

open import Cubical.Data.Int renaming (_+_ to +Int)
open import Cubical.Data.Nat

open import Cubical.HITs.Susp
open import Cubical.HITs.Nullification
open import Cubical.Data.Prod.Base
open import Cubical.Homotopy.Loopspace
open import Cubical.Data.Bool
open import Cubical.Data.Sum.Base
open import Cubical.Data.Sigma hiding (_×_)
open import Cubical.Foundations.Function
open import Cubical.Foundations.Pointed
open import Cubical.HITs.S3

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ
    B : Type ℓ'

{- We want to prove that Kn≃ΩKn+1. For this we use the map ϕ-}

ϕ : (pt a : A) → typ (Ω (Susp A , north))
ϕ pt a = (merid a) ∙ sym (merid pt)

  {- To define the map for n=0 we use the λ k → loopᵏ map for S₊ 1. The loop is given by ϕ north south -}

loop* : Path (S₊ 1) north north
loop* = ϕ north south

looper : Int → Path (S₊ 1) north north
looper (pos zero) = refl
looper (pos (suc n)) = looper (pos n) ∙ loop*
looper (negsuc zero) = sym loop*
looper (negsuc (suc n)) = looper (negsuc n) ∙ sym loop*

private

  {- The map of Kn≃ΩKn+1 is given as follows. -}
  Kn→ΩKn+1 : (n : ℕ) → coHomK n → typ (Ω (coHomK-ptd (suc n)))
  Kn→ΩKn+1 zero x = cong ∣_∣ (looper x)
  Kn→ΩKn+1 (suc n) = trRec (isOfHLevelTrunc (2 + (suc (suc n))) ∣ north ∣ ∣ north ∣)
                             λ a → cong ∣_∣ ((merid a) ∙ (sym (merid north)))

  {- We show that looper is a composition of intLoop with two other maps, all three being isos -}
  sndcomp : ΩS¹ → Path (Susp Bool) north north
  sndcomp = cong S¹→SuspBool

  thrdcomp : Path (Susp Bool) north north → Path (S₊ 1) north north
  thrdcomp = cong SuspBool→S1

looper2 : Int → Path (S₊ 1) north north
looper2 a = thrdcomp (sndcomp (intLoop a))

looper≡looper2 : (x : Int) → looper x ≡ looper2 x
looper≡looper2 (pos zero) = refl
looper≡looper2 (pos (suc n)) =
       looper (pos n) ∙ loop*                                       ≡⟨ (λ i → looper≡looper2 (pos n) i ∙ congFunct SuspBool→S1 (merid false)  (sym (merid true)) (~ i)) ⟩
       looper2 (pos n) ∙ cong SuspBool→S1 (ϕ true false)           ≡⟨ sym (congFunct SuspBool→S1 (sndcomp (intLoop (pos n))) (ϕ true false)) ⟩
       cong SuspBool→S1 (sndcomp (intLoop (pos n)) ∙ ϕ true false) ≡⟨ cong thrdcomp (sym (congFunct S¹→SuspBool (intLoop (pos n)) loop)) ⟩
       looper2 (pos (suc n)) ∎
looper≡looper2 (negsuc zero) =
       sym loop*                                                    ≡⟨ symDistr (merid south) (sym (merid north)) ⟩
       merid north ∙ sym (merid south)                              ≡⟨ sym (congFunct SuspBool→S1 (merid true) (sym (merid false))) ⟩
       cong SuspBool→S1 (merid true ∙ sym (merid false))           ≡⟨ cong thrdcomp (sym (symDistr (merid false) (sym (merid true)))) ⟩
       looper2 (negsuc zero) ∎
looper≡looper2 (negsuc (suc n)) =
       looper (negsuc n) ∙ sym loop*                                                    ≡⟨ ((λ i → looper≡looper2 (negsuc n) i ∙ symDistr (merid south) (sym (merid north)) i)) ⟩
       looper2 (negsuc n) ∙ merid north ∙ sym (merid south)                             ≡⟨ cong (λ x → looper2 (negsuc n) ∙ x) (sym (congFunct SuspBool→S1 (merid true) (sym (merid false)))) ⟩
       looper2 (negsuc n) ∙ cong SuspBool→S1 (ϕ false true)                            ≡⟨ cong (λ x → looper2 (negsuc n) ∙ x) (cong thrdcomp (sym (symDistr (merid false) (sym (merid true))))) ⟩
       looper2 (negsuc n) ∙ cong SuspBool→S1 (sym (ϕ true false))                      ≡⟨ sym (congFunct SuspBool→S1 (sndcomp (intLoop (negsuc n))) (sym (ϕ true false))) ⟩
       thrdcomp (cong S¹→SuspBool (intLoop (negsuc n)) ∙ cong S¹→SuspBool (sym loop)) ≡⟨ cong thrdcomp (sym (congFunct S¹→SuspBool (intLoop (negsuc n)) (sym loop))) ⟩
       looper2 (negsuc (suc n)) ∎

private
  isolooper2 : Iso Int (Path (S₊ 1) north north)
  isolooper2 = compIso (invIso ΩS¹IsoInt) (compIso iso2 iso1)
    where
    iso1 : Iso (Path (Susp Bool) north north) (Path (S₊ 1) north north)
    iso1 = congIso SuspBoolIsoS1

    iso2 : Iso ΩS¹ (Path (Susp Bool) north north)
    iso2 = congIso S¹IsoSuspBool

  isolooper : Iso Int (Path (S₊ 1) north north)
  Iso.fun isolooper = looper
  Iso.inv isolooper = Iso.inv isolooper2
  Iso.rightInv isolooper a = (looper≡looper2 (Iso.inv isolooper2 a)) ∙ Iso.rightInv isolooper2 a
  Iso.leftInv isolooper a = cong (Iso.inv isolooper2) (looper≡looper2 a) ∙ Iso.leftInv isolooper2 a

  {- We want to show that this map is an equivalence. n ≥ 2 follows from Freudenthal, and  -}

  {-
  We want to show that the function (looper : Int → S₊ 1) defined by λ k → loopᵏ is an equivalece. We already know that the corresponding function (intLoop : Int → S¹ is) an equivalence,
  so the idea is to show that when intLoop is transported along a suitable path S₊ 1 ≡ S¹ we get looper. Instead of using S₊ 1 straight away, we begin by showing this for the equivalent Susp Bool.
  -}

  ----------------------------------- n = 1 -----------------------------------------------------

  {- We begin by stating some useful lemmas -}

  S³≡SuspSuspS¹ : S³ ≡ Susp (Susp S¹)
  S³≡SuspSuspS¹ = S³≡SuspS² ∙ λ i → Susp (S²≡SuspS¹ i)

  S3≡SuspSuspS¹ : S₊ 3 ≡ Susp (Susp S¹)
  S3≡SuspSuspS¹ = (λ i → Susp (Susp (Susp (ua Bool≃Susp⊥ (~ i))))) ∙ λ i → Susp (Susp (S¹≡SuspBool (~ i)))

  sphereConnectedSpecCase : isConnected 4 (Susp (Susp S¹))
  sphereConnectedSpecCase = transport (λ i → isConnected 4 (S3≡SuspSuspS¹ i)) (sphereConnected 3)

  {- We give the following map and show that its truncation is an equivalence -}

  d-map : typ (Ω ((Susp S¹) , north)) → S¹
  d-map p = subst HopfSuspS¹ p base

  d-mapId : (r : S¹) → d-map (ϕ base r) ≡ r
  d-mapId r = substComposite HopfSuspS¹ (merid r) (sym (merid base)) base ∙
              rotLemma r
    where
    rotLemma : (r : S¹) → rot r base ≡ r
    rotLemma base = refl
    rotLemma (loop i) = refl

  d-mapComp : fiber d-map base ≡ Path (Susp (Susp S¹)) north north
  d-mapComp = ΣPathTransport≡PathΣ {B = HopfSuspS¹} _ _ ∙ helper
    where
    helper : Path (Σ (Susp S¹) λ x → HopfSuspS¹ x) (north , base) (north , base) ≡ Path (Susp (Susp S¹)) north north
    helper = (λ i → (Path (S³≡TotalHopf (~ i))
                          (transp (λ j → S³≡TotalHopf (~ i ∨ ~ j)) (~ i) (north , base))
                          ((transp (λ j → S³≡TotalHopf (~ i ∨ ~ j)) (~ i) (north , base))))) ∙
             (λ i → Path (S³≡SuspSuspS¹ i) (transp (λ j → S³≡SuspSuspS¹ (i ∧ j)) (~ i) base) ((transp (λ j → S³≡SuspSuspS¹ (i ∧ j)) (~ i) base)))

  is1Connected-dmap : isConnectedFun 3 d-map
  is1Connected-dmap = toPropElim (λ s → isPropIsOfHLevel 0) (transport (λ j → isContr (∥ d-mapComp (~ j) ∥ 3))
                                      (transport (λ i →  isContr (PathΩ {A = Susp (Susp S¹)} {a = north} 3 i))
                                                 (refl , isOfHLevelSuc 1 (isOfHLevelSuc 0 sphereConnectedSpecCase) ∣ north ∣ ∣ north ∣ (λ _ → ∣ north ∣))))

  d-iso2 : Iso (hLevelTrunc 3 (typ (Ω (Susp S¹ , north)))) (hLevelTrunc 3 S¹)
  d-iso2 = connectedTruncIso _ d-map is1Connected-dmap

  {- We show that composing (λ a → ∣ ϕ base a ∣) and (λ x → ∣ d-map x ∣) gives us the identity function.  -}

  d-mapId2 : Iso.fun d-iso2 ∘ trMap (ϕ base) ≡ idfun (hLevelTrunc 3 S¹)
  d-mapId2 = funExt (trElim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) (λ a → cong ∣_∣ (d-mapId a)))

  {- This means that (λ a → ∣ ϕ base a ∣) is an equivalence -}

  Iso∣ϕ-base∣ : Iso (hLevelTrunc 3 S¹) (hLevelTrunc 3 (typ (Ω (Susp S¹ , north))))
  Iso∣ϕ-base∣ = composesToId→Iso d-iso2 (trMap (ϕ base)) d-mapId2

  ---------------------------------
  -- We cheat when n = 1 and use J to prove the following lemmma.  There is an obvious dependent path between ϕ base and ϕ north. Since the first one is an iso, so is the other.
  -- So far this hasn't been an issue.

  pointFunIso : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ} {C : (A : Type ℓ) (a1 : A) → Type ℓ'} (p : A ≡ B) (a : A) (b : B) →
              (transport p a ≡ b) →
              (f : (A : Type ℓ) →
              (a1 : A) (a2 : hLevelTrunc 3 A)  → C A a1) →
              isIso (f A a) →
              isIso (f B b)
  pointFunIso {ℓ = ℓ}{A = A} {B = B} {C = C} =
           J (λ B p → (a : A) (b : B) →
                        (transport p a ≡ b) →
                        (f : (A : Type ℓ) →
                        (a1 : A) (a2 : hLevelTrunc 3 A)  → C A a1) →
                        isIso (f A a) →
                        isIso (f B b))
             λ a b trefl f is → transport (λ i → isIso (f A ((sym (transportRefl a) ∙ trefl) i))) is

  {- By pointFunIso, this gives that λ a → ∣ ϕ north a ∣ is an iso -}

  isIso∣ϕ∣ : isIso {A = hLevelTrunc 3 (S₊ 1)} {B = hLevelTrunc 3 (typ (Ω (S₊ 2 , north)))} (trMap (ϕ north))
  isIso∣ϕ∣ = pointFunIso {A = S¹} (λ i → S¹≡S1 (~ i)) base north refl (λ A a1 → trMap (ϕ a1)) ((Iso.inv Iso∣ϕ-base∣) , ((Iso.rightInv Iso∣ϕ-base∣) , (Iso.leftInv Iso∣ϕ-base∣)))

  Iso∣ϕ∣ : Iso (hLevelTrunc 3 (S₊ 1)) (hLevelTrunc 3 (typ (Ω (S₊ 2 , north))))
  Iso.fun Iso∣ϕ∣ = trMap (ϕ north)
  Iso.inv Iso∣ϕ∣ = isIso∣ϕ∣ .fst
  Iso.rightInv Iso∣ϕ∣ = isIso∣ϕ∣ .snd .fst
  Iso.leftInv Iso∣ϕ∣ = isIso∣ϕ∣ .snd .snd

---------------------------------------------------- Finishing up ---------------------------------

-- We need ΩTrunc. It appears to compute better when restated for this particular case --

decode-fun2 : (n : HLevel) → (x : A) → hLevelTrunc n (x ≡ x) → Path (hLevelTrunc (suc n) A) ∣ x ∣ ∣ x ∣
decode-fun2 zero x = trElim (λ _ → isOfHLevelPath 0 (∣ x ∣ , isOfHLevelTrunc 1 ∣ x ∣) ∣ x ∣ ∣ x ∣) (λ p i → ∣ p i ∣)
decode-fun2 (suc n) x = trElim (λ _ → isOfHLevelPath' (suc n) (isOfHLevelTrunc (suc (suc n))) ∣ x ∣ ∣ x ∣) (cong ∣_∣)

funsAreSame : (n : HLevel) (x : A) (b : hLevelTrunc n (x ≡ x)) → (decode-fun2 n x b) ≡ (ΩTrunc.decode-fun ∣ x ∣ ∣ x ∣ b)
funsAreSame zero x = trElim (λ a → isOfHLevelPath 0 (refl , (isOfHLevelSuc 1 (isOfHLevelTrunc 1) ∣ x ∣ ∣ x ∣ refl)) _ _) λ a → refl
funsAreSame (suc n) x = trElim (λ a → isOfHLevelPath _ (isOfHLevelPath' (suc n) (isOfHLevelTrunc (suc (suc n))) ∣ x ∣ ∣ x ∣) _ _) λ a → refl

decodeIso : (n : HLevel) (x : A) → Iso (hLevelTrunc n (x ≡ x)) (Path (hLevelTrunc (suc n) A) ∣ x ∣ ∣ x ∣)
Iso.fun (decodeIso n x) = decode-fun2 n x
Iso.inv (decodeIso n x) = ΩTrunc.encode-fun ∣ x ∣ ∣ x ∣
Iso.rightInv (decodeIso n x) b = funsAreSame n x (ΩTrunc.encode-fun ∣ x ∣ ∣ x ∣ b) ∙ ΩTrunc.P-rinv ∣ x ∣ ∣ x ∣ b
Iso.leftInv (decodeIso n x) b = cong (ΩTrunc.encode-fun ∣ x ∣ ∣ x ∣) (funsAreSame n x b) ∙ ΩTrunc.P-linv ∣ x ∣ ∣ x ∣ b

Iso-Kn-ΩKn+1 : (n : HLevel) → Iso (coHomK n) (typ (Ω (coHomK-ptd (suc n))))
Iso-Kn-ΩKn+1 zero = compIso isolooper (congIso (truncIdempotentIso _ isOfHLevelS1))
Iso-Kn-ΩKn+1 (suc zero) = compIso Iso∣ϕ∣ (decodeIso _ north)
Iso-Kn-ΩKn+1 (suc (suc n)) = compIso (connectedTruncIso2 (4 + n) _ (ϕ north) (n , helper)
                                                                             (isConnectedσ (suc n) (sphereConnected _)))
                                     (decodeIso _ north)
  where
  helper : n + (4 + n) ≡ 2 + (n + (2 + n))
  helper = +-suc n (3 + n) ∙ (λ i → suc (+-suc n (2 + n) i))

mapId2 : (n : ℕ) →  Kn→ΩKn+1 n ≡ Iso.fun (Iso-Kn-ΩKn+1 n)
mapId2 zero = refl
mapId2 (suc zero) = funExt (trElim (λ x → isOfHLevelPath 3 (isOfHLevelTrunc 4 ∣ north ∣ ∣ north ∣) _ _) λ a → refl)
mapId2 (suc (suc n)) = funExt (trElim (λ x → isOfHLevelPath (4 + n) (isOfHLevelTrunc (5 + n) ∣ north ∣ ∣ north ∣) _ _) λ a → refl)

-- Experiments with abstract definitions

Iso2-Kn-ΩKn+1 : (n : ℕ) → Iso (coHomK n) (typ (Ω (coHomK-ptd (suc n))))
Iso.fun (Iso2-Kn-ΩKn+1 n) = Kn→ΩKn+1 n
Iso.inv (Iso2-Kn-ΩKn+1 n) = Iso.inv (Iso-Kn-ΩKn+1 n)
Iso.rightInv (Iso2-Kn-ΩKn+1 n) a = rinv
  where
  abstract
    rinv : Kn→ΩKn+1 n (Iso.inv (Iso-Kn-ΩKn+1 n) a) ≡ a
    rinv = funExt⁻ (mapId2 n) _ ∙ Iso.rightInv (Iso-Kn-ΩKn+1 n) a
Iso.leftInv (Iso2-Kn-ΩKn+1 n) a = linv
  where
  abstract
    linv : Iso.inv (Iso-Kn-ΩKn+1 n) (Kn→ΩKn+1 n a) ≡ a
    linv = cong (Iso.inv (Iso-Kn-ΩKn+1 n)) (funExt⁻ (mapId2 n) a) ∙ Iso.leftInv (Iso-Kn-ΩKn+1 n) a

--- even more abstract

abstract
  absInv' : (n : ℕ) → typ (Ω (coHomK-ptd (2 + n))) → coHomK (1 + n)
  absInv' n = Iso.inv (Iso-Kn-ΩKn+1 (1 + n))

  absSect' : (n : ℕ) (a : typ (Ω (coHomK-ptd (2 + n)))) → Kn→ΩKn+1 (1 + n) (absInv' n a) ≡ a
  absSect' n a = funExt⁻ (mapId2 (1 + n)) _ ∙ Iso.rightInv (Iso-Kn-ΩKn+1 (1 + n)) a

  absRetr' : (n : ℕ) (a : coHomK (1 + n)) → absInv' n (Kn→ΩKn+1 (1 + n) a) ≡ a
  absRetr' n a = cong (Iso.inv (Iso-Kn-ΩKn+1 (1 + n))) (funExt⁻ (mapId2 (1 + n)) a) ∙ Iso.leftInv (Iso-Kn-ΩKn+1 (1 + n)) a

absInv : (n : ℕ) → typ (Ω (coHomK-ptd (1 + n))) → coHomK n
absInv zero = Iso.inv (Iso-Kn-ΩKn+1 zero)
absInv (suc n) = absInv' n

absSect : (n : ℕ) → section (Kn→ΩKn+1 n) (absInv n)
absSect zero a = funExt⁻ (mapId2 zero) (Iso.inv isolooper2 (Iso.inv (congIso (truncIdempotentIso _ isOfHLevelS1)) a)) ∙ Iso.rightInv (Iso-Kn-ΩKn+1 zero) a
absSect (suc n) = absSect' n

absRetr : (n : ℕ) → retract (Kn→ΩKn+1 n) (absInv n)
absRetr zero a = cong (Iso.inv (Iso-Kn-ΩKn+1 zero)) (funExt⁻ (mapId2 zero) a) ∙ Iso.leftInv (Iso-Kn-ΩKn+1 zero) a
absRetr (suc n) = absRetr' n

Iso3-Kn-ΩKn+1 : (n : ℕ) → Iso (coHomK n) (typ (Ω (coHomK-ptd (suc n))))
Iso.fun (Iso3-Kn-ΩKn+1 n) = Kn→ΩKn+1 n
Iso.inv (Iso3-Kn-ΩKn+1 n) = absInv n
Iso.rightInv (Iso3-Kn-ΩKn+1 n) = absSect n
Iso.leftInv (Iso3-Kn-ΩKn+1 n) = absRetr n