import      Lvl
open import Type

module Structure.Logic.Constructive.NaturalDeduction {ℓₗ} {Formula : Type{ℓₗ}} {ℓₘₗ} (Proof : Formula → Type{ℓₘₗ}) where

open import Functional

module Propositional where
  -- Rules of bottom
  record Bottom(⊥ : Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
    field
      elim  : ∀{X} → Proof(⊥) → Proof(X)

  -- Rules of top
  record Top(⊤ : Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
    field
      intro : Proof(⊤)

  -- Rules of conjunction
  record Conjunction(_∧_ : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
    field
      intro : ∀{X Y} → Proof(X) → Proof(Y) → Proof(X ∧ Y)
      elimₗ  : ∀{X Y} → Proof(X ∧ Y) → Proof(X)
      elimᵣ  : ∀{X Y} → Proof(X ∧ Y) → Proof(Y)

    redundancyₗ : ∀{X} → Proof(X ∧ X) ← Proof(X)
    redundancyₗ x = intro x x

    redundancyᵣ : ∀{X} → Proof(X ∧ X) → Proof(X)
    redundancyᵣ = elimₗ

    transitivity : ∀{X Y Z} → Proof(X ∧ Y) → Proof(Y ∧ Z) → Proof(X ∧ Z)
    transitivity xy yz = intro(elimₗ xy) (elimᵣ yz)

    commutativity : ∀{X Y} → Proof(X ∧ Y) → Proof(Y ∧ X)
    commutativity xy = intro(elimᵣ xy) (elimₗ xy)

    associativityₗ : ∀{X Y Z} → Proof((X ∧ Y) ∧ Z) ← Proof(X ∧ (Y ∧ Z))
    associativityₗ xyz = intro (intro (elimₗ xyz) (elimₗ(elimᵣ xyz))) (elimᵣ(elimᵣ xyz))

    associativityᵣ : ∀{X Y Z} → Proof((X ∧ Y) ∧ Z) → Proof(X ∧ (Y ∧ Z))
    associativityᵣ xyz = intro (elimₗ(elimₗ xyz)) (intro (elimᵣ(elimₗ xyz)) (elimᵣ xyz))

  -- Rules of implication
  record Implication(_⟶_ : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
    field
      intro : ∀{X Y} → (Proof(X) → Proof(Y)) → Proof(X ⟶ Y)
      elim  : ∀{X Y} → Proof(X ⟶ Y) → Proof(X) → Proof(Y)

    reflexivity : ∀{X} → Proof(X ⟶ X)
    reflexivity = intro id

    transitivity : ∀{X Y Z} → Proof(X ⟶ Y) → Proof(Y ⟶ Z) → Proof(X ⟶ Z)
    transitivity xy yz = intro((elim yz) ∘ (elim xy))

  -- Rules of reversed implication
  record Consequence(_⟵_ : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
    field
      intro : ∀{X Y} → (Proof(X) → Proof(Y)) → Proof(Y ⟵ X)
      elim  : ∀{X Y} → Proof(Y ⟵ X) → Proof(X) → Proof(Y)

    reflexivity : ∀{X} → Proof(X ⟵ X)
    reflexivity = intro id

    transitivity : ∀{X Y Z} → Proof(X ⟵ Y) → Proof(Y ⟵ Z) → Proof(X ⟵ Z)
    transitivity xy yz = intro((elim xy) ∘ (elim yz))

  -- Rules of equivalence
  record Equivalence(_⟷_ : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
    field
      intro : ∀{X Y} → (Proof(X) ← Proof(Y)) → (Proof(X) → Proof(Y)) → Proof(X ⟷ Y)
      elimₗ  : ∀{X Y} → Proof(X ⟷ Y) → Proof(Y) → Proof(X)
      elimᵣ  : ∀{X Y} → Proof(X ⟷ Y) → Proof(X) → Proof(Y)

    reflexivity : ∀{X} → Proof(X ⟷ X)
    reflexivity = intro id id

    commutativity : ∀{X Y} → Proof(X ⟷ Y) → Proof(Y ⟷ X)
    commutativity xy = intro(elimᵣ xy) (elimₗ xy)

    transitivity : ∀{X Y Z} → Proof(X ⟷ Y) → Proof(Y ⟷ Z) → Proof(X ⟷ Z)
    transitivity xy yz = intro ((elimₗ xy) ∘ (elimₗ yz)) ((elimᵣ yz) ∘ (elimᵣ xy))

  -- Rules of disjunction
  record Disjunction(_∨_  : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
    field
      introₗ : ∀{X Y} → Proof(X) → Proof(X ∨ Y)
      introᵣ : ∀{X Y} → Proof(Y) → Proof(X ∨ Y)
      elim  : ∀{X Y Z} → (Proof(X) → Proof(Z)) → (Proof(Y) → Proof(Z)) → Proof(X ∨ Y) → Proof(Z)

    redundancyₗ : ∀{X} → Proof(X ∨ X) ← Proof(X)
    redundancyₗ = introₗ

    redundancyᵣ : ∀{X} → Proof(X ∨ X) → Proof(X)
    redundancyᵣ = elim id id

    commutativity : ∀{X Y} → Proof(X ∨ Y) → Proof(Y ∨ X)
    commutativity = elim(introᵣ)(introₗ)

    associativityₗ : ∀{X Y Z} → Proof((X ∨ Y) ∨ Z) ← Proof(X ∨ (Y ∨ Z))
    associativityₗ = elim(introₗ ∘ introₗ) (elim (introₗ ∘ introᵣ) (introᵣ))

    associativityᵣ : ∀{X Y Z} → Proof((X ∨ Y) ∨ Z) → Proof(X ∨ (Y ∨ Z))
    associativityᵣ = elim(elim (introₗ) (introᵣ ∘ introₗ)) (introᵣ ∘ introᵣ)

  -- Rules of negation
  record Negation(¬_ : Formula → Formula) {⊥} ⦃ _ : Bottom(⊥) ⦄ : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
    open Bottom ⦃ ... ⦄
    field
      intro : ∀{X} → (Proof(X) → Proof(⊥)) → Proof(¬ X)
      elim  : ∀{X} → Proof(¬ X) → Proof(X) → Proof(⊥)

  record Signature : Type{ℓₗ} where
    infixl 1005 _∧_
    infixl 1000 _⟶_
    infixl 1000 _⟵_
    infixl 1000 _⟷_
    infixl 1004 _∨_
    infixl 1010 ¬_

    field
      ⊥    : Formula
      ⊤    : Formula
      _∧_  : Formula → Formula → Formula
      _⟶_ : Formula → Formula → Formula
      _⟷_ : Formula → Formula → Formula
      _∨_  : Formula → Formula → Formula
      ¬_   : Formula → Formula

    _⟵_ : Formula → Formula → Formula
    _⟵_ = swap _⟶_

  -- A theory of constructive propositional logic expressed using natural deduction rules
  record Theory ⦃ sign : Signature ⦄ : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
    open Signature(sign)

    field
      instance ⦃ bottom ⦄      : Bottom(⊥)
      instance ⦃ top ⦄         : Top(⊤)
      instance ⦃ conjunction ⦄ : Conjunction(_∧_)
      instance ⦃ disjunction ⦄ : Disjunction(_∨_)
      instance ⦃ implication ⦄ : Implication(_⟶_)
      instance ⦃ consequence ⦄ : Consequence(_⟵_)
      instance ⦃ equivalence ⦄ : Equivalence(_⟷_)
      instance ⦃ negation ⦄    : Negation(¬_) ⦃ bottom ⦄

    module [⊥] = Bottom      (bottom)
    module [⊤] = Top         (top)
    module [∧] = Conjunction (conjunction)
    module [∨] = Disjunction (disjunction)
    module [→] = Implication (implication)
    module [←] = Consequence (consequence)
    module [↔] = Equivalence (equivalence)
    module [¬] = Negation    (negation)

module Domained {ℓₒ} (Domain : Type{ℓₒ}) where
  module Predicate where
    record UniversalQuantification(∀ₗ : (Domain → Formula) → Formula) : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
      field
        intro : ∀{P : Domain → Formula} → (∀{x : Domain} → Proof(P(x))) → Proof(∀ₗ P)
        elim  : ∀{P : Domain → Formula} → Proof(∀ₗ P) → (∀{x : Domain} → Proof(P(x)))

    record ExistentialQuantification(∃ₗ : (Domain → Formula) → Formula) : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
      field
        intro : ∀{P : Domain → Formula}{a} → Proof(P(a)) → Proof(∃ₗ P)
        elim  : ∀{P : Domain → Formula}{Z : Formula} → (∀{x : Domain} → Proof(P(x)) → Proof(Z)) → Proof(∃ₗ P) → Proof(Z)

    -- These allows the creation of new symbols which points to something which exists and is unique.
    -- TODO: Does this make this theory have no models? For functions, the functions in the meta-theory here (Agda-functions) represent computable things, and all unique existances are not computable. Normally in set theory, one could interpret every (f(x) = y)-formula as ((x,y) ∈ f), so normally it probably works out in the end of the day?
    record ExistentialWitness(∃ₗ : (Domain → Formula) → Formula) : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
      field
        [∃]-witness : ∀{P : Domain → Formula} → ⦃ _ : Proof(∃ₗ P) ⦄ → Domain
        [∃]-proof   : ∀{P : Domain → Formula} → ⦃ p : Proof(∃ₗ P) ⦄ → Proof(P([∃]-witness{P} ⦃ p ⦄))

    record Signature : Type{ℓₗ Lvl.⊔ ℓₒ} where
      field
        ∀ₗ : (Domain → Formula) → Formula
        ∃ₗ : (Domain → Formula) → Formula

      NonEmptyDomain = ∀{P} → Proof(P) → Proof(∃ₗ(const P))

    -- A theory of constructive predicate/(first-order) logic expressed using natural deduction rules
    record Theory ⦃ sign : Signature ⦄ : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
      open Signature(sign)

      field
        instance ⦃ universalQuantification ⦄   : UniversalQuantification(∀ₗ)
        instance ⦃ existentialQuantification ⦄ : ExistentialQuantification(∃ₗ)

      module [∀] = UniversalQuantification   (universalQuantification)
      module [∃] = ExistentialQuantification (existentialQuantification)

      module NonEmptyDomain ⦃ nonEmptyDomain : NonEmptyDomain ⦄ where
        [∀]-redundancyₗ : ∀{φ} → Proof(∀ₗ(const φ)) ← Proof(φ)
        [∀]-redundancyₗ (proof) = [∀].intro(\{_} → proof)

        [∀]-redundancyᵣ : ∀{φ} → Proof(∀ₗ(const φ)) → Proof(φ)
        [∀]-redundancyᵣ (proof) = [∃].elim(\{x} → _ ↦ [∀].elim(proof){x}) (nonEmptyDomain proof)

        [∃]-redundancyₗ : ∀{φ} → Proof(∃ₗ(const φ)) ← Proof(φ)
        [∃]-redundancyₗ (proof) = [∃].elim(\{x} → _ ↦ [∃].intro{_}{x}(proof)) (nonEmptyDomain proof)

        [∃]-redundancyᵣ : ∀{φ} → Proof(∃ₗ(const φ)) → Proof(φ)
        [∃]-redundancyᵣ = [∃].elim(\{_} → id)

  module Equality where
    -- Rules of equality
    record Equality(_≡_ : Domain → Domain → Formula) : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
      field
        intro : ∀{x} → Proof(x ≡ x)
        elimᵣ  : ∀{P : Domain → Formula}{a b} → Proof(a ≡ b) → Proof(P(a)) → Proof(P(b))

      symmetry : ∀{a b} → Proof(a ≡ b) → Proof(b ≡ a)
      symmetry{a} (proof) = elimᵣ{x ↦ x ≡ a} (proof) (intro{a})

      elimₗ : ∀{P : Domain → Formula}{a b} → Proof(a ≡ b) → Proof(P(a)) ← Proof(P(b))
      elimₗ (proof) (pb) = elimᵣ (symmetry proof) (pb)

      transitivity : ∀{a b c} → Proof(a ≡ b) → Proof(b ≡ c) → Proof(a ≡ c)
      transitivity (ab) (bc) = elimᵣ bc ab

    record Signature : Type{ℓₗ Lvl.⊔ ℓₒ} where
      infixl 2000 _≡_
      field
        _≡_ : Domain → Domain → Formula

    module PropositionallyDerivedSignature ⦃ propositional : Propositional.Signature ⦄ ⦃ sign : Signature ⦄ where
      open Propositional.Signature(propositional)
      open Signature(sign)

      _≢_ : Domain → Domain → Formula
      _≢_ a b = ¬(_≡_ a b)

    record Theory ⦃ sign : Signature ⦄ : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
      open Signature(sign)

      field
        instance ⦃ equality ⦄ : Equality(_≡_)

      module [≡] = Equality(equality)

  module Uniqueness ⦃ propositionalSign : Propositional.Signature ⦄ ⦃ predicateSign : Predicate.Signature ⦄ ⦃ equalitySign : Equality.Signature ⦄ where
    open Propositional.Signature(propositionalSign)
    open Predicate.Signature(predicateSign)
    open Equality.Signature(equalitySign)

    module Signature where
      -- Definition of uniqueness of a property.
      -- This means that there is at most one element that satisfies this property.
      -- This is similiar to "Injective" for functions, but this is for statements.
      Unique : (Domain → Formula) → Formula
      Unique(P) = ∀ₗ(x ↦ ∀ₗ(y ↦ (P(x) ∧ P(y)) ⟶ (x ≡ y)))

      -- Definition of existence of an unique element satisfying a property.
      -- This means that there is one and only one element that satisfies this property.
      ∃ₗ! : (Domain → Formula) → Formula
      ∃ₗ! P = ((∃ₗ P) ∧ Unique(P))

    module _ ⦃ propositional : Propositional.Theory ⦄ ⦃ predicate : Predicate.Theory ⦄ ⦃ equality : Equality.Theory ⦄ where
      open Signature
      open Propositional.Theory(propositional)
      open Predicate.Theory(predicate)
      open Equality.Theory(equality)

      module WitnessTheory ⦃ existentialWitness : Predicate.ExistentialWitness(∃ₗ) ⦄ where
        open Predicate.ExistentialWitness(existentialWitness)

        [∃!]-witness : ∀{P : Domain → Formula} → ⦃ _ : Proof(∃ₗ! P) ⦄ → Domain
        [∃!]-witness{P} ⦃ proof ⦄ = [∃]-witness{P} ⦃ [∧].elimₗ proof ⦄

        [∃!]-proof : ∀{P : Domain → Formula} → ⦃ p : Proof(∃ₗ! P) ⦄ → Proof(P([∃!]-witness{P} ⦃ p ⦄))
        [∃!]-proof{P} ⦃ proof ⦄ = [∃]-proof{P} ⦃ [∧].elimₗ proof ⦄

        [∃!]-unique : ∀{P : Domain → Formula} → ⦃ p : Proof(∃ₗ! P) ⦄ → Proof(∀ₗ(x ↦ P(x) ⟶ (x ≡ [∃!]-witness{P} ⦃ p ⦄)))
        [∃!]-unique{P} ⦃ proof ⦄ =
          ([∀].intro(\{x} →
            ([→].intro(px ↦
              ([→].elim
                ([∀].elim([∀].elim([∧].elimᵣ proof) {x}) {[∃!]-witness{P} ⦃ proof ⦄})
                ([∧].intro
                  (px)
                  ([∃!]-proof{P} ⦃ proof ⦄)
                )
              )
            ))
          ))

module _ {ℓₒ} (Domain : Type{ℓₒ}) where
  record ConstructiveLogicSignature : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
    open Domained(Domain)

    field
      instance ⦃ propositionalSignature ⦄ : Propositional.Signature
      instance ⦃ predicateSignature ⦄     : Predicate.Signature
      instance ⦃ equalitySignature ⦄      : Equality.Signature
    open Propositional.Signature(propositionalSignature) public
    open Predicate.Signature(predicateSignature) public
    open Equality.Signature(equalitySignature) public
    open Equality.PropositionallyDerivedSignature ⦃ propositionalSignature ⦄ ⦃ equalitySignature ⦄ public
    open Uniqueness.Signature ⦃ propositionalSignature ⦄ ⦃ predicateSignature ⦄ ⦃ equalitySignature ⦄ public

  record ConstructiveLogic : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
    open Domained(Domain)

    field
      instance ⦃ constructiveLogicSignature ⦄ : ConstructiveLogicSignature
    open ConstructiveLogicSignature public

    field
      instance ⦃ propositionalTheory ⦄ : Propositional.Theory
      instance ⦃ predicateTheory ⦄     : Predicate.Theory
      instance ⦃ equalityTheory ⦄      : Equality.Theory
    open Propositional.Theory(propositionalTheory) public
    open Predicate.Theory(predicateTheory) public
    open Equality.Theory(equalityTheory) public

module MultiSorted {ℓₒ} {Sorts : Type{ℓₒ}} (Domain : Sorts → Type{ℓₒ}) where
  module Predicate where
    record UniversalQuantification(∀ₗ : ∀{Sort} → (Domain(Sort) → Formula) → Formula) : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
      field
        intro : ∀{Sort}{P : Domain(Sort) → Formula} → (∀{x : Domain(Sort)} → Proof(P(x))) → Proof(∀ₗ P)
        elim  : ∀{Sort}{P : Domain(Sort) → Formula} → Proof(∀ₗ P) → (∀{x : Domain(Sort)} → Proof(P(x)))

    record ExistentialQuantification(∃ₗ : ∀{Sort} → (Domain(Sort) → Formula) → Formula) : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
      field
        intro : ∀{Sort}{P : Domain(Sort) → Formula}{a} → Proof(P(a)) → Proof(∃ₗ P)
        elim  : ∀{Sort}{P : Domain(Sort) → Formula}{Z : Formula} → (∀{x : Domain(Sort)} → Proof(P(x)) → Proof(Z)) → Proof(∃ₗ P) → Proof(Z)

    record Signature : Type{ℓₗ Lvl.⊔ ℓₒ} where
      field
        ∀ₗ : ∀{Sort} → (Domain(Sort) → Formula) → Formula
        ∃ₗ : ∀{Sort} → (Domain(Sort) → Formula) → Formula

    -- A theory of constructive predicate/(first-order) multi-sorted logic expressed using natural deduction rules
    record Theory ⦃ sign : Signature ⦄ : Type{ℓₘₗ Lvl.⊔ (ℓₗ Lvl.⊔ ℓₒ)} where
      open Signature(sign)

      field
        instance ⦃ universalQuantification ⦄   : UniversalQuantification(∀ₗ)
        instance ⦃ existentialQuantification ⦄ : ExistentialQuantification(∃ₗ)

      module [∀] = UniversalQuantification   (universalQuantification)
      module [∃] = ExistentialQuantification (existentialQuantification)


module GetTypes where

open import Level using () renaming (zero to ℓ₀)
open import Data.Nat using (ℕ)
open import Data.List using (List ; map)
open import Data.Vec using (Vec) renaming (map to mapV)
open import Function using (_∘_ ; id)
open import Relation.Binary.PropositionalEquality using (_≗_)

open import Structures using (Shaped ; module Shaped)
open import Instances using (VecShaped)

module ListList where
  record Get : Set₁ where
    field
      get : {A : Set} → List A → List A
      free-theorem : {α β : Set} → (f : α → β) → get ∘ map f ≗ map f ∘ get

module VecVec where
  record Get : Set₁ where
    field
      getlen : ℕ → ℕ
      get : {A : Set} {n : ℕ} → Vec A n → Vec A (getlen n)
      free-theorem : {α β : Set} (f : α → β) {n : ℕ} → get {_} {n} ∘ mapV f ≗ mapV f ∘ get

module PartialVecVec where
  record Get : Set₁ where
    field
      I : Set
      gl₁ : I → ℕ
      gl₂ : I → ℕ
      get : {A : Set} {i : I} → Vec A (gl₁ i) → Vec A (gl₂ i)
      free-theorem : {α β : Set} → (f : α → β) → {i : I} → get {_} {i} ∘ mapV f ≗ mapV f ∘ get

VecVec-to-PartialVecVec : VecVec.Get → PartialVecVec.Get
VecVec-to-PartialVecVec G = record
  { I = ℕ
  ; gl₁ = id
  ; gl₂ = getlen
  ; get = get
  ; free-theorem = free-theorem
  } where open VecVec.Get G

module PartialShapeShape where
  record Get : Set₁ where
    field
      SourceShape : Set
      SourceContainer : Set → SourceShape → Set
      SourceShapeT : Shaped SourceShape SourceContainer

      ViewShape : Set
      ViewContainer : Set → ViewShape → Set
      ViewShapeT : Shaped ViewShape ViewContainer

      I : Set
      gl₁ : I → SourceShape
      gl₂ : I → ViewShape

    open Shaped SourceShapeT using () renaming (fmap to fmapS)
    open Shaped ViewShapeT using () renaming (fmap to fmapV)

    field
      get : {A : Set} {i : I} → SourceContainer A (gl₁ i) → ViewContainer A (gl₂ i)
      free-theorem : {α β : Set} → (f : α → β) → {i : I} → get {_} {i} ∘ fmapS f ≗ fmapV f ∘ get

    open Shaped SourceShapeT public using () renaming (fmap to fmapS)
    open Shaped ViewShapeT public using () renaming (fmap to fmapV)

PartialVecVec-to-PartialShapeShape : PartialVecVec.Get → PartialShapeShape.Get
PartialVecVec-to-PartialShapeShape G = record
  { SourceShapeT = VecShaped
  ; ViewShapeT   = VecShaped
  ; I            = I
  ; gl₁          = gl₁
  ; gl₂          = gl₂
  ; get          = get
  ; free-theorem = free-theorem
  } where open PartialVecVec.Get G


module _ (A : Set) where

id : A → A
id x = x


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

module Issue228 where

postulate
  Level : Set
  zero : Level
  suc  : Level → Level
  ∞    : Level
  _⊔_  : Level → Level → Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}
{-# BUILTIN LEVELMAX  _⊔_   #-}

infixl 6 _⊔_

data _×_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  _,_ : A → B → A × B

data Large : Set ∞ where
  large : Large

data Small : Set₁ where
  small : Set → Small

P : Set
P = Large × Small

[_] : Set → P
[ A ] = (large , small A)

potentially-bad : P
potentially-bad = [ P ]


open import MJ.Types as Types
import MJ.Classtable.Core as Core

module MJ.Semantics.Objects {c}(Ct : Core.Classtable c) where

open import Prelude

open import Level renaming (suc to lsuc; zero to lzero)
open import Data.List
open import Data.List.Relation.Unary.All
open import Data.List.Prefix

open Core c
open Classtable Ct

open import MJ.Classtable.Membership Ct
open import MJ.Semantics.Values Ct
open import MJ.LexicalScope c

{-
Abstract interface for object encodings.
-}
record ObjEncoding : Set (lsuc lzero) where
  field
    Obj : World c → Cid c → Set
    weaken-obj : ∀ {W W'} cid → W' ⊒ W → Obj W cid → Obj W' cid
    getter : ∀ {W m a} c → Obj W c → IsMember c FIELD m a → Val W a
    setter : ∀ {W m a} c → Obj W c → IsMember c FIELD m a → Val W a → Obj W c
    defaultObject : ∀ {W} c → Obj W c

  data StoreVal (W : World c) : Ty⁺ c → Set where
    val : ∀ {ty} → Val W ty → StoreVal W (vty ty)
    obj : ∀ cid → Obj W cid → StoreVal W (obj cid)

  Store : World c → Set
  Store W = All (StoreVal W) W


-- Given p : A ⟷ B do action on X

act : (A ⟷ B) ⟷ (X ⟷ X)
act = ?


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

module Haskell.Modules.FunctorApplicativeMonad where

open import Haskell.Modules.Either
------------------------------------------------------------------------------
open import Data.List
open import Data.Maybe renaming (_>>=_ to _Maybe->>=_)
open import Function
open import Level renaming (suc to ℓ+1; zero to ℓ0; _⊔_ to _ℓ⊔_)

record Functor  {ℓ₁ ℓ₂ : Level} (F : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where
  infixl 4 _<$>_
  field
    _<$>_ : ∀ {A B : Set ℓ₁} → (A → B) → F A → F B
  fmap = _<$>_
open Functor ⦃ ... ⦄ public

record Applicative {ℓ₁ ℓ₂ : Level} (F : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where
  infixl 4 _<*>_
  field
    pure  : ∀ {A : Set ℓ₁} → A → F A
    _<*>_ : ∀ {A B : Set ℓ₁} → F (A → B) → F A → F B
open Applicative ⦃ ... ⦄ public
instance
  ApplicativeFunctor : ∀ {ℓ₁ ℓ₂} {F : Set ℓ₁ → Set ℓ₂} ⦃ _ : Applicative F ⦄ → Functor F
  Functor._<$>_ ApplicativeFunctor f xs = pure f <*> xs

record Monad {ℓ₁ ℓ₂ : Level} (M : Set ℓ₁ → Set ℓ₂) : Set (ℓ₂ ℓ⊔ ℓ+1 ℓ₁) where
  infixl 1 _>>=_ _>>_
  field
    return : ∀ {A : Set ℓ₁} → A → M A
    _>>=_  : ∀ {A B : Set ℓ₁} → M A → (A → M B) → M B

  _>>_ : ∀ {A B : Set ℓ₁} → M A → M B → M B
  m₁ >> m₂ = m₁ >>= λ _ → m₂
open Monad ⦃ ... ⦄ public
instance
  MonadApplicative : ∀ {ℓ₁ ℓ₂} {M : Set ℓ₁ → Set ℓ₂} ⦃ _ : Monad M ⦄ → Applicative M
  Applicative.pure  MonadApplicative       = return
  Applicative._<*>_ MonadApplicative fs xs = do
    f ← fs
    x ← xs
    return (f x)

instance
  Monad-Either : ∀ {ℓ}{C : Set ℓ} → Monad{ℓ}{ℓ} (Either C)
  Monad.return (Monad-Either{ℓ}{C}) = Right
  Monad._>>=_  (Monad-Either{ℓ}{C}) = either (const ∘ Left) _|>_

  Monad-Maybe : ∀ {ℓ} → Monad {ℓ} {ℓ} Maybe
  Monad.return (Monad-Maybe{ℓ}) = just
  Monad._>>=_  (Monad-Maybe{ℓ}) = _Maybe->>=_

  Monad-List : ∀ {ℓ} → Monad {ℓ}{ℓ} List
  Monad.return Monad-List x   = x ∷ []
  Monad._>>=_  Monad-List x f = concat (Data.List.map f x)


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

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

module Renamings where

-- SET OF RENAMINGS BETWEEN CONTEXTS

data Ren : Ctx → Ctx → Set where

  ⟨_,_⟩ : {Γ Γ' : Ctx} {X : VType} →
          Ren Γ Γ' →
          X ∈ Γ' →
          --------------------------
          Ren (Γ ∷ X) Γ'

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

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

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

-- RENAMING VARIABLES

ren-var : {Γ Γ' : Ctx} {X : VType} →
          Ren Γ Γ' →
          X ∈ Γ →
          --------------------------
          X ∈ Γ'

ren-var ⟨ f , x ⟩ Hd =
  x
ren-var (π f) Hd =
  Tl-v (ren-var f Hd)
ren-var ⟨ f , y ⟩ (Tl-v x) =
  ren-var f x
ren-var (π f) (Tl-v x) =
  Tl-v (ren-var f (Tl-v x))
ren-var (π f) (Tl-■ p x) =
  Tl-v (ren-var f (Tl-■ p x))
ren-var (φ f) (Tl-■ p x) =
  Tl-■ p (ren-var f x)

-- IDENTITY RENAMING

ren-id : {Γ : Ctx} →
         -----------
         Ren Γ Γ

ren-id {[]} =
  ε
ren-id {Γ ∷ X} =
  ⟨ π ren-id , Hd ⟩
ren-id {Γ ■} =
  φ ren-id

-- EXCHANGE RENAMING

ren-exch : {Γ : Ctx} {X Y : VType} →
           ---------------------------
           Ren (Γ ∷ X ∷ Y) (Γ ∷ Y ∷ X)

ren-exch {Γ} = ⟨ ⟨ π (π ren-id) , Hd ⟩ , Tl-v Hd ⟩

-- COMPOSITION OF RENAMINGS

ren-comp : {Γ Γ' Γ'' : Ctx} →
           Ren Γ' Γ'' →
           Ren Γ Γ' →
           ------------------
           Ren Γ Γ''

ren-comp g ⟨ f , x ⟩ =
  ⟨ ren-comp g f , ren-var g x ⟩
ren-comp g ε =
  ε
ren-comp ⟨ g , x ⟩ (π f) =
  ren-comp g f
ren-comp (π g) (π f) =
  π (ren-comp g (π f))
ren-comp (π g) (φ f) =
  π (ren-comp g (φ f))
ren-comp (φ g) (φ f) =
  φ (ren-comp g f)

-- WEAKENING OF RENAMINGS

ren-wk : {Γ : Ctx} {X : VType} →
         -----------------------
         Ren Γ (Γ ∷ X)

ren-wk =
  π ren-id

-- CONGRUENCE OF RENAMINGS

ren-cong : {Γ Γ' : Ctx} {X : VType} →
           Ren Γ Γ' →
           --------------------------
           Ren (Γ ∷ X) (Γ' ∷ X)

ren-cong f =
  ⟨ π f , Hd ⟩

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

mutual

  V-rename : {X : VType} {Γ Γ' : Ctx} →
             Ren Γ Γ' →
             Γ ⊢V⦂ X →
             --------------------------
             Γ' ⊢V⦂ X

  V-rename f (` x) =
    ` ren-var f x
  V-rename f (´ c) =
    ´ c
  V-rename f ⋆ =
    ⋆
  V-rename f (ƛ M) =
    ƛ (C-rename (ren-cong f) M)
  V-rename f ⟨ V ⟩ =
    ⟨ V-rename f V ⟩
  V-rename f (□ V) =
    □ (V-rename (φ f) V)

  C-rename : {C : CType} {Γ Γ' : Ctx} →
             Ren Γ Γ' →
             Γ ⊢C⦂ C →
             --------------------------
             Γ' ⊢C⦂ C

  C-rename f (return V) =
    return (V-rename f V)
  C-rename f (let= M `in N) =
    let= C-rename f M `in C-rename (ren-cong f) N
  C-rename f (V · W) =
    V-rename f V · V-rename f W
  C-rename f (↑ op p V M) =
    ↑ op p (V-rename f V) (C-rename f M)
  C-rename f (↓ op V M) =
    ↓ op (V-rename f V) (C-rename f M)
  C-rename f (promise op ∣ p ↦ M `in N) =
    promise op ∣ p ↦ C-rename (ren-cong (ren-cong f)) M `in C-rename (ren-cong f) N
  C-rename f (await V until M) =
    await (V-rename f V) until (C-rename (ren-cong f) M)
  C-rename f (unbox V `in M) =
    unbox (V-rename f V) `in (C-rename (ren-cong f) M)
  C-rename f (spawn M N) =
    spawn (C-rename (φ f) M) (C-rename f N)
  C-rename f (coerce p q M) =
    coerce p q (C-rename f M)

-- ACTION OF RENAMING ON WELL-TYPED PROCESSES

P-rename : {o : O} {PP : PType o} {Γ Γ' : Ctx} → Ren Γ Γ' → Γ ⊢P⦂ PP → Γ' ⊢P⦂ PP
P-rename f (run M) =
  run (C-rename f M)
P-rename f (P ∥ Q) =
  P-rename f P ∥ P-rename f Q
P-rename f (↑ op p V P) =
  ↑ op p (V-rename f V) (P-rename f P)
P-rename f (↓ op V P) =
  ↓ op (V-rename f V) (P-rename f P)


{-# OPTIONS --cubical --no-import-sorts --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.Groups.Wedge where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Properties
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Function
open import Cubical.Foundations.GroupoidLaws
open import Cubical.HITs.Wedge
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; rec2 to pRec2 ; elim to sElim ; elim2 to sElim2 ; map to sMap)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; ∣_∣ to ∣_∣₁)
open import Cubical.HITs.Truncation renaming (elim to trElim ; rec to trRec ; elim2 to trElim2)
open import Cubical.Data.Nat
open import Cubical.Algebra.Group

open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Sn

open import Cubical.HITs.Pushout
open import Cubical.Data.Sigma

open import Cubical.Foundations.Isomorphism
open import Cubical.Homotopy.Connected
open import Cubical.HITs.Susp
open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.Foundations.Equiv

open GroupIso renaming (map to map')
open GroupHom

{-
This module proves that Hⁿ(A ⋁ B) ≅ Hⁿ(A) × Hⁿ(B) for n ≥ 1 directly (rather than by means of Mayer-Vietoris).

Proof sketch:

Any ∣ f ∣₂ ∈ Hⁿ(A ⋁ B) is uniquely characterised by a pair of functions
  f₁ : A → Kₙ
  f₂ : B → Kₙ
together with a path
  p : f₁ (pt A) ≡ f₂ (pt B)

The map F : Hⁿ(A ⋁ B) → Hⁿ(A) × Hⁿ(B) simply forgets about p, i.e.:
  F(∣ f ∣₂) := (∣ f₁ ∣₂ , ∣ f₂ ∣₂)

The construction of its inverse is defined by
  F⁻(∣ f₁ ∣₂ , ∣ f₂ ∣₂) := ∣ f₁∨f₂ ∣₂
  where
  f₁∨f₂ : A ⋁ B → Kₙ is defined inductively by
  f₁∨f₂ (inl x) := f₁ x + f₂ (pt B)
  f₁∨f₂ (inr x) := f₂ x + f₁ (pt B)
  cong f₁∨f₂ (push tt) := "f₁ (pt A) + f₂ (pt B) =(commutativity) f₂ (pt B) + f₁ (pt A)"
  (this is the map wedgeFun⁻ below)
  Note that the cong-case above reduces to refl when f₁ (pt A) := f₂ (pt B) := 0

The fact that F and F⁻ cancel out is a proposition and we may thus assume for any
  ∣ f ∣₂ ∈ Hⁿ(A ⋁ B) and its corresponding f₁ that
  f₁ (pt A) = f₂ (pt B) = 0                (*)
  and
  f (inl (pt A)) = 0                       (**)

The fact that F(F⁻(∣ f₁ ∣₂ , ∣ f₂ ∣₂)) = ∣ f₁ ∣₂ , ∣ f₂ ∣₂) follows immediately from (*)

The other way is slightly trickier. We need to construct paths
  Pₗ : f (inl (x)) + f (inr (pt B)) ---> f (inl (x))
  Pᵣ  : f (inr (x)) + f (inl (pt A)) ---> f (inr (x))

Together with a filler of the following square

     cong f (push tt)
    ----------------->
   ^                  ^
   |                  |
   |                  |
Pₗ |                  | Pᵣ
   |                  |
   |                  |
   |                  |
    ----------------->
            Q
where Q is commutativity proof f (inl (pt A)) + f (inr (pt B)) = f (inr (pt B)) + f (inl (pt A))

The square is filled by first constructing Pₗ by
  f (inl (x)) + f (inr (pt B))    ---[cong f (push tt)⁻¹]--->
  f (inl (x)) + f (inl (pt A))    ---[(**)]--->
  f (inl (x)) + 0                 ---[right-unit]--->
  f (inl (x))

and then Pᵣ by
  f (inr (x)) + f (inl (pt A))    ---[(**)]--->
  f (inr (x)) + 0                 ---[right-unit]--->
  f (inr (x))

and finally by using the fact that the group laws for Kₙ are refl at its base point.
-}

module _ {ℓ ℓ'} (A : Pointed ℓ) (B : Pointed ℓ') where

  private
    wedgeFun⁻ : ∀ n → (f : typ A → coHomK (suc n)) (g : typ B → coHomK (suc n))
            → ((A ⋁ B) → coHomK (suc n))
    wedgeFun⁻ n f g (inl x) = f x +ₖ g (pt B)
    wedgeFun⁻ n f g (inr x) = g x +ₖ f (pt A)
    wedgeFun⁻ n f g (push a i) = commₖ (suc n) (f (pt A)) (g (pt B)) i

  Hⁿ-⋁ : (n : ℕ) → GroupIso (coHomGr (suc n) (A ⋁ B)) (×coHomGr (suc n) (typ A) (typ B))
  fun (map' (Hⁿ-⋁ zero)) =
    sElim (λ _ → isSet× setTruncIsSet setTruncIsSet)
           λ f → ∣ (λ x → f (inl x)) ∣₂ , ∣ (λ x → f (inr x)) ∣₂
  isHom (map' (Hⁿ-⋁ zero)) =
    sElim2 (λ _ _ → isOfHLevelPath 2 (isSet× setTruncIsSet setTruncIsSet) _ _)
            λ _ _ → refl
  inv (Hⁿ-⋁ zero) = uncurry (sElim2 (λ _ _ → setTruncIsSet)
                             λ f g → ∣ wedgeFun⁻ 0 f g ∣₂)
  rightInv (Hⁿ-⋁ zero) =
    uncurry
    (coHomPointedElim _ (pt A) (λ _ → isPropΠ λ _ → isSet× setTruncIsSet setTruncIsSet _ _)
      λ f fId → coHomPointedElim _ (pt B) (λ _ → isSet× setTruncIsSet setTruncIsSet _ _)
        λ g gId → ΣPathP (cong ∣_∣₂ (funExt (λ x → cong (f x +ₖ_) gId ∙ rUnitₖ 1 (f x))) ,
                           cong ∣_∣₂ (funExt (λ x → cong (g x +ₖ_) fId ∙ rUnitₖ 1 (g x)))))
  leftInv (Hⁿ-⋁ zero) =
    sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
      (λ f → pRec (setTruncIsSet _ _)
                   (λ fId → cong ∣_∣₂ (sym fId))
                   (helper f _ refl))
    where
    helper : (f : A ⋁ B → coHomK 1) (x : coHomK 1)
          → f (inl (pt A)) ≡ x
          → ∥ f ≡ wedgeFun⁻ 0 (λ x → f (inl x)) (λ x → f (inr x)) ∥
    helper f =
      trElim (λ _ → isProp→isOfHLevelSuc 2 (isPropΠ λ _ → propTruncIsProp))
        (sphereElim 0 (λ _ → isPropΠ λ _ → propTruncIsProp)
          λ inlId → (∣ funExt (λ { (inl x) → sym (rUnitₖ 1 (f (inl x)))
                                           ∙∙ cong ((f (inl x)) +ₖ_) (sym inlId)
                                           ∙∙ cong ((f (inl x)) +ₖ_) (cong f (push tt))
                                 ; (inr x) → sym (rUnitₖ 1 (f (inr x)))
                                            ∙ cong ((f (inr x)) +ₖ_) (sym inlId)
                                 ; (push tt i) j → cheating (f (inl (pt A))) (sym (inlId))
                                                             (f (inr (pt B)))
                                                             (cong f (push tt)) j i}) ∣₁))
      where
      cheating : (x : coHomK 1) (r : ∣ base ∣ ≡ x) (y : coHomK 1) (p : x ≡ y)
             → PathP (λ j → ((sym (rUnitₖ 1 x) ∙∙ cong (x +ₖ_) r ∙∙ cong (x +ₖ_) p)) j
                             ≡ (sym (rUnitₖ 1 y) ∙ cong (y +ₖ_) r) j)
                       p (commₖ 1 x y)
      cheating x = J (λ x r → (y : coHomK 1) (p : x ≡ y)
                            → PathP (λ j → ((sym (rUnitₖ 1 x) ∙∙ cong (x +ₖ_) r ∙∙ cong (x +ₖ_) p)) j
                                            ≡ (sym (rUnitₖ 1 y) ∙ cong (y +ₖ_) r) j)
                                     p (commₖ 1 x y))
                     λ y → J (λ y p → PathP (λ j → ((sym (rUnitₖ 1 ∣ base ∣) ∙∙ refl ∙∙ cong (∣ base ∣ +ₖ_) p)) j
                                                     ≡ (sym (rUnitₖ 1 y) ∙ refl) j)
                                              p (commₖ 1 ∣ base ∣ y))
                             λ i j → comp (λ _ → hLevelTrunc 3 S¹)
                                           (λ k → λ {(i = i0) → ∣ base ∣
                                                    ; (i = i1) → ∣ base ∣
                                                    ; (j = i0) → (rUnit (λ _ → ∣ base ∣) k) i
                                                    ; (j = i1) → (rUnit (λ _ → ∣ base ∣) k) i})
                                           ∣ base ∣
  fun (map' (Hⁿ-⋁ (suc n))) =
    sElim (λ _ → isSet× setTruncIsSet setTruncIsSet)
           λ f → ∣ (λ x → f (inl x)) ∣₂ , ∣ (λ x → f (inr x)) ∣₂
  isHom (map' (Hⁿ-⋁ (suc n))) =
    sElim2 (λ _ _ → isOfHLevelPath 2 (isSet× setTruncIsSet setTruncIsSet) _ _)
            λ _ _ → refl
  inv (Hⁿ-⋁ (suc n)) =
    uncurry (sElim2 (λ _ _ → setTruncIsSet)
                     λ f g → ∣ wedgeFun⁻ (suc n) f g ∣₂)
  rightInv (Hⁿ-⋁ (suc n)) =
   uncurry
    (coHomPointedElim _ (pt A) (λ _ → isPropΠ λ _ → isSet× setTruncIsSet setTruncIsSet _ _)
      λ f fId → coHomPointedElim _ (pt B) (λ _ → isSet× setTruncIsSet setTruncIsSet _ _)
        λ g gId → ΣPathP (cong ∣_∣₂ (funExt (λ x → cong (f x +ₖ_) gId ∙ rUnitₖ (2 + n) (f x))) ,
                           cong ∣_∣₂ (funExt (λ x → cong (g x +ₖ_) fId ∙ rUnitₖ (2 + n) (g x)))))
  leftInv (Hⁿ-⋁ (suc n)) =
    sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
      (λ f → pRec (setTruncIsSet _ _)
                   (λ fId → cong ∣_∣₂ (sym fId))
                   (helper f _ refl))
    where
    helper : (f : A ⋁ B → coHomK (2 + n)) (x : coHomK (2 + n))
          → f (inl (pt A)) ≡ x
          → ∥ f ≡ wedgeFun⁻ (suc n) (λ x → f (inl x)) (λ x → f (inr x)) ∥
    helper f =
      trElim (λ _ → isProp→isOfHLevelSuc (3 + n) (isPropΠ λ _ → propTruncIsProp))
        (sphereToPropElim (suc n) (λ _ → isPropΠ λ _ → propTruncIsProp)
          λ inlId → (∣ funExt (λ { (inl x) → sym (rUnitₖ (2 + n) (f (inl x)))
                                           ∙∙ cong ((f (inl x)) +ₖ_) (sym inlId)
                                           ∙∙ cong ((f (inl x)) +ₖ_) (cong f (push tt))
                                 ; (inr x) → sym (rUnitₖ (2 + n) (f (inr x)))
                                            ∙ cong ((f (inr x)) +ₖ_) (sym inlId)
                                 ; (push tt i) j → cheating (f (inl (pt A))) (sym (inlId))
                                                             (f (inr (pt B))) (cong f (push tt)) j i}) ∣₁))
      where
      cheating : (x : coHomK (2 + n)) (r : ∣ north ∣ ≡ x) (y : coHomK (2 + n)) (p : x ≡ y)
             → PathP (λ j → ((sym (rUnitₖ (2 + n) x) ∙∙ cong (x +ₖ_) r ∙∙ cong (x +ₖ_) p)) j
                             ≡ (sym (rUnitₖ (2 + n) y) ∙ cong (y +ₖ_) r) j)
                       p (commₖ (2 + n) x y)
      cheating x =
         J (λ x r → (y : coHomK (2 + n)) (p : x ≡ y)
                            → PathP (λ j → ((sym (rUnitₖ (2 + n) x) ∙∙ cong (x +ₖ_) r ∙∙ cong (x +ₖ_) p)) j
                                            ≡ (sym (rUnitₖ (2 + n) y) ∙ cong (y +ₖ_) r) j)
                                     p (commₖ (2 + n) x y))
                     doubleCheating
        where
        doubleCheating : (y : coHomK (2 + n)) → (p : ∣ north ∣ ≡ y)
                      → PathP (λ j → ((refl ∙∙ refl ∙∙ cong (∣ north ∣ +ₖ_) p)) j
                                      ≡ (sym (rUnitₖ (2 + n) y) ∙ refl) j)
                               p
                               (commₖ (2 + n) ∣ north ∣ y)
        doubleCheating y =
          J (λ y p → PathP (λ j → ((refl ∙∙ refl ∙∙ cong (∣ north ∣ +ₖ_) p)) j
                                      ≡ (sym (rUnitₖ (2 + n) y) ∙ refl) j)
                               p
                               (commₖ (2 + n) ∣ north ∣ y))
            λ i j → comp (λ _ → coHomK (2 + n))
                          (λ k → λ {(i = i0) → ∣ north ∣
                                   ; (i = i1) → commₖ-base (2 + n) (~ k) j
                                   ; (j = i0) → rUnit (λ _ → ∣ north ∣) k i
                                   ; (j = i1) → rUnit (λ _ → ∣ north ∣) k i})
                          ∣ north ∣

  wedgeConnected : ((x : typ A) → ∥ pt A ≡ x ∥) → ((x : typ B) → ∥ pt B ≡ x ∥) → (x : A ⋁ B) → ∥ inl (pt A) ≡ x ∥
  wedgeConnected conA conB =
    PushoutToProp (λ _ → propTruncIsProp)
                  (λ a → pRec propTruncIsProp (λ p → ∣ cong inl p ∣₁) (conA a))
                   λ b → pRec propTruncIsProp (λ p → ∣ push tt ∙ cong inr p ∣₁) (conB b)

open import Cubical.Data.Int
open import Cubical.Data.Empty renaming (rec to ⊥-rec)
open import Cubical.Data.Bool
open import Cubical.Data.Int renaming (+-comm to +-commℤ ; _+_ to _+ℤ_)

even : Int → Bool
even (pos zero) = true
even (pos (suc zero)) = false
even (pos (suc (suc n))) = even (pos n)
even (negsuc zero) = false
even (negsuc (suc n)) = even (pos n)

open import Cubical.Data.Sum

even-2 : (x : Int) → even (-2 +ℤ x) ≡ even x
even-2 (pos zero) = refl
even-2 (pos (suc zero)) = refl
even-2 (pos (suc (suc n))) =
    cong even (cong sucInt (sucInt+pos _ _)
            ∙∙ sucInt+pos _ _
            ∙∙ +-commℤ 0 (pos n))
  ∙ noClueWhy n
  where
  noClueWhy : (n : ℕ) → even (pos n) ≡ even (pos n)
  noClueWhy n = refl
even-2 (negsuc zero) = refl
even-2 (negsuc (suc n)) =
    cong even (predInt+negsuc n _
             ∙ +-commℤ -3 (negsuc n))
  ∙ noClueWhy n
  where
  noClueWhy : (n : ℕ) → even (negsuc (suc (suc (suc n)))) ≡ even (pos n)
  noClueWhy n = refl

test3 : (p : 0ₖ 1 ≡ 0ₖ 1) → even (ΩKn+1→Kn 0 (transport (λ i → ∣ (loop ∙ loop) i ∣ ≡ 0ₖ 1) p)) ≡ even (ΩKn+1→Kn 0 p)
test3 p = cong even (cong (ΩKn+1→Kn 0) (cong (transport (λ i → ∣ (loop ∙ loop) i ∣ ≡ 0ₖ 1)) (lUnit p)))
      ∙∙ cong even (cong (ΩKn+1→Kn 0) λ j → transp (λ i → ∣ (loop ∙ loop) (i ∨ j) ∣ ≡ 0ₖ 1) j ((λ i → ∣ (loop ∙ loop) (~ i ∧ j) ∣) ∙ p))
      ∙∙ cong even (ΩKn+1→Kn-hom 0 (sym (cong ∣_∣ (loop ∙ loop))) p)
       ∙ even-2 (ΩKn+1→Kn 0 p)

test2 :  Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 → Bool
test2 = uncurry (trElim (λ _ → isGroupoidΠ λ _ → isOfHLevelSuc 2 isSetBool)
                        λ {base p → even (ΩKn+1→Kn 0 p)
                        ; (loop i) p → hcomp (λ k → λ { (i = i0) → test3 p k
                                                        ; (i = i1) → even (ΩKn+1→Kn 0 p)})
                        (even (ΩKn+1→Kn 0 (transp (λ j → ∣ (loop ∙ loop) (i ∨ j) ∣ ≡ 0ₖ 1) i
                                                      p)))})

*' : (x y : coHomK 1) (p : x +ₖ x ≡ 0ₖ 1) (q : y +ₖ y ≡ 0ₖ 1) → ∥ Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 ∥₂
*' =
  trElim2 (λ _ _ → isGroupoidΠ2 λ _ _ → isOfHLevelSuc 2 setTruncIsSet)
          (wedgeConSn _ _
            (λ _ _ → isSetΠ2 λ _ _ → setTruncIsSet)
            (λ x p q → ∣ ∣ x ∣ , cong₂ _+ₖ_ p q ∣₂)
            (λ y p q → ∣ ∣ y ∣ , sym (rUnitₖ 1 (∣ y ∣ +ₖ ∣ y ∣)) ∙ cong₂ _+ₖ_ p q ∣₂)
            (funExt λ p → funExt λ q → cong ∣_∣₂ (ΣPathP (refl , (sym (lUnit _))))) .fst)

_*_ : ∥ Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 ∥₂ → ∥ Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 ∥₂ → ∥ Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 ∥₂
_*_ = sRec (isSetΠ (λ _ → setTruncIsSet)) λ a → sRec setTruncIsSet λ b → *' (fst a) (fst b) (snd a) (snd b)
*=∙ : (p q : 0ₖ 1 ≡ 0ₖ 1) → ∣ 0ₖ 1 , p ∣₂ * ∣ 0ₖ 1 , q ∣₂ ≡ ∣ 0ₖ 1 , p ∙ q ∣₂
*=∙ p q = cong ∣_∣₂ (ΣPathP (refl , sym (∙≡+₁ p q)))

help : (n : ℕ) → even (pos (suc n)) ≡ true → even (negsuc n) ≡ true
help zero p = ⊥-rec (true≢false (sym p))
help (suc n) p = p

help2 : (n : ℕ) → even (pos (suc n)) ≡ false → even (negsuc n) ≡ false
help2 zero p = refl
help2 (suc n) p = p

evenCharac : (x : Int) → even x ≡ true
    → Path ∥ Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 ∥₂
            ∣ (0ₖ 1 , Kn→ΩKn+1 0 x) ∣₂
            ∣ (0ₖ 1 , refl) ∣₂
evenCharac (pos zero) iseven i = ∣ (0ₖ 1) , (rUnit refl (~ i)) ∣₂
evenCharac (pos (suc zero)) iseven = ⊥-rec (true≢false (sym iseven))
evenCharac (pos (suc (suc zero))) iseven = cong ∣_∣₂ ((λ i → 0ₖ 1 , rUnit (cong ∣_∣ ((lUnit loop (~ i)) ∙ loop)) (~ i))
                                           ∙  (ΣPathP (cong ∣_∣ loop , λ i j → ∣ (loop ∙ loop) (i ∨ j) ∣)))
evenCharac (pos (suc (suc (suc n)))) iseven =
     (λ i → ∣ 0ₖ 1 , Kn→ΩKn+1-hom 0 (pos (suc n)) 2 i ∣₂)
  ∙∙ sym (*=∙ (Kn→ΩKn+1 0 (pos (suc n))) (Kn→ΩKn+1 0 (pos 2)))
  ∙∙ (cong₂ _*_ (evenCharac (pos (suc n)) iseven) (evenCharac 2 refl))

evenCharac (negsuc zero) iseven = ⊥-rec (true≢false (sym iseven))
evenCharac (negsuc (suc zero)) iseven =
  cong ∣_∣₂ ((λ i → 0ₖ 1 , λ i₁ → hfill (doubleComp-faces (λ i₂ → ∣ base ∣) (λ _ → ∣ base ∣) i₁)
                                         (inS ∣ compPath≡compPath' (sym loop) (sym loop) i i₁ ∣) (~ i))
                                ∙ ΣPathP ((cong ∣_∣ (sym loop)) , λ i j → ∣ (sym loop ∙' sym loop) (i ∨ j) ∣))
evenCharac (negsuc (suc (suc n))) iseven =
     cong ∣_∣₂ (λ i → 0ₖ 1 , Kn→ΩKn+1-hom 0 (negsuc n) -2 i)
  ∙∙ sym (*=∙ (Kn→ΩKn+1 0 (negsuc n)) (Kn→ΩKn+1 0 -2))
  ∙∙ cong₂ _*_ (evenCharac (negsuc n) (help n iseven)) (evenCharac -2 refl) -- i

oddCharac : (x : Int) → even x ≡ false
    → Path ∥ Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 ∥₂
            ∣ (0ₖ 1 , Kn→ΩKn+1 0 x) ∣₂
            ∣ (0ₖ 1 , cong ∣_∣ loop) ∣₂
oddCharac (pos zero) isOdd = ⊥-rec (true≢false isOdd)
oddCharac (pos (suc zero)) isOdd i =
  ∣ (0ₖ 1 , λ j → hfill (doubleComp-faces (λ i₂ → ∣ base ∣) (λ _ → ∣ base ∣) j)
                         (inS ∣ lUnit loop (~ i) j ∣) (~ i)) ∣₂
oddCharac (pos (suc (suc n))) isOdd =
  (λ i → ∣ 0ₖ 1 , Kn→ΩKn+1-hom 0 (pos n) 2 i ∣₂)
  ∙∙ sym (*=∙ (Kn→ΩKn+1 0 (pos n)) (Kn→ΩKn+1 0 2))
  ∙∙ cong₂ _*_ (oddCharac (pos n) isOdd) (evenCharac 2 refl)
oddCharac (negsuc zero) isOdd =
    cong ∣_∣₂ ((λ i → 0ₖ 1 , rUnit (sym (cong ∣_∣ loop)) (~ i))
  ∙ ΣPathP (cong ∣_∣ (sym loop) , λ i j → ∣ hcomp (λ k → λ { (i = i0) → loop (~ j ∧ k)
                                                           ; (i = i1) → loop j
                                                           ; (j = i1) → base})
                                                 (loop (j ∨ ~ i)) ∣))
oddCharac (negsuc (suc zero)) isOdd = ⊥-rec (true≢false isOdd)
oddCharac (negsuc (suc (suc n))) isOdd =
     cong ∣_∣₂ (λ i → 0ₖ 1 , Kn→ΩKn+1-hom 0 (negsuc n) -2 i)
  ∙∙ sym (*=∙ (Kn→ΩKn+1 0 (negsuc n)) (Kn→ΩKn+1 0 -2))
  ∙∙ cong₂ _*_ (oddCharac (negsuc n) (help2 n isOdd)) (evenCharac (negsuc 1) refl)

map⁻ : Bool → ∥ Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 ∥₂
map⁻ false = ∣ 0ₖ 1 , cong ∣_∣ loop ∣₂
map⁻ true = ∣ 0ₖ 1 , refl ∣₂

testIso : Iso ∥ Σ[ x ∈ coHomK 1 ] x +ₖ x ≡ 0ₖ 1 ∥₂ Bool
Iso.fun testIso = sRec isSetBool test2
Iso.inv testIso = map⁻
Iso.rightInv testIso false = refl
Iso.rightInv testIso true = refl
Iso.leftInv testIso =
  sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        (uncurry (trElim
          (λ _ → isGroupoidΠ λ _ → isOfHLevelPlus {n = 1} 2 (setTruncIsSet _ _))
          (toPropElim (λ _ → isPropΠ (λ _ → setTruncIsSet _ _))
          (λ p → path p (even (ΩKn+1→Kn 0 p)) refl))))
  where
  path : (p : 0ₖ 1 ≡ 0ₖ 1) (b : Bool) → (even (ΩKn+1→Kn 0 p) ≡ b) → map⁻ (test2 (∣ base ∣ , p)) ≡ ∣ ∣ base ∣ , p ∣₂
  path p false q =
       (cong map⁻ q)
    ∙∙ sym (oddCharac (ΩKn+1→Kn 0 p) q)
    ∙∙ cong ∣_∣₂ λ i → 0ₖ 1 , Iso.rightInv (Iso-Kn-ΩKn+1 0) p i
  path p true q =
       cong map⁻ q
    ∙∙ sym (evenCharac (ΩKn+1→Kn 0 p) q)
    ∙∙ cong ∣_∣₂ λ i → 0ₖ 1 , Iso.rightInv (Iso-Kn-ΩKn+1 0) p i


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

module FinEquivEquivTimes where

open import Data.Product using (_×_; proj₁; proj₂)

open import Equiv using (refl∼; sym∼; sym≃; _⊎≃_; id≃; _≃_; _●_; _×≃_; qinv)

open import FinEquivPlusTimes using (F0≃⊥; Fin1≃⊤; module Plus; module Times)
open Plus using (⊎≃+; +≃⊎)
open Times using (×≃*; *≃×)

open import FinEquivTypeEquiv
  using (_fin≃_; module PlusE; module TimesE; module PlusTimesE)
open PlusE using (_+F_; unite+; uniti+; unite+r; uniti+r; assocr+; assocl+;
                 swap+; sswap+)
open TimesE using (_*F_; unite*; uniti*; unite*r; uniti*r; assocr*; assocl*;
                  swap*; sswap*)
open PlusTimesE using (distz; factorz; distzr; factorzr;
                       dist; factor; distl; factorl)
open import EquivEquiv
open import TypeEquiv
  using (unite⋆equiv; unite⋆′equiv; assocl⋆equiv)

open import Data.Empty using (⊥)
open import Data.Unit using (⊤)
open import Data.Nat using (ℕ; _+_; _*_)
open import Data.Fin using (Fin)
open import Data.Sum using (_⊎_)
open import Data.Product using (_,_)
import Relation.Binary.PropositionalEquality as P using (refl)

import TypeEquivEquiv as T
  using (id×id≋id; ×●≋●×; _×≋_; sym≃-distrib×;
      unite⋆-nat; assocl⋆-nat;
      [g*1]●[1*f]≋[1*f]●[g*1]; unite⋆′-nat)

------------------------------------------------------------------------------
-- Equivalences for the multiplicative structure

id1≃ : Fin 1 ≃ Fin 1
id1≃ = id≃ {A = Fin 1}

id*id≋id : ∀ {m n : ℕ} →
    id≃ {A = Fin m} *F id≃ {A = Fin n} ≋ id≃
id*id≋id {m} {n} =
  let em = id≃ {A = Fin m} in
  let en = id≃ {A = Fin n} in
  let em×en = id≃ {A = Fin m × Fin n} in
  let em*n = id≃ {A = Fin (m * n)} in
  let f≋ = id≋ {x = ×≃* {m} {n}} in
  let g≋ = id≋ {x = *≃× {m} {n}} in
  begin (
  em *F en
    ≋⟨ id≋ ⟩
  ×≃* ● (em ×≃ en) ● *≃×
    ≋⟨ f≋ ◎ (T.id×id≋id ◎ g≋) ⟩
  ×≃* ● id≃ {A = Fin m × Fin n} ● *≃×
    ≋⟨ f≋ ◎ lid≋ {f = *≃×} ⟩
  ×≃* {m} ● *≃×
    ≋⟨ rinv≋ (×≃* {m}) ⟩
  em*n ∎)
  where open ≋-Reasoning

intro-inv-r* : {m n : ℕ} {B : Set} (f : (Fin m × Fin n) ≃ B) → f ≋ (f ● *≃×) ● ×≃*
intro-inv-r* f =
  begin (
    f
      ≋⟨ sym≋ rid≋ ⟩
    f ● id≃
      ≋⟨ id≋ {x = f} ◎ sym≋ (linv≋ ×≃*) ⟩
    f ● (*≃× ● ×≃*)
      ≋⟨ ●-assocl  ⟩
    (f ● *≃×) ● ×≃* ∎)
  where open ≋-Reasoning

*●≋●* : {A B C D E F : ℕ} →
  {f : A fin≃ C} {g : B fin≃ D} {h : C fin≃ E} {i : D fin≃ F} →
  (h ● f) *F (i ● g) ≋ (h *F i) ● (f *F g)
*●≋●* {f = f} {g} {h} {i} =
  let f≋ = id≋ {x = ×≃*} in
  let g≋ = id≋ {x = *≃×} in
  let id≋fg = id≋ {x = f ×≃ g} in
  begin (
    (h ● f) *F (i ● g)
      ≋⟨ id≋ ⟩
    ×≃* ● ((h ● f) ×≃ (i ● g)) ● *≃×
      ≋⟨ f≋ ◎ (T.×●≋●× ◎ g≋) ⟩ -- the real work, rest is shuffling
    ×≃* ● ((h ×≃ i) ● (f ×≃ g)) ● *≃×
      ≋⟨ ●-assocl ⟩
    (×≃* ● ((h ×≃ i) ● (f ×≃ g))) ● *≃×
      ≋⟨ ●-assocl ◎ g≋ ⟩
    ((×≃* ● h ×≃ i) ● f ×≃ g) ● *≃×
      ≋⟨ ((f≋ ◎ intro-inv-r* (h ×≃ i)) ◎ id≋fg) ◎ g≋ ⟩
    ((×≃* ● (h ×≃ i ● *≃×) ● ×≃*) ● f ×≃ g) ● *≃×
      ≋⟨ (●-assocl ◎ id≋fg) ◎ g≋ ⟩
    (((×≃* ● (h ×≃ i ● *≃×)) ● ×≃*) ● f ×≃ g) ● *≃×
      ≋⟨ id≋ ⟩ -- the left part is done, show it
    ((h *F i ● ×≃*) ● f ×≃ g) ● *≃×
      ≋⟨ ●-assoc {f = f ×≃ g} {×≃*} {h *F i} ◎ g≋ ⟩
    (h *F i ● (×≃* ● f ×≃ g)) ● *≃×
      ≋⟨ ●-assoc {f = *≃×} {×≃* ● f ×≃ g} {h *F i}⟩
    (h *F i) ● ((×≃* ● f ×≃ g) ● *≃×)
      ≋⟨ id≋ {x = h *F i} ◎ ●-assoc {f = *≃×} {f ×≃ g} {×≃*}⟩
    (h *F i) ● (f *F g) ∎)
  where open ≋-Reasoning

_*≋_ : {A B C D : ℕ} {f₁ g₁ : A fin≃ B} {f₂ g₂ : C fin≃ D} →
  (f₁ ≋ g₁) → (f₂ ≋ g₂) → (f₁ *F f₂ ≋ g₁ *F g₂)
_*≋_ {A} {B} {C} {D} {f₁} {g₁} {f₂} {g₂} f₁≋g₁ f₂≋g₂ =
  let f≋ = id≋ {x = ×≃*} in
  let g≋ = id≋ {x = *≃×} in
  begin (
    f₁ *F f₂
      ≋⟨ id≋ ⟩
    ×≃* ● (f₁ ×≃ f₂) ● *≃×
      ≋⟨ f≋ ◎ (T._×≋_ f₁≋g₁ f₂≋g₂ ◎ g≋) ⟩
    ×≃* ● (g₁ ×≃ g₂) ● *≃×
      ≋⟨ id≋ ⟩
    g₁ *F g₂ ∎)
  where open ≋-Reasoning

unite⋆-nat : {m n : ℕ} {f : m fin≃ n} →
  unite* ● (id1≃ *F f) ≋ f ● unite*
unite⋆-nat {m} {n} {f} =
  begin (
    unite* ● (id1≃ *F f)
      ≋⟨ id≋ ⟩
    (unite⋆equiv ● (Fin1≃⊤ ×≃ id≃) ● *≃×) ● ×≃* ● ((id≃ ×≃ f) ● *≃×)
      ≋⟨ ●-assocl {f = (id≃ ×≃ f) ● *≃×} {×≃*} {unite⋆equiv ● (Fin1≃⊤ ×≃ id≃) ● *≃×} ⟩
    ((unite⋆equiv ● ((Fin1≃⊤ ×≃ id≃) ● *≃×)) ● ×≃*) ● ((id≃ ×≃ f) ● *≃×)
      ≋⟨ (●-assocl ◎ id≋) ◎ id≋ ⟩
    (((unite⋆equiv ● (Fin1≃⊤ ×≃ id≃)) ● *≃×) ● ×≃*) ● (id≃ ×≃ f) ● *≃×
      ≋⟨ sym≋ (intro-inv-r* (unite⋆equiv ● (Fin1≃⊤ ×≃ id≃))) ◎ id≋ ⟩
    (unite⋆equiv ● (Fin1≃⊤ ×≃ id≃)) ● (id≃ ×≃ f) ● *≃×
      ≋⟨ ●-assocl ⟩
    ((unite⋆equiv ● (Fin1≃⊤ ×≃ id≃)) ● (id≃ ×≃ f)) ● *≃×
      ≋⟨ ●-assoc ◎ id≋ ⟩
    (unite⋆equiv ● (Fin1≃⊤ ×≃ id≃) ● (id≃ ×≃ f)) ● *≃×
      ≋⟨ (id≋ ◎ (T.[g*1]●[1*f]≋[1*f]●[g*1] {f = f} {Fin1≃⊤})) ◎ id≋ ⟩
    (unite⋆equiv ● ((id≃ ×≃ f) ● (Fin1≃⊤ ×≃ id≃))) ● *≃×
      ≋⟨ ●-assocl ◎ id≋ ⟩
    ((unite⋆equiv ● (id≃ ×≃ f)) ● (Fin1≃⊤ ×≃ id≃)) ● *≃×
      ≋⟨ ●-assoc ⟩
    (unite⋆equiv ● (id≃ ×≃ f)) ● (Fin1≃⊤ ×≃ id≃) ● *≃×
      ≋⟨ T.unite⋆-nat ◎ id≋ ⟩
    (f ● unite⋆equiv) ● (Fin1≃⊤ ×≃ id≃) ● *≃×
      ≋⟨ ●-assoc ⟩
    f ● unite⋆equiv ● (Fin1≃⊤ ×≃ id≃) ● *≃×
      ≋⟨ id≋ ⟩
    f ● unite* ∎)
  where open ≋-Reasoning

-- sym≃ distributes over *F
sym*F : ∀ {A B C D} {f : A fin≃ B} {g : C fin≃ D} →
  sym≃ (f *F g) ≋ sym≃ f *F sym≃ g
sym*F {f = f} {g = g} =
  begin (
    sym≃ (f *F g)
      ≋⟨ id≋ ⟩
    sym≃ (×≃* ● (f ×≃ g ● *≃×))
      ≋⟨ sym≃● ⟩
    sym≃ (f ×≃ g ● *≃×) ● sym≃ ×≃*
      ≋⟨ sym≃● ◎ id≋ ⟩
    (sym≃ *≃× ● sym≃ (f ×≃ g)) ● sym≃ ×≃*
      ≋⟨ (id≋ ◎ T.sym≃-distrib×) ◎ id≋ ⟩
    (sym≃ *≃× ● (sym≃ f ×≃ sym≃ g)) ● sym≃ ×≃*
      ≋⟨ ●-assoc ⟩
    sym≃ *≃× ● ((sym≃ f ×≃ sym≃ g) ● sym≃ ×≃*)
      ≋⟨ id≋ ⟩
    sym≃ f *F sym≃ g ∎)
  where open ≋-Reasoning

uniti⋆-nat : ∀ {A B} {f : A fin≃ B} →
  uniti* ● f ≋ (id1≃ *F f) ● uniti*
uniti⋆-nat {f = f} =
  begin (
    uniti* ● f
      ≋⟨ id≋ ⟩
    sym≃ unite* ● sym≃ (sym≃ f)
      ≋⟨ sym≋ sym≃● ⟩
    sym≃ (sym≃ f ● unite*)
      ≋⟨ flip-sym≋ unite⋆-nat ⟩
    sym≃ (unite* ● (id1≃ *F sym≃ f))
      ≋⟨ sym≃● ⟩
    sym≃ (id1≃ *F sym≃ f) ● uniti*
      ≋⟨  sym*F ◎ id≋ {x = uniti*} ⟩
    (id1≃ *F sym≃ (sym≃ f)) ● uniti*
      ≋⟨ id≋ ⟩
    (id1≃ *F f) ● uniti* ∎)
  where open ≋-Reasoning

unite⋆r-nat : {m n : ℕ} {f : m fin≃ n} →
  unite*r ● (f *F id1≃) ≋ f ● unite*r
unite⋆r-nat {m} {n} {f} =
  let 1*⊥ = id≃ ×≃ Fin1≃⊤ in
  let f*1 = f ×≃ id≃ in
  let g≋ = id≋ {x = *≃×} in
  let rhs≋ = id≋ {x = f*1 ● *≃×} in
  begin (
    unite*r ● (f *F id1≃)
      ≋⟨ id≋ ⟩
    (unite⋆′equiv ● 1*⊥ ● *≃×) ● ×≃* ● (f*1 ● *≃×)
      ≋⟨ ●-assocl ⟩
    ((unite⋆′equiv ● 1*⊥ ● *≃×) ● ×≃*) ● (f*1 ● *≃×)
      ≋⟨ (●-assocl ◎ id≋) ◎ id≋ ⟩
    (((unite⋆′equiv ● 1*⊥) ● *≃×) ● ×≃*) ● (f*1 ● *≃×)
      ≋⟨ sym≋ (intro-inv-r* (unite⋆′equiv ● 1*⊥)) ◎ rhs≋ ⟩
    (unite⋆′equiv ● 1*⊥) ● (f*1 ● *≃×)
      ≋⟨ trans≋ ●-assocl (●-assoc ◎ id≋) ⟩
    (unite⋆′equiv ● (1*⊥ ● f*1)) ● *≃×
      ≋⟨ (id≋ {x = unite⋆′equiv} ◎ sym≋ (T.[g*1]●[1*f]≋[1*f]●[g*1] {f = Fin1≃⊤} {f})) ◎ g≋ ⟩
    (unite⋆′equiv ● (f ×≃ id≃) ● (id≃ ×≃ Fin1≃⊤)) ● *≃× -- the id≃ are at different types!
      ≋⟨ ●-assocl ◎ id≋ ⟩
    ((unite⋆′equiv ● (f ×≃ id≃)) ● (id≃ ×≃ Fin1≃⊤)) ● *≃×
      ≋⟨ ●-assoc ⟩
    (unite⋆′equiv ● (f ×≃ id≃)) ● (id≃ ×≃ Fin1≃⊤) ● *≃×
      ≋⟨ T.unite⋆′-nat ◎ id≋ {x = (id≃ ×≃ Fin1≃⊤) ● *≃×} ⟩
    (f ● unite⋆′equiv) ● (id≃ ×≃ Fin1≃⊤) ● *≃×
      ≋⟨ ●-assoc ⟩ -- assoc * defn
    f ● unite*r ∎)
  where open ≋-Reasoning

uniti₊r-nat : {m n : ℕ} {f : m fin≃ n} →
    uniti*r ● f ≋ (f *F id1≃) ● uniti*r
uniti₊r-nat {f = f} =
  begin (
    uniti*r ● f
      ≋⟨ id≋ ⟩
     sym≃ unite*r ● sym≃ (sym≃ f)
      ≋⟨ sym≋ sym≃● ⟩
     sym≃ (sym≃ f ● unite*r)
      ≋⟨ flip-sym≋ unite⋆r-nat ⟩
     sym≃ (unite*r ● (sym≃ f *F id1≃))
      ≋⟨ sym≃● ⟩
     sym≃ (sym≃ f *F id1≃) ● uniti*r
      ≋⟨ sym*F ◎ id≋ {x = uniti*r} ⟩
     (sym≃ (sym≃ f) *F id1≃) ● uniti*r
      ≋⟨ id≋ ⟩
    (f *F id1≃) ● uniti*r ∎)
  where open ≋-Reasoning

-- assocl* is the one which is defined directly (?)
assocl⋆-nat : {m n o m' n' o' : ℕ}
    {f : m fin≃ m'} {g : n fin≃ n'} {h : o fin≃ o'} →
    assocl* {m'} {n'} {o'} ● (f *F (g *F h)) ≋
    ((f *F g) *F h) ● assocl* {m} {n} {o}
-- expand the definitions right away, the pattern is clear
assocl⋆-nat {m} {n} {o} {m'} {n'} {o'} {f} {g} {h} =
  let αmno' = assocl⋆equiv {Fin m'} {Fin n'} {Fin o'} in
  let αmno = assocl⋆equiv {Fin m} {Fin n} {Fin o} in
  begin (
  (×≃* ● ×≃* ×≃ id≃ ● αmno' ● id≃ ×≃ *≃× ● *≃×) ●
            ×≃* ● ((f ×≃ (×≃* ● g ×≃ h ● *≃×)) ● *≃×)
    ≋⟨ ●-assocl ⟩
  ((×≃* ● ×≃* ×≃ id≃ ● assocl⋆equiv ● id≃ ×≃ *≃× ● *≃×) ● ×≃*) ●
            (f ×≃ (×≃* ● g ×≃ h ● *≃×) ● *≃×)
    ≋⟨ ((id≋ ◎ (id≋ ◎ ●-assocl)) ◎ id≋) ◎ id≋ ⟩
  ((×≃* ● ×≃* ×≃ id≃ ● (assocl⋆equiv ● id≃ ×≃ *≃×) ● *≃×) ● ×≃*) ●
            (f ×≃ (×≃* ● g ×≃ h ● *≃×) ● *≃×)
    ≋⟨ ((id≋ ◎ ●-assocl) ◎ id≋) ◎ id≋ ⟩
  ((×≃* ● (×≃* ×≃ id≃ ● (assocl⋆equiv ● id≃ ×≃ *≃×)) ● *≃×) ● ×≃*) ●
            (f ×≃ (×≃* ● g ×≃ h ● *≃×) ● *≃×)
    ≋⟨ (●-assocl ◎ id≋) ◎ id≋ ⟩
  (((×≃* ● (×≃* ×≃ id≃ ● (assocl⋆equiv ● id≃ ×≃ *≃×))) ● *≃×) ● ×≃*) ●
            (f ×≃ (×≃* ● g ×≃ h ● *≃×) ● *≃×)
    ≋⟨ sym≋ (intro-inv-r* (×≃* ● (×≃* ×≃ id≃ ● (assocl⋆equiv ● id≃ ×≃ *≃×)))) ◎ id≋ ⟩
   (×≃* ● (×≃* ×≃ id≃ ● (assocl⋆equiv ● id≃ ×≃ *≃×))) ●
          (f ×≃ (×≃* ● g ×≃ h ● *≃×) ● *≃×)
    ≋⟨ ●-assoc ⟩
  ×≃* ● (×≃* ×≃ id≃ ● (assocl⋆equiv ● id≃ ×≃ *≃×)) ●
          (f ×≃ (×≃* ● g ×≃ h ● *≃×) ● *≃×)
    ≋⟨ id≋ ◎ (●-assocl ◎ id≋) ⟩
  ×≃* ● ((×≃* ×≃ id≃ ● assocl⋆equiv) ● id≃ ×≃ *≃×) ●
          (f ×≃ (×≃* ● g ×≃ h ● *≃×) ● *≃×)
    ≋⟨ id≋ ◎ ●-assoc ⟩
  ×≃* ● (×≃* ×≃ id≃ ● assocl⋆equiv) ● (id≃ ×≃ *≃× ●
          (f ×≃ (×≃* ● g ×≃ h ● *≃×) ● *≃×))
    ≋⟨ id≋ ◎ (id≋ ◎ ●-assocl) ⟩
  ×≃* ● (×≃* ×≃ id≃ ● assocl⋆equiv) ● ((id≃ ×≃ *≃× ●
          f ×≃ (×≃* ● g ×≃ h ● *≃×)) ● *≃×)
    ≋⟨ id≋ ◎ (id≋ ◎ (sym≋ T.×●≋●× ◎ id≋)) ⟩
  ×≃* ● (×≃* ×≃ id≃ ● assocl⋆equiv) ● ((id≃ ● f) ×≃ (*≃× ● (×≃* ● g ×≃ h ● *≃×))) ● *≃×
    ≋⟨ id≋ ◎ (id≋ ◎ (T._×≋_
                     (trans≋ lid≋ (sym≋ rid≋))
                     (trans≋ ●-assocl  (trans≋ (linv≋ ×≃* ◎ id≋) lid≋)) ◎ id≋)) ⟩
  ×≃* ● (×≃* ×≃ id≃ ● assocl⋆equiv) ● ((f ● id≃) ×≃ (g ×≃ h ● *≃×)) ● *≃×
    ≋⟨ id≋ ◎ (id≋ ◎ (T.×●≋●× ◎ id≋)) ⟩
  ×≃* ● (×≃* ×≃ id≃ ● assocl⋆equiv) ● (f ×≃ (g ×≃ h) ● id≃ ×≃ *≃×) ● *≃×
    ≋⟨ id≋ ◎ ●-assocl ⟩
  ×≃* ● ((×≃* ×≃ id≃ ● assocl⋆equiv) ● (f ×≃ (g ×≃ h) ● id≃ ×≃ *≃×)) ● *≃×
    ≋⟨ id≋ ◎ (●-assocl ◎ id≋) ⟩
  ×≃* ● (((×≃* ×≃ id≃ ● assocl⋆equiv) ● f ×≃ (g ×≃ h)) ● id≃ ×≃ *≃×) ● *≃×
    ≋⟨ id≋ ◎ ((●-assoc ◎ id≋) ◎ id≋) ⟩
  ×≃* ● ((×≃* ×≃ id≃ ● (assocl⋆equiv ● f ×≃ (g ×≃ h))) ● id≃ ×≃ *≃×) ● *≃×
    ≋⟨ id≋ ◎ ( ((id≋ ◎ T.assocl⋆-nat) ◎ id≋) ◎ id≋) ⟩
  ×≃* ● ((×≃* ×≃ id≃ ● ((f ×≃ g) ×≃ h) ● assocl⋆equiv) ● id≃ ×≃ *≃×) ● *≃×
    ≋⟨ id≋ ◎ ((●-assocl ◎ id≋)  ◎ id≋) ⟩
  ×≃* ● (((×≃* ×≃ id≃ ● (f ×≃ g) ×≃ h) ● assocl⋆equiv) ● id≃ ×≃ *≃×) ● *≃×
    ≋⟨ id≋ ◎ (((T*1-nat ◎ id≋) ◎ id≋) ◎ id≋) ⟩
  ×≃* ● ((((×≃* ● f ×≃ g ● *≃×) ● ×≃*) ×≃ (h ● id≃) ● assocl⋆equiv) ● id≃ ×≃ *≃×) ● *≃×
    ≋⟨ id≋ ◎ ●-assoc ⟩
  ×≃* ● (((×≃* ● f ×≃ g ● *≃×) ● ×≃*) ×≃ (h ● id≃) ● assocl⋆equiv) ● (id≃ ×≃ *≃× ● *≃×)
    ≋⟨ id≋ ◎ ●-assoc ⟩
  ×≃* ● ((×≃* ● f ×≃ g ● *≃×) ● ×≃*) ×≃ (h ● id≃) ● (assocl⋆equiv ● id≃ ×≃ *≃× ● *≃×)
    ≋⟨ ●-assocl ⟩
  (×≃* ● ((×≃* ● (f ×≃ g) ● *≃×) ● ×≃*) ×≃ (h ● id≃)) ● (αmno ● id≃ ×≃ *≃× ● *≃×)
    ≋⟨ (id≋ ◎ T.×●≋●× ) ◎ id≋ ⟩
  (×≃* ●  (((×≃* ● (f ×≃ g) ● *≃×) ×≃ h) ● (×≃* ×≃ id≃))) ●
           (αmno ● id≃ ×≃ *≃× ● *≃×)
    ≋⟨ ●-assocl ◎ id≋ ⟩
  ((×≃* ●  ((×≃* ● (f ×≃ g) ● *≃×) ×≃ h)) ● (×≃* ×≃ id≃)) ●
           (αmno ● id≃ ×≃ *≃× ● *≃×)
    ≋⟨ ●-assoc ⟩
  (×≃* ●  ((×≃* ● (f ×≃ g) ● *≃×) ×≃ h)) ●
            (×≃* ×≃ id≃ ● αmno ● id≃ ×≃ *≃× ● *≃×)
    ≋⟨ id≋ ◎ sym≋ lid≋ ⟩
  (×≃* ●  ((×≃* ● (f ×≃ g) ● *≃×) ×≃ h)) ●
            id≃ ● (×≃* ×≃ id≃ ● αmno ● id≃ ×≃ *≃× ● *≃×)
    ≋⟨ id≋ ◎ (sym≋ (rinv≋ *≃×) ◎ id≋) ⟩
  (×≃* ●  ((×≃* ● (f ×≃ g) ● *≃×) ×≃ h)) ●
            (*≃× ● ×≃*) ● (×≃* ×≃ id≃ ● αmno ● id≃ ×≃ *≃× ● *≃×)
    ≋⟨ id≋ ◎ ●-assoc ⟩
  ((×≃* ●  ((×≃* ● (f ×≃ g) ● *≃×) ×≃ h))) ●
            (*≃× ● ×≃* ● ×≃* ×≃ id≃ ● αmno ● id≃ ×≃ *≃× ● *≃×)
    ≋⟨ ●-assocl ⟩
  ((×≃* ●  ((×≃* ● (f ×≃ g) ● *≃×) ×≃ h)) ● *≃×) ●
            (×≃* ● ×≃* ×≃ id≃ ● αmno ● id≃ ×≃ *≃× ● *≃×)
    ≋⟨ ●-assoc ◎ id≋ ⟩
  (×≃* ● ((×≃* ● (f ×≃ g) ● *≃×) ×≃ h) ● *≃×) ●
            (×≃* ● ×≃* ×≃ id≃ ● αmno ● id≃ ×≃ *≃× ● *≃×) ∎)
  where
    open ≋-Reasoning
    T*1-nat : ×≃* ×≃ id≃ ● (f ×≃ g) ×≃ h ≋  ((×≃* ● f ×≃ g ● *≃×) ● ×≃*) ×≃ (h ● id≃)
    T*1-nat = begin (
      ×≃* ×≃ id≃ ● (f ×≃ g) ×≃ h
        ≋⟨ sym≋ (T.×●≋●×) ⟩
      (×≃* ● f ×≃ g) ×≃ (id≃ ● h)
        ≋⟨ id≋ T.×≋ (trans≋ lid≋ (sym≋ rid≋))⟩
      (×≃* ● f ×≃ g) ×≃ (h ● id≃)
        ≋⟨ trans≋ (intro-inv-r* ((×≃* ● f ×≃ g))) ●-assoc T.×≋ id≋ ⟩
        ((×≃* ● f ×≃ g) ● *≃× ● ×≃*) ×≃ (h ● id≃)
         ≋⟨ trans≋ ●-assocl (●-assoc ◎ id≋) T.×≋ id≋ ⟩
       ((×≃* ● f ×≃ g ● *≃×) ● ×≃*) ×≃ (h ● id≃) ∎)

assocr₊-nat : {m n o m' n' o' : ℕ}
    {f : m fin≃ m'} {g : n fin≃ n'} {h : o fin≃ o'} →
    assocr* {m'} {n'} {o'} ● ((f *F g) *F h) ≋
    (f *F (g *F h)) ● assocr* {m} {n} {o}
assocr₊-nat {m} {n} {o} {m'} {n'} {o'} {f} {g} {h} = begin (
  assocr* {m'} {n'} {o'} ● ((f *F g) *F h)
    ≋⟨ id≋ ⟩
  sym≃ assocl* ● sym≃ (sym≃ ((f *F g) *F h))
    ≋⟨ sym≋ (sym≃● {f = assocl*}) ⟩
  sym≃ (sym≃ ((f *F g) *F h) ● assocl* {m'} {n'} {o'})
    ≋⟨ flip≋ ((trans≋ sym*F (sym*F *≋ id≋ )) ◎ id≋) ⟩
  sym≃ (((sym≃ f *F sym≃ g) *F sym≃ h) ● assocl* {m'})
    ≋⟨ flip-sym≋ assocl⋆-nat ⟩
  sym≃ (assocl* {m} {n} {o} ● (sym≃ f *F (sym≃ g *F sym≃ h)))
    ≋⟨ flip≋ (id≋ ◎ (trans≋ (id≋ *≋ (sym≋ sym*F)) (sym≋ sym*F))) ⟩
  sym≃ ( assocl* ● sym≃ (f *F (g *F h)))
    ≋⟨ sym≃● ⟩
  sym≃ (sym≃ (f *F (g *F h))) ● sym≃ (assocl* {m} {n} {o})
    ≋⟨ id≋ ⟩
  (f *F (g *F h)) ● (assocr* {m} {n} {o}) ∎)
  where open ≋-Reasoning

unite-assocr*-coh : {m n : ℕ} →
    unite*r {m = m} *F id≃ {A = Fin n} ≋
    (id≃ {A = Fin m} *F unite* {m = n}) ● assocr* {m} {1} {n}
unite-assocr*-coh = {!!}

assocr*-coh : {m n o p : ℕ} →
    assocr* {m} {n} {o * p} ● assocr* {m * n} {o} {p} ≋
    (id≃ {A = Fin m} *F assocr* {n} {o} {p}) ●
      assocr* {m} {n * o} {p} ● (assocr* {m} {n} {o} *F id≃ {A = Fin p})
assocr*-coh = {!!}

swap*-nat : {m n o p : ℕ} {f : m fin≃ o} {g : n fin≃ p} →
    swap* {o} {p} ● (f *F g) ≋ (g *F f) ● swap* {m} {n}
swap*-nat = {!!}

sswap*-nat : {m n o p : ℕ} {f : m fin≃ o} {g : n fin≃ p} →
    sswap* {o} {p} ● (g *F f) ≋ (f *F g) ● sswap* {m} {n}
sswap*-nat = {!!}

assocr*-swap*-coh : {m n o : ℕ} →
    assocr* {n} {o} {m} ● swap* {m} {n * o} ● assocr* {m} {n} {o} ≋
    (id≃ {A = Fin n} *F swap* {m} {o}) ●
      assocr* {n} {m} {o} ● (swap* {m} {n} *F id≃ {A = Fin o})
assocr*-swap*-coh = {!!}

assocl*-swap*-coh : {m n o : ℕ} →
    assocl* {o} {m} {n} ● swap* {m * n} {o} ● assocl* {m} {n} {o} ≋
    (swap* {m} {o} *F id≃ {A = Fin n}) ●
      assocl* {m} {o} {n} ● (id≃ {A = Fin m} *F swap* {n} {o})
assocl*-swap*-coh = {!!}

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


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

module Dodo.Binary.Intersection where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Data.Product as P
open import Data.Product using (_×_; _,_; swap; proj₁; proj₂)
open import Relation.Binary using (REL)
-- Local imports
open import Dodo.Binary.Equality

-- # Definitions

infixl 30 _∩₂_

_∩₂_ : {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
  → REL A B ℓ₁
  → REL A B ℓ₂
  → REL A B (ℓ₁ ⊔ ℓ₂)
_∩₂_ P Q x y = P x y × Q x y

-- # Properties

module _ {a b ℓ : Level} {A : Set a} {B : Set b} {R : REL A B ℓ} where

  ∩₂-idem : (R ∩₂ R) ⇔₂ R
  ∩₂-idem = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : (R ∩₂ R) ⊆₂' R
    ⊆-proof _ _ = proj₁
    ⊇-proof : R ⊆₂' (R ∩₂ R)
    ⊇-proof _ _ Rxy = (Rxy , Rxy)

module _ {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
  {P : REL A B ℓ₁} {Q : REL A B ℓ₂} where

  ∩₂-comm : (P ∩₂ Q) ⇔₂ (Q ∩₂ P)
  ∩₂-comm = ⇔: (λ _ _ → swap) (λ _ _ → swap)

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
  {P : REL A B ℓ₁} {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∩₂-assoc : P ∩₂ (Q ∩₂ R) ⇔₂ (P ∩₂ Q) ∩₂ R
  ∩₂-assoc = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : P ∩₂ (Q ∩₂ R) ⊆₂' (P ∩₂ Q) ∩₂ R
    ⊆-proof _ _ (Pxy , (Qxy , Rxy)) = ((Pxy , Qxy) , Rxy)
    ⊇-proof : (P ∩₂ Q) ∩₂ R ⊆₂' P ∩₂ (Q ∩₂ R)
    ⊇-proof _ _ ((Pxy , Qxy) , Rxy) = (Pxy , (Qxy , Rxy))

-- # Operations

-- ## Operations: ⊆₂

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∩₂-combine-⊆₂ : P ⊆₂ Q → P ⊆₂ R → P ⊆₂ (Q ∩₂ R)
  ∩₂-combine-⊆₂ (⊆: P⊆Q) (⊆: P⊆R) = ⊆: (λ x y Pxy → (P⊆Q x y Pxy , P⊆R x y Pxy))

module _ {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} where

  ∩₂-introˡ-⊆₂ : (P ∩₂ Q) ⊆₂ Q
  ∩₂-introˡ-⊆₂ = ⊆: λ _ _ → proj₂

  ∩₂-introʳ-⊆₂ : (P ∩₂ Q) ⊆₂ P
  ∩₂-introʳ-⊆₂ = ⊆: λ _ _ → proj₁

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∩₂-elimˡ-⊆₂ : P ⊆₂ (Q ∩₂ R) → P ⊆₂ R
  ∩₂-elimˡ-⊆₂ (⊆: P⊆[Q∩R]) = ⊆: (λ x y Pxy → proj₂ (P⊆[Q∩R] x y Pxy))

  ∩₂-elimʳ-⊆₂ : P ⊆₂ (Q ∩₂ R) → P ⊆₂ Q
  ∩₂-elimʳ-⊆₂ (⊆: P⊆[Q∩R]) = ⊆: (λ x y Pxy → proj₁ (P⊆[Q∩R] x y Pxy))

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∩₂-substˡ-⊆₂ : P ⊆₂ Q → (P ∩₂ R) ⊆₂ (Q ∩₂ R)
  ∩₂-substˡ-⊆₂ (⊆: P⊆Q) = ⊆: (λ x y → P.map₁ (P⊆Q x y))

  ∩₂-substʳ-⊆₂ : P ⊆₂ Q → (R ∩₂ P) ⊆₂ (R ∩₂ Q)
  ∩₂-substʳ-⊆₂ (⊆: P⊆Q) = ⊆: (λ x y → P.map₂ (P⊆Q x y))

-- ## Operations: ⇔₂

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} {R : REL A B ℓ₃} where

  ∩₂-substˡ : P ⇔₂ Q → (P ∩₂ R) ⇔₂ (Q ∩₂ R)
  ∩₂-substˡ = ⇔₂-compose ∩₂-substˡ-⊆₂ ∩₂-substˡ-⊆₂

  ∩₂-substʳ : P ⇔₂ Q → (R ∩₂ P) ⇔₂ (R ∩₂ Q)
  ∩₂-substʳ = ⇔₂-compose ∩₂-substʳ-⊆₂ ∩₂-substʳ-⊆₂


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

open import HoTT
open import homotopy.EilenbergMacLane1
open import homotopy.EilenbergMacLane

{- Given sequence of groups (Gₙ : n ≥ 1) such that Gₙ is abelian for n > 1,
 - we can construct a space X such that πₙ(X) == Gₙ.
 - (We can also make π₀(X) whatever we want but this isn't done here.) -}

module homotopy.SpaceFromGroups where

{- From a sequence of spaces (Fₙ) such that Fₙ is n-connected and
 - n+1-truncated, construct a space X such that πₙ₊₁(X) == πₙ₊₁(Fₙ) -}
module SpaceFromEMs {i} (F : ℕ → Ptd i)
  {{pF : {n : ℕ} → has-level ⟨ S n ⟩ (de⊙ (F n))}}
  {{cF : (n : ℕ) → is-connected ⟨ n ⟩ (de⊙ (F n))}} where

  X : Ptd i
  X = ⊙FinTuples F

  πS-X : (n : ℕ) → πS n X ≃ᴳ πS n (F n)
  πS-X n =
    πS n (⊙FinTuples F)
      ≃ᴳ⟨ prefix-lemma n O F ⟩
    πS n (⊙FinTuples (λ k → F (n + k)))
      ≃ᴳ⟨ πS-emap n (⊙fin-tuples-cons (λ k → F (n + k))) ⁻¹ᴳ ⟩
    πS n (F (n + O) ⊙× ⊙FinTuples (λ k → F (n + S k)))
      ≃ᴳ⟨ πS-× n (F (n + O)) (⊙FinTuples (λ k → F (n + S k))) ⟩
    πS n (F (n + O)) ×ᴳ πS n (⊙FinTuples (λ k → F (n + S k)))
      ≃ᴳ⟨ ×ᴳ-emap (idiso (πS n (F (n + O))) )
         (contr-iso-0ᴳ _ $
           connected-at-level-is-contr {{⟨⟩}}
             {{Trunc-preserves-conn {n = 0} $ Ω^-conn _ (S n) _ $
               transport
                 (λ k → is-connected k
                          (FinTuples (λ k → F (n + S k))))
                 (+2+-comm 0 ⟨ n ⟩₋₁)
                 (ncolim-conn _ _ {{connected-lemma _ _ (λ k →
                   transport (λ s → is-connected ⟨ s ⟩ (de⊙ (F (n + S k))))
                     (+-βr n k ∙ +-comm (S n) k)
                     (cF (n + S k)))}})}}) ⟩
    πS n (F (n + O)) ×ᴳ 0ᴳ
      ≃ᴳ⟨ ×ᴳ-unit-r _ ⟩
    πS n (F (n + O))
      ≃ᴳ⟨ transportᴳ-iso (λ k → πS n (F k)) (+-unit-r n) ⟩
    πS n (F n)
      ≃ᴳ∎
    where
    {- In computing πₙ₊₁, spaces before Fₙ are ignored because of their
     - truncation level -}
    prefix-lemma : (n : ℕ) (m : ℕ) (F : ℕ → Ptd i)
      {{_ : {k : ℕ} → has-level ⟨ S m + k ⟩ (de⊙ (F k))}}
      → πS (m + n) (⊙FinTuples F)
        ≃ᴳ πS (m + n) (⊙FinTuples (λ k → F (n + k)))
    prefix-lemma O m F = idiso _
    prefix-lemma (S n) m F =
      πS (m + S n) (⊙FinTuples F)
        ≃ᴳ⟨ πS-emap (m + S n) (⊙fin-tuples-cons F) ⁻¹ᴳ ⟩
      πS (m + S n) (F O ⊙× ⊙FinTuples (F ∘ S))
        ≃ᴳ⟨ πS-× (m + S n) (F O) (⊙FinTuples (F ∘ S)) ⟩
      πS (m + S n) (F O) ×ᴳ πS (m + S n) (⊙FinTuples (F ∘ S))
        ≃ᴳ⟨ ×ᴳ-emap lemma₁ lemma₂ ⟩
      0ᴳ ×ᴳ πS (m + S n) (⊙FinTuples (λ k → F (S (n + k))))
        ≃ᴳ⟨ ×ᴳ-unit-l _ ⟩
      πS (m + S n) (⊙FinTuples (λ k → F (S (n + k))))
        ≃ᴳ∎
      where
      {- ignore first space -}
      lemma₁ : πS (m + S n) (F O) ≃ᴳ 0ᴳ
      lemma₁ =
        πS->level-econv (m + S n) _ (F O)
          (⟨⟩-monotone-< (<-ap-S (<-+-l m (O<S n))))

      {- ignore the rest by recursive call -}
      lemma₂ : πS (m + S n) (⊙FinTuples (F ∘ S))
        ≃ᴳ πS (m + S n) (⊙FinTuples (λ k → F (S (n + k))))
      lemma₂ =
        πS (m + S n) (⊙FinTuples (F ∘ S))
          ≃ᴳ⟨ transportᴳ-iso (λ s → πS s (⊙FinTuples (F ∘ S))) (+-βr m n) ⟩
        πS (S m + n) (⊙FinTuples (F ∘ S))
          ≃ᴳ⟨ prefix-lemma n (S m) (F ∘ S)
                {{λ {k} → transport (λ s → has-level ⟨ s ⟩ (de⊙ (F (S k))))
                     (+-βr (S m) k) ⟨⟩}} ⟩
        πS (S m + n) (⊙FinTuples (λ k → F (S (n + k))))
          ≃ᴳ⟨ transportᴳ-iso (λ s → πS s (⊙FinTuples (λ k → F (S (n + k))))) (+-βr m n) ⁻¹ᴳ ⟩
        πS (m + S n) (⊙FinTuples (λ k → F (S (n + k))))
          ≃ᴳ∎

    connected-lemma : (m : ℕ) (F : ℕ → Ptd i)
      (cA' : (n : ℕ) → is-connected ⟨ n + m ⟩ (de⊙ (F n)))
      (n : ℕ) → is-connected ⟨ m ⟩ (FinTuplesType F n)
    connected-lemma m F cA' O =
      Trunc-preserves-level ⟨ m ⟩ ⟨⟩
    connected-lemma m F cA' (S n) = ×-conn
      (cA' O)
      (connected-lemma m (F ∘ S)
        (λ n → connected-≤T (⟨⟩-monotone-≤ (inr ltS)) {{cA' (S n)}}) n)

{- Given sequence of groups (Gₙ : n ≥ 1) such that Gₙ is abelian for n > 1,
 - construct a space X such that πₙ(X) == Gₙ. -}
module SpaceFromGroups {i} (G : ℕ → Group i)
  (abG-S : (n : ℕ) → is-abelian (G (S n))) where

  private
    F : ℕ → Ptd i
    F O = ⊙EM₁ (G O)
    F (S n) = EMExplicit.⊙EM (G (S n) , abG-S n) (S (S n))

    instance
      pF : (n : ℕ) → has-level ⟨ S n ⟩ (de⊙ (F n))
      pF O = EM₁-level {G = G O}
      pF (S n) = EMExplicit.EM-level (G (S n) , abG-S n) (S (S n))

      cF : (n : ℕ) → is-connected ⟨ n ⟩ (de⊙ (F n))
      cF O = EM₁-conn {G = G O}
      cF (S n) = EMExplicit.EM-conn (G (S n) , abG-S n) (S n)

    module M = SpaceFromEMs F

  X = M.X

  πS-X : (n : ℕ) → πS n X ≃ᴳ G n
  πS-X O = π₁-EM₁ (G O) ∘eᴳ M.πS-X O
  πS-X (S n) =
    EMExplicit.πS-diag (G (S n) , abG-S n) (S n) ∘eᴳ M.πS-X (S n)