module Structure.Relator where

import Lvl
open import Functional using (_∘₂_)
open import Functional.Dependent
open import Lang.Instance
open import Logic
open import Logic.Propositional
open import Structure.Setoid
open import Structure.Relator.Names
open import Structure.Relator.Properties
open import Syntax.Function
open import Type

-- TODO: It seems possible to define UnaryRelator as a special case of Function, so let's do that

private variable ℓₒ ℓₒ₁ ℓₒ₂ ℓₒ₃ ℓₗ ℓₗ₁ ℓₗ₂ ℓₗ₃ ℓₗ₄ : Lvl.Level

module Names where
  module _ {A : Type{ℓₒ}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ (P : A → Stmt{ℓₗ₂}) where
    Substitution₁ = ∀{x y : A} → (x ≡ y) → P(x) → P(y)

  module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ (_▫_ : A → B → Stmt{ℓₗ₃}) where
    Substitution₂ = ∀{x₁ y₁ : A}{x₂ y₂ : B} → (x₁ ≡ y₁) → (x₂ ≡ y₂) → (x₁ ▫ x₂) → (y₁ ▫ y₂)

  module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ {C : Type{ℓₒ₃}} ⦃ _ : Equiv{ℓₗ₃}(C) ⦄ (_▫_▫_ : A → B → C → Stmt{ℓₗ₄}) where
    Substitution₃ = ∀{x₁ y₁ : A}{x₂ y₂ : B}{x₃ y₃ : C} → (x₁ ≡ y₁) → (x₂ ≡ y₂) → (x₃ ≡ y₃) → (x₁ ▫ x₂ ▫ x₃) → (y₁ ▫ y₂ ▫ y₃)

-- The unary relator `P` "(behaves like)/is a relator" in the context of `_≡_` from the Equiv instance.
module _ {A : Type{ℓₒ}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ (P : A → Stmt{ℓₗ₂}) where
  record UnaryRelator : Stmt{ℓₒ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field
      substitution : Names.Substitution₁(P)
    substitution-sym : ∀{x y : A} → (x ≡ y) → P(x) ← P(y)
    substitution-sym = substitution ∘ Structure.Relator.Properties.symmetry(_≡_)
    substitution-equivalence : ∀{x y : A} → (x ≡ y) → (P(x) ↔ P(y))
    substitution-equivalence xy = [↔]-intro (substitution-sym xy) (substitution xy)
  substitute₁ₗ = inst-fn UnaryRelator.substitution-sym
  substitute₁ᵣ = inst-fn UnaryRelator.substitution
  substitute₁ₗᵣ = inst-fn UnaryRelator.substitution-equivalence
  substitute₁ = substitute₁ᵣ
  unaryRelator = resolve UnaryRelator

-- The binary relator `_▫_` "(behaves like)/is a relator" in the context of `_≡_` from the Equiv instance.
module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ (_▫_ : A → B → Stmt{ℓₗ₃}) where
  open Structure.Relator.Properties

  record BinaryRelator : Stmt{ℓₒ₁ Lvl.⊔ ℓₒ₂ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂ Lvl.⊔ ℓₗ₃} where
    constructor intro
    field
      substitution : Names.Substitution₂(_▫_)
    left : ∀{x} → UnaryRelator(_▫ x)
    left = intro(\p → substitution p (reflexivity(_≡_)))
    right : ∀{x} → UnaryRelator(x ▫_)
    right = intro(\p → substitution (reflexivity(_≡_)) p)
    substitutionₗ = \{a x y} → UnaryRelator.substitution(left {a}) {x}{y}
    substitutionᵣ = \{a x y} → UnaryRelator.substitution(right{a}) {x}{y}
    substitution-sym : ∀{x₁ y₁ : A}{x₂ y₂ : B} → (x₁ ≡ y₁) → (x₂ ≡ y₂) → ((x₁ ▫ x₂) ← (y₁ ▫ y₂))
    substitution-sym xy1 xy2 = substitution (Structure.Relator.Properties.symmetry(_≡_) xy1) (Structure.Relator.Properties.symmetry(_≡_) xy2)
    substitution-equivalence : ∀{x₁ y₁ : A}{x₂ y₂ : B} → (x₁ ≡ y₁) → (x₂ ≡ y₂) → ((x₁ ▫ x₂) ↔ (y₁ ▫ y₂))
    substitution-equivalence xy1 xy2 = [↔]-intro (substitution-sym xy1 xy2) (substitution xy1 xy2)
  substitute₂ = inst-fn BinaryRelator.substitution
  substitute₂ₗ = inst-fn BinaryRelator.substitutionₗ
  substitute₂ᵣ = inst-fn BinaryRelator.substitutionᵣ
  substitute₂ₗᵣ = inst-fn BinaryRelator.substitution-equivalence
  binaryRelator = resolve BinaryRelator

module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ {C : Type{ℓₒ₃}} ⦃ _ : Equiv{ℓₗ₃}(C) ⦄ (_▫_▫_ : A → B → C → Stmt{ℓₗ₄}) where
  open Structure.Relator.Properties

  record TrinaryRelator : Stmt{ℓₒ₁ Lvl.⊔ ℓₒ₂ Lvl.⊔ ℓₒ₃ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂ Lvl.⊔ ℓₗ₃ Lvl.⊔ ℓₗ₄} where
    constructor intro
    field
      substitution : Names.Substitution₃(_▫_▫_)
    unary₁ : ∀{y z} → UnaryRelator(_▫ y ▫ z)
    unary₁ = intro(\p → substitution p (reflexivity(_≡_)) (reflexivity(_≡_)))
    unary₂ : ∀{x z} → UnaryRelator(x ▫_▫ z)
    unary₂ = intro(\p → substitution (reflexivity(_≡_)) p (reflexivity(_≡_)))
    unary₃ : ∀{x y} → UnaryRelator(x ▫ y ▫_)
    unary₃ = intro(\p → substitution (reflexivity(_≡_)) (reflexivity(_≡_)) p)
    binary₁₂ : ∀{z} → BinaryRelator(_▫_▫ z)
    binary₁₂ = intro(\p q → substitution p q (reflexivity(_≡_)))
    binary₁₃ : ∀{y} → BinaryRelator(_▫ y ▫_)
    binary₁₃ = intro(\p q → substitution p (reflexivity(_≡_)) q)
    binary₂₃ : ∀{x} → BinaryRelator(x ▫_▫_)
    binary₂₃ = intro(\p q → substitution (reflexivity(_≡_)) p q)
    substitution-unary₁ = \{a b x y} → UnaryRelator.substitution(unary₁ {a}{b}) {x}{y}
    substitution-unary₂ = \{a b x y} → UnaryRelator.substitution(unary₂ {a}{b}) {x}{y}
    substitution-unary₃ = \{a b x y} → UnaryRelator.substitution(unary₃ {a}{b}) {x}{y}
    substitution-binary₁₂ = \{a x₁ x₂ y₁ y₂} → BinaryRelator.substitution(binary₁₂ {a}) {x₁}{x₂}{y₁}{y₂}
    substitution-binary₁₃ = \{a x₁ x₂ y₁ y₂} → BinaryRelator.substitution(binary₁₃ {a}) {x₁}{x₂}{y₁}{y₂}
    substitution-binary₂₃ = \{a x₁ x₂ y₁ y₂} → BinaryRelator.substitution(binary₂₃ {a}) {x₁}{x₂}{y₁}{y₂}
  substitute₃ = inst-fn TrinaryRelator.substitution
  substitute₃-unary₁ = inst-fn TrinaryRelator.substitution-unary₁
  substitute₃-unary₂ = inst-fn TrinaryRelator.substitution-unary₂
  substitute₃-unary₃ = inst-fn TrinaryRelator.substitution-unary₃
  substitute₃-binary₁₂ = inst-fn TrinaryRelator.substitution-binary₁₂
  substitute₃-binary₁₃ = inst-fn TrinaryRelator.substitution-binary₁₃
  substitute₃-binary₂₃ = inst-fn TrinaryRelator.substitution-binary₂₃
  trinaryRelator = resolve TrinaryRelator


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

-- From: On the Bright Side of Type Classes: Instances Arguments in
-- Agda (ICFP'11).

module InstanceArguments where

open import Data.Bool.Base
open import Data.Nat hiding ( equal ) renaming ( suc to succ )

-- Note: Agda doesn't have a primitive function primBoolEquality.
boolEq : Bool → Bool → Bool
boolEq true  true  = true
boolEq false false = true
{-# CATCHALL #-}
boolEq _     _     = false

natEq : ℕ → ℕ → Bool
natEq zero  zero         = true
natEq (succ m) (succ n)  = natEq m n
{-# CATCHALL #-}
natEq _     _            = false

record Eq (t : Set) : Set where
  field equal : t → t → Bool

instance
  eqInstanceBool : Eq Bool
  eqInstanceBool = record { equal = boolEq }

  eqInstanceℕ : Eq ℕ
  eqInstanceℕ = record { equal = natEq }

equal : {t : Set} → {{eqT : Eq t}} → t → t → Bool
equal {{eqT}} = Eq.equal eqT

test : Bool
test = equal 5 3 ∨ equal true false


-- We can let Agda infer the parameters of the constructor target

data List (A : Set) : Set where
  nil  : List _
  cons : A → List A → List _

-- 2017-01-12, Andreas: we can even omit the whole target
-- (for parameterized data types, but not inductive families)

data Bool : Set where
  true false : _

data Maybe (A : Set) : Set where
  nothing : _
  just : (x : A) → _


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

module Issue765 where

infixr 1 _⊎_
infixr 4 _,_
infix 4 _≡_

data ⊥ : Set where

⊥-elim : {A : Set} → ⊥ → A
⊥-elim ()

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

data _⊎_ (A : Set) (B : Set) : Set where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

[_,_]₁ : ∀ {A : Set} {B : Set} {C : A ⊎ B → Set₁} →
        ((x : A) → C (inj₁ x)) → ((x : B) → C (inj₂ x)) →
        ((x : A ⊎ B) → C x)
[ f , g ]₁ (inj₁ x) = f x
[ f , g ]₁ (inj₂ y) = g y

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

open Σ public

infix 5 _◃_
infixr 1 _⊎C_

record Container : Set₁ where
  constructor _◃_
  field
    Shape     : Set
    Position  : Shape → Set

open Container public

constC : Set → Container
constC X = X ◃ λ _ → ⊥

_⊎C_ : Container → Container → Container
S ◃ P ⊎C S′ ◃ P′ = (S ⊎ S′) ◃ [ P , P′ ]₁

data μ (C : Container) : Set where
  sup : (s : Shape C) (k : Position C s → μ C) → μ C

_⋆_ : Container → Set → Set
C ⋆ X = μ (constC X ⊎C C)

to : ∀ {C X} → C ⋆ X → C ⋆ (C ⋆ X)
to m = sup (inj₁ m) ⊥-elim

injective : ∀ {C X}{m n : C ⋆ X} → to m ≡ to n → m ≡ n
injective refl = refl


{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Data.Queue.Truncated2List where

open import Cubical.Foundations.Everything

open import Cubical.Foundations.SIP
open import Cubical.Structures.Queue

open import Cubical.Data.Maybe
open import Cubical.Data.List
open import Cubical.Data.Sigma

open import Cubical.Data.Queue.1List

module Truncated2List {ℓ} (A : Type ℓ) (Aset : isSet A) where
 open Queues-on A Aset

 data Q : Type ℓ where
   Q⟨_,_⟩ : (xs ys : List A) → Q
   tilt : ∀ xs ys z → Q⟨ xs ++ [ z ] , ys ⟩ ≡ Q⟨ xs , ys ++ [ z ] ⟩
   trunc : (q q' : Q) (α β : q ≡ q') → α ≡ β

 multitilt : (xs ys zs : List A) → Q⟨ xs ++ rev zs , ys ⟩ ≡ Q⟨ xs , ys ++ zs ⟩
 multitilt xs ys [] = cong₂ Q⟨_,_⟩ (++-unit-r xs) (sym (++-unit-r ys))
 multitilt xs ys (z ∷ zs) =
   cong (λ ws → Q⟨ ws , ys ⟩) (sym (++-assoc xs (rev zs) [ z ]))
   ∙ tilt (xs ++ rev zs) ys z
   ∙ multitilt xs (ys ++ [ z ]) zs
   ∙ cong (λ ws → Q⟨ xs , ws ⟩) (++-assoc ys [ z ] zs)

  -- enq into the first list, deq from the second if possible

 emp : Q
 emp = Q⟨ [] , [] ⟩

 enq : A → Q → Q
 enq a Q⟨ xs , ys ⟩ = Q⟨ a ∷ xs , ys ⟩
 enq a (tilt xs ys z i) = tilt (a ∷ xs) ys z i
 enq a (trunc q q' α β i j) =
   trunc _ _ (cong (enq a) α) (cong (enq a) β) i j

 deqFlush : List A → Maybe (Q × A)
 deqFlush [] = nothing
 deqFlush (x ∷ xs) = just (Q⟨ [] , xs ⟩ , x)

 deq : Q → Maybe (Q × A)
 deq Q⟨ xs , [] ⟩ = deqFlush (rev xs)
 deq Q⟨ xs , y ∷ ys ⟩ = just (Q⟨ xs , ys ⟩ , y)
 deq (tilt xs [] z i) = path i
   where
   path : deqFlush (rev (xs ++ [ z ])) ≡ just (Q⟨ xs , [] ⟩ , z)
   path =
     cong deqFlush (rev-++ xs [ z ])
     ∙ cong (λ q → just (q , z)) (sym (multitilt [] [] (rev xs)))
     ∙ cong (λ ys → just (Q⟨ ys , [] ⟩ , z)) (rev-rev xs)
 deq (tilt xs (y ∷ ys) z i) = just (tilt xs ys z i , y)
 deq (trunc q q' α β i j) =
   isOfHLevelMaybe 0
     (isSetΣ trunc λ _ → Aset)
     (deq q) (deq q') (cong deq α) (cong deq β)
    i j

 Raw : RawQueue
 Raw = (Q , emp , enq , deq)

 -- We construct an equivalence to 1Lists and prove this is an equivalence of queue structures

 private
   module One = 1List A Aset
   open One renaming (Q to Q₁; emp to emp₁; enq to enq₁; deq to deq₁) using ()

 quot : Q₁ → Q
 quot xs = Q⟨ xs , [] ⟩

 eval : Q → Q₁
 eval Q⟨ xs , ys ⟩ = xs ++ rev ys
 eval (tilt xs ys z i) = path i
   where
   path : (xs ++ [ z ]) ++ rev ys ≡ xs ++ rev (ys ++ [ z ])
   path =
     ++-assoc xs [ z ] (rev ys)
     ∙ cong (_++_ xs) (sym (rev-++ ys [ z ]))
 eval (trunc q q' α β i j) = -- truncated case
   isOfHLevelList 0 Aset (eval q) (eval q') (cong eval α) (cong eval β) i j

 quot∘eval : ∀ q → quot (eval q) ≡ q
 quot∘eval Q⟨ xs , ys ⟩ = multitilt xs [] ys
 quot∘eval (tilt xs ys z i) = -- truncated case
   isOfHLevelPathP'
     {A = λ i → quot (eval (tilt xs ys z i)) ≡ tilt xs ys z i}
     0
     (trunc _ _)
     (multitilt (xs ++ [ z ]) [] ys) (multitilt xs [] (ys ++ [ z ]))
     .fst i
 quot∘eval (trunc q q' α β i j) = -- truncated case
   isOfHLevelPathP'
     {A = λ i →
       PathP (λ j → quot (eval (trunc q q' α β i j)) ≡ trunc q q' α β i j)
         (quot∘eval q) (quot∘eval q')}
     0
     (isOfHLevelPathP' 1 (isOfHLevelSuc 2 trunc _ _) _ _)
     (cong quot∘eval α) (cong quot∘eval β)
     .fst i j

 eval∘quot : ∀ xs → eval (quot xs) ≡ xs
 eval∘quot = ++-unit-r

 -- We get our desired equivalence
 quotEquiv : Q₁ ≃ Q
 quotEquiv = isoToEquiv (iso quot eval quot∘eval eval∘quot)

 -- Now it only remains to prove that this is an equivalence of queue structures
 quot∘emp : quot emp₁ ≡ emp
 quot∘emp = refl

 quot∘enq : ∀ x xs → quot (enq₁ x xs) ≡ enq x (quot xs)
 quot∘enq x xs = refl

 quot∘deq : ∀ xs → deqMap quot (deq₁ xs) ≡ deq (quot xs)
 quot∘deq [] = refl
 quot∘deq (x ∷ []) = refl
 quot∘deq (x ∷ x' ∷ xs) =
   deqMap-∘ quot (enq₁ x) (deq₁ (x' ∷ xs))
   ∙ sym (deqMap-∘ (enq x) quot (deq₁ (x' ∷ xs)))
   ∙ cong (deqMap (enq x)) (quot∘deq (x' ∷ xs))
   ∙ lemma x x' (rev xs)
   where
   lemma : ∀ x x' ys
     → deqMap (enq x) (deqFlush (ys ++ [ x' ]))
       ≡ deqFlush ((ys ++ [ x' ]) ++ [ x ])
   lemma x x' [] i = just (tilt [] [] x i , x')
   lemma x x' (y ∷ ys) i = just (tilt [] (ys ++ [ x' ]) x i , y)

 quotEquivHasQueueEquivStr : RawQueueEquivStr One.Raw Raw quotEquiv
 quotEquivHasQueueEquivStr = quot∘emp , quot∘enq , quot∘deq

 -- And we get a path between the raw 1Lists and 2Lists
 Raw-1≡2 : One.Raw ≡ Raw
 Raw-1≡2 = sip rawQueueUnivalentStr _ _ (quotEquiv , quotEquivHasQueueEquivStr)

 -- We derive the axioms for 2List from those for 1List
 WithLaws : Queue
 WithLaws = Q , str Raw , subst (uncurry QueueAxioms) Raw-1≡2 (snd (str One.WithLaws))

 WithLaws-1≡2 : One.WithLaws ≡ WithLaws
 WithLaws-1≡2 = sip queueUnivalentStr _ _ (quotEquiv , quotEquivHasQueueEquivStr)

 Finite : FiniteQueue
 Finite = Q , str WithLaws , subst (uncurry FiniteQueueAxioms) WithLaws-1≡2 (snd (str One.Finite))


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

------------------------------------------------------------------------
-- Lists, based on the Kleene star and plus.
--
-- These lists are exatcly equivalent to normal lists, except the "cons"
-- case is split into its own data type. This lets us write all the same
-- functions as before, but it has 2 advantages:
--
-- * Some functions are easier to express on the non-empty type. For
--   instance, head can be clearly expressed without the need for
--   maybes.
-- * It can make some proofs easier. By using the non-empty type where
--   possible, we can avoid an extra pattern match, which can really
--   simplify certain proofs.

module Data.List.Kleene.Base where

open import Data.Product as Product using (_×_; _,_; map₂; map₁; proj₁; proj₂)
open import Data.Nat     as ℕ       using (ℕ; suc; zero)
open import Data.Maybe   as Maybe   using (Maybe; just; nothing)
open import Data.Sum     as Sum     using (_⊎_; inj₁; inj₂)
open import Algebra

open import Function

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

infixr 5 _&_ ∹_
mutual
  -- Non-Empty Lists
  record _⁺ {a} (A : Set a) : Set a where
    inductive
    constructor _&_
    field
      head : A
      tail : A ⋆

  -- Possibly Empty Lists
  data _⋆ {a} (A : Set a) : Set a where
    [] : A ⋆
    ∹_ : A ⁺ → A ⋆
open _⁺ public

------------------------------------------------------------------------
-- FoldMap

module _ {c ℓ a} (sgrp : Semigroup c ℓ) {A : Set a} where
  open Semigroup sgrp

  foldMap⁺ : (A → Carrier) → A ⁺ → Carrier
  foldMap⁺ f (x & []) = f x
  foldMap⁺ f (x & ∹ xs) = f x ∙ foldMap⁺ f xs

module _ {c ℓ a} (mon : Monoid c ℓ) {A : Set a} where
  open Monoid mon

  foldMap⋆ : (A → Carrier) → A ⋆ → Carrier
  foldMap⋆ f [] = ε
  foldMap⋆ f (∹ xs) = foldMap⁺ semigroup f xs

------------------------------------------------------------------------
-- Folds

module _ {a b} {A : Set a} {B : Set b} (f : A → B → B) (b : B) where
  foldr⁺ : A ⁺ → B
  foldr⋆ : A ⋆ → B

  foldr⁺ (x & xs) = f x (foldr⋆ xs)

  foldr⋆ [] = b
  foldr⋆ (∹ xs) = foldr⁺ xs

module _ {a b} {A : Set a} {B : Set b} (f : B → A → B) where
  foldl⁺ : B → A ⁺ → B
  foldl⋆ : B → A ⋆ → B

  foldl⁺ b (x & xs) = foldl⋆ (f b x) xs

  foldl⋆ b [] = b
  foldl⋆ b (∹ xs) = foldl⁺ b xs

------------------------------------------------------------------------
-- Concatenation

module _ {a} {A : Set a} where
  _⁺++⁺_ : A ⁺ → A ⁺ → A ⁺
  _⁺++⋆_ : A ⁺ → A ⋆ → A ⁺
  _⋆++⁺_ : A ⋆ → A ⁺ → A ⁺
  _⋆++⋆_ : A ⋆ → A ⋆ → A ⋆

  head (xs ⁺++⋆ ys) = head xs
  tail (xs ⁺++⋆ ys) = tail xs ⋆++⋆ ys

  xs ⋆++⋆ ys = foldr⋆ (λ x zs → ∹ x & zs) ys xs

  xs ⁺++⁺ ys = foldr⁺ (λ x zs → x & ∹ zs) ys xs

  []     ⋆++⁺ ys = ys
  (∹ xs) ⋆++⁺ ys = xs ⁺++⁺ ys

------------------------------------------------------------------------
-- Mapping

module _ {a b} {A : Set a} {B : Set b} (f : A → B) where
  map⁺ : A ⁺ → B ⁺
  map⋆ : A ⋆ → B ⋆

  head (map⁺ xs) = f (head xs)
  tail (map⁺ xs) = map⋆ (tail xs)

  map⋆ [] = []
  map⋆ (∹ xs) = ∹ map⁺ xs

------------------------------------------------------------------------
-- Applicative Operations

module _ {a} {A : Set a} where
  pure⁺ : A → A ⁺
  pure⋆ : A → A ⋆

  head (pure⁺ x) = x
  tail (pure⁺ x) = []

  pure⋆ x = ∹ pure⁺ x

module _ {a b} {A : Set a} {B : Set b} where
  _⋆<*>⋆_ : (A → B) ⋆ → A ⋆ → B ⋆
  _⁺<*>⋆_ : (A → B) ⁺ → A ⋆ → B ⋆
  _⋆<*>⁺_ : (A → B) ⋆ → A ⁺ → B ⋆
  _⁺<*>⁺_ : (A → B) ⁺ → A ⁺ → B ⁺

  []     ⋆<*>⋆ xs = []
  (∹ fs) ⋆<*>⋆ xs = fs ⁺<*>⋆ xs

  fs ⁺<*>⋆ xs = map⋆ (head fs) xs ⋆++⋆ (tail fs ⋆<*>⋆ xs)

  []     ⋆<*>⁺ xs = []
  (∹ fs) ⋆<*>⁺ xs = ∹ fs ⁺<*>⁺ xs

  fs ⁺<*>⁺ xs = map⁺ (head fs) xs ⁺++⋆ (tail fs ⋆<*>⁺ xs)

------------------------------------------------------------------------
-- Monadic Operations

module _ {a b} {A : Set a} {B : Set b} where
  _⁺>>=⁺_ : A ⁺ → (A → B ⁺) → B ⁺
  _⁺>>=⋆_ : A ⁺ → (A → B ⋆) → B ⋆
  _⋆>>=⁺_ : A ⋆ → (A → B ⁺) → B ⋆
  _⋆>>=⋆_ : A ⋆ → (A → B ⋆) → B ⋆

  (x & xs) ⁺>>=⁺ k = k x ⁺++⋆ (xs ⋆>>=⁺ k)

  (x & xs) ⁺>>=⋆ k = k x ⋆++⋆ (xs ⋆>>=⋆ k)

  []     ⋆>>=⋆ k = []
  (∹ xs) ⋆>>=⋆ k = xs ⁺>>=⋆ k

  []     ⋆>>=⁺ k = []
  (∹ xs) ⋆>>=⁺ k = ∹ xs ⁺>>=⁺ k

------------------------------------------------------------------------
-- Scans

module Scanr {a b} {A : Set a} {B : Set b} (f : A → B → B) (b : B) where
  cons : A → B ⁺ → B ⁺
  head (cons x xs) = f x (head xs)
  tail (cons x xs) = ∹ xs

  scanr⁺ : A ⁺ → B ⁺
  scanr⋆ : A ⋆ → B ⁺

  scanr⋆ = foldr⋆ cons (b & [])
  scanr⁺ = foldr⁺ cons (b & [])
open Scanr public using (scanr⁺; scanr⋆)

module _ {a b} {A : Set a} {B : Set b} (f : B → A → B) where
  scanl⁺ : B → A ⁺ → B ⁺
  scanl⋆ : B → A ⋆ → B ⁺

  head (scanl⁺ b xs) = b
  tail (scanl⁺ b xs) = ∹ scanl⋆ (f b (head xs)) (tail xs)

  head (scanl⋆ b xs) = b
  tail (scanl⋆ b []) = []
  tail (scanl⋆ b (∹ xs)) = ∹ scanl⋆ (f b (head xs)) (tail xs)

  scanl₁ : B → A ⁺ → B ⁺
  scanl₁ b xs = scanl⋆ (f b (head xs)) (tail xs)

------------------------------------------------------------------------
-- Accumulating maps

module _ {a b c} {A : Set a} {B : Set b} {C : Set c} (f : B → A → (B × C)) where
  mapAccumL⋆ : B → A ⋆ → (B × C ⋆)
  mapAccumL⁺ : B → A ⁺ → (B × C ⁺)

  mapAccumL⋆ b [] = b , []
  mapAccumL⋆ b (∹ xs) = map₂ ∹_ (mapAccumL⁺ b xs)

  mapAccumL⁺ b (x & xs) =
    let y , ys = f b x
        z , zs = mapAccumL⋆ y xs
    in z , (ys & zs)

module _ {a b c} {A : Set a} {B : Set b} {C : Set c} (f : A → B → (C × B)) (b : B) where
  mapAccumR⋆ : A ⋆ → (C ⋆ × B)
  mapAccumR⁺ : A ⁺ → (C ⁺ × B)

  mapAccumR⋆ [] = [] , b
  mapAccumR⋆ (∹ xs) = map₁ ∹_ (mapAccumR⁺ xs)

  mapAccumR⁺ (x & xs) =
    let ys , y = mapAccumR⋆ xs
        zs , z = f x y
    in (zs & ys) , z

------------------------------------------------------------------------
-- Non-Empty Folds

module _ {a} {A : Set a} where
  last : A ⁺ → A
  last (x & []) = x
  last (_ & (∹ xs)) = last xs

module _ {a} {A : Set a} (f : A → A → A) where
  foldr1 : A ⁺ → A
  foldr1 (x & []) = x
  foldr1 (x & (∹ xs)) = f x (foldr1 xs)

  foldl1 : A ⁺ → A
  foldl1 (x & xs) = foldl⋆ f x xs

module _ {a b} {A : Set a} {B : Set b} (f : A → Maybe B → B) where
  foldrMay⋆ : A ⋆ → Maybe B
  foldrMay⁺ : A ⁺ → B

  foldrMay⋆ [] = nothing
  foldrMay⋆ (∹ xs) = just (foldrMay⁺ xs)

  foldrMay⁺ xs = f (head xs) (foldrMay⋆ (tail xs))

------------------------------------------------------------------------
-- Indexing

module _ {a} {A : Set a} where
  _[_]⋆ : A ⋆ → ℕ → Maybe A
  _[_]⁺ : A ⁺ → ℕ → Maybe A

  []     [ _ ]⋆ = nothing
  (∹ xs) [ i ]⋆ = xs [ i ]⁺

  xs [ zero  ]⁺ = just (head xs)
  xs [ suc i ]⁺ = tail xs [ i ]⋆

  applyUpTo⋆ : (ℕ → A) → ℕ → A ⋆
  applyUpTo⁺ : (ℕ → A) → ℕ → A ⁺

  applyUpTo⋆ f zero    = []
  applyUpTo⋆ f (suc n) = ∹ applyUpTo⁺ f n

  head (applyUpTo⁺ f n) = f zero
  tail (applyUpTo⁺ f n) = applyUpTo⋆ (f ∘ suc) n

upTo⋆ : ℕ → ℕ ⋆
upTo⋆ = applyUpTo⋆ id

upTo⁺ : ℕ → ℕ ⁺
upTo⁺ = applyUpTo⁺ id

------------------------------------------------------------------------
-- Manipulation

module _ {a} {A : Set a} (x : A) where
  intersperse⁺ : A ⁺ → A ⁺
  intersperse⋆ : A ⋆ → A ⋆

  head (intersperse⁺ xs) = head xs
  tail (intersperse⁺ xs) = prepend (tail xs)
    where
    prepend : A ⋆ → A ⋆
    prepend [] = []
    prepend (∹ xs) = ∹ x & ∹ intersperse⁺ xs

  intersperse⋆ [] = []
  intersperse⋆ (∹ xs) = ∹ intersperse⁺ xs

module _ {a} {A : Set a} where
  _⁺<|>⁺_ : A ⁺ → A ⁺ → A ⁺
  _⁺<|>⋆_ : A ⁺ → A ⋆ → A ⁺
  _⋆<|>⁺_ : A ⋆ → A ⁺ → A ⁺
  _⋆<|>⋆_ : A ⋆ → A ⋆ → A ⋆

  head (xs ⁺<|>⁺ ys) = head xs
  tail (xs ⁺<|>⁺ ys) = ∹ (ys ⁺<|>⋆ tail xs)

  head (xs ⁺<|>⋆ ys) = head xs
  tail (xs ⁺<|>⋆ ys) = ys ⋆<|>⋆ tail xs

  []     ⋆<|>⁺ ys = ys
  (∹ xs) ⋆<|>⁺ ys = xs ⁺<|>⁺ ys

  []     ⋆<|>⋆ ys = ys
  (∹ xs) ⋆<|>⋆ ys = ∹ (xs ⁺<|>⋆ ys)

module _ {a b c} {A : Set a} {B : Set b} {C : Set c} (f : A → B → C) where
  ⁺zipWith⁺ : A ⁺ → B ⁺ → C ⁺
  ⋆zipWith⁺ : A ⋆ → B ⁺ → C ⋆
  ⁺zipWith⋆ : A ⁺ → B ⋆ → C ⋆
  ⋆zipWith⋆ : A ⋆ → B ⋆ → C ⋆

  head (⁺zipWith⁺ xs ys) = f (head xs) (head ys)
  tail (⁺zipWith⁺ xs ys) = ⋆zipWith⋆ (tail xs) (tail ys)

  ⋆zipWith⁺ [] ys = []
  ⋆zipWith⁺ (∹ xs) ys = ∹ ⁺zipWith⁺ xs ys

  ⁺zipWith⋆ xs [] = []
  ⁺zipWith⋆ xs (∹ ys) = ∹ ⁺zipWith⁺ xs ys

  ⋆zipWith⋆ [] ys = []
  ⋆zipWith⋆ (∹ xs) ys = ⁺zipWith⋆ xs ys

module Unzip {a b c} {A : Set a} {B : Set b} {C : Set c} (f : A → B × C) where
  cons : B × C → B ⋆ × C ⋆ → B ⁺ × C ⁺
  head (proj₁ (cons x xs)) = proj₁ x
  tail (proj₁ (cons x xs)) = proj₁ xs
  head (proj₂ (cons x xs)) = proj₂ x
  tail (proj₂ (cons x xs)) = proj₂ xs

  unzipWith⋆ : A ⋆ → B ⋆ × C ⋆
  unzipWith⁺ : A ⁺ → B ⁺ × C ⁺

  unzipWith⋆ = foldr⋆ (λ x xs → Product.map ∹_ ∹_ (cons (f x) xs)) ([] , [])

  unzipWith⁺ xs = cons (f (head xs)) (unzipWith⋆ (tail xs))
open Unzip using (unzipWith⁺; unzipWith⋆) public

module Partition {a b c} {A : Set a} {B : Set b} {C : Set c} (f : A → B ⊎ C) where
  cons : B ⊎ C → B ⋆ × C ⋆ → B ⋆ × C ⋆
  proj₁ (cons (inj₁ x) xs) = ∹ x & proj₁ xs
  proj₂ (cons (inj₁ x) xs) = proj₂ xs
  proj₂ (cons (inj₂ x) xs) = ∹ x & proj₂ xs
  proj₁ (cons (inj₂ x) xs) = proj₁ xs

  partitionSumsWith⋆ : A ⋆ → B ⋆ × C ⋆
  partitionSumsWith⁺ : A ⁺ → B ⋆ × C ⋆

  partitionSumsWith⋆ = foldr⋆ (cons ∘ f) ([] , [])

  partitionSumsWith⁺ = foldr⁺ (cons ∘ f) ([] , [])
open Partition using (partitionSumsWith⁺; partitionSumsWith⋆) public

module _ {a} {A : Set a} where
  ⋆transpose⋆ : (A ⋆) ⋆ → (A ⋆) ⋆
  ⋆transpose⁺ : (A ⋆) ⁺ → (A ⁺) ⋆
  ⁺transpose⋆ : (A ⁺) ⋆ → (A ⋆) ⁺
  ⁺transpose⁺ : (A ⁺) ⁺ → (A ⁺) ⁺

  ⋆transpose⋆ [] = []
  ⋆transpose⋆ (∹ xs) = map⋆ ∹_ (⋆transpose⁺ xs)

  ⋆transpose⁺ (x & []) = map⋆ pure⁺ x
  ⋆transpose⁺ (x & (∹ xs)) = ⋆zipWith⋆ (λ y z → y & ∹ z) x (⋆transpose⁺ xs)

  ⁺transpose⋆ [] = [] & []
  ⁺transpose⋆ (∹ xs) = map⁺ ∹_ (⁺transpose⁺ xs)

  ⁺transpose⁺ (x & []) = map⁺ pure⁺ x
  ⁺transpose⁺ (x & (∹ xs)) = ⁺zipWith⁺ (λ y z → y & ∹ z) x (⁺transpose⁺ xs)

module _ {a} {A : Set a} where
  tails⋆ : A ⋆ → (A ⁺) ⋆
  tails⁺ : A ⁺ → (A ⁺) ⁺

  head (tails⁺ xs) = xs
  tail (tails⁺ xs) = tails⋆ (tail xs)

  tails⋆ [] = []
  tails⋆ (∹ xs) = ∹ tails⁺ xs

module _ {a} {A : Set a} where
  reverse⋆ : A ⋆ → A ⋆
  reverse⋆ = foldl⋆ (λ xs x → ∹ x & xs) []

  reverse⁺ : A ⁺ → A ⁺
  reverse⁺ (x & xs) = foldl⋆ (λ ys y → y & (∹ ys)) (x & []) xs


------------------------------------------------------------------------
-- Pointed types and loop spaces
------------------------------------------------------------------------

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

-- Partly following the HoTT book.

open import Equality

module Pointed-type
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude as P hiding (_×_)

open import Bijection eq as B using (_↔_)
open import Equivalence eq as E using (_≃_)
open import Function-universe eq as F hiding (id; _∘_)
open import H-level eq
open import Surjection eq using (_↠_)
open import Univalence-axiom eq

private
  variable
    a b ℓ : Level
    A B   : Type a
    x y   : A
    p q   : x ≡ y
    k     : Kind

------------------------------------------------------------------------
-- The definition of pointed types

-- Pointed types.

Pointed-type : ∀ ℓ → Type (lsuc ℓ)
Pointed-type a = ∃ λ (A : Type a) → A

------------------------------------------------------------------------
-- Based maps

-- Based maps (generalised to several kinds of underlying
-- "functions").

infix 4 _↝[_]ᴮ_ _→ᴮ_ _≃ᴮ_

_↝[_]ᴮ_ : Pointed-type a → Kind → Pointed-type b → Type (a ⊔ b)
(A , x) ↝[ k ]ᴮ (B , y) =
  ∃ λ (f : A ↝[ k ] B) → to-implication f x ≡ y

-- Based maps.

_→ᴮ_ : Pointed-type a → Pointed-type b → Type (a ⊔ b)
_→ᴮ_ = _↝[ implication ]ᴮ_

-- Based equivalences.

_≃ᴮ_ : Pointed-type a → Pointed-type b → Type (a ⊔ b)
_≃ᴮ_ = _↝[ equivalence ]ᴮ_

private
  variable
    P P₁ P₂ Q Q₁ Q₂ R : Pointed-type a
    P→Q               : P →ᴮ Q
    P≃Q               : P ≃ᴮ Q

-- Based equivalences can be converted to based maps.

≃ᴮ→→ᴮ : P ≃ᴮ Q → P →ᴮ Q
≃ᴮ→→ᴮ = Σ-map _≃_.to id

-- Based equivalences are equivalent to equalities (assuming
-- univalence).

≃ᴮ≃≡ : {P Q : Pointed-type a} → Univalence a → (P ≃ᴮ Q) ≃ (P ≡ Q)
≃ᴮ≃≡ {P = A , x} {Q = B , y} univ =
  (∃ λ (A≃B : A ≃ B) → _≃_.to A≃B x ≡ y)    ↝⟨ (inverse $
                                                Σ-cong (≡≃≃ univ) λ A≃B →
                                                ≡⇒≃ $ cong (_≡ _) $
                                                subst-id-in-terms-of-≡⇒↝ equivalence) ⟩
  (∃ λ (A≡B : A ≡ B) → subst id A≡B x ≡ y)  ↔⟨ B.Σ-≡,≡↔≡ ⟩□
  (A , x) ≡ (B , y)                         □

-- _↝[ k ]ᴮ_ is reflexive.

↝ᴮ-refl : P ↝[ k ]ᴮ P
↝ᴮ-refl {k = k} = F.id , cong (_$ _) (to-implication-id k)

-- _↝[ k ]ᴮ_ is transitive.

↝ᴮ-trans : P ↝[ k ]ᴮ Q → Q ↝[ k ]ᴮ R → P ↝[ k ]ᴮ R
↝ᴮ-trans {P = _ , x} {k = k} {Q = _ , y} {R = _ , z}
  (A↝B , p) (B↝C , q) =
    B↝C F.∘ A↝B
  , (to-implication (B↝C F.∘ A↝B) x             ≡⟨ cong (_$ _) $ to-implication-∘ k ⟩
     to-implication B↝C (to-implication A↝B x)  ≡⟨ cong (to-implication B↝C) p ⟩
     to-implication B↝C y                       ≡⟨ q ⟩∎
     z                                          ∎)

-- _≃ᴮ_ is symmetric.

≃ᴮ-sym : P ≃ᴮ Q → Q ≃ᴮ P
≃ᴮ-sym (A≃B , p) = inverse A≃B , _≃_.to-from A≃B p

-- "Equational" reasoning combinators.

infix  -1 _□ᴮ finallyᴮ
infixr -2 stepᴮ

-- For an explanation of why stepᴮ is defined in this way, see
-- Equality.step-≡.

stepᴮ : (P : Pointed-type a) {Q : Pointed-type b} →
        Q ↝[ k ]ᴮ R → P ↝[ k ]ᴮ Q → P ↝[ k ]ᴮ R
stepᴮ _ = flip ↝ᴮ-trans

syntax stepᴮ P Q↝R P↝Q = P ↝ᴮ⟨ P↝Q ⟩ Q↝R

finallyᴮ :
  (P : Pointed-type a) (Q : Pointed-type b) →
  P ↝[ k ]ᴮ Q → P ↝[ k ]ᴮ Q
finallyᴮ _ _ P↝Q = P↝Q

syntax finallyᴮ P Q P↝Q = P ↝ᴮ⟨ P↝Q ⟩□ Q □

_□ᴮ : (P : Pointed-type a) → P ↝[ k ]ᴮ P
_ □ᴮ = ↝ᴮ-refl

-- There is a split surjection from based maps from
-- (Maybe A , nothing) to functions.

Maybe→ᴮ↠→ : (Maybe A , nothing) →ᴮ (B , x) ↠ (A → B)
Maybe→ᴮ↠→ {A = A} {B = B} {x = x} = record
  { logical-equivalence = record
    { to   = (Maybe A , nothing) →ᴮ (B , x)  ↝⟨ proj₁ ⟩
             (Maybe A → B)                   ↝⟨ _∘ inj₂ ⟩□
             (A → B)                         □
    ; from = λ f → [ (λ _ → x) , f ] , refl x
    }
  ; right-inverse-of = refl
  }

-- Based maps from (Maybe A , nothing) are isomorphic to functions
-- (assuming extensionality).

Maybe→ᴮ↔→ :
  ∀ {A : Type a} {B : Type b} {x} →
  (Maybe A , nothing) →ᴮ (B , x) ↝[ a ∣ b ] (A → B)
Maybe→ᴮ↔→ {A = A} {B} {x} = generalise-ext?
  (_↠_.logical-equivalence Maybe→ᴮ↠→)
  (λ ext →
       refl
     , (λ (f , eq) → Σ-≡,≡→≡
          (apply-ext (E.good-ext ext)
             [ (λ _ →
                  x          ≡⟨ sym eq ⟩∎
                  f nothing  ∎)
             , (λ _ → refl _)
             ])
          (subst (λ f → f nothing ≡ x)
                 (apply-ext (E.good-ext ext)
                    [ (λ _ → sym eq) , (λ _ → refl _) ])
                 (refl x)                                 ≡⟨ E.subst-good-ext ext _ _ ⟩

           subst (_≡ x) (sym eq) (refl x)                 ≡⟨ subst-trans _ ⟩

           trans eq (refl x)                              ≡⟨ trans-reflʳ _ ⟩∎

           eq                                             ∎)))

-- A corollary.

Bool→ᴮ↔ :
  ∀ {A : Type a} {x} →
  (Bool , true) →ᴮ (A , x) ↝[ lzero ∣ a ] A
Bool→ᴮ↔ {A = A} {x = x} ext =
  (Bool , true) →ᴮ (A , x)  ↝⟨ Maybe→ᴮ↔→ ext ⟩
  (⊤ → A)                   ↔⟨ Π-left-identity ⟩□
  A                         □

------------------------------------------------------------------------
-- Loop spaces

-- The loop space of a pointed type.

Ω : Pointed-type ℓ → Pointed-type ℓ
Ω (A , x) = (x ≡ x) , refl x

-- Iterated loop spaces.
--
-- The HoTT book uses Ω[ n ] ∘ Ω rather than Ω ∘ Ω[ n ]. I prefer
-- the following definition, because with the other definition the
-- type of Equality.Groupoid.Ω[2+n]-commutative would not be
-- well-formed. (See also Ω∘Ω[]≡Ω[]∘Ω.)

Ω[_] : ℕ → Pointed-type ℓ → Pointed-type ℓ
Ω[ zero  ] = id
Ω[ suc n ] = Ω ∘ Ω[ n ]

-- A rearrangement lemma for Ω and Ω[_].

Ω∘Ω[]≡Ω[]∘Ω : ∀ n → Ω (Ω[ n ] P) ≡ Ω[ n ] (Ω P)
Ω∘Ω[]≡Ω[]∘Ω {P = P} zero =
  Ω P  ∎
Ω∘Ω[]≡Ω[]∘Ω {P = P} (suc n) =
  Ω (Ω[ suc n ] P)  ≡⟨⟩
  Ω (Ω (Ω[ n ] P))  ≡⟨ cong Ω $ Ω∘Ω[]≡Ω[]∘Ω n ⟩
  Ω (Ω[ n ] (Ω P))  ≡⟨⟩
  Ω[ suc n ] (Ω P)  ∎

-- Ω preserves based maps.

Ω-cong-→ᴮ : P →ᴮ Q → Ω P →ᴮ Ω Q
Ω-cong-→ᴮ {P = A , x} {Q = B , y} (to , to≡) =
    (x ≡ x        ↝⟨ cong to ⟩
     to x ≡ to x  ↔⟨ ≡⇒≃ $ cong₂ _≡_ to≡ to≡ ⟩□
     y ≡ y        □)
  , (≡⇒→ (cong₂ _≡_ to≡ to≡) (cong to (refl x))      ≡⟨ cong (≡⇒→ (cong₂ _≡_ to≡ to≡)) $ cong-refl _ ⟩
     ≡⇒→ (cong₂ _≡_ to≡ to≡) (refl (to x))           ≡⟨ elim¹
                                                          (λ to≡ → ≡⇒→ (cong₂ _≡_ to≡ to≡) (refl (to x)) ≡
                                                                   refl _)
                                                          (
         ≡⇒→ (cong₂ _≡_ (refl _) (refl _)) (refl _)        ≡⟨ cong (λ eq → ≡⇒→ eq (refl _)) $ cong₂-refl _≡_ ⟩
         ≡⇒→ (refl _) (refl _)                             ≡⟨ cong (λ eq → _≃_.to eq (refl _)) ≡⇒↝-refl ⟩∎
         refl _                                                       ∎)
                                                          _ ⟩∎
     refl y                                          ∎)

-- Ω preserves based equivalences.

Ω-cong-≃ᴮ : P ≃ᴮ Q → Ω P ≃ᴮ Ω Q
Ω-cong-≃ᴮ {P = A , x} {Q = B , y} (A≃B , to≡) =
    (x ≡ x                        ↝⟨ inverse $ E.≃-≡ A≃B ⟩
     _≃_.to A≃B x ≡ _≃_.to A≃B x  ↝⟨ ≡⇒↝ _ $ cong₂ _≡_ to≡ to≡ ⟩□
     y ≡ y                        □)
  , proj₂ (Ω-cong-→ᴮ (_≃_.to A≃B , to≡))

-- Ω[ n ] preserves based maps.

Ω[_]-cong-→ᴮ : ∀ n → P →ᴮ Q → Ω[ n ] P →ᴮ Ω[ n ] Q
Ω[ zero  ]-cong-→ᴮ A→B = A→B
Ω[ suc n ]-cong-→ᴮ A→B = Ω-cong-→ᴮ (Ω[ n ]-cong-→ᴮ A→B)

-- Ω[ n ] preserves based equivalences.

Ω[_]-cong-≃ᴮ : ∀ n → P ≃ᴮ Q → Ω[ n ] P ≃ᴮ Ω[ n ] Q
Ω[ zero  ]-cong-≃ᴮ A≃B = A≃B
Ω[ suc n ]-cong-≃ᴮ A≃B = Ω-cong-≃ᴮ (Ω[ n ]-cong-≃ᴮ A≃B)

-- ≃ᴮ→→ᴮ commutes with Ω-cong-≃ᴮ/Ω-cong-→ᴮ.

≃ᴮ→→ᴮ-Ω-cong-≃ᴮ :
  (P≃Q : P ≃ᴮ Q) →
  ≃ᴮ→→ᴮ (Ω-cong-≃ᴮ P≃Q) ≡ Ω-cong-→ᴮ (≃ᴮ→→ᴮ P≃Q)
≃ᴮ→→ᴮ-Ω-cong-≃ᴮ _ = refl _

-- ≃ᴮ→→ᴮ commutes with Ω[ n ]-cong-≃ᴮ/Ω[ n ]-cong-→ᴮ.

≃ᴮ→→ᴮ-Ω[_]-cong-≃ᴮ :
  ∀ n →
  ≃ᴮ→→ᴮ (Ω[ n ]-cong-≃ᴮ P≃Q) ≡
  Ω[ n ]-cong-→ᴮ (≃ᴮ→→ᴮ P≃Q)
≃ᴮ→→ᴮ-Ω[_]-cong-≃ᴮ {P≃Q = P≃Q} = λ where
  zero    → refl _
  (suc n) →
    ≃ᴮ→→ᴮ (Ω-cong-≃ᴮ (Ω[ n ]-cong-≃ᴮ P≃Q))  ≡⟨⟩
    Ω-cong-→ᴮ (≃ᴮ→→ᴮ (Ω[ n ]-cong-≃ᴮ P≃Q))  ≡⟨ cong Ω-cong-→ᴮ ≃ᴮ→→ᴮ-Ω[ n ]-cong-≃ᴮ ⟩
    Ω-cong-→ᴮ (Ω[ n ]-cong-→ᴮ (≃ᴮ→→ᴮ P≃Q))  ∎

-- A lemma relating Ω-cong-→ᴮ and ↝ᴮ-refl.

proj₁-Ω-cong-→ᴮ-↝ᴮ-refl :
  proj₁ (Ω-cong-→ᴮ ↝ᴮ-refl) p ≡ p
proj₁-Ω-cong-→ᴮ-↝ᴮ-refl {p = p} =
  ≡⇒→
    (cong₂ _≡_
       (cong (_$ _) (refl _))
       (cong (_$ _) (refl _)))
    (cong id p)                 ≡⟨ cong₂ ≡⇒→
                                     (trans (cong₂ (cong₂ _≡_)
                                               (cong-refl _)
                                               (cong-refl _)) $
                                      cong₂-refl _≡_)
                                     (sym $ cong-id _) ⟩

  ≡⇒→ (refl _) p                ≡⟨ cong (_$ _) ≡⇒→-refl ⟩∎

  p                             ∎

-- A lemma relating Ω-cong-≃ᴮ and ↝ᴮ-refl.

proj₁-Ω-cong-≃ᴮ-↝ᴮ-refl :
  _≃_.to (proj₁ (Ω-cong-≃ᴮ ↝ᴮ-refl)) p ≡ p
proj₁-Ω-cong-≃ᴮ-↝ᴮ-refl = proj₁-Ω-cong-→ᴮ-↝ᴮ-refl

-- A lemma relating Ω-cong-→ᴮ and trans.

Ω-cong-→ᴮ-trans :
  proj₁ (Ω-cong-→ᴮ P→Q) (trans p q) ≡
  trans (proj₁ (Ω-cong-→ᴮ P→Q) p)
        (proj₁ (Ω-cong-→ᴮ P→Q) q)
Ω-cong-→ᴮ-trans {P→Q = to , to≡} {p = p} {q = q} =
  ≡⇒→ (cong₂ _≡_ to≡ to≡) (cong to (trans p q))            ≡⟨ cong (≡⇒→ (cong₂ _≡_ to≡ to≡)) $
                                                              cong-trans _ _ _ ⟩
  ≡⇒→ (cong₂ _≡_ to≡ to≡)
    (trans (cong to p) (cong to q))                        ≡⟨ lemma _ ⟩

  trans
    (trans (sym to≡)
       (trans (cong to p) (cong to q)))
    to≡                                                    ≡⟨ trans (cong (flip trans _) $ sym $ trans-assoc _ _ _) $
                                                              trans-assoc _ _ _ ⟩
  trans
    (trans (sym to≡) (cong to p))
    (trans (cong to q) to≡)                                ≡⟨ cong (trans _) $ sym $
                                                              trans--[trans-sym] _ _ ⟩
  trans (trans (sym to≡) (cong to p))
    (trans to≡ (trans (sym to≡) (trans (cong to q) to≡)))  ≡⟨ trans (cong (trans _) $ cong (trans _) $ sym $ trans-assoc _ _ _) $
                                                              sym $ trans-assoc _ _ _ ⟩
  trans
    (trans (trans (sym to≡) (cong to p)) to≡)
    (trans (trans (sym to≡) (cong to q)) to≡)              ≡⟨ sym $ cong₂ trans (lemma _) (lemma _) ⟩∎

  trans
    (≡⇒→ (cong₂ _≡_ to≡ to≡) (cong to p))
    (≡⇒→ (cong₂ _≡_ to≡ to≡) (cong to q))                  ∎
  where
  lemma = λ p →
    ≡⇒→ (cong₂ _≡_ to≡ to≡) p                          ≡⟨⟩
    ≡⇒→ (trans (cong (_≡ _) to≡) (cong (_ ≡_) to≡)) p  ≡⟨ cong (_$ p) $ ≡⇒↝-trans equivalence ⟩
    ≡⇒→ (cong (_ ≡_) to≡) (≡⇒→ (cong (_≡ _) to≡) p)    ≡⟨ sym $ subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩
    subst (_ ≡_) to≡ (≡⇒→ (cong (_≡ _) to≡) p)         ≡⟨ sym trans-subst ⟩
    trans (≡⇒→ (cong (_≡ _) to≡) p) to≡                ≡⟨ cong (flip trans _) $ sym $ subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩
    trans (subst (_≡ _) to≡ p) to≡                     ≡⟨ cong (flip trans _) subst-trans-sym ⟩∎
    trans (trans (sym to≡) p) to≡                      ∎

-- A lemma relating Ω-cong-≃ᴮ and trans.

Ω-cong-≃ᴮ-trans :
  (P≃Q : P ≃ᴮ Q) →
  _≃_.to (proj₁ (Ω-cong-≃ᴮ P≃Q)) (trans p q) ≡
  trans (_≃_.to (proj₁ (Ω-cong-≃ᴮ P≃Q)) p)
        (_≃_.to (proj₁ (Ω-cong-≃ᴮ P≃Q)) q)
Ω-cong-≃ᴮ-trans _ = Ω-cong-→ᴮ-trans

-- A lemma relating Ω[_]-cong-→ᴮ and trans.

Ω[1+_]-cong-→ᴮ-trans :
  ∀ n {p q} →
  proj₁ (Ω[ 1 + n ]-cong-→ᴮ P→Q) (trans p q) ≡
  trans (proj₁ (Ω[ 1 + n ]-cong-→ᴮ P→Q) p)
        (proj₁ (Ω[ 1 + n ]-cong-→ᴮ P→Q) q)
Ω[1+ _ ]-cong-→ᴮ-trans = Ω-cong-→ᴮ-trans

-- A lemma relating Ω[_]-cong-≃ᴮ and trans.

Ω[1+_]-cong-≃ᴮ-trans :
  ∀ n {p q} (P≃Q : P ≃ᴮ Q) →
  _≃_.to (proj₁ (Ω[ 1 + n ]-cong-≃ᴮ P≃Q)) (trans p q) ≡
  trans (_≃_.to (proj₁ (Ω[ 1 + n ]-cong-≃ᴮ P≃Q)) p)
        (_≃_.to (proj₁ (Ω[ 1 + n ]-cong-≃ᴮ P≃Q)) q)
Ω[1+ n ]-cong-≃ᴮ-trans P≃Q = Ω-cong-≃ᴮ-trans (Ω[ n ]-cong-≃ᴮ P≃Q)

-- A has h-level 1 + n iff the iterated loop space Ω[ n ] (A , x) is
-- contractible for every x : A.

+⇔∀contractible-Ω[] :
  ∀ n →
  H-level (1 + n) A
    ⇔
  ((x : A) → Contractible (proj₁ $ Ω[ n ] (A , x)))
+⇔∀contractible-Ω[] {A = A} zero =
  Is-proposition A      ↝⟨ record { to   = propositional⇒inhabited⇒contractible
                                  ; from = [inhabited⇒contractible]⇒propositional
                                  } ⟩□
  (A → Contractible A)  □

+⇔∀contractible-Ω[] {A = A} (suc zero) =
  Is-set A                            ↝⟨ 2+⇔∀1+≡ 0 ⟩
  ((x : A) → Is-proposition (x ≡ x))  ↝⟨ (∀-cong _ λ x → record { to   = flip propositional⇒inhabited⇒contractible (refl x)
                                                                ; from = mono₁ 0
                                                                }) ⟩□
  ((x : A) → Contractible (x ≡ x))    □

+⇔∀contractible-Ω[] {A = A} (suc (suc n)) =
  H-level (3 + n) A                                                  ↝⟨ 2+⇔∀1+≡ (1 + n) ⟩

  ((x : A) → H-level (2 + n) (x ≡ x))                                ↝⟨ (∀-cong _ λ _ → +⇔∀contractible-Ω[] (suc n)) ⟩

  ((x : A) (p : x ≡ x) →
   Contractible (proj₁ $ Ω[ 1 + n ] ((x ≡ x) , p)))                  ↝⟨ (∀-cong _ λ _ → ∀-cong _ λ _ → H-level-cong _ _ $ proj₁ $
                                                                         Ω[ 1 + n ]-cong-≃ᴮ $ lemma _) ⟩

  ((x : A) → x ≡ x → Contractible (proj₁ $ Ω[ 1 + n ] (Ω (A , x))))  ↝⟨ (∀-cong _ λ x → _↠_.logical-equivalence $ inhabited→↠ (refl x)) ⟩

  ((x : A) → Contractible (proj₁ $ Ω[ 1 + n ] (Ω (A , x))))          ↝⟨ (∀-cong _ λ _ → ≡⇒↝ _ $ cong (Contractible ∘ proj₁) $ sym $
                                                                         Ω∘Ω[]≡Ω[]∘Ω (1 + n)) ⟩□
  ((x : A) → Contractible (proj₁ $ Ω[ 2 + n ] (A , x)))              □
  where
  lemma : (p : x ≡ x) → ((x ≡ x) , p) ≃ᴮ Ω (A , x)
  lemma p = E.↔⇒≃ (inverse $ flip-trans-isomorphism p)
          , (trans p (sym p)  ≡⟨ trans-symʳ _ ⟩∎
             refl _           ∎)

------------------------------------------------------------------------
-- Products

-- The product of two pointed types.

infixr 2 _×_

_×_ : Pointed-type a → Pointed-type b → Pointed-type (a ⊔ b)
(A , x) × (B , y) = (A P.× B) , (x , y)

-- The first projection.

proj₁ᴾ : (P × Q) →ᴮ P
proj₁ᴾ = proj₁ , refl _

-- The second projection.

proj₂ᴾ : (P × Q) →ᴮ Q
proj₂ᴾ = proj₂ , refl _

-- The operator _×_ preserves based maps and equivalences.

infixr 2 _×-cong-→ᴮ_ _×-cong-≃ᴮ_

_×-cong-→ᴮ_ : P₁ →ᴮ P₂ → Q₁ →ᴮ Q₂ → (P₁ × Q₁) →ᴮ (P₂ × Q₂)
(f₁ , eq₁) ×-cong-→ᴮ (f₂ , eq₂) =
    (f₁ ×-cong f₂)
  , cong₂ _,_ eq₁ eq₂

_×-cong-≃ᴮ_ : P₁ ≃ᴮ P₂ → Q₁ ≃ᴮ Q₂ → (P₁ × Q₁) ≃ᴮ (P₂ × Q₂)
(f₁ , eq₁) ×-cong-≃ᴮ (f₂ , eq₂) =
    (f₁ ×-cong f₂)
  , cong₂ _,_ eq₁ eq₂

-- Ω commutes with _×_.

Ω-× : Ω (P × Q) ≃ᴮ (Ω P × Ω Q)
Ω-× {P = A , x} {Q = B , y} =
    ((x , y) ≡ (x , y)  ↝⟨ E.↔⇒≃ (inverse ≡×≡↔≡) ⟩□
     x ≡ x P.× y ≡ y    □)
  , ((cong proj₁ (refl (x , y)) , cong proj₂ (refl (x , y)))  ≡⟨ cong₂ _,_ (cong-refl _) (cong-refl _) ⟩∎
     (refl x , refl y)                                        ∎)

-- Ω[ n ] commutes with _×_.

Ω[_]-× : ∀ n → Ω[ n ] (P × Q) ≃ᴮ (Ω[ n ] P × Ω[ n ] Q)
Ω[_]-× {P = P} {Q = Q} = λ where
  zero    → P × Q  □ᴮ
  (suc n) →
    Ω (Ω[ n ] (P × Q))           ↝ᴮ⟨ Ω-cong-≃ᴮ Ω[ n ]-× ⟩
    Ω (Ω[ n ] P × Ω[ n ] Q)      ↝ᴮ⟨ Ω-× ⟩□
    Ω (Ω[ n ] P) × Ω (Ω[ n ] Q)  □

-- A lemma relating Ω[ 1 ]-× and Ω-×.

Ω[1]-× : _≃_.to (proj₁ Ω[ 1 ]-×) p ≡ _≃_.to (proj₁ Ω-×) p
Ω[1]-× {p = p} =
  _≃_.to (proj₁ Ω[ 1 ]-×) p                                  ≡⟨⟩
  _≃_.to (proj₁ Ω-×) (_≃_.to (proj₁ (Ω-cong-≃ᴮ ↝ᴮ-refl)) p)  ≡⟨ cong (_≃_.to (proj₁ Ω-×)) proj₁-Ω-cong-≃ᴮ-↝ᴮ-refl ⟩∎
  _≃_.to (proj₁ Ω-×) p                                       ∎

-- A lemma relating Ω-× and trans.

Ω-×-trans :
  _≃_.to (proj₁ Ω-×) (trans p q) ≡
  Σ-zip trans trans
    (_≃_.to (proj₁ Ω-×) p)
    (_≃_.to (proj₁ Ω-×) q)
Ω-×-trans {p = p} {q = q} =
  _≃_.to (proj₁ Ω-×) (trans p q)         ≡⟨⟩

  ( cong proj₁ (trans p q)
  , cong proj₂ (trans p q)
  )                                      ≡⟨ cong₂ _,_
                                              (cong-trans _ _ _)
                                              (cong-trans _ _ _) ⟩
  ( trans (cong proj₁ p) (cong proj₁ q)
  , trans (cong proj₂ p) (cong proj₂ q)
  )                                      ≡⟨⟩

  Σ-zip trans trans
    (_≃_.to (proj₁ Ω-×) p)
    (_≃_.to (proj₁ Ω-×) q)               ∎

-- A lemma relating Ω[_]-× and trans.

Ω[1+_]-×-trans :
  ∀ n {p q : proj₁ (Ω[ suc n ] (P × Q))} →
  _≃_.to (proj₁ Ω[ suc n ]-×) (trans p q) ≡
  Σ-zip trans trans
    (_≃_.to (proj₁ Ω[ suc n ]-×) p)
    (_≃_.to (proj₁ Ω[ suc n ]-×) q)
Ω[1+ n ]-×-trans {p = p} {q = q} =
  _≃_.to (proj₁ Ω-×)
    (_≃_.to (proj₁ (Ω-cong-≃ᴮ Ω[ n ]-×)) (trans p q))  ≡⟨ cong (_≃_.to (proj₁ Ω-×)) $ Ω-cong-≃ᴮ-trans Ω[ n ]-× ⟩

  _≃_.to (proj₁ Ω-×)
    (trans (_≃_.to (proj₁ (Ω-cong-≃ᴮ Ω[ n ]-×)) p)
           (_≃_.to (proj₁ (Ω-cong-≃ᴮ Ω[ n ]-×)) q))    ≡⟨ Ω-×-trans ⟩∎

  Σ-zip trans trans
    (_≃_.to (proj₁ Ω-×)
       (_≃_.to (proj₁ (Ω-cong-≃ᴮ Ω[ n ]-×)) p))
    (_≃_.to (proj₁ Ω-×)
       (_≃_.to (proj₁ (Ω-cong-≃ᴮ Ω[ n ]-×)) q))        ∎


module Numeral.PositiveInteger.Oper.Proofs where

open import Functional
open import Function.Equals
open import Function.Iteration
open import Function.Iteration.Proofs
open import Logic.Propositional
open import Logic.Predicate
import      Numeral.Natural as ℕ
import      Numeral.Natural.Oper as ℕ
open import Numeral.PositiveInteger
open import Numeral.PositiveInteger.Oper
open import Relator.Equals
open import Relator.Equals.Proofs
import      Function.Names as Names
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Function.Multi
open import Structure.Operator
open import Structure.Operator.Monoid
import      Structure.Operator.Names as Names
open import Structure.Operator.Proofs.Util
open import Structure.Operator.Proofs
open import Structure.Operator.Properties
open import Syntax.Transitivity
open import Type

-- TODO: Move stuff related to ℕ₊-to-ℕ

instance
  ℕ-ℕ₊-preserves-𝐒 : Preserving₁(ℕ₊-to-ℕ)(𝐒)(ℕ.𝐒)
  Preserving.proof ℕ-ℕ₊-preserves-𝐒 = p where
    p : Names.Preserving₁(ℕ₊-to-ℕ)(𝐒)(ℕ.𝐒)
    p {𝟏}   = [≡]-intro
    p {𝐒 x} = congruence₁(ℕ.𝐒) p

instance
  ℕ-ℕ₊-preserves-[+] : Preserving₂(ℕ₊-to-ℕ)(_+_)(ℕ._+_)
  Preserving.proof ℕ-ℕ₊-preserves-[+] = p where
    p : Names.Preserving₂(ℕ₊-to-ℕ)(_+_)(ℕ._+_)
    p {x} {𝟏}   = [≡]-intro
    p {x} {𝐒 y} = congruence₁(ℕ.𝐒) p

instance
  ℕ-ℕ₊-preserves-[⋅] : Preserving₂(ℕ₊-to-ℕ)(_⋅_)(ℕ._⋅_)
  Preserving.proof ℕ-ℕ₊-preserves-[⋅] {x}{y} = p{x}{y} where
    p : Names.Preserving₂(ℕ₊-to-ℕ)(_⋅_)(ℕ._⋅_)
    p {x} {𝟏}   = [≡]-intro
    p {x} {𝐒 y} =
      ℕ₊-to-ℕ (x + (x ⋅ y))                         🝖[ _≡_ ]-[ preserving₂(ℕ₊-to-ℕ)(_+_)(ℕ._+_) ]
      (ℕ₊-to-ℕ x) ℕ.+ (ℕ₊-to-ℕ (x ⋅ y))             🝖[ _≡_ ]-[ congruence₁((ℕ₊-to-ℕ x) ℕ.+_) (p{x}{y}) ]
      (ℕ₊-to-ℕ x) ℕ.+ ((ℕ₊-to-ℕ x) ℕ.⋅ (ℕ₊-to-ℕ y)) 🝖[ _≡_ ]-end

instance
  𝐒-from-ℕ-preserves-𝐒 : Preserving₁(𝐒-from-ℕ)(ℕ.𝐒)(𝐒)
  Preserving.proof 𝐒-from-ℕ-preserves-𝐒 = [≡]-intro

instance
  𝐒-from-ℕ-preserves-[+] : Preserving₂(𝐒-from-ℕ)(ℕ.𝐒 ∘₂ ℕ._+_)(_+_)
  Preserving.proof 𝐒-from-ℕ-preserves-[+] = p where
    p : Names.Preserving₂(𝐒-from-ℕ)(ℕ.𝐒 ∘₂ ℕ._+_)(_+_)
    p {x}{ℕ.𝟎}   = [≡]-intro
    p {x}{ℕ.𝐒 y} = congruence₁(𝐒) (p {x}{y})

{-instance
  𝐒-from-ℕ-preserves-[⋅] : Preserving₂(𝐒-from-ℕ)(ℕ.𝐒 ∘₂ ℕ._⋅_ )(_⋅_)
  Preserving.proof 𝐒-from-ℕ-preserves-[⋅] = p where
    p : Names.Preserving₂(𝐒-from-ℕ)(ℕ.𝐒 ∘₂ ℕ._⋅_ )(_⋅_)
    p {x}{ℕ.𝟎}   = {!!}
    p {x}{ℕ.𝐒 y} = {!!}
-}
{-      𝐒-from-ℕ (ℕ.𝐒(x ℕ.+ (x ℕ.⋅ ℕ.𝐒(y))))         🝖[ _≡_ ]-[ preserving₂(𝐒-from-ℕ)(ℕ.𝐒 ∘₂ ℕ._+_)(_+_) ]
      (𝐒-from-ℕ x) + (𝐒-from-ℕ (x ℕ.⋅ ℕ.𝐒(y)))     🝖[ _≡_ ]-[]
      (𝐒-from-ℕ x) + (𝐒-from-ℕ (x ℕ.+ (x ℕ.⋅ y)))  🝖[ _≡_ ]-[ congruence₁((𝐒-from-ℕ x) +_) (p{x}{y}) ]
      (𝐒-from-ℕ x) + ((𝐒-from-ℕ x) ⋅ (𝐒-from-ℕ y)) 🝖[ _≡_ ]-end
-}

{-
instance
  ℕ₊-to-ℕ-injective : Injective(ℕ₊-to-ℕ)
  Injective.proof ℕ₊-to-ℕ-injective {𝟏}   {𝟏}   p = [≡]-intro
  Injective.proof ℕ₊-to-ℕ-injective {𝟏}   {𝐒 y} p = {!congruence₁(\x → ℕ-to-ℕ₊ x ⦃ ? ⦄) p!}
  Injective.proof ℕ₊-to-ℕ-injective {𝐒 x} {𝟏}   p = {!preserving₁(ℕ₊-to-ℕ)(𝐒)(ℕ.𝐒) 🝖 p!}
  Injective.proof ℕ₊-to-ℕ-injective {𝐒 x} {𝐒 y} p = {!!}
-}

{-
module _ where
  [+]-repeatᵣ-𝐒 : ∀{x y z : ℕ} → (x + y ≡ repeatᵣ y (const 𝐒) z x)
  [+]-repeatᵣ-𝐒 {x} {𝟎}       = [≡]-intro
  [+]-repeatᵣ-𝐒 {x} {𝐒 y} {z} = congruence₁(𝐒) ([+]-repeatᵣ-𝐒 {x} {y} {z})

  [+]-repeatₗ-𝐒 : ∀{x y z : ℕ} → (x + y ≡ repeatₗ y (const ∘ 𝐒) x z)
  [+]-repeatₗ-𝐒 {x} {𝟎}       = [≡]-intro
  [+]-repeatₗ-𝐒 {x} {𝐒 y} {z} = congruence₁(𝐒) ([+]-repeatₗ-𝐒 {x} {y} {z})

  [⋅]-repeatᵣ-[+] : ∀{x y} → (x ⋅ y ≡ repeatᵣ y (_+_) x 0)
  [⋅]-repeatᵣ-[+] {x} {𝟎}   = [≡]-intro
  [⋅]-repeatᵣ-[+] {x} {𝐒 y} = congruence₁(x +_) ([⋅]-repeatᵣ-[+] {x} {y})

  [^]-repeatᵣ-[⋅] : ∀{x y} → (x ^ y ≡ repeatᵣ y (_⋅_) x 1)
  [^]-repeatᵣ-[⋅] {x} {𝟎}   = [≡]-intro
  [^]-repeatᵣ-[⋅] {x} {𝐒 y} = congruence₁(x ⋅_) ([^]-repeatᵣ-[⋅] {x} {y})
-}

instance
  [𝐒]-injective : Injective(𝐒)
  Injective.proof [𝐒]-injective [≡]-intro = [≡]-intro

[1+]-𝐒 : ∀{x : ℕ₊} → (𝟏 + x ≡ 𝐒(x))
[1+]-𝐒 {𝟏}   = [≡]-intro
[1+]-𝐒 {𝐒 x} = congruence₁(𝐒) ([1+]-𝐒 {x})
{-# REWRITE [1+]-𝐒 #-}

[+]-step : ∀{x y : ℕ₊} → (𝐒(x) + y) ≡ (x + 𝐒(y))
[+]-step {x} {𝟏}   = [≡]-intro
[+]-step {x} {𝐒 y} = congruence₁(𝐒) ([+]-step {x} {y})
{-# REWRITE [+]-step #-}

[+]-commutativity-raw : Names.Commutativity(_+_)
[+]-commutativity-raw {𝟏}   {𝟏}   = [≡]-intro
[+]-commutativity-raw {𝟏}   {𝐒 y} = congruence₁(𝐒) ([+]-commutativity-raw {𝟏} {y})
[+]-commutativity-raw {𝐒 x} {𝟏}   = congruence₁(𝐒) ([+]-commutativity-raw {x} {𝟏})
[+]-commutativity-raw {𝐒 x} {𝐒 y} = congruence₁(𝐒) (congruence₁(𝐒) ([+]-commutativity-raw {x} {y}))

instance
  [+]-commutativity : Commutativity(_+_)
  [+]-commutativity = intro [+]-commutativity-raw

[+]-associativity-raw : Names.Associativity(_+_)
[+]-associativity-raw {x} {y} {𝟏} = [≡]-intro
[+]-associativity-raw {x} {y} {𝐒 z} = congruence₁(𝐒) ([+]-associativity-raw {x} {y} {z})

instance
  [+]-associativity : Associativity(_+_)
  [+]-associativity = intro [+]-associativity-raw

[⋅]-identityₗ-raw : Names.Identityₗ(_⋅_)(𝟏)
[⋅]-identityₗ-raw {𝟏}   = [≡]-intro
[⋅]-identityₗ-raw {𝐒 x} = congruence₁(𝐒) ([⋅]-identityₗ-raw {x}) -- commutativity(_+_) 🝖 congruence₁(𝐒) ([⋅]-identityₗ-raw {x})
{-# REWRITE [⋅]-identityₗ-raw #-}

[⋅]-identityᵣ-raw : Names.Identityᵣ(_⋅_)(𝟏)
[⋅]-identityᵣ-raw = [≡]-intro

instance
  [⋅]-identityₗ : Identityₗ(_⋅_)(𝟏)
  [⋅]-identityₗ = intro [⋅]-identityₗ-raw

instance
  [⋅]-identityᵣ : Identityᵣ(_⋅_)(𝟏)
  [⋅]-identityᵣ = intro [⋅]-identityᵣ-raw

instance
  [⋅]-identity : Identity(_⋅_)(𝟏)
  [⋅]-identity = intro

[⋅]-commutativity-raw : Names.Commutativity(_⋅_) -- TODO: Extract the proof of (x + (𝐒 x + 𝐒 y) ≡ y + (𝐒 x + 𝐒 y)). Note that the properties here can probably also be proven using Function.Repeat.Proofs
[⋅]-commutativity-raw {x} {𝟏}   = [≡]-intro
[⋅]-commutativity-raw {𝟏} {𝐒 y} = [≡]-intro
[⋅]-commutativity-raw {𝐒 x} {𝐒 y} =
  𝐒 x ⋅ 𝐒 y           🝖[ _≡_ ]-[]
  𝐒 x + (𝐒 x ⋅ y)     🝖-[ congruence₁(𝐒) (congruence₂ᵣ(_+_)(x) ([⋅]-commutativity-raw {𝐒 x} {y})) ]
  𝐒 x + (y ⋅ 𝐒 x)     🝖[ _≡_ ]-[]
  𝐒 x + (y ⋅ 𝐒 x)     🝖[ _≡_ ]-[]
  𝐒 x + (y + (y ⋅ x)) 🝖-[ congruence₁(𝐒) (associativity(_+_)) ]-sym
  (𝐒 x + y) + (y ⋅ x) 🝖[ _≡_ ]-[]
  𝐒(x + y) + (y ⋅ x)  🝖-[ congruence₁(𝐒) (congruence₂(_+_) ([+]-commutativity-raw {x}{y}) ([⋅]-commutativity-raw {y}{x})) ]
  𝐒(y + x) + (x ⋅ y)  🝖[ _≡_ ]-[]
  (𝐒 y + x) + (x ⋅ y) 🝖-[ congruence₁(𝐒) (associativity(_+_)) ]
  𝐒 y + (x + (x ⋅ y)) 🝖[ _≡_ ]-[]
  𝐒 y + (x ⋅ 𝐒 y)     🝖-[ congruence₁(𝐒) (congruence₂ᵣ(_+_)(y) ([⋅]-commutativity-raw {𝐒 y} {x})) ]-sym
  𝐒 y + (𝐒 y ⋅ x)     🝖[ _≡_ ]-[]
  𝐒 y ⋅ 𝐒 x           🝖-end

instance
  [⋅]-commutativity : Commutativity(_⋅_)
  [⋅]-commutativity = intro(\{x}{y} → [⋅]-commutativity-raw {x}{y})

[⋅][+]-distributivityᵣ-raw : Names.Distributivityᵣ(_⋅_)(_+_)
[⋅][+]-distributivityᵣ-raw {x} {y} {𝟏}   = [≡]-intro
[⋅][+]-distributivityᵣ-raw {x} {y} {𝐒 z} =
  (x + y) + ((x + y) ⋅ z)       🝖[ _≡_ ]-[ congruence₁((x + y) +_) ([⋅][+]-distributivityᵣ-raw {x} {y} {z}) ]
  (x + y) + ((x ⋅ z) + (y ⋅ z)) 🝖[ _≡_ ]-[ One.associate-commute4 {a = x}{y}{x ⋅ z}{y ⋅ z} ([+]-commutativity-raw{x = y}) ]
  (x + (x ⋅ z)) + (y + (y ⋅ z)) 🝖[ _≡_ ]-[]
  (x ⋅ 𝐒(z)) + (y ⋅ 𝐒(z))       🝖[ _≡_ ]-end

instance
  [⋅][+]-distributivityᵣ : Distributivityᵣ(_⋅_)(_+_)
  [⋅][+]-distributivityᵣ = intro(\{x}{y}{z} → [⋅][+]-distributivityᵣ-raw {x}{y}{z})

instance
  [⋅][+]-distributivityₗ : Distributivityₗ(_⋅_)(_+_)
  [⋅][+]-distributivityₗ = [↔]-to-[←] OneTypeTwoOp.distributivity-equivalence-by-commutativity [⋅][+]-distributivityᵣ

[⋅]-associativity-raw : Names.Associativity(_⋅_)
[⋅]-associativity-raw {x} {y} {𝟏} = [≡]-intro
[⋅]-associativity-raw {x} {y} {𝐒 z} =
  (x ⋅ y) + (x ⋅ y ⋅ z)   🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(x ⋅ y) ([⋅]-associativity-raw {x}{y}{z}) ]
  (x ⋅ y) + (x ⋅ (y ⋅ z)) 🝖[ _≡_ ]-[ distributivityₗ(_⋅_)(_+_) {x = x}{y = y}{z = y ⋅ z} ]-sym
  x ⋅ (y + (y ⋅ z))       🝖-end

instance
  [⋅]-associativity : Associativity(_⋅_)
  [⋅]-associativity = intro(\{x}{y}{z} → [⋅]-associativity-raw {x}{y}{z})

instance
  ℕ₊-multiplicative-monoid : Monoid(_⋅_)
  Monoid.binary-operator    ℕ₊-multiplicative-monoid = [≡]-binary-operator
  Monoid.identity-existence ℕ₊-multiplicative-monoid = [∃]-intro(𝟏)

[⋅]-with-[𝐒]ₗ : ∀{x y} → (𝐒(x) ⋅ y ≡ (x ⋅ y) + y)
[⋅]-with-[𝐒]ₗ {x}{y} =
  𝐒(x) ⋅ y          🝖[ _≡_ ]-[ congruence₁(_⋅ y) [1+]-𝐒 ]-sym
  (x + 𝟏) ⋅ y       🝖[ _≡_ ]-[ [⋅][+]-distributivityᵣ-raw{x}{𝟏}{y} ]
  (x ⋅ y) + (𝟏 ⋅ y) 🝖[ _≡_ ]-[ congruence₁((x ⋅ y) +_) ([⋅]-identityₗ-raw {y}) ]
  (x ⋅ y) + y       🝖[ _≡_ ]-end

[⋅]-with-[𝐒]ᵣ : ∀{x y} → (x ⋅ 𝐒(y) ≡ x + (x ⋅ y))
[⋅]-with-[𝐒]ᵣ = [≡]-intro


------------------------------------------------------------------------
-- Helpers intended to ease the development of "tactics" which use
-- proof by reflection
------------------------------------------------------------------------

open import Relation.Binary
open import Data.Nat
open import Data.Fin
open import Data.Vec as Vec
open import Data.Function

-- Think of the parameters as follows:
--
-- * Expr:    A representation of code.
-- * var:     The Expr type should support a notion of variables.
-- * ⟦_⟧:     Computes the semantics of an expression. Takes an
--            environment mapping variables to something.
-- * ⟦_⇓⟧:    Computes the semantics of the normal form of the
--            expression.
-- * correct: Normalisation preserves the semantics.
--
-- Given these parameters two "tactics" are returned, prove and solve.
--
-- For an example of the use of this module, see Algebra.RingSolver.

module Relation.Binary.Reflection
         {Expr : ℕ → Set} {A}
         Sem
         (var : ∀ {n} → Fin n → Expr n)
         (⟦_⟧ ⟦_⇓⟧ : ∀ {n} → Expr n → Vec A n → Setoid.carrier Sem)
         (correct : ∀ {n} (e : Expr n) ρ →
                    ⟦ e ⇓⟧ ρ ⟨ Setoid._≈_ Sem ⟩₁ ⟦ e ⟧ ρ)
         where

open import Data.Vec.N-ary
open import Data.Product
import Relation.Binary.EqReasoning as Eq

open Setoid Sem
open Eq Sem

-- If two normalised expressions are semantically equal, then their
-- non-normalised forms are also equal.

prove : ∀ {n} (ρ : Vec A n) e₁ e₂ →
        ⟦ e₁ ⇓⟧ ρ ≈ ⟦ e₂ ⇓⟧ ρ →
        ⟦ e₁  ⟧ ρ ≈ ⟦ e₂  ⟧ ρ
prove ρ e₁ e₂ hyp = begin
  ⟦ e₁  ⟧ ρ ≈⟨ sym (correct e₁ ρ) ⟩
  ⟦ e₁ ⇓⟧ ρ ≈⟨ hyp ⟩
  ⟦ e₂ ⇓⟧ ρ ≈⟨ correct e₂ ρ ⟩
  ⟦ e₂  ⟧ ρ ∎

-- Applies the function to all possible "variables".

close : ∀ {A} n → N-ary n (Expr n) A → A
close n f = f $ⁿ Vec.map var (allFin n)

-- A variant of prove which should in many cases be easier to use,
-- because variables and environments are handled in a less explicit
-- way.
--
-- If the type signature of solve is a bit daunting, then it may be
-- helpful to instantiate n with a small natural number and normalise
-- the remainder of the type.

solve : ∀ n (f : N-ary n (Expr n) (Expr n × Expr n)) →
  Eqʰ n _≈_ (curryⁿ ⟦ proj₁ (close n f) ⇓⟧) (curryⁿ ⟦ proj₂ (close n f) ⇓⟧) →
  Eq  n _≈_ (curryⁿ ⟦ proj₁ (close n f)  ⟧) (curryⁿ ⟦ proj₂ (close n f)  ⟧)
solve n f hyp =
  curryⁿ-pres ⟦ proj₁ (close n f) ⟧ ⟦ proj₂ (close n f) ⟧
    (λ ρ → prove ρ (proj₁ (close n f)) (proj₂ (close n f))
             (curryⁿ-pres⁻¹ ⟦ proj₁ (close n f) ⇓⟧ ⟦ proj₂ (close n f) ⇓⟧
                            (Eqʰ-to-Eq n hyp) ρ))

-- A variant of _,_ which is intended to make uses of solve look a
-- bit nicer.

infix 4 _⊜_

_⊜_ : ∀ {A} → A → A → A × A
_⊜_ = _,_


{-# OPTIONS --exact-split #-}
-- {-# OPTIONS -v tc.cover.splittree:10 #-}

open import Common.Prelude
open import Common.Equality

test : {m n : Nat} → m ≡ n → Nat
test {zero}  refl = zero
test {suc m} refl = suc m


------------------------------------------------------------------------
-- The Agda standard library
--
-- Indexed applicative functors
------------------------------------------------------------------------

-- Note that currently the applicative functor laws are not included
-- here.

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

module Category.Applicative.Indexed where

open import Category.Functor using (RawFunctor)
open import Data.Product using (_×_; _,_)
open import Function
open import Level
open import Relation.Binary.PropositionalEquality as P using (_≡_)

private
  variable
    a b c i f : Level
    A : Set a
    B : Set b
    C : Set c

IFun : Set i → (ℓ : Level) → Set (i ⊔ suc ℓ)
IFun I ℓ = I → I → Set ℓ → Set ℓ

------------------------------------------------------------------------
-- Type, and usual combinators

record RawIApplicative {I : Set i} (F : IFun I f) :
                       Set (i ⊔ suc f) where
  infixl 4 _⊛_ _<⊛_ _⊛>_
  infix  4 _⊗_

  field
    pure : ∀ {i} → A → F i i A
    _⊛_  : ∀ {i j k} → F i j (A → B) → F j k A → F i k B

  rawFunctor : ∀ {i j} → RawFunctor (F i j)
  rawFunctor = record
    { _<$>_ = λ g x → pure g ⊛ x
    }

  private
    open module RF {i j : I} =
           RawFunctor (rawFunctor {i = i} {j = j})
           public

  _<⊛_ : ∀ {i j k} → F i j A → F j k B → F i k A
  x <⊛ y = const <$> x ⊛ y

  _⊛>_ : ∀ {i j k} → F i j A → F j k B → F i k B
  x ⊛> y = flip const <$> x ⊛ y

  _⊗_ : ∀ {i j k} → F i j A → F j k B → F i k (A × B)
  x ⊗ y = (_,_) <$> x ⊛ y

  zipWith : ∀ {i j k} → (A → B → C) → F i j A → F j k B → F i k C
  zipWith f x y = f <$> x ⊛ y

  zip : ∀ {i j k} → F i j A → F j k B → F i k (A × B)
  zip = zipWith _,_

------------------------------------------------------------------------
-- Applicative with a zero

record RawIApplicativeZero
       {I : Set i} (F : IFun I f) :
       Set (i ⊔ suc f) where
  field
    applicative : RawIApplicative F
    ∅           : ∀ {i j} → F i j A

  open RawIApplicative applicative public

------------------------------------------------------------------------
-- Alternative functors: `F i j A` is a monoid

record RawIAlternative
       {I : Set i} (F : IFun I f) :
       Set (i ⊔ suc f) where
  infixr 3 _∣_
  field
    applicativeZero : RawIApplicativeZero F
    _∣_             : ∀ {i j} → F i j A → F i j A → F i j A

  open RawIApplicativeZero applicativeZero public

------------------------------------------------------------------------
-- Applicative functor morphisms, specialised to propositional
-- equality.

record Morphism {I : Set i} {F₁ F₂ : IFun I f}
                (A₁ : RawIApplicative F₁)
                (A₂ : RawIApplicative F₂) : Set (i ⊔ suc f) where
  module A₁ = RawIApplicative A₁
  module A₂ = RawIApplicative A₂
  field
    op      : ∀ {i j} → F₁ i j A → F₂ i j A
    op-pure : ∀ {i} (x : A) → op (A₁.pure {i = i} x) ≡ A₂.pure x
    op-⊛    : ∀ {i j k} (f : F₁ i j (A → B)) (x : F₁ j k A) →
              op (f A₁.⊛ x) ≡ (op f A₂.⊛ op x)

  op-<$> : ∀ {i j} (f : A → B) (x : F₁ i j A) →
           op (f A₁.<$> x) ≡ (f A₂.<$> op x)
  op-<$> f x = begin
    op (A₁._⊛_ (A₁.pure f) x)       ≡⟨ op-⊛ _ _ ⟩
    A₂._⊛_ (op (A₁.pure f)) (op x)  ≡⟨ P.cong₂ A₂._⊛_ (op-pure _) P.refl ⟩
    A₂._⊛_ (A₂.pure f) (op x)       ∎
    where open P.≡-Reasoning


module Issue27 where

infix  4 _≡_
infixl 4 _>_ _<_
infixr 1 _∨_

postulate ℝ : Set

------------------------------------------------------------------------------
-- Logic stuff

-- The identity type on the universe of discourse.
data _≡_ (x : ℝ) : ℝ → Set where
  refl : x ≡ x

data _∨_ (A B : Set) : Set where
  inj₁ : A → A ∨ B
  inj₂ : B → A ∨ B

case : ∀ {A B} → {C : Set} → (A → C) → (B → C) → A ∨ B → C
case f g (inj₁ a) = f a
case f g (inj₂ b) = g b

------------------------------------------------------------------------------
-- Real numbers stuff

postulate _>_ : ℝ → ℝ → Set

_<_ : ℝ → ℝ → Set
y < x = x > y
{-# ATP definition _<_ #-}

postulate
  trichotomy : (x y : ℝ) → (x > y) ∨ (x ≡ y) ∨ (x < y)
{-# ATP axiom trichotomy #-}

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

rmin : ℝ → ℝ → ℝ
rmin x y = case (λ _ → y) (λ h → case (λ _ → x) (λ _ → x) h) (trichotomy x y)
{-# ATP definition rmin #-}

postulate foo : ∀ x y → rmin x y ≡ rmin x y
{-# ATP prove foo #-}

{-
Error:
$ apia --check Issue27.agda
apia: tptp4X found an error/warning in the file /tmp/Issue27/44-foo.fof
Please report this as a bug

WARNING: Line 34 Char 159 Token "," : Multiple arity symbol n_62__46_8405600604384089447, arity 0 and now 2
WARNING: Line 34 Char 259 Token ")" : Multiple arity symbol n_60__48_8405600604384089447, arity 0 and now 2
WARNING: Line 34 Char 387 Token "," : Multiple arity symbol n_60__48_8405600604384089447, arity 0 and now 2
WARNING: Line 34 Char 460 Token ")" : Multiple arity symbol case_32_8405600604384089447, arity 5 and now 6
-}


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

open import Categories.Category

module Categories.Yoneda.Continuous {o ℓ e} (C : Category o ℓ e) where

open import Function.Equality using (Π)
open import Relation.Binary using (Setoid)

open import Categories.Category.Construction.Cones
open import Categories.Category.Construction.Presheaves
open import Categories.Diagram.Cone.Properties
open import Categories.Diagram.Limit
open import Categories.Functor
open import Categories.Functor.Limits
open import Categories.Functor.Hom
open import Categories.Functor.Hom.Properties C
open import Categories.NaturalTransformation
open import Categories.Yoneda

import Categories.Morphism.Reasoning as MR

open Hom C
open Yoneda C
open Π using (_⟨$⟩_)

private
  module C = Category C

module _ {o′ ℓ′ e′} {J : Category o′ ℓ′ e′} {F : Functor J C} (L : Limit F) where
  private
    module J = Category J
    module F = Functor F
    module L = Limit L
    open C.HomReasoning
    open MR C

    yF = embed ∘F F

    ⊤ : Cone yF
    ⊤ = F-map-Coneˡ embed L.limit

    HomL : ∀ X → Limit (Hom[ X ,-] ∘F F)
    HomL X = hom-resp-limit X L
    module HomL X = Limit (HomL X)

    module _ {K : Cone yF} where
      private
        module K where
          open Cone _ K public
          module N   = Functor N
          module ψ j = NaturalTransformation (ψ j)

      KHF : ∀ X → Cone (Hom[ X ,-] ∘F F)
      KHF X = record
        { N    = K.N.₀ X
        ; apex = record
          { ψ       = λ j → K.ψ.η j X
          ; commute = λ f eq → C.∘-resp-≈ʳ C.identityʳ ○ K.commute f eq
          }
        }

      ! : Cones yF [ K , ⊤ ]
      ! = record
        { arr     = ntHelper record
          { η       = λ X → Cone⇒.arr (HomL.terminal.! X {KHF X})
          ; commute = λ {X Y} f {x y} eq → L.terminal.!-unique record
            { arr     = C.id C.∘ L.rep _ C.∘ f
            ; commute = λ {j} → begin
              L.proj j C.∘ C.id C.∘ L.rep _ C.∘ f ≈⟨ refl⟩∘⟨ C.identityˡ ⟩
              L.proj j C.∘ L.rep _ C.∘ f          ≈⟨ pullˡ L.commute ⟩
              (K.ψ.η j X ⟨$⟩ y) C.∘ f             ≈˘⟨ C.identityˡ ⟩
              C.id C.∘ (K.ψ.η j X ⟨$⟩ y) C.∘ f    ≈˘⟨ K.ψ.commute j f eq ⟩
              K.ψ.η j Y ⟨$⟩ (K.N.₁ f ⟨$⟩ x)       ∎
            }
          }
        ; commute = λ eq → L.commute ○ Π.cong (K.ψ.η _ _) eq
        }

      module _ (f : Cones yF [ K , ⊤ ]) where
        private
          module f where
            open Cone⇒ _ f public
            module arr = NaturalTransformation arr

        !-unique : Cones yF [ ! ≈ f ]
        !-unique {X} {x} {y} eq = L.terminal.!-unique record
          { arr     = f.arr.η X ⟨$⟩ y
          ; commute = f.commute (Setoid.sym (K.N.₀ X) eq)
          }

  embed-resp-limit : Limit yF
  embed-resp-limit = record
    { terminal = record
      { ⊤             = ⊤
      ; ⊤-is-terminal = record
        { !        = !
        ; !-unique = !-unique
        }
      }
    }

embed-Continous : ∀ o′ ℓ′ e′ → Continuous o′ ℓ′ e′ embed
embed-Continous _ _ _ L = terminal.⊤-is-terminal
  where open Limit (embed-resp-limit L)


{-# OPTIONS --no-positivity-check #-}
module IIRDr where

import LF
import IIRD

open LF
open IIRD

-- Agda2 has restricted IIRDs so we can define Ur/Tr directly

mutual
  data Ur {I : Set}{D : I -> Set1}(γ : OPr I D)(i : I) : Set where
    intror : Hu γ (Ur γ) (Tr γ) i -> Ur {I}{D} γ i

  Tr : {I : Set}{D : I -> Set1}(γ : OPr I D)(i : I) -> Ur γ i -> D i
  Tr γ i (intror a) = Ht γ (Ur γ) (Tr γ) i a

-- Elimination rule
Rr : {I : Set}{D : I -> Set1}(γ : OPr I D)(F : (i : I) -> Ur γ i -> Set1)
     (h : (i : I)(a : Hu γ (Ur γ) (Tr γ) i) -> KIH (γ i) (Ur γ) (Tr γ) F a -> F i (intror a))
     (i : I)(u : Ur γ i) -> F i u
Rr γ F h i (intror a) = h i a (Kmap (γ i) (Ur γ) (Tr γ) F (Rr γ F h) a)

-- Helpers

ι★r : {I : Set}{D : I -> Set1} -> OP I D One'
ι★r = ι ★'


------------------------------------------------------------------------
-- The Agda standard library
--
-- Automatic solvers for equations over lists
------------------------------------------------------------------------

-- See README.Nat for examples of how to use similar solvers

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

module Data.List.Solver where

import Algebra.Solver.Monoid as Solver
open import Data.List.Properties using (++-monoid)

------------------------------------------------------------------------
-- A module for automatically solving propositional equivalences
-- containing _++_

module ++-Solver {a} {A : Set a} =
  Solver (++-monoid A) renaming (id to nil)


open import Data.Empty
open import Data.Maybe
open import Data.Product
open import Data.Sum

open import AEff
open import EffectAnnotations
open import Types

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

module AwaitingComputations where

-- COMPUTATIONS THAT ARE TEMPORARILY STUCK DUE TO AWAITING FOR A PARTICULAR PROMISE

data _⧗_ {Γ : Ctx} {X : VType} (x : ⟨ X ⟩ ∈ Γ) : {C : CType} → Γ ⊢M⦂ C → Set where

  await     : {C : CType}
              {M : Γ ∷ X ⊢M⦂ C} →
              -------------------------
              x ⧗ (await (` x) until M)

  let-in    : {X Y : VType}
              {o : O}
              {i : I}
              {M : Γ ⊢M⦂ X ! (o , i)}
              {N : Γ ∷ X ⊢M⦂ Y ! (o , i)} →
              x ⧗ M →
              -----------------------------
              x ⧗ (let= M `in N)

  interrupt : {X : VType}
              {o : O}
              {i : I}
              {op : Σₛ}
              {V : Γ ⊢V⦂ ``(payload op)}
              {M : Γ ⊢M⦂ X ! (o , i)} →
              x ⧗ M →
              -------------------------
              x ⧗ (↓ op V M)

  coerce    : {X : VType}
              {o o' : O}
              {i i' : I}
              {p : o ⊑ₒ o'}
              {q : i ⊑ᵢ i'}
              {M : Γ ⊢M⦂ X ! (o , i)} →
              x ⧗ M →
              -------------------------
              x ⧗ (coerce p q M)


open import Level hiding ( suc ; zero )
open import Algebra
module sym5a where

open import Symmetric
open import Data.Unit using (⊤ ; tt )
open import Function.Inverse as Inverse using (_↔_; Inverse; _InverseOf_)
open import Function hiding (flip)
open import Data.Nat hiding (_⊔_) -- using (ℕ; suc; zero)
open import Data.Nat.Properties
open import Relation.Nullary
open import Data.Empty
open import Data.Product

open import Gutil
open import Putil
open import Solvable using (solvable)
open import  Relation.Binary.PropositionalEquality hiding ( [_] )

open import Data.Fin hiding (_<_ ; _≤_  ; lift )
open import Data.Fin.Permutation  hiding (_∘ₚ_)

infixr  200 _∘ₚ_
_∘ₚ_ = Data.Fin.Permutation._∘ₚ_

open import Data.List  hiding ( [_] )
open import nat
open import fin
open import logic

open _∧_

¬sym5solvable : ¬ ( solvable (Symmetric 5) )
¬sym5solvable sol = counter-example (end5 (abc 0<3 0<4 ) (any3de (dervied-length sol) 3rot 0<3 0<4 ) ) where
--
--    dba       1320      d → b → a → d
--    (dba)⁻¹   3021      a → b → d → a
--    aec       21430
--    (aec)⁻¹   41032
--    [ dba , aec ] = (abd)(cea)(dba)(aec) = abc
--      so commutator always contains abc, dba and aec

     open ≡-Reasoning

     open solvable
     open Solvable ( Symmetric 5)
     end5 : (x : Permutation 5 5) → deriving (dervied-length sol) x →  x =p= pid
     end5 x der = end sol x der

     0<4 : 0 < 4
     0<4 = s≤s z≤n

     0<3 : 0 < 3
     0<3 = s≤s z≤n

     --- 1 ∷ 2 ∷ 0 ∷ []      abc
     3rot : Permutation 3 3
     3rot = pid {3} ∘ₚ pins (n≤ 2)

     save2 : {i j : ℕ }  → (i ≤ 3 ) → ( j ≤ 4 ) →  Permutation  5 5
     save2 i<3 j<4 = flip (pins (s≤s i<3)) ∘ₚ flip (pins j<4)

     -- Permutation 5 5 include any Permutation 3 3
     any3 : {i j : ℕ }  → Permutation 3 3  → (i ≤ 3 ) → ( j ≤ 4 ) → Permutation  5 5
     any3 abc i<3 j<4 = (save2 i<3 j<4 ∘ₚ (pprep (pprep abc))) ∘ₚ flip (save2 i<3 j<4 )

     any3cong : {i j : ℕ }  → {x y : Permutation 3 3 } → {i<3 : i ≤ 3 } → {j<4 : j ≤ 4 } → x =p= y → any3 x i<3 j<4  =p= any3 y i<3 j<4
     any3cong {i} {j} {x} {y} {i<3} {j<4} x=y = presp {5} {save2 i<3 j<4 ∘ₚ (pprep (pprep x))} {_} {flip (save2 i<3 j<4 )}
         (presp {5} {save2 i<3 j<4} prefl (pprep-cong (pprep-cong x=y)) ) prefl

     open _=p=_

     -- derving n includes any Permutation 3 3,
     any3de : {i j : ℕ } → (n : ℕ) → (abc : Permutation 3 3) →  (i<3 : i ≤ 3 ) → (j<4 :  j ≤ 4 ) → deriving n (any3 abc i<3 j<4)
     any3de {i} {j} zero abc i<3 j<4 = Level.lift tt
     any3de {i} {j} (suc n) abc i<3 j<4 = ccong abc-from-comm (comm (any3de n (abc  ∘ₚ abc) i<3 j0<4 ) (any3de n (abc  ∘ₚ abc) i0<3 j<4 ))  where
         i0 : ℕ
         i0 = ?
         j0 : ℕ
         j0 = ?
         i0<3 : i0 ≤ 3
         i0<3 = {!!}
         j0<4 : j0 ≤ 4
         j0<4 = {!!}
         abc-from-comm : [ any3 (abc  ∘ₚ abc) i<3 j0<4  , any3 (abc  ∘ₚ abc) i0<3 j<4 ] =p= any3 abc i<3 j<4
         abc-from-comm = {!!}

     abc : {i j : ℕ }  → (i ≤ 3 ) → ( j ≤ 4 ) → Permutation  5 5
     abc i<3 j<4 = any3 3rot i<3 j<4

     counter-example :  ¬ (abc 0<3 0<4  =p= pid )
     counter-example eq with ←pleq _ _ eq
     ...  | ()


------------------------------------------------------------------------
-- Another definition of indexed containers
------------------------------------------------------------------------

-- Partly based on "Indexed containers" by Altenkirch, Ghani, Hancock,
-- McBride and Morris, and partly based on "Non-wellfounded trees in
-- Homotopy Type Theory" by Ahrens, Capriotti and Spadotti.

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

open import Equality

module Container.Indexed.Variant
  {e⁺} (eq : ∀ {a p} → Equality-with-J a p e⁺) where

open Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

import Bijection eq as B
open import Container.Indexed eq as C
  using (_⇾_; id⇾; _∘⇾_; Shape; Position; index)
open import Equivalence eq as Eq using (_≃_)
open import Function-universe eq as F hiding (id; _∘_)
open import H-level.Closure eq
open import Tactic.Sigma-cong eq
open import Univalence-axiom eq

private
  variable
    a ℓ p p₁ p₂ p′ q : Level
    A I O            : Type a
    P Q R            : A → Type p
    ext f i k o s    : A

------------------------------------------------------------------------
-- Containers

-- Doubly indexed containers.

record Container₂
         (I : Type i) (O : Type o) s p :
         Type (i ⊔ o ⊔ lsuc (s ⊔ p)) where
  constructor _◁_
  field
    Shape    : O → Type s
    Position : ∀ {o} → Shape o → I → Type p

open Container₂ public

-- Singly indexed containers.

Container : Type i → ∀ s p → Type (i ⊔ lsuc (s ⊔ p))
Container I = Container₂ I I

private
  variable
    C : Container₂ I O s p

-- Container₂ can be expressed as a Σ-type.

Container≃Σ :
  Container₂ I O s p ≃
  (∃ λ (S : O → Type s) → ∀ {o} → S o → I → Type p)
Container≃Σ = Eq.↔→≃ (λ (S ◁ P) → S , P) (uncurry _◁_) refl refl

------------------------------------------------------------------------
-- Polynomial functors

-- The polynomial functor associated to a container.

⟦_⟧ :
  {I : Type i} {O : Type o} →
  Container₂ I O s p → (I → Type ℓ) → O → Type (ℓ ⊔ i ⊔ s ⊔ p)
⟦ S ◁ P ⟧ Q o = ∃ λ (s : S o) → P s ⇾ Q

-- A map function.

map : (C : Container₂ I O s p) → P ⇾ Q → ⟦ C ⟧ P ⇾ ⟦ C ⟧ Q
map C f _ (s , g) = s , f ∘⇾ g

-- Functor laws.

map-id : map C (id⇾ {P = P}) ≡ id⇾
map-id = refl _

map-∘ :
  (f : Q ⇾ R) (g : P ⇾ Q) →
  map C (f ∘⇾ g) ≡ map C f ∘⇾ map C g
map-∘ _ _ = refl _

-- A preservation lemma.

⟦⟧-cong :
  {I : Type i} {P₁ : I → Type p₁} {P₂ : I → Type p₂} →
  Extensionality? k (i ⊔ p) (p ⊔ p₁ ⊔ p₂) →
  (C : Container₂ I O s p) →
  (∀ i → P₁ i ↝[ k ] P₂ i) →
  (∀ o → ⟦ C ⟧ P₁ o ↝[ k ] ⟦ C ⟧ P₂ o)
⟦⟧-cong {i = i} {k = k} {p = p} {P₁ = Q₁} {P₂ = Q₂}
        ext (S ◁ P) Q₁↝Q₂ o =
  (∃ λ (s : S o) → P s ⇾ Q₁)  ↝⟨ (∃-cong λ _ →
                                  ∀-cong (lower-extensionality? k p lzero ext) λ _ →
                                  ∀-cong (lower-extensionality? k i p ext) λ _ →
                                  Q₁↝Q₂ _) ⟩□
  (∃ λ (s : S o) → P s ⇾ Q₂)  □

-- The forward direction of ⟦⟧-cong is an instance of map (at least
-- when k is equivalence).

_ : _≃_.to (⟦⟧-cong ext C f o) ≡ map C (_≃_.to ∘ f) o
_ = refl _

-- The shapes of a container are pointwise equivalent to the
-- polynomial functor of the container applied to the constant
-- function yielding the unit type.
--
-- (This lemma was suggested to me by an anonymous reviewer of a
-- paper.)

Shape≃⟦⟧⊤ :
  (C : Container₂ I O s p) →
  Shape C o ≃ ⟦ C ⟧ (λ _ → ⊤) o
Shape≃⟦⟧⊤ {o = o} (S ◁ P) =
  S o                                ↔⟨ inverse $ drop-⊤-right (λ _ → →-right-zero F.∘ inverse currying) ⟩□
  (∃ λ (s : S o) → ∀ i → P s i → ⊤)  □

------------------------------------------------------------------------
-- Coalgebras

-- The type of coalgebras for a (singly indexed) container.

Coalgebra : {I : Type i} → Container I s p → Type (lsuc (i ⊔ s ⊔ p))
Coalgebra {i = i} {s = s} {p = p} {I = I} C =
  ∃ λ (P : I → Type (i ⊔ s ⊔ p)) → P ⇾ ⟦ C ⟧ P

-- Coalgebra morphisms.

infix 4 _⇨_

_⇨_ :
  {I : Type i} {C : Container I s p} →
  Coalgebra C → Coalgebra C → Type (i ⊔ s ⊔ p)
(P , f) ⇨ (Q , g) = ∃ λ (h : P ⇾ Q) → g ∘⇾ h ≡ map _ h ∘⇾ f

private
  variable
    X Y Z : Coalgebra C

-- An identity morphism.

id⇨ : X ⇨ X
id⇨ = id⇾ , refl _

-- Composition for _⇨_.

infix 9 [_]_∘⇨_

[_]_∘⇨_ : ∀ Z → Y ⇨ Z → X ⇨ Y → X ⇨ Z
[_]_∘⇨_ {Y = _ , g} {X = _ , f} (_ , h) (f₁ , eq₁) (f₂ , eq₂) =
    f₁ ∘⇾ f₂
  , (h ∘⇾ (f₁ ∘⇾ f₂)              ≡⟨⟩
     (h ∘⇾ f₁) ∘⇾ f₂              ≡⟨ cong (_∘⇾ f₂) eq₁ ⟩
     (map _ f₁ ∘⇾ g) ∘⇾ f₂        ≡⟨⟩
     map _ f₁ ∘⇾ (g ∘⇾ f₂)        ≡⟨ cong (map _ f₁ ∘⇾_) eq₂ ⟩
     map _ f₁ ∘⇾ (map _ f₂ ∘⇾ f)  ≡⟨⟩
     map _ (f₁ ∘⇾ f₂) ∘⇾ f        ∎)

-- The property of being a final coalgebra.

Final :
  {I : Type i} {C : Container I s p} →
  Coalgebra C → Type (lsuc (i ⊔ s ⊔ p))
Final X = ∀ Y → Contractible (Y ⇨ X)

-- A perhaps more traditional definition of what it means to be final.

Final′ :
  {I : Type i} {C : Container I s p} →
  Coalgebra C → Type (lsuc (i ⊔ s ⊔ p))
Final′ X =
  ∀ Y → ∃ λ (m : Y ⇨ X) → (m′ : Y ⇨ X) → proj₁ m ≡ proj₁ m′

-- Final X implies Final′ X.

Final→Final′ : (X : Coalgebra C) → Final X → Final′ X
Final→Final′ _ =
  ∀-cong _ λ _ → ∃-cong λ _ → ∀-cong _ λ _ → cong proj₁

-- Final is pointwise propositional (assumption extensionality).

Final-propositional :
  {I : Type i} {C : Container I s p} →
  Extensionality (lsuc (i ⊔ s ⊔ p)) (i ⊔ s ⊔ p) →
  (X : Coalgebra C) →
  Is-proposition (Final X)
Final-propositional ext _ =
  Π-closure ext 1 λ _ →
  Contractible-propositional (lower-extensionality _ lzero ext)

-- Final coalgebras.

Final-coalgebra :
  {I : Type i} →
  Container I s p → Type (lsuc (i ⊔ s ⊔ p))
Final-coalgebra C = ∃ λ (X : Coalgebra C) → Final X

-- Final coalgebras, defined using Final′.

Final-coalgebra′ :
  {I : Type i} →
  Container I s p → Type (lsuc (i ⊔ s ⊔ p))
Final-coalgebra′ C = ∃ λ (X : Coalgebra C) → Final′ X

-- Final-coalgebra C implies Final-coalgebra′ C.

Final-coalgebra→Final-coalgebra′ :
  Final-coalgebra C → Final-coalgebra′ C
Final-coalgebra→Final-coalgebra′ =
  ∃-cong Final→Final′

-- Carriers of final coalgebras (defined using Final′) for a given
-- container are pointwise equivalent.

carriers-of-final-coalgebras-equivalent′ :
  (((P₁ , _) , _) ((P₂ , _) , _) : Final-coalgebra′ C) →
  ∀ i → P₁ i ≃ P₂ i
carriers-of-final-coalgebras-equivalent′ (X₁ , final₁) (X₂ , final₂) i =
  Eq.↔→≃ (proj₁ to i) (proj₁ from i) to∘from from∘to
  where
  to : X₁ ⇨ X₂
  to = proj₁ (final₂ X₁)

  from : X₂ ⇨ X₁
  from = proj₁ (final₁ X₂)

  to∘from : ∀ x → proj₁ ([ X₂ ] to ∘⇨ from) i x ≡ x
  to∘from x =
    proj₁ ([ X₂ ] to ∘⇨ from) i x  ≡⟨ cong (λ f → f i x) $ sym $ proj₂ (final₂ X₂) $ [ X₂ ] to ∘⇨ from ⟩
    proj₁ (proj₁ (final₂ X₂)) i x  ≡⟨ cong (λ f → f i x) $ proj₂ (final₂ X₂) id⇨ ⟩
    proj₁ (id⇨ {X = X₂}) i x       ≡⟨⟩
    x                              ∎

  from∘to : ∀ x → proj₁ ([ X₁ ] from ∘⇨ to) i x ≡ x
  from∘to x =
    proj₁ ([ X₁ ] from ∘⇨ to) i x  ≡⟨ cong (λ f → f i x) $ sym $ proj₂ (final₁ X₁) $ [ X₁ ] from ∘⇨ to ⟩
    proj₁ (proj₁ (final₁ X₁)) i x  ≡⟨ cong (λ f → f i x) $ proj₂ (final₁ X₁) id⇨ ⟩
    proj₁ (id⇨ {X = X₁}) i x       ≡⟨⟩
    x                              ∎

-- The previous lemma relates the "out" functions of the two final
-- coalgebras in a certain way.

out-related′ :
  {C : Container I s p}
  (F₁@((_ , out₁) , _) F₂@((_ , out₂) , _) : Final-coalgebra′ C) →
  map C (_≃_.to ∘ carriers-of-final-coalgebras-equivalent′ F₁ F₂) ∘⇾
    out₁
    ≡
  out₂ ∘⇾ (_≃_.to ∘ carriers-of-final-coalgebras-equivalent′ F₁ F₂)
out-related′ (X₁ , _) (_ , final₂) =
  sym $ proj₂ (proj₁ (final₂ X₁))

-- Carriers of final coalgebras for a given container are pointwise
-- equivalent.

carriers-of-final-coalgebras-equivalent :
  (((P₁ , _) , _) ((P₂ , _) , _) : Final-coalgebra C) →
  ∀ i → P₁ i ≃ P₂ i
carriers-of-final-coalgebras-equivalent =
  carriers-of-final-coalgebras-equivalent′ on
    Final-coalgebra→Final-coalgebra′

-- The previous lemma relates the "out" functions of the two final
-- coalgebras in a certain way.

out-related :
  {C : Container I s p}
  (F₁@((_ , out₁) , _) F₂@((_ , out₂) , _) : Final-coalgebra C) →
  map C (_≃_.to ∘ carriers-of-final-coalgebras-equivalent F₁ F₂) ∘⇾ out₁
    ≡
  out₂ ∘⇾ (_≃_.to ∘ carriers-of-final-coalgebras-equivalent F₁ F₂)
out-related = out-related′ on Final-coalgebra→Final-coalgebra′

-- If X and Y are final coalgebras (with finality defined using
-- Final′), then—assuming extensionality—finality of X (defined using
-- Final) is equivalent to finality of Y.

Final′→Final≃Final :
  {I : Type i} {C : Container I s p}
  ((X , _) (Y , _) : Final-coalgebra′ C) →
  Extensionality (i ⊔ s ⊔ p) (i ⊔ s ⊔ p) →
  Final X ↝[ lsuc (i ⊔ s ⊔ p) ∣ i ⊔ s ⊔ p ] Final Y
Final′→Final≃Final {i = i} {s = s} {p = p} {C = C}
  ((X₁ , out₁) , final₁) ((X₂ , out₂) , final₂) ext {k = k} ext′ =
  ∀-cong ext′ λ Y@(_ , f) →
  H-level-cong
    (lower-extensionality? k _ lzero ext′)
    0
    (Σ-cong (lemma₂ Y) λ g →

       out₁ ∘⇾ g ≡ map C g ∘⇾ f                 ↝⟨ inverse $ Eq.≃-≡ (lemma₃ Y) ⟩

       _≃_.to (lemma₃ Y) (out₁ ∘⇾ g) ≡
       _≃_.to (lemma₃ Y) (map C g ∘⇾ f)         ↔⟨⟩

       map C (_≃_.to ∘ lemma₁) ∘⇾ out₁ ∘⇾ g ≡
       map C (_≃_.to ∘ lemma₁) ∘⇾ map C g ∘⇾ f  ↝⟨ ≡⇒↝ _ $ cong (λ h → h ∘⇾ g ≡ map C (_≃_.to ∘ lemma₁) ∘⇾ map C g ∘⇾ f) $
                                                   out-related′ ((X₁ , out₁) , final₁) ((X₂ , out₂) , final₂) ⟩
       out₂ ∘⇾ (_≃_.to ∘ lemma₁) ∘⇾ g ≡
       map C (_≃_.to ∘ lemma₁) ∘⇾ map C g ∘⇾ f  ↔⟨⟩

       out₂ ∘⇾ _≃_.to (lemma₂ Y) g ≡
       map C (_≃_.to (lemma₂ Y) g) ∘⇾ f         □)
  where
  ext₁ = lower-extensionality (s ⊔ p) lzero ext
  ext₂ = lower-extensionality (i ⊔ s) lzero ext

  lemma₁ : ∀ i → X₁ i ≃ X₂ i
  lemma₁ =
    carriers-of-final-coalgebras-equivalent′
      ((X₁ , out₁) , final₁)
      ((X₂ , out₂) , final₂)

  lemma₂ : ((Y , _) : Coalgebra C) → (Y ⇾ X₁) ≃ (Y ⇾ X₂)
  lemma₂ _ =
    ∀-cong ext₁ λ _ →
    ∀-cong ext  λ _ →
    lemma₁ _

  lemma₃ : ((Y , _) : Coalgebra C) → (Y ⇾ ⟦ C ⟧ X₁) ≃ (Y ⇾ ⟦ C ⟧ X₂)
  lemma₃ _ =
    ∀-cong ext₁ λ _ →
    ∀-cong ext  λ _ →
    ⟦⟧-cong ext₂ C lemma₁ _

-- If there is a final C-coalgebra, and we have Final′ X for some
-- C-coalgebra X, then we also have Final X (assuming extensionality).

Final′→Final :
  {I : Type i} {C : Container I s p} →
  Extensionality (i ⊔ s ⊔ p) (i ⊔ s ⊔ p) →
  Final-coalgebra C →
  ((X , _) : Final-coalgebra′ C) →
  Final X
Final′→Final ext F₁@(_ , final₁) F₂ =
  Final′→Final≃Final
    (Final-coalgebra→Final-coalgebra′ F₁) F₂
    ext _ final₁

-- Final-coalgebra is pointwise propositional, assuming extensionality
-- and univalence.
--
-- This is a variant of Lemma 5 from "Non-wellfounded trees in
-- Homotopy Type Theory".

Final-coalgebra-propositional :
  {I : Type i} {C : Container I s p} →
  Extensionality (lsuc (i ⊔ s ⊔ p)) (lsuc (i ⊔ s ⊔ p)) →
  Univalence (i ⊔ s ⊔ p) →
  Is-proposition (Final-coalgebra C)
Final-coalgebra-propositional {I = I} {C = C@(S ◁ P)}
  ext univ F₁@((P₁ , out₁) , _) F₂@(X₂@(P₂ , out₂) , _) =
  block λ b →
  Σ-≡,≡→≡ (Σ-≡,≡→≡ (lemma₁ b) (lemma₂ b))
    (Final-propositional (lower-extensionality lzero _ ext) X₂ _ _)
  where
  ext₁′ = lower-extensionality _ lzero ext
  ext₁  = Eq.good-ext ext₁′

  lemma₀ : Block "lemma₀" → ∀ i → P₁ i ≃ P₂ i
  lemma₀ ⊠ = carriers-of-final-coalgebras-equivalent F₁ F₂

  lemma₀-lemma :
    ∀ b x →
    map C (_≃_.to ∘ lemma₀ b) i (out₁ i (_≃_.from (lemma₀ b i) x)) ≡
    out₂ i x
  lemma₀-lemma {i = i} ⊠ x =
    map C (_≃_.to ∘ lemma₀ ⊠) i (out₁ i (_≃_.from (lemma₀ ⊠ i) x))  ≡⟨ cong (λ f → f _ (_≃_.from (lemma₀ ⊠ i) x)) $
                                                                       out-related F₁ F₂ ⟩
    out₂ i (_≃_.to (lemma₀ ⊠ i) (_≃_.from (lemma₀ ⊠ i) x))          ≡⟨ cong (out₂ _) $
                                                                       _≃_.right-inverse-of (lemma₀ ⊠ i) _ ⟩∎
    out₂ i x                                                        ∎

  lemma₁ : Block "lemma₀" → P₁ ≡ P₂
  lemma₁ b =
    apply-ext ext₁ λ i →
    ≃⇒≡ univ (lemma₀ b i)

  lemma₁-lemma₁ = λ b i →
    sym $ Σ-≡,≡→≡ (sym (lemma₁ b)) (subst-const _)   ≡⟨ cong sym Σ-≡,≡→≡-subst-const-refl ⟩
    sym $ cong₂ _,_ (sym (lemma₁ b)) (refl _)        ≡⟨ sym cong₂-sym ⟩
    cong₂ _,_ (sym (sym (lemma₁ b))) (sym (refl _))  ≡⟨ cong₂ (cong₂ _) (sym-sym _) sym-refl ⟩
    cong₂ _,_ (lemma₁ b) (refl i)                    ≡⟨ cong₂-reflʳ _ ⟩∎
    cong (_, i) (lemma₁ b)                           ∎

  lemma₁-lemma₂ = λ b i x →
    subst (_$ i) (sym (lemma₁ b)) x                                    ≡⟨⟩
    subst (_$ i) (sym (apply-ext ext₁ λ i → ≃⇒≡ univ (lemma₀ b i))) x  ≡⟨ cong (flip (subst (_$ i)) _) $ sym $
                                                                          Eq.good-ext-sym ext₁′ _ ⟩
    subst (_$ i) (apply-ext ext₁ λ i → sym (≃⇒≡ univ (lemma₀ b i))) x  ≡⟨ Eq.subst-good-ext ext₁′ _ _ ⟩
    subst id (sym (≃⇒≡ univ (lemma₀ b i))) x                           ≡⟨ subst-id-in-terms-of-inverse∘≡⇒↝ equivalence ⟩
    _≃_.from (≡⇒≃ (≃⇒≡ univ (lemma₀ b i))) x                           ≡⟨ cong (λ eq → _≃_.from eq _) $
                                                                          _≃_.right-inverse-of (≡≃≃ univ) _ ⟩∎
    _≃_.from (lemma₀ b i) x                                            ∎

  lemma₁-lemma₃ : ∀ b (f : P s ⇾ P₁) i p → _ ≡ _
  lemma₁-lemma₃ b f i p =
    subst (_$ i) (lemma₁ b) (f i p)                                    ≡⟨⟩
    subst (_$ i) (apply-ext ext₁ λ i → ≃⇒≡ univ (lemma₀ b i)) (f i p)  ≡⟨ Eq.subst-good-ext ext₁′ _ _ ⟩
    subst id (≃⇒≡ univ (lemma₀ b i)) (f i p)                           ≡⟨ subst-id-in-terms-of-≡⇒↝ equivalence ⟩
    ≡⇒→ (≃⇒≡ univ (lemma₀ b i)) (f i p)                                ≡⟨ cong (λ eq → _≃_.to eq _) $
                                                                          _≃_.right-inverse-of (≡≃≃ univ) _ ⟩∎
    _≃_.to (lemma₀ b i) (f i p)                                        ∎

  lemma₂ = λ b →
    apply-ext (lower-extensionality _ _ ext) λ i →
    apply-ext (lower-extensionality _ _ ext) λ x →

    subst (λ P → P ⇾ ⟦ C ⟧ P) (lemma₁ b) out₁ i x                   ≡⟨⟩

    subst (λ P → ∀ i → P i → ⟦ C ⟧ P i) (lemma₁ b) out₁ i x         ≡⟨ cong (_$ x) subst-∀ ⟩

    subst (uncurry λ P i → P i → ⟦ C ⟧ P i)
      (sym $ Σ-≡,≡→≡ (sym (lemma₁ b)) (refl _))
      (out₁ (subst (λ _ → I) (sym (lemma₁ b)) i)) x                 ≡⟨ elim¹
                                                                         (λ {i′} eq →
                                                                            subst (uncurry λ P i → P i → ⟦ C ⟧ P i)
                                                                              (sym $ Σ-≡,≡→≡ (sym (lemma₁ b)) (refl _))
                                                                              (out₁ (subst (λ _ → I) (sym (lemma₁ b)) i)) x ≡
                                                                            subst (uncurry λ P i → P i → ⟦ C ⟧ P i)
                                                                              (sym $ Σ-≡,≡→≡ (sym (lemma₁ b)) eq)
                                                                              (out₁ i′) x)
                                                                         (refl _)
                                                                         _ ⟩
    subst (uncurry λ P i → P i → ⟦ C ⟧ P i)
      (sym $ Σ-≡,≡→≡ (sym (lemma₁ b)) (subst-const _))
      (out₁ i) x                                                    ≡⟨ cong (λ eq → subst (uncurry λ P i → P i → ⟦ C ⟧ P i) eq _ _) $
                                                                       lemma₁-lemma₁ b i ⟩
    subst (uncurry λ P i → P i → ⟦ C ⟧ P i)
      (cong (_, _) (lemma₁ b))
      (out₁ i) x                                                    ≡⟨ cong (_$ x) $ sym $ subst-∘ _ _ _ ⟩

    subst (λ P → P i → ⟦ C ⟧ P i) (lemma₁ b) (out₁ i) x             ≡⟨ subst-→ ⟩

    subst (λ P → ⟦ C ⟧ P i) (lemma₁ b)
      (out₁ i (subst (_$ i) (sym (lemma₁ b)) x))                    ≡⟨ cong (subst (λ P → ⟦ C ⟧ P i) _) $ cong (out₁ _) $
                                                                       lemma₁-lemma₂ b i x ⟩
    subst (λ P → ⟦ C ⟧ P i) (lemma₁ b)
      (out₁ i (_≃_.from (lemma₀ b i) x))                            ≡⟨⟩

    subst (λ Q → ∃ λ (s : S i) → P s ⇾ Q) (lemma₁ b)
      (out₁ i (_≃_.from (lemma₀ b i) x))                            ≡⟨ push-subst-pair-× _ _ ⟩

    (let s , f = out₁ i (_≃_.from (lemma₀ b i) x) in
     s , subst (λ Q → P s ⇾ Q) (lemma₁ b) f)                        ≡⟨ (let s , _ = out₁ i (_≃_.from (lemma₀ b i) x) in
                                                                        cong (s ,_) $
                                                                        apply-ext (lower-extensionality _ _ ext) λ _ → sym $
                                                                        push-subst-application _ _) ⟩
    (let s , f = out₁ i (_≃_.from (lemma₀ b i) x) in
     s , λ i → subst (λ Q → P s i → Q i) (lemma₁ b) (f i))          ≡⟨ (let s , _ = out₁ i (_≃_.from (lemma₀ b i) x) in
                                                                        cong (s ,_) $
                                                                        apply-ext (lower-extensionality _ _ ext) λ _ →
                                                                        apply-ext (lower-extensionality _ _ ext) λ _ → sym $
                                                                        push-subst-application _ _) ⟩
    (let s , f = out₁ i (_≃_.from (lemma₀ b i) x) in
     s , λ i p → subst (_$ i) (lemma₁ b) (f i p))                   ≡⟨ (let _ , f = out₁ i (_≃_.from (lemma₀ b i) x) in
                                                                        cong (_ ,_) $
                                                                        apply-ext (lower-extensionality _ _ ext) λ i →
                                                                        apply-ext (lower-extensionality _ _ ext) $
                                                                        lemma₁-lemma₃ b f i) ⟩
    (let s , f = out₁ i (_≃_.from (lemma₀ b i) x) in
     s , λ i p → _≃_.to (lemma₀ b i) (f i p))                       ≡⟨⟩

    map C (_≃_.to ∘ lemma₀ b) i (out₁ i (_≃_.from (lemma₀ b i) x))  ≡⟨ lemma₀-lemma b x ⟩∎

    out₂ i x                                                        ∎

------------------------------------------------------------------------
-- Conversion lemmas

-- A conversion lemma for Container. Note that the last index is not
-- unrestricted.

Container⇔Container :
  ∀ {I : Type i} {O : Type o} p →
  Container₂ I O s (i ⊔ p) ⇔ C.Container₂ I O s (i ⊔ p)
Container⇔Container {i = iℓ} {s = s} {I = I} {O = O} p =
  Container₂ I O s (iℓ ⊔ p)                 ↔⟨ Container≃Σ ⟩

  (∃ λ (S : O → Type s) →
   ∀ {o} → S o → I → Type (iℓ ⊔ p))         ↔⟨ (∃-cong λ _ →
                                                B.implicit-Π↔Π) ⟩
  (∃ λ (S : O → Type s) →
   ∀ o (s : S o) → I → Type (iℓ ⊔ p))       ↝⟨ (∃-cong λ _ → ∀-cong _ λ _ → ∀-cong _ λ _ →
                                                Pow⇔Fam p) ⟩
  (∃ λ (S : O → Type s) →
   ∀ o (s : S o) →
   ∃ λ (P : Type (iℓ ⊔ p)) → P → I)         ↝⟨ (∃-cong λ _ →
                                                from-bijection ΠΣ-comm F.∘
                                                ∀-cong _ λ _ → from-bijection ΠΣ-comm) ⟩
  (∃ λ (S : O → Type s) →
   ∃ λ (P : ∀ o → S o → Type (iℓ ⊔ p)) →
   ∀ o (s : S o) → P o s → I)               ↝⟨ (∃-cong λ _ → inverse $
                                                Σ-cong-refl {k₂ = logical-equivalence} B.implicit-Π↔Π λ _ →
                                                (∀-cong _ λ _ →
                                                 from-bijection B.implicit-Π↔Π) F.∘
                                                from-bijection B.implicit-Π↔Π) ⟩
  (∃ λ (S : O → Type s) →
   ∃ λ (P : ∀ {o} → S o → Type (iℓ ⊔ p)) →
   ∀ {o} {s : S o} → P s → I)               ↔⟨ inverse C.Container≃Σ ⟩□

  C.Container₂ I O s (iℓ ⊔ p)               □

-- Another conversion lemma for Container.

Container≃Container :
  ∀ {I : Type i} {O : Type o} p →
  Extensionality (i ⊔ o ⊔ s) (lsuc i ⊔ s ⊔ lsuc p) →
  Univalence (i ⊔ p) →
  Container₂ I O s (i ⊔ p) ≃ C.Container₂ I O s (i ⊔ p)
Container≃Container {i = i} {o = o} {s = s} {I = I} {O = O} p ext univ =
  Container₂ I O s (i ⊔ p)                 ↝⟨ Container≃Σ ⟩

  (∃ λ (S : O → Type s) →
   ∀ {o} → S o → I → Type (i ⊔ p))         ↔⟨ (∃-cong λ _ →
                                               B.implicit-Π↔Π) ⟩
  (∃ λ (S : O → Type s) →
   ∀ o (s : S o) → I → Type (i ⊔ p))       ↔⟨ (∃-cong λ _ →
                                               ∀-cong (lower-extensionality l r ext) λ _ →
                                               ∀-cong (lower-extensionality l r ext) λ _ →
                                               Pow↔Fam p (lower-extensionality l r ext) univ) ⟩
  (∃ λ (S : O → Type s) →
   ∀ o (s : S o) →
   ∃ λ (P : Type (i ⊔ p)) → P → I)         ↔⟨ (∃-cong λ _ →
                                               ΠΣ-comm F.∘
                                               ∀-cong (lower-extensionality l r ext) λ _ → ΠΣ-comm) ⟩
  (∃ λ (S : O → Type s) →
   ∃ λ (P : ∀ o → S o → Type (i ⊔ p)) →
   ∀ o (s : S o) → P o s → I)              ↝⟨ (∃-cong λ _ → inverse $
                                               Σ-cong-refl {k₂ = logical-equivalence} B.implicit-Π↔Π λ _ →
                                               (∀-cong _ λ _ →
                                                from-bijection B.implicit-Π↔Π) F.∘
                                               from-bijection B.implicit-Π↔Π) ⟩
  (∃ λ (S : O → Type s) →
   ∃ λ (P : ∀ {o} → S o → Type (i ⊔ p)) →
   ∀ {o} {s : S o} → P s → I)              ↝⟨ inverse C.Container≃Σ ⟩□

  C.Container₂ I O s (i ⊔ p)               □
  where
  l = i ⊔ o ⊔ s
  r = lsuc i ⊔ s ⊔ lsuc p

-- The two conversion lemmas for Container are related.

_ :
  {I : Type i} {univ : Univalence (i ⊔ p)} →
  _≃_.logical-equivalence
    (Container≃Container {I = I} {O = O} p ext univ) ≡
  Container⇔Container p
_ = refl _

-- A conversion lemma for ⟦_⟧.

⟦⟧≃⟦⟧ :
  ∀ p →
  {I : Type i} (C : Container₂ I O s (i ⊔ p)) {P : I → Type ℓ} →
  ∀ o →
  C.⟦ _⇔_.to (Container⇔Container p) C ⟧ P o ≃ ⟦ C ⟧ P o
⟦⟧≃⟦⟧ _ {I = I} C {P = P} o =
  (∃ λ (s : Shape C o) → ((i , _) : Σ I (Position C s)) → P i)  ↔⟨ (∃-cong λ _ → currying) ⟩□
  (∃ λ (s : Shape C o) → (i : I) → Position C s i → P i)        □

-- Another conversion lemma for ⟦_⟧.

⟦⟧≃⟦⟧′ :
  ∀ p →
  {I : Type i} (C : C.Container₂ I O s (i ⊔ p)) {P : I → Type ℓ} →
  ∀ o →
  ⟦ _⇔_.from (Container⇔Container p) C ⟧ P o ↝[ i ⊔ p ∣ i ⊔ p ⊔ ℓ ]
  C.⟦ C ⟧ P o
⟦⟧≃⟦⟧′ {i = i} {ℓ = ℓ} p {I = I} C {P = P} _ {k = k} ext =
  ∃-cong λ s →

  ((i : I) → (∃ λ (p : C .Position s) → C .index p ≡ i) → P i)     ↝⟨ (∀-cong (lower-extensionality? k l r ext) λ _ →
                                                                       from-bijection currying) ⟩

  ((i : I) (p : C .Position s) → C .index p ≡ i → P i)             ↔⟨ Π-comm ⟩

  ((p : C .Position s) (i : I) → C .index p ≡ i → P i)             ↝⟨ (∀-cong (lower-extensionality? k l r ext) λ _ →
                                                                       ∀-cong (lower-extensionality? k l r ext) λ _ →
                                                                       ∀-cong (lower-extensionality? k l r ext) λ eq →
                                                                       ≡⇒↝ _ $ cong P (sym eq)) ⟩

  ((p : C .Position s) (i : I) → C .index p ≡ i → P (C .index p))  ↝⟨ (∀-cong (lower-extensionality? k l r ext) λ _ →
                                                                       from-bijection $ inverse currying) ⟩
  ((p : C .Position s) → (∃ λ (i : I) → C .index p ≡ i) →
   P (C .index p))                                                 ↝⟨ (∀-cong (lower-extensionality? k l r ext) λ _ →
                                                                       drop-⊤-left-Π (lower-extensionality? k l r ext) $
                                                                       _⇔_.to contractible⇔↔⊤ $
                                                                       other-singleton-contractible _) ⟩□
  ((p : C .Position s) → P (C .index p))                           □
  where
  l = i ⊔ p
  r = i ⊔ p ⊔ ℓ

-- The map functions commute with ⟦⟧≃⟦⟧ (in a certain sense).

_ :
  map C f ∘⇾ (_≃_.to ∘ ⟦⟧≃⟦⟧ p C) ≡
  (_≃_.to ∘ ⟦⟧≃⟦⟧ p C) ∘⇾ C.map (_⇔_.to (Container⇔Container p) C) f
_ = refl _

-- The map functions commute with ⟦⟧≃⟦⟧′ (in a certain sense, assuming
-- extensionality).

map≡map′ :
  {I : Type i} {O : Type o} {P : I → Type p} {Q : I → Type q} →
  ∀ p′ →
  Extensionality (i ⊔ o ⊔ p ⊔ s ⊔ p′) (i ⊔ p ⊔ q ⊔ s ⊔ p′) →
  (C : C.Container₂ I O s (i ⊔ p′)) {f : P ⇾ Q} →
  C.map C f ∘⇾ (λ o → ⟦⟧≃⟦⟧′ p′ C o _) ≡
  (λ o → ⟦⟧≃⟦⟧′ p′ C o _) ∘⇾ map (_⇔_.from (Container⇔Container p′) C) f
map≡map′ {i = i} {o = o} {p = p} {q = q} {s = s} {P = P} {Q = Q}
  p′ ext C {f = f} =
  apply-ext (lower-extensionality l r ext) λ _ →
  apply-ext (lower-extensionality l r ext) λ (_ , g) →
  cong (_ ,_) $
  apply-ext (lower-extensionality l r ext) λ p →
  let i = C .index p in

  f i (≡⇒↝ _ (cong P (sym (refl _))) (g i (p , refl _)))  ≡⟨ cong (λ eq → f i (≡⇒↝ _ eq (g i (p , refl _)))) $
                                                             trans (cong (cong P) sym-refl) $
                                                             cong-refl _ ⟩
  f i (≡⇒↝ _ (refl _) (g i (p , refl _)))                 ≡⟨ cong (f i) $ cong (_$ g i (p , refl _))
                                                             ≡⇒↝-refl ⟩
  f i (g i (p , refl _))                                  ≡⟨ cong (_$ f i (g i (p , refl _))) $ sym
                                                             ≡⇒↝-refl ⟩
  ≡⇒↝ _ (refl _) (f i (g i (p , refl _)))                 ≡⟨ cong (λ eq → ≡⇒↝ _ eq (f i (g i (p , refl _)))) $ sym $
                                                             trans (cong (cong Q) sym-refl) $
                                                             cong-refl _ ⟩∎
  ≡⇒↝ _ (cong Q (sym (refl _))) (f i (g i (p , refl _)))  ∎
  where
  l = i ⊔ o ⊔ p ⊔ s ⊔ p′
  r = i ⊔ p ⊔ q ⊔ s ⊔ p′

-- A conversion lemma for Coalgebra.

Coalgebra≃Coalgebra :
  ∀ p {I : Type i} (C : Container I s (i ⊔ p)) →
  Coalgebra C ↝[ i ⊔ s ⊔ p ∣ i ⊔ s ⊔ p ]
  C.Coalgebra (_⇔_.to (Container⇔Container p) C)
Coalgebra≃Coalgebra {s = s} p C {k = k} ext =
  (∃ λ P → P ⇾ ⟦ C ⟧ P)                                   ↝⟨ (∃-cong λ _ →
                                                              ∀-cong (lower-extensionality? k (s ⊔ p) lzero ext) λ _ →
                                                              ∀-cong ext λ _ →
                                                              from-equivalence $ inverse $ ⟦⟧≃⟦⟧ p C _) ⟩□
  (∃ λ P → P ⇾ C.⟦ _⇔_.to (Container⇔Container p) C ⟧ P)  □

-- A conversion lemma for _⇨_.

⇨≃⇨ :
  ∀ p {I : Type i} (C : Container I s (i ⊔ p)) →
  Extensionality (i ⊔ s ⊔ p) (i ⊔ s ⊔ p) →
  (X Y : Coalgebra C) →
  (X ⇨ Y) ≃
  (Coalgebra≃Coalgebra p C _ X C.⇨ Coalgebra≃Coalgebra p C _ Y)
⇨≃⇨ {s = s} p C ext (P , f) (Q , g) =
  (∃ λ (h : P ⇾ Q) → g ∘⇾ h ≡ map _ h ∘⇾ f)     ↝⟨ (∃-cong λ h → inverse $ Eq.≃-≡ $
                                                    ∀-cong (lower-extensionality (s ⊔ p) lzero ext) λ _ →
                                                    ∀-cong ext λ _ →
                                                    inverse $ ⟦⟧≃⟦⟧ p C _) ⟩□
  (∃ λ (h : P ⇾ Q) →
     ((Σ-map id uncurry ∘_) ∘ g) ∘⇾ h ≡
     C.map _ h ∘⇾ ((Σ-map id uncurry ∘_) ∘ f))  □

-- A conversion lemma for Final.

Final≃Final :
  ∀ p {I : Type i} (C : Container I s (i ⊔ p)) →
  Extensionality (lsuc (i ⊔ s ⊔ p)) (i ⊔ s ⊔ p) →
  (ext : Extensionality (i ⊔ s ⊔ p) (i ⊔ s ⊔ p))
  (X : Coalgebra C) →
  Final X ≃ C.Final (_≃_.to (Coalgebra≃Coalgebra p C ext) X)
Final≃Final p C ext′ ext X =
  (∀ Y → Contractible (Y ⇨ X))                              ↝⟨ (Π-cong ext′ (Coalgebra≃Coalgebra p C {k = equivalence} ext) λ Y →
                                                                H-level-cong ext 0 $
                                                                ⇨≃⇨ p C ext Y X) ⟩□
  (∀ Y → Contractible (Y C.⇨ Coalgebra≃Coalgebra p C _ X))  □

-- A conversion lemma for Final′.

Final′≃Final′ :
  ∀ p {I : Type i} (C : Container I s (i ⊔ p)) →
  Extensionality (lsuc (i ⊔ s ⊔ p)) (i ⊔ s ⊔ p) →
  (ext : Extensionality (i ⊔ s ⊔ p) (i ⊔ s ⊔ p))
  (X : Coalgebra C) →
  Final′ X ≃ C.Final′ (_≃_.to (Coalgebra≃Coalgebra p C ext) X)
Final′≃Final′ p C ext′ ext X =
  (∀ Y → ∃ λ (m : Y   ⇨ X ) → (m′ : Y   ⇨ X ) → proj₁ m ≡ proj₁ m′)  ↝⟨ (Π-cong ext′ (Coalgebra≃Coalgebra p C {k = equivalence} ext) λ Y →
                                                                         Σ-cong (⇨≃⇨ p C ext Y X) λ _ →
                                                                         Π-cong ext (⇨≃⇨ p C ext Y X) λ _ →
                                                                         F.id) ⟩□
  (∀ Y → ∃ λ (m : Y C.⇨ X′) → (m′ : Y C.⇨ X′) → proj₁ m ≡ proj₁ m′)  □
  where
  X′ = _≃_.to (Coalgebra≃Coalgebra p C ext) X

-- A conversion lemma for Final-coalgebra.

Final-coalgebra≃Final-coalgebra :
  ∀ p {I : Type i} (C : Container I s (i ⊔ p)) →
  Extensionality (lsuc (i ⊔ s ⊔ p)) (i ⊔ s ⊔ p) →
  Final-coalgebra C ≃
  C.Final-coalgebra (_⇔_.to (Container⇔Container p) C)
Final-coalgebra≃Final-coalgebra p C ext =
  (∃ λ (X :   Coalgebra C ) →   Final X)  ↝⟨ Σ-cong {k₁ = equivalence}
                                               (Coalgebra≃Coalgebra p C ext′)
                                               (Final≃Final p C ext ext′) ⟩□
  (∃ λ (X : C.Coalgebra C′) → C.Final X)  □
  where
  C′   = _⇔_.to (Container⇔Container p) C
  ext′ = lower-extensionality _ lzero ext

-- A conversion lemma for Final-coalgebra′.

Final-coalgebra′≃Final-coalgebra′ :
  ∀ p {I : Type i} (C : Container I s (i ⊔ p)) →
  Extensionality (lsuc (i ⊔ s ⊔ p)) (i ⊔ s ⊔ p) →
  Final-coalgebra′ C ≃
  C.Final-coalgebra′ (_⇔_.to (Container⇔Container p) C)
Final-coalgebra′≃Final-coalgebra′ p C ext =
  (∃ λ (X :   Coalgebra C ) →   Final′ X)  ↝⟨ Σ-cong {k₁ = equivalence}
                                                (Coalgebra≃Coalgebra p C ext′)
                                                (Final′≃Final′ p C ext ext′) ⟩□
  (∃ λ (X : C.Coalgebra C′) → C.Final′ X)  □
  where
  C′   = _⇔_.to (Container⇔Container p) C
  ext′ = lower-extensionality _ lzero ext


module _ (A : Set) where

record R : Set where
  field f : A

test : R → R
test r = {!r!}