module Structure.Sets.Operator where

open import Data.Boolean
open import Data.Boolean.Stmt
open import Functional
import      Lvl
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Function
open import Structure.Relator
open import Structure.Setoid using (Equiv) renaming (_≡_ to _≡ₛ_ ; _≢_ to _≢ₛ_)
import      Structure.Sets.Names as Names
open import Structure.Sets.Relator using (SubsetRelation)
open import Type

private variable ℓ ℓₗ ℓₗ₁ ℓₗ₂ ℓᵣ ℓᵣₑₗ ℓₒ ℓₛ : Lvl.Level
private variable A B C S S₁ S₂ Sₒ Sᵢ Sₗ Sᵣ E E₁ E₂ Eₗ Eᵣ I O : Type{ℓ}
private variable _∈_ _∈ₒ_ _∈ᵢ_ : E → S → Stmt{ℓₗ}
private variable _∈ₗ_ : E → Sₗ → Stmt{ℓₗ}
private variable _∈ᵣ_ : E → Sᵣ → Stmt{ℓᵣ}
private variable _⊆_ : Sₗ → Sᵣ → Stmt{ℓᵣ}

private variable ⦃ equiv-I ⦄ : Equiv{ℓₗ}(I)
private variable ⦃ equiv-E ⦄ : Equiv{ℓₗ}(E)
private variable ⦃ equiv-Eₗ ⦄ : Equiv{ℓₗ}(Eₗ)
private variable ⦃ equiv-Eᵣ ⦄ : Equiv{ℓₗ}(Eᵣ)
private variable ⦃ equiv-O ⦄ : Equiv{ℓₗ}(O)
private variable ⦃ sub ⦄ : SubsetRelation(_∈ₗ_)(_∈ᵣ_)(_⊆_)

module _ (_∈_ : E → S → Stmt{ℓₗ}) where
  record EmptySet(∅ : S) : Type{Lvl.of(E) Lvl.⊔ ℓₗ} where
    constructor intro
    field membership : Names.EmptyMembership(_∈_)(∅)

  record UniversalSet(𝐔 : S) : Type{Lvl.of(E) Lvl.⊔ ℓₗ} where
    constructor intro
    field membership : Names.UniversalMembership(_∈_)(𝐔)

  module _ ⦃ equiv-I : Equiv{ℓₗ₁}(I) ⦄ ⦃ equiv-E : Equiv{ℓₗ₂}(E) ⦄ where
    record ImageFunction(⊶ : (f : I → E) → ⦃ func : Function(f) ⦄ → S) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(I) Lvl.⊔ ℓₗ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
      constructor intro
      field membership : Names.ImageMembership(_∈_)(⊶)

  module _ ⦃ equiv-E : Equiv{ℓₗ₁}(E) ⦄ {O : Type{ℓ}} ⦃ equiv-O : Equiv{ℓₗ₂}(O) ⦄ where
    record FiberFunction(fiber : (f : E → O) → ⦃ func : Function(f) ⦄ → (O → S)) : Type{Lvl.of(E) Lvl.⊔ ℓ Lvl.⊔ ℓₗ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
      constructor intro
      field membership : Names.FiberMembership(_∈_)(fiber)

  module _ ⦃ equiv-E : Equiv{ℓₗ}(E) ⦄ where
    record SingletonFunction(singleton : E → S) : Type{Lvl.of(E) Lvl.⊔ ℓₗ} where
      constructor intro
      field membership : Names.SingletonMembership(_∈_)(singleton)

    record PairFunction(pair : E → E → S) : Type{Lvl.of(E) Lvl.⊔ ℓₗ} where
      constructor intro
      field membership : Names.PairMembership(_∈_)(pair)

    record ComprehensionFunction(comp : (P : E → Stmt{ℓ}) ⦃ unaryRelator : UnaryRelator(P) ⦄ → S) : Type{Lvl.of(E) Lvl.⊔ ℓₗ Lvl.⊔ Lvl.𝐒(ℓ)} where
      constructor intro
      field membership : Names.ComprehensionMembership(_∈_)(comp)

module _ (_∈ₗ_ : E → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : E → Sᵣ → Stmt{ℓᵣ}) where
  record ComplementOperator(∁ : Sₗ → Sᵣ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ} where
    constructor intro
    field membership : Names.ComplementMembership(_∈ₗ_)(_∈ᵣ_)(∁)

  module _ ⦃ equiv-E : Equiv{ℓₗ}(E) ⦄ where
    record AddOperator(add : E → Sₗ → Sᵣ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ} where
      constructor intro
      field membership : Names.AddMembership(_∈ₗ_)(_∈ᵣ_)(add)

    record RemoveOperator(remove : E → Sₗ → Sᵣ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ} where
      constructor intro
      field membership : Names.RemoveMembership(_∈ₗ_)(_∈ᵣ_)(remove)

    record FilterFunction(filter : (P : E → Stmt{ℓ}) ⦃ unaryRelator : UnaryRelator(P) ⦄ → (Sₗ → Sᵣ)) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ Lvl.𝐒(ℓ)} where
      constructor intro
      field membership : Names.FilterMembership(_∈ₗ_)(_∈ᵣ_)(filter)

  record BooleanFilterFunction(boolFilter : (E → Bool) → (Sₗ → Sᵣ)) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ} where
    constructor intro
    field membership : Names.BooleanFilterMembership(_∈ₗ_)(_∈ᵣ_)(boolFilter)

  record IndexedBigUnionOperator(⋃ᵢ : (I → Sₗ) → Sᵣ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ Lvl.of(I)} where
    constructor intro
    field membership : Names.IndexedBigUnionMembership(_∈ₗ_)(_∈ᵣ_)(⋃ᵢ)

  record IndexedBigIntersectionOperator(⋂ᵢ : (I → Sₗ) → Sᵣ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ Lvl.of(I)} where
    constructor intro
    field membership : Names.IndexedBigIntersectionMembership(_∈ₗ_)(_∈ᵣ_)(⋂ᵢ)

module _ (_∈ₗ_ : Eₗ → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : Eᵣ → Sᵣ → Stmt{ℓᵣ}) where
  module _ ⦃ equiv-Eₗ : Equiv{ℓₗ₁}(Eₗ) ⦄ ⦃ equiv-Eᵣ : Equiv{ℓₗ₂}(Eᵣ) ⦄ where
    record MapFunction(map : (f : Eₗ → Eᵣ) ⦃ func : Function(f) ⦄ → (Sₗ → Sᵣ)) : Type{Lvl.of(Eₗ) Lvl.⊔ Lvl.of(Eᵣ) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
      constructor intro
      field membership : Names.MapMembership(_∈ₗ_)(_∈ᵣ_)(map)

    record UnmapFunction(unmap : (f : Eₗ → Eᵣ) ⦃ func : Function(f) ⦄ → (Sᵣ → Sₗ)) : Type{Lvl.of(Eₗ) Lvl.⊔ Lvl.of(Eᵣ) Lvl.⊔ Lvl.of(Sᵣ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
      constructor intro
      field membership : Names.UnmapMembership(_∈ₗ_)(_∈ᵣ_)(unmap)

module _ (_∈ₗ_ : E → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : E → Sᵣ → Stmt{ℓᵣ}) (_∈ₒ_ : E → Sₒ → Stmt{ℓₒ}) where
  record UnionOperator(_∪_ : Sₗ → Sᵣ → Sₒ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ Lvl.of(Sᵣ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ ℓₒ} where
    constructor intro
    field membership : Names.UnionMembership(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)(_∪_)

  record IntersectionOperator(_∩_ : Sₗ → Sᵣ → Sₒ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ Lvl.of(Sᵣ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ ℓₒ} where
    constructor intro
    field membership : Names.IntersectMembership(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)(_∩_)

  record WithoutOperator(_∖_ : Sₗ → Sᵣ → Sₒ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ Lvl.of(Sᵣ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ ℓₒ} where
    constructor intro
    field membership : Names.WithoutMembership(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)(_∖_)

module _ (_∈ₗ_ : E → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : E → Sᵣ → Stmt{ℓᵣ}) (_∈ₒ_ : Sₗ → Sₒ → Stmt{ℓₒ}) {_⊆_ : Sₗ → Sᵣ → Stmt{ℓₛ}} ⦃ sub : SubsetRelation(_∈ₗ_)(_∈ᵣ_)(_⊆_) ⦄ where
  record PowerFunction(℘ : Sᵣ → Sₒ) : Type{Lvl.of(Sₗ) Lvl.⊔ Lvl.of(Sᵣ) Lvl.⊔ ℓₛ Lvl.⊔ ℓₒ} where
    constructor intro
    field membership : Names.PowerMembership(_∈ₒ_)(_⊆_)(℘)

module _ (_∈ₗ_ : E → Sₗ → Stmt{ℓₗ}) (_∈ᵣ_ : Sₗ → Sᵣ → Stmt{ℓᵣ}) (_∈ₒ_ : E → Sₒ → Stmt{ℓₒ}) where
  record BigUnionOperator(⋃ : Sᵣ → Sₒ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ Lvl.of(Sᵣ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ ℓₒ} where
    constructor intro
    field membership : Names.BigUnionMembership(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)(⋃)

  record BigIntersectionOperator(⋂ : Sᵣ → Sₒ) : Type{Lvl.of(E) Lvl.⊔ Lvl.of(Sₗ) Lvl.⊔ Lvl.of(Sᵣ) Lvl.⊔ ℓₗ Lvl.⊔ ℓᵣ Lvl.⊔ ℓₒ} where
    constructor intro
    field membership : Names.BigIntersectionMembership(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)(⋂)

module _ ⦃ p : ∃(EmptySet(_∈_)) ⦄ where
  open ∃(p) using () renaming (witness to ∅) public
  open EmptySet([∃]-proof p) using () renaming (membership to [∅]-membership) public

module _ ⦃ p : ∃(UniversalSet(_∈_)) ⦄ where
  open ∃(p) using () renaming (witness to 𝐔) public
  open UniversalSet([∃]-proof p) using () renaming (membership to [𝐔]-membership) public

module _ ⦃ p : ∃(ImageFunction(_∈_) ⦃ equiv-I ⦄ ⦃ equiv-E ⦄) ⦄ where
  open ∃(p) using () renaming (witness to ⊶) public
  open ImageFunction([∃]-proof p) using () renaming (membership to [⊶]-membership) public

module _ ⦃ p : ∃(FiberFunction(_∈_) ⦃ equiv-E ⦄ ⦃ equiv-O ⦄) ⦄ where
  open ∃(p) using () renaming (witness to fiber) public
  open FiberFunction([∃]-proof p) using () renaming (membership to Fiber-membership) public

module _ ⦃ p : ∃(SingletonFunction(_∈_) ⦃ equiv-E ⦄) ⦄ where
  open ∃(p) using () renaming (witness to singleton) public
  open SingletonFunction([∃]-proof p) using () renaming (membership to Singleton-membership) public

module _ ⦃ p : ∃(PairFunction(_∈_) ⦃ equiv-E ⦄) ⦄ where
  open ∃(p) using () renaming (witness to pair) public
  open PairFunction([∃]-proof p) using () renaming (membership to Pair-membership) public

module _ ⦃ p : ∃(ComplementOperator(_∈ₗ_)(_∈ᵣ_)) ⦄ where
  open ∃(p) using () renaming (witness to ∁) public
  open ComplementOperator([∃]-proof p) using () renaming (membership to [∁]-membership) public

module _ ⦃ p : ∃(AddOperator(_∈ₗ_)(_∈ᵣ_) ⦃ equiv-E ⦄) ⦄ where
  open ∃(p) using () renaming (witness to add) public
  open AddOperator([∃]-proof p) using () renaming (membership to Add-membership) public

module _ ⦃ p : ∃(RemoveOperator(_∈ₗ_)(_∈ᵣ_) ⦃ equiv-E ⦄) ⦄ where
  open ∃(p) using () renaming (witness to remove) public
  open RemoveOperator([∃]-proof p) using () renaming (membership to Remove-membership) public

module _ ⦃ p : ∃(FilterFunction(_∈ₗ_)(_∈ᵣ_) ⦃ equiv-E ⦄ {ℓ}) ⦄ where
  open ∃(p) using () renaming (witness to filter) public
  open FilterFunction([∃]-proof p) using () renaming (membership to Filter-membership) public

module _ ⦃ p : ∃(BooleanFilterFunction(_∈ₗ_)(_∈ᵣ_)) ⦄ where
  open ∃(p) using () renaming (witness to boolFilter) public
  open BooleanFilterFunction([∃]-proof p) using () renaming (membership to BooleanFilter-membership) public

module _ ⦃ p : ∃(IndexedBigUnionOperator(_∈ₗ_)(_∈ᵣ_) {I = I}) ⦄ where
  open ∃(p) using () renaming (witness to ⋃ᵢ) public
  open IndexedBigUnionOperator([∃]-proof p) using () renaming (membership to [⋃ᵢ]-membership) public

module _ ⦃ p : ∃(IndexedBigIntersectionOperator(_∈ₗ_)(_∈ᵣ_) {I = I}) ⦄ where
  open ∃(p) using () renaming (witness to ⋂ᵢ) public
  open IndexedBigIntersectionOperator([∃]-proof p) using () renaming (membership to [⋂ᵢ]-membership) public

module _ ⦃ p : ∃(MapFunction(_∈ₗ_)(_∈ᵣ_) ⦃ equiv-Eₗ ⦄ ⦃ equiv-Eᵣ ⦄) ⦄ where
  open ∃(p) using () renaming (witness to map) public
  open MapFunction([∃]-proof p) using () renaming (membership to Map-membership) public

module _ ⦃ p : ∃(UnmapFunction(_∈ₗ_)(_∈ᵣ_) ⦃ equiv-Eₗ ⦄ ⦃ equiv-Eᵣ ⦄) ⦄ where
  open ∃(p) using () renaming (witness to unmap) public
  open UnmapFunction([∃]-proof p) using () renaming (membership to Unmap-membership) public

module _ ⦃ p : ∃(UnionOperator(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)) ⦄ where
  open ∃(p) using () renaming (witness to _∪_) public
  open UnionOperator([∃]-proof p) using () renaming (membership to [∪]-membership) public

module _ ⦃ p : ∃(IntersectionOperator(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)) ⦄ where
  open ∃(p) using () renaming (witness to _∩_) public
  open IntersectionOperator([∃]-proof p) using () renaming (membership to [∩]-membership) public

module _ ⦃ p : ∃(WithoutOperator(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)) ⦄ where
  open ∃(p) using () renaming (witness to _∖_) public
  open WithoutOperator([∃]-proof p) using () renaming (membership to [∖]-membership) public

module _ ⦃ p : ∃(PowerFunction(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_) ⦃ sub ⦄) ⦄ where
  open ∃(p) using () renaming (witness to ℘) public
  open PowerFunction([∃]-proof p) using () renaming (membership to [℘]-membership) public

module _ ⦃ p : ∃(BigUnionOperator(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)) ⦄ where
  open ∃(p) using () renaming (witness to ⋃) public
  open BigUnionOperator([∃]-proof p) using () renaming (membership to [⋃]-membership) public

module _ ⦃ p : ∃(BigIntersectionOperator(_∈ₗ_)(_∈ᵣ_)(_∈ₒ_)) ⦄ where
  open ∃(p) using () renaming (witness to ⋂) public
  open BigIntersectionOperator([∃]-proof p) using () renaming (membership to [⋂]-membership) public


module Cats.Category.Cat.Facts.Exponential where

open import Data.Product using (_,_)
open import Level using (_⊔_)
open import Relation.Binary using (IsEquivalence)

open import Cats.Bifunctor using
  (Bifunctor ; Bifunctor→Functor₁ ; transposeBifunctor₁ ; transposeBifunctor₁-resp)
open import Cats.Category
open import Cats.Category.Cat as Cat using
  (Cat ; Functor ; _∘_ ; _≈_) renaming
  (id to Id)
open import Cats.Category.Cat.Facts.Product using (hasBinaryProducts ; ⟨_×_⟩)
open import Cats.Category.Fun using (Fun ; Trans ; ≈-intro ; ≈-elim)
open import Cats.Category.Fun.Facts using (NatIso→≅)
open import Cats.Category.Product.Binary using (_×_)
open import Cats.Trans.Iso as NatIso using (NatIso)
open import Cats.Util.Conv
open import Cats.Util.Simp using (simp!)

import Cats.Category.Base as Base
import Cats.Category.Constructions.Unique as Unique
import Cats.Category.Constructions.Iso as Iso

open Functor
open Trans
open Iso.Build._≅_

infixr 1 _↝_

_↝_ : ∀ {lo la l≈ lo′ la′ l≈′}
  → Category lo la l≈
  → Category lo′ la′ l≈′
  → Category (lo ⊔ la ⊔ l≈ ⊔ lo′ ⊔ la′ ⊔ l≈′) (lo ⊔ la ⊔ la′ ⊔ l≈′) (lo ⊔ l≈′)
_↝_ = Fun

module _ {lo la l≈ lo′ la′ l≈′}
  {B : Category lo la l≈} {C : Category lo′ la′ l≈′}
  where

  private
    module B = Category B
    module C = Category C
    module B↝C = Category (Fun B C)

  Eval : Bifunctor (B ↝ C) B C
  Eval = record
      { fobj = λ where
          (F , x) → fobj F x
      ; fmap = λ where
          {F , a} {G , b} (θ , f) → fmap G f C.∘ component θ a
      ; fmap-resp = λ where
          {F , a} {G , b} {θ , f} {ι , g} (θ≈ι , f≈g) →
            C.∘-resp (fmap-resp G f≈g) (≈-elim θ≈ι)
      ; fmap-id = λ { {F , b} → C.≈.trans (C.∘-resp-l (fmap-id F)) C.id-l }
      ; fmap-∘ = λ where
          {F , a} {G , b} {H , c} {θ , f} {ι , g} →
            begin
              (fmap H f C.∘ component θ b) C.∘ (fmap G g C.∘ component ι a)
            ≈⟨ C.∘-resp-l (C.≈.sym (natural θ)) ⟩
              (component θ c C.∘ fmap G f) C.∘ (fmap G g C.∘ component ι a)
            ≈⟨ simp! C ⟩
              component θ c C.∘ (fmap G f C.∘ fmap G g) C.∘ component ι a
            ≈⟨ C.∘-resp-r (C.∘-resp-l (fmap-∘ G)) ⟩
              component θ c C.∘ (fmap G (f B.∘ g)) C.∘ component ι a
            ≈⟨ simp! C ⟩
              (component θ c C.∘ fmap G (f B.∘ g)) C.∘ component ι a
            ≈⟨ C.∘-resp-l (natural θ) ⟩
              (fmap H (f B.∘ g) C.∘ component θ a) C.∘ component ι a
            ≈⟨ simp! C ⟩
              fmap H (f B.∘ g) C.∘ component θ a C.∘ component ι a
            ∎
      }
    where
      open C.≈-Reasoning

module _ {lo la l≈ lo′ la′ l≈′ lo″ la″ l≈″}
  {B : Category lo la l≈} {C : Category lo′ la′ l≈′} {D : Category lo″ la″ l≈″}
  where

  private
    module B = Category B
    module C = Category C
    module D = Category D
    module C↝D = Category (Fun C D)

  Curry : Bifunctor B C D → Functor B (C ↝ D)
  Curry F = transposeBifunctor₁ F

  Curry-resp : ∀ {F G} → F ≈ G → Curry F ≈ Curry G
  Curry-resp = transposeBifunctor₁-resp

  Curry-correct : ∀ {F} → Eval ∘ ⟨ Curry F × Id ⟩ ≈ F
  Curry-correct {F} = record
      { iso = D.≅.refl
      ; forth-natural = λ where
        {a , a′} {b , b′} {f , f′} →
          begin
            D.id D.∘ fmap F (B.id , f′) D.∘ fmap F (f , C.id)
          ≈⟨ D.≈.trans D.id-l (fmap-∘ F) ⟩
            fmap F (B.id B.∘ f , f′ C.∘ C.id)
          ≈⟨ fmap-resp F (B.id-l , C.id-r) ⟩
            fmap F (f , f′)
          ≈⟨ D.≈.sym D.id-r ⟩
            fmap F (f , f′) D.∘ D.id
          ∎
      }
    where
      open D.≈-Reasoning

  Curry-unique : ∀ {F Curry′}
    → Eval ∘ ⟨ Curry′ × Id ⟩ ≈ F
    → Curry′ ≈ Curry F
  Curry-unique {F} {Curry′} eq@record { iso = iso ; forth-natural = fnat } = record
      { iso = λ {x} →
          let open C↝D.≅-Reasoning in
          C↝D.≅.sym (
            begin
              fobj (Curry F) x
            ≈⟨ NatIso.iso (Curry-resp (sym-Cat eq)) ⟩
              fobj (Curry (Eval ∘ ⟨ Curry′ × Id ⟩)) x
            ≈⟨ NatIso→≅ (lem x) ⟩
              fobj Curry′ x
            ∎
          )
      ; forth-natural = λ {a} {b} {f} → ≈-intro λ {x} →
          -- TODO We need a simplification tactic.
          let open D.≈-Reasoning in
          triangle (forth iso D.∘ component (fmap Curry′ f) x)
          ( begin
              ((forth iso D.∘
                 (fmap (fobj Curry′ b) C.id D.∘ component (fmap Curry′ B.id) x) D.∘ D.id) D.∘
               D.id D.∘ D.id) D.∘
              component (fmap Curry′ f) x
            ≈⟨ ∘-resp-l (trans (∘-resp-r id-l) (trans id-r (trans (∘-resp-r
                 (trans id-r (trans (∘-resp (fmap-id (fobj Curry′ b))
                    (≈-elim (fmap-id Curry′))) id-l))) id-r))) ⟩
              forth iso D.∘ component (fmap Curry′ f) x
            ∎
          )
          ( begin
              fmap F (f , C.id) D.∘
              (forth iso D.∘ (fmap (fobj Curry′ a) C.id D.∘ component (fmap Curry′ B.id) x) D.∘ D.id) D.∘
              D.id D.∘ D.id
            ≈⟨ ∘-resp-r (trans (∘-resp-r id-r) (trans id-r (trans (∘-resp-r
                 (trans id-r (trans (∘-resp-l (fmap-id (fobj Curry′ a)))
                    (trans id-l (≈-elim (fmap-id Curry′)))))) id-r))) ⟩
              fmap F (f , C.id) D.∘ forth iso
            ≈⟨ sym fnat ⟩
              forth iso D.∘ fmap (fobj Curry′ b) C.id D.∘ component (fmap Curry′ f) x
            ≈⟨ ∘-resp-r (trans (∘-resp-l (fmap-id (fobj Curry′ b))) id-l) ⟩
              forth iso D.∘ component (fmap Curry′ f) x
            ∎
          )
      }
    where
      open D using (id-l ; id-r ; ∘-resp ; ∘-resp-l ; ∘-resp-r)
      open D.≈ using (sym ; trans)
      open IsEquivalence Cat.equiv using () renaming (sym to sym-Cat)

      lem : ∀ x
        → NatIso (Bifunctor→Functor₁ (Eval ∘ ⟨ Curry′ × Id ⟩) x) (fobj Curry′ x)
      lem x = record
          { iso = D.≅.refl
          ; forth-natural = D.≈.trans D.id-l (D.∘-resp-r (≈-elim (fmap-id Curry′)))
          }

instance
  hasExponentials : ∀ l → HasExponentials (Cat l l l)
  hasExponentials l = record
      { _↝′_ = λ B C → record
          { Cᴮ = B ↝ C
          ; eval = Eval
          ; curry′ = λ F → record
              { arr = Curry F
              ; prop = Curry-correct {F = F}
              ; unique = λ {g} eq →
                  let open IsEquivalence Cat.equiv using (sym) in
                  sym (Curry-unique eq)
              }
          }
      }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Non empty trie, basic type and operations
------------------------------------------------------------------------

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

open import Relation.Binary using (StrictTotalOrder)

module Data.Trie.NonEmpty {k e r} (S : StrictTotalOrder k e r) where

open import Level
open import Size
open import Category.Monad
open import Data.Product as Prod using (∃; uncurry; -,_)
open import Data.List.Base as List using (List; []; _∷_; _++_)
open import Data.List.NonEmpty as List⁺ using (List⁺; [_]; concatMap)
open import Data.Maybe.Base as Maybe using (Maybe; nothing; just; maybe′) hiding (module Maybe)
open import Data.These as These using (These; this; that; these)
open import Function as F
import Function.Identity.Categorical as Identity
open import Relation.Unary using (_⇒_; IUniversal)

open StrictTotalOrder S
  using (module Eq)
  renaming (Carrier to Key)

open import Data.List.Relation.Binary.Equality.Setoid Eq.setoid
open import Data.AVL.Value hiding (Value)
open import Data.AVL.Value ≋-setoid using (Value)
open import Data.AVL.NonEmpty S as Tree⁺ using (Tree⁺)
open Value

------------------------------------------------------------------------
-- Definition

-- A Trie⁺ is a tree branching over an alphabet of Keys. It stores values
-- indexed over the Word (i.e. List Key) that was read to reach them.
-- Each node in the Trie⁺ contains either a value, a non-empty Tree of
-- sub-Trie⁺ reached by reading an extra letter, or both.

Word : Set k
Word = List Key

eat : ∀ {v} → Value v → Word → Value v
family   (eat V ks) = family   V ∘′ (ks ++_)
respects (eat V ks) = respects V ∘′ ++⁺ ≋-refl

data Trie⁺ {v} (V : Value v) : Size → Set (v ⊔ k ⊔ e ⊔ r)
Tries⁺ : ∀ {v} (V : Value v) (i : Size) → Set (v ⊔ k ⊔ e ⊔ r)

map : ∀ {v w} (V : Value v) (W : Value w) {i} →
      ∀[ family V ⇒ family W ] →
      Trie⁺ V i → Trie⁺ W i

data Trie⁺ V where
  node : ∀ {i} → These (family V []) (Tries⁺ V i) → Trie⁺ V (↑ i)

Tries⁺ V j = Tree⁺ $ MkValue (λ k → Trie⁺ (eat V (k ∷ [])) j)
                   $ λ eq → map _ _ (respects V (eq ∷ ≋-refl))

map V W f (node t) = node $ These.map f (Tree⁺.map (map _ _ f)) t

------------------------------------------------------------------------
-- Query

lookup : ∀ {v} {V : Value v} ks → Trie⁺ V ∞ →
         Maybe (These (family V ks) (Tries⁺ (eat V ks) ∞))
lookup []       (node nd) = just (These.map₂ (Tree⁺.map id) nd)
lookup (k ∷ ks) (node nd) = let open Maybe in do
  ts ← These.fromThat nd
  t  ← Tree⁺.lookup k ts
  lookup ks t

module _ {v} {V : Value v} where

  lookupValue : ∀ (ks : Word) → Trie⁺ V ∞ → Maybe (family V ks)
  lookupValue ks t = lookup ks t Maybe.>>= These.fromThis

  lookupTries⁺ : ∀ ks → Trie⁺ V ∞ → Maybe (Tries⁺ (eat V ks) ∞)
  lookupTries⁺ ks t = lookup ks t Maybe.>>= These.fromThat

  lookupTrie⁺ : ∀ k → Trie⁺ V ∞ → Maybe (Trie⁺ (eat V (k ∷ [])) ∞)
  lookupTrie⁺ k t = lookupTries⁺ [] t Maybe.>>= Tree⁺.lookup k

------------------------------------------------------------------------
-- Construction

singleton : ∀ {v} {V : Value v} ks → family V ks → Trie⁺ V ∞
singleton []       v = node (this v)
singleton (k ∷ ks) v = node (that (Tree⁺.singleton k (singleton ks v)))

insertWith : ∀ {v} {V : Value v} ks → (Maybe (family V ks) → family V ks) →
             Trie⁺ V ∞ → Trie⁺ V ∞
insertWith []       f (node nd) =
  node (These.fold (this ∘ f ∘ just) (these (f nothing)) (these ∘ f ∘ just) nd)
insertWith {v} {V} (k ∷ ks) f (node {j} nd) = node $
  These.fold (λ v → these v (Tree⁺.singleton k end))
             (that ∘′ rec)
             (λ v → these v ∘′ rec)
             nd
  where

  end : Trie⁺ (eat V (k ∷ [])) ∞
  end = singleton ks (f nothing)

  rec : Tries⁺ V ∞ → Tries⁺ V ∞
  rec = Tree⁺.insertWith k (maybe′ (insertWith ks f) end)

module _ {v} {V : Value v} where

  private Val = family V

  insert : ∀ ks → Val ks → Trie⁺ V ∞ → Trie⁺ V ∞
  insert ks = insertWith ks ∘′ F.const

  fromList⁺ : List⁺ (∃ Val) → Trie⁺ V ∞
  fromList⁺ = List⁺.foldr (uncurry insert) (uncurry singleton)

toList⁺ : ∀ {v} {V : Value v} {i} → let Val = Value.family V in
          Trie⁺ V i → List⁺ (∃ Val)
toList⁺ (node nd) = These.mergeThese List⁺._⁺++⁺_
                    $ These.map fromVal fromTries⁺ nd
  where

  fromVal    = [_] ∘′ -,_
  fromTries⁺ = concatMap (uncurry λ k → List⁺.map (Prod.map (k ∷_) id) ∘′ toList⁺)
             ∘′ Tree⁺.toList⁺

------------------------------------------------------------------------
-- Modification

-- Deletion

deleteWith : ∀ {v} {V : Value v} {i} ks →
             (∀ {i} → Trie⁺ (eat V ks) i → Maybe (Trie⁺ (eat V ks) i)) →
             Trie⁺ V i → Maybe (Trie⁺ V i)
deleteWith []       f t           = f t
deleteWith (k ∷ ks) f t@(node nd) = let open RawMonad Identity.monad in do
  just ts ← These.fromThat nd where _ → just t
  -- This would be a lot cleaner if we had
  -- Tree⁺.updateWith : ∀ k → (Maybe (V k) → Maybe (V k)) → AVL → AVL
  -- Instead we lookup the subtree, update it and either put it back in
  -- or delete the corresponding leaf depending on whether the result is successful.
  just t′ ← Tree⁺.lookup k ts where _ → just t
  Maybe.map node ∘′ Maybe.align (These.fromThis nd) $′ case deleteWith ks f t′ of λ where
    nothing  → Tree⁺.delete k ts
    (just u) → just (Tree⁺.insert k u ts)

module _ {v} {V : Value v} where

  deleteTrie⁺ : ∀ {i} (ks : Word) → Trie⁺ V i → Maybe (Trie⁺ V i)
  deleteTrie⁺ ks = deleteWith ks (F.const nothing)

  deleteValue : ∀ {i} (ks : Word) → Trie⁺ V i → Maybe (Trie⁺ V i)
  deleteValue ks = deleteWith ks $ λ where
    (node nd) → Maybe.map node $′ These.deleteThis nd

  deleteTries⁺ : ∀ {i} (ks : Word) → Trie⁺ V i → Maybe (Trie⁺ V i)
  deleteTries⁺ ks = deleteWith ks $ λ where
    (node nd) → Maybe.map node $′ These.deleteThat nd


module kiss where

open import string
open import list
open import bool
open import relations
open import product
open import unit

data formula : Set where
  $ : string → formula
  True : formula
  Implies : formula → formula → formula
  And : formula → formula → formula

ctxt : Set
ctxt = 𝕃 formula

data _⊢_ : ctxt → formula → Set where
  Assume : ∀{Γ f} → (f :: Γ) ⊢ f
  Weaken : ∀{Γ f f'} → Γ ⊢ f → (f' :: Γ) ⊢ f
  ImpliesI : ∀{Γ f1 f2} → (f1 :: Γ) ⊢ f2 → Γ ⊢ (Implies f1 f2)
  ImpliesE : ∀{Γ f1 f2} → Γ ⊢ (Implies f1 f2) → Γ ⊢ f1 → Γ ⊢ f2
  TrueI : ∀{Γ} → Γ ⊢ True
  AndI : ∀{Γ f1 f2} → Γ ⊢ f1 → Γ ⊢ f2 → Γ ⊢ (And f1 f2)
  AndE : ∀(b : 𝔹){Γ f1 f2} → Γ ⊢ (And f1 f2) → Γ ⊢ (if b then f1 else f2)
{-
p : formula
p = $ "p"

f1 : (p :: []) ⊢ p
f1 = assume {[]}{p}

f2 : (p :: []) ⊢ (And p p)
f2 = AndI f1 f1

f3 : [] ⊢ (Implies p (And p p))
f3 = ImpliesI f2
-}
record struct : Set1 where
  field W         : Set
        R         : W → W → Set
        preorderR : preorder R
        V         : W → string → Set
        monoV     : ∀{w w'} → R w w' → ∀{i} →
                    V w i → V w' i
  reflR : reflexive R
  reflR = fst preorderR
  transR : transitive R
  transR = snd preorderR

data world : Set where
  w0 : world
  w1 : world
  w2 : world

data rel : world → world → Set where
  r00 : rel w0 w0
  r11 : rel w1 w1
  r22 : rel w2 w2
  r01 : rel w0 w1
  r02 : rel w0 w2

rel-refl : reflexive rel
rel-refl {w0} = r00
rel-refl {w1} = r11
rel-refl {w2} = r22

rel-trans : transitive rel
rel-trans r00 r00 = r00
rel-trans r00 r01 = r01
rel-trans r00 r02 = r02
rel-trans r11 r11 = r11
rel-trans r22 r22 = r22
rel-trans r01 r11 = r01
rel-trans r02 r22 = r02

data val : world → string → Set where
  v1p : val w1 "p"
  v1q : val w1 "q"
  v2p : val w2 "p"
  v2q : val w2 "q"

mono-val : ∀{w w'} → rel w w' →
           ∀{i} → val w i → val w' i
mono-val r00 p = p
mono-val r11 p = p
mono-val r22 p = p
mono-val r01 ()
mono-val r02 ()

k : struct
k = record { W         = world ;
             R         = rel ;
             preorderR = (rel-refl , rel-trans) ;
             V         = val ;
             monoV     = mono-val }

open struct

_,_⊨_ : ∀(k : struct) → W k → formula → Set
k , w ⊨ ($ x) = V k w x
k , w ⊨ True = ⊤
k , w ⊨ Implies f1 f2 = ∀ {w' : W k} → R k w w' →
                        k , w' ⊨ f1 → k , w' ⊨ f2
k , w ⊨ And f1 f2 = k , w ⊨ f1 ∧ k , w ⊨ f2

pf-test-sem : k , w0 ⊨ Implies ($ "p") ($ "q")
pf-test-sem r00 ()
pf-test-sem r01 p = v1q
pf-test-sem r02 p = v2q

_,_⊨ctxt_ : ∀(k : struct) → W k → ctxt → Set
k , w ⊨ctxt [] = ⊤
k , w ⊨ctxt (f :: Γ) = (k , w ⊨ f) ∧ (k , w ⊨ctxt Γ)

mono⊨ : ∀{k : struct}{w1 w2 : W k}{f : formula} →
         R k w1 w2 →
         k , w1 ⊨ f →
         k , w2 ⊨ f
mono⊨{k} {f = $ x} r p = monoV k r p
mono⊨{k} {f = True} r p = triv
mono⊨{k} {f = Implies f1 f2} r p r' p' = p (transR k r r') p'
mono⊨{k} {f = And f1 f2} r (p1 , p2) = mono⊨{f = f1} r p1 , mono⊨{f = f2} r p2

mono⊨ctxt : ∀{k : struct}{Γ : ctxt}{w1 w2 : W k} →
            R k w1 w2 →
            k , w1 ⊨ctxt Γ →
            k , w2 ⊨ctxt Γ
mono⊨ctxt{k}{[]} _ _ = triv
mono⊨ctxt{k}{f :: Γ} r (u , v) = mono⊨{k}{f = f} r u , mono⊨ctxt{k}{Γ} r v

_⊩_ : ctxt → formula → Set1
Γ ⊩ f = ∀{k : struct}{w : W k} → k , w ⊨ctxt Γ → k , w ⊨ f

Soundness : ∀{Γ : ctxt}{f : formula} → Γ ⊢ f → Γ ⊩ f
Soundness Assume g = fst g
Soundness (Weaken p) g = Soundness p (snd g)
Soundness (ImpliesI p) g r u' = Soundness p (u' , mono⊨ctxt r g)
Soundness (ImpliesE p p') {k} g = (Soundness p g) (reflR k) (Soundness p' g)
Soundness TrueI g = triv
Soundness (AndI p p') g = (Soundness p g , Soundness p' g)
Soundness (AndE tt p) g = fst (Soundness p g)
Soundness (AndE ff p) g = snd (Soundness p g)

data _≼_ : 𝕃 formula → 𝕃 formula → Set where
  ≼-refl : ∀{Γ} → Γ ≼ Γ
  ≼-cons : ∀{Γ Γ' f} → Γ ≼ Γ' → Γ ≼ (f :: Γ')

≼-trans : ∀ {Γ Γ' Γ''} → Γ ≼ Γ' → Γ' ≼ Γ'' → Γ ≼ Γ''
≼-trans u ≼-refl = u
≼-trans u (≼-cons u') = ≼-cons (≼-trans u u')

Weaken≼ : ∀ {Γ Γ'}{f : formula} → Γ ≼ Γ' → Γ ⊢ f → Γ' ⊢ f
Weaken≼ ≼-refl p = p
Weaken≼ (≼-cons d) p = Weaken (Weaken≼ d p)

U : struct
U = record { W = ctxt ;
             R = _≼_ ;
             preorderR = ≼-refl , ≼-trans ;
             V = λ Γ n → Γ ⊢ $ n ;
             monoV = λ d p → Weaken≼ d p }

CompletenessU : ∀{f : formula}{Γ : W U} → U , Γ ⊨ f → Γ ⊢ f
SoundnessU : ∀{f : formula}{Γ : W U} → Γ ⊢ f → U , Γ ⊨ f
CompletenessU {$ x} u = u
CompletenessU {True} u = TrueI
CompletenessU {And f f'} u = AndI (CompletenessU{f} (fst u)) (CompletenessU{f'} (snd u))
CompletenessU {Implies f f'}{Γ} u =
  ImpliesI
    (CompletenessU {f'}
      (u (≼-cons ≼-refl) (SoundnessU {f} (Assume {Γ}))))
SoundnessU {$ x} p = p
SoundnessU {True} p = triv
SoundnessU {And f f'} p = SoundnessU{f} (AndE tt p) , SoundnessU{f'} (AndE ff p)
SoundnessU {Implies f f'} p r u = SoundnessU (ImpliesE (Weaken≼ r p) (CompletenessU {f} u))

ctxt-id : ∀{Γ : ctxt} → U , Γ ⊨ctxt Γ
ctxt-id{[]} = triv
ctxt-id{f :: Γ} = SoundnessU{f} Assume , mono⊨ctxt (≼-cons ≼-refl) (ctxt-id {Γ})

Completeness : ∀{Γ : ctxt}{f : formula} → Γ ⊩ f → Γ ⊢ f
Completeness{Γ} p = CompletenessU (p{U}{Γ} (ctxt-id{Γ}))

Universality1 : ∀{Γ : ctxt}{f : formula} → Γ ⊩ f → U , Γ ⊨ f
Universality1{Γ}{f} p = SoundnessU (Completeness{Γ}{f} p)

Universality2 : ∀{Γ : ctxt}{f : formula} → U , Γ ⊨ f → Γ ⊩ f
Universality2{Γ}{f} p = Soundness (CompletenessU{f}{Γ} p)

nbe : ∀ {Γ f} → Γ ⊢ f → Γ ⊢ f
nbe {Γ} p = Completeness (Soundness p)


open import Common.Prelude hiding (_>>=_)
open import Common.Reflection
open import Common.Equality

set₀ = sort (lit 0)
set! = sort unknown

-- Definitions added by tactics always use the original context, and thus are not
-- affected by inContext and extendContext. The reason for this is that they are added
-- to the module of the macro call, so they need to live in the context of that module
-- or things break.

freshFun : Type → List Clause → Tactic
freshFun t cs hole =
  freshName "fresh" >>= λ n →
  inContext [] (define (vArg n) (funDef t cs)) >>= λ _ →
  unify hole (def n [])

macro
  ack : Tactic
  ack = freshFun set! (clause [] set₀ ∷ [])

  theA : Tactic
  theA = freshFun set₀ (clause [] (var 0 []) ∷ [])

module Foo (A : Set) where
  foo : Set
  foo = theA

  bar : Set₁
  bar = ack

check : {A : Set} → Foo.foo A ≡ A
check = refl


{-# OPTIONS --cubical --prop #-}
module Issue2487-2 where

import Issue2487.Infective


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

open import M-types.Base.Core

module M-types.Base.Sum  where
    infixr 4 _,_
    record ∑ (X : Ty ℓ₀) (Y : X → Ty ℓ₁) : Ty (ℓ-max ℓ₀ ℓ₁) where
        constructor _,_
        field
            pr₀ : X
            pr₁ : Y pr₀
    open ∑ public
    {-# BUILTIN SIGMA ∑ #-}

    ∑-syntax : (X : Ty ℓ₀) → (Y : X → Ty ℓ₁) → Ty (ℓ-max ℓ₀ ℓ₁)
    ∑-syntax = ∑
    infix 2 ∑-syntax
    syntax ∑-syntax X (λ x → Y) = ∑[ x ∈ X ] Y

    infixr 2 _×_
    _×_ : (X : Ty ℓ₀) → (Y : Ty ℓ₁) → Ty (ℓ-max ℓ₀ ℓ₁)
    X × Y = ∑[ x ∈ X ] Y

    ty = pr₀
    fun = pr₀


open import Agda.Primitive using (lzero; lsuc; _⊔_)

import SecondOrder.Arity
import SecondOrder.Signature
import SecondOrder.Metavariable
import SecondOrder.Renaming
import SecondOrder.Term

module SecondOrder.Theory
  {ℓ}
  {𝔸 : SecondOrder.Arity.Arity}
  (Σ : SecondOrder.Signature.Signature ℓ 𝔸)
  where

  open SecondOrder.Metavariable Σ public
  open SecondOrder.Term Σ public
  open SecondOrder.Signature.Signature Σ public
  open SecondOrder.Renaming Σ

  record Axiom : Set ℓ where
    constructor make-ax
    field
      ax-mv-ctx : MContext -- metavariable context of an equation
      ax-sort : sort -- sort of an equation
      ax-lhs : Term ax-mv-ctx ctx-empty ax-sort -- left-hand side
      ax-rhs : Term ax-mv-ctx ctx-empty ax-sort -- right-hand side

  record Theory ℓa : Set (lsuc (ℓ ⊔ ℓa)) where
    field
      ax : Set ℓa -- the axioms
      ax-eq : ax → Axiom -- each axiom has a corresponding Axiom

    ax-mv-ctx : ax → MContext -- the meta-context of each axiom
    ax-mv-ctx ε = Axiom.ax-mv-ctx (ax-eq ε)

    ax-sort : ax → sort -- the sort of each axiom
    ax-sort ε = Axiom.ax-sort (ax-eq ε)

    -- the left- and right-hand side of each axiom s ≈ t, promoted to any context
    ax-lhs : ∀ (ε : ax) {Γ} → Term (ax-mv-ctx ε) Γ (ax-sort ε)
    ax-lhs ε =  [ inʳ ]ʳ Axiom.ax-lhs (ax-eq ε)

    ax-rhs : ∀ (ε : ax) {Γ} → Term (ax-mv-ctx ε) Γ (ax-sort ε)
    ax-rhs ε = [ inʳ ]ʳ Axiom.ax-rhs (ax-eq ε)


-- Σ-Terms
module Terms where

open import Data.Vec hiding (_++_)
open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.List
open import Data.List.All
open import Data.Fin.Base

open import Size

-- Ranked alphabet: Vector of natural numbers, where vec[i] denotes the arity of symbol i
RankAlph : ℕ → Set
RankAlph n = Vec ℕ n

-- Types
data Type : Set where
  TTerm : ∀ {n} → RankAlph n → Type
  TFun  : Type → Type → Type

-- Type environment
Env : Set
Env = List Type

-- Environment lookup
data _∈`_ : Type → Env → Set where
  here  : ∀ {φ A}    → A ∈` (A ∷ φ)
  there : ∀ {φ A A'} → A ∈` φ → A ∈` (A' ∷ φ)

-- Bind a type n times on top of an environment
bind : Env → (A : Type) → ℕ → Env
bind φ A zero    = φ
bind φ A (suc n) = A ∷ (bind φ A n)

-- Zero & Successor, Variables, prim. recursion on Σ-Nat, Abstraction, Application
data Expr : Env → Type → Set where
  -- Given terms σ₁, ..., σₘ and a term σ with arity α(σ) = m, we get a new term σ(σ₁, ..., σₘ); Special case: m = 0
  Term    : ∀ {φ n vec} {i : Fin n} {m} {eq : Data.Vec.lookup vec i ≡ m} → (∀ (l : Fin m) → Expr φ (TTerm vec)) → Expr φ (TTerm vec)
  -- Recursion on Terms: For every term σ ∈ Σ with arity α(σ) = m, we have an expression of type A in an environment that binds m variables of type A
  --                     Together with an expression of type Σ, by recursion on the correct expression we get an expression of type A
  Term-Rec  : ∀ {φ n vec A} → (∀ {l : Fin n} {m} {eq : (Data.Vec.lookup vec l) ≡ m} → Expr (bind φ A m) A) → Expr φ (TTerm vec) → Expr φ A
  Var    : ∀ {φ A}   → A ∈` φ → Expr φ A
  Abs    : ∀ {φ A B} → Expr (A ∷ φ) B → Expr φ (TFun A B)
  App    : ∀ {φ A B} → Expr φ (TFun A B) → Expr φ A → Expr φ B

----- Big step semantics using Agda semantics -----
-- Data type for terms
data TTerm' {n} : RankAlph n →  Set where
  Term' : ∀ {vec m} {i : Fin n} {eq : (Data.Vec.lookup vec i) ≡ m} → (∀ (l : Fin m) → (TTerm' vec)) → (TTerm' vec)

data TTerm'' {n} (ra : RankAlph n) : {i : Size} → Set where
  mk : ∀ {i} → (symb : Fin n) → Vec (TTerm'' ra {i}) (Data.Vec.lookup ra symb) → TTerm'' ra {↑ i}

-- From data type to expression
conversion : ∀ {φ n} {vec : RankAlph n} → TTerm' vec → Expr φ (TTerm vec)
conversion (Term'{m = zero}{eq = eq} x)   = Term{eq = eq} λ ()
conversion (Term'{m = suc n}{eq = eq} x)  = Term{eq = eq} (λ l → conversion (x l))

-- Value definition
Value : Type → Set
Value (TTerm vec) = TTerm' vec
Value (TFun A B)  = Value A → Value B

-- Lookup in environment of values
access : ∀ {A φ} → A ∈` φ → All Value φ → Value A
access here      (px ∷ p) = px
access (there x) (px ∷ p) = access x p

-- Given a map from Fin (suc m) to anything; we can derive a map from Fin m to anything
-- (make the Urbild smaller)
urbild : ∀ {m} {A : Set} → (Fin (suc m) → A) → (Fin m → A)
urbild l = λ x → l (raise 1 x)

nary : (A : Set) → ℕ → Set
nary A zero = A
nary A (suc n) = A → nary A n

algebra : ∀ {n} → RankAlph n → (A : Set) → Vec Set n
algebra vec A = Data.Vec.map (nary A) vec

term-rec : ∀ {A : Set} {n : ℕ} {vec : RankAlph n} → (alg : Vec Set n) → TTerm' vec → A
term-rec v (Term'{m = zero}   x)  = {!!}
term-rec v (Term'{m = suc m}  x)  = {!!}

-- Evaluation
eval : ∀ {φ A} → Expr φ A → All Value φ → Value A
--
eval (Term{m = zero}{eq = eq} x) ϱ    = Term'{eq = eq} λ ()
eval (Term{m = suc n}{eq = eq} x) ϱ   = Term'{eq = eq} (λ l → eval (x l) ϱ)
eval (Term-Rec σ-exprs eₛ) ϱ          = {!!}
eval (Var x) ϱ                        = access x ϱ
eval (Abs e) ϱ                        = λ x → eval e (x ∷ ϱ)
eval (App e e₁) ϱ                     = (eval e ϱ) (eval e₁ ϱ)
-----

{--
-- eval (Σ-Rec σ-exprs eₛ)  with (eval eₛ ϱ)
-- ... | σ∈Σ⁰ i x    = eval (σ-exprs i x) ϱ
-- ... | σ∈Σᵐ i x x₁ = eval (σ-exprs i x₁) (rec σ-exprs ϱ x)
-- rec  : ∀ {φ A n m} {vec : Vec ℕ n} → (∀ (l : Fin n) → ∀ {m} → (Data.Vec.lookup vec l) ≡ m → Expr (bind φ A m) A) → All Value φ → (∀ (l : Fin m) → (Σ' vec)) → All Value (bind φ A m)
-- rec {m = zero} σ-exprs ϱ terms  = ϱ
-- rec {m = suc m} σ-exprs ϱ terms = eval (Σ-Rec σ-exprs (conversion (terms (fromℕ m)))) ϱ ∷ (rec{m = m} σ-exprs ϱ (urbild terms))

-- Example: ℕ; Σ = {Z⁰, S¹} (where ⁿ defines arity)
Nat : Type
Nat = TTerm (0 ∷ 1 ∷ [])

--- Natural number to expression
ℕtoE : ℕ → Expr [] Nat

--- Cases
plus-exprs : ℕ → (∀ (l : Fin 2) → ∀ {m} → (Data.Vec.lookup (0 ∷ 1 ∷ []) l) ≡ m → Expr (bind [] (Nat) m) Nat)
-- base case for n + zero = n
plus-exprs n zero       {zero}        0≡0  = ℕtoE n
-- suc case, n + (suc m) = suc (n + m); (n + m) recursively calculated and put ontop of the environemnt, hence Var here
-- plus-exprs n (suc zero) {suc zero}    1≡1  = Term{m = 1} (suc zero) (λ l → Var here) refl

_plus_ : ℕ → ℕ → Expr [] (Nat)
n plus m = Term-Rec (plus-exprs n) (ℕtoE m)

-- Example with explanation
--
--}
----- Small step semantics -----
----- Substitution: See SystemT.agda for a more detailed description
insdebr : ∀ {φ φ'} {A B} → B ∈` (φ' ++ φ) → B ∈` (φ' ++ (A ∷ φ))
insdebr {φ' = []} here           = there here
insdebr {φ' = []} (there x)      = there (there x)
insdebr {φ' = y ∷ ys} here      = here
insdebr {φ' = y ∷ ys} (there x) = there (insdebr x)

-- Extract the ℕ m from proof that vector contains it at index l
extr : ∀ {n l m} {vec : RankAlph n} → (Data.Vec.lookup vec l ≡ m) → ℕ
extr {m} refl = m

-- Proof that (A' ∷ ... ∷ A' ∷ (φ' ++ A ∷ φ)) is "equal to itself", Agda cannot see this
-- from the definition of bind
insbind : ∀ (φ' : Env)  (φ : Env)  (A' : Type) (m : ℕ) → bind (φ' ++ φ) A' m ≡  bind φ' A' m ++ φ
insbind [] φ' A' zero          = refl
insbind [] φ' A' (suc m)       = cong (_∷_ A') (insbind [] φ' A' m)
insbind (x ∷ φ) φ' A' zero    = refl
insbind (x ∷ φ) φ' A' (suc m) = cong (_∷_ A') (insbind (x ∷ φ) φ' A' m)

ins : ∀ {φ φ'} {A B} → Expr (φ' ++ φ) B → Expr (φ' ++ A ∷ φ) B
ins (Var x)                             = Var (insdebr x)
ins (Term{m = zero}{eq = eq} x)         = Term{eq = eq} (λ ())
ins (Term{m = suc m}{eq = eq} x)        = Term{eq = eq} λ l → ins (x l)
-- Direct rewriting does not work since arity (m) is not in scope
-- ins {φ} {φ'} {A} {B} (Term-Rec{n = n}{vec = vec}{A = .B} x x₁) rewrite (insbind φ' φ B {!!})
ins {φ} {φ'} {A} {B} (Term-Rec{n = n}{vec = vec}{A = .B} x x₁)
    = Term-Rec (λ {l : Fin n} {m} {eq : Data.Vec.lookup vec l ≡ m} → ϱ{vec = vec} l m eq (x {l} {m} {eq})) (ins x₁)
    where
    ϱ : ∀ {vec} → (l : Fin n) → (m : ℕ) → (Data.Vec.lookup vec l) ≡ m → Expr (bind (φ' ++ φ) B m) B → Expr (bind (φ' ++ (A ∷ φ)) B m) B
    ϱ l m eq ex rewrite (insbind φ' φ B m) | (insbind φ' (A ∷ φ) B m) = ins{φ = φ}{φ' = bind φ' B m}{A = A} ex
ins {φ' = φ'} (Abs{A = A'} x)           = Abs (ins{φ' = A' ∷ φ'}  x)
ins (App x y)                           = App (ins x) (ins y)

varsub : ∀ {φ φ'} {A B} → A ∈` (φ' ++ B ∷ φ) → Expr φ B → Expr (φ' ++ φ) A
varsub {φ' = []} here M           = M
varsub {φ' = []} (there x) M      = Var x
varsub {φ' = z ∷ zs} here M      = Var here
varsub {φ' = z ∷ zs} (there x) M = ins{φ' = []} (varsub x M)

_[[_]] : ∀ {φ φ'} {A B : Type} → Expr (φ' ++ B ∷ φ) A → Expr φ B → Expr (φ' ++ φ) A
Var x [[ M ]]                      = varsub x M
Term{m = zero}{eq = eq} x [[ M ]]  = Term{eq = eq} (λ ())
Term{m = suc m}{eq = eq} x [[ M ]] = Term{eq = eq} λ l → x l [[ M ]]
_[[_]] {φ} {φ'} {A} {B} (Term-Rec{n = n}{vec = vec}{A = A'} trms e) M
  = Term-Rec (λ {l} {m} {eq} → ϱ{vec = vec} l m eq (trms {l} {m} {eq})) (e [[ M ]])
  where
  ϱ : ∀ {vec} → (l : Fin n) → (m : ℕ) → (Data.Vec.lookup vec l) ≡ m → Expr (bind (φ' ++ B ∷ φ) A m) A → Expr (bind (φ' ++ φ) A m) A
  ϱ l m eq expr rewrite (insbind φ' (B ∷ φ) A m) | (insbind φ' φ A m) = _[[_]] {φ} {bind φ' A m} {A} {B} expr M
Abs N [[ M ]]                      = Abs (N [[ M ]])
App N N' [[ M ]]                   = App (N [[ M ]]) (N' [[ M ]])

-- Values
data Value' {φ} : (t : Type) → Expr φ t → Set where
  VTerm : ∀ {n} {vec : Vec ℕ n} {i : Fin n} {m} {eq : Data.Vec.lookup vec i ≡ m}
    → (subt : Fin m → Expr φ (TTerm vec))
    → (∀ {l : Fin m} → Value' (TTerm vec) (subt l))
    → Value' (TTerm vec) (Term {i = i}{m}{eq} subt)
  VFun  : ∀ {A B expr} → Value' (TFun A B) (Abs expr)

---- Functions required for Term-Rec
-- Select term for recursion
termsel : ∀ {φ A n m vec} → (∀ {l : Fin n} {m'} {eq : Data.Vec.lookup vec l ≡ m'} → Expr (bind φ A m') A) → Expr φ (TTerm vec) → Expr (bind φ A m) A
termsel {m = m} {vec = vec} trms (Term{i = i}{m = m'}{eq = eq} x) = {!!}
termsel trms (Term-Rec x trm) = {!!}
termsel trms (Var x)          = {!!}
termsel trms (App trm trm₁)   = {!!}

-- Proof that (bind (A ∷ φ) A m) ≡ (A ∷ bind φ A m)
bindapp : ∀ {φ A m} → bind (A ∷ φ) A m ≡ (A ∷ bind φ A m)
bindapp {m = zero}  = refl
bindapp {A = A} {m = suc m} = cong (_∷_ A) bindapp

-- Looks more complicated than it is:
-- Given a Term-Rec expression - including a map that for each term t' in our ranked alphabet with arity α(t') = m'
-- defines an expression with m' bound variables - and a specific Term t with arity α(t) = m:
-- Recursively, on m from "right-to-left", bind a Term-Rec expression with the same map using the topmost subterm on top of the environment
-- Term-Rec trms σ(t₁, ..., tₘ) →
-- ( ... ((trms(σ) [y₁ ↦ Term-Rec trms t₁]) [y₂ ↦ Term-Rec trms t₂]) ...) [yₘ ↦ Term-Rec trms tₘ]
bindtosubs : ∀ {m n φ A} {vec : RankAlph n} →
  (trms : (∀ {l : Fin n} {m'} {eq : Data.Vec.lookup vec l ≡ m'} → Expr (bind φ A m') A)) →
  (subtrms : (∀ (l : Fin m) → Expr φ (TTerm vec))) →
  Expr (bind φ A m) A →
  Expr φ A
bindtosubs {zero} trms subtrms e  = e
bindtosubs {suc m} {n = n} {φ} {A} {vec = vec} trms subtrms e rewrite sym (bindapp {φ} {A} {m})
                                  = (bindtosubs{m = m}{n = n}{vec = vec} (λ {l} {m'} {eq} → ϱ l m' eq (trms {l} {m'} {eq})) (λ l → ins{φ' = []}{A = A} ((urbild subtrms) l)) e)
                                    [[ Term-Rec (λ {l} {m'} {eq} → trms {l} {m'} {eq}) (subtrms (fromℕ m)) ]]
                                    where -- Adjustement of environment/DeBruijn indices: In the recursion step, we have to adjust the term map (∀ t' with α(t') = m' we get an Expr with m' bound vars)
                                          --                                              by adding another bound variable. If we for example have a "Var here" in σ, this adjustement leads to the correct
                                          --                                              substitution with evaluated σ₁ that has m bound variables.
                                    ϱ : (l : Fin n) → (m' : ℕ) → (Data.Vec.lookup vec l) ≡ m' → Expr (bind φ A m') A → Expr (bind (A ∷ φ) A m') A
                                    ϱ l m' eq ex rewrite (bindapp {φ} {A} {m'}) = ins{φ' = []}{A = A} ex

data _↠_ {φ} : {A : Type} → Expr φ A → Expr φ A → Set where
  -- Basic call-by-value λ-calc. stuff
  -- Application: Elimination & Reduction
  ξ-App1 : ∀ {A B} {L L' : Expr φ (TFun B A)} {M}
           → L ↠ L'
           → App L M ↠ App L' M

  ξ-App2 : ∀ {A B} {M M' : Expr φ A} {L : Expr φ (TFun A B)}
           → Value' (TFun A B) L
           → M ↠ M'
           → App L M ↠ App L M'

  β-App : ∀ {A B M exp}
          → Value' B M
          → App{B = A} (Abs exp) M ↠ (exp [[ M ]])

  -- Term elimination
  ξ-TermRec : ∀ {A} {n} {vec : RankAlph n} {e e'}
               {trms : (∀ {l : Fin n} {m : ℕ} {eq : (Data.Vec.lookup vec l ≡ m)} → Expr (bind φ A m) A)}
              → e ↠ e'
              → Term-Rec{n = n}{vec = vec} (λ {l} {m'} {eq} → trms {l} {m'} {eq}) e ↠ Term-Rec (λ {l} {m'} {eq} → trms {l} {m'} {eq}) e'

{-
  β-TermRec : ∀ {A} {n i} {vec : Vec ℕ n} {e}
               {trms : (∀ {l : Fin n} {m : ℕ} {eq : (Data.Vec.lookup vec i ≡ m)} → Expr (bind φ A m) A)}
             → Value' (TTerm vec) e
             → {!!}
-}


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

open import HoTT
open import lib.cubical.elims.CubeMove

module lib.cubical.elims.CofWedge where

cof-wedge-path-rec : ∀ {i j k l}
  {X : Ptd i} {Y : Ptd j} {C : Type k} {D : Type l}
  {f : X ∨ Y → C} {d₁ d₂ : D}
  → (p : d₁ == d₂)
  → (q : C → d₁ == d₂)
  → ((x : fst X) → p == q (f (winl x)))
  → ((y : fst Y) → p == q (f (winr y)))
  → ((κ : Cofiber f) → d₁ == d₂)
cof-wedge-path-rec {X = X} {Y = Y} {f = f} base* cod* winl* winr* =
  CofiberRec.f _
    base*
    cod*
    (WedgeElim.f
      winl*
      (λ y → (winl* (snd X) ∙ ap (cod* ∘ f) wglue)
             ∙ ! (winr* (snd Y)) ∙ winr* y)
      (↓-cst=app-from-square $ disc-to-square $ ! $
        ap (λ w → (winl* (snd X) ∙ ap (cod* ∘ f) wglue) ∙ w)
           (!-inv-l (winr* (snd Y)))
        ∙ ∙-unit-r _))

cof-wedge-path-elim : ∀ {i j k l}
  {X : Ptd i} {Y : Ptd j} {C : Type k} {D : Type l}
  {f : X ∨ Y → C} (g h : Cofiber f → D)
  → (p : g (cfbase _) == h (cfbase _))
  → (q : (c : C) → g (cfcod _ c) == h (cfcod _ c))
  → ((x : fst X) → Square p (ap g (cfglue _ (winl x)))
                            (ap h (cfglue _ (winl x))) (q (f (winl x))))
  → ((y : fst Y) → Square p (ap g (cfglue _ (winr y)))
                            (ap h (cfglue _ (winr y))) (q (f (winr y))))
  → ((κ : Cofiber f) → g κ == h κ)
cof-wedge-path-elim {X = X} {Y = Y} {f = f} g h base* cod* winl* winr* =
  Cofiber-elim _
    base*
    cod*
    (↓-='-from-square ∘ Wedge-elim
      winl*
      (λ y → fst fill ⊡h winr* y)
      (cube-to-↓-square $
        cube-right-from-front _ (winr* (snd Y)) (snd fill)))
  where
  fill : Σ (Square base* idp idp base*) (λ sq' →
    Cube (winl* (snd X)) sq'
      (natural-square (λ _ → base*) wglue)
      (square-push-rb _ _ (natural-square (ap g ∘ cfglue _) wglue))
      (square-push-rb _ _ (natural-square (ap h ∘ cfglue _) wglue))
      (natural-square (cod* ∘ f) wglue ⊡h' !□h (winr* (snd Y))))

  fill = fill-cube-right _ _ _ _ _

{- Note, only squares with constant endpoints. General case? -}
cof-wedge-square-elim : ∀ {i j k l}
  {X : Ptd i} {Y : Ptd j} {C : Type k} {D : Type l}
  {f : X ∨ Y → C} {d₀₀ d₀₁ d₁₀ d₁₁ : D}
  (p₀₋ : (κ : Cofiber f) → d₀₀ == d₀₁)
  (p₋₀ : (κ : Cofiber f) → d₀₀ == d₁₀)
  (p₋₁ : (κ : Cofiber f) → d₀₁ == d₁₁)
  (p₁₋ : (κ : Cofiber f) → d₁₀ == d₁₁)
  → (base* : Square (p₀₋ (cfbase _)) (p₋₀ (cfbase _))
                    (p₋₁ (cfbase _)) (p₁₋ (cfbase _)))
  → (cod* : (c : C) → Square (p₀₋ (cfcod _ c)) (p₋₀ (cfcod _ c))
                             (p₋₁ (cfcod _ c)) (p₁₋ (cfcod _ c)))
  → ((x : fst X) → Cube base* (cod* (f (winl x)))
                     (natural-square p₀₋ (cfglue _ (winl x)))
                     (natural-square p₋₀ (cfglue _ (winl x)))
                     (natural-square p₋₁ (cfglue _ (winl x)))
                     (natural-square p₁₋ (cfglue _ (winl x))))
  → ((y : fst Y) → Cube base* (cod* (f (winr y)))
                     (natural-square p₀₋ (cfglue _ (winr y)))
                     (natural-square p₋₀ (cfglue _ (winr y)))
                     (natural-square p₋₁ (cfglue _ (winr y)))
                     (natural-square p₁₋ (cfglue _ (winr y))))

  → ((κ : Cofiber f) → Square (p₀₋ κ) (p₋₀ κ) (p₋₁ κ) (p₁₋ κ))
cof-wedge-square-elim p₀₋ p₋₀ p₋₁ p₁₋ base* cod* winl* winr* =
  disc-to-square ∘ cof-wedge-path-elim _ _
    (square-to-disc base*)
    (square-to-disc ∘ cod*)
    (cube-to-disc-square ∘ winl*)
    (cube-to-disc-square ∘ winr*)


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

open import HoTT
open import cw.CW

module cw.examples.Unit where

cw-unit-skel : Skeleton {lzero} 0
cw-unit-skel = Unit , Unit-is-set
CWUnit = ⟦ cw-unit-skel ⟧

CWUnit-equiv-Unit : CWUnit ≃ Unit
CWUnit-equiv-Unit = ide _


module UnequalSorts where

data One  : Set  where one : One
data One' : Set1 where one' : One'

err : One
err = one'


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

open import Fragment.Equational.Theory

module Fragment.Equational.FreeExtension.Base (Θ : Theory) where

open import Fragment.Equational.Model Θ
open import Fragment.Equational.Coproduct Θ

open import Level using (Level; Setω; _⊔_)
open import Data.Nat using (ℕ)

private
  variable
    a ℓ : Level

Extension : Setω
Extension = ∀ {a} {ℓ} → Model {a} {ℓ} → ℕ → Model {a} {a ⊔ ℓ}

IsFreeExtension : Extension → Setω
IsFreeExtension _[_] =
  ∀ {a ℓ} (A : Model {a} {ℓ}) (n : ℕ) → IsCoproduct A (J n) (A [ n ])

record FreeExtension : Setω where
  field
    _[_]        : Extension
    _[_]-isFrex : IsFreeExtension _[_]


open import Everything

module Test.Functor where

List = List⟨_⟩

module _
  {a b} {A : Set a} {B : Set b}
  where

  map-list : (A → B) → List A → List B
  map-list f ∅ = ∅
  map-list f (x , xs) = f x , map-list f xs

instance

  SurjtranscommutativityList : ∀ {ℓ} → Surjtranscommutativity.class Function⟦ ℓ ⟧ (MFunction List) _≡̇_ map-list transitivity transitivity
  SurjtranscommutativityList .⋆ f g ∅ = ∅
  SurjtranscommutativityList .⋆ f g (x , xs) rewrite SurjtranscommutativityList .⋆ f g xs = ∅

  SurjextensionalityList : ∀ {ℓ} → Surjextensionality.class Function⟦ ℓ ⟧ _≡̇_ (MFunction List) _≡̇_ _ map-list
  SurjextensionalityList .⋆ _ _ f₁ f₂ f₁≡̇f₂ ∅ = ∅
  SurjextensionalityList .⋆ _ _ f₁ f₂ f₁≡̇f₂ (x , xs) rewrite SurjextensionalityList .⋆ _ _ f₁ f₂ f₁≡̇f₂ xs | f₁≡̇f₂ x = ∅

  SurjidentityList : ∀ {ℓ} → Surjidentity.class Function⟦ ℓ ⟧ (MFunction List) _≡̇_ map-list ε ε
  SurjidentityList .⋆ ∅ = ∅
  SurjidentityList .⋆ (x , xs) rewrite SurjidentityList .⋆ xs = ∅

test-isprecategory-1 : ∀ {ℓ} → IsPrecategory {𝔒 = Ø ℓ} Function⟦ ℓ ⟧ _≡̇_ (flip _∘′_)
test-isprecategory-1 {ℓ} = IsPrecategoryExtension {A = Ø ℓ} {B = ¡}

test-isprecategory-2 : ∀ {ℓ} → IsPrecategory {𝔒 = Ø ℓ} Function⟦ ℓ ⟧ _≡̇_ (flip _∘′_)
test-isprecategory-2 {ℓ} = IsPrecategoryFunction {𝔬 = ℓ}

test-isprecategory-1a : ∀ {ℓ} → IsPrecategory {𝔒 = Ø ℓ} (Extension (¡ {𝔒 = Ø ℓ})) _≡̇_ (flip _∘′_)
test-isprecategory-1a {ℓ} = IsPrecategoryExtension {A = Ø ℓ} {B = ¡}

test-isprecategory-2a : ∀ {ℓ} → IsPrecategory {𝔒 = Ø ℓ} (Extension (¡ {𝔒 = Ø ℓ})) _≡̇_ (flip _∘′_)
test-isprecategory-2a {ℓ} = IsPrecategoryFunction {𝔬 = ℓ}

test-isprecategory-1b : IsPrecategory {𝔒 = ¶} (Extension (Term.Term ¶)) _≡̇_ (flip _∘′_)
test-isprecategory-1b = IsPrecategoryExtension {A = ¶} {B = Term.Term ¶}

-- test-isprecategory-2b : IsPrecategory {𝔒 = ¶} (Extension (Term.Term ¶)) _≡̇_ (flip _∘′_)
-- test-isprecategory-2b = {!!} -- IsPrecategoryFunction {𝔬 = ?}

instance

  HmapList : ∀ {a} → Hmap.class Function⟦ a ⟧ (MFunction List)
  HmapList = ∁ λ _ _ → map-list

instance

  isPrefunctorList : ∀ {ℓ} → IsPrefunctor (λ (x y : Ø ℓ) → x → y)
                                          Proposextensequality
                                          transitivity
                                          (λ (x y : Ø ℓ) → List x → List y)
                                          Proposextensequality
                                          transitivity
                                          smap
  isPrefunctorList = ∁

  isFunctorList : ∀ {ℓ} → IsFunctor (λ (x y : Ø ℓ) → x → y)
                                    Proposextensequality
                                    ε
                                    transitivity
                                    (λ (x y : Ø ℓ) → List x → List y)
                                    Proposextensequality
                                    ε
                                    transitivity
                                    smap
  isFunctorList = ∁

instance

  FmapList : ∀ {ℓ} → Fmap (List {ℓ})
  FmapList = ∁ smap

module _
  {a} {A : Set a} {B : Set a}
  where
  test-smap-list : (A → B) → List A → List B
  test-smap-list = smap

module _
  {a} {A : Set a} {B : Set a}
  where
  test-fmap-list : (A → B) → List A → List B
  test-fmap-list = fmap -- the intention here is to try to say "I want to invoke a functoral mapping, so that I can be sure that, for example, that `test-map-list ε₁ ≡ ε₂`.


{-# OPTIONS --copatterns  #-}

module TestsInstances where

open import Function
open import Data.Product
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Relation.Binary.PropositionalEquality as P
open ≡-Reasoning

open import Data.Empty renaming (⊥ to Empty)
open import Data.Unit renaming (⊤ to One) hiding (_≟_)
open import Data.Bool hiding (_≟_)
open import Data.Bool.Properties using (¬-not; T-not-≡)
open import Data.Nat hiding (_⊔_)

open import Isomorphisms
open import Tests

-- | Functions are testable if their codomain is
FunTestable : {A B : Set} → Testable B → Testable (A → B)
FunTestable {A} {B} TB =
  record
  { index = A
  ; parts = λ _ → B
  ; kind = coind
  ; obs = λ f → record { app = f }
  ; partsTestable = λ _ → TB
  }

FunIsoTestable : {A B : Set} → IsoTestable B → IsoTestable (A → B)
FunIsoTestable T =
  record
  { testable = FunTestable (testable T)
  ; obsIso = (record { inv = app
                     ; isLeftInv = λ a → refl
                     ; isRightInv = λ b → refl })
  }

-- | We get extensionality for functions under observational equivalence.
ext : {A B : Set} → (T : Testable B) →
      (f : A → B) → (g : A → B) →
      ((a : A) →  f a ≃⟨ T ⟩ g a) →  f ≃⟨ FunTestable T ⟩ g
ext {A} {B} TB f g p = record { eqProof = q }
  where
    q : (φ : Test (FunTestable TB)) → f ⊨ φ ≡ g ⊨ φ
    q ⊤ = refl
    q ⊥ = refl
    q (nonTriv (i , ψ)) = eqProof (p i) ψ

-- | Make unit type testable
⊤-testable : Testable One
index  ⊤-testable = One
parts  ⊤-testable = λ _ → One
kind   ⊤-testable = coind
obs    ⊤-testable = λ { tt  → record { app = λ x → x } }
partsTestable ⊤-testable = λ i → ⊤-testable

⊤-IsoTestable : IsoTestable One
⊤-IsoTestable =
  record
  { testable = ⊤-testable
  ; obsIso =
    record { inv = λ f → app f tt
           ; isLeftInv = λ a → refl
           ; isRightInv = λ b → refl
           }
  }

-- | Obs. equiv. is a congruence on ⊤.
≃-cong-⊤ : {A : Set} → {T : Testable A} → {x y : One} →
           (f : One → A) → x ≃⟨ ⊤-testable ⟩ y → f x ≃⟨ T ⟩ f y
≃-cong-⊤ f p = record { eqProof = λ φ → refl }

Parts-ℕ : Bool → Set
Parts-ℕ true = One
Parts-ℕ false = ℕ

rep-ℕ : ℕ → Σ Bool Parts-ℕ
rep-ℕ ℕ.zero = (true , tt)
rep-ℕ (ℕ.suc n) = (false , n)

unrep-ℕ : Σ Bool Parts-ℕ → ℕ
unrep-ℕ (true , tt) = ℕ.zero
unrep-ℕ (false , n) = ℕ.suc n

-- | Make naturals testable
ℕ-testable : Testable ℕ
index  ℕ-testable = Bool
parts  ℕ-testable = Parts-ℕ
kind   ℕ-testable = ind
obs    ℕ-testable = rep-ℕ
partsTestable ℕ-testable = λ
  { true → ⊤-testable
  ; false → ℕ-testable }

ℕ-IsoTestable : IsoTestable ℕ
ℕ-IsoTestable =
  record
  { testable = ℕ-testable
  ; obsIso =
    record { inv = unrep-ℕ
           ; isLeftInv = li
           ; isRightInv = ri
           }
  }
  where
    li : (n : ℕ) → unrep-ℕ (rep-ℕ n) ≡ n
    li ℕ.zero = refl
    li (ℕ.suc a) = refl
    ri : (x : Σ Bool Parts-ℕ) → rep-ℕ (unrep-ℕ x) ≡ x
    ri (true , tt) = refl
    ri (false , n) = refl

¬zero→suc : (n : ℕ) → n ≢ zero → ∃ (λ m → n ≡ suc m)
¬zero→suc n p with n ≟ zero
¬zero→suc zero    p | yes n=z = ⊥-elim (p n=z)
¬zero→suc (suc m) p | yes sm=z = ⊥-elim (p sm=z)
¬zero→suc zero    p | no ¬n=z = ⊥-elim (p refl)
¬zero→suc (suc n) p | no ¬n=z = n , refl

lem-tt≢ff : (a : Bool) → a ≡ true → a ≢ false
lem-tt≢ff true   _ ()
lem-tt≢ff false () _

-- | If a number is observationally equivalent to 0, then it is
-- actually 0.
lem-≃→≡-ℕ-zero : {n : ℕ} → n ≃⟨ ℕ-testable ⟩ zero → n ≡ zero
lem-≃→≡-ℕ-zero {n} p = q
  where
    -- Test to distinguish zero
    ψs : SubTests ℕ-testable ind
    ψs = record { app = λ {
        true → ⊤ ;
        false → ⊥ } }

    φ : Test ℕ-testable
    φ = nonTriv ψs

    -- n fulfils test, ...
    u : n ⊨ φ ≡ true
    u = eqProof p φ

    -- ... hence is 0.
    q : n ≡ zero
    q with n ≟ zero
    q | yes n=z = n=z
    q | no ¬n=z = ⊥-elim (lem (¬zero→suc n ¬n=z))
      where
        -- If n ≡ suc n, then we get a contradiction to u
        lem : (∃ (λ m → n ≡ suc m)) → Empty
        lem (m , q) with (n ≟ suc m)
        ... | yes n=sm = lem-tt≢ff (n ⊨ φ) u contradict
          where
            contradict : n ⊨ φ ≡ false
            contradict =
              begin
                n ⊨ φ
              ≡⟨ refl ⟩
                cotuple (λ i y → y ⊨ app ψs i) (rep-ℕ n)
              ≡⟨ cong (λ u → cotuple (λ i y → y ⊨ app ψs i) (rep-ℕ u)) n=sm ⟩
                cotuple (λ i y → y ⊨ app ψs i) (false , n)
              ≡⟨ refl ⟩
                false
              ∎
        ... | no ¬n=sm = ¬n=sm q

-- | If a number is observationally equivalent to a successor, then it is
-- actually a succesor.
lem-≃→≡-ℕ-suc : (n m : ℕ) → n ≃⟨ ℕ-testable ⟩ suc m →
       ∃ λ n' → (n ≡ suc n') × (n' ≃⟨ ℕ-testable ⟩ m)
lem-≃→≡-ℕ-suc = {!!}

-- | Observational equivalence for natural numbers implies equivalence.
≃→≡-ℕ : {n m : ℕ} → n ≃⟨ ℕ-testable ⟩ m → n ≡ m
≃→≡-ℕ {n} {zero} p = lem-≃→≡-ℕ-zero p
≃→≡-ℕ {n} {(suc m)} p with lem-≃→≡-ℕ-suc n m p
... | n' , q , p' =
  begin
    n
  ≡⟨ q ⟩
    suc n'
  ≡⟨ cong suc (≃→≡-ℕ {n'} {m} p') ⟩
    suc m
  ∎

-- | Obs. equiv. is a congruence for natural numbers.
≃-cong-ℕ : {A : Set} → {T : Testable A} → {x y : ℕ} →
           (f : ℕ → A) → x ≃⟨ ℕ-testable ⟩ y → f x ≃⟨ T ⟩ f y
≃-cong-ℕ {A} {T} {x} {y} f p = record { eqProof = q }
  where
    q : (φ : Test T) → f x ⊨ φ ≡ f y ⊨ φ
    q φ = cong (λ u → f u ⊨ φ) (≃→≡-ℕ p)


-- Andreas, 2015-07-07 continuation of issue 665

{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.with.strip:60 -v tc.lhs:10 #-}

postulate
  C : Set
  anything : C

record I : Set where
  constructor c
  field
    f : C

data Wrap : (j : I) → Set where
  wrap : ∀ {j} → Wrap j

works1 : ∀ {j} → Wrap j → C
works1 {c ._} (wrap {c x}) with anything
... | z = z

works2 : ∀ {j} → Wrap j → C
works2 (wrap {_}) with anything
... | z = z

works3 : ∀ {j} → Wrap j → C
works3 wrap with anything
... | z = z

works : ∀ {j} → Wrap j → C
works {c _} (wrap {c ._}) with anything
works {c _} (wrap .{c _}) | z = z

-- The following should not pass, but issue 142 is hard to fix
-- with the current infrastructure for with-clauses.
-- Not many attempts have been made since 2009, and none succeeded.
issue142 : ∀ {j} → Wrap j → C
issue142 {c _} (wrap {c ._}) with anything
issue142 {c _} (wrap .{c anything}) | z = z

test : ∀ {j} → Wrap j → C
test {c _} (wrap {c ._}) with anything
test {c _} (wrap {c ._}) | z = z

test' : ∀ {j} → Wrap j → C
test' {c _} (wrap {c ._}) with anything
... | z = z

-- ERROR WAS::
-- Inaccessible (dotted) patterns from the parent clause must also be
-- inaccessible in the with clause, when checking the pattern {c ._},
-- when checking that the clause
-- test {c _} (wrap {c ._}) with anything
-- test {c _} (wrap {c ._}) | z = z
-- has type {j : I} → Wrap j → C

works1a : ∀ {j} → Wrap j → C
works1a {c ._} (wrap {c x}) with anything
works1a {c ._} (wrap {c x}) | z = z

works1b : ∀ {j} → Wrap j → C
works1b {c ._} (wrap {c x}) with anything
works1b .{c _} (wrap {c x}) | z = z

-- ERROR WAS:
-- With clause pattern .(c _) is not an instance of its parent pattern
-- (c .(Var 0 []) : {I})
-- when checking that the clause
-- works1b {c ._} (wrap {c _}) with anything
-- works1b {.(c _)} (wrap {c _}) | z = z
-- has type {j : I} → Wrap j → C

-- should pass


-- Andreas & Jesper, 2018-05-11, issue #3052 reported by identicalsnowflake
--
-- The problem here was that free variable collection had the standard
-- monoid instance of IntMap, which is just "randomly" picking one variant.
-- Thus, if we have both irrelevant and relevant occurrences of a variable,
-- we get whatever.
-- Now we keep the stronger information (relevant, see maxVarOcc).

{-# OPTIONS --show-irrelevant #-}
-- {-# OPTIONS -v tc.meta.assign:100 -v tc.meta.occurs:45 #-}
-- {-# OPTIONS -v tc.lhs:100 #-}

postulate
  A : Set
  B : A → Set

record Σ : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁
open Σ public

record Foo : Set where
  constructor foo
  field
    .theFoo : Σ

test : Foo → Foo
test (foo (a , b)) = foo (a , thm a b) -- Error at b
  -- Constraint: a, b ⊢ ?0 .a .b a = B a : Set
  -- Note the irrelevant occurrence .a and the relevant occurrence a
  -- on the lhs of this constraint!
  where
    -- Meta ?0 : [.a, .b, x] Set
    postulate thm : (x : A) (y : _) → B x
    -- Underscore should solved by B x
    -- thm x y = y -- WAS: Worked only if definition is given (which

-- Should succeed.


{-# OPTIONS --prop --rewriting #-}

module Examples.Gcd.Refine where

open import Calf.CostMonoid
import Calf.CostMonoids as CM

open import Calf CM.ℕ-CostMonoid
open import Calf.Types.Nat
open import Calf.Types.Bounded CM.ℕ-CostMonoid

open import Examples.Gcd.Euclid
open import Examples.Gcd.Clocked as Clocked

open import Data.Nat.DivMod
open import Data.Nat
open import Relation.Binary.PropositionalEquality as P
open import Function
open import Data.Nat.Properties
open import Data.Product
open import Data.Bool using (Bool; false; true)
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary

fib : ℕ → ℕ
fib 0 = 0
fib 1 = 1
fib (suc (suc n)) = fib (suc n) + fib n

fib⁻¹/helper : ℕ → ℕ → ℕ
fib⁻¹/helper F zero = 0
fib⁻¹/helper F (suc i) with fib (suc i) ≤? F
... | (true because (ofʸ py)) = suc i
... | (false because (ofⁿ pn)) = fib⁻¹/helper F i

fib⁻¹ : ℕ → ℕ
fib⁻¹ F = fib⁻¹/helper F (1 + F)

fib⁻¹-unfold : ∀ F i → ¬ (fib (suc i) ≤ F) →
               fib⁻¹/helper F (suc i) ≡ fib⁻¹/helper F i
fib⁻¹-unfold F i h with fib (suc i) ≤? F
... | (true because (ofʸ py)) = case (h py) of λ {()}
... | (false because (ofⁿ pn)) = refl

fib-base : ∀ n → 1 ≤ fib (1 + n)
fib-base zero = s≤s z≤n
fib-base (suc n') =
  let g = fib-base n' in
  ≤-trans g (m≤m+n _ _)

fib-inc : ∀ n → n < fib (2 + n)
fib-inc zero = s≤s z≤n
fib-inc (suc n') =
  let g = fib-inc n' in
  let g1 = +-mono-≤ g (fib-base n') in
  subst (λ k → k ≤ fib (2 + suc n')) (P.cong suc (P.trans (+-suc n' 0) (P.cong suc (+-identityʳ _)))) g1

fib-fib⁻¹/helper : ∀ F i → fib (suc i) > F → Σ (fib (fib⁻¹/helper F i) ≤ F) λ _ → F < fib (1 + fib⁻¹/helper F i)
fib-fib⁻¹/helper F zero h = z≤n , h
fib-fib⁻¹/helper F (suc i') h with fib (suc i') ≤? F
... | (true because (ofʸ py)) = py , h
... | (false because (ofⁿ pn)) = fib-fib⁻¹/helper F i' (≰⇒> pn)

fib-fib⁻¹ : ∀ F → Σ (fib (fib⁻¹ F) ≤ F) λ _ → F < fib (1 + fib⁻¹ F)
fib-fib⁻¹ F = fib-fib⁻¹/helper F (1 + F) (fib-inc F)

fib-mono-< : fib Preserves _<_ ⟶ _≤_
fib-mono-< {zero} {zero} h = case h of λ {()}
fib-mono-< {zero} {suc y} h = ≤-trans z≤n (fib-base y)
fib-mono-< {1} {1} (s≤s h) = case h of λ {()}
fib-mono-< {1} {suc (suc y)} h = fib-base (suc y)
fib-mono-< {suc (suc x)} {suc (suc y)} (s≤s (s≤s h)) =
  let g = fib-mono-< h in
  let g1 = fib-mono-< (s≤s h) in
  +-mono-≤ g1 g

-- test : ℕ
-- test = gcd/depth (7 , 4 , s≤s (s≤s (s≤s (s≤s (s≤s z≤n)))))

gcd/fib : ∀ (n : ℕ) (i@(x , y , h) : m>n) →
          gcd/depth i ≥ 1 + n  →
          Σ (x ≥ fib (2 + n)) λ _ → (y ≥ fib (1 + n))
gcd/fib zero (x , y , h) h1 with 1 ≤? y | 1 ≤? x
... | (true because (ofʸ py)) | (true because (ofʸ px)) = px , py
... | (true because _) | (false because (ofⁿ px)) =
  let g = ≰⇒> px in
  let g1 = n<1⇒n≡0 g in
  let g2 = P.subst (λ x → y < x) g1 h in
  case g2 of λ { () }
... | (false because (ofⁿ py)) | _ rewrite (n<1⇒n≡0 (≰⇒> py)) =
  case h1 of λ { () }
gcd/fib (suc n) (x , y , h) h1 with y
... | zero = let g = n≤0⇒n≡0 h1 in case g of λ {()}
... | suc y' rewrite gcd/depth-unfold-suc {x} {y'} {h} =
  let g : suc (gcd/depth (suc y' , x % suc y' , m%n<n x y')) ≥ 1 + (suc n)
      g = h1 in
  let g1 = +-cancelˡ-≤ 1 g in
  let (r1 , r2) = gcd/fib n (suc y' , x % suc y' , m%n<n x y') g1 in
  let r1' : fib n + fib (suc n) ≤ suc y'
      r1' = P.subst (λ n → n ≤ suc y') (+-comm (fib (suc n)) (fib n)) r1 in
  (let e1 = m≡m%n+[m/n]*n x y' in
  let e2 = m/n*n≤m x (suc y') in
  let e3 : 1 ≤ x / suc y'
      e3 = m≥n⇒m/n>0 (≤-trans (n≤1+n (suc y'))  h) in
  let e4 : 1 * (suc y') ≤ x / suc y' * suc y'
      e4 = *-monoˡ-≤ (suc y') e3 in
  let e5 = P.subst (λ n → n ≤ x / suc y' * suc y') (*-identityˡ (suc y')) e4 in
  P.subst (λ n → x ≥ n) (P.sym (+-assoc (fib (1 + n)) (fib n) (fib (1 + n)))) (
  P.subst (λ x → x ≥ _) (P.sym e1)
    (+-mono-≤ {x = fib (1 + n)} {y = x % (suc y')}
    r2 (≤-trans r1' e5))
  )), r1

gcd/depth/bound : ∀ (n : ℕ) (i@(x , y , h) : m>n) →
                x < fib (2 + n) → y < (fib (1 + n)) →
                gcd/depth i < 1 + n
gcd/depth/bound n i h1 h2 = ≰⇒> (contraposition (gcd/fib n i) (λ { (g1 , g2) → (<⇒≱ h1) g1}))

gcd/depth/closed : m>n → ℕ
gcd/depth/closed i@(x , y , h) = 1 + fib⁻¹ x

gcd/depth≤gcd/depth/closed : ∀ (i@(x , y , h) : m>n) → gcd/depth i ≤ gcd/depth/closed i
gcd/depth≤gcd/depth/closed i@(x , y , h) =
  let g : x < fib (1 + fib⁻¹ x)
      g = fib-fib⁻¹ x .proj₂ in
  let g1 : fib (1 + fib⁻¹ x) ≤ fib (2 + fib⁻¹ x)
      g1 = fib-mono-< {1 + fib⁻¹ x} {2 + fib⁻¹ x} (+-monoˡ-< (fib⁻¹ x) (s≤s (s≤s z≤n))) in
  (<⇒≤ (gcd/depth/bound _ i (<-transˡ g g1) (<-trans h g)))

gcd≤gcd/depth/closed : ∀ i → IsBounded nat (gcd i) (gcd/depth/closed i)
gcd≤gcd/depth/closed i = bound/relax (λ _ → gcd/depth≤gcd/depth/closed i) (gcd≤gcd/depth i)


{-# OPTIONS --prop #-}

postulate
  P : Prop
  p : P

-- C-c C-n should print `p` as `_`

record Box (X : Prop) : Set where
  constructor box
  field unbox : X
open Box

test : P → Box P
test = λ x → box x

-- C-c C-n should print `test` as `λ x → box _`


{-# OPTIONS --allow-unsolved-metas #-}
module _ where

open import Agda.Builtin.Nat
open import Agda.Builtin.List
open import Agda.Builtin.Unit
open import Agda.Builtin.Sigma

_×_ : Set → Set → Set
A × B = Σ A λ _ → B

data Vec (A : Set) : Nat → Set where
  []  : Vec A 0
  _∷_ : ∀ {n} → A → Vec A n → Vec A (suc n)

data All {A : Set} (P : A → Set) : List A → Set where
  []  : All P []
  _∷_ : ∀ {x xs} → P x → All P xs → All P (x ∷ xs)

data Ty : Set where

module Code where

  Schema : List Nat → Set
  Schema = All (λ k → Vec Ty k × Ty)

  data Binder : Set where
    bound unbound : Binder

  Shape : Nat → Set
  Shape n = List (Vec Binder n)

  data Code : Set₁ where
    sg : (A : Set) → (A → Code) → Code
    node : (n : Nat) (shape : Shape n) (wt : Vec Ty n → All (λ _ → Ty) shape → Ty → Set) → Code

module Ctx where
  infixr 4 _,_

  data Ctx : Set where
    ∅ : Ctx
    _,_ : Ctx → Ty → Ctx

  _<><_ : Ctx → List Ty → Ctx
  Γ <>< [] = Γ
  Γ <>< (t ∷ ts) = (Γ , t) <>< ts

module Typed (code : Code.Code) where
  open Code
  open Ctx

  visible : ∀ {n} → Vec Binder n → Vec Ty n → List Ty
  visible []             []       = []
  visible (bound ∷ bs)   (t ∷ ts) = t ∷ visible bs ts
  visible (unbound ∷ bs) (_ ∷ ts) = visible bs ts

  mutual
    data Tm (Γ : Ctx) : Ty → Set where

    data Con (Γ : Ctx) (t : Ty) : Code → Set where
      sg : ∀ {A c} x → Con Γ t (c x) → Con Γ t (sg A c)
      node : ∀ {n shape wt} (ts₀ : Vec Ty n) {ts : All (λ _ → Ty) shape} (es : Children Γ ts₀ ts) →
        {{_ : wt ts₀ ts t}} → Con Γ t (node n shape wt)

    data Children (Γ : Ctx) {n : Nat} (ts₀ : Vec Ty n) : {sh : Shape n} → All (λ _ → Ty) sh → Set where
      [] : Children Γ ts₀ []
      _∷_ : ∀ {bs sh t ts} → Tm (Γ <>< visible bs ts₀) t → Children Γ ts₀ {sh} ts → Children Γ ts₀ {bs ∷ sh} (t ∷ ts)

  module Sem₀ (P : Ctx → Ty → Set) where
    children : ∀ {n} (Γ : Ctx) (ts₀ : Vec Ty n) (shape : List (Vec Binder n)) (ts : All (λ _ → Ty) shape) → Set
    children Γ ts₀ [] [] = ⊤
    children Γ ts₀ (bs ∷ bss) (t ∷ ts) = P (Γ <>< visible bs ts₀ ) t × children Γ ts₀ bss ts

    aux : Code → Set
    aux (sg A k) = (x : A) → aux (k x)
    aux (node n shape wt) = ∀ {Γ t} {ts₀ ts} → children Γ ts₀ shape ts → wt ts₀ ts t → P Γ t

  Sem : (P : Ctx → Ty → Set) → Set
  Sem P = Sem₀.aux P code

open Code

data Phase : Set where
  input : Phase

data `STLC : Phase → Set where
  `let : `STLC input

STLC : Phase → Code
STLC p = sg (`STLC p) aux
  where
    aux : `STLC p → Code
    aux `let = node 1 ((bound ∷ []) ∷ []) λ { (t₀ ∷ _) (t₁ ∷ _) t → ⊤ }

open Ctx

open Typed (STLC input) using (Sem)

ap : Sem λ Γ t → Nat
ap = λ where `let → {!!}


  postulate
    F : Set₂ → Set₃
    G : Set₁ → Set₂
    H : Set₀ → Set₁

  infix 1 F
  infix 2 G
  infix 3 H

  syntax F x = ! x
  syntax G x = # x
  syntax H x = ! x

  ok₁ : Set₀ → Set₂
  ok₁ X = # ! X

  ok₂ : Set₁ → Set₃
  ok₂ X = ! # X


------------------------------------------------------------------------
-- This module proves that the context-sensitive language aⁿbⁿcⁿ can
-- be recognised
------------------------------------------------------------------------

-- This is obvious given the proof in
-- TotalRecognisers.LeftRecursion.ExpressiveStrength but the code
-- below provides a non-trivial example of the use of the parser
-- combinators.

module TotalRecognisers.LeftRecursion.NotOnlyContextFree where

open import Algebra
open import Codata.Musical.Notation
open import Data.Bool using (Bool; true; false; _∨_)
open import Function
open import Data.List as List using (List; []; _∷_; _++_; [_])
import Data.List.Properties
private
  module ListMonoid {A : Set} =
    Monoid (Data.List.Properties.++-monoid A)
open import Data.Nat as Nat using (ℕ; zero; suc; _+_)
import Data.Nat.Properties as NatProp
private
  module NatCS = CommutativeSemiring NatProp.+-*-commutativeSemiring
import Data.Nat.Solver
open Data.Nat.Solver.+-*-Solver
open import Data.Product
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open ≡-Reasoning

import TotalRecognisers.LeftRecursion
import TotalRecognisers.LeftRecursion.Lib as Lib

------------------------------------------------------------------------
-- The alphabet

data Tok : Set where
  a b c : Tok

_≟_ : Decidable (_≡_ {A = Tok})
a ≟ a = yes refl
a ≟ b = no λ()
a ≟ c = no λ()
b ≟ a = no λ()
b ≟ b = yes refl
b ≟ c = no λ()
c ≟ a = no λ()
c ≟ b = no λ()
c ≟ c = yes refl

open TotalRecognisers.LeftRecursion Tok
open Lib Tok
private
  open module TokTok = Lib.Tok Tok _≟_ using (tok)

------------------------------------------------------------------------
-- An auxiliary definition and a boring lemma

infixr 8 _^^_

_^^_ : Tok → ℕ → List Tok
_^^_ = flip List.replicate

private

  shallow-comm : ∀ i n → i + suc n ≡ suc (i + n)
  shallow-comm i n =
    solve 2 (λ i n → i :+ (con 1 :+ n) := con 1 :+ i :+ n) refl i n

------------------------------------------------------------------------
-- Some lemmas relating _^^_, _^_ and tok

tok-^-complete : ∀ t i → t ^^ i ∈ tok t ^ i
tok-^-complete t zero    = empty
tok-^-complete t (suc i) =
  add-♭♯ ⟨ false ^ i ⟩-nullable TokTok.complete · tok-^-complete t i

tok-^-sound : ∀ t i {s} → s ∈ tok t ^ i → s ≡ t ^^ i
tok-^-sound t zero    empty     = refl
tok-^-sound t (suc i) (t∈ · s∈)
  with TokTok.sound (drop-♭♯ ⟨ false ^ i ⟩-nullable t∈)
... | refl = cong (_∷_ t) (tok-^-sound t i s∈)

------------------------------------------------------------------------
-- aⁿbⁿcⁿ

-- The context-sensitive language { aⁿbⁿcⁿ | n ∈ ℕ } can be recognised
-- using the parser combinators defined in this development.

private

  -- The two functions below are not actually mutually recursive, but
  -- are placed in a mutual block to ensure that the constraints
  -- generated by the second function can be used to instantiate the
  -- underscore in the body of the first.

  mutual

    aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-index : ℕ → Bool
    aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-index _ = _

    aⁿbⁱ⁺ⁿcⁱ⁺ⁿ : (i : ℕ) → P (aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-index i)
    aⁿbⁱ⁺ⁿcⁱ⁺ⁿ i = cast lem (♯? (tok a) · ♯ aⁿbⁱ⁺ⁿcⁱ⁺ⁿ (suc i))
                 ∣ tok b ^ i ⊙ tok c ^ i
      where lem = left-zero (aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-index (suc i))

aⁿbⁿcⁿ : P true
aⁿbⁿcⁿ = aⁿbⁱ⁺ⁿcⁱ⁺ⁿ 0

-- Let us prove that aⁿbⁿcⁿ is correctly defined.

aⁿbⁿcⁿ-string : ℕ → List Tok
aⁿbⁿcⁿ-string n = a ^^ n ++ b ^^ n ++ c ^^ n

private

  aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-string : ℕ → ℕ → List Tok
  aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-string n i = a ^^ n ++ b ^^ (i + n) ++ c ^^ (i + n)

aⁿbⁿcⁿ-complete : ∀ n → aⁿbⁿcⁿ-string n ∈ aⁿbⁿcⁿ
aⁿbⁿcⁿ-complete n = aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-complete n 0
  where
  aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-complete : ∀ n i → aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-string n i ∈ aⁿbⁱ⁺ⁿcⁱ⁺ⁿ i
  aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-complete zero i with i + 0 | proj₂ NatCS.+-identity i
  ... | .i | refl = ∣-right {n₁ = false} (helper b · helper c)
    where
    helper = λ (t : Tok) →
      add-♭♯ ⟨ false ^ i ⟩-nullable (tok-^-complete t i)
  aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-complete (suc n) i with i + suc n | shallow-comm i n
  ... | .(suc i + n) | refl =
    ∣-left $ cast {eq = lem} (
      add-♭♯ (aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-index (suc i)) TokTok.complete ·
      aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-complete n (suc i))
    where lem = left-zero (aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-index (suc i))

aⁿbⁿcⁿ-sound : ∀ {s} → s ∈ aⁿbⁿcⁿ → ∃ λ n → s ≡ aⁿbⁿcⁿ-string n
aⁿbⁿcⁿ-sound = aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-sound 0
  where
  aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-sound : ∀ {s} i → s ∈ aⁿbⁱ⁺ⁿcⁱ⁺ⁿ i →
                     ∃ λ n → s ≡ aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-string n i
  aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-sound i (∣-left (cast (t∈ · s∈)))
    with TokTok.sound (drop-♭♯ (aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-index (suc i)) t∈)
  ... | refl with aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-sound (suc i) s∈
  ... | (n , refl) = suc n , (begin
    a ^^ suc n ++ b ^^ (suc i + n) ++ c ^^ (suc i + n)
      ≡⟨ cong (λ i → a ^^ suc n ++ b ^^ i ++ c ^^ i)
              (sym (shallow-comm i n)) ⟩
    a ^^ suc n ++ b ^^ (i + suc n) ++ c ^^ (i + suc n)
      ∎)
  aⁿbⁱ⁺ⁿcⁱ⁺ⁿ-sound i (∣-right (_·_ {s₁} {s₂} s₁∈ s₂∈)) = 0 , (begin
    s₁ ++ s₂
      ≡⟨ cong₂ _++_ (tok-^-sound b i
                      (drop-♭♯ ⟨ false ^ i ⟩-nullable s₁∈))
                    (tok-^-sound c i
                      (drop-♭♯ ⟨ false ^ i ⟩-nullable s₂∈)) ⟩
    b ^^ i ++ c ^^ i
      ≡⟨ cong (λ i → b ^^ i ++ c ^^ i)
              (sym (proj₂ NatCS.+-identity i)) ⟩
    b ^^ (i + 0) ++ c ^^ (i + 0)
      ∎)


{-# OPTIONS --safe #-}

module Definition.Typed.Consequences.Reduction where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Fundamental.Reducibility
import Tools.PropositionalEquality as PE

open import Tools.Product

-- Helper function where all reducible types can be reduced to WHNF.
whNorm′ : ∀ {A rA Γ l} ([A] : Γ ⊩⟨ l ⟩ A ^ rA)
                → ∃ λ B → Whnf B × Γ ⊢ A :⇒*: B ^ rA
whNorm′ (Uᵣ′ _ _ r l _ e d) = Univ r l , Uₙ , PE.subst (λ ll → _ ⊢ _ :⇒*: Univ r l ^ [ ! , ll ]) e d
whNorm′ (ℕᵣ D) = ℕ , ℕₙ , D
whNorm′ (Emptyᵣ {l = l} D) = Empty l , Emptyₙ , D
whNorm′ (ne′ K D neK K≡K) = K , ne neK , D
whNorm′ (Πᵣ {l = l} (Πᵣ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) = Π F ^ rF ° lF ▹ G ° lG ° l , Πₙ , D
whNorm′ (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) = ∃ F ▹ G , ∃ₙ , D
whNorm′ (emb emb< [A]) = whNorm′ [A]
whNorm′ (emb ∞< [A]) = whNorm′ [A]

-- Well-formed types can all be reduced to WHNF.
whNorm : ∀ {A rA Γ} → Γ ⊢ A ^ rA → ∃ λ B → Whnf B × Γ ⊢ A :⇒*: B ^ rA
whNorm A = whNorm′ (reducible A)

-- whNorm-conv : ∀ {A rA Γ} → Γ ⊢ A ≡ B ^ rA → ∃ λ B → Whnf B × Γ ⊢ A :⇒*: B ^ rA
-- whNorm-conv A = whNorm′ (reducible A)

-- Helper function where reducible all terms can be reduced to WHNF.
whNormTerm′ : ∀ {a A Γ l lA} ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , lA ]) → Γ ⊩⟨ l ⟩ a ∷ A ^ [ ! , lA ] / [A]
                → ∃ λ b → Whnf b × Γ ⊢ a :⇒*: b ∷ A ^ lA
whNormTerm′ (Uᵣ′ _ _ r l _ e dU) (Uₜ A d typeA A≡A [t]) = A , typeWhnf typeA ,
  conv:⇒*: (PE.subst (λ ll → _ ⊢ _ :⇒*: _ ∷ _ ^ ll) e d)
    (sym (subset* (red (PE.subst (λ ll → _ ⊢ _ :⇒*: Univ r l ^ [ ! , ll ]) e dU))))
whNormTerm′ (ℕᵣ x) (ℕₜ n d n≡n prop) =
  let natN = natural prop
  in  n , naturalWhnf natN , convRed:*: d (sym (subset* (red x)))
whNormTerm′ (ne (ne K D neK K≡K)) (neₜ k d (neNfₜ neK₁ ⊢k k≡k)) =
  k , ne neK₁ , convRed:*: d (sym (subset* (red D)))
whNormTerm′ (Πᵣ′ rF lF lG lF≤ lG≤  F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Πₜ f d funcF f≡f [f] [f]₁) =
  f , functionWhnf funcF , convRed:*: d (sym (subset* (red D)))
whNormTerm′ (emb emb< [A]) [a] = whNormTerm′ [A] [a]
whNormTerm′ (emb ∞< [A]) [a] = whNormTerm′ [A] [a]

-- Well-formed terms can all be reduced to WHNF.
whNormTerm : ∀ {a A Γ lA} → Γ ⊢ a ∷ A ^ [ ! , lA ] → ∃ λ b → Whnf b × Γ ⊢ a :⇒*: b ∷ A ^ lA
whNormTerm {a} {A} ⊢a =
  let [A] , [a] = reducibleTerm ⊢a
  in  whNormTerm′ [A] [a]


module Tactic.Nat.Coprime.Decide where

open import Prelude
open import Prelude.Equality.Unsafe
open import Prelude.List.Relations.Any
open import Prelude.List.Relations.All
open import Prelude.List.Relations.Properties

open import Numeric.Nat
open import Tactic.Nat.Coprime.Problem

private
  infix 4 _isIn_
  _isIn_ : Nat → Exp → Bool
  x isIn atom y = isYes (x == y)
  x isIn a ⊗ b = x isIn a || x isIn b

  proves : Nat → Nat → Formula → Bool
  proves x y (a ⋈ b) = x isIn a && y isIn b || x isIn b && y isIn a

  hypothesis : Nat → Nat → List Formula → Bool
  hypothesis x y Γ = any? (proves x y) Γ

  canProve' : List Formula → Exp → Exp → Bool
  canProve' Γ (atom x) (atom y) = hypothesis x y Γ
  canProve' Γ a (b ⊗ c) = canProve' Γ a b && canProve' Γ a c
  canProve' Γ (a ⊗ b) c = canProve' Γ a c && canProve' Γ b c

canProve : Problem → Bool
canProve (Γ ⊨ a ⋈ b) = canProve' Γ a b

-- Soundness proof --

private
  invert-&&₁ : ∀ {a b} → (a && b) ≡ true → a ≡ true
  invert-&&₁ {false} ()
  invert-&&₁ {true}  prf = refl

  invert-&&₂ : ∀ {a b} → (a && b) ≡ true → b ≡ true
  invert-&&₂ {false} ()
  invert-&&₂ {true} prf = prf

  invert-|| : ∀ a {b} → (a || b) ≡ true → Either (a ≡ true) (b ≡ true)
  invert-|| false prf = right prf
  invert-|| true  prf = left prf

  sound-eq : (a b : Nat) → isYes (a == b) ≡ true → a ≡ b
  sound-eq a b ok with a == b
  sound-eq a b ok | yes a=b = a=b
  sound-eq a b () | no _

  sound-any : ∀ {A : Set} (p : A → Bool) xs → any? p xs ≡ true → Any (λ x → p x ≡ true) xs
  sound-any p [] ()
  sound-any p (x ∷ xs) ok with p x | graphAt p x
  ... | false | _          = suc (sound-any p xs ok)
  ... | true  | ingraph eq = zero eq

private
  syntax WithHyps Γ (λ ρ → A) = ρ ∈ Γ ⇒ A
  WithHyps : List Formula → (Env → Set) → Set
  WithHyps Γ F = ∀ ρ → All (⟦_⟧f ρ) Γ → F ρ

  sound-isIn' : ∀ x y a b → (x isIn a) ≡ true → (y isIn b) ≡ true → ∀ ρ → ⟦ a ⋈ b ⟧f ρ → Coprime (ρ x) (ρ y)

  sound-isIn-⊗-l : ∀ x y a b c → (x isIn a) ≡ true → (y isIn b ⊗ c) ≡ true →
                                 ∀ ρ → ⟦ a ⋈ b ⊗ c ⟧f ρ → Coprime (ρ x) (ρ y)
  sound-isIn-⊗-l x y a b c oka okbc ρ H =
    case invert-|| (y isIn b) okbc of λ where
      (left okb)  → sound-isIn' x y a b oka okb ρ (mul-coprime-l (⟦ a ⟧e ρ) (⟦ b ⟧e ρ) (⟦ c ⟧e ρ) H)
      (right okc) → sound-isIn' x y a c oka okc ρ (mul-coprime-r (⟦ a ⟧e ρ) (⟦ b ⟧e ρ) (⟦ c ⟧e ρ) H)

  sound-isIn' x y (atom x') (atom y') oka okb ρ H =
    case₂ sound-eq x x' oka , sound-eq y y' okb of λ where
      refl refl → H
  sound-isIn' x y a@(atom _) (b ⊗ c) oka okbc ρ H = sound-isIn-⊗-l x y a b c oka okbc ρ H
  sound-isIn' x y a@(_ ⊗ _) (b ⊗ c) oka okbc ρ H = sound-isIn-⊗-l x y a b c oka okbc ρ H
  sound-isIn' x y (a ⊗ b) c@(atom _) okab okc ρ H =
    let nf = λ e → ⟦ e ⟧e ρ
        H' = coprime-sym _ (nf c) H
    in
    case invert-|| (x isIn a) okab of λ where
      (left  oka) → sound-isIn' x y a c oka okc ρ
                      (coprime-sym (nf c) _
                        (mul-coprime-l (nf c) (nf a) (nf b) H'))
      (right okb) → sound-isIn' x y b c okb okc ρ
                      (coprime-sym (nf c) _
                        (mul-coprime-r (nf c) (nf a) _ H'))

  sound-isIn : ∀ x y a b → (x isIn a && y isIn b) ≡ true → ∀ ρ → ⟦ a ⋈ b ⟧f ρ → Coprime (ρ x) (ρ y)
  sound-isIn x y a b ok = sound-isIn' x y a b (invert-&&₁ ok) (invert-&&₂ ok)

  sound-proves : ∀ x y φ → proves x y φ ≡ true → ∀ ρ → ⟦ φ ⟧f ρ → Coprime (ρ x) (ρ y)
  sound-proves x y (a ⋈ b) ok ρ H =
    case invert-|| (x isIn a && y isIn b) ok of λ where
      (left  ok) → sound-isIn x y a b ok ρ H
      (right ok) → sound-isIn x y b a ok ρ (coprime-sym (⟦ a ⟧e ρ) _ H)

  sound-hyp : ∀ x y Γ → hypothesis x y Γ ≡ true → ρ ∈ Γ ⇒ Coprime (ρ x) (ρ y)
  sound-hyp x y Γ ok ρ Ξ =
    case lookupAny Ξ (sound-any (proves x y) Γ ok) of λ where
      (φ , H , okφ) → sound-proves x y φ okφ ρ H

  sound' : ∀ Γ a b → canProve' Γ a b ≡ true → ρ ∈ Γ ⇒ ⟦ a ⋈ b ⟧f ρ

  sound-⊗-r : ∀ Γ a b c → (canProve' Γ a b && canProve' Γ a c) ≡ true → ρ ∈ Γ ⇒ ⟦ a ⋈ b ⊗ c ⟧f ρ
  sound-⊗-r Γ a b c ok ρ Ξ =
    let a⋈b : ⟦ a ⋈ b ⟧f ρ
        a⋈b = sound' Γ a b (invert-&&₁ ok) ρ Ξ
        a⋈c : ⟦ a ⋈ c ⟧f ρ
        a⋈c = sound' Γ a c (invert-&&₂ ok) ρ Ξ
    in coprime-mul-r (⟦ a ⟧e ρ) _ _ a⋈b a⋈c

  sound' Γ (atom x) (atom y) ok ρ Ξ = sound-hyp x y Γ ok ρ Ξ
  sound' Γ a@(atom _) (b ⊗ c) ok ρ Ξ = sound-⊗-r Γ a b c ok ρ Ξ
  sound' Γ a@(_ ⊗ _) (b ⊗ c) ok ρ Ξ = sound-⊗-r Γ a b c ok ρ Ξ
  sound' Γ (a ⊗ b) c@(atom _) ok ρ Ξ =
    let a⋈c : ⟦ a ⋈ c ⟧f ρ
        a⋈c = sound' Γ a c (invert-&&₁ ok) ρ Ξ
        b⋈c : ⟦ b ⋈ c ⟧f ρ
        b⋈c = sound' Γ b c (invert-&&₂ ok) ρ Ξ
    in coprime-mul-l (⟦ a ⟧e ρ) _ _ a⋈c b⋈c

sound : ∀ Q → canProve Q ≡ true → ∀ ρ → ⟦ Q ⟧p ρ
sound Q@(Γ ⊨ a ⋈ b) ok ρ = curryProblem Q ρ (sound' Γ a b ok ρ)


module Sessions.Semantics.Commands where

open import Prelude
open import Data.Fin

open import Sessions.Syntax.Types
open import Sessions.Syntax.Values

mutual
  data Cmd : Pred RCtx 0ℓ where
    fork    :             ∀[ Comp unit ⇒ Cmd ]
    mkchan  : ∀ α       → ε[ Cmd ]
    send    : ∀ {a α}   → ∀[ (Endptr (a ! α) ✴ Val a) ⇒ Cmd ]
    receive : ∀ {a α}   → ∀[ Endptr (a ¿ α) ⇒ Cmd ]
    close   :             ∀[ Endptr end ⇒ Cmd ]

  δ : ∀ {Δ} → Cmd Δ → Pred RCtx 0ℓ
  δ (fork {α} _)        = Emp
  δ (mkchan α)          = Endptr α ✴ Endptr (α ⁻¹)
  δ (send {α = α} _)    = Endptr α
  δ (receive {a} {α} _) = Val a ✴ Endptr α
  δ (close _)           = Emp

  open import Relation.Ternary.Separation.Monad.Free Cmd δ renaming (Cont to Cont')
  open import Relation.Ternary.Separation.Monad.Error

  Comp : Type → Pred RCtx _
  Comp a = ErrorT Free (Val a)


module Preduploid.Functor where

open import Preduploid

open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)

open import Level

private
  variable p q r s : Polarity

record Functor {o₁ ℓ₁ o₂ ℓ₂} (𝒞 : Preduploid o₁ ℓ₁) (𝒟 : Preduploid o₂ ℓ₂)
  : Set (levelOfTerm 𝒞 ⊔ levelOfTerm 𝒟) where
  private
    module 𝒞 = Preduploid.Preduploid 𝒞
    module 𝒟 = Preduploid.Preduploid 𝒟

  open 𝒟

  field
    F₀ : 𝒞.Ob p -> Ob p
    F₁ : forall {A : 𝒞.Ob p} {B : 𝒞.Ob q} -> A 𝒞.⇒ B -> F₀ A ⇒ F₀ B

    identity : forall {A : 𝒞.Ob p} -> F₁ 𝒞.id ≡ id {A = F₀ A}
    homomorphism : forall {A : 𝒞.Ob p} {B : 𝒞.Ob q} {C : 𝒞.Ob r} {f : A 𝒞.⇒ B} {g : B 𝒞.⇒ C}
      -> F₁ (g 𝒞.⊙ f) ≡ F₁ g ⊙ F₁ f


module Data.Num.Properties where

open import Data.Num
open import Data.Num.Core
open import Data.Num.Next
open import Data.Num.Continuous

open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Data.Nat.Properties.Extra
open import Data.Fin.Properties hiding (setoid; _≟_)
open import Data.Nat.DM
open import Data.Fin as Fin
    using (Fin; #_; fromℕ≤; inject≤)
    renaming (zero to z; suc to s)
open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥)
open import Function
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Nullary.Negation
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning
open ≤-Reasoning renaming (begin_ to start_; _∎ to _□; _≡⟨_⟩_ to _≈⟨_⟩_)

open DecTotalOrder decTotalOrder using (reflexive) renaming (refl to ≤-refl)

-- start
--     {!   !}
-- ≤⟨ {!   !} ⟩
--     {!   !}
-- ≤⟨ {!   !} ⟩
--     {!   !}
-- ≤⟨ {!   !} ⟩
--     {!   !}
-- □

-- begin
--     {!   !}
-- ≡⟨ {!   !} ⟩
--     {!   !}
-- ≡⟨ {!   !} ⟩
--     {!   !}
-- ≡⟨ {!   !} ⟩
--     {!   !}
-- ≡⟨ {!   !} ⟩
--     {!   !}
-- ∎

-- toℕ-⊹-ℤₙ-homo : ∀ {o}
--     → (xs ys : Numeral 1 1 o)
--     → ⟦ ⊹-ℤₙ xs ys ⟧ ≡ ⟦ xs ⟧ + ⟦ ys ⟧
-- toℕ-⊹-ℤₙ-homo {o} (x ∙) ys =
--     begin
--         Digit-toℕ x o + ⟦ ys ⟧ * 1
--     ≡⟨ cong (_+_ (Digit-toℕ x o)) (*-right-identity ⟦ ys ⟧) ⟩
--         Digit-toℕ x o + ⟦ ys ⟧
--     ∎
-- toℕ-⊹-ℤₙ-homo {o} (x ∷ xs) ys =
--     begin
--         Digit-toℕ x o + ⟦ ⊹-ℤₙ xs ys ⟧ * 1
--     ≡⟨ cong (λ w → Digit-toℕ x o + w * 1) (toℕ-⊹-ℤₙ-homo xs ys) ⟩
--         Digit-toℕ x o + (⟦ xs ⟧ + ⟦ ys ⟧) * 1
--     ≡⟨ cong (_+_ (Digit-toℕ x o)) (distribʳ-*-+ 1 ⟦ xs ⟧ ⟦ ys ⟧) ⟩
--         Digit-toℕ x o + (⟦ xs ⟧ * 1 + ⟦ ys ⟧ * 1)
--     ≡⟨ cong (λ w → Digit-toℕ x o + (⟦ xs ⟧ * 1 + w)) (*-right-identity ⟦ ys ⟧) ⟩
--         Digit-toℕ x o + (⟦ xs ⟧ * 1 + ⟦ ys ⟧)
--     ≡⟨ sym (+-assoc (Digit-toℕ x o) (⟦ xs ⟧ * 1) ⟦ ys ⟧) ⟩
--         Digit-toℕ x o + ⟦ xs ⟧ * 1 + ⟦ ys ⟧
--     ∎

toℕ-⊹-Proper-homo : ∀ {b d o}
    → (¬gapped : ¬ (Gapped#0 b d o))
    → (proper : suc d + o ≥ 2)
    → (xs ys : Numeral (suc b) (suc d) o)
    →  ⟦ ⊹-Proper ¬gapped proper xs ys ⟧ ≡ ⟦ xs ⟧ + ⟦ ys ⟧
toℕ-⊹-Proper-homo {b} {d} {o} ¬gapped proper (x ∙) ys = n+-Proper-toℕ ¬gapped proper x ys
toℕ-⊹-Proper-homo {b} {d} {o} ¬gapped proper (x ∷ xs) (y ∙) =
    begin
        ⟦ n+-Proper ¬gapped proper y (x ∷ xs) ⟧
    ≡⟨ n+-Proper-toℕ ¬gapped proper y (x ∷ xs) ⟩
        Digit-toℕ y o + (Digit-toℕ x o + ⟦ xs ⟧ * suc b)
    ≡⟨ +-comm (Digit-toℕ y o) (Digit-toℕ x o + ⟦ xs ⟧ * suc b) ⟩
        Digit-toℕ x o + ⟦ xs ⟧ * suc b + Digit-toℕ y o
    ∎
toℕ-⊹-Proper-homo {b} {d} {o} ¬gapped proper (x ∷ xs) (y ∷ ys) with sumView b d o ¬gapped proper x y
toℕ-⊹-Proper-homo {b} {d} {o} ¬gapped proper (x ∷ xs) (y ∷ ys) | NoCarry leftover property =
    begin
        Digit-toℕ leftover o + ⟦ ⊹-Proper ¬gapped proper xs ys ⟧ * suc b
    ≡⟨ cong (λ w → Digit-toℕ leftover o + w * suc b) (toℕ-⊹-Proper-homo ¬gapped proper xs ys) ⟩
        Digit-toℕ leftover o + (⟦ xs ⟧ + ⟦ ys ⟧) * suc b
    ≡⟨ cong (λ w → w + (⟦ xs ⟧ + ⟦ ys ⟧) * suc b) property ⟩
        Digit-toℕ x o + (Digit-toℕ y o) + (⟦ xs ⟧ + ⟦ ys ⟧) * suc b
    ≡⟨ cong (λ w → Digit-toℕ x o + (Digit-toℕ y o) + w) (distribʳ-*-+ (suc b) ⟦ xs ⟧ ⟦ ys ⟧) ⟩
        (Digit-toℕ x o) + (Digit-toℕ y o) + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b)
    ≡⟨ +-assoc (Digit-toℕ x o) (Digit-toℕ y o) (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b) ⟩
        Digit-toℕ x o + (Digit-toℕ y o + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b))
    ≡⟨ cong (λ w → Digit-toℕ x o + w) (a+[b+c]≡b+[a+c] (Digit-toℕ y o) (⟦ xs ⟧ * suc b) (⟦ ys ⟧ * suc b)) ⟩
        Digit-toℕ x o + (⟦ xs ⟧ * suc b + (Digit-toℕ y o + ⟦ ys ⟧ * suc b))
    ≡⟨ sym (+-assoc (Digit-toℕ x o) (⟦ xs ⟧ * suc b) (Digit-toℕ y o + ⟦ ys ⟧ * suc b)) ⟩
        Digit-toℕ x o + ⟦ xs ⟧ * suc b + (Digit-toℕ y o + ⟦ ys ⟧ * suc b)
    ∎
toℕ-⊹-Proper-homo {b} {d} {o} ¬gapped proper (x ∷ xs) (y ∷ ys) | Fixed leftover carry property =
    begin
        Digit-toℕ leftover o + ⟦ n+-Proper ¬gapped proper carry (⊹-Proper ¬gapped proper xs ys) ⟧ * suc b
    ≡⟨ cong (λ w → Digit-toℕ leftover o + w * suc b) (n+-Proper-toℕ ¬gapped proper carry (⊹-Proper ¬gapped proper xs ys))   ⟩
        Digit-toℕ leftover o + (Digit-toℕ carry o + ⟦ ⊹-Proper ¬gapped proper xs ys ⟧) * suc b
    ≡⟨ cong (λ w → Digit-toℕ leftover o + (Digit-toℕ carry o + w) * suc b) (toℕ-⊹-Proper-homo ¬gapped proper xs ys) ⟩
        Digit-toℕ leftover o + (Digit-toℕ carry o + (⟦ xs ⟧ + ⟦ ys ⟧)) * suc b
    ≡⟨ cong (λ w → Digit-toℕ leftover o + w) (distribʳ-*-+ (suc b) (Digit-toℕ carry o) (⟦ xs ⟧ + ⟦ ys ⟧)) ⟩
        Digit-toℕ leftover o + ((Digit-toℕ carry o) * suc b + (⟦ xs ⟧ + ⟦ ys ⟧) * suc b)
    ≡⟨ cong (λ w → Digit-toℕ leftover o + ((Digit-toℕ carry o) * suc b + w)) (distribʳ-*-+ (suc b) ⟦ xs ⟧ ⟦ ys ⟧) ⟩
        Digit-toℕ leftover o + ((Digit-toℕ carry o) * suc b + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b))
    ≡⟨ sym (+-assoc (Digit-toℕ leftover o) ((Digit-toℕ carry o) * suc b) (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b)) ⟩
        Digit-toℕ leftover o + (Digit-toℕ carry o) * suc b + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b)
    ≡⟨ cong (λ w → w + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b)) property ⟩
        (Digit-toℕ x o) + (Digit-toℕ y o) + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b)
    ≡⟨ +-assoc (Digit-toℕ x o) (Digit-toℕ y o) (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b) ⟩
        Digit-toℕ x o + (Digit-toℕ y o + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b))
    ≡⟨ cong (λ w → Digit-toℕ x o + w) (a+[b+c]≡b+[a+c] (Digit-toℕ y o) (⟦ xs ⟧ * suc b) (⟦ ys ⟧ * suc b)) ⟩
        Digit-toℕ x o + (⟦ xs ⟧ * suc b + (Digit-toℕ y o + ⟦ ys ⟧ * suc b))
    ≡⟨ sym (+-assoc (Digit-toℕ x o) (⟦ xs ⟧ * suc b) (Digit-toℕ y o + ⟦ ys ⟧ * suc b)) ⟩
        Digit-toℕ x o + ⟦ xs ⟧ * suc b + (Digit-toℕ y o + ⟦ ys ⟧ * suc b)
    ∎
toℕ-⊹-Proper-homo {b} {d} {o} ¬gapped proper (x ∷ xs) (y ∷ ys) | Floating leftover carry property =
    begin
        Digit-toℕ leftover o + ⟦ n+-Proper ¬gapped proper carry (⊹-Proper ¬gapped proper xs ys) ⟧ * suc b
    ≡⟨ cong (λ w → Digit-toℕ leftover o + w * suc b) (n+-Proper-toℕ ¬gapped proper carry (⊹-Proper ¬gapped proper xs ys))   ⟩
        Digit-toℕ leftover o + (Digit-toℕ carry o + ⟦ ⊹-Proper ¬gapped proper xs ys ⟧) * suc b
    ≡⟨ cong (λ w → Digit-toℕ leftover o + (Digit-toℕ carry o + w) * suc b) (toℕ-⊹-Proper-homo ¬gapped proper xs ys) ⟩
        Digit-toℕ leftover o + (Digit-toℕ carry o + (⟦ xs ⟧ + ⟦ ys ⟧)) * suc b
    ≡⟨ cong (λ w → Digit-toℕ leftover o + w) (distribʳ-*-+ (suc b) (Digit-toℕ carry o) (⟦ xs ⟧ + ⟦ ys ⟧)) ⟩
        Digit-toℕ leftover o + ((Digit-toℕ carry o) * suc b + (⟦ xs ⟧ + ⟦ ys ⟧) * suc b)
    ≡⟨ cong (λ w → Digit-toℕ leftover o + ((Digit-toℕ carry o) * suc b + w)) (distribʳ-*-+ (suc b) ⟦ xs ⟧ ⟦ ys ⟧) ⟩
        Digit-toℕ leftover o + ((Digit-toℕ carry o) * suc b + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b))
    ≡⟨ sym (+-assoc (Digit-toℕ leftover o) ((Digit-toℕ carry o) * suc b) (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b)) ⟩
        Digit-toℕ leftover o + (Digit-toℕ carry o) * suc b + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b)
    ≡⟨ cong (λ w → w + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b)) property ⟩
        (Digit-toℕ x o) + (Digit-toℕ y o) + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b)
    ≡⟨ +-assoc (Digit-toℕ x o) (Digit-toℕ y o) (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b) ⟩
        Digit-toℕ x o + (Digit-toℕ y o + (⟦ xs ⟧ * suc b + ⟦ ys ⟧ * suc b))
    ≡⟨ cong (λ w → Digit-toℕ x o + w) (a+[b+c]≡b+[a+c] (Digit-toℕ y o) (⟦ xs ⟧ * suc b) (⟦ ys ⟧ * suc b)) ⟩
        Digit-toℕ x o + (⟦ xs ⟧ * suc b + (Digit-toℕ y o + ⟦ ys ⟧ * suc b))
    ≡⟨ sym (+-assoc (Digit-toℕ x o) (⟦ xs ⟧ * suc b) (Digit-toℕ y o + ⟦ ys ⟧ * suc b)) ⟩
        Digit-toℕ x o + ⟦ xs ⟧ * suc b + (Digit-toℕ y o + ⟦ ys ⟧ * suc b)
    ∎

-- _⊹_ : ∀ {b d o}
--     → {cond : N+Closed b d o}
--     → (xs ys : Numeral b d o)
--     → Numeral b d o
-- _⊹_ {b} {d} {o} {IsContinuous cont} xs ys with numView b d o
-- _⊹_ {cond = IsContinuous ()} xs ys | NullBase d o
-- _⊹_ {cond = IsContinuous cont} xs ys | NoDigits b o = NoDigits-explode xs
-- _⊹_ {cond = IsContinuous ()} xs ys | AllZeros b
-- _⊹_ {cond = IsContinuous cont} xs ys | Proper b d o proper with Gapped#0? b d o
-- _⊹_ {cond = IsContinuous ()} xs ys | Proper b d o proper | yes ¬gapped#0
-- _⊹_ {cond = IsContinuous cont} xs ys | Proper b d o proper | no ¬gapped#0 = ⊹-Proper (≤-pred (≰⇒> ¬gapped#0)) proper xs ys
-- _⊹_ {cond = ℤₙ} xs ys = ⊹-ℤₙ xs ys

toℕ-⊹-homo : ∀ {b d o}
    → (cont : True (Continuous? b d o))
    → (xs ys : Numeral b d o)
    → ⟦ _⊹_ {cont = cont} xs ys ⟧ ≡ ⟦ xs ⟧ + ⟦ ys ⟧
toℕ-⊹-homo {b} {d} {o} cont xs ys with numView b d o
toℕ-⊹-homo ()   xs ys | NullBase d o
toℕ-⊹-homo cont xs ys | NoDigits b o = NoDigits-explode xs
toℕ-⊹-homo ()   xs ys | AllZeros b
toℕ-⊹-homo cont xs ys | Proper b d o proper with Gapped#0? b d o
toℕ-⊹-homo ()   xs ys | Proper b d o proper | yes gapped#0
toℕ-⊹-homo cont xs ys | Proper b d o proper | no ¬gapped#0 = toℕ-⊹-Proper-homo ¬gapped#0 proper xs ys

-- toℕ-≋-ℕ⇒Num-lemma-1 : ∀ m n → m * suc n ≡ 0 → m ≡ 0
-- toℕ-≋-ℕ⇒Num-lemma-1 zero n p = refl
-- toℕ-≋-ℕ⇒Num-lemma-1 (suc m) n ()
--
--
-- toℕ-≋-ℕ⇒Num-lemma-2 : ∀ m n → m ≢ 0 → m + n ≢ 0
-- toℕ-≋-ℕ⇒Num-lemma-2 zero    n p = contradiction refl p
-- toℕ-≋-ℕ⇒Num-lemma-2 (suc m) n p ()
--
-- toℕ-≋-ℕ⇒Numeral : ∀ {b d o}
--     → (xs ys : Numeral b d o)
--     → toℕ xs ≡ toℕ ys
--     → xs ≋ ys
-- toℕ-≋-ℕ⇒Numeral ∙ ∙        ⟦xs⟧≡⟦ys⟧ = tt
-- toℕ-≋-ℕ⇒Numeral {b} {zero} ∙ (() ∷ ys) ⟦∙⟧≡⟦y∷ys⟧
-- toℕ-≋-ℕ⇒Numeral {b} {suc d} {o} ∙ (y ∷ ys) ⟦∙⟧≡⟦y∷ys⟧ with Digit-toℕ y o ≟ 0
-- toℕ-≋-ℕ⇒Numeral {zero} {suc d} ∙ (y ∷ ys) ⟦∙⟧≡⟦y∷ys⟧ | yes p = tt
-- toℕ-≋-ℕ⇒Numeral {suc b} {suc d} {o} ∙ (y ∷ ys) ⟦∙⟧≡⟦y∷ys⟧ | yes p =
--     let ⟦ys⟧≡0 : toℕ ys * suc b ≡ 0
--         ⟦ys⟧≡0 =
--             begin
--                 toℕ ys * suc b
--             ≡⟨ cong (λ w → w + toℕ ys * suc b) (sym p) ⟩
--                 o + Fin.toℕ y + toℕ ys * suc b
--             ≡⟨ sym ⟦∙⟧≡⟦y∷ys⟧ ⟩
--                 zero
--             ∎
--     in
--     toℕ-≋-ℕ⇒Numeral ∙ ys (sym (toℕ-≋-ℕ⇒Num-lemma-1 (toℕ ys) b ⟦ys⟧≡0))
-- toℕ-≋-ℕ⇒Numeral {b} {suc d} {o} ∙ (y ∷ ys) ⟦∙⟧≡⟦y∷ys⟧ | no ¬p = toℕ-≋-ℕ⇒Num-lemma-2 (Digit-toℕ y o) (toℕ ys * b) ¬p (sym ⟦∙⟧≡⟦y∷ys⟧)
-- toℕ-≋-ℕ⇒Numeral {b} {zero} (() ∷ xs) ∙ ⟦x∷xs⟧≡⟦∙⟧
-- toℕ-≋-ℕ⇒Numeral {b} {suc d} {o} (x ∷ xs) ∙ ⟦x∷xs⟧≡⟦∙⟧ with Digit-toℕ x o ≟ 0
-- toℕ-≋-ℕ⇒Numeral {zero} {suc d} (x ∷ xs) ∙ ⟦x∷xs⟧≡⟦∙⟧ | yes p = tt
-- toℕ-≋-ℕ⇒Numeral {suc b} {suc d} (x ∷ xs) ∙ ⟦x∷xs⟧≡⟦∙⟧ | yes p = {!   !}
-- toℕ-≋-ℕ⇒Numeral {b} {suc d} (x ∷ xs) ∙ ⟦x∷xs⟧≡⟦∙⟧ | no ¬p = {!   !}
-- toℕ-≋-ℕ⇒Numeral (x ∷ xs) (x₁ ∷ ys) ⟦xs⟧≡⟦ys⟧ = {!   !}

-- begin
--     {!   !}
-- ≡⟨ {!   !} ⟩
--     {!   !}
-- ≡⟨ {!   !} ⟩
--     {!   !}
-- ≡⟨ {!   !} ⟩
--     {!   !}
-- ≡⟨ {!   !} ⟩
--     {!   !}
-- ∎
-- start
--     {!   !}
-- ≤⟨ {!   !} ⟩
--     {!   !}
-- ≤⟨ {!   !} ⟩
--     {!   !}
-- ≤⟨ {!   !} ⟩
--     {!   !}
-- □


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

{-
  Adapted from Ulrik's work in Lean (released under Apache License 2.0)
  https://github.com/leanprover/lean/blob/master/hott/homotopy/cellcomplex.hlean
-}

open import HoTT

module cw.CW where

open import cw.Attached public

{-
  Naming convension: most of them have the "cw-" prefix
-}

-- skeleton

Skeleton : ∀ {i} → ℕ → Type (lsucc i)
Realizer : ∀ {i} {n : ℕ} → Skeleton {i} n → Type i

Skeleton {i} O = Type i
Skeleton {i} (S n) =
  Σ (Skeleton {i} n)
    (λ s → Σ (Type i) λ A → Attaching (Realizer s) A (Sphere n))

Realizer {n = O} A = A
Realizer {n = S n} (s , (A , attaching)) = Attached attaching

⟦_⟧ = Realizer

-- Take a prefix of a skeleton

cw-take : ∀ {i} {m n : ℕ} (m≤n : m ≤ n) → Skeleton {i} n → Skeleton {i} m
cw-take (inl idp)        skel       = skel
cw-take (inr ltS)        (skel , _) = skel
cw-take (inr (ltSR m≤n)) (skel , _) = cw-take (inr m≤n) skel

cw-head : ∀ {i} {n : ℕ} → Skeleton {i} n → Type i
cw-head {n = O}   = cw-take (inl idp)
cw-head {n = S n} = cw-take (inr (O<S n))

incl^ : ∀ {i} {n : ℕ} (skel : Skeleton {i} n)
  → cw-head skel → ⟦ skel ⟧
incl^ {n = O}       skel       c = c
incl^ {n = S O}     (skel , _) c = incl c
incl^ {n = S (S n)} (skel , _) c = incl (incl^ skel c)

-- Pointedness

⊙Skeleton : ∀ {i} (n : ℕ) → Type (lsucc i)
⊙Skeleton n = Σ (Skeleton n) cw-head

⊙Realizer : ∀ {i} {n : ℕ} → ⊙Skeleton {i} n → Ptd i
⊙Realizer (skel , pt) = ⟦ skel ⟧ , incl^ skel pt

⊙⟦_⟧ = ⊙Realizer

-- Access the [m]th cells

cells-last : ∀ {i} {n : ℕ} → Skeleton {i} n → Type i
cells-last {n = O}   skel            = skel
cells-last {n = S n} (_ , cells , _) = cells

cells-nth : ∀ {i} {m n : ℕ} (m≤n : m ≤ n) → Skeleton {i} n → Type i
cells-nth m≤n = cells-last ∘ cw-take m≤n

-- Access the [m]th dimensional attaching map

Sphere₋₁ : ℕ → Type₀
Sphere₋₁ O = Empty
Sphere₋₁ (S n) = Sphere n

Realizer₋₁ : ∀ {i} {n : ℕ} → Skeleton {i} n → Type i
Realizer₋₁ {n = O}   _          = Lift Empty
Realizer₋₁ {n = S n} (skel , _) = ⟦ skel ⟧

⟦_⟧₋₁ = Realizer₋₁

attaching-last : ∀ {i} {n : ℕ} (s : Skeleton {i} n)
  → cells-last s → (Sphere₋₁ n → ⟦ s ⟧₋₁)
attaching-last {n = O}    _                  = λ{_ ()}
attaching-last {n = S n} (_ , _ , attaching) = attaching

attaching-nth : ∀ {i} {m n : ℕ} (m≤n : m ≤ n) (skel : Skeleton {i} n)
  → cells-nth m≤n skel → Sphere₋₁ m → ⟦ cw-take m≤n skel ⟧₋₁
attaching-nth m≤n = attaching-last ∘ cw-take m≤n

-- Misc

-- Extra conditions on CW complexes
-- XXX Needs a better name
has-dec-cells : ∀ {i} {n} → Skeleton {i} n → Type i
has-dec-cells {n = 0} skel = has-dec-eq skel
has-dec-cells {n = S n} (skel , cells , _) = has-dec-cells skel × has-dec-eq cells

-- Extra conditions on CW complexes for constructive degrees
-- The ideas is that boundaries maps need to be pointed after contraction
-- XXX Needs a better name
is-aligned : ∀ {i} {n} → Skeleton {i} n → Type i
is-aligned {n = 0} _ = Lift ⊤
is-aligned {n = 1} _ = Lift ⊤
is-aligned {n = S (S n)} (skel , _ , boundary) =
  is-aligned skel × (∀ c → hfiber incl (boundary c north))

{- Some basic CWs -}

-- Empty

CWEmpty-skel : Skeleton {lzero} 0
CWEmpty-skel = Empty
CWEmpty = ⟦ CWEmpty-skel ⟧

CWEmpty≃Empty : CWEmpty ≃ Empty
CWEmpty≃Empty = ide _

CWEmpty-is-aligned : is-aligned CWEmpty-skel
CWEmpty-is-aligned = lift tt

-- Unit

CWUnit-skel : Skeleton {lzero} 0
CWUnit-skel = Unit
CWUnit = ⟦ CWUnit-skel ⟧

CWUnit≃Unit : CWUnit ≃ Unit
CWUnit≃Unit = ide _

CWUnit-is-aligned : is-aligned CWUnit-skel
CWUnit-is-aligned = lift tt

{- Basic transformation  -}

-- dimension lifting

cw-lift₁ : ∀ {i} {n : ℕ} → Skeleton {i} n → Skeleton {i} (S n)
cw-lift₁ skel = skel , Lift Empty , λ{(lift ()) _}

-- This slightly extends the naming convension
-- to two skeletons being extensionally equal.
cw-lift₁-equiv : ∀ {i} {n} (skel : Skeleton {i} n)
  → ⟦ cw-lift₁ skel ⟧ ≃ ⟦ skel ⟧
cw-lift₁-equiv skel = equiv to incl to-incl incl-to
  where
    to : ⟦ cw-lift₁ skel ⟧ → ⟦ skel ⟧
    to = Attached-rec (idf ⟦ skel ⟧) (λ{(lift ())}) (λ{(lift ()) _})

    to-incl : ∀ x → to (incl x) == x
    to-incl _ = idp

    incl-to : ∀ x → incl (to x) == x
    incl-to = Attached-elim (λ _ → idp) (λ{(lift ())}) (λ{(lift ()) _})

cw-lift : ∀ {i} {n m : ℕ} → n < m → Skeleton {i} n → Skeleton {i} m
cw-lift ltS = cw-lift₁
cw-lift (ltSR lt) = cw-lift₁ ∘ cw-lift lt