-- Copyright:  (c) 2016 Ertugrul Söylemez
-- License:    BSD3
-- Maintainer: Ertugrul Söylemez <esz@posteo.de>

module Data.Mod where

open import Core
open import Data.Int.Core hiding (module Props)
import Data.Int.Core as ℤ
open import Data.Nat.Core using (ℕ)
import Data.Nat.Core as ℕ

private module ℤP = ℤ.Props

ModEq : ℕ → Equiv ℤ
ModEq n =
  record {
    _≈_ = _≈_;
    refl = λ {x} → 0 , ℤP.+-right-inv x;
    sym = λ {x} {y} → sym' x y;
    trans = λ {x} {y} {z} → trans' x y z
  }

  where
  infix 4 _≈_

  _≈_ : ℤ → ℤ → Set
  x ≈ y = ∃ (λ k → x - y ≡ k * pos n)

  sym' : ∀ x y → x ≈ y → y ≈ x
  sym' x y (k , p) =
    neg k ,
    (begin
      y - x           || sym (ℤP.neg-flip x y) ::
      neg (x - y)     || cong neg p ::
      neg (k * pos n) || sym (ℤP.*-assoc -1 k (pos n)) ::
      neg k * pos n
    qed)

    where
    open Equiv (PropEq ℤ)

  trans' : ∀ x y z → x ≈ y → y ≈ z → x ≈ z
  trans' x y z (k1 , p1) (k2 , p2) =
    k1 + k2 ,
    (begin
      x - z                   || cong (x +_) (sym (ℤP.+-left-id (neg z))) ::
      x + (0 - z)             || cong (λ a → x + (a - z)) (sym (ℤP.+-left-inv y)) ::
      x + (neg y + y - z)     || cong (x +_) (ℤP.+-assoc (neg y) y (neg z)) ::
      x + (neg y + (y - z))   || sym (ℤP.+-assoc x (neg y) (y + neg z)) ::
      x + neg y + (y - z)     || cong2 _+_ p1 p2 ::
      k1 * pos n + k2 * pos n || sym (ℤP.*-+-right-dist k1 k2 (pos n)) ::
      (k1 + k2) * pos n
    qed)

    where
    open Equiv (PropEq ℤ)

module Props (n : ℕ) where
  open Equiv (ModEq n) using (_≈_)
  open Equiv (PropEq ℤ) hiding (_≈_)

  +-cong : ∀ {x1 x2 y1 y2} → x1 ≈ x2 → y1 ≈ y2 → x1 + y1 ≈ x2 + y2
  +-cong {x1} {x2} {y1} {y2} (k1 , p1) (k2 , p2) =
    k1 + k2 ,
    (begin
      x1 + y1 - (x2 + y2)   || ℤP.+-assoc x1 y1 _ ::
      x1 + (y1 - (x2 + y2)) ||
      cong (x1 +_) (
        y1 - (x2 + y2)         || cong (y1 +_) (ℤP.*-+-left-dist -1 x2 y2) ::
        y1 + (neg x2 + neg y2) || sym (ℤP.+-assoc y1 (neg x2) (neg y2)) ::
        (y1 + neg x2 + neg y2) || cong (_+ neg y2) (ℤP.+-comm y1 (neg x2)) ::
        neg x2 + y1 + neg y2   || ℤP.+-assoc (neg x2) y1 _ ::
        neg x2 + (y1 + neg y2)
      qed) ::
      x1 + (neg x2 + (y1 + neg y2)) || sym (ℤP.+-assoc x1 (neg x2) _) ::
      x1 - x2 + (y1 - y2)           || cong2 _+_ p1 p2 ::
      k1 * pos n + k2 * pos n       || sym (ℤP.*-+-right-dist k1 k2 (pos n)) ::
      (k1 + k2) * pos n
    qed)


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

open import HoTT
open import homotopy.PushoutSplit

module cw.cohomology.CofiberGrid {i j k}
  {A : Type i} {B : Type j} {C : Type k}
  (f : A → B) (g : B → C) where

  {-
    A -------> B -----------> C
    |          |           _/|
    |          |         _/  |
    |          |     __.D_   |
    v          v .--'   | `-.v
    1 ------> B/A ------|-> C/A
               |        |    |
               |        v    |
               |     __.E_   |
               v .--'     `-.v
               1 ---------> C/B
  -}

  open import cw.cohomology.GridMap f g

  private
    B-to-B/A : B → B/A
    B-to-B/A = cfcod' f

    D-span : Span
    D-span = span B/A C B B-to-B/A g
    D : Type (lmax i (lmax j k))
    D = Pushout D-span

  private
    module VSplit = PushoutRSplit (λ _ → tt) f g
    module C/AToD = VSplit.Split
  C/A-to-D : C/A → D
  C/A-to-D = C/AToD.f

  B/A-to-D : B/A → D
  B/A-to-D = left

  private
    E : Type (lmax i (lmax j k))
    E = Cofiber B/A-to-D

  private
    module HSplit = PushoutLSplit B-to-B/A (λ _ → tt) g
    module C/BToE = HSplit.Split
  C/B-to-E : C/B → E
  C/B-to-E = C/BToE.f

  private
    module DToC/B = HSplit.Inner
    D-to-C/B : D → C/B
    D-to-C/B = DToC/B.f

    D-to-E : D → E
    D-to-E = cfcod

    C/A-to-D-to-C/B : ∀ c/a → D-to-C/B (C/A-to-D c/a) == C/A-to-C/B c/a
    C/A-to-D-to-C/B = Cofiber-elim
      idp
      (λ c → idp)
      (λ a → ↓-='-in' $ ! $
        ap (D-to-C/B ∘ C/A-to-D) (glue a)
          =⟨ ap-∘ D-to-C/B C/A-to-D (glue a) ⟩
        ap D-to-C/B (ap C/A-to-D (glue a))
          =⟨ C/AToD.glue-β a |in-ctx ap D-to-C/B ⟩
        ap D-to-C/B (ap left (glue a) ∙ glue (f a))
          =⟨ ap-∙ D-to-C/B (ap left (glue a)) (glue (f a)) ⟩
        ap D-to-C/B (ap left (glue a)) ∙ ap D-to-C/B (glue (f a))
          =⟨ ap2 _∙_ (∘-ap D-to-C/B left (glue a)) (DToC/B.glue-β (f a)) ⟩
        ap (λ _ → cfbase) (glue a) ∙ glue (f a)
          =⟨ ap-cst cfbase (glue a) |in-ctx _∙ glue (f a) ⟩
        glue (f a)
          =⟨ ! $ C/AToC/B.glue-β a ⟩
        ap C/A-to-C/B (glue a)
          =∎)

    D-to-C/B-to-E : ∀ d → C/B-to-E (D-to-C/B d) == D-to-E d
    D-to-C/B-to-E = HSplit.split-inner

  {- The public interface -}

  C/A-to-C/B-comm-square : CommSquare C/A-to-C/B D-to-E C/A-to-D C/B-to-E
  C/A-to-C/B-comm-square = comm-sqr λ c/a → ap C/B-to-E (! (C/A-to-D-to-C/B c/a))
                                     ∙ D-to-C/B-to-E (C/A-to-D c/a)

  B/A-to-C/A-comm-square : CommSquare B/A-to-C/A B/A-to-D (idf B/A) C/A-to-D
  B/A-to-C/A-comm-square = comm-sqr VSplit.split-inner

  C/A-to-D-is-equiv : is-equiv C/A-to-D
  C/A-to-D-is-equiv = snd VSplit.split-equiv

  C/B-to-E-is-equiv : is-equiv C/B-to-E
  C/B-to-E-is-equiv = snd HSplit.split-equiv


module proofs where

open import lambdasyntax
open import static
open import dynamic

open import Data.Empty
open import Data.Nat
open import Function
open import Data.Vec using (Vec; [])
open import Data.Bool using (Bool; true; false)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

-- label precision
data _⊑ˡ_ : (ℓ₁ ℓ₂ : Label) → Set where
    ℓ⊑✭ : ∀ {ℓ} → ℓ ⊑ˡ ✭
    ℓ⊑ℓ : ∀ {ℓ} → ℓ ⊑ˡ ℓ

_⊑ˡ?_ : ∀ (ℓ₁ ℓ₂ : Label) → Dec (ℓ₁ ⊑ˡ ℓ₂)
⊤ ⊑ˡ? ⊤ = yes ℓ⊑ℓ
⊤ ⊑ˡ? ⊥ = no (λ ())
⊤ ⊑ˡ? ✭ = yes ℓ⊑✭
⊥ ⊑ˡ? ⊤ = no (λ ())
⊥ ⊑ˡ? ⊥ = yes ℓ⊑ℓ
⊥ ⊑ˡ? ✭ = yes ℓ⊑✭
✭ ⊑ˡ? ⊤ = no (λ ())
✭ ⊑ˡ? ⊥ = no (λ ())
✭ ⊑ˡ? ✭ = yes ℓ⊑✭

-- type precision
data _⊑_ : (t₁ t₂ : GType) → Set where
    b⊑b : ∀ {ℓ₁ ℓ₂} → ℓ₁ ⊑ˡ ℓ₂ → bool ℓ₁ ⊑ bool ℓ₂
    λ⊑λ : ∀ {s₁₁ s₂₁ s₁₂ s₂₂ ℓ₁ ℓ₂} → s₁₁ ⊑ s₂₁ → s₁₂ ⊑ s₂₂ → ℓ₁ ⊑ˡ ℓ₂ → ((s₁₁ ⇒ ℓ₁) s₁₂) ⊑ ((s₂₁ ⇒ ℓ₂) s₂₂)

lem₁ : ∀ {t₁ t₂ t₃ t₄ ℓ ℓ₁} → (x : (t₁ ⇒ ℓ) t₂ ⊑ (t₃ ⇒ ℓ₁) t₄) → t₃ ⊑ t₁
lem₁ (λ⊑λ x x₁ x₂) = {!  !}

_⊑?_ : ∀ (t₁ t₂ : GType) → Dec (t₁ ⊑ t₂)
bool x ⊑? bool x₁ with x ⊑ˡ? x₁
bool x ⊑? bool x₁ | yes p = yes (b⊑b p)
bool x ⊑? bool x₁ | no ¬p = no (¬p ∘ lem)
    where lem : ∀ {ℓ₁ ℓ₂ : Label} → (bool ℓ₁ ⊑ bool ℓ₂) → ℓ₁ ⊑ˡ ℓ₂
          lem (b⊑b x) = x
bool x ⊑? (t₂ ⇒ x₁) t₃      = no (λ ())
bool x ⊑? err               = no (λ ())
(t₁ ⇒ x) t₂ ⊑? bool x₁      = no (λ ())
(t₁ ⇒ ℓ) t₂ ⊑? (t₃ ⇒ ℓ₁) t₄ with t₃ ⊑? t₁ | t₂ ⊑? t₄
(t₁ ⇒ ℓ) t₂ ⊑? (t₃ ⇒ ℓ₁) t₄ | yes p | (yes p₁) = yes {!   !}
(t₁ ⇒ ℓ) t₂ ⊑? (t₃ ⇒ ℓ₁) t₄ | yes p | (no ¬p) = no (¬p ∘ lem)
    where lem : ∀ {t₁ t₂ t₃ t₄ ℓ ℓ₁} (x : (t₁ ⇒ ℓ) t₂ ⊑ (t₃ ⇒ ℓ₁) t₄) → t₂ ⊑ t₄
          lem (λ⊑λ x x₁ x₂) = x₁
(t₁ ⇒ ℓ) t₂ ⊑? (t₃ ⇒ ℓ₁) t₄ | no ¬p | (yes p) = no {!!}
(t₁ ⇒ ℓ) t₂ ⊑? (t₃ ⇒ ℓ₁) t₄ | no ¬p | (no ¬p₁) = no (¬p ∘ {!   !})
(t₁ ⇒ x) t₂ ⊑? err          = no (λ ())
err ⊑? bool x               = no (λ ())
err ⊑? (t₂ ⇒ x) t₃          = no (λ ())
err ⊑? err                  = no (λ ())


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma
open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.Semigroup

open GroupStr
open IsGroup hiding (rid ; lid ; invr ; invl)
open IsMonoid hiding (rid ; lid)
open IsSemigroup

DirProd : ∀ {ℓ ℓ'} → Group ℓ → Group ℓ' → Group (ℓ-max ℓ ℓ')
fst (DirProd G H) = fst G × fst H
1g (snd (DirProd G H)) = (1g (snd G)) , (1g (snd H))
_·_ (snd (DirProd G H)) x y = _·_ (snd G) (fst x) (fst y)
                            , _·_ (snd H) (snd x) (snd y)
(inv (snd (DirProd G H))) x = (inv (snd G) (fst x)) , (inv (snd H) (snd x))
is-set (isSemigroup (isMonoid (isGroup (snd (DirProd G H))))) =
  isSet× (is-set (snd G)) (is-set (snd H))
assoc (isSemigroup (isMonoid (isGroup (snd (DirProd G H))))) x y z i =
  assoc (snd G) (fst x) (fst y) (fst z) i , assoc (snd H) (snd x) (snd y) (snd z) i
fst (identity (isMonoid (isGroup (snd (DirProd G H)))) x) i =
  rid (snd G) (fst x) i , rid (snd H) (snd x) i
snd (identity (isMonoid (isGroup (snd (DirProd G H)))) x) i =
  lid (snd G) (fst x) i , lid (snd H) (snd x) i
fst (inverse (isGroup (snd (DirProd G H))) x) i =
  (invr (snd G) (fst x) i) , invr (snd H) (snd x) i
snd (inverse (isGroup (snd (DirProd G H))) x) i =
  (invl (snd G) (fst x) i) , invl (snd H) (snd x) i


{-# OPTIONS --without-K #-}
open import Library
open import Basic

--------------------------------------------------------------------------------
-- Universes for a Functor
--------------------------------------------------------------------------------

record FntrLevel : Set where
  field
    C : CatLevel
    D : CatLevel

  module C = CatLevel C
  module D = CatLevel D

  Fntr : Level
  Fntr = ℓ-max C.Cat D.Cat

--------------------------------------------------------------------------------
-- Definition of a Functor
--------------------------------------------------------------------------------

module _ {ℓ : FntrLevel}    (let module ℓ = FntrLevel ℓ)
         (C : Category ℓ.C) (let module C = Category C)
           (open C using () renaming (_⇒_ to _⇒ᶜ_ ; _∘_ to _∘ᶜ_))
         (D : Category ℓ.D) (let module D = Category D)
           (open D using () renaming (_⇒_ to _⇒ᵈ_ ; _∘_ to _∘ᵈ_)) where

  record Functor : Set ℓ.Fntr where
    field
      map  : C.Obj → D.Obj
      fmap : ∀{X Y} → X ⇒ᶜ Y → (map X) ⇒ᵈ (map Y)

    field
      id   : ∀{X} → fmap (C.id X) ≡ D.id (map X)
      comp : ∀{X Y Z}{f : X ⇒ᶜ Y}{g : Y ⇒ᶜ Z}
               → fmap (g ∘ᶜ f) ≡ (fmap g) ∘ᵈ (fmap f)

--------------------------------------------------------------------------------
-- Definition of a Natural Transformation and a Natural Isomorphism
--------------------------------------------------------------------------------

module _ {ℓ : FntrLevel}     (let module ℓ = FntrLevel ℓ)
         {C : Category ℓ.C}  (let module C = Category C)
           (open C using () renaming (_⇒_ to _⇒ᶜ_ ; _∘_ to _∘ᶜ_))
         {D : Category ℓ.D}  (let module D = Category D)
           (open D using () renaming (_⇒_ to _⇒ᵈ_ ; _∘_ to _∘ᵈ_))
         (F G : Functor C D) (let module F = Functor F)
                                 (let module G = Functor G) where

  record NaturalTrans : Set ℓ.Fntr where
    field
      map    : (X : C.Obj) → (F.map X) ⇒ᵈ (G.map X)
      nat-sq : {X Y : C.Obj}{f : X ⇒ᶜ Y} →
                 (G.fmap f) ∘ᵈ (map X) ≡ (map Y) ∘ᵈ (F.fmap f)

    is-natrual-isomorphism : Set (ℓ-max ℓ.C.Obj ℓ.D.Hom)
    is-natrual-isomorphism = ∀(X : C.Obj) → D.is-isomorphism (map X)

  NaturalIso : Set ℓ.Fntr
  NaturalIso = Σ NaturalTrans NaturalTrans.is-natrual-isomorphism

--------------------------------------------------------------------------------
-- Category of Functors
--------------------------------------------------------------------------------

module _ {ℓ : FntrLevel}     (let module ℓ = FntrLevel ℓ)
         (C : Category ℓ.C) (let module C = Category C)
           (open C using () renaming (_⇒_ to _⇒ᶜ_ ; _∘_ to _∘ᶜ_))
         (D : Category ℓ.D) (let module D = Category D)
           (open D using () renaming (_⇒_ to _⇒ᵈ_ ; _∘_ to _∘ᵈ_)) where

  FntrCat : Category (record { Obj = ℓ.Fntr ; Hom = ℓ.Fntr })
  FntrCat = record { Obj   = Functor C D
                   ; _⇒_   = NaturalTrans
                   ; id    = natural-trans-id
                   ; _∘_   = vertical-comp
                   ; idl   = {!!}
                   ; idr   = {!!}
                   ; assoc = {!!} }
    where
      natural-trans-id : (F : Functor C D) → NaturalTrans F F
      natural-trans-id F = record
        { map    = λ (X : C.Obj) → D.id (F.map X)
        ; nat-sq = λ {X Y : C.Obj} {f : X ⇒ᶜ Y} →               ≡-proof
            (F.fmap f) ∘ᵈ D.id (F.map X)                        ≡⟨ D.idr       ⟩
            F.fmap f                                            ≡⟨ ≡-sym D.idl ⟩
            D.id (F.map Y) ∘ᵈ (F.fmap f)                        ≡-qed
        } where module F = Functor F

      vertical-comp : {F G H : Functor C D}
                        → NaturalTrans G H → NaturalTrans F G → NaturalTrans F H
      vertical-comp {F} {G} {H} β α = record
        { map    = λ (X : C.Obj) → (β.map X) ∘ᵈ (α.map X)
        ; nat-sq = λ {X Y : C.Obj} {f : X ⇒ᶜ Y} →           ≡-proof
            H.fmap f ∘ᵈ (β.map X ∘ᵈ α.map X)          ≡⟨ ≡-sym D.assoc ⟩
            (H.fmap f ∘ᵈ β.map X) ∘ᵈ α.map X          ≡⟨ {!!} ⟩
            (β.map Y ∘ᵈ G.fmap f) ∘ᵈ α.map X          ≡⟨ D.assoc ⟩
            β.map Y ∘ᵈ (G.fmap f ∘ᵈ α.map X)          ≡⟨ {!!} ⟩
            β.map Y ∘ᵈ (α.map Y ∘ᵈ F.fmap f)          ≡⟨ ≡-sym D.assoc ⟩
            (β.map Y ∘ᵈ α.map Y) ∘ᵈ F.fmap f            ≡-qed
        } where module F = Functor F
                module G = Functor G
                module H = Functor H
                module α = NaturalTrans α
                module β = NaturalTrans β

--------------------------------------------------------------------------------
-- Definition of Presheaf
--------------------------------------------------------------------------------

-- module _ {C : CatLevel} (open CatLevel C)
--          (C : Category C) (let module C = Category C) where
--   Presheaf : Category (record { Obj = ℓ-suc Obj ; Hom = ℓ-suc Hom })
--   Presheaf C = record { Obj = Functor C.op (Type Hom)
--                       ; _⇒_ = NaturalTrans
--                       ; id  = NaturalTrans-id
--                       ; __}


module Structure.Operator.Monoid.Invertible.Proofs where

import      Data.Tuple as Tuple
import      Lvl
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Operator
open import Structure.Operator.Monoid
open import Structure.Operator.Monoid.Invertible
open import Structure.Operator.Properties hiding (InverseOperatorₗ ; InverseOperatorᵣ)
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

private variable ℓ ℓₗ ℓₑ : Lvl.Level
private variable T : Type{ℓ}
private variable _▫_ : T → T → T
private variable _⨞_ : T → T → Type{ℓₗ}

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ ⦃ monoid : Monoid{T = T}(_▫_) ⦄ ⦃ invRel : InverseRelationᵣ(_▫_){ℓₗ}(_⨞_) ⦄ where
  open Monoid(monoid) using (id)

  instance
    inverseRelationᵣ-reflexivity : Reflexivity(_⨞_)
    Reflexivity.proof inverseRelationᵣ-reflexivity = [↔]-to-[←] (InverseRelationᵣ.proof invRel) ([∃]-intro id ⦃ identityᵣ(_▫_)(id) ⦄)

  instance
    inverseRelationᵣ-transitivity : Transitivity(_⨞_)
    Transitivity.proof inverseRelationᵣ-transitivity xy yz
      with [∃]-intro a ⦃ pa ⦄ ← [↔]-to-[→] (InverseRelationᵣ.proof invRel) xy
      with [∃]-intro b ⦃ pb ⦄ ← [↔]-to-[→] (InverseRelationᵣ.proof invRel) yz
      = [↔]-to-[←] (InverseRelationᵣ.proof invRel) ([∃]-intro (a ▫ b) ⦃ symmetry(_≡_) (associativity(_▫_)) 🝖 congruence₂ₗ(_▫_)(b) pa 🝖 pb ⦄)

  inverseRelationᵣ-with-opᵣ : ∀{a x y} → (x ⨞ y) → ((a ▫ x) ⨞ (a ▫ y))
  inverseRelationᵣ-with-opᵣ {a}{x}{y} xy
    with [∃]-intro z ⦃ xzy ⦄ ← [↔]-to-[→] (InverseRelationᵣ.proof invRel) xy
    = [↔]-to-[←] (InverseRelationᵣ.proof invRel) ([∃]-intro z ⦃ associativity(_▫_) 🝖 congruence₂ᵣ(_▫_)(a) xzy ⦄)

  inverseRelationᵣ-without-opᵣ : ⦃ cancₗ : Cancellationₗ(_▫_) ⦄ → ∀{a x y} → ((a ▫ x) ⨞ (a ▫ y)) → (x ⨞ y)
  inverseRelationᵣ-without-opᵣ {a}{x}{y} xy
    with [∃]-intro z ⦃ xzy ⦄ ← [↔]-to-[→] (InverseRelationᵣ.proof invRel) xy
    = [↔]-to-[←] (InverseRelationᵣ.proof invRel) ([∃]-intro z ⦃ cancellationₗ(_▫_) (symmetry(_≡_) (associativity(_▫_)) 🝖 xzy) ⦄)

  inverseRelationᵣ-of-idₗ : ∀{x} → (id ⨞ x)
  inverseRelationᵣ-of-idₗ {x} = [↔]-to-[←] (InverseRelationᵣ.proof invRel) ([∃]-intro x ⦃ identityₗ(_▫_)(id) ⦄)

  module _ {_⋄_ : (x : T) → (y : T) → . ⦃ inv : (y ⨞ x) ⦄ → T} ⦃ invOper : InverseOperatorᵣ(_▫_)(_⋄_) ⦄ where
    {-op-cancellationᵣ : ∀{a x y} → (a ⨞ x) → (a ⨞ y) → (a ▫ x ≡ a ▫ y) → (x ≡ y)
    op-cancellationᵣ {a}{x}{y} ax ay axay
      with [∃]-intro r ⦃ pr ⦄ ← [↔]-to-[→] (InverseRelationᵣ.proof invRel) ax
      with [∃]-intro s ⦃ ps ⦄ ← [↔]-to-[→] (InverseRelationᵣ.proof invRel) ay
      =
        x 🝖[ _≡_ ]-[ {!!} ]
        y 🝖-end-}

    inverseRelationᵣ-to-invertibleᵣ : ∀{x} → ⦃ x ⨞ id ⦄ → InvertibleElementᵣ(_▫_) ⦃ Monoid.identity-existenceᵣ(monoid) ⦄ (x)
    inverseRelationᵣ-to-invertibleᵣ {x} ⦃ xid ⦄ = [∃]-intro (id ⋄ x) ⦃ intro p ⦄ where
      p =
        (x ▫ (id ⋄ x))                                                    🝖[ _≡_ ]-[ congruence₂ᵣ(_▫_)(x) (InverseOperatorᵣ.proof invOper {id}{x}) ]
        (x ▫ [∃]-witness([↔]-to-[→] (InverseRelationᵣ.proof invRel) xid)) 🝖[ _≡_ ]-[ [∃]-proof([↔]-to-[→] (InverseRelationᵣ.proof invRel) xid) ]
        id                                                                🝖-end

    {- TODO: Should this not be possible without cancellation?
    inverseOperator-self : ∀{x} → let instance _ = reflexivity(_⨞_) in (x ⋄ x ≡ id)
    inverseOperator-self {x} = let instance _ = reflexivity(_⨞_) {x} in
      (x ⋄ x)                                                                        🝖[ _≡_ ]-[ InverseOperatorᵣ.proof invOper {x}{x} ]
      [∃]-witness([↔]-to-[→] (InverseRelationᵣ.proof invRel) (reflexivity(_⨞_) {x})) 🝖[ _≡_ ]-[]
      ∃.witness(Tuple.right(InverseRelationᵣ.proof invRel) (reflexivity(_⨞_)))       🝖[ _≡_ ]-[ {!!} ]
      id                                                                             🝖-end
    -}


module Data.Union.Relation.Binary.Subtype where

open import Data.List using (List)
open import Data.List.Relation.Unary.Any using (here; there)
open import Data.List.Relation.Binary.Subset.Propositional using (_⊆_)

open import Data.Union using (Union; here; there; inj)

open import Function using (_∘_; id)

open import Relation.Binary.PropositionalEquality using () renaming (refl to refl≡)

open import Level using (Level; _⊔_)

-- ----------------------------------------------------------------------
-- Subtyping

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

    F : A → Set f
    ts ts′ : List A

infix 4 _≼_ _,_⊢_≼_

_≼_ : Set a → Set b → Set (a ⊔ b)
A ≼ B = A → B

_,_⊢_≼_ : (A : Set a) → (F : A → Set b) → List A → List A → Set (a ⊔ b)
A , F ⊢ ts ≼ ts′ = Union A F ts ≼ Union A F ts′

refl : A ≼ A
refl = id

trans : A ≼ B → B ≼ C → A ≼ C
trans A≼B B≼C = B≼C ∘ A≼B

generalize : ts ⊆ ts′ → A , F ⊢ ts ≼ ts′
generalize ts⊆ts′ (here x) = inj (ts⊆ts′ (here refl≡)) x
generalize ts⊆ts′ (there x) = generalize (ts⊆ts′ ∘ there) x

function : C ≼ A → B ≼ D → (A → B) ≼ (C → D)
function C≼A B≼D f = B≼D ∘ f ∘ C≼A

coerce : A ≼ B → A → B
coerce = id


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

module Data.PolyP.Universe where

open import Prelude hiding (_⟨_⟩_)
open import Data.Vec.Iterated
open import Data.Fin.Indexed

--------------------------------------------------------------------------------
--
--  The Universe of functors we're interested in.
--
--------------------------------------------------------------------------------
data Functor (n : ℕ) : Type where
  !     : Fin n → Functor n
  _⊕_   : (F G : Functor n) → Functor n
  _⊗_   : (F G : Functor n) → Functor n
  μ⟨_⟩  : Functor (suc n) → Functor n
  ⓪     : Functor n
  ①     : Functor n

infixl 6 _⊕_
infixl 7 _⊗_

Params : ℕ → Type₁
Params = Vec Type

variable
  n m k : ℕ
  F G : Functor n
  As Bs : Params n

---------------------------------------------------------------------------------
--
-- Interpretation
--
---------------------------------------------------------------------------------

mutual
  ⟦_⟧ : Functor n → Params n → Type
  ⟦ ! i     ⟧ xs = xs [ i ]
  ⟦ F ⊕  G  ⟧ xs = ⟦ F ⟧ xs ⊎  ⟦ G ⟧ xs
  ⟦ F ⊗  G  ⟧ xs = ⟦ F ⟧ xs ×  ⟦ G ⟧ xs
  ⟦ μ⟨ F ⟩  ⟧ xs = μ F xs
  ⟦ ⓪       ⟧ xs = ⊥
  ⟦ ①       ⟧ xs = ⊤

  record μ (F : Functor (suc n)) (As : Params n) : Type where
    pattern; inductive; constructor ⟨_⟩
    field unwrap : ⟦ F ⟧ (μ F As ∷ As)
open μ public


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

open import Algebra.Structures.Bundles.Field

module Algebra.Linear.Structures.GL
  {k ℓᵏ} (K : Field k ℓᵏ)
  {a ℓ}
  where

open import Relation.Binary using (Setoid)
open import Algebra.Linear.Structures.Bundles
open import Algebra.Linear.Morphism.Bundles K
open import Categories.Category

open LinearMap


module lib.libraryDec where

-- old version of Dec
--

open import Data.Empty
open import Level
open import Relation.Nullary using ( ¬_ )

data Dec {p} (P : Set p) : Set p where
  yes : ( p :   P) → Dec P
  no  : (¬p :  ¬ P) → Dec P


module Prelude.Equality.Inspect where

open import Prelude.Function using (id)
open import Prelude.Equality
open import Prelude.Product

module _ {a b} {A : Set a} {B : A → Set b} (f : ∀ x → B x) (x : A) where

  -- The Graph idiom is more powerful than the old Inspect idiom
  -- (defined in terms of Graph below), in that it lets you both
  -- abstract over a term and keep the equation that the old term
  -- equals the abstracted variable.

  -- Use as follows:
  --   example : Γ → T (f e)
  --   example xs with f e | graphAt f e
  --   ... | z | ingraph eq = ?  -- eq : f e ≡ z, goal : T z

  data Graph (y : B x) : Set b where
    ingraph : f x ≡ y → Graph y

  graphAt : Graph (f x)
  graphAt = ingraph refl
  {-# INLINE graphAt #-}

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

  Inspect : A → Set a
  Inspect x = Σ _ λ y → Graph id x y

  infix 4 _with≡_
  pattern _with≡_ x eq = x , ingraph eq

  inspect : ∀ x → Inspect x
  inspect x = x , ingraph refl
  {-# INLINE inspect #-}


data A : Set where
  a : A

data T : A → Set where
  t : T a

postulate
  f : ∀ x → T x → Set

stuff : Set
stuff = f {!!} t

-- There should not be a (Checked) status for this module!


module Numeral.FixedPositional where

import      Lvl
open import Data using (<>)
open import Data.List
open import Data.Boolean hiding (elim)
open import Data.Boolean.Stmt
open import Numeral.Finite
open import Numeral.Natural
open import Functional
open import Syntax.Number
open import Type

private variable ℓ : Lvl.Level
private variable z : Bool
private variable b n : ℕ

-- A formalization of the fixed positional radix numeral system for the notation of numbers.
-- Each number is represented by a list of digits.
-- Digits are a finite set of ordered objects starting with zero (0), and a finite number of its successors.
-- Examples using radix 10 (b = 10):
--   ∅                               represents 0
--   # 0                             represents 0
--   # 0 · 0                         represents 0
--   # 2                             represents 2
--   # 1 · 3                         represents 13
--   # 5 · 0 · 4 · 0 · 0             represents 50400
--   # 0 · 5 · 0 · 4 · 0 · 0         represents 50400
--   # 0 · 0 · 0 · 5 · 0 · 4 · 0 · 0 represents 50400
--   # 5 · 0 · 4 · 0 · 0 · 0         represents 504000
-- Example using radix 2 (b = 2):
--   # 1 · 1             represents 3
--   # 0 · 1 · 0 · 1 · 1 represents 11
-- Note: The radix is also called base.
-- Note: This representation is in little endian: The deepest digit in the list is the most significant digit (greatest), and the first position of the list is the least significant digit. Note that the (_·_) operator is a reversed list cons operator, so it constructs a list from right to left when written without parenthesis.
Positional = List ∘ 𝕟
pattern # n = n ⊰ ∅
pattern _·_ a b = b ⊰ a
infixl 100 _·_

private variable x y : Positional(b)
private variable d : 𝕟(n)

-- Two positionals are equal when the sequence of digits in the lists are the same.
-- But also, when there are zeroes at the most significant positions, they should be skipped.
-- Examples:
--   # 4 · 5         ≡ₚₒₛ # 4 · 5
--   # 0 · 0 · 4 · 5 ≡ₚₒₛ # 4 · 5
--   # 4 · 5         ≡ₚₒₛ # 0 · 0 · 4 · 5
--   # 0 · 0 · 4 · 5 ≡ₚₒₛ # 0 · 4 · 5
data _≡ₚₒₛ_ : Positional b → Positional b → Type{Lvl.𝟎} where
  empty : (_≡ₚₒₛ_ {b} ∅ ∅)
  skipₗ : (x ≡ₚₒₛ ∅) → (x · 𝟎 ≡ₚₒₛ ∅)
  skipᵣ : (∅ ≡ₚₒₛ y) → (∅ ≡ₚₒₛ y · 𝟎)
  step  : (x ≡ₚₒₛ y) → (x · d ≡ₚₒₛ y · d)

module _ where
  open import Numeral.Natural.Oper

  -- Converts a positional to a number by adding the first digit and multiplying the rest with the radix.
  -- Examples in radix 10 (b = 10):
  --   to-ℕ (# 1 · 2 · 3) = 10 ⋅ (10 ⋅ (10 ⋅ 0 + 1) + 2) + 3 = ((0 + 100) + 20) + 3 = 100 + 20 + 3 = 123
  --   to-ℕ (# a · b · c) = 10 ⋅ (10 ⋅ (10 ⋅ 0 + a) + b) + c = (10² ⋅ a) + (10¹ ⋅ b) + c = (10² ⋅ a) + (10¹ ⋅ b) + (10⁰ ⋅ c)
  to-ℕ : Positional b → ℕ
  to-ℕ     ∅       = 𝟎
  to-ℕ {b} (l · n) = (b ⋅ (to-ℕ l)) + (𝕟-to-ℕ n)

  import      Data.List.Functions as List
  open import Logic.Propositional
  open import Numeral.Finite.Proofs
  open import Numeral.Natural.Inductions
  open import Numeral.Natural.Oper.Comparisons
  open import Numeral.Natural.Oper.FlooredDivision
  open import Numeral.Natural.Oper.FlooredDivision.Proofs
  open import Numeral.Natural.Oper.Modulo
  open import Numeral.Natural.Oper.Modulo.Proofs
  open import Numeral.Natural.Relation.Order
  open import Numeral.Natural.Relation.Order.Decidable
  open import Numeral.Natural.Relation.Order.Proofs
  open import Structure.Relator.Ordering
  import      Structure.Relator.Names as Names
  open import Structure.Relator.Equivalence
  open import Structure.Relator.Properties
  open import Syntax.Transitivity
  open import Type.Properties.Decidable
  open import Type.Properties.Decidable.Proofs

  -- Converts a number to its positional representation in the specified radix.
  -- This is done by extracting the next digit using modulo of the radix and then dividing the rest.
  -- This is the inverse of to-ℕ.
  from-ℕ-rec : ⦃ b-size : IsTrue(b >? 1) ⦄ → (x : ℕ) → ((prev : ℕ) ⦃ _ : prev < x ⦄ → Positional(b)) → Positional(b)
  from-ℕ-rec b@{𝐒(𝐒 _)} 𝟎       _    = ∅
  from-ℕ-rec b@{𝐒(𝐒 _)} n@(𝐒 _) prev = (prev(n ⌊/⌋ b) ⦃ [⌊/⌋]-ltₗ {n}{b} ⦄) · (ℕ-to-𝕟 (n mod b) ⦃ [↔]-to-[→] decider-true (mod-maxᵣ{n}{b}) ⦄)
  from-ℕ : ℕ → Positional(b)
  from-ℕ {0}        = const ∅
  from-ℕ {1}        = List.repeat 𝟎
  from-ℕ b@{𝐒(𝐒 _)} = Strict.Properties.wellfounded-recursion(_<_) from-ℕ-rec

  instance
    [≡ₚₒₛ]-reflexivity : Reflexivity(_≡ₚₒₛ_ {b})
    [≡ₚₒₛ]-reflexivity = intro p where
      p : Names.Reflexivity(_≡ₚₒₛ_ {b})
      p {x = ∅}     = empty
      p {x = _ ⊰ _} = _≡ₚₒₛ_.step p

  instance
    [≡ₚₒₛ]-symmetry : Symmetry(_≡ₚₒₛ_ {b})
    [≡ₚₒₛ]-symmetry = intro p where
      p : Names.Symmetry(_≡ₚₒₛ_ {b})
      p empty            = empty
      p (skipₗ eq)       = skipᵣ (p eq)
      p (skipᵣ eq)       = skipₗ (p eq)
      p (_≡ₚₒₛ_.step eq) = _≡ₚₒₛ_.step (p eq)

  instance
    [≡ₚₒₛ]-transitivity : Transitivity(_≡ₚₒₛ_ {b})
    [≡ₚₒₛ]-transitivity = intro p where
      p : Names.Transitivity(_≡ₚₒₛ_ {b})
      p empty           empty           = empty
      p empty           (skipᵣ b)       = skipᵣ b
      p (skipₗ a)       empty           = skipₗ a
      p (skipₗ a)       (skipᵣ b)       = _≡ₚₒₛ_.step (p a b)
      p (skipᵣ a)       (skipₗ b)       = p a b
      p (skipᵣ a)       (_≡ₚₒₛ_.step b) = skipᵣ (p a b)
      p (_≡ₚₒₛ_.step a) (skipₗ b)       = skipₗ (p a b)
      p (_≡ₚₒₛ_.step a) (_≡ₚₒₛ_.step b) = _≡ₚₒₛ_.step (p a b)

  instance
    [≡ₚₒₛ]-equivalence : Equivalence(_≡ₚₒₛ_ {b})
    [≡ₚₒₛ]-equivalence = intro

  open import Structure.Setoid using (Equiv ; intro)

  Positional-equiv : Equiv(Positional(b))
  Positional-equiv {b} = intro _ ⦃ [≡ₚₒₛ]-equivalence {b} ⦄

  open import Lang.Instance
  open import Numeral.Natural.Relation.Proofs
  open import Structure.Function
  open import Structure.Operator
  open import Relator.Equals
  open import Relator.Equals.Proofs

  from-ℕ-digit : ⦃ b-size : IsTrue(b >? 1) ⦄ → ⦃ _ : IsTrue(n <? b) ⦄ → (from-ℕ {b} n ≡ₚₒₛ ℕ-to-𝕟 n ⊰ ∅)
  from-ℕ-digit b@{𝐒(𝐒 bb)} {n} = Strict.Properties.wellfounded-recursion-intro(_<_) {rec = from-ℕ-rec} {φ = \{n} expr → ⦃ _ : IsTrue(n <? b) ⦄ → (expr ≡ₚₒₛ (ℕ-to-𝕟 n ⊰ ∅))} p {n} where
    p : (y : ℕ) → _ → _ → ⦃ _ : IsTrue(y <? b) ⦄ → (from-ℕ y ≡ₚₒₛ (ℕ-to-𝕟 y ⊰ ∅))
    p 𝟎 prev eq = skipᵣ empty
    p (𝐒 y) prev eq ⦃ ord ⦄ =
      from-ℕ (𝐒(y))                                                         🝖[ _≡ₚₒₛ_ ]-[ sub₂(_≡_)(_≡ₚₒₛ_) (eq{y} ⦃ reflexivity(_≤_) ⦄) ]
      from-ℕ (𝐒(y) ⌊/⌋ b) · ℕ-to-𝕟 (𝐒(y) mod b) ⦃ yb-ord? ⦄                 🝖[ _≡ₚₒₛ_ ]-[ _≡ₚₒₛ_.step (prev ⦃ [⌊/⌋]-ltₗ{𝐒 y}{b}  ⦄ ⦃ div-ord ⦄) ]
      ∅ · ℕ-to-𝕟 (𝐒(y) ⌊/⌋ b) ⦃ div-ord ⦄ · ℕ-to-𝕟 (𝐒(y) mod b) ⦃ yb-ord? ⦄ 🝖[ _≡ₚₒₛ_ ]-[ sub₂(_≡_)(_≡ₚₒₛ_) (congruence₂ᵣ(_·_)(_) (congruence-ℕ-to-𝕟 ⦃ infer ⦄ ⦃ yb-ord? ⦄ (mod-lesser-than-modulus {𝐒 y}{𝐒 bb} ⦃ yb-ord ⦄))) ]
      ∅ · ℕ-to-𝕟 (𝐒(y) ⌊/⌋ b) ⦃ div-ord ⦄ · ℕ-to-𝕟 (𝐒(y))                   🝖[ _≡ₚₒₛ_ ]-[ _≡ₚₒₛ_.step (sub₂(_≡_)(_≡ₚₒₛ_) (congruence₂ᵣ(_·_)(_) (congruence-ℕ-to-𝕟 ⦃ infer ⦄ ⦃ div-ord ⦄ ([⌊/⌋]-zero {𝐒 y}{b} yb-ord2)))) ]
      ∅ · 𝟎 · ℕ-to-𝕟 (𝐒(y))                                                 🝖[ _≡ₚₒₛ_ ]-[ _≡ₚₒₛ_.step (skipₗ empty) ]
      ∅ · ℕ-to-𝕟 (𝐒(y))                                                     🝖-end
      where
        yb-ord? = [↔]-to-[→] decider-true (mod-maxᵣ {𝐒(y)}{b} ⦃ infer ⦄)
        yb-ord = [↔]-to-[←] (decider-true ⦃ [<]-decider ⦄) ord
        yb-ord2 = [↔]-to-[←] (decider-true ⦃ [<]-decider ⦄) ord
        div-ord = [↔]-to-[→] decider-true ([⌊/⌋]-preserve-[<]ₗ {𝐒 y}{b}{b} yb-ord2)

  from-ℕ-step : ⦃ b-size : IsTrue(b >? 1) ⦄
              → let pos = [↔]-to-[←] Positive-greater-than-zero ([≤]-predecessor ([↔]-to-[←] (decider-true ⦃ [<]-decider {1}{b} ⦄) b-size))
                in (from-ℕ {b} n ≡ₚₒₛ (from-ℕ {b} ((n ⌊/⌋ b) ⦃ pos ⦄)) · (ℕ-to-𝕟 ((n mod b) ⦃ pos ⦄) ⦃ [↔]-to-[→] decider-true (mod-maxᵣ{n}{b} ⦃ pos ⦄) ⦄))
  from-ℕ-step b@{𝐒(𝐒 bb)} {n} = Strict.Properties.wellfounded-recursion-intro(_<_) {rec = from-ℕ-rec} {φ = \{n} expr → (expr ≡ₚₒₛ from-ℕ {b} (n ⌊/⌋ b) · (ℕ-to-𝕟 (n mod b) ⦃ ord n ⦄))} p {n} where
    ord = \n → [↔]-to-[→] decider-true (mod-maxᵣ{n}{b})
    p : (y : ℕ) → _ → _ → Strict.Properties.accessible-recursion(_<_) from-ℕ-rec y ≡ₚₒₛ from-ℕ (y ⌊/⌋ b) · ℕ-to-𝕟 (y mod b) ⦃ ord y ⦄
    p 𝟎     prev eq = skipᵣ empty
    p (𝐒 y) prev eq = (sub₂(_≡_)(_≡ₚₒₛ_) (eq {y} ⦃ reflexivity(_≤_) ⦄))

  open import Numeral.Natural.Oper.FlooredDivision.Proofs.Inverse
  open import Numeral.Natural.Oper.Proofs
  open import Structure.Operator.Properties
  from-ℕ-step-invs : ⦃ b-size : IsTrue(b >? 1) ⦄ → (from-ℕ {b} ((b ⋅ n) + (𝕟-to-ℕ d)) ≡ₚₒₛ (from-ℕ {b} n) · d)
  from-ℕ-step-invs b@{𝐒(𝐒 bb)} {n}{d} =
    from-ℕ (b ⋅ n + 𝕟-to-ℕ d)                                                     🝖[ _≡ₚₒₛ_ ]-[ from-ℕ-step {n = b ⋅ n + 𝕟-to-ℕ d} ]
    from-ℕ ((b ⋅ n + 𝕟-to-ℕ d) ⌊/⌋ b) · (ℕ-to-𝕟 ((b ⋅ n + 𝕟-to-ℕ d) mod b) ⦃ _ ⦄) 🝖[ _≡ₚₒₛ_ ]-[ sub₂(_≡_)(_≡ₚₒₛ_) (congruence₂(_·_) (congruence₁(from-ℕ) r) (congruence-ℕ-to-𝕟 ⦃ infer ⦄ ⦃ ord1 ⦄ ⦃ ord2 ⦄ q 🝖 ℕ-𝕟-inverse)) ]
    from-ℕ n · d                                                                  🝖-end where
      ord1 = [↔]-to-[→] decider-true (mod-maxᵣ{(b ⋅ n) + (𝕟-to-ℕ d)}{b})
      ord2 = [↔]-to-[→] decider-true ([<]-of-𝕟-to-ℕ {b}{d})
      q =
        ((b ⋅ n) + 𝕟-to-ℕ d) mod b 🝖[ _≡_ ]-[ congruence₁(_mod b) (commutativity(_+_) {b ⋅ n}{𝕟-to-ℕ d}) ]
        (𝕟-to-ℕ d + (b ⋅ n)) mod b 🝖[ _≡_ ]-[ mod-of-modulus-sum-multiple {𝕟-to-ℕ d}{b}{n} ]
        (𝕟-to-ℕ d) mod b           🝖[ _≡_ ]-[ mod-lesser-than-modulus ⦃ [≤]-without-[𝐒] [<]-of-𝕟-to-ℕ ⦄ ]
        𝕟-to-ℕ d                   🝖-end
      r =
        (b ⋅ n + 𝕟-to-ℕ d) ⌊/⌋ b             🝖[ _≡_ ]-[ [⌊/⌋][+]-distributivityᵣ {b ⋅ n}{𝕟-to-ℕ d}{b} ]
        ((b ⋅ n) ⌊/⌋ b) + ((𝕟-to-ℕ d) ⌊/⌋ b) 🝖[ _≡_ ]-[ congruence₂(_+_) ([⌊/⌋][swap⋅]-inverseOperatorᵣ {b}{n}) ([⌊/⌋]-zero ([<]-of-𝕟-to-ℕ {b}{d})) ]
        n + 𝟎                                🝖[ _≡_ ]-[]
        n                                    🝖-end

  open import Numeral.Natural.Oper.DivMod.Proofs
  open import Structure.Function.Domain
  import      Structure.Function.Names as Names

  instance
    from-to-inverse : ⦃ b-size : IsTrue(b >? 1) ⦄ → Inverseᵣ ⦃ Positional-equiv{b} ⦄ from-ℕ to-ℕ
    from-to-inverse b@{𝐒(𝐒 _)} = intro p where
      p : Names.Inverses ⦃ Positional-equiv{b} ⦄ from-ℕ to-ℕ
      p{x = ∅}     = empty
      p{x = x · n} = from-ℕ-step-invs{b}{to-ℕ x}{n} 🝖 _≡ₚₒₛ_.step (p{x = x})

  instance
    to-from-inverse : ⦃ b-size : IsTrue(b >? 1) ⦄ → Inverseᵣ(to-ℕ{b}) (from-ℕ{b})
    to-from-inverse {b@(𝐒(𝐒 bb))} = intro (\{n} → Strict.Properties.wellfounded-recursion-intro(_<_) {rec = from-ℕ-rec {b}} {φ = \{n} expr → (to-ℕ expr ≡ n)} p {n}) where
      p : (y : ℕ) → _ → _ → (to-ℕ {b} (from-ℕ {b} y) ≡ y)
      p 𝟎     _    _  = [≡]-intro
      p (𝐒 y) prev eq =
        to-ℕ {b} (from-ℕ (𝐒 y))                                                       🝖[ _≡_ ]-[ congruence₁(to-ℕ) (eq {𝐒(y) ⌊/⌋ b} ⦃ ord2 ⦄) ]
        to-ℕ {b} ((from-ℕ (𝐒(y) ⌊/⌋ b)) · (ℕ-to-𝕟 (𝐒(y) mod b) ⦃ _ ⦄))                🝖[ _≡_ ]-[]
        (b ⋅ to-ℕ {b} (from-ℕ {b} (𝐒(y) ⌊/⌋ b))) + 𝕟-to-ℕ (ℕ-to-𝕟 (𝐒(y) mod b) ⦃ _ ⦄) 🝖[ _≡_ ]-[ congruence₂(_+_) (congruence₂ᵣ(_⋅_)(b) (prev{𝐒(y) ⌊/⌋ b} ⦃ ord2 ⦄)) (𝕟-ℕ-inverse {b}{𝐒(y) mod b} ⦃ ord1 ⦄) ]
        (b ⋅ (𝐒(y) ⌊/⌋ b)) + (𝐒(y) mod b)                                             🝖[ _≡_ ]-[ [⌊/⌋][mod]-is-division-with-remainder-pred-commuted {𝐒 y}{b} ]
        𝐒(y)                                                                          🝖-end
        where
          ord1 = [↔]-to-[→] decider-true (mod-maxᵣ{𝐒(y)}{b})
          ord2 = [⌊/⌋]-ltₗ {𝐒 y}{b}

  instance
    to-ℕ-function : ⦃ b-size : IsTrue(b >? 1) ⦄ → Function ⦃ Positional-equiv ⦄ ⦃ [≡]-equiv ⦄ (to-ℕ {b})
    to-ℕ-function {b} = intro p where
      p : Names.Congruence₁ ⦃ Positional-equiv ⦄ ⦃ [≡]-equiv ⦄ (to-ℕ {b})
      p empty                          = reflexivity(_≡_)
      p (skipₗ xy) rewrite p xy        = reflexivity(_≡_)
      p (skipᵣ {y = ∅} xy)             = reflexivity(_≡_)
      p (skipᵣ {y = 𝟎 ⊰ y} (skipᵣ xy))
        rewrite symmetry(_≡_) (p xy)   = reflexivity(_≡_)
      p (_≡ₚₒₛ_.step xy)
        rewrite p xy = reflexivity(_≡_)

  open import Logic.Predicate
  open import Structure.Function.Domain.Proofs

  instance
    from-ℕ-bijective : ⦃ b-size : IsTrue(b >? 1) ⦄ → Bijective ⦃ [≡]-equiv ⦄ ⦃ Positional-equiv ⦄ (from-ℕ {b})
    from-ℕ-bijective = [↔]-to-[→] (invertible-when-bijective ⦃ _ ⦄ ⦃ _ ⦄) ([∃]-intro to-ℕ ⦃ [∧]-intro infer ([∧]-intro infer infer) ⦄)

  instance
    to-ℕ-bijective : ⦃ b-size : IsTrue(b >? 1) ⦄ → Bijective ⦃ Positional-equiv ⦄ ⦃ [≡]-equiv ⦄ (to-ℕ {b})
    to-ℕ-bijective = [↔]-to-[→] (invertible-when-bijective ⦃ _ ⦄ ⦃ _ ⦄) ([∃]-intro from-ℕ ⦃ [∧]-intro ([≡]-to-function ⦃ Positional-equiv ⦄) ([∧]-intro infer infer) ⦄)

  import      Data.Option.Functions as Option
  open import Function.Names
  open import Numeral.Natural.Relation.Order.Proofs

  -- TODO: Trying to define a bijection, but not really possible because not all functions
  PositionalSequence : List(𝕟(𝐒 b)) → (ℕ → 𝕟(𝐒 b))
  PositionalSequence l n = (List.index₀ n l) Option.or 𝟎

  sequencePositional : (f : ℕ → 𝕟(𝐒 b)) → ∃(N ↦ (f ∘ (_+ N) ⊜ const 𝟎)) → List(𝕟(𝐒 b))
  sequencePositional f ([∃]-intro 𝟎)           = ∅
  sequencePositional f ([∃]-intro (𝐒 N) ⦃ p ⦄) = f(𝟎) ⊰ sequencePositional (f ∘ 𝐒) ([∃]-intro N ⦃ \{n} → p{n} ⦄)


{-# OPTIONS --universe-polymorphism #-}
module Categories.Functor.Algebras where

open import Level hiding (lift)

open import Categories.Category
open import Categories.Functor hiding (_≡_; id; _∘_; equiv; assoc; identityˡ; identityʳ; ∘-resp-≡)
open import Categories.Functor.Algebra

record F-Algebra-Morphism {o ℓ e} {C : Category o ℓ e} {F : Endofunctor C} (X Y : F-Algebra F) : Set (ℓ ⊔ e) where
  constructor _,_
  open Category C
  module X = F-Algebra X
  module Y = F-Algebra Y
  open Functor F
  field
    f : X.A ⇒ Y.A
    .commutes : f ∘ X.α ≡ Y.α ∘ F₁ f

F-Algebras : ∀ {o ℓ e} {C : Category o ℓ e} → Endofunctor C → Category (ℓ ⊔ o) (e ⊔ ℓ) e
F-Algebras {C = C} F = record
  { Obj = Obj′
  ; _⇒_ = Hom′
  ; _≡_ = _≡′_
  ; _∘_ = _∘′_
  ; id = id′
  ; assoc = assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; equiv = record
    { refl = refl
    ; sym = sym
    ; trans = trans
    }
  ; ∘-resp-≡ = ∘-resp-≡
  }
  where
  open Category C
  open Equiv
  open Functor F

  Obj′ = F-Algebra F

  Hom′ : (A B : Obj′) → Set _
  Hom′ = F-Algebra-Morphism

  _≡′_ : ∀ {A B} (f g : Hom′ A B) → Set _
  (f , _) ≡′ (g , _) = f ≡ g

  _∘′_ : ∀ {A B C} → Hom′ B C → Hom′ A B → Hom′ A C
  _∘′_ {A} {B} {C} (f , pf₁) (g , pf₂) = _,_ {X = A} {C} (f ∘ g) pf -- TODO: find out why the hell I need to provide these implicits
    where
    module A = F-Algebra A
    module B = F-Algebra B
    module C = F-Algebra C

    .pf : (f ∘ g) ∘ A.α ≡ C.α ∘ (F₁ (f ∘ g))
    pf = begin
           (f ∘ g) ∘ A.α
         ↓⟨ assoc ⟩
           f ∘ (g ∘ A.α)
         ↓⟨ ∘-resp-≡ʳ pf₂ ⟩
           f ∘ (B.α ∘ F₁ g)
         ↑⟨ assoc ⟩
           (f ∘ B.α) ∘ F₁ g
         ↓⟨ ∘-resp-≡ˡ pf₁ ⟩
           (C.α ∘ F₁ f) ∘ F₁ g
         ↓⟨ assoc ⟩
           C.α ∘ (F₁ f ∘ F₁ g)
         ↑⟨ ∘-resp-≡ʳ homomorphism ⟩
           C.α ∘ (F₁ (f ∘ g))
         ∎
      where
      open HomReasoning

  id′ : ∀ {A} → Hom′ A A
  id′ {A} = _,_ {X = A} {A} id pf
    where
    module A = F-Algebra A

    .pf : id ∘ A.α ≡ A.α ∘ F₁ id
    pf = begin
           id ∘ A.α
         ↓⟨ identityˡ ⟩
           A.α
         ↑⟨ identityʳ ⟩
           A.α ∘ id
         ↑⟨ ∘-resp-≡ʳ identity ⟩
           A.α ∘ F₁ id
         ∎
      where
      open HomReasoning

open import Categories.Object.Initial

module Lambek {o ℓ e} {C : Category o ℓ e} {F : Endofunctor C} (I : Initial (F-Algebras F)) where
  open Category C
  open Equiv
  module FA = Category (F-Algebras F) renaming (_∘_ to _∘FA_; _≡_ to _≡FA_)
  open Functor F
  import Categories.Morphisms as Morphisms
  open Morphisms C
  open Initial I
  open F-Algebra ⊥

  lambek : A ≅ F₀ A
  lambek = record
    { f = f′
    ; g = g′
    ; iso = iso′
    }
    where
    f′ : A ⇒ F₀ A
    f′ = F-Algebra-Morphism.f (! {lift ⊥})

    g′ : F₀ A ⇒ A
    g′ = α

    .iso′ : Iso f′ g′
    iso′ = record
      { isoˡ = isoˡ′
      ; isoʳ = begin
                 f′ ∘ g′
               ↓⟨ F-Algebra-Morphism.commutes (! {lift ⊥}) ⟩
                 F₁ g′ ∘ F₁ f′
               ↑⟨ homomorphism ⟩
                 F₁ (g′ ∘ f′)
               ↓⟨ F-resp-≡ isoˡ′ ⟩
                 F₁ id
               ↓⟨ identity ⟩
                 id
               ∎
      }
      where
      open FA hiding (id; module HomReasoning)
      open HomReasoning

      isoˡ′ = ⊥-id ((_,_ {C = C} {F} g′ refl) ∘FA !)

open Lambek public


open import Oscar.Prelude
open import Oscar.Class.[ExtensibleType]
open import Oscar.Data.Proposequality

module Oscar.Class.[ExtensibleType].Proposequality where

instance

  [ExtensibleType]Proposequality : ∀ {a} {b} {A : Set a} {B : A → Set b} → [ExtensibleType] (λ {w} → Proposequality⟦ B w ⟧)
  [ExtensibleType]Proposequality = ∁


-- Andreas, 2015-06-17
-- Postponing checkArguments dropped already inserted implicit arguments.

{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.def.alias:100 -v tc.decl:10 -v tc.term.expr:20 -v tc.data.con:20 #-}
-- {-# OPTIONS  -v tc.meta.assign:10 #-}
-- {-# OPTIONS  -v tc.term.expr.args:80 #-}
-- {-# OPTIONS  -v tc.term.args:30 #-}

postulate
  S : Set
  Cxt : Set
  N : (Γ : Cxt) → Set

  NeP  : ∀ (i : S) Δ (n : N Δ) → Set
  inhN : ∀ i Δ (v : N Δ) → NeP i Δ v

data Val (Δ : Cxt) : Set where
  ne : ∀ (n : N Δ) → Val Δ

-- BEGIN mutual

data ValP i Δ : (v : Val Δ) → Set
NeO : _

data ValP i Δ where
  cn  : ∀ (n : N Δ) → NeO n i  → ValP i Δ (ne n)
-- adding constructor cn : (n : N Δ) → _24 i Δ n → ValP i Δ (ne n)
-- LATER    : term _24 i Δ n := NeO n i
-- SHOULD BE: term _24 i Δ n := NeO {Δ} i n

-- must be last in mutual block for error
-- implicit argument needed for error
-- NeO_[_] : ∀ {Δ} (n : N Δ) (i : S) → Set  -- full type signature removes error
NeO = λ {Δ} n i → NeP i Δ n

-- END mutual

inhVal : ∀ i Δ (v : Val Δ) → ValP i Δ v
inhVal i Δ (ne n) = cn n (inhN i Δ n)

-- Checking inhN i Δ n : NeO n [ i ] -->  λ i₁ → NeP i₁ n i

-- ANALYSIS:
-- checked type signature NeO : _20
-- checking constructor cn : (n : N Δ) → NeO n i → ValP i Δ (ne n)
-- adding constructor cn : (n : N Δ) → _24 i Δ n → ValP i Δ (ne n)
-- postponed checking arguments [n, i] against _20
-- progress: checked [] remaining [n, i] : _20
-- term _20 :>= {Δ : _27} → _29 {Δ}
-- term _20 :>= {Δ : _27} → _29 {Δ}
-- solving _20 := {Δ : _27} → _29 {Δ}
-- postponed checking arguments [n, i] against _29 {_Δ_30 i Δ n}
-- progress: checked [] remaining [n, i] : _29 {_Δ_30 i Δ n}
-- Checking λ n i → NeP i Δ n : _29 {Δ}
-- solving _29 := λ {Δ} → (n : N Δ) (i : S) → Set
-- solving _24 := (λ i Δ n → NeO n i)


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

module Categories.Adjoint.Alternatives where

open import Level

open import Categories.Adjoint
open import Categories.Category
open import Categories.Functor renaming (id to idF)
open import Categories.NaturalTransformation

import Categories.Morphism.Reasoning as MR

private
  variable
    o ℓ e : Level
    C D   : Category o ℓ e

  module _ (L : Functor C D) (R : Functor D C) where
    private
      module C = Category C
      module D = Category D
      module L = Functor L
      module R = Functor R

    record FromUnit : Set (levelOfTerm L ⊔ levelOfTerm R) where

      field
        unit : NaturalTransformation idF (R ∘F L)

      module unit = NaturalTransformation unit

      field
        θ       : ∀ {X Y} → C [ X , R.₀ Y ] → D [ L.₀ X , Y ]
        commute : ∀ {X Y} (g : C [ X , R.₀ Y ]) → g C.≈ R.₁ (θ g) C.∘ unit.η X
        unique  : ∀ {X Y} {f : D [ L.₀ X , Y ]} {g : C [ X , R.₀ Y ]} →
                    g C.≈ R.₁ f C.∘ unit.η X → θ g D.≈ f

      module _ where
        open C.HomReasoning
        open MR C

        θ-natural : ∀ {X Y Z} (f : D [ Y , Z ]) (g : C [ X , R.₀ Y ]) → θ (R.₁ f C.∘ g) D.≈ θ (R.₁ f) D.∘ L.₁ g
        θ-natural {X} {Y} f g = unique eq
          where eq : R.₁ f C.∘ g C.≈ R.₁ (θ (R.₁ f) D.∘ L.₁ g) C.∘ unit.η X
                eq = begin
                  R.₁ f C.∘ g                                      ≈⟨ commute (R.₁ f) ⟩∘⟨refl ⟩
                  (R.₁ (θ (R.₁ f)) C.∘ unit.η (R.F₀ Y)) C.∘ g    ≈⟨ C.assoc ⟩
                  R.₁ (θ (R.₁ f)) C.∘ unit.η (R.₀ Y) C.∘ g       ≈⟨ pushʳ (unit.commute g) ⟩
                  (R.₁ (θ (R.₁ f)) C.∘ R.₁ (L.₁ g)) C.∘ unit.η X ≈˘⟨ R.homomorphism ⟩∘⟨refl ⟩
                  R.₁ (θ (R.₁ f) D.∘ L.₁ g) C.∘ unit.η X         ∎

        θ-cong : ∀ {X Y} {f g : C [ X , R.₀ Y ]} → f C.≈ g → θ f D.≈ θ g
        θ-cong eq = unique (eq ○ commute _)

      θ-natural′ : ∀ {X Y} (g : C [ X , R.₀ Y ]) → θ g D.≈ θ C.id D.∘ L.₁ g
      θ-natural′ g = θ-cong (introˡ R.identity) ○ θ-natural D.id g ○ D.∘-resp-≈ˡ (θ-cong R.identity)
        where open D.HomReasoning
              open MR C

      counit : NaturalTransformation (L ∘F R) idF
      counit = ntHelper record
        { η       = λ d → θ C.id
        ; commute = λ f → begin
          θ C.id D.∘ L.₁ (R.₁ f) ≈˘⟨ θ-natural′ (R.₁ f) ⟩
          θ (R.₁ f)              ≈⟨ unique (CH.⟺ (MR.cancelʳ C (CH.⟺ (commute C.id))) CH.○ CH.⟺ (C.∘-resp-≈ˡ R.homomorphism)) ⟩
          f D.∘ θ C.id           ∎
        }
        where open D.HomReasoning
              module CH = C.HomReasoning

      unique′ : ∀ {X Y} {f g : D [ L.₀ X , Y ]} (h : C [ X , R.₀ Y ]) →
                  h C.≈ R.₁ f C.∘ unit.η X →
                  h C.≈ R.₁ g C.∘ unit.η X → f D.≈ g
      unique′ _ eq₁ eq₂ = ⟺ (unique eq₁) ○ unique eq₂
        where open D.HomReasoning

      zig : ∀ {A} → θ C.id D.∘ L.F₁ (unit.η A) D.≈ D.id
      zig {A} = unique′ (unit.η A)
                        (commute (unit.η A) ○ (C.∘-resp-≈ˡ (R.F-resp-≈ (θ-natural′ (unit.η A)))))
                        (introˡ R.identity)
        where open C.HomReasoning
              open MR C

      L⊣R : L ⊣ R
      L⊣R = record
        { unit   = unit
        ; counit = counit
        ; zig    = zig
        ; zag    = C.Equiv.sym (commute C.id)
        }

    record FromCounit : Set (levelOfTerm L ⊔ levelOfTerm R) where

      field
        counit : NaturalTransformation (L ∘F R) idF

      module counit = NaturalTransformation counit

      field
        θ       : ∀ {X Y} → D [ L.₀ X , Y ] → C [ X , R.₀ Y ]
        commute : ∀ {X Y} (g : D [ L.₀ X , Y ]) → g D.≈ counit.η Y D.∘ L.₁ (θ g)
        unique  : ∀ {X Y} {f : C [ X , R.₀ Y ]} {g : D [ L.₀ X , Y ]} →
                    g D.≈ counit.η Y D.∘ L.₁ f → θ g C.≈ f

      module _ where
        open D.HomReasoning
        open MR D

        θ-natural : ∀ {X Y Z} (f : C [ X , Y ]) (g : D [ L.₀ Y , Z ]) → θ (g D.∘ L.₁ f) C.≈ R.₁ g C.∘ θ (L.₁ f)
        θ-natural {X} {Y} {Z} f g = unique eq
          where eq : g D.∘ L.₁ f D.≈ counit.η Z D.∘ L.₁ (R.₁ g C.∘ θ (L.₁ f))
                eq = begin
                  g D.∘ L.₁ f                                     ≈⟨ pushʳ (commute (L.₁ f)) ⟩
                  (g D.∘ counit.η (L.F₀ Y)) D.∘ L.F₁ (θ (L.F₁ f)) ≈⟨ pushˡ (counit.sym-commute g) ⟩
                  counit.η Z D.∘ L.₁ (R.₁ g) D.∘ L.₁ (θ (L.₁ f))  ≈˘⟨ refl⟩∘⟨ L.homomorphism ⟩
                  counit.η Z D.∘ L.₁ (R.₁ g C.∘ θ (L.₁ f))        ∎

        θ-cong : ∀ {X Y} {f g : D [ L.₀ X , Y ]} → f D.≈ g → θ f C.≈ θ g
        θ-cong eq = unique (eq ○ commute _)

      θ-natural′ : ∀ {X Y} (g : D [ L.₀ X , Y ]) → θ g C.≈ R.₁ g C.∘ θ D.id
      θ-natural′ g = θ-cong (introʳ L.identity) ○ θ-natural C.id g ○ C.∘-resp-≈ʳ (θ-cong L.identity)
        where open C.HomReasoning
              open MR D

      unit : NaturalTransformation idF (R ∘F L)
      unit = ntHelper record
        { η       = λ _ → θ D.id
        ; commute = λ f → begin
          θ D.id C.∘ f           ≈˘⟨ unique (DH.⟺ (cancelˡ (DH.⟺ (commute D.id))) DH.○ D.∘-resp-≈ʳ (DH.⟺ L.homomorphism)) ⟩
          θ (L.₁ f)              ≈⟨ θ-natural′ (L.₁ f) ⟩
          R.₁ (L.₁ f) C.∘ θ D.id ∎
        }
        where open C.HomReasoning
              module DH = D.HomReasoning
              open MR D

      unique′ : ∀ {X Y} {f g : C [ X , R.₀ Y ]} (h : D [ L.₀ X , Y ]) →
                  h D.≈ counit.η Y D.∘ L.₁ f →
                  h D.≈ counit.η Y D.∘ L.₁ g →
                  f C.≈ g
      unique′ _ eq₁ eq₂ = ⟺ (unique eq₁) ○ unique eq₂
        where open C.HomReasoning

      zag : ∀ {B} → R.F₁ (counit.η B) C.∘ θ D.id C.≈ C.id
      zag {B} = unique′ (counit.η B)
                        (⟺ (cancelʳ (⟺ (commute D.id))) ○ pushˡ (counit.sym-commute (counit.η B)) ○ D.∘-resp-≈ʳ (⟺ L.homomorphism))
                        (introʳ L.identity)
        where open D.HomReasoning
              open MR D

      L⊣R : L ⊣ R
      L⊣R = record
        { unit   = unit
        ; counit = counit
        ; zig    = D.Equiv.sym (commute D.id)
        ; zag    = zag
        }

module _ {L : Functor C D} {R : Functor D C} where

  fromUnit : FromUnit L R → L ⊣ R
  fromUnit = FromUnit.L⊣R

  fromCounit : FromCounit L R → L ⊣ R
  fromCounit = FromCounit.L⊣R


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

open import Base
open import Integers
open import Homotopy.Truncation
open import Spaces.Spheres
open import Spaces.Suspension
open import Homotopy.Connected
open import Homotopy.ConnectedSuspension
open import Homotopy.Pointed
open import Homotopy.HomotopyGroups

module Spaces.PikSn where

abstract
  Sⁿ-S-is-connected : (n : ℕ) → is-connected ⟨ n ⟩ (Sⁿ (S n))
  Sⁿ-S-is-connected n =
    suspension-is-connected-S (Sⁿ n) ind-hyp (proj (⋆Sⁿ n)) where
      ind-hyp : is-connected (n -1) (Sⁿ n)
      ind-hyp with n
      ind-hyp | O = inhab-prop-is-contr (proj true) (τ-is-truncated _ _)
      ind-hyp | S n = Sⁿ-S-is-connected n

Sⁿ⋆ : (n : ℕ) → pType₀
Sⁿ⋆ n = ⋆[ Sⁿ n , ⋆Sⁿ n ]

abstract
  πk-Sⁿ-is-contr : (k n : ℕ) (lt : k < n)
    → is-contr⋆ (πⁿ k (Sⁿ⋆ n))
  πk-Sⁿ-is-contr k O ()
  πk-Sⁿ-is-contr k (S n) lt = connected-πⁿ k n lt _ (Sⁿ-S-is-connected n)


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

{-
  Ribbon is an explicit covering space construction.

  This construction is given by Daniel Grayson, Favonia
  and Guillaume Brunerie together.
-}

open import HoTT

-- A is the pointed base space.
-- El is intended to be a (group-)set,
module homotopy.RibbonCover {i : ULevel} where

  -- The HIT ribbon---reconstructed covering space

  module _ (X : Ptd i) {j} (gs : GroupSet (πS 0 X) j) (a₂ : de⊙ X) where
    private
      A = de⊙ X
      a₁ = pt X
      El = GroupSet.El gs
      El-level = GroupSet.El-level gs
      infix 80 _⊙_
      _⊙_ = GroupSet.act gs

    RibbonSet : Type (lmax i j)
    RibbonSet = El × (a₁ =₀ a₂)

    data RibbonRel : RibbonSet → RibbonSet → Type (lmax i j) where
      ribbon-rel : ∀ el loop (p : a₁ =₀ a₂)
        → RibbonRel (el ⊙ loop , p) (el , loop ∙₀ p)

    Ribbon : Type (lmax i j)
    Ribbon = SetQuot RibbonRel

  module _ {X : Ptd i} {j} {gs : GroupSet (πS 0 X) j} {a₂ : de⊙ X} where
    private
      A = de⊙ X
      a = pt X
      El = GroupSet.El gs
      El-level = GroupSet.El-level gs
      infix 80 _⊙_
      _⊙_ = GroupSet.act gs

    -- A point in the fiber [a₂].
    {-
      [e] is a point in the [fiber a], and
      [p] is a path to transport [y] to fiber [a₂].
    -}
    trace : El → a =₀ a₂ → Ribbon X gs a₂
    trace el p = q[ el , p ]

    {-
      A loop based at [a] can used as a group action
      or for concatination.  Both should be equivalent.
    -}
    paste : ∀ el loop (p : a =₀ a₂) → trace (el ⊙ loop) p == trace el (loop ∙₀ p)
    paste el loop p = quot-rel (ribbon-rel el loop p)

    {-
      Make each fiber a set and cancel all higher structures
      due to [paste].
    -}
    Ribbon-level : is-set (Ribbon X gs a₂)
    Ribbon-level = SetQuot-level

    Ribbon-is-set = Ribbon-level

    -- Elimination rules.
    module RibbonElim {j} {P : Ribbon X gs a₂ → Type j}
      (P-level : ∀ r → is-set (P r))
      (trace* : ∀ el p → P (trace el p))
      (paste* : ∀ el loop p
                → trace* (el ⊙ loop) p == trace* el (loop ∙₀ p)
                  [ P ↓ paste el loop p ]) where

      private
        q[_]* : (α : RibbonSet X gs a₂) → P q[ α ]
        q[ el , p ]* = trace* el p

        rel* : ∀ {α₁ α₂} (r : RibbonRel X gs a₂ α₁ α₂) → q[ α₁ ]* == q[ α₂ ]* [ P ↓ quot-rel r ]
        rel* (ribbon-rel el loop p) = paste* el loop p

        module M = SetQuotElim P-level q[_]* rel*

      f : Π (Ribbon X gs a₂) P
      f = M.f

    open RibbonElim public using () renaming (f to Ribbon-elim)

    module RibbonRec {j} {P : Type j}
      (P-level : is-set P)
      (trace* : ∀ el p → P)
      (paste* : ∀ el loop p
                → trace* (el ⊙ loop) p == trace* el (loop ∙₀ p)) where

      private
        module M = RibbonElim (λ _ → P-level) trace*
          (λ el loop p → ↓-cst-in (paste* el loop p))

      f : Ribbon X gs a₂ → P
      f = M.f

    open RibbonRec public using () renaming (f to Ribbon-rec)

  -- This data structure gives a cover.
  Ribbon-cover : ∀ (X : Ptd i) {j} (gs : GroupSet (πS 0 X) j)
    → Cover (de⊙ X) (lmax i j)
  Ribbon-cover X gs = record
    { Fiber = Ribbon X gs
    ; Fiber-level = λ a → Ribbon-level
    }

  transp-trace : ∀ {A : Type i} {a₁} {j}
    {gs : GroupSet (πS 0 ⊙[ A , a₁ ]) j}
    {a₂} (q : a₁ == a₂) y p
    → transport (Ribbon ⊙[ A , a₁ ] gs) q (trace y p) == trace y (p ∙₀ [ q ])
  transp-trace idp y p = ap (trace y) $ ! $ ∙₀-unit-r p


open import SOAS.Common
open import SOAS.Families.Core

-- Algebras for a signature endofunctor
module SOAS.Metatheory.Algebra {T : Set} (⅀F : Functor (𝔽amiliesₛ {T}) (𝔽amiliesₛ {T})) where

module ⅀ = Functor ⅀F

⅀ : Familyₛ → Familyₛ
⅀ = ⅀.₀

⅀₁ : {𝒳 𝒴 : Familyₛ} → 𝒳 ⇾̣ 𝒴 → ⅀ 𝒳 ⇾̣ ⅀ 𝒴
⅀₁ = Functor.₁ ⅀F


------------------------------------------------------------------------------
-- First-order logic with equality
------------------------------------------------------------------------------

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

-- This module exported all the logical constants and the
-- propositional equality. This module is re-exported by the "base"
-- modules whose theories are defined on first-order logic + equality.

module Common.FOL.FOL-Eq where

-- First-order logic (without equality).
open import Common.FOL.FOL public

-- Propositional equality.
open import Common.FOL.Relation.Binary.PropositionalEquality public


------------------------------------------------------------------------------
-- Test case due to Agda new unifier
------------------------------------------------------------------------------

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

module Agda.NewUnifier where

infixl 7 _·_
infixr 5 _∷_
infix 4  _≡_

-- The universe of discourse/universal domain.
postulate D : Set

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

postulate
  _·_  : D → D → D  -- FOTC application.

-- List constants.
postulate [] cons head tail null : D  -- FOTC partial lists.

-- Definitions
abstract
  _∷_  : D → D → D
  x ∷ xs = cons · x · xs

-- The FOTC lists type (inductive predicate for total lists).
data List : D → Set where
  lnil  : List []
  lcons : ∀ x {xs} → List xs → List (x ∷ xs)
{-# ATP axioms lnil lcons #-}

postulate
  _++_  : D → D → D
  ++-[] : ∀ ys → [] ++ ys            ≡ ys
  ++-∷  : ∀ x xs ys → (x ∷ xs) ++ ys ≡ x ∷ (xs ++ ys)
{-# ATP axioms ++-[] ++-∷ #-}

++-List : ∀ {xs ys} → List xs → List ys → List (xs ++ ys)
++-List {ys = ys} lnil Lys = prf
  where postulate prf : List ([] ++ ys)
        {-# ATP prove prf #-}

++-List {ys = ys} (lcons x {xs} Lxs) Lys = prf (++-List Lxs Lys)
  where postulate prf : List (xs ++ ys) → List ((x ∷ xs) ++ ys)
        {-# ATP prove prf #-}


module Section3 where

open import Section1 public

-- 3. The calculus of proof trees
-- ==============================
--
-- We define the set of proof trees of implicational logic in the ordinary style à la Church,
-- except that we use explicit substitutions.

-- 3.1. Definition of types
-- ------------------------
--
-- The types we have are base type and function types.  The set of types `𝒯 : Set` is introduced
-- by:

infixr 7 _⊃_
data 𝒯 : Set where
  •   : 𝒯
  _⊃_ : 𝒯 → 𝒯 → 𝒯

-- Types are denoted by `A`, `B`.  (…)
--
-- We write `•` for the base type and `A ⊃ B` for the function type.

module _ where
  inj₁⊃ : ∀ {A A′ B B′} → A ⊃ B ≡ A′ ⊃ B′ → A ≡ A′
  inj₁⊃ refl = refl

  inj₂⊃ : ∀ {A A′ B B′} → A ⊃ B ≡ A′ ⊃ B′ → B ≡ B′
  inj₂⊃ refl = refl

  _≟𝒯_ : (A A′ : 𝒯) → Dec (A ≡ A′)
  •       ≟𝒯 •         = yes refl
  •       ≟𝒯 (A′ ⊃ B′) = no λ ()
  (A ⊃ B) ≟𝒯 •         = no λ ()
  (A ⊃ B) ≟𝒯 (A′ ⊃ B′) with A ≟𝒯 A′ | B ≟𝒯 B′
  …                   | yes refl | yes refl = yes refl
  …                   | yes refl | no B≢B′  = no (λ p → inj₂⊃ p ↯ B≢B′)
  …                   | no A≢A′  | _        = no (λ p → inj₁⊃ p ↯ A≢A′)

-- 3.2. Definition of contexts
-- ---------------------------
--
-- Suppose a countably infinite set, `Name`, with names together with a decidable equality on it.
-- The set of contexts `𝒞` is mutually defined with a boolean-valued function `fresh` which describes
-- when a name is fresh in a context.  (…)
--
-- Ordinarily, the freshness condition is written as a side-condition, but since we are to
-- formalise the proof trees, this information must be represented, too.
--
-- We write `[]` for the empty context and `[ Γ , x ∷ A ]` for adding an element to a context,
-- hence when we write `[ Γ , x ∷ A ]`
-- it is implicit that we also have a proof that `x` is fresh in `Γ` (when `[ Γ , x ∷ A ]` occurs in the
-- conclusion of a statement, then it is implicit that `T (fresh x Γ)` is an assumption.)  The
-- function `fresh` is defined by induction on the context as:

mutual
  data 𝒞 : Set where
    []      : 𝒞
    [_,_∷_] : (Γ : 𝒞) (x : Name) {{_ : T (fresh x Γ)}} → 𝒯 → 𝒞

  fresh : Name → 𝒞 → Bool
  fresh x []            = true
  fresh x [ Γ , y ∷ A ] = and (x ≠ y) (fresh x Γ)

-- We use `Γ`, `Δ` and `Θ` for contexts.
--
-- The predicate `Γ ∋ x ∷ A` is true when a name with its type occurs in a context.
--
-- The introduction rules are:

data _∋_∷_ : 𝒞 → Name → 𝒯 → Set where
  zero : ∀ {Γ A x} {{_ : T (fresh x Γ)}} →
           [ Γ , x ∷ A ] ∋ x ∷ A
  suc  : ∀ {Γ A B x y} {{_ : T (fresh y Γ)}} →
           Γ ∋ x ∷ A →
           [ Γ , y ∷ B ] ∋ x ∷ A

module _ where
  injsuc : ∀ {Γ A B x y} {{_ : T (fresh y Γ)}} {i i′ : Γ ∋ x ∷ A} →
             suc {B = B} {y = y} i ≡ suc i′ → i ≡ i′
  injsuc refl = refl

  _≟∋_ : ∀ {Γ A x} → (i i′ : Γ ∋ x ∷ A) → Dec (i ≡ i′)
  zero  ≟∋ zero   = yes refl
  zero  ≟∋ suc i′ = no (λ ())
  suc i ≟∋ zero   = no (λ ())
  suc i ≟∋ suc i′ with i ≟∋ i′
  …              | yes refl = yes refl
  …              | no i≢i′  = no (λ p → injsuc p ↯ i≢i′)

module _ where
  _∌_∷_ : 𝒞 → Name → 𝒯 → Set
  Γ ∌ x ∷ A = ¬ (Γ ∋ x ∷ A)

  fresh→∌ : ∀ {x Γ A} {{_ : T (fresh x Γ)}} → Γ ∌ x ∷ A
  fresh→∌ {x} {{φ}}  zero             with x ≟ x
  fresh→∌ {x} {{()}} zero             | yes refl
  fresh→∌ {x} {{φ}}  zero             | no x≢x   = refl ↯ x≢x
  fresh→∌ {x} {{φ}}  (suc {y = y}  i) with x ≟ y
  fresh→∌ {x} {{()}} (suc {y = .x} i) | yes refl
  fresh→∌ {x} {{φ}}  (suc {y = y}  i) | no x≢y   = i ↯ fresh→∌

  freshlem₁ : ∀ {b′} → (x : Name) → ¬ (T (and (x ≠ x) b′))
  freshlem₁ x p with x ≟ x
  …            | yes refl = p
  …            | no x≢x   = refl ↯ x≢x

  freshlem₂ : ∀ {b′} → (x {y} : Name) → T (and (x ≠ y) b′) → T b′
  freshlem₂ x {y} p with x ≟ y
  …              | yes refl = elim⊥ p
  …              | no x≢y   = p

-- We also define the relation that describes when a context contains another.
--
-- We use the notational convention `Γ ⊇ Δ` for `Γ` being greater than `Δ`.
-- The set `_⊇_` has the constructors:

infix 3 _⊇_
data _⊇_ : 𝒞 → 𝒞 → Set where
  done : ∀ {Γ} →
           Γ ⊇ []
  step : ∀ {Γ Δ A x} {{_ : T (fresh x Δ)}} →
           Γ ⊇ Δ → Γ ∋ x ∷ A →
           Γ ⊇ [ Δ , x ∷ A ]

module _ where
  inj₁step : ∀ {Γ Δ A x} {{_ : T (fresh x Δ)}} {c c′ : Γ ⊇ Δ} {i i′ : Γ ∋ x ∷ A} →
               step c i ≡ step c′ i′ → c ≡ c′
  inj₁step refl = refl

  inj₂step : ∀ {Γ Δ A x} {{_ : T (fresh x Δ)}} {c c′ : Γ ⊇ Δ} {i i′ : Γ ∋ x ∷ A} →
               step c i ≡ step c′ i′ → i ≡ i′
  inj₂step refl = refl

  _≟⊇_ : ∀ {Γ Δ} → (c c′ : Γ ⊇ Δ) → Dec (c ≡ c′)
  done     ≟⊇ done       = yes refl
  step c i ≟⊇ step c′ i′ with c ≟⊇ c′ | i ≟∋ i′
  …                     | yes refl | yes refl = yes refl
  …                     | yes refl | no i≢i′  = no (λ p → inj₂step p ↯ i≢i′)
  …                     | no c≢c′  | _        = no (λ p → inj₁step p ↯ c≢c′)

-- The following lemmas are easy to prove:

-- Lemma 1.
ext⊇ : ∀ {Δ Γ} → (∀ {A x} → Δ ∋ x ∷ A → Γ ∋ x ∷ A) → Γ ⊇ Δ
ext⊇ {[]}            f = done
ext⊇ {[ Δ , x ∷ A ]} f = step (ext⊇ (λ i → f (suc i))) (f zero)

-- Lemma 2.
module _ where
  ↑⟨_⟩∋ : ∀ {Γ Δ A x} → Δ ⊇ Γ → Γ ∋ x ∷ A → Δ ∋ x ∷ A
  ↑⟨ done ⟩∋     ()
  ↑⟨ step c i ⟩∋ zero    = i
  ↑⟨ step c i ⟩∋ (suc j) = ↑⟨ c ⟩∋ j

  instance
    raise∋ : ∀ {A x} → Raiseable (_∋ x ∷ A)
    raise∋ = record { ↑⟨_⟩ = ↑⟨_⟩∋ }

-- Lemma 3.
refl⊇ : ∀ {Γ} → Γ ⊇ Γ
refl⊇ = ext⊇ id

-- Lemma 4.
module _ where
  _○_ : ∀ {Γ Δ Θ} → Γ ⊇ Δ → Θ ⊇ Γ → Θ ⊇ Δ
  c ○ c′ = ext⊇ (λ i → ↑⟨ c′ ⟩ (↑⟨ c ⟩ i))

  trans⊇ : ∀ {Γ Δ Θ} → Θ ⊇ Γ → Γ ⊇ Δ → Θ ⊇ Δ
  trans⊇ = flip _○_

-- Lemma 5.
weak⊇ : ∀ {Γ A x} {{_ : T (fresh x Γ)}} → [ Γ , x ∷ A ] ⊇ Γ
weak⊇ = ext⊇ suc

-- Lemma 6.
uniq∋ : ∀ {Γ A x} → (i i′ : Γ ∋ x ∷ A) → i ≡ i′
uniq∋ zero    zero     = refl
uniq∋ zero    (suc i′) = i′ ↯ fresh→∌
uniq∋ (suc i) zero     = i ↯ fresh→∌
uniq∋ (suc i) (suc i′) = cong suc (uniq∋ i i′)

-- Lemma 7.
uniq⊇ : ∀ {Γ Δ} → (c c′ : Γ ⊇ Δ) → c ≡ c′
uniq⊇ done       done         = refl
uniq⊇ (step c i) (step c′ i′) = cong² step (uniq⊇ c c′) (uniq∋ i i′)

-- `ext⊇`, `↑⟨_⟩∋` and `uniq⊇` are proven by induction on `Δ` and `uniq∋` is proven by
-- induction on `Γ`.  `refl⊇` and `weak⊇` are direct consequences of `ext⊇` and for `trans⊇`
-- we also use `↑⟨_⟩∋`.  (…)
--
-- The last two lemmas may seem slightly strange: they are used for guaranteeing independence
-- of the proofs of `_∋_∷_` and `_⊇_`.  For example, `uniq∋` says that if it can be shown that
-- `x ∷ A` occurs in a context `Γ`, then there is a unique proof of this fact.  The need to prove
-- independence of proofs might point to a problem in using type theory for formalising proofs.  On
-- the other hand, as we shall see, proof objects can also be useful: the present formalisation
-- heavily uses the possibilities to perform case analysis on proof objects, which reduces the
-- number of cases to consider.

module _ where
  id₁○ : ∀ {Γ Δ} → (c : Γ ⊇ Γ) (c′ : Δ ⊇ Γ) → c ○ c′ ≡ c′
  id₁○ c c′ = uniq⊇ (c ○ c′) c′

  id₂○ : ∀ {Γ Δ} → (c : Δ ⊇ Γ) (c′ : Δ ⊇ Δ) → c ○ c′ ≡ c
  id₂○ c c′ = uniq⊇ (c ○ c′) c

  assoc○ : ∀ {Γ Δ Θ Ω} → (c : Δ ⊇ Γ) (c′ : Θ ⊇ Δ) (c″ : Ω ⊇ Θ) →
             c ○ (c′ ○ c″) ≡ (c ○ c′) ○ c″
  assoc○ c c′ c″ = uniq⊇ (c ○ (c′ ○ c″)) ((c ○ c′) ○ c″)

  comp○ : ∀ {Γ Δ Θ} → (c : Δ ⊇ Γ) (c′ : Θ ⊇ Δ) (c″ : Θ ⊇ Γ) →
            c ○ c′ ≡ c″
  comp○ c c′ c″ = uniq⊇ (c ○ c′) c″

-- 3.3. Definition of proof trees
-- ------------------------------
--
-- Proof trees and substitutions are mutually inductively defined.  (…)
--
-- We use the notational convention `Γ ⊢ A` and `Δ ⋙ Γ` for a proof of `A` in context `Γ` and
-- a substitution of `Γ` by `Δ`, respectively.
--
-- A substitution of type `Δ ⋙ Γ` intuitively is a list that associates to each `x ∷ A` in `Γ` a unique
-- proof tree of type `Δ ⊢ A`.
--
-- The proof trees are defined by the following rules.
--
-- We recall that hidden assumptions in the definition above are implicitly universally defined
-- and that the notation `[ Γ , x ∷ A ]` implies that `x` is fresh in `Γ`.  (…)
--
-- In the definition of variables we can see that a proof of occurrence is part of the proof
-- tree.  The advantage is that we can do case-analysis on this proof to find out where in the
-- context `x ∷ A` occurs.  The disadvantage is that we need to prove that two variables are the
-- same even if they have two possibly different proofs of occurrence of `x ∷ A` (by Lemma 6 we
-- know that the proofs are the same).

mutual
  infix 3 _⊢_
  data _⊢_ : 𝒞 → 𝒯 → Set where
    ν   : ∀ {Γ A} →
            (x : Name) → Γ ∋ x ∷ A →
            Γ ⊢ A
    ƛ   : ∀ {Γ A B} →
            (x : Name) {{_ : T (fresh x Γ)}} → [ Γ , x ∷ A ] ⊢ B →
            Γ ⊢ A ⊃ B
    _∙_ : ∀ {Γ A B} →
            Γ ⊢ A ⊃ B → Γ ⊢ A →
            Γ ⊢ B
    _▶_ : ∀ {Γ Δ A} →
            Γ ⊢ A → Δ ⋙ Γ →
            Δ ⊢ A

  infix 3 _⋙_
  data _⋙_ : 𝒞 → 𝒞 → Set where
    π⟨_⟩    : ∀ {Γ Δ} →
                Δ ⊇ Γ →
                Δ ⋙ Γ
    _●_     : ∀ {Γ Δ Θ} →
                Γ ⋙ Δ → Θ ⋙ Γ →
                Θ ⋙ Δ
    [_,_≔_] : ∀ {Γ Δ A} →
                Δ ⋙ Γ → (x : Name) {{_ : T (fresh x Γ)}} → Δ ⊢ A →
                Δ ⋙ [ Γ , x ∷ A ]

-- Explicit substitutions are built from a projection map, update and composition (see below
-- for a discussion on the projection map).
--
-- We use the following notational conventions:
--
-- -   `ν x`           for referencing the occurrence `x`, where `x : Γ ∋ x ∷ A`
-- -   `M ▶ γ`         for applying the substitution `γ` to the term `M`
-- -   `ƛ x M`         for abstracting the occurrence `x` from the term `M`, where `M : [ Γ , x ∷ A ] ⊢ B`
-- -   `M ∙ N`         for applying the term `M` to the term `N`
-- -   `π⟨ c ⟩`        for projecting the inclusion `c` as a substitution
-- -   `[ γ , x ≔ M ]` for updating the substitution `γ` with the term `M` for the occurrence `x`
-- -   `γ ● δ`         for composing the substitution `δ` with the substitution `γ`
--
-- Proof trees and substitutions are named `M, N` and `γ, δ, θ` respectively.
--
-- The substitution `π⟨_⟩` is not a standard primitive for explicit substitutions.  Often one rather
-- has an identity substitution (in `Γ ⋙ Γ`) [1, 13] or the empty substitution (in `Γ ⋙ []`) [5].
-- Instead we have taken `π⟨_⟩` as primitive.  If `c : Γ ⊇ Γ`, then `π⟨ c ⟩` is the identity substitution and
-- if `c : Γ ⊇ []`, then `π⟨ c ⟩` is the empty substitution.  Abadi et al. [1] use a substitution `↑` that
-- corresponds to a shift on substitutions; the same substitution is here defined as `π⟨ c ⟩` where
-- `c : [ Γ , x ∷ A ] ⊇ Γ`.  In Martin-Löf’s substitution calculus [13, 20] we have as primitives also
-- thinning rules (i.e., if a term is well-typed in a given context, then it is also well-typed in a
-- larger context and likewise for substitutions.)  Here, thinning is achieved using `π⟨_⟩`, since if,
-- for example, `M : Γ ⊢ A` and `c : Δ ⊇ Γ`, then `M ▶ π⟨ c ⟩ : Δ ⊢ A`.
--
-- The first version of our work used combinators for the thinning rules, since we wanted it to
-- be a start for a complete mechanical analysis of Martin-Löf’s substitution calculus [13, 20].
-- The set of conversion rules we obtained using these combinators suggested the use of `π⟨_⟩`,
-- which gives fewer conversion rules.  There might be other advantages in using `π⟨_⟩`: if a proof
-- tree is of the form `M ▶ π⟨_⟩` we know which are the possible free variables of the term `M`,
-- information that might be used in a computation.

module _ where
  ↑⟨_⟩⊢ : ∀ {Γ Δ A} → Δ ⊇ Γ → Γ ⊢ A → Δ ⊢ A
  ↑⟨ c ⟩⊢ M = M ▶ π⟨ c ⟩

  ↑⟨_⟩⋙ : ∀ {Γ Δ Θ} → Δ ⊇ Γ → Γ ⋙ Θ → Δ ⋙ Θ
  ↑⟨ c ⟩⋙ δ = δ ● π⟨ c ⟩

  ↓⟨_⟩⋙ : ∀ {Γ Δ Θ} → Δ ⊇ Γ → Θ ⋙ Δ → Θ ⋙ Γ
  ↓⟨ c ⟩⋙ δ = π⟨ c ⟩ ● δ

  refl⋙ : ∀ {Γ} → Γ ⋙ Γ
  refl⋙ = π⟨ refl⊇ ⟩

  trans⋙ : ∀ {Γ Δ Θ} → Θ ⋙ Γ → Γ ⋙ Δ → Θ ⋙ Δ
  trans⋙ = flip _●_

  weak⋙ : ∀ {Γ A x} {{_ : T (fresh x Γ)}} → [ Γ , x ∷ A ] ⋙ Γ
  weak⋙ = π⟨ weak⊇ ⟩

  instance
    raise⊢ : ∀ {A} → Raiseable (_⊢ A)
    raise⊢ = record { ↑⟨_⟩ = ↑⟨_⟩⊢ }

    raise⋙ : ∀ {Γ} → Raiseable (_⋙ Γ)
    raise⋙ = record { ↑⟨_⟩ = ↑⟨_⟩⋙ }

    lower⋙ : ∀ {Δ} → Lowerable (Δ ⋙_)
    lower⋙ = record { ↓⟨_⟩ = ↓⟨_⟩⋙ }

-- 3.4. Convertibility of proof trees
-- ----------------------------------
--
-- The rules for conversion between proof trees and substitutions are inductively defined.
--
-- We use the notational convention `M ≅ N` and `γ ≅ₛ δ` for convertibility on proof trees and
-- on substitutions respectively.  (…)
--
-- The conversion rules for proof trees are the reflexivity, symmetry, transitivity, congruence
-- rules and the following rules:

mutual
  infix 3 _≅_
  data _≅_ : ∀ {Γ A} → Γ ⊢ A → Γ ⊢ A → Set where
    refl≅  : ∀ {Γ A} {M : Γ ⊢ A} →
               M ≅ M
    sym≅   : ∀ {Γ A} {M M′ : Γ ⊢ A} →
               M ≅ M′ →
               M′ ≅ M
    trans≅ : ∀ {Γ A} {M M′ M″ : Γ ⊢ A} →
               M ≅ M′ → M′ ≅ M″ →
               M ≅ M″

    congƛ≅ : ∀ {Γ A B x} {{_ : T (fresh x Γ)}} {M M′ : [ Γ , x ∷ A ] ⊢ B} →
               M ≅ M′ →
               ƛ x M ≅ ƛ x M′
    cong∙≅ : ∀ {Γ A B} {M M′ : Γ ⊢ A ⊃ B} {N N′ : Γ ⊢ A} →
               M ≅ M′ → N ≅ N′ →
               M ∙ N ≅ M′ ∙ N′
    cong▶≅ : ∀ {Γ Δ A} {M M′ : Γ ⊢ A} {γ γ′ : Δ ⋙ Γ} →
               M ≅ M′ → γ ≅ₛ γ′ →
               M ▶ γ ≅ M′ ▶ γ′

    conv₁≅ : ∀ {Γ Δ A B x} {{_ : T (fresh x Γ)}} →
               (M : [ Γ , x ∷ A ] ⊢ B) (N : Δ ⊢ A) (γ : Δ ⋙ Γ) →
               (ƛ x M ▶ γ) ∙ N ≅ M ▶ [ γ , x ≔ N ]
    conv₂≅ : ∀ {Γ A B x} {{_ : T (fresh x Γ)}} →
               (c : [ Γ , x ∷ A ] ⊇ Γ) (M : Γ ⊢ A ⊃ B) →
               M ≅ ƛ x ((M ▶ π⟨ c ⟩) ∙ ν x zero)
    conv₃≅ : ∀ {Γ Δ A x} {{_ : T (fresh x Γ)}} →
               (M : Δ ⊢ A) (γ : Δ ⋙ Γ) →
               ν x zero ▶ [ γ , x ≔ M ] ≅ M
    conv₄≅ : ∀ {Γ Δ A x} →
               (c : Δ ⊇ Γ) (i : Γ ∋ x ∷ A) (j : Δ ∋ x ∷ A) →
               ν x i ▶ π⟨ c ⟩ ≅ ν x j
    conv₅≅ : ∀ {Γ A} →
               (c : Γ ⊇ Γ) (M : Γ ⊢ A) →
               M ▶ π⟨ c ⟩ ≅ M
    conv₆≅ : ∀ {Γ Δ A B} →
               (M : Γ ⊢ A ⊃ B) (N : Γ ⊢ A) (γ : Δ ⋙ Γ) →
               (M ∙ N) ▶ γ ≅ (M ▶ γ) ∙ (N ▶ γ)
    conv₇≅ : ∀ {Γ Δ Θ A} →
               (M : Γ ⊢ A) (γ : Δ ⋙ Γ) (δ : Θ ⋙ Δ) →
               (M ▶ γ) ▶ δ ≅ M ▶ (γ ● δ)

  infix 3 _≅ₛ_
  data _≅ₛ_ : ∀ {Γ Δ} → Δ ⋙ Γ → Δ ⋙ Γ → Set where
    refl≅ₛ  : ∀ {Γ Δ} {γ : Δ ⋙ Γ} →
                γ ≅ₛ γ
    sym≅ₛ   : ∀ {Γ Δ} {γ γ′ : Δ ⋙ Γ} →
                γ ≅ₛ γ′ →
                γ′ ≅ₛ γ
    trans≅ₛ : ∀ {Γ Δ} {γ γ′ γ″ : Δ ⋙ Γ} →
                γ ≅ₛ γ′ → γ′ ≅ₛ γ″ →
                γ ≅ₛ γ″

    cong●≅ₛ : ∀ {Γ Δ Θ} {γ γ′ : Δ ⋙ Γ} {δ δ′ : Θ ⋙ Δ} →
                γ ≅ₛ γ′ → δ ≅ₛ δ′ →
                γ ● δ ≅ₛ γ′ ● δ′
    cong≔≅ₛ : ∀ {Γ Δ A x} {{_ : T (fresh x Γ)}} {γ γ′ : Δ ⋙ Γ} {M M′ : Δ ⊢ A} →
                γ ≅ₛ γ′ → M ≅ M′ →
                [ γ , x ≔ M ] ≅ₛ [ γ′ , x ≔ M′ ]

    conv₁≅ₛ : ∀ {Γ Δ Θ Ω} →
                (γ : Δ ⋙ Γ) (δ : Θ ⋙ Δ) (θ : Ω ⋙ Θ) →
                (γ ● δ) ● θ ≅ₛ γ ● (δ ● θ)
    conv₂≅ₛ : ∀ {Γ Δ Θ A x} {{_ : T (fresh x Γ)}} →
                (M : Δ ⊢ A) (γ : Δ ⋙ Γ) (δ : Θ ⋙ Δ) →
                [ γ , x ≔ M ] ● δ ≅ₛ [ γ ● δ , x ≔ M ▶ δ ]
    conv₃≅ₛ : ∀ {Γ Δ A x} {{_ : T (fresh x Γ)}} →
                (c : [ Γ , x ∷ A ] ⊇ Γ) (M : Δ ⊢ A) (γ : Δ ⋙ Γ) →
                π⟨ c ⟩ ● [ γ , x ≔ M ] ≅ₛ γ
    conv₄≅ₛ : ∀ {Γ Δ Θ} →
                (c : Θ ⊇ Γ) (c′ : Δ ⊇ Γ) (c″ : Θ ⊇ Δ) →
                π⟨ c′ ⟩ ● π⟨ c″ ⟩ ≅ₛ π⟨ c ⟩
    conv₅≅ₛ : ∀ {Γ Δ} →
                (c : Δ ⊇ Δ) (γ : Δ ⋙ Γ) →
                γ ● π⟨ c ⟩ ≅ₛ γ
    conv₆≅ₛ : ∀ {Γ} →
                (c : Γ ⊇ []) (γ : Γ ⋙ []) →
                γ ≅ₛ π⟨ c ⟩
    conv₇≅ₛ : ∀ {Γ Δ A x} {{_ : T (fresh x Γ)}} →
                (c : [ Γ , x ∷ A ] ⊇ Γ) (γ : Δ ⋙ [ Γ , x ∷ A ]) (i : [ Γ , x ∷ A ] ∋ x ∷ A) →
                γ ≅ₛ [ π⟨ c ⟩ ● γ , x ≔ ν x i ▶ γ ]

-- The first two `conv≅` rules correspond to the ordinary β- and η-rules, the next three define the effect
-- of substitutions and the last two rules can be seen as the correspondence of the η-rule for
-- substitutions.  The remaining `conv≅ₛ` rules define how the substitutions distribute.

module _ where
  ≡→≅ : ∀ {Γ A} {M M′ : Γ ⊢ A} → M ≡ M′ → M ≅ M′
  ≡→≅ refl = refl≅

  module ≅-Reasoning where
    infix 1 begin_
    begin_ : ∀ {Γ A} {M M′ : Γ ⊢ A} → M ≅ M′ → M ≅ M′
    begin p = p

    infixr 2 _≅⟨⟩_
    _≅⟨⟩_ : ∀ {Γ A} (M {M′} : Γ ⊢ A) → M ≅ M′ → M ≅ M′
    M ≅⟨⟩ p = p

    infixr 2 _≅⟨_⟩_
    _≅⟨_⟩_ : ∀ {Γ A} (M {M′ M″} : Γ ⊢ A) → M ≅ M′ → M′ ≅ M″ → M ≅ M″
    M ≅⟨ p ⟩ p′ = trans≅ p p′

    infixr 2 _≡⟨⟩_
    _≡⟨⟩_ : ∀ {Γ A} (M {M′} : Γ ⊢ A) → M ≅ M′ → M ≅ M′
    M ≡⟨⟩ p = p

    infixr 2 _≡⟨_⟩_
    _≡⟨_⟩_ : ∀ {Γ A} (M {M′ M″} : Γ ⊢ A) → M ≡ M′ → M′ ≅ M″ → M ≅ M″
    M ≡⟨ p ⟩ p′ = trans≅ (≡→≅ p) p′

    infix 3 _∎
    _∎ : ∀ {Γ A} (M : Γ ⊢ A) → M ≅ M
    M ∎ = refl≅

  ≡→≅ₛ : ∀ {Γ Δ} {γ γ′ : Δ ⋙ Γ} → γ ≡ γ′ → γ ≅ₛ γ′
  ≡→≅ₛ refl = refl≅ₛ

  module ≅ₛ-Reasoning where
    infix 1 begin_
    begin_ : ∀ {Γ Δ} {γ γ′ : Δ ⋙ Γ} → γ ≅ₛ γ′ → γ ≅ₛ γ′
    begin p = p

    infixr 2 _≅ₛ⟨⟩_
    _≅ₛ⟨⟩_ : ∀ {Γ Δ} (γ {γ′} : Δ ⋙ Γ) → γ ≅ₛ γ′ → γ ≅ₛ γ′
    γ ≅ₛ⟨⟩ p = p

    infixr 2 _≅ₛ⟨_⟩_
    _≅ₛ⟨_⟩_ : ∀ {Γ Δ} (γ {γ′ γ″} : Δ ⋙ Γ) → γ ≅ₛ γ′ → γ′ ≅ₛ γ″ → γ ≅ₛ γ″
    γ ≅ₛ⟨ p ⟩ p′ = trans≅ₛ p p′

    infixr 2 _≡⟨⟩_
    _≡⟨⟩_ : ∀ {Γ Δ} (γ {γ′} : Δ ⋙ Γ) → γ ≅ₛ γ′ → γ ≅ₛ γ′
    γ ≡⟨⟩ p = p

    infixr 2 _≡⟨_⟩_
    _≡⟨_⟩_ : ∀ {Γ Δ} (γ {γ′ γ″} : Δ ⋙ Γ) → γ ≡ γ′ → γ′ ≅ₛ γ″ → γ ≅ₛ γ″
    γ ≡⟨ p ⟩ p′ = trans≅ₛ (≡→≅ₛ p) p′

    infix 3 _∎
    _∎ : ∀ {Γ Δ} (γ : Δ ⋙ Γ) → γ ≅ₛ γ
    γ ∎ = refl≅ₛ


open import MJ.Types as Types
import MJ.Classtable.Core as Core

module MJ.Semantics.Values {c}(Ct : Core.Classtable c) where

open import Prelude

open import Level renaming (suc to lsuc; zero to lzero)
open import Data.List hiding (null)
open import Data.List.Membership.Propositional
open import Data.List.Prefix

open Core c
open Classtable Ct
open import MJ.Classtable.Membership Ct
open import MJ.LexicalScope c
open import Common.Weakening

{-
MJ inherits the values of STLC+Ref. In contrast to STCL+Ref, MJ also has
null-pointers; which we add as a constructor to our value type Val. The value
constructed by null is typed with an arbitrary reference type as it can be used
in place of any proper reference.
-}
data Val (W : World c) : Ty c → Set where
  num  : ℕ → Val W int
  unit : Val W void
  null : ∀ {C} → Val W (ref C)
  ref  : ∀ {C P} → (obj C) ∈ W → Σ ⊢ C <: P → Val W (ref P)

{-
We can construct default values out of thin air for every type
-}
default : ∀ {W} → (a : Ty c) → Val W a
default void = unit
default int = num 0
default (ref x) = null

{-
Value weakening
-}
weaken-val : ∀ {a}{W W' : World c} → W ⊒ W' → Val W' a → Val W a
weaken-val ext (num n) = num n
weaken-val ext unit = unit
weaken-val ext null = null
weaken-val ext (ref x sub) = ref (∈-⊒ x ext) sub

instance
  val-weakenable : ∀ {a} → Weakenable (λ W → Val W a)
  val-weakenable = record { wk = weaken-val }


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

-- There are really all 'private' sub-pieces of
-- Categories.Category.Monoidal.Closed.IsClosed, but that is taking
-- forever to typecheck, so the idea is to split things into pieces and
-- hope that that will help.

open import Categories.Category using (Category)
open import Categories.Category.Monoidal
open import Categories.Category.Monoidal.Closed using (Closed)

module Categories.Category.Monoidal.Closed.IsClosed.Identity
  {o ℓ e} {C : Category o ℓ e} {M : Monoidal C} (Cl : Closed M) where

open import Function using (_$_) renaming (_∘_ to _∙_)

open import Categories.Category.Monoidal.Utilities M
open import Categories.Morphism C using (Iso)
open import Categories.Morphism.Properties C using (Iso-resp-≈)
open import Categories.Morphism.Reasoning C using (pullʳ; pullˡ; pushˡ; cancelʳ)
open import Categories.Functor using (Functor) renaming (id to idF)
open import Categories.Functor.Bifunctor
open import Categories.Functor.Bifunctor.Properties
open import Categories.NaturalTransformation hiding (id)
open import Categories.NaturalTransformation.Dinatural
  using (Extranaturalʳ; extranaturalʳ; DinaturalTransformation)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism)
import Categories.Category.Closed as Cls

open Closed Cl
open Category C       -- most of it is used

open HomReasoning
open adjoint renaming (unit to η; counit to ε; Ladjunct to 𝕃)

private
  λ⇒ = unitorˡ.from
  λ⇐ = unitorˡ.to
  ρ⇒ = unitorʳ.from
  ρ⇐ = unitorʳ.to

identity : NaturalIsomorphism idF [ unit ,-]
identity = record
  { F⇒G = F∘id⇒F ∘ᵥ ([ unit ,-] ∘ˡ (unitorʳ-natural.F⇒G)) ∘ᵥ η
  ; F⇐G = ε ∘ᵥ (unitorʳ-natural.F⇐G ∘ʳ [ unit ,-]) ∘ᵥ F⇒id∘F
  ; iso = λ X → Iso-resp-≈ (iso X) (⟺ identityˡ) (⟺ (∘-resp-≈ʳ identityʳ))
  }
  where
  open Functor
  iso : ∀ X → Iso (𝕃 unitorʳ.from) (ε.η X ∘ unitorʳ.to)
  iso X = record
    { isoˡ = begin
      (ε.η X ∘ ρ⇐) ∘ 𝕃 ρ⇒      ≈⟨ pullʳ unitorʳ-commute-to ⟩
      ε.η X ∘ 𝕃 ρ⇒ ⊗₁ id ∘ ρ⇐  ≈˘⟨ assoc ⟩
      Radjunct (𝕃 ρ⇒) ∘ ρ⇐     ≈⟨ RLadjunct≈id ⟩∘⟨refl ⟩
      ρ⇒ ∘ ρ⇐                  ≈⟨ unitorʳ.isoʳ ⟩
      id                       ∎
    ; isoʳ = begin
      𝕃 ρ⇒ ∘ ε.η X ∘ ρ⇐                      ≈⟨ pullʳ (η.commute _) ⟩
      [ id , ρ⇒ ]₁ ∘ 𝕃 ((ε.η X ∘ ρ⇐) ⊗₁ id) ≈˘⟨ pushˡ (homomorphism [ unit ,-]) ⟩
      𝕃 (ρ⇒ ∘ (ε.η X ∘ ρ⇐) ⊗₁ id)           ≈⟨ F-resp-≈ [ unit ,-] unitorʳ-commute-from ⟩∘⟨refl ⟩
      𝕃 ((ε.η X ∘ ρ⇐) ∘ ρ⇒)                 ≈⟨ F-resp-≈ [ unit ,-] (cancelʳ unitorʳ.isoˡ) ⟩∘⟨refl ⟩
      𝕃 (ε.η X)                              ≈⟨ zag ⟩
      id                                     ∎
    }

module identity = NaturalIsomorphism identity

diagonal : Extranaturalʳ unit [-,-]
diagonal = extranaturalʳ (λ X → 𝕃 λ⇒)
  $ λ {X Y f} → begin
    [ id , f ]₁ ∘ 𝕃 λ⇒                             ≈˘⟨ pushˡ (homomorphism [ X ,-]) ⟩
    [ id , f ∘ λ⇒ ]₁ ∘ η.η unit                    ≈˘⟨ F-resp-≈ [ X ,-] unitorˡ-commute-from ⟩∘⟨refl ⟩
    [ id , λ⇒ ∘ id ⊗₁ f ]₁ ∘ η.η unit              ≈⟨ homomorphism [ X ,-] ⟩∘⟨refl ⟩
    ([ id , λ⇒ ]₁ ∘ [ id , id ⊗₁ f ]₁) ∘ η.η unit  ≈⟨ pullʳ (mate.commute₁ f) ⟩
    [ id , λ⇒ ]₁ ∘ [ f , id ]₁ ∘ η.η unit          ≈⟨ pullˡ [ [-,-] ]-commute ⟩
    ([ f , id ]₁ ∘ [ id , λ⇒ ]₁) ∘ η.η unit        ≈⟨ assoc ⟩
    [ f , id ]₁ ∘ 𝕃 λ⇒                             ∎
  where open Functor

module diagonal = DinaturalTransformation diagonal


module Section8 where

open import Section7 public

-- 8. Correctness of conversion between terms
-- ==========================================
--
-- The conversion rules for terms are sound:

-- Theorem 9.
postulate
  thm₉ : ∀ {Γ A t₀ t₁} →
           (M N : Γ ⊢ A) → t₀ 𝒟 M → t₁ 𝒟 N → Γ ⊢ t₀ ≊ t₁ ∷ A →
           M ≅ N

-- Proof: The proof is by induction on the proof of `Γ ⊢ t₀ ≊ t₁ ∷ A`.  We illustrate the proof
-- with the reflexivity case.  In this case we have that `t₀` and `t₁` are the same, hence by Corollary 3
-- we get `M ≅ N`.
--
-- To prove that the conversion rules are complete
-- is straightforward by induction on the proof of `M ≅ N`.

-- Theorem 10.
postulate
  thm₁₀ : ∀ {Γ A} →
            (M N : Γ ⊢ A) → M ≅ N →
            Γ ⊢ M ⁻ ≊ N ⁻ ∷ A


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

module Examples where

-- Sequential
import Examples.Id
import Examples.Gcd
import Examples.Queue

-- Parallel
import Examples.TreeSum
import Examples.Exp2

-- Hybrid
import Examples.Sorting


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

open import Categories.Category.Core using (Category)

module Categories.Category.BicartesianClosed {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level

open import Categories.Category.CartesianClosed 𝒞
open import Categories.Category.Cocartesian 𝒞

record BicartesianClosed : Set (levelOfTerm 𝒞) where
  field
    cartesianClosed : CartesianClosed
    cocartesian     : Cocartesian


-- Andreas, 2016-02-04
-- Printing of overapplied operator patterns

-- Expected results see comments.

_fun : (A : Set) → Set
_fun = {!!}
-- C-c C-c RET gives
--
-- A fun = ?

_nofun : (A : Set₁) (B : Set₁) → Set₁
_nofun = {!!}
-- C-c C-c RET gives
--
-- (A nofun) B = ?

module Works where

  record Safe : Set₁ where
    field <_>safe : Set
  open Safe

  mixfix : Safe
  mixfix = {!!}
  -- C-c C-c RET gives
  --
  --   < mixfix >safe

record Safe : Set₁ where
  field <_>safe : Set → Set
open Safe

mixfix : Safe
mixfix = {! !}
-- C-c C-c RET gives
--
--   < mixfix >safe x

_+_ : (A B C : Set) → Set
_+_ = {!!}
-- C-c C-c RET gives
--
--   (A + B) C = ?

-_ : (A B : Set) →  Set
-_ = {!!}
-- C-c C-c RET gives
--
--   (- A) B = ?

data D : Set where
  _*_ : (x y z : D) → D

splitP : D → D
splitP d = {! d!}
-- C-c C-c [d RET] gives
--
--   splitP ((d * d₁) d₂) = ?


-- The "intro" command manages to refine goals of type ∞ A with the
-- term ♯ ?.

{-# OPTIONS --universe-polymorphism #-}

module IntroSharp where

postulate
  Level : Set
  zero : Level
  suc  : (i : Level) → Level
  _⊔_ : Level -> Level -> Level

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

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

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

Foo : ∞ Set
Foo = ?


{-# OPTIONS --without-K --safe #-}
module Util.HoTT.Equiv.Core where

open import Util.Prelude
open import Util.HoTT.HLevel.Core

infix 4 _≅_ _≃_

private
  variable
    α β γ : Level
    A B C : Set α

Injective : (f : A → B) → Set _
Injective f = ∀ {x y} → f x ≡ f y → x ≡ y

record IsIso {A : Set α} {B : Set β} (forth : A → B) : Set (α ⊔ℓ β)
  where
  field
    back : B → A
    back∘forth : ∀ x → back (forth x) ≡ x
    forth∘back : ∀ x → forth (back x) ≡ x

record _≅_ (A : Set α) (B : Set β) : Set (α ⊔ℓ β) where
  field
    forth : A → B
    isIso : IsIso forth

  open IsIso isIso public

open _≅_ public

IsEquiv : {A : Set α} {B : Set β} (forth : A → B)
  → Set (α ⊔ℓ β)
IsEquiv {A = A} {B} forth
  = ∀ b → IsContr (Σ[ a ∈ A ] forth a ≡ b)

record _≃_ (A : Set α) (B : Set β) : Set (α ⊔ℓ β) where
  field
    forth : A → B
    isEquiv : IsEquiv forth

open _≃_ public


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

-- | Exclusive option for predicates
module Dodo.Unary.XOpt where

-- Stdlib imports
open import Level using (Level)
open import Relation.Unary using (Pred)
-- Local imports
open import Dodo.Nullary.XOpt

-- # XOpt₂

XOptPred₂ : {a ℓ₁ ℓ₂ : Level} {A : Set a} → Pred A ℓ₁ → Pred A ℓ₂ → Set _
XOptPred₂ {A = A} P Q = ∀ (x : A) → XOpt₂ (P x) (Q x)

-- # XOpt₃

XOptPred₃ : {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} → Pred A ℓ₁ → Pred A ℓ₂ → Pred A ℓ₃ → Set _
XOptPred₃ {A = A} P Q R = ∀ (x : A) → XOpt₃ (P x) (Q x) (R x)


------------------------------------------------------------------------
-- The semantics is deterministic
------------------------------------------------------------------------

open import Atom

module Deterministic (atoms : χ-atoms) where

open import Equality.Propositional
open import Prelude hiding (const)
open import Tactic.By.Propositional

open import Chi atoms

open χ-atoms atoms

Lookup-deterministic :
  ∀ {c₁ c₂ bs xs₁ xs₂ e₁ e₂} →
  Lookup c₁ bs xs₁ e₁ → Lookup c₂ bs xs₂ e₂ →
  c₁ ≡ c₂ → xs₁ ≡ xs₂ × e₁ ≡ e₂
Lookup-deterministic here          here          _    = refl , refl
Lookup-deterministic here          (there q _)   refl = ⊥-elim (q refl)
Lookup-deterministic (there p _)   here          refl = ⊥-elim (p refl)
Lookup-deterministic (there p₁ p₂) (there q₁ q₂) refl =
  Lookup-deterministic p₂ q₂ refl

↦-deterministic :
  ∀ {e xs es e₁ e₂} →
  e [ xs ← es ]↦ e₁ → e [ xs ← es ]↦ e₂ → e₁ ≡ e₂
↦-deterministic []    []    = refl
↦-deterministic (∷ p) (∷ q) = by (↦-deterministic p q)

mutual

  ⇓-deterministic : ∀ {e v₁ v₂} → e ⇓ v₁ → e ⇓ v₂ → v₁ ≡ v₂
  ⇓-deterministic (apply p₁ p₂ p₃) (apply q₁ q₂ q₃)
    with ⇓-deterministic p₁ q₁ | ⇓-deterministic p₂ q₂
  ... | refl | refl = ⇓-deterministic p₃ q₃

  ⇓-deterministic (case p₁ p₂ p₃ p₄) (case q₁ q₂ q₃ q₄)
    with ⇓-deterministic p₁ q₁
  ... | refl with Lookup-deterministic p₂ q₂ refl
  ...   | refl , refl rewrite ↦-deterministic p₃ q₃ =
    ⇓-deterministic p₄ q₄

  ⇓-deterministic (rec p)    (rec q)    = ⇓-deterministic p q
  ⇓-deterministic lambda     lambda     = refl
  ⇓-deterministic (const ps) (const qs) = by (⇓⋆-deterministic ps qs)

  ⇓⋆-deterministic : ∀ {es vs₁ vs₂} → es ⇓⋆ vs₁ → es ⇓⋆ vs₂ → vs₁ ≡ vs₂
  ⇓⋆-deterministic []       []       = refl
  ⇓⋆-deterministic (p ∷ ps) (q ∷ qs) =
    cong₂ _∷_ (⇓-deterministic p q) (⇓⋆-deterministic ps qs)


{-# OPTIONS --without-K #-}
module sets.nat.ordering.leq where

open import sets.nat.ordering.leq.core public
open import sets.nat.ordering.leq.level public
open import sets.nat.ordering.leq.decide public


open import Agda.Primitive using (lzero; lsuc; _⊔_; Level)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst)
open import Relation.Binary using (Setoid)

-- A formalization of raw syntax

module Syntax where

  -- Syntactic classes

  data ObjectClass : Set where
    Ty Tm : ObjectClass

  data Class : Set where
    obj : ObjectClass → Class
    EqTy EqTm : Class

  -- Variable context shape

  infixl 6 _⊕_

  data VShape : Set where
    𝟘 : VShape
    𝟙 : VShape
    _⊕_ : VShape → VShape → VShape

  data var : VShape → Set where
    var-here : var 𝟙
    var-left : ∀ {γ δ} → var γ → var (γ ⊕ δ)
    var-right : ∀ {γ δ} → var δ → var (γ ⊕ δ)

  -- Metavariable context shapes

  infixl 9 _⊕ᵐᵛ_

  data MShape : Set where
    𝟘ᵐᵛ : MShape
    𝟙ᵐᵛ : ∀ (cl : Class) (γ : VShape) → MShape
    _⊕ᵐᵛ_ : MShape → MShape → MShape

  infix 8 [_,_]∈_

  data [_,_]∈_ : Class → VShape → MShape → Set where
    mv-here : ∀ cl γ → [ cl , γ ]∈ 𝟙ᵐᵛ cl γ
    mv-left : ∀ {𝕂 𝕄} cl γ → [ cl , γ ]∈ 𝕂 → [ cl , γ ]∈ 𝕂 ⊕ᵐᵛ 𝕄
    mv-right : ∀ {𝕂 𝕄} cl γ → [ cl , γ ]∈ 𝕄 → [ cl , γ ]∈ 𝕂 ⊕ᵐᵛ 𝕄

  -- Symbol signature

  record Signature : Set₁ where
    field
      symb : ObjectClass → Set -- a set of symbol names, one for each class
      symb-arg : ∀ {cl} → symb cl → MShape

  -- Expressions

  module Expression (𝕊 : Signature) where
    open Signature 𝕊

    data Expr : Class → (𝕄 : MShape) → (γ : VShape) → Set

    Arg : ∀ (cl : Class) (𝕄 : MShape) (γ : VShape) (δ : VShape) → Set
    Arg cl 𝕄 γ δ = Expr cl 𝕄 (γ ⊕ δ)

    ExprObj : ∀ (cl : ObjectClass) (𝕄 : MShape) (γ : VShape) → Set
    ExprObj cl = Expr (obj cl)

    ExprTm = ExprObj Tm
    ExprTy = ExprObj Ty

    data Expr where
      expr-var : ∀ {𝕄} {γ} (x : var γ) → ExprTm 𝕄 γ
      expr-symb : ∀ {cl 𝕄 γ} (S : symb cl) →
                    (es : ∀ {clⁱ γⁱ} (i : [ clⁱ , γⁱ ]∈ symb-arg S) → Arg clⁱ 𝕄 γ γⁱ) →
                    ExprObj cl 𝕄 γ
      expr-meta : ∀ {cl 𝕄 γ} {γᴹ} (M : [ obj cl , γᴹ ]∈ 𝕄) → (ts : ∀ (i : var γᴹ) → ExprTm 𝕄 γ) → ExprObj cl 𝕄 γ
      expr-eqty : ∀ {γ} {𝕄} → Expr EqTy 𝕄 γ
      expr-eqtm : ∀ {γ} {𝕄} → Expr EqTm 𝕄 γ

    expr-meta-generic : ∀ {𝕄} {cl} {γ γᴹ} (M : [ cl , γᴹ ]∈ 𝕄) → Arg cl 𝕄 γ γᴹ
    expr-meta-generic {cl = obj _} M = expr-meta M (λ i → expr-var (var-right i))
    expr-meta-generic {cl = EqTy} M = expr-eqty
    expr-meta-generic {cl = EqTm} M = expr-eqtm

  -- Syntactic equality

  module Equality {𝕊 : Signature} where

    open Signature 𝕊
    open Expression 𝕊

    infix 4 _≈_

    data _≈_ : ∀ {cl 𝕄 γ} → Expr cl 𝕄 γ → Expr cl 𝕄 γ → Set where
      ≈-≡ : ∀ {cl 𝕄 γ} {t u : Expr cl 𝕄 γ} (ξ : t ≡ u) → t ≈ u
      ≈-symb : ∀ {cl 𝕄 γ} {S : symb cl} →
                {ds es : ∀ {cⁱ γⁱ} (i : [ cⁱ , γⁱ ]∈ symb-arg S) → Arg cⁱ 𝕄 γ γⁱ}
                (ξ : ∀ {cⁱ γⁱ} (i : [ cⁱ , γⁱ ]∈ symb-arg S) → ds i ≈ es i) → expr-symb S ds ≈ expr-symb S es
      ≈-meta : ∀ {cl 𝕄 γ} {γᴹ} {M : [ obj cl , γᴹ ]∈ 𝕄} → {ts us : ∀ (i : var γᴹ) → ExprTm 𝕄 γ}
                (ξ : ∀ i → ts i ≈ us i) → expr-meta M ts ≈ expr-meta M us

    ≈-refl : ∀ {cl 𝕄 γ} {t : Expr cl 𝕄 γ} → t ≈ t
    ≈-refl = ≈-≡ refl

    ≈-eqty : ∀ {𝕄 γ} {s t : Expr EqTy 𝕄  γ} → s ≈ t
    ≈-eqty {s = expr-eqty} {t = expr-eqty} = ≈-refl

    ≈-eqtm : ∀ {𝕄 γ} {s t : Expr EqTm 𝕄 γ} → s ≈ t
    ≈-eqtm {s = expr-eqtm} {t = expr-eqtm} = ≈-refl

    ≈-sym : ∀ {cl 𝕄 γ} {t u : Expr cl 𝕄 γ} → t ≈ u → u ≈ t
    ≈-sym (≈-≡ refl) = ≈-≡ refl
    ≈-sym (≈-symb ε) = ≈-symb (λ i → ≈-sym (ε i))
    ≈-sym (≈-meta ε) = ≈-meta (λ i → ≈-sym (ε i))

    ≈-trans : ∀ {cl 𝕄 γ} {t u v : Expr cl 𝕄 γ} → t ≈ u → u ≈ v → t ≈ v
    ≈-trans (≈-≡ refl) ξ = ξ
    ≈-trans (≈-symb ζ) (≈-≡ refl) = ≈-symb ζ
    ≈-trans (≈-symb ζ) (≈-symb ξ) = ≈-symb (λ i → ≈-trans (ζ i) (ξ i))
    ≈-trans (≈-meta ζ) (≈-≡ refl) = ≈-meta ζ
    ≈-trans (≈-meta ζ) (≈-meta ξ) = ≈-meta (λ i → ≈-trans (ζ i) (ξ i))

    -- the setoid of expressions

    Expr-setoid : ∀ (cl : Class) (𝕄 : MShape) (γ : VShape) →  Setoid lzero lzero
    Expr-setoid cl 𝕄 γ =
      record
        { Carrier =  Expr cl 𝕄 γ
        ; _≈_ = _≈_
        ; isEquivalence = record { refl = ≈-refl ; sym = ≈-sym ; trans = ≈-trans }
        }

  infix 4 _%_≈_

  _%_≈_ : ∀ (𝕊 : Signature) {cl 𝕄 γ} → (t u : Expression.Expr 𝕊 cl 𝕄 γ) → Set
  _%_≈_ 𝕊 = Equality._≈_ {𝕊 = 𝕊}


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

open import HoTT
open import homotopy.elims.Lemmas
open import homotopy.elims.CofPushoutSection

module homotopy.elims.SuspSmash {i j k} {X : Ptd i} {Y : Ptd j}
  {P : Suspension (X ∧ Y) → Type k}
  (north* : P north) (south* : P south)
  (cod* : (s : fst X × fst Y) → north* == south* [ P ↓ merid (cfcod s) ])
  where

private
  base* = transport (λ κ → north* == south* [ P ↓ merid κ ])
    (! (cfglue (winl (snd X))))
    (cod* (snd X , snd Y))

  coh* : (s : X ∧ Y) → north* == south* [ P ↓ merid s ]
  coh* = CofPushoutSection.elim (λ _ → tt) (λ _ → idp)
    base*
    (λ {(x , y) →
      (fst (fillX x) ∙ fst (fillY y)) ◃ fst fill0 ◃ cod* (x , y)})
    (↓↓-from-squareover ∘ λ x →
      snd (fillX x) ↓⊡h∙
      ap (λ p → p ◃ fst fill0 ◃ cod* (x , snd Y))
         (! (ap (λ q → fst (fillX x) ∙ q) fillY-lemma ∙ ∙-unit-r _)))
    (↓↓-from-squareover ∘ λ y →
      snd (fillY y) ↓⊡h∙
      ap (λ p → p ◃ fst fill0 ◃ cod* (snd X , y))
         (! (ap (λ q → q ∙ fst (fillY y)) fillX-lemma)))
    where
    fill-lemma : (w : X ∨ Y)
      (α : north* == south* [ P ↓ merid (cfcod (∨-in-× X Y w)) ])
      → Σ (north* == north*)
          (λ p → SquareOver P (natural-square merid (cfglue w))
                   base*
                   (↓-ap-in _ _ (apd (λ _ → north*) (cfglue w)))
                   (↓-ap-in _ _ (apd (λ _ → south*) (cfglue w)))
                   (p ◃ α))
    fill-lemma w α = fill-upper-right _ _ _ _ _

    fill0 = fill-lemma (winl (snd X)) (cod* (snd X , snd Y))
    fillX = λ x → fill-lemma (winl x) (fst fill0 ◃ cod* (x , snd Y))
    fillY = λ y → fill-lemma (winr y) (fst fill0 ◃ cod* (snd X , y))

    fillX-lemma : fst (fillX (snd X)) == idp
    fillX-lemma = ! $
      fill-upper-right-unique _ _ _ _ _ idp (snd fill0 ↓⊡h∙ ! (idp◃ _))

    fillY-lemma : fst (fillY (snd Y)) == idp
    fillY-lemma = ! $
      fill-upper-right-unique _ _ _ _ _ idp (snd fill0 ↓⊡h∙ ! (idp◃ _))
      ∙ ap (λ w → fst (fill-lemma w (fst fill0 ◃ cod* (∨-in-× X Y w))))
           wglue

susp-smash-elim : Π (Suspension (X ∧ Y)) P
susp-smash-elim = Suspension-elim north* south* coh*


------------------------------------------------------------------------
-- The Agda standard library
--
-- Decidable setoid membership over lists
------------------------------------------------------------------------

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

open import Relation.Binary using (Decidable; DecSetoid)

module Data.List.Membership.DecSetoid {a ℓ} (DS : DecSetoid a ℓ) where

open import Data.List.Relation.Unary.Any using (any)
open DecSetoid DS

------------------------------------------------------------------------
-- Re-export contents of propositional membership

open import Data.List.Membership.Setoid (DecSetoid.setoid DS) public

------------------------------------------------------------------------
-- Other operations

infix 4 _∈?_

_∈?_ : Decidable _∈_
x ∈? xs = any (x ≟_) xs


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

open import HoTT

module groups.Image where

module _ {i j k} {G : Group i} {H : Group j}
  {K : Group k} (φ : H →ᴳ K) (ψ : G →ᴳ H) where

  abstract
    im-sub-im-∘ : is-surjᴳ ψ → im-propᴳ φ ⊆ᴳ im-propᴳ (φ ∘ᴳ ψ)
    im-sub-im-∘ ψ-is-surj k = Trunc-rec Trunc-level
      (λ{(h , φh=k) → Trunc-rec Trunc-level
        (λ{(g , ψg=h) → [ g , ap (GroupHom.f φ) ψg=h ∙ φh=k ]})
        (ψ-is-surj h)})

    im-∘-sub-im : im-propᴳ (φ ∘ᴳ ψ) ⊆ᴳ im-propᴳ φ
    im-∘-sub-im k = Trunc-rec Trunc-level
      (λ{(g , φψg=k) → [ GroupHom.f ψ g , φψg=k ]})

  im-iso-im-pre∘ : is-surjᴳ ψ → Im φ ≃ᴳ Im (φ ∘ᴳ ψ)
  im-iso-im-pre∘ ψ-is-surj = Subgroup-emap-r
    (im-propᴳ φ) (im-propᴳ (φ ∘ᴳ ψ))
    (im-sub-im-∘ ψ-is-surj) im-∘-sub-im


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

-- A Monad in a Bicategory.
-- For the more elementary version of Monads, see 'Categories.Monad'.
module Categories.Bicategory.Monad where

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

open import Categories.Bicategory
import Categories.Bicategory.Extras as Bicat
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism)

record Monad {o ℓ e t} (𝒞 : Bicategory o ℓ e t) : Set (o ⊔ ℓ ⊔ e ⊔ t) where
  open Bicat 𝒞

  field
    C : Obj
    T : C ⇒₁ C
    η : id₁ ⇒₂ T
    μ : (T ⊚₀ T) ⇒₂ T

    assoc     : μ ∘ᵥ (T ▷ μ) ∘ᵥ associator.from ≈ (μ ∘ᵥ (μ ◁ T))
    sym-assoc : μ ∘ᵥ (μ ◁ T) ∘ᵥ associator.to ≈ (μ ∘ᵥ (T ▷ μ))
    identityˡ : μ ∘ᵥ (T ▷ η) ∘ᵥ unitorʳ.to ≈ id₂
    identityʳ : μ ∘ᵥ (η ◁ T) ∘ᵥ unitorˡ.to ≈ id₂


-- Forced constructor arguments don't count towards the size of the datatype
-- (only if not --withoutK).

data _≡_ {a} {A : Set a} : A → A → Set where
  refl : ∀ x → x ≡ x

data Singleton {a} {A : Set a} : A → Set where
  [_] : ∀ x → Singleton x


module Implicits.Syntax.Type.Constructors where

open import Prelude
open import Implicits.Syntax.Type
open import Implicits.Substitutions
open TypeSubst

-- polymorphic identity
tid : ∀ {n} → Type n
tid = ∀' (simpl ((TVar zero) →' (TVar zero)))

-- type of bools encoding
tbool : Type 0
tbool = ∀' (simpl ((TVar zero) →' (simpl ((TVar zero) →' (TVar zero)))))

-- church numerals
tnat : Type 0
tnat = ∀' (simpl ((simpl ((TVar zero) →' (TVar zero))) →' (simpl ((TVar zero) →' (TVar zero)))))

-- existential quantification
∃' : ∀ {n} → (Type (suc n)) → Type n
∃' a = ∀' (∀' (simpl ((a tp/tp (wk ↑)) →' (simpl ((TVar (suc zero)) →' (TVar zero))))))

-- unit type
⊤' : ∀ {n} → Type n
⊤' = tid

-- zero type
⊥' : ∀ {n} → Type n
⊥' = ∀' (TVar zero)

-- n-ary function type
infixr 7 _→ⁿ_
_→ⁿ_ : ∀ {n k} → Vec (Type n) k → Type n → Type n
[]       →ⁿ z = z
(a ∷ as) →ⁿ z = as →ⁿ (simpl (a →' z))

-- Record/finite tuple
rec : ∀ {n k} → Vec (Type n) k → Type n
rec []       = ⊤'
rec (a ∷ as) = ∀' (simpl ((map tp-weaken (a ∷ as) →ⁿ TVar zero) →' TVar zero))

-- tuple
_×'_ : ∀ {n} → Type n → Type n → Type n
a ×' b = rec (a ∷ b ∷ [])


------------------------------------------------------------------------
-- The Agda standard library
--
-- Sublist-related properties
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Sublist.Propositional.Properties {a} {A : Set a} where

open import Data.List using (map)
open import Data.List.Relation.Unary.Any using (Any; here; there)
open import Data.List.Relation.Unary.Any.Properties using (here-injective; there-injective)
open import Data.List.Relation.Binary.Sublist.Propositional
  hiding (map)
import Data.List.Relation.Binary.Sublist.Setoid.Properties
  as SetoidProperties
open import Function
open import Relation.Binary.PropositionalEquality as P hiding ([_])
open import Relation.Unary as U using (Pred)

------------------------------------------------------------------------
-- Re-exporting setoid properties

open SetoidProperties (P.setoid A) public
  hiding (map⁺)

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

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

  map⁺ : ∀ {as bs} (f : A → B) → as ⊆ bs → map f as ⊆ map f bs
  map⁺ f = SetoidProperties.map⁺ (setoid A) (setoid B) (cong f)

------------------------------------------------------------------------
-- The `lookup` function induced by a proof that `xs ⊆ ys` is injective

module _ {p} {P : Pred A p} where

  lookup-injective : ∀ {xs ys} {p : xs ⊆ ys} {v w : Any P xs} →
                     lookup p v ≡ lookup p w → v ≡ w
  lookup-injective {p = []}       {}
  lookup-injective {p = _   ∷ʳ _} {v}       {w}       =
    lookup-injective ∘′ there-injective
  lookup-injective {p = x≡y ∷ _}  {here pv} {here pw} =
    cong here ∘′ subst-injective x≡y ∘′ here-injective
  lookup-injective {p = _ ∷ _}    {there v} {there w} =
    cong there ∘′ lookup-injective ∘′ there-injective
  lookup-injective {p = _ ∷ _}    {here  _} {there _} ()
  lookup-injective {p = _ ∷ _}    {there _} {here  _} ()


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

module Cubical.Algebra.Group.Action where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Structure
open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Morphism
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Notation
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Structures.LeftAction
open import Cubical.Structures.Axioms
open import Cubical.Structures.Macro
open import Cubical.Structures.Auto
open import Cubical.Data.Sigma

private
  variable
    ℓ ℓ' : Level

record IsGroupAction (G : Group {ℓ = ℓ})
                     (H : Group {ℓ = ℓ'})
                     (_α_ : LeftActionStructure ⟨ G ⟩ ⟨ H ⟩) : Type (ℓ-max ℓ ℓ') where

  constructor isgroupaction

  open GroupNotationG G

  field
    isHom : (g : ⟨ G ⟩) → isGroupHom H H (g α_)
    identity : (h : ⟨ H ⟩) → 0ᴳ α h ≡ h
    assoc : (g g' : ⟨ G ⟩) → (h : ⟨ H ⟩) → (g +ᴳ g') α h ≡ g α (g' α h)

record GroupAction (G : Group {ℓ}) (H : Group {ℓ'}): Type (ℓ-suc (ℓ-max ℓ ℓ')) where

  constructor groupaction

  field
    _α_ : LeftActionStructure ⟨ G ⟩ ⟨ H ⟩
    isGroupAction : IsGroupAction G H _α_

module ActionΣTheory {ℓ ℓ' : Level} where

  module _ (G : Group {ℓ}) (H : Group {ℓ'}) (_α_ : LeftActionStructure ⟨ G ⟩ ⟨ H ⟩) where

    open GroupNotationG G

    IsGroupActionΣ : Type (ℓ-max ℓ ℓ')
    IsGroupActionΣ = ((g : ⟨ G ⟩) → isGroupHom H H (g α_))
                         × ((h : ⟨ H ⟩) → 0ᴳ α h ≡ h)
                         × ((g g' : ⟨ G ⟩) → (h : ⟨ H ⟩) → (g +ᴳ g') α h ≡ g α (g' α h))

    isPropIsGroupActionΣ : isProp IsGroupActionΣ
    isPropIsGroupActionΣ = isPropΣ isPropIsHom λ _ → isPropΣ isPropIdentity λ _ → isPropAssoc
      where
        isPropIsHom = isPropΠ (λ g → isPropIsGroupHom H H)
        isPropIdentity = isPropΠ (λ h → GroupStr.is-set (snd H) (0ᴳ α h) h)
        isPropAssoc = isPropΠ3 (λ g g' h → GroupStr.is-set (snd H) ((g +ᴳ g') α h) (g α (g' α h)))

    IsGroupAction→IsGroupActionΣ : IsGroupAction G H _α_ → IsGroupActionΣ
    IsGroupAction→IsGroupActionΣ (isgroupaction isHom identity assoc) = isHom , identity , assoc

    IsGroupActionΣ→IsGroupAction : IsGroupActionΣ → IsGroupAction G H _α_
    IsGroupActionΣ→IsGroupAction (isHom , identity , assoc) = isgroupaction isHom identity assoc

    IsGroupActionΣIso : Iso (IsGroupAction G H _α_) IsGroupActionΣ
    Iso.fun IsGroupActionΣIso = IsGroupAction→IsGroupActionΣ
    Iso.inv IsGroupActionΣIso = IsGroupActionΣ→IsGroupAction
    Iso.rightInv IsGroupActionΣIso = λ _ → refl
    Iso.leftInv IsGroupActionΣIso = λ _ → refl

open ActionΣTheory

isPropIsGroupAction : {ℓ ℓ' : Level }
                      (G : Group {ℓ}) (H : Group {ℓ'})
                      (_α_ : LeftActionStructure ⟨ G ⟩ ⟨ H ⟩)
                      → isProp (IsGroupAction G H _α_)
isPropIsGroupAction G H _α_ = isOfHLevelRespectEquiv 1
                                                     (invEquiv (isoToEquiv (IsGroupActionΣIso G H _α_)))
                                                     (isPropIsGroupActionΣ G H _α_)

module ActionNotationα {N : Group {ℓ}} {H : Group {ℓ'}} (Act : GroupAction H N) where
  _α_ = GroupAction._α_ Act
  private
    isGroupAction = GroupAction.isGroupAction Act
  α-id = IsGroupAction.identity isGroupAction
  α-hom = IsGroupAction.isHom isGroupAction
  α-assoc = IsGroupAction.assoc isGroupAction

module ActionLemmas {G : Group {ℓ}} {H : Group {ℓ'}} (Act : GroupAction G H) where
  open ActionNotationα {N = H} {H = G} Act
  open GroupNotationᴴ H
  open GroupNotationG G
  open MorphismLemmas {G = H} {H = H}
  open GroupLemmas

  abstract
    actOnUnit : (g : ⟨ G ⟩) → g α 0ᴴ ≡ 0ᴴ
    actOnUnit g = mapId (grouphom (g α_) (α-hom g))

    actOn-Unit : (g : ⟨ G ⟩) → g α (-ᴴ 0ᴴ) ≡ 0ᴴ
    actOn-Unit g = (cong (g α_) (invId H)) ∙ actOnUnit g

    actOn- : (g : ⟨ G ⟩) (h : ⟨ H ⟩) → g α (-ᴴ h) ≡ -ᴴ (g α h)
    actOn- g h = mapInv (grouphom (g α_) (α-hom g)) h

    -idAct : (h : ⟨ H ⟩) → (-ᴳ 0ᴳ) α h ≡ h
    -idAct h = (cong (_α h) (invId G)) ∙ (α-id h)

-- Examples
-- left adjoint action of a group on a normal subgroup


-- Andreas, 2015-07-18
-- Postpone checking of record expressions when type is blocked.
-- Guess type of record expressions when type is blocked.

open import Common.Product
open import Common.Prelude
open import Common.Equality

T : Bool → Set
T true  = Bool × Nat
T false = ⊥

works : (P : ∀{b} → b ≡ true → T b → Set) → Set
works P = P refl record{ proj₁ = true; proj₂ = 0 }

-- Guess or postpone.
test : (P : ∀{b} → T b → b ≡ true → Set) → Set
test P = P record{ proj₁ = true; proj₂ = 0 } refl

guess : (P : ∀{b} → T b → Set) → Set
guess P = P record{ proj₁ = true; proj₂ = 0 }

record R : Set where
  field
    f : Bool

record S : Set where
  field
    f : Bool

U : Bool → Set
U true = R
U false = S

postpone : (P : ∀{b} → U b → b ≡ true → Set) → Set
postpone P = P record{ f = false } refl

-- ambiguous : (P : ∀{b} → U b → Set) → Set
-- ambiguous P = P record{ f = false }