module Sigma.Renaming.Properties where

open import Data.Nat using (ℕ; _+_; zero; suc)
open import Data.Fin using (Fin; zero; suc)

open import Sigma.Subst.Core
open import Sigma.Renaming.Base

open import Sigma.Subst.Properties using (extensionality)

open import Function using (_∘_)

open import Relation.Binary.PropositionalEquality as Eq
  using (_≡_; refl; cong; cong₂)
open Eq.≡-Reasoning

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

⇑-cong : ∀ { m n } { ρ₁ ρ₂ : Ren m n }
  → ρ₁ ≡ ρ₂
  -- -----------
  → ρ₁ ⇑ ≡ ρ₂ ⇑
⇑-cong ρ₁≡ρ₂ = cong (_⇑) ρ₁≡ρ₂

⇑✶-cong : ∀ { m n } k { ρ₁ ρ₂ : Ren m n }
  → ρ₁ ≡ ρ₂
  -- -----------
  → ρ₁ ⇑✶ k  ≡ ρ₂ ⇑✶ k
⇑✶-cong k ρ₁≡ρ₂ = cong (_⇑✶ k) ρ₁≡ρ₂

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

∘-⇑-distrib : ∀ { m n k } ( ρ₁ : Ren m n ) ( ρ₂ : Ren n k )
  → (ρ₂ ⇑ ∘ ρ₁ ⇑) ≡ (ρ₂ ∘ ρ₁) ⇑
∘-⇑-distrib ρ₁ ρ₂ = extensionality lemma
  where
    lemma : ∀ x → (ρ₂ ⇑ ∘ ρ₁ ⇑) x ≡ ((ρ₂ ∘ ρ₁) ⇑) x
    lemma zero = refl
    lemma (suc x) = refl

-- TODO:
-- generalized for ⇑✶

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

⇑-id : ∀ { n } → (id { n }) ⇑ ≡ id
⇑-id = extensionality lemma
  where
    lemma : ∀ { n } x → (id { n } ⇑) x ≡ x
    lemma zero = refl
    lemma (suc x) = refl


{-# OPTIONS --without-K --safe #-}
-- Take a relation that is already reflexive and transitive
-- and make it symmetric.
--   (Borrowed from Categories/Support/ZigZag from copumpkin's Categories library

module Relation.Binary.Construct.Symmetrize where

open import Level
open import Relation.Binary
open import Relation.Binary.Construct.On using () renaming (isEquivalence to on-preserves-equivalence)

data Direction : Set where
  ↘ ↗ : Direction

rotate : Direction → Direction
rotate ↘ = ↗
rotate ↗ = ↘

private
  variable
    c ℓ₁ ℓ₂ : Level
    Carrier : Set c

data ZigZag′ (_∼_ : Rel Carrier ℓ₂) : (x y : Carrier) (begin end : Direction) → Set (levelOfTerm x ⊔ ℓ₂) where
  zig : ∀ {x y z e} (first : x ∼ y) (rest : ZigZag′ _∼_ y z ↗ e) → ZigZag′ _∼_ x z ↘ e
  zag : ∀ {x y z e} (first : y ∼ x) (rest : ZigZag′ _∼_ y z ↘ e) → ZigZag′ _∼_ x z ↗ e
  slish : ∀ {x y} (last : x ∼ y) → ZigZag′ _∼_ x y ↘ ↘
  slash : ∀ {x y} (last : y ∼ x) → ZigZag′ _∼_ x y ↗ ↗

data Alternating′ (_∼_ : Carrier -> Carrier -> Set ℓ₂) (x y : Carrier) : Set (levelOfTerm x ⊔ ℓ₂) where
  disorient : ∀ {begin end} (zz : ZigZag′ _∼_ x y begin end) → Alternating′ _∼_ x y

module _ (Base : Preorder c ℓ₁ ℓ₂) where

  ZigZag : (x y : Preorder.Carrier Base) (begin end : Direction) → Set (c ⊔ ℓ₂)
  ZigZag = ZigZag′ (Preorder._∼_ Base)

  private
    sym′ : {x y z : Preorder.Carrier Base} {begin middle end : Direction} → ZigZag y z middle end →
           ZigZag y x middle begin → ZigZag z x (rotate end) begin
    sym′ (zig first rest) accum = sym′ rest (zag first accum)
    sym′ (zag first rest) accum = sym′ rest (zig first accum)
    sym′ (slish last) accum     = zag last accum
    sym′ (slash last) accum     = zig last accum

  sym : ∀ {x y begin end} → ZigZag x y begin end → ZigZag y x (rotate end) (rotate begin)
  sym (zig first rest) = sym′ rest (slash first)
  sym (zag first rest) = sym′ rest (slish first)
  sym (slish last)     = slash last
  sym (slash last)     = slish last

  trans : ∀ {x y z begin end begin′ end′} → ZigZag x y begin end → ZigZag y z begin′ end′ → ZigZag x z begin end′
  trans (zig first rest) yz = zig first (trans rest yz)
  trans (zag first rest) yz = zag first (trans rest yz)
  trans (slish last) (zig first rest) = zig (Preorder.trans Base last first) rest
  trans (slish last) (zag first rest) = zig last (zag first rest)
  trans (slish last) (slish only) = slish (Preorder.trans Base last only)
  trans (slish last) (slash only) = zig last (slash only)
  trans (slash last) (zig first rest) = zag last (zig first rest)
  trans (slash last) (zag first rest) = zag (Preorder.trans Base first last) rest
  trans (slash last) (slish only) = zag last (slish only)
  trans (slash last) (slash only) = slash (Preorder.trans Base only last)

  Alternating : (x y : Preorder.Carrier Base) → Set (c ⊔ ℓ₂)
  Alternating = Alternating′ (Preorder._∼_ Base)

  private
    is-equivalence : IsEquivalence Alternating
    is-equivalence = record
      { refl = disorient (slash (Preorder.refl Base))
      ; sym = λ where (disorient zz) → disorient (sym zz)
      ; trans = λ where (disorient ij) (disorient jk) → disorient (trans ij jk)
      }

  setoid : Setoid c (c ⊔ ℓ₂)
  setoid = record
    { Carrier = Preorder.Carrier Base
    ; _≈_ = Alternating
    ; isEquivalence = is-equivalence
    }

  -- the main eliminators for Alternating -- they prove that any equivalence that
  -- respects the base preorder also respects its Alternating completion.
  locally-minimal : ∀ {ℓ′} {_≈_ : Rel (Preorder.Carrier Base) ℓ′} (≈-isEquivalence : IsEquivalence _≈_) →
    (Preorder._∼_ Base ⇒ _≈_) → (Alternating ⇒ _≈_)
  locally-minimal {_} {_≋_} isEq inj (disorient zz) = impl zz
    where
    open IsEquivalence isEq renaming (sym to >sym; trans to _>trans>_)

    impl : {i j : Preorder.Carrier Base} {b e : Direction} → ZigZag i j b e → i ≋ j
    impl (zig first rest) = inj first >trans> impl rest
    impl (zag first rest) = >sym (inj first) >trans> impl rest
    impl (slish last) = inj last
    impl (slash last) = >sym (inj last)

  minimal : ∀ {c′ ℓ′} (Dest : Setoid c′ ℓ′) (f : Preorder.Carrier Base → Setoid.Carrier Dest) →
            (Preorder._∼_ Base =[ f ]⇒ Setoid._≈_ Dest) → (Alternating =[ f ]⇒ Setoid._≈_ Dest)
  minimal Dest f inj = locally-minimal (on-preserves-equivalence f (Setoid.isEquivalence Dest)) inj


-- This module introduces operators.

module Introduction.Operators where

-- Agda has a very flexible mechanism for defining operators, supporting infix,
-- prefix, postfix and mixfix operators.

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

-- Any name containing underscores (_) can be used as an operator by writing
-- the arguments where the underscores are. For instance, the function _+_ is
-- the infix addition function. This function can be used either as a normal
-- function: '_+_ zero zero', or as an operator: 'zero + zero'.

_+_ : Nat -> Nat -> Nat
zero  + m = m
suc n + m = suc (n + m)

-- A fixity declaration specifies precedence level (50 in this case) and
-- associativity (left associative here) of an operator. Only infix operators
-- (whose names start and end with _) have associativity.
infixl 50 _+_

-- The only restriction on where _ can appear in a name is that there cannot be
-- two underscores in sequence. For instance, we can define an if-then-else
-- operator:

data Bool : Set where
  false : Bool
  true  : Bool

if_then_else_ : {A : Set} -> Bool -> A -> A -> A
if true  then x else y = x
if false then x else y = y

-- if_then_else_ is treated as a prefix operator (ends, but doesn't begin with
-- an _), so the declared precedence determines how something in an else branch
-- should be parsed. For instance, with the given precedences
--   if x then y else a + b
-- is parsed as
--   if x then y else (a + b)
-- and not
--   (if x then y else a) + b

infix 10 if_then_else_

-- In Agda there is no restriction on what characters are allowed to appear in
-- an operator (as opposed to a function symbol). For instance, it is allowed
-- (but not recommended) to define 'f' to be an infix operator and '+' to be a
-- function symbol.

module BadIdea where

  _f_ : Nat -> Nat -> Nat
  zero  f zero  = zero
  zero  f suc n = suc n
  suc n f zero  = suc n
  suc n f suc m = suc (n f m)

  + : Nat -> Nat
  + n = suc n


{-

This file contains:
  - Pushout-products of two maps;
  - The connectivity of pushout-product maps.

-}
{-# OPTIONS --safe #-}
module Cubical.HITs.Pushout.PushoutProduct where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.Properties
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels

open import Cubical.Data.Nat
open import Cubical.Data.Sigma

open import Cubical.HITs.Pushout.Base
open import Cubical.HITs.Pushout.Properties

open import Cubical.Homotopy.Connected

private
  variable
    ℓ ℓ' ℓ'' ℓ''' : Level
    A : Type ℓ
    B : Type ℓ'
    X : Type ℓ''
    Y : Type ℓ'''

-- The definition of pushout-product

PushProd : (f : X → A)(g : Y → B) → Type _
PushProd f g = Pushout (map-× (idfun _) g) (map-× f (idfun _))

_×̂_ : (f : X → A)(g : Y → B) → PushProd f g → A × B
(f ×̂ g) (inl (x , b)) = f x , b
(f ×̂ g) (inr (a , y)) = a , g y
(f ×̂ g) (push (x , y) i) = f x , g y

infixr 5 _×̂_

module _
  (m n : ℕ)(f : X → A)(g : Y → B)
  (connf : isConnectedFun m f)
  (conng : isConnectedFun n g)
  (P : A × B → TypeOfHLevel ℓ (m + n)) where

  module _
    (sec : (x : PushProd f g) → P ((f ×̂ g) x) .fst) where

    private
      fam : A → Type _
      fam a = Σ[ k ∈ ((b : B) → P (a , b) .fst) ] ((y : Y) → k (g y) ≡ sec (inr (a , y)))

      open Iso

      fiberEquiv : (a : A)
        → fam a ≃ fiber (λ(s : (b : B) → P (a , b) .fst) → s ∘ g) (λ y → sec (inr (a , y)))
      fiberEquiv a =  isoToEquiv
        (iso (λ (k , p) → k , λ i y → p y i)
             (λ (k , p) → k , λ y i → p i y)
             (λ _ → refl) (λ _ → refl))

      is-m-trunc-fam : (a : A) → isOfHLevel m (fam a)
      is-m-trunc-fam a =
        isOfHLevelRespectEquiv _ (invEquiv (fiberEquiv a))
          (isOfHLevelPrecomposeConnected m n (λ b → P (a , b)) g conng _)

      sec-fam : (x : X) → fam (f x)
      sec-fam x = (λ b → sec (inl (x , b))) , (λ y i → sec (push (x , y) i))

      map-iso = elim.isIsoPrecompose f _ (λ a → fam a , is-m-trunc-fam a) connf

      k = map-iso .inv sec-fam
      ϕ = map-iso .rightInv sec-fam

    ext : (x : A × B) → P x .fst
    ext (a , b) = k a .fst b

    ext-path : (x : PushProd f g) → ext ((f ×̂ g) x) ≡ sec x
    ext-path (inl (x , b)) i = ϕ i x .fst b
    ext-path (inr (a , y)) i = k a .snd y i
    ext-path (push (x , y) i) j =
      hcomp (λ k → λ
        { (i = i0) → ϕ j x .snd y i0
        ; (i = i1) → ϕ i0 x .snd y (j ∨ ~ k)
        ; (j = i0) → ϕ i0 x .snd y (i ∧ ~ k)
        ; (j = i1) → ϕ i1 x .snd y i })
      (ϕ j x .snd y i)

  lifting : hasSection (λ(s : (x : A × B) → P x .fst) → s ∘ (f ×̂ g))
  lifting .fst sec = ext sec
  lifting .snd sec i x = ext-path sec x i

-- The connectivity of pushout-product

isConnected×̂ : {m n : ℕ}{f : A → B}{g : X → Y}
  → isConnectedFun m f → isConnectedFun n g
  → isConnectedFun (m + n) (f ×̂ g)
isConnected×̂ congf congg =
  elim.isConnectedPrecompose _ _ (lifting _ _ _ _ congf congg)


open import Agda.Primitive

open import Equality

module Quotient where

  is-prop : ∀ {ℓ} (A : Set ℓ) → Set ℓ
  is-prop A = ∀ (x y : A) → x ≡ y

  record is-equivalence {ℓ k} {A : Set ℓ} (E : A → A → Set k) : Set (ℓ ⊔ k) where
    field
      equiv-prop : ∀ {x y} → is-prop (E x y)
      equiv-refl : ∀ {x} → E x x
      equiv-symm : ∀ {x y} → E x y → E y x
      equiv-tran : ∀ {x y z} → E x y → E y z → E x z

  record Equivalence {ℓ} (A : Set ℓ) : Set (lsuc ℓ) where
    field
      equiv-relation : A → A → Set ℓ
      equiv-is-equivalence : is-equivalence equiv-relation

  is-set : ∀ {ℓ} (A : Set ℓ) → Set ℓ
  is-set A = ∀ (x y : A) (p q : x ≡ y) → p ≡ q

  record HSet ℓ : Set (lsuc ℓ) where
    field
      hset-type : Set ℓ
      hset-is-set : is-set hset-type

  record Quotient {ℓ} (A : Set ℓ) (E : Equivalence A) : Set (lsuc ℓ) where
    open Equivalence

    field
      quot-type : Set ℓ
      quot-class : ∀ (x : A) → quot-type
      quot-≡ : ∀ {x y : A} → equiv-relation E x y → quot-class x ≡ quot-class y
      quot-is-set : is-set quot-type
      quot-elim :
        ∀ (B : ∀ quot-type → Set ℓ)
          (f : ∀ (x : A) → B (quot-class x)) →
          (∀ (x y : A) {ε : equiv-relation E x y} → transport B (quot-≡ ε) (f x) ≡ f y) →
          ∀ (ξ : quot-type) → B ξ
      quot-compute :
        ∀ (B : ∀ quot-type → Set ℓ)  →
          (f : ∀ (x : A) → B (quot-class x)) →
          (η : ∀ (x y : A) {ε : equiv-relation E x y} → transport B (quot-≡ ε) (f x) ≡ f y) →
          (quot-elim ? quot-class η)


open import Relation.Nullary using (¬_; Dec; yes; no)
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary.Decidable using (False; map)
open import Function.Equivalence as FE using ()

module AKS.Nat.Base where

open import Agda.Builtin.FromNat using (Number)
open import Data.Nat using (ℕ; _+_; _∸_; _*_; _≟_; _<ᵇ_; pred) public
open ℕ public
open import Data.Nat.Literals using (number)

instance
  ℕ-number : Number ℕ
  ℕ-number = number

data ℕ⁺ : Set where
  ℕ+ : ℕ → ℕ⁺

_+⁺_ : ℕ⁺ → ℕ⁺ → ℕ⁺
ℕ+ n +⁺ ℕ+ m = ℕ+ (suc (n + m))

_*⁺_ : ℕ⁺ → ℕ⁺ → ℕ⁺
ℕ+ n *⁺ ℕ+ m = ℕ+ (n + m * (suc n))

_≟⁺_ : Decidable {A = ℕ⁺} _≡_
ℕ+ n ≟⁺ ℕ+ m = map (FE.equivalence (λ { refl → refl }) (λ { refl → refl })) (n ≟ m)

⟅_⇑⟆ : ∀ n {≢0 : False (n ≟ zero)} → ℕ⁺
⟅ suc n ⇑⟆ = ℕ+ n

⟅_⇓⟆ : ℕ⁺ → ℕ
⟅ ℕ+ n ⇓⟆ = suc n

instance
  ℕ⁺-number : Number ℕ⁺
  ℕ⁺-number = record
    { Constraint = λ n → False (n ≟ zero)
    ; fromNat = λ n {{≢0}} → ⟅ n ⇑⟆ {≢0}
    }

infix 4 _≤_
record _≤_ (n : ℕ) (m : ℕ) : Set where
  constructor lte
  field
    k : ℕ
    ≤-proof : n + k ≡ m

infix 4 _≥_
_≥_ : ℕ → ℕ → Set
n ≥ m = m ≤ n

infix 4 _≰_
_≰_ : ℕ → ℕ → Set
n ≰ m = ¬ (n ≤ m)

infix 4 _≱_
_≱_ : ℕ → ℕ → Set
n ≱ m = ¬ (m ≤ n)

infix 4 _<_
_<_ : ℕ → ℕ → Set
n < m = suc n ≤ m

infix 4 _≮_
_≮_ : ℕ → ℕ → Set
n ≮ m = ¬ (n < m)

infix 4 _>_
_>_ : ℕ → ℕ → Set
n > m = m < n

infix 4 _≯_
_≯_ : ℕ → ℕ → Set
n ≯ m = m ≮ n


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

open import sets.nat.ordering.lt.core public
open import sets.nat.ordering.lt.level public


open import Categories
open import Monads

module Monads.Kleisli.Adjunction {a b}{C : Cat {a}{b}}(M : Monad C) where

open Cat C
open Monad M

open import Library
open import Functors
open import Monads.Kleisli M
open import Adjunctions
open import Monads.Kleisli.Functors M
open Fun

KlAdj : Adj C Kl
KlAdj = record {
  L        = KlL;
  R        = KlR;
  left     = id;
  right    = id;
  lawa     = λ _ → refl;
  lawb     = λ _ → refl;
  natleft  = lem;
  natright = lem}
  where
   lem = λ {X}{X'}{Y}{Y'} (f : Hom X' X)(g : Hom Y (T Y')) h →
    proof
    comp (bind g) (comp h f)
    ≅⟨ cong (λ h → comp (bind g) (comp h f)) (sym law2) ⟩
    comp (bind g) (comp (comp (bind h) η) f)
    ≅⟨ cong (comp (bind g)) ass ⟩
    comp (bind g) (comp (bind h) (comp η f))
    ∎


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

module Dodo.Binary.Trichotomous where

-- Stdlib imports
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; _≢_; refl; cong; subst; subst₂) renaming (sym to ≡-sym)
open import Level using (Level)
open import Function using (flip; _∘_; _∘₂_)
open import Data.Empty using (⊥-elim)
open import Data.Product using (_,_)
open import Relation.Unary using (Pred)
open import Relation.Binary using (Rel; Irreflexive; Trichotomous; Tri; tri<; tri≈; tri>)
open import Relation.Binary.Construct.Closure.Transitive using ([_])
-- Local imports
open import Dodo.Unary.Equality
open import Dodo.Binary.Equality
open import Dodo.Binary.Immediate
open import Dodo.Binary.Filter

-- # Definitions

tri-immˡ : {a ℓ₁ ℓ₂ : Level} {A : Set a} {_≈_ : Rel A ℓ₁} {R : Rel A ℓ₂}
  → Trichotomous _≈_ R → {x y z : A}
  → immediate R x z → immediate R y z
    ---------------------------------
  → x ≈ y
tri-immˡ triR {x} {y} {z} (Rxz , ¬∃y) (Ryz , ¬∃x) with triR x y
... | tri<  Rxy x≢y ¬Ryx = ⊥-elim (¬∃y (y , Rxy , [ Ryz ]))
... | tri≈ ¬Rxy x≡y ¬Ryx = x≡y
... | tri> ¬Rxy x≢y  Ryx = ⊥-elim (¬∃x (x , Ryx , [ Rxz ]))

tri-immʳ : {a ℓ₁ ℓ₂ : Level} {A : Set a} {_≈_ : Rel A ℓ₁} {R : Rel A ℓ₂}
  → Trichotomous _≈_ R → {x y z : A}
  → immediate R x y → immediate R x z
    ---------------------------------
  → y ≈ z
tri-immʳ triR {x} {y} {z} (Rxy , ¬∃z) (Rxz , ¬∃y) with triR y z
... | tri<  Ryz y≢z ¬Rzy = ⊥-elim (¬∃y (y , Rxy , [ Ryz ]))
... | tri≈ ¬Ryz y≡z ¬Rzy = y≡z
... | tri> ¬Ryz y≢z  Rzy = ⊥-elim (¬∃z (z , Rxz , [ Rzy ]))

tri-irreflexive : {a ℓ₁ ℓ₂ : Level} {A : Set a} {_≈_ : Rel A ℓ₁} {_<_ : Rel A ℓ₂}
  → Trichotomous _≈_ _<_
    --------------------
  → Irreflexive _≈_ _<_
tri-irreflexive triR {x} {y} x≈y x<y with triR x y
... | tri< x<y x≉y x≯y = x≉y x≈y
... | tri≈ x≮y x≈y x≯y = x≮y x<y
... | tri> x≮y x≉y x>y = x≉y x≈y

tri-flip : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → {x y : A}
  → Tri (R x y) (x ≡ y) (R y x)
    -------------------------------------
  → Tri (flip R x y) (x ≡ y) (flip R y x)
tri-flip (tri<  Rxy x≢y ¬Ryx) = tri> ¬Ryx x≢y  Rxy
tri-flip (tri≈ ¬Rxy x≡y ¬Ryx) = tri≈ ¬Ryx x≡y ¬Rxy
tri-flip (tri> ¬Rxy x≢y  Ryx) = tri<  Ryx x≢y ¬Rxy

trichotomous-flip : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → Trichotomous _≡_ R
    -------------------------
  → Trichotomous _≡_ (flip R)
trichotomous-flip {R = R} triR = tri-flip {R = R} ∘₂ triR


module container.m.core where

open import level
open import sum
open import equality.core
open import equality.calculus
open import function.core
open import function.isomorphism
open import function.extensionality
open import container.core
open import container.equality
open import container.fixpoint

infix 1000 ♯_

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

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

module Definition {li la lb}(c : Container li la lb) where
  open Container c public

  -- definition of indexed M-types using native Agda coinduction
  data M (i : I) : Set (la ⊔ lb) where
    inf : (a : A i) → ((b : B a) → ∞ (M (r b))) → M i

  -- the terminal coalgebra
  out : M →ⁱ F M
  out i (inf a f) = a , ♭ ∘' f

  -- normally, the constructor can be defined in terms of out and unfold, but
  -- Agda provides it natively, together with a definitional β rule
  inM' : F M →ⁱ M
  inM' i (a , f) = inf a (λ x → ♯ (f x))

  inM'-β : {i : I}(x : F M i) → out i (inM' i x) ≡ x
  inM'-β x = refl

  module Elim {lx}{X : I → Set lx}
              (α : X →ⁱ F X) where
    -- anamorphisms
    unfold : X →ⁱ M
    unfold i x = inf a f
      where
        u : F X i
        u = α i x

        a : A i
        a = proj₁ u

        f : (b : B a) → ∞ (M (r b))
        f b = ♯ unfold (r b) (proj₂ u b)

    -- computational rule for anamorphisms
    -- this holds definitionally
    unfold-β : {i : I}(x : X i)
             → out i (unfold i x) ≡ imap unfold i (α i x)
    unfold-β x = refl

    -- the corresponding η rule doesn't hold, so we postulate it
    postulate
      unfold-η : (h : X →ⁱ M)
               → (∀ {i} (x : X i) → out i (h i x) ≡ imap h i (α i x))
               → ∀ {i} (x : X i) → h i x ≡ unfold i x
  open Elim public

  -- using η, we can prove that the unfolding of out is the identity
  unfold-id : ∀ {i} (x : M i) → unfold out i x ≡ x
  unfold-id x = sym (unfold-η out idⁱ (λ _ → refl) x)

  -- the usual definition of the constructor
  inM : F M →ⁱ M
  inM = unfold (imap out)

  -- the constructor is the inverse of the destructor
  inM-η : ∀ {i} (x : M i) → inM i (out i x) ≡ x
  inM-η x = unfold-η out (inM ∘ⁱ out) (λ _ → refl) x · unfold-id x

  inM-β : ∀ {i} (x : F M i) → out i (inM i x) ≡ x
  inM-β {i} x = ap u (funext (λ i → funext inM-η))
    where
      u : (M →ⁱ M) → F M i
      u h = imap h i x

  fixpoint : ∀ i → M i ≅ F M i
  fixpoint i = iso (out i) (inM i) inM-η inM-β

  -- now we can prove that the constructor provided by Agda is equal to the
  -- usual one
  inM-alt : ∀ {i} (x : F M i) → inM' i x ≡ inM i x
  inM-alt {i} x = sym (inM-η (inM' i x))


----------------------------------------------------------------------------
-- Well-founded induction on the relation _◁_
----------------------------------------------------------------------------

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

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOT.FOTC.Program.McCarthy91.WF-Relation.Induction.NonAcc.WellFoundedATP
  where

open import FOTC.Base

open import FOTC.Data.Nat

open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.WF-Relation
open import FOTC.Program.McCarthy91.WF-Relation.PropertiesATP

----------------------------------------------------------------------------
-- Adapted from FOTC.Data.Nat.Induction.WellFoundedI.wfInd-LT₁.

{-# TERMINATING #-}
◁-wfind : (P : D → Set) →
          (∀ {n} → N n → (∀ {m} → N m → m ◁ n → P m) → P n) →
          ∀ {n} → N n → P n
◁-wfind P h Nn = h Nn (helper Nn)
  where
    helper : ∀ {n m} → N n → N m → m ◁ n → P m
    helper Nn nzero 0◁n = ⊥-elim (0◁x→⊥ Nn 0◁n)

    -- This equation does not pass the termination check.
    helper nzero (nsucc Nm) Sm◁0 = h (nsucc Nm)
      (λ {m'} Nm' m'◁Sm →
        let m'◁0 : m' ◁ zero
            m'◁0 = ◁-trans Nm' (nsucc Nm) nzero m'◁Sm Sm◁0

        in helper nzero Nm' m'◁0
      )

    -- Other version of the previous equation (this version neither
    -- pass the termination check).
    -- helper nzero (nsucc {m} Nm) Sm◁0 = h (nsucc Nm)
    --   (λ {m'} Nm' m'◁Sm →
    --     let m'◁m : MCR m' m
    --         m'◁m = x◁Sy→x◁y Nm' Nm m'◁Sm

    --     in helper Nm Nm' m'◁m
    --   )

    -- Other version of the previous equation (this version neither
    -- pass the termination check).
    -- helper nzero Nm m◁0 = h Nm
    --   (λ {m'} Nm' m'◁m →
    --     let m'◁0 : MCR m' zero
    --         m'◁0 = ◁-trans Nm' Nm nzero m'◁m m◁0

    --     in helper nzero Nm' m'◁0
    --   )

    -- Other version of the previous equation (this version neither
    -- pass the termination check).
    -- helper {m = m} nzero Nm m◁0 =
    --   h Nm (λ {m'} Nm' m'◁m → helper Nm Nm' m'◁m)

    helper (nsucc {n} Nn) (nsucc {m} Nm) Sm◁Sn = helper Nn (nsucc Nm) Sm◁n
      where
        Sm◁n : succ₁ m ◁ n
        Sm◁n = x◁Sy→x◁y (nsucc Nm) Nn Sm◁Sn


module Categories.Terminal where

open import Library
open import Categories
open import Categories.Sets
open Cat

record Term {a b} (C : Cat {a}{b})(T : Obj C) : Set (a ⊔ b) where
  constructor term
  field t : ∀{X} → Hom C X T
        law : ∀{X}{f : Hom C X T} → t {X} ≅ f

OneSet : Term Sets ⊤
OneSet = record {t = λ _ → _; law = ext (λ _ → refl)}


{-# OPTIONS --safe --warning=error --without-K #-}

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

open import LogicalFormulae
open import Functions.Definition

module Orders.Partial.Definition {a : _} (carrier : Set a) where

record PartialOrder {b : _} : Set (a ⊔ lsuc b) where
  field
    _<_ : Rel {a} {b} carrier
    irreflexive : {x : carrier} → (x < x) → False
    <Transitive : {a b c : carrier} → (a < b) → (b < c) → (a < c)
  <WellDefined : {r s t u : carrier} → (r ≡ t) → (s ≡ u) → r < s → t < u
  <WellDefined refl refl r<s = r<s


module Dave.Algebra.Naturals.Monus where
    open import Dave.Algebra.Naturals.Definition
    open import Dave.Algebra.Naturals.Addition

    _∸_ : ℕ → ℕ → ℕ
    m ∸ zero = m
    zero ∸ suc n = zero
    suc m ∸ suc n = m ∸ n

    infixl 6 _∸_

    ∸-zero : ∀ (n : ℕ) → 0 ∸ n ≡ 0
    ∸-zero zero = refl
    ∸-zero (suc n) = refl

    ∸-assoc-+ : ∀ (m n p : ℕ) → m ∸ n ∸ p ≡ m ∸ (n + p)
    ∸-assoc-+ m zero p = refl
    ∸-assoc-+ zero (suc n) p = ∸-zero p
    ∸-assoc-+ (suc m) (suc n) p = begin
        suc m ∸ suc n ∸ p ≡⟨⟩
        m ∸ n ∸ p ≡⟨ ∸-assoc-+ m n p ⟩
        m ∸ (n + p) ≡⟨⟩
        suc m ∸ suc (n + p) ≡⟨⟩
        suc m ∸ (suc n + p) ∎


module Chain
  {U : Set}(T : U -> Set)
  (_==_ : {a b : U} -> T a -> T b -> Set)
  (refl : {a : U}(x : T a) -> x == x)
  (trans : {a b c : U}(x : T a)(y : T b)(z : T c) -> x == y -> y == z -> x == z)
  where

infix 30 _∼_
infix 3 proof_
infixl 2 _≡_by_
infix 1 _qed

data _∼_ {a b : U}(x : T a)(y : T b) : Set where
  prf : x == y -> x ∼ y

proof_ : {a : U}(x : T a) -> x ∼ x
proof x = prf (refl x)

_≡_by_ : {a b c : U}{x : T a}{y : T b} -> x ∼ y -> (z : T c) -> y == z -> x ∼ z
prf p ≡ z by q = prf (trans _ _ _ p q)

_qed : {a b : U}{x : T a}{y : T b} -> x ∼ y -> x == y
prf p qed = p


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

module Data.Integer where

open import Level

open import Data.Nat using (ℕ; suc; zero)
import Data.Nat as ℕ
import Data.Nat.Properties as ℕ
open import Data.Bool

data ℤ : Type where
  ⁺   : ℕ → ℤ
  ⁻suc : ℕ → ℤ

⁻ : ℕ → ℤ
⁻ zero    = ⁺ zero
⁻ (suc n) = ⁻suc n

{-# DISPLAY ⁻suc n = ⁻ suc n #-}

negate : ℤ → ℤ
negate (⁺ x) = ⁻ x
negate (⁻suc x) = ⁺ (suc x)

{-# DISPLAY negate x = ⁻ x #-}

infixl 6 _+_

_-suc_ : ℕ → ℕ → ℤ
x -suc y =
  if y ℕ.<ᴮ x
    then ⁺ (x ℕ.∸ (suc y))
    else ⁻suc (y ℕ.∸ x)

_+_ : ℤ → ℤ → ℤ
⁺    x + ⁺    y = ⁺ (x ℕ.+ y)
⁺    x + ⁻suc y = x -suc y
⁻suc x + ⁺    y = y -suc x
⁻suc x + ⁻suc y = ⁻suc (suc x ℕ.+ y)

_*-suc_ : ℕ → ℕ → ℤ
zero  *-suc m = ⁺ zero
suc n *-suc m = ⁻suc (n ℕ.+ m ℕ.+ n ℕ.* m)

infixl 7 _*_
_*_ : ℤ → ℤ → ℤ
⁺    x * ⁺    y = ⁺ (x ℕ.* y)
⁺    x * ⁻suc y = x *-suc y
⁻suc x * ⁺    y = y *-suc x
⁻suc x * ⁻suc y = ⁺ (suc x ℕ.* suc y)


module Data.Tree.Base where

open import Class.Monoid
open import Class.Show
open import Data.List using (List; sum; map; replicate; intersperse)
open import Data.Nat using (ℕ; suc)
open import Data.Nat.Instance
open import Data.String using (String)
open import Data.String.Instance
open import Function

data Tree (A : Set) : Set where
  Node : A -> List (Tree A) -> Tree A

{-# TERMINATING #-}
lengthTree : ∀ {A} -> Tree A -> ℕ
lengthTree (Node x x₁) = 1 + sum (map lengthTree x₁)

-- show tree that is compatible with org mode
{-# TERMINATING #-}
showTreeOrg : ∀ {A} {{_ : Show A}} -> Tree A -> String
showTreeOrg = helper 1
  where
    helper : ∀ {A} {{_ : Show A}} -> ℕ -> Tree A -> String
    helper level (Node x x₁) =
      (concat $ replicate level "*") + " " + show x + "\n" +
      (concat $ intersperse "\n" $ map (helper (suc level)) x₁) + "\n"


module L0 where

open import Common

-- Syntax

data Name : Set where
 d n j m : Name

data Pred1 : Set where
 M B : Pred1

data Pred2 : Set where
 K L : Pred2

data Expr : Set where
  _⦅_⦆ : Pred1 -> Name -> Expr
  _⦅_,_⦆ : Pred2 -> Name -> Name -> Expr
  ¬ : Expr -> Expr
  [_∧_] : Expr -> Expr -> Expr
  [_∨_] : Expr -> Expr -> Expr
  [_⇒_] : Expr -> Expr -> Expr
  [_⇔_] : Expr -> Expr -> Expr

example1 : Expr
example1 = [ K ⦅ d , j ⦆ ∧ M ⦅ d ⦆  ]
example2 : Expr
example2 = ¬ [ M ⦅ d ⦆ ∨ B ⦅ m ⦆ ]
example3 : Expr
example3 = [ L ⦅ n , j ⦆ ⇒ [ B ⦅ d ⦆ ∨ ¬ (K ⦅ m , m ⦆) ] ]
example4 : Expr
example4 = [ ¬ (¬ (¬ (B ⦅ n ⦆))) ⇔ ¬ (M ⦅ n ⦆) ]

-- Semantics

data Person : Set where
  Richard_Nixon : Person
  Noam_Chomsky : Person
  John_Mitchell : Person
  Muhammad_Ali : Person

instance
  eqPerson : Eq Person
  -- _==_ ⦃ eqPerson ⦄ x y =  isEq x y (refl {!x y!})
  _==_ ⦃ eqPerson ⦄ Richard_Nixon Richard_Nixon = true
  _==_ ⦃ eqPerson ⦄ Noam_Chomsky Noam_Chomsky = true
  _==_ ⦃ eqPerson ⦄ John_Mitchell John_Mitchell = true
  _==_ ⦃ eqPerson ⦄ Muhammad_Ali Muhammad_Ali = true
  _==_ ⦃ eqPerson ⦄ _ _ = false

_∈_ : {A : Set} {{_ : Eq A}} -> A -> PSet A -> Bool
x ∈ ⦃⦄ = false
x ∈ (x₁ :: xs) = (x == x₁) || (x ∈ xs)

⟦_⟧ₙ : Name -> Person
⟦ d ⟧ₙ = Richard_Nixon
⟦ n ⟧ₙ = Noam_Chomsky
⟦ j ⟧ₙ = John_Mitchell
⟦ m ⟧ₙ = Muhammad_Ali

⟦_⟧ₚ₁ : Pred1 -> PSet Person
⟦ x ⟧ₚ₁ = {!!}

⟦_⟧ₚ₂ : Pred2 -> PSet (Pair Person)
⟦ x ⟧ₚ₂ = {!!}

⟦_⟧ₑ : Expr -> Bool
{-# TERMINATING #-}
⟦ x ⦅ x₁ ⦆ ⟧ₑ = ⟦ x₁ ⟧ₙ ∈ ⟦ x ⟧ₚ₁
⟦ x ⦅ x₁ , x₂ ⦆ ⟧ₑ = < ⟦ x₁ ⟧ₙ , ⟦ x₂ ⟧ₙ > ∈ ⟦ x ⟧ₚ₂
⟦ ¬ x ⟧ₑ = neg ⟦ x ⟧ₑ
⟦ [ x ∧ x₁ ] ⟧ₑ = ⟦ x ⟧ₑ && ⟦ x₁ ⟧ₑ
⟦ [ x ∨ x₁ ] ⟧ₑ = ⟦ x ⟧ₑ || ⟦ x₁ ⟧ₑ
⟦ [ x ⇒ x₁ ] ⟧ₑ = (neg ⟦ x₁ ⟧ₑ) || ⟦ x ⟧ₑ
⟦ [ x ⇔ x₁ ] ⟧ₑ = ⟦ [ x ⇒ x₁ ] ⟧ₑ && ⟦ [ x₁ ⇒ x ] ⟧ₑ


open import Oscar.Prelude

module Oscar.Class.Map where

module _
  {𝔬₁} {𝔒₁ : Ø 𝔬₁}
  {ℓ₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø ℓ₁)
  {ℓ₂} (_∼₂_ : 𝔒₁ → 𝔒₁ → Ø ℓ₂)
  where
  𝓶ap = ∀ {x y} → x ∼₁ y → x ∼₂ y
  record 𝓜ap : Ø 𝔬₁ ∙̂ ℓ₁ ∙̂ ℓ₂ where field map : 𝓶ap
open 𝓜ap ⦃ … ⦄ public


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

module Examples.Sorting.Sequential.Comparable where

open import Calf.CostMonoid
open import Calf.CostMonoids

costMonoid = ℕ-CostMonoid

open import Data.Nat using (ℕ)
open CostMonoid costMonoid using (ℂ)

fromℕ : ℕ → ℂ
fromℕ n = n

open import Examples.Sorting.Comparable costMonoid fromℕ public


------------------------------------------------------------------------
-- The Agda standard library
--
-- "Finite" sets indexed on coinductive "natural" numbers
------------------------------------------------------------------------

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

module Codata.Musical.Cofin where

open import Codata.Musical.Notation
open import Codata.Musical.Conat as Conat using (Coℕ; suc; ∞ℕ)
open import Data.Nat.Base using (ℕ; zero; suc)
open import Data.Fin using (Fin; zero; suc)
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)
open import Function

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

-- Note that Cofin ∞ℕ is /not/ finite. Note also that this is not a
-- coinductive type, but it is indexed on a coinductive type.

data Cofin : Coℕ → Set where
  zero : ∀ {n} → Cofin (suc n)
  suc  : ∀ {n} (i : Cofin (♭ n)) → Cofin (suc n)

suc-injective : ∀ {m} {p q : Cofin (♭ m)} → (Cofin (suc m) ∋ suc p) ≡ suc q → p ≡ q
suc-injective refl = refl

------------------------------------------------------------------------
-- Some operations

fromℕ : ℕ → Cofin ∞ℕ
fromℕ zero    = zero
fromℕ (suc n) = suc (fromℕ n)

toℕ : ∀ {n} → Cofin n → ℕ
toℕ zero    = zero
toℕ (suc i) = suc (toℕ i)

fromFin : ∀ {n} → Fin n → Cofin (Conat.fromℕ n)
fromFin zero    = zero
fromFin (suc i) = suc (fromFin i)

toFin : ∀ n → Cofin (Conat.fromℕ n) → Fin n
toFin zero    ()
toFin (suc n) zero    = zero
toFin (suc n) (suc i) = suc (toFin n i)

import Codata.Cofin as C

fromMusical : ∀ {n} → Cofin n → C.Cofin (Conat.fromMusical n)
fromMusical zero    = C.zero
fromMusical (suc n) = C.suc (fromMusical n)

toMusical : ∀ {n} → C.Cofin n → Cofin (Conat.toMusical n)
toMusical C.zero    = zero
toMusical (C.suc n) = suc (toMusical n)


{-# OPTIONS --warning=error --safe --without-K --guardedness #-}

open import Everything.Safe

open import Numbers.Reals.Definition
open import Fields.Orders.Limits.Definition
open import Rings.Orders.Partial.Bounded
open import Rings.Orders.Total.Bounded
open import Rings.Orders.Total.BaseExpansion
open import Fields.Orders.Limits.Lemmas
open import Rings.Orders.Total.Examples
--open import Fields.CauchyCompletion.Archimedean

open import Sets.Cardinality.Infinite.Examples

open import ProjectEuler.Problem2

open import LectureNotes.NumbersAndSets.Examples1
open import LectureNotes.Groups.Lecture1

module Everything.Guardedness where


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

module Dodo.Nullary.Disjoint where

-- Stdlib imports
open import Level using (Level)
open import Data.Product using (_×_)
open import Relation.Nullary using (¬_)

-- # Definitions

Disjoint : ∀ {a b : Level} (A : Set a) (B : Set b) → Set _
Disjoint A B = ¬ (A × B)


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

-- This module provides the basic expression type for polynomials.

module Polynomial.Expr where

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)

infixl 6 _⊕_
infixl 7 _⊗_
infixr 8 _⊛_
data Expr  {ℓ} (A : Set ℓ) (n : ℕ) : Set ℓ where
  Κ   : A → Expr A n
  Ι   : Fin n → Expr A n
  _⊕_ : Expr A n → Expr A n → Expr A n
  _⊗_ : Expr A n → Expr A n → Expr A n
  _⊛_ : Expr A n → ℕ → Expr A n
  ⊝_  : Expr A n → Expr A n

open import Polynomial.Parameters

module Eval {c r₁ r₂ r₃} (homo : Homomorphism c r₁ r₂ r₃) where
  open Homomorphism homo
  open import Polynomial.Exponentiation rawRing

  open import Data.Vec as Vec using (Vec)

  ⟦_⟧ : ∀ {n} → Expr Raw.Carrier n → Vec Carrier n → Carrier
  ⟦ Κ x ⟧ ρ = ⟦ x ⟧ᵣ
  ⟦ Ι x ⟧ ρ = Vec.lookup ρ x
  ⟦ x ⊕ y ⟧ ρ = ⟦ x ⟧ ρ + ⟦ y ⟧ ρ
  ⟦ x ⊗ y ⟧ ρ = ⟦ x ⟧ ρ * ⟦ y ⟧ ρ
  ⟦ ⊝ x ⟧ ρ = - ⟦ x ⟧ ρ
  ⟦ x ⊛ i ⟧ ρ = ⟦ x ⟧ ρ ^ i


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

open import HoTT
open import cohomology.Theory

open import cw.CW

module cw.cohomology.TipAndAugment {i} (OT : OrdinaryTheory i)
  (⊙skel : ⊙Skeleton {i} 0) where

open OrdinaryTheory OT
open import homotopy.DisjointlyPointedSet
open import cohomology.DisjointlyPointedSet OT

module _ (m : ℤ) where
  CX₀ : Group i
  CX₀ = C m (⊙cw-head ⊙skel)

  CX₀-is-abelian : is-abelian CX₀
  CX₀-is-abelian = C-is-abelian m (⊙cw-head ⊙skel)

  C2×CX₀ : Group i
  C2×CX₀ = C2 m ×ᴳ CX₀

  abstract
    C2×CX₀-is-abelian : is-abelian C2×CX₀
    C2×CX₀-is-abelian = ×ᴳ-is-abelian (C2 m) CX₀ (C2-is-abelian m) CX₀-is-abelian

  C2×CX₀-abgroup : AbGroup i
  C2×CX₀-abgroup = C2×CX₀ , C2×CX₀-is-abelian

  CX₀-β : ⊙has-cells-with-choice 0 ⊙skel i
    → CX₀ ≃ᴳ Πᴳ (MinusPoint (⊙cw-head ⊙skel)) (λ _ → C2 m)
  CX₀-β ac = C-set m (⊙cw-head ⊙skel) (snd (⊙Skeleton.skel ⊙skel)) (⊙Skeleton.pt-dec ⊙skel) ac

abstract
  CX₀-≠-is-trivial : ∀ {m} (m≠0 : m ≠ 0)
    → ⊙has-cells-with-choice 0 ⊙skel i
    → is-trivialᴳ (CX₀ m)
  CX₀-≠-is-trivial {m} m≠0 ac =
    iso-preserves'-trivial (CX₀-β m ac) $
      Πᴳ-is-trivial (MinusPoint (⊙cw-head ⊙skel))
        (λ _ → C2 m) (λ _ → C-dimension m≠0)

cw-coε : C2 0 →ᴳ C2×CX₀ 0
cw-coε = ×ᴳ-inl {G = C2 0} {H = CX₀ 0}


{-# OPTIONS --allow-unsolved-metas --guardedness #-}

import Tutorials.Monday-Complete as Mon
import Tutorials.Tuesday-Complete as Tue
import Tutorials.Wednesday-Complete as Wed
open Mon using (⊤; tt; ℕ; zero; suc)
open Mon.Simple using (_⊎_; inl; inr)
open Tue.Product using (Σ; _,_; fst; snd; _×_)

module Tutorials.Thursday where

variable
  A B C S : Set

-- Things that we skipped so far
--------------------------------

module WithAbstraction where
  open Mon using (Bool; true; false; Pred; _≡_; refl; _+_; subst; +-comm)
  open Mon.List using (List; []; _∷_)

  -- With abstraction
  -- You can use "with abstraction" to pattern match on intermediary computations
  -- These can be nested, or executed simultaneously

  filter : (A → Bool) → List A → List A
  filter f [] = []
  filter f (x ∷ xs) with f x
  filter f (x ∷ xs) | true = x ∷ filter f xs
  filter f (x ∷ xs) | false = filter f xs

  -- Alternative notation
  filter′ : (A → Bool) → List A → List A
  filter′ f [] = []
  filter′ f (x ∷ xs) with f x
  ...                | true = x ∷ filter′ f xs
  ...                | false = filter′ f xs

  -- The goal type and the type of the arguments are generalised over the value of the scrutinee
  thm : {P : Pred ℕ} (n m : ℕ) → P (n + m) → P (m + n)
  -- 1) Here (p : P (n + m)) and (eq : n + m ≡ m + n)
  -- thm n m p with +-comm n m
  -- thm n m p | eq = {!!}
  -- 2) Here (p : P x) and (eq : x ≡ m + n)
  -- thm n m p with n + m | +-comm n m
  -- thm n m p | x | eq = {!!}
  -- 3) Pattern matching we get (p : P (m + n)), the dot signifies that the argument is uniquely determined
  thm n m p with n + m | +-comm n m
  thm n m p | .(m + n) | refl = p

  -- This is such a common formula that there is special syntax for it
  thm′ : {P : Pred ℕ} (n m : ℕ) → P (n + m) → P (m + n)
  thm′ n m p rewrite +-comm n m = p

  -- We could use subst to be more explicit about *where* the rewrite happens
  thm′′ : {P : Pred ℕ} (n m : ℕ) → P (n + m) → P (m + n)
  thm′′ {P} n m p = subst {P = P} (+-comm n m) p

-- A little on coinductive types
--------------------------------

-- Stolen from https://github.com/pigworker/CS410-17/blob/master/lectures/Lec6Done.agda

ListT : Set → Set → Set
ListT X B = ⊤ ⊎ (X × B)

module List where
  data List (A : Set) : Set where
    [] : List A
    _∷_ : A → List A → List A

  mkList : ListT A (List A) → List A
  mkList x = {!!}

  foldr : (ListT A B → B) → List A → B
  foldr alg xs = {!!}

  list-id : List A → List A
  list-id = {!!}

  incr : ListT A ℕ → ℕ
  incr x = {!!}

  length : List A → ℕ
  length = {!!}

module CoList where
  record CoList (A : Set) : Set where
    coinductive
    field
      next : ListT A (CoList A)

  open CoList

  [] : CoList A
  [] = {!!}

  _∷_ : A → CoList A → CoList A
  (x ∷ xs) = {!!}

  unfoldr : (S → ListT A S) → S → CoList A
  unfoldr coalg s = {!!}

  colist-id : CoList A → CoList A
  colist-id = {!!}

  repeat : A → CoList A
  repeat = {!!}

  take : ℕ → CoList A → List.List A
  take n xs = {!!}

module Stream where
  record Stream (A : Set) : Set where
    coinductive
    field
      head : A
      tail : Stream A

  open Stream

  forever : A → Stream A
  forever x = {!!}

  unfold : (S → A × S) → S → Stream A
  unfold coalg s = {!!}

---------------------------------------------
-- If you are interested in more
-- Documentation for Agda: https://agda.readthedocs.io/en/v2.6.0.1/index.html
-- Programming Language Foundations in Agda: https://plfa.github.io/
-- Lots of other nice tutorials online
-- The standard library: https://agda.github.io/agda-stdlib/


{-

        Agda Implementors' Meeting VI

                  Göteborg
             May 24 - 30, 2007

                Hello Agda!

                Ulf Norell

-}

{-

   Getting your hands on Agda

   http://www.cs.chalmers.se/~ulfn/Agda

   darcs get --partial http://www.cs.chalmers.se/~ulfn/darcs/Agda2

-}

-- Each Agda file contains a top-level module, whose
-- name corresponds to the file name.

module Basics where

{-

  Expressions (types and terms)

-}

-- The expression language of Agda is your favorite dependently
-- typed λ-calculus.

-- For instance:
id₁ : (A : Set) -> A -> A
id₁ = \ A x -> x

id₂ : (A : Set) -> A -> A
id₂ = \ A x -> id₁ A (id₁ A x)

-- Note: Agda likes white space. This is not correct:
--   id:(A:Set)->A->A
-- Why not? In Agda the following strings are valid identifiers:
--   id:
--   A:Set
--   ->A->A

-- Another useful function, featuring telescopes
-- and typed λs.
compose : (A B C : Set)(f : B -> C)(g : A -> B) -> A -> C
compose = \(A B C : Set) -> \ f g x -> f (g x)

{-

  Implicit arguments

-}

-- Writing down type arguments explicitly soon gets old.
-- Enter implicit arguments.

-- Note the curlies in the telescope. And A mysteriously disappeared
-- in the definition.
id₃ : {A : Set} -> A -> A
id₃ = \ x -> x

-- And it's not there when applying the function.
id₄ : {A : Set} -> A -> A
id₄ = \ x -> (id₃ (id₃ x))

-- You can give implicit arguments explicitly.
id₅ : {A : Set} -> A -> A
id₅ {A} x = id₄ {A} x

-- If you want to give a particular implicit argument, you can refer
-- to it by name.
const : {A B : Set} -> A -> B -> A
const = \ x y -> x

const' : (A : Set) -> A -> A -> A
const' = \ A -> const {B = A}

-- It also works the other way around. If you think the type checker
-- should figure out the value of something explicit, you write _.
id₆ : {A : Set} -> A -> A
id₆ x = id₁ _ x

-- Interesting though it is, eventually you'll get bored
-- with the λ-calculus...

-- Move on to: Datatypes.agda


data ⊤ : Set where tt : ⊤

record R : Set where
  constructor r
  field .x : ⊤

f : R → R
R.x (f (r x)) = {!x!}


{-

The James Construction,
  also known as James Reduced Product

A very fundamental and useful construction in classical homotopy theory.
It can be seen as the free A∞-monoid constructed out of a given type,
namely the "correct higher version" of free monoid that is meaningful for all types,
instead of only h-Sets.

Referrence:
  Guillaume Brunerie,
  "The James construction and π₄(𝕊³) in homotopy type theory"
  (https://arxiv.org/abs/1710.10307)

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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed

private
  variable
    ℓ ℓ' : Level

module _
  ((X , x₀) : Pointed ℓ) where

  infixr 5 _∷_

  -- The James Construction

  data James : Type ℓ where
    []   : James
    _∷_  : X → James → James
    unit : (xs : James) → xs ≡ x₀ ∷ xs

  James∙ : Pointed ℓ
  James∙ = James , []

-- Basic operations on James construction, imitating those in Cubical.Data.List.Base

module _
  {X∙@(X , x₀) : Pointed ℓ} where

  infixr 5 _++_
  infixl 5 _∷ʳ_

  [_] : X → James X∙
  [ x ] = x ∷ []

  _++_ : James X∙ → James X∙ → James X∙
  [] ++ ys = ys
  (x ∷ xs) ++ ys = x ∷ xs ++ ys
  (unit xs i) ++ ys = unit (xs ++ ys) i

  ++₀ : (xs : James X∙) → xs ≡ xs ++ [ x₀ ]
  ++₀ [] = unit []
  ++₀ (x ∷ xs) i = x ∷ ++₀ xs i
  ++₀ (unit xs i) j = unit (++₀ xs j) i

  rev : James X∙ → James X∙
  rev [] = []
  rev (x ∷ xs) = rev xs ++ [ x ]
  rev (unit xs i) = ++₀ (rev xs) i

  _∷ʳ_ : James X∙ → X → James X∙
  xs ∷ʳ x = xs ++ x ∷ []

map : {X : Pointed ℓ}{Y : Pointed ℓ'} → (X →∙ Y) → James X → James Y
map f [] = []
map f (x ∷ xs) = f .fst x ∷ map f xs
map f (unit xs i) = (unit (map f xs) ∙ (λ i → f .snd (~ i) ∷ map f xs)) i

map∙ : {X : Pointed ℓ}{Y : Pointed ℓ'} → (X →∙ Y) → James∙ X →∙ James∙ Y
map∙ f .fst = map f
map∙ f .snd = refl


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

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

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

module Data.Bool.Solver where

import Algebra.Solver.Ring.Simple as Solver
import Algebra.Solver.Ring.AlmostCommutativeRing as ACR
open import Data.Bool using (_≟_)
open import Data.Bool.Properties

------------------------------------------------------------------------
-- A module for automatically solving propositional equivalences
-- containing _∨_ and _∧_

module ∨-∧-Solver =
  Solver (ACR.fromCommutativeSemiring ∨-∧-commutativeSemiring) _≟_

------------------------------------------------------------------------
-- A module for automatically solving propositional equivalences
-- containing _xor_ and _∧_

module xor-∧-Solver =
  Solver (ACR.fromCommutativeRing xor-∧-commutativeRing) _≟_


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

module HoTT.Homotopy where

open variables
private variable f g : A → B

-- Lemma 2.4.3
~-natural : (α : f ~ g) {x y : A} (p : x == y) → α x ∙ ap g p == ap f p ∙ α y
~-natural α {x} refl rewrite α x = refl

~-natural-id : (α : f ~ id) {x y : A} (p : x == y) → α x ∙ p == ap f p ∙ α y
~-natural-id α {x} refl rewrite α x = refl

-- Corollary 2.4.4
~-natural-comm : {f : A → A} (α : f ~ id) → α ∘ f ~ ap f ∘ α
~-natural-comm {f = f} α x = cancelᵣ (α (f x) ∙ₗ ap-id (α x) ⁻¹ ∙ ~-natural α (α x))

module ~-Reasoning where
  _~⟨_⟩_ : (f : Π A P) {g h : Π A P} → f ~ g → g ~ h → f ~ h
  x ~⟨ α ⟩ β = α ∙ₕ β
  infixr 2 _~⟨_⟩_

  _∎ : (f : Π A P) → f ~ f
  _ ∎ = reflₕ
  infix 3 _∎


-- Some basic stuff for Conor's talk.
module SomeBasicStuff where

infixr 40 _::_ _↦_∣_
infix 30 _∈_ _==_
infixr 10 _,_

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

data Σ (A : Set)(B : A -> Set) : Set where
  _,_ : (x : A) -> B x -> Σ A B

_×_ : Set -> Set -> Set
A × B = Σ A \_ -> B

fst : {A : Set}{B : A -> Set} -> Σ A B -> A
fst (x , y) = x

snd : {A : Set}{B : A -> Set}(p : Σ A B) -> B (fst p)
snd (x , y) = y

data   False : Set where
record True  : Set where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

data [_] (A : Set) : Set where
  []   : [ A ]
  _::_ : A -> [ A ] -> [ A ]

data _∈_ {A : Set} : A -> [ A ] -> Set where
  zero : forall {x xs} -> x ∈ x :: xs
  suc  : forall {x y xs} -> x ∈ xs -> x ∈ y :: xs

postulate Tag : Set
{-# BUILTIN STRING Tag #-}

Enumeration = [ Tag ]

data Enum (ts : Enumeration) : Set where
  enum : (t : Tag) -> t ∈ ts -> Enum ts

data Table (A : Set1) : Enumeration -> Set1 where
  []    : Table A []
  _↦_∣_ : forall {ts} -> (t : Tag) -> A -> Table A ts ->
          Table A (t :: ts)

lookup : forall {A ts} -> Table A ts -> Enum ts -> A
lookup []             (enum _ ())
lookup (.t ↦ v ∣ tbl) (enum t zero)    = v
lookup (_  ↦ v ∣ tbl) (enum t (suc p)) = lookup tbl (enum t p)


{-# OPTIONS --without-K #-}
open import Type
open import Type.Identities
open import Level.NP
open import Explore.Core
open import Explore.Properties
open import Explore.Explorable
open import Data.Zero
open import Function.NP
open import Function.Extensionality
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP using (_≡_; refl; _∙_; !_)
open import HoTT
open Equivalences

import Explore.Monad
open import Explore.Isomorphism

module Explore.Zero where

module _ {ℓ} where
    𝟘ᵉ : Explore ℓ 𝟘
    𝟘ᵉ = empty-explore
    {- or
    𝟘ᵉ ε _ _ = ε
    -}

    𝟘ⁱ : ∀ {p} → ExploreInd p 𝟘ᵉ
    𝟘ⁱ = empty-explore-ind
    {- or
    𝟘ⁱ _ Pε _ _ = Pε
    -}

module _ {ℓ₁ ℓ₂ ℓᵣ} {R : 𝟘 → 𝟘 → ★₀} where
    ⟦𝟘ᵉ⟧ : ⟦Explore⟧ {ℓ₁} {ℓ₂} ℓᵣ R 𝟘ᵉ 𝟘ᵉ
    ⟦𝟘ᵉ⟧ _ εᵣ _ _ = εᵣ

module 𝟘ⁱ = FromExploreInd 𝟘ⁱ
open 𝟘ⁱ public using ()
  renaming (sum to 𝟘ˢ
           ;product to 𝟘ᵖ
           ;reify to 𝟘ʳ
           ;unfocus to 𝟘ᵘ
           )

module _ {ℓ} where

    𝟘ˡ : Lookup {ℓ} 𝟘ᵉ
    𝟘ˡ _ ()

    𝟘ᶠ : Focus {ℓ} 𝟘ᵉ
    𝟘ᶠ ((), _)

    module _ {{_ : UA}} where
        Σᵉ𝟘-ok : Adequate-Σ {ℓ} (Σᵉ 𝟘ᵉ)
        Σᵉ𝟘-ok _ = ! Σ𝟘-lift∘fst

    module _ {{_ : UA}}{{_ : FunExt}} where
        Πᵉ𝟘-ok : Adequate-Π {ℓ} (Πᵉ 𝟘ᵉ)
        Πᵉ𝟘-ok _ = ! Π𝟘-uniq _

open Adequacy _≡_
module _ {{_ : UA}} where
    𝟘ˢ-ok : Adequate-sum 𝟘ˢ
    𝟘ˢ-ok _ = Fin0≡𝟘 ∙ ! Σ𝟘-fst

    adequate-sum𝟘     = 𝟘ˢ-ok

module _ {{_ : UA}}{{_ : FunExt}} where
    𝟘ᵖ-ok : Adequate-product 𝟘ᵖ
    𝟘ᵖ-ok _ = Fin1≡𝟙 ∙ ! (Π𝟘-uniq₀ _)

    adequate-product𝟘 = 𝟘ᵖ-ok

explore𝟘          = 𝟘ᵉ
explore𝟘-ind      = 𝟘ⁱ
lookup𝟘           = 𝟘ˡ
reify𝟘            = 𝟘ʳ
focus𝟘            = 𝟘ᶠ
unfocus𝟘          = 𝟘ᵘ
sum𝟘              = 𝟘ˢ
product𝟘          = 𝟘ᵖ

Lift𝟘ᵉ : ∀ {m} → Explore m (Lift 𝟘)
Lift𝟘ᵉ = explore-iso (≃-sym Lift≃id) 𝟘ᵉ

ΣᵉLift𝟘-ok : ∀ {{_ : UA}}{{_ : FunExt}}{m} → Adequate-Σ {m} (Σᵉ Lift𝟘ᵉ)
ΣᵉLift𝟘-ok = Σ-iso-ok (≃-sym Lift≃id) {Aᵉ = 𝟘ᵉ} Σᵉ𝟘-ok

-- -}


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

open import Cubical.Data.Nat using (ℕ)

open import Cubical.Algebra.Group

private variable
  ℓ : Level

open GroupStr

NProd-Group : (G : (n : ℕ) → Type ℓ) → (Gstr : (n : ℕ) → GroupStr (G n)) → Group ℓ
fst (NProd-Group G Gstr) = (n : ℕ) → G n
1g (snd (NProd-Group G Gstr)) = λ n → 1g (Gstr n)
GroupStr._·_ (snd (NProd-Group G Gstr)) = λ f g n → Gstr n ._·_ (f n) (g n)
inv (snd (NProd-Group G Gstr)) = λ f n → (Gstr n).inv (f n)
isGroup (snd (NProd-Group G Gstr)) = makeIsGroup (isSetΠ (λ _ → is-set (Gstr _)))
                                                 (λ f g h → funExt λ n → ·Assoc (Gstr n) _ _ _)
                                                 (λ f → funExt λ n → ·IdR (Gstr n) _)
                                                 (λ f → funExt λ n → ·IdL (Gstr n) _)
                                                 (λ f → funExt λ n → ·InvR (Gstr n) _)
                                                  λ f → funExt λ n → ·InvL (Gstr n) _


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

module Cubical.Categories.Equivalence.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Categories.NaturalTransformation

open Precategory
open Functor

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

-- Definition

record isEquivalence {C : Precategory ℓC ℓC'} {D : Precategory ℓD ℓD'}
                     (func : Functor C D) : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
  field
    invFunc : Functor D C

    η : 𝟙⟨ C ⟩ ≅ᶜ invFunc ∘F func
    ε : func ∘F invFunc ≅ᶜ 𝟙⟨ D ⟩

record _≃ᶜ_ (C : Precategory ℓC ℓC') (D : Precategory ℓD ℓD') : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
  field
    func : Functor C D
    isEquiv : isEquivalence func


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

open import lib.Basics
open import lib.NType2
open import lib.Function2
open import lib.types.Group
open import lib.types.Sigma
open import lib.types.Truncation
open import lib.groups.Homomorphism
open import lib.groups.Isomorphism
open import lib.groups.SubgroupProp

module lib.groups.Subgroup where

module _ {i j} {G : Group i} (P : SubgroupProp G j) where
  private
    module G = Group G
    module P = SubgroupProp P

  subgroup-struct : GroupStructure P.SubEl
  subgroup-struct = record {M} where
    module M where
      ident : P.SubEl
      ident = G.ident , P.ident

      inv : P.SubEl → P.SubEl
      inv (g , p) = G.inv g , P.inv p

      comp : P.SubEl → P.SubEl → P.SubEl
      comp (g₁ , p₁) (g₂ , p₂) = G.comp g₁ g₂ , P.comp p₁ p₂

      abstract
        unit-l : ∀ g → comp ident g == g
        unit-l (g , _) = Subtype=-out P.subEl-prop (G.unit-l g)

        assoc : ∀ g₁ g₂ g₃ → comp (comp g₁ g₂) g₃ == comp g₁ (comp g₂ g₃)
        assoc (g₁ , _) (g₂ , _) (g₃ , _) = Subtype=-out P.subEl-prop (G.assoc g₁ g₂ g₃)

        inv-l : ∀ g → comp (inv g) g == ident
        inv-l (g , _) = Subtype=-out P.subEl-prop (G.inv-l g)

  Subgroup : Group (lmax i j)
  Subgroup = group _ SubEl-level subgroup-struct
    where abstract SubEl-level = Subtype-level P.subEl-prop G.El-level

module Subgroup {i j} {G : Group i} (P : SubgroupProp G j) where
  private
    module P = SubgroupProp P
    module G = Group G

  grp = Subgroup P
  open Group grp public

  El=-out : ∀ {s₁ s₂ : El} → fst s₁ == fst s₂ → s₁ == s₂
  El=-out = Subtype=-out P.subEl-prop

  inject : Subgroup P →ᴳ G
  inject = record {f = fst; pres-comp = λ _ _ → idp}

  inject-lift : ∀ {j} {H : Group j} (φ : H →ᴳ G)
    → Π (Group.El H) (P.prop ∘ GroupHom.f φ)
    → (H →ᴳ Subgroup P)
  inject-lift {H = H} φ P-all = record {M} where
    module H = Group H
    module φ = GroupHom φ
    module M where
      f : H.El → P.SubEl
      f h = φ.f h , P-all h

      abstract
        pres-comp : ∀ h₁ h₂ → f (H.comp h₁ h₂) == Group.comp (Subgroup P) (f h₁) (f h₂)
        pres-comp h₁ h₂ = Subtype=-out P.subEl-prop (φ.pres-comp h₁ h₂)

full-subgroup : ∀ {i j} {G : Group i} {P : SubgroupProp G j}
  → is-fullᴳ P → Subgroup P ≃ᴳ G
full-subgroup {G = G} {P} full = Subgroup.inject P , is-eq _ from to-from from-to where
  from : Group.El G → Subgroup.El P
  from g = g , full g

  abstract
    from-to : ∀ p → from (fst p) == p
    from-to p = Subtype=-out (SubgroupProp.subEl-prop P) idp

    to-from : ∀ g → fst (from g) == g
    to-from g = idp

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

  private
    module G = Group G
    module H = Group H
    module φ = GroupHom φ

  module Ker = Subgroup (ker-propᴳ φ)
  Ker = Ker.grp

  module Im = Subgroup (im-propᴳ φ)
  Im = Im.grp

  im-lift : G →ᴳ Im
  im-lift = Im.inject-lift φ (λ g → [ g , idp ])

  im-lift-is-surj : is-surjᴳ im-lift
  im-lift-is-surj (_ , s) = Trunc-fmap
    (λ {(g , p) → (g , Subtype=-out (_ , λ _ → Trunc-level) p)}) s

module _ {i j k} {G : Group i} (P : SubgroupProp G j)
  (Q : SubgroupProp G k) where

  -- FIXME looks like a bad name
  Subgroup-fmap-r : P ⊆ᴳ Q → Subgroup P →ᴳ Subgroup Q
  Subgroup-fmap-r P⊆Q = group-hom (Σ-fmap-r P⊆Q)
    (λ _ _ → Subtype=-out (SubgroupProp.subEl-prop Q) idp)

  Subgroup-emap-r : P ⊆ᴳ Q → Q ⊆ᴳ P → Subgroup P ≃ᴳ Subgroup Q
  Subgroup-emap-r P⊆Q Q⊆P = Subgroup-fmap-r P⊆Q ,
    is-eq _ (Σ-fmap-r Q⊆P)
      (λ _ → Subtype=-out (SubgroupProp.subEl-prop Q) idp)
      (λ _ → Subtype=-out (SubgroupProp.subEl-prop P) idp)


{- Basic definitions using Σ-types

Σ-types are defined in Core/Primitives as they are needed for Glue types.

The file contains:

- Non-dependent pair types: A × B
- Mere existence: ∃[x ∈ A] B
- Unique existence: ∃![x ∈ A] B

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Sigma.Base where

open import Cubical.Core.Primitives public

open import Cubical.Foundations.Prelude
open import Cubical.HITs.PropositionalTruncation.Base

-- Non-dependent pair types

_×_ : ∀ {ℓ ℓ'} (A : Type ℓ) (B : Type ℓ') → Type (ℓ-max ℓ ℓ')
A × B = Σ A (λ _ → B)

infixr 5 _×_

-- Mere existence

∃ : ∀ {ℓ ℓ'} (A : Type ℓ) (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ')
∃ A B = ∥ Σ A B ∥

infix 2 ∃-syntax

∃-syntax : ∀ {ℓ ℓ'} (A : Type ℓ) (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ')
∃-syntax = ∃

syntax ∃-syntax A (λ x → B) = ∃[ x ∈ A ] B

-- Unique existence

∃! : ∀ {ℓ ℓ'} (A : Type ℓ) (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ')
∃! A B = isContr (Σ A B)

infix 2 ∃!-syntax

∃!-syntax : ∀ {ℓ ℓ'} (A : Type ℓ) (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ')
∃!-syntax = ∃!

syntax ∃!-syntax A (λ x → B) = ∃![ x ∈ A ] B


------------------------------------------------------------------------------
-- Well-founded induction on the relation TreeT
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.Mirror.TreeR.Induction.Acc.WellFoundedInduction
  where

open import FOTC.Base

open import FOT.FOTC.Program.Mirror.Induction.Acc.WellFounded
open import FOT.FOTC.Program.Mirror.TreeR
open import FOTC.Program.Mirror.Type

------------------------------------------------------------------------------
-- The relation TreeR is well-founded.
postulate wf-TreeR : WellFounded TreeR

-- Well-founded induction on the relation TreeT.
wfInd-TreeR :
  (P : D → Set) →
  (∀ {t} → Tree t → (∀ {t'} → Tree t' → TreeR t' t → P t') → P t) →
  ∀ {t} → Tree t → P t
wfInd-TreeR P = WellFoundedInduction wf-TreeR


------------------------------------------------------------------------
-- The Agda standard library
--
-- Products of nullary relations
------------------------------------------------------------------------

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

module Relation.Nullary.Product where

open import Data.Bool.Base
open import Data.Product
open import Function
open import Level
open import Relation.Nullary.Reflects
open import Relation.Nullary

private
  variable
    p q : Level
    P : Set p
    Q : Set q

------------------------------------------------------------------------
-- Some properties which are preserved by _×_.

infixr 2 _×-reflects_ _×-dec_

_×-reflects_ : ∀ {bp bq} → Reflects P bp → Reflects Q bq →
                           Reflects (P × Q) (bp ∧ bq)
ofʸ  p ×-reflects ofʸ  q = ofʸ (p , q)
ofʸ  p ×-reflects ofⁿ ¬q = ofⁿ (¬q ∘ proj₂)
ofⁿ ¬p ×-reflects _      = ofⁿ (¬p ∘ proj₁)

_×-dec_ : Dec P → Dec Q → Dec (P × Q)
does  (p? ×-dec q?) = does p? ∧ does q?
proof (p? ×-dec q?) = proof p? ×-reflects proof q?


module RMonads.CatofRMonads where

open import Categories
open import Functors
open import RMonads
open import RMonads.RMonadMorphs

CatofRMonads : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}(J : Fun C D) → Cat
CatofRMonads J = record
                 { Obj  = RMonad J
                 ; Hom  = RMonadMorph
                 ; iden = IdRMonadMorph _
                 ; comp = CompRMonadMorph
                 ; idl  = idl _
                 ; idr  = idr _
                 ; ass  = λ{_ _ _ _ f g h} → ass f g h
                 }


{-# OPTIONS --safe --warning=error --without-K #-}

open import Groups.Definition
open import Setoids.Setoids
open import LogicalFormulae
open import Sets.EquivalenceRelations
open import Groups.Homomorphisms.Definition
open import Groups.Homomorphisms.Lemmas
open import Groups.Isomorphisms.Definition
open import Groups.Subgroups.Definition
open import Groups.Lemmas

module Groups.FirstIsomorphismTheorem {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_+G_ : A → A → A} {_+H_ : B → B → B} {G : Group S _+G_} {H : Group T _+H_} {f : A → B} (fHom : GroupHom G H f) where

open import Groups.Homomorphisms.Image fHom
open import Groups.Homomorphisms.Kernel fHom
open import Groups.Cosets G groupKernelIsSubgroup
open import Groups.QuotientGroup.Definition G fHom
open Setoid T
open Equivalence eq
open import Setoids.Subset T

groupFirstIsomorphismTheoremWellDefined : {x y : A} → groupKernelPred (Group.inverse G y +G x) → Setoid._∼_ (subsetSetoid imageGroupSubset) (f x , (x , reflexive)) (f y , (y , reflexive))
groupFirstIsomorphismTheoremWellDefined {x} {y} pr = transitive (symmetric (invTwice H _)) (transitive (symmetric u) (invTwice H _))
  where
    t : Setoid._∼_ T (Group.inverse H (f y) +H (f x)) (Group.0G H)
    t = transitive (transitive (Group.+WellDefined H (symmetric (homRespectsInverse fHom)) reflexive) (symmetric (GroupHom.groupHom fHom))) pr
    u : Setoid._∼_ T (Group.inverse H (Group.inverse H (f y))) (Group.inverse H (Group.inverse H (f x)))
    u = inverseWellDefined H (transferToRight' H t)

groupFirstIsomorphismTheorem : GroupsIsomorphic (cosetGroup groupKernelIsNormalSubgroup) (subgroupIsGroup H imageGroupSubgroup)
GroupsIsomorphic.isomorphism groupFirstIsomorphismTheorem x = f x , (x , reflexive)
GroupHom.groupHom (GroupIso.groupHom (GroupsIsomorphic.proof groupFirstIsomorphismTheorem)) {x} {y} = GroupHom.groupHom fHom
GroupHom.wellDefined (GroupIso.groupHom (GroupsIsomorphic.proof groupFirstIsomorphismTheorem)) {x} {y} = groupFirstIsomorphismTheoremWellDefined {x} {y}
SetoidInjection.wellDefined (SetoidBijection.inj (GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem))) = groupFirstIsomorphismTheoremWellDefined
SetoidInjection.injective (SetoidBijection.inj (GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem))) fx=fy = transitive (GroupHom.groupHom fHom) (transitive (Group.+WellDefined H reflexive fx=fy) (transitive (symmetric (GroupHom.groupHom fHom)) (transitive (GroupHom.wellDefined fHom (Group.invLeft G)) (imageOfIdentityIsIdentity fHom))))
SetoidSurjection.wellDefined (SetoidBijection.surj (GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem))) = groupFirstIsomorphismTheoremWellDefined
SetoidSurjection.surjective (SetoidBijection.surj (GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem))) {b , (a , fa=b)} = a , fa=b

groupFirstIsomorphismTheoremWellDefined' : {x y : A} → f (x +G (Group.inverse G y)) ∼ Group.0G H → Setoid._∼_ (subsetSetoid imageGroupSubset) (f x , (x , reflexive)) (f y , (y , reflexive))
groupFirstIsomorphismTheoremWellDefined' {x} {y} pr = transferToRight H (transitive (symmetric (transitive (GroupHom.groupHom fHom) (Group.+WellDefined H reflexive (homRespectsInverse fHom)))) pr)

groupFirstIsomorphismTheorem' : GroupsIsomorphic (quotientGroupByHom) (subgroupIsGroup H imageGroupSubgroup)
GroupsIsomorphic.isomorphism groupFirstIsomorphismTheorem' a = f a , (a , reflexive)
GroupHom.groupHom (GroupIso.groupHom (GroupsIsomorphic.proof groupFirstIsomorphismTheorem')) {x} {y} = GroupHom.groupHom fHom
GroupHom.wellDefined (GroupIso.groupHom (GroupsIsomorphic.proof groupFirstIsomorphismTheorem')) {x} {y} = groupFirstIsomorphismTheoremWellDefined'
SetoidInjection.wellDefined (SetoidBijection.inj (GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem'))) {x} {y} = groupFirstIsomorphismTheoremWellDefined' {x} {y}
SetoidInjection.injective (SetoidBijection.inj (GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem'))) {x} {y} fx=fy = transitive (GroupHom.groupHom fHom) (transitive (Group.+WellDefined H reflexive (homRespectsInverse fHom)) (transferToRight'' H fx=fy))
SetoidSurjection.wellDefined (SetoidBijection.surj (GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem'))) {x} {y} = groupFirstIsomorphismTheoremWellDefined'
SetoidSurjection.surjective (SetoidBijection.surj (GroupIso.bij (GroupsIsomorphic.proof groupFirstIsomorphismTheorem'))) {b , (a , fa=b)} = a , fa=b


open import Agda.Primitive using (Level; lsuc)

variable
  ℓ p   : Level
  A B   : Set ℓ
  x y z : A

postulate
  easy : A

record R a : Set (lsuc a) where
  field
    _≡_ : {A : Set a} → A → A → Set a

module _ (r : ∀ ℓ → R ℓ) where

  open module R′ {ℓ} = R (r ℓ)

  postulate
    refl      : (x : A) → x ≡ x
    cong      : (f : A → B) → x ≡ y → f x ≡ f y
    subst     : (P : A → Set p) → x ≡ y → P x → P y
    trans     : x ≡ y → y ≡ z → x ≡ z
    elim      : (P : {x y : A} → x ≡ y → Set p) →
                (∀ x → P (refl x)) →
                (x≡y : x ≡ y) → P x≡y
    elim-refl : (P : {x y : A} → x ≡ y → Set p)
                (r : ∀ x → P (refl x)) →
                elim P r (refl x) ≡ r x

  [subst≡]≡[trans≡trans] :
    {p : x ≡ y} {q : x ≡ x} {r : y ≡ y} →
    (subst (λ z → z ≡ z) p q ≡ r)
      ≡
    (trans q p ≡ trans p r)
  [subst≡]≡[trans≡trans] {p = p} {q} {r} = elim
    (λ {x y} p → {q : x ≡ x} {r : y ≡ y} →
                 (subst (λ z → z ≡ z) p q ≡ r)
                   ≡
                 (trans q p ≡ trans p r))
    (λ _ → easy)
    p

  [subst≡]≡[trans≡trans]-refl :
    {q r : x ≡ x} →
    [subst≡]≡[trans≡trans] {p = refl x} {q = q} {r = r} ≡
    easy
  [subst≡]≡[trans≡trans]-refl {q = q} {r = r} =
    cong (λ f → f {q = q} {r = r})
      (elim-refl (λ {x y} _ → {q : x ≡ x} {r : y ≡ y} → _) _)


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

open import HoTT

module homotopy.AnyUniversalCoverIsPathSet {i} (X : Ptd i) where

private
  a₁ = pt X

path-set-is-universal : is-universal (path-set-cover X)
path-set-is-universal = has-level-in ([ pt X , idp₀ ] ,
  Trunc-elim
    {P = λ xp₀ → [ pt X , idp₀ ] == xp₀}
    (λ{(x , p₀) → Trunc-elim
      {P = λ p₀ → [ pt X , idp₀ ] == [ x , p₀ ]}
      (λ p → ap [_] $ pair= p (lemma p))
      p₀ }))
  where
    lemma : ∀ {x} (p : pt X == x) → idp₀ == [ p ] [ (pt X =₀_) ↓ p ]
    lemma idp = idp

module _ {j} (univ-cov : ⊙UniversalCover X j) where
  private
    module univ-cov = ⊙UniversalCover univ-cov
    instance _ = univ-cov.is-univ

    -- One-to-one mapping between the universal cover
    -- and the truncated path spaces from one point.

    [path] : ∀ (a⇑₁ a⇑₂ : univ-cov.TotalSpace) → a⇑₁ =₀ a⇑₂
    [path] a⇑₁ a⇑₂ = –> (Trunc=-equiv [ a⇑₁ ] [ a⇑₂ ])
      (contr-has-all-paths [ a⇑₁ ] [ a⇑₂ ])

    abstract
      [path]-has-all-paths :
        ∀ {a⇑₁ a⇑₂ : univ-cov.TotalSpace}
        → has-all-paths (a⇑₁ =₀ a⇑₂)
      [path]-has-all-paths {a⇑₁} {a⇑₂} =
        transport has-all-paths (ua (Trunc=-equiv [ a⇑₁ ] [ a⇑₂ ])) $
          contr-has-all-paths {{has-level-apply (raise-level -2 univ-cov.is-univ) [ a⇑₁ ] [ a⇑₂ ]}}

    to : ∀ {a₂} → univ-cov.Fiber a₂ → a₁ =₀ a₂
    to {a₂} a⇑₂ = ap₀ fst ([path] (a₁ , univ-cov.pt) (a₂ , a⇑₂))

    from : ∀ {a₂} → a₁ =₀ a₂ → univ-cov.Fiber a₂
    from p = cover-trace univ-cov.cov univ-cov.pt p

    abstract
      to-from : ∀ {a₂} (p : a₁ =₀ a₂) → to (from p) == p
      to-from = Trunc-elim
        (λ p → lemma p)
        where
          lemma : ∀ {a₂} (p : a₁ == a₂) → to (from [ p ]) == [ p ]
          lemma idp =
            ap₀ fst ([path] (a₁ , univ-cov.pt) (a₁ , univ-cov.pt))
              =⟨ ap (ap₀ fst)
                    $ [path]-has-all-paths
                      ([path] (a₁ , univ-cov.pt) (a₁ , univ-cov.pt))
                      (idp₀ :> ((a₁ , univ-cov.pt) =₀ (a₁ , univ-cov.pt))) ⟩
            (idp₀ :> (a₁ =₀ a₁))
              ∎

      from-to : ∀ {a₂} (a⇑₂ : univ-cov.Fiber a₂) → from (to a⇑₂) == a⇑₂
      from-to {a₂} a⇑₂ = Trunc-elim
        {{λ p → =-preserves-level
                {x = from (ap₀ fst p)}
                {y = a⇑₂}
                univ-cov.Fiber-is-set}}
        (λ p → to-transp $ snd= p)
        ([path] (a₁ , univ-cov.pt) (a₂ , a⇑₂))

  theorem : ∀ a₂ → univ-cov.Fiber a₂ ≃ (a₁ =₀ a₂)
  theorem a₂ = to , is-eq _ from to-from from-to


open import Data.Product using ( _×_ ; _,_ )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.ABox using ( ABox ; ε ; _,_ ; _∼_ ; _∈₁_ ; _∈₂_ )
open import Web.Semantic.DL.ABox.Interp using ( ⌊_⌋ ; ind )
open import Web.Semantic.DL.ABox.Model using ( _⊨a_ )
open import Web.Semantic.DL.Concept.Model using ( ⟦⟧₁-resp-≈ )
open import Web.Semantic.DL.Concept.Skolemization using ( CSkolems ; cskolem ; cskolem-sound )
open import Web.Semantic.DL.FOL using  ( Formula ; true ; _∧_ ; _∈₁_ ; _∈₂_ ; _∼_ )
open import Web.Semantic.DL.FOL.Model using ( _⊨f_ )
open import Web.Semantic.DL.Role.Skolemization using ( rskolem ; rskolem-sound )
open import Web.Semantic.DL.Role.Model using ( ⟦⟧₂-resp-≈ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.Util using ( True ; tt )

module Web.Semantic.DL.ABox.Skolemization {Σ : Signature} {X : Set} where

askolem : ∀ {Δ} → (X → Δ) → ABox Σ X → Formula Σ Δ
askolem i ε = true
askolem i (A , B) = (askolem i A) ∧ (askolem i B)
askolem i (x ∼ y) = i x ∼ i y
askolem i (x ∈₁ c) = i x ∈₁ c
askolem i ((x , y) ∈₂ r) = (i x , i y) ∈₂ r

askolem-sound : ∀ I A → (⌊ I ⌋ ⊨f askolem (ind I) A) → (I ⊨a A)
askolem-sound I ε _ = tt
askolem-sound I (A , B) (I⊨A , I⊨B) = (askolem-sound I A I⊨A , askolem-sound I B I⊨B)
askolem-sound I (x ∼ y) I⊨x∼y = I⊨x∼y
askolem-sound I (x ∈₁ c) I⊨x∈c = I⊨x∈c
askolem-sound I ((x , y) ∈₂ r) I⊨xy∈r = I⊨xy∈r


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Algebra (Σ : Signature) where

open import Level using (Level; _⊔_; suc)
open import Data.Vec using (Vec)
open import Data.Vec.Relation.Binary.Pointwise.Inductive using (Pointwise)
open import Relation.Binary using (Setoid; Rel; IsEquivalence)

private
  variable
    a ℓ : Level

module _ (S : Setoid a ℓ) where

  open import Data.Vec.Relation.Binary.Equality.Setoid S using (_≋_)

  open Setoid S renaming (Carrier to A)

  Interpretation : Set a
  Interpretation = ∀ {arity} → (f : ops Σ arity) → Vec A arity → A

  Congruence : Interpretation → Set (a ⊔ ℓ)
  Congruence ⟦_⟧ = ∀ {arity}
                   → (f : ops Σ arity)
                   → ∀ {xs ys} → Pointwise _≈_ xs ys → ⟦ f ⟧ xs ≈ ⟦ f ⟧ ys

  record IsAlgebra : Set (a ⊔ ℓ) where
    field
      ⟦_⟧     : Interpretation
      ⟦⟧-cong : Congruence ⟦_⟧

record Algebra : Set (suc a ⊔ suc ℓ) where
  constructor algebra
  field
    ∥_∥/≈           : Setoid a ℓ
    ∥_∥/≈-isAlgebra : IsAlgebra ∥_∥/≈

  ∥_∥ : Set a
  ∥_∥ = Setoid.Carrier ∥_∥/≈

  infix 10 _⟦_⟧_

  _⟦_⟧_ : Interpretation (∥_∥/≈)
  _⟦_⟧_ = IsAlgebra.⟦_⟧ ∥_∥/≈-isAlgebra

  _⟦_⟧-cong : Congruence (∥_∥/≈) (_⟦_⟧_)
  _⟦_⟧-cong = IsAlgebra.⟦⟧-cong ∥_∥/≈-isAlgebra

  ≈[_] : Rel ∥_∥ ℓ
  ≈[_] = Setoid._≈_ ∥_∥/≈

  ≈[_]-isEquivalence : IsEquivalence ≈[_]
  ≈[_]-isEquivalence = Setoid.isEquivalence ∥_∥/≈

open Algebra public

infix 5 ≈-syntax

≈-syntax : (A : Algebra {a} {ℓ}) → ∥ A ∥ → ∥ A ∥ → Set ℓ
≈-syntax A x y = Setoid._≈_ ∥ A ∥/≈ x y

syntax ≈-syntax A x y = x =[ A ] y


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

module Categories.Category.Concrete.Properties where

open import Data.Unit.Polymorphic
open import Function.Equality using (Π; _⟨$⟩_; const; _∘_)
open import Level
open import Relation.Binary using (Setoid)
import Relation.Binary.Reasoning.Setoid as SR

open import Categories.Adjoint using (_⊣_; Adjoint)
open import Categories.Category.Core using (Category)
open import Categories.Category.Instance.Setoids using (Setoids)
open import Categories.Category.Concrete
open import Categories.Functor.Core using (Functor)
open import Categories.Functor.Representable using (Representable)
open import Categories.Functor.Properties using (Faithful)
import Categories.Morphism.Reasoning as MR
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper)

open Concrete

⊣⇒Representable : {o ℓ e : Level} (C : Category o ℓ e) (conc : Concrete C ℓ e) → (F : Functor (Setoids ℓ e) C) →
  F ⊣ concretize conc  → RepresentablyConcrete C
⊣⇒Representable {_} {ℓ} {e} C conc F L = record
  { conc = conc
  ; representable = record
    { A = F.₀ OneS
    ; Iso = record
      { F⇒G = ntHelper record
        { η = λ X → record
          { _⟨$⟩_ = λ x → L.counit.η X C.∘ F.₁ (const x)
          ; cong = λ i≈j → C.∘-resp-≈ʳ (F.F-resp-≈ λ _ → i≈j)
          }
        ; commute = λ {X} {Y} f {x} {y} x≈y →
            let open C.HomReasoning in begin
            L.counit.η Y C.∘ F.₁ (const (U.₁ f ⟨$⟩ x))          ≈⟨ refl⟩∘⟨ F.F-resp-≈ (λ _ → Π.cong (U.₁ f) x≈y) ⟩
            L.counit.η Y C.∘ F.₁ (U.F₁ f ∘ const y)            ≈⟨ pushʳ F.homomorphism ⟩
            ((L.counit.η Y C.∘ F.₁ (U.₁ f)) C.∘ F.₁ (const y)) ≈⟨ pushˡ (commute L.counit f) ⟩
            f C.∘ L.counit.η X C.∘ F.₁ (const y)               ≈˘⟨ C.identityʳ ⟩
            (f C.∘ L.counit.η X C.∘ F.₁ (const y)) C.∘ C.id    ∎
        }
      ; F⇐G = ntHelper record
        { η = λ c → record
          { _⟨$⟩_ = λ 1⇒c → U.₁ 1⇒c ⟨$⟩ η1
          ; cong = λ i≈j → U.F-resp-≈ i≈j (Setoid.refl (U.₀ (F.₀ OneS)))
          }
        ; commute = λ {X} {Y} f {x} {y} x≈y →
             let module CH = C.HomReasoning in
             let open SR (U.₀ Y) in
             begin
             U.₁ ((f C.∘ x) C.∘ C.id) ⟨$⟩ η1 ≈⟨ U.F-resp-≈ (C.identityʳ CH.○ (CH.refl⟩∘⟨ x≈y)) Srefl ⟩
             U.₁ (f C.∘ y) ⟨$⟩ η1            ≈⟨ U.homomorphism Srefl ⟩
             U.₁ f ⟨$⟩ (U.₁ y ⟨$⟩ η1)         ∎
        }
      ; iso = λ X → record
        { isoˡ = λ {x} {y} x≈y → Setoid.trans (U.₀ X) (L.LRadjunct≈id {OneS} {X} {const x} tt) x≈y
        ; isoʳ = λ {1⇒x} {1⇒y} x≈y →
          let open C.HomReasoning in begin
          L.counit.η X C.∘ F.₁ (const (U.₁ 1⇒x ⟨$⟩ η1))   ≈⟨ (refl⟩∘⟨ F.F-resp-≈ λ _ → U.F-resp-≈ x≈y Srefl) ⟩
          L.counit.η X C.∘ F.₁ (U.₁ 1⇒y ∘ L.unit.η OneS)  ≈⟨ L.RLadjunct≈id {OneS} {X} {1⇒y}  ⟩
          1⇒y ∎
        }
      }
    }
  }
  where
  module C = Category C
  module U = Functor (concretize conc)
  module F = Functor F
  module L = Adjoint L
  open NaturalTransformation
  open MR C
  -- Is this somewhere else?  Should it be?
  OneS : Setoid ℓ e
  OneS = record { Carrier = ⊤ {ℓ} ; _≈_ = λ _ _ → ⊤ {e}}
  η1 : Setoid.Carrier (U.₀ (F.₀ OneS))
  η1 = L.unit.η OneS ⟨$⟩ tt
  Srefl = Setoid.refl (U.₀ (F.₀ OneS))


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

open import Categories.Category
open import Categories.Functor hiding (id)

-- Coimit of a Cocone over a Functor F : J → C
module Categories.Diagram.Colimit
  {o ℓ e} {o′ ℓ′ e′} {C : Category o ℓ e} {J : Category o′ ℓ′ e′} (F : Functor J C) where

private
  module C = Category C
  module J = Category J
open C
open HomReasoning
open Functor F

open import Level
open import Data.Product using (proj₂)

open import Categories.Category.Construction.Cocones F renaming (Cocone⇒ to _⇨_)
open import Categories.Object.Initial as I hiding (up-to-iso; transport-by-iso)
open import Categories.Morphism.Reasoning C
open import Categories.Morphism C
open import Categories.Morphism Cocones as MC using () renaming (_≅_ to _⇔_)

private
  variable
    K K′  : Cocone
    A B   : J.Obj
    X Y Z : Obj
    q     : K ⇨ K′

-- A Colimit is an Initial object in the category of Cocones
--   (This could be unpacked...)
record Colimit : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  field
    initial : Initial Cocones

  module initial = Initial initial

  open initial using () renaming (⊥ to colimit) public
  open Cocone colimit hiding (coapex) renaming (N to coapex; ψ to proj; commute to colimit-commute) public

  rep-cocone : ∀ K → colimit ⇨ K
  rep-cocone K = initial.! {K}

  rep : ∀ K → coapex ⇒ Cocone.N K
  rep K = arr
    where open _⇨_ (rep-cocone K)

  unrep : coapex ⇒ X → Cocone
  unrep f = record {
    coapex        = record
      { ψ       = λ A → f ∘ proj A
      ; commute = λ g → pullʳ (colimit-commute g)
      }
    }

  coconify : (f : coapex ⇒ X) → colimit ⇨ unrep f
  coconify f = record
    { arr     = f
    ; commute = refl
    }

  commute : rep K ∘ proj A ≈ Cocone.ψ K A
  commute {K = K} = _⇨_.commute (rep-cocone K)

  unrep-cone : (colimit ⇨ K) → Cocone
  unrep-cone f = unrep (_⇨_.arr f)

  g-η : ∀ {f : coapex ⇒ X} → rep (unrep f) ≈ f
  g-η {f = f} = initial.!-unique (coconify f)

  η-cocone : Cocones [ rep-cocone colimit ≈ Category.id Cocones ]
  η-cocone = initial.⊥-id (rep-cocone colimit)

  η : rep colimit ≈ id
  η = η-cocone

  rep-cocone∘ : Cocones [ Cocones [ q ∘ rep-cocone K ] ≈ rep-cocone K′ ]
  rep-cocone∘ {K = K} {q = q} = Equiv.sym (initial.!-unique (Cocones [ q ∘ rep-cocone K ]))

  rep∘ : ∀ {q : K ⇨ K′} → _⇨_.arr q ∘ rep K ≈ rep K′
  rep∘ {q = q} = rep-cocone∘ {q = q}

  rep-cone-self-id : Cocones [ rep-cocone colimit ≈  Cocones.id  ]
  rep-cone-self-id = initial.!-unique ( Cocones.id )

  rep-self-id : rep colimit ≈ id
  rep-self-id = rep-cone-self-id

open Colimit

up-to-iso-cone : (L₁ L₂ : Colimit) → colimit L₁ ⇔ colimit L₂
up-to-iso-cone L₁ L₂ =  I.up-to-iso Cocones (initial L₁) (initial L₂)

up-to-iso : (L₁ L₂ : Colimit) → coapex L₁ ≅ coapex L₂
up-to-iso L₁ L₂ =  iso-cocone⇒iso-coapex (up-to-iso-cone L₁ L₂)

transport-by-iso-cocone : (C : Colimit) → colimit C ⇔ K → Colimit
transport-by-iso-cocone C C⇿K = record
  { initial =  I.transport-by-iso Cocones (initial C) C⇿K
  }

transport-by-iso : (C : Colimit) → coapex C ≅ X → Colimit
transport-by-iso C C≅X = transport-by-iso-cocone C (proj₂ p)
  where p = cocone-resp-iso (colimit C) C≅X


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Relation.Binary.Raw where

open import Cubical.Relation.Binary.Base public
open import Cubical.Relation.Binary.Raw.Definitions public
open import Cubical.Relation.Binary.Raw.Structures public
open import Cubical.Relation.Binary.Raw.Bundles public


{-

This file contains:

- Definition of set truncations

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

open import Cubical.Core.Primitives
open import Cubical.Foundations.Pointed

-- set truncation as a higher inductive type:

data ∥_∥₂ {ℓ} (A : Type ℓ) : Type ℓ where
  ∣_∣₂ : A → ∥ A ∥₂
  squash₂ : ∀ (x y : ∥ A ∥₂) (p q : x ≡ y) → p ≡ q

-- Pointed version
∥_∥₂∙ : ∀ {ℓ} (A : Pointed ℓ) → Pointed ℓ
fst ∥ A ∥₂∙ = ∥ fst A ∥₂
snd ∥ A ∥₂∙ = ∣ pt A ∣₂


------------------------------------------------------------------------
-- The Agda standard library
--
-- Vectors
------------------------------------------------------------------------

module Data.Vec where

open import Category.Applicative
open import Data.Nat
open import Data.Fin using (Fin; zero; suc)
open import Data.List as List using (List)
open import Data.Product as Prod using (∃; ∃₂; _×_; _,_)
open import Function
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

------------------------------------------------------------------------
-- Types

infixr 5 _∷_

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

infix 4 _∈_

data _∈_ {a} {A : Set a} : A → {n : ℕ} → Vec A n → Set a where
  here  : ∀ {n} {x}   {xs : Vec A n} → x ∈ x ∷ xs
  there : ∀ {n} {x y} {xs : Vec A n} (x∈xs : x ∈ xs) → x ∈ y ∷ xs

infix 4 _[_]=_

data _[_]=_ {a} {A : Set a} :
            {n : ℕ} → Vec A n → Fin n → A → Set a where
  here  : ∀ {n}     {x}   {xs : Vec A n} → x ∷ xs [ zero ]= x
  there : ∀ {n} {i} {x y} {xs : Vec A n}
          (xs[i]=x : xs [ i ]= x) → y ∷ xs [ suc i ]= x

------------------------------------------------------------------------
-- Some operations

head : ∀ {a n} {A : Set a} → Vec A (1 + n) → A
head (x ∷ xs) = x

tail : ∀ {a n} {A : Set a} → Vec A (1 + n) → Vec A n
tail (x ∷ xs) = xs

[_] : ∀ {a} {A : Set a} → A → Vec A 1
[ x ] = x ∷ []

infixr 5 _++_

_++_ : ∀ {a m n} {A : Set a} → Vec A m → Vec A n → Vec A (m + n)
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

infixl 4 _⊛_

_⊛_ : ∀ {a b n} {A : Set a} {B : Set b} →
      Vec (A → B) n → Vec A n → Vec B n
[]       ⊛ _        = []
(f ∷ fs) ⊛ (x ∷ xs) = f x ∷ (fs ⊛ xs)

replicate : ∀ {a n} {A : Set a} → A → Vec A n
replicate {n = zero}  x = []
replicate {n = suc n} x = x ∷ replicate x

applicative : ∀ {a n} → RawApplicative (λ (A : Set a) → Vec A n)
applicative = record
  { pure = replicate
  ; _⊛_  = _⊛_
  }

map : ∀ {a b n} {A : Set a} {B : Set b} →
      (A → B) → Vec A n → Vec B n
map f xs = replicate f ⊛ xs

zipWith : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c} →
          (A → B → C) → Vec A n → Vec B n → Vec C n
zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

zip : ∀ {a b n} {A : Set a} {B : Set b} →
      Vec A n → Vec B n → Vec (A × B) n
zip = zipWith _,_

unzip : ∀ {a b n} {A : Set a} {B : Set b} →
        Vec (A × B) n → Vec A n × Vec B n
unzip []              = [] , []
unzip ((x , y) ∷ xys) = Prod.map (_∷_ x) (_∷_ y) (unzip xys)

foldr : ∀ {a b} {A : Set a} (B : ℕ → Set b) {m} →
        (∀ {n} → A → B n → B (suc n)) →
        B zero →
        Vec A m → B m
foldr b _⊕_ n []       = n
foldr b _⊕_ n (x ∷ xs) = x ⊕ foldr b _⊕_ n xs

foldr₁ : ∀ {a} {A : Set a} {m} →
         (A → A → A) → Vec A (suc m) → A
foldr₁ _⊕_ (x ∷ [])     = x
foldr₁ _⊕_ (x ∷ y ∷ ys) = x ⊕ foldr₁ _⊕_ (y ∷ ys)

foldl : ∀ {a b} {A : Set a} (B : ℕ → Set b) {m} →
        (∀ {n} → B n → A → B (suc n)) →
        B zero →
        Vec A m → B m
foldl b _⊕_ n []       = n
foldl b _⊕_ n (x ∷ xs) = foldl (λ n → b (suc n)) _⊕_ (n ⊕ x) xs

foldl₁ : ∀ {a} {A : Set a} {m} →
         (A → A → A) → Vec A (suc m) → A
foldl₁ _⊕_ (x ∷ xs) = foldl _ _⊕_ x xs

concat : ∀ {a m n} {A : Set a} →
         Vec (Vec A m) n → Vec A (n * m)
concat []         = []
concat (xs ∷ xss) = xs ++ concat xss

splitAt : ∀ {a} {A : Set a} m {n} (xs : Vec A (m + n)) →
          ∃₂ λ (ys : Vec A m) (zs : Vec A n) → xs ≡ ys ++ zs
splitAt zero    xs                = ([] , xs , refl)
splitAt (suc m) (x ∷ xs)          with splitAt m xs
splitAt (suc m) (x ∷ .(ys ++ zs)) | (ys , zs , refl) =
  ((x ∷ ys) , zs , refl)

take : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m
take m xs          with splitAt m xs
take m .(ys ++ zs) | (ys , zs , refl) = ys

drop : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A n
drop m xs          with splitAt m xs
drop m .(ys ++ zs) | (ys , zs , refl) = zs

group : ∀ {a} {A : Set a} n k (xs : Vec A (n * k)) →
        ∃ λ (xss : Vec (Vec A k) n) → xs ≡ concat xss
group zero    k []                  = ([] , refl)
group (suc n) k xs                  with splitAt k xs
group (suc n) k .(ys ++ zs)         | (ys , zs , refl) with group n k zs
group (suc n) k .(ys ++ concat zss) | (ys , ._ , refl) | (zss , refl) =
  ((ys ∷ zss) , refl)

-- Splits a vector into two "halves".

split : ∀ {a n} {A : Set a} → Vec A n → Vec A ⌈ n /2⌉ × Vec A ⌊ n /2⌋
split []           = ([]     , [])
split (x ∷ [])     = (x ∷ [] , [])
split (x ∷ y ∷ xs) = Prod.map (_∷_ x) (_∷_ y) (split xs)

reverse : ∀ {a n} {A : Set a} → Vec A n → Vec A n
reverse {A = A} = foldl (Vec A) (λ rev x → x ∷ rev) []

sum : ∀ {n} → Vec ℕ n → ℕ
sum = foldr _ _+_ 0

toList : ∀ {a n} {A : Set a} → Vec A n → List A
toList []       = List.[]
toList (x ∷ xs) = List._∷_ x (toList xs)

fromList : ∀ {a} {A : Set a} → (xs : List A) → Vec A (List.length xs)
fromList List.[]         = []
fromList (List._∷_ x xs) = x ∷ fromList xs

-- Snoc.

infixl 5 _∷ʳ_

_∷ʳ_ : ∀ {a n} {A : Set a} → Vec A n → A → Vec A (1 + n)
[]       ∷ʳ y = [ y ]
(x ∷ xs) ∷ʳ y = x ∷ (xs ∷ʳ y)

initLast : ∀ {a n} {A : Set a} (xs : Vec A (1 + n)) →
           ∃₂ λ (ys : Vec A n) (y : A) → xs ≡ ys ∷ʳ y
initLast {n = zero}  (x ∷ [])         = ([] , x , refl)
initLast {n = suc n} (x ∷ xs)         with initLast xs
initLast {n = suc n} (x ∷ .(ys ∷ʳ y)) | (ys , y , refl) =
  ((x ∷ ys) , y , refl)

init : ∀ {a n} {A : Set a} → Vec A (1 + n) → Vec A n
init xs         with initLast xs
init .(ys ∷ʳ y) | (ys , y , refl) = ys

last : ∀ {a n} {A : Set a} → Vec A (1 + n) → A
last xs         with initLast xs
last .(ys ∷ʳ y) | (ys , y , refl) = y

infixl 1 _>>=_

_>>=_ : ∀ {a b m n} {A : Set a} {B : Set b} →
        Vec A m → (A → Vec B n) → Vec B (m * n)
xs >>= f = concat (map f xs)

infixl 4 _⊛*_

_⊛*_ : ∀ {a b m n} {A : Set a} {B : Set b} →
       Vec (A → B) m → Vec A n → Vec B (m * n)
fs ⊛* xs = fs >>= λ f → map f xs

-- Interleaves the two vectors.

infixr 5 _⋎_

_⋎_ : ∀ {a m n} {A : Set a} →
      Vec A m → Vec A n → Vec A (m +⋎ n)
[]       ⋎ ys = ys
(x ∷ xs) ⋎ ys = x ∷ (ys ⋎ xs)

-- A lookup function.

lookup : ∀ {a n} {A : Set a} → Fin n → Vec A n → A
lookup zero    (x ∷ xs) = x
lookup (suc i) (x ∷ xs) = lookup i xs

-- An inverse of flip lookup.

tabulate : ∀ {n a} {A : Set a} → (Fin n → A) → Vec A n
tabulate {zero}  f = []
tabulate {suc n} f = f zero ∷ tabulate (f ∘ suc)

-- Update.

infixl 6 _[_]≔_

_[_]≔_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A → Vec A n
[]       [ ()    ]≔ y
(x ∷ xs) [ zero  ]≔ y = y ∷ xs
(x ∷ xs) [ suc i ]≔ y = x ∷ xs [ i ]≔ y

-- Generates a vector containing all elements in Fin n. This function
-- is not placed in Data.Fin because Data.Vec depends on Data.Fin.
--
-- The implementation was suggested by Conor McBride ("Fwd: how to
-- count 0..n-1", http://thread.gmane.org/gmane.comp.lang.agda/2554).

allFin : ∀ n → Vec (Fin n) n
allFin _ = tabulate id


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

module Data.Bool.Base where

open import Level
open import Agda.Builtin.Bool using (Bool; true; false) public
open import Data.Unit

bool : ∀ {ℓ} {P : Bool → Type ℓ} (f : P false) (t : P true) → (x : Bool) → P x
bool f t false = f
bool f t true = t
{-# INLINE bool #-}

bool′ : A → A → Bool → A
bool′ = bool
{-# INLINE bool′ #-}

not : Bool → Bool
not false = true
not true = false

infixl 6 _or_
_or_ : Bool → Bool → Bool
false or y = y
true  or y = true

infixl 7 _and_
_and_ : Bool → Bool → Bool
false and y = false
true  and y = y

infixr 0 if_then_else_
if_then_else_ : ∀ {a} {A : Set a} → Bool → A → A → A
if p then x else y = bool y x p
{-# INLINE if_then_else_ #-}


{-# OPTIONS --without-K --safe #-}
module Categories.Bicategory.Monad.Properties where

open import Categories.Category
open import Categories.Bicategory.Instance.Cats
open import Categories.NaturalTransformation using (NaturalTransformation)
open import Categories.Functor using (Functor)

import Categories.Bicategory.Monad as BicatMonad
import Categories.Monad as ElemMonad

import Categories.Morphism.Reasoning as MR

--------------------------------------------------------------------------------
-- Bicategorical Monads in Cat are the same as the more elementary
-- definition of Monads.

CatMonad⇒Monad : ∀ {o ℓ e} → (T : BicatMonad.Monad (Cats o ℓ e)) → ElemMonad.Monad (BicatMonad.Monad.C T)
CatMonad⇒Monad T = record
  { F = T.T
  ; η = T.η
  ; μ = T.μ
  ; assoc = λ {X} → begin
    η T.μ X ∘ F₁ T.T (η T.μ X)               ≈⟨ intro-ids ⟩
    (η T.μ X ∘ (F₁ T.T (η T.μ X) ∘ id) ∘ id) ≈⟨ T.assoc ⟩
    (η T.μ X ∘ F₁ T.T id ∘ η T.μ (F₀ T.T X)) ≈⟨ ∘-resp-≈ʳ (∘-resp-≈ˡ (identity T.T) ○ identityˡ) ⟩
    η T.μ X ∘ η T.μ (F₀ T.T X)               ∎
  ; sym-assoc = λ {X} → begin
    η T.μ X ∘ η T.μ (F₀ T.T X)                    ≈⟨ intro-F-ids ⟩
    η T.μ X ∘ (F₁ T.T id ∘ η T.μ (F₀ T.T X)) ∘ id ≈⟨ T.sym-assoc ⟩
    η T.μ X ∘ F₁ T.T (η T.μ X) ∘ id               ≈⟨ ∘-resp-≈ʳ identityʳ ⟩
    η T.μ X ∘ F₁ T.T (η T.μ X)                    ∎
  ; identityˡ = λ {X} → begin
    η T.μ X ∘ F₁ T.T (η T.η X)             ≈⟨ intro-ids ⟩
    η T.μ X ∘ (F₁ T.T (η T.η X) ∘ id) ∘ id ≈⟨ T.identityˡ ⟩
    id                                     ∎
  ; identityʳ = λ {X} → begin
    η T.μ X ∘ η T.η (F₀ T.T X)                    ≈⟨ intro-F-ids ⟩
    η T.μ X ∘ (F₁ T.T id ∘ η T.η (F₀ T.T X)) ∘ id ≈⟨ T.identityʳ ⟩
    id                                            ∎
  }
  where
    module T = BicatMonad.Monad T
    open Category (BicatMonad.Monad.C T)
    open HomReasoning
    open Equiv
    open MR (BicatMonad.Monad.C T)

    open NaturalTransformation
    open Functor

    intro-ids : ∀ {X Y Z} {f : Y ⇒ Z} {g : X ⇒ Y} → f ∘ g ≈ f ∘ (g ∘ id) ∘ id
    intro-ids = ⟺ (∘-resp-≈ʳ identityʳ) ○ ⟺ (∘-resp-≈ʳ identityʳ)

    intro-F-ids : ∀ {X Y Z} {f : F₀ T.T Y ⇒ Z} {g : X ⇒ F₀ T.T Y} → f ∘ g ≈ f ∘ (F₁ T.T id ∘ g) ∘ id
    intro-F-ids = ∘-resp-≈ʳ (⟺ identityˡ ○  ⟺ (∘-resp-≈ˡ (identity T.T))) ○ ⟺ (∘-resp-≈ʳ identityʳ)

Monad⇒CatMonad : ∀ {o ℓ e} {𝒞 : Category o ℓ e} → (T : ElemMonad.Monad 𝒞) → BicatMonad.Monad (Cats o ℓ e)
Monad⇒CatMonad {𝒞 = 𝒞} T = record
  { C = 𝒞
  ; T = T.F
  ; η = T.η
  ; μ = T.μ
  ; assoc = λ {X} → begin
    T.μ.η X ∘ (T.F.F₁ (T.μ.η X) ∘ id) ∘ id ≈⟨ eliminate-ids ⟩
    T.μ.η X ∘ T.F.F₁ (T.μ.η X)             ≈⟨ T.assoc ⟩
    T.μ.η X ∘ T.μ.η (T.F.F₀ X)             ≈⟨ ∘-resp-≈ʳ (⟺ identityˡ ○ ∘-resp-≈ˡ (⟺ T.F.identity)) ⟩
    T.μ.η X ∘ T.F.F₁ id ∘ T.μ.η (T.F.F₀ X) ∎
  ; sym-assoc = λ {X} → begin
    T.μ.η X ∘ (T.F.F₁ id ∘ T.μ.η (T.F.F₀ X)) ∘ id ≈⟨ eliminate-F-ids ⟩
    T.μ.η X ∘ T.μ.η (T.F.F₀ X)                    ≈⟨ T.sym-assoc ⟩
    T.μ.η X ∘ T.F.F₁ (T.μ.η X)                    ≈⟨ ∘-resp-≈ʳ (⟺ identityʳ) ⟩
    T.μ.η X ∘ T.F.F₁ (T.μ.η X) ∘ id               ∎
  ; identityˡ = λ {X} → begin
    T.μ.η X ∘ (T.F.F₁ (T.η.η X) ∘ id) ∘ id ≈⟨ eliminate-ids ⟩
    T.μ.η X ∘ T.F.F₁ (T.η.η X)             ≈⟨ T.identityˡ ⟩
    id                                     ∎
  ; identityʳ = λ {X} → begin
    (T.μ.η X ∘ (T.F.F₁ id ∘ T.η.η (T.F.F₀ X)) ∘ id) ≈⟨ eliminate-F-ids ⟩
    T.μ.η X ∘ T.η.η (T.F.F₀ X)                      ≈⟨ T.identityʳ ⟩
    id                                              ∎
  }
  where
    module T = ElemMonad.Monad T
    open Category 𝒞
    open HomReasoning
    open MR 𝒞

    eliminate-ids : ∀ {X Y Z} {f : Y ⇒ Z} {g : X ⇒ Y} →  f ∘ (g ∘ id) ∘ id ≈ f ∘ g
    eliminate-ids = ∘-resp-≈ʳ identityʳ ○ ∘-resp-≈ʳ identityʳ

    eliminate-F-ids : ∀ {X Y Z} {f : T.F.F₀ Y ⇒ Z} {g : X ⇒ T.F.F₀ Y} →  f ∘ (T.F.F₁ id ∘ g) ∘ id ≈ f ∘ g
    eliminate-F-ids = ∘-resp-≈ʳ identityʳ ○ ∘-resp-≈ʳ (∘-resp-≈ˡ T.F.identity ○ identityˡ)


module SystemF.Syntax.Type where

open import Prelude
open import Data.Fin hiding (lift)
open import Data.Fin.Substitution
open import Extensions.Substitution
open import Data.Star using (Star; ε; _◅_)

infixl 10 _→'_
data Type (ν : ℕ) : Set where
  tc   : ℕ → Type ν
  tvar : (n : Fin ν) → Type ν
  _→'_ : Type ν → Type ν → Type ν
  _⟶_ : Type ν → Type ν → Type ν
  ∀'   : Type (suc ν) → Type ν

data Base {ν} : (Type ν) → Set where
  tc   : ∀ n → Base (tc n)
  tvar : ∀ n → Base (tvar n)
  _⟶_ : ∀ a b → Base (a ⟶ b)

module Functions where

  -- proposition that states that the given polytype
  -- is a (possibly polymorphic) function
  data IsFunction {ν : ℕ} : Type ν → Set where
    lambda : (a b : Type ν) → IsFunction (a →' b)
    ∀'-lambda : ∀ {f} → IsFunction f → IsFunction (∀' f)

  -- decision procedure for IsFunction
  is-function : ∀ {ν} → (a : Type ν) → Dec (IsFunction a)
  is-function (tc c) = no (λ ())
  is-function (tvar n) = no (λ ())
  is-function (a →' b) = yes (lambda a b)
  is-function (a ⟶ b) = no (λ ())
  is-function (∀' a) with is-function a
  is-function (∀' a) | yes a-is-f = yes $ ∀'-lambda a-is-f
  is-function (∀' a) | no a-not-f = no (λ{ (∀'-lambda a-is-f) → a-not-f a-is-f })

  domain : ∀ {ν} {f : Type ν} → IsFunction f → Type ν
  domain (lambda a b) = a
  domain (∀'-lambda f) = ∀' (domain f)

  codomain : ∀ {ν} {f : Type ν} → IsFunction f → Type ν
  codomain (lambda a b) = b
  codomain (∀'-lambda f) = ∀' (codomain f)

open Functions public


{-# OPTIONS --no-termination-check #-}

module AC where

import Nat
import Bool
import List
import Fin
import Logic
import Vec
import EqProof

open Nat hiding (_<_) renaming (_==_ to _=Nat=_)
open Bool
open List hiding (module Eq)
open Fin renaming (_==_ to _=Fin=_)
open Logic
open Vec

infix 20 _○_
infix 10 _≡_

ForAll : {A : Set}(n : Nat) -> (Vec n A -> Set) -> Set
ForAll      zero   F = F ε
ForAll {A} (suc n) F = (x : A) -> ForAll _ \xs -> F (x ∷ xs)

apply : {n : Nat}{A : Set}(F : Vec n A -> Set) -> ForAll n F -> (xs : Vec n A) -> F xs
apply {zero}  F t (vec vnil)         = t
apply {suc n} F f (vec (vcons x xs)) = apply _ (f x) xs

lambda : {n : Nat}{A : Set}(F : Vec n A -> Set) -> ((xs : Vec n A) -> F xs) -> ForAll n F
lambda {zero } F f = f ε
lambda {suc n} F f = \x -> lambda _ (\xs -> f (x ∷ xs))

data Expr (n : Nat) : Set where
  zro : Expr n
  var : Fin n -> Expr n
  _○_ : Expr n -> Expr n -> Expr n

data Theorem (n : Nat) : Set where
  _≡_ : Expr n -> Expr n -> Theorem n

theorem : (n : Nat) -> ({m : Nat} -> ForAll {Expr m} n \_ -> Theorem m) -> Theorem n
theorem n thm = apply _ thm (map var (fzeroToN-1 n))

module Provable where

  NF : Nat -> Set
  NF n = List (Fin n)

  infix 12 _⊕_

  _⊕_ : {n : Nat} -> NF n -> NF n -> NF n
  []      ⊕ ys              = ys
  x :: xs ⊕ []              = x :: xs
  x :: xs ⊕ y :: ys = if   x < y
                      then x :: (xs ⊕ y :: ys)
                      else y :: (x :: xs ⊕ ys)

  normalise : {n : Nat} -> Expr n -> NF n
  normalise  zro    = []
  normalise (var n) = n :: []
  normalise (a ○ b) = normalise a ⊕ normalise b

  infix 30 _↓

  _↓ : {n : Nat} -> NF n -> Expr n
  (i :: is) ↓ = var i ○ is ↓
  []        ↓ = zro

  infix 10 _=Expr=_ _=NF=_

  _=NF=_ : {n : Nat} -> NF n -> NF n -> Bool
  _=NF=_ = ListEq._==_
    where
      module ListEq = List.Eq _=Fin=_

  substNF : {n : Nat}{xs ys : NF n}(P : NF n -> Set) -> IsTrue (xs =NF= ys) -> P xs -> P ys
  substNF = List.Subst.subst _=Fin=_ (subst {_})

  _=Expr=_ : {n : Nat} -> Expr n -> Expr n -> Bool
  a =Expr= b = normalise a =NF= normalise b

  provable : {n : Nat} -> Theorem n -> Bool
  provable (a ≡ b) = a =Expr= b

module Semantics
  {A     : Set}
  (_==_  : A -> A -> Set)
  (_*_   : A -> A -> A)
  (one   : A)
  (refl  : {x : A} -> x == x)
  (sym   : {x y : A} -> x == y -> y == x)
  (trans : {x y z : A} -> x == y -> y == z -> x == z)
  (idL   : {x : A} -> (one * x) == x)
  (idR   : {x : A} -> (x * one) == x)
  (comm  : {x y : A} -> (x * y) == (y * x))
  (assoc : {x y z : A} -> (x * (y * z)) == ((x * y) * z))
  (congL : {x y z : A} -> y == z -> (x * y) == (x * z))
  (congR : {x y z : A} -> x == y -> (x * z) == (y * z))
  where

  open Provable

  module EqP = EqProof _==_ refl trans
  open EqP

  expr[_] : {n : Nat} -> Expr n -> Vec n A -> A
  expr[ zro   ] ρ = one
  expr[ var i ] ρ = ρ ! i
  expr[ a ○ b ] ρ = expr[ a ] ρ * expr[ b ] ρ

  eq[_] : {n : Nat} -> Theorem n -> Vec n A -> Set
  eq[ a ≡ b ] ρ = expr[ a ] ρ == expr[ b ] ρ

  data CantProve (A : Set) : Set where
    no-proof : CantProve A

  Prf : {n : Nat} -> Theorem n -> Bool -> Set
  Prf thm true  = ForAll _ \ρ -> eq[ thm ] ρ
  Prf thm false = CantProve (Prf thm true)

  Proof : {n : Nat} -> Theorem n -> Set
  Proof thm = Prf thm (provable thm)

  lem0 : {n : Nat} -> (xs ys : NF n) -> (ρ : Vec n A) ->
         eq[ xs ↓ ○ ys ↓ ≡ (xs ⊕ ys) ↓ ] ρ
  lem0 []        ys        ρ = idL
  lem0 (x :: xs) []        ρ = idR
  lem0 (x :: xs) (y :: ys) ρ = if' x < y then less else more
    where
      lhs     = (var x ○ xs ↓) ○ (var y ○ ys ↓)
      lbranch = x :: (xs ⊕ y :: ys)
      rbranch = y :: (x :: xs ⊕ ys)

      P = \z -> eq[ lhs ≡ (if z then lbranch else rbranch) ↓ ] ρ

      less : IsTrue (x < y) -> _
      less x<y = BoolEq.subst {true}{x < y} P x<y
                  (spine (lem0 xs (y :: ys) ρ))
        where
          spine : forall {x' xs' y' ys' zs} h -> _
          spine {x'}{xs'}{y'}{ys'}{zs} h =
            eqProof> (x' * xs') * (y' * ys')
                 === x' * (xs' * (y' * ys'))  by  sym assoc
                 === x' * zs              by  congL h

      more : IsFalse (x < y) -> _
      more x>=y = BoolEq.subst {false}{x < y} P x>=y
                    (spine (lem0 (x :: xs) ys ρ))
        where
          spine : forall {x' xs' y' ys' zs} h -> _
          spine {x'}{xs'}{y'}{ys'}{zs} h =
            eqProof> (x' * xs') * (y' * ys')
                 === (y' * ys') * (x' * xs')  by  comm
                 === y' * (ys' * (x' * xs'))  by  sym assoc
                 === y' * ((x' * xs') * ys')  by  congL comm
                 === y' * zs              by  congL h

  lem1 : {n : Nat} -> (e : Expr n) -> (ρ : Vec n A) -> eq[ e ≡ normalise e ↓ ] ρ
  lem1  zro    ρ = refl
  lem1 (var i) ρ = sym idR
  lem1 (a ○ b) ρ = trans step1 (trans step2 step3)
    where
      step1 : eq[ a ○ b ≡ normalise a ↓ ○ b ] ρ
      step1 = congR (lem1 a ρ)

      step2 : eq[ normalise a ↓ ○ b ≡ normalise a ↓ ○ normalise b ↓ ] ρ
      step2 = congL (lem1 b ρ)

      step3 : eq[ normalise a ↓ ○ normalise b ↓ ≡ (normalise a ⊕ normalise b) ↓ ] ρ
      step3 = lem0 (normalise a) (normalise b) ρ

  lem2 : {n : Nat} -> (xs ys : NF n) -> (ρ : Vec n A) -> IsTrue (xs =NF= ys) -> eq[ xs ↓ ≡ ys ↓ ] ρ
  lem2 xs ys ρ eq = substNF {_}{xs}{ys} (\z -> eq[ xs ↓ ≡ z ↓ ] ρ) eq refl

  prove : {n : Nat} -> (thm : Theorem n) -> Proof thm
  prove thm = proof (provable thm) thm (\h -> h)
    where
      proof : {n : Nat}(valid : Bool)(thm : Theorem n) -> (IsTrue valid -> IsTrue (provable thm)) -> Prf thm valid
      proof false  _      _       = no-proof
      proof true  (a ≡ b) isValid = lambda eq[ a ≡ b ] \ρ ->
          trans (step-a ρ) (trans (step-ab ρ) (step-b ρ))
        where
          step-a : forall ρ -> eq[ a ≡ normalise a ↓ ] ρ
          step-a ρ = lem1 a ρ

          step-b : forall ρ -> eq[ normalise b ↓ ≡ b ] ρ
          step-b ρ = sym (lem1 b ρ)

          step-ab : forall ρ -> eq[ normalise a ↓ ≡ normalise b ↓ ] ρ
          step-ab ρ = lem2 (normalise a) (normalise b) ρ (isValid tt)


{-# OPTIONS --postfix-projections #-}

module StateSizedIO.cellStateDependent where

open import Data.Product
open import Data.String.Base

{-
open import SizedIO.Object
open import SizedIO.ConsoleObject
-}

open import SizedIO.Console hiding (main)

open import SizedIO.Base

open import NativeIO

open import StateSizedIO.Object
open import StateSizedIO.IOObject

open import Size

data CellStateˢ  : Set where
  empty full  : CellStateˢ

data CellMethodEmpty A : Set where
    put : A → CellMethodEmpty A

data CellMethodFull A : Set where
    get : CellMethodFull A
    put : A → CellMethodFull A

CellMethodˢ : (A : Set) → CellStateˢ → Set
CellMethodˢ A empty = CellMethodEmpty A
CellMethodˢ A full = CellMethodFull A

putGen : {A : Set} → {i : CellStateˢ} → A → CellMethodˢ A i
putGen {i = empty} = put
putGen {i = full} = put

CellResultFull : ∀{A} → CellMethodFull A → Set
CellResultFull {A} get = A
CellResultFull (put _) = Unit

CellResultEmpty : ∀{A} → CellMethodEmpty A → Set
CellResultEmpty (put _) = Unit

CellResultˢ : (A : Set) → (s : CellStateˢ) → CellMethodˢ A s → Set
CellResultˢ A empty = CellResultEmpty{A}
CellResultˢ A full = CellResultFull{A}

nˢ : ∀{A} → (s : CellStateˢ) → (c : CellMethodˢ A s) → (CellResultˢ A s c) → CellStateˢ
nˢ _ _ _ = full

CellInterfaceˢ : (A : Set) → Interfaceˢ
Stateˢ (CellInterfaceˢ A)  = CellStateˢ
Methodˢ (CellInterfaceˢ A)  = CellMethodˢ A
Resultˢ (CellInterfaceˢ A)  = CellResultˢ A
nextˢ (CellInterfaceˢ A)  = nˢ

mutual
   cellPempty : (i : Size) → IOObjectˢ consoleI (CellInterfaceˢ String) i empty
   method (cellPempty i) {j} (put str) = do (putStrLn ("put (" ++ str ++ ")")) λ _ →
                                         return (unit , cellPfull j str)

   cellPfull : (i : Size) → (str : String) → IOObjectˢ consoleI (CellInterfaceˢ String) i full
   method (cellPfull i str) {j} get        = do (putStrLn ("get (" ++ str ++ ")")) λ _ →
                                             return (str , cellPfull j str)
   method (cellPfull i str) {j} (put str') = do (putStrLn ("put (" ++ str' ++ ")")) λ _ →
                                             return (unit , cellPfull j str')

-- UNSIZED Version, without IO
mutual
   cellPempty' : ∀{A} → Objectˢ (CellInterfaceˢ A) empty
   cellPempty' .objectMethod (put a)     =  (_ , cellPfull' a)

   cellPfull' : ∀{A} → A → Objectˢ (CellInterfaceˢ A) full
   cellPfull' a .objectMethod get         = (a , cellPfull' a)
   cellPfull' a .objectMethod (put a')  = (_ , cellPfull' a')


module Categories.Agda.ISetoids.Complete where

open import Level
open import Relation.Binary using (Setoid; module Setoid; Preorder; module Preorder; Rel; _=[_]⇒_)
open import Data.Product using (Σ; _,_; proj₁; proj₂)
open import Categories.Support.IProduct
-- import Relation.Binary.EqReasoning as EqReasoning

open import Categories.Support.Equivalence using (module I→R-Wrapper; setoid-i→r; Fam-setoid; ∀[_]-setoid_)
                                           renaming (Setoid to ISetoid; module Setoid to ISetoid)
open import Categories.Support.SetoidFunctions using (module _⟶_)
open import Categories.Support.PropositionalEquality
import Categories.Support.ZigZag as ZigZag

open import Categories.Category
open import Categories.Functor
import Categories.NaturalTransformation as NT
open import Categories.Agda
open import Categories.Colimit
open import Categories.Object.Initial
open import Categories.Cocones
open import Categories.Cocone

ISetoidsComplete : ∀ {o ℓ e c ℓ′} → Cocomplete o ℓ e (Category.op (ISetoids (c ⊔ ℓ′ ⊔ (o ⊔ ℓ ⊔ e)) (c ⊔ (o ⊔ ℓ ⊔ e))))
ISetoidsComplete {o} {ℓ} {e} {c} {cℓ} = record { colimit = colimit }
  where
  c′ = c ⊔ cℓ ⊔ (o ⊔ ℓ ⊔ e)
  ℓ′ = c ⊔ (o ⊔ ℓ ⊔ e)
  C = Category.op (ISetoids c′ ℓ′)
  colimit : ∀ {J : Category o ℓ e} (F : Functor J C) → Colimit F
  colimit {J} F = record { initial = record
    { ⊥ = record
          { N = Fam-setoid (Σ′ (∀ j → Carrier (F₀ j)) (λ f → ∀ {a b} (h : a J.⇒ b) → (F₀ a ≈ F₁ h ⟨$⟩ f b) (f a)))
                           (∀[ J.Obj ]-setoid F₀) proj₁′
          ; ψ = λ X → record
              { _⟨$⟩_ = λ f → proj₁′ f X
              ; cong  = λ eq → eq X
              }
          ; commute = λ {X} {Y} h {f} {g} f≈g → trans (F₀ X) (f≈g X) (sym (F₀ X) (proj₂′ g h))
          }
    ; ! = λ {A} → record
          { f = record
              { _⟨$⟩_ = λ X → (λ j → Cocone.ψ A j ⟨$⟩ X) , (λ {a} {b} h → sym (F₀ a) (Cocone.commute A h (refl (Cocone.N A))))
              ; cong  = λ i≈j a → cong (Cocone.ψ A a) i≈j
              }
           ; commute = λ {X} x≈y → cong (Cocone.ψ A X) x≈y
           }
    ; !-unique = λ {A} f x≈y a → sym (F₀ a) (CoconeMorphism.commute f (sym (Cocone.N A) x≈y))
    } }
    where
    module J = Category J
    open Functor F
    open ISetoid
    open _⟶_


module TypesMore where

open import Basics
open import Types4

module DESC (I : Set) where

  data Desc : Set1 where
    inx : I -> Desc
    sg  : (A : Set)(D : A -> Desc) -> Desc
    _!_ : I -> Desc -> Desc

  Node : Desc -> (I -> Set) -> I -> Set
  Node (inx x) R i = x == i
  Node (sg A D) R i = Sg A \ a -> Node (D a) R i
  Node (x ! D) R i = R x * Node D R i

  data Mu (D : Desc)(i : I) : Set where
    [_] : Node D (Mu D) i -> Mu D i

  cata : forall D {X} -> ({i : I} -> Node D X i -> X i) ->
           forall {i} -> Mu D i -> X i
  mapCata : forall {D} E {X} -> ({i : I} -> Node D X i -> X i) ->
           forall {i} -> Node E (Mu D) i -> Node E X i
  cata D f [ x ] = f (mapCata D f x)
  mapCata (inx x) f q = q
  mapCata (sg A E) f (a , e) = a , mapCata (E a) f e
  mapCata (i ! E) f (x , e) = cata _ f x , mapCata E f e

  module ORN (J : Set)(ji : J -> I) where

    Hits : I -> Set
    Hits i = Sg J \ j -> ji j == i

    data Orn : Desc -> Set1 where
      inx : forall {i} -> Hits i -> Orn (inx i)
      sg  : forall A {D} -> ((a : A) -> Orn (D a)) -> Orn (sg A D)
      _!_ : forall {i D} -> Hits i -> Orn D -> Orn (i ! D)
      ins : forall (X : Set) {D} -> (X -> Orn D) -> Orn D
      del : forall {A D} a -> Orn (D a) -> Orn (sg A D)

open DESC

NatDesc : Desc One
NatDesc = sg Two \ { tt -> inx <> ; ff -> <> ! inx <> }

NAT : Set
NAT = Mu One NatDesc <>
pattern ZE = [ tt , refl ]
pattern SU n = [ ff , n , refl ]
PLUS : NAT -> NAT -> NAT
PLUS ZE y = y
PLUS (SU x) y = SU (PLUS x y)

open ORN

orned : forall {I D J ji} -> Orn I J ji D -> Desc J
orned (inx (j , q)) = inx j
orned (sg A D) = sg A \ a -> orned (D a)
orned ((j , q) ! O) = j ! orned O
orned (ins X O) = sg X \ x -> orned (O x)
orned (del a O) = orned O

ListOrn : Set -> Orn One One _ NatDesc
ListOrn X = sg Two \
  { tt -> inx (<> , refl)
  ; ff -> ins X \ _ -> (<> , refl) ! (inx (<> , refl))
  }

forget : forall {I D J ji} (O : Orn I J ji D) {P : I -> Set} ->
         {j : J} -> Node J (orned O) (\ j -> P (ji j)) j ->
                    Node I D P (ji j)
forget (inx (j , refl)) refl = refl
forget (sg A O) (a , o) = a , forget (O a) o
forget ((j , refl) ! O) (p , o) = p , forget O o
forget (ins X O) (x , o) = forget (O x) o
forget (del a O) o = a , forget O o

plain : forall {I D J ji} (O : Orn I J ji D)
        {j : J} -> Mu J (orned O) j -> Mu I D (ji j)
plain O = cata _ (orned O) (\ x -> [ forget O {Mu _ _} x ])