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

{-
  Ribbon is an explicit covering space construction.

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

open import HoTT

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

  -- The HIT ribbon---reconstructed covering space

  private
    π1 = fundamental-group

  private
    module _ (A∙ : Ptd i) {j} (gs : Gset (π1 A∙) j) where
      private
        A = fst A∙
        a = snd A∙
        El = Gset.El gs
        El-level = Gset.El-level gs
        _⊙_ = Gset.act gs

      {-
        What the following data type definition should be
        when we have a proof assistant for HoTT:

        data Ribbon (a₂ : A) : Set where
          trace : El → a =₀ a₂ → Ribbon a₂
          paste : ∀ el loop (p : a =₀ a₂)
                → trace (el ⊙ loop) p == trace el (loop ∙₀ p)
      -}

      data #Ribbon-aux (a₂ : A) : Type (lmax i j) where
        #trace : El → a =₀ a₂ → #Ribbon-aux a₂

      data #Ribbon (a₂ : A) : Type (lmax i j) where
        #ribbon : #Ribbon-aux a₂ → (Unit → Unit) → #Ribbon a₂

  Ribbon : ∀ (A∙ : Ptd i) {j} (gs : Gset (π1 A∙) j)
    → fst A∙ → Type (lmax i j)
  Ribbon = #Ribbon

  module _ {A∙ : Ptd i} {j} {gs : Gset (fundamental-group A∙) j} {a₂ : fst A∙} where
    private
      A = fst A∙
      a = snd A∙
      El = Gset.El gs
      El-level = Gset.El-level gs
      _⊙_ = Gset.act gs

    -- A point in the fiber [a₂].
    {-
      [e] is a point in the [fiber a], and
      [p] is a path to transport [y] to fiber [a₂].
    -}
    trace : El → a =₀ a₂ → Ribbon A∙ gs a₂
    trace el p = #ribbon (#trace el p) _

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

    {-
      Make each fiber a set and cancel all higher structures
      due to [paste].
    -}
    postulate -- HIT
      Ribbon-is-set : is-set (Ribbon A∙ gs a₂)

    Ribbon-level = Ribbon-is-set

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

      f : Π (Ribbon A∙ gs a₂) P
      f = f-aux phantom phantom where

        f-aux : Phantom trace* → Phantom paste* → Π (Ribbon A∙ gs a₂) P
        f-aux phantom phantom (#ribbon (#trace el p) _) = trace* el p

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

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

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

      f : Ribbon A∙ gs a₂ → P
      f = M.f

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

  -- This data structure gives a cover.
  Ribbon-cover : ∀ (A∙ : Ptd i) {j} (gs : Gset (π1 A∙) j)
    → Cover (fst A∙) (lmax i j)
  Ribbon-cover A∙ gs = record
    { Fiber = Ribbon A∙ gs
    ; Fiber-level = λ a → Ribbon-level
    }

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


{-

Definition of the Klein bottle as a HIT

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.KleinBottle.Base where

open import Cubical.Core.Everything

data KleinBottle : Type where
  point : KleinBottle
  line1 : point ≡ point
  line2 : point ≡ point
  square : PathP (λ i → line1 (~ i) ≡ line1 i) line2 line2


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

module container.m where

open import container.m.coalgebra public
open import container.m.from-nat public
-- open import container.m.core public
-- open import container.m.extensionality public
-- open import container.m.level public


------------------------------------------------------------------------------
-- Non-intuitionistic logic theorems
------------------------------------------------------------------------------

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

module FOL.NonIntuitionistic.TheoremsATP where

open import FOL.Base hiding ( pem )

------------------------------------------------------------------------------
-- The principle of the excluded middle.
postulate pem : ∀ {A} → A ∨ ¬ A
{-# ATP prove pem #-}

-- The principle of indirect proof (proof by contradiction).
postulate ¬-elim : ∀ {A} → (¬ A → ⊥) → A
{-# ATP prove ¬-elim #-}

-- Double negation elimination.
postulate ¬¬-elim : ∀ {A} → ¬ ¬ A → A
{-# ATP prove ¬¬-elim #-}

-- The reductio ab absurdum rule. (Some authors uses this name for the
-- principle of indirect proof).
postulate raa : ∀ {A} → (¬ A → A) → A
{-# ATP prove raa #-}

-- ∃ in terms of ∀ and ¬.
postulate ¬∃¬→∀ : {A : D → Set} → ¬ (∃[ x ] ¬ A x) → ∀ {x} → A x
{-# ATP prove ¬∃¬→∀ #-}


{-# OPTIONS --cubical #-}
module Exercises where

open import Part2
open import Part3
open import Part4
open import Part5


------------------------------------------------------------------------
-- The Agda standard library
--
-- Sum combinators for propositional equality preserving functions
------------------------------------------------------------------------

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

module Data.Sum.Function.Propositional where

open import Data.Sum
open import Data.Sum.Function.Setoid
open import Data.Sum.Relation.Binary.Pointwise using (Pointwise-≡↔≡)
open import Function.Equivalence as Eq using (_⇔_; module Equivalence)
open import Function.Injection as Inj using (_↣_; module Injection)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Function.LeftInverse as LeftInv
  using (_↞_; _LeftInverseOf_; module LeftInverse)
open import Function.Related
open import Function.Surjection as Surj using (_↠_; module Surjection)

------------------------------------------------------------------------
-- Combinators for various function types

module _ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} where

  _⊎-⇔_ : A ⇔ B → C ⇔ D → (A ⊎ C) ⇔ (B ⊎ D)
  _⊎-⇔_ A⇔B C⇔D =
    Inverse.equivalence (Pointwise-≡↔≡ B D) ⟨∘⟩
    (A⇔B ⊎-equivalence C⇔D) ⟨∘⟩
    Eq.sym (Inverse.equivalence (Pointwise-≡↔≡ A C))
    where open Eq using () renaming (_∘_ to _⟨∘⟩_)

  _⊎-↣_ : A ↣ B → C ↣ D → (A ⊎ C) ↣ (B ⊎ D)
  _⊎-↣_ A↣B C↣D =
    Inverse.injection (Pointwise-≡↔≡ B D) ⟨∘⟩
    (A↣B ⊎-injection C↣D) ⟨∘⟩
    Inverse.injection (Inv.sym (Pointwise-≡↔≡ A C))
    where open Inj using () renaming (_∘_ to _⟨∘⟩_)

  _⊎-↞_ : A ↞ B → C ↞ D → (A ⊎ C) ↞ (B ⊎ D)
  _⊎-↞_ A↞B C↞D =
    Inverse.left-inverse (Pointwise-≡↔≡ B D) ⟨∘⟩
    (A↞B ⊎-left-inverse C↞D) ⟨∘⟩
    Inverse.left-inverse (Inv.sym (Pointwise-≡↔≡ A C))
    where open LeftInv using () renaming (_∘_ to _⟨∘⟩_)

  _⊎-↠_ : A ↠ B → C ↠ D → (A ⊎ C) ↠ (B ⊎ D)
  _⊎-↠_ A↠B C↠D =
    Inverse.surjection (Pointwise-≡↔≡ B D) ⟨∘⟩
    (A↠B ⊎-surjection C↠D) ⟨∘⟩
    Inverse.surjection (Inv.sym (Pointwise-≡↔≡ A C))
    where open Surj using () renaming (_∘_ to _⟨∘⟩_)

  _⊎-↔_ : A ↔ B → C ↔ D → (A ⊎ C) ↔ (B ⊎ D)
  _⊎-↔_ A↔B C↔D =
    Pointwise-≡↔≡ B D ⟨∘⟩
    (A↔B ⊎-inverse C↔D) ⟨∘⟩
    Inv.sym (Pointwise-≡↔≡ A C)
    where open Inv using () renaming (_∘_ to _⟨∘⟩_)

module _ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} where

  _⊎-cong_ : ∀ {k} → A ∼[ k ] B → C ∼[ k ] D → (A ⊎ C) ∼[ k ] (B ⊎ D)
  _⊎-cong_ {implication}         = map
  _⊎-cong_ {reverse-implication} = λ f g → lam (map (app-← f) (app-← g))
  _⊎-cong_ {equivalence}         = _⊎-⇔_
  _⊎-cong_ {injection}           = _⊎-↣_
  _⊎-cong_ {reverse-injection}   = λ f g → lam (app-↢ f ⊎-↣ app-↢ g)
  _⊎-cong_ {left-inverse}        = _⊎-↞_
  _⊎-cong_ {surjection}          = _⊎-↠_
  _⊎-cong_ {bijection}           = _⊎-↔_


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

module Cubical.Categories.Limits.Pullback where

open import Cubical.Foundations.Prelude
open import Cubical.Categories.Limits.Base
open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Data.Sigma
open import Cubical.Categories.Instances.Cospan public

private
  variable
    ℓ ℓ' : Level

module _ {C : Precategory ℓ ℓ'} where

  open Precategory C
  open Functor

  record Cospan : Type (ℓ-max ℓ ℓ') where
    constructor cospan
    field
      l m r : ob
      s₁ : C [ l , m ]
      s₂ : C [ r , m ]

  record PullbackLegs (cspn : Cospan) (c : ob) : Type (ℓ-max ℓ ℓ') where
    constructor pblegs
    open Cospan cspn
    field
      p₁ : C [ c , l ]
      p₂ : C [ c , r ]

  record PullbackCone (cspn : Cospan) (c : ob) : Type (ℓ-max ℓ ℓ') where
    constructor cone
    open Cospan cspn
    field
      pl : PullbackLegs cspn c
    open PullbackLegs pl public
    field
      sq : p₁ ⋆⟨ C ⟩ s₁ ≡ p₂ ⋆⟨ C ⟩ s₂

  record isPullback (cspn : _) {c} (pb : PullbackLegs cspn c) : Type (ℓ-max ℓ ℓ') where
    open Cospan cspn
    open PullbackLegs
    field
      sq : pb .p₁ ⋆⟨ C ⟩ s₁ ≡ pb .p₂ ⋆⟨ C ⟩ s₂

    open PullbackCone
    field
      up : ∀ {d}
         → (pb' : PullbackCone cspn d)
         → isContr (Σ[ f ∈ (C [ d , c ]) ] ((pb' .p₁ ≡ f ⋆⟨ C ⟩ pb .p₁)
              × (pb' .p₂ ≡ f ⋆⟨ C ⟩ pb .p₂)))

  Cospan→Func : Cospan → Functor CospanCat C
  Cospan→Func (cospan l m r f g) .F-ob ⓪ = l
  Cospan→Func (cospan l m r f g) .F-ob ① = m
  Cospan→Func (cospan l m r f g) .F-ob ② = r
  Cospan→Func (cospan l m r f g) .F-hom {⓪} {①} k = f
  Cospan→Func (cospan l m r f g) .F-hom {②} {①} k = g
  Cospan→Func (cospan l m r f g) .F-hom {⓪} {⓪} k = id l
  Cospan→Func (cospan l m r f g) .F-hom {①} {①} k = id m
  Cospan→Func (cospan l m r f g) .F-hom {②} {②} k = id r
  Cospan→Func (cospan l m r f g) .F-id {⓪} = refl
  Cospan→Func (cospan l m r f g) .F-id {①} = refl
  Cospan→Func (cospan l m r f g) .F-id {②} = refl
  Cospan→Func (cospan l m r f g) .F-seq {⓪} {⓪} {⓪} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {⓪} {⓪} {①} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {⓪} {①} {①} φ ψ = sym (⋆IdR _)
  Cospan→Func (cospan l m r f g) .F-seq {①} {①} {①} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {②} {②} {②} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {②} {②} {①} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {②} {①} {①} φ ψ = sym (⋆IdR _)

  -- TODO: show that this definition of Pullback is equivalent to the Cospan limit


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of disjoint lists (setoid equality)
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Disjoint.Setoid.Properties where

open import Data.List.Base
open import Data.List.Relation.Binary.Disjoint.Setoid
import Data.List.Relation.Unary.Any as Any
open import Data.List.Relation.Unary.All as All
open import Data.List.Relation.Unary.All.Properties using (¬Any⇒All¬)
open import Data.List.Relation.Unary.Any.Properties using (++⁻)
open import Data.Product using (_,_)
open import Data.Sum.Base using (inj₁; inj₂)
open import Relation.Binary
open import Relation.Nullary using (¬_)

------------------------------------------------------------------------
-- Relational properties
------------------------------------------------------------------------

module _ {c ℓ} (S : Setoid c ℓ) where

  sym : Symmetric (Disjoint S)
  sym xs#ys (v∈ys , v∈xs) = xs#ys (v∈xs , v∈ys)

------------------------------------------------------------------------
-- Relationship with other predicates
------------------------------------------------------------------------

module _ {c ℓ} (S : Setoid c ℓ) where

  open Setoid S

  Disjoint⇒AllAll : ∀ {xs ys} → Disjoint S xs ys →
                    All (λ x → All (λ y → ¬ x ≈ y) ys) xs
  Disjoint⇒AllAll xs#ys = All.map (¬Any⇒All¬ _)
    (All.tabulate (λ v∈xs v∈ys → xs#ys (Any.map reflexive v∈xs , v∈ys)))

------------------------------------------------------------------------
-- Introduction (⁺) and elimination (⁻) rules for list operations
------------------------------------------------------------------------
-- concat

module _ {c ℓ} (S : Setoid c ℓ) where

  concat⁺ʳ : ∀ {vs xss} → All (Disjoint S vs) xss → Disjoint S vs (concat xss)
  concat⁺ʳ {xss = xs ∷ xss} (vs#xs ∷ vs#xss) (v∈vs , v∈xs++concatxss)
    with ++⁻ xs v∈xs++concatxss
  ... | inj₁ v∈xs  = vs#xs (v∈vs , v∈xs)
  ... | inj₂ v∈xss = concat⁺ʳ vs#xss (v∈vs , v∈xss)


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

-- This implementation is designed for reasoning about dynamic
-- vectors which may increase or decrease in size.

-- See `Data.Vec.Functional` for an alternative implementation as
-- functions from finite sets, which is more suitable for reasoning
-- about fixed sized vectors and for when ease of retrevial is
-- important.

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

module Data.Vec where

open import Level
open import Data.Bool.Base
import Data.Nat.Properties as ℕₚ
open import Data.Vec.Bounded.Base as Vec≤
  using (Vec≤; ≤-cast; fromVec)
open import Relation.Nullary
open import Relation.Unary

private
  variable
    a p : Level
    A : Set a

------------------------------------------------------------------------
-- Publicly re-export the contents of the base module

open import Data.Vec.Base public

------------------------------------------------------------------------
-- Additional operations

module _ {P : A → Set p} (P? : Decidable P) where

  filter : ∀ {n} → Vec A n → Vec≤ A n
  filter []       = Vec≤.[]
  filter (a ∷ as) with does (P? a)
  ... | true  = a Vec≤.∷ filter as
  ... | false = ≤-cast (ℕₚ.n≤1+n _) (filter as)

  takeWhile : ∀ {n} → Vec A n → Vec≤ A n
  takeWhile []       = Vec≤.[]
  takeWhile (a ∷ as) with does (P? a)
  ... | true  = a Vec≤.∷ takeWhile as
  ... | false = Vec≤.[]

  dropWhile : ∀ {n} → Vec A n → Vec≤ A n
  dropWhile Vec.[]       = Vec≤.[]
  dropWhile (a Vec.∷ as) with does (P? a)
  ... | true  = ≤-cast (ℕₚ.n≤1+n _) (dropWhile as)
  ... | false = fromVec (a Vec.∷ as)


-- Andreas, 2011-05-10
module MetaAppUnderLambda where

data _≡_ {A : Set} (a : A) : A -> Set where
  refl : a ≡ a

data D (A : Set) : Set where
  cons : A -> (A -> A) -> D A

f : {A : Set} -> D A -> A
f (cons a h) = a

test : (A : Set) ->
       let X : A
           X = _
           Y : A -> A
           Y = λ v -> _ v
       in  f (cons X Y) ≡ X
test A = refl
-- should return "Unsolved Metas"
-- executes the defauls A.App case in the type checker (which is not covered by appView)


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

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

module Number.Postulates where

private
  variable
    ℓ ℓ' ℓ'' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Relation.Binary.Base -- Rel
open import Function.Base using (_∋_)

ℕℓ  = ℓ-zero
ℕℓ' = ℓ-zero

postulate
  ℤℓ ℤℓ' : Level
  ℚℓ ℚℓ' : Level
  ℝℓ ℝℓ' : Level
  ℂℓ ℂℓ' : Level

open import Number.Structures
open import Number.Bundles
import Number.Inclusions

import MoreAlgebra

module ℕ* where
  import Cubical.Data.Nat as Nat
  import Cubical.Data.Nat.Order as Order

  open import Agda.Builtin.Nat using () renaming (Nat to ℕ) public

  module Postulates where
    postulate
      min max : ℕ → ℕ → ℕ
      isROrderedCommSemiring : IsROrderedCommSemiring
        (Order._<_)
        (Order._≤_)
        ((MoreAlgebra.Definitions._#'_ {_<_ = Order._<_}))
        (min)
        (max)
        (Nat.zero)
        (1)
        (Nat._+_)
        (Nat._*_)

  module Bundle = ROrderedCommSemiring {ℕℓ} {ℕℓ'}
  Bundle = ROrderedCommSemiring {ℕℓ} {ℕℓ'}

  Carrier = ℕ

  bundle : Bundle
  bundle = (record
    { Carrier = ℕ
    ; _<_ = Order._<_
    ; _≤_ = Order._≤_
    ; _#_ = (MoreAlgebra.Definitions._#'_ { _<_ = Order._<_ })
    ; min = Postulates.min
    ; max = Postulates.max
    ; 0f  = Nat.zero
    ; 1f  = (Nat.suc Nat.zero)
    ; _+_ = Nat._+_
    ; _·_ = Nat._*_
    ; isROrderedCommSemiring = Postulates.isROrderedCommSemiring
    })

  open import Cubical.Data.Nat.Order using (_≤_; _<_) public
  import MoreAlgebra
  open MoreAlgebra.Definitions using (_#'_) public
  open import Agda.Builtin.Nat using () renaming (zero to 0f)  public

  -- _<_ = Bundle._<_ bundle
  -- _≤_ = Bundle._≤_ bundle
  _#_ = Bundle._#_ bundle
  min = Bundle.min bundle
  max = Bundle.max bundle
  -- 0f  = Bundle.0f  bundle
  1f  = Bundle.1f  bundle
  _+_ = Bundle._+_ bundle
  _·_ = Bundle._·_ bundle
  isROrderedCommSemiring = Bundle.isROrderedCommSemiring bundle

  abs : ℕ → ℕ
  abs x = x

  open IsROrderedCommSemiring isROrderedCommSemiring public

module ℕ  = ℕ* hiding (ℕ)
module ℕⁿ = ℕ*
    renaming
    ( Carrier to Carrierⁿ
    ; _<_ to _<ⁿ_
    ; _≤_ to _≤ⁿ_
    ; _#_ to _#ⁿ_
    ; min to minⁿ
    ; max to maxⁿ
    ; 0f  to 0ⁿ
    ; 1f  to 1ⁿ
    ; _+_ to _+ⁿ_
    ; _·_ to _·ⁿ_
    ; isROrderedCommSemiring to isROrderedCommSemiringⁿ
    ; abs to absⁿ
    )

module ℤ* where
  module Postulates where
    postulate
      ℤ           : Type ℤℓ
      _<_ _≤_ _#_ : Rel ℤ ℤ ℤℓ'
      min max     : ℤ → ℤ → ℤ
      0f 1f       : ℤ
      _+_ _·_     : ℤ → ℤ → ℤ
      -_          : ℤ → ℤ

    abs : ℤ → ℤ
    abs x = max x (- x)

    postulate
      isROrderedCommRing : IsROrderedCommRing _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_
      isAbsOrderedCommRing : IsAbsOrderedCommRing _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_ abs

  module Bundle = ROrderedCommRing {ℤℓ} {ℤℓ'}
  Bundle = ROrderedCommRing {ℤℓ} {ℤℓ'}

  open Postulates public

  Carrier = ℤ

  bundle : Bundle
  bundle = (record
    { Carrier = ℤ
    ; _<_ = _<_
    ; _≤_ = _≤_
    ; _#_ = _#_
    ; min = min
    ; max = max
    ; 0f  = 0f
    ; 1f  = 1f
    ; _+_ = _+_
    ; _·_ = _·_
    ; -_  = -_
    ; isROrderedCommRing = isROrderedCommRing
    ; isAbsOrderedCommRing = isAbsOrderedCommRing
    })

  open IsROrderedCommRing isROrderedCommRing public

  -- abs : ℤ → ℤ
  -- abs x = max x (- x)

module ℤ  = ℤ* hiding (ℤ)
module ℤᶻ = ℤ*
    renaming
    ( Carrier to Carrierᶻ
    ; _<_ to _<ᶻ_
    ; _≤_ to _≤ᶻ_
    ; _#_ to _#ᶻ_
    ; min to minᶻ
    ; max to maxᶻ
    ; 0f  to 0ᶻ
    ; 1f  to 1ᶻ
    ; _+_ to _+ᶻ_
    ; _·_ to _·ᶻ_
    ; -_  to -ᶻ_
    ; isROrderedCommRing to isROrderedCommRingᶻ
    ; abs to absᶻ
    )

module ℚ* where
  module Postulates where
    postulate
      ℚ           : Type ℚℓ
      _<_ _≤_ _#_ : Rel ℚ ℚ ℚℓ'
      min max     : ℚ → ℚ → ℚ
      0f 1f       : ℚ
      _+_ _·_     : ℚ → ℚ → ℚ
      -_          : ℚ → ℚ
      _⁻¹         : (x : ℚ) → {{ x # 0f }} → ℚ

    abs : ℚ → ℚ
    abs x = max x (- x)

    postulate
      isROrderedField : IsROrderedField _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_ _⁻¹
      isAbsOrderedCommRing : IsAbsOrderedCommRing _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_ abs

  module Bundle = ROrderedField {ℚℓ} {ℚℓ'}
  Bundle = ROrderedField {ℚℓ} {ℚℓ'}

  open Postulates public

  Carrier = ℚ

  bundle : Bundle
  bundle = (record
    { Carrier = ℚ
    ; _<_ = _<_
    ; _≤_ = _≤_
    ; _#_ = _#_
    ; min = min
    ; max = max
    ; 0f  = 0f
    ; 1f  = 1f
    ; _+_ = _+_
    ; _·_ = _·_
    ; -_  = -_
    ; _⁻¹ = _⁻¹
    ; isROrderedField = isROrderedField
    ; isAbsOrderedCommRing = isAbsOrderedCommRing
    })

  -- abs : ℚ → ℚ
  -- abs x = max x (- x)

  open IsROrderedField isROrderedField public

module ℚ  = ℚ* hiding (ℚ)
module ℚᶠ = ℚ*
  renaming
  ( Carrier to Carrierᶠ
  ; _<_ to _<ᶠ_
  ; _≤_ to _≤ᶠ_
  ; _#_ to _#ᶠ_
  ; min to minᶠ
  ; max to maxᶠ
  ; 0f  to 0ᶠ
  ; 1f  to 1ᶠ
  ; _+_ to _+ᶠ_
  ; _·_ to _·ᶠ_
  ; -_  to -ᶠ_
  ; _⁻¹ to _⁻¹ᶠ
  ; isROrderedField to isROrderedFieldᶠ
  ; abs to absᶠ
  )

module ℝ* where
  private
    module Postulates where
      postulate
        ℝ           : Type ℝℓ
        _<_ _≤_ _#_ : Rel ℝ ℝ ℝℓ'
        min max     : ℝ → ℝ → ℝ
        0f 1f       : ℝ
        _+_ _·_     : ℝ → ℝ → ℝ
        -_          : ℝ → ℝ
        _⁻¹         : (x : ℝ) → {{ x # 0f }} → ℝ

      abs : ℝ → ℝ
      abs x = max x (- x)

      postulate
        isROrderedField : IsROrderedField _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_ _⁻¹
        isAbsOrderedCommRing : IsAbsOrderedCommRing _<_ _≤_ _#_ min max 0f 1f _+_ _·_ -_ abs

        -- square root on ℝ₀⁺
        sqrt : (x : ℝ) → {{0f ≤ x}} → ℝ
        0≤sqrt : ∀ x → {{p : 0f ≤ x}} → 0f ≤ sqrt x {{p}}
        sqrt-reflects-≡ : ∀ x y → {{px : 0f ≤ x}} → {{py : 0f ≤ y}} → sqrt x {{px}} ≡ sqrt y {{py}} → x ≡ y
        sqrt-inv : ∀ x → {{p : 0f ≤ x}} → {{q : 0f ≤ (x · x)}}→ sqrt (x · x) {{q}} ≡ x
        sqrt²-id : ∀ x → {{p : 0f ≤ x}} → sqrt x {{p}} · sqrt x {{p}} ≡ x

  module Bundle = ROrderedField {ℝℓ} {ℝℓ'}
  Bundle = ROrderedField {ℝℓ} {ℝℓ'}

  open Postulates public

  Carrier = ℝ

  bundle : Bundle
  bundle = (record
    { Carrier = ℝ
    ; _<_ = _<_
    ; _≤_ = _≤_
    ; _#_ = _#_
    ; min = min
    ; max = max
    ; 0f  = 0f
    ; 1f  = 1f
    ; _+_ = _+_
    ; _·_ = _·_
    ; -_  = -_
    ; _⁻¹ = _⁻¹
    ; isROrderedField = isROrderedField
    ; isAbsOrderedCommRing = isAbsOrderedCommRing
    })

  -- abs : ℝ → ℝ
  -- abs x = max x (- x)

  open IsROrderedField isROrderedField public

module ℝ  = ℝ* hiding (ℝ)
module ℝʳ = ℝ*
    renaming
    ( Carrier to Carrierʳ
    ; _<_ to _<ʳ_
    ; _≤_ to _≤ʳ_
    ; _#_ to _#ʳ_
    ; min to minʳ
    ; max to maxʳ
    ; 0f  to 0ʳ
    ; 1f  to 1ʳ
    ; _+_ to _+ʳ_
    ; _·_ to _·ʳ_
    ; -_  to -ʳ_
    ; _⁻¹ to _⁻¹ʳ
    ; isROrderedField to isROrderedFieldʳ
    ; isRField to isRFieldʳ
    ; Bundle to Bundleʳ
    ; bundle to bundleʳ
    ; abs to absʳ
    )

module ℂ* where
  open ℝʳ
  module Postulates where
    postulate
      ℂ           : Type ℂℓ
      _#_         : Rel ℂ ℂ ℂℓ'
      0f 1f       : ℂ
      _+_ _·_     : ℂ → ℂ → ℂ
      -_          : ℂ → ℂ
      _⁻¹         : (x : ℂ) → {{ x # 0f }} → ℂ
      isRField : IsRField _#_ 0f 1f _+_ _·_ -_ _⁻¹
      abs         : ℂ → ℝ
      0≤abs       : ∀ x → 0ʳ ≤ʳ abs x
      abs-preserves-0 : ∀ x → x ≡ 0f → abs x ≡ 0ʳ
      abs-reflects-0  : ∀ x → abs x ≡ 0ʳ → x ≡ 0f
      abs-preserves-· : ∀ x y → abs (x · y) ≡ (abs x) ·ʳ (abs y)
      abs-preserves-#0 : ∀ x → x # 0f → abs x #ʳ 0ʳ
      abs-reflects-#0 : ∀ x → abs x #ʳ 0ʳ → x # 0f

  module Bundle = RField {ℂℓ} {ℂℓ'}
  Bundle = RField {ℂℓ} {ℂℓ'}

  open Postulates public

  Carrier = ℂ

  bundle : Bundle
  bundle = (record
    { Carrier  = ℂ
    ; _#_      = _#_
    ; 0f       = 0f
    ; 1f       = 1f
    ; _+_      = _+_
    ; _·_      = _·_
    ; -_       = -_
    ; _⁻¹      = _⁻¹
    ; isRField = isRField
    })

  open IsRField isRField public

module ℂ  = ℂ* hiding (ℂ)
module ℂᶜ = ℂ*
    renaming
    ( Carrier to Carrierᶜ
    ; _#_ to _#ᶜ_
    ; 0f  to 0ᶜ
    ; 1f  to 1ᶜ
    ; _+_ to _+ᶜ_
    ; _·_ to _·ᶜ_
    ; -_  to -ᶜ_
    ; _⁻¹ to _⁻¹ᶜ
    ; isRField to isRFieldᶜ
    ; abs to absᶜ
    )

Isℕ↪ℤ = Number.Inclusions.IsROrderedCommSemiringInclusion
Isℕ↪ℚ = Number.Inclusions.IsROrderedCommSemiringInclusion
Isℕ↪ℂ = Number.Inclusions.IsRCommSemiringInclusion
Isℕ↪ℝ = Number.Inclusions.IsROrderedCommSemiringInclusion
Isℤ↪ℚ = Number.Inclusions.IsROrderedCommRingInclusion
Isℤ↪ℝ = Number.Inclusions.IsROrderedCommRingInclusion
Isℤ↪ℂ = Number.Inclusions.IsRCommRingInclusion
Isℚ↪ℝ = Number.Inclusions.IsROrderedFieldInclusion
Isℚ↪ℂ = Number.Inclusions.IsRFieldInclusion
Isℝ↪ℂ = Number.Inclusions.IsRFieldInclusion

module Isℕ↪ℤ = Number.Inclusions.IsROrderedCommSemiringInclusion
module Isℕ↪ℚ = Number.Inclusions.IsROrderedCommSemiringInclusion
module Isℕ↪ℂ = Number.Inclusions.IsRCommSemiringInclusion
module Isℕ↪ℝ = Number.Inclusions.IsROrderedCommSemiringInclusion
module Isℤ↪ℚ = Number.Inclusions.IsROrderedCommRingInclusion
module Isℤ↪ℝ = Number.Inclusions.IsROrderedCommRingInclusion
module Isℤ↪ℂ = Number.Inclusions.IsRCommRingInclusion
module Isℚ↪ℝ = Number.Inclusions.IsROrderedFieldInclusion
module Isℚ↪ℂ = Number.Inclusions.IsRFieldInclusion
module Isℝ↪ℂ = Number.Inclusions.IsRFieldInclusion

module _ where
  open ℕ* using (ℕ)
  open ℤ* using (ℤ)
  open ℚ* using (ℚ)
  open ℝ* using (ℝ)
  open ℂ* using (ℂ)
  postulate
    ℕ↪ℤ : ℕ → ℤ
    ℕ↪ℚ : ℕ → ℚ
    ℕ↪ℂ : ℕ → ℂ
    ℕ↪ℝ : ℕ → ℝ
    ℤ↪ℚ : ℤ → ℚ
    ℤ↪ℝ : ℤ → ℝ
    ℤ↪ℂ : ℤ → ℂ
    ℚ↪ℝ : ℚ → ℝ
    ℚ↪ℂ : ℚ → ℂ
    ℝ↪ℂ : ℝ → ℂ

    ℕ↪ℤinc : Isℕ↪ℤ (record {ℕ*}) (record {ℤ*}) ℕ↪ℤ
    ℕ↪ℚinc : Isℕ↪ℚ (record {ℕ*}) (record {ℚ*}) ℕ↪ℚ
    ℕ↪ℂinc : Isℕ↪ℂ (record {ℕ*}) (record {ℂ*}) ℕ↪ℂ
    ℕ↪ℝinc : Isℕ↪ℝ (record {ℕ*}) (record {ℝ*}) ℕ↪ℝ
    ℤ↪ℚinc : Isℤ↪ℚ (record {ℤ*}) (record {ℚ*}) ℤ↪ℚ
    ℤ↪ℝinc : Isℤ↪ℝ (record {ℤ*}) (record {ℝ*}) ℤ↪ℝ
    ℤ↪ℂinc : Isℤ↪ℂ (record {ℤ*}) (record {ℂ*}) ℤ↪ℂ
    ℚ↪ℝinc : Isℚ↪ℝ (record {ℚ*}) (record {ℝ*}) ℚ↪ℝ
    ℚ↪ℂinc : Isℚ↪ℂ (record {ℚ*}) (record {ℂ*}) ℚ↪ℂ
    ℝ↪ℂinc : Isℝ↪ℂ (record {ℝ*}) (record {ℂ*}) ℝ↪ℂ

    {-
    ℕ↪ℤinc : Isℕ↪ℤ                    ℕ.bundle    (record { ℤ.Bundle ℤ.bundle }) ℕ↪ℤ
    ℕ↪ℚinc : Isℕ↪ℚ                    ℕ.bundle    (record { ℚ.Bundle ℚ.bundle }) ℕ↪ℚ
    ℕ↪ℂinc : Isℕ↪ℂ                    ℕ.bundle                       ℂ.bundle    ℕ↪ℂ
    ℕ↪ℝinc : Isℕ↪ℝ                    ℕ.bundle    (record { ℝ.Bundle ℝ.bundle }) ℕ↪ℝ
    ℤ↪ℚinc : Isℤ↪ℚ                    ℤ.bundle    (record { ℚ.Bundle ℚ.bundle }) ℤ↪ℚ
    ℤ↪ℝinc : Isℤ↪ℝ                    ℤ.bundle    (record { ℝ.Bundle ℝ.bundle }) ℤ↪ℝ
    ℤ↪ℂinc : Isℤ↪ℂ                    ℤ.bundle                       ℂ.bundle    ℤ↪ℂ
    ℚ↪ℝinc : Isℚ↪ℝ                    ℚ.bundle    (record { ℝ.Bundle ℝ.bundle }) ℚ↪ℝ
    ℚ↪ℂinc : Isℚ↪ℂ (record { ℚ.Bundle ℚ.bundle }) (record { ℂ.Bundle ℂ.bundle }) ℚ↪ℂ
    ℝ↪ℂinc : Isℝ↪ℂ (record { ℝ.Bundle ℝ.bundle }) (record { ℂ.Bundle ℂ.bundle }) ℝ↪ℂ
    -}


open import Agda.Primitive

postulate
  F : (a : Level) → Set a → Set a
  P : (a : Level) (A : Set a) → F a A → Set a
  p : (a : Level) (A : Set a) (x : F a A) → P a A x
  Q : (a : Level) (A : Set a) → A → Set a

variable
  a : Level
  A : Set a

postulate
  q : (x : F _ A) → Q a _ (p a A x)

q' : {a : Level} {A : Set a} (x : F a A) → Q a (P a A x) (p a A x)
q' {a} {A} = q {a} {A}


module AKS.Everything where

open import AKS.Binary
open import AKS.Exponentiation
open import AKS.Extended
open import AKS.Fin
-- open import AKS.Modular.Quotient
-- open import AKS.Polynomial
open import AKS.Primality
open import AKS.Nat
open import AKS.Nat.GCD


open import Oscar.Prelude
open import Oscar.Data.Constraint

module Oscar.Class where

record InnerClass {ℓ} {𝔢} {CONSTRAINTS : Ø 𝔢} (constraints : CONSTRAINTS) (_ : Constraint constraints) (SET-METHOD : Ø ℓ) : Ø ℓ where
  constructor ∁
  field
    ⋆ : SET-METHOD

open InnerClass public

module ℭLASS
  {ℓ}
  {𝔢}
  {CONSTRAINTS : Ø 𝔢}
  (constraints : CONSTRAINTS)
  (c : Ø ℓ)
  where
  class = InnerClass constraints ∅ c
  type = c
  method : ⦃ _ : class ⦄ → type
  method ⦃ ⌶ ⦄ = InnerClass.⋆ ⌶

record Rℭlass
  {ℓ 𝔯}
  {𝔢}
  {CONSTRAINTS : Ø 𝔢}
  (constraints : CONSTRAINTS)
  : Ø ↑̂ (ℓ ∙̂ 𝔯)
  where
  constructor ∁
  field
    SET-METHOD : Ø ℓ
    SET-R : SET-METHOD → Ø 𝔯
  record SET-CLASS
    ⦃ _ : Constraint constraints ⦄
    : Ø ℓ ∙̂ 𝔯
    where
    constructor ∁
    field ⋆ : SET-METHOD
          ⦃ ⋆⋆ ⦄ : SET-R ⋆
  open SET-CLASS public
  GET-CLASS : Ø _
  GET-CLASS = SET-CLASS
  GET-METHOD : ⦃ _ : GET-CLASS ⦄ → SET-METHOD
  GET-METHOD ⦃ ⌶ ⦄ = SET-CLASS.⋆ ⌶

open Rℭlass using (⋆; ∁) public


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

module Light.Library.Data.Boolean where

open import Light.Level using (Level ; Setω ; Lifted)
open import Light.Variable.Sets
open import Light.Library.Data.Unit as Unit using (Unit)
open import Light.Library.Data.Empty as Empty using (Empty)
open import Light.Package using (Package)
open import Light.Library.Relation.Binary
      using (SelfTransitive ; SelfSymmetric ; Reflexive)
open import Light.Library.Relation.Binary.Equality as ≈ using (_≈_)
open import Light.Library.Relation.Binary.Equality.Decidable using (DecidableSelfEquality)
import Light.Library.Relation.Decidable
open import Light.Library.Relation using (False)

record Dependencies : Setω where
      field
            ⦃ unit‐package ⦄ : Package record { Unit }
            ⦃ empty‐package ⦄ : Package record { Empty }

record Library (dependencies : Dependencies) : Setω where
      field
            ℓ : Level
            Boolean : Set ℓ
            true false : Boolean
            if_then_else_ : Boolean → 𝕒 → 𝕒 → 𝕒
            ¬_ : Boolean → Boolean
            _∧_ _∨_ _⇢_ : Boolean → Boolean → Boolean
            true‐is‐true : if true then Lifted (Empty.ℓ) Unit else Lifted (Unit.ℓ) Empty
            false‐is‐false : if false then Lifted (Unit.ℓ) Empty else Lifted (Empty.ℓ) Unit
            ⦃ equals ⦄ : DecidableSelfEquality Boolean
            ⦃ ≈‐transitive ⦄ : SelfTransitive (≈.self‐relation Boolean)
            ⦃ ≈‐symmetric ⦄ : SelfSymmetric (≈.self‐relation Boolean)
            ⦃ ≈‐reflexive ⦄ : Reflexive (≈.self‐relation Boolean)
            true‐≉‐false : False (true ≈ false)

open Library ⦃ ... ⦄ public


{-# OPTIONS --without-K #-}
module FT-Nat where

open import Data.Empty
open import Data.Unit
open import Data.Nat renaming (_⊔_ to _⊔ℕ_)
open import Data.Sum renaming (map to _⊎→_)
open import Data.Product
import Data.Fin as F
open import Data.Vec
import Data.List as L
open import Function renaming (_∘_ to _○_)

open import FT
open import SimpleHoTT using (refl; pathInd; _≡_; ap)
open import Equivalences
open import TypeEquivalences using (path⊎)
open import Path2Equiv
open import LeftCancellation

------------------------------------------------------------------
-- Finite Types and the natural numbers are intimately related.
--
-- Basically, this is because both of them are models of
-- unital semirings, and the natural numbers are the initial object
-- in the category of unital semirings.  In this case, things are
-- deeper still, and so we record many of these facts here.
--
-- And, of course, as Pi records the proof-theory of semirings in
-- a fairly explicit manner, we can use all this to link up
-- normalization of natural-numbers expressions and Pi-based paths.

toℕ : FT → ℕ
toℕ ZERO = zero
toℕ ONE = suc zero
toℕ (PLUS b₀ b₁) = (toℕ b₀) + (toℕ b₁)
toℕ (TIMES b₀ b₁) = (toℕ b₀) * (toℕ b₁)

fromℕ : ℕ → FT
fromℕ zero = ZERO
fromℕ (suc n) = PLUS ONE (fromℕ n)

toℕ∘fromℕ : toℕ ○ fromℕ ∼ id
toℕ∘fromℕ zero = refl zero
toℕ∘fromℕ (suc n) =
  pathInd
    (λ {x} {y} _ → suc x ≡ suc y)
    (λ m → refl (suc m))
    (toℕ∘fromℕ n)

assocr : {m : ℕ} (n : ℕ) → (PLUS (fromℕ n) (fromℕ m)) ⇛ fromℕ (n + m)
assocr zero = unite₊⇛
assocr (suc n) = assocr₊⇛ ◎ (id⇛ ⊕ (assocr n))

distr : (n₀ : ℕ) {n₁ : ℕ} → TIMES (fromℕ n₀) (fromℕ n₁) ⇛ fromℕ (n₀ * n₁)
distr zero = distz⇛
distr (suc n) {m} = dist⇛ ◎ (unite⋆⇛ ⊕ distr n) ◎ assocr m

-- normalize a finite type to (1 + (1 + (1 + ... + (1 + 0) ... )))
-- a bunch of ones ending with zero with left biased + in between

normalize : FT → FT
normalize = fromℕ ○ toℕ

normal : (b : FT) → b ⇛ normalize b
normal ZERO = id⇛
normal ONE = uniti₊⇛ ◎ swap₊⇛
normal (PLUS b₀ b₁) = (normal b₀ ⊕ normal b₁) ◎ assocr (toℕ b₀)
normal (TIMES b₀ b₁) = (normal b₀ ⊗ normal b₁) ◎ distr (toℕ b₀)

normalizeC : {B : FT} → ⟦ normalize B ⟧ ≃ ⟦ B ⟧
normalizeC {B} = path2equiv (sym⇛ (normal B))

mapNorm :  {B₁ B₂ : FT} → (⟦ B₁ ⟧ ≃ ⟦ B₂ ⟧) → ⟦ normalize B₁ ⟧ ≃ ⟦ normalize B₂ ⟧
mapNorm {B₁} {B₂} eq = trans≃ (trans≃ (normalizeC {B₁}) eq) (sym≃ (normalizeC {B₂}))

⟦_⟧ℕ : ℕ → Set
⟦ zero ⟧ℕ = ⊥
⟦ suc n ⟧ℕ = ⊤ ⊎ ⟦ n ⟧ℕ

ℕrespects⟦⟧ : {n : ℕ} → ⟦ fromℕ n ⟧ ≃ ⟦ n ⟧ℕ
ℕrespects⟦⟧ {zero} = id≃
ℕrespects⟦⟧ {suc n} = path⊎ id≃ (ℕrespects⟦⟧ {n})

------------------------------------------------------------------------------
-- Understanding the syntactic structure of pi combinators with respect
-- to normalization

data FTNF : Set where
  Z : FTNF
  S : FTNF → FTNF

fromℕNF : ℕ → FTNF
fromℕNF zero = Z
fromℕNF (suc n) = S (fromℕNF n)

normalizeNF : FT → FTNF
normalizeNF = fromℕNF ○ toℕ

data FTN : FT → Set where
  normalized : (b : FT) → FTN (normalize b)

-- in both the following two functions we are missing fundamental information
-- about how a type relates to its normal form...

{--
normalize⇛ : {b₁ b₂ : FT} → (b₁ ⇛ b₂) → (normalize b₁ ⇛ normalize b₂)
normalize⇛ unite₊⇛ = id⇛
normalize⇛ uniti₊⇛ = id⇛
normalize⇛ swap₊⇛ = {!!}
normalize⇛ assocl₊⇛ = {!!}
normalize⇛ assocr₊⇛ = {!!}
normalize⇛ unite⋆⇛ = {!!}
normalize⇛ uniti⋆⇛ = {!!}
normalize⇛ swap⋆⇛ = {!!}
normalize⇛ assocl⋆⇛ = {!!}
normalize⇛ assocr⋆⇛ = {!!}
normalize⇛ distz⇛ = id⇛
normalize⇛ factorz⇛ = id⇛
normalize⇛ dist⇛ = {!!}
normalize⇛ factor⇛ = {!!}
normalize⇛ id⇛ = id⇛
normalize⇛ (sym⇛ c) = sym⇛ (normalize⇛ c)
normalize⇛ (c₁ ◎ c₂) = normalize⇛ c₁ ◎ normalize⇛ c₂
normalize⇛ (c ⊕ c₁) = {!!}
normalize⇛ (c ⊗ c₁) = {!!}
--}

{--
swapii+1 : {b : FT} → (i : ℕ) → (b ⇛ b)
swapii+1 {PLUS ONE (PLUS ONE b)} 0 =
  (assocl₊⇛ {ONE} {ONE} {b}) ◎ (swap₊⇛ ⊕ id⇛) ◎ (assocr₊⇛ {ONE} {ONE} {b})
swapii+1 {PLUS ONE b} (suc n) = id⇛ ⊕ swapii+1 n
swapii+1 _ = {!!}
--}
------------------------------------------------------------------------------

-- needs LeftCancellation

liftℕ : (n₁ n₂ : ℕ) → ⟦ n₁ ⟧ℕ ≃ ⟦ n₂ ⟧ℕ → (fromℕ n₁) ≡ (fromℕ n₂)
liftℕ zero zero eq = refl ZERO
liftℕ zero (suc n₂) (_ , mkisequiv g α h β) with h (inj₁ tt)
liftℕ zero (suc n₂) (_ , mkisequiv g α h β) | ()
liftℕ (suc n₁) zero (f , _) with f (inj₁ tt)
liftℕ (suc n₁) zero (f , _) | ()
liftℕ (suc n₁) (suc n₂) eq = ap (λ x → PLUS ONE x) (liftℕ n₁ n₂ (left-cancel-⊤ eq))

liftNormal : {B₁ B₂ : FT} →  ⟦ normalize B₁ ⟧ ≃ ⟦ normalize B₂ ⟧ → (normalize B₁) ≡ (normalize B₂)
liftNormal {B₁} {B₂} eq =
  liftℕ (toℕ B₁) (toℕ B₂)
    (⟦ toℕ B₁ ⟧ℕ ≃⟨ sym≃ (ℕrespects⟦⟧ {toℕ B₁}) ⟩ ⟦ normalize B₁ ⟧ ≃⟨ eq ⟩ ⟦ normalize B₂ ⟧ ≃⟨ ℕrespects⟦⟧ {toℕ B₂} ⟩ id≃)

sameNorm : {B₁ B₂ : FT} → (⟦ B₁ ⟧ ≃ ⟦ B₂ ⟧) → (normalize B₁) ≡ (normalize B₂)
sameNorm {B₁} {B₂} eq = liftNormal {B₁} {B₂} (mapNorm eq)

bridge : {B₁ B₂ : FT} → (⟦ B₁ ⟧ ≃ ⟦ B₂ ⟧) → (normalize B₁) ⇛ (normalize B₂)
bridge eq =
  pathInd
    (λ {B₃} {B₄} _ → B₃ ⇛ B₄)
    (λ _ → id⇛)
    (sameNorm eq)

{--

Not used

exf : ⊤ ⊎ ℕ → ℕ
exf (inj₁ tt) = 0
exf (inj₂ n) = suc n

exg : ℕ → ⊤ ⊎ ℕ
exg 0 = inj₁ tt
exg (suc n) = inj₂ n

exα : exf ○ exg ∼ id
exα 0 = refl 0
exα (suc n) = refl (suc n)

exβ : exg ○ exf ∼ id
exβ (inj₁ tt) = refl (inj₁ tt)
exβ (inj₂ n) = refl (inj₂ n)

ex : (⊤ ⊎ ℕ) ≃ ℕ
ex = (exf , equiv₁ (mkqinv exg exα exβ))

exf2 : (⊤ ⊎ (⊤ ⊎ ℕ)) → (⊤ ⊎ ℕ)
exf2 (inj₁ tt) = inj₂ 0
exf2 (inj₂ (inj₁ tt)) = inj₂ 1
exf2 (inj₂ (inj₂ 0)) = inj₁ tt
exf2 (inj₂ (inj₂ (suc n))) = inj₂ (suc (suc n))

exg2 : (⊤ ⊎ ℕ) → (⊤ ⊎ (⊤ ⊎ ℕ))
exg2 (inj₁ tt) = inj₂ (inj₂ 0)
exg2 (inj₂ 0) = inj₁ tt
exg2 (inj₂ 1) = inj₂ (inj₁ tt)
exg2 (inj₂ (suc (suc n))) = inj₂ (inj₂ (suc n))

exα2 : exf2 ○ exg2 ∼ id
exα2 (inj₁ tt) = refl (inj₁ tt)
exα2 (inj₂ 0) = refl (inj₂ 0)
exα2 (inj₂ 1) = refl (inj₂ 1)
exα2 (inj₂ (suc (suc n))) = refl (inj₂ (suc (suc n)))

exβ2 : exg2 ○ exf2 ∼ id
exβ2 (inj₁ tt) = refl (inj₁ tt)
exβ2 (inj₂ (inj₁ tt)) = refl (inj₂ (inj₁ tt))
exβ2 (inj₂ (inj₂ 0)) = refl (inj₂ (inj₂ 0))
exβ2 (inj₂ (inj₂ (suc n))) = refl (inj₂ (inj₂ (suc n)))

ex2 : (⊤ ⊎ (⊤ ⊎ ℕ)) ≃ (⊤ ⊎ ℕ)
ex2 = (exf2 , equiv₁ (mkqinv exg2 exα2 exβ2))

--}


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

open import Agda.Builtin.Bool
open import Agda.Builtin.Nat
open import Agda.Primitive

record Graph ℓv ℓe : Set (lsuc (ℓv ⊔ ℓe)) where
  field
    Obj : Set ℓv
    Hom : Obj → Obj → Set ℓe

open Graph public

postulate
  t : Nat → Nat → Bool

ωGr : Graph lzero lzero
Obj ωGr = Nat
Hom ωGr m n with t m n
... | true = {!!} -- if n ≡ (suc m)
... | false = {!!} -- otherwise

foo : ∀ m n → Hom ωGr m n → {!!}
foo m n f with t m n
... | z = {!!}


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

module Data.Vec.Inductive where

open import Prelude
open import Data.List using (List; _∷_; []; length)

private
  variable
    n m : ℕ

infixr 5 _∷_
data Vec (A : Type a) : ℕ → Type a where
  [] : Vec A 0
  _∷_ : A → Vec A n → Vec A (suc n)

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

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

foldr′ : (A → B → B) → B → Vec A n → B
foldr′ f = foldr (const _) (λ x xs → f x xs)

foldl′ : (A → B → B) → B → Vec A n → B
foldl′ f = foldl (const _) (λ x xs → f x xs)

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

vecToList : Vec A n → List A
vecToList [] = []
vecToList (x ∷ xs) = x ∷ vecToList xs


------------------------------------------------------------------------------
-- Filter
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.List.Filter where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.PropertiesI
open import FOTC.Base.List
open import FOTC.Data.Bool.Type
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.Type
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI

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

postulate
  filter    : D → D → D
  filter-[] : ∀ p → filter p [] ≡ []
  filter-∷  : ∀ p x xs → filter p (x ∷ xs) ≡
              (if p · x then x ∷ filter p xs else filter p xs)

postulate filter-List : ∀ p {xs} → List xs → List (filter p xs)

from-Bool : ∀ {b} → Bool b → b ≡ true ∨ b ≡ false
from-Bool btrue  = inj₁ refl
from-Bool bfalse = inj₂ refl

-- lenght-filter : ∀ p {xs} → (∀ x → Bool (p · x)) → List xs →
--                 length (filter p xs) ≤ length xs
-- lenght-filter p hp lnil =
--   le (length (filter p [])) (length [])
--     ≡⟨ ltLeftCong (lengthCong (filter-[] p)) ⟩
--   le (length []) (length [])
--     ≡⟨ ltCong length-[] (succCong length-[]) ⟩
--   le zero zero
--     ≡⟨ x≤x nzero ⟩
--   true ∎

-- lenght-filter p hp (lcons x {xs} Lxs) = case prf₁ prf₂ (from-Bool (hp x))
--   where
--   prf₁ : p · x ≡ true →
--          le (length (filter p (x ∷ xs))) (length (x ∷ xs)) ≡ true
--   prf₁ h = {!!}

--   prf₂ : p · x ≡ false →
--          le (length (filter p (x ∷ xs))) (length (x ∷ xs)) ≡ true
--   prf₂ h =
--     le (length (filter p (x ∷ xs))) (length (x ∷ xs))
--       ≡⟨ ltLeftCong (lengthCong {!!}) ⟩
--     le (length (filter p xs)) (length (x ∷ xs))
--       ≡⟨ ≤-trans (lengthList-N (filter-List p Lxs))
--                  (lengthList-N Lxs)
--                  (lengthList-N (lcons x Lxs))
--                  (lenght-filter p hp Lxs)
--                  (x<y→x≤y (lengthList-N Lxs) (lengthList-N (lcons x Lxs))
--                           (lg-x<lg-x∷xs x Lxs)) ⟩
--     true ∎


-- A minor variant of code reported by Andreas Abel. The code below
-- should be rejected.

open import Agda.Builtin.Size

data ⊥ : Set where

data SizeLt (i : Size) : Set where
  size : (j : Size< i) → SizeLt i

<∞ : SizeLt ∞
<∞ = size ∞

data D (i : Size) : SizeLt i → Set where
  c : ∀ {i' : Size< i} → ((j : SizeLt i') → D i' j) → D i (size i')

f : D ∞ <∞ → ⊥
f (c h) = f (h <∞)

d : ∀ i s → D i s
d i (size j) = c (d j)

loop : ⊥
loop = f (d ∞ <∞)


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

open import Functions
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Setoids.Subset
open import Setoids.Setoids
open import Setoids.Orders
open import Fields.Fields
open import Rings.Orders.Total.Definition
open import Rings.Orders.Total.Lemmas
open import Rings.Orders.Partial.Definition
open import Rings.Definition
open import Fields.Orders.LeastUpperBounds.Definition
open import Numbers.ClassicalReals.RealField
open import Groups.Definition
open import Groups.Homomorphisms.Definition
open import Rings.Homomorphisms.Definition
open import Sets.EquivalenceRelations
open import Semirings.Definition

open import Numbers.Naturals.Semiring
open import Numbers.Integers.Definition
open import Numbers.Integers.RingStructure.Ring

module Numbers.ClassicalReals.RealField.AllIsomorphic (ℝ : RealField) where

open RealField ℝ
open Ring R
open Group additiveGroup
open Setoid S
open Equivalence eq
open import Rings.Lemmas R
open import Groups.Lemmas additiveGroup

fromN : ℕ → A
fromN zero = 0R
fromN (succ n) = 1R + fromN n

fromNPreserves+ : (a b : ℕ) → fromN (a +N b) ∼ (fromN a) + (fromN b)
fromNPreserves+ zero b = symmetric identLeft
fromNPreserves+ (succ a) b = transitive (+WellDefined reflexive (fromNPreserves+ a b)) +Associative

fromNPreserves* : (a b : ℕ) → fromN (a *N b) ∼ (fromN a) * (fromN b)
fromNPreserves* zero b = symmetric (transitive *Commutative timesZero)
fromNPreserves* (succ a) b = transitive (transitive (fromNPreserves+ b (a *N b)) (+WellDefined (symmetric identIsIdent) (fromNPreserves* a b))) (symmetric *DistributesOver+')

fromNWellDefined : {a b : ℕ} → a ≡ b → fromN a ∼ fromN b
fromNWellDefined refl = reflexive

fromZ : ℤ → A
fromZ (nonneg x) = fromN x
fromZ (negSucc x) = inverse (fromN (succ x))

private
  lemma : (a : ℕ) → (b : ℕ) → (1R + fromN (succ a *N b +N a)) ∼ ((1R + fromN a) * (1R + fromN b))
  lemma a b = transitive (transitive (transitive (+WellDefined reflexive (transitive (fromNPreserves+ ((succ a) *N b) a) (transitive groupIsAbelian (+WellDefined reflexive (transitive (fromNPreserves+ b (a *N b)) (+WellDefined (symmetric identIsIdent) (fromNPreserves* a b))))))) +Associative) (+WellDefined (transitive (symmetric identIsIdent) *Commutative) (symmetric *DistributesOver+'))) (symmetric *DistributesOver+)

fromZPreserves+ : (a b : ℤ) → fromZ (a +Z b) ∼ (fromZ a) + (fromZ b)
fromZPreserves+ (nonneg zero) (nonneg y) = symmetric identLeft
fromZPreserves+ (nonneg (succ x)) (nonneg y) = transitive (+WellDefined reflexive (fromNPreserves+ x y)) +Associative
fromZPreserves+ (nonneg zero) (negSucc y) = symmetric identLeft
fromZPreserves+ (nonneg (succ x)) (negSucc zero) = transitive (transitive (transitive (transitive (symmetric identLeft) (+WellDefined (symmetric invLeft) reflexive)) (symmetric +Associative)) (+WellDefined (inverseWellDefined (symmetric identRight)) reflexive)) (groupIsAbelian)
fromZPreserves+ (nonneg (succ x)) (negSucc (succ y)) = transitive (fromZPreserves+ (nonneg x) (negSucc y)) (transitive (transitive (transitive (transitive (transitive (transitive (transitive (symmetric identLeft) +Associative) groupIsAbelian) (+WellDefined reflexive (+WellDefined (symmetric invLeft) reflexive))) (+WellDefined reflexive (symmetric +Associative))) +Associative) groupIsAbelian) (+WellDefined reflexive (symmetric invContravariant)))
fromZPreserves+ (negSucc zero) (nonneg zero) = symmetric identRight
fromZPreserves+ (negSucc zero) (nonneg (succ y)) = transitive (transitive (symmetric identLeft) (+WellDefined (symmetric (transitive (+WellDefined reflexive (symmetric identRight)) invLeft)) reflexive)) (symmetric +Associative)
fromZPreserves+ (negSucc (succ x)) (nonneg zero) = symmetric identRight
fromZPreserves+ (negSucc (succ x)) (nonneg (succ y)) = transitive (fromZPreserves+ (negSucc x) (nonneg y)) (transitive (transitive (+WellDefined reflexive (transitive (symmetric identLeft) (transitive (+WellDefined (symmetric invLeft) reflexive) (symmetric +Associative)))) +Associative) (+WellDefined (symmetric invContravariant) reflexive))
fromZPreserves+ (negSucc x) (negSucc y) = transitive (transitive invContravariant (transitive (+WellDefined invContravariant reflexive) (transitive (+WellDefined (transitive (transitive (+WellDefined (transitive (inverseWellDefined (fromNPreserves+ x y)) invContravariant) reflexive) (symmetric +Associative)) groupIsAbelian) reflexive) (symmetric +Associative)))) (+WellDefined (symmetric invContravariant) (symmetric invContravariant))

fromZPreserves* : (a b : ℤ) → fromZ (a *Z b) ∼ (fromZ a) * (fromZ b)
fromZPreserves* (nonneg a) (nonneg b) = fromNPreserves* a b
fromZPreserves* (nonneg zero) (negSucc b) = symmetric (transitive *Commutative timesZero)
fromZPreserves* (nonneg (succ a)) (negSucc b) = transitive (inverseWellDefined (lemma a b)) (symmetric ringMinusExtracts)
fromZPreserves* (negSucc a) (nonneg zero) = symmetric timesZero
fromZPreserves* (negSucc a) (nonneg (succ b)) = transitive (inverseWellDefined (transitive (+WellDefined reflexive (fromNWellDefined {(a +N b *N a) +N b} {(b +N a *N b) +N a} (transitivity (Semiring.commutative ℕSemiring _ b) (transitivity (applyEquality (b +N_) (transitivity (Semiring.commutative ℕSemiring a _) (applyEquality (_+N a) (multiplicationNIsCommutative b a)))) (Semiring.+Associative ℕSemiring b _ a))))) (lemma a b))) (symmetric ringMinusExtracts')
fromZPreserves* (negSucc a) (negSucc b) = transitive (transitive (+WellDefined reflexive (fromNWellDefined {b +N a *N succ b} {(b +N a *N b) +N a} (transitivity (applyEquality (b +N_) (transitivity (multiplicationNIsCommutative a (succ b)) (transitivity (Semiring.commutative ℕSemiring a _) (applyEquality (_+N a) (multiplicationNIsCommutative b a))))) (Semiring.+Associative ℕSemiring b _ a)))) (lemma a b)) (symmetric twoNegativesTimes)

ringHom : RingHom ℤRing R fromZ
RingHom.preserves1 ringHom = identRight
RingHom.ringHom ringHom {r} {s} = fromZPreserves* r s
GroupHom.groupHom (RingHom.groupHom ringHom) {r} {s} = fromZPreserves+ r s
GroupHom.wellDefined (RingHom.groupHom ringHom) refl = reflexive


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

open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Naturals
open import Numbers.Naturals.Multiplication
open import Numbers.Integers.Order
open import Numbers.Integers.RingStructure.Ring
open import Numbers.Integers.RingStructure.IntegralDomain
open import Semirings.Definition
open import Rings.EuclideanDomains.Definition
open import Orders.Total.Definition
open import Numbers.Naturals.EuclideanAlgorithm

module Numbers.Integers.RingStructure.EuclideanDomain where

private
  norm : ℤ → ℕ
  norm (nonneg x) = x
  norm (negSucc x) = succ x

  norm' : {a : ℤ} → (a!=0 : (a ≡ nonneg 0) → False) → ℕ
  norm' {a} _ = norm a

  multiplyIncreasesSuccLemma : (a b : ℕ) → succ (succ a) <N (succ (succ a)) *N (succ (succ b))
  multiplyIncreasesSuccLemma a b with multiplyIncreases (succ (succ b)) (succ (succ a)) (le b (applyEquality succ (Semiring.commutative ℕSemiring b 1))) (le (succ a) (applyEquality (λ i → succ (succ i)) (Semiring.sumZeroRight ℕSemiring a)))
  ... | bl rewrite multiplicationNIsCommutative (succ (succ b)) (succ (succ a)) = bl

  multiplyIncreasesSucc : (a b : ℕ) → succ a ≤N (succ a) *N (succ b)
  multiplyIncreasesSucc zero zero = inr refl
  multiplyIncreasesSucc zero (succ b) = inl (le (b +N 0) (Semiring.commutative ℕSemiring (succ (b +N 0)) 1))
  multiplyIncreasesSucc (succ a) zero = inr (applyEquality (λ i → succ (succ i)) (equalityCommutative (productWithOneRight a)))
  multiplyIncreasesSucc (succ a) (succ b) = inl (multiplyIncreasesSuccLemma a b)

  multiplyIncreasesSuccLemma' : (a b : ℕ) → succ (succ a) <N succ ((succ (succ a)) *N succ b) +N succ a
  multiplyIncreasesSuccLemma' a b = succPreservesInequality (le (b +N succ (b +N a *N succ b)) refl)

  multiplyIncreasesSucc' : (a b : ℕ) → succ a ≤N succ ((b +N a *N b) +N a)
  multiplyIncreasesSucc' zero zero = inr refl
  multiplyIncreasesSucc' zero (succ b) = inl (le b (applyEquality succ (transitivity (Semiring.commutative ℕSemiring b 1) (transitivity (equalityCommutative (Semiring.sumZeroRight ℕSemiring (succ b))) (equalityCommutative (Semiring.sumZeroRight ℕSemiring _))))))
  multiplyIncreasesSucc' (succ a) zero rewrite multiplicationNIsCommutative a zero = inr refl
  multiplyIncreasesSucc' (succ a) (succ b) = inl (multiplyIncreasesSuccLemma' a b)

  normSize : {a b : ℤ} → (a!=0 : (a ≡ nonneg 0) → False) → (b!=0 : (b ≡ nonneg 0) → False) → (c : ℤ) → b ≡ (a *Z c) → (norm a) ≤N (norm b)
  normSize {nonneg a} {nonneg b} a!=0 b!=0 (nonneg zero) b=ac rewrite nonnegInjective b=ac | multiplicationNIsCommutative a 0 = exFalso (b!=0 refl)
  normSize {nonneg a} {nonneg b} a!=0 b!=0 (nonneg (succ 0)) b=ac rewrite nonnegInjective b=ac | multiplicationNIsCommutative a 1 = inr (equalityCommutative (Semiring.sumZeroRight ℕSemiring a))
  normSize {nonneg 0} {nonneg b} a!=0 b!=0 (nonneg (succ (succ c))) b=ac = exFalso (a!=0 refl)
  normSize {nonneg (succ a)} {nonneg (succ b)} a!=0 b!=0 (nonneg (succ (succ c))) b=ac rewrite nonnegInjective b=ac = multiplyIncreasesSucc a (succ c)
  normSize {nonneg 0} {nonneg b} a!=0 b!=0 (negSucc c) bad = exFalso (a!=0 refl)
  normSize {nonneg (succ a)} {nonneg b} a!=0 b!=0 (negSucc c) ()
  normSize {nonneg a} {negSucc b} a!=0 b!=0 (nonneg c) ()
  normSize {nonneg (succ a)} {negSucc b} a!=0 b!=0 (negSucc c) pr rewrite negSuccInjective pr = multiplyIncreasesSucc' a c
  normSize {negSucc a} {nonneg zero} _ b!=0 c pr = exFalso (b!=0 refl)
  normSize {negSucc a} {nonneg (succ b)} _ _ (nonneg zero) ()
  normSize {negSucc a} {nonneg (succ b)} _ _ (nonneg (succ x)) ()
  normSize {negSucc a} {nonneg (succ b)} _ _ (negSucc c) pr rewrite nonnegInjective pr = multiplyIncreasesSucc a c
  normSize {negSucc a} {negSucc b} _ _ (nonneg (succ c)) pr rewrite negSuccInjective pr | multiplicationNIsCommutative c a | Semiring.commutative ℕSemiring (a +N a *N c) c | Semiring.+Associative ℕSemiring c a (a *N c) | Semiring.commutative ℕSemiring c a | equalityCommutative (Semiring.+Associative ℕSemiring a c (a *N c)) | Semiring.commutative ℕSemiring a (c +N a *N c) = multiplyIncreasesSucc' a c

  divAlg : {a b : ℤ} → (a!=0 : (a ≡ nonneg 0) → False) → (b!=0 : (b ≡ nonneg 0) → False) → DivisionAlgorithmResult ℤRing norm' a!=0 b!=0
  divAlg {nonneg zero} {b} a!=0 b!=0 = exFalso (a!=0 refl)
  divAlg {nonneg (succ a)} {nonneg zero} a!=0 b!=0 = exFalso (b!=0 refl)
  divAlg {nonneg (succ a)} {nonneg (succ b)} a!=0 b!=0 with divisionAlg (succ b) (succ a)
  divAlg {nonneg (succ a)} {nonneg (succ b)} a!=0 b!=0 | record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } = record { quotient = nonneg quot ; rem = nonneg rem ; remSmall = u ; divAlg = transitivity (applyEquality nonneg (equalityCommutative pr)) t }
    where
      t : nonneg ((quot +N b *N quot) +N rem) ≡ nonneg (quot *N succ b) +Z nonneg rem
      t rewrite multiplicationNIsCommutative (succ b) quot = +Zinherits (quot *N succ b) rem
      u : (nonneg rem ≡ nonneg 0) || Sg ((nonneg rem ≡ nonneg 0) → False) (λ pr → rem <N succ b)
      u with TotalOrder.totality ℤOrder (nonneg 0) (nonneg rem)
      u | inl (inl 0<rem) = inr ((λ p → TotalOrder.irreflexive ℤOrder (TotalOrder.<WellDefined ℤOrder refl p 0<rem)) , remIsSmall)
      u | inr 0=rem rewrite 0=rem = inl refl
  divAlg {nonneg (succ a)} {negSucc b} _ _ with divisionAlg (succ b) (succ a)
  divAlg {nonneg (succ a)} {negSucc b} _ _ | record { quot = zero ; rem = rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = inl quotSmall } rewrite multiplicationNIsCommutative b 0 = record { quotient = nonneg 0 ; rem = nonneg rem ; remSmall = inr (p , remIsSmall) ; divAlg = applyEquality nonneg (equalityCommutative pr) }
    where
      p : (nonneg rem ≡ nonneg 0) → False
      p pr2 rewrite pr = naughtE (equalityCommutative (nonnegInjective pr2))
  divAlg {nonneg (succ a)} {negSucc b} _ _ | record { quot = succ quot ; rem = zero ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = inl quotSmall } = record { quotient = negSucc quot ; rem = nonneg zero ; remSmall = inl refl ; divAlg = applyEquality nonneg (transitivity (equalityCommutative pr) (applyEquality (λ i → i +N 0) (multiplicationNIsCommutative (succ b) (succ quot)))) }
  divAlg {nonneg (succ a)} {negSucc b} _ _ | record { quot = succ quot ; rem = succ rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = inl quotSmall } = record { quotient = negSucc quot ; rem = nonneg (succ rem) ; remSmall = inr ((λ ()) , remIsSmall) ; divAlg = applyEquality nonneg (transitivity (equalityCommutative pr) (applyEquality (λ i → i +N succ rem) (multiplicationNIsCommutative (succ b) (succ quot)))) }
  divAlg {negSucc a} {nonneg zero} _ b!=0 = exFalso (b!=0 refl)
  divAlg {negSucc a} {nonneg (succ b)} _ _ with divisionAlg (succ b) (succ a)
  divAlg {negSucc a} {nonneg (succ b)} _ _ | record { quot = zero ; rem = zero ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } = exFalso (naughtE (transitivity (equalityCommutative (transitivity (Semiring.sumZeroRight ℕSemiring _) (multiplicationNIsCommutative b 0))) pr))
  divAlg {negSucc a} {nonneg (succ b)} _ _ | record { quot = succ quot ; rem = zero ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } = record { quotient = negSucc quot ; rem = nonneg 0 ; remSmall = inl refl ; divAlg = applyEquality negSucc (succInjective (transitivity (equalityCommutative pr) t)) }
    where
      t : succ (quot +N b *N succ quot) +N 0 ≡ succ ((quot +N b *N quot) +N b)
      t rewrite Semiring.sumZeroRight ℕSemiring (succ (quot +N b *N succ quot)) | Semiring.commutative ℕSemiring (quot +N b *N quot) b | Semiring.+Associative ℕSemiring b quot (b *N quot) | Semiring.commutative ℕSemiring b quot | equalityCommutative (Semiring.+Associative ℕSemiring quot b (b *N quot)) | multiplicationNIsCommutative b (succ quot) | multiplicationNIsCommutative quot b = refl
  divAlg {negSucc a} {nonneg (succ b)} _ _ | record { quot = zero ; rem = succ rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } rewrite multiplicationNIsCommutative b 0 | equalityCommutative (succInjective pr) = record { quotient = nonneg zero ; rem = negSucc rem ; remSmall = inr (((λ ()) , remIsSmall)) ; divAlg = refl }
  divAlg {negSucc a} {nonneg (succ b)} _ _ | record { quot = succ quot ; rem = succ rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } = record { quotient = negSucc quot ; rem = negSucc rem ; remSmall = inr ((λ ()) , remIsSmall) ; divAlg = applyEquality negSucc (succInjective (transitivity (equalityCommutative pr) t)) }
    where
      t : succ b *N succ quot +N succ rem ≡ succ (succ (succ b *N quot +N b) +N rem)
      t rewrite Semiring.commutative ℕSemiring ((quot +N b *N quot) +N b) rem | Semiring.commutative ℕSemiring (succ rem) ((quot +N b *N quot) +N b) | multiplicationNIsCommutative b (succ quot) | equalityCommutative (Semiring.+Associative ℕSemiring quot (b *N quot) b) | Semiring.commutative ℕSemiring b (quot *N b) | multiplicationNIsCommutative b quot = refl
  divAlg {negSucc a} {negSucc b} _ _ with divisionAlg (succ b) (succ a)
  divAlg {negSucc a} {negSucc b} _ _ | record { quot = zero ; rem = zero ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } = exFalso (naughtE (transitivity (equalityCommutative (transitivity (Semiring.sumZeroRight ℕSemiring (b *N 0)) (multiplicationNIsCommutative b 0))) pr))
  divAlg {negSucc a} {negSucc b} _ _ | record { quot = zero ; rem = succ rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } rewrite multiplicationNIsCommutative b 0 | equalityCommutative (succInjective pr) = record { quotient = nonneg 0 ; rem = negSucc rem ; remSmall = inr ((λ ()) , remIsSmall) ; divAlg = refl }
  divAlg {negSucc a} {negSucc b} _ _ | record { quot = succ quot ; rem = zero ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } rewrite Semiring.sumZeroRight ℕSemiring (quot +N b *N succ quot) | Semiring.commutative ℕSemiring b (succ quot) = record { quotient = nonneg (succ quot) ; rem = nonneg 0 ; remSmall = inl refl ; divAlg = applyEquality negSucc (succInjective (transitivity (equalityCommutative pr) t)) }
    where
      t : succ (quot +N b *N succ quot) ≡ succ ((b +N quot *N b) +N quot)
      t rewrite Semiring.commutative ℕSemiring quot (b *N succ quot) | multiplicationNIsCommutative b (succ quot) = refl
  divAlg {negSucc a} {negSucc b} _ _ | record { quot = succ quot ; rem = succ rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = quotSmall } rewrite multiplicationNIsCommutative b (succ quot) | Semiring.commutative ℕSemiring quot (b +N quot *N b) | Semiring.commutative ℕSemiring ((b +N quot *N b) +N quot) (succ rem) | Semiring.commutative ℕSemiring rem ((b +N quot *N b) +N quot) = record { quotient = nonneg (succ quot) ; rem = negSucc rem ; remSmall = inr (((λ ()) , remIsSmall)) ; divAlg = applyEquality negSucc (equalityCommutative (succInjective pr)) }

ℤEuclideanDomain : EuclideanDomain ℤRing
EuclideanDomain.isIntegralDomain ℤEuclideanDomain = ℤIntDom
EuclideanDomain.norm ℤEuclideanDomain = norm'
EuclideanDomain.normSize ℤEuclideanDomain = normSize
EuclideanDomain.divisionAlg ℤEuclideanDomain {a} {b} a!=0 b!=0 = divAlg {a} {b} a!=0 b!=0


------------------------------------------------------------------------
-- The Agda standard library
--
-- Finite sets
------------------------------------------------------------------------

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

module Data.Fin where

------------------------------------------------------------------------
-- Publicly re-export the contents of the base module

open import Data.Fin.Base public

------------------------------------------------------------------------
-- Publicly re-export queries

open import Data.Fin.Properties public
  using (_≟_; _≤?_; _<?_)


import      Lvl
open import Type

module Type.Cardinality.Proofs {ℓₗ : Lvl.Level} where

open import Functional
import      Logic.Predicate
import      Logic.Predicate.Theorems
import      Relator.Equals
import      Relator.Equals.Proofs
import      Type.Cardinality
import      Type.Functions
import      Type.Functions.Proofs
import      Type.Functions.Inverse
import      Type.Functions.Inverse.Proofs

module _ {ℓₒ₁}{ℓₒ₂} {X : Type{ℓₒ₁}} {Y : Type{ℓₒ₂}} where
  open Logic.Predicate               {ℓₗ}
  open Logic.Predicate.Theorems      {ℓₗ}
  open Type.Cardinality              {ℓₗ}
  open Type.Functions                {ℓₗ}
  open Type.Functions.Inverse        {ℓₗ}
  open Type.Functions.Inverse.Proofs {ℓₗ}
  open Type.Functions.Proofs         {ℓₗ}

  instance
    [≍]-to-[≼] : ⦃ _ : X ≍ Y ⦄ → (X ≼ Y)
    [≍]-to-[≼] ⦃ proof ⦄ = [∃]-map (proof ↦ bijective-to-injective ⦃ proof ⦄) proof

  instance
    [≍]-to-[≽] : ⦃ _ : X ≍ Y ⦄ → (X ≼ Y)
    [≍]-to-[≽] ⦃ proof ⦄ = [∃]-map (proof ↦ bijective-to-injective ⦃ proof ⦄) proof

  [≍]-symmetry : (X ≍ Y) → (Y ≍ X)
  [≍]-symmetry ([∃]-intro f ⦃ proof ⦄) = [∃]-intro (inv f ⦃ proof ⦄) ⦃ inv-bijective {ℓₒ₁}{ℓₒ₂} {_}{_} {f} ⦃ proof ⦄ ⦄

  -- TODO: Is it possible to prove these?
  -- [≍]-antisymmetry : (X ≼ Y) → (X ≽ Y) → (X ≍ Y)
  -- [≍]-antisymmetry = [∃]-map ()

  -- [≼][≽]-swap : (X ≼ Y) → (Y ≽ X)
  -- [≽][≼]-swap : (X ≽ Y) → (Y ≼ X)

module _ {ℓₒ} {X : Type{ℓₒ}} where
  open Logic.Predicate          {ℓₗ Lvl.⊔ ℓₒ}
  open Logic.Predicate.Theorems {ℓₗ Lvl.⊔ ℓₒ}
  open Type.Cardinality         {ℓₗ Lvl.⊔ ℓₒ}
  open Type.Functions.Proofs     {ℓₗ Lvl.⊔ ℓₒ}

  instance
    [≍]-reflexivity : (X ≍ X)
    [≍]-reflexivity = [∃]-intro (id) ⦃ id-is-bijective ⦄

  instance
    [≼]-reflexivity : (X ≼ X)
    [≼]-reflexivity = [∃]-intro(id) ⦃ bijective-to-injective ⦃ id-is-bijective ⦄ ⦄

  instance
    [≽]-reflexivity : (X ≽ X)
    [≽]-reflexivity = [∃]-intro(id) ⦃ bijective-to-surjective ⦃ id-is-bijective ⦄ ⦄

module _ {ℓₒ} {X : Type{ℓₒ}} {Y : Type{ℓₒ}} where
  open Type.Cardinality {ℓₗ Lvl.⊔ ℓₒ}
  open Relator.Equals   {ℓₗ Lvl.⊔ ℓₒ}{Lvl.𝐒(ℓₒ)}

  [≡]-to-[≍] : (X ≡ Y) → (X ≍ Y)
  [≡]-to-[≍] [≡]-intro = [≍]-reflexivity


module Common.SumProperties where

open import Function as Fun
open import Data.Sum as Sum
open import Relation.Binary.PropositionalEquality as PE hiding ([_])
open ≡-Reasoning

copair-elimˡ : {A B C : Set} {f : A → C} {g : B → C} (x : A) →
               ([ f , g ]′ ) (inj₁ x) ≡ f x
copair-elimˡ x = refl

copair-elimʳ : {A B C : Set} {f : A → C} {g : B → C} (x : B) →
               ([ f , g ]′ ) (inj₂ x) ≡ g x
copair-elimʳ x = refl

copair-sum-map-merge : {A A' B B' C : Set}
                     {f₁ : A → A'} {f₂ : B → B'} {g₁ : A' → C} {g₂ : B' → C}
                     (x : A ⊎ B) →
                     ([ g₁ , g₂ ]′ ∘ Sum.map f₁ f₂) x ≡ [ g₁ ∘ f₁ , g₂ ∘ f₂ ]′ x
copair-sum-map-merge (inj₁ x) = refl
copair-sum-map-merge (inj₂ y) = refl

copair-cong : {A B C : Set} {f f' : A → C} {g : B → C}
              (p : (x : A) → f x ≡ f' x) →
              (x : A ⊎ B) →
              [ f , g ]′ x ≡ [ f' , g ]′ x
copair-cong {A} {B} {C} {f} {f'} {g} p (inj₁ x) =
  begin
    ([ f , g ]′ (inj₁ x))
  ≡⟨ refl ⟩
    f x
  ≡⟨ p x ⟩
    f' x
  ≡⟨ refl ⟩
    [ f' , g ]′ (inj₁ x)
  ∎
copair-cong p (inj₂ y) = refl

copair-distr : {A B C D : Set} {f : A → C} {g : B → C} {h : C → D}
              (x : A ⊎ B) →
              [ h ∘ f , h ∘ g ]′ x ≡ (h ∘ [ f , g ]′) x
copair-distr (inj₁ x) = refl
copair-distr (inj₂ y) = refl


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.Multivariate.Properties where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat renaming(_+_ to _+n_; _·_ to _·n_)
open import Cubical.Data.Vec
open import Cubical.Data.Vec.OperationsNat

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

open import Cubical.Algebra.Polynomials.Multivariate.Base

private variable
  ℓ ℓ' : Level

module Nth-Poly-structure (A' : CommRing ℓ) (n : ℕ) where

  private
    A = fst A'
    Ar = CommRing→Ring A'

  open CommRingStr (snd A')
  open RingTheory Ar

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

  poly-com-adv : (P Q R S : Poly A' n) →  ((P poly+ Q) poly+ (R poly+ S) ≡ (P poly+ R) poly+ (Q poly+ S))
  poly-com-adv P Q R S = ((P poly+ Q) poly+ (R poly+ S)  ≡⟨ poly+Assoc (P poly+ Q) R S ⟩
                         (((P poly+ Q) poly+ R) poly+ S) ≡⟨ cong (λ X → X poly+ S) (sym (poly+Assoc P Q R)) ⟩
                         ((P poly+ (Q poly+ R)) poly+ S) ≡⟨ cong (λ X → (P poly+ X) poly+ S) (poly+Comm Q R) ⟩
                         ((P poly+ (R poly+ Q)) poly+ S) ≡⟨ cong (λ X → X poly+ S) (poly+Assoc P R Q) ⟩
                         (((P poly+ R) poly+ Q) poly+ S) ≡⟨ sym (poly+Assoc (P poly+ R) Q S) ⟩
                         ((P poly+ R) poly+ (Q poly+ S)) ∎)

  poly+IdL : (P : Poly A' n) → 0P poly+ P ≡ P
  poly+IdL P = (poly+Comm 0P P) ∙ (poly+IdR P)

  polyInv : Poly A' n → Poly A' n
  polyInv = Poly-Rec-Set.f A' n (Poly A' n) trunc
            0P
            (λ v a → base v (- a))
            (λ PS RS → PS poly+ RS)
            poly+Assoc
            poly+IdR
            poly+Comm
            (λ v → base v (- 0r) ≡⟨ cong (base v) 0Selfinverse ⟩ base v 0r ≡⟨ base-0P v ⟩ 0P ∎)
            λ v a b → (base-poly+ v (- a) (- b)) ∙ (cong (base v) (-Dist a b))

  polyInvol : (P : Poly A' n) → polyInv (polyInv P) ≡ P
  polyInvol = Poly-Ind-Prop.f A' n (λ P → polyInv (polyInv P) ≡ P) (λ _ → trunc _ _)
              refl
              (λ v a → cong (base v) (-Idempotent a))
              λ {P Q} ind-P ind-Q → cong₂ _poly+_ ind-P ind-Q

  poly+InvR : (P : Poly A' n ) → P poly+ (polyInv P) ≡ 0P
  poly+InvR = Poly-Ind-Prop.f A' n (λ P → (P poly+ polyInv P) ≡ 0P) (λ _ → trunc _ _)
              (poly+IdR 0P)
              (λ v a → (base-poly+ v a (- a)) ∙ cong (base v) (+Rinv a) ∙ base-0P v)
              λ {P Q} ind-P ind-Q → ((P poly+ Q) poly+ ((polyInv P) poly+ (polyInv Q)))
                                              ≡⟨ poly-com-adv P Q (polyInv P) (polyInv Q) ⟩
                                     ((P poly+ polyInv P) poly+ (Q poly+ polyInv Q))
                                              ≡⟨ cong₂ _poly+_ ind-P ind-Q ⟩
                                     (0P poly+ 0P)
                                              ≡⟨ poly+IdR 0P ⟩
                                     0P ∎

  poly+InvL : (P  : Poly A' n) → (polyInv P) poly+ P ≡ 0P
  poly+InvL = Poly-Ind-Prop.f A' n _ (λ _ → trunc _ _)
              (poly+IdR 0P)
              (λ v a → (base-poly+ v (- a) a) ∙ cong (base v) (snd (+Inv a)) ∙ base-0P v)
              λ {U V} ind-U ind-V → poly-com-adv (polyInv U) (polyInv V) U V
                                     ∙ cong₂ _poly+_ ind-U ind-V
                                     ∙ poly+IdR 0P

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

  _poly*_ : Poly A' n → Poly A' n → Poly A' n
  _poly*_ = -- Induction Left Argument
            Poly-Rec-Set.f A' n (Poly A' n → Poly A' n)
            (λ f g p q i j Q → trunc (f Q) (g Q) (λ X → p X Q) (λ X → q X Q) i j )
            (λ Q    → 0P)
            (λ v a  → -- Induction Right Argument
                       Poly-Rec-Set.f A' n (Poly A' n) trunc
                       0P
                       (λ v' a' → base (v +n-vec v') (a · a'))
                       _poly+_
                       poly+Assoc
                       poly+IdR
                       poly+Comm
                       (λ v' → (cong (base (v +n-vec v')) (0RightAnnihilates a)) ∙ (base-0P (v +n-vec v')))
                       λ v' b c → (base-poly+ (v +n-vec v') (a · b) (a · c))
                                   ∙ (cong (base (v +n-vec v')) (sym (·Rdist+ a b c))))
                       -- End Right induction
            (λ PS QS Q → (PS Q) poly+ (QS Q) )
            (λ PS QS RS i Q → poly+Assoc (PS Q) (QS Q) (RS Q) i)
            (λ PS i Q       → poly+IdR (PS Q) i)
            (λ PS QS i Q    → poly+Comm (PS Q) (QS Q) i)
            (λ v    → funExt (
                             -- Induction Right Argument
                             Poly-Ind-Prop.f A' n _ (λ _ → trunc _ _)
                             refl
                             (λ v' a' → (cong (base (v +n-vec v')) (0LeftAnnihilates a')) ∙ (base-0P (v +n-vec v')))
                             λ {P Q} ind-P ind-Q → (cong₂ _poly+_ ind-P ind-Q) ∙ (poly+IdR 0P) ))
                             -- End Right Induction
            λ v a b → funExt (
                             -- Induction Right Argument
                             Poly-Ind-Prop.f A' n _ (λ _ → trunc _ _)
                             (poly+IdR 0P)
                             (λ v' c → (base-poly+ (v +n-vec v') (a · c) (b · c))
                                        ∙ (cong (base (v +n-vec v')) (sym (·Ldist+ a b c))))
                             λ {P Q} ind-P ind-Q → (poly-com-adv _ _ _ _) ∙ (cong₂ _poly+_ ind-P ind-Q))
                             -- End Right Induction
            -- End Left Induction

  poly*Assoc : (P Q R : Poly A' n) → P poly* (Q poly* R) ≡ (P poly* Q) poly* R
  poly*Assoc = Poly-Ind-Prop.f A' n _
                (λ P p q i Q R j → trunc (P poly* (Q poly* R)) ((P poly* Q) poly* R) (p Q R) (q Q R) i j)
                (λ _ _ → refl)
                (λ v a → Poly-Ind-Prop.f A' n _
                          (λ Q p q i R j → trunc (base v a poly* (Q poly* R)) ((base v a poly* Q) poly* R) (p R) (q R) i j)
                          (λ _ → refl)
                          (λ v' a' → Poly-Ind-Prop.f A' n _ (λ _ → trunc _ _)
                                      refl
                                      (λ v'' a'' → cong₂ base (+n-vec-assoc v v' v'') (·Assoc a a' a''))
                                      (λ {U V} ind-U ind-V → cong₂ _poly+_ ind-U ind-V))
                          (λ {U V} ind-U ind-V R → cong₂ _poly+_ (ind-U R) (ind-V R)))
                λ {U V} ind-U ind-V Q R → cong₂ _poly+_ (ind-U Q R) (ind-V Q R)

  poly*AnnihilL : (P : Poly A' n) → 0P poly* P ≡ 0P
  poly*AnnihilL P = refl

  poly*AnnihilR : (P : Poly A' n) → P poly* 0P ≡ 0P
  poly*AnnihilR = Poly-Ind-Prop.f A' n (λ P → (P poly* 0P) ≡ 0P) (λ _ → trunc _ _)
                           refl
                           (λ _ _ → refl)
                           λ {P Q} ind-P ind-Q → (cong₂ _poly+_ ind-P ind-Q) ∙ (poly+IdR 0P)

  1P : Poly A' n
  1P = base (replicate zero) 1r

  poly*IdR : (P : Poly A' n) → P poly* 1P ≡ P
  poly*IdR = Poly-Ind-Prop.f A' n (λ P → (P poly* 1P) ≡ P) (λ _ → trunc _ _)
              refl
              (λ v a → cong₂ base (+n-vec-rid v) (·Rid a))
              (λ {P Q} ind-P ind-Q → cong₂ _poly+_ ind-P ind-Q)

  poly*IdL : (P : Poly A' n) → 1P poly* P ≡ P
  poly*IdL = Poly-Ind-Prop.f A' n (λ P → (1P poly* P) ≡ P) (λ _ → trunc _ _)
              refl
              (λ v a → cong₂ base (+n-vec-lid v) (·Lid a))
              λ {P Q} ind-P ind-Q → cong₂ _poly+_ ind-P ind-Q

  poly*DistR : (P Q R : Poly A' n) → P poly* (Q poly+ R) ≡ (P poly* Q) poly+ (P poly* R)
  poly*DistR = Poly-Ind-Prop.f A' n _
               (λ P p q i Q R j → trunc (P poly* (Q poly+ R)) ((P poly* Q) poly+ (P poly* R)) (p Q R) (q Q R) i j)
               (λ _ _ → sym (poly+IdR 0P))
               (λ v a → λ Q R → refl)
               λ {U V} ind-U ind-V Q R → (cong₂ _poly+_ (ind-U Q R) (ind-V Q R)) ∙ poly-com-adv (U poly* Q) (U poly* R) (V poly* Q) (V poly* R)

  poly*DistL : (P Q R : Poly A' n) → (P poly+ Q) poly* R ≡ (P poly* R) poly+ (Q poly* R)
  poly*DistL P Q R = refl

  poly*Comm : (P Q : Poly A' n) → P poly* Q ≡ Q poly* P
  poly*Comm = Poly-Ind-Prop.f A' n _
              (λ P p q i Q j → trunc (P poly* Q) (Q poly* P) (p Q) (q Q) i j)
              (λ Q → sym (poly*AnnihilR Q))
              (λ v a → Poly-Ind-Prop.f A' n _ (λ _ → trunc _ _)
                        refl
                        (λ v' a' → cong₂ base (+n-vec-comm v v') (·Comm a a'))
                        (λ {U V} ind-U ind-V → cong₂ _poly+_ ind-U ind-V))
              λ {U V} ind-U ind-V Q → ((cong₂ _poly+_ (ind-U Q) (ind-V Q)) ∙ sym (poly*DistR Q U V))


module SingleSorted.Example where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open import Data.Product using (_×_; proj₁; proj₂; <_,_>; ∃; ∃-syntax; _,_)
import Function using (_∘_)
open import SingleSorted.AlgebraicTheory
open import Categories.Category.Instance.Sets
open import Categories.Category.Cartesian
open import Agda.Primitive
open import Categories.Category

module Sets₀ where
  𝒮 : Category (lsuc lzero) lzero lzero
  𝒮 = Sets lzero

open Sets₀
open Category 𝒮

-- Function extensionality
postulate
  funext : ∀ {X : Set} {Y : X → Set} {f g : ∀ (x : X) → (Y x)} → (∀ (x : X) → ((f x) ≡ (g x))) → (f ≡ g)

record singleton : Set where
  constructor ⋆

η-singleton : ∀ (x : singleton) → ⋆ ≡ x
η-singleton ⋆ = refl

prod-elem-structure : ∀ {A B : Set} {x : A × B} → ∃[ a ] ∃[ b ] (a , b) ≡ x
prod-elem-structure {A} {B} {x} = proj₁ x Data.Product., (proj₂ x) , refl

first-factor :  ∀ {X A B : Obj} {f : X ⇒ A} {g : X ⇒ B} → proj₁ ∘ < f , g > ≡ f
first-factor {X} {A} {B} {f} {g} = funext λ x → refl

second-factor : ∀ {X A B : Obj} {f : X ⇒ A} {g : X ⇒ B} → proj₂ ∘ < f , g > ≡ g
second-factor {X} {A} {B} {f} {g} = funext λ{ x → refl}

unique-map-into-product : ∀ {X A B : Set} {h : X → A × B} {f : X → A} {g : X → B}  {x : X}
  → (proj₁ ∘ h) x ≡ f x
  → (proj₂ ∘ h) x ≡ g x
  --------------------
  → < f , g > x ≡ h x
unique-map-into-product {X} {A} {B} {h} {f} {g} {x} eq1 eq2
  rewrite first-factor {X} {A} {B} {f} {g} | second-factor {X} {A} {B} {f} {g}
  = {!!}

cartesian-Sets : Cartesian 𝒮
cartesian-Sets =
  record
    { terminal = record
                 { ⊤ = singleton
                 ; ⊤-is-terminal = record
                                   { ! = λ{ x → ⋆}
                                   ; !-unique = λ{ f {x} → η-singleton (f x)}
                                   }
                 }
    ; products = record
                 { product = λ {A} {B} →
                           record
                           { A×B = A × B
                           ; π₁ = proj₁
                           ; π₂ = proj₂
                           ; ⟨_,_⟩ = <_,_>
                           ; project₁ = λ{ → refl}
                           ; project₂ = λ{ → refl}
                           ; unique = λ{ {X} {h} {f} {g} eq1 eq2 {x} → {!!}}
                           }

                 }
    }


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.BinNat where

open import Cubical.Data.BinNat.BinNat public


module Category.Choice where
open import Data.Sum using (_⊎_)
open import Agda.Primitive using (Level; _⊔_; lsuc)
open import Category.Profunctor

record ChoiceImp {a b : Level} (p : Set a → Set a → Set b) : Set (lsuc (a ⊔ b)) where
  field
    isProfunctor : ProfunctorImp p
    left' : ∀ {x y z : Set a} → p x y → p (x ⊎ z) (y ⊎ z)
    right' : ∀ {x y z : Set a} → p x y → p (z ⊎ x) (z ⊎ y)

module Choice {a b : Level} {p : Set a → Set a → Set b} (isChoice : ChoiceImp p) where
  left : ∀ {x y z : Set a} → p x y → p (x ⊎ z) (y ⊎ z)
  left = ChoiceImp.left' isChoice
  right : ∀ {x y z : Set a} → p x y → p (z ⊎ x) (z ⊎ y)
  right = ChoiceImp.right' isChoice
  open Profunctor (ChoiceImp.isProfunctor isChoice)


module cry.ec where

open import Level
open import Relation.Nullary
open import Agda.Builtin.Bool
open import Agda.Builtin.Nat using () renaming (Nat to ℕ)
open import Agda.Builtin.List

open import cry.gfp

infixr 4 _,_
infixr 2 _×_

record _×_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B

open _×_ public

-- EC: group of points of elliptic curve (in jacobian coordinates, without conversion to affine)

module ec {c ℓ} (gfp : RawField c ℓ) (a b : RawField.Carrier gfp) where
  module F = RawField gfp
  open F renaming (Carrier to 𝔽; _≈_ to _=F_; _≈?_ to _≟F_)

  record Point : Set c where
    constructor _∶_∶_
    field
      x y z : 𝔽

  is-point : Point → Bool
  -- (y/z³) ² ≡ (x/z²) ³ + a * (x/z²) + b
  is-point (x ∶ y ∶ z) =
    let
      y² = y ²
      x² = x ²
      x³ = x² * x
      z² = z ²
      z⁴ = z² ²
      z⁶ = z² * z⁴
      xz⁴ = x * z⁴
      axz⁴ = a * xz⁴
      bz⁶ = b * z⁶
      x³+axz⁴ = x³ + axz⁴
      x³+axz⁴+bz⁶ = x³+axz⁴ + bz⁶
    in y² F.?≈ x³+axz⁴+bz⁶

  aff : Point → Point
  aff (x ∶ y ∶ z) = x′ ∶ y′ ∶ 1# where
    z⁻¹ = z ⁻¹
    z⁻² = z⁻¹ ²
    z⁻³ = z⁻² * z⁻¹
    x′ = x * z⁻²
    y′ = y * z⁻³

  _==_ : Point → Point → Set _
  (x₁ ∶ y₁ ∶ z₁) == (x₂ ∶ y₂ ∶ z₂)
  -- p₁ == p₂ with norm2 p₁ p₂
  -- ... | (x₁z₂² , x₂z₁²) , (y₁z₂³ , y₂z₁³)
    = x₁z₂² =F x₂z₁² × y₁z₂³ =F y₂z₁³ where
    {-
    x₁/z₁² ≡ x₂/z₂²
    y₁/z₁³ ≡ y₂/z₂³
    -}
    z₂² = z₂ ²
    z₁² = z₁ ²
    x₁z₂² = x₁ * z₂²
    x₂z₁² = x₂ * z₁²
    z₂³ = z₂ * z₂²
    z₁³ = z₁ * z₁²
    y₁z₂³ = y₁ * z₂³
    y₂z₁³ = y₂ * z₁³

  _≟_ : (p₁ p₂ : Point) → Dec (p₁ == p₂)
  (x₁ ∶ y₁ ∶ z₁) ≟ (x₂ ∶ y₂ ∶ z₂) = r where
    z₂² = z₂ ²
    z₁² = z₁ ²
    x₁z₂² = x₁ * z₂²
    x₂z₁² = x₂ * z₁²
    z₂³ = z₂ * z₂²
    z₁³ = z₁ * z₁²
    y₁z₂³ = y₁ * z₂³
    y₂z₁³ = y₂ * z₁³
    r : _
    r with x₁z₂² ≟F x₂z₁²
    ... | no x₁≠x₂ = no (λ p₁=p₂ → x₁≠x₂ (proj₁ p₁=p₂))
    ... | yes x₁=x₂ with y₁z₂³ ≟F y₂z₁³
    ... | no y₁≠y₂ = no (λ p₁=p₂ → y₁≠y₂ (proj₂ p₁=p₂))
    ... | yes y₁=y₂ = yes (x₁=x₂ , y₁=y₂)

  is-𝕆 : Point → Set _
  is-𝕆 (_ ∶ _ ∶ z) = z =F 0#
  {-
  x₃ = λ² − x₁ − x₂
  y₃ = λ(x₁ − x₃) − y₁
  λ = (y₂ - y₁) / (x₂ - x₁), p₁ ≠ p₂
  λ = (3 x₁ ² + a) / (2 y₁), p₁ = p₂

  (x/z²)₃ = λ² − (x/z²)₁ − (x/z²)₂
  (y/z³)₃ = λ((x/z²)₁ − (x/z²)₃) − (y/z³)₁
  λ = ((y/z³)₂ - (y/z³)₁) / ((x/z²)₂ - (x/z²)₁), p₁ ≠ p₂
  λ = (3 (x/z²)₁ ² + a) / (2 (y/z³)₁), p₁ = p₂

  x₃/z₃² z₁² z₂² = λ² z₁² z₂² − x₁ z₂² − x₂ z₁²
  y₁/z₁³ + y₃/z₃³ = λ(x₁/z₁² − (x₃/z₃²))
  y₂/z₂³ + y₃/z₃³ = λ(x₂/z₂² − (x₃/z₃²))
  λ z₁ z₂ (x₂ z₁² - x₁ z₂²) = (y₂ z₁³ - y₁ z₂³), p₁ ≠ p₂
  λ = (3 (x/z²)₁ ² + a) / (2 (y/z³)₁), p₁ = p₂

  p₁ ≠ p₂:
  z₃ = z₁ z₂ (x₂ z₁² - x₁ z₂²)
  λ z₃ = (y₂ z₁³ - y₁ z₂³)
  x₃ = (y₂ z₁³ - y₁ z₂³)² − (x₁ z₂² + x₂ z₁²) (x₂ z₁² - x₁ z₂²)²
  y₃ z₁³ = (y₂ z₁³ - y₁ z₂³) (z₃² x₁ − x₃ z₁²) z₁ − y₁ z₃³

  (y₁ z₃³ + y₃ z₁³)/(y₂ z₁³ - y₁ z₂³) = (x₁ z₃² − x₃ z₁²) z₁
  (y₂ z₃³ + y₃ z₂³)/(y₂ z₁³ - y₁ z₂³) = (x₂ z₃² − x₃ z₂²) z₂

  x₁ z₃² − x₃ z₁² =
     x₁ (z₁ z₂ (x₂ z₁² - x₁ z₂²))² -
     (y₂ z₁³ - y₁ z₂³)² z₁² +
     ((x₂ z₁²)² - (x₁ z₂²)²) (x₂ z₁² - x₁ z₂²) z₁²
  = x₁ z₁² z₂² ((x₂ z₁²)² - 2 x₂ z₁² x₁ z₂² + (x₁ z₂²)²)
    + ((x₂ z₁²)³ - (x₂ z₁²)² x₁ z₂² - (x₁ z₂²)² x₂ z₁² + (x₁ z₂²)³) z₁²
    - (y₂ z₁³ - y₁ z₂³)² z₁²
  = (- (y₂ z₁³ - y₁ z₂³)²
    + 2 x₁³ z₂⁶ + x₂³ z₁⁶ + x₁² x₂ (-3 z₁² z₂⁴)) z₁²

  (y₁ z₃³ + y₃ z₁³) = (y₂ z₁³ - y₁ z₂³) (- (y₂ z₁³ - y₁ z₂³)²
    + 2 x₁³ z₂⁶ + x₂³ z₁⁶ + x₁² x₂ (-3 z₁² z₂⁴)) z₁³
  -}

  𝕆 : Point
  𝕆 = (1# ∶ 1# ∶ 0#)

  dbl : Point → Point
  dbl (x₁ ∶ y₁ ∶ z₁) = (x₃ ∶ y₃ ∶ z₃) where
    {- p₁ = p₂
    x₃ = λ² − x₁ − x₁
    y₃ = λ(x₁ − x₃) − y₁
    λ = (3 x₁ ² + a) / (2 y₁)

    x₃ = λ² z₃² − 2 x₁/z₁² z₃²
    y₃/z₃³ = λ(x₁/z₁² − x₃/z₃²) − y₁/z₁³
    λ = (3 (x₁/z₁²) ² + a) / (2 y₁/z₁³)

    λ 2 y₁ z₁ = 3 x₁² + a z₁⁴
    z₃ = 2 y₁ z₁
    x₃ = (3 x₁² + a z₁⁴)² − 2 x₁ (2 y₁)²

    y₃ = (3 x₁² + a z₁⁴) (x₁ (2 y₁)² − x₃) − y₁ (2 y₁)³
    -}
    2y₁ = y₁ + y₁
    z₃ = 2y₁ * z₁

    x₁² = x₁ ²
    2x₁² = x₁² + x₁²
    3x₁² = 2x₁² + x₁²
    z₁² = z₁ ²
    z₁⁴ = z₁² ²
    az₁⁴ = a * z₁⁴
    3x₁²+az₁⁴ = 3x₁² + az₁⁴
    [3x₁²+az₁⁴]² = 3x₁²+az₁⁴ ²
    y₁² = y₁ ²
    2y₁² = y₁² + y₁²
    4y₁² = 2y₁² + 2y₁²
    x₁[2y₁]² = x₁ * 4y₁²
    2x₁[2y₁]² = x₁[2y₁]² + x₁[2y₁]²
    x₃ = [3x₁²+az₁⁴]² - 2x₁[2y₁]²

    4y₁⁴ = 2y₁² ²
    8y₁⁴ = 4y₁⁴ + 4y₁⁴
    x₁[2y₁]²-x₃ = x₁[2y₁]² - x₃
    [3x₁²+az₁⁴][x₁[2y₁]²-x₃] = 3x₁²+az₁⁴ * x₁[2y₁]²-x₃
    y₃ = [3x₁²+az₁⁴][x₁[2y₁]²-x₃] - 8y₁⁴

  add : Point → Point → Point
  add (x₁ ∶ y₁ ∶ z₁) (x₂ ∶ y₂ ∶ z₂) = x₃ ∶ y₃ ∶ z₃ where
    {- p₁ ≠ p₂
    x₃ = λ² − x₁ − x₂
    y₃ = λ(x₁ − x₃) − y₁
    λ = (y₂ - y₁) / (x₂ - x₁)

    (x/z²)₃ = λ² − (x/z²)₁ − (x/z²)₂
    (y/z³)₃ = λ((x/z²)₁ − (x/z²)₃) − (y/z³)₁
    λ = ((y/z³)₂ - (y/z³)₁) / ((x/z²)₂ - (x/z²)₁)

    λ z₁ z₂ (x₂ z₁² - x₁ z₂²) = (y₂ z₁³ - y₁ z₂³)
    x₃/z₃² z₁² z₂² + x₁ z₂² + x₂ z₁² = λ² z₁² z₂²
    y₃/z₃³ = λ(x₁/z₁² − x₃/z₃²) − y₁/z₁³

    z₃ = z₁ z₂ (x₂ z₁² - x₁ z₂²)
    x₃ = (y₂ z₁³ - y₁ z₂³)² - (x₁ z₂² + x₂ z₁²) (x₂ z₁² - x₁ z₂²)²
    y₃ = (y₂ z₁³ - y₁ z₂³) (x₁ z₂² (x₂ z₁² - x₁ z₂²)² − x₃) − y₁ z₂³ (x₂ z₁² - x₁ z₂²)³
    y₃ = (y₂ z₁³ - y₁ z₂³) ((x₁ z₂²+x₂ z₁²)/2 (x₂ z₁² - x₁ z₂²)² − x₃)
       − (x₂ z₁² - x₁ z₂²)³ (y₁ z₂³ + y₂ z₁³)/2
    -}

    z₁z₂ = z₁ * z₂
    z₁² = z₁ ²
    z₂² = z₂ ²
    x₁z₂² = x₁ * z₂²
    x₂z₁² = x₂ * z₁²
    z₂³ = z₂ * z₂²
    z₁³ = z₁ * z₁²
    y₁z₂³ = y₁ * z₂³
    y₂z₁³ = y₂ * z₁³
    x₂z₁²+x₁z₂² = x₂z₁² + x₁z₂²
    x₂z₁²-x₁z₂² = x₂z₁² - x₁z₂²
    y₂z₁³-y₁z₂³ = y₂z₁³ - y₁z₂³

    z₃ = z₁z₂ * x₂z₁²-x₁z₂²

    [x₂z₁²-x₁z₂²]² = x₂z₁²-x₁z₂² ²
    [y₂z₁³-y₁z₂³]² = y₂z₁³-y₁z₂³ ²
    [x₂z₁²+x₁z₂²][x₂z₁²-x₁z₂²]² = x₂z₁²+x₁z₂² * [x₂z₁²-x₁z₂²]²
    x₃ = [y₂z₁³-y₁z₂³]² - [x₂z₁²+x₁z₂²][x₂z₁²-x₁z₂²]²

    [x₂z₁²-x₁z₂²]³ = x₂z₁²-x₁z₂² * [x₂z₁²-x₁z₂²]²
    y₁z₂³[x₂z₁²-x₁z₂²]³ = y₁z₂³ * [x₂z₁²-x₁z₂²]³
    x₁z₂²[x₂z₁²-x₁z₂²]² = x₁z₂² * [x₂z₁²-x₁z₂²]²
    x₁z₂²[x₂z₁²-x₁z₂²]²-x₃ = x₁z₂²[x₂z₁²-x₁z₂²]² - x₃
    [y₂z₁³-y₁z₂³][x₁z₂²[x₂z₁²-x₁z₂²]²-x₃] = y₂z₁³-y₁z₂³ * x₁z₂²[x₂z₁²-x₁z₂²]²-x₃
    y₃ = [y₂z₁³-y₁z₂³][x₁z₂²[x₂z₁²-x₁z₂²]²-x₃] - y₁z₂³[x₂z₁²-x₁z₂²]³

  dblAdd : Point → ℕ → Point
  dblAdd = times 𝕆 dbl add

module test-ec where
  g = cry.gfp.gfp 7

  open RawField g renaming (Carrier to 𝔽) public

  a b : 𝔽
  a = 4
  b = 1

  xₚ yₚ zₚ : 𝔽
  xₚ = 4
  yₚ = 2
  zₚ = 1

  open ec g a b public
  P 2P : Point
  P = (xₚ ∶ yₚ ∶ zₚ)
  2P = dbl P


module Issue802b where

data I : Set where
  i : I

f : I → I
f i = i

mutual

  data P : I → Set where
    p : (x : I) → Q x x → P (f x)

  Q : I → I → Set
  Q i = P

g : (x y : I) → Q x y → P y
g i _ q = q

data R : (x : I) → P x → Set where
  r : (x : I) (q : Q x x) → R _ (g x _ q) → R (f x) (p x q)


module MJ.Examples.While where

open import MJ.Examples.Integer

open import Prelude
open import MJ.Types
open import MJ.Classtable.Code Σ
open import MJ.Syntax Σ
open import MJ.Syntax.Program Σ
open import MJ.Semantics Σ Lib
open import MJ.Semantics.Values Σ
open import Data.List.Any
open import Data.List.Membership.Propositional
open import Data.Star
open import Data.Bool as Bools hiding (_≤?_)
open import Relation.Nullary.Decidable

-- a simple program that computes 10 using a while loop
p₁ : Prog int
p₁ = Lib ,
  let
    x = (here refl)
  in body
    (
        loc int
      ◅ asgn x (num 1)
      ◅ while iop (λ x y → Bools.if ⌊ suc x ≤? y ⌋ then 0 else 1) (var x) (num 10) run (
        asgn x (iop (λ x y → x + y) (var x) (num 1))
      )
      -- test simplest if-then-else and early return from statement
      ◅ if (num 0) then (ret (var x)) else (ret (num 0))
      ◅ ε
    )
    (num 0)

test1 : p₁ ⇓⟨ 100 ⟩ (λ {W} (v : Val W int) → v ≡ num 10)
test1 = refl


-- Andreas, 2014-12-02, issue reported by Jesper Cockx

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

subst : ∀ (A : Set)(P : A → Set)(x y : A) → x ≡ y → P x → P y
subst A P x .x refl t = t

mutual
  Type : Set
  postulate
    type : Type
    Term : Type → Set

  Type = Term type

mutual
  weakenType : Type → Type → Type
  weaken : (ty ty' : Type) → Term ty → Term (weakenType ty' ty)

  weakenType ty ty' =
    let X : Type
        X = {!!}
    in  subst Type Term (weakenType X type) type {!!} (weaken type X ty)
  weaken ty ty' t = {!!}

data Test : Type → Set where
  test : Test (weakenType type type)

-- Checking the constructor declaration was looping
-- should work now.


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

module Data.Binary.Conversion.Fast where

-- This module provides a conversion function from
-- nats which uses built-in functions.
-- It is dramatically faster than the normal conversion
-- even at smaller numbers.

open import Data.Binary.Definition
open import Data.Nat.DivMod
open import Data.Nat.Base
open import Data.Bool

⟦_⇑⟧⟨_⟩ : ℕ → ℕ → 𝔹
⟦ suc n ⇑⟧⟨ suc w ⟩ =
  if even n
    then 1ᵇ ⟦ n ÷ 2 ⇑⟧⟨ w ⟩
    else 2ᵇ ⟦ n ÷ 2 ⇑⟧⟨ w ⟩
⟦ zero  ⇑⟧⟨ _    ⟩ = 0ᵇ
⟦ suc _ ⇑⟧⟨ zero ⟩ = 0ᵇ -- will not happen

-- We build the output by repeatedly halving the input,
-- but we also pass in the number to reduce as we go so that
-- we satisfy the termination checker.
⟦_⇑⟧ : ℕ → 𝔹
⟦ n ⇑⟧ = ⟦ n ⇑⟧⟨ n ⟩
{-# INLINE ⟦_⇑⟧ #-}

-- Without the added argument to the recursor, the function does not
-- pass the termination checker:
-- {-# TERMINATING #-}
-- ⟦_⇑⟧″ : ℕ → 𝔹
-- ⟦ zero  ⇑⟧″ = 0ᵇ
-- ⟦ suc n ⇑⟧″ =
--   if rem n 2 ℕ.≡ᴮ 0
--   then 1ᵇ ⟦ n ÷ 2 ⇑⟧″
--   else 2ᵇ ⟦ n ÷ 2 ⇑⟧″

-- The "principled" version (which uses well-founded recursion) is
-- incredibly slow. (and the following doesn't even compute, because of
-- cubical)

-- open import Data.Nat.WellFounded

-- ⟦_⇑⟧‴ : ℕ → 𝔹
-- ⟦ n ⇑⟧‴ = go n (≤-wellFounded n)
--   where
--   go : ∀ n → Acc _<_ n → 𝔹
--   go zero    wf = 0ᵇ
--   go (suc n) (acc wf) =
--     if rem n 2 ℕ.≡ᴮ 0
--     then 1ᵇ go (n ÷ 2) (wf (n ÷ 2) (s≤s (div2≤ n)))
--     else 2ᵇ go (n ÷ 2) (wf (n ÷ 2) (s≤s (div2≤ n)))


{-# OPTIONS --type-in-type #-}
module dyn.fib where
open import prelude
open import functors
open import prelude.Stream using (take)
open import prelude.io
open import dyn

fib : Dyn
fib =  (plus   ⊠⊠⊠ delay ℕ) ⟫
    λ  (   f    ,     f₋  ) → f₋ , λ (.tt)
    → ((f₋ , f) ,     f   )
    where plus = fun→dyn (uncurry _ℕ+_)

main : IO ⊤
main = printStream (run fib auto (1 , 1))


open import Algebra using (CommutativeRing)

module AKS.Polynomial {c ℓ} (R : CommutativeRing c ℓ) where

open import AKS.Polynomial.Properties R public


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

module Categories.Adjoint.Instance.StrictCore where

-- The adjunction between the forgetful functor from (strict) Cats to
-- (strict) Groupoids and the (strict) Core functor.

open import Data.Product
open import Level using (_⊔_)
import Function
open import Relation.Binary using (IsEquivalence)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open import Categories.Adjoint
open import Categories.Category using (Category)
open import Categories.Category.Groupoid using (Groupoid)
import Categories.Category.Construction.Core as C
open import Categories.Category.Instance.StrictCats
open import Categories.Category.Instance.StrictGroupoids
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Equivalence
open import Categories.Functor.Instance.StrictCore
import Categories.Morphism as Morphism
import Categories.Morphism.Reasoning as MR
open import Categories.Morphism.IsoEquiv using (⌞_⌟; _≃_)

-- The forgetful functor from StrictGroupoids to StrictCats

Forgetful : ∀ {o ℓ e} → Functor (Groupoids o ℓ e) (Cats o ℓ e)
Forgetful {o} {ℓ} {e} = record
  { F₀ = Groupoid.category
  ; F₁ = Function.id
  ; identity     = λ {G} → Groupoids.Equiv.refl {G} {G} {idF}
  ; homomorphism = λ {G H K F H} → Groupoids.Equiv.refl {G} {K} {H ∘F F}
  ; F-resp-≈     = Function.id
  }
  where
    module Groupoids = Category (Groupoids o ℓ e)

-- Core is right-adjoint to the forgetful functor from Groupoids to
-- Cats

CoreAdj : ∀ {o ℓ e} → Forgetful {o} {ℓ ⊔ e} {e} ⊣ Core
CoreAdj = record
  { unit   = record { η = unit   ; commute = λ {G H} F → unit-commute {G} {H} F ; sym-commute = λ {G H} F → unit-sym-commute {G} {H} F }
  ; counit = record { η = counit ; commute = counit-commute                     ; sym-commute = counit-sym-commute }
  ; zig    = λ {G} → zig {G}
  ; zag    = zag
  }
  where
    open Groupoid using (category)
    module Core = Functor Core

    unit : ∀ G → Functor (category G) (C.Core (category G))
    unit G = record
      { F₀ = Function.id
      ; F₁ = λ f → record { from = f ; to = f ⁻¹ ; iso = iso }
      ; identity     = ⌞ Equiv.refl ⌟
      ; homomorphism = ⌞ Equiv.refl ⌟
      ; F-resp-≈     = ⌞_⌟
      }
      where open Groupoid G

    unit-commute : ∀ {G H} (F : Functor (category G) (category H)) →
                   unit H ∘F F ≡F Core.F₁ F ∘F unit G
    unit-commute {_} {H} F = record
      { eq₀ = λ _ → refl
      ; eq₁ = λ _ → ⌞ MR.id-comm-sym (category H) ⌟
      }

    unit-sym-commute : ∀ {G H} (F : Functor (category G) (category H)) →
                       Core.F₁ F ∘F unit G ≡F unit H ∘F F
    unit-sym-commute {_} {H} F = record
      { eq₀ = λ _ → refl
      ; eq₁ = λ _ → ⌞ MR.id-comm-sym (category H) ⌟
      }

    counit : ∀ C → Functor (C.Core C) C
    counit C = record
      { F₀ = Function.id
      ; F₁ = _≅_.from
      ; identity     = Equiv.refl
      ; homomorphism = Equiv.refl
      ; F-resp-≈     = _≃_.from-≈
      }
      where
        open Category C
        open Morphism C

    counit-commute : ∀ {C D} (F : Functor C D) →
                     counit D ∘F Core.F₁ F ≡F F ∘F counit C
    counit-commute {C} {D} F = record
      { eq₀ = λ _ → refl
      ; eq₁ = λ _ → MR.id-comm-sym D
      }

    counit-sym-commute : ∀ {C D} (F : Functor C D) →
                         F ∘F counit C ≡F counit D ∘F Core.F₁ F
    counit-sym-commute {C} {D} F = record
      { eq₀ = λ _ → refl
      ; eq₁ = λ _ → MR.id-comm-sym D
      }

    zig : ∀ {G} → counit (category G) ∘F unit G ≡F idF
    zig {G} = record
      { eq₀ = λ _ → refl
      ; eq₁ = λ _ → MR.id-comm-sym (category G)
      }

    zag : ∀ {B} → Core.F₁ (counit B) ∘F unit (Core.F₀ B) ≡F idF
    zag {B} = record { eq₀ = λ _ → refl ; eq₁ = λ _ → ⌞ MR.id-comm-sym B ⌟ }


-- Jesper, 2017-01-24: if we allow a variable to be instantiated with a value
-- of a supertype, the resulting dot pattern won't be type-correct.

open import Common.Size

data D (i : Size) : (j : Size< ↑ i) → Set where

  c : ∀ (j : Size< ↑ i) (k : Size< ↑ j)
       → D i j
       → D j k
       → D i k

split : ∀ i (j : Size< ↑ i) → D i j → Set
split i j x = {!x!}  -- split on x

-- Expected: splitting on x succeeds with
--   split i .k (c j₁ k x x₁) = {!!}


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

test : (p : Bool × Bool) → proj₁ p ≡ true → Set
test _ e = {!e!}

-- WAS:
-- Splitting on e gives
-- test r refl = ?
-- proj₁ r != true of type Bool
-- when checking that the pattern refl has type proj₁ r ≡ true


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

open import Cubical.Data.Int.Base
open import Cubical.Data.Nat.Base
open import Cubical.Data.Sigma

open import Cubical.Foundations.Pointed.Base

open import Cubical.HITs.Nullification.Base
open import Cubical.HITs.SetTruncation.Base
open import Cubical.HITs.Sn.Base
open import Cubical.HITs.S1.Base
open import Cubical.HITs.Susp.Base
open import Cubical.HITs.Truncation.Base

private
  variable
    ℓ : Level
    A : Type ℓ

--- Cohomology ---

{- EM-spaces Kₙ from Brunerie 2016 -}
coHomK : (n : ℕ) → Type₀
coHomK zero = Int
coHomK (suc n) = ∥ S₊ (suc n) ∥ (2 + suc n)

{- Cohomology -}
coHom : (n : ℕ) → Type ℓ → Type ℓ
coHom n A = ∥ (A → coHomK n) ∥₂

--- Reduced cohomology ---

coHom-pt : (n : ℕ) → coHomK n
coHom-pt 0 = 0
coHom-pt 1 = ∣ base ∣
coHom-pt (suc (suc n)) = ∣ north ∣

{- Pointed version of Kₙ  -}
coHomK-ptd : (n : ℕ) → Pointed (ℓ-zero)
coHomK-ptd n = coHomK n , coHom-pt n

{- Reduced cohomology -}
coHomRed : (n : ℕ) → (A : Pointed ℓ) → Type ℓ
coHomRed n A = ∥ A →∙ coHomK-ptd n ∥₂


{-# OPTIONS --cubical #-}

module Type.Cubical.Equiv where

import      Lvl
open import Type.Cubical
open import Type.Cubical.Path.Equality
import      Type.Equiv as Type
open import Type

private variable ℓ₁ ℓ₂ : Lvl.Level

-- `Type.Equiv._≍_` specialized to Path.
_≍_ : (A : Type{ℓ₁}) → (B : Type{ℓ₂}) → Type
A ≍ B = A Type.≍ B
{-# BUILTIN EQUIV _≍_ #-}

instance
  [≍]-reflexivity = \{ℓ} → Type.[≍]-reflexivity {ℓ} ⦃ Path-equiv ⦄

instance
  [≍]-symmetry = \{ℓ} → Type.[≍]-symmetry {ℓ} ⦃ Path-equiv ⦄

instance
  [≍]-transitivity = \{ℓ} → Type.[≍]-transitivity {ℓ} ⦃ Path-equiv ⦄ ⦃ Path-congruence₁ ⦄

instance
  [≍]-equivalence = \{ℓ} → Type.[≍]-equivalence {ℓ} ⦃ Path-equiv ⦄ ⦃ Path-congruence₁ ⦄


open import Agda.Primitive
open import Data.List
-- f1 : {l : Level} -> (a : Set l) -> (x : a) -> (y : x) -> x
-- f1 : (a : Set2) -> (x : a) -> (y : x) -> x
-- f1 a x y = ?

f0 : (a : Set) -> (x : a) -> a
f0 a x = x

f1 : (a : Set1) -> (x : a) -> a
f1 a x = x

myprod : (As : List Set) -> Set
myprod = {!!}

mysum : (As : List Set) -> Set
mysum = {!!}

hej : (tyOp : List Set -> Set) -> Set
hej = {!!}

test1 = hej myprod
test2 = hej mysum

Type = Set

data Dummy : Set where Dum : Dummy

-- Start of example

hej2 : List Type -> Type     -- Is universe-monomorphic in Agda, but polymorphic in Idris
hej2 (t ∷ ts) = t
hej2 _ = ?

test21 : Type
test21 = hej2 [ Type ]  -- test21 == Type in Idris, but Agda complains

test22 : Type
test22 = hej2 [ Dummy ]   -- test22 == Dummy


module Sized.ConsoleExample where

open import SizedIO.Base
open import SizedIO.Console hiding (main)

open import NativeIO

myProgram  :  ∀{i} → IOConsole i Unit
force myProgram  =  do'  getLine         λ line →
                    do  (putStrLn line)  λ _ →
                    do  (putStrLn line)  λ _ →
                    myProgram

main  :  NativeIO Unit
main  =  translateIOConsole myProgram


------------------------------------------------------------------------
-- Parser indices
------------------------------------------------------------------------

module RecursiveDescent.Index where

open import Data.Bool
open import Data.Product.Record
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Data.Function

------------------------------------------------------------------------
-- Indices to the parser type

-- Does the parser accept empty strings?

Empty : Set
Empty = Bool

-- The proper left corners of the parser, represented as a tree. See
-- the definition of RecursiveDescent.(Coi|I)nductive.Internal.Parser.

data Corners : Set where
  leaf : Corners
  step : Corners -> Corners
  node : Corners -> Corners -> Corners

Index : Set
Index = Empty × Corners

-- The parser type signature. The second argument is the result type.

ParserType : Set1
ParserType = Index -> Set -> Set

ParserType₁ : Set2
ParserType₁ = Index -> Set -> Set1

------------------------------------------------------------------------
-- Operations on indices

infixr 50 _·I_
infixr 40 _∣I_

0I : Index
0I = (false , leaf)

1I : Index
1I = (true , leaf)

_∣I_ : Index -> Index -> Index
i₁ ∣I i₂ = (proj₁ i₁ ∨ proj₁ i₂ , node (proj₂ i₁) (proj₂ i₂))

_·I_ : Index -> Index -> Index
i₁ ·I i₂ = ( proj₁ i₁ ∧ proj₁ i₂
           , (if proj₁ i₁ then node (proj₂ i₁) (proj₂ i₂)
                          else step (proj₂ i₁))
           )

------------------------------------------------------------------------
-- Testing indices for equality

infix 15 _Index-≟_ _Corners-≟_

private

  drop-step : forall {c₁ c₂} -> step c₁ ≡ step c₂ -> c₁ ≡ c₂
  drop-step refl = refl

  drop-node₁ : forall {c₁ c₂ c₃ c₄} ->
               node c₁ c₂ ≡ node c₃ c₄ -> c₁ ≡ c₃
  drop-node₁ refl = refl

  drop-node₂ : forall {c₁ c₂ c₃ c₄} ->
               node c₁ c₂ ≡ node c₃ c₄ -> c₂ ≡ c₄
  drop-node₂ refl = refl

_Corners-≟_ : Decidable {Corners} _≡_
leaf       Corners-≟ leaf         = yes refl
step c₁    Corners-≟ step  c₂     with c₁ Corners-≟ c₂
step c₁    Corners-≟ step .c₁     | yes refl   = yes refl
step c₁    Corners-≟ step  c₂     | no  ¬c₁≡c₂ = no (¬c₁≡c₂ ∘ drop-step)
node c₁ c₂ Corners-≟ node  c₃  c₄ with c₁ Corners-≟ c₃ | c₂ Corners-≟ c₄
node c₁ c₂ Corners-≟ node .c₁ .c₂ | yes refl   | yes refl = yes refl
node c₁ c₂ Corners-≟ node  c₃  c₄ | no  ¬c₁≡c₂ | _          = no (¬c₁≡c₂ ∘ drop-node₁)
node c₁ c₂ Corners-≟ node  c₃  c₄ | _          | no  ¬c₁≡c₂ = no (¬c₁≡c₂ ∘ drop-node₂)
leaf       Corners-≟ step _       = no \()
leaf       Corners-≟ node _ _     = no \()
step _     Corners-≟ leaf         = no \()
step _     Corners-≟ node _ _     = no \()
node _ _   Corners-≟ leaf         = no \()
node _ _   Corners-≟ step _       = no \()

_Index-≟_ : Decidable {Index} _≡_
i₁ Index-≟ i₂ with proj₁ i₁ ≟ proj₁ i₂
                 | proj₂ i₁ Corners-≟ proj₂ i₂
... | yes e₁≡e₂ | yes c₁≡c₂ = yes (cong₂ (_,_) e₁≡e₂ c₁≡c₂)
... | no ¬e₁≡e₂ | _         = no (¬e₁≡e₂ ∘ cong proj₁)
... | _         | no ¬c₁≡c₂ = no (¬c₁≡c₂ ∘ cong proj₂)