module Data.Tuple.Category where

import      Lvl
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Data.Tuple.Equivalence
import      Functional as Fn
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Category
open import Structure.Category.Functor
open import Structure.Category.Functor.Functors
open import Structure.Categorical.Properties
open import Structure.Function
open import Structure.Operator
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

private variable ℓ ℓₒ ℓₘ ℓₑ ℓₒ₁ ℓₘ₁ ℓₑ₁ ℓₒ₂ ℓₘ₂ ℓₑ₂ : Lvl.Level
private variable Obj Obj₁ Obj₂ Obj₁ₗ Obj₁ᵣ Obj₂ₗ Obj₂ᵣ : Type{ℓ}
private variable Morphism Morphism₁ Morphism₂ Morphism₁ₗ Morphism₂ₗ Morphism₁ᵣ Morphism₂ᵣ : Obj → Obj → Type{ℓ}
private variable ⦃ morphism-equiv morphism-equiv₁ morphism-equiv₂ morphism-equiv₁ₗ morphism-equiv₂ₗ morphism-equiv₁ᵣ morphism-equiv₂ᵣ ⦄ : ∀{x y : Obj} → Equiv{ℓₑ}(Morphism x y)
private variable F F₁ F₂ : Obj₁ → Obj₂
private variable C Cₗ Cᵣ C₁ₗ C₁ᵣ C₂ₗ C₂ᵣ C₁ C₂ C₃ : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}

module _
  (cat₁ : Category{Obj = Obj₁} (Morphism₁) ⦃ \{x y} → morphism-equiv₁{x}{y} ⦄)
  (cat₂ : Category{Obj = Obj₂} (Morphism₂) ⦃ \{x y} → morphism-equiv₂{x}{y} ⦄)
  where

  open Category ⦃ … ⦄

  private instance _ = cat₁
  private instance _ = cat₂

  productCategory : Category{Obj = Obj₁ ⨯ Obj₂} (\{(x₁ , x₂) (y₁ , y₂) → (Morphism₁ x₁ y₁) ⨯ (Morphism₂ x₂ y₂)})
  Category._∘_ productCategory (f₁ , f₂) (g₁ , g₂) = ((f₁ ∘ g₁) , (f₂ ∘ g₂))
  Category.id  productCategory                     = (id , id)
  _⨯_.left  (BinaryOperator.congruence (Category.binaryOperator productCategory) (p₁l , p₁r) (p₂l , p₂r)) = congruence₂(_∘_) p₁l p₂l
  _⨯_.right (BinaryOperator.congruence (Category.binaryOperator productCategory) (p₁l , p₁r) (p₂l , p₂r)) = congruence₂(_∘_) p₁r p₂r
  _⨯_.left  (Morphism.Associativity.proof (Category.associativity productCategory)) = Morphism.associativity(_∘_)
  _⨯_.right (Morphism.Associativity.proof (Category.associativity productCategory)) = Morphism.associativity(_∘_)
  _⨯_.left  (Morphism.Identityₗ.proof (_⨯_.left  (Category.identity productCategory))) = Morphism.identityₗ(_∘_)(id)
  _⨯_.right (Morphism.Identityₗ.proof (_⨯_.left  (Category.identity productCategory))) = Morphism.identityₗ(_∘_)(id)
  _⨯_.left  (Morphism.Identityᵣ.proof (_⨯_.right (Category.identity productCategory))) = Morphism.identityᵣ(_∘_)(id)
  _⨯_.right (Morphism.Identityᵣ.proof (_⨯_.right (Category.identity productCategory))) = Morphism.identityᵣ(_∘_)(id)

_⨯ᶜᵃᵗ_ : CategoryObject{ℓₒ₁}{ℓₘ₁}{ℓₑ₁} → CategoryObject{ℓₒ₂}{ℓₘ₂}{ℓₑ₂} → CategoryObject
(intro C₁) ⨯ᶜᵃᵗ (intro C₂) = intro (productCategory C₁ C₂)

module Tupleᶜᵃᵗ where
  open CategoryObject ⦃ … ⦄
  open Functor ⦃ … ⦄ renaming (map to fmap)
  private open module CategoryObjectEquiv {ℓₒ ℓₘ ℓₑ} ⦃ C : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ} ⦄ {x}{y} = Equivalence (Equiv-equivalence ⦃ CategoryObject.morphism-equiv(C){x}{y} ⦄) using ()
  private open module CategoryObjectCategory {ℓₒ ℓₘ ℓₑ} ⦃ C : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ} ⦄ = Category(category ⦃ C ⦄)

  open Structure.Category.Functor.Functors.Wrapped

  map : (C₁ₗ →ᶠᵘⁿᶜᵗᵒʳ C₁ᵣ) → (C₂ₗ →ᶠᵘⁿᶜᵗᵒʳ C₂ᵣ) → ((C₁ₗ ⨯ᶜᵃᵗ C₂ₗ) →ᶠᵘⁿᶜᵗᵒʳ (C₁ᵣ ⨯ᶜᵃᵗ C₂ᵣ))
  map {C₁ₗ = C₁ₗ} {C₁ᵣ = C₁ᵣ} {C₂ₗ = C₂ₗ} {C₂ᵣ = C₂ᵣ} ([∃]-intro F₁ ⦃ functor₁ ⦄) ([∃]-intro F₂ ⦃ functor₂ ⦄) = [∃]-intro _ ⦃ productMapFunctor ⦄ where
    instance _ = C₁ₗ ; instance _ = C₁ᵣ ; instance _ = C₂ₗ ; instance _ = C₂ᵣ
    instance _ = C₁ₗ ⨯ᶜᵃᵗ C₂ₗ ; instance _ = C₁ᵣ ⨯ᶜᵃᵗ C₂ᵣ
    productMapFunctor : Functor(productCategory (category ⦃ C₁ₗ ⦄) (category ⦃ C₂ₗ ⦄))(productCategory (category ⦃ C₁ᵣ ⦄) (category ⦃ C₂ᵣ ⦄)) (Tuple.map F₁ F₂)
    Functor.map productMapFunctor = Tuple.map fmap fmap
    Tuple.left  (Functor.op-preserving productMapFunctor) = op-preserving
    Tuple.right (Functor.op-preserving productMapFunctor) = op-preserving
    Tuple.left  (Functor.id-preserving productMapFunctor) = id-preserving
    Tuple.right (Functor.id-preserving productMapFunctor) = id-preserving

  mapLeft : (C₁ₗ →ᶠᵘⁿᶜᵗᵒʳ C₁ᵣ) → ((C₁ₗ ⨯ᶜᵃᵗ C₂) →ᶠᵘⁿᶜᵗᵒʳ (C₁ᵣ ⨯ᶜᵃᵗ C₂))
  mapLeft F = map F idᶠᵘⁿᶜᵗᵒʳ

  mapRight : (C₂ₗ →ᶠᵘⁿᶜᵗᵒʳ C₂ᵣ) → ((C₁ ⨯ᶜᵃᵗ C₂ₗ) →ᶠᵘⁿᶜᵗᵒʳ (C₁ ⨯ᶜᵃᵗ C₂ᵣ))
  mapRight F = map idᶠᵘⁿᶜᵗᵒʳ F

  left : ((Cₗ ⨯ᶜᵃᵗ Cᵣ) →ᶠᵘⁿᶜᵗᵒʳ Cₗ)
  ∃.witness left = Tuple.left
  Functor.map (∃.proof left) = Tuple.left
  Functor.op-preserving (∃.proof (left {Cₗ = Cₗ} {Cᵣ = Cᵣ})) {f = (fₗ , fᵣ)} {g = (gₗ , gᵣ)} =
    Tuple.left ((fₗ , fᵣ) ∘ (gₗ , gᵣ))        🝖[ _≡_ ]-[]
    Tuple.left ((fₗ ∘ gₗ) , (fᵣ ∘ gᵣ))        🝖[ _≡_ ]-[]
    fₗ ∘ gₗ                                   🝖[ _≡_ ]-[]
    Tuple.left(fₗ , fᵣ) ∘ Tuple.left(gₗ , gᵣ) 🝖-end
    where instance _ = Cₗ ; instance _ = Cᵣ ; instance _ = Cₗ ⨯ᶜᵃᵗ Cᵣ
  Functor.id-preserving (∃.proof (left {Cₗ = Cₗ} {Cᵣ = Cᵣ})) {x , y} =
    Tuple.left (id ⦃ Cₗ ⨯ᶜᵃᵗ Cᵣ ⦄ {x , y})      🝖[ _≡_ ]-[]
    Tuple.left (id ⦃ Cₗ ⦄ {x} , id ⦃ Cᵣ ⦄ {y})  🝖[ _≡_ ]-[]
    id ⦃ Cₗ ⦄ {x}                               🝖-end
    where instance _ = Cₗ ; instance _ = Cᵣ ; instance _ = Cₗ ⨯ᶜᵃᵗ Cᵣ

  right : ((Cₗ ⨯ᶜᵃᵗ Cᵣ) →ᶠᵘⁿᶜᵗᵒʳ Cᵣ)
  ∃.witness right = Tuple.right
  Functor.map (∃.proof right) = Tuple.right
  Functor.op-preserving (∃.proof (right {Cₗ = Cₗ} {Cᵣ = Cᵣ})) {f = (fₗ , fᵣ)} {g = (gₗ , gᵣ)} =
    Tuple.right ((fₗ , fᵣ) ∘ (gₗ , gᵣ))        🝖[ _≡_ ]-[]
    Tuple.right ((fₗ ∘ gₗ) , (fᵣ ∘ gᵣ))        🝖[ _≡_ ]-[]
    fᵣ ∘ gᵣ                                    🝖[ _≡_ ]-[]
    Tuple.right(fₗ , fᵣ) ∘ Tuple.right(gₗ , gᵣ) 🝖-end
    where instance _ = Cₗ ; instance _ = Cᵣ ; instance _ = Cₗ ⨯ᶜᵃᵗ Cᵣ
  Functor.id-preserving (∃.proof (right {Cₗ = Cₗ} {Cᵣ = Cᵣ})) {x , y} =
    Tuple.right (id ⦃ Cₗ ⨯ᶜᵃᵗ Cᵣ ⦄ {x , y})      🝖[ _≡_ ]-[]
    Tuple.right (id ⦃ Cₗ ⦄ {x} , id ⦃ Cᵣ ⦄ {y})  🝖[ _≡_ ]-[]
    id ⦃ Cᵣ ⦄ {y}                                🝖-end
    where instance _ = Cₗ ; instance _ = Cᵣ ; instance _ = Cₗ ⨯ᶜᵃᵗ Cᵣ

  repeat : (C →ᶠᵘⁿᶜᵗᵒʳ (C ⨯ᶜᵃᵗ C))
  ∃.witness repeat = Tuple.repeat
  Functor.map (∃.proof repeat) = Tuple.repeat
  Functor.op-preserving (∃.proof (repeat {C = C})) {f = f} {g = g} =
    Tuple.repeat(f ∘ g)               🝖[ _≡_ ]-[]
    Tuple.repeat(f) ∘ Tuple.repeat(g) 🝖-end
    where instance _ = C ; instance _ = C ⨯ᶜᵃᵗ C
  (Functor.id-preserving (∃.proof (repeat {C = C})) {x}) =
    Tuple.repeat(id{x = x})  🝖[ _≡_ ]-[]
    id{x = (x , x)}          🝖-end
    where instance _ = C ; instance _ = C ⨯ᶜᵃᵗ C

  constₗ : CategoryObject.Object(Cₗ) → (Cᵣ →ᶠᵘⁿᶜᵗᵒʳ (Cₗ ⨯ᶜᵃᵗ Cᵣ))
  constₗ c = mapLeft (constᶠᵘⁿᶜᵗᵒʳ c) ∘ᶠᵘⁿᶜᵗᵒʳ repeat

  constᵣ : CategoryObject.Object(Cᵣ) → (Cₗ →ᶠᵘⁿᶜᵗᵒʳ (Cₗ ⨯ᶜᵃᵗ Cᵣ))
  constᵣ c = mapRight (constᶠᵘⁿᶜᵗᵒʳ c) ∘ᶠᵘⁿᶜᵗᵒʳ repeat

  associateLeft : (C₁ ⨯ᶜᵃᵗ (C₂ ⨯ᶜᵃᵗ C₃)) →ᶠᵘⁿᶜᵗᵒʳ ((C₁ ⨯ᶜᵃᵗ C₂) ⨯ᶜᵃᵗ C₃)
  ∃.witness associateLeft = Tuple.associateLeft
  Functor.map (∃.proof associateLeft) = Tuple.associateLeft
  Functor.op-preserving (∃.proof (associateLeft {C₁ = C₁}{C₂ = C₂}{C₃ = C₃})) {f = f}{g = g} =
    Tuple.associateLeft(f ∘ g)                    🝖[ _≡_ ]-[]
    Tuple.associateLeft f ∘ Tuple.associateLeft g 🝖-end
    where
      instance _ = C₁ ; instance _ = C₂ ; instance _ = C₃
      instance _ = C₁ ⨯ᶜᵃᵗ C₂ ; instance _ = C₂ ⨯ᶜᵃᵗ C₃
      instance _ = C₁ ⨯ᶜᵃᵗ (C₂ ⨯ᶜᵃᵗ C₃) ; instance _ = (C₁ ⨯ᶜᵃᵗ C₂) ⨯ᶜᵃᵗ C₃
  Functor.id-preserving (∃.proof (associateLeft {C₁ = C₁}{C₂ = C₂}{C₃ = C₃})) =
    Tuple.associateLeft(id) 🝖[ _≡_ ]-[]
    id                      🝖-end
    where
      instance _ = C₁ ; instance _ = C₂ ; instance _ = C₃
      instance _ = C₁ ⨯ᶜᵃᵗ C₂ ; instance _ = C₂ ⨯ᶜᵃᵗ C₃
      instance _ = C₁ ⨯ᶜᵃᵗ (C₂ ⨯ᶜᵃᵗ C₃) ; instance _ = (C₁ ⨯ᶜᵃᵗ C₂) ⨯ᶜᵃᵗ C₃

  associateRight : ((C₁ ⨯ᶜᵃᵗ C₂) ⨯ᶜᵃᵗ C₃) →ᶠᵘⁿᶜᵗᵒʳ (C₁ ⨯ᶜᵃᵗ (C₂ ⨯ᶜᵃᵗ C₃))
  ∃.witness associateRight = Tuple.associateRight
  Functor.map (∃.proof associateRight) = Tuple.associateRight
  Functor.op-preserving (∃.proof (associateRight {C₁ = C₁}{C₂ = C₂}{C₃ = C₃})) {f = f}{g = g} =
    Tuple.associateRight(f ∘ g)                    🝖[ _≡_ ]-[]
    Tuple.associateRight f ∘ Tuple.associateRight g 🝖-end
    where
      instance _ = C₁ ; instance _ = C₂ ; instance _ = C₃
      instance _ = C₁ ⨯ᶜᵃᵗ C₂ ; instance _ = C₂ ⨯ᶜᵃᵗ C₃
      instance _ = C₁ ⨯ᶜᵃᵗ (C₂ ⨯ᶜᵃᵗ C₃) ; instance _ = (C₁ ⨯ᶜᵃᵗ C₂) ⨯ᶜᵃᵗ C₃
  Functor.id-preserving (∃.proof (associateRight {C₁ = C₁}{C₂ = C₂}{C₃ = C₃})) =
    Tuple.associateRight(id) 🝖[ _≡_ ]-[]
    id                       🝖-end
    where
      instance _ = C₁ ; instance _ = C₂ ; instance _ = C₃
      instance _ = C₁ ⨯ᶜᵃᵗ C₂ ; instance _ = C₂ ⨯ᶜᵃᵗ C₃
      instance _ = C₁ ⨯ᶜᵃᵗ (C₂ ⨯ᶜᵃᵗ C₃) ; instance _ = (C₁ ⨯ᶜᵃᵗ C₂) ⨯ᶜᵃᵗ C₃


------------------------------------------------------------------------
-- The Agda standard library
--
-- A solver for proving that one list is a sublist of the other.
------------------------------------------------------------------------

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

open import Relation.Binary using (Rel; Reflexive; Decidable)

module Data.List.Relation.Binary.Sublist.Heterogeneous.Solver
  {a r} {A : Set a} (R : Rel A r)
  (R-refl : Reflexive R) (R? : Decidable R)
  where

-- Note that we only need the above two constraints to define the
-- solver itself. The data structures do not depend on them. However,
-- having the whole module parametrised by them means that we can
-- instantiate them upon import.

open import Level using (_⊔_)
open import Data.Fin as Fin
open import Data.Maybe as M
open import Data.Nat.Base as Nat using (ℕ)
open import Data.Product
open import Data.Vec as Vec using (Vec ; lookup)
open import Data.List hiding (lookup)
open import Data.List.Properties
open import Data.List.Relation.Binary.Sublist.Heterogeneous
  hiding (lookup)
open import Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
open import Function

open import Relation.Binary.PropositionalEquality as P
  using (_≡_; _≗_; sym; cong; cong₂; subst₂)
open import Relation.Nullary

open P.≡-Reasoning

------------------------------------------------------------------------
-- Reified list expressions

-- Basic building blocks: variables and values
data Item (n : ℕ) : Set a where
  var : Fin n → Item n
  val : A → Item n

-- Abstract Syntax Trees
infixr 5 _<>_
data TList (n : ℕ) : Set a where
  It   : Item n → TList n
  _<>_ : TList n → TList n → TList n
  []   : TList n

-- Equivalent linearised representation
RList : ∀ n → Set a
RList n = List (Item n)

-- Semantics
⟦_⟧I : ∀ {n} → Item n → Vec (List A) n → List A
⟦ var k ⟧I ρ = lookup ρ k
⟦ val a ⟧I ρ = [ a ]

⟦_⟧T : ∀ {n} → TList n → Vec (List A) n → List A
⟦ It it  ⟧T ρ = ⟦ it ⟧I ρ
⟦ t <> u ⟧T ρ = ⟦ t ⟧T ρ ++ ⟦ u ⟧T ρ
⟦ []     ⟧T ρ = []

⟦_⟧R : ∀ {n} → RList n → Vec (List A) n → List A
⟦ []     ⟧R ρ = []
⟦ x ∷ xs ⟧R ρ = ⟦ x ⟧I ρ ++ ⟦ xs ⟧R ρ

-- Orders
data _⊆I_ {n} : (d e : Item n) → Set (a ⊔ r) where
  var : ∀ {k l} → k ≡ l → var k ⊆I var l
  val : ∀ {a b} → R a b → val a ⊆I val b

_⊆T_ : ∀ {n} → (d e : TList n) → Set (a ⊔ r)
d ⊆T e = ∀ ρ → Sublist R (⟦ d ⟧T ρ) (⟦ e ⟧T ρ)

_⊆R_ : ∀ {n} (d e : RList n) → Set (a ⊔ r)
d ⊆R e = ∀ ρ → Sublist R (⟦ d ⟧R ρ) (⟦ e ⟧R ρ)

-- Flattening in a semantics-respecting manner

⟦++⟧R : ∀ {n} xs ys (ρ : Vec (List A) n) → ⟦ xs ++ ys ⟧R ρ ≡ ⟦ xs ⟧R ρ ++ ⟦ ys ⟧R ρ
⟦++⟧R []       ys ρ = P.refl
⟦++⟧R (x ∷ xs) ys ρ = begin
  ⟦ x ⟧I ρ ++ ⟦ xs ++ ys ⟧R ρ
    ≡⟨ cong (⟦ x ⟧I ρ ++_) (⟦++⟧R xs ys ρ) ⟩
  ⟦ x ⟧I ρ ++ ⟦ xs ⟧R ρ ++ ⟦ ys ⟧R ρ
    ≡⟨ sym $ ++-assoc (⟦ x ⟧I ρ) (⟦ xs ⟧R ρ) (⟦ ys ⟧R ρ) ⟩
  (⟦ x ⟧I ρ ++ ⟦ xs ⟧R ρ) ++ ⟦ ys ⟧R ρ
    ∎

flatten : ∀ {n} (t : TList n) → Σ[ r ∈ RList n ] ⟦ r ⟧R ≗ ⟦ t ⟧T
flatten []       = [] , λ _ → P.refl
flatten (It it)  = it ∷ [] , λ ρ → ++-identityʳ (⟦ It it ⟧T ρ)
flatten (t <> u) =
  let (rt , eqt) = flatten t
      (ru , equ) = flatten u
  in rt ++ ru , λ ρ → begin
    ⟦ rt ++ ru ⟧R ρ        ≡⟨ ⟦++⟧R rt ru ρ ⟩
    ⟦ rt ⟧R ρ ++ ⟦ ru ⟧R ρ ≡⟨ cong₂ _++_ (eqt ρ) (equ ρ) ⟩
    ⟦ t ⟧T ρ ++ ⟦ u ⟧T ρ   ≡⟨⟩
    ⟦ t <> u ⟧T ρ          ∎

------------------------------------------------------------------------
-- Solver for the sublist problem

-- auxiliary lemmas

private

  keep-it : ∀ {n a b} → a ⊆I b → (xs ys : RList n) → xs ⊆R ys → (a ∷ xs) ⊆R (b ∷ ys)
  keep-it (var a≡b) xs ys hyp ρ = ++⁺ (reflexive R-refl (cong _ a≡b)) (hyp ρ)
  keep-it (val rab) xs ys hyp ρ = rab ∷ hyp ρ

  skip-it : ∀ {n} it (d e : RList n) → d ⊆R e → d ⊆R (it ∷ e)
  skip-it it d ys hyp ρ = ++ˡ (⟦ it ⟧I ρ) (hyp ρ)

-- Solver for items
solveI : ∀ {n} (a b : Item n) → Maybe (a ⊆I b)
solveI (var k) (var l) = M.map var $ decToMaybe (k Fin.≟ l)
solveI (val a) (val b) = M.map val $ decToMaybe (R? a b)
solveI _ _ = nothing

-- Solver for linearised expressions
solveR : ∀ {n} (d e : RList n) → Maybe (d ⊆R e)
-- trivial
solveR [] e  = just (λ ρ → minimum _)
solveR d  [] = nothing
-- actual work
solveR (a ∷ d) (b ∷ e) with solveI a b
... | just it = M.map (keep-it it d e) (solveR d e)
... | nothing = M.map (skip-it b (a ∷ d) e) (solveR (a ∷ d) e)

-- Coming back to ASTs thanks to flatten

solveT : ∀ {n} (t u : TList n) → Maybe (t ⊆T u)
solveT t u =
  let (rt , eqt) = flatten t
      (ru , equ) = flatten u
  in case solveR rt ru of λ where
    (just hyp) → just (λ ρ → subst₂ (Sublist R) (eqt ρ) (equ ρ) (hyp ρ))
    nothing    → nothing

-- Prover for ASTs

prove : ∀ {n} (d e : TList n) → From-just (solveT d e)
prove d e = from-just (solveT d e)


record R : Set₁ where
  field
    X : Set

data Δ (A : Set) : Set where
  _,_ : A → A → Δ A

foo : (A : Set) → R → Δ A → Set
foo A = λ { r (x , y) → let open R r in X }
  -- (y₁ : r) → Set !=< Set of type Set₁
  -- when checking that the expression .Foo.X has type Set


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Implementation.Standard where

module Data where
      module Empty where open import Light.Implementation.Standard.Data.Empty public
      module Unit where open import Light.Implementation.Standard.Data.Unit public
      module These where open import Light.Implementation.Standard.Data.These public
      module Product where open import Light.Implementation.Standard.Data.Product public

module Relation where
      module Decidable where open import Light.Implementation.Standard.Relation.Decidable public
      module Sets where open import Light.Implementation.Standard.Relation.Sets public


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Localization.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.PathSplitEquiv
open isPathSplitEquiv

module _ {ℓα ℓs ℓt} {A : Type ℓα} {S : A → Type ℓs} {T : A → Type ℓt} where

  isLocal : ∀ (F : ∀ α → S α → T α) {ℓ} (X : Type ℓ) → Type _
  isLocal F X = ∀ α → isPathSplitEquiv (λ (g : T α → X) → g ∘ F α)

  data Localize (F : ∀ α → S α → T α) {ℓ} (X : Type ℓ) : Type (ℓ-max ℓ (ℓ-max ℓα (ℓ-max ℓs ℓt))) where
    ∣_∣ : X → Localize F X
    -- (_∘ F α) : (T α → Localize F X) → (S α → Localize F X) is a path-split equivalence ∀ α
    ext   : ∀ α → (S α → Localize F X) → (T α → Localize F X)
    isExt : ∀ α (f : S α → Localize F X) (s : S α) → ext α f (F α s) ≡ f s
    ≡ext   : ∀ α (g h : T α → Localize F X) → ((s : S α) → g (F α s) ≡ h (F α s)) → ((t : T α) → g t ≡ h t)
    ≡isExt : ∀ α g h (p : (s : S α) → g (F α s) ≡ h (F α s)) (s : S α) → ≡ext α g h p (F α s) ≡ p s

  isLocal-Localize : ∀ (F : ∀ α → S α → T α) {ℓ} (X : Type ℓ) → isLocal F (Localize F X)
  fst (sec (isLocal-Localize F X α)) f t   = ext   α f t
  snd (sec (isLocal-Localize F X α)) f i s = isExt α f s i
  fst (secCong (isLocal-Localize F X α) g h) p i t   = ≡ext   α g h (funExt⁻ p) t i
  snd (secCong (isLocal-Localize F X α) g h) p i j t = ≡isExt α g h (funExt⁻ p) t i j


{-# OPTIONS --guardedness-preserving-type-constructors #-}
module Issue602 where

infixl 6 _⊔_

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

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

infix 1000 ♯_

postulate
  ∞  : ∀ {a} (A : Set a) → Set a
  ♯_ : ∀ {a} {A : Set a} → A → ∞ A
  ♭  : ∀ {a} {A : Set a} → ∞ A → A

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}

data CoNat : Set0 where
  z : CoNat
  s : ∞ CoNat → CoNat

record A : Set2 where
  field
    f : Set1

record B (a : ∞ A) : Set1 where
  field
    f : A.f (♭ a)

postulate
  a : A

e : CoNat → A
e z = a
e (s n) = record
  { f = B (♯ e (♭ n))
  }


open import Theory

module Categories.Category.Construction.Classifying {ℓ₁ ℓ₂ ℓ₃} (Th : Theory ℓ₁ ℓ₂ ℓ₃) where

open import Relation.Binary using (Rel)
open import Data.List using ([]; _∷_)
open import Data.Fin using () renaming (zero to fzero; suc to fsuc)
open import Level using (_⊔_)

open import Categories.Category

open import Syntax

open Theory.Theory Th
open Signature Sg
open Term Sg

private
  arr : Rel Type (ℓ₁ ⊔ ℓ₂)
  arr A B = A ∷ [] ⊢ B

  identityʳ : forall {A B} {e : A ∷ [] ⊢ B}
    -> A ∷ [] ⊢ e [ ext ! var ] ≡ e
  identityʳ {A} {e = e} = trans (cong/sub (trans (cong/ext !-unique refl) η-pair) refl) sub/id

  assoc : {A B C D : Type} {f : arr A B} {g : arr B C} {h : arr C D}
    -> A ∷ [] ⊢ h [ ext ! g ] [ ext ! f ] ≡ h [ ext ! (g [ ext ! f ]) ]
  assoc {f = f} {g = g} {h = h} = trans (sym sub/∙)
    (cong/sub (trans ext∙ (cong/ext (sym !-unique) refl)) refl)

Cl : Category ℓ₁ (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃)
Cl = record
       { Obj = Type
       ; _⇒_ = arr
       ; _≈_ = λ e₁ e₂ → _ ∷ [] ⊢ e₁ ≡ e₂
       ; id = var
       ; _∘_ = λ e₁ e₂ → e₁ [ ext ! e₂ ]
       ; assoc = assoc
       ; sym-assoc = sym assoc
       ; identityˡ = λ {A} {B} {f} -> var/ext ! f
       ; identityʳ = identityʳ
       ; identity² = var/ext ! var
       ; equiv = record { refl = refl ; sym = sym ; trans = trans }
       ; ∘-resp-≈ = λ x x₁ → cong/sub (cong/ext refl x₁) x
       }

open import Categories.Category.BinaryProducts Cl

module M where
  open import Categories.Category.CartesianClosed.Canonical Cl

  CC : CartesianClosed
  CC = record
         { ⊤ = Unit
         ; _×_ = _*_
         ; ! = unit
         ; π₁ = fst var
         ; π₂ = snd var
         ; ⟨_,_⟩ = pair
         ; !-unique = eta/Unit
         ; π₁-comp = trans comm/fst (trans (cong/fst (var/ext ! (pair _ _))) (beta/*₁ _ _))
         ; π₂-comp = trans comm/snd (trans (cong/snd (var/ext ! (pair _ _))) (beta/*₂ _ _))
         ; ⟨,⟩-unique = ⟨,⟩-unique
         ; _^_ = λ A B → B => A
         ; eval = app (fst var) (snd var)
         ; curry = λ e → abs (e [ ext ! (pair (var [ weaken ]) var) ])
         ; eval-comp = eval-comp
         ; curry-resp-≈ = λ x → cong/abs (cong/sub refl x)
         ; curry-unique = λ x → curry-unique x
         }
    where
      ⟨,⟩-unique : forall {A B C} {h : C ∷ [] ⊢ A * B} {i : C ∷ [] ⊢ A} {j : C ∷ [] ⊢ B}
        -> C ∷ [] ⊢ fst var [ ext ! h ] ≡ i
        -> C ∷ [] ⊢ snd var [ ext ! h ] ≡ j
        -> C ∷ [] ⊢ pair i j ≡ h
      ⟨,⟩-unique x y = trans
        (cong/pair
          (sym (trans (cong/fst (sym (var/ext ! _))) (trans (sym comm/fst) x)))
          (sym (trans (cong/snd (sym (var/ext ! _))) (trans (sym comm/snd) y)))
        )
        (eta/* _)

      open import Categories.Object.Product.Morphisms Cl using ([_⇒_]_×_)
      open import Categories.Object.Product Cl using (Product)

      product : forall {A B} -> Product A B
      product {A} {B} = record
                          { A×B = A * B
                          ; π₁ = fst var
                          ; π₂ = snd var
                          ; ⟨_,_⟩ = pair
                          ; project₁ = trans comm/fst (trans (cong/fst (var/ext ! (pair _ _))) (beta/*₁ _ _))
                          ; project₂ = trans comm/snd (trans (cong/snd (var/ext ! (pair _ _))) (beta/*₂ _ _))
                          ; unique = ⟨,⟩-unique
                          }

      eval-comp : forall {B A C} {f : arr (C * A) B}
        -> C * A ∷ [] ⊢
             app (fst var) (snd var)
               [ ext ! ([ product ⇒ product ] (abs (f [ ext ! (pair (var [ weaken ]) var)])) × var) ]
           ≡
             f
      eval-comp = trans comm/app (trans (cong/app (trans comm/fst (cong/fst (var/ext _ _))) (trans comm/snd (cong/snd (var/ext _ _)))) (trans (cong/app (trans (beta/*₁ _ _) comm/abs) (beta/*₂ _ _)) (trans (beta/=> _ _) (trans (sym sub/∙) (trans (cong/sub (trans ext∙ (cong/ext (trans (cong/∙ (trans ext∙ (cong/ext (sym !-unique) comm/fst)) refl) (trans ext∙ (cong/ext (sym !-unique) (trans comm/fst (cong/fst (trans (sym sub/∙) (cong/sub weaken/ext refl))))))) (trans (var/ext _ _) (var/ext _ _)))) refl) (trans (sym sub/∙) (trans (cong/sub (trans ext∙ (trans (cong/ext (sym !-unique) (trans comm/pair (cong/pair (trans (sym sub/∙) (trans (cong/sub weaken/ext refl) (trans (var/ext _ _) (cong/fst sub/id)))) (var/ext _ _)))) (trans (cong/ext !-unique (eta/* _)) η-pair))) refl) sub/id)))))))

      open BinaryProducts (record { product = product })
      open Category Cl

      helper : forall {A B C} {f : A ⇒ B => C}
        -> B ∷ A ∷ [] ⊨ ext ! (var [ weaken ]) ≡ weaken
      helper = trans (cong/ext (!-unique {γ = weaken ∙ weaken}) refl) (trans (sym ext∙) (trans (cong/∙ η-pair refl) id∙ˡ))

      curry-unique : forall {A B C} {f : A ⇒ B => C} {g : A × B ⇒ C}
        -> app (fst var) (snd var) ∘ (f ⁂ Category.id Cl) ≈ g
        -> f ≈ abs (g [ ext ! (pair (var [ weaken ]) var) ])
      curry-unique {A} {B} {C} {f = f} {g = g} x =
        begin
          f
        ≈˘⟨ eta/=> _ ⟩
          abs (app (f [ weaken ]) var)
        ≈˘⟨ cong/abs (cong/app (cong/sub (helper {f = f}) refl) refl) ⟩
          abs (app (f [ ext ! (var [ weaken ]) ]) var)
        ≈˘⟨ cong/abs (cong/app (beta/*₁ _ _) (beta/*₂ _ _)) ⟩
          abs (app (fst (pair (f [ ext ! (var [ weaken ]) ]) var)) (snd (pair (f [ ext ! (var [ weaken ]) ]) var)))
        ≈˘⟨ cong/abs (cong/app (trans comm/fst (cong/fst (var/ext _ _))) (trans comm/snd (cong/snd (var/ext _ _)))) ⟩
          abs (app (fst var [ ext ! (pair (f [ ext ! (var [ weaken ]) ]) var) ]) (snd var [ ext ! (pair (f [ ext ! (var [ weaken ]) ]) var) ]))
        ≈˘⟨ cong/abs comm/app ⟩
          abs (app (fst var) (snd var) [ ext ! (pair (f [ ext ! (var [ weaken ]) ]) var) ])
        ≈˘⟨ cong/abs (cong/sub (cong/ext refl (cong/pair (cong/sub (cong/ext refl (trans comm/fst (trans (cong/fst (var/ext _ _)) (beta/*₁ _ _)))) refl) refl)) refl) ⟩
          abs (app (fst var) (snd var) [ ext ! (pair (f [ ext ! (fst var [ ext ! (pair (var [ weaken ]) var)]) ]) var) ])
        ≈˘⟨ cong/abs (cong/sub (cong/ext refl (cong/pair (cong/sub (trans ext∙ (cong/ext (sym !-unique) refl)) refl) (trans (cong/snd (var/ext _ _)) (beta/*₂ _ _)))) refl) ⟩
          abs (app (fst var) (snd var) [ ext ! (pair (f [ ext ! (fst var) ∙ ext ! (pair (var [ weaken ]) var) ]) (snd (var [ ext ! (pair (var [ weaken ]) var) ]))) ])
        ≈˘⟨ cong/abs (cong/sub (cong/ext refl (cong/pair (sym sub/∙) comm/snd)) refl) ⟩
          abs (app (fst var) (snd var) [ ext ! (pair (f [ ext ! (fst var) ] [ ext ! (pair (var [ weaken ]) var) ]) (snd var [ ext ! (pair (var [ weaken ]) var) ])) ])
        ≈˘⟨ cong/abs (cong/sub (cong/ext refl comm/pair) refl) ⟩
          abs (app (fst var) (snd var) [ ext ! (pair (f [ ext ! (fst var) ]) (snd var) [ ext ! (pair (var [ weaken ]) var) ]) ])
        ≈⟨ cong/abs (cong/sub (cong/ext !-unique (cong/sub refl (cong/pair refl (sym (var/ext _ _))))) refl) ⟩
          abs (app (fst var) (snd var) [ ext (! ∙ ext ! (pair (var [ weaken ]) var)) (pair (f [ ext ! (fst var) ]) (var [ ext ! (snd var) ]) [ ext ! (pair (var [ weaken ]) var) ]) ])
        ≈˘⟨ cong/abs (cong/sub ext∙ refl) ⟩
          abs (app (fst var) (snd var) [ ext ! (pair (f [ ext ! (fst var) ]) (var [ ext ! (snd var) ])) ∙ ext ! (pair (var [ weaken ]) var) ])
        ≡⟨⟩
          abs (app (fst var) (snd var) [ ext ! ⟨ f ∘ fst var , Category.id Cl ∘ snd var ⟩ ∙ ext ! (pair (var [ weaken ]) var) ])
        ≈⟨ cong/abs sub/∙ ⟩
          abs ((app (fst var) (snd var) ∘ ⟨ f ∘ fst var , Category.id Cl ∘ snd var ⟩) [ ext ! (pair (var [ weaken ]) var) ])
        ≡⟨⟩
          abs ((app (fst var) (snd var) ∘ (f ⁂ Category.id Cl)) [ ext ! (pair (var [ weaken ]) var) ])
        ≈⟨ cong/abs (cong/sub refl x) ⟩
          abs (g [ ext ! (pair (var [ weaken ]) var) ])
        ∎
        where
          open import Relation.Binary.Reasoning.Setoid TermSetoid

open import Categories.Category.CartesianClosed Cl
import Categories.Category.CartesianClosed.Canonical Cl as Can

CC : CartesianClosed
CC = Can.Equivalence.fromCanonical M.CC

open import Semantics Cl CC Sg
open Category Cl

private
  open import Data.Product using (_,_)

  open import Categories.Morphism Cl using (Iso; _≅_)
  open import Categories.Category.Cartesian using (Cartesian)
  open import Categories.Functor
  open import Categories.Functor.Properties using ([_]-resp-∘)
  open import Categories.Functor.Construction.Product using (Product)
  open import Categories.Functor.Construction.Exponential using (Exp)
  open import Categories.Functor.Bifunctor using (Bifunctor)

  open CartesianClosed CC
  open BinaryProducts (Cartesian.products cartesian)
  open I ⌊_⌋

  P : Bifunctor Cl Cl Cl
  P = Product Cl cartesian

  E : Bifunctor Cl op Cl
  E = Exp Cl CC

  from/⟦⟧T : forall (A : Type) -> ⟦ A ⟧T ⇒ A
  to/⟦⟧T : forall (A : Type) -> A ⇒ ⟦ A ⟧T

  from/⟦⟧T ⌊ x ⌋ = Category.id Cl
  from/⟦⟧T Unit = Category.id Cl
  from/⟦⟧T (A * A₁) = from/⟦⟧T A ⁂ from/⟦⟧T A₁
  from/⟦⟧T (A => A₁) = λg (from/⟦⟧T A₁ ∘ eval′ ∘ (Category.id Cl ⁂ to/⟦⟧T A))

  to/⟦⟧T ⌊ x ⌋ = Category.id Cl
  to/⟦⟧T Unit = Category.id Cl
  to/⟦⟧T (A * A₁) = to/⟦⟧T A ⁂ to/⟦⟧T A₁
  to/⟦⟧T (A => A₁) = λg (to/⟦⟧T A₁ ∘ eval′ ∘ (Category.id Cl ⁂ from/⟦⟧T A))

  to∘from : forall {A} -> ⟦ A ⟧T ∷ [] ⊢ to/⟦⟧T A [ ext ! (from/⟦⟧T A) ] ≡ var
  to∘from {⌊ x ⌋} = var/ext _ _
  to∘from {Unit} = var/ext _ _
  to∘from {A * A₁} = trans ([ P ]-resp-∘ (to∘from , to∘from)) (Functor.identity P)
  to∘from {A => A₁} = trans ([ E ]-resp-∘ (to∘from , to∘from)) (Functor.identity E)

  from∘to : forall {A} -> A ∷ [] ⊢ from/⟦⟧T A [ ext ! (to/⟦⟧T A) ] ≡ var
  from∘to {⌊ x ⌋} = var/ext _ _
  from∘to {Unit} = var/ext _ _
  from∘to {A * A₁} = trans ([ P ]-resp-∘ (from∘to , from∘to)) (Functor.identity P)
  from∘to {A => A₁} = trans ([ E ]-resp-∘ (from∘to , from∘to)) (Functor.identity E)

  Iso/⟦⟧T : forall {A : Type} -> ⟦ A ⟧T ≅ A
  Iso/⟦⟧T {A} = record
    { from = from/⟦⟧T A
    ; to = to/⟦⟧T A
    ; iso = record { isoˡ = to∘from ; isoʳ = from∘to }
    }

  ⟦_⟧F : (f : Func) -> ⟦ dom f ⟧T ⇒ ⟦ cod f ⟧T
  ⟦_⟧F f = _≅_.to Iso/⟦⟧T ∘ x ∘ _≅_.from Iso/⟦⟧T
    where
      x : dom f ⇒ cod f
      x = func f var

S : Structure
S = record { ⟦_⟧G = ⌊_⌋ ; ⟦_⟧F = λ f → ⟦ f ⟧F }

open Structure S

private
  γC : forall {Γ} -> ⟦ Γ ⟧C ∷ [] ⊨ Γ
  γC {[]} = !
  γC {A ∷ Γ} = ext (γC {Γ} ∙ ext ! π₁) (from/⟦⟧T A ∘ π₂)

  open HomReasoning
  open import Categories.Morphism.Reasoning Cl
  import Categories.Object.Product Cl as Prod

  open import Categories.Object.Terminal Cl using (Terminal)
  module T = Terminal (Cartesian.terminal cartesian)

  helper : forall {Γ} {A} {e : Γ ⊢ A} -> ⟦ e ⟧ ≈ to/⟦⟧T A ∘ (e [ γC ])
  helperS : forall {Γ Γ′} {γ : Γ ⊨ Γ′} -> _ ⊨ γC ∙ ext ! ⟦ γ ⟧S ≡ γ ∙ γC

  helper {e = func f e} =
    begin
      (to/⟦⟧T (cod f) ∘ func f var ∘ from/⟦⟧T (dom f)) ∘ ⟦ e ⟧
    ≈⟨ ∘-resp-≈ʳ (helper {e = e}) ⟩
      (to/⟦⟧T (cod f) ∘ func f var ∘ from/⟦⟧T (dom f)) ∘ to/⟦⟧T _ ∘ (e [ γC ])
    ≈⟨ assoc²' ⟩
      to/⟦⟧T (cod f) ∘ func f var ∘ from/⟦⟧T (dom f) ∘ to/⟦⟧T (dom f) ∘ (e [ γC ])
    ≈⟨ ∘-resp-≈ʳ (∘-resp-≈ʳ (cancelˡ from∘to)) ⟩
      to/⟦⟧T (cod f) ∘ func f var ∘ (e [ γC ])
    ≈⟨ ∘-resp-≈ʳ (comm/func _ _ _ _ _) ⟩
      to/⟦⟧T (cod f) ∘ func f (var ∘ (e [ γC ]))
    ≈⟨ ∘-resp-≈ʳ (cong/func identityˡ) ⟩
      to/⟦⟧T (cod f) ∘ func f (e [ γC ])
    ≈˘⟨ ∘-resp-≈ʳ (comm/func _ _ _ _ _) ⟩
      to/⟦⟧T (cod f) ∘ (func f e [ γC ])
    ∎
  helper {e = var} =
    begin
      π₂
    ≈⟨ insertˡ to∘from ⟩
      to/⟦⟧T _ ∘ (from/⟦⟧T _ ∘ π₂)
    ≈˘⟨ ∘-resp-≈ʳ (var/ext _ _) ⟩
      to/⟦⟧T _ ∘ (var [ ext _ (from/⟦⟧T _ ∘ π₂) ])
    ∎
  helper {e = unit} = T.!-unique _
  helper {e = pair e₁ e₂} =
    begin
      ⟨ ⟦ e₁ ⟧ , ⟦ e₂ ⟧ ⟩
    ≈⟨ ⟨⟩-cong₂ (helper {e = e₁}) (helper {e = e₂}) ⟩
      ⟨ to/⟦⟧T _ ∘ (e₁ [ γC ]) , to/⟦⟧T _ ∘ (e₂ [ γC ]) ⟩
    ≈˘⟨ ⁂∘⟨⟩ ⟩
      (to/⟦⟧T _ ⁂ to/⟦⟧T _) ∘ (pair (e₁ [ γC ]) (e₂ [ γC ]))
    ≈˘⟨ ∘-resp-≈ʳ comm/pair ⟩
      (to/⟦⟧T _ ⁂ to/⟦⟧T _) ∘ (pair e₁ e₂ [ γC ])
    ∎
  helper {e = fst {A = A} {B = B} e} = switch-fromtoˡ Iso/⟦⟧T (
    begin
      from/⟦⟧T _ ∘ π₁ ∘ ⟦ e ⟧
    ≈⟨ ∘-resp-≈ʳ (∘-resp-≈ʳ (helper {e = e})) ⟩
      from/⟦⟧T A ∘ π₁ ∘ to/⟦⟧T (A * B) ∘ (e [ γC ])
    ≈⟨ ∘-resp-≈ʳ (pullˡ π₁∘⁂) ⟩
      from/⟦⟧T A ∘ (to/⟦⟧T A ∘ π₁) ∘ (e [ γC ])
    ≈⟨ assoc²'' ⟩
      (from/⟦⟧T A ∘ to/⟦⟧T A) ∘ π₁ ∘ (e [ γC ])
    ≈⟨ elimˡ from∘to ⟩
      π₁ ∘ (e [ γC ])
    ≈⟨ comm/fst ⟩
      fst (var [ ext ! (e [ γC ]) ])
    ≈⟨ cong/fst (var/ext _ _) ⟩
      fst (e [ γC ])
    ≈˘⟨ comm/fst ⟩
      fst e [ γC ]
    ∎)
  helper {e = snd e} =
    begin
      π₂ ∘ ⟦ e ⟧
    ≈⟨ ∘-resp-≈ʳ (helper {e = e}) ⟩
      π₂ ∘ (to/⟦⟧T _ ∘ (e [ γC ]))
    ≈⟨ pullˡ π₂∘⁂ ⟩
      (to/⟦⟧T _ ∘ snd var) ∘ (e [ γC ])
    ≈⟨ pullʳ comm/snd ⟩
      to/⟦⟧T _ ∘ snd (var ∘ (e [ γC ]))
    ≈⟨ ∘-resp-≈ʳ (cong/snd identityˡ) ⟩
      to/⟦⟧T _ ∘ snd (e [ γC ])
    ≈˘⟨ ∘-resp-≈ʳ comm/snd ⟩
      to/⟦⟧T _ ∘ (snd e [ γC ])
    ∎
  helper {e = abs e} =
    begin
      λg ⟦ e ⟧
    ≈⟨ λ-cong (helper {e = e}) ⟩
      λg (to/⟦⟧T _ ∘ (e [ γC ]))
    ≈⟨ refl ⟩
      λg (to/⟦⟧T _ ∘ (e [ ext (γC ∙ ext ! π₁) (from/⟦⟧T _ ∘ π₂) ]))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (cong/sub (cong/ext id∙ʳ refl) refl)) ⟩
      λg (to/⟦⟧T _ ∘ (e [ ext ((γC ∙ ext ! π₁) ∙ _⊨_.id) (from/⟦⟧T _ ∘ π₂) ]))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (cong/sub ×id′-ext refl)) ⟩
      λg (to/⟦⟧T _ ∘ (e [ (γC ∙ ext ! π₁) ×id′ ∙ ext _⊨_.id (from/⟦⟧T _ ∘ π₂)]))
    ≈⟨ λ-cong (∘-resp-≈ʳ sub/∙) ⟩
      λg (to/⟦⟧T _ ∘ (e [ (γC ∙ ext ! π₁) ×id′ ] [ ext _⊨_.id (from/⟦⟧T _ ∘ π₂)]))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (cong/sub refl (cong/sub ×id′-∙ refl))) ⟩
      λg (to/⟦⟧T _ ∘ (e [ γC ×id′ ∙ ext ! π₁ ×id′ ] [ ext _⊨_.id (from/⟦⟧T _ ∘ π₂)]))
    ≈⟨ λ-cong (∘-resp-≈ʳ (cong/sub refl sub/∙)) ⟩
      λg (to/⟦⟧T _ ∘ (e [ ext (γC ∙ weaken) var ] [ ext (ext ! π₁ ∙ weaken) var ] [ ext _⊨_.id (from/⟦⟧T _ ∘ π₂)]))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (beta/=> _ _)) ⟩
      λg (to/⟦⟧T _ ∘ app (abs (e [ ext (γC ∙ weaken) var ] [ ext (ext ! π₁ ∙ weaken) var ])) (from/⟦⟧T _ ∘ π₂))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (cong/app comm/abs refl)) ⟩
      λg (to/⟦⟧T _ ∘ app (abs (e [ ext (γC ∙ weaken) var ]) ∘ π₁) (from/⟦⟧T _ ∘ π₂))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (cong/app (beta/*₁ _ _) (beta/*₂ _ _))) ⟩
      λg (to/⟦⟧T _ ∘ app (fst (abs (e [ ext (γC ∙ weaken) var ]) ⁂ from/⟦⟧T _)) (snd (abs (e [ ext (γC ∙ weaken) var ]) ⁂ from/⟦⟧T _)))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (trans comm/app (cong/app (trans comm/fst (cong/fst (var/ext _ _))) (trans comm/snd (cong/snd (var/ext _ _)))))) ⟩
      λg (to/⟦⟧T _ ∘ (app π₁ π₂) ∘ (abs (e [ ext (γC ∙ weaken) var ]) ⁂ from/⟦⟧T _))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ˡ (cong/app (beta/*₁ _ _) (beta/*₂ _ _)))) ⟩
      λg (to/⟦⟧T _ ∘ (app (fst (pair π₁ π₂)) (snd (pair π₁ π₂))) ∘ (abs (e [ ext (γC ∙ weaken) var ]) ⁂ from/⟦⟧T _))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ˡ (cong/app (trans comm/fst (cong/fst (var/ext _ _))) (trans comm/snd (cong/snd (var/ext _ _)))))) ⟩
      λg (to/⟦⟧T _ ∘ (app (fst var ∘ pair π₁ π₂) (snd var ∘ pair π₁ π₂)) ∘ (abs (e [ ext (γC ∙ weaken) var ]) ⁂ from/⟦⟧T _))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ˡ comm/app)) ⟩
      λg (to/⟦⟧T _ ∘ (app (fst var) (snd var) ∘ (pair π₁ π₂)) ∘ (abs (e [ ext (γC ∙ weaken) var ]) ⁂ from/⟦⟧T _))
    ≈⟨ refl ⟩
      λg (to/⟦⟧T _ ∘ (eval ∘ Prod.repack product exp.product) ∘ (abs (e [ ext (γC ∙ weaken) var ]) ⁂ from/⟦⟧T _))
    ≈⟨ refl ⟩
      λg (to/⟦⟧T _ ∘ eval′ ∘ (abs (e [ ext (γC ∙ weaken) var ]) ⁂ from/⟦⟧T _))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ʳ (⁂-cong₂ comm/abs refl))) ⟩
      λg (to/⟦⟧T _ ∘ eval′ ∘ ((abs e [ γC ]) ⁂ from/⟦⟧T _))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ʳ (⁂-cong₂ identityˡ (Category.identityʳ Cl)))) ⟩
      λg (to/⟦⟧T _ ∘ eval′ ∘ (var ∘ (abs e [ γC ]) ⁂ from/⟦⟧T _ ∘ var))
    ≈˘⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ʳ ⁂∘⁂)) ⟩
      λg (to/⟦⟧T _ ∘ eval′ ∘ (var ⁂ from/⟦⟧T _) ∘ ((abs e [ γC ]) ⁂ var))
    ≈˘⟨ λ-cong assoc²' ⟩
      λg ((to/⟦⟧T _ ∘ eval′ ∘ (var ⁂ from/⟦⟧T _)) ∘ ((abs e [ γC ]) ⁂ var))
    ≈˘⟨ exp.subst product product ⟩
      (λg (to/⟦⟧T _ ∘ eval′ ∘ (var ⁂ from/⟦⟧T _))) ∘ (abs e [ γC ])
    ≈⟨ refl ⟩
      to/⟦⟧T (_ => _) ∘ (abs e [ γC ])
    ∎
  helper {e = app e₁ e₂} =
    begin
      eval′ ∘ ⟨ ⟦ e₁ ⟧ , ⟦ e₂ ⟧ ⟩
    ≈⟨ refl ⟩
      (app (fst var) (snd var) ∘ _) ∘ ⟨ ⟦ e₁ ⟧ , ⟦ e₂ ⟧ ⟩
    ≈⟨ ∘-resp-≈ˡ (elimʳ η) ⟩
      app (fst var) (snd var) ∘ ⟨ ⟦ e₁ ⟧ , ⟦ e₂ ⟧ ⟩
    ≈⟨ ∘-resp-≈ʳ (⟨⟩-cong₂ (helper {e = e₁}) (helper {e = e₂})) ⟩
      app (fst var) (snd var) ∘ ⟨ to/⟦⟧T _ ∘ (e₁ [ γC ]) , to/⟦⟧T _ ∘ (e₂ [ γC ]) ⟩
    ≈⟨ comm/app ⟩
      app (fst var ∘ ⟨ to/⟦⟧T _ ∘ (e₁ [ γC ]) , to/⟦⟧T _ ∘ (e₂ [ γC ]) ⟩)
          (snd var ∘ ⟨ to/⟦⟧T _ ∘ (e₁ [ γC ]) , to/⟦⟧T _ ∘ (e₂ [ γC ]) ⟩)
    ≈⟨ cong/app comm/fst comm/snd ⟩
      app (fst (var ∘ ⟨ to/⟦⟧T _ ∘ (e₁ [ γC ]) , to/⟦⟧T _ ∘ (e₂ [ γC ]) ⟩))
          (snd (var ∘ ⟨ to/⟦⟧T _ ∘ (e₁ [ γC ]) , to/⟦⟧T _ ∘ (e₂ [ γC ]) ⟩))
    ≈⟨ cong/app (cong/fst (var/ext _ _)) (cong/snd (var/ext _ _)) ⟩
      app (fst ⟨ to/⟦⟧T _ ∘ (e₁ [ γC ]) , to/⟦⟧T _ ∘ (e₂ [ γC ]) ⟩)
          (snd ⟨ to/⟦⟧T _ ∘ (e₁ [ γC ]) , to/⟦⟧T _ ∘ (e₂ [ γC ]) ⟩)
    ≈⟨ cong/app (beta/*₁ _ _) (beta/*₂ _ _) ⟩
      app (to/⟦⟧T (_ => _) ∘ (e₁ [ γC ]))
          (to/⟦⟧T _ ∘ (e₂ [ γC ]))
    ≈⟨ refl ⟩
      app (λg (to/⟦⟧T _ ∘ eval′ ∘ (var ⁂ from/⟦⟧T _)) ∘ (e₁ [ γC ]))
          (to/⟦⟧T _ ∘ (e₂ [ γC ]))
    ≈⟨ refl ⟩
      app (curry ((to/⟦⟧T _ ∘ eval′ ∘ (var ⁂ from/⟦⟧T _)) ∘ Prod.repack product product) ∘ (e₁ [ γC ]))
          (to/⟦⟧T _ ∘ (e₂ [ γC ]))
    ≈⟨ refl ⟩
      app (abs (((to/⟦⟧T _ ∘ eval′ ∘ (var ⁂ from/⟦⟧T _)) ∘ Prod.repack product product) [ ext ! (pair (var [ weaken ]) var) ]) ∘ (e₁ [ γC ]))
          (to/⟦⟧T _ ∘ (e₂ [ γC ]))
    ≈⟨ cong/app (cong/sub refl (cong/abs (cong/sub refl (elimʳ η)))) refl ⟩
      app (abs ((to/⟦⟧T _ ∘ eval′ ∘ (var ⁂ from/⟦⟧T _)) [ ext ! (pair (var [ weaken ]) var) ]) ∘ (e₁ [ γC ]))
          (to/⟦⟧T _ ∘ (e₂ [ γC ]))
    ≈⟨ cong/app comm/abs refl ⟩
      app (abs ((to/⟦⟧T _ ∘ eval′ ∘ (var ⁂ from/⟦⟧T _)) [ ext ! (pair (var [ weaken ]) var) ] [ ext ! (e₁ [ γC ]) ×id′ ]))
          (to/⟦⟧T _ ∘ (e₂ [ γC ]))
    ≈⟨ beta/=> _ _ ⟩
      (to/⟦⟧T _ ∘ eval′ ∘ (var ⁂ from/⟦⟧T _)) [ ext ! (pair (var [ weaken ]) var) ] [ ext ! (e₁ [ γC ]) ×id′ ] [ ext _⊨_.id (to/⟦⟧T _ ∘ (e₂ [ γC ])) ]
    ≈⟨ refl ⟩
      (to/⟦⟧T _ ∘ (eval ∘ Prod.repack product product) ∘ (var ⁂ from/⟦⟧T _)) [ ext ! (pair (var [ weaken ]) var) ] [ ext ! (e₁ [ γC ]) ×id′ ] [ ext _⊨_.id (to/⟦⟧T _ ∘ (e₂ [ γC ])) ]
    ≈⟨ cong/sub refl (cong/sub refl (cong/sub refl (∘-resp-≈ʳ (∘-resp-≈ˡ (elimʳ η))))) ⟩
      (to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (var ⁂ from/⟦⟧T _)) [ ext ! (pair (var [ weaken ]) var) ] [ ext ! (e₁ [ γC ]) ×id′ ] [ ext _⊨_.id (to/⟦⟧T _ ∘ (e₂ [ γC ])) ]
    ≈˘⟨ sub/∙ ⟩
      (to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (var ⁂ from/⟦⟧T _)) [ ext ! (pair (var [ weaken ]) var) ] [ ext ! (e₁ [ γC ]) ×id′ ∙ ext _⊨_.id (to/⟦⟧T _ ∘ (e₂ [ γC ])) ]
    ≈⟨ cong/sub (×id′-ext) refl ⟩
      (to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (var ⁂ from/⟦⟧T _)) [ ext ! (pair (var [ weaken ]) var) ] [ ext (ext ! (e₁ [ γC ]) ∙ _⊨_.id) (to/⟦⟧T _ ∘ (e₂ [ γC ])) ]
    ≈⟨ cong/sub (cong/ext id∙ʳ refl) refl ⟩
      (to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (var ⁂ from/⟦⟧T _)) [ ext ! (pair (var [ weaken ]) var) ] [ ext (ext ! (e₁ [ γC ])) (to/⟦⟧T _ ∘ (e₂ [ γC ])) ]
    ≈˘⟨ sub/∙ ⟩
      (to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (var ⁂ from/⟦⟧T _)) [ ext ! (pair (var [ weaken ]) var) ∙ ext (ext ! (e₁ [ γC ])) (to/⟦⟧T _ ∘ (e₂ [ γC ])) ]
    ≈⟨ cong/sub (trans ext∙ (cong/ext (sym !-unique) refl)) refl ⟩
      (to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (var ⁂ from/⟦⟧T _)) ∘ (pair (var [ weaken ]) var [ ext (ext ! (e₁ [ γC ])) (to/⟦⟧T _ ∘ (e₂ [ γC ])) ])
    ≈⟨ ∘-resp-≈ʳ (trans comm/pair (cong/pair (trans (sym sub/∙) (cong/sub weaken/ext refl)) (var/ext _ _))) ⟩
      (to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (var ⁂ from/⟦⟧T _)) ∘ (pair (var [ (ext ! (e₁ [ γC ])) ]) (to/⟦⟧T _ ∘ (e₂ [ γC ])))
    ≈⟨ ∘-resp-≈ʳ (cong/pair (var/ext _ _) refl) ⟩
      (to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (var ⁂ from/⟦⟧T _)) ∘ (pair (e₁ [ γC ]) (to/⟦⟧T _ ∘ (e₂ [ γC ])))
    ≈⟨ pull-last ⁂∘⟨⟩ ⟩
      to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (pair (var ∘ (e₁ [ γC ])) (from/⟦⟧T _ ∘ to/⟦⟧T _ ∘ (e₂ [ γC ])))
    ≈⟨ ∘-resp-≈ʳ (cong/sub (cong/ext refl (cong/pair identityˡ (cancelˡ from∘to))) refl) ⟩
      to/⟦⟧T _ ∘ (app (fst var) (snd var)) ∘ (pair (e₁ [ γC ]) (e₂ [ γC ]))
    ≈⟨ ∘-resp-≈ʳ (trans comm/app (cong/app (trans comm/fst (trans (cong/fst (var/ext _ _)) (beta/*₁ _ _))) (trans comm/snd (trans (cong/snd (var/ext _ _)) (beta/*₂ _ _))))) ⟩
      to/⟦⟧T _ ∘ (app (e₁ [ γC ]) (e₂ [ γC ]))
    ≈˘⟨ ∘-resp-≈ʳ (comm/app) ⟩
      to/⟦⟧T _ ∘ (app e₁ e₂ [ γC ])
    ∎
      where
        curry : _ -> _
        curry e = abs (e [ ext ! (pair (var [ weaken ]) var) ])
  helper {e = e [ γ ]} =
    begin
      ⟦ e ⟧ ∘ ⟦ γ ⟧S
    ≈⟨ pushˡ (helper {e = e}) ⟩
      to/⟦⟧T _ ∘ (e [ γC ]) ∘ ⟦ γ ⟧S
    ≈⟨ refl ⟩
      to/⟦⟧T _ ∘ (e [ γC ] [ ext ! ⟦ γ ⟧S ])
    ≈˘⟨ ∘-resp-≈ʳ sub/∙ ⟩
      to/⟦⟧T _ ∘ (e [ γC ∙ ext ! ⟦ γ ⟧S ])
    ≈⟨ ∘-resp-≈ʳ (cong/sub (helperS {γ = γ}) refl) ⟩
      to/⟦⟧T _ ∘ (e [ γ ∙ γC ])
    ≈⟨ ∘-resp-≈ʳ sub/∙ ⟩
      to/⟦⟧T _ ∘ (e [ γ ] [ γC ])
    ∎

  helperS {γ = id} = trans (trans (cong/∙ refl (cong/ext !-unique refl)) (trans (cong/∙ refl η-pair) id∙ʳ)) (sym id∙ˡ)
  helperS {γ = γ ∙ γ₁} =
    S.begin
      γC ∙ ext ! (⟦ γ ⟧S ∘ ⟦ γ₁ ⟧S)
    S.≈˘⟨ cong/∙ refl (trans ext∙ (cong/ext (sym !-unique) refl)) ⟩
      γC ∙ (ext ! ⟦ γ ⟧S ∙ ext ! ⟦ γ₁ ⟧S)
    S.≈˘⟨ assoc∙ ⟩
      (γC ∙ ext ! ⟦ γ ⟧S) ∙ ext ! ⟦ γ₁ ⟧S
    S.≈⟨ cong/∙ (helperS {γ = γ}) refl ⟩
      (γ ∙ γC) ∙ ext ! ⟦ γ₁ ⟧S
    S.≈⟨ assoc∙ ⟩
      γ ∙ (γC ∙ ext ! ⟦ γ₁ ⟧S)
    S.≈⟨ cong/∙ refl (helperS {γ = γ₁}) ⟩
      γ ∙ (γ₁ ∙ γC)
    S.≈˘⟨ assoc∙ ⟩
      (γ ∙ γ₁) ∙ γC
    S.∎
    where import Relation.Binary.Reasoning.Setoid SubstSetoid as S
  helperS {γ = weaken} = sym weaken/ext
  helperS {γ = ext γ e} =
    S.begin
      γC {_ ∷ _} ∙ (ext ! ⟨ ⟦ γ ⟧S , ⟦ e ⟧ ⟩)
    S.≡⟨⟩
      ext (γC ∙ ext ! π₁) (from/⟦⟧T _ ∘ π₂) ∙ (ext ! ⟨ ⟦ γ ⟧S , ⟦ e ⟧ ⟩)
    S.≈⟨ ext∙ ⟩
      ext ((γC ∙ ext ! π₁) ∙ (ext ! ⟨ ⟦ γ ⟧S , ⟦ e ⟧ ⟩)) ((from/⟦⟧T _ ∘ π₂) ∘ ⟨ ⟦ γ ⟧S , ⟦ e ⟧ ⟩)
    S.≈⟨ cong/ext assoc∙ (pullʳ project₂) ⟩
      ext (γC ∙ (ext ! π₁ ∙ (ext ! ⟨ ⟦ γ ⟧S , ⟦ e ⟧ ⟩))) (from/⟦⟧T _ ∘ ⟦ e ⟧)
    S.≈⟨ cong/ext (cong/∙ refl (trans ext∙ (cong/ext (sym !-unique) refl))) refl ⟩
      ext (γC ∙ (ext ! (π₁ [ ext ! ⟨ ⟦ γ ⟧S , ⟦ e ⟧ ⟩ ]))) (from/⟦⟧T _ ∘ ⟦ e ⟧)
    S.≈⟨ cong/ext (cong/∙ refl (cong/ext refl project₁)) refl ⟩
      ext (γC ∙ ext ! ⟦ γ ⟧S) (from/⟦⟧T _ ∘ ⟦ e ⟧)
    S.≈⟨ cong/ext (helperS {γ = γ}) (sym (switch-tofromˡ Iso/⟦⟧T (sym (helper {e = e})))) ⟩
      ext (γ ∙ γC) (e [ γC ])
    S.≈˘⟨ ext∙ ⟩
      ext γ e ∙ γC
    S.∎
    where import Relation.Binary.Reasoning.Setoid SubstSetoid as S
  helperS {γ = !} = trans (sym !-unique) !-unique

  satisfyAxiom : forall {Γ} {A} {e₁ e₂ : Γ ⊢ A} -> Ax Γ A e₁ e₂ -> ⟦ e₁ ⟧ ≈ ⟦ e₂ ⟧
  satisfyAxiom {Γ} {A} {e₁} {e₂} x = trans (helper {e = e₁}) (trans (∘-resp-≈ʳ a) (sym (helper {e = e₂})))
    where
      a : (e₁ [ γC ]) ≈ (e₂ [ γC ])
      a = cong/sub refl (ax x)

M : Model Cl CC Th
M = S , satisfyAxiom


------------------------------------------------------------------------
-- Forcing of parsers (can be used for inspection/debugging purposes)
------------------------------------------------------------------------

{-# OPTIONS --termination-depth=2 #-}

module TotalParserCombinators.Force where

open import Codata.Musical.Notation
import Data.List.Categorical as ListMonad
open import Data.Maybe hiding (_>>=_)
open import Data.Nat
open import Function
import Relation.Binary.PropositionalEquality as P

open import TotalParserCombinators.Congruence
open import TotalParserCombinators.Laws
open import TotalParserCombinators.Parser

-- force n p returns p, but with the first n layers of delay
-- constructors removed.

force : ∀ {Tok R xs} → ℕ → Parser Tok R xs → Parser Tok R xs
force zero    p                = p
force n       (return x)       = return x
force n       fail             = fail
force n       token            = token
force n       (p₁ ∣ p₂)        = force n p₁ ∣ force n p₂
force n       (f <$> p)        = f <$> force n p
force n       (nonempty p)     = nonempty (force n p)
force n       (cast xs₁≈xs₂ p) = cast xs₁≈xs₂ (force n p)
force (suc n) (p₁ ⊛ p₂)        with forced? p₁ | forced? p₂
... | just xs | nothing = force (suc n)   p₁  ⊛ force      n (♭ p₂)
... | just xs | just fs = force (suc n)   p₁  ⊛ force (suc n)   p₂
... | nothing | nothing = force      n (♭ p₁) ⊛ force      n (♭ p₂)
... | nothing | just fs =
  P.subst (Parser _ _) (ListMonad.Applicative.right-zero fs) $
                          force      n (♭ p₁) ⊛ force (suc n)   p₂
force (suc n) (p₁ >>= p₂)      with forced? p₁ | forced?′ p₂
... | just f  | nothing = force (suc n)   p₁  >>= λ x → force      n (♭ (p₂ x))
... | just f  | just xs = force (suc n)   p₁  >>= λ x → force (suc n)   (p₂ x)
... | nothing | nothing = force      n (♭ p₁) >>= λ x → force      n (♭ (p₂ x))
... | nothing | just xs =
  P.subst (Parser _ _) (ListMonad.MonadProperties.right-zero xs) $
                          force n (♭ p₁) >>= λ x → force (suc n) (p₂ x)

-- force preserves the semantics of its argument.

correct : ∀ {Tok R xs} (n : ℕ) (p : Parser Tok R xs) → force n p ≅P p
correct zero    p                = p ∎
correct (suc n) (return x)       = return x ∎
correct (suc n) fail             = fail ∎
correct (suc n) token            = token ∎
correct (suc n) (p₁ ∣ p₂)        = correct (suc n) p₁ ∣ correct (suc n) p₂
correct (suc n) (f <$> p)        = (λ _ → P.refl) <$> correct (suc n) p
correct (suc n) (nonempty p)     = nonempty (correct (suc n) p)
correct (suc n) (cast xs₁≈xs₂ p) = cast (correct (suc n) p)
correct (suc n) (p₁ ⊛ p₂)        with forced? p₁ | forced? p₂
... | just xs | nothing = [ ○ - ○ - ○ - ◌ ] correct (suc n)   p₁  ⊛ correct      n (♭ p₂)
... | just xs | just fs = [ ○ - ○ - ○ - ○ ] correct (suc n)   p₁  ⊛ correct (suc n)   p₂
... | nothing | nothing = [ ○ - ◌ - ○ - ◌ ] correct      n (♭ p₁) ⊛ correct      n (♭ p₂)
... | nothing | just fs =
  P.subst (Parser _ _) lemma forced  ≅⟨ Subst.correct lemma ⟩
  forced                             ≅⟨ [ ○ - ◌ - ○ - ○ ] correct n (♭ p₁) ⊛ correct (suc n) p₂ ⟩
  p₁ ⊛ p₂                            ∎
  where
  lemma  = ListMonad.Applicative.right-zero fs
  forced = force n (♭ p₁) ⊛ force (suc n) p₂
correct (suc n) (p₁ >>= p₂)      with forced? p₁ | forced?′ p₂
... | just f  | nothing = [ ○ - ○ - ○ - ◌ ] correct (suc n)   p₁  >>= λ x → correct      n (♭ (p₂ x))
... | just f  | just xs = [ ○ - ○ - ○ - ○ ] correct (suc n)   p₁  >>= λ x → correct (suc n)   (p₂ x)
... | nothing | nothing = [ ○ - ◌ - ○ - ◌ ] correct      n (♭ p₁) >>= λ x → correct      n (♭ (p₂ x))
... | nothing | just xs =
  P.subst (Parser _ _) lemma forced  ≅⟨ Subst.correct lemma ⟩
  forced                             ≅⟨ [ ○ - ◌ - ○ - ○ ] correct n (♭ p₁) >>= (λ x → correct (suc n) (p₂ x)) ⟩
  p₁ >>= p₂                          ∎
  where
  forced = force n (♭ p₁) >>= λ x → force (suc n) (p₂ x)
  lemma  = ListMonad.MonadProperties.right-zero xs


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

module Algebra.Construct.Free.Semilattice.Eliminators where

open import Algebra.Construct.Free.Semilattice.Definition
open import Prelude
open import Algebra

record _⇘_ {a p} (A : Type a) (P : 𝒦 A → Type p) : Type (a ℓ⊔ p) where
  no-eta-equality
  constructor elim
  field
    ⟦_⟧-set : ∀ {xs} → isSet (P xs)
    ⟦_⟧[] : P []
    ⟦_⟧_∷_⟨_⟩ : ∀ x xs → P xs → P (x ∷ xs)
  private z = ⟦_⟧[]; f = ⟦_⟧_∷_⟨_⟩
  field
    ⟦_⟧-com : ∀ x y xs pxs →
      f x (y ∷ xs) (f y xs pxs) ≡[ i ≔ P (com x y xs i) ]≡
      f y (x ∷ xs) (f x xs pxs)
    ⟦_⟧-dup : ∀ x xs pxs →
      f x (x ∷ xs) (f x xs pxs) ≡[ i ≔ P (dup x xs i) ]≡
      f x xs pxs
  ⟦_⟧⇓ : ∀ xs → P xs
  ⟦ [] ⟧⇓ = z
  ⟦ x ∷ xs ⟧⇓ = f x xs ⟦ xs ⟧⇓
  ⟦ com x y xs i ⟧⇓ = ⟦_⟧-com x y xs ⟦ xs ⟧⇓  i
  ⟦ dup x xs i ⟧⇓ = ⟦_⟧-dup x xs ⟦ xs ⟧⇓ i
  ⟦ trunc xs ys x y i j ⟧⇓ =
      isOfHLevel→isOfHLevelDep 2
        (λ xs → ⟦_⟧-set {xs})
        ⟦ xs ⟧⇓ ⟦ ys ⟧⇓
        (cong ⟦_⟧⇓ x) (cong ⟦_⟧⇓ y)
        (trunc xs ys x y)
        i j
  {-# INLINE ⟦_⟧⇓ #-}
open _⇘_ public

infixr 0 ⇘-syntax
⇘-syntax = _⇘_
syntax ⇘-syntax A (λ xs → Pxs) = xs ∈𝒦 A ⇒ Pxs

record _⇲_ {a p} (A : Type a) (P : 𝒦 A  → Type p) : Type (a ℓ⊔ p) where
  no-eta-equality
  constructor elim-prop
  field
    ∥_∥-prop : ∀ {xs} → isProp (P xs)
    ∥_∥[] : P []
    ∥_∥_∷_⟨_⟩ : ∀ x xs → P xs → P (x ∷ xs)
  private z = ∥_∥[]; f = ∥_∥_∷_⟨_⟩
  ∥_∥⇑ = elim
          (λ {xs} → isProp→isSet (∥_∥-prop {xs}))
          z f
          (λ x y xs pxs → toPathP (∥_∥-prop (transp (λ i → P (com x y xs i)) i0 (f x (y ∷ xs) (f y xs pxs))) (f y (x ∷ xs) (f x xs pxs))))
          (λ x xs pxs → toPathP (∥_∥-prop (transp (λ i → P (dup x xs i)) i0 (f x (x ∷ xs) (f x xs pxs))) (f x xs pxs) ))
  ∥_∥⇓ = ⟦ ∥_∥⇑ ⟧⇓
  {-# INLINE ∥_∥⇑ #-}
  {-# INLINE ∥_∥⇓ #-}

open _⇲_ public
elim-prop-syntax : ∀ {a p} → (A : Type a) → (𝒦 A → Type p) → Type (a ℓ⊔ p)
elim-prop-syntax = _⇲_

syntax elim-prop-syntax A (λ xs → Pxs) = xs ∈𝒦 A ⇒∥ Pxs ∥

record _↘∥_∥ {a p} (A : Type a) (P : 𝒦 A → Type p) : Type (a ℓ⊔ p) where
  no-eta-equality
  constructor elim-to-prop
  field
    ∣_∣[] : P []
    ∣_∣_∷_⟨_⟩ : ∀ x xs → P xs → P (x ∷ xs)
  private z = ∣_∣[]; f = ∣_∣_∷_⟨_⟩
  open import HITs.PropositionalTruncation.Sugar
  open import HITs.PropositionalTruncation

  ∣_∣⇑ : xs ∈𝒦 A ⇒∥ ∥ P xs ∥ ∥
  ∣_∣⇑ = elim-prop squash ∣ z ∣ λ x xs ∣Pxs∣ → f x xs ∥$∥ ∣Pxs∣
  ∣_∣⇓ = ∥ ∣_∣⇑ ∥⇓

open _↘∥_∥ public
elim-to-prop-syntax : ∀ {a p} → (A : Type a) → (𝒦 A → Type p) → Type (a ℓ⊔ p)
elim-to-prop-syntax = _↘∥_∥

syntax elim-to-prop-syntax A (λ xs → Pxs) = xs ∈𝒦 A ⇒∣ Pxs ∣

infixr 0 _↘_
record _↘_ {a b} (A : Type a) (B : Type b) : Type (a ℓ⊔ b) where
  no-eta-equality
  constructor rec
  field
    [_]-set  : isSet B
    [_]_∷_   : A → B → B
    [_][]    : B
  private f = [_]_∷_; z = [_][]
  field
    [_]-dup  : ∀ x xs → f x (f x xs) ≡ f x xs
    [_]-com : ∀ x y xs → f x (f y xs) ≡ f y (f x xs)
  [_]↑ = elim
            [_]-set
            z
            (λ x _ xs → f x xs)
            (λ x y xs → [_]-com x y)
            (λ x xs → [_]-dup x)
  [_]↓ = ⟦ [_]↑ ⟧⇓
  {-# INLINE [_]↑ #-}
  {-# INLINE [_]↓ #-}
open _↘_ public

module _ {a p} {A : Type a} {P : 𝒦 A → Type p} where
    𝒦-elim-prop : (∀ {xs} → isProp (P xs)) →
                  (∀ x xs → P xs → P (x ∷ xs)) →
                  (P []) →
                  ∀ xs → P xs
    𝒦-elim-prop isPropB f n = go
      where
      go : ∀ xs → P xs
      go [] = n
      go (x ∷ xs) = f x xs (go xs)
      go (com x y xs j) = toPathP {A = λ i → P (com x y xs i)} (isPropB (transp (λ i → P (com x y xs i)) i0 (f x (y ∷ xs) (f y xs (go xs)))) (f y (x ∷ xs) (f x xs (go xs)))) j
      go (dup x xs j) = toPathP {A = λ i → P (dup x xs i)} (isPropB (transp (λ i → P (dup x xs i)) i0 (f x (x ∷ xs) (f x xs (go xs)))) (f x xs (go xs)) ) j
      go (trunc xs ys x y i j) =
        isOfHLevel→isOfHLevelDep 2
          (λ xs → isProp→isSet (isPropB {xs}))
          (go xs) (go ys)
          (cong go x) (cong go y)
          (trunc xs ys x y)
          i j

module _ {a b} {A : Type a} {B : Type b} where
  𝒦-rec : isSet B →
          (f : A → B → B) →
          (n : B) →
          (fdup : ∀ x xs → f x (f x xs) ≡ f x xs) →
          (fcom : ∀ x y xs → f x (f y xs) ≡ f y (f x xs)) →
          𝒦 A →
          B
  𝒦-rec isSetB f n fdup fcom = go
    where
    go : 𝒦 A → B
    go [] = n
    go (x ∷ xs) = f x (go xs)
    go (com x y xs i) = fcom x y (go xs) i
    go (dup x xs i) = fdup x (go xs) i
    go (trunc xs ys x y i j) =
      isOfHLevel→isOfHLevelDep 2
        (λ xs → isSetB)
        (go xs) (go ys)
        (cong go x) (cong go y)
        (trunc xs ys x y)
        i j


------------------------------------------------------------------------
-- The Agda standard library
--
-- Empty type
------------------------------------------------------------------------

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

module Data.Empty where

open import Level

data ⊥ : Set where

⊥-elim : ∀ {w} {Whatever : Set w} → ⊥ → Whatever
⊥-elim ()


{-# OPTIONS --without-K #-}
open import HoTT.Base
open import HoTT.Equivalence

module HoTT.Equivalence.Lift where

open variables

Lift-equiv : Lift {i} A ≃ A
Lift-equiv = iso→eqv λ{.f → lower ; .g → lift ; .η _ → refl ; .ε _ → refl}
  where open Iso


open import MLib.Algebra.PropertyCode
open import MLib.Algebra.PropertyCode.Structures

module MLib.Matrix.SemiTensor.GeneralizesMul {c ℓ} (struct : Struct bimonoidCode c ℓ) where

open import MLib.Prelude
open import MLib.Matrix.Core
open import MLib.Matrix.Equality struct
open import MLib.Matrix.Mul struct
open import MLib.Matrix.Tensor struct
open import MLib.Matrix.SemiTensor.Core struct
open import MLib.Algebra.Operations struct

open Nat using () renaming (_+_ to _+ℕ_; _*_ to _*ℕ_)

open import MLib.Fin.Parts.Simple

open import Data.Nat.LCM
open import Data.Nat.Divisibility

-- Semi-tensor product generalizes the usual matrix product

module _ ⦃ props : Has (1# is rightIdentity for * ∷ []) ⦄ where
  generalizes-⊗ : ∀ {m n o} (A : Matrix S m n) (B : Matrix S n o) → A ⋉ B ≃ A ⊗ B

  open _≃_

  module Zero {m o} (A : Matrix S m 0) (B : Matrix S 0 o) where
    generalizes-⊗′ : A ⋉ B ≃ A ⊗ B
    generalizes-⊗′ .m≡p = Nat.*-identityʳ m
    generalizes-⊗′ .n≡q = Nat.*-identityʳ o
    generalizes-⊗′ .equal _ _ = S.refl

  module Nonzero {m n o} (A : Matrix S m (suc n)) (B : Matrix S (suc n) o) where
    private
      t = lcm (suc n) (suc n) .proj₁
      t-lcm = lcm (suc n) (suc n) .proj₂

      open Defn t-lcm renaming (n∣t to sn∣t; t/n to t/sn; p∣t to sn∣t′; t/p to t/sn′)

      A′′-lem : A′′ A B ≃ A
      B′′-lem : B′′ A B ≃ B

    generalizes-⊗′ : A ⋉ B ≃ A ⊗ B
    generalizes-⊗′ = ⊗-cong-≃ _ _ _ _ A′′-lem B′′-lem

    private
      abstract
        lcm-n-n : ∀ {n t} → LCM n n t → t ≡ n
        lcm-n-n {n} isLcm =
          let t∣n = LCM.least isLcm (∣-refl , ∣-refl)
              n∣t = LCM.commonMultiple isLcm .proj₁
          in ∣-antisym t∣n n∣t

        quotient-n-n : ∀ {n} (p : suc n ∣ suc n) → quotient p ≡ 1
        quotient-n-n (divides q equality) = Nat.*-cancelʳ-≡ q 1 (≡.sym (≡.trans (≡.cong suc (Nat.+-identityʳ _)) equality))

        quotient-subst : ∀ {n p q} (n∣p : n ∣ p) (p≡q : p ≡ q) → quotient n∣p ≡ quotient (≡.subst (λ h → n ∣ h) p≡q n∣p)
        quotient-subst n∣p ≡.refl = ≡.refl

        t≡sn : t ≡ suc n
        t≡sn = lcm-n-n t-lcm

        t/sn≡1 : t/sn ≡ 1
        t/sn≡1 =
          begin
            t/sn ≡⟨ quotient-subst sn∣t t≡sn ⟩
            quotient (≡.subst (λ h → suc n ∣ h) t≡sn sn∣t) ≡⟨ quotient-n-n (≡.subst (λ h → suc n ∣ h) t≡sn sn∣t) ⟩
            1 ∎
          where open ≡.Reasoning

        t/sn′≡1 : t/sn′ ≡ 1
        t/sn′≡1 =
          begin
            t/sn′ ≡⟨ quotient-subst sn∣t′ t≡sn ⟩
            quotient (≡.subst (λ h → suc n ∣ h) t≡sn sn∣t′) ≡⟨ quotient-n-n (≡.subst (λ h → suc n ∣ h) t≡sn sn∣t′) ⟩
            1 ∎
          where open ≡.Reasoning

        lhs≡m : m *ℕ t/sn ≡ m
        lhs≡m =
          begin
            m *ℕ t/sn ≡⟨ ≡.cong₂ _*ℕ_ (≡.refl {x = m}) t/sn≡1 ⟩
            m *ℕ 1 ≡⟨ Nat.*-identityʳ _ ⟩
            m ∎
          where open ≡.Reasoning

        rhs≡o : o *ℕ t/sn′ ≡ o
        rhs≡o =
          begin
            o *ℕ t/sn′ ≡⟨ ≡.cong₂ _*ℕ_ (≡.refl {x = o}) t/sn′≡1 ⟩
            o *ℕ 1 ≡⟨ Nat.*-identityʳ _ ⟩
            o ∎
          where open ≡.Reasoning

      A′′-lem = ≃-trans (≡-subst-≃₂ lem₁) (≃-trans (⊠-cong (≃-refl {A = A}) (1●-cong-≃ t/sn≡1)) (⊠-identityʳ ⦃ weaken props ⦄ A))
      B′′-lem = ≃-trans (≡-subst-≃₁ lem₂) (≃-trans (⊠-cong (≃-refl {A = B}) (1●-cong-≃ t/sn′≡1)) (⊠-identityʳ ⦃ weaken props ⦄ B))

  generalizes-⊗ {n = zero} = Zero.generalizes-⊗′
  generalizes-⊗ {n = suc n} = Nonzero.generalizes-⊗′


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of operations on characters
------------------------------------------------------------------------

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

module Data.Char.Properties where

open import Data.Bool using (Bool)
open import Data.Char.Base

import Data.Nat.Properties as ℕₚ

open import Function
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (map′;  ⌊_⌋)
open import Relation.Binary using (Decidable; Setoid; DecSetoid; StrictTotalOrder)
open import Relation.Binary.PropositionalEquality.Core
import Relation.Binary.Construct.On as On
import Relation.Binary.PropositionalEquality as PropEq

------------------------------------------------------------------------
-- Primitive properties

open import Agda.Builtin.Char.Properties
  renaming ( primCharToNatInjective to toNat-injective)
  public

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

infix 4 _≟_
_≟_ : Decidable {A = Char} _≡_
x ≟ y = map′ (toNat-injective x y) (cong toNat)
      $ toNat x ℕₚ.≟ toNat y

------------------------------------------------------------------------
-- Boolean equality test.
--
-- Why is the definition _==_ = primCharEquality not used? One reason
-- is that the present definition can sometimes improve type
-- inference, at least with the version of Agda that is current at the
-- time of writing: see unit-test below.

infix 4 _==_
_==_ : Char → Char → Bool
c₁ == c₂ = ⌊ c₁ ≟ c₂ ⌋

private

  -- The following unit test does not type-check (at the time of
  -- writing) if _==_ is replaced by primCharEquality.

  data P : (Char → Bool) → Set where
    p : (c : Char) → P (c ==_)

  unit-test : P ('x' ==_)
  unit-test = p _

------------------------------------------------------------------------
-- Structures

setoid : Setoid _ _
setoid = PropEq.setoid Char

decSetoid : DecSetoid _ _
decSetoid = PropEq.decSetoid _≟_

strictTotalOrder : StrictTotalOrder _ _ _
strictTotalOrder = On.strictTotalOrder ℕₚ.<-strictTotalOrder toNat


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.SetTruncation where

open import Cubical.HITs.SetTruncation.Base public
open import Cubical.HITs.SetTruncation.Properties public


open import Agda.Builtin.Bool

test : (true : Bool) → Set
test = {!!}  -- C-c C-c


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

module Cubical.Categories.NaturalTransformation.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism renaming (iso to iIso)
open import Cubical.Data.Sigma
open import Cubical.Categories.Category
open import Cubical.Categories.Functor.Base
open import Cubical.Categories.Morphism renaming (isIso to isIsoC)
open import Cubical.Categories.NaturalTransformation.Base

private
  variable
    ℓC ℓC' ℓD ℓD' : Level

open isIsoC
open NatIso
open NatTrans
open Precategory
open Functor

module _ {C : Precategory ℓC ℓC'} {D : Precategory ℓD ℓD'} where
  private
    _⋆ᴰ_ : ∀ {x y z} (f : D [ x , y ]) (g : D [ y , z ]) → D [ x , z ]
    f ⋆ᴰ g = f ⋆⟨ D ⟩ g

  -- natural isomorphism is symmetric
  symNatIso : ∀ {F G : Functor C D}
            → F ≅ᶜ G
            → G ≅ᶜ F
  symNatIso η .trans .N-ob x = η .nIso x .inv
  symNatIso η .trans .N-hom _ = sqLL η
  symNatIso η .nIso x .inv = η .trans .N-ob x
  symNatIso η .nIso x .sec = η .nIso x .ret
  symNatIso η .nIso x .ret = η .nIso x .sec

  -- Properties

  -- path helpers
  module NatTransP where

    module _ {F G : Functor C D} where
      open Iso

      -- same as Sigma version
      NatTransΣ = Σ[ ob ∈ ((x : C .ob) → D [(F .F-ob x) , (G .F-ob x)]) ]
                     ({x y : _ } (f : C [ x , y ]) → (F .F-hom f) ⋆ᴰ (ob y) ≡ (ob x) ⋆ᴰ (G .F-hom f))

      NatTransIsoΣ : Iso (NatTrans F G) NatTransΣ
      NatTransIsoΣ .fun (natTrans N-ob N-hom) = N-ob , N-hom
      NatTransIsoΣ .inv (N-ob , N-hom) = (natTrans N-ob N-hom)
      NatTransIsoΣ .rightInv _ = refl
      NatTransIsoΣ .leftInv _ = refl

      NatTrans≡Σ = ua (isoToEquiv NatTransIsoΣ)

      -- introducing paths
      NatTrans-≡-intro : ∀ {αo βo : N-ob-Type F G}
                           {αh : N-hom-Type F G αo}
                           {βh : N-hom-Type F G βo}
                       → (p : αo ≡ βo)
                       → PathP (λ i → ({x y : C .ob} (f : C [ x , y ]) → (F .F-hom f) ⋆ᴰ (p i y) ≡ (p i x) ⋆ᴰ (G .F-hom f))) αh βh
                       → natTrans {F = F} {G} αo αh ≡ natTrans βo βh
      NatTrans-≡-intro p q i = natTrans (p i) (q i)
    module _ {F G : Functor C D} {α β : NatTrans F G} where
      open Iso
      private
        αOb = α .N-ob
        βOb = β .N-ob
        αHom = α .N-hom
        βHom = β .N-hom
      -- path between natural transformations is the same as a pair of paths (between ob and hom)
      NTPathIsoPathΣ : Iso (α ≡ β)
                         (Σ[ p ∈ (αOb ≡ βOb) ]
                              (PathP (λ i → ({x y : _} (f : _) → F ⟪ f ⟫ ⋆ᴰ (p i y) ≡ (p i x) ⋆ᴰ G ⟪ f ⟫))
                                  αHom
                                  βHom))
      NTPathIsoPathΣ .fun p = (λ i → p i .N-ob) , (λ i → p i .N-hom)
      NTPathIsoPathΣ .inv (po , ph) i = record { N-ob = po i ; N-hom = ph i }
      NTPathIsoPathΣ .rightInv pσ = refl
      NTPathIsoPathΣ .leftInv p = refl

      NTPath≃PathΣ = isoToEquiv NTPathIsoPathΣ

      NTPath≡PathΣ = ua NTPath≃PathΣ

  module _ ⦃ isCatD : isCategory D ⦄ where
    open NatTransP

    -- if the target category has hom Sets, then any natural transformation is a set
    isSetNat : ∀ {F G : Functor C D}
             → isSet (NatTrans F G)
    isSetNat {F} {G} α β p1 p2 i = comp (λ i → NTPath≡PathΣ {F = F} {G} {α} {β} (~ i))
                                        (λ j → λ {(i = i0) → transport-filler NTPath≡PathΣ p1 (~ j) ;
                                                  (i = i1) → transport-filler NTPath≡PathΣ p2 (~ j)})
                                        (p1Σ≡p2Σ i)
      where
        αOb = α .N-ob
        βOb = β .N-ob
        αHom = α .N-hom
        βHom = β .N-hom

        -- convert to sigmas so we can reason about constituent paths separately
        p1Σ : Σ[ p ∈ (αOb ≡ βOb) ]
                (PathP (λ i → ({x y : _} (f : _) → F ⟪ f ⟫ ⋆ᴰ (p i y) ≡ (p i x) ⋆ᴰ G ⟪ f ⟫))
                      αHom
                      βHom)
        p1Σ = transport NTPath≡PathΣ p1

        p2Σ : Σ[ p ∈ (αOb ≡ βOb) ]
                (PathP (λ i → ({x y : _} (f : _) → F ⟪ f ⟫ ⋆ᴰ (p i y) ≡ (p i x) ⋆ᴰ G ⟪ f ⟫))
                       αHom
                       βHom)
        p2Σ = transport NTPath≡PathΣ p2

        -- type aliases
        typeN-ob = (x : C .ob) → D [(F .F-ob x) , (G .F-ob x)]
        typeN-hom : typeN-ob → Type _
        typeN-hom ϕ = {x y : C .ob} (f : C [ x , y ]) → (F .F-hom f) ⋆ᴰ (ϕ y) ≡ (ϕ x) ⋆ᴰ (G .F-hom f)

        -- the Ob function is a set
        isSetN-ob : isSet ((x : C .ob) → D [(F .F-ob x) , (G .F-ob x)])
        isSetN-ob = isOfHLevelΠ 2 λ _ → isCatD .isSetHom

        -- the Hom function is a set
        isSetN-hom : (ϕ : typeN-ob) → isSet (typeN-hom ϕ)
        isSetN-hom γ = isProp→isSet (isPropImplicitΠ λ x → isPropImplicitΠ λ y → isPropΠ λ f → isCatD .isSetHom _ _)

        -- in fact it's a dependent Set, which we need because N-hom depends on N-ob
        isSetN-homP : isOfHLevelDep 2 (λ γ → {x y : C .ob} (f : C [ x , y ]) → (F .F-hom f) ⋆ᴰ (γ y) ≡ (γ x) ⋆ᴰ (G .F-hom f))
        isSetN-homP = isOfHLevel→isOfHLevelDep 2 isSetN-hom

        -- components of the equality
        p1Ob≡p2Ob : fst p1Σ ≡ fst p2Σ
        p1Ob≡p2Ob = isSetN-ob _ _ (fst p1Σ) (fst p2Σ)

        p1Hom≡p2Hom : PathP (λ i → PathP (λ j → typeN-hom (p1Ob≡p2Ob i j)) αHom βHom)
                            (snd p1Σ) (snd p2Σ)
        p1Hom≡p2Hom = isSetN-homP _ _ (snd p1Σ) (snd p2Σ) p1Ob≡p2Ob

        p1Σ≡p2Σ : p1Σ ≡ p2Σ
        p1Σ≡p2Σ = ΣPathP (p1Ob≡p2Ob , p1Hom≡p2Hom)


open import Agda.Builtin.Bool

f : Bool → Bool
f x = let y = x in {!!}