module StateSizedIO.Base where

open import Size
open import SizedIO.Base

open import Data.Product

record IOInterfaceˢ  : Set₁ where
  field
    IOStateˢ   :  Set
    Commandˢ   :  IOStateˢ → Set
    Responseˢ  :  (s : IOStateˢ) → (m : Commandˢ s) → Set
    IOnextˢ    :  (s : IOStateˢ) → (m : Commandˢ s) → (Responseˢ s m)
                  → IOStateˢ
open IOInterfaceˢ public

record Interfaceˢ : Set₁ where
 field
  Stateˢ   :  Set
  Methodˢ  :  Stateˢ → Set
  Resultˢ  :  (s : Stateˢ) → (m : Methodˢ s) → Set
  nextˢ    :  (s : Stateˢ) → (m : Methodˢ s) → (Resultˢ s m)
              → Stateˢ
open Interfaceˢ public

{-
module _
 (ioinf   : IOInterface) --  (let C  = Command ioi)  (let R   = Response ioi)
 (objinf  : Interfaceˢ)   {-(let S = Stateˢ oi)-} --(let M  = Methodˢ objinf)    (let Rt  = Resultˢ objinf)
                               -- (let n = nextˢ objinf)
 where
 @BEGIN@IOObject
  record IOObjectˢ (i : Size) (s : Stateˢ objinf) : Set where
    coinductive
    field
 HIDE-END
      method :
        ∀{j : Size< i}
        (m : Methodˢ objinf s) →
        IO ioinf ∞ ( Σ[ r ∈ objinf .Resultˢ s m ]
                     IOObjectˢ j (objinf .nextˢ s m r))
  @END
-}

module _
  (ioinf  : IOInterface)
  (oinf  :  Interfaceˢ)
  where
 record IOObjectˢ (i : Size) (s : oinf .Stateˢ) : Set where
  coinductive
  field
   method :
    ∀{j : Size< i}
     (m : oinf .Methodˢ s) →
     IO ioinf ∞ (Σ[  r ∈ oinf .Resultˢ s m ]
                     IOObjectˢ j (oinf .nextˢ s m r))

module _
  (ioi   : IOInterface) (let C  = Command ioi)  (let R   = Response ioi)
  (oi  : Interfaceˢ)  (let S = Stateˢ oi) (let M  = Methodˢ oi)    (let Rt  = Resultˢ oi)
                                (let n = nextˢ oi)
  where
  record IOObjectˢ- (i : Size) (s : S) : Set where
    coinductive
    field
      method : ∀{j : Size< i} (m : M s) → IO ioi ∞ (Rt s m )

open IOObjectˢ public
open IOObjectˢ- public

module _ (I : IOInterfaceˢ )
         (let S = IOStateˢ I) (let C = Commandˢ I)
         (let R = Responseˢ I) (let n = IOnextˢ I)
           where

  mutual
    record IOˢ (i : Size)  (A : S → Set) (s : S) : Set where
      coinductive
      -- constructor delay
      field
        forceˢ : {j : Size< i} → IOˢ' j A s

    data IOˢ' (i : Size)  (A : S → Set) (s : S) : Set where
      doˢ'      :  (c : C s) (f : (r : R s c) → IOˢ i A (n s c r)) → IOˢ' i A s
      returnˢ'  :  (a : A s) → IOˢ' i A s

    data IOˢ+ (i : Size)  (A : S → Set) (s : S) : Set where
      doˢ' : (c : C s)  (f : (r : R s c) → IOˢ i A (n s c r)) → IOˢ+ i A s

open IOˢ public

delayˢ : {i : Size}{I : IOInterfaceˢ}{A : IOStateˢ I → Set}{s : IOStateˢ I} → IOˢ' I i A s → IOˢ I (↑ i) A s
delayˢ p .forceˢ = p

module _  {I : IOInterfaceˢ }
          (let S = IOStateˢ I) (let C = Commandˢ I)
          (let R = Responseˢ I) (let n = IOnextˢ I)
           where
  returnˢ : ∀{i}{A : S → Set} (s : S) (a : A s) → IOˢ I i A s
  returnˢ s a .forceˢ = returnˢ' a

  -- 2017-04-05: Argument s is hidden now.
  doˢ : ∀{i}{A : S → Set} {s : S} (c : C s)
           (f : (r : R s c) → IOˢ I i A (n s c r))
           → IOˢ I i A s
  doˢ c f .forceˢ = doˢ' c f

  mutual
    fmapˢ : (i : Size) → {A B : S → Set} → (f : (s : S) → A s → B s)
            → (s : S)
            → IOˢ I i A s
            → IOˢ I i B s
    fmapˢ i {A} {B} f s p .forceˢ {j} = fmapˢ' j {A} {B} f s (p .forceˢ {j})

    fmapˢ' : (i : Size) → {A B : S → Set} → (f : (s : S) → A s → B s)
            → (s : S)
            → IOˢ' I i A s
            → IOˢ' I i B s
    fmapˢ' i {A} {B} f s (doˢ' c f₁) = doˢ' c (λ r → fmapˢ i {A} {B} f (IOnextˢ I s c r)  (f₁ r))
    fmapˢ' i {A} {B} f s (returnˢ' a) = returnˢ' (f s a)


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

open import HoTT
open import cohomology.Exactness
open import cohomology.Theory
open import cohomology.CofiberSequence

module cohomology.LongExactSequence {i} (CT : CohomologyTheory i)
  (n : ℤ) {X Y : Ptd i} (f : fst (X ⊙→ Y)) where

open CohomologyTheory CT

long-exact-diag : ExactDiag _ _
long-exact-diag =
  C n (⊙Susp (⊙Cof f))  ⟨ CF-hom n (⊙susp-fmap (⊙cfcod f)) ⟩→
  C n (⊙Susp Y)         ⟨ CF-hom n (⊙susp-fmap f)          ⟩→
  C n (⊙Susp X)         ⟨ CF-hom n ⊙ext-glue               ⟩→
  C n (⊙Cof f)          ⟨ CF-hom n (⊙cfcod f)              ⟩→
  C n Y                 ⟨ CF-hom n f                       ⟩→
  C n X                 ⊣|

long-exact-cofiber : ExactSeq long-exact-diag
long-exact-cofiber = transport
  (λ {(_ , g , h , k) → ExactSeq $
    _ ⟨ CF-hom n k ⟩→ _ ⟨ CF-hom n h ⟩→ _ ⟨ CF-hom n g ⟩→
    _ ⟨ CF-hom n (⊙cfcod f) ⟩→ _ ⟨ CF-hom n f ⟩→ _ ⊣|})
  (cofiber-sequence f)
  (exact-build
    (_ ⟨ CF-hom n (⊙cfcod⁴ f) ⟩→ _ ⟨ CF-hom n (⊙cfcod³ f) ⟩→
     _ ⟨ CF-hom n (⊙cfcod² f) ⟩→ _ ⟨ CF-hom n (⊙cfcod f) ⟩→
     _ ⟨ CF-hom n f ⟩→ _ ⊣|)
    (C-exact n (⊙cfcod³ f)) (C-exact n (⊙cfcod² f))
    (C-exact n (⊙cfcod f)) (C-exact n f))


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

-- Pi combinators inspired by duals and traced monoidal categories

module PiPointedFracTrace where

open import Data.Unit
open import Data.Sum
open import Data.Product
open import Relation.Binary.PropositionalEquality

open import PiPointedFrac

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

dual : {A B : ∙𝕌} → (f : A ∙⟶ B) →  (Recipᵤ B ∙⟶ Recipᵤ A)
dual {A} {B} f = ∙uniti⋆l ∙⊚ (η A ∙⊗ ∙id⟷) ∙⊚ ((∙Singᵤ f ∙⊗ ∙id⟷) ∙⊗ ∙id⟷) ∙⊚
                 ∙assocr⋆ ∙⊚ (∙id⟷ ∙⊗ ∙swap⋆) ∙⊚ ∙assocl⋆ ∙⊚ (ε B ∙⊗ ∙id⟷) ∙⊚ ∙unite⋆l

-- name, coname
name : {A B : ∙𝕌} → (f : A ∙⟶ B) → ∙𝟙 ∙⟶ Singᵤ B ∙×ᵤ Recipᵤ A
name {A} {B} f = η A ∙⊚ (∙Singᵤ f ∙⊗ ∙id⟷)

coname : {A B : ∙𝕌} → (f : A ∙⟶ B) → Singᵤ A ∙×ᵤ Recipᵤ B ∙⟶ ∙𝟙
coname {A} {B} f = (∙Singᵤ f ∙⊗ ∙id⟷) ∙⊚ ε B

-- and 'trace' reveals something neat: we can't choose just any random 'a' and 'c'
-- to start with, but we need that make a coherence choice of a and c !!
trace : {A B C : ∙𝕌} → (f : A ∙×ᵤ C ∙⟶ B ∙×ᵤ C) → A ∙⟶ B
trace {A} {B} {C} f =
  ∙uniti⋆r ∙⊚                -- A ×ᵤ 1
  (return _ ∙⊗ η C) ∙⊚       -- A ×ᵤ (C ×ᵤ 1/C)
  ∙assocl⋆ ∙⊚                -- (A ×ᵤ C) ×ᵤ 1/C
  (tensor ∙⊗ ∙id⟷) ∙⊚    -- bring in the ●
  (∙Singᵤ f ∙⊗ ∙id⟷) ∙⊚  -- (B ×ᵤ C) ×ᵤ 1/C
  (untensor ∙⊗ ∙id⟷) ∙⊚  -- bring out the ●
  ∙assocr⋆ ∙⊚                -- B ×ᵤ (C ×ᵤ 1/C)
  (extract _ ∙⊗ ε C) ∙⊚
  ∙unite⋆r

-- Trace terminates!  The type C is pointed with point c; trace uses c
-- as the initial value for C. So f gets two values (a,c). It can do
-- whatever to produce (b',c'). But f is reversible so it is limited
-- to essentially either id or swap. Makes sense???

𝔹 : 𝕌
𝔹 = 𝟙 +ᵤ 𝟙

𝔽 𝕋 : ⟦ 𝔹 ⟧
𝔽 = inj₁ tt
𝕋 = inj₂ tt

zz1 : (A : 𝕌) (v : ⟦ A ⟧) → Σ (⟦ A ⟧ → ⟦ A ⟧) (λ f → f v ≡ v)
zz1 A v = ∙eval (trace {A # v} ∙swap⋆)

zz3 : (A : 𝕌) (v : ⟦ A ⟧) (T : ∙𝕌) → Σ (⟦ A ⟧ → ⟦ A ⟧) (λ f → f v ≡ v)
zz3 A v T = ∙eval (trace {A # v} {_} {T} ∙id⟷)

-- There are more thing you can put in trace as long as c is the fixpoint
NOT : 𝔹 ⟷ 𝔹
NOT = swap₊

CONTROLLED : {A : 𝕌} → (A ⟷ A) → 𝔹 ×ᵤ A ⟷ 𝔹 ×ᵤ A
CONTROLLED c = dist ⊚ (id⟷ ⊕ (id⟷ ⊗ c)) ⊚ factor

CNOT : 𝔹 ×ᵤ 𝔹 ⟷ 𝔹 ×ᵤ 𝔹
CNOT = CONTROLLED NOT

ex1 : ∀ {b} → 𝔹 # b ∙⟶ 𝔹 # b
ex1 = trace {C = 𝔹 # 𝔽} (∙swap⋆ ∙⊚ ∙#times ∙⊚ ∙c CNOT ∙⊚ ∙times# ∙⊚ ∙swap⋆)

-- Example in Sec. 4.3 from Abramsky's paper
-- http://www.cs.ox.ac.uk/files/341/calco05.pdf
∙q : {A1 A2 A3 A4 B1 B2 B3 B4 : ∙𝕌}
   → (f1 : A1 ∙⟶ B2)
   → (f2 : A2 ∙⟶ B4)
   → (f3 : A3 ∙⟶ B3)
   → (f4 : A4 ∙⟶ B1)
   → A1 ∙×ᵤ (A2 ∙×ᵤ (A3 ∙×ᵤ A4)) ∙⟶ B1 ∙×ᵤ (B2 ∙×ᵤ (B3 ∙×ᵤ B4))
∙q {A1} {A2} {A3} {A4} {B1} {B2} {B3} {B4} f1 f2 f3 f4 =
   (f1 ∙⊗ (f2 ∙⊗ (f3 ∙⊗ f4))) ∙⊚
   ∙assocl⋆ ∙⊚
   ∙swap⋆ ∙⊚
   ∙swap⋆ ∙⊗ ∙id⟷ ∙⊚
   ∙assocr⋆ ∙⊚ (∙id⟷ ∙⊗ ∙assocl⋆) ∙⊚
   ∙id⟷ ∙⊗ (∙swap⋆ ∙⊗ ∙id⟷ ∙⊚ ∙assocr⋆)

∙q' : {A1 U2 U3 U4 B1 : ∙𝕌}
    → (f1 : A1 ∙⟶ U2)
    → (f2 : U2 ∙⟶ U4)
    → (f3 : U3 ∙⟶ U3)
    → (f4 : U4 ∙⟶ B1)
    → A1 ∙⟶ B1
∙q' f1 f2 f3 f4 = trace (∙q f1 f2 f3 f4)

_⊸_ : (A B : ∙𝕌) → ∙𝕌
A ⊸ B = Recipᵤ A ∙×ᵤ Singᵤ B

id⊸ : {A : ∙𝕌} → (A ⊸ A) ∙⟶ ∙𝟙
id⊸ {A} = ∙swap⋆ ∙⊚ ε A

comp⊸ : (A B C : ∙𝕌) → (A ⊸ B) ∙×ᵤ (B ⊸ C) ∙⟶ (A ⊸ C)
comp⊸ A B C = ∙assocr⋆ ∙⊚
              ∙id⟷ ∙⊗ ∙assocl⋆ ∙⊚
              ∙id⟷ ∙⊗ (ε B ∙⊗ ∙id⟷) ∙⊚
              ∙id⟷ ∙⊗ ∙unite⋆l

app : (A B : ∙𝕌) → (A ⊸ B) ∙×ᵤ Singᵤ A ∙⟶ Singᵤ B
app A B = ∙swap⋆ ∙⊗ ∙id⟷ ∙⊚
          ∙assocr⋆ ∙⊚ (∙id⟷ ∙⊗ (∙swap⋆ ∙⊚ ε A)) ∙⊚
          ∙unite⋆r

-- B/A × D/C ⟷ B × D / A × C
dist×/ : {A B C D : ∙𝕌} → (A ⊸ B) ∙×ᵤ (C ⊸ D) ∙⟶ ((A ∙×ᵤ C) ⊸ (B ∙×ᵤ D))
dist×/ {A} {B} {C} {D} = ∙assocr⋆ ∙⊚
                         (∙id⟷ ∙⊗ ∙assocl⋆) ∙⊚
                         ∙id⟷ ∙⊗ (∙swap⋆ ∙⊗ ∙id⟷) ∙⊚
                         (∙id⟷ ∙⊗ ∙assocr⋆) ∙⊚ ∙assocl⋆ ∙⊚
                         c ∙⊗ tensor
  where
  c : (Recipᵤ A ∙×ᵤ Recipᵤ C) ∙⟶ Recipᵤ (A ∙×ᵤ C)
  c = ∙uniti⋆l ∙⊚
      (η (A ∙×ᵤ C) ∙⊗ ∙id⟷) ∙⊚
      (∙swap⋆ ∙⊗ ∙id⟷) ∙⊚
      ∙assocr⋆ ∙⊚
      (∙id⟷ ∙⊗ (untensor ∙⊗ ∙id⟷)) ∙⊚
      (∙id⟷ ∙⊗ (∙swap⋆ ∙⊗ ∙id⟷)) ∙⊚
      (∙id⟷ ∙⊗ ∙assocr⋆) ∙⊚
      (∙id⟷ ∙⊗ (∙id⟷ ∙⊗ ∙assocl⋆)) ∙⊚
      (∙id⟷ ∙⊗ (∙id⟷ ∙⊗ ((ε A ∙⊗ ∙id⟷) ∙⊚ ∙unite⋆l))) ∙⊚
      (∙id⟷ ∙⊗ ε C) ∙⊚
      ∙unite⋆r

-- 1/A x 1/B <-> 1 / (A x B)
rev× : {A B : ∙𝕌} → (A ⊸ ∙𝟙) ∙×ᵤ (B ⊸ ∙𝟙) ∙⟶ (A ∙×ᵤ B ⊸ ∙𝟙)
rev× {A} {B} = dist×/ ∙⊚ (∙id⟷ ∙⊗ ∙Singᵤ ∙unite⋆l)

-- (A <-> B) -> (1/A <-> 1/B)
rev : {A B : ∙𝕌} → (f : A ∙⟶ B) → Recipᵤ B ∙⟶ Recipᵤ A
rev {A} {B} f = dual f

-- A <-> 1 / (1/A)
revrev : {A : ∙𝕌} → Singᵤ A ∙⟶ Recipᵤ (Recipᵤ A)
revrev {A} = ∙uniti⋆r ∙⊚
             ∙id⟷ ∙⊗ η (Recipᵤ A) ∙⊚
             ∙assocl⋆ ∙⊚
             ((∙id⟷ ∙⊗ extract (Recipᵤ A)) ∙⊗ ∙id⟷) ∙⊚
             (ε A ∙⊗ ∙id⟷) ∙⊚
             ∙unite⋆l


{-

This file contains:

- Fibers of induced map between set truncations is the set truncation of fibers
  modulo a certain equivalence relation defined by π₁ of the base.

-}
{-# OPTIONS --safe #-}
module Cubical.HITs.SetTruncation.Fibers where

open import Cubical.HITs.SetTruncation.Base

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Path
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv

open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation as Prop
open import Cubical.HITs.SetTruncation as Set
open import Cubical.HITs.SetQuotients as SetQuot

open import Cubical.Relation.Binary

private
  variable
    ℓ ℓ' : Level

module _
  {X : Type ℓ }
  {Y : Type ℓ'}
  (f : X → Y) where

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

  module _ (y : Y) where

    open Iso

    isSetFiber∥∥₂ : isSet (fiber ∥f∥₂ ∣ y ∣₂)
    isSetFiber∥∥₂ = isOfHLevelΣ 2 squash₂ (λ _ → isProp→isSet (squash₂ _ _))

    fiberRel : ∥ fiber f y ∥₂ → ∥ fiber f y ∥₂ → Type ℓ
    fiberRel a b = Set.map fst a ≡ Set.map fst b

    private
      proj : ∥ fiber f y ∥₂ / fiberRel → ∥ X ∥₂
      proj = SetQuot.rec squash₂ (Set.map fst) (λ _ _ p → p)

    ∥fiber∥₂/R→fiber∥∥₂ : ∥ fiber f y ∥₂ / fiberRel → fiber ∥f∥₂ ∣ y ∣₂
    ∥fiber∥₂/R→fiber∥∥₂ = SetQuot.rec isSetFiber∥∥₂ ∥fiber∥₂→fiber∥∥₂ feq
      where
      fiber→fiber∥∥₂ : fiber f y → fiber ∥f∥₂ ∣ y ∣₂
      fiber→fiber∥∥₂ (x , p) = ∣ x ∣₂ , cong ∣_∣₂ p

      ∥fiber∥₂→fiber∥∥₂ : ∥ fiber f y ∥₂ → fiber ∥f∥₂ ∣ y ∣₂
      ∥fiber∥₂→fiber∥∥₂ = Set.rec isSetFiber∥∥₂ fiber→fiber∥∥₂

      feq : (a b : ∥ fiber f y ∥₂) (r : fiberRel a b) → ∥fiber∥₂→fiber∥∥₂ a ≡ ∥fiber∥₂→fiber∥∥₂ b
      feq =
        Set.elim2 (λ _ _ → isProp→isSet (isPropΠ (λ _ → isSetFiber∥∥₂ _ _))) λ _ _ p →
        ΣPathP (p , isSet→isSet' squash₂ _ _ _ _)

    mereFiber→∥fiber∥₂/R : (x : X) → ∥ f x ≡ y ∥ → ∥ fiber f y ∥₂ / fiberRel
    mereFiber→∥fiber∥₂/R x = Prop.rec→Set squash/ (λ p → [ ∣ _ , p ∣₂ ]) (λ _ _ → eq/ _ _ refl)

    fiber∥∥₂→∥fiber∥₂/R : fiber ∥f∥₂ ∣ y ∣₂ → ∥ fiber f y ∥₂ / fiberRel
    fiber∥∥₂→∥fiber∥₂/R =
      uncurry
        (Set.elim (λ _ → isSetΠ λ _ → squash/) λ x p →
          mereFiber→∥fiber∥₂/R x (PathIdTrunc₀Iso .fun p))

    ∥fiber∥₂/R→fiber∥∥₂→fst : (q : ∥ fiber f y ∥₂ / fiberRel) → ∥fiber∥₂/R→fiber∥∥₂ q .fst ≡ proj q
    ∥fiber∥₂/R→fiber∥∥₂→fst =
      SetQuot.elimProp (λ _ → squash₂ _ _)
        (Set.elim (λ _ → isProp→isSet (squash₂ _ _)) (λ _ → refl))

    fiber∥∥₂→∥fiber∥₂/R→proj : (x : fiber ∥f∥₂ ∣ y ∣₂) → proj (fiber∥∥₂→∥fiber∥₂/R x) ≡ x .fst
    fiber∥∥₂→∥fiber∥₂/R→proj =
      uncurry
        (Set.elim (λ _ → isSetΠ λ _ → isProp→isSet (squash₂ _ _)) λ x p →
          Prop.elim {P = λ t → proj (mereFiber→∥fiber∥₂/R x t) ≡ ∣ x ∣₂}
            (λ _ → squash₂ _ _)
            (λ _ → refl)
            (PathIdTrunc₀Iso .fun p))

    ∥fiber∥₂/R→fiber∥∥₂→∥fiber∥₂/R :
      (x : ∥ fiber f y ∥₂ / fiberRel) → fiber∥∥₂→∥fiber∥₂/R (∥fiber∥₂/R→fiber∥∥₂ x) ≡ x
    ∥fiber∥₂/R→fiber∥∥₂→∥fiber∥₂/R =
      SetQuot.elimProp (λ _ → squash/ _ _)
        (Set.elim (λ _ → isProp→isSet (squash/ _ _))
          (λ _ → eq/ _ _ refl))

    fiber∥∥₂→∥fiber∥₂/R→fiber∥∥₂ :
      (x : fiber ∥f∥₂ ∣ y ∣₂) → ∥fiber∥₂/R→fiber∥∥₂ (fiber∥∥₂→∥fiber∥₂/R x) ≡ x
    fiber∥∥₂→∥fiber∥₂/R→fiber∥∥₂ x =
      Σ≡Prop
        (λ _ → squash₂ _ _)
        (∥fiber∥₂/R→fiber∥∥₂→fst (fiber∥∥₂→∥fiber∥₂/R x) ∙ fiber∥∥₂→∥fiber∥₂/R→proj x)

    Iso-∥fiber∥₂/R-fiber∥∥₂ : Iso (∥ fiber f y ∥₂ / fiberRel) (fiber ∥f∥₂ ∣ y ∣₂)
    Iso-∥fiber∥₂/R-fiber∥∥₂ .fun = ∥fiber∥₂/R→fiber∥∥₂
    Iso-∥fiber∥₂/R-fiber∥∥₂ .inv = fiber∥∥₂→∥fiber∥₂/R
    Iso-∥fiber∥₂/R-fiber∥∥₂ .leftInv = ∥fiber∥₂/R→fiber∥∥₂→∥fiber∥₂/R
    Iso-∥fiber∥₂/R-fiber∥∥₂ .rightInv = fiber∥∥₂→∥fiber∥₂/R→fiber∥∥₂

    -- main results

    ∥fiber∥₂/R≃fiber∥∥₂ : ∥ fiber f y ∥₂ / fiberRel ≃ fiber ∥f∥₂ ∣ y ∣₂
    ∥fiber∥₂/R≃fiber∥∥₂ = isoToEquiv Iso-∥fiber∥₂/R-fiber∥∥₂

    -- the relation is an equivalence relation

    open BinaryRelation
    open isEquivRel

    isEquivRelFiberRel : isEquivRel fiberRel
    isEquivRelFiberRel .reflexive _ = refl
    isEquivRelFiberRel .symmetric _ _ = sym
    isEquivRelFiberRel .transitive _ _ _ = _∙_

    -- alternative characterization of the relation in terms of equality in Y and fiber f y

    ∣transport∣ : ∥ y ≡ y ∥₂ → ∥ fiber f y ∥₂ → ∥ fiber f y ∥₂
    ∣transport∣ = Set.rec2 squash₂ (λ s (x , q) → ∣ x , q ∙ s ∣₂)

    fiberRel2 : (x x' : ∥ fiber f y ∥₂) → Type (ℓ-max ℓ ℓ')
    fiberRel2 x x' = ∥ Σ[ s ∈ ∥ y ≡ y ∥₂ ] ∣transport∣ s x ≡ x' ∥

    fiberRel2→1 : ∀ x x' → fiberRel2 x x' → fiberRel x x'
    fiberRel2→1 =
      Set.elim2 (λ _ _ → isSetΠ λ _ → isOfHLevelPath 2 squash₂ _ _) λ _ _ →
      Prop.rec (squash₂ _ _)
        (uncurry
          (Set.elim (λ _ → isSetΠ λ _ → isOfHLevelPath 2 squash₂ _ _) λ _ →
            cong (Set.map fst)))

    fiberRel1→2 : ∀ x x' → fiberRel x x' → fiberRel2 x x'
    fiberRel1→2 =
      Set.elim2 (λ _ _ → isSetΠ λ _ → isProp→isSet squash) λ a b p →
      Prop.rec squash
        (λ q →
          let
            filler = doubleCompPath-filler (sym (a .snd)) (cong f q) (b .snd)
          in
            ∣ ∣ filler i1 ∣₂ , cong ∣_∣₂ (ΣPathP (q , adjustLemma (flipSquare filler))) ∣)
        (PathIdTrunc₀Iso .Iso.fun p)
      where
      adjustLemma : {x y z w : Y} {p : x ≡ y} {q : x ≡ z} {r : z ≡ w} {s : y ≡ w}
        → PathP (λ i → p i ≡ r i) q s
        → PathP (λ i → p i ≡ w) (q ∙ r) s
      adjustLemma {p = p} {q} {r} {s} α i j =
        hcomp
          (λ k → λ
            { (i = i0) → compPath-filler q r k j
            ; (i = i1) → s j
            ; (j = i0) → p i
            ; (j = i1) → r (i ∨ k)})
          (α i j)

    fiberRel1≃2 : ∀ x x' → fiberRel x x' ≃ fiberRel2 x x'
    fiberRel1≃2 _ _ =
      propBiimpl→Equiv (squash₂ _ _) squash (fiberRel1→2 _ _) (fiberRel2→1 _ _)


{-# OPTIONS --cubical --safe --postfix-projections #-}

module Relation.Nullary.Decidable.Logic where

open import Prelude
open import Data.Sum

infixl 7 _&&_
_&&_ : Dec A → Dec B → Dec (A × B)
(x && y) .does = x .does and y .does
(yes x && yes y) .why  = ofʸ (x , y)
(yes x && no  y) .why  = ofⁿ (y ∘ snd)
(no  x && y) .why  = ofⁿ (x ∘ fst)

infixl 6 _||_
_||_ : Dec A → Dec B → Dec (A ⊎ B)
(x || y) .does = x .does or y .does
(yes x || y) .why = ofʸ (inl x)
(no  x || yes y) .why = ofʸ (inr y)
(no  x || no  y) .why = ofⁿ (either x y)

! : Dec A → Dec (¬ A)
! x .does = not (x .does)
! (yes x) .why = ofⁿ (λ z → z x)
! (no  x) .why = ofʸ x


open import Coinduction using ( ♭ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong ; cong₂ )
open import System.IO.Transducers using ( _⇒_ ; inp ; out ; done ; out*' ; _⟫_ ; _⟨&⟩_ ; _⟨&⟩[_]_ ; discard ; π₁ ; π₂ ; ⟦_⟧ ; _≃_ )
open import System.IO.Transducers.Session using ( [] ; _∷_ ; _&_ )
open import System.IO.Transducers.Trace using ( _≤_ ; Trace ; [] ; _∷_ )
open import System.IO.Transducers.Properties.Lemmas using ( cong₃ ; revApp ; out*'-semantics )
open import System.IO.Transducers.Properties.BraidedMonoidal using ( _++_ )
open import System.IO.Transducers.Properties.Category using ( _⟦⟫⟧_ ; ⟫-semantics )

module System.IO.Transducers.Properties.LaxProduct where

open Relation.Binary.PropositionalEquality.≡-Reasoning

_⟦⟨&⟩⟧_ : ∀ {S T U} →
  (f : Trace S → Trace T) → (g : Trace S → Trace U) →
    (Trace S) → (Trace (T & U))
(f ⟦⟨&⟩⟧ g) as = f as ++ g as

_⟦⟨&⟩[_]⟧_ : ∀ {S T U V} →
  (Trace S → Trace T) → (U ≤ V) → (Trace S → Trace U) →
    (Trace S → Trace (T & V))
(f ⟦⟨&⟩[ cs ]⟧ g) as = f as ++ (revApp cs (g as))

⟨&⟩[]-semantics : ∀ {S T U V} →
  (P : S ⇒ T) → (cs : U ≤ V) →  (Q : S ⇒ U) →
    (⟦ P ⟨&⟩[ cs ] Q ⟧ ≃ ⟦ P ⟧ ⟦⟨&⟩[ cs ]⟧ ⟦ Q ⟧)
⟨&⟩[]-semantics (inp {T = []}     F) cs Q         as with ⟦ inp F ⟧ as
⟨&⟩[]-semantics (inp {T = []}     F) cs Q         as    | [] = out*'-semantics cs Q as
⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs (inp G)   []         = refl
⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs (inp G)   (a ∷ as)   = ⟨&⟩[]-semantics (♭ F a) cs (♭ G a) as
⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs (out c Q) as         = ⟨&⟩[]-semantics (inp F) (c ∷ cs) Q as
⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs done      []         = refl
⟨&⟩[]-semantics (inp {T = W ∷ Ts} F) cs done      (a ∷ as)   = ⟨&⟩[]-semantics (♭ F a) (a ∷ cs) done as
⟨&⟩[]-semantics (out b P)            cs Q         as         = cong (_∷_ b) (⟨&⟩[]-semantics P cs Q as)
⟨&⟩[]-semantics (done {[]})          cs Q         []         = out*'-semantics cs Q []
⟨&⟩[]-semantics (done {W ∷ Ts})      cs (inp F)   []         = refl
⟨&⟩[]-semantics (done {W ∷ Ts})      cs (inp F)   (a ∷ as)   = cong (_∷_ a) (⟨&⟩[]-semantics done cs (♭ F a) as)
⟨&⟩[]-semantics (done {W ∷ Ts})      cs (out c Q) as         = ⟨&⟩[]-semantics done (c ∷ cs) Q as
⟨&⟩[]-semantics (done {W ∷ Ts})      cs done      []         = refl
⟨&⟩[]-semantics (done {W ∷ Ts})      cs done      (a ∷ as)   = cong (_∷_ a) (⟨&⟩[]-semantics done (a ∷ cs) done as)

⟨&⟩-semantics : ∀ {S T U} →
  (P : S ⇒ T) → (Q : S ⇒ U) →
    (⟦ P ⟨&⟩ Q ⟧ ≃ ⟦ P ⟧ ⟦⟨&⟩⟧ ⟦ Q ⟧)
⟨&⟩-semantics P Q = ⟨&⟩[]-semantics P [] Q

⟫-dist-⟨&⟩ : ∀ {S T U V} →
  (P : T ⇒ U) → (Q : T ⇒ V) → (R : S ⇒ T) →
    (⟦ R ⟫ (P ⟨&⟩ Q) ⟧ ≃ ⟦ (R ⟫ P) ⟨&⟩ (R ⟫ Q) ⟧)
⟫-dist-⟨&⟩ P Q R as =
  begin
    ⟦ R ⟫ P ⟨&⟩ Q ⟧ as
  ≡⟨ ⟫-semantics R (P ⟨&⟩ Q) as ⟩
    ⟦ P ⟨&⟩ Q ⟧ (⟦ R ⟧ as)
  ≡⟨ ⟨&⟩-semantics P Q (⟦ R ⟧ as) ⟩
    ⟦ P ⟧ (⟦ R ⟧ as) ++ ⟦ Q ⟧ (⟦ R ⟧ as)
  ≡⟨ cong₂ _++_ (sym (⟫-semantics R P as)) (sym (⟫-semantics R Q as)) ⟩
    ⟦ R ⟫ P ⟧ as ++ ⟦ R ⟫ Q ⟧ as
  ≡⟨ sym (⟨&⟩-semantics (R ⟫ P) (R ⟫ Q) as) ⟩
    ⟦ (R ⟫ P) ⟨&⟩ (R ⟫ Q) ⟧ as
  ∎


-- Tactic for proving coprimality.
-- Finds Coprime hypotheses in the context.
module Tactic.Nat.Coprime where

import Agda.Builtin.Nat as Builtin

open import Prelude
open import Control.Monad.Zero
open import Control.Monad.State
open import Container.List
open import Container.Traversable
open import Numeric.Nat
open import Tactic.Reflection
open import Tactic.Reflection.Parse
open import Tactic.Reflection.Quote

open import Tactic.Nat.Coprime.Problem
open import Tactic.Nat.Coprime.Decide
open import Tactic.Nat.Coprime.Reflect

private
  Proof : Problem → Env → Set
  Proof Q ρ with canProve Q
  ... | true  = ⟦ Q ⟧p ρ
  ... | false = ⊤

  erasePrf : ∀ Q {ρ} → ⟦ Q ⟧p ρ → ⟦ Q ⟧p ρ
  erasePrf ([] ⊨ a ⋈ b) Ξ = eraseEquality Ξ
  erasePrf (ψ ∷ Γ ⊨ φ) Ξ = λ H → erasePrf (Γ ⊨ φ) (Ξ H)

  proof : ∀ Q ρ → Proof Q ρ
  proof Q ρ with canProve Q | sound Q
  ... | true  | prf = erasePrf Q (prf refl ρ)
  ... | false | _   = _

  -- For the error message

  unquoteE : List Term → Exp → Term
  unquoteE ρ (atom x) = fromMaybe (lit (nat 0)) (index ρ x)
  unquoteE ρ (e ⊗ e₁) = def₂ (quote _*_) (unquoteE ρ e) (unquoteE ρ e₁)

  unquoteF : List Term → Formula → Term
  unquoteF ρ (a ⋈ b) = def₂ (quote Coprime) (unquoteE ρ a) (unquoteE ρ b)

macro
  auto-coprime : Tactic
  auto-coprime ?hole = withNormalisation true $ do
    goal ← inferType ?hole
    ensureNoMetas goal
    cxt  ← reverse <$> getContext
    (_ , Hyps , Q) , ρ ← runParse (parseProblem (map unArg cxt) goal)
    unify ?hole (def (quote proof) $ map vArg (` Q ∷ quotedEnv ρ ∷ Hyps))
      <|> do
        case Q of λ where
          (Γ ⊨ φ) → typeError (strErr "Cannot prove" ∷
                               termErr (unquoteF ρ φ) ∷
                               strErr "from" ∷
                               punctuate (strErr "and") (map (termErr ∘ unquoteF ρ) Γ))


{-# OPTIONS --safe #-}

module Cubical.Categories.Instances.Sets where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.Properties
open import Cubical.Foundations.Isomorphism
open import Cubical.Data.Unit
open import Cubical.Data.Sigma
open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Categories.NaturalTransformation

open import Cubical.Categories.Limits

open Category

module _ ℓ where
  SET : Category (ℓ-suc ℓ) ℓ
  ob SET = hSet ℓ
  Hom[_,_] SET (A , _) (B , _) = A → B
  id SET x = x
  _⋆_ SET f g x = g (f x)
  ⋆IdL SET f = refl
  ⋆IdR SET f = refl
  ⋆Assoc SET f g h = refl
  isSetHom SET {A} {B} = isSetΠ (λ _ → snd B)

private
  variable
    ℓ ℓ' : Level

open Functor

-- Hom functors
_[-,_] : (C : Category ℓ ℓ') → (c : C .ob) → Functor (C ^op) (SET ℓ')
(C [-, c ]) .F-ob x    = (C [ x , c ]) , C .isSetHom
(C [-, c ]) .F-hom f k = f ⋆⟨ C ⟩ k
(C [-, c ]) .F-id      = funExt λ _ → C .⋆IdL _
(C [-, c ]) .F-seq _ _ = funExt λ _ → C .⋆Assoc _ _ _

_[_,-] : (C : Category ℓ ℓ') → (c : C .ob)→ Functor C (SET ℓ')
(C [ c ,-]) .F-ob x    = (C [ c , x ]) , C .isSetHom
(C [ c ,-]) .F-hom f k = k ⋆⟨ C ⟩ f
(C [ c ,-]) .F-id      = funExt λ _ → C .⋆IdR _
(C [ c ,-]) .F-seq _ _ = funExt λ _ → sym (C .⋆Assoc _ _ _)

module _ {C : Category ℓ ℓ'} {F : Functor C (SET ℓ')} where
  open NatTrans

  -- natural transformations by pre/post composition
  preComp : {x y : C .ob}
          → (f : C [ x , y ])
          → C [ x ,-] ⇒ F
          → C [ y ,-] ⇒ F
  preComp f α .N-ob c k = (α ⟦ c ⟧) (f ⋆⟨ C ⟩ k)
  preComp f α .N-hom {x = c} {d} k
    = (λ l → (α ⟦ d ⟧) (f ⋆⟨ C ⟩ (l ⋆⟨ C ⟩ k)))
    ≡[ i ]⟨ (λ l → (α ⟦ d ⟧) (⋆Assoc C f l k (~ i))) ⟩
      (λ l → (α ⟦ d ⟧) (f ⋆⟨ C ⟩ l ⋆⟨ C ⟩ k))
    ≡[ i ]⟨ (λ l → (α .N-hom k) i (f ⋆⟨ C ⟩ l)) ⟩
      (λ l → (F ⟪ k ⟫) ((α ⟦ c ⟧) (f ⋆⟨ C ⟩ l)))
    ∎

-- properties
-- TODO: move to own file
open CatIso renaming (inv to cInv)
open Iso

module _ {A B : (SET ℓ) .ob } where

  Iso→CatIso : Iso (fst A) (fst B)
             → CatIso (SET ℓ) A B
  Iso→CatIso is .mor = is .fun
  Iso→CatIso is .cInv = is .inv
  Iso→CatIso is .sec = funExt λ b → is .rightInv b -- is .rightInv
  Iso→CatIso is .ret = funExt λ b → is .leftInv b -- is .rightInv

  CatIso→Iso : CatIso (SET ℓ) A B
             → Iso (fst A) (fst B)
  CatIso→Iso cis .fun = cis .mor
  CatIso→Iso cis .inv = cis .cInv
  CatIso→Iso cis .rightInv = funExt⁻ λ b → cis .sec b
  CatIso→Iso cis .leftInv = funExt⁻ λ b → cis .ret b

  Iso-Iso-CatIso : Iso (Iso (fst A) (fst B)) (CatIso (SET ℓ) A B)
  fun Iso-Iso-CatIso = Iso→CatIso
  inv Iso-Iso-CatIso = CatIso→Iso
  rightInv Iso-Iso-CatIso b = refl
  fun (leftInv Iso-Iso-CatIso a i) = fun a
  inv (leftInv Iso-Iso-CatIso a i) = inv a
  rightInv (leftInv Iso-Iso-CatIso a i) = rightInv a
  leftInv (leftInv Iso-Iso-CatIso a i) = leftInv a

  Iso-CatIso-≡ : Iso (CatIso (SET ℓ) A B) (A ≡ B)
  Iso-CatIso-≡ = compIso (invIso Iso-Iso-CatIso) (hSet-Iso-Iso-≡ _ _)

-- SET is univalent

isUnivalentSET : isUnivalent {ℓ' = ℓ} (SET _)
isUnivalent.univ isUnivalentSET (A , isSet-A) (B , isSet-B)  =
   precomposesToId→Equiv
      pathToIso _ (funExt w) (isoToIsEquiv Iso-CatIso-≡)
   where
     w : _
     w ci =
       invEq
         (congEquiv (isoToEquiv (invIso Iso-Iso-CatIso)))
         (SetsIso≡-ext isSet-A isSet-B
            (λ x i → transp (λ _ → B) i (ci .mor  (transp (λ _ → A) i x)))
            (λ x i → transp (λ _ → A) i (ci .cInv (transp (λ _ → B) i x))))

-- SET is complete

open LimCone
open Cone

completeSET : ∀ {ℓJ ℓJ'} → Limits {ℓJ} {ℓJ'} (SET (ℓ-max ℓJ ℓJ'))
lim (completeSET J D) = Cone D (Unit* , isOfHLevelLift 2 isSetUnit) , isSetCone D _
coneOut (limCone (completeSET J D)) j e = coneOut e j tt*
coneOutCommutes (limCone (completeSET J D)) j i e = coneOutCommutes e j i tt*
univProp (completeSET J D) c cc =
  uniqueExists
    (λ x → cone (λ v _ → coneOut cc v x) (λ e i _ → coneOutCommutes cc e i x))
    (λ _ → funExt (λ _ → refl))
    (λ x → isPropIsConeMor cc (limCone (completeSET J D)) x)
    (λ x hx → funExt (λ d → cone≡ λ u → funExt (λ _ → sym (funExt⁻ (hx u) d))))


{-# OPTIONS --cubical --no-positivity-check --no-termination-check #-}

open import Prelude
open import Algebra
open import Algebra.Monus
open import Relation.Binary
open import Data.Maybe
open import Data.List using (List; _∷_; []; foldr)

module Control.Monad.HeapT
  {ℓ}
  (monoid : Monoid ℓ)
  (gmon : GradedMonad monoid ℓ ℓ)
  where

open Monoid monoid
open GradedMonad gmon

private
  variable
    w : 𝑆

infixr 5 _∷_
infixr 6 _⋊_

mutual
  record Root (A : Type ℓ) : Type ℓ where
    coinductive
    constructor _⋊_
    field
      weight : 𝑆
      step : 𝐹 weight (Branch A)

  data Node (A : Type ℓ) : Type ℓ where
    ⌊_⌋ : A → Node A
    ⌈_⌉ : Root A → Node A

  data Branch (A : Type ℓ) : Type ℓ where
    []  : Branch A
    _∷_ : Node A → 𝐹 ε (Branch A) → Branch A
open Root public

Heap : Type ℓ → Type ℓ
Heap A = 𝐹 ε (Branch A)

infixr 5 _++_
_++_ : 𝐹 w (Branch A) → 𝐹 ε (Branch A) → 𝐹 w (Branch A)
xs ++ ys =
  xs >>=ε λ  {  []       → ys
             ;  (x ∷ xs) → pure (x ∷ xs ++ ys) }

infixr 1 _>>=ᴺ_ _>>=ᴴ_
mutual
  _>>=ᴺ_ : Node A → (A → Heap B) → Heap B
  ⌊ x ⌋  >>=ᴺ f = f x
  ⌈ x ⌉  >>=ᴺ f = pure (⌈ weight x ⋊ (step x >>=ᴴ f) ⌉ ∷ pure [])

  _>>=ᴴ_ : 𝐹 w (Branch A) → (A → Heap B) → 𝐹 w (Branch B)
  xs >>=ᴴ f =
    xs >>=ε λ  {  []        → pure []
               ;  (x ∷ xs)  → (x >>=ᴺ f) ++ (xs >>=ᴴ f) }

pureᴴ : A → Heap A
pureᴴ x = pure (⌊ x ⌋ ∷ pure [])

liftᴴ : 𝐹 w A → Heap A
liftᴴ xs = pure (⌈ _ ⋊ map (λ x → ⌊ x ⌋ ∷ pure []) xs ⌉ ∷ pure [])

flatten : 𝐹 w (Branch A) → 𝐹 w (List A × List (Root A))
flatten xs =
  xs >>=ε λ  {  []            → pure ([] , [])
             ;  (⌊ x ⌋ ∷ xs)  → map (map₁ (x ∷_)) (flatten xs)
             ;  (⌈ x ⌉ ∷ xs)  → map (map₂ (x ∷_)) (flatten xs) }

module PopMin
  (_≤|≥_ : Total (λ x y → ∃ z × (y ≡ x ∙ z)))
  (decomp : ∀ {A B w₁ w₂ w₃} → 𝐹 (w₁ ∙ w₂) A → 𝐹 (w₁ ∙ w₃) B → 𝐹 w₁ (𝐹 w₂ A × 𝐹 w₃ B)) where

  _∪_ : Root A → Root A → Root A
  xs ∪ ys with weight xs ≤|≥ weight ys
  ... | inl (k , wʸ≡wˣ∙k) = weight xs ⋊ map (λ { (xs , ys) → ⌈ k ⋊ ys ⌉ ∷ xs }) (decomp (subst (flip 𝐹 _) (sym (∙ε _)) (step xs)) (subst (flip 𝐹 _) wʸ≡wˣ∙k (step ys)))
  ... | inr (k , wˣ≡wʸ∙k) = weight ys ⋊ map (λ { (ys , xs) → ⌈ k ⋊ xs ⌉ ∷ ys }) (decomp (subst (flip 𝐹 _) (sym (∙ε _)) (step ys)) (subst (flip 𝐹 _) wˣ≡wʸ∙k (step xs)))

  ⋃⁺ : Root A → List (Root A) → Root A
  ⋃⁺ x₁ []             = x₁
  ⋃⁺ x₁ (x₂ ∷ [])      = x₁ ∪ x₂
  ⋃⁺ x₁ (x₂ ∷ x₃ ∷ xs) = (x₁ ∪ x₂) ∪ ⋃⁺ x₃ xs

  ⋃ : List (Root A) → Maybe (Root A)
  ⋃ []       = nothing
  ⋃ (x ∷ xs) = just (⋃⁺ x xs)

  popMin : 𝐹 w (Branch A) → 𝐹 w (List A × Maybe (Root A))
  popMin = map (map₂ ⋃) ∘ flatten


-- Andreas, 2014-03-02, issue and test case by Nisse

-- {-# OPTIONS --show-implicit -v tc.meta.assign:25 -v tc.meta.occurs:70 -v tc.meta.kill:30 #-}
-- {-# OPTIONS -v tc:10 #-}

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

open Σ public

postulate
  A : Set
  D : A → Set

data P : ∀ {xP} → D xP → Set where
  c : ∀ {xc} (dc : D xc) → P dc

module M (f : ∀ {x} → D x → Σ A D)
         (_ : ∀ {xM} (dM : D xM) → P (proj₂ (f dM)))
  where

  postulate
    p : ∀ {x} → D x → A
    q : ∀ {x} {d : D x} → D (p d)

p : ∀ {x} → D x → A
p = M.p (λ x → _ , x) c

q : ∀ {xq} {dq : D xq} → D (p dq)
q = M.q _ c

-- WAS: Unsound pruning of metas under projections
--
-- Cannot instantiate the metavariable _49 to solution d since it
-- contains the variable d which is not in scope of the metavariable
-- or irrelevant in the metavariable but relevant in the solution
-- when checking that the expression c has type ((d : D .x₁) → P _49)

-- NOW: type-checks fine


-- {-# OPTIONS -v tc.cover.splittree:10 -v tc.cc.splittree:10  #-}
module Issue106 where

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

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC suc #-}

_+_ : ℕ -> ℕ -> ℕ
zero + m = m
suc n + m = suc (n + m)

record ⊤ : Set where

data C : ℕ -> Set where
  c : C 0

data D : Set where
  d : forall s (x : C s) (xs : D) -> D

f : D -> ℕ -> ⊤
f (d zero c x) (suc n) = f (d 0 c x) n
f (d .zero c x) n      = f x (suc n)

g : D -> ℕ -> ⊤
g (d .zero c x) (suc n) = g (d zero c x) n
g (d .zero c x) n       = g x (suc n)

h : D -> ℕ -> ⊤
h (d .zero c x) (suc n) = h (d 0 c x) n
h (d .zero c x) n       = h x (suc n)


{-# OPTIONS --cubical --no-import-sorts --guardedness --safe #-}

module Cubical.Codata.M.AsLimit.M.Properties where

open import Cubical.Data.Unit
open import Cubical.Data.Prod
open import Cubical.Data.Nat as ℕ using (ℕ ; suc ; _+_ )
open import Cubical.Data.Sum
open import Cubical.Data.Sigma

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv using (_≃_)
open import Cubical.Foundations.Function using (_∘_)
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv

open import Cubical.Functions.Embedding

open import Cubical.Codata.M.AsLimit.helper
open import Cubical.Codata.M.AsLimit.M.Base
open import Cubical.Codata.M.AsLimit.Container

-- in-fun and out-fun are inverse

open Iso

in-inverse-out : ∀ {ℓ} {S : Container ℓ} → (in-fun {S = S} ∘ out-fun {S = S}) ≡ idfun (M S)
in-inverse-out {S = S} = subst (λ inv → in-fun {S = S} ∘ inv ≡ idfun (M S)) idpath def where
  -- substituting refl makes type-checking work a lot faster, but introduces a transport
  -- TODO (2020-05-23): revisit this at some point to see if it's still needed in future versions of agda
  def : (in-fun {S = S} ∘ inv (shift-iso S)) ≡ idfun (M S)
  def = funExt (rightInv (shift-iso S))
  idpath : inv (shift-iso S) ≡ out-fun {S = S}
  idpath = refl

out-inverse-in : ∀ {ℓ} {S : Container ℓ} → (out-fun {S = S} ∘ in-fun {S = S}) ≡ idfun (P₀ S (M S))
out-inverse-in {S = S} = subst (λ fun → out-fun {S = S} ∘ fun ≡ idfun (P₀ S (M S))) idpath def where
  def : (out-fun {S = S} ∘ fun (shift-iso S)) ≡ idfun (P₀ S (M S))
  def = funExt (leftInv (shift-iso S))
  idpath : fun (shift-iso S) ≡ in-fun {S = S}
  idpath = refl

in-out-id : ∀ {ℓ} {S : Container ℓ} -> ∀ {x y : M S} → (in-fun (out-fun x) ≡ in-fun (out-fun y)) ≡ (x ≡ y)
in-out-id {x = x} {y} i = (in-inverse-out i x) ≡ (in-inverse-out i y)

-- constructor properties

in-inj : ∀ {ℓ} {S : Container ℓ} {Z : Type ℓ} → ∀ {f g : Z → P₀ S (M S)} → (in-fun ∘ f ≡ in-fun ∘ g) ≡ (f ≡ g)
in-inj {ℓ} {S = S} {Z = Z} {f = f} {g = g} = iso→fun-Injection-Path {ℓ = ℓ} {A = P₀ S (M S)} {B = M S} {C = Z} (shift-iso S) {f = f} {g = g}

out-inj : ∀ {ℓ} {S : Container ℓ} {Z : Type ℓ} → ∀ {f g : Z → M S} → (out-fun ∘ f ≡ out-fun ∘ g) ≡ (f ≡ g)
out-inj {ℓ} {S = S} {Z = Z} {f = f} {g = g} = iso→inv-Injection-Path {ℓ = ℓ} {A = P₀ S (M S)} {B = M S} {C = Z} (shift-iso S) {f = f} {g = g}

in-inj-x : ∀ {ℓ} {S : Container ℓ} → ∀ {x y : P₀ S (M S)} → (in-fun x ≡ in-fun y) ≡ (x ≡ y)
in-inj-x {ℓ} {S = S} {x = x} {y} = iso→fun-Injection-Path-x (shift-iso S) {x} {y}

out-inj-x : ∀ {ℓ} {S : Container ℓ} → ∀ {x y : M S} → (out-fun x ≡ out-fun y) ≡ (x ≡ y)
out-inj-x {ℓ} {S = S} {x = x} {y} = iso→inv-Injection-Path-x (shift-iso S) {x} {y}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Pointwise lifting of relations to lists
------------------------------------------------------------------------

module Relation.Binary.List.Pointwise where

open import Function
open import Function.Inverse using (Inverse)
open import Data.Product hiding (map)
open import Data.List hiding (map)
open import Level
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec using (map′)
open import Relation.Binary renaming (Rel to Rel₂)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

infixr 5 _∷_

data Rel {a b ℓ} {A : Set a} {B : Set b}
         (_∼_ : REL A B ℓ) : List A → List B → Set (a ⊔ b ⊔ ℓ) where
  []  : Rel _∼_ [] []
  _∷_ : ∀ {x xs y ys} (x∼y : x ∼ y) (xs∼ys : Rel _∼_ xs ys) →
        Rel _∼_ (x ∷ xs) (y ∷ ys)

head : ∀ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} {x y xs ys} →
       Rel _∼_ (x ∷ xs) (y ∷ ys) → x ∼ y
head (x∼y ∷ xs∼ys) = x∼y

tail : ∀ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} {x y xs ys} →
       Rel _∼_ (x ∷ xs) (y ∷ ys) → Rel _∼_ xs ys
tail (x∼y ∷ xs∼ys) = xs∼ys

rec : ∀ {a b c ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ}
      (P : ∀ {xs ys} → Rel _∼_ xs ys → Set c) →
      (∀ {x y xs ys} {xs∼ys : Rel _∼_ xs ys} →
         (x∼y : x ∼ y) → P xs∼ys → P (x∼y ∷ xs∼ys)) →
      P [] →
      ∀ {xs ys} (xs∼ys : Rel _∼_ xs ys) → P xs∼ys
rec P c n []            = n
rec P c n (x∼y ∷ xs∼ys) = c x∼y (rec P c n xs∼ys)

map : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
        {_≈_ : REL A B ℓ₁} {_∼_ : REL A B ℓ₂} →
      _≈_ ⇒ _∼_ → Rel _≈_ ⇒ Rel _∼_
map ≈⇒∼ []            = []
map ≈⇒∼ (x≈y ∷ xs≈ys) = ≈⇒∼ x≈y ∷ map ≈⇒∼ xs≈ys

reflexive : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
              {_≈_ : REL A B ℓ₁} {_∼_ : REL A B ℓ₂} →
            _≈_ ⇒ _∼_ → Rel _≈_ ⇒ Rel _∼_
reflexive ≈⇒∼ []            = []
reflexive ≈⇒∼ (x≈y ∷ xs≈ys) = ≈⇒∼ x≈y ∷ reflexive ≈⇒∼ xs≈ys

refl : ∀ {a ℓ} {A : Set a} {_∼_ : Rel₂ A ℓ} →
       Reflexive _∼_ → Reflexive (Rel _∼_)
refl rfl {[]}     = []
refl rfl {x ∷ xs} = rfl ∷ refl rfl

symmetric : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
              {_≈_ : REL A B ℓ₁} {_∼_ : REL B A ℓ₂} →
            Sym _≈_ _∼_ → Sym (Rel _≈_) (Rel _∼_)
symmetric sym []            = []
symmetric sym (x∼y ∷ xs∼ys) = sym x∼y ∷ symmetric sym xs∼ys

transitive :
  ∀ {a b c ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} {C : Set c}
    {_≋_ : REL A B ℓ₁} {_≈_ : REL B C ℓ₂} {_∼_ : REL A C ℓ₃} →
  Trans _≋_ _≈_ _∼_ → Trans (Rel _≋_) (Rel _≈_) (Rel _∼_)
transitive trans []            []            = []
transitive trans (x∼y ∷ xs∼ys) (y∼z ∷ ys∼zs) =
  trans x∼y y∼z ∷ transitive trans xs∼ys ys∼zs

antisymmetric : ∀ {a ℓ₁ ℓ₂} {A : Set a}
                  {_≈_ : Rel₂ A ℓ₁} {_≤_ : Rel₂ A ℓ₂} →
                Antisymmetric _≈_ _≤_ →
                Antisymmetric (Rel _≈_) (Rel _≤_)
antisymmetric antisym []            []            = []
antisymmetric antisym (x∼y ∷ xs∼ys) (y∼x ∷ ys∼xs) =
  antisym x∼y y∼x ∷ antisymmetric antisym xs∼ys ys∼xs

respects₂ : ∀ {a ℓ₁ ℓ₂} {A : Set a}
              {_≈_ : Rel₂ A ℓ₁} {_∼_ : Rel₂ A ℓ₂} →
            _∼_ Respects₂ _≈_ → (Rel _∼_) Respects₂ (Rel _≈_)
respects₂ {_≈_ = _≈_} {_∼_} resp =
  (λ {xs} {ys} {zs} → resp¹ {xs} {ys} {zs}) ,
  (λ {xs} {ys} {zs} → resp² {xs} {ys} {zs})
  where
  resp¹ : ∀ {xs} → (Rel _∼_ xs) Respects (Rel _≈_)
  resp¹ []            []            = []
  resp¹ (x≈y ∷ xs≈ys) (z∼x ∷ zs∼xs) =
    proj₁ resp x≈y z∼x ∷ resp¹ xs≈ys zs∼xs

  resp² : ∀ {ys} → (flip (Rel _∼_) ys) Respects (Rel _≈_)
  resp² []            []            = []
  resp² (x≈y ∷ xs≈ys) (x∼z ∷ xs∼zs) =
    proj₂ resp x≈y x∼z ∷ resp² xs≈ys xs∼zs

decidable : ∀ {a b ℓ} {A : Set a} {B : Set b} {_∼_ : REL A B ℓ} →
            Decidable _∼_ → Decidable (Rel _∼_)
decidable dec []       []       = yes []
decidable dec []       (y ∷ ys) = no (λ ())
decidable dec (x ∷ xs) []       = no (λ ())
decidable dec (x ∷ xs) (y ∷ ys) with dec x y
... | no ¬x∼y = no (¬x∼y ∘ head)
... | yes x∼y with decidable dec xs ys
...           | no ¬xs∼ys = no (¬xs∼ys ∘ tail)
...           | yes xs∼ys = yes (x∼y ∷ xs∼ys)

isEquivalence : ∀ {a ℓ} {A : Set a} {_≈_ : Rel₂ A ℓ} →
                IsEquivalence _≈_ → IsEquivalence (Rel _≈_)
isEquivalence eq = record
  { refl  = refl       Eq.refl
  ; sym   = symmetric  Eq.sym
  ; trans = transitive Eq.trans
  } where module Eq = IsEquivalence eq

isPreorder : ∀ {a ℓ₁ ℓ₂} {A : Set a}
               {_≈_ : Rel₂ A ℓ₁} {_∼_ : Rel₂ A ℓ₂} →
             IsPreorder _≈_ _∼_ → IsPreorder (Rel _≈_) (Rel _∼_)
isPreorder pre = record
  { isEquivalence = isEquivalence Pre.isEquivalence
  ; reflexive     = reflexive     Pre.reflexive
  ; trans         = transitive    Pre.trans
  } where module Pre = IsPreorder pre

isDecEquivalence : ∀ {a ℓ} {A : Set a}
                     {_≈_ : Rel₂ A ℓ} → IsDecEquivalence _≈_ →
                   IsDecEquivalence (Rel _≈_)
isDecEquivalence eq = record
  { isEquivalence = isEquivalence DE.isEquivalence
  ; _≟_           = decidable     DE._≟_
  } where module DE = IsDecEquivalence eq

isPartialOrder : ∀ {a ℓ₁ ℓ₂} {A : Set a}
                   {_≈_ : Rel₂ A ℓ₁} {_≤_ : Rel₂ A ℓ₂} →
                 IsPartialOrder _≈_ _≤_ →
                 IsPartialOrder (Rel _≈_) (Rel _≤_)
isPartialOrder po = record
  { isPreorder = isPreorder    PO.isPreorder
  ; antisym    = antisymmetric PO.antisym
  } where module PO = IsPartialOrder po

preorder : ∀ {p₁ p₂ p₃} → Preorder p₁ p₂ p₃ → Preorder _ _ _
preorder p = record
  { isPreorder = isPreorder (Preorder.isPreorder p)
  }

setoid : ∀ {c ℓ} → Setoid c ℓ → Setoid _ _
setoid s = record
  { isEquivalence = isEquivalence (Setoid.isEquivalence s)
  }

decSetoid : ∀ {c ℓ} → DecSetoid c ℓ → DecSetoid _ _
decSetoid d = record
  { isDecEquivalence = isDecEquivalence (DecSetoid.isDecEquivalence d)
  }

poset : ∀ {c ℓ₁ ℓ₂} → Poset c ℓ₁ ℓ₂ → Poset _ _ _
poset p = record
  { isPartialOrder = isPartialOrder (Poset.isPartialOrder p)
  }

-- Rel _≡_ coincides with _≡_.

Rel≡⇒≡ : ∀ {a} {A : Set a} → Rel {A = A} _≡_ ⇒ _≡_
Rel≡⇒≡ []               = P.refl
Rel≡⇒≡ (P.refl ∷ xs∼ys) with Rel≡⇒≡ xs∼ys
Rel≡⇒≡ (P.refl ∷ xs∼ys) | P.refl = P.refl

≡⇒Rel≡ : ∀ {a} {A : Set a} → _≡_ ⇒ Rel {A = A} _≡_
≡⇒Rel≡ P.refl = refl P.refl

Rel↔≡ : ∀ {a} {A : Set a} →
        Inverse (setoid (P.setoid A)) (P.setoid (List A))
Rel↔≡ = record
  { to         = record { _⟨$⟩_ = id; cong = Rel≡⇒≡ }
  ; from       = record { _⟨$⟩_ = id; cong = ≡⇒Rel≡ }
  ; inverse-of = record
    { left-inverse-of  = λ _ → refl P.refl
    ; right-inverse-of = λ _ → P.refl
    }
  }

decidable-≡ : ∀ {a} {A : Set a} →
              Decidable {A = A} _≡_ → Decidable {A = List A} _≡_
decidable-≡ dec xs ys = Dec.map′ Rel≡⇒≡ ≡⇒Rel≡ (xs ≟ ys)
  where
  open DecSetoid (decSetoid (P.decSetoid dec))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of general interleavings
------------------------------------------------------------------------

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

module Data.List.Relation.Ternary.Interleaving.Properties where

open import Data.Nat
open import Data.Nat.Properties using (+-suc)
open import Data.List.Base hiding (_∷ʳ_)
open import Data.List.Properties using (reverse-involutive)
open import Data.List.Relation.Ternary.Interleaving hiding (map)
open import Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; cong; module ≡-Reasoning)
open ≡-Reasoning

------------------------------------------------------------------------
-- length

module _ {a b c l r} {A : Set a} {B : Set b} {C : Set c}
         {L : REL A C l} {R : REL B C r} where

  interleave-length : ∀ {as l r} → Interleaving L R l r as →
                      length as ≡ length l + length r
  interleave-length []        = refl
  interleave-length (l ∷ˡ sp) = cong suc (interleave-length sp)
  interleave-length {as} {l} {r ∷ rs} (_ ∷ʳ sp) = begin
    length as                   ≡⟨ cong suc (interleave-length sp) ⟩
    suc (length l + length rs)  ≡⟨ sym $ +-suc _ _ ⟩
    length l + length (r ∷ rs)  ∎

------------------------------------------------------------------------
-- _++_

  ++⁺ : ∀ {as₁ as₂ l₁ l₂ r₁ r₂} →
        Interleaving L R as₁ l₁ r₁ → Interleaving L R as₂ l₂ r₂ →
        Interleaving L R (as₁ ++ as₂) (l₁ ++ l₂) (r₁ ++ r₂)
  ++⁺ []         sp₂ = sp₂
  ++⁺ (l ∷ˡ sp₁) sp₂ = l ∷ˡ (++⁺ sp₁ sp₂)
  ++⁺ (r ∷ʳ sp₁) sp₂ = r ∷ʳ (++⁺ sp₁ sp₂)

  ++-disjoint : ∀ {as₁ as₂ l₁ r₂} →
                Interleaving L R l₁ [] as₁ → Interleaving L R [] r₂ as₂ →
                Interleaving L R l₁ r₂ (as₁ ++ as₂)
  ++-disjoint []         sp₂ = sp₂
  ++-disjoint (l ∷ˡ sp₁) sp₂ = l ∷ˡ ++-disjoint sp₁ sp₂

------------------------------------------------------------------------
-- map

module _ {a b c d e f l r}
         {A : Set a} {B : Set b} {C : Set c}
         {D : Set d} {E : Set e} {F : Set f}
         {L : REL A C l} {R : REL B C r}
         (f : E → A) (g : F → B) (h : D → C)
         where

  map⁺ : ∀ {as l r} →
         Interleaving (λ x z → L (f x) (h z)) (λ y z → R (g y) (h z)) l r as  →
         Interleaving L R (map f l) (map g r) (map h as)
  map⁺ []        = []
  map⁺ (l ∷ˡ sp) = l ∷ˡ map⁺ sp
  map⁺ (r ∷ʳ sp) = r ∷ʳ map⁺ sp

  map⁻ : ∀ {as l r} →
         Interleaving L R (map f l) (map g r) (map h as) →
         Interleaving (λ x z → L (f x) (h z)) (λ y z → R (g y) (h z)) l r as
  map⁻ {[]}    {[]}    {[]}    []        = []
  map⁻ {_ ∷ _} {[]}    {_ ∷ _} (r ∷ʳ sp) = r ∷ʳ map⁻ sp
  map⁻ {_ ∷ _} {_ ∷ _} {[]}    (l ∷ˡ sp) = l ∷ˡ map⁻ sp
  map⁻ {_ ∷ _} {_ ∷ _} {_ ∷ _} (l ∷ˡ sp) = l ∷ˡ map⁻ sp
  map⁻ {_ ∷ _} {_ ∷ _} {_ ∷ _} (r ∷ʳ sp) = r ∷ʳ map⁻ sp
  -- impossible cases needed until 2.6.0
  map⁻ {[]} {_} {_ ∷ _} ()
  map⁻ {[]} {_ ∷ _} {_} ()
  map⁻ {_ ∷ _} {[]} {[]} ()

------------------------------------------------------------------------
-- reverse

module _ {a b c l r} {A : Set a} {B : Set b} {C : Set c}
         {L : REL A C l} {R : REL B C r}
         where

  reverseAcc⁺ : ∀ {as₁ as₂ l₁ l₂ r₁ r₂} →
                Interleaving L R l₁ r₁ as₁ →
                Interleaving L R l₂ r₂ as₂ →
                Interleaving L R (reverseAcc l₁ l₂) (reverseAcc r₁ r₂) (reverseAcc as₁ as₂)
  reverseAcc⁺ sp₁ []         = sp₁
  reverseAcc⁺ sp₁ (l ∷ˡ sp₂) = reverseAcc⁺ (l ∷ˡ sp₁) sp₂
  reverseAcc⁺ sp₁ (r ∷ʳ sp₂) = reverseAcc⁺ (r ∷ʳ sp₁) sp₂

  reverse⁺ : ∀ {as l r} → Interleaving L R l r as →
             Interleaving L R (reverse l) (reverse r) (reverse as)
  reverse⁺ = reverseAcc⁺ []

  reverse⁻ : ∀ {as l r} → Interleaving L R (reverse l) (reverse r) (reverse as) →
             Interleaving L R l r as
  reverse⁻ {as} {l} {r} sp with reverse⁺ sp
  ... | sp′ rewrite reverse-involutive as
                  | reverse-involutive l
                  | reverse-involutive r = sp′


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

module Cubical.Algebra.Group.EilenbergMacLane.CupProduct where

open import Cubical.Algebra.Group.EilenbergMacLane.Base renaming (elim to EM-elim)
open import Cubical.Algebra.Group.EilenbergMacLane.WedgeConnectivity
open import Cubical.Algebra.Group.EilenbergMacLane.GroupStructure
open import Cubical.Algebra.Group.EilenbergMacLane.Properties
open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.GroupoidLaws renaming (assoc to ∙assoc)
open import Cubical.Foundations.Path
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Transport

open import Cubical.Foundations.Pointed.Homogeneous

open import Cubical.Functions.Morphism

open import Cubical.Homotopy.Loopspace

open import Cubical.HITs.Truncation as Trunc renaming (rec to trRec; elim to trElim)
open import Cubical.HITs.EilenbergMacLane1 renaming (rec to EMrec)
open import Cubical.Algebra.AbGroup.Base
open import Cubical.Data.Empty
  renaming (rec to ⊥-rec)
open import Cubical.HITs.Truncation
  renaming (elim to trElim ; rec to trRec ; rec2 to trRec2)
open import Cubical.Data.Nat hiding (_·_) renaming (elim to ℕelim)
open import Cubical.HITs.Susp

open import Cubical.Algebra.AbGroup.TensorProduct
open import Cubical.Algebra.Group

open AbGroupStr renaming (_+_ to _+Gr_ ; -_ to -Gr_)

open PlusBis

private
  variable
    ℓ ℓ' ℓ'' : Level

-- Lemma for distributativity of cup product (used later)
pathType : ∀ {ℓ} {G : AbGroup ℓ} (n : ℕ) (x : EM G (2 + n)) (p : 0ₖ (2 + n) ≡ x) → Type ℓ
pathType n x p = sym (rUnitₖ (2 + n) x) ∙ (λ i → x +ₖ p i)
               ≡ sym (lUnitₖ (2 + n) x) ∙ λ i → p i +ₖ x

pathTypeMake : ∀ {ℓ} {G : AbGroup ℓ} (n : ℕ) (x : EM G (2 + n)) (p : 0ₖ (2 + n) ≡ x)
    → pathType n x p
pathTypeMake n x = J (λ x p → pathType n x p) refl

-- Definition of cup product (⌣ₖ, given by ·₀ when first argument is in K(G,0))
module _ {G' : AbGroup ℓ} {H' : AbGroup ℓ'} where
   private
     G = fst G'
     H = fst H'

     strG = snd G'
     strH = snd H'

     0G = 0g strG
     0H = 0g strH

     _+G_ = _+Gr_ strG
     _+H_ = _+Gr_ strH

     -H_ = -Gr_ strH
     -G_ = -Gr_ strG

   ·₀' : H → (m : ℕ) → EM G' m → EM (G' ⨂ H') m
   ·₀' h =
     elim+2
       (_⊗ h)
       (elimGroupoid _ (λ _ → emsquash)
         embase
         (λ g → emloop (g ⊗ h))
         λ g l →
           compPathR→PathP
             (sym (∙assoc _ _ _
                ∙∙ cong₂ _∙_ (sym (emloop-comp _ _ _)
                            ∙ cong emloop (sym (⊗DistL+⊗ g l h))) refl
                ∙∙ rCancel _)))
       λ n f → trRec (isOfHLevelTrunc (4 + n))
                        λ { north → 0ₖ (suc (suc n))
                          ; south → 0ₖ (suc (suc n))
                          ; (merid a i) → EM→ΩEM+1 (suc n) (f (EM-raw→EM _ _ a)) i}

   ·₀ : G → (m : ℕ) → EM H' m → EM (G' ⨂ H') m
   ·₀ g =
     elim+2 (λ h → g ⊗ h)
               (elimGroupoid _ (λ _ → emsquash)
                 embase
                 (λ h → emloop (g ⊗ h))
                 λ h l → compPathR→PathP
                   (sym (∙assoc _ _ _
                      ∙∙ cong₂ _∙_ (sym (emloop-comp _ _ _) ∙ cong emloop (sym (⊗DistR+⊗ g h l))) refl
                      ∙∙ rCancel _)))
               λ n f
               → trRec (isOfHLevelTrunc (4 + n))
                        λ { north → 0ₖ (suc (suc n))
                          ; south → 0ₖ (suc (suc n))
                          ; (merid a i) → EM→ΩEM+1 (suc n) (f (EM-raw→EM _ _ a)) i}

   ·₀-distr : (g h : G) → (m : ℕ)  (x : EM H' m) → ·₀ (g +G h) m x ≡ ·₀ g m x +ₖ ·₀ h m x
   ·₀-distr g h =
     elim+2
       (⊗DistL+⊗ g h)
       (elimSet _ (λ _ → emsquash _ _)
         refl
         (λ w → compPathR→PathP (sym ((λ i → emloop (⊗DistL+⊗ g h w i)
                               ∙ (lUnit (sym (cong₂+₁ (emloop (g ⊗ w)) (emloop (h ⊗ w)) i)) (~ i)))
              ∙∙ cong₂ _∙_ (emloop-comp _ (g ⊗ w) (h ⊗ w)) refl
              ∙∙ rCancel _))))
       λ m ind →
         trElim (λ _ → isOfHLevelTruncPath)
                λ { north → refl
                  ; south → refl
                  ; (merid a i) k → z m ind a k i}

      where
      z : (m : ℕ) → ((x : EM H' (suc m))
        → ·₀ (g +G h) (suc m) x
         ≡ ·₀ g (suc m) x +ₖ ·₀ h (suc m) x) → (a : EM-raw H' (suc m))
        → cong (·₀ (g +G h) (suc (suc m))) (cong ∣_∣ₕ (merid a)) ≡
          cong₂ _+ₖ_
            (cong (·₀ g (suc (suc m))) (cong ∣_∣ₕ (merid a)))
            (cong (·₀ h (suc (suc m))) (cong ∣_∣ₕ (merid a)))
      z m ind a = (λ i → EM→ΩEM+1 _ (ind (EM-raw→EM _ _ a) i))
               ∙∙ EM→ΩEM+1-hom _ (·₀ g (suc m) (EM-raw→EM H' (suc m) a))
                                  (·₀ h (suc m) (EM-raw→EM H' (suc m) a))
               ∙∙ sym (cong₂+₂ m (cong (·₀ g (suc (suc m))) (cong ∣_∣ₕ (merid a)))
                                 (cong (·₀ h (suc (suc m))) (cong ∣_∣ₕ (merid a))))

   ·₀0 : (m : ℕ) → (g : G) → ·₀ g m (0ₖ m) ≡ 0ₖ m
   ·₀0 zero = ⊗AnnihilR
   ·₀0 (suc zero) g = refl
   ·₀0 (suc (suc m)) g = refl

   ·₀'0 : (m : ℕ) (h : H) → ·₀' h m (0ₖ m) ≡ 0ₖ m
   ·₀'0 zero = ⊗AnnihilL
   ·₀'0 (suc zero) g = refl
   ·₀'0 (suc (suc m)) g = refl

   0·₀ : (m : ℕ) → (x : _) → ·₀ 0G m x ≡ 0ₖ m
   0·₀ =
     elim+2 ⊗AnnihilL
       (elimSet _ (λ _ → emsquash _ _)
         refl
         λ g → compPathR→PathP ((sym (emloop-1g _)
                                ∙ cong emloop (sym (⊗AnnihilL g)))
                                ∙∙ (λ i → rUnit (rUnit (cong (·₀ 0G 1) (emloop g)) i) i)
                                ∙∙ sym (∙assoc _ _ _)))
       λ n f → trElim (λ _ → isOfHLevelTruncPath)
                       λ { north → refl
                         ; south → refl
                         ; (merid a i) j → (cong (EM→ΩEM+1 (suc n)) (f (EM-raw→EM _ _ a))
                                           ∙ EM→ΩEM+1-0ₖ _) j i}

   0·₀' : (m : ℕ) (g : _) → ·₀' 0H m g ≡ 0ₖ m
   0·₀' =
     elim+2
       ⊗AnnihilR
       (elimSet _ (λ _ → emsquash _ _)
         refl
         λ g → compPathR→PathP (sym (∙assoc _ _ _
                              ∙∙ sym (rUnit _) ∙ sym (rUnit _)
                              ∙∙ (cong emloop (⊗AnnihilR g)
                                ∙ emloop-1g _))))
       λ n f → trElim (λ _ → isOfHLevelTruncPath)
                       λ { north → refl
                         ; south → refl
                         ; (merid a i) j → (cong (EM→ΩEM+1 (suc n)) (f (EM-raw→EM _ _ a))
                                           ∙ EM→ΩEM+1-0ₖ _) j i}

-- Definition of the cup product
   cup∙ : ∀ n m → EM G' n → EM∙ H' m →∙ EM∙ (G' ⨂ H') (n +' m)
   cup∙ =
     ℕelim
       (λ m g → (·₀ g m) , ·₀0 m g)
         λ n f →
           ℕelim
             (λ g → (λ h → ·₀' h (suc n) g) , 0·₀' (suc n) g)
             λ m _ → main n m f

     where
     main : (n m : ℕ) (ind : ((m : ℕ) → EM G' n → EM∙ H' m →∙ EM∙ (G' ⨂ H') (n +' m)))
         → EM G' (suc n) →  EM∙ H' (suc m) →∙ EM∙ (G' ⨂ H') (suc (suc (n + m)))
     main zero m ind =
       elimGroupoid _ (λ _ → isOfHLevel↑∙ _ _)
         ((λ _ → 0ₖ (2 + m)) , refl)
         (f m)
         λ n h → finalpp m n h
       where
       f : (m : ℕ) → G → typ (Ω (EM∙ H' (suc m) →∙ EM∙ (G' ⨂ H') (suc (suc m)) ∙))
       fst (f m g i) x = EM→ΩEM+1 _ (·₀ g _ x) i
       snd (f zero g i) j = EM→ΩEM+1-0ₖ (suc zero) j i
       snd (f (suc m) g i) j = EM→ΩEM+1-0ₖ (suc (suc m)) j i

       f-hom-fst : (m : ℕ) (g h : G) → cong fst (f m (g +G h)) ≡ cong fst (f m g ∙ f m h)
       f-hom-fst m g h =
            (λ i j x → EM→ΩEM+1 _ (·₀-distr g h (suc m) x i) j)
         ∙∙ (λ i j x → EM→ΩEM+1-hom _ (·₀ g (suc m) x) (·₀ h (suc m) x) i j)
         ∙∙ sym (cong-∙ fst (f m g) (f m h))

       f-hom : (m : ℕ) (g h : G) → f m (g +G h) ≡ f m g ∙ f m h
       f-hom m g h = →∙Homogeneous≡Path (isHomogeneousEM _) _ _ (f-hom-fst m g h)

       finalpp : (m : ℕ) (g h : G) → PathP (λ i → f m g i ≡ f m (g +G h) i) refl (f m h)
       finalpp m g h =
         compPathR→PathP (sym (rCancel _)
                       ∙∙ cong (_∙ sym (f m (g +G h))) (f-hom m g h)
                       ∙∙ sym (∙assoc _ _ _))

     main (suc n) m ind =
       trElim (λ _ → isOfHLevel↑∙ (2 + n) m)
         λ { north → (λ _ → 0ₖ (3 + (n + m))) , refl
           ; south → (λ _ → 0ₖ (3 + (n + m))) , refl
           ; (merid a i) → Iso.inv (ΩfunExtIso _ _)
                             (EM→ΩEM+1∙ _ ∘∙ ind (suc m) (EM-raw→EM _ _ a)) i}

   _⌣ₖ_ : {n m : ℕ} (x : EM G' n) (y : EM H' m) → EM (G' ⨂ H') (n +' m)
   _⌣ₖ_ x y = cup∙ _ _ x .fst y

   ⌣ₖ-0ₖ : (n m : ℕ) (x : EM G' n) → (x ⌣ₖ 0ₖ m) ≡ 0ₖ (n +' m)
   ⌣ₖ-0ₖ n m x = cup∙ n m x .snd

   0ₖ-⌣ₖ : (n m : ℕ) (x : EM H' m) → ((0ₖ n) ⌣ₖ x) ≡ 0ₖ (n +' m)
   0ₖ-⌣ₖ zero m = 0·₀ _
   0ₖ-⌣ₖ (suc zero) zero x = refl
   0ₖ-⌣ₖ (suc (suc n)) zero x = refl
   0ₖ-⌣ₖ (suc zero) (suc m) x = refl
   0ₖ-⌣ₖ (suc (suc n)) (suc m) x = refl

module LeftDistributivity {G' : AbGroup ℓ} {H' : AbGroup ℓ'} where
   private
     distrl1 : (n m : ℕ) → EM H' m → EM H' m
             → EM∙ G' n →∙ EM∙ (G' ⨂ H') (n +' m)
     fst (distrl1 n m x y) z = z ⌣ₖ (x +ₖ y)
     snd (distrl1 n m x y) = 0ₖ-⌣ₖ n m _

     distrl2 : (n m : ℕ) → EM H' m → EM H' m
             → EM∙ G' n →∙ EM∙ (G' ⨂ H') (n +' m)
     fst (distrl2 n m x y) z = (z ⌣ₖ x) +ₖ (z ⌣ₖ y)
     snd (distrl2 n m x y) =
       cong₂ _+ₖ_ (0ₖ-⌣ₖ n m x) (0ₖ-⌣ₖ n m y) ∙ rUnitₖ _ (0ₖ (n +' m))

   hLevLem : (n m : ℕ) → isOfHLevel (suc (suc m)) (EM∙ G' (suc n) →∙ EM∙ (G' ⨂ H') ((suc n) +' m))
   hLevLem n m =
     subst (isOfHLevel (suc (suc m)))
           (λ i → EM∙ G' (suc n) →∙ EM∙ (G' ⨂ H')
           ((cong suc (+-comm m n) ∙ sym (+'≡+ (suc n) m)) i)) (isOfHLevel↑∙ m n)

   mainDistrL : (n m : ℕ) (x y : EM H' (suc m))
     → distrl1 (suc n) (suc m) x y ≡ distrl2 (suc n) (suc m) x y
   mainDistrL n zero =
     wedgeConEM.fun H' H' 0 0
       (λ _ _ → hLevLem _ _ _ _)
       (λ x → →∙Homogeneous≡ (isHomogeneousEM _)
              (funExt λ z → l x z))
       (λ y → →∙Homogeneous≡ (isHomogeneousEM _)
              (funExt λ z → r y z ))
       λ i → →∙Homogeneous≡ (isHomogeneousEM (suc (suc (n + 0))))
                               (funExt (λ z → l≡r z i))
     where
     l : (x : EM H' 1) (z : _)
       → (distrl1 (suc n) 1 embase x .fst z) ≡ (distrl2 (suc n) 1 embase x .fst z)
     l x z = cong (z ⌣ₖ_) (lUnitₖ _ x)
            ∙∙ sym (lUnitₖ _ (z ⌣ₖ x))
            ∙∙ λ i → (⌣ₖ-0ₖ (suc n) (suc zero) z (~ i)) +ₖ (z ⌣ₖ x)

     r : (z : EM H' 1) (x : EM G' (suc n))
       → (distrl1 (suc n) 1 z embase .fst x) ≡ (distrl2 (suc n) 1 z embase .fst x)
     r y z = cong (z ⌣ₖ_) (rUnitₖ _ y)
            ∙∙ sym (rUnitₖ _ (z ⌣ₖ y))
            ∙∙ λ i → (z ⌣ₖ y) +ₖ (⌣ₖ-0ₖ (suc n) (suc zero) z (~ i))

     l≡r : (z : EM G' (suc n)) → l embase z ≡ r embase z
     l≡r z = sym (pathTypeMake _ _ (sym (⌣ₖ-0ₖ (suc n) (suc zero) z)))

   mainDistrL n (suc m) =
     elim2 (λ _ _ → isOfHLevelPath (4 + m) (hLevLem _ _) _ _)
           (wedgeConEM.fun H' H' (suc m) (suc m)
             (λ x y p q → isOfHLevelPlus {n = suc (suc m)} (suc m)
                             (hLevLem n (suc (suc m))
                               (distrl1 (suc n) (suc (suc m)) ∣ x ∣ ∣ y ∣)
                               (distrl2 (suc n) (suc (suc m)) ∣ x ∣ ∣ y ∣) p q))
             (λ x → →∙Homogeneous≡ (isHomogeneousEM _)
               (funExt (l x)))
             (λ x → →∙Homogeneous≡ (isHomogeneousEM _)
               (funExt (r x)))
             λ i → →∙Homogeneous≡ (isHomogeneousEM _)
                     (funExt (λ z → l≡r z i)))
    where
    l : (x : EM-raw H' (suc (suc m))) (z : EM G' (suc n))
     → (distrl1 (suc n) (suc (suc m)) (0ₖ _) ∣ x ∣ₕ .fst z)
      ≡ (distrl2 (suc n) (suc (suc m)) (0ₖ _) ∣ x ∣ₕ .fst z)
    l x z = cong (z ⌣ₖ_) (lUnitₖ (suc (suc m)) ∣ x ∣)
         ∙∙ sym (lUnitₖ _ (z ⌣ₖ ∣ x ∣))
         ∙∙ λ i → (⌣ₖ-0ₖ (suc n) (suc (suc m)) z (~ i)) +ₖ (z ⌣ₖ ∣ x ∣)

    r : (x : EM-raw H' (suc (suc m))) (z : EM G' (suc n))
      → (distrl1 (suc n) (suc (suc m)) ∣ x ∣ₕ (0ₖ _) .fst z)
       ≡ (distrl2 (suc n) (suc (suc m)) ∣ x ∣ₕ (0ₖ _) .fst z)
    r x z = cong (z ⌣ₖ_) (rUnitₖ (suc (suc m)) ∣ x ∣)
         ∙∙ sym (rUnitₖ _ (z ⌣ₖ ∣ x ∣))
         ∙∙ λ i → (z ⌣ₖ ∣ x ∣) +ₖ (⌣ₖ-0ₖ (suc n) (suc (suc m)) z (~ i))

    l≡r : (z : EM G' (suc n)) → l north z ≡ r north z
    l≡r z = sym (pathTypeMake _ _ (sym (⌣ₖ-0ₖ (suc n) (suc (suc m)) z)))

module RightDistributivity {G' : AbGroup ℓ} {H' : AbGroup ℓ'} where
   private
     G = fst G'
     H = fst H'

     strG = snd G'
     strH = snd H'

     0G = 0g strG
     0H = 0g strH

     _+G_ = _+Gr_ strG
     _+H_ = _+Gr_ strH

     -H_ = -Gr_ strH
     -G_ = -Gr_ strG

     distrr1 : (n m : ℕ) → EM G' n → EM G' n → EM∙ H' m →∙ EM∙ (G' ⨂ H') (n +' m)
     fst (distrr1 n m x y) z = (x +ₖ y) ⌣ₖ z
     snd (distrr1 n m x y) = ⌣ₖ-0ₖ n m _

     distrr2 : (n m : ℕ) → EM G' n → EM G' n → EM∙ H' m →∙ EM∙ (G' ⨂ H') (n +' m)
     fst (distrr2 n m x y) z = (x ⌣ₖ z) +ₖ (y ⌣ₖ z)
     snd (distrr2 n m x y) = cong₂ _+ₖ_ (⌣ₖ-0ₖ n m x) (⌣ₖ-0ₖ n m y) ∙ rUnitₖ _ (0ₖ (n +' m))

   mainDistrR : (n m : ℕ) (x y : EM G' (suc n))
     → distrr1 (suc n) (suc m) x y ≡ distrr2 (suc n) (suc m) x y
   mainDistrR zero m =
     wedgeConEM.fun G' G' 0 0
       (λ _ _ → isOfHLevel↑∙ 1 m _ _)
       (λ x → →∙Homogeneous≡ (isHomogeneousEM _)
                        (funExt (l x)))
       (λ x → →∙Homogeneous≡ (isHomogeneousEM _)
                        (funExt (r x)))
       λ i → →∙Homogeneous≡ (isHomogeneousEM _)
                        (funExt λ z → l≡r z i)
     where
     l : (x : _) (z : _) → _ ≡ _
     l x z =
          (λ i → (lUnitₖ 1 x i) ⌣ₖ z)
       ∙∙ sym (lUnitₖ _ (x ⌣ₖ z))
       ∙∙ λ i → 0ₖ-⌣ₖ _ _ z (~ i) +ₖ (x ⌣ₖ z)

     r : (x : _) (z : _) → _ ≡ _
     r x z =
          ((λ i → (rUnitₖ 1 x i) ⌣ₖ z))
       ∙∙ sym (rUnitₖ _ _)
       ∙∙ λ i → (_⌣ₖ_ {n = 1} {m = suc m} x z) +ₖ 0ₖ-⌣ₖ (suc zero) (suc m) z (~ i)

     l≡r : (z : _) → l embase z ≡ r embase z
     l≡r z = pathTypeMake _ _ _

   mainDistrR (suc n) m =
     elim2 (λ _ _ → isOfHLevelPath (4 + n)
                      (isOfHLevel↑∙ (2 + n) m) _ _)
           (wedgeConEM.fun _ _ _ _
             (λ x y → isOfHLevelPath ((2 + n) + (2 + n))
                       (transport (λ i → isOfHLevel (((λ i → (+-comm n 2 (~ i) + (2 + n)))
                                                         ∙ sym (+-assoc n 2 (2 + n))) (~ i))
                                  (EM∙ H' (suc m) →∙ EM∙ ((fst (AbGroupPath (G' ⨂ H') (H' ⨂ G'))) ⨂-comm (~ i))
                                  ((+'-comm (suc m) (suc (suc n))) i)))
                                  (isOfHLevelPlus n
                                    (LeftDistributivity.hLevLem m (suc (suc n))))) _ _)
             (λ x → →∙Homogeneous≡ (isHomogeneousEM _)
                        (funExt (l x)))
             (λ x → →∙Homogeneous≡ (isHomogeneousEM _)
                        (funExt (r x)))
             λ i → →∙Homogeneous≡ (isHomogeneousEM _)
                        (funExt λ z → r≡l z i))
     where
     l : (x : _) (z : _) → _ ≡ _
     l x z = (λ i → (lUnitₖ _ ∣ x ∣ i) ⌣ₖ z)
        ∙∙ sym (lUnitₖ _ (∣ x ∣ ⌣ₖ z))
        ∙∙ λ i → 0ₖ-⌣ₖ _ _ z (~ i) +ₖ (∣ x ∣ ⌣ₖ z)

     r : (x : _) (z : _) → _ ≡ _
     r x z = (λ i → (rUnitₖ _ ∣ x ∣ i) ⌣ₖ z)
           ∙∙ sym (rUnitₖ _ (∣ x ∣ ⌣ₖ z))
           ∙∙ λ i → (∣ x ∣ ⌣ₖ z) +ₖ 0ₖ-⌣ₖ _ _ z (~ i)

     r≡l : (z : _) → l north z ≡ r north z
     r≡l z = pathTypeMake _ _ _

-- TODO: Summarise distributivity proofs
-- TODO: Associativity and graded commutativity, following Cubical.ZCohomology.RingStructure
-- The following lemmas will be needed to make the types match up.


{-# OPTIONS --cubical --no-import-sorts --safe #-}

open import Cubical.Core.Everything
open import Cubical.Foundations.HLevels

module Cubical.Algebra.Monoid.Construct.Free {ℓ} (Aˢ : hSet ℓ) where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Path
open import Cubical.Algebra.Monoid

open import Cubical.Data.Empty.Polymorphic
open import Cubical.Data.Prod

open import Cubical.Relation.Binary.Reasoning.Equality

private
  A = ⟨ Aˢ ⟩
  isSetA = Aˢ .snd

------------------------------------------------------------------------
-- The direct free monoid type

data FreeM : Type ℓ where
  inj : A → FreeM
  _•_ : Op₂ FreeM
  ε   : FreeM

  •-assoc     : Associative _•_
  ε-identityˡ : LeftIdentity ε _•_
  ε-identityʳ : RightIdentity ε _•_

  squash : isSet FreeM

ε-identity : Identity ε _•_
ε-identity = ε-identityˡ , ε-identityʳ

elim : ∀ {ℓ′} {B : FreeM → Type ℓ′} →
        (∀ x → isSet (B x)) →
        (∀ x → B (inj x)) →
        (op : ∀ {x y} → B x → B y → B (x • y)) →
        (e : B ε) →
        (∀ {x y z} (a : B x) (b : B y) (c : B z) → PathP (λ i → B (•-assoc x y z i)) (op (op a b) c) (op a (op b c))) →
        (∀ {x} (a : B x) → PathP (λ i → B (ε-identityˡ x i)) (op e a) a) →
        (∀ {x} (a : B x) → PathP (λ i → B (ε-identityʳ x i)) (op a e) a) →
        (x : FreeM) → B x
elim isSetB f op e assc idˡ idʳ (inj x) = f x
elim isSetB f op e assc idˡ idʳ (x • y) = op (elim isSetB f op e assc idˡ idʳ x) (elim isSetB f op e assc idˡ idʳ y)
elim isSetB f op e assc idˡ idʳ ε = e
elim isSetB f op e assc idˡ idʳ (•-assoc x y z i) = assc (elim isSetB f op e assc idˡ idʳ x)
                                                          (elim isSetB f op e assc idˡ idʳ y)
                                                          (elim isSetB f op e assc idˡ idʳ z) i
elim isSetB f op e assc idˡ idʳ (ε-identityˡ x i) = idˡ (elim isSetB f op e assc idˡ idʳ x) i
elim isSetB f op e assc idˡ idʳ (ε-identityʳ x i) = idʳ (elim isSetB f op e assc idˡ idʳ x) i
elim isSetB f op e assc idˡ idʳ (squash x y p q i j) =
  isOfHLevel→isOfHLevelDep 2 isSetB
    (elim isSetB f op e assc idˡ idʳ x) (elim isSetB f op e assc idˡ idʳ y)
    (cong (elim isSetB f op e assc idˡ idʳ) p) (cong (elim isSetB f op e assc idˡ idʳ) q) (squash x y p q) i j

------------------------------------------------------------------------
-- The simplified free monoid type

-- Defined in Cubical.Data.List
open import Cubical.Data.List
open Structures isSetA public

------------------------------------------------------------------------
-- Proving the two types are equivalent

List→FreeM : List A → FreeM
List→FreeM []       = ε
List→FreeM (x ∷ xs) = inj x • List→FreeM xs

FreeM→List : FreeM → List A
FreeM→List = elim (λ _ → isOfHLevelList 0 isSetA) [_] _++_ [] ++-assoc ++-identityˡ ++-identityʳ

++-hom : Homomorphic₂ List→FreeM _++_ _•_
++-hom [] ys = sym (ε-identityˡ _)
++-hom (x ∷ xs) ys = cong (inj x •_) (++-hom xs ys) ∙ sym (•-assoc (inj x) (List→FreeM xs) (List→FreeM ys))

List→FreeM→List : retract List→FreeM FreeM→List
List→FreeM→List [] = refl
List→FreeM→List (x ∷ xs) = cong (x ∷_) (List→FreeM→List xs)

FreeM→List→FreeM : section List→FreeM FreeM→List
FreeM→List→FreeM = elim (λ _ → isSet→isGroupoid squash _ _) (λ _ → ε-identityʳ _) sectionOp refl
                    (λ _ _ _ → isOfHLevelPathP' 0 (squash _ _) _ _ .fst)
                    (λ _ → isOfHLevelPathP' 0 (squash _ _) _ _ .fst)
                    (λ _ → isOfHLevelPathP' 0 (squash _ _) _ _ .fst)
  where
    sectionOp : ∀ {x y} → List→FreeM (FreeM→List x) ≡ x →
                          List→FreeM (FreeM→List y) ≡ y →
                          List→FreeM (FreeM→List (x • y)) ≡ (x • y)
    sectionOp {x} {y} p q =
      List→FreeM (FreeM→List (x • y))                       ≡⟨⟩
      List→FreeM (FreeM→List x ++ FreeM→List y)             ≡⟨ ++-hom (FreeM→List x) (FreeM→List y) ⟩
      List→FreeM (FreeM→List x) • List→FreeM (FreeM→List y) ≡⟨ cong₂ _•_ p q ⟩
      x • y                                                 ∎

List≃FreeM : List A ≃ FreeM
List≃FreeM = isoToEquiv (iso List→FreeM FreeM→List FreeM→List→FreeM List→FreeM→List)

List≡FreeM : List A ≡ FreeM
List≡FreeM = ua List≃FreeM

------------------------------------------------------------------------
-- Monoid structure

FreeM-isMonoid : IsMonoid FreeM _•_ ε
FreeM-isMonoid = record
  { isSemigroup = record
      { isMagma = record { is-set = squash }
      ; assoc   = •-assoc
      }
  ; identity = ε-identity
  }

FreeMonoid : Monoid ℓ
FreeMonoid = record { isMonoid = FreeM-isMonoid }

EquivFreeM : MonoidEquiv ListMonoid FreeMonoid
EquivFreeM = record
  { eq    = List≃FreeM
  ; isHom = record
      { preservesOp = ++-hom
      ; preservesId = refl
      }
  }

FreeMonoid≡ : ListMonoid ≡ FreeMonoid
FreeMonoid≡ = uaMonoid EquivFreeM


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

-- Definition of Pi with fractionals

module PiFrac2 where

-- From the standard library:
open import Data.Empty using (⊥)
open import Data.Unit using (⊤; tt)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; cong₂)

-- The basic types we add:
open import Singleton

infix  80 ●_ 𝟙/●_
infixr 70 _×ᵤ_
infixr 60 _+ᵤ_
infixr 50 _⊚_

------------------------------------------------------------------------------
-- Pi with fractionals

-- The following are all mutually dependent:

data 𝕌 : Set                               -- 𝕌niverse of types
⟦_⟧ : (A : 𝕌) → Set                        -- denotation of types
data _⟷_ : 𝕌 → 𝕌 → Set                     -- type equivalences
eval : {A B : 𝕌} → (A ⟷ B) → ⟦ A ⟧ → ⟦ B ⟧ -- evaluating an equivalence

data 𝕌 where
  𝟘       : 𝕌
  𝟙       : 𝕌
  _+ᵤ_    : 𝕌 → 𝕌 → 𝕌
  _×ᵤ_    : 𝕌 → 𝕌 → 𝕌
  ●_   : {A : 𝕌} → ⟦ A ⟧ → 𝕌
  𝟙/●_ : {A : 𝕌} → ⟦ A ⟧ → 𝕌

⟦ 𝟘 ⟧ = ⊥
⟦ 𝟙 ⟧ = ⊤
⟦ t₁ +ᵤ t₂ ⟧ = ⟦ t₁ ⟧ ⊎ ⟦ t₂ ⟧
⟦ t₁ ×ᵤ t₂ ⟧ = ⟦ t₁ ⟧ × ⟦ t₂ ⟧
⟦ ● v ⟧ = Singleton _ v
⟦ 𝟙/● v ⟧ = Recip _ v

data _⟷_ where
  unite₊l : {t : 𝕌} → 𝟘 +ᵤ t ⟷ t
  uniti₊l : {t : 𝕌} → t ⟷ 𝟘 +ᵤ t
  unite₊r : {t : 𝕌} → t +ᵤ 𝟘 ⟷ t
  uniti₊r : {t : 𝕌} → t ⟷ t +ᵤ 𝟘
  swap₊   : {t₁ t₂ : 𝕌} → t₁ +ᵤ t₂ ⟷ t₂ +ᵤ t₁
  assocl₊ : {t₁ t₂ t₃ : 𝕌} → t₁ +ᵤ (t₂ +ᵤ t₃) ⟷ (t₁ +ᵤ t₂) +ᵤ t₃
  assocr₊ : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) +ᵤ t₃ ⟷ t₁ +ᵤ (t₂ +ᵤ t₃)
  unite⋆l : {t : 𝕌} → 𝟙 ×ᵤ t ⟷ t
  uniti⋆l : {t : 𝕌} → t ⟷ 𝟙 ×ᵤ t
  unite⋆r : {t : 𝕌} → t ×ᵤ 𝟙 ⟷ t
  uniti⋆r : {t : 𝕌} → t ⟷ t ×ᵤ 𝟙
  swap⋆   : {t₁ t₂ : 𝕌} → t₁ ×ᵤ t₂ ⟷ t₂ ×ᵤ t₁
  assocl⋆ : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ ×ᵤ t₃) ⟷ (t₁ ×ᵤ t₂) ×ᵤ t₃
  assocr⋆ : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₂) ×ᵤ t₃ ⟷ t₁ ×ᵤ (t₂ ×ᵤ t₃)
  absorbr : {t : 𝕌} → 𝟘 ×ᵤ t ⟷ 𝟘
  absorbl : {t : 𝕌} → t ×ᵤ 𝟘 ⟷ 𝟘
  factorzr : {t : 𝕌} → 𝟘 ⟷ t ×ᵤ 𝟘
  factorzl : {t : 𝕌} → 𝟘 ⟷ 𝟘 ×ᵤ t
  dist    : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) ×ᵤ t₃ ⟷ (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃)
  factor  : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃) ⟷ (t₁ +ᵤ t₂) ×ᵤ t₃
  distl   : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ +ᵤ t₃) ⟷ (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃)
  factorl : {t₁ t₂ t₃ : 𝕌 } → (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃) ⟷ t₁ ×ᵤ (t₂ +ᵤ t₃)
  id⟷     : {t : 𝕌} → t ⟷ t
  _⊚_     : {t₁ t₂ t₃ : 𝕌} → (t₁ ⟷ t₂) → (t₂ ⟷ t₃) → (t₁ ⟷ t₃)
  _⊕_     : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ⟷ t₃) → (t₂ ⟷ t₄) → (t₁ +ᵤ t₂ ⟷ t₃ +ᵤ t₄)
  _⊗_     : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ⟷ t₃) → (t₂ ⟷ t₄) → (t₁ ×ᵤ t₂ ⟷ t₃ ×ᵤ t₄)
  -- new operations on Singleton
{--
  lift : {t₁ t₂ : 𝕌} → {v₁ : ⟦ t₁ ⟧} →
           (c : t₁ ⟷ t₂) →
           ((● v₁) ⟷ (● (eval c v₁)))
  tensorl : {t₁ t₂ : 𝕌} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} →
            ●_ {A = t₁ ×ᵤ t₂} (v₁ , v₂) ⟷ ● v₁ ×ᵤ ● v₂
  tensorr : {t₁ t₂ : 𝕌} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} →
            ● v₁ ×ᵤ ● v₂ ⟷ ●_ {A = t₁ ×ᵤ t₂} (v₁ , v₂)
  plusll : {t₁ t₂ : 𝕌} {v : ⟦ t₁ ⟧} →
            ●_ {A = t₁ +ᵤ t₂} (inj₁ v) ⟷ ● v
  pluslr : {t₁ t₂ : 𝕌} {v : ⟦ t₁ ⟧} →
             ● v ⟷ ●_ {A = t₁ +ᵤ t₂} (inj₁ v)
  plusrl : {t₁ t₂ : 𝕌} {v : ⟦ t₂ ⟧} →
            ●_ {A = t₁ +ᵤ t₂} (inj₂ v) ⟷ ● v
  plusrr : {t₁ t₂ : 𝕌} {v : ⟦ t₂ ⟧} →
             ● v ⟷ ●_ {A = t₁ +ᵤ t₂} (inj₂ v)
  fracl : {t₁ t₂ : 𝕌} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} →
            𝟙/●_ {A = t₁ ×ᵤ t₂} (v₁ , v₂) ⟷ 𝟙/● v₁ ×ᵤ 𝟙/● v₂
  fracr : {t₁ t₂ : 𝕌} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} →
            𝟙/● v₁ ×ᵤ 𝟙/● v₂ ⟷ 𝟙/●_ {A = t₁ ×ᵤ t₂} (v₁ , v₂)
--}
  -- fractionals
  η : {t : 𝕌} → (v : ⟦ t ⟧) → 𝟙 ⟷ ● v ×ᵤ 𝟙/● v
  ε : {t : 𝕌} → (v : ⟦ t ⟧) → ● v ×ᵤ 𝟙/● v ⟷ 𝟙
  -- double lift prop eq
{--
  ll : ∀ {t : 𝕌} {v : ⟦ t ⟧} {w : ⟦ ● v ⟧} →
        ●_ {A = ● v} w  ⟷ ● v
  == : ∀ {t₁ t₂ : 𝕌} {v : ⟦ t₁ ⟧} {w w' : ⟦ t₂ ⟧} →
       (● v ⟷ ● w) → (w ≡ w') → (● v ⟷ ● w')
--}

eval unite₊l (inj₂ v) = v
eval uniti₊l v  = inj₂ v
eval unite₊r (inj₁ v) = v
eval uniti₊r v  = inj₁ v
eval swap₊ (inj₁ v) = inj₂ v
eval swap₊ (inj₂ v) = inj₁ v
eval assocl₊ (inj₁ v) = inj₁ (inj₁ v)
eval assocl₊ (inj₂ (inj₁ v)) = inj₁ (inj₂ v)
eval assocl₊ (inj₂ (inj₂ v)) = inj₂ v
eval assocr₊ (inj₁ (inj₁ v)) = inj₁ v
eval assocr₊ (inj₁ (inj₂ v)) = inj₂ (inj₁ v)
eval assocr₊ (inj₂ v) = inj₂ (inj₂ v)
eval unite⋆l (tt , v) = v
eval uniti⋆l v = (tt , v)
eval unite⋆r (v , tt) = v
eval uniti⋆r v = (v , tt)
eval swap⋆ (v₁ , v₂)          = (v₂ , v₁)
eval assocl⋆ (v₁ , (v₂ , v₃)) = ((v₁ , v₂) , v₃)
eval assocr⋆ ((v₁ , v₂) , v₃) = (v₁ , (v₂ , v₃))
eval absorbl ()
eval absorbr ()
eval factorzl ()
eval factorzr ()
eval dist (inj₁ v₁ , v₃) = inj₁ (v₁ , v₃)
eval dist (inj₂ v₂ , v₃) = inj₂ (v₂ , v₃)
eval factor (inj₁ (v₁ , v₃)) = (inj₁ v₁ , v₃)
eval factor (inj₂ (v₂ , v₃)) = (inj₂ v₂ , v₃)
eval distl (v , inj₁ v₁) = inj₁ (v , v₁)
eval distl (v , inj₂ v₂) = inj₂ (v , v₂)
eval factorl (inj₁ (v , v₁)) = (v , inj₁ v₁)
eval factorl (inj₂ (v , v₂)) = (v , inj₂ v₂)
eval id⟷ v = v
eval (c₁ ⊚ c₂) v = eval c₂ (eval c₁ v)
eval (c₁ ⊕ c₂) (inj₁ v) = inj₁ (eval c₁ v)
eval (c₁ ⊕ c₂) (inj₂ v) = inj₂ (eval c₂ v)
eval (c₁ ⊗ c₂) (v₁ , v₂) = (eval c₁ v₁ , eval c₂ v₂)
{--
eval (lift c) (w , v≡w) = eval c w , cong (eval c) v≡w
eval tensorl ((w₁ , w₂) , vp≡wp) =
  (w₁ , cong proj₁ vp≡wp) , (w₂ , cong proj₂ vp≡wp)
eval tensorr ((w₁ , p₁) , (w₂ , p₂)) =
  (w₁ , w₂) , cong₂ _,_ p₁ p₂
--}
eval (η v) tt = (v , refl) , λ _ → tt
eval (ε v) (p , f) = f p
{--
eval (plusll {v = .w₁}) (inj₁ w₁ , refl) = w₁ , refl
eval pluslr (v₁ , refl) = inj₁ v₁ , refl
eval (plusrl {v = .w₂}) (inj₂ w₂ , refl) = w₂ , refl
eval plusrr (v₂ , refl) = inj₂ v₂ , refl
eval (fracl {v₁ = v₁} {v₂ = v₂}) f = (λ _ → f ((v₁ , v₂) , refl)) , (λ _ → f ((v₁ , v₂) , refl))
eval fracr (f₁ , f₂) ((w₁ , w₂) , refl) = let _ = f₁ (w₁ , refl) ; _ = f₂ (w₂ , refl) in tt
eval (ll {t} {v} {.w}) (w , refl) = v , refl
eval (== c eq) s₁ = let (w₂ , p) = eval c s₁ in w₂ , trans (sym eq) p
--}

-- monad/comonad pair

{--

focus : {t : 𝕌} → (v : ⟦ t ⟧) → Singleton ⟦ t ⟧ v
focus v = (v , refl)

unfocus : {t : 𝕌} {v : ⟦ t ⟧} → Singleton ⟦ t ⟧ v → ⟦ t ⟧
unfocus (v , refl) = v

open import Data.Empty using (⊥)
open import Data.Unit using (⊤; tt)
open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_]′)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; subst)

------------------------------------------------------------------------------
-- Useful for examples

infixr 2  _⟷⟨_⟩_
infix  3  _□

_⟷⟨_⟩_ : (t₁ : 𝕌) {t₂ : 𝕌} {t₃ : 𝕌} →
          (t₁ ⟷ t₂) → (t₂ ⟷ t₃) → (t₁ ⟷ t₃)
_ ⟷⟨ α ⟩ β = α ⊚ β

_□ : (t : 𝕌) → {t : 𝕌} → (t ⟷ t)
_□ t = id⟷

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

𝔹 : 𝕌
𝔹 = 𝟙 +ᵤ 𝟙

𝔹² : 𝕌
𝔹² = 𝔹 ×ᵤ 𝔹

𝔽 𝕋 : ⟦ 𝔹 ⟧
𝔽 = inj₁ tt
𝕋 = inj₂ tt

not : ⟦ 𝔹 ⟧ → ⟦ 𝔹 ⟧
not (inj₁ tt) = inj₂ tt
not (inj₂ tt) = inj₁ tt

-- this version might look more contrived that the fully expanded
-- one via pattern matching, but it generalizes better.
controlled : ∀ {A} → (⟦ A ⟧ → ⟦ A ⟧) → ⟦ 𝔹 ⟧ × ⟦ A ⟧ → ⟦ 𝔹 ⟧ × ⟦ A ⟧
controlled f (b , a) = (b , [ (λ _ → a) , (λ _ → f a) ]′ b)
-- controlled f (inj₁ tt , a) = (inj₁ tt , a  )
-- controlled f (inj₂ tt , a) = (inj₂ tt , f a)

------------------------------------------------------------------------------
-- Examples

zigzag : ∀ b → ●_ {𝔹} b ⟷ ● b
zigzag b =
  uniti⋆l ⊚                -- ONE * POINTED TWO
  (η b ⊗ id⟷) ⊚          -- (POINTED TWO * RECIP TWO) * POINTED TWO
  assocr⋆ ⊚                -- POINTED TWO * (RECIP TWO * POINTED TWO)
  (id⟷ ⊗ swap⋆) ⊚         -- POINTED TWO * (POINTED TWO * RECIP TWO)
  (id⟷ ⊗ ε b) ⊚           -- POINTED TWO * ONE
  unite⋆r

test1 = eval (zigzag 𝔽) (𝔽 , refl)      -- (⇑ #f refl)
-- test2 = eval (zigzag 𝔽) (𝕋 , refl)   -- typechecks if given proof #f=#t
-- test3 = eval (zigzag 𝕋) (𝔽 , refl)   -- typechecks if given proof #f=#t
test4 = eval (zigzag 𝕋) (𝕋 , refl)      -- (⇑ #t refl)

zigzagU : ⟦ 𝔹 ⟧ → ⟦ 𝔹 ⟧
zigzagU b = unfocus (eval (zigzag b) (focus b))

-- Conventional PI examples

NOT : 𝔹 ⟷ 𝔹
NOT = swap₊

NEG1 NEG2 NEG3 NEG4 NEG5 : 𝔹 ⟷ 𝔹
NEG1 = swap₊
NEG2 = id⟷ ⊚ NOT
NEG3 = NOT ⊚ NOT ⊚ NOT
NEG4 = NOT ⊚ id⟷
NEG5 = uniti⋆l ⊚ swap⋆ ⊚ (NOT ⊗ id⟷) ⊚ swap⋆ ⊚ unite⋆l
NEG6 = uniti⋆r ⊚ (NOT ⊗ id⟷) ⊚ unite⋆r -- same as above, but shorter

CNOT : 𝔹² ⟷ 𝔹²
CNOT =
  𝔹 ×ᵤ 𝔹                ⟷⟨ id⟷ ⟩
  (x +ᵤ y) ×ᵤ 𝔹         ⟷⟨ dist ⟩
  (x ×ᵤ 𝔹) +ᵤ (y ×ᵤ 𝔹)  ⟷⟨ id⟷ ⊕ (id⟷ ⊗ NOT) ⟩
  (x ×ᵤ 𝔹) +ᵤ (y ×ᵤ 𝔹)  ⟷⟨ factor ⟩
  (x +ᵤ y) ×ᵤ 𝔹         ⟷⟨ id⟷ ⟩
  𝔹 ×ᵤ 𝔹 □
  where x = 𝟙; y = 𝟙

TOFFOLI : 𝔹 ×ᵤ 𝔹² ⟷ 𝔹 ×ᵤ 𝔹²
TOFFOLI =
  𝔹 ×ᵤ 𝔹²                 ⟷⟨ id⟷ ⟩
  (x +ᵤ y) ×ᵤ 𝔹²          ⟷⟨ dist ⟩
  (x ×ᵤ 𝔹²) +ᵤ (y ×ᵤ 𝔹²)  ⟷⟨ id⟷ ⊕ (id⟷ ⊗ CNOT) ⟩
  (x ×ᵤ 𝔹²) +ᵤ (y ×ᵤ 𝔹²)  ⟷⟨ factor ⟩
  (x +ᵤ y) ×ᵤ 𝔹²          ⟷⟨ id⟷ ⟩
  𝔹 ×ᵤ 𝔹² □
  where x = 𝟙; y = 𝟙

PERES : (𝔹 ×ᵤ 𝔹) ×ᵤ 𝔹 ⟷ (𝔹 ×ᵤ 𝔹) ×ᵤ 𝔹
PERES = (id⟷ ⊗ NOT) ⊚ assocr⋆ ⊚ (id⟷ ⊗ swap⋆) ⊚
        TOFFOLI ⊚
        (id⟷ ⊗ (NOT ⊗ id⟷)) ⊚
        TOFFOLI ⊚
        (id⟷ ⊗ swap⋆) ⊚ (id⟷ ⊗ (NOT ⊗ id⟷)) ⊚
        TOFFOLI ⊚
        (id⟷ ⊗ (NOT ⊗ id⟷)) ⊚ assocl⋆

SWAP12 SWAP23 SWAP13 ROTL ROTR : 𝟙 +ᵤ 𝟙 +ᵤ 𝟙 ⟷ 𝟙 +ᵤ 𝟙 +ᵤ 𝟙
SWAP12 = assocl₊ ⊚ (swap₊ ⊕ id⟷) ⊚ assocr₊
SWAP23 = id⟷ ⊕ swap₊
SWAP13 = SWAP23 ⊚ SWAP12 ⊚ SWAP23
ROTR   = SWAP12 ⊚ SWAP23
ROTL   = SWAP13 ⊚ SWAP23

t3 : ∀ {b₁ b₂} →
     ● (𝔽 , (b₁ , b₂)) ⟷
     ● (𝔽 , (b₁ , b₂))
t3 = lift TOFFOLI

{--
The following do not typecheck. Good

t4 : ● (𝔹 ×ᵤ 𝔹²) [ 𝕋 , (𝔽 , 𝔽) ] ⟷
     ● (𝔹 ×ᵤ 𝔹²) [ 𝕋 , (𝔽 , 𝕋) ]
t4 = lift TOFFOLI

t5 : ∀ {b₁ b₂} →
     ● (𝔹 ×ᵤ 𝔹²) [ b₁ , (𝔽 , b₂) ] ⟷
     ● (𝔹 ×ᵤ 𝔹²) [ b₁ , (𝔽 , b₂) ]
t5 = lift TOFFOLI
--}

t6 : ∀ {b} →
     ● (𝕋 , (𝕋 , b)) ⟷
     ● (𝕋 , (𝕋 , eval NOT b))
t6 = lift TOFFOLI

-- Ancilla examples from literature

-- Fig. 2 in Ricercar

CONTROLLED : {A : 𝕌} → (A ⟷ A) → 𝔹 ×ᵤ A ⟷ 𝔹 ×ᵤ A
CONTROLLED c = dist ⊚ (id⟷ ⊕ (id⟷ ⊗ c)) ⊚ factor

fig2a : 𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹 ⟷
        𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹
fig2a = CONTROLLED (CONTROLLED (CONTROLLED NOT))

-- first write the circuit with the additional ancilla

fig2b' : ((𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹) ×ᵤ 𝔹) ⟷ ((𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹) ×ᵤ 𝔹)
fig2b' =
  (swap⋆ ⊗ id⟷) ⊚
  assocr⋆ ⊚
  (swap⋆ ⊗ id⟷) ⊚
  assocr⋆ ⊚
  (id⟷ ⊗ CONTROLLED (CONTROLLED NOT))  -- first ccnot
  ⊚
  assocl⋆ ⊚
  (swap⋆ ⊗ id⟷) ⊚
  assocl⋆ ⊚
  (swap⋆ ⊗ id⟷)                        -- move it back
  ⊚
  (assocl⋆ ⊗ id⟷) ⊚
  assocr⋆ ⊚
  (id⟷ ⊗ swap⋆) ⊚
  (id⟷ ⊗ CONTROLLED (CONTROLLED NOT))  -- second ccnot
  ⊚
  (id⟷ ⊗ swap⋆) ⊚
  assocl⋆ ⊚
  (assocr⋆ ⊗ id⟷)                      -- move it back
  ⊚
  (swap⋆ ⊗ id⟷) ⊚
  assocr⋆ ⊚
  (swap⋆ ⊗ id⟷) ⊚
  assocr⋆ ⊚
  (id⟷ ⊗ CONTROLLED (CONTROLLED NOT))  -- third ccnot
  ⊚
  assocl⋆ ⊚
  (swap⋆ ⊗ id⟷) ⊚
  assocl⋆ ⊚
  (swap⋆ ⊗ id⟷)                        -- move it back

-- then prove a theorem that specifies its semantics

fig2b'≡ : (a b c d : ⟦ 𝔹 ⟧) →
          proj₂ (eval fig2b' ((a , b , c , d) , 𝔽)) ≡ 𝔽
fig2b'≡ a         (inj₁ tt) c d = refl
fig2b'≡ (inj₁ tt) (inj₂ tt) c d = refl
fig2b'≡ (inj₂ tt) (inj₂ tt) c d = refl

-- generalize above?  Method:
-- for 'dist' to evaluate, need to split on b first
--   in first case, split on e (same reason)
--   in second case, split on a (same reason)
--     split on e
--     split on e
foo : (a b c d e : ⟦ 𝔹 ⟧) →
          proj₂ (eval fig2b' ((a , b , c , d) , e)) ≡ e
foo a         (inj₁ x) c d (inj₁ x₁) = refl
foo a         (inj₁ x) c d (inj₂ y)  = refl
foo (inj₁ x)  (inj₂ y) c d (inj₁ x₁) = refl
foo (inj₁ x)  (inj₂ y) c d (inj₂ y₁) = refl
foo (inj₂ y₁) (inj₂ y) c d (inj₁ x)  = refl
foo (inj₂ y₁) (inj₂ y) c d (inj₂ y₂) = refl

postulate
  -- boring...
  tensor4 : ∀ {a b c d e} →
          (●_ {𝔹} a ×ᵤ ●_ {𝔹} b ×ᵤ ●_ {𝔹} c ×ᵤ ●_ {𝔹} d) ×ᵤ ●_ {𝔹} e ⟷
          ●_ {(𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹) ×ᵤ 𝔹} ((a , b , c , d) , e)
  itensor4 : ∀ {a b c d e} →
          ●_ {(𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹 ×ᵤ 𝔹) ×ᵤ 𝔹} ((a , b , c , d) , e) ⟷
          (● a ×ᵤ ● b ×ᵤ ● c ×ᵤ ● d)  ×ᵤ ● e

-- now lift it

fig2b : ∀ {a b c d e} →
        let ((x , y , z , w) , u) = eval fig2b' ((a , b , c , d) , e)
        in
           ● a ×ᵤ ● b ×ᵤ ● c ×ᵤ ● d ⟷
           ● x ×ᵤ ● y ×ᵤ ● z ×ᵤ ● w
fig2b {a} {b} {c} {d} {e} =
  let ((x , y , z , w) , u) = eval fig2b' ((a , b , c , d) , e)
  in    uniti⋆r ⊚
        -- (●𝔹[a] × ●𝔹[b] × ●𝔹[c] × ●𝔹[d]) × ●𝟙[e]
        (id⟷ ⊗ η e) ⊚
        -- (●𝔹[a] × ●𝔹[b] × ●𝔹[c] × ●𝔹[d]) × (●𝔹[e] x ●1/𝔹[e])
        assocl⋆ ⊚
        -- ((●𝔹[a] × ●𝔹[b] × ●𝔹[c] × ●𝔹[d]) × ●𝔹[e) x ●1/𝔹[e]
        (tensor4 ⊗ id⟷) ⊚
         -- ● ((𝔹 × 𝔹 × 𝔹 × 𝔹) × 𝔹) [ (a,b,c,d),e ] x ●1/𝔹[e]
        (lift fig2b' ⊗ id⟷) ⊚
         -- ● ((𝔹 × 𝔹 × 𝔹 × 𝔹) × 𝔹) [ (x,y,z,w),e ] x ●1/𝔹[e]
        (((== id⟷ (cong (λ H → ((x , y , z , w)) , H) (foo a b c d e))) ⊗ id⟷)) ⊚
         -- ● ((𝔹 × 𝔹 × 𝔹 × 𝔹) × 𝔹) [ (x,y,z,w),e ] x ●1/𝔹[e]
        (itensor4 ⊗ id⟷) ⊚
         -- ((●𝔹[x] × ●𝔹[y] × ●𝔹[z] × ●𝔹[w]) × ●𝔹[e]) x ●1/𝔹[e]
        assocr⋆ ⊚
        (id⟷ ⊗ ε e) ⊚
        unite⋆r

-- This is mostly to show that == is really 'subst' in hiding.
fig2b₂ : ∀ {a b c d e} →
        let ((x , y , z , w) , u) = eval fig2b' ((a , b , c , d) , e)
        in
           ● a ×ᵤ ● b ×ᵤ ● c ×ᵤ ● d ⟷
           ● x ×ᵤ ● y ×ᵤ ● z ×ᵤ ● w
fig2b₂ {a} {b} {c} {d} {e} =
  let ((x , y , z , w) , u) = eval fig2b' ((a , b , c , d) , e)
  in    uniti⋆r ⊚
        -- (●𝔹[a] × ●𝔹[b] × ●𝔹[c] × ●𝔹[d]) × ●𝟙[e]
        (id⟷ ⊗ η e) ⊚
        -- (●𝔹[a] × ●𝔹[b] × ●𝔹[c] × ●𝔹[d]) × (●𝔹[e] x ●1/𝔹[e])
        assocl⋆ ⊚
        -- ((●𝔹[a] × ●𝔹[b] × ●𝔹[c] × ●𝔹[d]) × ●𝔹[e) x ●1/𝔹[e]
        (tensor4 ⊗ id⟷) ⊚
         -- ● ((𝔹 × 𝔹 × 𝔹 × 𝔹) × 𝔹) [ (a,b,c,d),e ] x ●1/𝔹[e]
        (lift fig2b' ⊗ id⟷) ⊚
         -- ● ((𝔹 × 𝔹 × 𝔹 × 𝔹) × 𝔹) [ (x,y,z,w),e ] x ●1/𝔹[e]
        (itensor4 ⊗ id⟷) ⊚
         -- ((●𝔹[x] × ●𝔹[y] × ●𝔹[z] × ●𝔹[w]) × ●𝔹[e]) x ●1/𝔹[e]
        assocr⋆ ⊚
        (id⟷ ⊗ (subst (λ ee → ● ee ×ᵤ 𝟙/● e ⟷ 𝟙) (sym (foo a b c d e)) (ε e))) ⊚
        unite⋆r

open import Data.Empty using (⊥)
open import Data.Unit using (⊤; tt)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; cong₂; subst; module ≡-Reasoning)

open import Data.Product using (Σ; _,_; proj₁; proj₂)
open import Relation.Binary.PropositionalEquality
  using (_≡_; subst)

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

dual : {A B : 𝕌} → (f : A ⟷ B) → (v : ⟦ A ⟧ ) →
                   (𝟙/● (eval f v) ⟷ 𝟙/● v)
dual f v = uniti⋆l ⊚ (η v ⊗ id⟷) ⊚ ((lift f ⊗ id⟷) ⊗ id⟷) ⊚
  assocr⋆ ⊚ (id⟷ ⊗ swap⋆) ⊚ assocl⋆ ⊚ (ε (eval f v) ⊗ id⟷) ⊚ unite⋆l

-- name, coname
name : {A B : 𝕌} → (f : A ⟷ B) → (v : ⟦ A ⟧ ) → 𝟙 ⟷ ● (eval f v) ×ᵤ 𝟙/● v
name f v = η v ⊚ (lift f ⊗ id⟷)

coname : {A B : 𝕌} → (f : A ⟷ B) → (v : ⟦ A ⟧ ) → ● v ×ᵤ 𝟙/● (eval f v) ⟷ 𝟙
coname f v = (lift f ⊗ id⟷) ⊚ ε (eval f v)

-- and 'trace' reveals something neat: we can't choose just any random 'a' and 'c'
-- to start with, but we need that make a coherence choice of a and c !!
trace : {A B C : 𝕌} (a : ⟦ A ⟧ ) → (f : A ×ᵤ C ⟷ B ×ᵤ C) →
  (coh : Σ ⟦ C ⟧ (λ c → proj₂ (eval f (a , c)) ≡ c)) →
  ● a ⟷ ● (proj₁ (eval f (a , proj₁ coh)))
trace {A} {B} {C} a f (c , choice) =
  uniti⋆r ⊚        -- A ×ᵤ 1
  (id⟷ ⊗ η c) ⊚   -- A ×ᵤ (C ×ᵤ 1/C)
  assocl⋆ ⊚       -- (A ×ᵤ C) ×ᵤ 1/C
  (tensorr ⊗ id⟷) ⊚ -- bring in the ●
  (lift f ⊗ id⟷) ⊚ -- (B ×ᵤ C) ×ᵤ 1/C
  (tensorl ⊗ id⟷) ⊚ -- bring out the ●
  assocr⋆ ⊚          -- B ×ᵤ (C ×ᵤ 1/C)
  (id⟷ ⊗ (subst fixer choice id⟷ ⊚ ε c)) ⊚ -- B ×ᵤ 1
  unite⋆r
  where
    fixer : ⟦ C ⟧ → Set
    fixer d = (● (proj₂ (eval f (a , c))) ×ᵤ 𝟙/● d) ⟷ (● d ×ᵤ 𝟙/● d)

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

-- Example in Sec. 4.3 from Abramsky's paper
-- http://www.cs.ox.ac.uk/files/341/calco05.pdf

q : {A1 A2 A3 A4 B1 B2 B3 B4 : 𝕌} →
  (f1 : A1 ⟷ B2) →
  (f2 : A2 ⟷ B4) →
  (f3 : A3 ⟷ B3) →
  (f4 : A4 ⟷ B1) →
  A1 ×ᵤ (A2 ×ᵤ (A3 ×ᵤ A4)) ⟷ B1 ×ᵤ (B2 ×ᵤ (B3 ×ᵤ B4))
q {A1} {A2} {A3} {A4} {B1} {B2} {B3} {B4} f1 f2 f3 f4 =
  (A1 ×ᵤ A2 ×ᵤ A3 ×ᵤ A4)     ⟷⟨ f1 ⊗ (f2 ⊗ (f3 ⊗ f4)) ⟩
  (B2 ×ᵤ B4 ×ᵤ B3 ×ᵤ B1)     ⟷⟨ assocl⋆ ⟩
  (B2 ×ᵤ B4) ×ᵤ (B3 ×ᵤ B1)   ⟷⟨ swap⋆ ⟩
  (B3 ×ᵤ B1) ×ᵤ (B2 ×ᵤ B4)   ⟷⟨ swap⋆ ⊗ id⟷ ⟩
  (B1 ×ᵤ B3) ×ᵤ (B2 ×ᵤ B4)   ⟷⟨ assocr⋆ ⊚ (id⟷ ⊗ assocl⋆) ⟩
  B1 ×ᵤ ((B3 ×ᵤ B2) ×ᵤ B4)   ⟷⟨ id⟷ ⊗ ((swap⋆ ⊗ id⟷) ⊚ assocr⋆) ⟩
  B1 ×ᵤ (B2 ×ᵤ (B3 ×ᵤ B4)) □

q' : {A1 U2 U3 U4 B1 : 𝕌} →
  (f1 : A1 ⟷ U2) →
  (f2 : U2 ⟷ U4) →
  (f3 : U3 ⟷ U3) →
  (f4 : U4 ⟷ B1) → (v : ⟦ A1 ⟧) (u3 : ⟦ U3 ⟧)  → (u3-fix : eval f3 u3 ≡ u3) →
  let u2 = eval f1 v in
  let u4 = eval f2 u2 in
  ● v ⟷ ● (proj₁ (eval (q f1 f2 f3 f4) (v , u2 , u3 , u4)))
q' f1 f2 f3 f4 v u3 u3fix =
  trace v (q f1 f2 f3 f4) (( u2 , ( u3 , u4 ) ), cong₂ _,_ refl (cong₂ _,_ u3fix refl))
  where
    u2 = eval f1 v
    u3′ = eval f3 u3
    u4 = eval f2 u2

-- The point is that q' acts in a very particular way:
q'-closed-form : {A1 U2 U3 U4 B1 : 𝕌} →
  (f1 : A1 ⟷ U2) →
  (f2 : U2 ⟷ U4) →
  (f3 : U3 ⟷ U3) →
  (f4 : U4 ⟷ B1) → (u3 : ⟦ U3 ⟧) (u3-fix : eval f3 u3 ≡ u3) → (v : ⟦ A1 ⟧) →
  proj₁ (eval (q' f1 f2 f3 f4 v u3 u3-fix) (v , refl)) ≡ eval (f1 ⊚ f2 ⊚ f4) v
q'-closed-form f1 f2 f3 f4 u3 u3fix v = refl

---------------------------------------------------------------------------------
-- I think the examples below are 'obsolete', in the sense that the one above
-- is more faithful to the original, and more general too.  Delete?
p : {A1 A2 A3 A4 : 𝕌} →
    (A1 ×ᵤ A2) ×ᵤ (A3 ×ᵤ A4) ⟷ (A2 ×ᵤ A4) ×ᵤ (A3 ×ᵤ A1)
p = (swap⋆ ⊗ swap⋆) ⊚
       assocr⋆ ⊚ (id⟷ ⊗ assocl⋆) ⊚ (id⟷ ⊗ (swap⋆ ⊗ id⟷)) ⊚
       (id⟷ ⊗ assocr⋆) ⊚ assocl⋆ ⊚ (id⟷ ⊗ swap⋆)

p' : {A1 A2 A3 A4 : 𝕌} →
    ((A1 ×ᵤ A2) ×ᵤ A4) ×ᵤ A3 ⟷ ((A2 ×ᵤ A4) ×ᵤ A1) ×ᵤ A3
p' = assocr⋆ ⊚ (id⟷ ⊗ swap⋆) ⊚ p ⊚ (id⟷ ⊗ swap⋆) ⊚ assocl⋆

p2 : 𝔹 ×ᵤ (𝔹 ×ᵤ (𝔹 ×ᵤ 𝔹)) ⟷ 𝔹 ×ᵤ (𝔹 ×ᵤ (𝔹 ×ᵤ 𝔹))
p2 = assocl⋆ ⊚ (swap⋆ ⊗ swap⋆) ⊚
       assocr⋆ ⊚ (id⟷ ⊗ assocl⋆) ⊚ (id⟷ ⊗ (swap⋆ ⊗ id⟷)) ⊚
       (id⟷ ⊗ assocr⋆) ⊚ assocl⋆ ⊚ (id⟷ ⊗ swap⋆) ⊚ assocr⋆

p2' : (v : ⟦ 𝔹 ⟧) →
      ● v ⟷ ● (proj₁ (proj₁ (eval p ((v , v) , (v , v)))))
p2' v = trace v p2 ((v , (v , v)) , refl)

---------------------------------------------------------------------------------
-- Examples inspired by compact closed categories and fractional numbers.

-- Intuition:
-- 1/A x B is a space transformer; takes A space and returns B space
-- denote space transformers as A ⊸ B

-- Best we can do:
-- we need Singletons, so |a ⊸ b| is 1 component of a function.

_⊸_ : {A : 𝕌} → (a : ⟦ A ⟧) → {B : 𝕌} → (b : ⟦ B ⟧) → 𝕌
_⊸_ {A} a {B} b = 𝟙/● a ×ᵤ ● b

id⊸ : {A : 𝕌} {a : ⟦ A ⟧} → (a ⊸ a) ⟷ 𝟙
id⊸ {A} {a} =
  (𝟙/● a ×ᵤ ● a) ⟷⟨ swap⋆ ⟩
  (● a ×ᵤ 𝟙/● a) ⟷⟨ ε a ⟩
  𝟙 □

comp⊸ : {A B C : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} {c : ⟦ C ⟧} →
        (a ⊸ b) ×ᵤ (b ⊸ c) ⟷ (a ⊸ c)
comp⊸ {A} {B} {C} {a} {b} {c} =
  (𝟙/● a ×ᵤ ● b) ×ᵤ (𝟙/● b ×ᵤ ● c) ⟷⟨ assocr⋆ ⟩
  𝟙/● a ×ᵤ (● b ×ᵤ (𝟙/● b ×ᵤ ● c)) ⟷⟨ id⟷ ⊗ assocl⋆ ⟩
  𝟙/● a ×ᵤ (● b ×ᵤ 𝟙/● b) ×ᵤ ● c   ⟷⟨ id⟷ ⊗ (ε b ⊗ id⟷) ⟩
  𝟙/● a ×ᵤ (𝟙 ×ᵤ ● c)                          ⟷⟨ id⟷ ⊗ unite⋆l ⟩
  𝟙/● a ×ᵤ ● c □

app : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} → (a ⊸ b) ×ᵤ ● a ⟷ ● b
app {A} {B} {a} {b} =
  (𝟙/● a ×ᵤ ● b) ×ᵤ ● a ⟷⟨ swap⋆ ⊗ id⟷ ⟩
  (● b ×ᵤ 𝟙/● a) ×ᵤ ● a ⟷⟨ assocr⋆ ⊚ (id⟷ ⊗ (swap⋆ ⊚ ε a)) ⟩
  ● b ×ᵤ 𝟙                          ⟷⟨ unite⋆r ⟩
  ● b □

-- B/A × D/C ⟷ B × D / A × C
dist×/ : {A B C D : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} {c : ⟦ C ⟧} {d : ⟦ D ⟧}
       → (a ⊸ b) ×ᵤ (c ⊸ d) ⟷ ((a , c) ⊸ (b , d))
dist×/ {A} {B} {C} {D} {a} {b} {c} {d} =
  (𝟙/● a ×ᵤ ● b) ×ᵤ (𝟙/● c ×ᵤ ● d) ⟷⟨ assocr⋆ ⊚ (id⟷ ⊗ assocl⋆) ⟩
  (𝟙/● a ×ᵤ (● b ×ᵤ 𝟙/● c) ×ᵤ ● d) ⟷⟨ id⟷ ⊗ (swap⋆ ⊗ id⟷) ⟩
  (𝟙/● a ×ᵤ (𝟙/● c ×ᵤ ● b) ×ᵤ ● d) ⟷⟨ (id⟷ ⊗ assocr⋆) ⊚ assocl⋆ ⟩
  (𝟙/● a ×ᵤ 𝟙/● c) ×ᵤ (● b ×ᵤ ● d) ⟷⟨ fracr ⊗ tensorr ⟩
  (𝟙/●_ {A ×ᵤ C} (a , c)) ×ᵤ (●_ {B ×ᵤ D} (b , d)) □

-- 1/A x 1/B <-> 1 / (A x B)
rev× : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧}
     → (a ⊸ tt) ×ᵤ (b ⊸ tt) ⟷ ((a , b) ⊸ tt)
rev× {A} {B} {a} {b} =
  (𝟙/● a ×ᵤ ● tt) ×ᵤ (𝟙/● b ×ᵤ ● tt) ⟷⟨ dist×/ ⟩
  (𝟙/● (a , b) ×ᵤ ● (tt , tt)) ⟷⟨ id⟷ ⊗ lift unite⋆l ⟩
  (𝟙/●_ {A ×ᵤ B} (a , b) ×ᵤ ● tt) □

{--
trivial : ● 𝟙 [ tt ] ⟷ 𝟙
trivial = {!!}
--}

-- (A <-> B) -> (1/A <-> 1/B)
--rev : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧}
--     → ● A [ a ] ⟷ ● B [ b ] → (b ⊸ tt) ⟷ (a ⊸ tt)
--  (𝟙/● A [ a ] ×ᵤ ● 𝟙 [ tt ]) ⟷⟨ {!!} ⟩
--  (𝟙/● B [ b ] ×ᵤ ● 𝟙 [ tt ]) □

rev : {A B : 𝕌} {a : ⟦ A ⟧}
     → (f : A ⟷ B) → (𝟙/● (eval f a) ⟷ 𝟙/● a)
rev {A} {B} {a} f = dual f a

-- A <-> 1 / (1/A)
revrev : {A : 𝕌} {a : ⟦ A ⟧} {a⋆ : ⟦ 𝟙/● a ⟧} →
         ● a ⟷ 𝟙/● a⋆
revrev {A} {a} {a⋆} =
  ● a ⟷⟨ uniti⋆r ⟩
  ● a ×ᵤ 𝟙 ⟷⟨ {!id⟷ ⊗ η a⋆!} ⟩
  ● a ×ᵤ (𝟙/● a ×ᵤ 𝟙/● a⋆) ⟷⟨ {!!} ⟩
  𝟙/● a⋆ □

-- this is strange
-- A/C + B/C <-> (A + B) / C
-- factor+/l : {A B C : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} {c : ⟦ C ⟧}
--           → (c ⊸ a) +ᵤ (c ⊸ b) ⟷ (_⊸_ {C} c {A +ᵤ B} (inj₁ a))
-- factor+/l {A} {B} {C} {a} {b} {c} =
--   (𝟙/● C [ c ] ×ᵤ ● A [ a ] +ᵤ 𝟙/● C [ c ] ×ᵤ ● B [ b ]) ⟷⟨ factorl ⟩
--   (𝟙/● C [ c ] ×ᵤ (● A [ a ] +ᵤ ● B [ b ])) ⟷⟨ id⟷ ⊗ {!!} ⟩
--   (𝟙/● C [ c ] ×ᵤ ● A +ᵤ B [ inj₁ a ]) □

-- same issue here with the +
-- A/B + C/D <-> (A x D + B x C) / (B x D)

-- SAT solver Sec. 5 from https://www.cs.indiana.edu/~sabry/papers/rational.pdf

-- can we do this?
-- curry⊸ : {A B C : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} {c : ⟦ C ⟧}
--        → (● A [ a ] ×ᵤ (b ⊸ c)) ⟷ (a ⊸ {!!}) -- what do we put here?
-- curry⊸ {A} {B} {C} {a} {b} {c} = {!!}

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

--}


module UnSizedIO.Console where

open import NativeIO
open import UnSizedIO.Base hiding (main)

data ConsoleCommand : Set where
  putStrLn : String → ConsoleCommand
  getLine  : ConsoleCommand

ConsoleResponse : ConsoleCommand → Set
ConsoleResponse (putStrLn s) = Unit
ConsoleResponse  getLine     = String

ConsoleInterface : IOInterface
Command  ConsoleInterface = ConsoleCommand
Response ConsoleInterface = ConsoleResponse

IOConsole : Set → Set
IOConsole = IO ConsoleInterface

IOConsole+ : Set → Set
IOConsole+ = IO+ ConsoleInterface

translateIOConsoleLocal : (c : ConsoleCommand) → NativeIO (ConsoleResponse c)
translateIOConsoleLocal (putStrLn s) = nativePutStrLn s
translateIOConsoleLocal getLine      = nativeGetLine

translateIOConsole : {A : Set} → IOConsole A → NativeIO A
translateIOConsole = translateIO translateIOConsoleLocal

main : NativeIO Unit
main = nativePutStrLn "Console"


open import Agda.Builtin.Nat

f : Nat → Nat
f 0 = zero
f 0 = 0        -- All                      -- But Only
f (suc n) = n  -- These
f 0 = 0        -- Lines                    -- These Two
               -- Used to be highlighted   -- Should be!

g : Nat → Nat
g 0 = zero
g 0     -- The highlihting should still
  = 0   -- span multiple lines if the clause does
g (suc n) = n
g 0     -- Even
        -- With
        -- A Lot
   = 0  -- Of Empty Lines in between


------------------------------------------------------------------------------
-- Conversion rules for the division
------------------------------------------------------------------------------

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

module LTC-PCF.Program.Division.ConversionRules where

open import Common.FOL.Relation.Binary.EqReasoning

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

------------------------------------------------------------------------------
-- Division properties

private
    -- Before to prove some properties for div it is convenient
    -- to have a proof for each possible execution step.

    -- Initially, we define the possible states (div-s₁, div-s₂,
    -- ...) and after that, we write down the proof for the execution
    -- step from the state p to the state q, e.g.
    --
    -- proof₂₋₃ : ∀ i j → div-s₂ i j ≡ div-s₃ i j.

    -- Initially, the conversion rule fix-eq is applied.
    div-s₁ : D → D → D
    div-s₁ i j = divh (fix divh) · i · j

    -- First argument application.
    div-s₂ : D → D → D
    div-s₂ i j = fun · j
      where
      fun : D
      fun = lam (λ j → if (lt i j)
                         then zero
                         else succ₁ (fix divh · (i ∸ j) · j))

    -- Second argument application.
    div-s₃ : D → D → D
    div-s₃ i j = if (lt i j) then zero else succ₁ (fix divh · (i ∸ j) · j)

    -- lt i j ≡ true.
    div-s₄ : D → D → D
    div-s₄ i j = if true then zero else succ₁ (fix divh · (i ∸ j) · j)

    -- lt i j ≡ false.
    div-s₅ : D → D → D
    div-s₅ i j = if false then zero else succ₁ (fix divh · (i ∸ j) · j)

    -- The conditional is true.
    div-s₆ : D
    div-s₆ = zero

    -- The conditional is false.
    div-s₇ : D → D → D
    div-s₇ i j = succ₁ (fix divh · (i ∸ j) · j)

    {-

    To prove the execution steps, e.g.

    proof₃₋₄ : ∀ i j → div-s₃ i j → divh_s₄ i j,

    we usually need to prove that

                             ... m ... ≡ ... n ...    (1)

    given that
                                  m ≡ n,              (2)

    where (2) is a conversion rule usually.

    We prove (1) using

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

    where
      • P is given by \m → ... m ... ≡ ... n ...,
      • x ≡ y is given n ≡ m (actually, we use ≡-sym (m ≡ n)) and
      • P x is given by ... n ... ≡ ... n ... (i.e. ≡-refl)
    -}

    -- From div · i · j to div-s₁ using the conversion rule fix-eq.
    proof₀₋₁ : ∀ i j → fix divh · i · j ≡ div-s₁ i j
    proof₀₋₁ i j = subst (λ t → t · i · j ≡ divh (fix divh) · i · j)
                         (sym (fix-eq divh))
                         refl

    -- From div-s₁ to div-s₂ using the conversion rule beta.
    proof₁₋₂ : ∀ i j → div-s₁ i j ≡ div-s₂ i j
    proof₁₋₂ i j =
      subst (λ t → t · j ≡ fun i · j)
            (sym (beta fun i))
            refl
         where
         -- The function fun is the same that the fun part of div-s₂,
         -- except that we need a fresh variable y to avoid the
         -- clashing of the variable i in the application of the beta
         -- rule.
         fun : D → D
         fun y = lam (λ j → if (lt y j)
                              then zero
                              else succ₁ (fix divh · (y ∸ j) · j))

    -- From div-s₂ to div-s₃ using the conversion rule beta.
    proof₂₋₃ : ∀ i j → div-s₂ i j ≡ div-s₃ i j
    proof₂₋₃ i j  = beta fun j
      where
      -- The function fun is the same that div-s₃, except that we
      -- need a fresh variable y to avoid the clashing of the
      -- variable j in the application of the beta rule.
      fun : D → D
      fun y = if (lt i y) then zero else succ₁ ((fix divh) · (i ∸ y) · y)

    -- From div-s₃ to div-s₄ using the proof i<j.
    proof₃_₄ : ∀ i j → i < j → div-s₃ i j ≡ div-s₄ i j
    proof₃_₄ i j i<j =
      subst (λ t → (if t then zero else succ₁ ((fix divh) · (i ∸ j) · j)) ≡
                   (if true then zero else succ₁ ((fix divh) · (i ∸ j) · j)))
            (sym i<j)
            refl

    -- From div-s₃ to div-s₅ using the proof i≮j.
    proof₃₋₅ : ∀ i j → i ≮ j → div-s₃ i j ≡ div-s₅ i j
    proof₃₋₅ i j i≮j =
      subst (λ t → (if t then zero else succ₁ ((fix divh) · (i ∸ j) · j)) ≡
                   (if false then zero else succ₁ ((fix divh) · (i ∸ j) · j)))
            (sym i≮j)
            refl

    -- From div-s₄ to div-s₆ using the conversion rule if-true.
    proof₄₋₆ : ∀ i j → div-s₄ i j ≡ div-s₆
    proof₄₋₆ i j = if-true zero

    -- From div-s₅ to div-s₇ using the conversion rule if-false.
    proof₅₋₇ : ∀ i j → div-s₅ i j ≡ div-s₇ i j
    proof₅₋₇ i j = if-false (succ₁ (fix divh · (i ∸ j) · j))

----------------------------------------------------------------------
-- The division result when the dividend is minor than the
-- the divisor.
div-x<y : ∀ {i j} → i < j → div i j ≡ zero
div-x<y {i} {j} i<j =
  div i j    ≡⟨ proof₀₋₁ i j ⟩
  div-s₁ i j ≡⟨ proof₁₋₂ i j ⟩
  div-s₂ i j ≡⟨ proof₂₋₃ i j ⟩
  div-s₃ i j ≡⟨ proof₃_₄ i j i<j ⟩
  div-s₄ i j ≡⟨ proof₄₋₆ i j ⟩
  div-s₆     ∎

----------------------------------------------------------------------
-- The division result when the dividend is greater or equal than the
-- the divisor.
div-x≮y : ∀ {i j} → i ≮ j → div i j ≡ succ₁ (div (i ∸ j) j)
div-x≮y {i} {j} i≮j =
  div i j    ≡⟨ proof₀₋₁ i j ⟩
  div-s₁ i j ≡⟨ proof₁₋₂ i j ⟩
  div-s₂ i j ≡⟨ proof₂₋₃ i j ⟩
  div-s₃ i j ≡⟨ proof₃₋₅ i j i≮j ⟩
  div-s₅ i j ≡⟨ proof₅₋₇ i j ⟩
  div-s₇ i j ∎


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties related to All
------------------------------------------------------------------------

module Data.List.All.Properties where

open import Data.Bool
open import Data.Bool.Properties
open import Data.Empty
open import Data.List as List
import Data.List.Any as Any; open Any.Membership-≡
open import Data.List.All as All using (All; []; _∷_)
open import Data.List.Any using (Any; here; there)
open import Data.Product as Prod
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence using (_⇔_; module Equivalence)
open import Function.Inverse using (_↔_)
open import Function.Surjection using (_↠_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
open import Relation.Unary using (Decidable) renaming (_⊆_ to _⋐_)

-- Functions can be shifted between the predicate and the list.

All-map : ∀ {a b p} {A : Set a} {B : Set b} {P : B → Set p}
            {f : A → B} {xs} →
          All (P ∘ f) xs → All P (List.map f xs)
All-map []       = []
All-map (p ∷ ps) = p ∷ All-map ps

map-All : ∀ {a b p} {A : Set a} {B : Set b} {P : B → Set p}
            {f : A → B} {xs} →
          All P (List.map f xs) → All (P ∘ f) xs
map-All {xs = []}    []       = []
map-All {xs = _ ∷ _} (p ∷ ps) = p ∷ map-All ps

-- A variant of All.map.

gmap : ∀ {a b p q}
         {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q}
         {f : A → B} →
       P ⋐ Q ∘ f → All P ⋐ All Q ∘ List.map f
gmap g = All-map ∘ All.map g

-- All and all are related via T.

All-all : ∀ {a} {A : Set a} (p : A → Bool) {xs} →
          All (T ∘ p) xs → T (all p xs)
All-all p []         = _
All-all p (px ∷ pxs) = Equivalence.from T-∧ ⟨$⟩ (px , All-all p pxs)

all-All : ∀ {a} {A : Set a} (p : A → Bool) xs →
          T (all p xs) → All (T ∘ p) xs
all-All p []       _     = []
all-All p (x ∷ xs) px∷xs with Equivalence.to (T-∧ {p x}) ⟨$⟩ px∷xs
all-All p (x ∷ xs) px∷xs | (px , pxs) = px ∷ all-All p xs pxs

-- All is anti-monotone.

anti-mono : ∀ {a p} {A : Set a} {P : A → Set p} {xs ys} →
            xs ⊆ ys → All P ys → All P xs
anti-mono xs⊆ys pys = All.tabulate (All.lookup pys ∘ xs⊆ys)

-- all is anti-monotone.

all-anti-mono : ∀ {a} {A : Set a} (p : A → Bool) {xs ys} →
                xs ⊆ ys → T (all p ys) → T (all p xs)
all-anti-mono p xs⊆ys = All-all p ∘ anti-mono xs⊆ys ∘ all-All p _

-- All P (xs ++ ys) is isomorphic to All P xs and All P ys.

private

  ++⁺ : ∀ {a p} {A : Set a} {P : A → Set p} {xs ys : List A} →
        All P xs → All P ys → All P (xs ++ ys)
  ++⁺ []         pys = pys
  ++⁺ (px ∷ pxs) pys = px ∷ ++⁺ pxs pys

  ++⁻ : ∀ {a p} {A : Set a} {P : A → Set p} (xs : List A) {ys} →
        All P (xs ++ ys) → All P xs × All P ys
  ++⁻ []       p          = [] , p
  ++⁻ (x ∷ xs) (px ∷ pxs) = Prod.map (_∷_ px) id $ ++⁻ _ pxs

  ++⁺∘++⁻ : ∀ {a p} {A : Set a} {P : A → Set p} xs {ys}
            (p : All P (xs ++ ys)) → uncurry′ ++⁺ (++⁻ xs p) ≡ p
  ++⁺∘++⁻ []       p          = P.refl
  ++⁺∘++⁻ (x ∷ xs) (px ∷ pxs) = P.cong (_∷_ px) $ ++⁺∘++⁻ xs pxs

  ++⁻∘++⁺ : ∀ {a p} {A : Set a} {P : A → Set p} {xs ys}
            (p : All P xs × All P ys) → ++⁻ xs (uncurry ++⁺ p) ≡ p
  ++⁻∘++⁺ ([]       , pys) = P.refl
  ++⁻∘++⁺ (px ∷ pxs , pys) rewrite ++⁻∘++⁺ (pxs , pys) = P.refl

++↔ : ∀ {a p} {A : Set a} {P : A → Set p} {xs ys} →
      (All P xs × All P ys) ↔ All P (xs ++ ys)
++↔ {P = P} {xs = xs} = record
  { to         = P.→-to-⟶ $ uncurry ++⁺
  ; from       = P.→-to-⟶ $ ++⁻ xs
  ; inverse-of = record
    { left-inverse-of  = ++⁻∘++⁺
    ; right-inverse-of = ++⁺∘++⁻ xs
    }
  }

-- Three lemmas relating Any, All and negation.

¬Any↠All¬ : ∀ {a p} {A : Set a} {P : A → Set p} {xs} →
            ¬ Any P xs ↠ All (¬_ ∘ P) xs
¬Any↠All¬ {P = P} = record
  { to         = P.→-to-⟶ (to _)
  ; surjective = record
    { from             = P.→-to-⟶ from
    ; right-inverse-of = to∘from
    }
  }
  where
  to : ∀ xs → ¬ Any P xs → All (¬_ ∘ P) xs
  to []       ¬p = []
  to (x ∷ xs) ¬p = ¬p ∘ here ∷ to xs (¬p ∘ there)

  from : ∀ {xs} → All (¬_ ∘ P) xs → ¬ Any P xs
  from []        ()
  from (¬p ∷ _)  (here  p) = ¬p p
  from (_  ∷ ¬p) (there p) = from ¬p p

  to∘from : ∀ {xs} (¬p : All (¬_ ∘ P) xs) → to xs (from ¬p) ≡ ¬p
  to∘from []         = P.refl
  to∘from (¬p ∷ ¬ps) = P.cong₂ _∷_ P.refl (to∘from ¬ps)

  -- If equality of functions were extensional, then the surjection
  -- could be strengthened to a bijection.

  from∘to : P.Extensionality _ _ →
            ∀ xs → (¬p : ¬ Any P xs) → from (to xs ¬p) ≡ ¬p
  from∘to ext []       ¬p = ext λ ()
  from∘to ext (x ∷ xs) ¬p = ext λ
    { (here p)  → P.refl
    ; (there p) → P.cong (λ f → f p) $ from∘to ext xs (¬p ∘ there)
    }

Any¬→¬All : ∀ {a p} {A : Set a} {P : A → Set p} {xs} →
            Any (¬_ ∘ P) xs → ¬ All P xs
Any¬→¬All (here  ¬p) = ¬p           ∘ All.head
Any¬→¬All (there ¬p) = Any¬→¬All ¬p ∘ All.tail

Any¬⇔¬All : ∀ {a p} {A : Set a} {P : A → Set p} {xs} →
            Decidable P → Any (¬_ ∘ P) xs ⇔ ¬ All P xs
Any¬⇔¬All {P = P} dec = record
  { to   = P.→-to-⟶ Any¬→¬All
  ; from = P.→-to-⟶ (from _)
  }
  where
  from : ∀ xs → ¬ All P xs → Any (¬_ ∘ P) xs
  from []       ¬∀ = ⊥-elim (¬∀ [])
  from (x ∷ xs) ¬∀ with dec x
  ... | yes p = there (from xs (¬∀ ∘ _∷_ p))
  ... | no ¬p = here ¬p

  -- If equality of functions were extensional, then the logical
  -- equivalence could be strengthened to a surjection.

  to∘from : P.Extensionality _ _ →
            ∀ {xs} (¬∀ : ¬ All P xs) → Any¬→¬All (from xs ¬∀) ≡ ¬∀
  to∘from ext ¬∀ = ext (⊥-elim ∘ ¬∀)