------------------------------------------------------------------------
-- Equivalence between omniscience principles
------------------------------------------------------------------------

-- http://math.fau.edu/lubarsky/Separating%20LLPO.pdf
-- https://pdfs.semanticscholar.org/deb5/23b6078032c845d8041ee6a5383fec41191c.pdf
-- http://www.math.lmu.de/~schwicht/pc16transparencies/ishihara/lecture1.pdf
-- https://ncatlab.org/nlab/show/weak+excluded+middle

------------------------------------------------------------------------
-- ->  : implication
-- <=> : equivalence
-- ∧   : conjunction

{-
                EM <=> DNE <=> Peirce <=> MI <=> DEM₁ <=> DEM₂-----┐
                 |      |        |                         |       v
                 |      |        v                         v     EM⁻¹ <=> DNE⁻¹
                 |      |       DGP          ¬ ¬ EM  <=>  DNS
                 |      |        |
                 |      |        v
                 |      |       WEM <=> DEM₃ <=> DN-distrib-⊎
                 v      v        |
                LPO     KS-------------┐
                /  \             |     \
               /    \            |      \
              v      v           v       v
Σ-Call/CC <=> MP    WLPO <=> Σ-Π-DGP -> PFP -> WPFP
              |\     |
              | \    v
              |  \  LLPO <=> Σ-DGP <=> Π-DGP
              |   \  |
              v    v v
             WMP   MP∨
-}

-- WLPO ∧ MP -> LPO
-- WLPO ∧ WMP -> LPO

-- WMP ∧ MP∨ -> MP

-- WPFP ∧ MP -> LPO

-- WPFP ∧ MP∨ -> WLPO
-- WPFP ∧ LLPO -> WLPO

-- Inhabited ∧ LPO <=> Searchable

-- MR <=> Σ-Σ-Peirce

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

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

module Constructive.Axiom.Properties.Base where

-- agda-stdlib
open import Axiom.Extensionality.Propositional
open import Level renaming (suc to lsuc; zero to lzero)
open import Data.Bool using (Bool; true; false; not)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Unit using (⊤; tt)
open import Data.Sum as Sum
open import Data.Product as Prod
open import Data.Nat as ℕ using (ℕ; zero; suc; _≤_; s≤s; z≤n; _≤?_; _+_; _*_)
import Data.Nat.Properties as ℕₚ
import Data.Nat.Induction as ℕInd
open import Data.Fin using (Fin)
import Data.Fin.Properties as Finₚ
open import Function.Base
import Function.Equality as Eq
import Function.Equivalence as Eqv
import Function.LeftInverse as LInv -- TODO use new packages
import Induction.WellFounded as Ind
open import Relation.Binary
  using (tri≈; tri<; tri>; Rel; Trichotomous)
open import Relation.Binary.PropositionalEquality hiding (Extensionality) -- TODO remove
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)

-- agda-misc
open import Constructive.Axiom
import Constructive.Axiom.Properties.Base.Lemma as Lemma
open import Constructive.Combinators
open import Constructive.Common
open import TypeTheory.HoTT.Data.Sum.Properties using (isProp-⊎)
open import TypeTheory.HoTT.Relation.Nullary.Negation.Properties
  using (isProp-¬)

-- Properties
aclt : ∀ {a b p} {A : Set a} {B : Set b} → ACLT A B p
aclt f = (λ x → proj₁ (f x)) , (λ x → proj₂ (f x))

lower-dne : ∀ a b → DNE (a ⊔ b) → DNE a
lower-dne a b dne = lower ∘′ dne ∘′ DN-map (lift {ℓ = b})

lower-wem : ∀ a b → WEM (a ⊔ b) → WEM a
lower-wem a b wem with wem
... | inj₁ ¬Lx  = inj₁ λ x → ¬Lx (lift {ℓ = b} x)
... | inj₂ ¬¬Lx = inj₂ λ ¬A → ¬¬Lx λ LA → ¬A (lower LA)

-- LPO for finite set
lpo-Fin : ∀ {n p} → LPO (Fin n) p
lpo-Fin = dec⇒dec⊎ ∘ Finₚ.any? ∘ DecU⇒decidable

dec-dns-i : ∀ {a p} {A : Set a} {P : A → Set p} → DecU P → DNS-i P
dec-dns-i P? ∀¬¬P = DN-intro (P?⇒∀¬¬P→∀P P? ∀¬¬P)

-- TODO
-- dns-Fin : ∀ {n p} → DNS (Fin n) p

------------------------------------------------------------------------
-- Equivalence between classical proposition
------------------------------------------------------------------------

-- DNE <=> EM
dne⇒em : ∀ {a} → DNE a → EM a
dne⇒em dne = dne DN-Dec⊎

em⇒dne : ∀ {a} → EM a → DNE a
em⇒dne em = A⊎B→¬B→A em

-- Peirce => DNE, EM => Peirce
peirce⇒dne : ∀ {a b} → Peirce a b → DNE a
peirce⇒dne peirce ¬¬A =
  peirce {B = Lift _ ⊥} λ A→B → ⊥-elim (¬¬A λ x → lower $ A→B x)

em⇒peirce : ∀ {a b} → EM a → Peirce a b
em⇒peirce em f = Sum.[ id , [[A→B]→A]→¬A→A f ] em

-- DEM₁ => EM, DNE => DEM₁
dem₁⇒em : ∀ {a} → DEM₁ a a → EM a
dem₁⇒em dem₁ = dem₁ (uncurry (flip _$_))

dne⇒dem₁ : ∀ {a b} → DNE (a ⊔ b) → DEM₁ a b
dne⇒dem₁ dne g = dne (g ∘ ¬[A⊎B]→¬A×¬B)

-- DNE <=> DEM₂
dne⇒dem₂ : ∀ {a} → DNE a → DEM₂ a a
dne⇒dem₂ dne f = Prod.map dne dne $ ¬[A⊎B]→¬A×¬B f

dem₂⇒dne : ∀ {a} → DEM₂ a lzero → DNE a
dem₂⇒dne dem₂ ¬¬A = uncurry id (dem₂ Sum.[ (λ f → ¬¬A (f ∘′ const)) , _$ tt ])

-- DNE => DEM₃
dne⇒dem₃ : ∀ {a b} → DNE (a ⊔ b) → DEM₃ a b
dne⇒dem₃ dne ¬[A×B] = dne (¬[A×B]→¬¬[¬A⊎¬B] ¬[A×B])

-- Converse of contraposition
dne⇒contraposition-converse : ∀ {a b} → DNE a →
                              {A : Set a} {B : Set b} → (¬ A → ¬ B) → B → A
dne⇒contraposition-converse dne ¬A→¬B b = dne $ contraposition ¬A→¬B (DN-intro b)

contraposition-converse⇒dne : ∀ {a} → ({A B : Set a} → (¬ A → ¬ B) → B → A) →
                              DNE a
contraposition-converse⇒dne f = f DN-intro

-- MI <=> EM
mi⇒em : ∀ {a} → MI a a → EM a
mi⇒em f = Sum.swap $ f id

em⇒mi : ∀ {a b} → EM a → MI a b
em⇒mi em f = Sum.swap $ Sum.map₁ f em

-- EM <=> [¬A→B]→A⊎B
em⇒[¬A→B]→A⊎B : ∀ {a b} → EM a → {A : Set a} {B : Set b} → (¬ A → B) → A ⊎ B
em⇒[¬A→B]→A⊎B em f = Sum.map₂ f em

[¬A→B]→A⊎B⇒em : ∀ {a} → ({A B : Set a} → (¬ A → B) → A ⊎ B) → EM a
[¬A→B]→A⊎B⇒em f = f id

-- Properties of WEM
em⇒wem : ∀ {a} → EM a → WEM a
em⇒wem em {A = A} = em {A = ¬ A}

-- WEM <=> DEM₃
wem⇒dem₃ : ∀ {a} → WEM a → DEM₃ a a
wem⇒dem₃ wem ¬[A×B] with wem | wem
... | inj₁ ¬A  | _        = inj₁ ¬A
... | inj₂ ¬¬A | inj₁ ¬B  = inj₂ ¬B
... | inj₂ ¬¬A | inj₂ ¬¬B = ⊥-elim $ DN-undistrib-× (¬¬A , ¬¬B) ¬[A×B]

dem₃⇒wem : ∀ {a} → DEM₃ a a → WEM a
dem₃⇒wem dem₃ = dem₃ ¬[A×¬A]

dgp-i⇒DN-distrib-⊎-i : ∀ {a b} {A : Set a} {B : Set b} →
                       DGP-i A B → ¬ ¬ (A ⊎ B) → ¬ ¬ A ⊎ ¬ ¬ B
dgp-i⇒DN-distrib-⊎-i dgp-i ¬¬[A⊎B] =
  Sum.map (λ B→A ¬A → ¬¬[A⊎B] Sum.[ ¬A , contraposition B→A ¬A ])
          (λ A→B ¬B → ¬¬[A⊎B] Sum.[ contraposition A→B ¬B , ¬B ])
          (Sum.swap dgp-i)

-- WEM <=> DN-distrib-⊎
wem⇒DN-distrib-⊎ : ∀ {a b} → WEM (a ⊔ b) →
                   {A : Set a} {B : Set b} → ¬ ¬ (A ⊎ B) → ¬ ¬ A ⊎ ¬ ¬ B
wem⇒DN-distrib-⊎ {a} {b} wem ¬¬[A⊎B] with lower-wem a b wem | lower-wem b a wem
... | inj₁ ¬A  | inj₁ ¬B  = ⊥-elim $ ¬¬[A⊎B] (¬A×¬B→¬[A⊎B] (¬A , ¬B))
... | inj₁ ¬A  | inj₂ ¬¬B = inj₂ ¬¬B
... | inj₂ ¬¬A | _        = inj₁ ¬¬A

DN-distrib-⊎⇒wem : ∀ {a} → ({A B : Set a} → ¬ ¬ (A ⊎ B) → ¬ ¬ A ⊎ ¬ ¬ B) → WEM a
DN-distrib-⊎⇒wem DN-distrib-⊎ = Sum.swap $ Sum.map₂ TN-to-N $ DN-distrib-⊎ DN-Dec⊎

-- WEM-i ∧ Stable => Dec⊎
wem-i∧stable⇒dec⊎ : ∀ {a} {A : Set a} → WEM-i A → Stable A → Dec⊎ A
wem-i∧stable⇒dec⊎ (inj₁ x) stable = inj₂ x
wem-i∧stable⇒dec⊎ (inj₂ y) stable = inj₁ (stable y)

-- EM => DGP => WEM
em⇒dgp : ∀ {a b} → EM (a ⊔ b) → DGP a b
em⇒dgp em = em⇒[¬A→B]→A⊎B em ¬[A→B]→B→A

dgp-i⇒dem₃-i : ∀ {a b} {A : Set a} {B : Set b} → DGP-i A B → DEM₃-i A B
dgp-i⇒dem₃-i dgp-i ¬[A×B] =
  Sum.map (λ A→B → contraposition (λ x → x , A→B x) ¬[A×B])
          (λ B→A → contraposition (λ y → B→A y , y) ¬[A×B])
          dgp-i

dgp⇒dem₃ : ∀ {a b} → DGP a b → DEM₃ a b
dgp⇒dem₃ dgp ¬[A×B] = dgp-i⇒dem₃-i dgp ¬[A×B]

dgp⇒wem : ∀ {a} → DGP a a → WEM a
dgp⇒wem dgp = dem₃⇒wem $ dgp⇒dem₃ dgp

-- Properties of DNS
-- DNE => DNS
dne⇒dns : ∀ {a p} {A : Set a} → DNE (a ⊔ p) → DNS A (a ⊔ p)
dne⇒dns dne f = λ x → x λ y → dne (f y)

-- DNS <=> ¬ ¬ EM
dns⇒¬¬em : ∀ {a} → ({A : Set (lsuc a)} → DNS A a) → ¬ ¬ EM a
dns⇒¬¬em dns = DN-map (λ x {A} → x A) $ dns (λ _ → DN-Dec⊎)

¬¬em⇒dns : ∀ {a} → ¬ ¬ EM a → ({A : Set a} → DNS A a)
¬¬em⇒dns ¬¬em =
  λ ∀x→¬¬Px ¬[∀x→Px] → ¬¬em λ em → ¬[∀x→Px] (λ x → em⇒dne em (∀x→¬¬Px x))

-- call/cc is classical
call/cc⇒dne : ∀ {a} → Call/CC a → DNE a
call/cc⇒dne call/cc ¬¬A = call/cc λ ¬A → ⊥-elim (¬¬A ¬A)

em⇒call/cc : ∀ {a} → EM a → Call/CC a
em⇒call/cc em ¬A→A = Sum.[ id , ¬A→A ] em

-- DNE <=> ¬[A×¬B]→A→B
dne⇒¬[A×¬B]→A→B : ∀ {a b} → DNE (a ⊔ b) →
                  {A : Set a} {B : Set b} → ¬ (A × ¬ B) → A → B
dne⇒¬[A×¬B]→A→B dne = dne λ x → x λ y z → ⊥-elim (y (z , (λ w → x λ u v → w)))

¬[A×¬B]→A→B⇒dne : ∀ {a} → ({A B : Set a} → ¬ (A × ¬ B) → A → B) → DNE a
¬[A×¬B]→A→B⇒dne f ¬¬A = f (uncurry id) ¬¬A

-- EM <=> [A→B]→¬A⊎B
em⇒[A→B]→¬A⊎B : ∀ {a b} → EM b → {A : Set a} {B : Set b} → (A → B) → ¬ A ⊎ B
em⇒[A→B]→¬A⊎B em f = Sum.swap (Sum.map₂ (contraposition f) em)

[A→B]→¬A⊎B⇒em : ∀ {a} → ({A B : Set a} → (A → B) → ¬ A ⊎ B) → EM a
[A→B]→¬A⊎B⇒em f = Sum.swap (f id)

dne⇒¬[A→¬B]→A×B : ∀ {a b} → DNE (a ⊔ b) →
                  {A : Set a} {B : Set b} → ¬ (A → ¬ B) → A × B
dne⇒¬[A→¬B]→A×B dne f = dne λ ¬[A×B] → f λ x y → ¬[A×B] (x , y)

-- the counterexample principle
dne⇒¬[A→B]→A×¬B : ∀ {a b} → DNE (a ⊔ b) →
                  {A B : Set a} {B : Set b} → ¬ (A → B) → A × ¬ B
dne⇒¬[A→B]→A×¬B dne f =
  dne λ ¬[A×¬B] → f λ x → ⊥-elim (¬[A×¬B] (x , (λ y → f (const y))))

¬[A→B]→A×¬B⇒dne : ∀ {a} → ({A B : Set a} → ¬ (A → B) → A × ¬ B) → DNE a
¬[A→B]→A×¬B⇒dne {a} f ¬¬A with f {B = Lift a ⊥} λ A→L⊥ → ¬¬A λ x → lower $ A→L⊥ x
... | x , _ = x

dne⇒ip : ∀ {a b c} → DNE (a ⊔ b ⊔ c) → IP a b c
dne⇒ip dne q f = dne (DN-ip q f)

-- Properties of DNE⁻¹ and EM⁻¹
em⇒em⁻¹ : ∀ {a} → EM a → EM⁻¹ a
em⇒em⁻¹ em _ = em

-- DNE⁻¹ <=> EM⁻¹
dne⁻¹⇒em⁻¹ : ∀ {a} → Extensionality a lzero → DNE⁻¹ a → EM⁻¹ a
dne⁻¹⇒em⁻¹ ext dne⁻¹ isP = dne⁻¹ isP′ DN-Dec⊎
  where
  isP′ : ∀ x y → x ≡ y
  isP′ = isProp-⊎ ¬[A×¬A] isP (isProp-¬ ext)

em⁻¹⇒dne⁻¹ : ∀ {a} → EM⁻¹ a → DNE⁻¹ a
em⁻¹⇒dne⁻¹ em⁻¹ isP = dec⊎⇒stable (em⁻¹ isP)

-----------------------------------------------------------------------
-- Properties of LPO, LLPO, WLPO, MP, MP⊎, WMP, KS, PFP, WPFP, Σ-DGP,
--   Π-DGP, Σ-Π-DGP, Σ-Call/CC
-----------------------------------------------------------------------

-----------------------------------------------------------------------
-- Convert between alternative forms

-- MP <=> MR
mp⇒mr : ∀ {a p} {A : Set a} → MP A p → MR A p
mp⇒mr mp P? ¬¬∃P = P?⇒∃¬¬P→∃P P? $ mp (¬-DecU P?) (¬¬∃P→¬∀¬P ¬¬∃P)

mr⇒mp : ∀ {a p} {A : Set a} → MR A p → MP A p
mr⇒mp mr P? ¬∀P = mr (¬-DecU P?) (P?⇒¬∀P→¬¬∃¬P P? ¬∀P)

-- WLPO <=> WLPO-Alt
wlpo⇒wlpo-Alt : ∀ {a p} {A : Set a} → WLPO A p → WLPO-Alt A p
wlpo⇒wlpo-Alt wlpo P? = Sum.map ∀¬P→¬∃P ¬∀¬P→¬¬∃P (wlpo (¬-DecU P?))

wlpo-Alt⇒wlpo : ∀ {a p} {A : Set a} → WLPO-Alt A p → WLPO A p
wlpo-Alt⇒wlpo wlpo-Alt P? =
  Sum.map (P?⇒¬∃¬P→∀P P?) ¬¬∃¬P→¬∀P (wlpo-Alt (¬-DecU P?))

-- MP⊎ <=> MP⊎-Alt
mp⊎⇒mp⊎-Alt : ∀ {a p} {A : Set a} → MP⊎ A p → MP⊎-Alt A p
mp⊎⇒mp⊎-Alt mp⊎ P? Q? =
  Sum.map (contraposition ∀P→¬∃¬P) (contraposition ∀P→¬∃¬P) ∘′
  mp⊎ (¬-DecU P?) (¬-DecU Q?) ∘′
  contraposition (Prod.map (P?⇒¬∃¬P→∀P P?) (P?⇒¬∃¬P→∀P Q?))

mp⊎-Alt⇒mp⊎ : ∀ {a p} {A : Set a} → MP⊎-Alt A p → MP⊎ A p
mp⊎-Alt⇒mp⊎ mp⊎-Alt P? Q? =
  Sum.map (contraposition ¬∃P→∀¬P) (contraposition ¬∃P→∀¬P) ∘′
  mp⊎-Alt (¬-DecU P?) (¬-DecU Q?) ∘′
  contraposition (Prod.map ∀¬P→¬∃P ∀¬P→¬∃P)

-- MP⊎ <=> MP∨
mp⊎⇒mp∨ : ∀ {a p} {A : Set a} → MP⊎ A p → MP∨ A p
mp⊎⇒mp∨ mp⊎ P? Q? ¬¬∃x→Px⊎Qx = mp⊎ P? Q? ([¬¬∃x→Px⊎Qx]→¬[¬∃P×¬∃Q] ¬¬∃x→Px⊎Qx)

mp∨⇒mp⊎ : ∀ {a p} {A : Set a} → MP∨ A p → MP⊎ A p
mp∨⇒mp⊎ mp∨ P? Q? ¬[¬∃P×¬∃Q] = mp∨ P? Q? (¬[¬∃P×¬∃Q]→¬¬∃x→Px⊎Qx ¬[¬∃P×¬∃Q])

-- LLPO <=> LLPO-Alt
llpo⇒llpo-Alt : ∀ {a p} {A : Set a} → LLPO A p → LLPO-Alt A p
llpo⇒llpo-Alt llpo P? Q? =
  Sum.map (P?⇒¬∃¬P→∀P P?) (P?⇒¬∃¬P→∀P Q?) ∘′
  llpo (¬-DecU P?) (¬-DecU Q?) ∘′
  contraposition (¬A×¬B→¬[A⊎B] ∘ Prod.map ∃¬P→¬∀P ∃¬P→¬∀P)

llpo-Alt⇒llpo : ∀ {a p} {A : Set a} → LLPO-Alt A p → LLPO A p
llpo-Alt⇒llpo llpo-Alt P? Q? =
  Sum.map ∀¬P→¬∃P ∀¬P→¬∃P ∘′
  llpo-Alt (¬-DecU P?) (¬-DecU Q?) ∘′
  DN-map (Sum.map ¬∃P→∀¬P ¬∃P→∀¬P) ∘′ ¬[A×B]→¬¬[¬A⊎¬B]

-- LLPO <=> LLPO-ℕ
llpo⇒llpo-ℕ : ∀ {p} → LLPO ℕ p → LLPO-ℕ p
llpo⇒llpo-ℕ llpo P? ∀mn→m≢n→Pm⊎Pn with
  llpo (λ n → ¬-DecU P? (2 * n)) (λ n → ¬-DecU P? (1 + 2 * n))
       (uncurry (Lemma.lemma₁ ∀mn→m≢n→Pm⊎Pn))
... | inj₁ ¬∃n→¬P2n   = inj₁ (P?⇒¬∃¬P→∀P (λ n → P? (2 * n)) ¬∃n→¬P2n)
... | inj₂ ¬∃n→¬P1+2n = inj₂ (P?⇒¬∃¬P→∀P (λ n → P? (suc (2 * n))) ¬∃n→¬P1+2n)

private
  module _ {p} {P Q : ℕ → Set p} (P? : DecU P) (Q? : DecU Q) where
    combine : DecU (λ n → Sum.[ P , Q ] (Lemma.parity n))
    combine n with Lemma.parity n
    ... | inj₁ m = P? m
    ... | inj₂ m = Q? m

{-
    lemma : ¬ (∃ P × ∃ Q) → ∀ m n → m ≢ n →
            Sum.[ (λ o → ¬ P o) , (λ o → ¬ Q o) ] (Lemma.parity m) ⊎
            Sum.[ (λ o → ¬ P o) , (λ o → ¬ Q o) ] (Lemma.parity n)
    lemma _ m n m≢n with
      Lemma.parity n | inspect Lemma.parity n | Lemma.parity m | inspect Lemma.parity m
    ... | inj₁ o | [ eq₁ ] | inj₁ p | [ eq₂ ] = {!   !}
    ... | inj₁ o | [ eq₁ ] | inj₂ p | [ eq₂ ] = {!   !}
    ... | inj₂ o | [ eq₁ ] | inj₁ p | [ eq₂ ] = {!   !}
    ... | inj₂ o | [ eq₁ ] | inj₂ p | [ eq₂ ] = {!   !}

llpo-ℕ⇒llpo-Alt : ∀ {p} → LLPO-ℕ p → LLPO-Alt ℕ p
llpo-ℕ⇒llpo-Alt llpo-ℕ P? Q? ¬¬[∀P⊎∀Q] with llpo-ℕ (combine P? Q?) {!   !}
... | inj₁ ∀n→[P,Q]parity[2*n]   =
  inj₁ λ n → subst Sum.[ _ , _ ] (Lemma.parity-even n) (∀n→[P,Q]parity[2*n] n)
... | inj₂ ∀n→[P,Q]parity[1+2*n] =
  inj₂ λ n → subst Sum.[ _ , _ ] (Lemma.parity-odd n) (∀n→[P,Q]parity[1+2*n] n)
-}

-----------------------------------------------------------------------
-- Implications

-- EM => LPO
em⇒lpo : ∀ {a p} {A : Set a} → EM (a ⊔ p) → LPO A p
em⇒lpo em _ = em

-- LPO => LLPO
lpo⇒llpo : ∀ {a p} {A : Set a} → LPO A p → LLPO A p
lpo⇒llpo lpo P? Q? ¬[∃P×∃Q] with lpo P? | lpo Q?
... | inj₁ ∃P  | inj₁ ∃Q  = contradiction (∃P , ∃Q) ¬[∃P×∃Q]
... | inj₁ ∃P  | inj₂ ¬∃Q = inj₂ ¬∃Q
... | inj₂ ¬∃P | _        = inj₁ ¬∃P

-- LPO <=> WLPO-Alt ∧ MR
lpo⇒wlpo-Alt : ∀ {a p} {A : Set a} → LPO A p → WLPO-Alt A p
lpo⇒wlpo-Alt lpo P? = ¬-dec⊎ (lpo P?)

lpo⇒mr : ∀ {a p} {A : Set a} → LPO A p → MR A p
lpo⇒mr lpo P? = dec⊎⇒stable (lpo P?)

wlpo-Alt∧mr⇒lpo : ∀ {a p} {A : Set a} → WLPO-Alt A p → MR A p → LPO A p
wlpo-Alt∧mr⇒lpo wlpo-Alt mr P? = wem-i∧stable⇒dec⊎ (wlpo-Alt P?) (mr P?)

-- WLPO => LLPO-Alt
wlpo⇒llpo-Alt : ∀ {a p} {A : Set a} → WLPO A p → LLPO-Alt A p
wlpo⇒llpo-Alt wlpo P? Q? ¬¬[∀P⊎∀Q] with wlpo P? | wlpo Q?
... | inj₁ ∀P  | _        = inj₁ ∀P
... | inj₂ ¬∀P | inj₁ ∀Q  = inj₂ ∀Q
... | inj₂ ¬∀P | inj₂ ¬∀Q = contradiction (¬A×¬B→¬[A⊎B] (¬∀P , ¬∀Q)) ¬¬[∀P⊎∀Q]

-- WEM => WLPO-Alt
wem⇒wlpo-Alt : ∀ {a p} {A : Set a} → WEM (a ⊔ p) → WLPO-Alt A p
wem⇒wlpo-Alt wem P? = wem

-- (WMP ∧ MP∨) <=> MR
mr⇒wmp : ∀ {a p} {A : Set a} → MR A p → WMP A p
mr⇒wmp mr {P = P} P? pp =
  mr P? $ Sum.[ id , (λ ¬¬∃x→Px×¬Px _ → f ¬¬∃x→Px×¬Px) ] (pp P?)
  where
  f : ¬ ¬ ∃ (λ x → P x × ¬ P x) → ⊥
  f ¬¬∃x→Px×¬Px = ⊥-stable $ DN-map (¬[A×¬A] ∘ proj₂) ¬¬∃x→Px×¬Px

-- MR => MP∨
mr⇒mp∨ : ∀ {a p} {A : Set a} → MR A p → MP∨ A p
mr⇒mp∨ mr {P = P} {Q = Q} P? Q? ¬¬∃x→Px⊎Qx =
  Sum.map DN-intro DN-intro $ ∃-distrib-⊎ $
  mr {P = λ x → P x ⊎ Q x} (DecU-⊎ P? Q?) ¬¬∃x→Px⊎Qx

-- WMP ∧ MP∨ => MR
-- α = P, β = Q, γ = R in [2]
wmp∧mp∨⇒mr : ∀ {a p} {A : Set a} → WMP A p → MP∨ A p → MR A p
wmp∧mp∨⇒mr {a} {p} {A} wmp mp∨ {P = P} P? ¬¬∃P = wmp P? Lem.¬¬∃Q⊎¬¬∃R
  where
  module Lem {Q : A → Set p} (Q? : DecU Q) where
    R : A → Set p
    R x = P x × ¬ Q x

    ¬¬∃x→Qx⊎Rx : ¬ ¬ ∃ λ x → Q x ⊎ R x
    ¬¬∃x→Qx⊎Rx = DN-map f ¬¬∃P
      where
      f : ∃ P → ∃ (λ x → Q x ⊎ (P x × ¬ Q x))
      f (x , Px) = x , Sum.map₂ (Px ,_) (Q? x)

    R? : DecU R
    R? = DecU-× P? (¬-DecU Q?)

    ¬¬∃Q⊎¬¬∃R : ¬ ¬ ∃ Q ⊎ ¬ ¬ ∃ R
    ¬¬∃Q⊎¬¬∃R = mp∨ Q? R? ¬¬∃x→Qx⊎Rx

-- Properties that required to prove `llpo⇒Σ-dgp`
record HasProperties
  {a} r p (A : Set a) : Set (a ⊔ lsuc r ⊔ lsuc p)
  where
  field
    _<_       : Rel A r
    <-cmp     : Trichotomous _≡_ _<_
    <-any-dec : {P : A → Set p} → DecU P → DecU (λ n → ∃ λ m → (m < n) × P m)
    <-wf      : Ind.WellFounded _<_

  private
    ¬∃¬→∀ : ∀ {P : A → Set p} {x} →
            DecU P → ¬ (∃ λ y → y < x × ¬ P y) → ∀ y → y < x → P y
    ¬∃¬→∀ {x} P? ¬∃y→y<x×¬Py y y<x =
      DecU⇒stable P? y λ ¬Py → ¬∃y→y<x×¬Py (y , (y<x , ¬Py))

  <-all-dec : {P : A → Set p} → DecU P → DecU (λ n → ∀ i → i < n → P i)
  <-all-dec P? n with <-any-dec (¬-DecU P?) n
  ... | inj₁ (m , m<n , ¬Pm) = inj₂ λ ∀i→i<n→Pi → ¬Pm (∀i→i<n→Pi m m<n)
  ... | inj₂ ¬∃m→m<n×¬Pm     = inj₁ (¬∃¬→∀ P? ¬∃m→m<n×¬Pm)

  First : (A → Set p) → A → Set (a ⊔ p ⊔ r)
  First P x = (∀ y → y < x → ¬ P y) × P x

  First? : {P : A → Set p} → DecU P → DecU (First P)
  First? P? = DecU-× (<-all-dec (¬-DecU P?)) P?

  None : (A → Set p) → A → Set (a ⊔ p ⊔ r)
  None P x = (∀ y → y < x → ¬ P y) × ¬ P x

  None? : {P : A → Set p} → DecU P → DecU (None P)
  None? P? = DecU-× (<-all-dec (¬-DecU P?)) (¬-DecU P?)

  ∃⊎None : {P : A → Set p} → DecU P → ∀ x → ∃ P ⊎ None P x
  ∃⊎None P? x with P? x | <-any-dec P? x
  ... | inj₁ Px  | _                 = inj₁ (x , Px)
  ... | inj₂ ¬Px | inj₁ (y , _ , Py) = inj₁ (y , Py)
  ... | inj₂ ¬Px | inj₂ ¬∃           =
    inj₂ ((λ y y<x Py → ¬∃ (y , (y<x , Py))) , ¬Px)

  findFirst : {P : A → Set p} → DecU P →
              ∃ P → ∃ (First P)
  findFirst {P} P? (x , Px) = go x (<-wf x) Px
    where
    go : ∀ x → Ind.Acc _<_ x → P x → ∃ λ y → (∀ i → i < y → ¬ P i) × P y
    go x (Ind.acc rs) Px with <-any-dec P? x
    ... | inj₁ (y , y<x , Py) = go y (rs y y<x) Py
    ... | inj₂ ¬∃y→y<x×Py     =
      x , (λ i i<x Pi → ¬∃y→y<x×Py (i , (i<x , Pi))) , Px

  First-unique : ∀ {P : A → Set p} {x y} → First P x → First P y → x ≡ y
  First-unique {P} {x} {y} (∀i→i<x→¬Pi , Px) (∀i→i<y→¬Pi , Py) with <-cmp x y
  ... | tri< x<y _ _ = contradiction Px (∀i→i<y→¬Pi x x<y)
  ... | tri≈ _ x≡y _ = x≡y
  ... | tri> _ _ x>y = contradiction Py (∀i→i<x→¬Pi y x>y)

  module HasPropertiesLemma
    {P Q : A → Set p} (P? : DecU P) (Q? : DecU Q)
    where

    R S : A → Set (r ⊔ p ⊔ a)
    R x = First P x × None Q x
    S x = First Q x × None P x

    R? : DecU R
    R? = DecU-× (First? P?) (None? Q?)

    S? : DecU S
    S? = DecU-× (First? Q?) (None? P?)

    ¬[∃R×∃S] : ¬ (∃ R × ∃ S)
    ¬[∃R×∃S] ((x , (∀i→i<x→¬Pi , Px) , ∀i→i<x→¬Qi , ¬Qx) ,
              (y , (∀i→i<y→¬Qi , Qy) , ∀i→i<y→¬Pi , ¬Py )) with <-cmp x y
    ... | tri< x<y _ _ = ∀i→i<y→¬Pi x x<y Px
    ... | tri≈ _ x≡y _ = ¬Py (subst P x≡y Px)
    ... | tri> _ _ y<x = ∀i→i<x→¬Qi y y<x Qy

    ¬∃R→∃P→∃Q : ¬ ∃ R → ∃ P → ∃ Q
    ¬∃R→∃P→∃Q ¬∃R ∃P with findFirst P? ∃P
    ¬∃R→∃P→∃Q ¬∃R ∃P | x , firstP with ∃⊎None Q? x
    ¬∃R→∃P→∃Q ¬∃R ∃P | x , firstP | inj₁ ∃Q    = ∃Q
    ¬∃R→∃P→∃Q ¬∃R ∃P | x , firstP | inj₂ noneQ =
      contradiction (x , firstP , noneQ) ¬∃R

    ¬∃S→∃Q→∃P : ¬ ∃ S → ∃ Q → ∃ P
    ¬∃S→∃Q→∃P ¬∃S ∃Q with findFirst Q? ∃Q
    ¬∃S→∃Q→∃P ¬∃S ∃Q | x , firstQ with ∃⊎None P? x
    ¬∃S→∃Q→∃P ¬∃S ∃Q | x , firstQ | inj₁ ∃P    = ∃P
    ¬∃S→∃Q→∃P ¬∃S ∃Q | x , firstQ | inj₂ noneP =
      contradiction (x , firstQ , noneP) ¬∃S

-- Proposition 8.6.1. [1]
-- Σ-DGP <=> LLPO
llpo⇒Σ-dgp : ∀ {r p a} {A : Set a} → HasProperties r p A →
             LLPO A (p ⊔ a ⊔ r) → Σ-DGP A p
llpo⇒Σ-dgp has llpo {P = P} {Q} P? Q? =
  Sum.map ¬∃R→∃P→∃Q ¬∃S→∃Q→∃P ¬∃R⊎¬∃S
  where
  open HasProperties has
  open HasPropertiesLemma P? Q?

  ¬∃R⊎¬∃S : ¬ ∃ R ⊎ ¬ ∃ S
  ¬∃R⊎¬∃S = llpo R? S? ¬[∃R×∃S]

Σ-dgp⇒llpo : ∀ {a p} {A : Set a} → Σ-DGP A p → LLPO A p
Σ-dgp⇒llpo Σ-dgp P? Q? ¬[∃P×∃Q] = dgp-i⇒dem₃-i (Σ-dgp P? Q?) ¬[∃P×∃Q]

-- Σ-DGP => MP∨
Σ-dgp⇒mp∨ : ∀ {p a} {A : Set a} → Σ-DGP A p → MP∨ A p
Σ-dgp⇒mp∨ Σ-dgp {P = P} {Q} P? Q? ¬¬[∃x→Px⊎Qx] = ¬¬∃P⊎¬¬∃Q
  where
  ¬¬[∃P⊎∃Q] : ¬ ¬ (∃ P ⊎ ∃ Q)
  ¬¬[∃P⊎∃Q] = DN-map ∃-distrib-⊎ ¬¬[∃x→Px⊎Qx]

  ¬¬∃P⊎¬¬∃Q : ¬ ¬ ∃ P ⊎ ¬ ¬ ∃ Q
  ¬¬∃P⊎¬¬∃Q = dgp-i⇒DN-distrib-⊎-i (Σ-dgp P? Q?) ¬¬[∃P⊎∃Q]

-- Σ-DGP => Π-DGP
Σ-dgp⇒Π-dgp : ∀ {p a} {A : Set a} → Σ-DGP A p → Π-DGP A p
Σ-dgp⇒Π-dgp Σ-dgp P? Q? =
  Sum.map (P?⇒[∃¬P→∃¬Q]→∀Q→∀P Q?) (P?⇒[∃¬P→∃¬Q]→∀Q→∀P P?)
          (Σ-dgp (¬-DecU Q?) (¬-DecU P?))

-- Π-DGP => LLPO-Alt
Π-dgp⇒llpo-Alt : ∀ {a p} {A : Set a} → Π-DGP A p → LLPO-Alt A p
Π-dgp⇒llpo-Alt Π-dgp P? Q? = Sum.map (P?⇒¬¬∀P→∀P P?) (P?⇒¬¬∀P→∀P Q?) ∘′
                             dgp-i⇒DN-distrib-⊎-i (Π-dgp P? Q?)

-- LLPO => MP∨
llpo⇒mp∨ : ∀ {r p a} {A : Set a} →
           HasProperties r p A → LLPO A (p ⊔ a ⊔ r) → MP∨ A p
llpo⇒mp∨ has llpo = Σ-dgp⇒mp∨ (llpo⇒Σ-dgp has llpo)

ℕ-hasProperties : ∀ p → HasProperties lzero p ℕ
ℕ-hasProperties _ = record
  { _<_       = ℕ._<_
  ; <-cmp     = ℕₚ.<-cmp
  ; <-any-dec = Lemma.ℕ<-any-dec
  ; <-wf      = ℕInd.<-wellFounded
  }

ℕ-llpo⇒mp∨ : ∀ {p} → LLPO ℕ p → MP∨ ℕ p
ℕ-llpo⇒mp∨ = llpo⇒mp∨ (ℕ-hasProperties _)

ℕ-llpo⇒Σ-dgp : ∀ {p} → LLPO ℕ p → Σ-DGP ℕ p
ℕ-llpo⇒Σ-dgp = llpo⇒Σ-dgp (ℕ-hasProperties _)

-- Proposition 8.6.1. [1]
-- WLPO <=> Σ-Π-DGP
wlpo⇒Σ-Π-dgp : ∀ {a p} {A : Set a} → WLPO A p → Σ-Π-DGP A p
wlpo⇒Σ-Π-dgp wlpo P? Q? with wlpo Q?
... | inj₁  ∀Q = inj₁ λ _ → ∀Q
... | inj₂ ¬∀Q = inj₂ λ ∀Q → ⊥-elim $ ¬∀Q ∀Q

Σ-Π-dgp⇒wlpo : ∀ {a p} {A : Set a} → Σ-Π-DGP A p → WLPO A p
Σ-Π-dgp⇒wlpo Σ-Π-dgp P? with Σ-Π-dgp (¬-DecU P?) P?
... | inj₁ ∃¬P→∀P = inj₁ (P?⇒[∃¬P→∀P]→∀P P? ∃¬P→∀P)
... | inj₂ ∀P→∃¬P = inj₂ λ ∀P → ∃¬P→¬∀P (∀P→∃¬P ∀P) ∀P

-- Question 15 [1]
-- MR <=> Σ-Call/CC
mr⇒Σ-call/cc : ∀ {a p} {A : Set a} → MR A p → Σ-Call/CC A p
mr⇒Σ-call/cc mr P? = mr P? ∘′ [¬A→A]→¬¬A

Σ-call/cc⇒mr : ∀ {a p} {A : Set a} → Σ-Call/CC A p → MR A p
Σ-call/cc⇒mr Σ-call/cc P? ¬¬∃P = Σ-call/cc P? λ ¬∃P → ⊥-elim $ ¬¬∃P ¬∃P

-- Question 15 [1]
-- MR <=> Σ-Σ-Peirce
mr⇒Σ-Σ-peirce : ∀ {a p} {A : Set a} → MR A p → Σ-Σ-Peirce A p
mr⇒Σ-Σ-peirce mr P? Q? [∃P→∃Q]→∃P = mr P? ([[A→B]→A]→¬¬A [∃P→∃Q]→∃P)

Σ-Σ-peirce⇒mr : ∀ {a p} {A : Set a} → Σ-Σ-Peirce A p → MR A p
Σ-Σ-peirce⇒mr {A = A} Σ-Σ-peirce P? =
  [[[A→B]→A]→A]→¬B→¬¬A→A (Σ-Σ-peirce {Q = λ _ → Lift _ ⊥} P? (λ _ → inj₂ lower))
                         f
  where
  f : Σ A (λ _ → Lift _ ⊥) → ⊥
  f (_ , ())

-- MR => Σ-Π-Peirce
mr⇒Σ-Π-peirce : ∀ {a p} {A : Set a} → MR A p → Σ-Π-Peirce A p
mr⇒Σ-Π-peirce mr P? Q? [∃P→∀Q]→∃P = mr P? ([[A→B]→A]→¬¬A [∃P→∀Q]→∃P)

-- Inhabited ∧ Σ-Π-peirce => MR
inhabited∧Σ-Π-peirce⇒mr : ∀ {a p} {A : Set a} →
                          Inhabited A → Σ-Π-Peirce A p → MR A p
inhabited∧Σ-Π-peirce⇒mr {p = p} {A} inhabited Σ-Π-peirce P? =
  [[[A→B]→A]→A]→¬B→¬¬A→A (Σ-Π-peirce {Q = λ _ → Lift _ ⊥} P? (λ _ → inj₂ lower))
                         f
  where
  f : ¬ ((x : A) → Lift p ⊥)
  f ∀x→L⊥ = lower (∀x→L⊥ inhabited)

-- Proposition 6.4.1. [1]
-- WMP ∧ WLPO-Alt => LPO
wmp∧wlpo-Alt⇒lpo : ∀ {a p} {A : Set a} → WMP A p → WLPO-Alt A p → LPO A p
wmp∧wlpo-Alt⇒lpo {a} {p} {A} wmp wlpo-Alt {P = P} P? with wlpo-Alt P?
... | inj₁ ¬∃P  = inj₂ ¬∃P
... | inj₂ ¬¬∃P = inj₁ (wmp P? Lem.res)
  where
  module Lem {Q : A → Set p} (Q? : DecU Q) where
    R : A → Set p
    R x = P x × ¬ Q x

    R? : DecU R
    R? = DecU-× P? (¬-DecU Q?)

    ¬∃R⊎¬¬∃R : ¬ ∃ R ⊎ ¬ ¬ ∃ R
    ¬∃R⊎¬¬∃R = wlpo-Alt R?

    res : ¬ ¬ ∃ Q ⊎ (¬ ¬ ∃ λ x → P x × ¬ Q x)
    res = Sum.map₁ (λ ¬∃R ¬∃Q → ¬¬∃P (f ¬∃R ¬∃Q)) ¬∃R⊎¬¬∃R
      where
      f : ¬ ∃ R → ¬ ∃ Q → ¬ ∃ P
      f ¬∃R ¬∃Q (x , Px) = ¬∃R (x , (Px , ¬∃P→∀¬P ¬∃Q x))

-- direct proof of WLPO => MP⊎
wlpo-Alt⇒mp⊎ : ∀ {a p} {A : Set a} → WLPO-Alt A p → MP⊎ A p
wlpo-Alt⇒mp⊎ wlpo-Alt P? Q? ¬[¬∃P×¬∃Q] with wlpo-Alt P? | wlpo-Alt Q?
... | inj₁ ¬∃P  | inj₁ ¬∃Q  = ⊥-elim $ ¬[¬∃P×¬∃Q] (¬∃P , ¬∃Q)
... | inj₁ ¬∃P  | inj₂ ¬¬∃Q = inj₂ ¬¬∃Q
... | inj₂ ¬¬∃P | _         = inj₁ ¬¬∃P

-- EM => KS
em⇒ks : ∀ {a p} q {A : Set a} (x : A) → EM p → KS A p q
em⇒ks q x em P with em {A = P}
em⇒ks q x em P | inj₁ xP =
  (λ _ → Lift q ⊤) , (λ _ → inj₁ (lift tt)) , ((λ _ → x , lift tt) , (λ _ → xP))
em⇒ks q x em P | inj₂ ¬P =
  (λ _ → Lift q ⊥) , (λ _ → inj₂ lower) ,
  ((λ xP → ⊥-elim $ ¬P xP) , (λ A×L⊥ → ⊥-elim $ lower $ proj₂ A×L⊥))

-- KS => PFP
ks⇒pfp : ∀ {a p q} {A : Set a} → KS A (a ⊔ p) q → PFP A p q
ks⇒pfp ks {P = P} P? = ks (∀ x → P x)

-- PFP => WPFP
pfp⇒wpfp : ∀ {a p q} {A : Set a} → PFP A p q → WPFP A p q
pfp⇒wpfp pfp {P = P} P? with pfp P?
... | Q , Q? , ∀P→∃Q , ∃Q→∀P = (λ x → ¬ Q x) , (¬-DecU Q? , (f , g))
  where
  f : (∀ x → P x) → ¬ (∀ x → ¬ Q x)
  f ∀P = ∃P→¬∀¬P (∀P→∃Q ∀P)
  g : (¬ (∀ x → ¬ Q x)) → ∀ x → P x
  g = P?⇒[∃Q→∀P]→¬∀¬Q→∀P P? ∃Q→∀P

-- WLPO => PFP
wlpo⇒pfp : ∀ {a p} q {A : Set a} → Inhabited A → WLPO A p → PFP A p q
wlpo⇒pfp {p = p} q xA wlpo {P = P} P? with wlpo P?
... | inj₁ ∀P  = (λ _ → Lift q ⊤) , (λ _ → inj₁ (lift tt)) , (f , g)
  where
  f : (∀ x → P x) → ∃ λ x → Lift q ⊤
  f _ = xA , lift tt
  g : (∃ λ x → Lift q ⊤) → (∀ x → P x)
  g _ = ∀P
... | inj₂ ¬∀P = (λ _ → Lift q ⊥) , (λ _ → inj₂ lower) , f , g
  where
  f : (∀ x → P x) → ∃ (λ x → Lift q ⊥)
  f ∀P = ⊥-elim $ ¬∀P ∀P
  g : ∃ (λ x → Lift q ⊥) → ∀ x → P x
  g (x , L⊥) = ⊥-elim $ lower L⊥

-- WLPO => WPFP
wlpo⇒wpfp : ∀ {a p} q {A : Set a} → Inhabited A → WLPO A p → WPFP A p q
wlpo⇒wpfp q xA wlpo = pfp⇒wpfp (wlpo⇒pfp q xA wlpo)

-- Proposition 6.2.3 [1]
-- WPFP ∧ MP⊎-Alt => WLPO
wpfp∧mp⊎-Alt⇒wlpo : ∀ {a p} {A : Set a} → WPFP A p p → MP⊎-Alt A p → WLPO A p
wpfp∧mp⊎-Alt⇒wlpo wpfp mp⊎-Alt {P = P} P? with wpfp P?
... | Q , Q? , ∀P→¬∀Q , ¬∀Q→∀P = Sum.map₁ ¬∀Q→∀P (Sum.swap ¬∀P⊎¬∀Q)
  where
  ¬[∀P×∀Q] : ¬ ((∀ x → P x) × (∀ x → Q x))
  ¬[∀P×∀Q] (∀P , ∀Q) = ∀P→¬∀Q ∀P ∀Q
  ¬∀P⊎¬∀Q : ¬ (∀ x → P x) ⊎ ¬ (∀ x → Q x)
  ¬∀P⊎¬∀Q = mp⊎-Alt P? Q? ¬[∀P×∀Q]

-- WPFP ∧ LLPO-Alt => WLPO
wpfp∧llpo-Alt⇒wlpo : ∀ {a p} {A : Set a} → WPFP A p p → LLPO-Alt A p → WLPO A p
wpfp∧llpo-Alt⇒wlpo wpfp llpo-Alt {P = P} P? with wpfp P?
... | Q , Q? , ∀P→¬∀Q , ¬∀Q→∀P = Sum.map₂ (λ ∀Q ∀P → ∀P→¬∀Q ∀P ∀Q) ∀P⊎∀Q
  where
  ∀P⊎∀Q : (∀ x → P x) ⊎ (∀ x → Q x)
  ∀P⊎∀Q = llpo-Alt P? Q? (DN-map (Sum.swap ∘′ Sum.map₂ ¬∀Q→∀P) DN-Dec⊎)

-- WPFP ∧ MR <=> LPO
wpfp∧mr⇒lpo : ∀ {a p} {A : Set a} → WPFP A p p → MR A p → LPO A p
wpfp∧mr⇒lpo wpfp mr =
  wlpo-Alt∧mr⇒lpo (wlpo⇒wlpo-Alt (wpfp∧mp⊎-Alt⇒wlpo wpfp (mp⊎⇒mp⊎-Alt
                    (mp∨⇒mp⊎ (mr⇒mp∨ mr)))))
                  mr

-- Proposition 1.2.1.2 in [1]
{-
lpo⇒P1212 : ∀ {p} → LPO ℕ p →
            {P : ℕ → Set p} → DecU P →
            (∃ λ N → ∀ n → N ≤ n → ¬ P n) ⊎ (Σ (ℕ → ℕ) λ k → ∀ n → P (k n))
lpo⇒P1212 {p} lpo {P} P? = {!   !}
  where
  R : ℕ → Set p
  R k = ∀ n → k ≤ n → ¬ P n

  -- use lpo
  R? : DecU R
  R? k = ?
-}

-- Searchable set
-- Searchable <=> Inhabited ∧ LPO
searchable⇒lpo : ∀ {a p} {A : Set a} → Searchable A p → LPO A p
searchable⇒lpo searchable P? with searchable (¬-DecU P?)
... | x₀ , ¬Px₀→∀¬P = Sum.[ (λ Px₀  → inj₁ (x₀ , Px₀)) ,
                            (λ ¬Px₀ → inj₂ (∀¬P→¬∃P (¬Px₀→∀¬P ¬Px₀))) ]′
                          (P? x₀)

searchable⇒inhabited : ∀ {a p} {A : Set a} →
                       Searchable A p → Inhabited A
searchable⇒inhabited {p = p} searchable =
  proj₁ (searchable {P = λ _ → Lift p ⊤} λ _ → inj₁ (lift tt))

inhabited∧lpo⇒searchable : ∀ {a p} {A : Set a} →
                           Inhabited A → LPO A p → Searchable A p
inhabited∧lpo⇒searchable inhabited lpo P? with lpo (¬-DecU P?)
... | inj₁ (x , ¬Px) = x , (λ Px → contradiction Px ¬Px)
... | inj₂ ¬∃¬P      = inhabited , (λ _ → P?⇒¬∃¬P→∀P P? ¬∃¬P)

-- [1] Hannes Diener "Constructive Reverse Mathematics"
-- [2] Hajime lshihara "Markov’s principle, Church’s thesis and LindeUf’s theorem"


open import Data.Product using ( ∃ ; _×_ ; _,_ ; proj₁ ; proj₂ )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.TBox.Interp using ( Δ ; _⊨_≈_ ) renaming
  ( Interp to Interp′ ; emp to emp′ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.Util using ( False ; id )

module Web.Semantic.DL.ABox.Interp where

infixr 4 _,_
infixr 5 _*_

{-
   An interpretation of a signature Σ (made of concept and role names)
   over a set X of individuals consists of
    - a Signature interpreation I
    - a mapping from X do Δ I, the domain of interpretation of I
   Note: In RDF the members of X are  sets of IRIs, BNodes or Literals, but
   IRIs can also refer to TBox elements.
-}
data Interp (Σ : Signature) (X : Set) : Set₁ where
  -- I is a full Interpreation (Interp')
  -- The function X → Δ {Σ} I interprets the variables in X
  _,_ : ∀ I → (X → Δ {Σ} I) → (Interp Σ X)

-- extract the Signature Interpretation, forgetting the interpretation of variables
⌊_⌋ : ∀ {Σ X} → Interp Σ X → Interp′ Σ
⌊ I , i ⌋ = I

-- return the individuals function for an interpretation
ind : ∀ {Σ X} → (I : Interp Σ X) → X → Δ ⌊ I ⌋
ind (I , i) = i

-- paired individuals function for an interpretation, useful for relations/roles
ind² : ∀ {Σ X} → (I : Interp Σ X) → (X × X) → (Δ ⌊ I ⌋ × Δ ⌊ I ⌋)
ind² I (x , y) = (ind I x , ind I y)

-- why * ?
_*_ : ∀ {Σ X Y} → (Y → X) → Interp Σ X → Interp Σ Y
f * I = (⌊ I ⌋ , λ y → ind I (f y))

-- Empty interpretation
emp : ∀ {Σ} → Interp Σ False
emp = (emp′ , id)

data Surjective {Σ X} (I : Interp Σ X) : Set where
  -- y is a variable i.e. y : X
  -- (ind I y), x : Δ
  -- all elements x of the domain Δ, have a variable y that it is an interpretation of
  surj : (∀ x → ∃ λ y → ⌊ I ⌋ ⊨ x ≈ ind I y) → (I ∈ Surjective)

ind⁻¹ : ∀ {Σ X} {I : Interp Σ X} → (I ∈ Surjective) → (Δ ⌊ I ⌋ → X)
ind⁻¹ (surj i) x = proj₁ (i x)

surj✓ : ∀ {Σ X} {I : Interp Σ X} (I∈Surj : I ∈ Surjective) → ∀ x → (⌊ I ⌋ ⊨ x ≈ ind I (ind⁻¹ I∈Surj x))
surj✓ (surj i) x = proj₂ (i x)


module Records where

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

fst : {A : Set}{B : A -> Set} -> Sigma A B -> A
fst (x , y) = x

snd : {A : Set}{B : A -> Set} -> (p : Sigma A B) -> B (fst p)
snd (x , y) = y

data Sigma1 (A : Set1) (B : A -> Set1) : Set1 where
  _,_ : (x : A) (y : B x) -> Sigma1 A B

fst1 : {A : Set1}{B : A -> Set1} -> Sigma1 A B -> A
fst1 (x , y) = x

snd1 : {A : Set1}{B : A -> Set1} -> (p : Sigma1 A B) -> B (fst1 p)
snd1 (x , y) = y

data Zero : Set where
data Unit  : Set where
  Void : Unit

data Test1 : Set where
data Test2 : Set where
data Test3 : Set where

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Fin : Nat -> Set where
  fze : {n : Nat} -> Fin (su n)
  fsu : {n : Nat} -> Fin n -> Fin (su n)

mutual
  data Sig : Set1 where
    Epsilon : Sig
    _<_ : (S : Sig)(A : [| S |] -> Set) -> Sig

  [|_|] : Sig -> Set
  [| Epsilon |] = Unit
  [| S < A |] = Sigma [| S |] A

size : Sig -> Nat
size Epsilon = ze
size (S < A) = su (size S)

typeAt : (S : Sig) -> Fin (size S) -> Sigma1 Sig (\ S -> [| S |] -> Set)
typeAt Epsilon ()
typeAt (S < A) fze = ( S , A )
typeAt (S < A) (fsu y) = typeAt S y

fsts : (S : Sig)(i : Fin (size S)) -> [| S |] -> [| fst1 (typeAt S i) |]
fsts Epsilon () rec
fsts (S < A) fze rec = fst rec
fsts (S < A) (fsu y) rec = fsts S y (fst rec)

at : (S : Sig)(i : Fin (size S))(rec : [| S |]) -> snd1 (typeAt S i) (fsts S i rec)
at Epsilon () rec
at (S < A) fze rec = snd rec
at (S < A) (fsu y) rec = at S y (fst rec)

-- * Record definition combinators:

-- ** Non dependant case works:

fi : {a : Set1} -> (S : Sig) -> Set -> (Sig -> a) -> a
fi S A k = k (S < (\_ -> A))

begin : {a : Set1} -> (Sig -> a) -> a
begin k = k Epsilon

end : (Sig -> Sig)
end x = x

test : Sig
test = begin fi Test1 fi Test2 fi Test3 end

-- ** Dependant case doesn't:

fiD : {a : Sig -> Set1} -> (S : Sig) -> (A : ([| S |] -> Set)) -> ((S : Sig) -> a S) -> a (S < A)
fiD S A k = k (S < A)

beginD : {a : Sig -> Set1} -> ((S : Sig) -> a S) -> a Epsilon
beginD k = k Epsilon

endD : (Sig -> Sig)
endD x = x

test2 : Sig
test2 = beginD fiD ((\ _ -> Test1)) fiD {!!} fiD {!!} endD


{-

This file contains:

- Definition of the Bouquet of circles of a type aka wedge of A circles

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

module Cubical.HITs.Bouquet.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed

private
  variable
    ℓ : Level

data Bouquet (A : Type ℓ) : Type ℓ where
  base : Bouquet A
  loop : A → base ≡ base

Bouquet∙ : Type ℓ → Pointed ℓ
Bouquet∙ A = Bouquet A , base


import AssocFree.STLambdaC.Typ
import AssocFree.STLambdaC.Exp

module AssocFree.STLambdaC.NF
  (TConst : Set)
  (Const : AssocFree.STLambdaC.Typ.Typ TConst → Set) where

open module Typ = AssocFree.STLambdaC.Typ TConst using
  ( Typ ; Ctxt ; const ; _⇝_ ; [_] ; [] ; _∷_ ; _++_ ; case ; singleton ; _≪_ )

open module Exp = AssocFree.STLambdaC.Exp TConst Const using
  ( Exp ; const ; abs ; app ; var ; var₀ ; weaken+ ; weaken* ; xweaken+ )

mutual

-- Normal forms

  data Atom {Γ : Ctxt} {T : Typ} : Exp Γ T → Set where
    const : ∀ c → Atom (const c)
    var : ∀ x → Atom (var x)
    app : ∀ {U M} {N : Exp Γ U} → Atom M → NF N → Atom (app M N)

  data NF {Γ : Ctxt} : ∀ {T} → Exp Γ T → Set where
    atom : ∀ {C} {M : Exp Γ (const C)} → Atom M → NF M
    abs : ∀ T {U} {M : Exp (T ∷ Γ) U} → NF M → NF (abs {Γ} T M)

-- Shorthand

atom₀ : ∀ {Γ T} → Atom (var₀ {Γ} {T})
atom₀ {Γ} {T} = var (singleton T ≪ Γ)

-- Weakening

mutual

  aweaken+ : ∀ B Γ Δ {T M} → Atom M → Atom (weaken+ B Γ Δ {T} M)
  aweaken+ B Γ Δ (const c) = const c
  aweaken+ B Γ Δ (app M N) = app (aweaken+ B Γ Δ M) (nweaken+ B Γ Δ N)
  aweaken+ B Γ Δ (var x)   = var (xweaken+ B Γ Δ x)

  nweaken+ : ∀ B Γ Δ {T M} → NF M → NF (weaken+ B Γ Δ {T} M)
  nweaken+ B Γ Δ (atom N)   = atom (aweaken+ B Γ Δ N)
  nweaken+ B Γ Δ (abs T N)  = abs T (nweaken+ (T ∷ B) Γ Δ N)

aweaken* : ∀ Γ {Δ T M} → Atom M → Atom (weaken* Γ {Δ} {T} M)
aweaken* Γ {Δ} = aweaken+ [] Γ Δ


module Basics where

id : {A : Set} -> A -> A
id a = a

_o_ : {A : Set}{B : A -> Set}{C : (a : A)(b : B a) -> Set} ->
      ({a : A}(b : B a) -> C a b) -> (g : (a : A) -> B a) ->
      (a : A) -> C a (g a)
_o_ f g a = f (g a)


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

module Categories.Bicategory.Extras where

open import Data.Product using (_,_)

open import Categories.Bicategory using (Bicategory)
open import Categories.Functor using (Functor)
open import Categories.Functor.Bifunctor using (appʳ; appˡ)
open import Categories.Functor.Bifunctor.Properties using ([_]-commute)
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism)

import Categories.Morphism as Mor
import Categories.Morphism.Reasoning as MR

module Extras {o ℓ e t} (Bicat : Bicategory o ℓ e t) where
  open Bicategory Bicat
  private
    variable
      A B C D : Obj
      f g h i : A ⇒₁ B
      α β γ : f ⇒₂ g

  module ⊚ {A B C}          = Functor (⊚ {A} {B} {C})
  module ⊚-assoc {A B C D}  = NaturalIsomorphism (⊚-assoc {A} {B} {C} {D})
  module unitˡ {A B}        = NaturalIsomorphism (unitˡ {A} {B})
  module unitʳ {A B}        = NaturalIsomorphism (unitʳ {A} {B})
  module id {A}             = Functor (id {A})

  unitorˡ : {A B : Obj} {f : A ⇒₁ B} → Mor._≅_ (hom A B) (id₁ ∘ₕ f) f
  unitorˡ {_} {_} {f} = record
    { from = unitˡ.⇒.η (_ , f)
    ; to   = unitˡ.⇐.η (_ , f)
    ; iso  = unitˡ.iso (_ , f)
    }

  module unitorˡ {A B f} = Mor._≅_ (unitorˡ {A} {B} {f})

  unitorʳ : {A B : Obj} {f : A ⇒₁ B} → Mor._≅_ (hom A B) (f ∘ₕ id₁) f
  unitorʳ {_} {_} {f} = record
    { from = unitʳ.⇒.η (f , _)
    ; to   = unitʳ.⇐.η (f , _)
    ; iso  = unitʳ.iso (f , _)
    }

  module unitorʳ {A B f} = Mor._≅_ (unitorʳ {A} {B} {f})

  associator : {A B C D : Obj} {f : D ⇒₁ B} {g : C ⇒₁ D} {h : A ⇒₁ C} →  Mor._≅_ (hom A B) ((f ∘ₕ g) ∘ₕ h) (f ∘ₕ g ∘ₕ h)
  associator {_} {_} {_} {_} {f} {g} {h} = record
    { from = ⊚-assoc.⇒.η ((f , g) , h)
    ; to   = ⊚-assoc.⇐.η ((f , g) , h)
    ; iso  = ⊚-assoc.iso ((f , g) , h)
    }

  module associator {A B C D} {f : C ⇒₁ B} {g : D ⇒₁ C} {h} = Mor._≅_ (associator {A = A} {B = B} {f = f} {g = g} {h = h})

  -⊚_ : C ⇒₁ A → Functor (hom A B) (hom C B)
  -⊚_ = appʳ ⊚

  _⊚- : B ⇒₁ C → Functor (hom A B) (hom A C)
  _⊚- = appˡ ⊚

  identity₂ˡ : id₂ ∘ᵥ α ≈ α
  identity₂ˡ = hom.identityˡ

  identity₂ʳ : α ∘ᵥ id₂ ≈ α
  identity₂ʳ = hom.identityʳ

  assoc₂ : (α ∘ᵥ β) ∘ᵥ γ ≈ α ∘ᵥ β ∘ᵥ γ
  assoc₂ = hom.assoc

  id₂◁ : id₂ {f = g} ◁ f ≈ id₂
  id₂◁ = ⊚.identity

  ▷id₂ : f ▷ id₂ {f = g} ≈ id₂
  ▷id₂ = ⊚.identity

  open hom.HomReasoning
  open hom.Equiv
  private
    module MR′ {A} {B} where
      open MR (hom A B) using (conjugate-to) public
      open Mor (hom A B) using (module ≅) public
    open MR′

  ∘ᵥ-distr-◁ : (α ◁ f) ∘ᵥ (β ◁ f) ≈ (α ∘ᵥ β) ◁ f
  ∘ᵥ-distr-◁ {f = f} = ⟺ (Functor.homomorphism (-⊚ f))

  ∘ᵥ-distr-▷ : (f ▷ α) ∘ᵥ (f ▷ β) ≈ f ▷ (α ∘ᵥ β)
  ∘ᵥ-distr-▷ {f = f} = ⟺ (Functor.homomorphism (f ⊚-))

  ρ-∘ᵥ-▷ : unitorˡ.from ∘ᵥ (id₁ ▷ α) ≈ α ∘ᵥ unitorˡ.from
  ρ-∘ᵥ-▷ {α = α} = begin
    unitorˡ.from ∘ᵥ (id₁ ▷ α)    ≈˘⟨ hom.∘-resp-≈ʳ (⊚.F-resp-≈ (id.identity , refl)) ⟩
    unitorˡ.from ∘ᵥ id.F₁ _ ⊚₁ α ≈⟨ unitˡ.⇒.commute (_ , α) ⟩
    α ∘ᵥ unitorˡ.from            ∎

  ▷-∘ᵥ-ρ⁻¹ : (id₁ ▷ α) ∘ᵥ unitorˡ.to ≈ unitorˡ.to ∘ᵥ α
  ▷-∘ᵥ-ρ⁻¹ = conjugate-to (≅.sym unitorˡ) (≅.sym unitorˡ) ρ-∘ᵥ-▷

  λ-∘ᵥ-◁ : unitorʳ.from ∘ᵥ (α ◁ id₁) ≈ α ∘ᵥ unitorʳ.from
  λ-∘ᵥ-◁ {α = α} = begin
    unitorʳ.from ∘ᵥ (α ◁ id₁)      ≈˘⟨ hom.∘-resp-≈ʳ (⊚.F-resp-≈ (refl , id.identity)) ⟩
    unitorʳ.from ∘ᵥ (α ⊚₁ id.F₁ _) ≈⟨ unitʳ.⇒.commute (α , _) ⟩
    α ∘ᵥ unitorʳ.from              ∎

  ◁-∘ᵥ-λ⁻¹ : (α ◁ id₁) ∘ᵥ unitorʳ.to ≈ unitorʳ.to ∘ᵥ α
  ◁-∘ᵥ-λ⁻¹ = conjugate-to (≅.sym unitorʳ) (≅.sym unitorʳ) λ-∘ᵥ-◁

  assoc⁻¹-◁-∘ₕ : associator.to ∘ᵥ (α ◁ (g ∘ₕ f)) ≈ ((α ◁ g) ◁ f) ∘ᵥ associator.to
  assoc⁻¹-◁-∘ₕ {α = α} {g = g} {f = f} = begin
    associator.to ∘ᵥ (α ◁ (g ∘ₕ f))    ≈˘⟨ hom.∘-resp-≈ʳ (⊚.F-resp-≈ (refl , ⊚.identity)) ⟩
    associator.to ∘ᵥ (α ⊚₁ id₂ ⊚₁ id₂) ≈⟨ ⊚-assoc.⇐.commute ((α , id₂) , id₂) ⟩
    ((α ◁ g) ◁ f) ∘ᵥ associator.to     ∎

  assoc⁻¹-▷-◁ : associator.to ∘ᵥ (f ▷ (α ◁ g)) ≈ ((f ▷ α) ◁ g) ∘ᵥ associator.to
  assoc⁻¹-▷-◁ {f = f} {α = α} {g = g} = ⊚-assoc.⇐.commute ((id₂ , α) , id₂)

  assoc⁻¹-▷-∘ₕ : associator.to ∘ᵥ (g ▷ (f ▷ α)) ≈ ((g ∘ₕ f) ▷ α) ∘ᵥ associator.to
  assoc⁻¹-▷-∘ₕ {g = g} {f = f} {α = α} = begin
    associator.to ∘ᵥ (g ▷ (f ▷ α))       ≈⟨ ⊚-assoc.⇐.commute ((id₂ , id₂) , α) ⟩
    ((id₂ ⊚₁ id₂) ⊚₁ α) ∘ᵥ associator.to ≈⟨ hom.∘-resp-≈ˡ (⊚.F-resp-≈ (⊚.identity , refl)) ⟩
    ((g ∘ₕ f) ▷ α) ∘ᵥ associator.to      ∎

  ◁-▷-exchg : ∀ {α : f ⇒₂ g} {β : h ⇒₂ i} → (i ▷ α) ∘ᵥ (β ◁ f) ≈ (β ◁ g) ∘ᵥ (h ▷ α)
  ◁-▷-exchg = [ ⊚ ]-commute


module Numeral.Integer.Function where

open import Numeral.Integer
open import Numeral.Integer.Oper
open import Numeral.Natural as ℕ using (ℕ)


module string-thms where

open import bool
open import eq
open import string

postulate
  =string-refl : (s : string) → s =string s ≡ tt
  =string-to-≡ : (a b : string) → a =string b ≡ tt → a ≡ b

≡string-to-= : (a b : string) → a ≡ b → a =string b ≡ tt
≡string-to-= a .a refl = =string-refl a


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.RingSolver.RawRing where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Sigma
open import Cubical.Data.Nat using (ℕ)

open import Cubical.Algebra.RingSolver.AlmostRing hiding (⟨_⟩)

private
  variable
    ℓ : Level

record RawRing : Type (ℓ-suc ℓ) where

  constructor rawring

  field
    Carrier : Type ℓ
    0r      : Carrier
    1r      : Carrier
    _+_     : Carrier → Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier

  infixl 8 _·_
  infixl 7 -_
  infixl 6 _+_

⟨_⟩ : RawRing → Type ℓ
⟨_⟩ = RawRing.Carrier

AlmostRing→RawRing : AlmostRing {ℓ} → RawRing {ℓ}
AlmostRing→RawRing (almostring Carrier 0r 1r _+_ _·_ -_ isAlmostRing) =
                   rawring Carrier 0r 1r _+_ _·_ -_


{-# OPTIONS --safe --experimental-lossy-unification #-}

-- This file could be proven using the file Sn
-- However the proofs are easier than in Sn
-- And so kept for pedagologic reasons

module Cubical.ZCohomology.CohomologyRings.S1 where

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

open import Cubical.Data.Unit
open import Cubical.Data.Nat renaming (_+_ to _+n_ ; _·_ to _·n_ ; snotz to nsnotz)
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.FGIdeal
open import Cubical.Algebra.CommRing.QuotientRing
open import Cubical.Algebra.Polynomials.Multivariate.Base renaming (base to baseP)
open import Cubical.Algebra.CommRing.Instances.Int renaming (ℤCommRing to ℤCR)
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.HITs.Sn

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.Sn

open Iso

module Equiv-S1-Properties where

-----------------------------------------------------------------------------
-- Definitions

  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 (S₊ 1))) 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
    ; ·Comm     to ·PℤComm
    ; ·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*-S¹ : ℤ[x] → H* (S₊ 1)
  ℤ[x]→H*-S¹ = Poly-Rec-Set.f _ _ _ isSetH*
                  0H*
                  base-trad
                  _+H*_
                  +H*Assoc
                  +H*Rid
                  +H*Comm
                  base-neutral-eq
                  base-add-eq
               where
               e : _
               e = Hᵐ-Sⁿ

               base-trad : _
               base-trad (zero ∷ [])        a = base 0 (inv (fst (Hᵐ-Sⁿ 0 1)) a)
               base-trad (one ∷ [])         a = base 1 (inv (fst (Hᵐ-Sⁿ 1 1)) a)
               base-trad (suc (suc n) ∷ []) a = 0H*

               base-neutral-eq :  _
               base-neutral-eq (zero ∷ [])        = cong (base 0) (IsGroupHom.pres1 (snd (invGroupIso (Hᵐ-Sⁿ 0 1)))) ∙ base-neutral _
               base-neutral-eq (one ∷ [])         = cong (base 1) (IsGroupHom.pres1 (snd (invGroupIso (Hᵐ-Sⁿ 1 1)))) ∙ base-neutral _
               base-neutral-eq (suc (suc n) ∷ []) = refl

               base-add-eq : _
               base-add-eq (zero ∷ []) a b        = (base-add _ _ _) ∙ (cong (base 0) (sym (IsGroupHom.pres· (snd (invGroupIso (Hᵐ-Sⁿ 0 1))) a b)))
               base-add-eq (one ∷ []) a b         = (base-add _ _ _) ∙ (cong (base 1) (sym (IsGroupHom.pres· (snd (invGroupIso (Hᵐ-Sⁿ 1 1))) a b)))
               base-add-eq (suc (suc n) ∷ []) a b = +H*Rid _

-----------------------------------------------------------------------------
-- Morphism on ℤ[x]

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

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

-- cup product on H⁰ → H⁰ → H⁰
  T0 : (z : ℤ) → coHom 0 (S₊ 1)
  T0 = λ z → inv (fst (Hᵐ-Sⁿ 0 1)) z

  T0g : IsGroupHom (ℤG .snd) (fst (invGroupIso (Hᵐ-Sⁿ 0 1)) .fun) (coHomGr 0 (S₊ (suc 0)) .snd)
  T0g = snd (invGroupIso (Hᵐ-Sⁿ 0 1))

  -- 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)
-- cup product on H⁰ → H¹ → H¹
  T1 : (z : ℤ) → coHom 1 (S₊ 1)
  T1 = λ z → inv (fst (Hᵐ-Sⁿ 1 1)) z

  -- idea : control of the unfolding + simplification of T0 on the left
  T1g : IsGroupHom (ℤG .snd) (fst (invGroupIso (Hᵐ-Sⁿ 1 1)) .fun) (coHomGr 1 (S₊ 1) .snd)
  T1g = snd (invGroupIso (Hᵐ-Sⁿ 1 1))

  pres·-base-case-01 : (a : ℤ) → (b : ℤ) →
                        T1 (a ·ℤ b) ≡ (T0 a) ⌣ (T1 b)
  pres·-base-case-01 (pos zero)       b = (IsGroupHom.pres1 T1g)
  pres·-base-case-01 (pos (suc n))    b = ((IsGroupHom.pres· T1g b (pos n ·ℤ b)))
                                          ∙ (cong (λ X → (T1 b) +ₕ X) (pres·-base-case-01 (pos n) b))
  pres·-base-case-01 (negsuc zero)    b = IsGroupHom.presinv T1g b
  pres·-base-case-01 (negsuc (suc n)) b = cong T1 (+ℤComm (-ℤ b) (negsuc n ·ℤ b)) -- ·ℤ and ·₀ are defined asymetrically !
                                          ∙ IsGroupHom.pres· T1g (negsuc n ·ℤ b) (-ℤ b)
                                          ∙ cong₂ _+ₕ_ (pres·-base-case-01 (negsuc n) b)
                                                         (IsGroupHom.presinv T1g b)

-- Nice packaging of the proof
  pres·-base-case-int : (n : ℕ) → (a : ℤ) → (m : ℕ) → (b : ℤ) →
                ℤ[x]→H*-S¹ (baseP (n ∷ []) a ·Pℤ baseP (m ∷ []) b)
              ≡ ℤ[x]→H*-S¹ (baseP (n ∷ []) a) cup ℤ[x]→H*-S¹ (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 one           b = cong (base 1) (pres·-base-case-01 a b)
  pres·-base-case-int zero          a (suc (suc m)) b = refl
  pres·-base-case-int one           a zero          b = cong ℤ[x]→H*-S¹ (·PℤComm (baseP (1 ∷ []) a) (baseP (zero ∷ []) b))
                                                         ∙ pres·-base-case-int 0 b 1 a
                                                         ∙ gradCommRing (S₊ 1) 0 1 (inv (fst (Hᵐ-Sⁿ 0 1)) b) (inv (fst (Hᵐ-Sⁿ 1 1)) a)
  pres·-base-case-int one           a one           b = sym (base-neutral 2) ∙
                                                         cong (base 2) (isOfHLevelRetractFromIso 1 (fst (Hⁿ-Sᵐ≅0 1 0 nsnotz)) isPropUnit _ _)
  pres·-base-case-int one           a (suc (suc m)) b = refl
  pres·-base-case-int (suc (suc n)) a m             b = refl

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

  -- proof of the morphism
  ℤ[x]→H*-S¹-pres· : (x y : ℤ[x]) → ℤ[x]→H*-S¹ (x ·Pℤ y) ≡ ℤ[x]→H*-S¹ x cup ℤ[x]→H*-S¹ y
  ℤ[x]→H*-S¹-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 (S₊ 1)) _))
                           (λ 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+ _ _ _)

-----------------------------------------------------------------------------
-- Function on ℤ[x]/x + morphism

  ℤ[x]→H*-S¹-cancelX : (k : Fin 1) → ℤ[x]→H*-S¹ (<X²> k) ≡ 0H*
  ℤ[x]→H*-S¹-cancelX zero = refl

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

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

  ℤ[x]/x²→H*-S¹ : ℤ[x]/x² → H* (S₊ 1)
  ℤ[x]/x²→H*-S¹ = fst ℤ[X]/X²→H*R-S¹

-----------------------------------------------------------------------------
-- Converse Sens on ℤ[X] + ℤ[x]/x

  H*-S¹→ℤ[x] : H* (S₊ 1) → ℤ[x]
  H*-S¹→ℤ[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 : _
               base-trad zero a          = baseP (0 ∷ []) (fun (fst (Hᵐ-Sⁿ 0 1)) a)
               base-trad one a           = baseP (1 ∷ []) (fun (fst (Hᵐ-Sⁿ 1 1)) a)
               base-trad (suc (suc n)) a = 0Pℤ

               base-neutral-eq : _
               base-neutral-eq zero          = cong (baseP (0 ∷ [])) (IsGroupHom.pres1 (snd (Hᵐ-Sⁿ 0 1))) ∙ base-0P _
               base-neutral-eq one           = cong (baseP (1 ∷ [])) (IsGroupHom.pres1 (snd (Hᵐ-Sⁿ 1 1))) ∙ base-0P _
               base-neutral-eq (suc (suc n)) = refl

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

  H*-S¹→ℤ[x]-pres+ : (x y : H* (S₊ 1)) → H*-S¹→ℤ[x] ( x +H* y) ≡ H*-S¹→ℤ[x] x +Pℤ H*-S¹→ℤ[x] y
  H*-S¹→ℤ[x]-pres+ x y = refl

  H*-S¹→ℤ[x]/x² : H* (S₊ 1) → ℤ[x]/x²
  H*-S¹→ℤ[x]/x² = [_] ∘ H*-S¹→ℤ[x]

  H*-S¹→ℤ[x]/x²-pres+ : (x y : H* (S₊ 1)) → H*-S¹→ℤ[x]/x² (x +H* y) ≡ (H*-S¹→ℤ[x]/x² x) +PℤI (H*-S¹→ℤ[x]/x² y)
  H*-S¹→ℤ[x]/x²-pres+ x y = refl

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

  e-sect : (x : H* (S₊ 1)) → ℤ[x]/x²→H*-S¹ (H*-S¹→ℤ[x]/x² x) ≡ x
  e-sect = DS-Ind-Prop.f _ _ _ _ (λ _ → isSetH* _ _)
           refl
           base-case
           λ {U V} ind-U ind-V → cong₂ _+H*_ ind-U ind-V
           where
           base-case : _
           base-case zero          a = cong (base 0) (leftInv (fst (Hᵐ-Sⁿ 0 1)) a)
           base-case one           a = cong (base 1) (leftInv (fst (Hᵐ-Sⁿ 1 1)) a)
           base-case (suc (suc n)) a = (sym (base-neutral (suc (suc n))))
                                       ∙ cong (base (suc (suc n))) (isOfHLevelRetractFromIso 1 (fst (Hⁿ-Sᵐ≅0 (suc n) 0 nsnotz)) isPropUnit _ _)

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

  e-retr : (x : ℤ[x]/x²) → H*-S¹→ℤ[x]/x² (ℤ[x]/x²→H*-S¹ 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 = cong [_] (cong (baseP (0 ∷ [])) (rightInv (fst (Hᵐ-Sⁿ 0 1)) a))
           base-case (one ∷ [])         a = cong [_] (cong (baseP (1 ∷ [])) (rightInv (fst (Hᵐ-Sⁿ 1 1)) a))
           base-case (suc (suc n) ∷ []) a = eq/ 0Pℤ (baseP (suc (suc n) ∷ []) a) ∣ ((λ x → baseP (n ∷ []) (-ℤ a)) , helper) ∣₁
             where
             helper : _
             helper = (+PℤLid _) ∙ cong₂ baseP (cong (λ X → X ∷ []) (sym (+-comm n 2))) (sym (·ℤRid _)) ∙ (sym (+PℤRid _))

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

module _ where

  open Equiv-S1-Properties

  S¹-CohomologyRing : RingEquiv (CommRing→Ring ℤ[X]/X²) (H*R (S₊ 1))
  fst S¹-CohomologyRing = isoToEquiv is
    where
    is : Iso ℤ[x]/x² (H* (S₊ 1))
    fun is = ℤ[x]/x²→H*-S¹
    inv is = H*-S¹→ℤ[x]/x²
    rightInv is = e-sect
    leftInv is = e-retr
  snd S¹-CohomologyRing = snd ℤ[X]/X²→H*R-S¹

  CohomologyRing-S¹ : RingEquiv (H*R (S₊ 1)) (CommRing→Ring ℤ[X]/X²)
  CohomologyRing-S¹ = RingEquivs.invEquivRing S¹-CohomologyRing


-- Shrunk version of examples/TT.agda
-- Bug introduced by fix of issue 1560

{-# OPTIONS --allow-unsolved-metas #-}
-- {-# OPTIONS --no-termination-check #-}
-- {-# OPTIONS --no-positivity-check #-}

-- {-# OPTIONS -v tc.pos:10 #-}
-- {-# OPTIONS -v tc.polarity:30 #-}

data True : Set where
  tt : True

data ⊥ : Set where

infix 3 _/\_

data _/\_ (P Q : Set) : Set where
  andI : P -> Q -> P /\ Q

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

-- Finite sets ------------------------------------------------------------

data Suc (A : Set) : Set where
  fzero' : Suc A
  fsuc'  : A -> Suc A

mutual
  data Fin (n : Nat) : Set where
    finI : Fin' n -> Fin n

  Fin' : Nat -> Set
  Fin'  zero   = ⊥
  Fin' (suc n) = Suc (Fin n)

fsuc : {n : Nat} -> Fin n -> Fin (suc n)
fsuc i = finI (fsuc' i)

module FinEq where

  infix 5 _==_

  _==_ : {n : Nat} -> Fin n -> Fin n -> Set
  _==_ {suc _} (finI  fzero'  ) (finI  fzero'  ) = True
  _==_ {suc _} (finI (fsuc' i)) (finI (fsuc' j)) = i == j
  _==_          _                _               = ⊥

  -- Needed
  rewriteEq : {n : Nat}(C : Fin n -> Set){i j : Fin n} -> i == j -> C j -> C i
  rewriteEq {suc _} C {finI  fzero'  } {finI  fzero'  } eq x = x
  rewriteEq {suc _} C {finI (fsuc' i)} {finI (fsuc' j)} eq x = rewriteEq (\z -> C (fsuc z)) eq x
  rewriteEq {suc _} C {finI (fsuc' _)} {finI fzero'   } () _
  rewriteEq {suc _} C {finI fzero'   } {finI (fsuc' _)} () _
  rewriteEq {zero}  C {finI ()}        {_}              _  _

data Expr (n : Nat) : Set where
  eVar : Fin n -> Expr n
  eApp : Expr n -> Expr n -> Expr n

module ExprEq where

  infix 5 _==_

  _==_ : {n : Nat} -> Expr n -> Expr n -> Set
  eVar i     == eVar j     = FinEq._==_ i j
  eApp e1 e2 == eApp e3 e4 = e1 == e3 /\ e2 == e4
  _          == _          = ⊥

  rewriteEq : {n : Nat}(C : Expr n -> Set){r s : Expr n} -> r == s -> C s -> C r
  rewriteEq C {eVar i    } {eVar j    } eq x = FinEq.rewriteEq (\z -> C (eVar z)) eq x
  rewriteEq C {eApp e1 e2} {eApp e3 e4} (andI eq13 eq24) x =
    rewriteEq (\z -> C (eApp z e2)) eq13 (
      rewriteEq (\z -> C (eApp e3 z)) eq24 x
    )
  rewriteEq C {eVar _} {eApp _ _} () _
  rewriteEq C {eApp _ _} {eVar _  } () _

-- checking args of rewriteEq
-- args of rewriteEq =
--   [Mixed, Unused, Mixed, Mixed, Unused, StrictPos]
-- Computing polarity of Polarity.ExprEq.rewriteEq
-- Polarity of Polarity.ExprEq.rewriteEq from positivity:
--   [Invariant,Nonvariant,Invariant,Invariant,Nonvariant,Covariant]
-- Refining polarity with type  {n : Nat} (C : Expr n → Set)
--                              {r s : Expr n} →
--                              r == s → C s → C r
-- Polarity of Polarity.ExprEq.rewriteEq: [Invariant,Invariant,Invariant,Invariant,Nonvariant,Covariant]

-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Polarity.hs:235

-- -}
-- -}


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.Multivariate.EquivCarac.An[Am[X]]-Anm[X] where

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

open import Cubical.Data.Nat using (ℕ) renaming (_+_ to _+n_)
open import Cubical.Data.Vec
open import Cubical.Data.Vec.OperationsNat
open import Cubical.Data.Sigma

open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly

private variable
  ℓ ℓ' : Level

module Comp-Poly-nm
  (Acr@(A , Astr) : CommRing ℓ)
  (n m : ℕ)
  where

  private
    PAm   = PolyCommRing Acr m
    PAn+m = PolyCommRing Acr (n +n m)
    PAmn  = PolyCommRing (PolyCommRing Acr m) n

  open CommRingStr

-----------------------------------------------------------------------------
-- direct sens

  PAmn→PAn+m-base : (v : Vec ℕ n) → Poly Acr m → Poly Acr (n +n m)
  PAmn→PAn+m-base v = DS-Rec-Set.f _ _ _ _ trunc
                       (0r (snd PAn+m))
                       (λ v' a → base (v ++ v') a)
                       (_+_ (snd PAn+m))
                       (+Assoc (snd PAn+m))
                       (+IdR (snd PAn+m))
                       (+Comm (snd PAn+m))
                       (λ v' → base-neutral (v ++ v'))
                       (λ v' a b → base-add (v ++ v') a b)

  PAmn→PAn+m : Poly (PolyCommRing Acr m) n → Poly Acr (n +n m)
  PAmn→PAn+m = DS-Rec-Set.f _ _ _ _ trunc
                (0r (snd PAn+m))
                PAmn→PAn+m-base
                (_+_ (snd PAn+m))
                (+Assoc (snd PAn+m))
                (+IdR (snd PAn+m))
                (+Comm (snd PAn+m))
                (λ _ → refl)
                λ _ _ _ → refl

-----------------------------------------------------------------------------
-- Converse sens

  PAn+m→PAmn : Poly Acr (n +n m) → Poly (PolyCommRing Acr m) n
  PAn+m→PAmn = DS-Rec-Set.f _ _ _ _ trunc
                (0r (snd PAmn))
                (λ v a → base (fst (sep-vec n m v)) (base (snd (sep-vec n m v)) a))
                (_+_ (snd PAmn))
                (+Assoc (snd PAmn))
                (+IdR (snd PAmn))
                (+Comm (snd PAmn))
                (λ v → (cong (base (fst (sep-vec n m v))) (base-neutral _)) ∙ (base-neutral _))
                 λ v a b → base-add _ _ _ ∙ cong (base (fst (sep-vec n m v))) (base-add _ _ _)

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

  e-sect : (P : Poly Acr (n +n m)) → PAmn→PAn+m (PAn+m→PAmn P) ≡ P
  e-sect = DS-Ind-Prop.f _ _ _ _ (λ _ → trunc _ _)
           refl
           (λ v a → cong (λ X → base X a) (sep-vec-id n m v))
           (λ {U V} ind-U ind-V → cong₂ (_+_ (snd PAn+m)) ind-U ind-V)

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

  e-retr : (P : Poly (PolyCommRing Acr m) n) → PAn+m→PAmn (PAmn→PAn+m P) ≡ P
  e-retr = DS-Ind-Prop.f _ _ _ _ (λ _ → trunc  _ _)
           refl
           (λ v → DS-Ind-Prop.f _ _ _ _ (λ _ → trunc _ _)
                   (sym (base-neutral _))
                   (λ v' a → cong₂ base (sep-vec-fst n m v v')
                                          (cong (λ X → base X a) (sep-vec-snd n m v v')))
                   λ {U V} ind-U ind-V → (cong₂ (_+_ (snd PAmn)) ind-U ind-V) ∙ (base-add _ _ _))
           (λ {U V} ind-U ind-V → cong₂ (_+_ (snd PAmn)) ind-U ind-V)

-----------------------------------------------------------------------------
-- Morphism of ring

  PAmn→PAn+m-pres1 : PAmn→PAn+m (1r (snd PAmn)) ≡ 1r (snd PAn+m)
  PAmn→PAn+m-pres1 = cong (λ X → base X (1r Astr)) (rep-concat n m 0 )

  PAmn→PAn+m-pres+ : (P Q : Poly (PolyCommRing Acr m) n) →
                      PAmn→PAn+m (snd PAmn ._+_ P Q) ≡ snd PAn+m ._+_ (PAmn→PAn+m P) (PAmn→PAn+m Q)
  PAmn→PAn+m-pres+ = λ _ _ → refl

  PAmn→PAn+m-pres· : (P Q : Poly (PolyCommRing Acr m) n) →
                      PAmn→PAn+m ( snd PAmn ._·_ P Q) ≡ snd PAn+m ._·_ (PAmn→PAn+m P) (PAmn→PAn+m Q)
  PAmn→PAn+m-pres· =
    DS-Ind-Prop.f _ _ _ _ (λ _ → isPropΠ (λ _ → trunc _ _))
    (λ Q → refl)
    (λ v → DS-Ind-Prop.f _ _ _ _ (λ _ → isPropΠ (λ _ → trunc _ _))
            (λ Q → cong (λ X → PAmn→PAn+m (snd PAmn ._·_ X Q)) (base-neutral v))
            (λ v' a → DS-Ind-Prop.f _ _ _ _ (λ _ → trunc _ _)
                       refl
                       (λ w → DS-Ind-Prop.f _ _ _ _ (λ _ → trunc _ _)
                               refl
                               (λ w' b → cong (λ X → base X (Astr ._·_ a b)) (+n-vec-concat _ _ _ _ _ _))
                               λ {U V} ind-U ind-V → cong (λ X → PAmn→PAn+m (snd PAmn ._·_ (base v (base v' a)) X))
                                                           (sym (base-add _ _ _))
                                                      ∙ cong₂ (snd PAn+m ._+_) ind-U ind-V
                                                      ∙ sym (cong (λ X → snd PAn+m ._·_ (PAmn→PAn+m (base v (base v' a)))
                                                                  (PAmn→PAn+m X)) (base-add _ _ _)))
                       λ {U V} ind-U ind-V → cong₂ (snd PAn+m ._+_) ind-U ind-V)
            λ {U V} ind-U ind-V Q → cong (λ X → PAmn→PAn+m (snd PAmn ._·_ X Q)) (sym (base-add _ _ _))
                                     ∙ cong₂ (snd PAn+m ._+_) (ind-U Q) (ind-V Q)
                                     ∙ sym (cong (λ X → snd PAn+m ._·_ (PAmn→PAn+m X) (PAmn→PAn+m Q)) (base-add _ _ _)))
    λ {U V} ind-U ind-V Q → cong₂ (_+_ (snd PAn+m)) (ind-U Q) (ind-V Q)

-----------------------------------------------------------------------------
-- Ring Equivalence

module _ (A' : CommRing ℓ) (n m : ℕ) where

  open Comp-Poly-nm A' n m

  CRE-PolyN∘M-PolyN+M : CommRingEquiv (PolyCommRing (PolyCommRing A' m) n) (PolyCommRing A' (n +n m))
  fst CRE-PolyN∘M-PolyN+M = isoToEquiv is
    where
    is : Iso _ _
    Iso.fun is = PAmn→PAn+m
    Iso.inv is = PAn+m→PAmn
    Iso.rightInv is = e-sect
    Iso.leftInv is = e-retr

  snd CRE-PolyN∘M-PolyN+M = makeIsRingHom PAmn→PAn+m-pres1 PAmn→PAn+m-pres+ PAmn→PAn+m-pres·


module Numeral.Natural.Sequence.Proofs where

import      Lvl
open import Data
open import Data.Either as Either using (_‖_)
open import Data.Either.Equiv as Either
open import Data.Either.Equiv.Id
open import Data.Either.Proofs as Either
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Data.Tuple.Equiv as Tuple
open import Data.Tuple.Equiv.Id
open import Data.Tuple.Proofs as Tuple
open import Functional
open import Function.Proofs
open import Lang.Inspect
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.DivMod.Proofs
open import Numeral.Natural.Oper.FlooredDivision
open import Numeral.Natural.Sequence
open import Relator.Equals renaming (_≡_ to Id)
open import Relator.Equals.Proofs.Equiv{T = ℕ}
open import Relator.Equals.Proofs.Equivalence using () renaming ([≡]-equiv to Id-equiv ; [≡]-to-function to Id-to-function)
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Function.Domain.Proofs
import      Structure.Function.Names as Names
open import Structure.Operator
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ ℓₑ₄ ℓₑ₅ ℓₑ₆ : Lvl.Level
private variable n : ℕ
private variable A : Type{ℓ}
private variable B : Type{ℓ}

alternate₂-args : ∀{n} → (alternate₂(n ⋅ 2) ≡ Either.Left(n)) ∧ (alternate₂(𝐒(n ⋅ 2)) ≡ Either.Right(n))
alternate₂-args {0}       = [∧]-intro [≡]-intro [≡]-intro
alternate₂-args {1}       = [∧]-intro [≡]-intro [≡]-intro
alternate₂-args {𝐒(𝐒(n))} with [∧]-intro l r ← alternate₂-args {n} rewrite l rewrite r = [∧]-intro [≡]-intro [≡]-intro

alternate₂-values : ∀{n} → (alternate₂(n) ≡ Either.Left(n ⌊/⌋ 2)) ∨ (alternate₂(n) ≡ Either.Right(n ⌊/⌋ 2))
alternate₂-values {0}       = Either.Left  [≡]-intro
alternate₂-values {1}       = Either.Right [≡]-intro
alternate₂-values {𝐒(𝐒(n))} with alternate₂-values {n}
... | Either.Left  eq rewrite eq = Either.Left  [≡]-intro
... | Either.Right eq rewrite eq = Either.Right [≡]-intro

instance
  alternate₂-inverseₗ : Inverseₗ(alternate₂)(unalternate₂)
  alternate₂-inverseₗ = intro proof where
    p : ∀{e} → (unalternate₂(Either.map 𝐒 𝐒 e) ≡ 𝐒(𝐒(unalternate₂ e)))
    p {Either.Left  _} = [≡]-intro
    p {Either.Right _} = [≡]-intro

    proof : Names.Inverses(unalternate₂)(alternate₂)
    proof {0}       = [≡]-intro
    proof {1}       = [≡]-intro
    proof {𝐒(𝐒(n))} =
      (unalternate₂ ∘ alternate₂) (𝐒(𝐒(n)))        🝖[ _≡_ ]-[]
      unalternate₂(alternate₂(𝐒(𝐒(n))))            🝖[ _≡_ ]-[]
      unalternate₂(Either.map 𝐒 𝐒 (alternate₂ n)) 🝖[ _≡_ ]-[ p{alternate₂ n} ]
      𝐒(𝐒(unalternate₂(alternate₂ n)))             🝖[ _≡_ ]-[ congruence₁(𝐒) (congruence₁(𝐒) (proof {n})) ]
      𝐒(𝐒(n))                                      🝖-end

instance
  alternate₂-inverseᵣ : Inverseᵣ(alternate₂)(unalternate₂)
  alternate₂-inverseᵣ = intro proof where
    proof : Names.Inverses(alternate₂)(unalternate₂)
    proof {Either.Left  n} = [∧]-elimₗ alternate₂-args
    proof {Either.Right n} = [∧]-elimᵣ alternate₂-args

instance
  alternate₂-inverse : Inverse(alternate₂)(unalternate₂)
  alternate₂-inverse = [∧]-intro alternate₂-inverseₗ alternate₂-inverseᵣ

instance
  alternate₂-bijective : Bijective(alternate₂)
  alternate₂-bijective = invertible-to-bijective ⦃ inver = [∃]-intro unalternate₂ ⦃ [∧]-intro Id-to-function alternate₂-inverse ⦄ ⦄

pairIndexing-def3 : ∀{a b} → (pairIndexing a (𝐒 b) ≡ 𝐒(pairIndexing (𝐒 a) b))
pairIndexing-def3 {𝟎}   {b} = [≡]-intro
pairIndexing-def3 {𝐒 a} {b} = [≡]-intro

instance
  {-# TERMINATING #-}
  pairIndexing-inverseₗ : Inverseₗ(Tuple.uncurry pairIndexing)(diagonalFilling)
  pairIndexing-inverseₗ = intro proof where
    proof : Names.Inverses(diagonalFilling)(Tuple.uncurry pairIndexing)
    proof {𝟎    , 𝟎}    = [≡]-intro
    proof {𝐒(a) , 𝟎}    with diagonalFilling(pairIndexing 𝟎 a) | proof {𝟎 , a}
    ... | 𝟎    , 𝟎    | [≡]-intro = [≡]-intro
    ... | 𝟎    , 𝐒(d) | [≡]-intro = [≡]-intro
    ... | 𝐒(c) , 𝟎    | ()
    ... | 𝐒(c) , 𝐒(d) | ()
    {-# CATCHALL #-}
    proof {a    , 𝐒(b)} rewrite pairIndexing-def3 {a}{b} with diagonalFilling(pairIndexing (𝐒(a)) b) | proof {𝐒(a) , b}
    ... | 𝟎    , 𝟎    | ()
    ... | 𝟎    , 𝐒(d) | ()
    ... | 𝐒(c) , 𝟎    | [≡]-intro = [≡]-intro
    ... | 𝐒(c) , 𝐒(d) | [≡]-intro = [≡]-intro

instance
  pairIndexing-inverseᵣ : Inverseᵣ(Tuple.uncurry pairIndexing)(diagonalFilling)
  pairIndexing-inverseᵣ = intro proof where
    proof : Names.Inverses(Tuple.uncurry pairIndexing)(diagonalFilling)
    proof {𝟎}    = [≡]-intro
    proof {𝐒(n)} with diagonalFilling n | proof {n}
    ... | (𝟎    , b) | q = congruence₁(𝐒) q
    ... | (𝐒(a) , b) | q rewrite pairIndexing-def3 {a}{b} = congruence₁(𝐒) q

instance
  pairIndexing-inverse : Inverse(Tuple.uncurry pairIndexing)(diagonalFilling)
  pairIndexing-inverse = [∧]-intro pairIndexing-inverseₗ pairIndexing-inverseᵣ

instance
  diagonalFilling-inverse : Inverse(diagonalFilling)(Tuple.uncurry pairIndexing)
  diagonalFilling-inverse = [∧]-intro pairIndexing-inverseᵣ pairIndexing-inverseₗ

instance
  pairIndexing-bijective : Bijective(Tuple.uncurry pairIndexing)
  pairIndexing-bijective = invertible-to-bijective ⦃ inver = [∃]-intro diagonalFilling ⦃ [∧]-intro [≡]-function pairIndexing-inverse ⦄ ⦄

instance
  diagonalFilling-bijective : Bijective(diagonalFilling)
  diagonalFilling-bijective = invertible-to-bijective ⦃ inver = [∃]-intro (Tuple.uncurry pairIndexing) ⦃ [∧]-intro Id-to-function diagonalFilling-inverse ⦄ ⦄

tupleIndexing-inverseᵣ : Inverseᵣ(tupleIndexing{𝐒(n)})(spaceFilling{𝐒(n)})
tupleIndexing-inverseᵣ{n} = intro(proof{n}) where
  proof : ∀{n} → Names.Inverses(tupleIndexing{𝐒(n)})(spaceFilling{𝐒(n)})
  proof {𝟎}   {_} = [≡]-intro
  proof {𝐒(n)}{i} with (x , y) ← diagonalFilling i | intro [≡]-intro ← inspect diagonalFilling i =
    pairIndexing x (tupleIndexing{𝐒(n)} (spaceFilling{𝐒(n)} y)) 🝖[ _≡_ ]-[ congruence₁(pairIndexing(x)) (proof{n}{y}) ]
    pairIndexing x y                                            🝖[ _≡_ ]-[ inverseᵣ(Tuple.uncurry pairIndexing)(diagonalFilling) ]
    i                                                           🝖-end

tupleIndexing-inverseₗ : Inverseₗ(tupleIndexing{𝐒(n)})(spaceFilling{𝐒(n)})
tupleIndexing-inverseₗ{n} = intro(proof{n}) where
  proof : ∀{n} → Names.Inverses(spaceFilling{𝐒(n)})(tupleIndexing{𝐒(n)})
  proof {𝟎}   {_}      = [≡]-intro
  proof {𝐒(n)}{x , xs} =
    Tuple.mapRight spaceFilling (diagonalFilling (pairIndexing x (tupleIndexing xs))) 🝖[ _≡_ ]-[ congruence₁(Tuple.mapRight spaceFilling) (inverseₗ(Tuple.uncurry pairIndexing)(diagonalFilling)) ]
    Tuple.mapRight spaceFilling (x , tupleIndexing xs)                                🝖[ _≡_ ]-[]
    (x , spaceFilling(tupleIndexing xs))                                              🝖[ _≡_ ]-[ congruence₂ᵣ(_,_)(x) (proof{n}{xs}) ]
    (x , xs)                                                                          🝖-end

instance
  tupleIndexing-inverse : Inverse(tupleIndexing{𝐒(n)})(spaceFilling{𝐒(n)})
  tupleIndexing-inverse = [∧]-intro tupleIndexing-inverseₗ tupleIndexing-inverseᵣ

instance
  tupleIndexing-bijective : Bijective(tupleIndexing{𝐒(n)})
  tupleIndexing-bijective = invertible-to-bijective ⦃ inver = [∃]-intro spaceFilling ⦃ [∧]-intro [≡]-function tupleIndexing-inverse ⦄ ⦄

module _
  ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  ⦃ equiv-AB : Equiv{ℓₑ}(A ‖ B) ⦄ ⦃ ext-AB : Either.Extensionality ⦃ equiv-A ⦄ ⦃ equiv-B ⦄ (equiv-AB) ⦄
  {af : ℕ → A} ⦃ bij-af : Bijective ⦃ [≡]-equiv ⦄ ⦃ equiv-A ⦄ (af) ⦄
  {bf : ℕ → B} ⦃ bij-bf : Bijective ⦃ [≡]-equiv ⦄ ⦃ equiv-B ⦄ (bf) ⦄
  where

  instance
    interleave-bijective : Bijective(interleave af bf)
    interleave-bijective = [∘]-bijective ⦃ bij-f = Either.map-bijective ⦄ ⦃ bij-g = alternate₂-bijective ⦄

module _
  ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  ⦃ equiv-AB : Equiv{ℓₑ}(A ⨯ B) ⦄ ⦃ ext-AB : Tuple.Extensionality ⦃ equiv-A ⦄ ⦃ equiv-B ⦄ (equiv-AB) ⦄
  {af : ℕ → A} ⦃ bij-af : Bijective ⦃ [≡]-equiv ⦄ ⦃ equiv-A ⦄ (af) ⦄
  {bf : ℕ → B} ⦃ bij-bf : Bijective ⦃ [≡]-equiv ⦄ ⦃ equiv-B ⦄ (bf) ⦄
  where

  instance
    pair-bijective : Bijective ⦃ [≡]-equiv ⦄ ⦃ equiv-AB ⦄ (pair af bf)
    pair-bijective = [∘]-bijective ⦃ bij-f = Tuple.map-bijective ⦃ Id-equiv ⦄ ⦃ Id-equiv ⦄ ⦃ equiv-A ⦄ ⦃ equiv-B ⦄ ⦃ Id-equiv ⦄ ⦄ ⦃ bij-g = diagonalFilling-bijective ⦄

{- TODO: Old stuff. Probably okay to delete? But maybe it could be handy when the new interleave is used (it is similar to the old one)?

-- Interleaves two sequences into one, alternating between the elements from each sequence.
interleave : (ℕ → A) → (ℕ → B) → (ℕ → (A ‖ B))
interleave af bf 𝟎        = Either.Left(af(𝟎))
interleave af bf (𝐒 𝟎)    = Either.Right(bf(𝟎))
interleave af bf (𝐒(𝐒 n)) = interleave (af ∘ 𝐒) (bf ∘ 𝐒) n

private variable af : ℕ → A
private variable bf : ℕ → B

interleave-left : ∀{n} → (interleave af bf (2 ⋅ n) ≡ Either.Left(af(n)))
interleave-left {n = 𝟎}   = [≡]-intro
interleave-left {n = 𝐒 n} = interleave-left {n = n}

interleave-right : ∀{n} → (interleave af bf (𝐒(2 ⋅ n)) ≡ Either.Right(bf(n)))
interleave-right {n = 𝟎}   = [≡]-intro
interleave-right {n = 𝐒 n} = interleave-right {n = n}

interleave-values : ∀{n} → (interleave af bf n ≡ Either.Left(af(n ⌊/⌋ 2))) ∨ (interleave af bf n ≡ Either.Right(bf(n ⌊/⌋ 2)))
interleave-values                    {n = 𝟎}      = [∨]-introₗ [≡]-intro
interleave-values                    {n = 𝐒 𝟎}    = [∨]-introᵣ [≡]-intro
interleave-values {af = af}{bf = bf} {n = 𝐒(𝐒 n)} = interleave-values {af = af ∘ 𝐒}{bf = bf ∘ 𝐒} {n = n}

interleave-left-args : ⦃ _ : Injective(af) ⦄ → ∀{m n} → (interleave af bf m ≡ Either.Left(af(n))) ↔ (m ≡ 2 ⋅ n)
interleave-left-args {n = n} = [↔]-intro (\{[≡]-intro → interleave-left{n = n}}) r where
  r : ⦃ _ : Injective(af) ⦄ → ∀{m n} → (interleave af bf m ≡ Either.Left(af(n))) → (m ≡ 2 ⋅ n)
  r {af = af} {m = 𝟎}{n = n} = congruence₁(2 ⋅_) ∘ injective(af) ∘ injective(Either.Left) ⦃ Left-injective ⦄
  r {af = af}{bf = bf} {m = 𝐒 (𝐒 m)}{n = 𝟎} p with interleave-values {af = af}{bf = bf}{n = 𝐒(𝐒 m)}
  ... | [∨]-introₗ v with () ← injective(af) (injective(Either.Left) ⦃ Left-injective ⦄ (symmetry(_≡_) v 🝖 p))
  ... | [∨]-introᵣ v with () ← symmetry(_≡_) v 🝖 p
  r {af = af} {m = 𝐒 (𝐒 m)}{n = 𝐒 n} p = congruence₁(𝐒 ∘ 𝐒) (r ⦃ [∘]-injective {f = af} ⦄{m = m}{n = n} p)

interleave-right-args : ⦃ _ : Injective(bf) ⦄ → ∀{m n} → (interleave af bf m ≡ Either.Right(bf(n))) ↔ (m ≡ 𝐒(2 ⋅ n))
interleave-right-args {n = n} = [↔]-intro (\{[≡]-intro → interleave-right{n = n}}) r where
  r : ⦃ _ : Injective(bf) ⦄ → ∀{m n} → (interleave af bf m ≡ Either.Right(bf(n))) → (m ≡ 𝐒(2 ⋅ n))
  r {bf = bf} {m = 𝐒 𝟎}{n = n} = congruence₁(𝐒 ∘ (2 ⋅_)) ∘ injective(bf) ∘ injective(Either.Right) ⦃ Right-injective ⦄
  r {bf = bf}{af = af} {m = 𝐒 (𝐒 m)}{n = 𝟎} p with interleave-values {af = af}{bf = bf}{n = 𝐒(𝐒 m)}
  ... | [∨]-introₗ v with () ← symmetry(_≡_) v 🝖 p
  ... | [∨]-introᵣ v with () ← injective(bf) (injective(Either.Right) ⦃ Right-injective ⦄ (symmetry(_≡_) v 🝖 p))
  r {bf = bf} {m = 𝐒 (𝐒 m)}{n = 𝐒 n} p = congruence₁(𝐒 ∘ 𝐒) (r ⦃ [∘]-injective {f = bf} ⦄{m = m}{n = n} p)

interleave-step-left : ⦃ _ : Injective(af) ⦄ → ∀{m n} → (interleave af bf m ≡ Either.Left(af(n))) ↔ (interleave af bf (𝐒(𝐒 m)) ≡ Either.Left(af(𝐒 n)))
interleave-step-left{af = iaf}{bf = ibf}{m = m}{n = n} = [↔]-intro (l{af = iaf}{bf = ibf}{m = m}{n = n}) (r{af = iaf}{bf = ibf}{m = m}{n = n}) where
  l : ⦃ _ : Injective(af) ⦄ → ∀{m n} → (interleave af bf m ≡ Either.Left(af(n))) ← (interleave af bf (𝐒(𝐒 m)) ≡ Either.Left(af(𝐒 n)))
  l {af = af}          {m = 𝟎}      {n}   = congruence₁(Either.Left) ∘ congruence₁(af) ∘ injective(𝐒) ∘ injective(af) ∘ injective(Either.Left) ⦃ Left-injective ⦄
  l {af = af}{bf = bf} {m = 𝐒 (𝐒 m)}{𝟎}   p with interleave-values {af = af}{bf = bf}{n = 𝐒(𝐒(𝐒(𝐒 m)))}
  ... | [∨]-introₗ v with () ← injective(af) (injective(Either.Left) ⦃ Left-injective ⦄ (symmetry(_≡_) v 🝖 p))
  ... | [∨]-introᵣ v with () ← symmetry(_≡_) v 🝖 p
  l {af = af}          {m = 𝐒 (𝐒 m)}{𝐒 n} = l {af = af ∘ 𝐒} ⦃ [∘]-injective {f = af} ⦄ {m = m}{n}

  r : ⦃ _ : Injective(af) ⦄ → ∀{m n} → (interleave af bf m ≡ Either.Left(af(n))) → (interleave af bf (𝐒(𝐒 m)) ≡ Either.Left(af(𝐒 n)))
  r {af = af}          {m = 𝟎}      {n}   = congruence₁(Either.Left) ∘ congruence₁(af) ∘ congruence₁(𝐒) ∘ injective(af) ∘ injective(Either.Left) ⦃ Left-injective ⦄
  r {af = af}{bf = bf} {m = 𝐒(𝐒 m)} {𝟎}   p with interleave-values {af = af}{bf = bf}{n = 𝐒(𝐒 m)}
  ... | [∨]-introₗ v with () ← injective(af) (injective(Either.Left) ⦃ Left-injective ⦄ (symmetry(_≡_) v 🝖 p))
  ... | [∨]-introᵣ v with () ← symmetry(_≡_) v 🝖 p
  r {af = af}          {m = 𝐒(𝐒 m)} {𝐒 n} = r {af = af ∘ 𝐒} ⦃ [∘]-injective {f = af} ⦄ {m = m}{n}

postulate interleave-injective-raw : ⦃ inj-af : Injective(af) ⦄ → ⦃ inj-bf : Injective(bf) ⦄ → Names.Injective(interleave af bf)
{-interleave-injective-raw {af = af} {bf = bf} {x = 𝟎}       {y = 𝟎}       fxfy = [≡]-intro
interleave-injective-raw {af = af} {bf = bf} {x = 𝟎}       {y = 𝐒 (𝐒 y)} fxfy = symmetry(_≡_) ([↔]-to-[→] (interleave-left-args {bf = bf}) (symmetry(_≡_) fxfy))
interleave-injective-raw {af = af} {bf = bf} {x = 𝐒 (𝐒 x)} {y = 𝟎}       fxfy = [↔]-to-[→] (interleave-left-args {bf = bf}) fxfy
interleave-injective-raw {af = af} {bf = bf} {x = 𝐒 𝟎} {y = 𝐒 𝟎} fxfy = [≡]-intro
interleave-injective-raw {af = af} {bf = bf} {x = 𝐒 𝟎} {y = 𝐒 (𝐒 y)} fxfy = symmetry(_≡_) ([↔]-to-[→] (interleave-right-args {bf = bf}{af = af}) (symmetry(_≡_) fxfy))
interleave-injective-raw {af = af} {bf = bf} {x = 𝐒 (𝐒 x)} {y = 𝐒 𝟎} fxfy = [↔]-to-[→] (interleave-right-args {bf = bf}{af = af}) fxfy
interleave-injective-raw {af = af} {bf = bf} {x = 𝐒 (𝐒 x)} {y = 𝐒 (𝐒 y)} fxfy with interleave-values {af = af ∘ 𝐒}{bf = bf ∘ 𝐒}{n = x} | interleave-values {af = af ∘ 𝐒}{bf = bf ∘ 𝐒}{n = y}
... | [∨]-introₗ p | [∨]-introₗ q = {!congruence₁(𝐒) (injective(af) (injective(Either.Left) (symmetry(_≡_) p 🝖 fxfy 🝖 q)))!} -- TODO: interleave-left and a proof of the division algorihm would work here instead of using interleave-values. Or alternatively, use this, multiply by 2, prove the divisibilities for both cases so that each case have division as inverse of multiplication
... | [∨]-introₗ p | [∨]-introᵣ q = {!!}
... | [∨]-introᵣ p | [∨]-introₗ q = {!!}
... | [∨]-introᵣ p | [∨]-introᵣ q = {!congruence₁(𝐒) (injective(bf) (injective(Either.Right) (symmetry(_≡_) p 🝖 fxfy 🝖 q)))!}
-}

instance
  interleave-injective : ⦃ inj-af : Injective(af) ⦄ → ⦃ inj-bf : Injective(bf) ⦄ → Injective(interleave af bf)
  interleave-injective = intro interleave-injective-raw

instance
  interleave-surjective : ⦃ surj-af : Surjective(af) ⦄ → ⦃ surj-bf : Surjective(bf) ⦄ → Surjective(interleave af bf)
  Surjective.proof (interleave-surjective {af = af}{bf = bf}) {[∨]-introₗ y} with surjective(af){y}
  ... | [∃]-intro n ⦃ [≡]-intro ⦄ = [∃]-intro(2 ⋅ n) ⦃ interleave-left{n = n} ⦄
  Surjective.proof (interleave-surjective {af = af}{bf = bf}) {[∨]-introᵣ y} with surjective(bf){y}
  ... | [∃]-intro n ⦃ [≡]-intro ⦄ = [∃]-intro(𝐒(2 ⋅ n)) ⦃ interleave-right{n = n} ⦄

instance
  interleave-bijective : ⦃ bij-af : Bijective(af) ⦄ → ⦃ bij-bf : Bijective(bf) ⦄ → Bijective(interleave af bf)
  interleave-bijective {af = af}{bf = bf} = injective-surjective-to-bijective(interleave af bf) where
    instance
      inj-af : Injective(af)
      inj-af = bijective-to-injective af
    instance
      inj-bf : Injective(bf)
      inj-bf = bijective-to-injective bf
    instance
      surj-af : Surjective(af)
      surj-af = bijective-to-surjective af
    instance
      surj-bf : Surjective(bf)
      surj-bf = bijective-to-surjective bf
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some code related to propositional equality that relies on the K
-- rule
------------------------------------------------------------------------

{-# OPTIONS --with-K --safe #-}

module Relation.Binary.PropositionalEquality.WithK where

open import Axiom.UniquenessOfIdentityProofs.WithK
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.Core

------------------------------------------------------------------------
-- Re-exporting safe erasure function

-- ≡-erase ignores its `x ≡ y` argument and reduces to refl whenever
-- x and y are judgmentally equal. This is useful when the computation
-- producing the proof `x ≡ y` is expensive.

open import Agda.Builtin.Equality.Erase
  using ()
  renaming ( primEraseEquality to ≡-erase )
  public

------------------------------------------------------------------------
-- Proof irrelevance

≡-irrelevant : ∀ {a} {A : Set a} → Irrelevant {A = A} _≡_
≡-irrelevant = uip

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.0

≡-irrelevance = ≡-irrelevant
{-# WARNING_ON_USAGE ≡-irrelevance
"Warning: ≡-irrelevance was deprecated in v1.0.
Please use ≡-irrelevant instead."
#-}


{-# OPTIONS --cubical-compatible #-}

module WithoutK2 where

-- Equality defined with two indices.

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

K : {A : Set} (P : {x : A} → x ≡ x → Set) →
    (∀ x → P (refl x)) →
    ∀ {x} (x≡x : x ≡ x) → P x≡x
K P p (refl x) = p x


{-

A parameterized family of structures S can be combined into a single structure:
X ↦ (a : A) → S a X

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Parameterized where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Functions.FunExtEquiv
open import Cubical.Foundations.SIP

module _ {ℓ ℓ₁ ℓ₂} (A : Type ℓ) where

  ParamStructure : (S : A → Type ℓ₁ → Type ℓ₂)
    → Type ℓ₁ → Type (ℓ-max ℓ ℓ₂)
  ParamStructure S X = (a : A) → S a X

  ParamEquivStr : {S : A → Type ℓ₁ → Type ℓ₂} {ℓ₃ : Level}
    → (∀ a → StrEquiv (S a) ℓ₃) → StrEquiv (ParamStructure S) (ℓ-max ℓ ℓ₃)
  ParamEquivStr ι (X , l) (Y , m) e = ∀ a → ι a (X , l a) (Y , m a) e

  ParamUnivalentStr : {S : A → Type ℓ₁ → Type ℓ₂} {ℓ₃ : Level}
    (ι : ∀ a → StrEquiv (S a) ℓ₃) (θ : ∀ a → UnivalentStr (S a) (ι a))
    → UnivalentStr (ParamStructure S) (ParamEquivStr ι)
  ParamUnivalentStr ι θ e = compEquiv (equivPi λ a → θ a e) funExtEquiv


module #14 where

{-
  Why do the induction principles for identity types not allow us to construct a
  function f : ∏(x:A) ∏(p:x=x) (p = refl[x]) with the defining equation
              f(x,refl[x]) :≡ refl[refl[x]]   ?
-}

{-
  To use induction here we need proof that refl x ≡ p then use refl as a relation to prove
  that refl x ≡ p again.  It's a circular construction.
-}

open import Relation.Binary.PropositionalEquality

{- Closest I could get this into Agda.  Does not compile.
f : {A : Set} → (x : A) → (p : x ≡ x) → p ≡ refl x
f x (refl x) = refl (refl x)
-}


{-

This file contains:
- Rijke finiteness is closed under forming Σ-type.

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

module Cubical.Data.FinType.Sigma where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv

open import Cubical.HITs.SetTruncation as Set
open import Cubical.HITs.SetTruncation.Fibers

open import Cubical.Data.Nat
open import Cubical.Data.Sigma

open import Cubical.Data.FinSet
open import Cubical.Data.FinSet.DecidablePredicate
open import Cubical.Data.FinSet.Constructors
open import Cubical.Data.FinSet.Quotients
open import Cubical.Data.FinType

open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidablePropositions
  hiding (DecProp) renaming (DecProp' to DecProp)

private
  variable
    ℓ ℓ' : Level

module _
  (X : Type ℓ )
  (Y : Type ℓ') (h : isFinType 1 Y)
  (f : X → Y)
  (q : (y : Y) → isFinType 0 (fiber f y)) where

  private
    ∥f∥₂ : ∥ X ∥₂ → ∥ Y ∥₂
    ∥f∥₂ = Set.map f

  module _ (y : Y) where

    isDecPropFiberRel : (x x' : ∥ fiber f y ∥₂) → isDecProp (fiberRel f y x x')
    isDecPropFiberRel x x' =
      isDecPropRespectEquiv (fiberRel1≃2 f y x x')
        (isDecProp∃ (_ , h .snd y y) (λ _ → _ , isDecProp≡ (_ , q y) _ _))

    isFinSetFiber∥∥₂' : isFinSet (fiber ∥f∥₂ ∣ y ∣₂)
    isFinSetFiber∥∥₂' =
      EquivPresIsFinSet (∥fiber∥₂/R≃fiber∥∥₂ f y)
        (isFinSetQuot (_ , q y) (fiberRel f y) (isEquivRelFiberRel f y) isDecPropFiberRel)

  isFinSetFiber∥∥₂ : (y : ∥ Y ∥₂) → isFinSet (fiber ∥f∥₂ y)
  isFinSetFiber∥∥₂ = Set.elim (λ _ → isProp→isSet isPropIsFinSet) isFinSetFiber∥∥₂'

  isFinType0Total : isFinType 0 X
  isFinType0Total = isFinSetTotal ∥ X ∥₂ (∥ Y ∥₂ , h .fst) ∥f∥₂ isFinSetFiber∥∥₂

module _
  (X : FinType ℓ 1)
  (Y : X .fst → FinType ℓ' 0) where

  isFinType0Σ : isFinType 0 (Σ (X .fst) (λ x → Y x .fst))
  isFinType0Σ =
    isFinType0Total (Σ (X .fst) (λ x → Y x .fst)) (X .fst) (X .snd) fst
      (λ x → EquivPresIsFinType 0 (fiberProjEquiv _ _ x) (Y x .snd))

-- the main result

isFinTypeΣ : {n : ℕ}
  (X : FinType ℓ (1 + n))
  (Y : X .fst → FinType ℓ' n)
  → isFinType n (Σ (X .fst) (λ x → Y x .fst))
isFinTypeΣ {n = 0} = isFinType0Σ
isFinTypeΣ {n = suc n} X Y .fst =
  isFinType0Σ (_ , isFinTypeSuc→isFinType1 {n = suc n} (X .snd))
    (λ x → _ , isFinType→isFinType0 {n = suc n} (Y x .snd))
isFinTypeΣ {n = suc n} X Y .snd a b =
  EquivPresIsFinType n (ΣPathTransport≃PathΣ a b)
    (isFinTypeΣ {n = n} (_ , X .snd .snd _ _) (λ _ → _ , Y _ .snd .snd _ _))


module Optics.Iso where
open import Agda.Primitive using (Level; _⊔_; lsuc)
open import Function.Equality using (Π)
open import Function.Inverse using (_↔_; inverse; Inverse; _InverseOf_)
open import Relation.Binary.PropositionalEquality using (_≡_; →-to-⟶; refl)

open import Category.Functor.Arr
open import Category.Functor.Const
open import Category.Profunctor
open import Category.Profunctor.Star
open import Category.Profunctor.Joker
open import Optics

Iso : ∀ {l} (S T A B : Set l) → Set (lsuc l)
Iso = Optic ProfunctorImp

module Iso {l} {S T A B : Set l} (iso : Iso S T A B) where
  get : S → A
  get = getOptic S T A B (starProfunctor constFunctor) iso
  put : B → T
  put = putOptic S T A B (jokerProfunctor arrFunctor) iso

record LawfulIsoImp {l} {S A : Set l} (iso' : Iso S S A A) : Set (lsuc l) where
  open Iso iso'
  field
    putget : ∀ (s : S) → put (get s) ≡ s
    getput : ∀ (a : A) → get (put a) ≡ a

module LawfulIso {l} {S A : Set l} {iso' : Iso S S A A} (isLawful : LawfulIsoImp iso') where
  open Iso iso' public
  iso : Iso S S A A
  iso = iso'
  open LawfulIsoImp isLawful public

isoIso : ∀ {S A : Set} {iso : Iso S S A A} → (i : LawfulIsoImp iso) → S ↔ A
isoIso {S} {A} i = inverse to from from∘to to∘from
  where
    open LawfulIso i
    to = get
    from = put
    from∘to : (s : S) → from (to s) ≡ s
    from∘to = putget
    to∘from : (a : A) → to (from a) ≡ a
    to∘from = getput

invLawfulIso : ∀ {l} {S A : Set l} {get : S → A} {put : A → S} → (→-to-⟶ get) InverseOf (→-to-⟶ put) ↔ LawfulIsoImp (λ p → Profunctor.dimap p get put)
invLawfulIso = inverse invertibleIsLawful lawfulIsInvertible (λ _ → refl) (λ _ → refl)
  where
    invertibleIsLawful : ∀ {l} {S A : Set l} {get : S → A} {put : A → S} → (→-to-⟶ get) InverseOf (→-to-⟶ put) → LawfulIsoImp (λ p → Profunctor.dimap p get put)
    invertibleIsLawful i = record
      { putget = right-inverse-of
      ; getput = left-inverse-of
      } where
        open _InverseOf_ i

    lawfulIsInvertible : ∀ {l} {S A : Set l} {get : S → A} {put : A → S} → LawfulIsoImp (λ p → Profunctor.dimap p get put) → (→-to-⟶ get) InverseOf (→-to-⟶ put)
    lawfulIsInvertible isLawful = record
      { left-inverse-of = getput
      ; right-inverse-of = putget
      }
      where open LawfulIso isLawful


module eq-reas-nouni {A : Set} where

  open import eq

  infix  1 begin_
  infixr 2 _equiv[]_ _equiv[_]_
  infix  3 _qed

  begin_ : ∀ {x y : A}
    → x ≡ y
    -----
    → x ≡ y
  begin x≡y  =  x≡y

  _equiv[]_ : ∀ (x : A) {y : A}
    → x ≡ y
    -----
    → x ≡ y
  x equiv[] x≡y  =  x≡y

  _equiv[_]_ : ∀ (x : A) {y z : A}
    → x ≡ y
    → y ≡ z
    -----
    → x ≡ z
  x equiv[ x≡y ] y≡z  =  trans x≡y y≡z

  _qed : ∀ (x : A)
    -----
    → x ≡ x
  x qed  =  refl


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

open import HoTT
open import homotopy.SuspSectionDecomp
open import homotopy.CofiberComp
open import homotopy.SmashIsCofiber

module homotopy.SuspProduct where

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

  private
    i₁ : X ⊙→ X ⊙× Y
    i₁ = ((λ x → (x , pt Y)) , idp)

    i₂ : Y ⊙→ X ⊙× Y
    i₂ = ((λ y → (pt X , y)) , idp)

    j₂ : de⊙ (⊙Cofiber i₁) → de⊙ Y
    j₂ = CofiberRec.f (pt Y) snd (λ x → idp)

  ⊙eq : ⊙Susp (X ⊙× Y) ⊙≃ ⊙Susp X ⊙∨ (⊙Susp Y ⊙∨ ⊙Susp (X ⊙∧ Y))
  ⊙eq =
    ⊙∨-emap (⊙ide (⊙Susp X))
      (⊙∨-emap (⊙ide (⊙Susp Y))
        (⊙Susp-emap (Smash-⊙equiv-Cof X Y ⊙⁻¹ ⊙∘e CofiberComp.⊙eq i₁ i₂)))
    ⊙∘e ⊙∨-emap (⊙ide (⊙Susp X))
          (≃-to-⊙≃ (SuspSectionDecomp.eq (⊙cfcod' i₁ ⊙∘ i₂) j₂ (λ y → idp))
                   (! $ ap winl $ merid (pt Y)))
    ⊙∘e ≃-to-⊙≃ (SuspSectionDecomp.eq i₁ fst (λ x → idp))
                (! $ ap winl $ merid (pt X))


{-

A parameterized family of structures S can be combined into a single structure:
X ↦ (a : A) → S a X

This is more general than Structures.Function in that S can vary in A.

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Parameterized where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Functions.FunExtEquiv
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Univalence

private
  variable
    ℓ ℓ₁ ℓ₁' : Level

module _ {ℓ₀} (A : Type ℓ₀) where

  ParamStructure : (S : A → Type ℓ → Type ℓ₁)
    → Type ℓ → Type (ℓ-max ℓ₀ ℓ₁)
  ParamStructure S X = (a : A) → S a X

  ParamEquivStr : {S : A → Type ℓ → Type ℓ₁}
    → (∀ a → StrEquiv (S a) ℓ₁') → StrEquiv (ParamStructure S) (ℓ-max ℓ₀ ℓ₁')
  ParamEquivStr ι (X , l) (Y , m) e = ∀ a → ι a (X , l a) (Y , m a) e

  paramUnivalentStr : {S : A → Type ℓ → Type ℓ₁}
    (ι : ∀ a → StrEquiv (S a) ℓ₁') (θ : ∀ a → UnivalentStr (S a) (ι a))
    → UnivalentStr (ParamStructure S) (ParamEquivStr ι)
  paramUnivalentStr ι θ e = compEquiv (equivΠCod λ a → θ a e) funExtEquiv

  paramEquivAction : {S : A → Type ℓ → Type ℓ₁}
    → (∀ a → EquivAction (S a)) → EquivAction (ParamStructure S)
  paramEquivAction α e = equivΠCod (λ a → α a e)

  paramTransportStr : {S : A → Type ℓ → Type ℓ₁}
    (α : ∀ a → EquivAction (S a)) (τ : ∀ a → TransportStr (α a))
    → TransportStr (paramEquivAction α)
  paramTransportStr {S = S} α τ e f =
    funExt λ a →
    τ a e (f a)
    ∙ cong (λ fib → transport (λ i → S (fib .snd (~ i)) (ua e i)) (f (fib .snd i1)))
      (isContrSingl a .snd (_ , sym (transportRefl a)))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by decidable total orders
------------------------------------------------------------------------

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

open import Relation.Binary

module Relation.Binary.Properties.DecTotalOrder
  {d₁ d₂ d₃} (DT : DecTotalOrder d₁ d₂ d₃) where

open DecTotalOrder DT hiding (trans)

import Relation.Binary.Construct.Converse as Converse
import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ as ToStrict
import Relation.Binary.Properties.TotalOrder totalOrder as TotalOrderProperties
open import Relation.Nullary using (¬_)

------------------------------------------------------------------------
-- _≥_ - the flipped relation is also a total order

open TotalOrderProperties public
  using
  ( _≥_
  ; ≥-refl
  ; ≥-reflexive
  ; ≥-trans
  ; ≥-antisym
  ; ≥-total
  ; ≥-isPreorder
  ; ≥-isPartialOrder
  ; ≥-isTotalOrder
  ; ≥-preorder
  ; ≥-poset
  ; ≥-totalOrder
  )

≥-isDecTotalOrder : IsDecTotalOrder _≈_ _≥_
≥-isDecTotalOrder = Converse.isDecTotalOrder isDecTotalOrder

≥-decTotalOrder : DecTotalOrder _ _ _
≥-decTotalOrder = record
  { isDecTotalOrder = ≥-isDecTotalOrder
  }

open DecTotalOrder ≥-decTotalOrder public
  using () renaming (_≤?_ to _≥?_)

------------------------------------------------------------------------
-- _<_ - the strict version is a strict total order

open TotalOrderProperties public
  using
  ( _<_
  ; <-resp-≈
  ; <-respʳ-≈
  ; <-respˡ-≈
  ; <-irrefl
  ; <-asym
  ; <-trans
  ; <-isStrictPartialOrder
  ; <-strictPartialOrder
  ; <⇒≉
  ; ≤∧≉⇒<
  ; <⇒≱
  ; ≤⇒≯
  ; ≰⇒>
  )

<-isStrictTotalOrder : IsStrictTotalOrder _≈_ _<_
<-isStrictTotalOrder = ToStrict.<-isStrictTotalOrder₂ isDecTotalOrder

<-strictTotalOrder : StrictTotalOrder _ _ _
<-strictTotalOrder = record
  { isStrictTotalOrder = <-isStrictTotalOrder
  }

open StrictTotalOrder <-strictTotalOrder public
  using () renaming (compare to <-compare)

≮⇒≥ : ∀ {x y} → ¬ (x < y) → y ≤ x
≮⇒≥ = ToStrict.≮⇒≥ Eq.sym _≟_ reflexive total

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.2

strictTotalOrder = <-strictTotalOrder
{-# WARNING_ON_USAGE strictTotalOrder
"Warning: strictTotalOrder was deprecated in v1.2.
Please use <-strictTotalOrder instead."
#-}


-- {-# OPTIONS -v impossible:100 -v tc.lhs.imp:100 #-}
-- {-# OPTIONS -v impossible:100 -v tc.cover:20 #-}
{-# OPTIONS --copatterns #-}
module Copatterns where

open import Common.Equality

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B
open _×_

pair : {A B : Set} → A → B → A × B
fst (pair a b) = a
snd (pair a b) = b

swap : {A B : Set} → A × B → B × A
fst (swap p) = snd p
snd (swap p) = fst p

swap3 : {A B C : Set} → A × (B × C) → C × (B × A)
fst (swap3 t)       = snd (snd t)
fst (snd (swap3 t)) = fst (snd t)
snd (snd (swap3 t)) = fst t

-- should also work if we shuffle the clauses
swap4 : {A B C D : Set} → A × (B × (C × D)) → D × (C × (B × A))
fst (snd (swap4 t))       = fst (snd (snd t))
snd (snd (snd (swap4 t))) = fst t
fst (swap4 t)             = snd (snd (snd t))
fst (snd (snd (swap4 t))) = fst (snd t)

-- multiple clauses with abstractions

fswap3 : {A B C X : Set} → (X → A) × ((X → B) × C) → (X → C) × (X → (B × A))
fst (fswap3 t) x       = snd (snd t)
fst (snd (fswap3 t) y) = fst (snd t) y
snd (snd (fswap3 t) z) = fst t z

-- State monad example

-- The State newtype

record State (S A : Set) : Set where
  constructor state
  field
    runState : S → A × S
open State

-- The Monad type class

record Monad (M : Set → Set) : Set1 where
  constructor monad
  field
    return : {A : Set}   → A → M A
    _>>=_  : {A B : Set} → M A → (A → M B) → M B

module NoInstance where

-- State is an instance of Monad

  stateMonad : {S : Set} → Monad (State S)
  runState (Monad.return stateMonad a  ) s  = a , s
  runState (Monad._>>=_  stateMonad m k) s₀ =
    let a , s₁ = runState m s₀
    in  runState (k a) s₁

  module InstantiatedModule {S : Set} where

    open Monad (stateMonad {S})

    leftId : {A B : Set}(a : A)(k : A → State S B) →
      (return a >>= k) ≡ k a
    leftId a k = refl

    rightId : {A B : Set}(m : State S A) →
      (m >>= return) ≡ m
    rightId m = refl

    assoc : {A B C : Set}(m : State S A)(k : A → State S B)(l : B → State S C) →
      ((m >>= k) >>= l) ≡ (m >>= λ a → (k a >>= l))
    assoc m k l = refl

  module VisibleArgument where

    open Monad

    leftId : {A B S : Set}(a : A)(k : A → State S B) →
      (_>>=_ stateMonad (return stateMonad a) k) ≡ k a
    leftId a k = refl

    rightId : {A B S : Set}(m : State S A) →
      (_>>=_ stateMonad m (return stateMonad)) ≡ m
    rightId m = refl

    assoc : {A B C S : Set}(m : State S A)(k : A → State S B)(l : B → State S C) →
       (_>>=_ stateMonad (_>>=_ stateMonad m k) l) ≡
      (_>>=_ stateMonad m λ a → _>>=_ stateMonad (k a) l)
    assoc m k l = refl

  module HiddenArgument where

    return : ∀ {M}{dict : Monad M}{A : Set} → A → M A
    return {dict = dict} = Monad.return dict

    _>>=_ :  ∀ {M}{dict : Monad M}{A B : Set} → M A → (A → M B) → M B
    _>>=_ {dict = dict} = Monad._>>=_ dict

    leftId : {A B S : Set}(a : A)(k : A → State S B) →
      (_>>=_ {dict = stateMonad} (return {dict = stateMonad} a) k) ≡ k a
    leftId a k = refl

  {- LOTS OF YELLOW:

    leftId : {A B S : Set}(a : A)(k : A → State S B) → (return {dict = stateMonad {S}} a >>= k) ≡ k a
    leftId a k = refl

    rightId : {A B S : Set}(m : State S A) → (m >>= return) ≡ m
    rightId m = refl

    assoc : {A B C S : Set}(m : State S A)(k : A → State S B)(l : B → State S C) →
       ((m >>= k) >>= l) ≡ (m >>= λ a → k a >>= l)
    assoc m k l = refl
  -}

{- WORKS NOT YET
module InstanceArgument where

  open Monad {{...}}

  -- State is an instance of Monad

  -- TODO: this does not work with hidden argument yet
  stateMonad : {S : Set} → Monad (State S)
  runState (return {{stateMonad {S}}} a  ) s  = a , s
  runState (_>>=_  {{stateMonad {S}}} m k) s₀ =
    let a , s₁ = runState m s₀
    in  runState (k a) s₁

  _~_ : {S A : Set} → State S A → State S A → Set
  m ~ m' = ∀ {s} → runState m s ≡ runState m' s

  -- the following identities should also hold with _≡_
  -- but that would need a back-translation of copatterns to
  -- record expressions, which does not preserve SN for recursive cases
  leftId : {A B S : Set}(a : A)(k : A → State S B) → (return a >>= k) ≡ k a
  leftId a k = refl

  rightId : {A B S : Set}(m : State S A) → (m >>= return) ~ m
  rightId m = refl

  assoc : {A B C S : Set}(m : State S A)(k : A → State S B)(l : B → State S C) →
     ((m >>= k) >>= l) ~ (m >>= λ a → k a >>= l)
  assoc m k l = refl
-}