module Structure.Categorical.Properties where

import      Functional.Dependent as Fn
open import Lang.Instance
import      Lvl
open import Logic
open import Logic.Predicate
open import Logic.Propositional
open import Structure.Setoid
import      Structure.Categorical.Names as Names
import      Structure.Operator.Names as Names
import      Structure.Relator.Names as Names
open import Structure.Relator.Properties
open import Syntax.Function
open import Type
open import Type.Properties.Singleton

private variable ℓₒ ℓₘ ℓₑ : Lvl.Level
private variable Obj : Type{ℓₒ}

module Object where
  module _ (Morphism : Obj → Obj → Type{ℓₘ}) where
    open Names.ArrowNotation(Morphism)

    module _ ⦃ morphism-equiv : ∀{x y} → Equiv{ℓₑ}(x ⟶ y) ⦄ where
      -- An initial object is an object in which there is an unique morphism from it to every object.
      Initial : Obj → Stmt
      Initial(x) = (∀{y} → IsUnit(x ⟶ y))

      -- An terminal object is an object in which there is an unique morphism to it from every object.
      Terminal : Obj → Stmt
      Terminal(y) = (∀{x} → IsUnit(x ⟶ y))

module Morphism where
  module _ {Morphism : Obj → Obj → Type{ℓₘ}} ⦃ equiv-morphism : ∀{x y} → Equiv{ℓₑ}(Morphism x y) ⦄ where
    open Names.ArrowNotation(Morphism)

    module OperModule (_▫_ : Names.SwappedTransitivity(_⟶_)) where
      record Associativity : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
        constructor intro
        field proof : Names.Morphism.Associativity{Morphism = Morphism}(_▫_)
      associativity = inst-fn Associativity.proof

      module _ {x : Obj} (f : x ⟶ x) where
        record Idempotent : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
          constructor intro
          field proof : Names.Morphism.Idempotent{Morphism = Morphism}(_▫_)(f)
        idempotent = inst-fn Idempotent.proof

      module IdModule (id : Names.Reflexivity(_⟶_)) where
        record Identityₗ : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
          constructor intro
          field proof : Names.Morphism.Identityₗ(_▫_)(\{a} → id{a})
        identityₗ = inst-fn Identityₗ.proof

        record Identityᵣ : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
          constructor intro
          field proof : Names.Morphism.Identityᵣ(_▫_)(\{a} → id{a})
        identityᵣ = inst-fn Identityᵣ.proof

        Identity = Identityₗ ∧ Identityᵣ
        identity-left  = inst-fn{X = Identity}(Identityₗ.proof Fn.∘ [∧]-elimₗ{Q = Identityᵣ})
        identity-right = inst-fn{X = Identity}(Identityᵣ.proof Fn.∘ [∧]-elimᵣ{P = Identityₗ})

        module _ {x : Obj} (f : x ⟶ x) where
          record Involution : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
            constructor intro
            field proof : Names.Morphism.Involution{Morphism = Morphism}(_▫_)(id)(f)
          involution = inst-fn Involution.proof

        module _ {x y : Obj} (f : x ⟶ y) where
          module _ (f⁻¹ : y ⟶ x) where
            -- A morphism have a right inverse morphism.
            -- Also called: Split monomorphism, retraction
            record Inverseₗ : Stmt{ℓₘ Lvl.⊔ ℓₑ} where
              constructor intro
              field proof : Names.Morphism.Inverseₗ(_▫_)(\{a} → id{a})(f)(f⁻¹)
            inverseₗ = inst-fn Inverseₗ.proof

            -- A morphism have a right inverse morphism.
            -- Also called: Split epimorphism, section
            record Inverseᵣ : Stmt{ℓₘ Lvl.⊔ ℓₑ} where
              constructor intro
              field proof : Names.Morphism.Inverseᵣ(_▫_)(\{a} → id{a})(f)(f⁻¹)
            inverseᵣ = inst-fn Inverseᵣ.proof

            Inverse = Inverseₗ ∧ Inverseᵣ
            module Inverse(inverse : Inverse) where
              instance
                left : Inverseₗ
                left = [∧]-elimₗ inverse

              instance
                right : Inverseᵣ
                right = [∧]-elimᵣ inverse

          Invertibleₗ = ∃(Inverseₗ)
          Invertibleᵣ = ∃(Inverseᵣ)

          -- A morphism is an isomorphism when it is invertible with respect to the operator.
          -- For the set and functions category, it means that f is bijective.
          Isomorphism : Stmt
          Isomorphism = ∃(Inverse)
          module Isomorphism ⦃ iso : Isomorphism ⦄ where
            instance inverse = [∃]-proof iso
            instance inverse-left  = [∧]-elimₗ inverse
            instance inverse-right = [∧]-elimᵣ inverse

          inv : ⦃ Isomorphism ⦄ → (y ⟶ x)
          inv ⦃ p ⦄ = [∃]-witness p

        -- Proposition stating that two objects are isomorphic.
        Isomorphic : Obj → Obj → Stmt
        Isomorphic(x)(y) = ∃(Isomorphism{x}{y})
        _⤖_ = Isomorphic

        module _ {x : Obj} (f : ⟲ x) where
          -- A morphism is an automorphism when it is an endomorphism and an isomorphism.
          Automorphism : Stmt
          Automorphism = Isomorphism(f)

        Automorphic : Obj → Stmt
        Automorphic(x) = ∃(Automorphism{x})

      module _ {x y : Obj} (f : x ⟶ y) where
        -- A morphism is an monomorphism when it is left-cancellable ("injective").
        -- ∀{z}{g₁ g₂ : z ⟶ x} → (f ∘ g₁ ≡ f ∘ g₂) → (g₁ ≡ g₂)
        record Monomorphism : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
          constructor intro
          field
            proof : ∀{z} → Names.CancellationOnₗ {T₂ = z ⟶ x} (_▫_) (f)
        cancellationₗ = inst-fn Monomorphism.proof

        -- A morphism is an epimorphism when it is right-cancellable ("surjective").
        -- ∀{z}{g₁ g₂ : y ⟶ z} → (g₁ ∘ f ≡ g₂ ∘ f) → (g₁ ≡ g₂)
        record Epimorphism : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
          constructor intro
          field
            proof : ∀{z} → Names.CancellationOnᵣ {T₁ = y ⟶ z} (_▫_) (f)
        cancellationᵣ = inst-fn Epimorphism.proof

      -- Proposition stating that two objects are monomorphic.
      Monomorphic : Obj → Obj → Stmt
      Monomorphic(x)(y) = ∃(Monomorphism{x}{y})
      _↣_ = Monomorphic

      -- Proposition stating that two objects are epimorphic.
      Epimorphic : Obj → Obj → Stmt
      Epimorphic(x)(y) = ∃(Epimorphism{x}{y})
      _↠_ = Epimorphic

    open OperModule public
    open IdModule   public

module Polymorphism where
  module _ {Morphism : Obj → Obj → Type{ℓₘ}} ⦃ equiv-morphism : ∀{x y} → Equiv{ℓₑ}(Morphism x y) ⦄ where
    open Names.ArrowNotation(Morphism)

    module OperModule (_▫_ : Names.SwappedTransitivity(_⟶_)) where
      module _ (x y : Obj) (f : ∀{x y} → (x ⟶ y)) where
        record IdempotentOn : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
          constructor intro
          field proof : Names.Polymorphism.IdempotentOn{Morphism = Morphism}(_▫_)(x)(y)(f)
        idempotent-on = inst-fn IdempotentOn.proof

      module IdModule (id : Names.Reflexivity(_⟶_)) where
        module _ (x y : Obj) (f : ∀{x y} → (x ⟶ y)) where
          record InvolutionOn : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
            constructor intro
            field proof : Names.Polymorphism.InvolutionOn{Morphism = Morphism}(_▫_)(id) (x)(y) (f)
          involution-on = inst-fn InvolutionOn.proof

        module _ (f : ∀{x y} → (x ⟶ y)) where
          record Involution : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
            constructor intro
            field proof : Names.Polymorphism.Involution{Morphism = Morphism}(_▫_)(id)(f)
          involution = inst-fn Involution.proof

        module _ (inv : ∀{x y : Obj} → (x ⟶ y) → (y ⟶ x)) where
          -- A morphism have a right inverse morphism.
          -- Also called: Split monomorphism, retraction
          record Inverterₗ : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
            constructor intro
            field proof : ∀{x y : Obj}{f : x ⟶ y} → Names.Morphism.Inverseₗ(_▫_)(\{a} → id{a})(f)(inv f)
            instance
              inverseₗ : ∀{x y : Obj}{f : x ⟶ y} → Morphism.Inverseₗ(_▫_)(\{x} → id{x})(f)(inv f)
              inverseₗ = Morphism.intro proof

          inverterₗ = inst-fn Inverterₗ.proof

          -- A morphism have a right inverse morphism.
          -- Also called: Split epimorphism, section
          record Inverterᵣ : Stmt{Lvl.of(Obj) Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
            constructor intro
            field proof : ∀{x y : Obj}{f : x ⟶ y} → Names.Morphism.Inverseᵣ(_▫_)(\{a} → id{a})(f)(inv f)
            instance
              inverseᵣ : ∀{x y : Obj}{f : x ⟶ y} → Morphism.Inverseᵣ(_▫_)(\{x} → id{x})(f)(inv f)
              inverseᵣ = Morphism.intro proof
          inverterᵣ = inst-fn Inverterᵣ.proof

          Inverter = Inverterₗ ∧ Inverterᵣ
          module Inverter(inverter : Inverter) where
            instance
              left : Inverterₗ
              left = [∧]-elimₗ inverter
            open Inverterₗ(left) public

            instance
              right : Inverterᵣ
              right = [∧]-elimᵣ inverter
            open Inverterᵣ(right) public

            module _ {x y : Obj} {f : x ⟶ y} where
              instance
                inverse : Morphism.Inverse(_▫_)(\{x} → id{x})(f)(inv f)
                inverse = [∧]-intro inverseₗ inverseᵣ
              open Morphism.Inverse(_▫_)(\{x} → id{x})(f)(inv f)(inverse) renaming (left to inverseₗ ; right to inverseᵣ)

            invertibleₗ : ∀{x y : Obj}{f : x ⟶ y} → Morphism.Invertibleₗ(_▫_)(\{x} → id{x})(f)
            invertibleₗ {f = f} = [∃]-intro (inv f) ⦃ inverseₗ ⦄

            invertibleᵣ : ∀{x y : Obj}{f : x ⟶ y} → Morphism.Invertibleᵣ(_▫_)(\{x} → id{x})(f)
            invertibleᵣ {f = f} = [∃]-intro (inv f) ⦃ inverseᵣ ⦄

            isomorphism : ∀{x y : Obj}{f : x ⟶ y} → Morphism.Isomorphism(_▫_)(\{x} → id{x})(f)
            isomorphism {f = f} = [∃]-intro (inv f) ⦃ inverse ⦄

    open OperModule public
    open IdModule   public


module slots.defs where

open import slots.imports

record config
  : Set where

  field
    n : ℕ -- reel count
    m : ℕ -- fruit count

  Win/Bet = ℕ -- win per 1 bet
  Fruit = Fin m
  ReelNo = Fin n
  Reel = List Fruit
  Reels = Vec Reel n
  WinLine = Vec Win/Bet n
  WinTable = Vec WinLine m
  Line = Vec Fruit n

record game (cfg : config) : Set where
  open config cfg

  field
    reels : Reels
    winTable : WinTable


module Interior where

open import Basics
open import Ix
open import All
open import Cutting

module INTERIOR {I}(C : I |> I) where

  open _|>_ C

  data Interior (P : I -> Set)(i : I) : Set where
    tile : P i -> Interior P i
    <_>  : Cutting C (Interior P) i -> Interior P i

  ifold : forall {P Q} ->
          [ P -:> Q ] ->
          [ Cutting C Q -:> Q ] ->
          [ Interior P -:> Q ]
  ifolds : forall {P Q} ->
          [ P -:> Q ] ->
          [ Cutting C Q -:> Q ] ->
          [ All (Interior P) -:> All Q ]
  ifold pq cq i (tile p) = pq i p
  ifold pq cq i < c 8>< ps > = cq i (c 8>< ifolds pq cq _ ps)
  ifolds pq cq [] <> = <>
  ifolds pq cq (i ,- is) (x , xs) = ifold pq cq i x , ifolds pq cq is xs

  -- tile : [ P -:> Interior P ]

  extend : forall {P Q} ->
          [ P -:> Interior Q ] ->
          [ Interior P -:> Interior Q ]
  extend k = ifold k (\ i x -> < x >)

  -- and we have a monad, not in Set, but in I -> Set

open INTERIOR NatCut
{-
foo : Interior (\ n -> n == 3) 12
foo = < ((3 , 9 , refl _)) 8>< (tile (refl _) , {!!} , <>) >
-}


------------------------------------------------------------------------
-- Pure type systems (PTS)
------------------------------------------------------------------------

-- This file contains some core definitions which are reexported by
-- Pts.Typing

module Pts.Core where

open import Data.Fin.Substitution.Typed
open import Data.Product using (∃)

import Pts.Syntax

-- Instances of pure type systems.
record PTS : Set₁ where

  -- The following predicates represent the set of sorts, axioms and
  -- rules, respectively.
  field
    Sort  : Set                        -- sorts
    Axiom : Sort → Sort → Set          -- axioms
    Rule  : Sort → Sort → Sort → Set   -- rules

  -- Convenience aliases of modules in Pts.Syntax.
  module Syntax       = Pts.Syntax.Syntax       Sort
  module Substitution = Pts.Syntax.Substitution Sort
  module Ctx          = Pts.Syntax.Ctx          Sort

  open Syntax
  open Ctx

  -- Abstract well-formed typing contexts.
  module WfCtx (_⊢_∈_ : Typing Term Term Term) where

    -- Well-formedness of terms/types.
    _⊢_wf : Wf Term
    Γ ⊢ a wf = ∃ λ s → Γ ⊢ a ∈ sort s

    -- FIXME: the following definition should not be necessary.
    --
    -- Instead, it should be sufficient to directly open the module
    -- WellFormedContext like so:
    --
    --   open WellFormedContext _⊢_wf public
    --
    -- but there is currently a bug that prevents us from doing so.
    -- See https://github.com/agda/agda/issues/2901

    _wf : ∀ {n} → Ctx n → Set
    _wf = WellFormedContext._wf  _⊢_wf

    open WellFormedContext _⊢_wf public hiding (_wf)


module GGT.Group.Structures
  {a b ℓ}
  where

open import Relation.Unary using (Pred)
open import Relation.Binary
open import Algebra.Bundles using (Group)
open import Level
open import GGT.Group.Definitions

record IsSubGroup (G : Group a ℓ) (P : Pred (Group.Carrier G) b) : Set (a ⊔ b ⊔ ℓ) where
  open Group G
  field
    ε∈ : (P ε)
    ∙-⁻¹-closed : IsOpInvClosed G P
    r : P Respects _≈_

  -- coset relation
  _∼_ : Rel Carrier b
  x ∼ y = P (x - y)

syntax IsSubGroup G P = P ≤ G


{-# OPTIONS --cubical --safe --no-import-sorts #-}
module Cubical.Algebra.Module.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Macro
open import Cubical.Algebra.Ring      renaming (⟨_⟩ to ⟨_⟩r)
open import Cubical.Algebra.AbGroup   hiding (⟨_⟩)
open import Cubical.Algebra.Group     hiding (⟨_⟩)

open Iso

private
  variable
    ℓ : Level

record IsLeftModule (R : Ring {ℓ}) {M : Type ℓ}
              (0m : M)
              (_+_ : M → M → M)
              (-_ : M → M)
              (_⋆_ : ⟨ R ⟩r → M → M) : Type ℓ where

  constructor ismodule

  open Ring R using (_·_; 1r) renaming (_+_ to _+r_)

  field
    +-isAbGroup : IsAbGroup 0m _+_ -_
    ⋆-assoc : (r s : ⟨ R ⟩r) (x : M) → (r · s) ⋆ x ≡ r ⋆ (s ⋆ x)
    ⋆-ldist : (r s : ⟨ R ⟩r) (x : M) → (r +r s) ⋆ x ≡ (r ⋆ x) + (s ⋆ x)
    ⋆-rdist : (r : ⟨ R ⟩r) (x y : M) → r ⋆ (x + y) ≡ (r ⋆ x) + (r ⋆ y)
    ⋆-lid   : (x : M) → 1r ⋆ x ≡ x

  open IsAbGroup +-isAbGroup public
    renaming
    ( assoc       to +-assoc
    ; identity    to +-identity
    ; lid         to +-lid
    ; rid         to +-rid
    ; inverse     to +-inv
    ; invl        to +-linv
    ; invr        to +-rinv
    ; comm        to +-comm
    ; isSemigroup to +-isSemigroup
    ; isMonoid    to +-isMonoid
    ; isGroup     to +-isGroup
    )

record LeftModule (R : Ring {ℓ}) : Type (ℓ-suc ℓ) where

  constructor leftmodule

  field
    Carrier        : Type ℓ
    0m             : Carrier
    _+_            : Carrier → Carrier → Carrier
    -_             : Carrier → Carrier
    _⋆_            : ⟨ R ⟩r → Carrier → Carrier
    isLeftModule   : IsLeftModule R 0m _+_ -_ _⋆_

  open IsLeftModule isLeftModule public

module _ {R : Ring {ℓ}} where
  ⟨_⟩ : LeftModule R → Type ℓ
  ⟨_⟩ = LeftModule.Carrier

  LeftModule→AbGroup : (M : LeftModule R) → AbGroup {ℓ}
  LeftModule→AbGroup (leftmodule _ _ _ _ _ isLeftModule) =
                     abgroup _ _ _ _ (IsLeftModule.+-isAbGroup isLeftModule)

  isSetLeftModule : (M : LeftModule R) → isSet ⟨ M ⟩
  isSetLeftModule M = isSetAbGroup (LeftModule→AbGroup M)

  open Ring R using (1r) renaming (_+_ to _+r_; _·_ to _·s_)

  makeIsLeftModule : {M : Type ℓ} {0m : M}
                  {_+_ : M → M → M} { -_ : M → M} {_⋆_ : ⟨ R ⟩r → M → M}
                  (isSet-M : isSet M)
                  (+-assoc :  (x y z : M) → x + (y + z) ≡ (x + y) + z)
                  (+-rid : (x : M) → x + 0m ≡ x)
                  (+-rinv : (x : M) → x + (- x) ≡ 0m)
                  (+-comm : (x y : M) → x + y ≡ y + x)
                  (⋆-assoc : (r s : ⟨ R ⟩r) (x : M) → (r ·s s) ⋆ x ≡ r ⋆ (s ⋆ x))
                  (⋆-ldist : (r s : ⟨ R ⟩r) (x : M) → (r +r s) ⋆ x ≡ (r ⋆ x) + (s ⋆ x))
                  (⋆-rdist : (r : ⟨ R ⟩r) (x y : M) → r ⋆ (x + y) ≡ (r ⋆ x) + (r ⋆ y))
                  (⋆-lid   : (x : M) → 1r ⋆ x ≡ x)
                → IsLeftModule R 0m _+_ -_ _⋆_
  makeIsLeftModule isSet-M
                +-assoc +-rid +-rinv +-comm
                ⋆-assoc ⋆-ldist ⋆-rdist ⋆-lid =
                ismodule (makeIsAbGroup isSet-M +-assoc +-rid +-rinv +-comm)
                         ⋆-assoc ⋆-ldist ⋆-rdist ⋆-lid

record LeftModuleEquiv {R : Ring {ℓ}} (M N : LeftModule R) : Type ℓ where

  constructor moduleiso

  private
    instance
      _ : LeftModule R
      _ = M
      _ : LeftModule R
      _ = N

  open LeftModule {{...}}

  field
    e : ⟨ M ⟩ ≃ ⟨ N ⟩
    isHom+ : (x y : ⟨ M ⟩) → equivFun e (x + y) ≡ equivFun e x + equivFun e y
    comm⋆ : (r : ⟨ R ⟩r) (x : ⟨ M ⟩) → equivFun e (r ⋆ x) ≡ r ⋆ equivFun e x

module LeftModuleΣTheory (R : Ring {ℓ}) where

  RawLeftModuleStructure = λ (M : Type ℓ) → (M → M → M) × (⟨ R ⟩r → M → M)

  RawLeftModuleEquivStr = AutoEquivStr RawLeftModuleStructure

  rawLeftModuleUnivalentStr : UnivalentStr _ RawLeftModuleEquivStr
  rawLeftModuleUnivalentStr = autoUnivalentStr RawLeftModuleStructure

  open Ring R using (_·_; 1r) renaming (_+_ to _+r_)

  LeftModuleAxioms : (M : Type ℓ) (s : RawLeftModuleStructure M) → Type ℓ
  LeftModuleAxioms M (_+_ , _⋆_) = AbGroupΣTheory.AbGroupAxioms M _+_
                                    × ((r s : ⟨ R ⟩r) (x : M) → (r · s) ⋆ x ≡ r ⋆ (s ⋆ x))
                                    × ((r s : ⟨ R ⟩r) (x : M) → (r +r s) ⋆ x ≡ (r ⋆ x) + (s ⋆ x))
                                    × ((r : ⟨ R ⟩r) (x y : M) → r ⋆ (x + y) ≡ (r ⋆ x) + (r ⋆ y))
                                    × ((x : M) → 1r ⋆ x ≡ x)

  LeftModuleStructure : Type ℓ → Type ℓ
  LeftModuleStructure = AxiomsStructure RawLeftModuleStructure LeftModuleAxioms

  LeftModuleΣ : Type (ℓ-suc ℓ)
  LeftModuleΣ = TypeWithStr ℓ LeftModuleStructure

  LeftModuleEquivStr : StrEquiv LeftModuleStructure ℓ
  LeftModuleEquivStr = AxiomsEquivStr RawLeftModuleEquivStr LeftModuleAxioms

  open AbGroupΣTheory using (isSetAbGroupΣ)

  isSetLeftModuleΣ : (M : LeftModuleΣ)  → isSet _
  isSetLeftModuleΣ (M , (_+_ , _) , (isAbGroup-M , _)) = isSetAbGroupΣ (M , _+_ , isAbGroup-M)

  isPropLeftModuleAxioms : (M : Type ℓ) (s : RawLeftModuleStructure M)
                             → isProp (LeftModuleAxioms M s)
  isPropLeftModuleAxioms M (_+_ , _⋆_) =
     isPropΣ (AbGroupΣTheory.isPropAbGroupAxioms M _+_)
             λ isAbGroup-M →
             isProp× (isPropΠ3 λ _ _ _ → (isSetAbGroupΣ (M , _+_ , isAbGroup-M)) _ _)
            (isProp× (isPropΠ3 λ _ _ _ → (isSetAbGroupΣ (M , _+_ , isAbGroup-M)) _ _)
            (isProp× (isPropΠ3 λ _ _ _ → (isSetAbGroupΣ (M , _+_ , isAbGroup-M)) _ _)
                     (isPropΠ  λ _     → (isSetAbGroupΣ (M , _+_ , isAbGroup-M)) _ _)))

  LeftModule→LeftModuleΣ : LeftModule R → LeftModuleΣ
  LeftModule→LeftModuleΣ
    (leftmodule M 0m _+_ -_ _⋆_ (ismodule +-isAbGroup ⋆-assoc ⋆-ldist ⋆-rdist ⋆-lid)) =
    M , (_+_ , _⋆_) ,
    AbGroupΣTheory.AbGroup→AbGroupΣ (abgroup _ _ _ _ +-isAbGroup) .snd .snd ,
    ⋆-assoc , ⋆-ldist , ⋆-rdist , ⋆-lid

  LeftModuleΣ→LeftModule : LeftModuleΣ → LeftModule R
  LeftModuleΣ→LeftModule (M , (_+_ , _⋆_) , isAbGroup-M , ⋆-assoc , ⋆-ldist , ⋆-rdist , ⋆-lid) =
    let isAbGroup = AbGroupΣTheory.AbGroupΣ→AbGroup (_ , _ , isAbGroup-M ) .AbGroup.isAbGroup
    in leftmodule M _ _+_ _ _⋆_
       (ismodule isAbGroup ⋆-assoc ⋆-ldist ⋆-rdist ⋆-lid)

  LeftModuleIsoLeftModuleΣ : Iso (LeftModule R) LeftModuleΣ
  LeftModuleIsoLeftModuleΣ = iso LeftModule→LeftModuleΣ LeftModuleΣ→LeftModule
                                 (λ _ → refl) helper
    where
      open AbGroupΣTheory
      abgroup-helper : retract (AbGroup→AbGroupΣ {ℓ}) AbGroupΣ→AbGroup
      abgroup-helper = Iso.leftInv AbGroupIsoAbGroupΣ

      open LeftModule
      open IsLeftModule
      helper : _
      Carrier (helper M i) = Carrier M
      0m (helper M i) = 0m M
      _+_ (helper M i) = _+_ M
      -_ (helper M i) =  -_ M
      _⋆_ (helper M i) = _⋆_ M

      +-isAbGroup (isLeftModule (helper M i)) =
        AbGroup.isAbGroup (abgroup-helper (abgroup _ _ _ _ (+-isAbGroup M)) i)
      ⋆-assoc (isLeftModule (helper M i)) = ⋆-assoc M
      ⋆-ldist (isLeftModule (helper M i)) = ⋆-ldist M
      ⋆-rdist (isLeftModule (helper M i)) = ⋆-rdist M
      ⋆-lid (isLeftModule (helper M i)) = ⋆-lid M

  leftModuleUnivalentStr : UnivalentStr LeftModuleStructure LeftModuleEquivStr
  leftModuleUnivalentStr = axiomsUnivalentStr _ isPropLeftModuleAxioms rawLeftModuleUnivalentStr

  LeftModuleΣPath : (M N : LeftModuleΣ) → (M ≃[ LeftModuleEquivStr ] N) ≃ (M ≡ N)
  LeftModuleΣPath = SIP leftModuleUnivalentStr

  LeftModuleEquivStrΣ : (M N : LeftModule R) → Type ℓ
  LeftModuleEquivStrΣ M N = LeftModule→LeftModuleΣ M ≃[ LeftModuleEquivStr ] LeftModule→LeftModuleΣ N

  LeftModuleEquivStrΣPath : {M N : LeftModule R} → Iso (LeftModuleEquiv M N) (LeftModuleEquivStrΣ M N)
  fun LeftModuleEquivStrΣPath (moduleiso e isHom+ comm⋆) = e , isHom+ , comm⋆
  inv LeftModuleEquivStrΣPath (e , isHom+ , comm⋆) = moduleiso e isHom+ comm⋆
  rightInv LeftModuleEquivStrΣPath _ = refl
  leftInv LeftModuleEquivStrΣPath _ = refl

  LeftModulePath : (M N : LeftModule R) → (LeftModuleEquiv M N) ≃ (M ≡ N)
  LeftModulePath M N =
    LeftModuleEquiv M N                                    ≃⟨ isoToEquiv LeftModuleEquivStrΣPath ⟩
    LeftModuleEquivStrΣ M N                                   ≃⟨ LeftModuleΣPath _ _ ⟩
    LeftModule→LeftModuleΣ M ≡ LeftModule→LeftModuleΣ N  ≃⟨ isoToEquiv
                                                             (invIso
                                                             (congIso
                                                             LeftModuleIsoLeftModuleΣ))
                                                           ⟩
    M ≡ N ■

LeftModulePath : {R : Ring {ℓ}} (M N : LeftModule R) → (LeftModuleEquiv M N) ≃ (M ≡ N)
LeftModulePath {ℓ} {R} = LeftModuleΣTheory.LeftModulePath R


module Issue2858-Fresh {A : Set} (_#_ : A → A → Set) where

  interleaved mutual

    data Fresh : Set
    data IsFresh (a : A) : Fresh → Set

    -- nil is a fresh list
    constructor
      []  : Fresh
      #[] : IsFresh a []

    -- cons is fresh as long as the new value is fresh
    constructor
      cons  : (x : A) (xs : Fresh) → IsFresh x xs → Fresh
      #cons : ∀ {x xs p} → a # x → IsFresh a xs → IsFresh a (cons x xs p)


{-

This file contains the classic isomorphism theorems for groups (so far
only the first theorem)

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.IsomorphismTheorems where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Powerset
open import Cubical.Foundations.Function
open import Cubical.Data.Sigma
open import Cubical.HITs.SetQuotients renaming (_/_ to _/s_ ; rec to recS ; elim to elimS)
open import Cubical.HITs.PropositionalTruncation

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Subgroup
open import Cubical.Algebra.Group.QuotientGroup
open import Cubical.Algebra.Group.GroupPath

private
  variable
    ℓ : Level

-- The first isomorphism theorem: im ϕ ≃ G / ker ϕ
module _ {G H : Group ℓ} (ϕ : GroupHom G H) where

  open isSubgroup
  open Iso
  open GroupTheory

  kerNormalSubgroup : NormalSubgroup G
  kerNormalSubgroup = kerSubgroup ϕ , isNormalKer ϕ

  private
    imϕ : Group ℓ
    imϕ = imGroup ϕ

  -- for completeness:
  imNormalSubgroup : ((x y : ⟨ H ⟩)
    → GroupStr._·_ (snd H) x y ≡ GroupStr._·_ (snd H) y x)
    → NormalSubgroup H
  imNormalSubgroup comm = imSubgroup ϕ , isNormalIm ϕ comm

  private
    module G = GroupStr (snd G)
    module H = GroupStr (snd H)
    module imG = GroupStr (snd imϕ)
    module kerG = GroupStr (snd (G / kerNormalSubgroup))
    module ϕ = IsGroupHom (ϕ .snd)

  f1 : ⟨ imϕ ⟩ → ⟨ G / kerNormalSubgroup ⟩
  f1 (x , Hx) = rec→Set ( squash/)
                         (λ { (y , hy) → [ y ]})
                         (λ { (y , hy) (z , hz) → eq/ y z (rem y z hy hz) })
                         Hx
    where
    rem : (y z : ⟨ G ⟩) → ϕ .fst y ≡ x → ϕ .fst z ≡ x → ϕ .fst (y G.· G.inv z) ≡ H.1g
    rem y z hy hz =
      ϕ .fst (y G.· G.inv z)        ≡⟨ ϕ.pres· _ _ ⟩
      ϕ .fst y H.· ϕ .fst (G.inv z) ≡⟨ cong (ϕ .fst y H.·_) (ϕ.presinv _) ⟩
      ϕ .fst y H.· H.inv (ϕ .fst z) ≡⟨ (λ i → hy i H.· H.inv (hz i)) ⟩
      x H.· H.inv x                 ≡⟨ H.·InvR x ⟩
      H.1g                          ∎

  f2 : ⟨ G / kerNormalSubgroup ⟩ → ⟨ imϕ ⟩
  f2 = recS imG.is-set (λ y → ϕ .fst y , ∣ y , refl ∣₁)
                       (λ x y r → Σ≡Prop (λ _ → squash₁)
                       (rem x y r))
    where
    rem : (x y : ⟨ G ⟩) → ϕ .fst (x G.· G.inv y) ≡ H.1g → ϕ .fst x ≡ ϕ .fst y
    rem x y r =
      ϕ .fst x                                      ≡⟨ sym (H.·IdR _) ⟩
      ϕ .fst x H.· H.1g                             ≡⟨ cong (ϕ .fst x H.·_) (sym (H.·InvL _)) ⟩
      ϕ .fst x H.· H.inv (ϕ .fst y) H.· ϕ .fst y    ≡⟨ (λ i → ϕ .fst x H.· ϕ.presinv y (~ i) H.· ϕ .fst y) ⟩
      ϕ .fst x H.· ϕ .fst (G.inv y) H.· ϕ .fst y    ≡⟨ H.·Assoc _ _ _ ⟩
      (ϕ .fst x H.· ϕ .fst (G.inv y)) H.· ϕ .fst y  ≡⟨ cong (H._· _) (sym (ϕ.pres· _ _)) ⟩
      ϕ .fst (x G.· G.inv y) H.· ϕ .fst y           ≡⟨ cong (H._· ϕ .fst y) r ⟩
      H.1g H.· ϕ .fst y                             ≡⟨ H.·IdL _ ⟩
      ϕ .fst y ∎

  f12 : (x : ⟨ G / kerNormalSubgroup ⟩) → f1 (f2 x) ≡ x
  f12 = elimProp (λ _ → squash/ _ _) (λ _ → refl)

  f21 : (x : ⟨ imϕ ⟩) → f2 (f1 x) ≡ x
  f21 (x , hx) = elim {P = λ hx → f2 (f1 (x , hx)) ≡ (x , hx)}
                      (λ _ → imG.is-set _ _)
                      (λ {(x , hx) → Σ≡Prop (λ _ → squash₁) hx})
                      hx

  f1-isHom : (x y : ⟨ imϕ ⟩) → f1 (x imG.· y) ≡ f1 x kerG.· f1 y
  f1-isHom (x , hx) (y , hy) =
    elim2 {P = λ hx hy → f1 ((x , hx) imG.· (y , hy)) ≡ f1 (x , hx) kerG.· f1 (y , hy)}
          (λ _ _ → kerG.is-set _ _) (λ _ _ → refl) hx hy

  -- The first isomorphism theorem for groups
  isoThm1 : GroupIso imϕ (G / kerNormalSubgroup)
  fun (fst isoThm1) = f1
  inv (fst isoThm1) = f2
  rightInv (fst isoThm1) = f12
  leftInv (fst isoThm1) = f21
  snd isoThm1 = makeIsGroupHom f1-isHom

  -- The SIP lets us turn the isomorphism theorem into a path
  pathThm1 : imϕ ≡ G / kerNormalSubgroup
  pathThm1 = uaGroup (GroupIso→GroupEquiv isoThm1)

  surjImIso : isSurjective ϕ → GroupIso imϕ H
  surjImIso surj =
    BijectionIso→GroupIso
      (bijIso indHom
              (uncurry
                (λ h → elim (λ _ → isPropΠ (λ _ → imG.is-set _ _))
                  (uncurry λ g y
                    → λ inker → Σ≡Prop (λ _ → squash₁) inker)))
              λ b → map (λ x → (b , ∣ x ∣₁) , refl) (surj b))
    where
    indHom : GroupHom imϕ H
    fst indHom = fst
    snd indHom = makeIsGroupHom λ _ _ → refl


open import Type

module Structure.Container.IndexedIterable {ℓᵢ} {Index : Type{ℓᵢ}} where

import      Lvl
open import Data
open import Data.Boolean
open import Data.Boolean.Stmt
open import Data.Option
import      Data.Option.Functions as Option
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.Natural
open import Numeral.Natural.Relation.Order
open import Relator.Equals

private variable ℓ ℓₑ ℓₑ₁ ℓₑ₂ : Lvl.Level
private variable T : Type{ℓ}
private variable Elem : Type{ℓₑ}
private variable i : Index

module _ (Iter : Index → Type{ℓ}) where
  IsEmptyTypeFn = ∀{i} → Iter(i) → Bool

  IndexStepFn : IsEmptyTypeFn → Type
  IndexStepFn isEmpty = ∀{i} → (iter : Iter(i)) → (if isEmpty(iter) then Unit else Index)

  CurrentFn : Type{ℓₑ} → IsEmptyTypeFn → Type
  CurrentFn Element isEmpty = ∀{i} → (iter : Iter(i)) → (if isEmpty(iter) then Unit else Element)

  StepFn : Type{ℓₑ} → (isEmpty : IsEmptyTypeFn) → IndexStepFn isEmpty → Type
  StepFn Element isEmpty indexStep =  ∀{i} → (iter : Iter(i)) → Out iter where
    Out : Iter(i) → Type
    Out iter with isEmpty iter | indexStep iter
    ... | 𝑇 | <> = Unit
    ... | 𝐹 | is = Iter(is)

-- An iterator type `Iter` is iterable when there may be elements that the iterator can yield in sequence.
-- It should be possible to decide whether the iterator is empty, and when it is not, get the element it points to and advancing to its next state containing the next element in order.
record Iterable (Iter : Index → Type{ℓ}) {ℓₑ} : Type{ℓ Lvl.⊔ ℓᵢ Lvl.⊔ Lvl.𝐒(ℓₑ)} where
  field
    -- The type of the elements in the iterator.
    {Element} : Type{ℓₑ}

    -- Whether there are no elements left in the iterator.
    isEmpty : IsEmptyTypeFn(Iter)

    -- The current/frontmost element in the iterator if it is non-empty.
    current : CurrentFn(Iter) Element isEmpty

    -- The next iterator index. Advances the index if the iterator is non-empty.
    {indexStep} : IndexStepFn(Iter) isEmpty

    -- The next iterator state. Advancing the iterator if it is non-empty.
    step : StepFn(Iter) Element isEmpty indexStep

  -- Whether there are at most the given number of elements in the iterator.
  atMost : ℕ → Iter(i) → Bool
  atMost(𝟎)    iter = isEmpty(iter)
  atMost(𝐒(n)) iter with isEmpty(iter) | indexStep iter | step iter
  ... | 𝑇 | <>  | <> = 𝑇
  ... | 𝐹 | _   | is = atMost(n) is

  -- Skipping the given number of iterator indices. Advances as many steps as possible.
  indexWalk : (n : ℕ) → (iter : Iter(i)) → (if(atMost n iter) then Unit else Index)
  indexWalk {i} 𝟎 iter with isEmpty(iter)
  ... | 𝑇 = <>
  ... | 𝐹 = i
  indexWalk {i} (𝐒(n)) iter with isEmpty(iter) | indexStep iter | step iter
  ... | 𝑇 | <> | <>    = <>
  ... | 𝐹 | _  | iters = indexWalk n iters

  WalkFn : Type
  WalkFn = ∀{i} → (n : ℕ) → (iter : Iter(i)) → Out n iter where
    Out : ℕ → Iter(i) → Type
    Out n iter with atMost n iter | indexWalk n iter
    ... | 𝑇 | <> = Unit
    ... | 𝐹 | is = Iter(is)

    {-
    walk : WalkFn
    walk(𝟎) iter with isEmpty(iter)
    ... | 𝑇 = <>
    ... | 𝐹 = iter
    walk(𝐒(n)) iter with isEmpty(iter) | indexStep iter | step iter | walk n iter
    ... | 𝑇 | <> | <>    | _    = <>
    ... | 𝐹 | _  | iters | iters2 = ? -- walk n iters
    -}

  Foldᵣ : ∀{ℓ} → Type{ℓ} → Type
  Foldᵣ(T) = ∀{i} → (Element → T → T) → T → Iter(i) → T

  FoldᵣCriteria : Foldᵣ(T) → (∀{i} → (Element → T → T) → T → Iter(i) → Type)
  FoldᵣCriteria foldᵣ(_▫_) id iter with isEmpty iter | indexStep iter | current iter | step iter
  ... | 𝑇 | <> | <> | <>    = (foldᵣ(_▫_) id iter ≡ id)
  ... | 𝐹 | _  | x  | iters = (foldᵣ(_▫_) id iter ≡ x ▫ foldᵣ(_▫_) id iters)

  -- An iterator is finite when it is possible to fold it (when a fold function exists).
  -- This works because a fold for an infinite iterator cannot terminate, and only terminating functions exist.
  -- TODO: But it seems to be impossible to define a "foldUntil" function (though it is up to function extensionality).
  Finite = ∀{ℓ}{T : Type{ℓ}} → ∃{Obj = Foldᵣ(T)}(foldᵣ ↦ ∀{i}{_▫_}{id : T}{iter : Iter(i)} → FoldᵣCriteria (\{i}(_▫_) id → foldᵣ{i}(_▫_) id) (_▫_) id iter)
  module _ ⦃ fin : Finite ⦄ where
    foldᵣ : ∀{i} → (Element → T → T) → T → Iter(i) → T
    foldᵣ = [∃]-witness fin

    length : ∀{i} → Iter(i) → ℕ
    length = foldᵣ(const 𝐒) 𝟎

    count : ∀{i} → (Element → Bool) → Iter(i) → ℕ
    count(P) = foldᵣ(x ↦ if P(x) then 𝐒 else id) 𝟎

    foldₗ : (T → Element → T) → T → Iter(i) → T
    foldₗ(_▫_) = swap(foldᵣ(y ↦ f ↦ x ↦ f(x ▫ y)) id)

    last : ∀{i} → Iter(i) → Option(Element)
    last = foldₗ(const Some) None

    -- Note: Below are possibly inefficient implementations of functions because if they were guaranteed to exit early, the number of computations would be reduced.
    first : ∀{i} → Iter(i) → Option(Element)
    first = foldᵣ(const ∘ Some) None

  -- TODO: Complete = Surjective(step)

  record Initialed (i : Index) : Type{ℓᵢ Lvl.⊔ ℓ} where
    constructor initialed
    eta-equality
    field
      iter : Iter(i)
      left : ℕ

  Initialed-iterable : Iterable(Initialed)
  Element   Initialed-iterable = Element
  isEmpty   Initialed-iterable (initialed iter 𝟎)      = 𝑇
  current   Initialed-iterable (initialed iter 𝟎)      = <>
  indexStep Initialed-iterable (initialed iter 𝟎)      = <>
  step      Initialed-iterable (initialed iter 𝟎)      = <>
  isEmpty   Initialed-iterable (initialed iter (𝐒(_))) = isEmpty iter
  current   Initialed-iterable (initialed iter (𝐒(_))) = current iter
  indexStep Initialed-iterable (initialed iter (𝐒(_))) = indexStep iter
  step      Initialed-iterable (initialed iter (𝐒(n))) with isEmpty iter | indexStep iter | step iter
  ... | 𝑇 | _ | _     = <>
  ... | 𝐹 | _ | sIter = initialed sIter n

  {-
  record Skipped (i : Index) : Type{ℓᵢ Lvl.⊔ ℓ} where
    constructor skipped
    eta-equality
    field
      iter  : Iter(i)
      still : ℕ

  Skipped-iterable : Iterable(Skipped)
  Element   Skipped-iterable = Element
  isEmpty   Skipped-iterable (skipped iter 𝟎)      = 𝑇
  current   Skipped-iterable (skipped iter 𝟎)      = <>
  indexStep Skipped-iterable (skipped iter 𝟎)      = <>
  step      Skipped-iterable (skipped iter 𝟎)      = <>
  isEmpty   Skipped-iterable (skipped iter (𝐒(_))) = isEmpty (walk (𝐒(n)) iter)
  current   Skipped-iterable (skipped iter (𝐒(_))) = current (walk (𝐒(n)) iter)
  indexStep Skipped-iterable (skipped iter (𝐒(_))) = indexStep (walk (𝐒(n)) iter)
  step      Skipped-iterable (skipped iter (𝐒(n))) with isEmpty iter | indexStep iter | step iter
  -}

  mapped : (Element → Elem) → Iterable(Iter)
  Element (mapped {Elem = Elem} f) = Elem
  isEmpty (mapped f) = isEmpty
  current (mapped f) iter with isEmpty iter | current iter
  ... | 𝑇 | <> = <>
  ... | 𝐹 | x  = f(x)
  indexStep (mapped f) iter = indexStep iter
  step      (mapped f) iter = step iter

{-record Stored (n : ℕ) {Iter : Index → Type{ℓ₁}} (iterable : Iterable(Iter)) : Type where
  field
    Queue(Iterator.Element(iterable))
-}

  {- TODO: Also needs to store data, so it cannot be the same Iter
  skipped : ℕ → Iterator{ℓₑ} → Iterator
  Iterator.Element (skipped _ iterator) = Iterator.Element iterator
  Iterator.isEmpty (skipped n iterator) = Iterator.atMost n iterator
  Iterator.current (skipped _ iterator) =
  Iterator.indexStep (skipped iterator) =
  Iterator.step      (skipped iterator) =
-}

{-
skipped : ℕ → ∀{iter} → Iterable{ℓₑ}(iter) → Iterable(iter)
skipped 𝟎 iterable = iterable
skipped (𝐒 n) iterable = {!!}
-}

  -- An empty iterator of the iterable.
  EmptyConstruction : ∀{i} → Iter(i) → Type
  EmptyConstruction(empty) = IsTrue(isEmpty empty)

  -- A function prepending an element to an iterator of the iterable.
  PrependConstruction : ∀{indexPrepend : ∀{i} → Element → Iter(i) → Index} → (∀{i} → (x : Element) → (iter : Iter(i)) → Iter(indexPrepend x iter)) → Type
  PrependConstruction{indexPrepend} (prepend) = ∀{i}{x}{iter : Iter(i)} → ∃{Obj = IndexStep x iter}(Out x iter) where
    IndexStep : Element → Iter(i) → Type
    IndexStep{i} x iter with isEmpty(prepend x iter) | indexStep(prepend x iter)
    ... | 𝑇 | _ = Empty
    ... | 𝐹 | p = (p ≡ i)

    Out : (x : Element) → (iter : Iter(i)) → IndexStep x iter → Type
    Out x iter stepProof with isEmpty(prepend x iter) | indexStep(prepend x iter) | current(prepend x iter) | step(prepend x iter)
    ... | 𝐹 | _ | cur | st with [≡]-intro ← stepProof = (x ≡ cur) ∧ (st ≡ iter)

  module _
    {indexEmpty}{empty}
    ⦃ empty-construciton : EmptyConstruction{indexEmpty}(empty) ⦄
    {indexPrepend : ∀{i} → Element → Iter(i) → Index}
    {prepend : ∀{i} → (x : Element) → (iter : Iter(i)) → Iter(indexPrepend x iter)}
    ⦃ prepend-construction : PrependConstruction{indexPrepend}(prepend) ⦄
    where

    singleton : (x : Element) → Iter(indexPrepend x empty)
    singleton x = prepend x empty


open import Prelude
open import Nat
open import Bij

module NatDelta where

  instance
    NatBij : bij Nat Nat
    NatBij = record {
      convert = λ n → n;
      inj     = λ n → n;
      surj    = λ n → n , refl}

  open import Delta Nat {{NatBij}}

  nat-dd = dd


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

module Dodo.Binary.Subtraction where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Relation.Binary using (REL)
-- Local imports
open import Dodo.Binary.Empty using (¬₂_)
open import Dodo.Binary.Intersection using (_∩₂_)

-- # Definitions

infixl 30 _\₂_

_\₂_ : {a b ℓ₀ ℓ₁ : Level} {A : Set a} {B : Set b} → REL A B ℓ₀ → REL A B ℓ₁ → REL A B (ℓ₀ ⊔ ℓ₁)
_\₂_ R Q = R ∩₂ (¬₂ Q)


{-# OPTIONS --cubical #-}

module Issue2799 where

open import Agda.Primitive.Cubical

postulate
  PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ

{-# BUILTIN PATHP        PathP     #-}

_≡_ : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ
_≡_ {A = A} = PathP (λ _ → A)

record Stream (A : Set) : Set where
  coinductive
  constructor _,_
  field
    head : A
    tail : Stream A

open Stream

mapS : ∀ {A B} → (A → B) → Stream A → Stream B
head (mapS f xs) = f (head xs)
tail (mapS f xs) = mapS f (tail xs)

mapS-id : ∀ {A} {xs : Stream A} → mapS (λ x → x) xs ≡ xs
head (mapS-id {xs = xs} i) = head xs
tail (mapS-id {xs = xs} i) = mapS-id {xs = tail xs} i


module Data.ListSized.Proofs where

import      Lvl
open import Data.ListSized
open import Data.ListSized.Functions
open import Functional
open import Function.Equals
open import Numeral.Finite
open import Numeral.Natural
open import Numeral.Natural.Function
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Operator
open import Structure.Relator.Properties
open import Syntax.Transitivity
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable T A A₁ A₂ B B₁ B₂ C C₁ C₂ Result : Type{ℓ}
private variable a b n n₁ n₂ : ℕ
private variable f : B → C
private variable g : A → B
private variable l l₁ l₂ : List(T)(n)
private variable x : T

map-id : (map{A = A}{n = n} id ⊜ id)
_⊜_.proof map-id {∅}     = reflexivity(_≡_)
_⊜_.proof map-id {x ⊰ l} = congruence₂ᵣ(_⊰_)(_) (_⊜_.proof map-id {l})

map-[∘] : (map{n = n} (f ∘ g) ⊜ (map f) ∘ (map g))
_⊜_.proof map-[∘] {∅}     = reflexivity(_≡_)
_⊜_.proof map-[∘] {x ⊰ l} = congruence₂ᵣ(_⊰_)(_) (_⊜_.proof map-[∘] {l})

map-[++] : map f(l₁ ++ l₂) ≡ map f(l₁) ++ map f(l₂)
map-[++] {l₁ = ∅}       = reflexivity(_≡_)
map-[++] {l₁ = x₁ ⊰ l₁} = congruence₂ᵣ(_⊰_)(_) (map-[++] {l₁ = l₁})

map-repeat : map f(repeat x n) ≡ repeat (f(x)) n
map-repeat {n = 𝟎}   = reflexivity(_≡_)
map-repeat {n = 𝐒 n} = congruence₂ᵣ(_⊰_)(_) (map-repeat {n = n})

[+][++]-repeat : repeat x (n₁ + n₂) ≡ repeat x n₁ ++ repeat x n₂
[+][++]-repeat {n₁ = 𝟎}    = reflexivity(_≡_)
[+][++]-repeat {n₁ = 𝐒 n₁} = congruence₂ᵣ(_⊰_)(_) ([+][++]-repeat {n₁ = n₁})


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

module Data.Vec.Iterated where

open import Data.Unit.UniversePolymorphic
open import Level
open import Data.Nat.Base
open import Function

private
  variable
    n m : ℕ

mutual
  Vec :  Type a → ℕ → Type a
  Vec A zero     = Vec⁰
  Vec A (suc n)  = Vec⁺ A n

  record Vec⁰ {a} : Type a where
    eta-equality
    constructor []

  infixr 5 _∷_
  record Vec⁺ {a} (A : Type a) (n : ℕ) : Type a where
    eta-equality
    inductive
    constructor _∷_
    field
      head : A
      tail : Vec A n

open Vec⁺ public

foldr : ∀ {p} (P : ℕ → Type p) →
          (∀ {n} → A → P n → P (suc n)) →
          P zero →
          Vec A n → P n
foldr {n = zero} P f b _         = b
foldr {n = suc n} P f b (x ∷ xs) = f x (foldr P f b xs)

foldl : ∀ {p} (P : ℕ → Type p) →
          (∀ {n} → A → P n → P (suc n)) →
          P zero →
          Vec A n → P n
foldl {n = zero } P f b _ = b
foldl {n = suc n} P f b (x ∷ xs) = foldl (P ∘ suc) f (f x b) xs

foldlN : ∀ {p} (P : ℕ → Type p) →
          (∀ {n} → A → P (suc n) → P n) →
          P n →
          Vec A n → P zero
foldlN P f b xs = foldr (λ n → P n → P zero) (λ x k xs → k (f x xs)) id xs b

module _ (f : A → B → B) (e : B) where
  foldr′ : Vec A n → B
  foldr′ {n = zero } xs = e
  foldr′ {n = suc n} (x ∷ xs) = f x (foldr′ xs)

foldl′ : (A → B → B) → B → Vec A n → B
foldl′ {n = zero}  f b xs = b
foldl′ {n = suc n} f b (x ∷ xs) = foldl′ f (f x b) xs

-- vecFromList : (xs : List A) → Vec A (length xs)
-- vecFromList List.[] = []
-- vecFromList (x List.∷ xs) = x ∷ vecFromList xs

-- vecToList : Vec A n → List A
-- vecToList = foldr′ List._∷_ List.[]

open import Data.Fin.Indexed

infixl 4 lookup
lookup : Fin n → Vec A n → A
lookup f0     = head
lookup (fs i) xs = lookup i (tail xs)

syntax lookup i xs = xs [ i ]

infixl 4 replace
replace : Fin n → A → Vec A n → Vec A n
replace f0     x xs .head = x
replace f0     x xs .tail = xs .tail
replace (fs i) x xs .head = xs .head
replace (fs i) x xs .tail = replace i x (xs .tail)

syntax replace i x xs = xs [ i ]≔ x


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

module Data.List.Kleene where

open import Prelude
open import Data.Fin

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

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

mutual
  foldr⁺ : (A → B → B) → B → A ⁺ → B
  foldr⁺ f b (x & xs) = f x (foldr⋆ f b xs)

  foldr⋆ : (A → B → B) → B → A ⋆ → B
  foldr⋆ f b [] = b
  foldr⋆ f b (∹ xs) = foldr⁺ f b xs

length⋆ : A ⋆ → ℕ
length⋆ = foldr⋆ (const suc) zero

length⁺ : A ⁺ → ℕ
length⁺ = foldr⁺ (const suc) zero

mutual
  _!⁺_ : (xs : A ⁺) → Fin (length⁺ xs) → A
  xs !⁺ f0  = xs .head
  xs !⁺ fs i = xs .tail !⋆ i

  _!⋆_ : (xs : A ⋆) → Fin (length⋆ xs) → A
  (∹ xs) !⋆ i = xs !⁺ i

map⋆ : (A → B) → A ⋆ → B ⋆
map⋆ f = foldr⋆ (λ x xs → ∹ f x & xs) []

map⁺ : (A → B) → A ⁺ → B ⁺
map⁺ f (x & xs) = f x & map⋆ f xs

mutual
  _⋆++⋆_ : A ⋆ → A ⋆ → A ⋆
  [] ⋆++⋆ ys = ys
  (∹ xs) ⋆++⋆ ys = ∹ (xs ⁺++⋆ ys)

  _⁺++⋆_ : A ⁺ → A ⋆ → A ⁺
  head (xs ⁺++⋆ ys) = head xs
  tail (xs ⁺++⋆ ys) = tail xs ⋆++⋆ ys


{-# OPTIONS --without-K --safe #-}
module Cats.Category.Constructions.Thin where

open import Cats.Category.Base

open import Level using (_⊔_)
open import Relation.Binary.PropositionalEquality using (_≡_)

module _ {lo la l≈} (C : Category lo la l≈) where

  open Category C

  Thin : Set (lo ⊔ la ⊔ l≈)
  Thin = ∀ {A B} {f g : A ⇒ B} → f ≈ g

  StronglyThin : Set (lo ⊔ la)
  StronglyThin = ∀ {A B} {f g : A ⇒ B} → f ≡ g

StronglyThin→Thin : ∀ {lo la l≈} {C : Category lo la l≈}
  → StronglyThin C → Thin C
StronglyThin→Thin {C = C} sthin = ≈.reflexive sthin
  where
    open Category C


{-# OPTIONS --without-K --safe #-}
module Cats.Category.Presheaves where

open import Level using (_⊔_ ; suc)

open import Cats.Category
open import Cats.Category.Fun using (Fun)
open import Cats.Category.Op using (_ᵒᵖ)
open import Cats.Category.Setoids using (Setoids)

Presheaves : ∀ {lo la l≈} (C : Category lo la l≈) l l′
  → Category (lo ⊔ la ⊔ l≈ ⊔ suc (l ⊔ l′)) (lo ⊔ la ⊔ l ⊔ l′) (lo ⊔ l ⊔ l′)
Presheaves C l l′ = Fun (C ᵒᵖ) (Setoids l l′)


-- Andreas, 2013-05-16, raised by Andrea 2015-02-10

open import Common.Size
open import Common.Prelude

data Wrap (A : SizeUniv) : SizeUniv where
-- data Wrap (A : Set) : Set where
  wrap : A → Wrap A

module M (f : ∀ i → Wrap (Size< i)) where

  test : ∀ i → Wrap (Size< i) → ⊥
  test i (wrap j) = test j (f j)

module N (pred : ∀ i → Size< i) where

  f = (λ i → wrap (pred i))
  open M f

  loop : Size → ⊥
  loop i = test i (f i)
  -- = test i (wrap (pred i))
  -- = test (pred i) ((λ i → wrap (pred i)) (pred i))
  -- = test (pred i) (wrap (pred (pred i)))
  -- = test (pred (pred i)) (wrap (pred (pred (pred i))))
  -- = ...


-- 2010-09-07 Andreas

module IrrelevantRecordMatching where

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

wrongElim : {A : Set} -> .(Prod A A) -> A
wrongElim (a , a') = a
-- needs to fail because a is irrelevant


module Formalization.SKICombinatorCalculus where

import      Lvl
import      Function
open import Functional using (_∘_)
open import Type
open import Structure.Relator.Properties
open import Syntax.Transitivity

data Term : Type{Lvl.𝟎} where
  S   : Term               -- Fusion
  K   : Term               -- Constant
  _·_ : Term → Term → Term
infixl 30 _·_

pattern B  = S · (K · S) · K                 -- Composition
pattern C  = S · (S · (K · B) · S) · (K · K) -- Swapped application
pattern I  = S · K · K                       -- Identity of operation
pattern SA = (S · I) · I                     -- Self application
pattern W  = S · S · (S · K)                 --
pattern Ω  = SA · SA                         --
pattern SW = S · (K · (S · I)) · K           -- Swapped operation
T = C
Z = B
-- Z = C · (C · (B · N · (S · I · I)) · Ω) · I

{- TODO: Is this possible?
term-fn-type : ∀{ℓ} → Term → Type{Lvl.𝐒(ℓ)}
term-fn-type {ℓ} S = ∀{X Y Z : Type{ℓ}} → (X → (Y → Z)) → (X → Y) → (X → Z)
term-fn-type {ℓ} K = ∀{X Y : Type{ℓ}} → Y → X → Y
term-fn-type {ℓ} (x · y) = {!term-fn-type {ℓ} x!}
-}

module Derivation where
  -- TODO: But there are no base cases?
  data deriv : Term → Type{Lvl.𝟎} where
    constant : ∀{α β γ ι} → deriv(α · ((K · β) · γ) · ι) → deriv(α · β · ι)
    fuse     : ∀{α β γ δ ι} → deriv(α · (((S · β) · γ) · δ) · ι) → deriv(α · ((β · δ) · (γ · δ)) · ι)

  _⇒_ : Term → Term → Type
  a ⇒ b = ∀{α ι} → deriv(α · a · ι) → deriv(α · b · ι)

  identity : ∀{β} → ((I · β) ⇒ β)
  identity = constant ∘ fuse

  -- composition : ∀{α ι a b c} → deriv(α · (B · a · b · c) · ι) → deriv(α · ((a · (b · c))) · ι)
  -- composition = {!!}

-- TODO: Is this really correct? Should be similar to deriv
data _⟶_ : Term → Term → Type{Lvl.𝟎} where -- TODO: Use reflexive-transitive closure instead
  constant : ∀{c t} → (((K · c) · t) ⟶ c)
  fuse     : ∀{a b c} → ((((S · a) · b) · c) ⟶ ((a · c) · (b · c)))

  comp     : ∀{a₁ a₂ b₁ b₂} → (a₁ ⟶ a₂) → (b₁ ⟶ b₂) → ((a₁ · b₁) ⟶ (a₂ · b₂))
  refl     : ∀{a} → (a ⟶ a)
  trans    : ∀{a b c} → (a ⟶ b) → (b ⟶ c) → (a ⟶ c)
infixl 29 _⟶_

instance
  [⟶]-reflexivity : Reflexivity(_⟶_)
  [⟶]-reflexivity = intro refl

instance
  [⟶]-transitivity : Transitivity(_⟶_)
  [⟶]-transitivity = intro trans

-- identity : ∀{t} → ((I · t) ⟶ t)
pattern identity = trans fuse constant

-- compₗ : ∀{a₁ a₂ b} → (a₁ ⟶ a₂) → ((a₁ · b) ⟶ (a₂ · b))
pattern compₗ p = comp p refl

-- compᵣ : ∀{a b₁ b₂} → (b₁ ⟶ b₂) → ((a · b₁) ⟶ (a · b₂))
pattern compᵣ p = comp refl p

composition : ∀{a b c} → ((B · a · b · c) ⟶ (a · (b · c)))
composition {a}{b}{c} =
  B · a · b · c                     🝖-[ refl ]
  ((S · (K · S) · K · a) · b) · c   🝖-[ compₗ (compₗ fuse) ]
  (((K · S · a) · (K · a)) · b) · c 🝖-[ compₗ (compₗ (compₗ constant)) ]
  ((S · (K · a)) · b) · c           🝖-[ fuse ]
  (K · a · c) · (b · c)             🝖-[ compₗ constant ]
  a · (b · c)                       🝖-end

swapped-application : ∀{a b c} → ((C · a · b · c) ⟶ ((a · c) · b))
swapped-application {a}{b}{c} =
  C · a · b · c                               🝖-[ refl ]
  S · (S · (K · B) · S) · (K · K) · a · b · c 🝖-[ compₗ (compₗ fuse) ]
  (S · (K · B) · S · a) · (K · K · a) · b · c 🝖-[ compₗ (compₗ (comp fuse constant)) ]
  (K · B · a · (S · a)) · K · b · c           🝖-[ compₗ (compₗ (compₗ (compₗ constant))) ]
  (B · (S · a)) · K · b · c                   🝖-[ compₗ composition ]
  (S · a) · (K · b) · c                       🝖-[ fuse ]
  (a · c) · (K · b · c)                       🝖-[ compᵣ constant ]
  (a · c) · b                                 🝖-end

apply-self : ∀{t} → ((SA · t) ⟶ (t · t))
apply-self = trans fuse (comp identity identity)

swapping : ∀{a b} → ((SW · a · b) ⟶ (b · a))
swapping {a}{b} =
  S · (K · (S · I)) · K · a · b   🝖-[ compₗ fuse ]
  (K · (S · I) · a) · (K · a) · b 🝖-[ compₗ (compₗ constant) ]
  (S · I) · (K · a) · b           🝖-[ fuse ]
  I · b · (K · a · b)             🝖-[ comp identity constant ]
  b · a                           🝖-end

module Boolean where
  TRUE  = K             -- True
  FALSE = S · K         -- False
  NOT   = FALSE · TRUE  -- Not (Negation)
  OR    = TRUE          -- Or (Disjunction)
  AND   = FALSE         -- And (Conjunction)

  IsTrue : Term → Type{Lvl.𝟎}
  IsTrue(a) = ∀{t f} → ((a · t · f) ⟶ t)

  IsFalse : Term → Type{Lvl.𝟎}
  IsFalse(a) = ∀{t f} → ((a · t · f) ⟶ f)

  reduce-true-is-true : ∀{t} → (t ⟶ TRUE) → IsTrue(t)
  reduce-true-is-true tT = (compₗ (compₗ tT)) 🝖 constant

  reduce-false-is-false : ∀{t} → (t ⟶ FALSE) → IsFalse(t)
  reduce-false-is-false tT = (compₗ (compₗ tT)) 🝖 identity

  true : IsTrue(TRUE)
  true = constant

  false : IsFalse(FALSE)
  false = identity

  not-true-is-false : ∀{t} → IsTrue(t) → IsFalse(t · NOT)
  not-true-is-false t-true = (compₗ t-true) 🝖 fuse 🝖 constant

  {-not-false-is-true : ∀{t} → IsFalse(t) → IsTrue(t · NOT)
  not-false-is-true {term} t-false {t}{f} =
    term · NOT · t · f         🝖-[ refl ]
    term · (S · K · K) · t · f 🝖-[ {!!} ]
    f · (S · K · K) · t · f 🝖-[ {!!} ]
    t                          🝖-end
  -}

  not-true : IsFalse(TRUE · NOT)
  not-true {t}{f} = not-true-is-false constant
    {-TRUE · NOT · t · f            🝖-[ refl ]
    TRUE · (FALSE · TRUE) · t · f 🝖-[ refl ]
    K · (S · K · K) · t · f       🝖-[ compₗ constant ]
    S · K · K · f                 🝖-[ fuse ]
    K · f · (K · f)               🝖-[ constant ]
    f                             🝖-end-}

  {-
  not-false : IsTrue(FALSE · NOT)
  not-false {t}{f} =
    FALSE · NOT · t · f            🝖-[ refl ]
    FALSE · (FALSE · TRUE) · t · f 🝖-[ refl ]
    S · K · (S · K · K) · t · f    🝖-[ compₗ fuse ]
    K · t · (S · K · K · t) · f    🝖-[ compₗ constant ]
    t · f                          🝖-[ {!!} ] -- TODO: ???
    t                              🝖-end
  -- not-false-is-true identity
  -}

  or-true-true : IsTrue(TRUE · OR · TRUE)
  or-true-true = reduce-true-is-true constant

  or-true-false : IsTrue(TRUE · OR · FALSE)
  or-true-false = reduce-true-is-true constant

  or-false-true : IsTrue(FALSE · OR · TRUE)
  or-false-true = reduce-true-is-true(fuse 🝖 constant)

  or-false-true2 : IsTrue(FALSE · OR · TRUE)
  or-false-true2 = reduce-true-is-true(fuse 🝖 constant)

  or-false-false : IsFalse(FALSE · OR · FALSE)
  or-false-false = reduce-false-is-false(fuse 🝖 constant)

  and-true-true : IsTrue(TRUE · TRUE · AND)
  and-true-true = reduce-true-is-true(constant)

  and-true-false : IsFalse(TRUE · FALSE · AND)
  and-true-false = reduce-false-is-false(constant)

  and-false-true : IsFalse(FALSE · TRUE · AND)
  and-false-true = reduce-false-is-false(identity)

  and-false-false : IsFalse(FALSE · FALSE · AND)
  and-false-false = reduce-false-is-false(fuse 🝖 constant)


-- Andreas and James, 2013-11-19

{-# OPTIONS --copatterns  #-}
-- {-# OPTIONS -v tc.cover.splittree:15 -v tc.cc:15 #-}

open import Common.Level
open import Common.Product

mutual
  data Delay (A : Set) : Set where
    later : ∞Delay A → Delay A

  record ∞Delay (A : Set) : Set where
    coinductive
    constructor delay
    field
      force : Delay A
open ∞Delay public

data Def {A : Set} : Delay A → Set where
  later⇓ : ∀ (x : ∞Delay A) → Def (force x) → Def (later x)

data Ty : Set where
  _⇒_ : (a b : Ty) → Ty

data Tm (Γ : Ty) : (a : Ty) → Set where
  abs : ∀ a b (t : Tm (Γ ⇒ a) b) → Tm Γ (a ⇒ b)

data Val : (a : Ty) → Set where
  lam : ∀ Γ a b (t : Tm (Γ ⇒ a) b) → Val (a ⇒ b)

postulate
  eval : ∀ Γ a → Tm Γ a → Delay (Val a)

∞apply : ∀ a b → Val (a ⇒ b) → ∞Delay (Val b)
force (∞apply .a .b (lam Γ a b t)) = eval (Γ ⇒ a) b t

β-expand : ∀ Γ a b (t : Tm (Γ ⇒ a) b) →
  Def (eval (Γ ⇒ a) b t) → Def (later (∞apply a b (lam Γ a b t)))
β-expand Γ a b t = later⇓ (∞apply a b (lam Γ a b t))

-- This line failed because of a missing reduction (due to wrong split tree).


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

module Bundles where

open import Algebra.Core
open import Relation.Binary
open import Level
open import Algebra.Bundles
open import Algebra.Structures
open import Structures

------------------------------------------------------------------------
-- Bundles with 1 binary operation
------------------------------------------------------------------------

record IdempotentMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isIdempotentMagma  : IsIdempotentMagma _≈_ _∙_

  open IsIdempotentMagma isIdempotentMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record AlternateMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isAlternateMagma  : IsAlternateMagma _≈_ _∙_

  open IsAlternateMagma isAlternateMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record FlexibleMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isFlexibleMagma  : IsFlexibleMagma _≈_ _∙_

  open IsFlexibleMagma isFlexibleMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record MedialMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isMedialMagma  : IsMedialMagma _≈_ _∙_

  open IsMedialMagma isMedialMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record SemimedialMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isSemimedialMagma  : IsSemimedialMagma _≈_ _∙_

  open IsSemimedialMagma isSemimedialMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record LatinQuasigroup c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isLatinQuasigroup : IsLatinQuasigroup _≈_ _∙_

  open IsLatinQuasigroup isLatinQuasigroup public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (_≉_; rawMagma)

record InverseSemigroup c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier            : Set c
    _≈_                : Rel Carrier ℓ
    _∙_                : Op₂ Carrier
    isInverseSemigroup : IsInverseSemigroup _≈_ _∙_

  open IsInverseSemigroup isInverseSemigroup public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (_≉_; rawMagma)

------------------------------------------------------------------------
-- Bundles with 1 binary operation and 1 element
------------------------------------------------------------------------

record LeftUnitalMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier  : Set c
    _≈_      : Rel Carrier ℓ
    _∙_      : Op₂ Carrier
    ε        : Carrier
    isLeftUnitalMagma  : IsLeftUnitalMagma _≈_ _∙_ ε

  open IsLeftUnitalMagma isLeftUnitalMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

record RightUnitalMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier  : Set c
    _≈_      : Rel Carrier ℓ
    _∙_      : Op₂ Carrier
    ε        : Carrier
    isRightUnitalMagma  : IsRightUnitalMagma _≈_ _∙_ ε

  open IsRightUnitalMagma isRightUnitalMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (rawMagma)

------------------------------------------------------------------------
-- Bundles with 2 binary operations, 1 unary operation & 1 element
------------------------------------------------------------------------

record NonAssociativeRing c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 -_
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier               : Set c
    _≈_                   : Rel Carrier ℓ
    _+_                   : Op₂ Carrier
    _*_                   : Op₂ Carrier
    -_                    : Op₁ Carrier
    0#                    : Carrier
    1#                    : Carrier
    isNonAssociativeRing  : IsNonAssociativeRing _≈_ _+_ _*_ -_ 0# 1#

  open IsNonAssociativeRing isNonAssociativeRing public

  +-abelianGroup : AbelianGroup _ _
  +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup }

  open AbelianGroup +-abelianGroup public
    using () renaming (group to +-group; invertibleMagma to +-invertibleMagma; invertibleUnitalMagma to +-invertibleUnitalMagma)

------------------------------------------------------------------------
-- Bundles with 3 binary operation and 1 element
------------------------------------------------------------------------

record Pique c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infixl 7 _\\_
  infixl 7 _//_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    _\\_    : Op₂ Carrier
    _//_    : Op₂ Carrier
    ε       : Carrier
    isPique : IsPique _≈_ _∙_ _\\_ _//_ ε

  open IsPique isPique public

record LeftBolLoop c ℓ : Set (suc (c ⊔ ℓ)) where
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    _\\_    : Op₂ Carrier
    _//_    : Op₂ Carrier
    ε       : Carrier
    isLeftBolLoop : IsLeftBolLoop  _≈_ _∙_ _\\_ _//_ ε

  open IsLeftBolLoop isLeftBolLoop public

  loop : Loop _ _
  loop = record { isLoop = isLoop }

  open Loop loop public
    using (quasigroup)

record RightBolLoop c ℓ : Set (suc (c ⊔ ℓ)) where
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    _\\_    : Op₂ Carrier
    _//_    : Op₂ Carrier
    ε       : Carrier
    isRightBolLoop : IsRightBolLoop  _≈_ _∙_ _\\_ _//_ ε

  open IsRightBolLoop isRightBolLoop public

  loop : Loop _ _
  loop = record { isLoop = isLoop }

  open Loop loop public
    using (quasigroup)

record MoufangLoop c ℓ : Set (suc (c ⊔ ℓ)) where
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    _\\_    : Op₂ Carrier
    _//_    : Op₂ Carrier
    ε       : Carrier
    isMoufangLoop : IsMoufangLoop  _≈_ _∙_ _\\_ _//_ ε

  open IsMoufangLoop isMoufangLoop public

  loop : Loop _ _
  loop = record { isLoop = isLoop }

  open Loop loop public
    using (quasigroup)


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

open import Base

module Spaces.WedgeCircles {i} (A : Set i) where

{-
The idea is

data wedge-circles : Set (suc i) where
  base : wedge-circles
  loops : A → base ≡ base
-}

private
  data #wedge-circles : Set (suc i) where
    #base : #wedge-circles

wedge-circles : Set (suc i)
wedge-circles = #wedge-circles

base : wedge-circles
base = #base

postulate  -- HIT
  loops : A → base ≡ base

wedge-circles-rec : ∀ {i} (P : wedge-circles → Set i) (x : P base)
  (p : (t : A) → transport P (loops t) x ≡ x) → ((t : wedge-circles) → P t)
wedge-circles-rec P x p #base = x

postulate  -- HIT
  β : ∀ {i} (P : wedge-circles → Set i) (x : P base)
      (p : (t : A) → transport P (loops t) x ≡ x) (t : A)
      → apd (wedge-circles-rec P x p) (loops t) ≡ p t

wedge-circles-rec-nondep : ∀ {i} (B : Set i) (x : B) (p : A → x ≡ x)
  → (wedge-circles → B)
wedge-circles-rec-nondep B x p #base = x

postulate  -- HIT
  β-nondep : ∀ {i} (B : Set i) (x : B) (p : A → x ≡ x) (t : A)
      → ap (wedge-circles-rec-nondep B x p) (loops t) ≡ p t


module Section9 where

open import Section8 public

-- 9. A decision algorithm for terms
-- =================================
--
-- The reduction defined above can be used for deciding if two well-typed terms are convertible
-- with each other or not: reduce the terms and check if the results are equal.  This algorithm
-- is implicit in Martin-Löf’s notes [13].
--
-- The decision algorithm is complete:

-- Theorem 11.
postulate
  thm₁₁ : ∀ {Γ A t₀ t₁} →
            Γ ⊢ t₀ ≊ t₁ ∷ A →
            Σ 𝕋 (λ t → Γ ⊢ t₀ ⇓ t ∷ A × Γ ⊢ t₁ ⇓ t ∷ A)

-- Proof:  By Lemma 14 and Lemma 12 we know that there exist proof trees `M, N` such
-- that `t₀` is equal to `M ⁻` and `t₁` is equal to `N ⁻`.  By Theorem 9 we get that `M ≅ N`.  We can
-- choose `nf M ⁻` for `t` since, by Lemma 8, `Γ ⊢ M ⁻ ⇓ nf M ⁻ ∷ A`, `Γ ⊢ N ⁻ ⇓ nf N ⁻ ∷ A`
-- and by Theorem 6 we have `nf M ≡ nf N` and hence that `nf M ⁻` and `nf N ⁻` are the
-- same.
--
-- This decision algorithm is correct, i.e.,

-- Theorem 12.
postulate
  thm₁₂ : ∀ {Γ A t} →
            (M N : Γ ⊢ A) → Γ ⊢ M ⁻ ⇓ t ∷ A → Γ ⊢ N ⁻ ⇓ t ∷ A →
            M ≅ N

-- Proof:  We have `nf M ⁻ ≡ nf N ⁻` since, by Lemma 8, `Γ ⊢ M ⁻ ⇓ nf M ⁻ ∷ A`
-- and `Γ ⊢ N ⁻ ⇓ nf N ⁻ ∷ A` and the reduction is deterministic.  By Corollary 2 we get
-- `M ≅ N`.


module Data.Either.Equiv.Id where

import      Lvl
open import Data
open import Data.Either as Either
open import Data.Either.Equiv
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Setoid
open import Structure.Function.Domain
open import Type

private variable ℓ ℓₑ ℓₑ₁ ℓₑ₂ : Lvl.Level
private variable A B : Type{ℓ}

module _ ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ where
  instance
    Left-injectivity : Injective(Left{A = A}{B = B})
    Injective.proof Left-injectivity [≡]-intro = [≡]-intro

  instance
    Right-injectivity : Injective(Right{A = A}{B = B})
    Injective.proof Right-injectivity [≡]-intro = [≡]-intro

  instance
    Either-Id-extensionality : Extensionality{A = A}{B = B} [≡]-equiv
    Either-Id-extensionality = intro \()


module Data.List.All.Properties.Extra {a}{A : Set a} where

open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Fin
open import Data.List as List hiding (reverse)
open import Data.List.Relation.Unary.Any hiding (tail)
open import Data.List.Membership.Propositional
open import Data.List.Properties.Extra
open import Data.List.At
open import Data.List.Relation.Unary.All as All hiding (_[_]=_)
open import Data.List.Relation.Unary.All.Properties
open import Data.Product
open import Function

map-map : ∀ {p q r}{P : A → Set p}{Q : A → Set q}{R : A → Set r}{l : List A}(ps : All P l)
          {f : ∀ {x : A} → P x → Q x}{g : ∀ {x : A} → Q x → R x} →
          All.map g (All.map f ps) ≡ All.map (g ∘ f) ps
map-map [] = refl
map-map (px ∷ ps) = cong₂ _∷_ refl (map-map ps)

drop-all : ∀ {p}{P : A → Set p}{l : List A} n → All P l → All P (drop n l)
drop-all zero px = px
drop-all (suc n) [] = []
drop-all (suc n) (px ∷ pxs) = drop-all n pxs

split-++ : ∀ {p}{P : A → Set p}(l m : List A) → All P (l ++ m) → All P l × All P m
split-++ [] m pxs = [] , pxs
split-++ (x ∷ l) m (px ∷ pxs) with split-++ l m pxs
... | lp , rp = px ∷ lp , rp

_++-all_ : ∀ {l m p}{P : A → Set p} → All P l → All P m → All P (l ++ m)
[] ++-all pm = pm
(px ∷ pl) ++-all pm = px ∷ (pl ++-all pm)

∈-all : ∀ {p}{P : A → Set p}{l : List A}{x} → x ∈ l → All P l → P x
∈-all (here refl) (px ∷ q) = px
∈-all (there p) (px ∷ q) = ∈-all p q

-- proof matters; update a particular witness of a property
_All[_]≔_ : ∀ {p}{P : A → Set p} {xs : List A} {i x} →
            All P xs → xs [ i ]= x → P x → All P xs
_All[_]≔_ [] ()
_All[_]≔_ {xs = .(_ ∷ _)} {zero} (px ∷ xs) refl px' = px' ∷ xs
_All[_]≔_ {xs = .(_ ∷ _)} {suc i} (px ∷ xs) q px' = px ∷ (xs All[ q ]≔ px')

-- strong update
-- _All[_]≔!_ : ∀ {p}{P : A → Set p} {xs : List A} {x} →
--             All P xs → (i : Fin (length xs)) → P x → All P (xs [ i ]≔ x)
-- [] All[ () ]≔! y
-- (px ∷ xs) All[ zero ]≔! y = y ∷ xs
-- (px ∷ xs) All[ suc i ]≔! y = px ∷ xs All[ i ]≔! y

_all-∷ʳ_ : ∀ {p}{l : List A} {x} {P : A → Set p} → All P l → P x → All P (l ∷ʳ x)
_all-∷ʳ_ [] q = q ∷ []
_all-∷ʳ_ (px ∷ p) q = px ∷ (p all-∷ʳ q)

-- All≔'∘map : ∀ {p q}{P : A → Set p}{Q : A → Set q}{xs : List A} {x}(pxs : All P xs)(e : x ∈ xs)(px : P x)(f : ∀ {x} → P x → Q x) →
--             (All.map f pxs) All[ e ]≔' (f px) ≡ All.map f (pxs All[ e ]≔' px)
-- All≔'∘map [] ()
-- All≔'∘map (px ∷ pxs) (here refl) qx f = refl
-- All≔'∘map (px ∷ pxs) (there e) qx f = cong₂ _∷_ refl (All≔'∘map pxs e qx f)

all-∷ʳ∘map : ∀ {p q}{P : A → Set p}{Q : A → Set q}{xs : List A} {x}(pxs : All P xs)(px : P x)(f : ∀ {x} → P x → Q x) →
             (All.map f pxs) all-∷ʳ (f px) ≡ All.map f (pxs all-∷ʳ px)
all-∷ʳ∘map [] px f = refl
all-∷ʳ∘map (px₁ ∷ pxs) px f = cong₂ _∷_ refl (all-∷ʳ∘map pxs px f)

lookup∘map : ∀ {p q}{P : A → Set p}{Q : A → Set q}{xs : List A} {x}(pxs : All P xs)(e : x ∈ xs)(f : ∀ {x} → P x → Q x) →
             All.lookup (All.map f pxs) e ≡ f (All.lookup pxs e)
lookup∘map [] ()
lookup∘map (px ∷ pxs) (here refl) f = refl
lookup∘map (px ∷ pxs) (there e) f = lookup∘map pxs e f

erase : ∀ {p b}{P : A → Set p}{l : List A}{B : Set b} → (∀ {x} → P x → B) → All P l → List B
erase f [] = []
erase f (px ∷ xs₁) = f px ∷ erase f xs₁

-- pop₁ : ∀ {x : A}{p xs}{P : A → Set p} → All P (x ∷ xs) → P x × All P xs
-- pop₁ st = head st , tail st

-- open import Data.List.Properties
-- popₙ : ∀ (as : List A){p xs}{P : A → Set p} → All P (as ++ xs) → All P (List.reverse as) × All P xs
-- popₙ [] st = [] , st
-- popₙ (x ∷ xs) (px ∷ pxs) rewrite unfold-reverse x xs =
--   let pys , pzs = popₙ xs pxs in (pys all-∷ʳ px) , pzs

-- open import Relation.Binary.Core
-- open import Data.List.Relation.Pointwise hiding (Rel)
-- module _ {a ℓ}{A : Set a}(_∼_ : Rel A ℓ) where

--   pw-map : ∀ {l m p}{P : A → Set p} → (∀ {a b} → a ∼ b → P a → P b) → Pointwise _∼_ l m → All P l → All P m
--   pw-map f [] [] = []
--   pw-map f (x∼y ∷ r) (px ∷ xs) = f x∼y px ∷ pw-map f r xs


open import Level using (0ℓ)
open import Function using (_$_)

open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; sym; trans; cong; cong₂; isEquivalence; setoid; module ≡-Reasoning)
open import Relation.Binary.PropositionalEquality.WithK using (≡-irrelevant)
open import Relation.Nullary.Negation using (contradiction)
open ≡-Reasoning

open import Data.Unit using (⊤; tt)
open import Agda.Builtin.FromNat using (Number)

open import Data.Product using (_,_)

open import AKS.Primality using (IsPrime; Prime; bézout-prime)

module AKS.Modular.Quotient.Properties {P : Prime} where

open Prime P using () renaming (prime to p; isPrime to p-isPrime)
open IsPrime p-isPrime using (1<p)

open import AKS.Nat using (ℕ; zero; suc; _<_; _≤_; _∸_) renaming (_+_ to _+ℕ_; _*_ to _*ℕ_; _≟_ to _≟ℕ_)
open import AKS.Nat using (<⇒≤; [n∸m]+m≡n; suc-mono-≤; *-mono-≤; ≤-refl)
import AKS.Nat as Nat
import Data.Nat.Properties as Nat
open import AKS.Nat.Divisibility using (_%_; %-distribˡ-+; %-distribˡ-∸; %-distribˡ-*; m%n%n≡m%n; n<m⇒n%m≡n; n%m<m; n%n≡0; 0%m≡0; 1%m≡1; [m+kn]%n≡m%n)
open import AKS.Nat.GCD using (+ʳ; +ˡ)
open import AKS.Modular.Quotient.Base using (ℤ/[_]; ℤ✓; mod; mod<p; module Operations)
open Operations {P} using ([_]; _+_; _*_; -_; _⁻¹; _/_; _≟_; p≢0; ℤ/[]-irrelevance; n≢0⇒mod[n]≢0)

open import Algebra.Structures {A = ℤ/[ P ]} _≡_ using
  ( IsCommutativeRing; IsRing; IsAbelianGroup
  ; IsGroup; IsMonoid; IsSemigroup; IsMagma
  )
open import Algebra.Definitions {A = ℤ/[ P ]} _≡_ using
  ( _DistributesOver_; _DistributesOverʳ_; _DistributesOverˡ_
  ; RightIdentity; LeftIdentity; Identity; Associative; Commutative
  ; RightInverse; LeftInverse; Inverse
  )
open import AKS.Algebra.Structures (ℤ/[ P ]) _≡_ using (IsNonZeroCommutativeRing; IsIntegralDomain; IsGCDDomain; IsDecField)
open import Algebra.Bundles using (Ring; CommutativeRing)
open import AKS.Algebra.Bundles using (NonZeroCommutativeRing; DecField)

open import AKS.Unsafe using (≢-irrelevant)

+-isMagma : IsMagma _+_
+-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong = cong₂ _+_
  }

mod≡mod%p : ∀ (x : ℤ/[ P ]) → mod x ≡ (mod x % p) {p≢0}
mod≡mod%p (ℤ✓ x x<p) = sym (n<m⇒n%m≡n x<p)

mod≡mod%p%p : ∀ (x : ℤ/[ P ]) → mod x ≡ ((mod x % p) {p≢0} % p) {p≢0}
mod≡mod%p%p x = begin
  mod x         ≡⟨ mod≡mod%p x ⟩
  mod x % p     ≡⟨ sym (m%n%n≡m%n (mod x) p) ⟩
  mod x % p % p ∎

+-assoc : Associative _+_
+-assoc x y z = ℤ/[]-irrelevance $ begin
  ((mod x +ℕ mod y) % p +ℕ mod z) % p             ≡⟨ cong₂ (λ a b → (a +ℕ b) % p) (%-distribˡ-+ (mod x) (mod y) p {p≢0}) (mod≡mod%p z) ⟩
  ((mod x % p +ℕ mod y % p) % p +ℕ mod z % p) % p ≡⟨ sym (%-distribˡ-+ (mod x % p +ℕ mod y % p) (mod z) p) ⟩
  ((mod x % p +ℕ mod y % p) +ℕ mod z) % p         ≡⟨ cong (λ a → (a % p) {p≢0}) (Nat.+-assoc (mod x % p) (mod y % p) (mod z)) ⟩
  (mod x % p +ℕ (mod y % p +ℕ mod z)) % p         ≡⟨ %-distribˡ-+ (mod x % p) (mod y % p +ℕ mod z) p ⟩
  (mod x % p % p +ℕ (mod y % p +ℕ mod z) % p) % p ≡⟨ cong₂ (λ a b → (a +ℕ (b +ℕ mod z) % p) % p) (sym (mod≡mod%p%p x)) (sym (mod≡mod%p y)) ⟩
  (mod x +ℕ (mod y +ℕ mod z) % p) % p ∎

+-isSemigroup : IsSemigroup _+_
+-isSemigroup = record
  { isMagma = +-isMagma
  ; assoc = +-assoc
  }

+-comm : Commutative _+_
+-comm x y = ℤ/[]-irrelevance $ begin
  (mod x +ℕ mod y) % p ≡⟨ cong (λ a → (a % p) {p≢0}) (Nat.+-comm (mod x) (mod y)) ⟩
  (mod y +ℕ mod x) % p ∎

+-identityˡ : LeftIdentity 0 _+_
+-identityˡ x = ℤ/[]-irrelevance $ begin
  (0 % p +ℕ mod x) % p     ≡⟨ cong (λ a → (0 % p +ℕ a) % p) (mod≡mod%p x) ⟩
  (0 % p +ℕ mod x % p) % p ≡⟨ sym (%-distribˡ-+ 0 (mod x) p) ⟩
  (0 +ℕ mod x) % p         ≡⟨ sym (mod≡mod%p x) ⟩
  mod x                    ∎

open import Algebra.FunctionProperties.Consequences.Propositional using (comm+idˡ⇒idʳ; comm+invˡ⇒invʳ; comm+distrˡ⇒distrʳ)

+-identityʳ : RightIdentity 0 _+_
+-identityʳ = comm+idˡ⇒idʳ +-comm {0} +-identityˡ

+-identity : Identity 0 _+_
+-identity = +-identityˡ , +-identityʳ

+-isMonoid : IsMonoid _+_ 0
+-isMonoid = record
  { isSemigroup = +-isSemigroup
  ; identity = +-identity
  }

-‿inverseˡ : LeftInverse 0 -_ _+_
-‿inverseˡ (ℤ✓ zero x<p) = refl
-‿inverseˡ (ℤ✓ (suc x) x<p) = ℤ/[]-irrelevance $ begin
  ((p ∸ suc x) +ℕ suc x) % p ≡⟨ cong (λ a → (a % p) {p≢0}) ([n∸m]+m≡n (<⇒≤ x<p)) ⟩
  p % p ≡⟨ n%n≡0 p ⟩
  0     ≡⟨ sym (0%m≡0 p {p≢0}) ⟩
  0 % p ∎

-‿inverseʳ : RightInverse 0 -_ _+_
-‿inverseʳ = comm+invˡ⇒invʳ {_⁻¹ = -_} +-comm -‿inverseˡ

-‿inverse : Inverse 0 -_ _+_
-‿inverse = -‿inverseˡ , -‿inverseʳ

+-isGroup : IsGroup _+_ 0 -_
+-isGroup = record
  { isMonoid = +-isMonoid
  ; inverse = -‿inverse
  ; ⁻¹-cong = cong -_
  }

+-isAbelianGroup : IsAbelianGroup _+_ 0 -_
+-isAbelianGroup = record
  { isGroup = +-isGroup
  ; comm = +-comm
  }

*-isMagma : IsMagma _*_
*-isMagma = record
  { isEquivalence = isEquivalence
  ; ∙-cong = cong₂ _*_
  }

*-assoc : Associative _*_
*-assoc x y z = ℤ/[]-irrelevance $ begin
  ((mod x *ℕ mod y) % p *ℕ mod z) % p                   ≡⟨ cong₂ (λ a b → (a *ℕ b) % p) (%-distribˡ-* (mod x) (mod y) p {p≢0}) (mod≡mod%p z) ⟩
  (((mod x % p) *ℕ (mod y % p)) % p *ℕ (mod z % p)) % p ≡⟨ sym (%-distribˡ-* ((mod x % p) *ℕ (mod y % p)) (mod z) p) ⟩
  (((mod x % p) *ℕ (mod y % p)) *ℕ mod z) % p           ≡⟨ cong (λ a → (a % p) {p≢0}) (Nat.*-assoc (mod x % p) (mod y % p) (mod z)) ⟩
  ((mod x % p) *ℕ ((mod y % p) *ℕ mod z)) % p           ≡⟨ %-distribˡ-* (mod x % p) ((mod y % p) *ℕ mod z) p ⟩
  ((mod x % p % p) *ℕ (((mod y % p) *ℕ mod z) % p)) % p ≡⟨ cong₂ (λ a b → (a *ℕ ((b *ℕ mod z) % p)) % p) (sym (mod≡mod%p%p x)) (sym (mod≡mod%p y)) ⟩
  (mod x *ℕ ((mod y *ℕ mod z) % p)) % p ∎

*-isSemigroup : IsSemigroup _*_
*-isSemigroup = record
  { isMagma = *-isMagma
  ; assoc = *-assoc
  }

*-comm : Commutative _*_
*-comm x y = ℤ/[]-irrelevance $ begin
  (mod x *ℕ mod y) % p ≡⟨ cong (λ a → (a % p) {p≢0}) (Nat.*-comm (mod x) (mod y)) ⟩
  (mod y *ℕ mod x) % p ∎

*-identityˡ : LeftIdentity 1 _*_
*-identityˡ x = ℤ/[]-irrelevance $ begin
  (1 % p *ℕ mod x) % p ≡⟨ cong (λ a → ((a *ℕ mod x) % p) {p≢0}) (1%m≡1 1<p) ⟩
  (1 *ℕ mod x) % p     ≡⟨ cong (λ a → a % p) (Nat.*-identityˡ (mod x)) ⟩
  mod x % p            ≡⟨ sym (mod≡mod%p x) ⟩
  mod x                ∎

*-identityʳ : RightIdentity 1 _*_
*-identityʳ = comm+idˡ⇒idʳ *-comm {1} *-identityˡ

*-identity : Identity 1 _*_
*-identity = *-identityˡ , *-identityʳ

*-isMonoid : IsMonoid _*_ 1
*-isMonoid = record
  { isSemigroup = *-isSemigroup
  ; identity = *-identity
  }

*-distribˡ-+ : _*_ DistributesOverˡ _+_
*-distribˡ-+ r x y = ℤ/[]-irrelevance $ begin
  (mod r *ℕ ((mod x +ℕ mod y) % p)) % p              ≡⟨ cong (λ a → (a *ℕ ((mod x +ℕ mod y) % p)) % p) (mod≡mod%p r) ⟩
  (mod r % p *ℕ ((mod x +ℕ mod y) % p)) % p          ≡⟨ sym (%-distribˡ-* (mod r) (mod x +ℕ mod y) p) ⟩
  (mod r *ℕ (mod x +ℕ mod y)) % p                    ≡⟨ cong (λ a → (a % p) {p≢0}) (Nat.*-distribˡ-+ (mod r) (mod x) (mod y)) ⟩
  (mod r *ℕ mod x +ℕ mod r *ℕ mod y) % p             ≡⟨ %-distribˡ-+ (mod r *ℕ mod x) (mod r *ℕ mod y) p ⟩
  ((mod r *ℕ mod x) % p +ℕ (mod r *ℕ mod y) % p) % p ∎

*-distribʳ-+ : _*_ DistributesOverʳ _+_
*-distribʳ-+ = comm+distrˡ⇒distrʳ {_} {_} {_*_} {_+_} *-comm *-distribˡ-+

*-distrib-+ : _*_ DistributesOver _+_
*-distrib-+ = *-distribˡ-+ , *-distribʳ-+

+-*-isRing : IsRing _+_ _*_ -_ 0 1
+-*-isRing = record
  { +-isAbelianGroup = +-isAbelianGroup
  ; *-isMonoid = *-isMonoid
  ; distrib = *-distrib-+
  }

+-*-isCommutativeRing : IsCommutativeRing _+_ _*_ -_ 0 1
+-*-isCommutativeRing = record
  { isRing = +-*-isRing
  ; *-comm = *-comm
  }

open import Data.Empty using (⊥)

0≢1 : [ 0 ] ≢ [ 1 ]
0≢1 [0]≡[1] = false
  where
  0≡1 : zero ≡ 1
  0≡1 = begin
    0     ≡⟨ sym (0%m≡0 p {p≢0}) ⟩
    0 % p ≡⟨ cong mod [0]≡[1] ⟩
    1 % p ≡⟨ 1%m≡1 1<p ⟩
    1     ∎
  false : ⊥
  false with 0≡1
  ... | ()

+-*-isNonZeroCommutativeRing : IsNonZeroCommutativeRing _+_ _*_ -_ 0 1
+-*-isNonZeroCommutativeRing = record
  { isCommutativeRing = +-*-isCommutativeRing
  ; 0#≉1# = 0≢1
  }

+-*-nonZeroCommutativeRing : NonZeroCommutativeRing 0ℓ 0ℓ
+-*-nonZeroCommutativeRing = record { isNonZeroCommutativeRing = +-*-isNonZeroCommutativeRing }

⁻¹-inverse-lemma₁ : ∀ (n : ℤ/[ P ]) x y → 1 +ℕ x *ℕ mod n ≡ y *ℕ p → ((mod n *ℕ (p ∸ (x % p) {p≢0})) % p) {p≢0} ≡ (1 % p) {p≢0}
⁻¹-inverse-lemma₁ n x y 1+x*n≡y*p = begin
  (mod n *ℕ (p ∸ x % p)) % p                             ≡⟨ cong (λ t → (t % p) {p≢0}) (Nat.*-distribˡ-∸ (mod n) p (x % p)) ⟩
  ((1 +ℕ mod n *ℕ p) ∸ (1 +ℕ mod n *ℕ (x % p))) % p     ≡⟨ %-distribˡ-∸ (1 +ℕ mod n *ℕ p) (1 +ℕ mod n *ℕ (x % p)) p 1+n*x%p≤1+n*p ⟩
  ((1 +ℕ mod n *ℕ p) ∸ (1 +ℕ mod n *ℕ (x % p)) % p) % p ≡⟨ cong (λ t → ((1 +ℕ mod n *ℕ p) ∸ t) % p) lemma ⟩
  ((1 +ℕ mod n *ℕ p) ∸ 0) % p                           ≡⟨ [m+kn]%n≡m%n 1 (mod n) p ⟩
  1 % p                                                  ∎
  where
  lemma : ((1 +ℕ mod n *ℕ (x % p) {p≢0}) % p) {p≢0} ≡ 0
  lemma = begin
    (1 +ℕ mod n *ℕ (x % p)) % p                 ≡⟨ cong (λ t → ((1 +ℕ t *ℕ (x % p) {p≢0}) % p) {p≢0}) (mod≡mod%p n) ⟩
    (1 +ℕ (mod n % p) *ℕ (x % p)) % p           ≡⟨ %-distribˡ-+ 1 ((mod n % p) *ℕ (x % p)) p ⟩
    (1 % p +ℕ ((mod n % p) *ℕ (x % p)) % p) % p ≡⟨ cong (λ t → (1 % p +ℕ t) % p) (sym (%-distribˡ-* (mod n) x p)) ⟩
    (1 % p +ℕ (mod n *ℕ x) % p) % p             ≡⟨ sym (%-distribˡ-+ 1 (mod n *ℕ x) p) ⟩
    (1 +ℕ mod n *ℕ x) % p                       ≡⟨ cong (λ t → ((1 +ℕ t) % p) {p≢0}) (Nat.*-comm (mod n) x) ⟩
    (1 +ℕ x *ℕ mod n) % p                       ≡⟨ cong (λ t → (t % p) {p≢0}) 1+x*n≡y*p ⟩
    (y *ℕ p) % p                                ≡⟨ [m+kn]%n≡m%n 0 y p ⟩
    0 % p                                       ≡⟨ 0%m≡0 p ⟩
    0 ∎
  1+n*x%p≤1+n*p : 1 +ℕ mod n *ℕ (x % p) {p≢0} ≤ 1 +ℕ mod n *ℕ p
  1+n*x%p≤1+n*p = suc-mono-≤ (*-mono-≤ {mod n} ≤-refl (<⇒≤ (n%m<m x p)))

⁻¹-inverse-lemma₂ : ∀ (n : ℤ/[ P ]) x y → 1 +ℕ y *ℕ p ≡ x *ℕ mod n → ((mod n *ℕ (x % p) {p≢0}) % p) {p≢0} ≡ (1 % p) {p≢0}
⁻¹-inverse-lemma₂ n x y 1+y*p≡x*n = begin
  (mod n *ℕ (x % p)) % p       ≡⟨ cong (λ t → (t *ℕ (x % p)) % p) (mod≡mod%p n) ⟩
  ((mod n % p) *ℕ (x % p)) % p ≡⟨ sym (%-distribˡ-* (mod n) x p) ⟩
  (mod n *ℕ x) % p             ≡⟨ cong (λ t → (t % p) {p≢0}) (Nat.*-comm (mod n) x) ⟩
  (x *ℕ mod n) % p             ≡⟨ cong (λ t → (t % p) {p≢0}) (sym 1+y*p≡x*n) ⟩
  (1 +ℕ y *ℕ p) % p            ≡⟨ [m+kn]%n≡m%n 1 y p ⟩
  1 % p ∎

⁻¹-inverse : ∀ n {n≢0} → n * (n ⁻¹) {n≢0} ≡ 1
⁻¹-inverse n {n≢0} with bézout-prime (mod n) p (n≢0⇒mod[n]≢0 n≢0) (mod<p n) p-isPrime
... | +ʳ x y 1+x*n≡y*p = ℤ/[]-irrelevance (⁻¹-inverse-lemma₁ n x y 1+x*n≡y*p)
... | +ˡ x y 1+y*p≡x*n = ℤ/[]-irrelevance (⁻¹-inverse-lemma₂ n x y 1+y*p≡x*n)

/-inverse : ∀ x y {y≢0} → x ≡ y * (x / y) {y≢0}
/-inverse x y {y≢0} = begin
  x                      ≡⟨ sym (*-identityʳ x) ⟩
  x * 1                  ≡⟨ cong (λ a → x * a) (sym (⁻¹-inverse y {y≢0})) ⟩
  x * (y * (y ⁻¹) {y≢0}) ≡⟨ sym (*-assoc x y ((y ⁻¹) {y≢0})) ⟩
  (x * y) * (y ⁻¹) {y≢0} ≡⟨ cong (λ a → a * (y ⁻¹) {y≢0}) (*-comm x y) ⟩
  (y * x) * (y ⁻¹) {y≢0} ≡⟨ *-assoc y x ((y ⁻¹) {y≢0}) ⟩
  y * (x / y) {y≢0} ∎

open import AKS.Algebra.Consequences +-*-nonZeroCommutativeRing using (module Inverse⇒Field)

open Inverse⇒Field _≟_ ≡-irrelevant ≢-irrelevant _/_ /-inverse
  using (gcd)
  renaming (isField to +-*-/-isField; [field] to +-*-/-field) public

+-*-/-isDecField : IsDecField _≟_ _+_ _*_ -_ 0 1 _/_ gcd
+-*-/-isDecField = record { isField = +-*-/-isField }

+-*-/-decField : DecField 0ℓ 0ℓ
+-*-/-decField = record { isDecField = +-*-/-isDecField }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Comonads
------------------------------------------------------------------------

-- Note that currently the monad laws are not included here.

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

module Category.Comonad where

open import Level
open import Function

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

record RawComonad (W : Set f → Set f) : Set (suc f) where

  infixl 1 _=>>_ _=>=_
  infixr 1 _<<=_ _=<=_

  field
    extract : W A → A
    extend  : (W A → B) → (W A → W B)

  duplicate : W A → W (W A)
  duplicate = extend id

  liftW : (A → B) → W A → W B
  liftW f = extend (f ∘′ extract)

  _=>>_ : W A → (W A → B) → W B
  _=>>_ = flip extend

  _=>=_ : (W A → B) → (W B → C) → W A → C
  f =>= g = g ∘′ extend f

  _<<=_ : (W A → B) → W A → W B
  _<<=_ = extend

  _=<=_ : (W B → C) → (W A → B) → W A → C
  _=<=_ = flip _=>=_


{-# OPTIONS --without-K #-}
open import HoTT.Base
open import HoTT.Equivalence
open import HoTT.Equivalence.Lift
open import HoTT.Identity.Sigma
open import HoTT.Identity.Universe
open import HoTT.HLevel
open import HoTT.Logic

module HoTT.Exercises.Chapter3.Exercise10 {i} where

postulate
  lem : LEM {lsuc i}

_ : Prop𝒰 i ≃ Prop𝒰 (lsuc i)
_ = f , qinv→isequiv (g , η , ε)
  where
  f : _
  f P = LiftProp P
  g : _
  g P with lem P
  ... | inl _ = ⊤
  ... | inr _ = ⊥
  η : g ∘ f ~ id
  η P with lem (f P)
  ... | inl t = hlevel⁼ (ua (prop-equiv (const (lower t)) (const ★)))
  ... | inr f = hlevel⁼ (ua (prop-equiv 𝟎-rec (𝟎-rec ∘ f ∘ lift)))
  ε : f ∘ g ~ id
  ε P with lem P
  ... | inl t = hlevel⁼ (ua (Lift-equiv ∙ₑ prop-equiv (const t) (const ★)))
  ... | inr f = hlevel⁼ (ua (Lift-equiv ∙ₑ prop-equiv 𝟎-rec (𝟎-rec ∘ f)))


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

-- See README.Integer for examples of how to use this solver

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

module Data.Integer.Solver where

import Algebra.Solver.Ring.Simple as Solver
import Algebra.Solver.Ring.AlmostCommutativeRing as ACR
open import Data.Integer using (_≟_)
open import Data.Integer.Properties using (+-*-commutativeRing)

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

-- A module for automatically solving propositional equivalences
module +-*-Solver =
  Solver (ACR.fromCommutativeRing +-*-commutativeRing) _≟_


-- Andrea & Andreas, 2014-11-12
-- Pruning projected vars during solving

open import Common.Product
open import Common.Equality

postulate
  A : Set

works1 : {q1 : Set} {q2 : Set → Set} ->
       let M : Set -> Set; M = _ in {z : Set} -> q1 ≡ M (q2 z)
works1 = refl

works2 : {q1 : Set} {q2 : Set → Set} ->
       let M : Set -> Set; M = _ in q1 ≡ M (q2 A)
works2 = refl

works3 : {q : Set × Set} ->
       let M : Set -> Set; M = _ in proj₁ q ≡ M (proj₂ q)
works3 = refl

test1 : {q : Set × (Set → Set)} ->
       let M : Set -> Set; M = _ in {z : Set} -> proj₁ q ≡ M (proj₂ q z)
test1 = refl

test2 : {q : Set × (Set → Set)} ->
       let M : Set -> Set; M = _ in proj₁ q ≡ M (proj₂ q A)
test2 = refl

-- these tests should succeed, as expanding q into a pair gets us back to
-- works1 and works2


{-# OPTIONS --without-K  #-}
module algebra where

open import algebra.semigroup public
open import algebra.monoid public
open import algebra.group public


------------------------------------------------------------------------
-- Bounded vectors (inefficient, concrete implementation)
------------------------------------------------------------------------

-- Vectors of a specified maximum length.

module Data.BoundedVec.Inefficient where

open import Data.Nat
open import Data.List

------------------------------------------------------------------------
-- The type

infixr 5 _∷_

data BoundedVec (a : Set) : ℕ → Set where
  []  : ∀ {n} → BoundedVec a n
  _∷_ : ∀ {n} (x : a) (xs : BoundedVec a n) → BoundedVec a (suc n)

------------------------------------------------------------------------
-- Increasing the bound

-- Note that this operation is linear in the length of the list.

↑ : ∀ {a n} → BoundedVec a n → BoundedVec a (suc n)
↑ []       = []
↑ (x ∷ xs) = x ∷ ↑ xs

------------------------------------------------------------------------
-- Conversions

fromList : ∀ {a} → (xs : List a) → BoundedVec a (length xs)
fromList []       = []
fromList (x ∷ xs) = x ∷ fromList xs

toList : ∀ {a n} → BoundedVec a n → List a
toList []       = []
toList (x ∷ xs) = x ∷ toList xs


------------------------------------------------------------------------------
-- Agda-Prop Library.
-- Properties.
------------------------------------------------------------------------------

open import Data.Nat using ( ℕ )

module Data.PropFormula.Properties ( n : ℕ ) where

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

open import Data.Bool.Base using ( Bool; false; true; not; T )
open import Data.Fin       using ( Fin ; suc; zero )

open import Data.PropFormula.Syntax n
open import Data.PropFormula.Dec n

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

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

suc-injective : ∀ {o} {m n : Fin o} → Fin.suc m ≡ Fin.suc n → m ≡ n
suc-injective refl = refl

var-injective : ∀ {x x₁} → Var x ≡ Var x₁ → x ≡ x₁
var-injective refl = refl

∧-injective₁ : ∀ {φ φ₁ ψ ψ₁} → (φ ∧ φ₁) ≡ (ψ ∧ ψ₁) → φ ≡ ψ
∧-injective₁ refl = refl

∧-injective₂ : ∀ {φ φ₁ ψ ψ₁} → (φ ∧ φ₁) ≡ (ψ ∧ ψ₁) → φ₁ ≡ ψ₁
∧-injective₂ refl = refl

∨-injective₁ : ∀ {φ φ₁ ψ ψ₁} → (φ ∨ φ₁) ≡ (ψ ∨ ψ₁) → φ ≡ ψ
∨-injective₁ refl = refl

∨-injective₂ : ∀ {φ φ₁ ψ ψ₁} → (φ ∨ φ₁) ≡ (ψ ∨ ψ₁) → φ₁ ≡ ψ₁
∨-injective₂ refl = refl

⊃-injective₁ : ∀ {φ φ₁ ψ ψ₁} → (φ ⊃ φ₁) ≡ (ψ ⊃ ψ₁) → φ ≡ ψ
⊃-injective₁ refl = refl

⊃-injective₂ : ∀ {φ φ₁ ψ ψ₁} → (φ ⊃ φ₁) ≡ (ψ ⊃ ψ₁) → φ₁ ≡ ψ₁
⊃-injective₂ refl = refl

⇔-injective₁ : ∀ {φ φ₁ ψ ψ₁} → (φ ⇔ φ₁) ≡ (ψ ⇔ ψ₁) → φ ≡ ψ
⇔-injective₁ refl = refl

⇔-injective₂ : ∀ {φ φ₁ ψ ψ₁} → (φ ⇔ φ₁) ≡ (ψ ⇔ ψ₁) → φ₁ ≡ ψ₁
⇔-injective₂ refl = refl

¬-injective : ∀ {φ ψ} → ¬ φ ≡ ¬ ψ → φ ≡ ψ
¬-injective refl = refl

-- Def.
_≟_ : {n : ℕ} → Decidable {A = Fin n} _≡_
zero  ≟ zero  = yes refl
zero  ≟ suc y = no λ()
suc x ≟ zero  = no λ()
suc x ≟ suc y with x ≟ y
... | yes x≡y = yes (cong Fin.suc x≡y)
... | no  x≢y = no (λ r → x≢y (suc-injective r))

-- Def.
eq : (φ ψ : PropFormula) → Dec (φ ≡ ψ)

-- Equality with Var.
eq (Var x) ⊤        = no λ()
eq (Var x) ⊥        = no λ()
eq (Var x) (ψ ∧ ψ₁) = no λ()
eq (Var x) (ψ ∨ ψ₁) = no λ()
eq (Var x) (ψ ⊃ ψ₁) = no λ()
eq (Var x) (ψ ⇔ ψ₁) = no λ()
eq (Var x) (¬ ψ)    = no λ()
eq (Var x) (Var x₁) with x ≟ x₁
... | yes refl = yes refl
... | no x≢x₁  = no (λ r → x≢x₁ (var-injective r))

-- Equality with ⊤.
eq ⊤ (Var x)        = no λ()
eq ⊤ ⊥              = no λ()
eq ⊤ (ψ ∧ ψ₁)       = no λ()
eq ⊤ (ψ ∨ ψ₁)       = no λ()
eq ⊤ (ψ ⊃ ψ₁)       = no λ()
eq ⊤ (ψ ⇔ ψ₁)      = no λ()
eq ⊤ (¬ ψ)          = no λ()
eq ⊤ ⊤              = yes refl

-- Equality with ⊥.
eq ⊥ (Var x)        = no λ()
eq ⊥ ⊤              = no λ()
eq ⊥ (ψ ∧ ψ₁)       = no λ()
eq ⊥ (ψ ∨ ψ₁)       = no λ()
eq ⊥ (ψ ⊃ ψ₁)       = no λ()
eq ⊥ (ψ ⇔ ψ₁)       = no λ()
eq ⊥ (¬ ψ)          = no λ()
eq ⊥ ⊥              = yes refl

-- Equality with ∧.
eq (φ ∧ φ₁) (Var x)  = no λ()
eq (φ ∧ φ₁) ⊤        = no λ()
eq (φ ∧ φ₁) ⊥        = no λ()
eq (φ ∧ φ₁) (ψ ∨ ψ₁) = no λ()
eq (φ ∧ φ₁) (ψ ⊃ ψ₁) = no λ()
eq (φ ∧ φ₁) (ψ ⇔ ψ₁) = no λ()
eq (φ ∧ φ₁) (¬ ψ)    = no λ()
eq (φ ∧ φ₁) (ψ ∧ ψ₁) with eq φ ψ | eq φ₁ ψ₁
... | yes refl | yes refl = yes refl
... | yes _    | no φ₁≢ψ₁ = no (λ r → φ₁≢ψ₁ (∧-injective₂ r))
... | no φ≢ψ   | _        = no (λ r → φ≢ψ   (∧-injective₁ r))

-- Equality with ∨.
eq (φ ∨ φ₁) (Var x)  = no λ()
eq (φ ∨ φ₁) ⊤        = no λ()
eq (φ ∨ φ₁) ⊥        = no λ()
eq (φ ∨ φ₁) (ψ ∧ ψ₁) = no λ()
eq (φ ∨ φ₁) (ψ ⊃ ψ₁) = no λ()
eq (φ ∨ φ₁) (ψ ⇔ ψ₁) = no λ()
eq (φ ∨ φ₁) (¬ ψ)    = no λ()
eq (φ ∨ φ₁) (ψ ∨ ψ₁) with eq φ ψ | eq φ₁ ψ₁
... | yes refl | yes refl  = yes refl
... | yes _    | no  φ₁≢ψ₁ = no (λ r → φ₁≢ψ₁ (∨-injective₂ r))
... | no φ≢ψ   | _         = no (λ r → φ≢ψ   (∨-injective₁ r))

-- Equality with ⊃.
eq (φ ⊃ φ₁) (Var x)  = no λ()
eq (φ ⊃ φ₁) ⊤        = no λ()
eq (φ ⊃ φ₁) ⊥        = no λ()
eq (φ ⊃ φ₁) (ψ ∧ ψ₁) = no λ()
eq (φ ⊃ φ₁) (ψ ∨ ψ₁) = no λ()
eq (φ ⊃ φ₁) (ψ ⇔ ψ₁) = no λ()
eq (φ ⊃ φ₁) (¬ ψ)    = no λ()
eq (φ ⊃ φ₁) (ψ ⊃ ψ₁) with eq φ ψ | eq φ₁ ψ₁
... | yes refl | yes refl  = yes refl
... | yes _    | no  φ₁≢ψ₁ = no (λ r → φ₁≢ψ₁ (⊃-injective₂ r))
... | no φ≢ψ   | _         = no (λ r → φ≢ψ   (⊃-injective₁ r))

-- Equality with ⇔.
eq (φ ⇔ φ₁) (Var x)  = no λ()
eq (φ ⇔ φ₁) ⊤        = no λ()
eq (φ ⇔ φ₁) ⊥        = no λ()
eq (φ ⇔ φ₁) (ψ ∧ ψ₁) = no λ()
eq (φ ⇔ φ₁) (ψ ∨ ψ₁) = no λ()
eq (φ ⇔ φ₁) (ψ ⊃ ψ₁) = no λ()
eq (φ ⇔ φ₁) (¬ ψ)    = no λ()
eq (φ ⇔ φ₁) (ψ ⇔ ψ₁) with eq φ ψ | eq φ₁ ψ₁
... | yes refl | yes refl  = yes refl
... | yes _    | no  φ₁≢ψ₁ = no (λ r → φ₁≢ψ₁ (⇔-injective₂ r))
... | no φ≢ψ   | _         = no (λ r → φ≢ψ   (⇔-injective₁ r))

-- Equality with ¬.
eq (¬ φ) (Var x)  = no λ()
eq (¬ φ) ⊤        = no λ()
eq (¬ φ) ⊥        = no λ()
eq (¬ φ) (ψ ∧ ψ₁) = no λ()
eq (¬ φ) (ψ ∨ ψ₁) = no λ()
eq (¬ φ) (ψ ⊃ ψ₁) = no λ()
eq (¬ φ) (ψ ⇔ ψ₁) = no λ()
eq (¬ φ) (¬ ψ) with eq φ ψ
... | yes refl = yes refl
... | no φ≢ψ   = no (λ r → φ≢ψ (¬-injective r))

-- Theorem.
subst
  : ∀ {Γ} {φ ψ}
  → φ ≡ ψ
  → Γ ⊢ φ
  → Γ ⊢ ψ
subst refl o = o

-- Theorem.
substΓ
  : ∀ {Γ₁ Γ₂} {φ}
  → Γ₁ ≡ Γ₂
  → Γ₁ ⊢ φ
  → Γ₂ ⊢ φ
substΓ refl o = o


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

open import Base
open import Homotopy.PullbackDef

-- We only consider the universal property internally to a fixed
-- universe [Set i]. If we don’t, we would have to consider an universe
-- polymorphic [P] and I don’t want to quantify over universe polymorphic things
module Homotopy.PullbackUP {i} (d : pullback-diag i)
  (P : Set i → Set i) ⦃ PA : P (pullback-diag.A d) ⦄
  ⦃ PB : P (pullback-diag.B d) ⦄ ⦃ PC : P (pullback-diag.C d) ⦄ where

open pullback-diag d

record cone (top : Set i) : Set i where
  constructor _,_,_
  field
    top→A : top → A
    top→B : top → B
    h : (t : top) → f (top→A t) ≡ g (top→B t)

top→D : (top : Set i) → pullback-diag i
top→D top = diag (top → A), (top → B), (top → C), (λ h → f ◯ h), (λ h → g ◯ h)

pullback-to-cone : (top : Set i) → (pullback (top→D top) → cone top)
pullback-to-cone top (top→A , top→B , h) = (top→A , top→B , happly h)

cone-to-pullback : (top : Set i) → (cone top → pullback (top→D top))
cone-to-pullback top (a , b , h) = (a , b , funext h)

pullback-to-cone-equiv : (top : Set i) → is-equiv (pullback-to-cone top)
pullback-to-cone-equiv top = iso-is-eq _ (cone-to-pullback top)
  (λ y → ap (λ u → _ , _ , u) (happly-funext _))
  (λ x → ap (λ u → _ , _ , u) (funext-happly _))

cone-to-pullback-equiv : (top : Set i) → is-equiv (cone-to-pullback top)
cone-to-pullback-equiv top = iso-is-eq _ (pullback-to-cone top)
  (λ x → ap (λ u → _ , _ , u) (funext-happly _))
  (λ y → ap (λ u → _ , _ , u) (happly-funext _))

compose-cone-map : (D E : Set i) (Dcone : cone D)
  → ((f : E → D) → cone E)
compose-cone-map D E (top→A , top→B , h) f =
  ((top→A ◯ f) , (top→B ◯ f) , λ x → h (f x))

is-pullback : (D : Set i) ⦃ PD : P D ⦄ (Dcone : cone D) → Set _
is-pullback D Dcone = (E : Set i) ⦃ PE : P E ⦄
                        → is-equiv (compose-cone-map D E Dcone)


module Cats.Ditrans where

open import Level using (Level ; _⊔_)

open import Cats.Category
open import Cats.Category.Setoids using (Setoids)
open import Cats.Profunctor

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

  private
    module C = Category C
    open Category D

  record Ditrans (F G : Profunctor C C D) : Set (lo ⊔ la ⊔ la′ ⊔ l≈′)
    where
    field
      dicomponent : ∀ c → pobj F c c ⇒ pobj G c c
      dinatural : ∀ {a b} (f : a C.⇒ b)
        → pmap₂ G f ∘ dicomponent a ∘ pmap₁ F f
        ≈ pmap₁ G f ∘ dicomponent b ∘ pmap₂ F f