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

open import Light.Library.Data.Integer as ℤ using (ℤ ; zero ; successor)
open import Light.Package using (Package)

module Light.Literals.Integer ⦃ package : Package record { ℤ } ⦄ where

open import Light.Literals.Definition.Natural using (FromNatural)
open import Light.Literals.Definition.Negative using (FromNegative)
open FromNatural using (convert)
open import Light.Library.Relation.Decidable using (if_then_else_)
open import Light.Library.Relation.Binary.Equality using (_≈_)
import Light.Library.Data.Natural as ℕ
import Light.Library.Relation.Binary.Equality.Decidable

instance from‐natural : FromNatural ℤ
convert from‐natural n =
      if n ≈ ℕ.zero
      then zero
      else successor (convert from‐natural (ℕ.predecessor n))


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

open import Cubical.Core.Everything
open import Cubical.Foundations.HLevels

module Cubical.Algebra.Magma.Construct.Right {ℓ} (Aˢ : hSet ℓ) where

open import Cubical.Foundations.Prelude
open import Cubical.Algebra.Magma

private
  A = ⟨ Aˢ ⟩
  isSetA = Aˢ .snd

_▸_ : Op₂ A
x ▸ y = y

------------------------------------------------------------------------
-- Properties

▸-identityˡ : ∀ x → LeftIdentity x _▸_
▸-identityˡ _ _ = refl

▸-zeroʳ : ∀ x → RightZero x _▸_
▸-zeroʳ _ _ = refl

------------------------------------------------------------------------
-- Magma definition

Right-isMagma : IsMagma A _▸_
Right-isMagma = record { is-set = isSetA }

RightMagma : Magma ℓ
RightMagma = record { isMagma = Right-isMagma }


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

open import LogicalFormulae
open import Groups.Definition
open import Setoids.Setoids
open import Functions.Definition
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Lists.Lists

module Rings.Polynomial.Multiplication {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) where

open Ring R
open Group additiveGroup
open import Groups.Polynomials.Definition additiveGroup
open import Groups.Polynomials.Group additiveGroup
open Setoid S
open Equivalence eq

_*P_ : NaivePoly → NaivePoly → NaivePoly
[] *P b = []
(x :: a) *P [] = []
(x :: a) *P (y :: b) = (x * y) :: (((map (x *_) b) +P (map (y *_) a)) +P (0R :: (a *P b)))

abstract
  +PCommutative : {x y : NaivePoly} → polysEqual (x +P y) (y +P x)
  +PCommutative {x} {y} = comm (record { commutative = groupIsAbelian }) {x} {y}

  p*Commutative : {a b : NaivePoly} → polysEqual (a *P b) (b *P a)
  p*Commutative {[]} {[]} = record {}
  p*Commutative {[]} {x :: b} = record {}
  p*Commutative {x :: a} {[]} = record {}
  p*Commutative {x :: xs} {y :: ys} = *Commutative ,, +PwellDefined (+PCommutative {map (_*_ x) ys} {map (_*_ y) xs}) (reflexive ,, p*Commutative {xs} {ys})

  zeroTimes1 : {a : NaivePoly} (c : A) → (c ∼ 0G) → polysEqual (map (_*_ c) a) []
  zeroTimes1 {[]} c c=0 = record {}
  zeroTimes1 {x :: a} c c=0 = transitive (transitive *Commutative (*WellDefined reflexive c=0)) (timesZero {x}) ,, zeroTimes1 {a} c c=0

  zeroTimes2 : {a : NaivePoly} (c : A) → polysEqual a [] → polysEqual (map (_*_ c) a) []
  zeroTimes2 {[]} c a=0 = record {}
  zeroTimes2 {x :: a} c (fst ,, snd) = transitive (*WellDefined reflexive fst) (timesZero {c}) ,, zeroTimes2 {a} c snd

  mapWellDefined : (a c : A) (bs : NaivePoly) → (a ∼ c) → polysEqual (map (_*_ a) bs) (map (_*_ c) bs)
  mapWellDefined a c [] a=c = record {}
  mapWellDefined a c (x :: bs) a=c = *WellDefined a=c reflexive ,, mapWellDefined a c bs a=c

  mapWellDefined' : (a : A) (bs cs : NaivePoly) → polysEqual bs cs → polysEqual (map (_*_ a) bs) (map (_*_ a) cs)
  mapWellDefined' a [] [] bs=cs = record {}
  mapWellDefined' a [] (x :: cs) (fst ,, snd) = transitive (*WellDefined reflexive fst) (timesZero {a}) ,, Equivalence.symmetric (Setoid.eq naivePolySetoid) (zeroTimes2 {cs} a (Equivalence.symmetric (Setoid.eq naivePolySetoid) snd))
  mapWellDefined' a (x :: bs) [] (fst ,, snd) = transitive (*WellDefined reflexive fst) (timesZero {a}) ,, zeroTimes2 {bs} a snd
  mapWellDefined' a (b :: bs) (c :: cs) (fst ,, snd) = *WellDefined reflexive fst ,, mapWellDefined' a bs cs snd

  *PwellDefinedL : {a b c : NaivePoly} → polysEqual a c → polysEqual (a *P b) (c *P b)
  *PwellDefinedL {[]} {[]} {[]} a=c = record {}
  *PwellDefinedL {[]} {[]} {x :: c} a=c = record {}
  *PwellDefinedL {[]} {x :: b} {[]} a=c = record {}
  *PwellDefinedL {[]} {b :: bs} {c :: cs} (fst ,, snd) = transitive (transitive *Commutative (*WellDefined reflexive fst)) (timesZero {b}) ,, Equivalence.transitive (Setoid.eq naivePolySetoid) (Equivalence.transitive (Setoid.eq naivePolySetoid) {_} {(map (_*_ c) bs) +P (0G :: (cs *P bs))} (Equivalence.transitive (Setoid.eq naivePolySetoid) {_} {[] +P (0G :: (cs *P bs))} (reflexive ,, ans) (+PwellDefined (Equivalence.symmetric (Setoid.eq naivePolySetoid) (zeroTimes1 {bs} c fst)) (Equivalence.reflexive (Setoid.eq naivePolySetoid) {0G :: (cs *P bs)}))) (+PwellDefined (Equivalence.symmetric (Setoid.eq naivePolySetoid) (Group.identRight polyGroup {map (_*_ c) bs})) (Equivalence.reflexive (Setoid.eq naivePolySetoid) {0G :: (cs *P bs)}))) (+PwellDefined {(map (_*_ c) bs +P [])} {0G :: (cs *P bs)} {(map (_*_ c) bs) +P map (_*_ b) cs} (+PwellDefined (Equivalence.reflexive (Setoid.eq naivePolySetoid) {map (_*_ c) bs}) (Equivalence.symmetric (Setoid.eq naivePolySetoid) (zeroTimes2 {cs} b (Equivalence.symmetric (Setoid.eq naivePolySetoid) snd)))) (Equivalence.reflexive (Setoid.eq naivePolySetoid) {0G :: (cs *P bs)}))
    where
      ans : polysEqual [] (map id (cs *P bs))
      ans rewrite mapId (cs *P bs) = *PwellDefinedL snd
  *PwellDefinedL {a :: as} {[]} {[]} a=c = record {}
  *PwellDefinedL {a :: as} {[]} {x :: c} a=c = record {}
  *PwellDefinedL {a :: as} {b :: bs} {[]} (fst ,, snd) = transitive (transitive *Commutative (*WellDefined reflexive fst)) (timesZero {b}) ,, Equivalence.transitive (Setoid.eq naivePolySetoid) (+PwellDefined {(map (_*_ a) bs +P map (_*_ b) as)} {0G :: (as *P bs)} {[] +P []} {[]} (+PwellDefined {map (_*_ a) bs} {map (_*_ b) as} {[]} {[]} (zeroTimes1 {bs} a fst) (zeroTimes2 {as} b snd)) (reflexive ,, *PwellDefinedL {as} {bs} {[]} snd)) (record {})
  *PwellDefinedL {a :: as} {b :: bs} {c :: cs} (fst ,, snd) = *WellDefined fst reflexive ,, +PwellDefined {(map (_*_ a) bs) +P (map (_*_ b) as)} {0G :: (as *P bs)} {map (_*_ c) bs +P map (_*_ b) cs} {0G :: (cs *P bs)} (+PwellDefined {map (_*_ a) bs} {map (_*_ b) as} {map (_*_ c) bs} {map (_*_ b) cs} (mapWellDefined a c bs fst) (mapWellDefined' b as cs snd)) (reflexive ,, *PwellDefinedL {as} {bs} {cs} snd)

  *PwellDefinedR : {a b c : NaivePoly} → polysEqual b c → polysEqual (a *P b) (a *P c)
  *PwellDefinedR {a} {b} {c} b=c = Equivalence.transitive (Setoid.eq naivePolySetoid) (p*Commutative {a} {b}) (Equivalence.transitive (Setoid.eq naivePolySetoid) (*PwellDefinedL b=c) (p*Commutative {c} {a}))

  *PwellDefined : {a b c d : NaivePoly} → polysEqual a c → polysEqual b d → polysEqual (a *P b) (c *P d)
  *PwellDefined {a}{b}{c}{d} a=c b=d = Equivalence.transitive (Setoid.eq naivePolySetoid) (*PwellDefinedL a=c) (*PwellDefinedR b=d)

  private
    *1 : (a : NaivePoly) → polysEqual (map (_*_ 1R) a) a
    *1 [] = record {}
    *1 (x :: a) = Ring.identIsIdent R ,, *1 a

  *Pident : {a : NaivePoly} → polysEqual ((1R :: []) *P a) a
  *Pident {[]} = record {}
  *Pident {x :: a} = Ring.identIsIdent R ,, Equivalence.transitive (Setoid.eq naivePolySetoid) (+PwellDefined {map (_*_ 1R) a +P []} {0G :: []} {map (_*_ 1R) a} {[]} (Group.identRight polyGroup) (reflexive ,, record {})) (Equivalence.transitive (Setoid.eq naivePolySetoid) (Group.identRight polyGroup {map (_*_ 1R) a}) (*1 a))

  private
    mapMap' : (f g : A → A) (xs : NaivePoly) → map f (map g xs) ≡ map (λ x → f (g x)) xs
    mapMap' f g [] = refl
    mapMap' f g (x :: xs) rewrite mapMap' f g xs = refl

    mapMap'' : (f g : A → A) (xs : NaivePoly) → Setoid._∼_ naivePolySetoid (map f (map g xs)) (map (λ x → f (g x)) xs)
    mapMap'' f g xs rewrite mapMap' f g xs = Equivalence.reflexive (Setoid.eq naivePolySetoid)

    mapWd : (f g : A → A) (xs : NaivePoly) → ((x : A) → (f x) ∼ (g x)) → polysEqual (map f xs) (map g xs)
    mapWd f g [] ext = record {}
    mapWd f g (x :: xs) ext = ext x ,, mapWd f g xs ext

    mapDist' : (b c : A) → (as : NaivePoly) → polysEqual (map (_*_ (b + c)) as) (map (_*_ c) as +P map (_*_ b) as)
    mapDist' b c [] = record {}
    mapDist' b c (x :: as) = transitive (Ring.*DistributesOver+' R {b} {c} {x}) groupIsAbelian ,, mapDist' b c as

    mapTimes : (a b : NaivePoly) (c : A) → polysEqual (a *P (map (_*_ c) b)) (map (_*_ c) (a *P b))
    mapTimes [] b c = record {}
    mapTimes (a :: as) [] c = record {}
    mapTimes (a :: as) (x :: b) c = transitive *Associative (transitive (*WellDefined *Commutative reflexive) (symmetric *Associative)) ,, trans (+PwellDefined {(map (_*_ a) (map (_*_ c) b)) +P map (_*_ (c * x)) as} {0G :: (as *P map (_*_ c) b)} {map (_*_ c) (map (_*_ a) b +P map (_*_ x) as)} (trans (+PwellDefined {map (_*_ a) (map (_*_ c) b)} {map (_*_ (c * x)) as} {map (_*_ c) (map (_*_ a) b)} (trans (mapMap'' (_*_ a) (_*_ c) b) (trans (mapWd (λ x → a * (c * x)) (λ x → c * (a * x)) b (λ x → transitive *Associative (transitive (*WellDefined *Commutative reflexive) (symmetric *Associative)))) (sym (mapMap'' (_*_ c) (_*_ a) b)))) (trans (mapWd (_*_ (c * x)) (λ y → c * (x * y)) as λ y → symmetric *Associative) (sym (mapMap'' (_*_ c) (_*_ x) as)))) (sym (mapDist (_*_ c) *DistributesOver+ (map (_*_ a) b) (map (_*_ x) as)))) (symmetric timesZero ,, mapTimes as b c)) (sym (mapDist (_*_ c) *DistributesOver+ (map (_*_ a) b +P map (_*_ x) as) (0G :: (as *P b))))
      where
        open Equivalence (Setoid.eq naivePolySetoid) renaming (transitive to trans ; symmetric to sym ; reflexive to ref)

    mapTimes' : (a b : NaivePoly) (c : A) → polysEqual (map (_*_ c) (a *P b)) ((map (_*_ c) a) *P b)
    mapTimes' a b c = trans (trans (mapWellDefined' c (a *P b) (b *P a) (p*Commutative {a} {b})) (sym (mapTimes b a c))) (p*Commutative {b} {map (_*_ c) a})
      where
        open Equivalence (Setoid.eq naivePolySetoid) renaming (transitive to trans ; symmetric to sym ; reflexive to ref)

  bumpTimes' : (a bs : NaivePoly) (b : A) → polysEqual (a *P (b :: bs)) (map (_*_ b) a +P (0G :: (a *P bs)))
  bumpTimes' [] bs b = reflexive ,, record {}
  bumpTimes' (x :: a) bs b = transitive *Commutative (symmetric identRight) ,, trans (+PwellDefined {map (_*_ x) bs +P map (_*_ b) a} {0G :: (a *P bs)} {_} {0G :: (a *P bs)} (+PCommutative {map (_*_ x) bs} {map (_*_ b) a}) (ref {0G :: (a *P bs)})) (trans (sym (Group.+Associative polyGroup {map (_*_ b) a})) (+PwellDefined {map (_*_ b) a} {_} {map (_*_ b) a} {_} (ref {map (_*_ b) a}) (trans (trans (+PwellDefined {map (_*_ x) bs} {_} {map (_*_ x) bs} (ref {map (_*_ x) bs}) (reflexive ,, p*Commutative {a})) (sym (bumpTimes' bs a x))) (p*Commutative {bs}))))
    where
      open Equivalence (Setoid.eq naivePolySetoid) renaming (transitive to trans ; symmetric to sym ; reflexive to ref)

  bumpTimes : {a b : NaivePoly} → polysEqual (a *P (0G :: b)) (0G :: (a *P b))
  bumpTimes {[]} {b} = reflexive ,, record {}
  bumpTimes {x :: a} {[]} = timesZero ,, trans (sym (Group.+Associative polyGroup {[]} {map (_*_ 0G) a})) ans
    where
      open Equivalence (Setoid.eq naivePolySetoid) renaming (transitive to trans ; symmetric to sym ; reflexive to ref)
      ans : polysEqual (map id (map (_*_ 0G) a +P (0G :: (a *P [])))) []
      ans rewrite mapId (map (_*_ 0G) a +P (0G :: (a *P []))) = (+PwellDefined {map (_*_ 0G) a} {0G :: (a *P [])} {[]} {[]} (zeroTimes1 0G reflexive) (reflexive ,, p*Commutative {a}))
  bumpTimes {x :: a} {b :: bs} = timesZero ,, trans (+PwellDefined {((x * b) :: map (_*_ x) bs) +P map (_*_ 0G) a} {0G :: (a *P (b :: bs))} {(x * b) :: map (_*_ x) bs} {0G :: (a *P (b :: bs))} (trans (+PwellDefined {(x * b) :: map (_*_ x) bs} {map (_*_ 0G) a} {(x * b) :: map (_*_ x) bs} {[]} (ref {(x * b) :: map (_*_ x) bs}) (zeroTimes1 0G reflexive)) (Group.identRight polyGroup {(x * b) :: map (_*_ x) bs})) (ref {0G :: (a *P (b :: bs))})) (identRight ,, trans (+PwellDefined {map (_*_ x) bs} {_} {map (_*_ x) bs} ref (bumpTimes' a bs b)) (Group.+Associative polyGroup {map (_*_ x) bs} {map (_*_ b) a} {0G :: (a *P bs)}))
    where
      open Equivalence (Setoid.eq naivePolySetoid) renaming (transitive to trans ; symmetric to sym ; reflexive to ref)

  *Pdistrib : {a b c : NaivePoly} → polysEqual (a *P (b +P c)) ((a *P b) +P (a *P c))
  *Pdistrib {[]} {b} {c} = record {}
  *Pdistrib {a :: as} {[]} {[]} = record {}
  *Pdistrib {a :: as} {[]} {c :: cs} rewrite mapId cs | mapId ((map (_*_ a) cs +P map (_*_ c) as) +P (0G :: (as *P cs))) = reflexive ,, +PwellDefined {(map (_*_ a) cs) +P (map (_*_ c) as)} {_} {(map (_*_ a) cs) +P (map (_*_ c) as)} (Equivalence.reflexive (Setoid.eq naivePolySetoid)) (Equivalence.reflexive (Setoid.eq naivePolySetoid) {0G :: (as *P cs)})
  *Pdistrib {a :: as} {b :: bs} {[]} rewrite mapId bs | mapId ((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs))) = reflexive ,, +PwellDefined {(map (_*_ a) bs) +P (map (_*_ b) as)} {_} {(map (_*_ a) bs) +P (map (_*_ b) as)} (Equivalence.reflexive (Setoid.eq naivePolySetoid)) (Equivalence.reflexive (Setoid.eq naivePolySetoid) {0G :: (as *P bs)})
  *Pdistrib {a :: as} {b :: bs} {c :: cs} = *DistributesOver+ ,, trans (+PwellDefined {(map (_*_ a) (bs +P cs)) +P (map (_*_ (b + c)) as)} {0G :: (as *P (bs +P cs))} {(map (_*_ a) bs +P map (_*_ b) as) +P ((map (_*_ a) cs) +P (map (_*_ c) as))} {0G :: ((as *P bs) +P (as *P cs))} (trans (+PwellDefined (mapDist (_*_ a) *DistributesOver+ bs cs) (mapDist' b c as)) (trans (sym (+Assoc {map (_*_ a) bs} {map (_*_ a) cs})) (trans (+PwellDefined (ref {map (_*_ a) bs}) (trans (trans (+Assoc {map (_*_ a) cs} {map (_*_ c) as}) ref) (+PCommutative {map (_*_ a) cs +P map (_*_ c) as} {map (_*_ b) as}))) (+Assoc {map (_*_ a) bs} {map (_*_ b) as})))) (reflexive ,, *Pdistrib {as} {bs} {cs})) (trans (sym (+Assoc {(map (_*_ a) bs +P map (_*_ b) as)} {(map (_*_ a) cs +P map (_*_ c) as)} {0G :: ((as *P bs) +P (as *P cs))})) (trans (+PwellDefined (ref {map (_*_ a) bs +P map (_*_ b) as}) (trans (trans (+PwellDefined (ref {map (_*_ a) cs +P map (_*_ c) as}) (symmetric identLeft ,, +PCommutative {as *P bs})) (+Assoc {map (_*_ a) cs +P (map (_*_ c) as)} {0G :: (as *P cs)} {0G :: (as *P bs)})) (+PCommutative {(map (_*_ a) cs +P map (_*_ c) as) +P (0G :: (as *P cs))} {0G :: (as *P bs)}))) (+Assoc {map (_*_ a) bs +P map (_*_ b) as} {0G :: (as *P bs)})))
    where
      open Equivalence (Setoid.eq naivePolySetoid) renaming (transitive to trans ; symmetric to sym ; reflexive to ref)
      open Group polyGroup renaming (+Associative to +Assoc ; 0G to 0P) hiding (identLeft)

*Passoc : {a b c : NaivePoly} → polysEqual (a *P (b *P c)) ((a *P b) *P c)
*Passoc {[]} {b} {c} = record {}
*Passoc {a :: as} {[]} {c} = record {}
*Passoc {a :: as} {b :: bs} {[]} = record {}
*Passoc {a :: as} {b :: bs} {c :: cs} = *Associative ,, trans (+PwellDefined {(map (_*_ a) ((map (_*_ b) cs +P map (_*_ c) bs) +P (0G :: (bs *P cs))) +P map (_*_ (b * c)) as)} {0G :: (as *P ((map (_*_ b) cs +P map (_*_ c) bs) +P (0G :: (bs *P cs))))} {(((map (_*_ (a * b)) cs) +P (map (_*_ (a * c)) bs)) +P (map (_*_ a) (0G :: (bs *P cs)))) +P (map (_*_ (b * c)) as)} {0G :: (((map (_*_ b) (as *P cs)) +P (map (_*_ c) (as *P bs))) +P (as *P (0G :: (bs *P cs))))} (+PwellDefined {map (_*_ a) ((map (_*_ b) cs +P map (_*_ c) bs) +P (0G :: (bs *P cs)))} {map (_*_ (b * c)) as} {((map (_*_ (a * b)) cs +P map (_*_ (a * c)) bs) +P ((a * 0G) :: map (_*_ a) (bs *P cs)))} {map (_*_ (b * c)) as} (trans (mapDist (_*_ a) *DistributesOver+ (map (_*_ b) cs +P map (_*_ c) bs) (0G :: (bs *P cs))) (+PwellDefined {map (_*_ a) (map (_*_ b) cs +P map (_*_ c) bs)} {(a * 0G) :: map (_*_ a) (bs *P cs)} {map (_*_ (a * b)) cs +P map (_*_ (a * c)) bs} (trans (mapDist (_*_ a) *DistributesOver+ (map (_*_ b) cs) (map (_*_ c) bs)) (+PwellDefined {map (_*_ a) (map (_*_ b) cs)} {map (_*_ a) (map (_*_ c) bs)} {map (_*_ (a * b)) cs} (trans (mapMap'' (_*_ a) (_*_ b) cs) (mapWd (λ x → a * (b * x)) (_*_ (a * b)) cs (λ x → *Associative))) (trans (mapMap'' (_*_ a) (_*_ c) bs) (mapWd (λ x → a * (c * x)) (_*_ (a * c)) bs λ x → *Associative)))) (ref {(a * 0G) :: map (_*_ a) (bs *P cs)}))) (ref {map (_*_ (b * c)) as})) (reflexive ,, trans (*Pdistrib {as} {(map (_*_ b) cs +P map (_*_ c) bs)} {0G :: (bs *P cs)}) (+PwellDefined {(as *P (map (_*_ b) cs +P map (_*_ c) bs))} {as *P (0G :: (bs *P cs))} {(map (_*_ b) (as *P cs) +P map (_*_ c) (as *P bs))} (trans (*Pdistrib {as} {map (_*_ b) cs} {map (_*_ c) bs}) (+PwellDefined {as *P map (_*_ b) cs} {as *P map (_*_ c) bs} {map (_*_ b) (as *P cs)} (mapTimes as cs b) (mapTimes as bs c))) (ref {as *P (0G :: (bs *P cs))})))) (trans (trans (sym (Group.+Associative polyGroup {((map (_*_ (a * b)) cs) +P (map (_*_ (a * c)) bs)) +P ((a * 0G) :: map (_*_ a) (bs *P cs))})) (trans (sym (Group.+Associative polyGroup {(map (_*_ (a * b)) cs) +P (map (_*_ (a * c)) bs)})) (trans (sym (Group.+Associative polyGroup {map (_*_ (a * b)) cs})) (+PwellDefined {map (_*_ (a * b)) cs} (ref {map (_*_ (a * b)) cs}) (trans (trans ans (Group.+Associative polyGroup {map (_*_ c) (map (_*_ a) bs +P map (_*_ b) as)})) (+PwellDefined {_} {0G :: (((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs))) *P cs)} {map (_*_ c) ((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs)))} (sym (mapDist (_*_ c) *DistributesOver+ ((map (_*_ a) bs +P map (_*_ b) as)) (0G :: (as *P bs)))) (ref {0G :: (((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs))) *P cs)}))))))) (Group.+Associative polyGroup {map (_*_ (a * b)) cs} {map (_*_ c) ((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs)))}))
  where
    open Equivalence (Setoid.eq naivePolySetoid) renaming (transitive to trans ; symmetric to sym ; reflexive to ref)
    open Group polyGroup renaming (+Associative to +Assoc ; 0G to 0P) hiding (identLeft ; identRight)
    ans2 : polysEqual ((map (_*_ a) (bs *P cs) +P (map (_*_ b) (as *P cs) +P map (_*_ c) (as *P bs))) +P (as *P (0G :: (bs *P cs)))) (map (_*_ c) (as *P bs) +P (((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs))) *P cs))
    ans2 = trans (+PwellDefined {_} {as *P (0G :: (bs *P cs))} {_} {as *P (0G :: (bs *P cs))} (trans (+Assoc {map (_*_ a) (bs *P cs)} {map (_*_ b) (as *P cs)} {map (_*_ c) (as *P bs)}) (+PCommutative {map (_*_ a) (bs *P cs) +P map (_*_ b) (as *P cs)} {map (_*_ c) (as *P bs)})) ref) (trans (sym (+Assoc {map (_*_ c) (as *P bs)} {_} {as *P (0G :: (bs *P cs))}) ) (+PwellDefined {map (_*_ c) (as *P bs)} {_} {map (_*_ c) (as *P bs)} ref (trans (+PwellDefined {map (_*_ a) (bs *P cs) +P map (_*_ b) (as *P cs)} {as *P (0G :: (bs *P cs))} {((map (_*_ a) bs) *P cs) +P ((map (_*_ b) as) *P cs)} {0G :: (as *P (bs *P cs))} (+PwellDefined {map (_*_ a) (bs *P cs)} {map (_*_ b) (as *P cs)} {map (_*_ a) bs *P cs} {map (_*_ b) as *P cs} (mapTimes' bs cs a) (mapTimes' as cs b)) (bumpTimes {as} {bs *P cs})) (trans (trans (+PwellDefined {(map (_*_ a) bs *P cs) +P (map (_*_ b) as *P cs)} {0G :: (as *P (bs *P cs))} {cs *P (map (_*_ a) bs +P map (_*_ b) as)} {cs *P (0G :: (as *P bs))} (trans (+PwellDefined {map (_*_ a) bs *P cs} {map (_*_ b) as *P cs} {cs *P map (_*_ a) bs} {cs *P map (_*_ b) as} (p*Commutative {_} {cs}) (p*Commutative {_} {cs})) (sym (*Pdistrib {cs} {map (_*_ a) bs} {map (_*_ b) as}))) (trans (reflexive ,, trans (*Passoc {as} {bs} {cs}) (p*Commutative {_} {cs})) (sym (bumpTimes {cs} {as *P bs})))) (sym (*Pdistrib {cs} {(map (_*_ a) bs) +P (map (_*_ b) as)} {0G :: (as *P bs)}))) (p*Commutative {cs} {(map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs))})))))
    ans :
      polysEqual
        ((map (_*_ (a * c)) bs) +P (((a * 0G) :: map (_*_ a) (bs *P cs)) +P (map (_*_ (b * c)) as +P (0G :: ((map (_*_ b) (as *P cs) +P map (_*_ c) (as *P bs)) +P (as *P (0G :: (bs *P cs))))))))
        ((map (_*_ c) ((map (_*_ a) bs) +P (map (_*_ b) as))) +P (((c * 0G) :: map (_*_ c) (as *P bs)) +P (0G :: (((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs))) *P cs))))
    ans = trans (trans (+PwellDefined {map (_*_ (a * c)) bs} {_} {map (_*_ c) (map (_*_ a) bs)} (trans (mapWd (_*_ (a * c)) (λ x → c * (a * x)) bs (λ x → transitive (*WellDefined *Commutative reflexive) (symmetric *Associative))) (sym (mapMap'' (_*_ c) (_*_ a) bs))) (trans (+PCommutative {(a * 0G) :: map (_*_ a) (bs *P cs)} {map (_*_ (b * c)) as +P (0G :: ((map (_*_ b) (as *P cs) +P map (_*_ c) (as *P bs)) +P (as *P (0G :: bs *P cs))))}) (trans (sym (+Assoc {map (_*_ (b * c)) as})) (+PwellDefined {map (_*_ (b * c)) as} {_} {map (_*_ c) (map (_*_ b) as)} (trans (mapWd (_*_ (b * c)) (λ x → c * (b * x)) as λ x → transitive (*WellDefined *Commutative reflexive) (symmetric *Associative)) (sym (mapMap'' (_*_ c) (_*_ b) as))) (transitive identLeft (transitive (transitive timesZero (symmetric timesZero)) (symmetric identRight)) ,, trans (+PCommutative {(map (_*_ b) (as *P cs) +P map (_*_ c) (as *P bs)) +P (as *P (0G :: (bs *P cs)))} {map (_*_ a) (bs *P cs)}) (trans (+Assoc {map (_*_ a) (bs *P cs)} {(map (_*_ b) (as *P cs)) +P (map (_*_ c) (as *P bs))} {as *P (0G :: (bs *P cs))}) ans2)))))) (+Assoc {map (_*_ c) (map (_*_ a) bs)})) (+PwellDefined {(map (_*_ c) (map (_*_ a) bs)) +P (map (_*_ c) (map (_*_ b) as))} {(((c * 0G) :: map (_*_ c) (as *P bs)) +P (0G :: (((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs))) *P cs)))} {map (_*_ c) ((map (_*_ a) bs) +P (map (_*_ b) as))} {(((c * 0G) :: map (_*_ c) (as *P bs)) +P (0G :: (((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs))) *P cs)))} (sym (mapDist (_*_ c) (*DistributesOver+) (map (_*_ a) bs) (map (_*_ b) as))) (ref {(((c * 0G) :: map (_*_ c) (as *P bs)) +P (0G :: (((map (_*_ a) bs +P map (_*_ b) as) +P (0G :: (as *P bs))) *P cs)))}))


{-# OPTIONS --without-K #-}
module NTypes.Universe where

open import Equivalence
open import NTypes
open import PathOperations
open import PathStructure.Coproduct
open import Types
open import Univalence

Bool : Set
Bool = ⊤ ⊎ ⊤

not : Bool → Bool
not = case (λ _ → Bool) (λ _ → inr _) (λ _ → inl _)

not-not : ∀ x → not (not x) ≡ x
not-not = case
  (λ x → not (not x) ≡ x)
  (λ _ → refl) (λ _ → refl)

Bool-eq₁ : Bool ≃ Bool
Bool-eq₁ = ≡→eq refl

Bool-eq₂ : Bool ≃ Bool
Bool-eq₂
  = not
  , (not , not-not)
  , (not , not-not)

nope : Bool-eq₁ ≡ Bool-eq₂ → ⊥
nope x = lower (split-path (happly (ap π₁ x) (inl _)))

-- With Lift, we could prove stronger statement
-- (∀ ℓ → isSet (Set ℓ) → ⊥), but the idea is same - pick
-- something equivalent to Bool in Set ℓ, find two different
-- ways in which this type is equivalent and derive
-- a contradiction.
¬U-set : (∀ ℓ → isSet (Set ℓ)) → ⊥
¬U-set U-set = nope
  ( from-to-eq _ ⁻¹
  · ap from-≡
    (U-set _ Bool Bool (to-≡ Bool-eq₁) (to-≡ Bool-eq₂))
  · from-to-eq _
  )
  where
  from-≡     =         π₁ (ua {A = Bool} {B = Bool})
  to-≡       = π₁ (π₁ (π₂ (ua {A = Bool} {B = Bool})))
  from-to-eq = π₂ (π₁ (π₂ (ua {A = Bool} {B = Bool})))


-- Andreas, 2017-04-26, issue #2554
-- Allow mutual sized types in successor style.

-- {-# OPTIONS -v tc.pos.args:100 #-}
-- {-# OPTIONS -v tc.pos:100 #-}
-- {-# OPTIONS -v tc.polarity:20 #-}

open import Agda.Builtin.Size

mutual

  data C : Size → Set where
    c : ∀{i} → D i → C (↑ i)

  data D : Size → Set where
    d : ∀{i} → C i → D (↑ i)

-- Test subtyping

test : ∀{i} {j : Size< i} → C j → C i
test x = x

-- Define a size-preserving function

mutual

  f : ∀{i} → C i → C i
  f (c y) = c (g y)

  g : ∀{i} → D i → D i
  g (d x) = d (f x)


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

module Cauchy where

-- Definitions for permutations in the Cauchy representation

open import Relation.Binary.PropositionalEquality using (subst)
open import Data.Nat.Properties.Simple
  using (+-right-identity; +-suc; +-assoc; +-comm;
        *-assoc; *-comm; *-right-zero; distribʳ-*-+; +-*-suc)

open import Data.Bool using (Bool; false; true)
open import Data.Nat using (ℕ; suc; _+_; _*_)
open import Data.Fin
  using (Fin; zero; suc; toℕ; fromℕ;
         raise; inject+; inject₁; inject≤; _≻toℕ_)
open import Data.Vec
  using (Vec; tabulate; []; _∷_; lookup; allFin)
  renaming (_++_ to _++V_; map to mapV; concat to concatV)
open import Function using (id)

open import Proofs using (i*n+k≤m*n; trans≤; refl′; splitVOp+)

------------------------------------------------------------------------------
-- Semantic representations of permutations

-- One possibility of course is to represent them as functions but
-- this is a poor representation and eventually requires function
-- extensionality.

-- Representation III
-- This is the 2 line Cauchy representation. The first line is in
-- canonical order and implicit in the indices of the vector

Cauchy : ℕ → Set
Cauchy n = Vec (Fin n) n

------------------------------------------------------------------------------
-- Elementary permutations in the Cauchy representation

emptycauchy : Cauchy 0
emptycauchy = []

idcauchy : (n : ℕ) → Cauchy n
idcauchy = allFin

-- Sequential composition

scompcauchy : ∀ {n} → Cauchy n → Cauchy n → Cauchy n
scompcauchy {n} perm₁ perm₂ =
  tabulate (λ i → lookup (lookup i perm₁) perm₂)

-- swap the first m elements with the last n elements
-- [ v₀ , v₁   , v₂   , ... , vm-1 ,     vm , vm₊₁ , ... , vm+n-1 ]
-- ==>
-- [ vm , vm₊₁ , ... , vm+n-1 ,     v₀ , v₁   , v₂   , ... , vm-1 ]

id+ : ∀ {m n} → Fin (n + m) → Fin (m + n)
id+ {m} {n} x = subst Fin (+-comm n m) x

swap+cauchy : (m n : ℕ) → Cauchy (m + n)
swap+cauchy m n = splitVOp+ {m} {n} {f = id+ {m} {n}}

-- Parallel additive composition
-- append both permutations but adjust the indices in the second
-- permutation by the size of the first type so that it acts on the
-- second part of the vector

pcompcauchy : ∀ {m n} → Cauchy m → Cauchy n → Cauchy (m + n)
pcompcauchy {m} {n} α β = mapV (inject+ n) α ++V mapV (raise m) β

-- Tensor multiplicative composition
-- Transpositions in α correspond to swapping entire rows
-- Transpositions in β correspond to swapping entire columns

tcompcauchy : ∀ {m n} → Cauchy m → Cauchy n → Cauchy (m * n)
tcompcauchy {m} {n} α β =
  concatV
    (mapV
      (λ b →
         mapV (λ d → inject≤ (fromℕ (toℕ b * n + toℕ d)) (i*n+k≤m*n b d)) β)
      α)

-- swap⋆
--
-- This is essentially the classical problem of in-place matrix transpose:
-- "http://en.wikipedia.org/wiki/In-place_matrix_transposition"
-- Given m and n, the desired permutation in Cauchy representation is:
-- P(i) = m*n-1 if i=m*n-1
--      = m*i mod m*n-1 otherwise

transposeIndex : (m n : ℕ) →
       (b : Fin m) → (d : Fin n) → Fin (m * n)
transposeIndex m n b d =
  inject≤
    (fromℕ (toℕ d * m + toℕ b))
    (trans≤ (i*n+k≤m*n d b) (refl′ (*-comm n m)))

swap⋆cauchy : (m n : ℕ) → Cauchy (m * n)
swap⋆cauchy m n =
  concatV (mapV
            (λ b → mapV (λ d → transposeIndex m n b d) (allFin n))
            (allFin m))

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


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by total orders
------------------------------------------------------------------------

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

open import Relation.Binary

module Relation.Binary.Properties.TotalOrder
  {t₁ t₂ t₃} (T : TotalOrder t₁ t₂ t₃) where

open TotalOrder T

open import Data.Sum.Base using (inj₁; inj₂)
import Relation.Binary.Construct.Converse as Converse
import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ as ToStrict
import Relation.Binary.Properties.Poset poset as PosetProperties
open import Relation.Binary.Consequences
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Negation using (contradiction)

------------------------------------------------------------------------
-- Total orders are almost decidable total orders

decTotalOrder : Decidable _≈_ → DecTotalOrder _ _ _
decTotalOrder ≟ = record
  { isDecTotalOrder = record
    { isTotalOrder = isTotalOrder
    ; _≟_          = ≟
    ; _≤?_         = total+dec⟶dec reflexive antisym total ≟
    }
  }

------------------------------------------------------------------------
-- _≥_ - the flipped relation is also a total order

open PosetProperties public
  using
  ( _≥_
  ; ≥-refl
  ; ≥-reflexive
  ; ≥-trans
  ; ≥-antisym
  ; ≥-isPreorder
  ; ≥-isPartialOrder
  ; ≥-preorder
  ; ≥-poset
  )

≥-isTotalOrder : IsTotalOrder _≈_ _≥_
≥-isTotalOrder = Converse.isTotalOrder isTotalOrder

≥-totalOrder : TotalOrder _ _ _
≥-totalOrder = record
  { isTotalOrder = ≥-isTotalOrder
  }

open TotalOrder ≥-totalOrder public
  using () renaming (total to ≥-total)

------------------------------------------------------------------------
-- _<_ - the strict version is a strict partial order

-- Note that total orders can NOT be turned into strict total orders as
-- in order to distinguish between the _≤_ and _<_ cases we must have
-- decidable equality _≈_.

open PosetProperties public
  using
  ( _<_
  ; <-resp-≈
  ; <-respʳ-≈
  ; <-respˡ-≈
  ; <-irrefl
  ; <-asym
  ; <-trans
  ; <-isStrictPartialOrder
  ; <-strictPartialOrder
  ; <⇒≉
  ; ≤∧≉⇒<
  ; <⇒≱
  ; ≤⇒≯
  )

≰⇒> : ∀ {x y} → ¬ (x ≤ y) → y < x
≰⇒> = ToStrict.≰⇒> Eq.sym reflexive total


{-# OPTIONS --safe #-}
module Cubical.Algebra.Field.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.SIP
open import Cubical.Relation.Nullary

open import Cubical.Data.Sigma
open import Cubical.Data.Unit
open import Cubical.Data.Empty

open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.Ring
  hiding (_$_)
open import Cubical.Algebra.CommRing

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open import Cubical.Reflection.RecordEquiv

open Iso

private
  variable
    ℓ ℓ' : Level

record IsField {R : Type ℓ}
                  (0r 1r : R) (_+_ _·_ : R → R → R) (-_ : R → R) : Type ℓ where

  constructor isfield

  field
    isCommRing : IsCommRing 0r 1r _+_ _·_ -_
    hasInverse : (x : R) → ¬ x ≡ 0r → Σ[ y ∈ R ] x · y ≡ 1r
    0≢1        : ¬ 0r ≡ 1r

  open IsCommRing isCommRing public

  _[_]⁻¹ : (x : R) → ¬ x ≡ 0r → R
  x [ ¬x≡0 ]⁻¹ = hasInverse x ¬x≡0 .fst

  ·⁻¹≡1 : (x : R) (≢0 : ¬ x ≡ 0r) → x · (x [ ≢0 ]⁻¹) ≡ 1r
  ·⁻¹≡1 x ¬x≡0 = hasInverse x ¬x≡0 .snd

record FieldStr (A : Type ℓ) : Type (ℓ-suc ℓ) where

  constructor fieldstr

  field
    0r         : A
    1r         : A
    _+_        : A → A → A
    _·_        : A → A → A
    -_         : A → A
    isField    : IsField 0r 1r _+_ _·_ -_

  infix  8 -_
  infixl 7 _·_
  infixl 6 _+_

  open IsField isField public

Field : ∀ ℓ → Type (ℓ-suc ℓ)
Field ℓ = TypeWithStr ℓ FieldStr

isSetField : (R : Field ℓ) → isSet ⟨ R ⟩
isSetField R = R .snd .FieldStr.isField .IsField.·IsMonoid .IsMonoid.isSemigroup .IsSemigroup.is-set

makeIsField : {R : Type ℓ} {0r 1r : R} {_+_ _·_ : R → R → R} { -_ : R → R}
                 {_[_]⁻¹ : (x : R) → ¬ (x ≡ 0r) → R}
                 (is-setR : isSet R)
                 (+-assoc : (x y z : R) → x + (y + z) ≡ (x + y) + z)
                 (+-rid : (x : R) → x + 0r ≡ x)
                 (+-rinv : (x : R) → x + (- x) ≡ 0r)
                 (+-comm : (x y : R) → x + y ≡ y + x)
                 (·-assoc : (x y z : R) → x · (y · z) ≡ (x · y) · z)
                 (·-rid : (x : R) → x · 1r ≡ x)
                 (·-rdist-+ : (x y z : R) → x · (y + z) ≡ (x · y) + (x · z))
                 (·-comm : (x y : R) → x · y ≡ y · x)
                 (·⁻¹≡1 : (x : R) (≢0 : ¬ (x ≡ 0r)) → x · (x [ ≢0 ]⁻¹) ≡ 1r)
                 (0≢1 : ¬ (0r ≡ 1r))
               → IsField 0r 1r _+_ _·_ -_
makeIsField {R = R} {0r = 0r} {1r = 1r} {_+_ = _+_} {_·_ = _·_} {_[_]⁻¹ = _[_]⁻¹}
  is-setR +-assoc +-rid +-rinv +-comm ·-assoc ·-rid ·-rdist-+ ·-comm ·⁻¹≡1 0≢1 =
  isfield (makeIsCommRing is-setR +-assoc +-rid +-rinv +-comm ·-assoc ·-rid ·-rdist-+ ·-comm) ·-inv 0≢1
    where
    ·-inv : (x : R) → ¬ x ≡ 0r → Σ[ y ∈ R ] x · y ≡ 1r
    ·-inv x ¬x≡0 = x [ ¬x≡0 ]⁻¹ , ·⁻¹≡1 x ¬x≡0

makeField : {R : Type ℓ} (0r 1r : R) (_+_ _·_ : R → R → R) (-_ : R → R) (_[_]⁻¹ : (x : R) → ¬ (x ≡ 0r) → R)
                 (is-setR : isSet R)
                 (+-assoc : (x y z : R) → x + (y + z) ≡ (x + y) + z)
                 (+-rid : (x : R) → x + 0r ≡ x)
                 (+-rinv : (x : R) → x + (- x) ≡ 0r)
                 (+-comm : (x y : R) → x + y ≡ y + x)
                 (·-assoc : (x y z : R) → x · (y · z) ≡ (x · y) · z)
                 (·-rid : (x : R) → x · 1r ≡ x)
                 (·-rdist-+ : (x y z : R) → x · (y + z) ≡ (x · y) + (x · z))
                 (·-comm : (x y : R) → x · y ≡ y · x)
                 (·⁻¹≡1 : (x : R) (≢0 : ¬ (x ≡ 0r)) → x · (x [ ≢0 ]⁻¹) ≡ 1r)
                 (0≢1 : ¬ (0r ≡ 1r))
               → Field ℓ
makeField 0r 1r _+_ _·_ -_ _[_]⁻¹ is-setR +-assoc +-rid +-rinv +-comm ·-assoc ·-rid ·-rdist-+ ·-comm ·⁻¹≡1 0≢1 =
  _ , fieldstr _ _ _ _ _ (makeIsField is-setR +-assoc +-rid +-rinv +-comm ·-assoc ·-rid ·-rdist-+ ·-comm ·⁻¹≡1 0≢1)

module _ (R : CommRing ℓ) where

  open CommRingStr (R .snd)

  makeFieldFromCommRing :
    (hasInv : (x : R .fst) → ¬ x ≡ 0r → Σ[ y ∈ R .fst ] x · y ≡ 1r)
    (0≢1 : ¬ 0r ≡ 1r)
    → Field ℓ
  makeFieldFromCommRing hasInv 0≢1 .fst = R .fst
  makeFieldFromCommRing hasInv 0≢1 .snd = fieldstr _ _ _ _ _ (isfield isCommRing hasInv 0≢1)

FieldStr→CommRingStr : {A : Type ℓ} → FieldStr A → CommRingStr A
FieldStr→CommRingStr (fieldstr _ _ _ _ _ H) = commringstr _ _ _ _ _ (IsField.isCommRing H)

Field→CommRing : Field ℓ → CommRing ℓ
Field→CommRing (_ , fieldstr _ _ _ _ _ H) = _ , commringstr _ _ _ _ _ (IsField.isCommRing H)

record IsFieldHom {A : Type ℓ} {B : Type ℓ'} (R : FieldStr A) (f : A → B) (S : FieldStr B)
  : Type (ℓ-max ℓ ℓ')
  where

  -- Shorter qualified names
  private
    module R = FieldStr R
    module S = FieldStr S

  field
    pres0  : f R.0r ≡ S.0r
    pres1  : f R.1r ≡ S.1r
    pres+  : (x y : A) → f (x R.+ y) ≡ f x S.+ f y
    pres·  : (x y : A) → f (x R.· y) ≡ f x S.· f y
    pres-  : (x : A) → f (R.- x) ≡ S.- (f x)

unquoteDecl IsFieldHomIsoΣ = declareRecordIsoΣ IsFieldHomIsoΣ (quote IsFieldHom)

FieldHom : (R : Field ℓ) (S : Field ℓ') → Type (ℓ-max ℓ ℓ')
FieldHom R S = Σ[ f ∈ (⟨ R ⟩ → ⟨ S ⟩) ] IsFieldHom (R .snd) f (S .snd)

IsFieldEquiv : {A : Type ℓ} {B : Type ℓ'}
  (R : FieldStr A) (e : A ≃ B) (S : FieldStr B) → Type (ℓ-max ℓ ℓ')
IsFieldEquiv R e S = IsFieldHom R (e .fst) S

FieldEquiv : (R : Field ℓ) (S : Field ℓ') → Type (ℓ-max ℓ ℓ')
FieldEquiv R S = Σ[ e ∈ (R .fst ≃ S .fst) ] IsFieldEquiv (R .snd) e (S .snd)

_$_ : {R S : Field ℓ} → (φ : FieldHom R S) → (x : ⟨ R ⟩) → ⟨ S ⟩
φ $ x = φ .fst x

FieldEquiv→FieldHom : {A B : Field ℓ} → FieldEquiv A B → FieldHom A B
FieldEquiv→FieldHom (e , eIsHom) = e .fst , eIsHom

isPropIsField : {R : Type ℓ} (0r 1r : R) (_+_ _·_ : R → R → R) (-_ : R → R)
             → isProp (IsField 0r 1r _+_ _·_ -_)
isPropIsField {R = R} 0r 1r _+_ _·_ -_ H@(isfield RR RC RD) (isfield SR SC SD) =
  λ i → isfield (isPropIsCommRing _ _ _ _ _ RR SR i)
                   (isPropInv RC SC i) (isProp¬ _ RD SD i)
  where
  isSetR : isSet _
  isSetR =  RR .IsCommRing.·IsMonoid .IsMonoid.isSemigroup .IsSemigroup.is-set

  isPropInv : isProp ((x : _) → ¬ x ≡ 0r → Σ[ y ∈ R ] x · y ≡ 1r)
  isPropInv = isPropΠ2 (λ x _ → Units.inverseUniqueness (Field→CommRing (_ , fieldstr _ _ _ _ _ H)) x)

𝒮ᴰ-Field : DUARel (𝒮-Univ ℓ) FieldStr ℓ
𝒮ᴰ-Field =
  𝒮ᴰ-Record (𝒮-Univ _) IsFieldEquiv
    (fields:
      data[ 0r ∣ null ∣ pres0 ]
      data[ 1r ∣ null ∣ pres1 ]
      data[ _+_ ∣ bin ∣ pres+ ]
      data[ _·_ ∣ bin ∣ pres· ]
      data[ -_ ∣ autoDUARel _ _ ∣ pres- ]
      prop[ isField ∣ (λ _ _ → isPropIsField _ _ _ _ _) ])
  where
  open FieldStr
  open IsFieldHom

  -- faster with some sharing
  null = autoDUARel (𝒮-Univ _) (λ A → A)
  bin = autoDUARel (𝒮-Univ _) (λ A → A → A → A)

FieldPath : (R S : Field ℓ) → FieldEquiv R S ≃ (R ≡ S)
FieldPath = ∫ 𝒮ᴰ-Field .UARel.ua

uaField : {A B : Field ℓ} → FieldEquiv A B → A ≡ B
uaField {A = A} {B = B} = equivFun (FieldPath A B)


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

open import HoTT

module groups.KernelSndImageInl {i j k}
  (G : Group i) {H : Group j} {K : Group k}
  -- the argument [φ-snd], which is intended to be [φ ∘ᴳ ×-snd],
  -- gives the possibility of making the second part
  -- (the proof of being a group homomorphism) abstract.
  (φ : H →ᴳ K) (φ-snd : G ×ᴳ H →ᴳ K)
  (φ-snd-β : ∀ x → GroupHom.f φ-snd x == GroupHom.f φ (snd x))
  (G×H-is-abelian : is-abelian (G ×ᴳ H))
  where

  open import groups.KernelImage
    φ-snd (×ᴳ-inl {G = G} {H = H}) G×H-is-abelian

  private
    module G = Group G
    module H = Group H

  Ker-φ-snd-quot-Im-inl : Ker φ ≃ᴳ Ker/Im
  Ker-φ-snd-quot-Im-inl = to-hom , is-eq to from to-from from-to where
    to : Ker.El φ → Ker/Im.El
    to (h , h-in-ker) = q[ (G.ident , h) , lemma ]
      where abstract lemma = φ-snd-β (G.ident , h) ∙ h-in-ker

    abstract
      to-pres-comp : ∀ k₁ k₂ → to (Ker.comp φ k₁ k₂) == Ker/Im.comp (to k₁) (to k₂)
      to-pres-comp _ _ = ap q[_] $ Ker.El=-out φ-snd $
        pair×= (! (G.unit-l G.ident)) idp

    to-hom : Ker φ →ᴳ Ker/Im
    to-hom = group-hom to to-pres-comp

    abstract
      from' : Ker.El φ-snd → Ker.El φ
      from' ((g , h) , h-in-ker) = h , ! (φ-snd-β (g , h)) ∙ h-in-ker

      from-rel : ∀ {gh₁ gh₂} → ker/im-rel gh₁ gh₂ → from' gh₁ == from' gh₂
      from-rel {gh₁} {gh₂} = Trunc-rec (Ker.El-is-set φ _ _)
        (λ{(g , inl-g=h₁h₂⁻¹) → Ker.El=-out φ
          (H.zero-diff-same (snd (fst gh₁)) (snd (fst gh₂)) (! (snd×= inl-g=h₁h₂⁻¹)))})

    from : Ker/Im.El → Ker.El φ
    from = SetQuot-rec (Ker.El-is-set φ) from' from-rel

    abstract
      to-from : ∀ g → to (from g) == g
      to-from = SetQuot-elim
        {P = λ g → to (from g) == g}
        (λ _ → =-preserves-set Ker/Im.El-is-set)
        (λ{((g , h) , h-in-ker) → quot-rel
          [ G.inv g , ap2 _,_ (! (G.unit-l (G.inv g))) (! (H.inv-r h)) ]})
        (λ _ → prop-has-all-paths-↓ (Ker/Im.El-is-set _ _))

      from-to : ∀ g → from (to g) == g
      from-to _ = Ker.El=-out φ idp


data Dec (A : Set) : Set where
  yes : A → Dec A
  no  : Dec A

record ⊤ : Set where constructor tt

data _≡_ {A : Set}(x : A) : A → Set where
  refl : x ≡ x

subst : ∀ {A}(P : A → Set){x y} → x ≡ y → P x → P y
subst P refl px = px

cong : ∀ {A B}(f : A → B){x y} → x ≡ y → f x ≡ f y
cong f refl = refl

postulate _≟_ : (n n' : ⊤) → Dec (n ≡ n')

record _×_ A B : Set where
  constructor _,_
  field proj₁ : A
        proj₂ : B

open _×_

data Maybe : Set where
  nothing : Maybe

data Blah (a : Maybe × ⊤) : Set where
  blah  : {b : Maybe × ⊤} → Blah b → Blah a

update : {A : Set} → ⊤ → A → A
update n m with n ≟ n
update n m | yes p  = m
update n m | no     = m

lem-upd : ∀ {A} n (m : A) → update n m ≡ m
lem-upd n m with n ≟ n
... | yes p = refl
... | no    = refl

bug : {x : Maybe × ⊤} → proj₁ x ≡ nothing → Blah x
bug ia = blah (bug (subst {⊤}
                      (λ _ → proj₁ {B = ⊤}
                                   (update tt (nothing , tt)) ≡ nothing)
                   refl (cong proj₁ (lem-upd _ _))))


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

module Calf.Types.Sum where

open import Calf.Prelude
open import Calf.Metalanguage

open import Data.Sum using (_⊎_; inj₁; inj₂) public

sum : tp pos → tp pos → tp pos
sum A B = U (meta (val A ⊎ val B))

sum/case : ∀ A B (X : val (sum A B) → tp neg) → (s : val (sum A B)) → ((a : val A) → cmp (X (inj₁ a))) → ((b : val B) → cmp (X (inj₂ b))) → cmp (X s)
sum/case A B X (inj₁ x) b₁ _  = b₁ x
sum/case A B X (inj₂ x) _  b₂ = b₂ x


open import Relation.Binary.PropositionalEquality using ( refl )
open import Web.Semantic.DL.ABox.Interp using ( Interp ; ⌊_⌋ ; ind ; _*_ )
open import Web.Semantic.DL.ABox.Model using
  ( _⊨a_ ; ⊨a-resp-≡³ ; ⊨a-impl-⊨b ; ⊨b-impl-⊨a
  ; _,_ ; inb ; on-bnode ; bnodes )
open import Web.Semantic.DL.Category.Object using ( Object ; IN ; iface )
open import Web.Semantic.DL.Category.Morphism using
  ( _⇒_ ; _,_ ; BN ; impl ; _⊑_ ; _≣_ )
open import Web.Semantic.DL.KB using ( _,_ )
open import Web.Semantic.DL.KB.Model using ( _⊨_ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox ; _,_ )
open import Web.Semantic.DL.TBox.Interp using ( Δ )
open import Web.Semantic.Util using ( _⊕_⊕_ ; inode )

module Web.Semantic.DL.Category.Properties.Equivalence
  {Σ : Signature} {S T : TBox Σ} where

⊑-refl : ∀ {A B : Object S T} (F : A ⇒ B) → (F ⊑ F)
⊑-refl F I I⊨STA I⊨F = ⊨a-impl-⊨b I (impl F) I⊨F

⊑-trans : ∀ {A B : Object S T} (F G H : A ⇒ B) → (F ⊑ G) → (G ⊑ H) → (F ⊑ H)
⊑-trans {A} {B} F G H F⊑G G⊑H I I⊨STA I⊨F = (g , I⊨H) where

  f : BN G → Δ ⌊ I ⌋
  f = inb (F⊑G I I⊨STA I⊨F)

  J : Interp Σ (IN A ⊕ BN G ⊕ IN B)
  J = bnodes I f

  J⊨STA : inode * J ⊨ (S , T) , iface A
  J⊨STA = I⊨STA

  J⊨G : J ⊨a impl G
  J⊨G = ⊨b-impl-⊨a (F⊑G I I⊨STA I⊨F)

  g : BN H → Δ ⌊ I ⌋
  g = inb (G⊑H J J⊨STA J⊨G)

  K : Interp Σ (IN A ⊕ BN H ⊕ IN B)
  K = bnodes J g

  K⊨H : K ⊨a impl H
  K⊨H = ⊨b-impl-⊨a (G⊑H J J⊨STA J⊨G)

  I⊨H : bnodes I g ⊨a impl H
  I⊨H = ⊨a-resp-≡³ K (on-bnode g (ind I)) refl (impl H) K⊨H

≣-refl : ∀ {A B : Object S T} (F : A ⇒ B) → (F ≣ F)
≣-refl F = (⊑-refl F , ⊑-refl F)

≣-sym :  ∀ {A B : Object S T} {F G : A ⇒ B} → (F ≣ G) → (G ≣ F)
≣-sym (F⊑G , G⊑F) = (G⊑F , F⊑G)

≣-trans :  ∀ {A B : Object S T} {F G H : A ⇒ B} → (F ≣ G) → (G ≣ H) → (F ≣ H)
≣-trans {A} {B} {F} {G} {H} (F⊑G , G⊑F) (G⊑H , H⊑G) =
  (⊑-trans F G H F⊑G G⊑H , ⊑-trans H G F H⊑G G⊑F)


open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Nat.Show using (show)
open import Function using (_$!_)
open import IO using (run; putStrLn)

sum : ℕ
sum = f 1000000000 0
  where
  f : ℕ → ℕ → ℕ
  f zero    acc = acc
  f (suc n) acc = f n $! suc n + acc

main = run (putStrLn (show sum))


{-# OPTIONS --universe-polymorphism #-}
module Categories.Comma.Functors where

open import Categories.Category
open import Categories.Functor renaming (_∘_ to _∘F_)
open import Categories.FunctorCategory renaming (Functors to [_⇒_])
open import Categories.NaturalTransformation using (module NaturalTransformation)
open import Data.Product using (∃; _,_; proj₁; proj₂; zip; map)
open import Level
open import Relation.Binary using (Rel)
open import Categories.Support.EqReasoning
open import Categories.Square

open import Categories.Comma
open import Categories.Product renaming (Product to _×_)

πComma :
  ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂ o₃ ℓ₃ e₃}
    → {A : Category o₁ ℓ₁ e₁}
    → {B : Category o₂ ℓ₂ e₂}
    → {C : Category o₃ ℓ₃ e₃}
    → (S : Functor B C) (T : Functor A C)
    → Functor (S ↓ T) (B × A)
πComma {A = A} {B} {C} S T =
  record
    { F₀ = F₀′
    ; F₁ = F₁′
    ; identity = B×A.Equiv.refl
    ; homomorphism = B×A.Equiv.refl
    ; F-resp-≡ = λ pf → pf
    }
  where
    module S↓T = Category (S ↓ T)
    module B×A = Category (B × A)
    open Comma S T using (_,_[_]) renaming (_,_,_ to ⟨_,_,_⟩)

    F₀′ : S↓T.Obj → B×A.Obj
    F₀′ ⟨ α , β , f ⟩ = α , β

    F₁′ : ∀ {X Y} → (S ↓ T) [ X , Y ] → (B × A) [ F₀′ X , F₀′ Y ]
    F₁′ (g , h [ commutes ]) = g , h

InducedFunctor : ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂ o₃ ℓ₃ e₃}
                   {A : Category o₁ ℓ₁ e₁}
                   {B : Category o₂ ℓ₂ e₂}
                   {C : Category o₃ ℓ₃ e₃}
                   {s₁ s₂ d₁ d₂}
                   (m : (Category.op [ A ⇒ C ] × [ B ⇒ C ]) [ (s₁ , s₂) , (d₁ , d₂) ])
                 → Functor (s₁ ↓ s₂) (d₁ ↓ d₂)
InducedFunctor {A = A} {B} {C} {s₁} {s₂} {d₁} {d₂} m = record
  { F₀ = F₀′
  ; F₁ = F₁′
  ; identity = λ {X} → d₁↓d₂.Equiv.refl {_} {_} {d₁↓d₂.id {F₀′ X}}
  ; homomorphism = λ {_ _ _ f g} → d₁↓d₂.Equiv.refl {_} {_} {F₁′ ((s₁ ↓ s₂) [ g ∘ f ])}
  ; F-resp-≡ = λ pf → pf
  }
  where
  module s₁↓s₂ = Category (s₁ ↓ s₂)
  module d₁↓d₂ = Category (d₁ ↓ d₂)
  module s₁ = Functor s₁
  module s₂ = Functor s₂
  module d₁ = Functor d₁
  module d₂ = Functor d₂
  module m₁ = NaturalTransformation (proj₁ m)
  module m₂ = NaturalTransformation (proj₂ m)

  open Category C
  open Comma renaming (_,_,_ to ⟨_,_,_⟩)

  F₀′ : s₁↓s₂.Obj → d₁↓d₂.Obj
  F₀′ ⟨ α , β , f ⟩ = ⟨ α , β , m₂.η β ∘ f ∘ m₁.η α ⟩

  F₁′ : ∀ {X Y} → (s₁ ↓ s₂) [ X , Y ] → (d₁ ↓ d₂) [ F₀′ X , F₀′ Y ]
  F₁′ {⟨ α₁ , β₁ , f₁ ⟩} {⟨ α₂ , β₂ , f₂ ⟩} (g , h [ commutes ]) = g , h [ (
      begin
        d₂.F₁ h ∘ m₂.η β₁ ∘ f₁ ∘ m₁.η α₁
      ↑⟨ pushˡ (m₂.commute h) ⟩
        (m₂.η β₂ ∘ s₂.F₁ h) ∘ f₁ ∘ m₁.η α₁
      ↓⟨ pullˡ (pullʳ commutes) ⟩
        (m₂.η β₂ ∘ f₂ ∘ s₁.F₁ g) ∘ m₁.η α₁
      ↑⟨ extendˡ (extendˡ (m₁.commute g)) ⟩
        (m₂.η β₂ ∘ f₂ ∘ m₁.η α₂) ∘ d₁.F₁ g
      ∎ ) ]
    where
    open HomReasoning
    open GlueSquares C


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Instance.Posets where

-- The category of partially ordered sets and order-preserving maps.

open import Level
open import Relation.Binary using (Poset; IsEquivalence; _Preserves_⟶_)
open import Relation.Binary.Morphism using (IsOrderHomomorphism)
import Relation.Binary.Morphism.Construct.Identity as Id
import Relation.Binary.Morphism.Construct.Composition as Comp

open import Categories.Category

open Poset renaming (_≈_ to ₍_₎_≈_; _≤_ to ₍_₎_≤_)

private
  variable
    a₁ a₂ a₃ b₁ b₂ b₃ : Level
    A B C : Poset a₁ a₂ a₃

record _⇒-Poset_ (A : Poset a₁ a₂ a₃) (B : Poset b₁ b₂ b₃) : Set (a₁ ⊔ a₂ ⊔ a₃ ⊔ b₁ ⊔ b₂ ⊔ b₃)  where
  field
    fun : Carrier A → Carrier B
    isOrderHomomorphism : IsOrderHomomorphism ₍ A ₎_≈_ ₍ B ₎_≈_ ₍ A ₎_≤_ ₍ B ₎_≤_ fun

  open IsOrderHomomorphism isOrderHomomorphism public
    renaming (mono to monotone)

open _⇒-Poset_

⇒-Poset-id : A ⇒-Poset A
⇒-Poset-id = record
  { isOrderHomomorphism = Id.isOrderHomomorphism _ _
  }

⇒-Poset-∘ : B ⇒-Poset C → A ⇒-Poset B → A ⇒-Poset C
⇒-Poset-∘ B⇒C A⇒B = record
  { isOrderHomomorphism = Comp.isOrderHomomorphism (isOrderHomomorphism A⇒B) (isOrderHomomorphism B⇒C)
  }

module _ {A : Poset a₁ a₂ a₃} {B : Poset b₁ b₂ b₃} where

  infix 4 _≗_

  -- Order morphisms preserve equality.
  mono⇒cong : ∀ {f} → f Preserves ₍ A ₎_≤_ ⟶ ₍ B ₎_≤_ → f Preserves ₍ A ₎_≈_ ⟶ ₍ B ₎_≈_
  mono⇒cong {f} monotone x≈y = antisym B
    (monotone (reflexive A x≈y))
    (monotone (reflexive A (Eq.sym A x≈y)))

  ⇒-Poset-helper : ∀ f → f Preserves ₍ A ₎_≤_ ⟶ ₍ B ₎_≤_ → A ⇒-Poset B
  ⇒-Poset-helper f mono = record
    { isOrderHomomorphism = record
      { cong = mono⇒cong mono
      ; mono = mono
      }
    }

  -- Pointwise equality (on order preserving maps).

  _≗_ : (f g : A ⇒-Poset B) → Set (a₁ ⊔ b₂)
  f ≗ g = ∀ {x} → ₍ B ₎ fun f x ≈ fun g x

  ≗-isEquivalence : IsEquivalence _≗_
  ≗-isEquivalence = record
    { refl    = Eq.refl B
    ; sym     = λ f≈g → Eq.sym B f≈g
    ; trans   = λ f≈g g≈h → Eq.trans B f≈g g≈h
    }

  module ≗ = IsEquivalence ≗-isEquivalence

-- The category of posets and order-preserving maps.

Posets : ∀ c ℓ₁ ℓ₂ → Category (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) (c ⊔ ℓ₁ ⊔ ℓ₂) (c ⊔ ℓ₁)
Posets c ℓ₁ ℓ₂ = record
  { Obj       = Poset c ℓ₁ ℓ₂
  ; _⇒_       = _⇒-Poset_
  ; _≈_       = _≗_
  ; id        = ⇒-Poset-id
  ; _∘_       = ⇒-Poset-∘
  ; assoc     = λ {_ _ _ D} → Eq.refl D
  ; sym-assoc = λ {_ _ _ D} → Eq.refl D
  ; identityˡ = λ {_ B} → Eq.refl B
  ; identityʳ = λ {_ B} → Eq.refl B
  ; identity² = λ {A} → Eq.refl A
  ; equiv     = ≗-isEquivalence
  ; ∘-resp-≈  = λ {_ _ C _ h} f≈h g≈i → Eq.trans C f≈h (cong h g≈i)
  }


{-# OPTIONS --safe #-}
module Cubical.Algebra.OrderedCommMonoid.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Structure
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.SIP using (TypeWithStr)

open import Cubical.Data.Sigma

open import Cubical.Algebra.CommMonoid
open import Cubical.Algebra.OrderedCommMonoid.Base

open import Cubical.Relation.Binary.Poset

private
  variable
    ℓ ℓ' ℓ'' : Level

module _
    (M : OrderedCommMonoid ℓ ℓ')
    (P : ⟨ M ⟩ → hProp ℓ'')
    where
  open OrderedCommMonoidStr (snd M)
  module _
    (·Closed : (x y : ⟨ M ⟩) → ⟨ P x ⟩ → ⟨ P y ⟩ → ⟨ P (x · y) ⟩)
    (εContained : ⟨ P ε ⟩)
    where
    private
      subtype = Σ[ x ∈ ⟨ M ⟩ ] ⟨ P x ⟩
      submonoid =  makeSubCommMonoid (OrderedCommMonoid→CommMonoid M) P ·Closed εContained
      _≤ₛ_ : (x y : ⟨ submonoid ⟩) → Type ℓ'
      x ≤ₛ y = (fst x) ≤ (fst y)
      pres≤ : (x y : ⟨ submonoid ⟩) (x≤y : x ≤ₛ y) → (fst x) ≤ (fst y)
      pres≤ x y x≤y = x≤y

    makeOrderedSubmonoid : OrderedCommMonoid _ ℓ'
    fst makeOrderedSubmonoid = subtype
    OrderedCommMonoidStr._≤_ (snd makeOrderedSubmonoid) = _≤ₛ_
    OrderedCommMonoidStr._·_ (snd makeOrderedSubmonoid) = CommMonoidStr._·_ (snd submonoid)
    OrderedCommMonoidStr.ε (snd makeOrderedSubmonoid) = CommMonoidStr.ε (snd submonoid)
    OrderedCommMonoidStr.isOrderedCommMonoid (snd makeOrderedSubmonoid) =
      IsOrderedCommMonoidFromIsCommMonoid
        (CommMonoidStr.isCommMonoid (snd submonoid))
        (λ x y → is-prop-valued (fst x) (fst y))
        (λ x → is-refl (fst x))
        (λ x y z → is-trans (fst x) (fst y) (fst z))
        (λ x y x≤y y≤x
          → Σ≡Prop (λ x → snd (P x))
                   (is-antisym (fst x) (fst y) (pres≤ x y x≤y) (pres≤ y x y≤x)))
        (λ x y z x≤y → MonotoneR (pres≤ x y x≤y))
        λ x y z x≤y → MonotoneL (pres≤ x y x≤y)


{-# OPTIONS --safe #-}
module Cubical.Algebra.AbGroup.Instances.DirectSumHIT where

open import Cubical.Foundations.Prelude

open import Cubical.Algebra.AbGroup

open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.DirectSum.DirectSumHIT.Properties

private variable
  ℓ ℓ' : Level

module _ (Idx : Type ℓ) (P : Idx → Type ℓ') (AGP : (r : Idx) → AbGroupStr (P r)) where

  open AbGroupStr
  open AbGroupProperties Idx P AGP

  ⊕HIT-AbGr : AbGroup (ℓ-max ℓ ℓ')
  fst ⊕HIT-AbGr = ⊕HIT Idx P AGP
  0g (snd ⊕HIT-AbGr) = neutral
  _+_ (snd ⊕HIT-AbGr) = _add_
  - snd ⊕HIT-AbGr = inv
  isAbGroup (snd ⊕HIT-AbGr) = makeIsAbGroup trunc addAssoc addRid rinv addComm


{-# OPTIONS --safe #-}
module Cubical.Algebra.DirectSum.DirectSumFun.Properties where

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

open import Cubical.Data.Nat renaming (_+_ to _+n_ ; _·_ to _·n_)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation as PT

open import Cubical.Algebra.Group
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.DirectSum.DirectSumFun.Base

private variable
  ℓ : Level

open GroupTheory
open AbGroupStr

-----------------------------------------------------------------------------
-- AbGroup Properties

module DSF-properties
  (G : ℕ → Type ℓ)
  (Gstr : (n : ℕ) → AbGroupStr (G n))
  where

  private
    GG : ℕ → Group ℓ
    GG n = AbGroup→Group ((G n) , (Gstr n))

  isSet⊕Fun : isSet (⊕Fun G Gstr)
  isSet⊕Fun = isSetΣSndProp (isSetΠ (λ n → is-set (Gstr n))) (λ _ → squash₁)

  -- Object
  0⊕Fun : ⊕Fun G Gstr
  0⊕Fun = (λ n → 0g (Gstr n)) , ∣ (0 , λ n p → refl) ∣₁

  _+⊕Fun_ : ⊕Fun G Gstr → ⊕Fun G Gstr → ⊕Fun G Gstr
  _+⊕Fun_ (f , Anf) (g , Ang) = f+g , Anf+g Anf Ang
    where
    f+g = λ n → Gstr n ._+_ (f n) (g n)
    Anf+g : AlmostNullP G Gstr f → AlmostNullP G Gstr g → AlmostNullP G Gstr f+g
    Anf+g = PT.rec2 squash₁
            (λ { (k , nf) → λ { (l , ng) →
               ∣ ((k +n l) ,
                 (λ n p → cong₂ ((Gstr n)._+_) (nf n (<-+k-trans p)) (ng n (<-k+-trans p))
                           ∙ +IdR (Gstr n) (0g (Gstr n)))) ∣₁ } })

  Inv⊕Fun : ⊕Fun G Gstr → ⊕Fun G Gstr
  Inv⊕Fun (f , Anf) = f- , Anf- Anf
    where
    f- = λ n → (Gstr n).-_ (f n)
    Anf- : AlmostNullP G Gstr f → AlmostNullP G Gstr f-
    Anf- = PT.rec squash₁
           (λ { (k , nf) →
              ∣ (k , λ n p → cong ((Gstr n).-_) (nf n p) ∙ inv1g (GG n)) ∣₁})

  -- AbGroup Properties
  +⊕FunAssoc : (x y z : ⊕Fun G Gstr) → x +⊕Fun (y +⊕Fun z) ≡ (x +⊕Fun y) +⊕Fun z
  +⊕FunAssoc (f , Anf) (g , Ang) (h , Anh) =
             ΣPathTransport→PathΣ _ _
             (funExt (λ n → Gstr n .+Assoc _ _ _) , (squash₁ _ _))

  +⊕FunRid : (x : ⊕Fun G Gstr) → x +⊕Fun 0⊕Fun ≡ x
  +⊕FunRid (f , Anf) = ΣPathTransport→PathΣ _ _
                       ((funExt (λ n → +IdR (Gstr n) _)) , squash₁ _ _)

  +⊕FunInvR : (x : ⊕Fun G Gstr) → x +⊕Fun Inv⊕Fun x ≡ 0⊕Fun
  +⊕FunInvR (f , Anf) = ΣPathTransport→PathΣ _ _
                        ((funExt (λ n → +InvR (Gstr n) _)) , (squash₁ _ _))

  +⊕FunComm : (x y : ⊕Fun G Gstr) →  x +⊕Fun y ≡ y +⊕Fun x
  +⊕FunComm (f , Anf) (g , Ang) = ΣPathTransport→PathΣ _ _
                                  ((funExt (λ n → Gstr n .+Comm _ _)) , (squash₁ _ _))


{-# OPTIONS --without-K #-}
module NTypes.Sigma where

open import NTypes
open import PathOperations
open import PathStructure.Sigma
open import Transport
open import Types

Σ-isSet : ∀ {a b} {A : Set a} {B : A → Set b} →
  isSet A → (∀ x → isSet (B x)) → isSet (Σ A B)
Σ-isSet {A = A} {B = B} A-set B-set x y p q
  = split-eq p ⁻¹
  · ap₂-dep-eq {B = B} _,_
      (ap π₁ p)
      (ap π₁ q)
      π₁-eq
      (tr-∘ π₁ p (π₂ x) ⁻¹ · apd π₂ p)
      (tr-∘ π₁ q (π₂ x) ⁻¹ · apd π₂ q)
      π₂-eq
  · split-eq q
  where
  split-eq : (p : x ≡ y) →
    ap₂-dep {B = B} _,_ (ap π₁ p)
      (tr-∘ π₁ p (π₂ x) ⁻¹  · apd π₂ p) ≡ p
  split-eq = π₂ (π₂ (π₂ split-merge-eq))

  π₁-eq : ap π₁ p ≡ ap π₁ q
  π₁-eq = A-set _ _ (ap π₁ p) (ap π₁ q)

  π₂-eq : tr (λ z → tr B z (π₂ x) ≡ π₂ y) π₁-eq
            (tr-∘ π₁ p (π₂ x) ⁻¹ · apd π₂ p)
        ≡ tr-∘ π₁ q (π₂ x) ⁻¹ · apd π₂ q
  π₂-eq = B-set _ (tr B (ap π₁ q) (π₂ x)) (π₂ y)
    (tr
      (λ z → tr B z (π₂ x) ≡ π₂ y)
      π₁-eq
      (tr-∘ π₁ p (π₂ x) ⁻¹ · apd π₂ p))
    (tr-∘ π₁ q (π₂ x) ⁻¹ · apd π₂ q)


module Web.Semantic.DL.Signature where

infixr 4 _,_

data Signature : Set₁ where
  _,_ : (CN RN : Set) → Signature

CN : Signature → Set
CN (CN , RN) = CN

RN : Signature → Set
RN (CN , RN) = RN


{-

This module converts between the path types and the inductively
defined equality types.

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

module Cubical.Data.Equality where

open import Cubical.Foundations.Prelude public
  hiding ( _≡_ ; _≡⟨_⟩_ ; _∎ ; isPropIsContr)
  renaming ( refl      to reflPath
           ; transport to transportPath
           ; J         to JPath
           ; JRefl     to JPathRefl
           ; sym       to symPath
           ; _∙_       to compPath
           ; cong      to congPath
           ; subst     to substPath
           ; funExt    to funExtPath
           ; isContr   to isContrPath
           ; isProp    to isPropPath )
open import Cubical.Foundations.Equiv
  renaming ( fiber     to fiberPath
           ; isEquiv   to isEquivPath
           ; _≃_       to EquivPath
           ; equivFun  to equivFunPath
           ; isPropIsEquiv to isPropIsEquivPath )
  hiding   ( equivCtr
           ; equivIsEquiv )
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence hiding (univalence)
open import Cubical.HITs.PropositionalTruncation public
  renaming (rec to recPropTruncPath
           ; elim to elimPropTruncPath )
open import Cubical.HITs.S1 as S1
  renaming (loop to loopPath)
  hiding (helix ; winding ; ΩS¹ ; encode ; intLoop ; decode ; decodeEncode)
open import Cubical.Data.Nat
open import Cubical.Data.Int

-- Import the builtin equality type defined as an inductive family
open import Agda.Builtin.Equality public

private
 variable
  ℓ ℓ' : Level
  A B : Type ℓ
  x y z : A

infix  3 _∎
infixr 2 _≡⟨_⟩_

ap : (f : A → B) {x y : A} → x ≡ y → f x ≡ f y
ap f refl = refl

_∙_ : {x y z : A} → x ≡ y → y ≡ z → x ≡ z
refl ∙ q = q

_≡⟨_⟩_ : (x : A) {y z : A} → x ≡ y → y ≡ z → x ≡ z
_ ≡⟨ p ⟩ q = p ∙ q

_∎ : (x : A) → x ≡ x
_ ∎ = refl

transport : ∀ (C : A → Type ℓ') {x y : A} → x ≡ y → C x → C y
transport C refl b = b

sym : {x y : A} → x ≡ y → y ≡ x
sym refl = refl

apd : {C : A → Type ℓ} (f : (x : A) → C x) {x y : A} (p : x ≡ y) → transport C p (f x) ≡ f y
apd f refl = refl

congPathd : {C : A → Type ℓ} (f : (x : A) → C x) {x y : A} (p : Path A x y) → Path (C y) (substPath C p (f x)) (f y)
congPathd f p = fromPathP (congPath f p)

-- Equality between Path and equality
eqToPath : {x y : A} → x ≡ y → Path A x y
eqToPath refl = reflPath

pathToEq : {x y : A} → Path A x y → x ≡ y
pathToEq {x = x} = JPath (λ y _ → x ≡ y) refl

eqToPath-pathToEq : {x y : A} → (p : Path A x y) → Path _ (eqToPath (pathToEq p)) p
eqToPath-pathToEq p =
  JPath (λ _ h → Path _ (eqToPath (pathToEq h)) h)
        (congPath eqToPath (transportRefl refl)) p

pathToEq-eqToPath : {x y : A} → (p : x ≡ y) → Path _ (pathToEq (eqToPath p)) p
pathToEq-eqToPath refl = transportRefl refl

PathIsoEq : {x y : A} → Iso (Path A x y) (x ≡ y)
PathIsoEq = iso pathToEq eqToPath pathToEq-eqToPath eqToPath-pathToEq

PathPathEq : {x y : A} → Path _ (Path A x y) (x ≡ y)
PathPathEq = isoToPath PathIsoEq

Path≡Eq : {x y : A} → (Path A x y) ≡ (x ≡ y)
Path≡Eq = pathToEq PathPathEq

-- We get funext by going back and forth between Path and Eq
funExt : {B : A → Type ℓ} {f g : (x : A) → B x} → ((x : A) → f x ≡ g x) → f ≡ g
funExt p = pathToEq (λ i x → eqToPath (p x) i)

-- Some lemmas relating the definitions for Path and ≡
substPath≡transport' : (C : A → Type ℓ) {x y : A} (b : C x) (p : x ≡ y) → substPath C (eqToPath p) b ≡ transport C p b
substPath≡transport' C b refl = pathToEq (transportRefl b)

substPath≡transport : (C : A → Type ℓ) {x y : A} (b : C x) (p : Path _ x y) → substPath C p b ≡ transport C (pathToEq p) b
substPath≡transport C b p = ap (λ x → substPath C x b) (pathToEq (symPath (eqToPath-pathToEq p)))
                          ∙ substPath≡transport' C b (pathToEq p)

congPath≡ap : {x y : A} → (f : A → B) (p : x ≡ y) → congPath f (eqToPath p) ≡ eqToPath (ap f p)
congPath≡ap f refl = refl

ap≡congPath : {x y : A} → (f : A → B) (p : Path A x y) → ap f (pathToEq p) ≡ pathToEq (congPath f p)
ap≡congPath {x = x} f p = JPath (λ _ q → ap f (pathToEq q) ≡ pathToEq (congPath f q)) rem p
  where
  rem : ap f (transp (λ i → x ≡ x) i0 refl) ≡ transp (λ i → f x ≡ f x) i0 refl
  rem = pathToEq (compPath (λ i → ap f (transportRefl refl i)) (symPath (transportRefl refl)))

-- Equivalences expressed using ≡ everywhere
fiber : ∀ {A : Type ℓ} {B : Type ℓ'} (f : A → B) (y : B) → Type (ℓ-max ℓ ℓ')
fiber {A = A} f y = Σ[ x ∈ A ] f x ≡ y

isContr : Type ℓ → Type ℓ
isContr A = Σ[ x ∈ A ] (∀ y → x ≡ y)

isProp : Type ℓ → Type ℓ
isProp A = (x y : A) → x ≡ y

record isEquiv {A : Type ℓ} {B : Type ℓ'} (f : A → B) : Type (ℓ-max ℓ ℓ') where
  field
    equiv-proof : (y : B) → isContr (fiber f y)

open isEquiv public

infix 4 _≃_

_≃_ : ∀ (A : Type ℓ) (B : Type ℓ') → Type (ℓ-max ℓ ℓ')
A ≃ B = Σ[ f ∈ (A → B) ] (isEquiv f)

equivFun : A ≃ B → A → B
equivFun e = e .fst

equivIsEquiv : (e : A ≃ B) → isEquiv (equivFun e)
equivIsEquiv e = e .snd

equivCtr : (e : A ≃ B) (y : B) → fiber (equivFun e) y
equivCtr e y = e .snd .equiv-proof y .fst

-- Functions for going between the various definitions. This could
-- also be achieved by making lines in the universe and transporting
-- back and forth along them.

fiberPathToFiber : {f : A → B} {y : B} → fiberPath f y → fiber f y
fiberPathToFiber (x , p) = (x , pathToEq p)

fiberToFiberPath : {f : A → B} {y : B} → fiber f y → fiberPath f y
fiberToFiberPath (x , p) = (x , eqToPath p)

fiberToFiber : {f : A → B} {y : B} (p : fiber f y) → Path _ (fiberPathToFiber (fiberToFiberPath p)) p
fiberToFiber (x , p) i = x , pathToEq-eqToPath p i

fiberPathToFiberPath : {f : A → B} {y : B} (p : fiberPath f y) → Path _ (fiberToFiberPath (fiberPathToFiber p)) p
fiberPathToFiberPath (x , p) i = x , eqToPath-pathToEq p i

isContrPathToIsContr : isContrPath A → isContr A
isContrPathToIsContr (ctr , p) = (ctr , λ y → pathToEq (p y))

isContrToIsContrPath : isContr A → isContrPath A
isContrToIsContrPath (ctr , p) = (ctr , λ y → eqToPath (p y))

isPropPathToIsProp : isPropPath A → isProp A
isPropPathToIsProp H x y = pathToEq (H x y)

isPropToIsPropPath : isProp A → isPropPath A
isPropToIsPropPath H x y = eqToPath (H x y)

-- Specialized helper lemmas for going back and forth between
-- isContrPath and isContr:

helper1 : {A B : Type ℓ} (f : A → B) (g : B → A) (h : ∀ y → Path _ (f (g y)) y)
        → isContrPath A → isContr B
helper1 f g h (x , p) =
  (f x , λ y → pathToEq (λ i → hcomp (λ j → λ { (i = i0) → f x
                                              ; (i = i1) → h y j })
                                     (f (p (g y) i))))

helper2 : {A B : Type ℓ} (f : A → B) (g : B → A) (h : ∀ y → Path _ (g (f y)) y)
        → isContr B → isContrPath A
helper2 {A = A} f g h (x , p) = (g x , λ y → eqToPath (ap g (p (f y)) ∙ pathToEq (h y)))

-- This proof is essentially the one for proving that isContr with
-- Path is a proposition, but as we are working with ≡ we have to
-- insert a lof of conversion functions.
-- TODO: prove this directly following the HoTT proof?
isPropIsContr : (p1 p2 : isContr A) → Path (isContr A) p1 p2
isPropIsContr (a0 , p0) (a1 , p1) j =
  ( eqToPath (p0 a1) j ,
    hcomp (λ i → λ { (j = i0) →  λ x → pathToEq-eqToPath (p0 x) i
                   ; (j = i1) →  λ x → pathToEq-eqToPath (p1 x) i })
          (λ x → pathToEq (λ i → hcomp (λ k → λ { (i = i0) → eqToPath (p0 a1) j
                                                ; (i = i1) → eqToPath (p0 x) (j ∨ k)
                                                ; (j = i0) → eqToPath (p0 x) (i ∧ k)
                                                ; (j = i1) → eqToPath (p1 x) i })
                                       (eqToPath (p0 (eqToPath (p1 x) i)) j))))

-- We now prove that isEquiv is a proposition
isPropIsEquiv : {A B : Type ℓ} {f : A → B} (h1 h2 : isEquiv f) → Path _ h1 h2
equiv-proof (isPropIsEquiv h1 h2 i) y = isPropIsContr (h1 .equiv-proof y) (h2 .equiv-proof y) i

equivToEquivPath : A ≃ B → EquivPath A B
equivToEquivPath (f , p) =
  (f , λ { .equiv-proof y → helper2 fiberPathToFiber fiberToFiberPath fiberPathToFiberPath (p .equiv-proof y) })

-- Go from a Path equivalence to an ≡ equivalence
equivPathToEquiv : EquivPath A B → A ≃ B
equivPathToEquiv (f , p) =
  (f , λ { .equiv-proof y → helper1 fiberPathToFiber fiberToFiberPath fiberToFiber (p .equiv-proof y) })

equivToEquiv : {A B : Type ℓ} (p : A ≃ B) → Path _ (equivPathToEquiv (equivToEquivPath p)) p
equivToEquiv (f , p) i =
  (f , isPropIsEquiv (λ { .equiv-proof y → helper1 fiberPathToFiber fiberToFiberPath fiberToFiber
                                             (helper2 fiberPathToFiber fiberToFiberPath fiberPathToFiberPath (p .equiv-proof y)) }) p i)

equivPathToEquivPath : {A B : Type ℓ} (p : EquivPath A B) → Path _ (equivToEquivPath (equivPathToEquiv p)) p
equivPathToEquivPath (f , p) i =
  ( f , isPropIsEquivPath f (equivToEquivPath (equivPathToEquiv (f , p)) .snd) p i )

equivPath≡Equiv : {A B : Type ℓ} → Path _ (EquivPath A B) (A ≃ B)
equivPath≡Equiv {ℓ} = isoToPath (iso (equivPathToEquiv {ℓ}) equivToEquivPath equivToEquiv equivPathToEquivPath)

path≡Eq : {A B : Type ℓ} → Path _ (Path _ A B) (A ≡ B)
path≡Eq = isoToPath (iso pathToEq eqToPath pathToEq-eqToPath eqToPath-pathToEq)

-- Univalence formulated using ≡ everywhere
univalenceEq : (A ≡ B) ≃ (A ≃ B)
univalenceEq {A = A} {B = B} = equivPathToEquiv rem
  where
  rem0 : Path _ (Lift (EquivPath A B)) (Lift (A ≃ B))
  rem0 = congPath Lift equivPath≡Equiv

  rem1 : Path _ (A ≡ B) (Lift (A ≃ B))
  rem1 i = hcomp (λ j → λ { (i = i0) → path≡Eq {A = A} {B = B} j
                          ; (i = i1) → rem0 j })
                 (univalencePath {A = A} {B = B} i)

  rem : EquivPath (A ≡ B) (A ≃ B)
  rem = compEquiv (eqweqmap rem1) (invEquiv LiftEquiv)

-- Propositional truncation using ≡ with paths under the hood

∥∥-isProp : ∀ (x y : ∥ A ∥₁) → x ≡ y
∥∥-isProp x y = pathToEq (squash₁ x y)

∥∥-recursion : ∀ {A : Type ℓ} {P : Type ℓ} → isProp P → (A → P) → ∥ A ∥₁ → P
∥∥-recursion Pprop = recPropTruncPath (isPropToIsPropPath Pprop)

∥∥-induction : ∀ {A : Type ℓ} {P : ∥ A ∥₁ → Type ℓ} → ((a : ∥ A ∥₁) → isProp (P a)) →
                ((x : A) → P ∣ x ∣₁) → (a : ∥ A ∥₁) → P a
∥∥-induction Pprop = elimPropTruncPath (λ a → isPropToIsPropPath (Pprop a))

-- The circle using ≡

loop : base ≡ base
loop = pathToEq loopPath

S¹-rec : {A : Type ℓ} (b : A) (l : b ≡ b) → S¹ → A
S¹-rec b l = S1.rec b (eqToPath l)

S¹-recβ : (b : A) (l : b ≡ b) → ap (S¹-rec b l) loop ≡ l
S¹-recβ b l =
  ap (S¹-rec b l) loop ≡⟨ ap≡congPath (S¹-rec b l) loopPath ⟩
  pathToEq (congPath (S¹-rec b l) loopPath) ≡⟨ refl ⟩
  pathToEq (eqToPath l) ≡⟨ pathToEq (pathToEq-eqToPath l) ⟩
  l ∎

-- TODO: see https://github.com/agda/cubical/pull/309#discussion_r424664465
-- S¹-elimβ : (C : S¹ → Type ℓ) (b : C base) (l : transport C loop b ≡ b) → apd (S¹-elim C b l) loop ≡ l
-- S¹-elimβ C b l =
  -- apd (S¹-elim C b l) (pathToEq loopPath) ≡⟨ {!!} ⟩
  -- {!!} ≡⟨ {!!} ⟩
  -- l ∎

-- We now compute some winding numbers to check that everything computes as expected

Cover : S¹ → Type₀
Cover = S¹-rec ℤ (pathToEq sucPathℤ)

ΩS¹ : Type₀
ΩS¹ = base ≡ base

encode : {x : S¹} → base ≡ x → Cover x
encode p = transport Cover p (pos zero)

winding : ΩS¹ → ℤ
winding = encode {base}

loop^ : ℤ → ΩS¹
loop^ (pos zero)       = refl
loop^ (pos (suc n))    = loop^ (pos n) ∙ loop
loop^ (negsuc zero)    = sym loop
loop^ (negsuc (suc n)) = loop^ (negsuc n) ∙ sym loop

private
  test-winding-refl : winding refl ≡ pos 0
  test-winding-refl = refl

  -- These should type check if things would compute:

  -- test-winding-loop : winding loop ≡ pos 1
  -- test-winding-loop = refl

  -- test-winding-pos5 : winding (loop^ (pos 2)) ≡ pos 2
  -- test-winding-pos5 = refl

  -- test-winding-neg5 : winding (loop^ (negsuc 2)) ≡ negsuc 2
  -- test-winding-neg5 = refl


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Bool.Properties where

open import Cubical.Core.Everything

open import Cubical.Functions.Involution

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence

open import Cubical.Data.Bool.Base
open import Cubical.Data.Empty

open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidableEq

notnot : ∀ x → not (not x) ≡ x
notnot true  = refl
notnot false = refl

notIsEquiv : isEquiv not
notIsEquiv = involIsEquiv {f = not} notnot

notEquiv : Bool ≃ Bool
notEquiv = involEquiv {f = not} notnot

notEq : Bool ≡ Bool
notEq = involPath {f = not} notnot

private
  variable
    ℓ : Level

  -- This computes to false as expected
  nfalse : Bool
  nfalse = transp (λ i → notEq i) i0 true

  -- Sanity check
  nfalsepath : nfalse ≡ false
  nfalsepath = refl

K-Bool
  : (P : {b : Bool} → b ≡ b → Type ℓ)
  → (∀{b} → P {b} refl)
  → ∀{b} → (q : b ≡ b) → P q
K-Bool P Pr {false} = J (λ{ false q → P q ; true _ → Lift ⊥ }) Pr
K-Bool P Pr {true}  = J (λ{ true q → P q ; false _ → Lift ⊥ }) Pr

isSetBool : isSet Bool
isSetBool a b = J (λ _ p → ∀ q → p ≡ q) (K-Bool (refl ≡_) refl)

true≢false : ¬ true ≡ false
true≢false p = subst (λ b → if b then Bool else ⊥) p true

false≢true : ¬ false ≡ true
false≢true p = subst (λ b → if b then ⊥ else Bool) p true

not≢const : ∀ x → ¬ not x ≡ x
not≢const false = true≢false
not≢const true  = false≢true

zeroˡ : ∀ x → true or x ≡ true
zeroˡ false = refl
zeroˡ true  = refl

zeroʳ : ∀ x → x or true ≡ true
zeroʳ false = refl
zeroʳ true  = refl

or-identityˡ : ∀ x → false or x ≡ x
or-identityˡ false = refl
or-identityˡ true  = refl

or-identityʳ : ∀ x → x or false ≡ x
or-identityʳ false = refl
or-identityʳ true  = refl

or-comm      : ∀ x y → x or y ≡ y or x
or-comm false y =
  false or y ≡⟨ or-identityˡ y ⟩
  y          ≡⟨ sym (or-identityʳ y) ⟩
  y or false ∎
or-comm true y =
  true or y ≡⟨ zeroˡ y ⟩
  true      ≡⟨ sym (zeroʳ y) ⟩
  y or true ∎

or-assoc     : ∀ x y z → x or (y or z) ≡ (x or y) or z
or-assoc false y z =
  false or (y or z)   ≡⟨ or-identityˡ _ ⟩
  y or z              ≡[ i ]⟨ or-identityˡ y (~ i) or z ⟩
  ((false or y) or z) ∎
or-assoc true y z  =
 true or (y or z)  ≡⟨ zeroˡ _ ⟩
  true             ≡⟨ sym (zeroˡ _) ⟩
  true or z        ≡[ i ]⟨ zeroˡ y (~ i) or z ⟩
  (true or y) or z ∎

or-idem      : ∀ x → x or x ≡ x
or-idem false = refl
or-idem true  = refl

⊕-identityʳ : ∀ x → x ⊕ false ≡ x
⊕-identityʳ false = refl
⊕-identityʳ true = refl

⊕-comm : ∀ x y → x ⊕ y ≡ y ⊕ x
⊕-comm false false = refl
⊕-comm false true  = refl
⊕-comm true  false = refl
⊕-comm true  true  = refl

⊕-assoc : ∀ x y z → x ⊕ (y ⊕ z) ≡ (x ⊕ y) ⊕ z
⊕-assoc false y z = refl
⊕-assoc true false z = refl
⊕-assoc true true z = notnot z

not-⊕ˡ : ∀ x y → not (x ⊕ y) ≡ not x ⊕ y
not-⊕ˡ false y = refl
not-⊕ˡ true  y = notnot y

⊕-invol : ∀ x y → x ⊕ (x ⊕ y) ≡ y
⊕-invol false x = refl
⊕-invol true  x = notnot x

isEquiv-⊕ : ∀ x → isEquiv (x ⊕_)
isEquiv-⊕ x = involIsEquiv (⊕-invol x)

⊕-Path : ∀ x → Bool ≡ Bool
⊕-Path x = involPath {f = x ⊕_} (⊕-invol x)

⊕-Path-refl : ⊕-Path false ≡ refl
⊕-Path-refl = isInjectiveTransport refl

¬transportNot : ∀(P : Bool ≡ Bool) b → ¬ (transport P (not b) ≡ transport P b)
¬transportNot P b eq = not≢const b sub
  where
  sub : not b ≡ b
  sub = subst {A = Bool → Bool} (λ f → f (not b) ≡ f b)
          (λ i c → transport⁻Transport P c i) (cong (transport⁻ P) eq)

module BoolReflection where
  data Table (A : Type₀) (P : Bool ≡ A) : Type₀ where
    inspect : (b c : A)
            → transport P false ≡ b
            → transport P true ≡ c
            → Table A P

  table : ∀ P → Table Bool P
  table = J Table (inspect false true refl refl)

  reflLemma : (P : Bool ≡ Bool)
         → transport P false ≡ false
         → transport P true ≡ true
         → transport P ≡ transport (⊕-Path false)
  reflLemma P ff tt i false = ff i
  reflLemma P ff tt i true = tt i

  notLemma : (P : Bool ≡ Bool)
         → transport P false ≡ true
         → transport P true ≡ false
         → transport P ≡ transport (⊕-Path true)
  notLemma P ft tf i false = ft i
  notLemma P ft tf i true  = tf i

  categorize : ∀ P → transport P ≡ transport (⊕-Path (transport P false))
  categorize P with table P
  categorize P | inspect false true p q
    = subst (λ b → transport P ≡ transport (⊕-Path b)) (sym p) (reflLemma P p q)
  categorize P | inspect true false p q
    = subst (λ b → transport P ≡ transport (⊕-Path b)) (sym p) (notLemma P p q)
  categorize P | inspect false false p q
    = rec (¬transportNot P false (q ∙ sym p))
  categorize P | inspect true true p q
    = rec (¬transportNot P false (q ∙ sym p))

  ⊕-complete : ∀ P → P ≡ ⊕-Path (transport P false)
  ⊕-complete P = isInjectiveTransport (categorize P)

  ⊕-comp : ∀ p q → ⊕-Path p ∙ ⊕-Path q ≡ ⊕-Path (q ⊕ p)
  ⊕-comp p q = isInjectiveTransport (λ i x → ⊕-assoc q p x i)

  open Iso

  reflectIso : Iso Bool (Bool ≡ Bool)
  reflectIso .fun = ⊕-Path
  reflectIso .inv P = transport P false
  reflectIso .leftInv = ⊕-identityʳ
  reflectIso .rightInv P = sym (⊕-complete P)

  reflectEquiv : Bool ≃ (Bool ≡ Bool)
  reflectEquiv = isoToEquiv reflectIso


module Test01 where

hoge : {A : Set} → A → A
hoge x = x

open import Relation.Binary.PropositionalEquality as PropEq using (_≡_; subst)
open import Function using (id)

lemma1 : {X Y : Set} → (X ≡ (X → Y)) → X
lemma1 p rewrite p = (λ x → let f = subst id p x in f x)

curry : {X Y : Set} → (X ≡ (X → Y)) → Y
curry p = (let f = subst id p (lemma1 p) in f (lemma1 p))

open import Data.Bool
open import Data.Nat
open import Data.Empty

postulate
  First : ℕ → Set
  All   : ℕ → Set
  fToA  : ((n : ℕ) → First n) → ((n : ℕ) → All n)
  fToA2 : (z : ℕ) → (First z → All z)
  tekito : (z : ℕ) → ((All z → ⊥) → (First z → ⊥)) → First (suc z)
  contra : (z : ℕ) → ((All z → ⊥) → (First z → ⊥)) → (First z → All z)

mutual
  -- 失敗
  contraFirstToAll : (z : ℕ) → ((All z → ⊥) → (First z → ⊥))
  -- contraFirstToAll z allToVoid _ = let foo = (contra z (contraFirstToAll z)) (limitedDivSeq z) in  allToVoid foo
  contraFirstToAll z allToVoid _ = let foo = fToA (λ k → limitedDivSeq k) in  allToVoid (foo z)

  limitedDivSeq : (n : ℕ) → First n
  limitedDivSeq zero    = {!   !}
  limitedDivSeq (suc n) = let bar = contraFirstToAll n in tekito n bar

-- Idris
{-
postulate foo : (t : Nat) -> LT' t (S t)
contraFirstToAll :
  (z : Nat) -> (((AllLimited . B.allDivSeq) z -> Void) -> ((FirstLimited . B.allDivSeq) z -> Void))
contraFirstToAll Z     allToVoid _ = allToVoid IsAllLimited00
contraFirstToAll (S z) _         _ = wfInd {P=(\z=>Void)} {rel=LT'} step (S z) where
  step : (x : Nat) -> ((y : Nat) -> LT' y x -> Void) -> Void
  step Z     _  = believe_me "ここには来ない"
  step (S x) rs = rs x (foo x)
-- ?rhs1 が書けない！！
contraFirstToAll :
  (z : Nat) -> (((AllLimited . B.allDivSeq) z -> Void) -> ((FirstLimited . B.allDivSeq) z -> Void))
contraFirstToAll Z     allToVoid _ = allToVoid IsAllLimited00
contraFirstToAll (S z) _         _ = step (S z) SIsNotZ (wellFounded {rel=LT'} (S z)) where
  step : (x : Nat) -> Not (x = Z) -> Accessible LT' x -> Void
  step Z     p _           = void (p Refl)
  step (S x) p (Access rs) = step x ?rhs1 (rs x (foo x))
-}


module AbsurdPatternRequiresNoRHS where

data   False : Set where
record True  : Set where

f : False -> True
f () = _


module UniDB.Morph.Pair where

open import UniDB.Spec

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

infixl 5 _⊗_
data Pair (Ξ Ζ : MOR) : MOR where
  _⊗_ : {γ₁ γ₂ γ₃ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₂ γ₃) →
    Pair Ξ Ζ γ₁ γ₃

instance
  iHCompPair : {Ξ Ζ : MOR} → HComp Ξ Ζ (Pair Ξ Ζ)
  _⊡_ {{iHCompPair}} = _⊗_

module _
  {Ξ : MOR} {{upΞ : Up Ξ}}
  {Ζ : MOR} {{upΖ : Up Ζ}}
  where

  instance
    iUpPair : Up (Pair Ξ Ζ)
    _↑₁ {{iUpPair}} (ξ ⊗ ζ) = ξ ↑₁ ⊗ ζ ↑₁
    _↑_ {{iUpPair}} (ξ ⊗ ζ) δ = (ξ ↑ δ) ⊗ (ζ ↑ δ)
    ↑-zero {{iUpPair}} (ξ ⊗ ζ) rewrite ↑-zero ξ | ↑-zero ζ = refl
    ↑-suc {{iUpPair}} (ξ ⊗ ζ) δ⁺ rewrite ↑-suc ξ δ⁺ | ↑-suc ζ δ⁺ = refl

    iUpHCompPair : UpHComp Ξ Ζ (Pair Ξ Ζ)
    ⊡-↑₁ {{iUpHCompPair}} ξ ζ = refl

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


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

open import Types
open import Functions
open import Paths
open import HLevel

module Equivalences where

hfiber : ∀ {i j} {A : Set i} {B : Set j} (f : A → B) (y : B) → Set (max i j)
hfiber {A = A} f y = Σ A (λ x → f x ≡ y)

is-equiv : ∀ {i j} {A : Set i} {B : Set j} (f : A → B) → Set (max i j)
is-equiv {B = B} f = (y : B) → is-contr (hfiber f y)

_~_ : ∀ {i j} {A : Set i} {B : Set j} (f g : A → B) → Set (max i j)
_~_ {A = A} f g = (x : A) → (f x ≡ g x)

is-iso : ∀ {i j} {A : Set i} {B : Set j} (f : A → B) → Set (max i j)
is-iso {A = A} {B = B} f = Σ (B → A) (λ g → ((f ◯ g) ~ id B) × ((g ◯ f) ~ id A))

is-hae : ∀ {i j} {A : Set i} {B : Set j} (f : A → B) → Set (max i j)
is-hae {A = A} {B = B} f =
  Σ (B → A)          (λ g →
  Σ ((g ◯ f) ~ id A) (λ η →
  Σ ((f ◯ g) ~ id B) (λ ε →
  (x : A) → ap f (η x) ≡ ε (f x))))

iso-is-hae : ∀ {i j} {A : Set i} {B : Set j} → (f : A → B) → is-iso f → is-hae f
iso-is-hae {A = A} {B = B} f (g , (ε , η)) = g , (η , (ε' , τ)) where
  ε' : (f ◯ g) ~ id B
  ε' b = ! (ε (f (g b))) ∘ ap f (η (g b)) ∘ ε b

  lem : (a : A) → η (g (f a)) ≡ ap (g ◯ f) (η a)
  lem a =
      η (g (f a))
    ≡⟨ ! (refl-right-unit (η (g (f a))) ) ⟩
      η (g (f a)) ∘ refl
    ≡⟨ ap (λ p → η (g (f a)) ∘ p) (! (opposite-right-inverse (η a))) ⟩
      η (g (f a)) ∘ (η a ∘ (! (η a)))
    ≡⟨ ! (concat-assoc (η (g (f a))) (η a) (! (η a))) ⟩
      (η (g (f a)) ∘ η a) ∘ (! (η a))
    ≡⟨ ap (λ p → p ∘ (! (η a)) ) (! (homotopy-naturality-toid (g ◯ f) η (η a))) ⟩
      (ap (g ◯ f) (η a) ∘ η a) ∘ (! (η a))
    ≡⟨ concat-assoc (ap (g ◯ f) (η a)) (η a) (! (η a)) ⟩
      ap (g ◯ f) (η a) ∘ (η a ∘ (! (η a)))
    ≡⟨ ap (λ p → ap (g ◯ f) (η a) ∘ p) (opposite-right-inverse (η a)) ⟩
      ap (g ◯ f) (η a) ∘ refl
    ≡⟨ refl-right-unit (ap (g ◯ f) (η a)) ⟩
      ap (g ◯ f) (η a)
    ∎

  lem₂ : (a : A) →  ε (f (g (f a))) ∘ ap f (η a) ≡ ap f (η (g (f a))) ∘ ε (f a)
  lem₂ a =
    ! (ap f (η (g (f a))) ∘ ε (f a)
    ≡⟨ ap (λ p → ap f p ∘ ε (f a)) (lem a) ⟩
      ap f (ap (g ◯ f) (η a)) ∘ ε (f a)
    ≡⟨ ap (λ p → p ∘ ε (f a)) (compose-ap f (g ◯ f) (η a)) ⟩
      ap (f ◯ (g ◯ f)) (η a) ∘ ε (f a)
    ≡⟨ homotopy-naturality (f ◯ (g ◯ f)) f (λ x → ε (f x)) (η a) ⟩
      ε (f (g (f a))) ∘ ap f (η a)
    ∎)

  τ : (a : A) → ap f (η a) ≡ ε' (f a)
  τ a =
      ap f (η a)
    ≡⟨ refl ⟩
      refl ∘ ap f (η a)
    ≡⟨ ap (λ p → p ∘ ap f (η a)) (! (opposite-left-inverse (ε (f (g (f a)))))) ⟩
      (! (ε (f (g (f a)))) ∘ (ε (f (g (f a))))) ∘ ap f (η a)
    ≡⟨ concat-assoc (! (ε (f (g (f a))))) (ε (f (g (f a)))) (ap f (η a)) ⟩
      ! (ε (f (g (f a)))) ∘ ((ε (f (g (f a)))) ∘ ap f (η a))
    ≡⟨ ap (λ p → ! (ε (f (g (f a)))) ∘ p) (lem₂ a) ⟩
       ! (ε (f (g (f a)))) ∘ (ap f (η (g (f a))) ∘ ε (f a))
    ∎

hae-is-eq : ∀ {i j} {A : Set i} {B : Set j} → (f : A → B) → is-hae f → is-equiv f
hae-is-eq f (g , (η , (ε , τ))) y = (g y , ε y) , contr where
  contr : (xp : hfiber f y) → xp ≡ g y , ε y
  contr (x , p) = total-Σ-eq ( ((! (η x)) ∘ ap g p) , t) where
    t : transport (λ z → f z ≡ y) (! (η x) ∘ ap g p) p ≡ ε y
    t =
        transport (λ z → f z ≡ y) (! (η x) ∘ ap g p) p
      ≡⟨ trans-app≡cst f y (! (η x) ∘ ap g p) p ⟩
        ! (ap f (! (η x) ∘ ap g p)) ∘ p
      ≡⟨ ap (λ q → q ∘ p) (opposite-ap f (! (η x) ∘ ap g p)) ⟩
        ap f (! (! (η x) ∘ ap g p)) ∘ p
      ≡⟨ ap (λ q → ap f q ∘ p) (opposite-concat (! (η x)) (ap g p)) ⟩
        ap f (! (ap g p) ∘ ! (! (η x))) ∘ p
      ≡⟨ ap (λ q → ap f (! (ap g p) ∘ q) ∘ p) (opposite-opposite (η x)) ⟩
        ap f (! (ap g p) ∘ η x) ∘ p
      ≡⟨ ap (λ q → q ∘ p) (ap-concat f (! (ap g p)) (η x)) ⟩
        (ap f (! (ap g p)) ∘ ap f (η x)) ∘ p
      ≡⟨ ap (λ q → (q ∘ ap f (η x)) ∘ p) (ap-opposite f (ap g p)) ⟩
        (! (ap f (ap g p)) ∘ ap f (η x)) ∘ p
      ≡⟨ ap (λ q → (! q ∘ ap f (η x)) ∘ p) (compose-ap f g p) ⟩
        (! (ap (f ◯ g) p) ∘ ap f (η x)) ∘ p
      ≡⟨ ap (λ q → ((! (ap (f ◯ g) p)) ∘ q) ∘ p ) (τ x) ⟩
        (! (ap (f ◯ g) p) ∘ ε (f x)) ∘ p
      ≡⟨ ap (λ q → (q ∘ ε (f x)) ∘ p) (opposite-ap (f ◯ g) p) ⟩
        (ap (f ◯ g) (! p) ∘ ε (f x)) ∘ p
      ≡⟨ ap (λ q → q ∘ p) (homotopy-naturality-toid (f ◯ g) ε (! p)) ⟩
        (ε y ∘ ! p) ∘ p
      ≡⟨ concat-assoc (ε y) (! p) p ⟩
        ε y ∘ ((! p) ∘ p)
      ≡⟨ ap (λ q → ε y ∘ q) (opposite-left-inverse p) ⟩
        ε y ∘ refl
      ≡⟨ refl-right-unit (ε y) ⟩
        ε y
      ∎

_≃_ : ∀ {i j} (A : Set i) (B : Set j) → Set (max i j)  -- \simeq
A ≃ B = Σ (A → B) is-equiv

id-is-equiv : ∀ {i} (A : Set i) → is-equiv (id A)
id-is-equiv A = pathto-is-contr

id-equiv : ∀ {i} (A : Set i) → A ≃ A
id-equiv A = (id A , id-is-equiv A)

path-to-eq : ∀ {i} {A B : Set i} → (A ≡ B → A ≃ B)
path-to-eq refl = id-equiv _

module _ {i} {j} {A : Set i} {B : Set j} where

  -- Notation for the application of an equivalence to an argument
  _☆_ : (f : A ≃ B) (x : A) → B
  f ☆ x = (π₁ f) x

  inverse : (f : A ≃ B) → B → A
  inverse (f , e) = λ y → π₁ (π₁ (e y))

  abstract
    inverse-right-inverse : (f : A ≃ B) (y : B) → f ☆ (inverse f y) ≡ y
    inverse-right-inverse (f , e) y = π₂ (π₁ (e y))

    inverse-left-inverse : (f : A ≃ B) (x : A) → inverse f (f ☆ x) ≡ x
    inverse-left-inverse (f , e) x =
      ! (base-path (π₂ (e (f x)) (x , refl)))

    hfiber-triangle : (f : A → B) (z : B) {x y : hfiber f z} (p : x ≡ y)
      → ap f (base-path p) ∘ π₂ y ≡ π₂ x
    hfiber-triangle f z {x} {.x} refl = refl

    inverse-triangle : (f : A ≃ B) (x : A) →
      inverse-right-inverse f (f ☆ x) ≡ ap (π₁ f) (inverse-left-inverse f x)
    inverse-triangle (f , e) x = move1!-left-on-left _ _
      (hfiber-triangle f _ (π₂ (e (f x)) (x , refl)))
       ∘ opposite-ap f _

  iso-is-eq' : (f : A → B) → is-iso f → is-equiv f
  iso-is-eq' f iso = hae-is-eq f (iso-is-hae f iso)

  iso-is-eq : (f : A → B) → (g : B → A) → (∀ y → f (g y) ≡ y) → (∀ x → g (f x) ≡ x) → is-equiv f
  iso-is-eq f g η ε = iso-is-eq' _ (g , (η , ε))

  inverse-iso-is-eq : (f : A → B) → (iso : is-iso f) → inverse (f , iso-is-eq' f iso) ≡ π₁ iso
  inverse-iso-is-eq f iso = refl

-- The inverse of an equivalence is an equivalence
inverse-is-equiv : ∀ {i} {j} {A : Set i} {B : Set j} (f : A ≃ B)
  → is-equiv (inverse f)
inverse-is-equiv f =
  iso-is-eq (inverse f) (π₁ f) (inverse-left-inverse f) (inverse-right-inverse f)

_⁻¹ : ∀ {i} {j} {A : Set i} {B : Set j} (f : A ≃ B) → B ≃ A  -- \^-\^1
_⁻¹ f = (inverse f , inverse-is-equiv f)

-- Equivalences are injective
equiv-is-inj : ∀ {i} {j} {A : Set i} {B : Set j} (f : A ≃ B) (x y : A)
  → (f ☆ x ≡ f ☆ y → x ≡ y)
equiv-is-inj f x y p = ! (inverse-left-inverse f x)
                       ∘ (ap (inverse f) p ∘ inverse-left-inverse f y)

-- Any contractible type is equivalent to the unit type
contr-equiv-unit : ∀ {i j} {A : Set i} → (is-contr A → A ≃ unit {j})
contr-equiv-unit e = ((λ _ → tt) , iso-is-eq _ (λ _ → π₁ e) (λ _ → refl) (λ x → ! (π₂ e x)))

-- The composite of two equivalences is an equivalence
compose-is-equiv : ∀ {i j k} {A : Set i} {B : Set j} {C : Set k}
  (f : A ≃ B) (g : B ≃ C) → is-equiv (π₁ g ◯ π₁ f)
compose-is-equiv f g =
  iso-is-eq _
    (inverse f ◯ inverse g)
    (λ y → ap (π₁ g) (inverse-right-inverse f (inverse g y)) ∘ inverse-right-inverse g y)
    (λ x → ap (inverse f) (inverse-left-inverse g (π₁ f x)) ∘ inverse-left-inverse f x)

equiv-compose : ∀ {i j k} {A : Set i} {B : Set j} {C : Set k}
  → (A ≃ B → B ≃ C → A ≃ C)
equiv-compose f g = ((π₁ g ◯ π₁ f) , compose-is-equiv f g)

-- An equivalence induces an equivalence on the path spaces
-- The proofs here can probably be simplified
module _ {i j} {A : Set i} {B : Set j} (f : A ≃ B) (x y : A) where

  private
    ap-is-inj : (p : f ☆ x ≡ f ☆ y) → x ≡ y
    ap-is-inj p = equiv-is-inj f x y p

    abstract
      left-inverse : (p : x ≡ y) → ap-is-inj (ap (π₁ f) p) ≡ p
      left-inverse p =
        move!-right-on-left (inverse-left-inverse f x) _ p
          (move-right-on-right (ap (inverse f) (ap (π₁ f) p)) _ _
           (compose-ap (inverse f) (π₁ f) p
           ∘ move!-left-on-right (ap (inverse f ◯ π₁ f) p)
               (inverse-left-inverse f x ∘ p)
               (inverse-left-inverse f y)
               (homotopy-naturality-toid (inverse f ◯ π₁ f)
                 (inverse-left-inverse f) p)))

      right-inverse : (p : f ☆ x ≡ f ☆ y) → ap (π₁ f) (ap-is-inj p) ≡ p
      right-inverse p =
        ap-concat (π₁ f) (! (inverse-left-inverse f x)) _
        ∘ (ap (λ u → u ∘ ap (π₁ f) (ap (inverse f) p
                  ∘ inverse-left-inverse f y))
               (ap-opposite (π₁ f) (inverse-left-inverse f x))
          ∘ move!-right-on-left (ap (π₁ f) (inverse-left-inverse f x)) _ p
            (ap-concat (π₁ f) (ap (inverse f) p) (inverse-left-inverse f y)
            ∘ (ap (λ u → u ∘ ap (π₁ f) (inverse-left-inverse f y))
                   (compose-ap (π₁ f) (inverse f) p)
            ∘ (whisker-left (ap (π₁ f ◯ inverse f) p)
                            (! (inverse-triangle f y))
            ∘ (homotopy-naturality-toid (π₁ f ◯ inverse f)
                                        (inverse-right-inverse f)
                                        p
            ∘ whisker-right p (inverse-triangle f x))))))

  equiv-ap : (x ≡ y) ≃ (f ☆ x ≡ f ☆ y)
  equiv-ap = (ap (π₁ f) , iso-is-eq _ ap-is-inj right-inverse left-inverse)

abstract
  total-Σ-eq-is-equiv : ∀ {i j} {A : Set i} {P : A → Set j} {x y : Σ A P}
    → is-equiv (total-Σ-eq {xu = x} {yv = y})
  total-Σ-eq-is-equiv {P = P} =
    iso-is-eq _
      (λ totp → base-path totp , fiber-path totp)
      Σ-eq-base-path-fiber-path
      (λ p → Σ-eq (base-path-Σ-eq (π₁ p) (π₂ p)) (fiber-path-Σ-eq {P = P} (π₁ p) (π₂ p)))

total-Σ-eq-equiv : ∀ {i j} {A : Set i} {P : A → Set j} {x y : Σ A P}
  → (Σ (π₁ x ≡ π₁ y) (λ p → transport P p (π₂ x) ≡ (π₂ y))) ≃ (x ≡ y)
total-Σ-eq-equiv = (total-Σ-eq , total-Σ-eq-is-equiv)


-- {-# OPTIONS -v term:20 #-}
-- Andreas, 2011-04-19 (Agda list post by Leonard Rodriguez)
module TerminationSubExpression where

infixr 3 _⇨_
data Type : Set where
 int   : Type
 _⇨_   : Type → Type → Type

test : Type → Type
test int = int
test (φ ⇨ int) = test φ
test (φ ⇨ (φ′ ⇨ φ″))  = test (φ′ ⇨ φ″)
-- this should terminate since rec. call on subterm

test' : Type → Type
test' int = int
test' (φ ⇨ int) = test' φ
test' (φ ⇨ φ′)  = test' φ′

ok : Type → Type
ok int = int
ok (φ ⇨ φ′) with φ′
... | int = ok φ
... | (φ″ ⇨ φ‴) = ok (φ″ ⇨ φ‴)


module UniDB.Subst where

open import UniDB.Subst.Core public
open import UniDB.Subst.Pair public
open import UniDB.Subst.Inst public


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Construction.Properties.Kleisli where

open import Level
import Relation.Binary.PropositionalEquality as ≡

open import Categories.Adjoint
open import Categories.Adjoint.Properties
open import Categories.Category
open import Categories.Functor using (Functor; _∘F_)
open import Categories.Functor.Equivalence
open import Categories.Monad
import Categories.Morphism.Reasoning as MR

open import Categories.Adjoint.Construction.Kleisli
open import Categories.Category.Construction.Kleisli

private
  variable
    o ℓ e : Level
    𝒞 𝒟 : Category o ℓ e

module _ {F : Functor 𝒞 𝒟} {G : Functor 𝒟 𝒞} (F⊣G : Adjoint F G) where
  private
    T : Monad 𝒞
    T = adjoint⇒monad F⊣G

    𝒞ₜ : Category _ _ _
    𝒞ₜ = Kleisli T

    module 𝒞 = Category 𝒞
    module 𝒟 = Category 𝒟
    module 𝒞ₜ = Category 𝒞ₜ

    module T = Monad T
    module F = Functor F
    module G = Functor G

    open Adjoint F⊣G

  -- Maclane's Comparison Functor
  ComparisonF : Functor 𝒞ₜ 𝒟
  ComparisonF = record
    { F₀ = λ X → F.F₀ X
    ; F₁ = λ {A} {B} f → 𝒟 [ counit.η (F.F₀ B) ∘ F.F₁ f ]
    ; identity = zig
    ; homomorphism = λ {X} {Y} {Z} {f} {g} → begin
      𝒟 [ counit.η (F.F₀ Z) ∘ F.F₁ (𝒞 [ 𝒞 [ G.F₁ (counit.η (F.F₀ Z)) ∘ G.F₁ (F.F₁ g)] ∘ f ])]                 ≈⟨ refl⟩∘⟨ F.homomorphism ⟩
      𝒟 [ counit.η (F.F₀ Z) ∘ 𝒟 [ F.F₁ (𝒞 [ G.F₁ (counit.η (F.F₀ Z)) ∘ G.F₁ (F.F₁ g) ]) ∘ F.F₁ f ] ]          ≈⟨ refl⟩∘⟨ F.homomorphism  ⟩∘⟨refl ⟩
      𝒟 [ counit.η (F.F₀ Z) ∘ 𝒟 [ 𝒟 [ F.F₁ (G.F₁ (counit.η (F.F₀ Z))) ∘ F.F₁ (G.F₁ (F.F₁ g)) ] ∘ F.F₁ f ] ]   ≈⟨ center⁻¹ refl refl ⟩
      𝒟 [ 𝒟 [ counit.η (F.F₀ Z) ∘ F.F₁ (G.F₁ (counit.η (F.F₀ Z))) ] ∘ 𝒟 [ F.F₁ (G.F₁ (F.F₁ g)) ∘ F.F₁ f ] ]   ≈⟨ counit.commute (counit.η (F.F₀ Z)) ⟩∘⟨refl ⟩
      𝒟 [ 𝒟 [ counit.η (F.F₀ Z) ∘ (counit.η (F.F₀ (G.F₀ (F.F₀ Z)))) ] ∘ 𝒟 [ F.F₁ (G.F₁ (F.F₁ g)) ∘ F.F₁ f ] ] ≈⟨ extend² (counit.commute (F.F₁ g))  ⟩
      𝒟 [ 𝒟 [ counit.η (F.F₀ Z) ∘ F.F₁ g ] ∘ 𝒟 [ counit.η (F.F₀ Y) ∘ F.F₁ f ] ]                               ∎
    ; F-resp-≈ = λ eq → 𝒟.∘-resp-≈ʳ (F.F-resp-≈ eq)
    }
    where
      open 𝒟.HomReasoning
      open MR 𝒟

  private
    L = ComparisonF
    module L = Functor L
    module Gₜ = Functor (Forgetful T)
    module Fₜ = Functor (Free T)

  G∘L≡Forgetful : (G ∘F L) ≡F Forgetful T
  G∘L≡Forgetful = record
    { eq₀ = λ X → ≡.refl
    ; eq₁ = λ {A} {B} f → begin
      𝒞 [ 𝒞.id ∘ G.F₁ (𝒟 [ counit.η (F.F₀ B) ∘ F.F₁ f ]) ]        ≈⟨ 𝒞.identityˡ ⟩
      G.F₁ (𝒟 [ counit.η (F.F₀ B) ∘ F.F₁ f ])                      ≈⟨ G.homomorphism ⟩
      𝒞 [ G.F₁ (counit.η (F.F₀ B)) ∘ G.F₁ (F.F₁ f) ]               ≈˘⟨ 𝒞.identityʳ ⟩
      𝒞 [ 𝒞 [ G.F₁ (counit.η (F.F₀ B)) ∘ G.F₁ (F.F₁ f) ] ∘ 𝒞.id ] ∎

    }
    where
      open 𝒞.HomReasoning

  L∘Free≡F : (L ∘F Free T) ≡F F
  L∘Free≡F = record
    { eq₀ = λ X → ≡.refl
    ; eq₁ = λ {A} {B} f → begin
      𝒟 [ 𝒟.id ∘ 𝒟 [ counit.η (F.F₀ B) ∘ F.F₁ (𝒞 [ unit.η B ∘ f ]) ] ] ≈⟨ 𝒟.identityˡ ⟩
      𝒟 [ counit.η (F.F₀ B) ∘ F.F₁ (𝒞 [ unit.η B ∘ f ]) ]               ≈⟨ pushʳ F.homomorphism ⟩
      𝒟 [ 𝒟 [ counit.η (F.F₀ B) ∘ F.F₁ (unit.η B) ] ∘ F.F₁ f ]          ≈⟨ elimˡ zig ⟩
      F.F₁ f                                                              ≈˘⟨ 𝒟.identityʳ ⟩
      𝒟 [ F.F₁ f ∘ 𝒟.id ]                                               ∎
    }
    where
      open 𝒟.HomReasoning
      open MR 𝒟


module Properties.Remember where

open import Agda.Builtin.Equality using (_≡_; refl)

data Remember {A : Set} (a : A) : Set where
  _,_ : ∀ b → (a ≡ b) → Remember(a)

remember : ∀ {A} (a : A) → Remember(a)
remember a = (a , refl)


-- {-# OPTIONS -v tc.size.solve:60 #-}

module Issue300 where

open import Common.Size

data Nat : Size → Set where
  zero : (i : Size) → Nat (↑ i)
  suc  : (i : Size) → Nat i → Nat (↑ i)

-- Size meta used in a different context than the one created in

A : Set₁
A = (Id : (i : Size) → Nat _ → Set)
    (k : Size) (m : Nat (↑ k)) (p : Id k m) →
    (j : Size) (n : Nat j    ) → Id j n
-- should solve _ with ↑ i

-- 1) Id,k,m |- ↑ 1 ≤ X 1      ==> ↑ 4 ≤ X 4
-- 2) Id,k,m,p,j,n |- 1 ≤ X 1

-- Unfixed by fix for #1914 (Andreas, 2016-04-08).


------------------------------------------------------------------------
-- The Agda standard library
--
-- Decidable vector equality over propositional equality
------------------------------------------------------------------------

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

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

module Data.Vec.Relation.Binary.Equality.DecPropositional
  {a} {A : Set a} (_≟_ : Decidable {A = A} _≡_) where

import Data.Vec.Relation.Binary.Equality.Propositional as PEq
import Data.Vec.Relation.Binary.Equality.DecSetoid as DSEq

------------------------------------------------------------------------
-- Publicly re-export everything from decSetoid and propositional
-- equality

open PEq public
open DSEq (decSetoid _≟_) public
  using (_≋?_; ≋-isDecEquivalence; ≋-decSetoid)


module Builtin.Size where

open import Agda.Builtin.Size public


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

module Relation.Binary.Equivalence.PropHIT where

open import Prelude
open import Relation.Nullary.Stable
open import HITs.PropositionalTruncation
open import HITs.PropositionalTruncation.Sugar
open import Relation.Binary

infix 4 _≐_
_≐_ : A → A → Type _
x ≐ y = ∥ x ≡ y ∥

import Relation.Binary.Equivalence.Reasoning

module _ {A : Type a} where
  prop-equiv : Equivalence A _
  prop-equiv .Equivalence._≋_ = _≐_
  prop-equiv .Equivalence.sym = sym ∥$∥_
  prop-equiv .Equivalence.refl = ∣ refl ∣
  prop-equiv .Equivalence.trans x≐y y≐z = ⦇ x≐y ; y≐z ⦈

  module Reasoning = Relation.Binary.Equivalence.Reasoning prop-equiv

-- data ∙⊥ : Prop where

-- private
--   variable
--     x y z : A

-- rerel : ∙⊥ → ⊥
-- rerel ()

-- ∙refute : x ≐ y → (x ≡ y → ⊥) → ∙⊥
-- ∙refute ∣ x≡y ∣ x≢y with x≢y x≡y
-- ∙refute ∣ x≡y ∣ x≢y | ()

-- refute : x ≐ y → ¬ (¬ (x ≡ y))
-- refute x≐y x≢y = rerel (∙refute x≐y x≢y)

-- unsquash : Stable (x ≡ y) → x ≐ y → x ≡ y
-- unsquash st x≐y = st (refute x≐y)

-- ∙refl : x ≐ x
-- ∙refl = ∣ refl ∣

-- ∙trans : x ≐ y → y ≐ z → x ≐ z
-- ∙trans ∣ xy ∣ (∣_∣ yz) = ∣_∣ (xy ; yz)

-- ∙sym : x ≐ y → y ≐ x
-- ∙sym (∣_∣ p) = ∣_∣ (sym p)

-- ∙cong : (f : A → B) → x ≐ y → f x ≐ f y
-- ∙cong f ∣ x≡y ∣ = ∣ cong f x≡y ∣

-- module Reasoning where
--   infixr 2 ≐˘⟨⟩-syntax ≐⟨∙⟩-syntax

--   ≐˘⟨⟩-syntax : ∀ (x : A) {y z} → y ≐ z → y ≐ x → x ≐ z
--   ≐˘⟨⟩-syntax _ y≡z y≡x = ∙trans (∙sym y≡x) y≡z

--   syntax ≐˘⟨⟩-syntax x y≡z y≡x = x ≐˘⟨ y≡x ⟩ y≡z

--   ≐⟨∙⟩-syntax : ∀ (x : A) {y z} → y ≐ z → x ≐ y → x ≐ z
--   ≐⟨∙⟩-syntax _ y≡z x≡y = ∙trans x≡y y≡z

--   syntax ≐⟨∙⟩-syntax x y≡z x≡y = x ≐⟨ x≡y ⟩ y≡z

--   _≐⟨⟩_ : ∀ (x : A) {y} → x ≐ y → x ≐ y
--   _ ≐⟨⟩ x≡y = x≡y

--   infix 2.5 _∎
--   _∎ : ∀ {A : Type a} (x : A) → x ≐ x
--   _∎ x = ∙refl

--   infixr 2 ≡˘⟨⟩-syntax ≡⟨∙⟩-syntax

--   ≡˘⟨⟩-syntax : ∀ (x : A) {y z} → y ≐ z → y ≡ x → x ≐ z
--   ≡˘⟨⟩-syntax _ y≡z y≡x = ∙trans (∣_∣ (sym y≡x)) y≡z

--   syntax ≡˘⟨⟩-syntax x y≡z y≡x = x ≡˘⟨ y≡x ⟩ y≡z

--   ≡⟨∙⟩-syntax : ∀ (x : A) {y z} → y ≐ z → x ≡ y → x ≐ z
--   ≡⟨∙⟩-syntax _ y≡z x≡y = ∙trans ∣ x≡y ∣ y≡z

--   syntax ≡⟨∙⟩-syntax x y≡z x≡y = x ≡⟨ x≡y ⟩ y≡z


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

module Cardinality.Finite.ManifestEnumerable.Inductive where

open import Prelude
open import Data.List public
open import Data.List.Membership public

ℰ : Type a → Type a
ℰ A = Σ[ xs ⦂ List A ] Π[ x ⦂ A ] ∥ x ∈ xs ∥


------------------------------------------------------------------------
-- Big-step semantics for the untyped λ-calculus
------------------------------------------------------------------------

module Lambda.Substitution.OneSemantics where

open import Codata.Musical.Notation
open import Data.Fin
open import Function
open import Data.Nat

open import Lambda.Syntax
open WHNF
open import Lambda.Substitution

-- Semantic domain. ⊥ represents non-termination.

data Sem (n : ℕ) : Set where
  ⊥   : Sem n
  val : (v : Value n) → Sem n

-- Big-step semantics.

mutual

  infix 4 _⇒_ _⇒?_

  data _⇒_ {n} : Tm n → Sem n → Set where
    val : ∀ {v} → ⌜ v ⌝ ⇒ val v
    app : ∀ {t₁ t₂ t v s}
          (t₁⇓   : t₁ ⇒? val (ƛ t))
          (t₂⇓   : t₂ ⇒? val v)
          (t₁t₂⇒ : t / sub ⌜ v ⌝ ⇒? s) →
          t₁ · t₂ ⇒ s
    ·ˡ  : ∀ {t₁ t₂}
          (t₁⇑ : t₁ ⇒? ⊥) →
          t₁ · t₂ ⇒ ⊥
    ·ʳ  : ∀ {t₁ t₂ v}
          (t₁⇓ : t₁ ⇒? val v)
          (t₂⇑ : t₂ ⇒? ⊥) →
          t₁ · t₂ ⇒ ⊥

  -- Conditional coinduction: coinduction only for diverging
  -- computations.

  _⇒?_ : ∀ {n} → Tm n → Sem n → Set
  t ⇒? ⊥     = ∞ (t ⇒ ⊥)
  t ⇒? val v = t ⇒ val v

-- Example.

Ω-loops : Ω ⇒ ⊥
Ω-loops = app val val (♯ Ω-loops)


open import Mockingbird.Forest using (Forest)

module Mockingbird.Forest.Combination.Vec.Base {b ℓ} (forest : Forest {b} {ℓ}) where

open import Data.Fin using (Fin; zero; suc; #_)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Nat.Properties using (_≤?_)
open import Data.Vec as Vec using (Vec; _∷_)
open import Data.Vec.Relation.Unary.Any using (here; there) public
open import Level using (_⊔_)
open import Relation.Nullary.Decidable.Core using (True)
open import Relation.Unary using (Pred; _∈_)

open Forest forest

import Mockingbird.Forest.Combination.Base forest as Base
import Mockingbird.Forest.Combination.Properties forest as Combinationₚ
open import Mockingbird.Forest.Combination.Base forest using ([_]; _⟨∙⟩_∣_; _⟨∙⟩_) public
open import Data.Vec.Membership.Setoid setoid using () renaming (_∈_ to _∈′_)

⟨_⟩ : ∀ {n} → Vec Bird n → Pred Bird (b ⊔ ℓ)
⟨ bs ⟩ = Base.⟨ _∈′ bs ⟩

[_]′ : ∀ {n} {bs : Vec Bird n} (i : Fin n) → Vec.lookup bs i ∈ ⟨ bs ⟩
[_]′ {suc n} {x ∷ bs} zero = [ here refl ]
[_]′ {suc n} {x ∷ bs} (suc i) = Combinationₚ.⟨ _ ⟩⊆⟨ _ ⟩ there [ i ]′

[#_] : ∀ m {n} {m<n : True (suc m ≤? n)} {bs : Vec Bird n}
  → Vec.lookup bs (#_ m {m<n = m<n}) ∈ ⟨ bs ⟩
[# m ] = [ # m ]′


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

module K-FOTC where

postulate D : Set

data _≡_ (x : D) : D → Set where
  refl : x ≡ x

K : (x : D)(P : x ≡ x → Set) → P refl → (p : x ≡ x) → P p
K x P pr refl = pr


{-# OPTIONS --cubical #-}

open import Agda.Primitive.Cubical
open import Agda.Builtin.Cubical.Path

data Interval : Set where
  left right : Interval
  path : left ≡ right

swap : Interval → Interval
swap left = right
swap right = left
swap (path i) = {!!}


module Web.Semantic.DL.Category.Properties where

open import Web.Semantic.DL.Category.Properties.Equivalence public using
  ( ≣-refl ; ≣-sym ; ≣-trans )

open import Web.Semantic.DL.Category.Properties.Composition public using
  ( compose-resp-≣ ; compose-unit₁ ; compose-unit₂ ; compose-assoc )

open import Web.Semantic.DL.Category.Properties.Tensor public using
  ( tensor-resp-≣ ; tensor-resp-id ; tensor-resp-compose
  ; symm-iso ; assoc-iso ; assoc⁻¹-iso
  ; unit₁-iso ; unit₁⁻¹-iso ; unit₂-iso ; unit₂⁻¹-iso
  ; assoc-unit ; assoc-assoc ; assoc-symm
  ; unit₁-natural ; unit₂-natural ; symm-natural ; assoc-natural )


open import Kaleid as K using ()
open import Extract (K.kompile-funp) using (kompile)
open import ReflHelper

open import Data.Nat
open import Data.Nat.Properties
open import Data.List as L using (List; []; _∷_)

open import Data.Fin using (Fin; zero; suc; fromℕ<)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

open import Reflection hiding (_≟_; _>>=_; return)

open import Structures
open import Function

test1-f : ℕ → ℕ
test1-f x = 1 + x

test₁ : kompile test1-f [] [] ≡ ok _
test₁ = refl

test2-f : ℕ → ℕ → ℕ
test2-f (suc x) (suc y) = suc $ test2-f x y
test2-f _ _ = 0

test₂ : kompile test2-f [] [] ≡ ok _
test₂ = refl

test3-f : (a b : ℕ) → a ≡ b → ℕ
test3-f a b _ = a ∸ b

test₃ : kompile test3-f [] [] ≡ ok _
test₃ = refl

test4-f : (x : ℕ) → x ≡ 0 → (y : ℕ) → x ≡ y → ℕ
test4-f x () (suc y) refl
test4-f x x=0 zero x=y = 0

test₄ : kompile test4-f [] [] ≡ ok _
test₄ = refl

-- _>_ is not (yet) supported, so no test₅ for now.
test5-f : (x y : ℕ) → x > y → ℕ
test5-f 0 0 ()
test5-f 0 x _ = x
test5-f (suc x) y _ = x + y

test6-f : (x y : ℕ) → ℕ
test6-f x y with x ≟ y
... | yes pf = 1
... | _ = 2

test₆ = kompile test6-f (quote _≟_ ∷ []) []

test7-f : (n : ℕ) → Fin (suc (n * n))
test7-f n = fromℕ< ≤-refl

test8-f : ℕ → ℕ
test8-f x = let a = x * x + 3 * x + 5 in a + a

test-args : (a b c d : ℕ) → ℕ
test-args a b c d = a + b + c + d

test-args2 : (a b : ℕ) → ℕ
test-args2 a b = test-args a b a b


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

open import Level

open import Categories.Category
open import Categories.Agda
open import Categories.Functor using (Functor)
open import Categories.Functor.Hom
open import Categories.NaturalIsomorphism

record Representable {o ℓ e} (C : Category o ℓ e) : Set (o ⊔ suc ℓ ⊔ suc e) where
  open Category C
  open Hom C
  field
    F : Functor C (ISetoids ℓ e) -- should this be a parameter to the record?
    A : Obj
    Iso : NaturalIsomorphism F Hom[ A ,-]